gcc/testsuite/gfortran.dg/dtio_1.f90

   1 ! { dg-do run  }
   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 libgfortranthe child procedure back to
  11 !    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     iomsg = "SUCCESS"
  37     iostat=0
  38     if (iotype.eq."DT") then
  39       if (size(vlist).ne.0) print *, 36
  40       WRITE(unit, FMT = '(a,5x,i2)', IOSTAT=iostat, advance='no') trim(dtv%name), dtv%age
  41       if (iostat.ne.0) iomsg = "Fail PWF DT"
  42     endif
  43     if (iotype.eq."DTzeroth") then
  44       if (size(vlist).ne.0) print *, 40
  45       WRITE(unit, FMT = '(g0,g0)', advance='no') dtv%name, dtv%age
  46       if (iostat.ne.0) iomsg = "Fail PWF DTzeroth"
  47     endif
  48     if (iotype.eq."DTtwo") then
  49       if (size(vlist).ne.2) call abort
  50       WRITE(udfmt,'(A,A,I1,A,I1,A)') '(', 'A', vlist(1),',I', vlist(2), ')'
  51       WRITE(unit, FMT='(A8,I2)') dtv%name, dtv%age
  52       if (iostat.ne.0) iomsg = "Fail PWF DTtwo"
  53     endif
  54     if (iotype.eq."DTthree") then
  55       WRITE(udfmt,'(2A,I2,A,I1,A,I2,A)',iostat=myios) '(', 'A', vlist(1),',I', vlist(2), ',F', vlist(3), '.2)'
  56       WRITE(unit, FMT=udfmt, IOSTAT=iostat, advance='no') trim(dtv%name), dtv%age, 3.14
  57       if (iostat.ne.0) iomsg = "Fail PWF DTthree"
  58     endif
  59     if (iotype.eq."LISTDIRECTED") then
  60       if (size(vlist).ne.0) print *, 55
  61       WRITE(unit, FMT = *) dtv%name, dtv%age
  62       if (iostat.ne.0) iomsg = "Fail PWF LISTDIRECTED"
  63     endif
  64     if (iotype.eq."NAMELIST") then
  65       if (size(vlist).ne.0) print *, 59
  66       iostat=6000
  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     iomsg = "SUCCESS"
  82     iostat=0
  83     if (iotype.eq."DT") then
  84       if (size(vlist).ne.0) print *, 36
  85       READ(unit, FMT = '(a,5x,i2)', IOSTAT=iostat, advance='no') dtv%name, dtv%age
  86       if (iostat.ne.0) iomsg = "Fail PWF DT"
  87     endif
  88     if (iotype.eq."DTzeroth") then
  89       if (size(vlist).ne.0) print *, 40
  90       READ(unit, FMT = '(a,I2)', advance='no') dtv%name, dtv%age
  91       if (iostat.ne.0) iomsg = "Fail PWF DTzeroth"
  92     endif
  93     if (iotype.eq."DTtwo") then
  94       if (size(vlist).ne.2) call abort
  95       WRITE(udfmt,'(A,A,I1,A,I1,A)') '(', 'A', vlist(1),',I', vlist(2), ')'
  96       READ(unit, FMT='(A8,I2)') dtv%name, dtv%age
  97       if (iostat.ne.0) iomsg = "Fail PWF DTtwo"
  98     endif
  99     if (iotype.eq."DTthree") then
 100       WRITE(udfmt,'(2A,I2,A,I1,A,I2,A)',iostat=myios) '(', 'A', vlist(1),',I', vlist(2), ',F', vlist(3), '.2)'
 101       READ(unit, FMT=udfmt, IOSTAT=iostat, advance='no') dtv%name, dtv%age, areal
 102       if (iostat.ne.0) iomsg = "Fail PWF DTthree"
 103     endif
 104     if (iotype.eq."LISTDIRECTED") then
 105       if (size(vlist).ne.0) print *, 55
 106       READ(unit, FMT = *) dtv%name, dtv%age
 107       if (iostat.ne.0) iomsg = "Fail PWF LISTDIRECTED"
 108     endif
 109     if (iotype.eq."NAMELIST") then
 110       if (size(vlist).ne.0) print *, 59
 111       iostat=6000
 112     endif
 113     !READ (UNIT = UNIT, FMT = *) dtv%name, dtv%age
 114   END SUBROUTINE prf
 115
 116 END MODULE p
 117
 118 PROGRAM test
 119   USE p
 120   TYPE (person), SAVE :: chairman
 121   TYPE (person), SAVE :: member
 122   character(80) :: astring
 123   integer :: thelength
 124
 125   chairman%name="Charlie"
 126   chairman%age=62
 127   member%name="George"
 128   member%age=42
 129   astring = "FAILURE"
 130   write (10, "(DT'zeroth',3x, DT'three'(11,4,10),11x,DT'two'(8,2))", &
 131          & iostat=myiostat, iomsg=astring) member, chairman, member
 132   if (myiostat.ne.0) call abort
 133   if (astring.ne."SUCCESS") call abort
 134   astring = "FAILURE"
 135   write (10, *, iostat=myiostat, iomsg=astring) member, chairman, member
 136   if (myiostat.ne.0) call abort
 137   if (astring.ne."SUCCESS") call abort
 138   write(10,*) ! See note below
 139   rewind(10)
 140   chairman%name="bogus1"
 141   chairman%age=99
 142   member%name="bogus2"
 143   member%age=66
 144   astring = "FAILURE"
 145   read(10,"(DT'zeroth',3x, DT'three'(11,4,10),11x,DT'two'(8,2))") member, chairman, member
 146   if (member%name.ne."George") call abort
 147   if (chairman%name.ne."    Charlie") call abort
 148   if (member%age.ne.42) call abort
 149   if (chairman%age.ne.62) call abort
 150   chairman%name="bogus1"
 151   chairman%age=99
 152   member%name="bogus2"
 153   member%age=66
 154   astring = "FAILURE"
 155   read (10, *, iostat=myiostat, iomsg=astring) member, chairman, member
 156   ! The user defined procedure reads to the end of the line/file, then finalizing the parent
 157   ! reads past, so we wrote a blank line above. User needs to address these nuances in their
 158   ! procedures. (subject to interpretation)
 159   if (astring.ne."SUCCESS") call abort
 160   if (member%name.ne."George") call abort
 161   if (chairman%name.ne."Charlie") call abort
 162   if (member%age.ne.42) call abort
 163   if (chairman%age.ne.62) call abort
 164 END PROGRAM test