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! 8MODULE 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 20CONTAINS 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) STOP 1 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) STOP 1 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 125END MODULE p 126 127PROGRAM 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") STOP 1 151 if (chairman%name.ne."Charlie") STOP 1 152 if (member%age.ne.42) STOP 1 153 if (chairman%age.ne.62) STOP 1 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") STOP 1 168 if (chairman%name.ne."Charlie") STOP 1 169 if (member%age.ne.42) STOP 1 170 if (chairman%age.ne.62) STOP 1 171 close(10) 172END PROGRAM test 173