gcc/testsuite/gfortran.dg/dtio_1.f90

   1 ! { dg-do run { target fd_truncate } }
   2 !
   3 ! Functional test of User Defined Derived Type IO, Formatted WRITE/READ
   4 !
   5 ! 1) Tests passing of iostat out of the user procedure.
   6 ! 2) Tests parsing of the DT optional string and passing in and using
   7 !    to control execution.
   8 ! 3) Tests parsing of the optional vlist, passing in and using it to
   9 !    generate a user defined format string.
  10 ! 4) Tests passing an iostat or iomsg out of the libgfortran child
  11 !    procedure back to the parent.
  12 !
  13 MODULE p
  14   USE ISO_FORTRAN_ENV
  15   TYPE :: person
  16     CHARACTER (LEN=20) :: name
  17     INTEGER(4) :: age
  18     CONTAINS
  19       procedure :: pwf
  20       procedure :: prf
  21       GENERIC :: WRITE(FORMATTED) => pwf
  22       GENERIC :: READ(FORMATTED) => prf
  23   END TYPE person
  24 CONTAINS
  25   SUBROUTINE pwf (dtv,unit,iotype,vlist,iostat,iomsg)
  26     CLASS(person), INTENT(IN) :: dtv
  27     INTEGER, INTENT(IN) :: unit
  28     CHARACTER (LEN=*), INTENT(IN) :: iotype
  29     INTEGER, INTENT(IN) :: vlist(:)
  30     INTEGER, INTENT(OUT) :: iostat
  31     CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
  32     CHARACTER (LEN=30) :: udfmt
  33     INTEGER :: myios
  34
  35     udfmt='(*(g0))'
  36     iostat=0
  37     if (iotype.eq."DT") then
  38       if (size(vlist).ne.0) print *, 36
  39       WRITE(unit, FMT = '(a,5x,i2)', IOSTAT=iostat, advance='no') trim(dtv%name), dtv%age
  40       if (iostat.ne.0) iomsg = "Fail PWF DT"
  41     endif
  42     if (iotype.eq."DTzeroth") then
  43       if (size(vlist).ne.0) print *, 40
  44       WRITE(unit, FMT = '(g0,g0)', advance='no') dtv%name, dtv%age
  45       if (iostat.ne.0) iomsg = "Fail PWF DTzeroth"
  46     endif
  47     if (iotype.eq."DTtwo") then
  48       if (size(vlist).ne.2) STOP 1
  49       WRITE(udfmt,'(A,A,I1,A,I1,A)') '(', 'A', vlist(1),',I', vlist(2), ')'
  50       WRITE(unit, FMT='(A8,I2)') dtv%name, dtv%age
  51       if (iostat.ne.0) iomsg = "Fail PWF DTtwo"
  52     endif
  53     if (iotype.eq."DTthree") then
  54       WRITE(udfmt,'(2A,I2,A,I1,A,I2,A)',iostat=myios) '(', 'A', vlist(1),',I', vlist(2), ',F', vlist(3), '.2)'
  55       WRITE(unit, FMT=udfmt, IOSTAT=iostat, advance='no') trim(dtv%name), dtv%age, 3.14
  56       if (iostat.ne.0) iomsg = "Fail PWF DTthree"
  57     endif
  58     if (iotype.eq."LISTDIRECTED") then
  59       if (size(vlist).ne.0) print *, 55
  60       WRITE(unit, FMT = *) dtv%name, dtv%age
  61       if (iostat.ne.0) iomsg = "Fail PWF LISTDIRECTED"
  62     endif
  63     if (iotype.eq."NAMELIST") then
  64       if (size(vlist).ne.0) print *, 59
  65       iostat=6000
  66       iomsg = "NAMELIST not implemented in pwf"
  67     endif
  68   END SUBROUTINE pwf
  69
  70   SUBROUTINE prf (dtv,unit,iotype,vlist,iostat,iomsg)
  71     CLASS(person), INTENT(INOUT) :: dtv
  72     INTEGER, INTENT(IN) :: unit
  73     CHARACTER (LEN=*), INTENT(IN) :: iotype
  74     INTEGER, INTENT(IN) :: vlist(:)
  75     INTEGER, INTENT(OUT) :: iostat
  76     CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
  77     CHARACTER (LEN=30) :: udfmt
  78     INTEGER :: myios
  79     real :: areal
  80     udfmt='(*(g0))'
  81     iostat=0
  82     if (iotype.eq."DT") then
  83       if (size(vlist).ne.0) print *, 36
  84       READ(unit, FMT = '(a,5x,i2)', IOSTAT=iostat, advance='no') dtv%name, dtv%age
  85       if (iostat.ne.0) iomsg = "Fail PWF DT"
  86     endif
  87     if (iotype.eq."DTzeroth") then
  88       if (size(vlist).ne.0) print *, 40
  89       READ(unit, FMT = '(a,I2)', advance='no') dtv%name, dtv%age
  90       if (iostat.ne.0) iomsg = "Fail PWF DTzeroth"
  91     endif
  92     if (iotype.eq."DTtwo") then
  93       if (size(vlist).ne.2) STOP 2
  94       WRITE(udfmt,'(A,A,I1,A,I1,A)') '(', 'A', vlist(1),',I', vlist(2), ')'
  95       READ(unit, FMT='(A8,I2)') dtv%name, dtv%age
  96       if (iostat.ne.0) iomsg = "Fail PWF DTtwo"
  97     endif
  98     if (iotype.eq."DTthree") then
  99       WRITE(udfmt,'(2A,I2,A,I1,A,I2,A)',iostat=myios) '(', 'A', vlist(1),',I', vlist(2), ',F', vlist(3), '.2)'
 100       READ(unit, FMT=udfmt, IOSTAT=iostat, advance='no') dtv%name, dtv%age, areal
 101       if (iostat.ne.0) iomsg = "Fail PWF DTthree"
 102     endif
 103     if (iotype.eq."LISTDIRECTED") then
 104       if (size(vlist).ne.0) print *, 55
 105       READ(unit, FMT = *) dtv%name, dtv%age
 106       if (iostat.ne.0) iomsg = "Fail PWF LISTDIRECTED"
 107     endif
 108     if (iotype.eq."NAMELIST") then
 109       if (size(vlist).ne.0) print *, 59
 110       iostat=6000
 111       iomsg = "NAMELIST not implemented in prf"
 112     endif
 113   END SUBROUTINE prf
 114
 115 END MODULE p
 116
 117 PROGRAM test
 118   USE p
 119   TYPE (person), SAVE :: chairman
 120   TYPE (person), SAVE :: member
 121   character(80) :: astring
 122   integer :: thelength
 123
 124   chairman%name="Charlie"
 125   chairman%age=62
 126   member%name="George"
 127   member%age=42
 128   astring = "SUCCESS"
 129   write (10, "(DT'zeroth',3x, DT'three'(11,4,10),11x,DT'two'(8,2))", &
 130          & iostat=myiostat, iomsg=astring) member, chairman, member
 131   if (myiostat.ne.0) STOP 3
 132   if (astring.ne."SUCCESS") STOP 4
 133   astring = "SUCCESS"
 134   write (10, *, iostat=myiostat, iomsg=astring) member, chairman, member
 135   if (myiostat.ne.0) STOP 5
 136   if (astring.ne."SUCCESS") STOP 6
 137   write(10,*) ! See note below
 138   rewind(10)
 139   chairman%name="bogus1"
 140   chairman%age=99
 141   member%name="bogus2"
 142   member%age=66
 143   astring = "SUCCESS"
 144   read(10,"(DT'zeroth',3x, DT'three'(11,4,10),11x,DT'two'(8,2))") member, chairman, member
 145   if (member%name.ne."George") STOP 7
 146   if (chairman%name.ne."    Charlie") STOP 8
 147   if (member%age.ne.42) STOP 9
 148   if (chairman%age.ne.62) STOP 10
 149   chairman%name="bogus1"
 150   chairman%age=99
 151   member%name="bogus2"
 152   member%age=66
 153   astring = "SAME"
 154   read (10, *, iostat=myiostat, iomsg=astring) member, chairman, member
 155   ! The user defined procedure reads to the end of the line/file, then finalizing the parent
 156   ! reads past, so we wrote a blank line above. User needs to address these nuances in their
 157   ! procedures. (subject to interpretation)
 158   if (astring.ne."SAME" .or. myiostat.ne.0) STOP 11
 159   if (member%name.ne."George") STOP 12
 160   if (chairman%name.ne."Charlie") STOP 13
 161   if (member%age.ne.42) STOP 14
 162   if (chairman%age.ne.62) STOP 15
 163 END PROGRAM test