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