gcc/testsuite/gfortran.dg/dtio_4.f90

   1 ! { dg-do run }
   2 !
   3 ! Functional test of User Defined Derived Type IO.
   4 !
   5 ! This tests a combination of module procedure and generic procedure
   6 ! and performs reading and writing an array with a pseudo user defined
   7 ! tag at the beginning of the file.
   8 !
   9 module usertypes
  10   type udt
  11      integer :: myarray(15)
  12    contains
  13      procedure :: user_defined_read
  14      generic :: read (formatted) => user_defined_read
  15   end type udt
  16   type, extends(udt) :: more
  17     integer :: someinteger = -25
  18   end type
  19
  20   interface write(formatted)
  21     module procedure user_defined_write
  22   end interface
  23
  24   integer :: result_array(15)
  25 contains
  26   subroutine user_defined_read (dtv, unit, iotype, v_list, iostat, iomsg)
  27     class(udt), intent(inout)   :: dtv
  28     integer, intent(in)         :: unit
  29     character(*), intent(in)    :: iotype
  30     integer, intent(in)         :: v_list (:)
  31     integer, intent(out)        :: iostat
  32     character(*), intent(inout) :: iomsg
  33     character(10)               :: typestring
  34
  35     iomsg = 'SUCCESS'
  36     read (unit, '(a6)',  iostat=iostat, iomsg=iomsg) typestring
  37     typestring = trim(typestring)
  38     select type (dtv)
  39       type is (udt)
  40         if (typestring.eq.' UDT:     ') then
  41           read (unit, fmt=*,  iostat=iostat, iomsg=iomsg) dtv%myarray
  42         else
  43           iostat = 6000
  44           iomsg = 'FAILURE'
  45         end if
  46       type is (more)
  47         if (typestring.eq.' MORE:    ') then
  48           read (unit, fmt=*,  iostat=iostat, iomsg=iomsg) dtv%myarray
  49         else
  50           iostat = 6000
  51           iomsg = 'FAILUREwhat'
  52         end if
  53     end select
  54   end subroutine user_defined_read
  55
  56   subroutine user_defined_write (dtv, unit, iotype, v_list, iostat, iomsg)
  57     class(udt), intent(in)      :: dtv
  58     integer, intent(in)         :: unit
  59     character(*), intent(in)    :: iotype
  60     integer, intent(in)         :: v_list (:)
  61     integer, intent(out)        :: iostat
  62     character(*), intent(inout) :: iomsg
  63     character(10)               :: typestring
  64     select type (dtv)
  65       type is (udt)
  66         write (unit, fmt=*, iostat=iostat, iomsg=iomsg)  "UDT:  "
  67         write (unit, fmt=*, iostat=iostat, iomsg=iomsg)  dtv%myarray
  68       type is (more)
  69         write (unit, fmt=*, iostat=iostat, iomsg=iomsg)  "MORE: "
  70         write (unit, fmt=*, iostat=iostat, iomsg=iomsg)  dtv%myarray
  71     end select
  72     write (unit,*)
  73   end subroutine user_defined_write
  74 end  module usertypes
  75
  76 program test1
  77   use usertypes
  78   type (udt) :: udt1
  79   type (more) :: more1
  80   class (more), allocatable :: somemore
  81   integer  :: thesize, i, ios
  82   character(25):: iomsg
  83
  84 ! Create a file that contains some data for testing.
  85   open (10, form='formatted', status='scratch')
  86   write(10, '(a)') ' UDT: '
  87   do i = 1, 15
  88     write(10,'(i5)', advance='no') i
  89   end do
  90   write(10,*)
  91   rewind(10)
  92   udt1%myarray = 99
  93   result_array = (/ (i, i = 1, 15) /)
  94   more1%myarray = result_array
  95   read (10, fmt='(dt)', advance='no', iomsg=iomsg) udt1
  96   if (iomsg.ne.'SUCCESS') STOP 1
  97   if (any(udt1%myarray.ne.result_array)) STOP 1
  98   close(10)
  99   open (10, form='formatted', status='scratch')
 100   write (10, '(dt)') more1
 101   rewind(10)
 102   more1%myarray = 99
 103   read (10, '(dt)', iostat=ios, iomsg=iomsg) more1
 104   if (iomsg.ne.'SUCCESS') STOP 1
 105   if (any(more1%myarray.ne.result_array)) STOP 1
 106   close (10)
 107 end program test1