gcc/testsuite/gfortran.dg/dtio_8.f90

   1 ! { dg-do run }
   2 !
   3 ! Tests dtio transfer sequence types.
   4 !
   5 ! Note difficulty at end with comparisons at any level of optimization.
   6 !
   7 MODULE p
   8   TYPE :: person
   9     sequence
  10     CHARACTER (LEN=20) :: name
  11     INTEGER(4) :: age
  12   END TYPE person
  13   INTERFACE WRITE(UNFORMATTED)
  14     MODULE PROCEDURE pwuf
  15   END INTERFACE
  16   INTERFACE READ(UNFORMATTED)
  17     MODULE PROCEDURE pruf
  18   END INTERFACE
  19
  20 CONTAINS
  21
  22   SUBROUTINE pwuf (dtv,unit,iostat,iomsg)
  23     type(person), INTENT(IN) :: dtv
  24     INTEGER, INTENT(IN) :: unit
  25     INTEGER, INTENT(OUT) :: iostat
  26     CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
  27     WRITE (UNIT=UNIT) DTV%name, DTV%age
  28   END SUBROUTINE pwuf
  29
  30   SUBROUTINE pruf (dtv,unit,iostat,iomsg)
  31     type(person), INTENT(INOUT) :: dtv
  32     INTEGER, INTENT(IN) :: unit
  33     INTEGER, INTENT(OUT) :: iostat
  34     CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
  35     READ (UNIT = UNIT) dtv%name, dtv%age
  36   END SUBROUTINE pruf
  37
  38 END MODULE p
  39
  40 PROGRAM test
  41   USE p
  42   TYPE (person) :: chairman
  43   character(10) :: line
  44
  45   chairman%name="Charlie"
  46   chairman%age=62
  47
  48   OPEN (UNIT=71, status = 'scratch', FORM='UNFORMATTED')
  49   write (71) chairman
  50   rewind (71)
  51
  52   chairman%name = "Charles"
  53   chairman%age = 0
  54
  55   read (71) chairman
  56   close (unit = 71)
  57
  58 ! Straight comparisons fail at any level of optimization.
  59
  60   write(line, "(A7)") chairman%name
  61   if (trim (line) .ne. "Charlie") call abort
  62   line = "          "
  63   write(line, "(I4)") chairman%age
  64   if (trim (line) .eq. "   62") print *, trim(line)
  65 END PROGRAM test