Mercurial > hg > CbC > CbC_gcc
view gcc/testsuite/gfortran.dg/pdt_1.f03 @ 111:04ced10e8804
gcc 7
author | kono |
---|---|
date | Fri, 27 Oct 2017 22:46:09 +0900 |
parents | |
children | 84e7813d76e9 |
line wrap: on
line source
! { dg-do run } ! { dg-options "-fcheck=all" } ! ! Basic check of Parameterized Derived Types. ! ! -fcheck=all is used here to ensure that when the parameter ! 'b' of the dummy in 'foo' is assumed, there is no error. ! Likewise in 'bar' and 'foobar', when 'b' has the correct ! explicit value. ! implicit none integer, parameter :: ftype = kind(0.0e0) integer :: pdt_len = 4 integer :: i type :: mytype (a,b) integer, kind :: a = kind(0.0d0) integer, LEN :: b integer :: i real(kind = a) :: d(b, b) character (len = b*b) :: chr end type type(mytype(b=4)) :: z(2) type(mytype(ftype, 4)) :: z2 z(1)%i = 1 z(2)%i = 2 z(1)%d = reshape ([(real(i), i = 1, 16)],[4,4]) z(2)%d = 10*z(1)%d z(1)%chr = "hello pdt" z(2)%chr = "goodbye pdt" z2%d = z(1)%d * 10 - 1 z2%chr = "scalar pdt" call foo (z) call bar (z) call foobar (z2) contains elemental subroutine foo (arg) type(mytype(8,*)), intent(in) :: arg if (arg%i .eq. 1) then if (trim (arg%chr) .ne. "hello pdt") error stop if (int (sum (arg%d)) .ne. 136) error stop else if (arg%i .eq. 2 ) then if (trim (arg%chr) .ne. "goodbye pdt") error stop if (int (sum (arg%d)) .ne. 1360) error stop else error stop end if end subroutine subroutine bar (arg) type(mytype(b=4)) :: arg(:) if (int (sum (arg(1)%d)) .ne. 136) call abort if (trim (arg(2)%chr) .ne. "goodbye pdt") call abort end subroutine subroutine foobar (arg) type(mytype(ftype, pdt_len)) :: arg if (int (sum (arg%d)) .ne. 1344) call abort if (trim (arg%chr) .ne. "scalar pdt") call abort end subroutine end