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