gcc/testsuite/gfortran.dg/dec_type_print_2.f03

   1 ! { dg-do run }
   2 ! { dg-options "-fdec -fcheck=all" }
   3 !
   4 ! Verify that -fdec does not break parsing of PDTs.
   5 ! This test code is copied from pdt_1.f03 but compiled with -fdec.
   6 !
   7 program main
   8   implicit none
   9   integer, parameter :: ftype = kind(0.0e0)
  10   integer :: pdt_len = 4
  11   integer :: i
  12   type :: mytype (a,b)
  13     integer, kind :: a = kind(0.0d0)
  14     integer, LEN :: b
  15     integer :: i
  16     real(kind = a) :: d(b, b)
  17     character (len = b*b) :: chr
  18   end type
  19
  20   type(mytype(b=4)) :: z(2)
  21   type(mytype(ftype, 4)) :: z2
  22
  23   z(1)%i = 1
  24   z(2)%i = 2
  25   z(1)%d = reshape ([(real(i), i = 1, 16)],[4,4])
  26   z(2)%d = 10*z(1)%d
  27   z(1)%chr = "hello pdt"
  28   z(2)%chr = "goodbye pdt"
  29
  30   z2%d = z(1)%d * 10 - 1
  31   z2%chr = "scalar pdt"
  32
  33   call foo (z)
  34   call bar (z)
  35   call foobar (z2)
  36 contains
  37   elemental subroutine foo (arg)
  38     type(mytype(8,*)), intent(in) :: arg
  39     if (arg%i .eq. 1) then
  40       if (trim (arg%chr) .ne. "hello pdt") error stop
  41       if (int (sum (arg%d)) .ne. 136) error stop
  42     else if (arg%i .eq. 2 ) then
  43       if (trim (arg%chr) .ne. "goodbye pdt") error stop
  44       if (int (sum (arg%d)) .ne. 1360) error stop
  45     else
  46       error stop
  47     end if
  48   end subroutine
  49   subroutine bar (arg)
  50     type(mytype(b=4)) :: arg(:)
  51     if (int (sum (arg(1)%d)) .ne. 136) call abort
  52     if (trim (arg(2)%chr) .ne. "goodbye pdt") call abort
  53   end subroutine
  54   subroutine foobar (arg)
  55     type(mytype(ftype, pdt_len)) :: arg
  56     if (int (sum (arg%d)) .ne. 1344) call abort
  57     if (trim (arg%chr) .ne. "scalar pdt") call abort
  58   end subroutine
  59 end