gcc/testsuite/gfortran.fortran-torture/execute/der_io.f90

   1 ! Program to test IO of derived types
   2 program derived_io
   3   character(400) :: buf1, buf2, buf3
   4
   5   type xyz_type
   6      integer :: x
   7      character(11) :: y
   8      logical :: z
   9   end type xyz_type
  10
  11   type abcdef_type
  12      integer :: a
  13      logical :: b
  14      type (xyz_type) :: c
  15      integer :: d
  16      real(4) :: e
  17      character(11) :: f
  18   end type abcdef_type
  19
  20   type (xyz_type), dimension(2) :: xyz
  21   type (abcdef_type) abcdef
  22
  23   xyz(1)%x = 11111
  24   xyz(1)%y = "hello world"
  25   xyz(1)%z = .true.
  26   xyz(2)%x = 0
  27   xyz(2)%y = "go away"
  28   xyz(2)%z = .false.
  29
  30   abcdef%a = 0
  31   abcdef%b = .true.
  32   abcdef%c%x = 111
  33   abcdef%c%y = "bzz booo"
  34   abcdef%c%z = .false.
  35   abcdef%d = 3
  36   abcdef%e = 4.0
  37   abcdef%f = "kawabanga"
  38
  39   write (buf1, *), xyz(1)%x, xyz(1)%y, xyz(1)%z
  40   ! Use function call to ensure it is only evaluated once
  41   write (buf2, *), xyz(bar())
  42   if (buf1.ne.buf2) call abort
  43
  44   write (buf1, *), abcdef
  45   write (buf2, *), abcdef%a, abcdef%b, abcdef%c, abcdef%d, abcdef%e, abcdef%f
  46   write (buf3, *), abcdef%a, abcdef%b, abcdef%c%x, abcdef%c%y, &
  47                    abcdef%c%z, abcdef%d, abcdef%e, abcdef%f
  48   if (buf1.ne.buf2) call abort
  49   if (buf1.ne.buf3) call abort
  50
  51   call foo(xyz(1))
  52
  53   contains
  54
  55     subroutine foo(t)
  56       type (xyz_type) t
  57       write (buf1, *), t%x, t%y, t%z
  58       write (buf2, *), t
  59       if (buf1.ne.buf2) call abort
  60     end subroutine foo
  61
  62     integer function bar()
  63       integer, save :: i = 1
  64       bar = i
  65       i = i + 1
  66     end function
  67 end