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 the libgfortran child 11! procedure back to 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 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 115END MODULE p 116 117PROGRAM 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 163END PROGRAM test 164