gcc/testsuite/gfortran.dg/pdt_1.f03

   1 ! { dg-do run }
   2 ! { dg-options "-fcheck=all" }
   3 !
   4 ! Basic check of Parameterized Derived Types.
   5 !
   6 ! -fcheck=all is used here to ensure that when the parameter
   7 ! 'b' of the dummy in 'foo' is assumed, there is no error.
   8 ! Likewise in 'bar' and 'foobar', when 'b' has the correct
   9 ! explicit value.
  10 !
  11   implicit none
  12   integer, parameter :: ftype = kind(0.0e0)
  13   integer :: pdt_len = 4
  14   integer :: i
  15   type :: mytype (a,b)
  16     integer, kind :: a = kind(0.0d0)
  17     integer, LEN :: b
  18     integer :: i
  19     real(kind = a) :: d(b, b)
  20     character (len = b*b) :: chr
  21   end type
  22
  23   type(mytype(b=4)) :: z(2)
  24   type(mytype(ftype, 4)) :: z2
  25
  26   z(1)%i = 1
  27   z(2)%i = 2
  28   z(1)%d = reshape ([(real(i), i = 1, 16)],[4,4])
  29   z(2)%d = 10*z(1)%d
  30   z(1)%chr = "hello pdt"
  31   z(2)%chr = "goodbye pdt"
  32
  33   z2%d = z(1)%d * 10 - 1
  34   z2%chr = "scalar pdt"
  35
  36   call foo (z)
  37   call bar (z)
  38   call foobar (z2)
  39 contains
  40   elemental subroutine foo (arg)
  41     type(mytype(8,*)), intent(in) :: arg
  42     if (arg%i .eq. 1) then
  43       if (trim (arg%chr) .ne. "hello pdt") error stop
  44       if (int (sum (arg%d)) .ne. 136) error stop
  45     else if (arg%i .eq. 2 ) then
  46       if (trim (arg%chr) .ne. "goodbye pdt") error stop
  47       if (int (sum (arg%d)) .ne. 1360) error stop
  48     else
  49       error stop
  50     end if
  51   end subroutine
  52   subroutine bar (arg)
  53     type(mytype(b=4)) :: arg(:)
  54     if (int (sum (arg(1)%d)) .ne. 136) call abort
  55     if (trim (arg(2)%chr) .ne. "goodbye pdt") call abort
  56   end subroutine
  57   subroutine foobar (arg)
  58     type(mytype(ftype, pdt_len)) :: arg
  59     if (int (sum (arg%d)) .ne. 1344) call abort
  60     if (trim (arg%chr) .ne. "scalar pdt") call abort
  61   end subroutine
  62 end