gcc/testsuite/gfortran.dg/dtio_9.f90

   1 ! { dg-do run }
   2 !
   3 ! Tests dtio of transfer bind-C types.
   4 !
   5 ! Note difficulties with c_char at -O1. This is why no character field is used.
   6 !
   7 MODULE p
   8   USE ISO_C_BINDING
   9   TYPE, BIND(C) :: person
  10     integer(c_int) :: id_no
  11     INTEGER(c_int) :: 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%id_no, 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%id_no, dtv%age
  36   END SUBROUTINE pruf
  37
  38 END MODULE p
  39
  40 PROGRAM test
  41   USE p
  42   TYPE (person) :: chairman
  43   CHARACTER (kind=c_char) :: cname(20)
  44   integer (c_int) :: cage, cid_no
  45   character(10) :: line
  46
  47   cid_no = 1
  48   cage = 62
  49   chairman%id_no = cid_no
  50   chairman%age = cage
  51
  52   OPEN (UNIT=71, status = 'scratch', FORM='UNFORMATTED')
  53   write (71) chairman
  54   rewind (71)
  55
  56   chairman%id_no = 0
  57   chairman%age = 0
  58
  59   read (71) chairman
  60   close (unit = 71)
  61
  62   write(line, "(I4)") chairman%id_no
  63   if (trim (line) .ne. "   1") call abort
  64   write(line, "(I4)") chairman%age
  65   if (trim (line) .ne. "  62") call abort
  66 end program