| blob | 9117ffe29d204fb5d125e24d32bd366dcdd48b44 |
1 ! { dg-do run }
2 !
3 ! Automatic reallocate on assignment, deferred length parameter for char
4 !
5 ! PR fortran/45170
6 ! PR fortran/35810
7 ! PR fortran/47350
8 !
9 ! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
10 !
11 program test
12 implicit none
13 call mold_check()
14 call mold_check4()
15 call source_check()
16 call source_check4()
17 call ftn_test()
18 call ftn_test4()
19 call source3()
20 contains
21 subroutine source_check()
22 character(len=:), allocatable :: str, str2
23 target :: str
24 character(len=8) :: str3
25 character(len=:), pointer :: str4, str5
26 nullify(str4)
27 str3 = 'AbCdEfGhIj'
28 if(allocated(str)) STOP 1
29 allocate(str, source=str3)
30 if(.not.allocated(str)) STOP 2
31 if(len(str) /= 8) STOP 3
32 if(str /= 'AbCdEfGh') STOP 4
33 if(associated(str4)) STOP 5
34 str4 => str
35 if(str4 /= str .or. len(str4)/=8) STOP 6
36 if(.not.associated(str4, str)) STOP 7
37 str4 => null()
38 str = '12a56b78'
39 if(str4 == '12a56b78') STOP 8
40 str4 = 'ABCDEFGH'
41 if(str == 'ABCDEFGH') STOP 9
42 allocate(str5, source=str)
43 if(associated(str5, str)) STOP 10
44 if(str5 /= '12a56b78' .or. len(str5)/=8) STOP 11
45 str = 'abcdef'
46 if(str5 == 'abcdef') STOP 12
47 str5 = 'ABCDEF'
48 if(str == 'ABCDEF') STOP 13
49 end subroutine source_check
50 subroutine source_check4()
51 character(kind=4,len=:), allocatable :: str, str2
52 target :: str
53 character(kind=4,len=8) :: str3
54 character(kind=4,len=:), pointer :: str4, str5
55 nullify(str4)
56 str3 = 4_'AbCdEfGhIj'
57 if(allocated(str)) STOP 14
58 allocate(str, source=str3)
59 if(.not.allocated(str)) STOP 15
60 if(len(str) /= 8) STOP 16
61 if(str /= 4_'AbCdEfGh') STOP 17
62 if(associated(str4)) STOP 18
63 str4 => str
64 if(str4 /= str .or. len(str4)/=8) STOP 19
65 if(.not.associated(str4, str)) STOP 20
66 str4 => null()
67 str = 4_'12a56b78'
68 if(str4 == 4_'12a56b78') STOP 21
69 str4 = 4_'ABCDEFGH'
70 if(str == 4_'ABCDEFGH') STOP 22
71 allocate(str5, source=str)
72 if(associated(str5, str)) STOP 23
73 if(str5 /= 4_'12a56b78' .or. len(str5)/=8) STOP 24
74 str = 4_'abcdef'
75 if(str5 == 4_'abcdef') STOP 25
76 str5 = 4_'ABCDEF'
77 if(str == 4_'ABCDEF') STOP 26
78 end subroutine source_check4
79 subroutine mold_check()
80 character(len=:), allocatable :: str, str2
81 character(len=8) :: str3
82 character(len=:), pointer :: str4, str5
83 nullify(str4)
84 str2 = "ABCE"
85 ALLOCATE( str, MOLD=str3)
86 if (len(str) /= 8) STOP 27
87 DEALLOCATE(str)
88 ALLOCATE( str, MOLD=str2)
89 if (len(str) /= 4) STOP 28
91 IF (associated(str4)) STOP 29
92 ALLOCATE( str4, MOLD=str3)
93 IF (.not.associated(str4)) STOP 30
94 str4 = '12345678'
95 if (len(str4) /= 8) STOP 31
96 if(str4 /= '12345678') STOP 32
97 DEALLOCATE(str4)
98 ALLOCATE( str4, MOLD=str2)
99 str4 = 'ABCD'
100 if (len(str4) /= 4) STOP 33
101 if (str4 /= 'ABCD') STOP 34
102 str5 => str4
103 if(.not.associated(str4,str5)) STOP 35
104 if(len(str5) /= 4 .or. len(str4) /= len(str5)) STOP 36
105 if(str5 /= str4) STOP 37
106 deallocate(str4)
107 end subroutine mold_check
108 subroutine mold_check4()
109 character(len=:,kind=4), allocatable :: str, str2
110 character(len=8,kind=4) :: str3
111 character(len=:,kind=4), pointer :: str4, str5
112 nullify(str4)
113 str2 = 4_"ABCE"
114 ALLOCATE( str, MOLD=str3)
115 if (len(str) /= 8) STOP 38
116 DEALLOCATE(str)
117 ALLOCATE( str, MOLD=str2)
118 if (len(str) /= 4) STOP 39
120 IF (associated(str4)) STOP 40
121 ALLOCATE( str4, MOLD=str3)
122 IF (.not.associated(str4)) STOP 41
123 str4 = 4_'12345678'
124 if (len(str4) /= 8) STOP 42
125 if(str4 /= 4_'12345678') STOP 43
126 DEALLOCATE(str4)
127 ALLOCATE( str4, MOLD=str2)
128 str4 = 4_'ABCD'
129 if (len(str4) /= 4) STOP 44
130 if (str4 /= 4_'ABCD') STOP 45
131 str5 => str4
132 if(.not.associated(str4,str5)) STOP 46
133 if(len(str5) /= 4 .or. len(str4) /= len(str5)) STOP 47
134 if(str5 /= str4) STOP 48
135 deallocate(str4)
136 end subroutine mold_check4
137 subroutine ftn_test()
138 character(len=:), allocatable :: str_a
139 character(len=:), pointer :: str_p
140 nullify(str_p)
141 call proc_test(str_a, str_p, .false.)
142 if (str_p /= '123457890abcdef') STOP 49
143 if (len(str_p) /= 50) STOP 50
144 if (str_a(1:5) /= 'ABCDE ') STOP 51
145 if (len(str_a) /= 50) STOP 52
146 deallocate(str_p)
147 str_a = '1245'
148 if(len(str_a) /= 4) STOP 53
149 if(str_a /= '1245') STOP 54
150 allocate(character(len=6) :: str_p)
151 if(len(str_p) /= 6) STOP 55
152 str_p = 'AbCdEf'
153 call proc_test(str_a, str_p, .true.)
154 if (str_p /= '123457890abcdef') STOP 56
155 if (len(str_p) /= 50) STOP 57
156 if (str_a(1:5) /= 'ABCDE ') STOP 58
157 if (len(str_a) /= 50) STOP 59
158 deallocate(str_p)
159 end subroutine ftn_test
160 subroutine proc_test(a, p, alloc)
161 character(len=:), allocatable :: a
162 character(len=:), pointer :: p
163 character(len=5), target :: loc
164 logical :: alloc
165 if (.not. alloc) then
166 if(associated(p)) STOP 60
167 if(allocated(a)) STOP 61
168 else
169 if(len(a) /= 4) STOP 62
170 if(a /= '1245') STOP 63
171 if(len(p) /= 6) STOP 64
172 if(p /= 'AbCdEf') STOP 65
173 deallocate(a)
174 nullify(p)
175 end if
176 allocate(character(len=50) :: a)
177 a(1:5) = 'ABCDE'
178 if(len(a) /= 50) STOP 66
179 if(a(1:5) /= "ABCDE") STOP 67
180 loc = '12345'
181 p => loc
182 if (len(p) /= 5) STOP 68
183 if (p /= '12345') STOP 69
184 p = '12345679'
185 if (len(p) /= 5) STOP 70
186 if (p /= '12345') STOP 71
187 p = 'ABC'
188 if (loc /= 'ABC ') STOP 72
189 allocate(p, mold=a)
190 if (.not.associated(p)) STOP 73
191 p = '123457890abcdef'
192 if (p /= '123457890abcdef') STOP 74
193 if (len(p) /= 50) STOP 75
194 end subroutine proc_test
195 subroutine ftn_test4()
196 character(len=:,kind=4), allocatable :: str_a
197 character(len=:,kind=4), pointer :: str_p
198 nullify(str_p)
199 call proc_test4(str_a, str_p, .false.)
200 if (str_p /= 4_'123457890abcdef') STOP 76
201 if (len(str_p) /= 50) STOP 77
202 if (str_a(1:5) /= 4_'ABCDE ') STOP 78
203 if (len(str_a) /= 50) STOP 79
204 deallocate(str_p)
205 str_a = 4_'1245'
206 if(len(str_a) /= 4) STOP 80
207 if(str_a /= 4_'1245') STOP 81
208 allocate(character(len=6, kind = 4) :: str_p)
209 if(len(str_p) /= 6) STOP 82
210 str_p = 4_'AbCdEf'
211 call proc_test4(str_a, str_p, .true.)
212 if (str_p /= 4_'123457890abcdef') STOP 83
213 if (len(str_p) /= 50) STOP 84
214 if (str_a(1:5) /= 4_'ABCDE ') STOP 85
215 if (len(str_a) /= 50) STOP 86
216 deallocate(str_p)
217 end subroutine ftn_test4
218 subroutine proc_test4(a, p, alloc)
219 character(len=:,kind=4), allocatable :: a
220 character(len=:,kind=4), pointer :: p
221 character(len=5,kind=4), target :: loc
222 logical :: alloc
223 if (.not. alloc) then
224 if(associated(p)) STOP 87
225 if(allocated(a)) STOP 88
226 else
227 if(len(a) /= 4) STOP 89
228 if(a /= 4_'1245') STOP 90
229 if(len(p) /= 6) STOP 91
230 if(p /= 4_'AbCdEf') STOP 92
231 deallocate(a)
232 nullify(p)
233 end if
234 allocate(character(len=50,kind=4) :: a)
235 a(1:5) = 4_'ABCDE'
236 if(len(a) /= 50) STOP 93
237 if(a(1:5) /= 4_"ABCDE") STOP 94
238 loc = '12345'
239 p => loc
240 if (len(p) /= 5) STOP 95
241 if (p /= 4_'12345') STOP 96
242 p = 4_'12345679'
243 if (len(p) /= 5) STOP 97
244 if (p /= 4_'12345') STOP 98
245 p = 4_'ABC'
246 if (loc /= 4_'ABC ') STOP 99
247 allocate(p, mold=a)
248 if (.not.associated(p)) STOP 100
249 p = 4_'123457890abcdef'
250 if (p /= 4_'123457890abcdef') STOP 101
251 if (len(p) /= 50) STOP 102
252 end subroutine proc_test4
253 subroutine source3()
254 character(len=:, kind=1), allocatable :: a1
255 character(len=:, kind=4), allocatable :: a4
256 character(len=:, kind=1), pointer :: p1
257 character(len=:, kind=4), pointer :: p4
258 allocate(a1, source='ABC') ! << ICE
259 if(len(a1) /= 3 .or. a1 /= 'ABC') STOP 103
260 allocate(a4, source=4_'12345') ! << ICE
261 if(len(a4) /= 5 .or. a4 /= 4_'12345') STOP 104
262 allocate(p1, mold='AB') ! << ICE
263 if(len(p1) /= 2) STOP 105
264 allocate(p4, mold=4_'145') ! << ICE
265 if(len(p4) /= 3) STOP 106
266 end subroutine source3
267 end program test
268 ! Spurious -Wstringop-overflow warning with -O1
269 ! { dg-prune-output "\\\[-Wstringop-overflow=]" }