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! 13MODULE 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 24CONTAINS 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) 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 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) STOP 2 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 116END MODULE p 117 118PROGRAM 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) STOP 3 133 if (astring.ne."SUCCESS") STOP 4 134 astring = "FAILURE" 135 write (10, *, iostat=myiostat, iomsg=astring) member, chairman, member 136 if (myiostat.ne.0) STOP 5 137 if (astring.ne."SUCCESS") STOP 6 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") STOP 7 147 if (chairman%name.ne." Charlie") STOP 8 148 if (member%age.ne.42) STOP 9 149 if (chairman%age.ne.62) STOP 10 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") STOP 11 160 if (member%name.ne."George") STOP 12 161 if (chairman%name.ne."Charlie") STOP 13 162 if (member%age.ne.42) STOP 14 163 if (chairman%age.ne.62) STOP 15 164END PROGRAM test 165