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