PR tree-optimization/86415 - strlen() not folded for substrings within constant arrays
[official-gcc.git] / gcc / testsuite / gfortran.dg / dtio_3.f90
blobd960812524df5a1312b429a15b38ee72c339cb9c
1 ! { dg-do run }
3 ! Functional test of User Defined Derived Type IO.
5 ! This tests recursive calls where a derived type has a member that is
6 ! itself.
8 MODULE 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
20 CONTAINS
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
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
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
125 END MODULE p
127 PROGRAM test
128 USE p
129 TYPE (person) :: chairman
130 TYPE (person), target :: member
131 character(80) :: astring
132 integer :: thelength
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)
172 END PROGRAM test