gcc/testsuite/gfortran.dg/dtio_2.f90

   1 ! { dg-do run  }
   2 !
   3 ! Functional test of User Defined DT IO, unformatted WRITE/READ
   4 !
   5 ! 1) Tests unformatted DTV write with other variables in the record
   6 ! 2) Tests reading back the recods written.
   7 !
   8 module p
   9   type :: person
  10     character (len=20) :: name
  11     integer(4) :: age
  12     contains
  13       procedure :: pwuf
  14       procedure :: pruf
  15       generic :: write(unformatted) => pwuf
  16       generic :: read(unformatted) => pruf
  17   end type person
  18 contains
  19   subroutine pwuf (dtv,unit,iostat,iomsg)
  20     class(person), intent(in) :: dtv
  21     integer, intent(in) :: unit
  22     integer, intent(out) :: iostat
  23     character (len=*), intent(inout) :: iomsg
  24     write (unit=unit, iostat=iostat, iomsg=iomsg) dtv%name, dtv%age
  25   end subroutine pwuf
  26
  27   subroutine pruf (dtv,unit,iostat,iomsg)
  28     class(person), intent(inout) :: dtv
  29     integer, intent(in) :: unit
  30     integer, intent(out) :: iostat
  31     character (len=*), intent(inout) :: iomsg
  32     read (unit = unit) dtv%name, dtv%age
  33   end subroutine pruf
  34
  35 end module p
  36
  37 program test
  38   use p
  39   type (person), save :: chairman
  40   character(3) :: tmpstr1, tmpstr2
  41   chairman%name="charlie"
  42   chairman%age=62
  43
  44   open (unit=71, file='myunformatted_data.dat', form='unformatted')
  45   write (71) "abc", chairman, "efg"
  46   write (71) "hij", chairman, "klm"
  47   write (71) "nop", chairman, "qrs"
  48   rewind (unit = 71)
  49   chairman%name="boggle"
  50   chairman%age=1234
  51   read (71) tmpstr1, chairman, tmpstr2
  52   if (tmpstr1.ne."abc") call abort
  53   if (tmpstr2.ne."efg") call abort
  54   if (chairman%name.ne."charlie") call abort
  55   if (chairman%age.ne.62) call abort
  56   chairman%name="boggle"
  57   chairman%age=1234
  58   read (71) tmpstr1, chairman, tmpstr2
  59   if (tmpstr1.ne."hij") call abort
  60   if (tmpstr2.ne."klm") call abort
  61   if (chairman%name.ne."charlie") call abort
  62   if (chairman%age.ne.62) call abort
  63   chairman%name="boggle"
  64   chairman%age=1234
  65   read (71) tmpstr1, chairman, tmpstr2
  66   if (tmpstr1.ne."nop") call abort
  67   if (tmpstr2.ne."qrs") call abort
  68   if (chairman%name.ne."charlie") call abort
  69   if (chairman%age.ne.62) call abort
  70   close (unit = 71, status='delete')
  71 end program test