gcc/testsuite/gfortran.dg/dtio_3.f90

   1 ! { dg-do run }
   2 !
   3 ! Functional test of User Defined Derived Type IO.
   4 !
   5 ! This tests recursive calls where a derived type has a member that is
   6 ! itself.
   7 !
   8 MODULE p
   9   USE ISO_FORTRAN_ENV
  10   TYPE :: person
  11     CHARACTER (LEN=20) :: name
  12     INTEGER(4) :: age
  13     type(person), pointer :: next => NULL()
  14     CONTAINS
  15       procedure :: pwf
  16       procedure :: prf
  17       GENERIC :: WRITE(FORMATTED) => pwf
  18       GENERIC :: READ(FORMATTED) => prf
  19   END TYPE person
  20 CONTAINS
  21   RECURSIVE SUBROUTINE pwf (dtv,unit,iotype,vlist,iostat,iomsg)
  22     CLASS(person), INTENT(IN) :: dtv
  23     INTEGER, INTENT(IN) :: unit
  24     CHARACTER (LEN=*), INTENT(IN) :: iotype
  25     INTEGER, INTENT(IN) :: vlist(:)
  26     INTEGER, INTENT(OUT) :: iostat
  27     CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
  28     CHARACTER (LEN=30) :: udfmt
  29     INTEGER :: myios
  30
  31     udfmt='(*(g0))'
  32     iomsg = "SUCCESS"
  33     iostat=0
  34     if (iotype.eq."DT") then
  35       if (size(vlist).ne.0) print *, 36
  36       if (associated(dtv%next)) then
  37         WRITE(unit, FMT = '(a20,i2, DT)', IOSTAT=iostat, advance='no') dtv%name, dtv%age, dtv%next
  38       else
  39         WRITE(unit, FMT = '(a20,i2)', IOSTAT=iostat, advance='no') dtv%name, dtv%age
  40       endif
  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       if (associated(dtv%next)) then
  62         WRITE(unit, FMT = *) dtv%name, dtv%age, dtv%next
  63       else
  64         WRITE(unit, FMT = *) dtv%name, dtv%age
  65       endif
  66       if (iostat.ne.0) iomsg = "Fail PWF LISTDIRECTED"
  67     endif
  68     if (iotype.eq."NAMELIST") then
  69       if (size(vlist).ne.0) print *, 59
  70       iostat=6000
  71     endif
  72     if (associated (dtv%next) .and. (iotype.eq."LISTDIRECTED")) write(unit, fmt = *) dtv%next
  73   END SUBROUTINE pwf
  74
  75   RECURSIVE SUBROUTINE prf (dtv,unit,iotype,vlist,iostat,iomsg)
  76     CLASS(person), INTENT(INOUT) :: dtv
  77     INTEGER, INTENT(IN) :: unit
  78     CHARACTER (LEN=*), INTENT(IN) :: iotype
  79     INTEGER, INTENT(IN) :: vlist(:)
  80     INTEGER, INTENT(OUT) :: iostat
  81     CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
  82     CHARACTER (LEN=30) :: udfmt
  83     INTEGER :: myios
  84     real :: areal
  85     udfmt='(*(g0))'
  86     iomsg = "SUCCESS"
  87     iostat=0
  88     if (iotype.eq."DT") then
  89       if (size(vlist).ne.0) print *, 36
  90       if (associated(dtv%next)) then
  91         READ(unit, FMT = '(a20,i2, DT)', IOSTAT=iostat, advance='no') dtv%name, dtv%age, dtv%next
  92       else
  93         READ(unit, FMT = '(a20,i2)', IOSTAT=iostat, advance='no') dtv%name, dtv%age
  94       endif
  95       if (iostat.ne.0) iomsg = "Fail PWF DT"
  96     endif
  97     if (iotype.eq."DTzeroth") then
  98       if (size(vlist).ne.0) print *, 40
  99       READ(unit, FMT = '(a,I2)', advance='no') dtv%name, dtv%age
 100       if (iostat.ne.0) iomsg = "Fail PWF DTzeroth"
 101     endif
 102     if (iotype.eq."DTtwo") then
 103       if (size(vlist).ne.2) call abort
 104       WRITE(udfmt,'(A,A,I1,A,I1,A)') '(', 'A', vlist(1),',I', vlist(2), ')'
 105       READ(unit, FMT='(A8,I2)') dtv%name, dtv%age
 106       if (iostat.ne.0) iomsg = "Fail PWF DTtwo"
 107     endif
 108     if (iotype.eq."DTthree") then
 109       WRITE(udfmt,'(2A,I2,A,I1,A,I2,A)',iostat=myios) '(', 'A', vlist(1),',I', vlist(2), ',F', vlist(3), '.2)'
 110       READ(unit, FMT=udfmt, IOSTAT=iostat, advance='no') dtv%name, dtv%age, areal
 111       if (iostat.ne.0) iomsg = "Fail PWF DTthree"
 112     endif
 113     if (iotype.eq."LISTDIRECTED") then
 114       if (size(vlist).ne.0) print *, 55
 115       READ(unit, FMT = *) dtv%name, dtv%age
 116       if (iostat.ne.0) iomsg = "Fail PWF LISTDIRECTED"
 117     endif
 118     if (iotype.eq."NAMELIST") then
 119       if (size(vlist).ne.0) print *, 59
 120       iostat=6000
 121     endif
 122     !READ (UNIT = UNIT, FMT = *) dtv%name, dtv%age
 123   END SUBROUTINE prf
 124
 125 END MODULE p
 126
 127 PROGRAM test
 128   USE p
 129   TYPE (person) :: chairman
 130   TYPE (person), target :: member
 131   character(80) :: astring
 132   integer :: thelength
 133
 134   chairman%name="Charlie"
 135   chairman%age=62
 136   member%name="George"
 137   member%age=42
 138   astring = "FAILURE"
 139   ! At this point, next is NULL as defined up in the type block.
 140   open(10, status = "scratch")
 141   write (10, *, iostat=myiostat, iomsg=astring) member, chairman
 142   write(10,*)
 143   rewind(10)
 144   chairman%name="bogus1"
 145   chairman%age=99
 146   member%name="bogus2"
 147   member%age=66
 148   read (10, *, iostat=myiostat, iomsg=astring) member, chairman
 149   if (astring.ne."SUCCESS") print *, astring
 150   if (member%name.ne."George") call abort
 151   if (chairman%name.ne."Charlie") call abort
 152   if (member%age.ne.42) call abort
 153   if (chairman%age.ne.62) call abort
 154   close(10, status='delete')
 155   ! Now we set next to point to member. This changes the code path
 156   ! in the pwf and prf procedures.
 157   chairman%next => member
 158   open(10, status = "scratch")
 159   write (10,"(DT)") chairman
 160   rewind(10)
 161   chairman%name="bogus1"
 162   chairman%age=99
 163   member%name="bogus2"
 164   member%age=66
 165   read (10,"(DT)", iomsg=astring) chairman
 166   !print *, trim(astring)
 167   if (member%name.ne."George") call abort
 168   if (chairman%name.ne."Charlie") call abort
 169   if (member%age.ne.42) call abort
 170   if (chairman%age.ne.62) call abort
 171   close(10)
 172 END PROGRAM test