Mercurial > hg > CbC > CbC_gcc
diff gcc/testsuite/gfortran.dg/pdt_1.f03 @ 111:04ced10e8804
gcc 7
author | kono |
---|---|
date | Fri, 27 Oct 2017 22:46:09 +0900 (2017-10-27) |
parents | |
children | 84e7813d76e9 |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/gcc/testsuite/gfortran.dg/pdt_1.f03 Fri Oct 27 22:46:09 2017 +0900 @@ -0,0 +1,62 @@ +! { 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