hppa64: Fix fmt_f_default_field_width_3.f90 and fmt_g_default_field_width_3.f90
[official-gcc.git] / gcc / testsuite / gfortran.dg / bind-c-contiguous-1.f90
blobd638dbbef252bc8a291cd67983e71280ca714f7a
1 ! { dg-do run }
2 ! { dg-additional-sources bind-c-contiguous-1.c }
3 ! { dg-additional-options "-fcheck=all" }
4 ! { dg-additional-options -Wno-complain-wrong-lang }
6 ! Fortran demands that with bind(C), the callee ensure that for
7 ! * 'contiguous'
8 ! * len=* with explicit/assumed-size arrays
9 ! noncontiguous actual arguments are handled.
10 ! (in without bind(C) in gfortran, caller handles the copy in/out
12 ! Additionally, for a bind(C) callee, a Fortran-written caller
13 ! has to ensure the same (for contiguous + len=* to explicit-/assumed-size arrays)
15 module m
16 use iso_c_binding, only: c_intptr_t, c_bool, c_loc, c_int
17 implicit none (type, external)
19 type, bind(C) :: loc_t
20 integer(c_intptr_t) :: x, y, z
21 end type loc_t
23 interface
24 type(loc_t) function char_assumed_size_c (xx, yy, zz, n, num) bind(C)
25 import :: loc_t, c_bool, c_int
26 integer(c_int), value :: n, num
27 character(len=*) :: xx(*), yy(n:*), zz(6:6, 3:n, 3:*)
28 end function
30 type(loc_t) function char_assumed_size_in_c (xx, yy, zz, n, num) bind(C)
31 import :: loc_t, c_bool, c_int
32 integer(c_int), value :: n, num
33 character(len=*), intent(in) :: xx(*), yy(n:*), zz(6:6, 3:n, 3:*)
34 end function
36 type(loc_t) function char_expl_size_c (xx, yy, zz, n, num) bind(c)
37 import :: loc_t, c_bool, c_int
38 integer(c_int), value :: n, num
39 character(len=*) :: xx(n), yy(n:n+3), zz(6:6, 3:n, 3:n+3)
40 end function
42 type(loc_t) function char_expl_size_in_c (xx, yy, zz, n, num) bind(c)
43 import :: loc_t, c_bool, c_int
44 integer(c_int), value :: n, num
45 character(len=*), intent(in) :: xx(n), yy(n:n+3), zz(6:6, 3:n, 3:n+3)
46 end function
48 type(loc_t) function char_assumed_rank_c (xx, yy, zz, k, num) bind(c)
49 import :: loc_t, c_bool, c_int
50 integer, value :: k, num
51 character(len=*) :: xx(..)
52 character(len=3) :: yy(..)
53 character(len=k) :: zz(..)
54 end function
56 type(loc_t) function char_assumed_rank_in_c (xx, yy, zz, k, num) bind(c)
57 import :: loc_t, c_bool, c_int
58 integer, value :: k, num
59 character(len=*), intent(in) :: xx(..)
60 character(len=3), intent(in) :: yy(..)
61 character(len=k), intent(in) :: zz(..)
62 end function
64 type(loc_t) function char_assumed_rank_cont_c (xx, yy, zz, k, num) bind(c)
65 import :: loc_t, c_bool, c_int
66 integer, value :: k, num
67 character(len=*), contiguous :: xx(..)
68 character(len=3), contiguous :: yy(..)
69 character(len=k), contiguous :: zz(..)
70 end function
72 type(loc_t) function char_assumed_rank_cont_in_c (xx, yy, zz, k, num) bind(c)
73 import :: loc_t, c_bool, c_int
74 integer, value :: k, num
75 character(len=*), contiguous, intent(in) :: xx(..)
76 character(len=3), contiguous, intent(in) :: yy(..)
77 character(len=k), contiguous, intent(in) :: zz(..)
78 end function
80 type(loc_t) function char_assumed_shape_c (xx, yy, zz, k, num) bind(c)
81 import :: loc_t, c_bool, c_int
82 integer, value :: k, num
83 character(len=*) :: xx(:)
84 character(len=3) :: yy(5:)
85 character(len=k) :: zz(-k:)
86 end function
88 type(loc_t) function char_assumed_shape_in_c (xx, yy, zz, k, num) bind(c)
89 import :: loc_t, c_bool, c_int
90 integer, value :: k, num
91 character(len=*), intent(in) :: xx(:)
92 character(len=3), intent(in) :: yy(5:)
93 character(len=k), intent(in) :: zz(-k:)
94 end function
96 type(loc_t) function char_assumed_shape_cont_c (xx, yy, zz, k, num) bind(c)
97 import :: loc_t, c_bool, c_int
98 integer, value :: k, num
99 character(len=*), contiguous :: xx(:)
100 character(len=3), contiguous :: yy(5:)
101 character(len=k), contiguous :: zz(-k:)
102 end function
104 type(loc_t) function char_assumed_shape_cont_in_c (xx, yy, zz, k, num) bind(c)
105 import :: loc_t, c_bool, c_int
106 integer, value :: k, num
107 character(len=*), contiguous, intent(in) :: xx(:)
108 character(len=3), contiguous, intent(in) :: yy(5:)
109 character(len=k), contiguous, intent(in) :: zz(-k:)
110 end function
111 end interface
113 contains
115 type(loc_t) function char_assumed_size_f (xx, yy, zz, n, num) bind(c) result(res)
116 integer, value :: num, n
117 character(len=*) :: xx(*), yy(n:*), zz(6:6, 3:n, 3:*)
118 print *, xx(1:3)
119 if (3 /= len(xx)) error stop 1
120 if (3 /= len(yy)) error stop 1
121 if (3 /= len(zz)) error stop 1
122 if (1 /= lbound(xx,dim=1)) error stop 1
123 if (3 /= lbound(yy,dim=1)) error stop 1
124 if (6 /= lbound(zz,dim=1)) error stop 1
125 if (3 /= lbound(zz,dim=2)) error stop 1
126 if (3 /= lbound(zz,dim=3)) error stop 1
127 if (1 /= size(zz,dim=1)) error stop 1
128 if (1 /= size(zz,dim=2)) error stop 1
129 if (6 /= ubound(zz,dim=1)) error stop 1
130 if (3 /= ubound(zz,dim=2)) error stop 1
131 if (num == 1) then
132 if (xx(1) /= "abc") error stop 2
133 if (xx(2) /= "ghi") error stop 3
134 if (xx(3) /= "nop") error stop 4
135 if (yy(3) /= "abc") error stop 2
136 if (yy(4) /= "ghi") error stop 3
137 if (yy(5) /= "nop") error stop 4
138 if (zz(6,n,3) /= "abc") error stop 2
139 if (zz(6,n,4) /= "ghi") error stop 3
140 if (zz(6,n,5) /= "nop") error stop 4
141 else if (num == 2) then
142 if (xx(1) /= "def") error stop 2
143 if (xx(2) /= "ghi") error stop 3
144 if (xx(3) /= "jlm") error stop 4
145 if (yy(3) /= "def") error stop 2
146 if (yy(4) /= "ghi") error stop 3
147 if (yy(5) /= "jlm") error stop 4
148 if (zz(6,n,3) /= "def") error stop 2
149 if (zz(6,n,4) /= "ghi") error stop 3
150 if (zz(6,n,5) /= "jlm") error stop 4
151 else
152 error stop 8
153 endif
154 xx(1) = "ABC"
155 xx(2) = "DEF"
156 xx(3) = "GHI"
157 yy(3) = "ABC"
158 yy(4) = "DEF"
159 yy(5) = "GHI"
160 zz(6,n,3) = "ABC"
161 zz(6,n,4) = "DEF"
162 zz(6,n,5) = "GHI"
163 res%x = %loc(xx) ! { dg-warning "Legacy Extension" }
164 res%y = %loc(yy) ! { dg-warning "Legacy Extension" }
165 res%z = %loc(zz) ! { dg-warning "Legacy Extension" }
168 type(loc_t) function char_assumed_size_in_f (xx, yy, zz, n, num) bind(c) result(res)
169 integer, value :: num, n
170 character(len=*) :: xx(*), yy(n:*), zz(6:6, 3:n, 3:*)
171 intent(in) :: xx, yy, zz
172 print *, xx(1:3)
173 if (3 /= len(xx)) error stop 1
174 if (3 /= len(yy)) error stop 1
175 if (3 /= len(zz)) error stop 1
176 if (1 /= lbound(xx,dim=1)) error stop 1
177 if (3 /= lbound(yy,dim=1)) error stop 1
178 if (6 /= lbound(zz,dim=1)) error stop 1
179 if (3 /= lbound(zz,dim=2)) error stop 1
180 if (3 /= lbound(zz,dim=3)) error stop 1
181 if (1 /= size(zz,dim=1)) error stop 1
182 if (1 /= size(zz,dim=2)) error stop 1
183 if (6 /= ubound(zz,dim=1)) error stop 1
184 if (3 /= ubound(zz,dim=2)) error stop 1
185 if (num == 1) then
186 if (xx(1) /= "abc") error stop 2
187 if (xx(2) /= "ghi") error stop 3
188 if (xx(3) /= "nop") error stop 4
189 if (yy(3) /= "abc") error stop 2
190 if (yy(4) /= "ghi") error stop 3
191 if (yy(5) /= "nop") error stop 4
192 if (zz(6,n,3) /= "abc") error stop 2
193 if (zz(6,n,4) /= "ghi") error stop 3
194 if (zz(6,n,5) /= "nop") error stop 4
195 else if (num == 2) then
196 if (xx(1) /= "def") error stop 2
197 if (xx(2) /= "ghi") error stop 3
198 if (xx(3) /= "jlm") error stop 4
199 if (yy(3) /= "def") error stop 2
200 if (yy(4) /= "ghi") error stop 3
201 if (yy(5) /= "jlm") error stop 4
202 if (zz(6,n,3) /= "def") error stop 2
203 if (zz(6,n,4) /= "ghi") error stop 3
204 if (zz(6,n,5) /= "jlm") error stop 4
205 else
206 error stop 8
207 endif
208 res%x = %loc(xx) ! { dg-warning "Legacy Extension" }
209 res%y = %loc(yy) ! { dg-warning "Legacy Extension" }
210 res%z = %loc(zz) ! { dg-warning "Legacy Extension" } if (num == 1) then
213 type(loc_t) function char_expl_size_f (xx, yy, zz, n, num) bind(c) result(res)
214 integer, value :: num, n
215 character(len=*) :: xx(n), yy(n:n+2), zz(6:6, 3:n, 3:n+2)
216 print *, xx(1:3)
217 if (3 /= len(xx)) error stop 1
218 if (3 /= len(yy)) error stop 1
219 if (3 /= len(zz)) error stop 1
220 if (1 /= lbound(xx,dim=1)) error stop 1
221 if (3 /= lbound(yy,dim=1)) error stop 1
222 if (6 /= lbound(zz,dim=1)) error stop 1
223 if (3 /= lbound(zz,dim=2)) error stop 1
224 if (3 /= lbound(zz,dim=3)) error stop 1
225 if (3 /= size(xx,dim=1)) error stop 1
226 if (3 /= size(yy,dim=1)) error stop 1
227 if (1 /= size(zz,dim=1)) error stop 1
228 if (1 /= size(zz,dim=2)) error stop 1
229 if (3 /= size(zz,dim=3)) error stop 1
230 if (3 /= ubound(xx,dim=1)) error stop 1
231 if (5 /= ubound(yy,dim=1)) error stop 1
232 if (6 /= ubound(zz,dim=1)) error stop 1
233 if (3 /= ubound(zz,dim=2)) error stop 1
234 if (5 /= ubound(zz,dim=3)) error stop 1
235 if (num == 1) then
236 if (xx(1) /= "abc") error stop 2
237 if (xx(2) /= "ghi") error stop 3
238 if (xx(3) /= "nop") error stop 4
239 if (yy(3) /= "abc") error stop 2
240 if (yy(4) /= "ghi") error stop 3
241 if (yy(5) /= "nop") error stop 4
242 if (zz(6,n,3) /= "abc") error stop 2
243 if (zz(6,n,4) /= "ghi") error stop 3
244 if (zz(6,n,5) /= "nop") error stop 4
245 else if (num == 2) then
246 if (xx(1) /= "def") error stop 2
247 if (xx(2) /= "ghi") error stop 3
248 if (xx(3) /= "jlm") error stop 4
249 if (yy(3) /= "def") error stop 2
250 if (yy(4) /= "ghi") error stop 3
251 if (yy(5) /= "jlm") error stop 4
252 if (zz(6,n,3) /= "def") error stop 2
253 if (zz(6,n,4) /= "ghi") error stop 3
254 if (zz(6,n,5) /= "jlm") error stop 4
255 else
256 error stop 8
257 endif
258 xx(1) = "ABC"
259 xx(2) = "DEF"
260 xx(3) = "GHI"
261 yy(3) = "ABC"
262 yy(4) = "DEF"
263 yy(5) = "GHI"
264 zz(6,n,3) = "ABC"
265 zz(6,n,4) = "DEF"
266 zz(6,n,5) = "GHI"
267 res%x = %loc(xx) ! { dg-warning "Legacy Extension" }
268 res%y = %loc(yy) ! { dg-warning "Legacy Extension" }
269 res%z = %loc(zz) ! { dg-warning "Legacy Extension" }
272 type(loc_t) function char_expl_size_in_f (xx, yy, zz, n, num) bind(c) result(res)
273 integer, value :: num, n
274 character(len=*) :: xx(n), yy(n:n+2), zz(6:6, 3:n, 3:n+2)
275 intent(in) :: xx, yy, zz
276 print *, xx(1:3)
277 if (3 /= len(xx)) error stop 1
278 if (3 /= len(yy)) error stop 1
279 if (3 /= len(zz)) error stop 1
280 if (1 /= lbound(xx,dim=1)) error stop 1
281 if (3 /= lbound(yy,dim=1)) error stop 1
282 if (6 /= lbound(zz,dim=1)) error stop 1
283 if (3 /= lbound(zz,dim=2)) error stop 1
284 if (3 /= lbound(zz,dim=3)) error stop 1
285 if (3 /= size(xx,dim=1)) error stop 1
286 if (3 /= size(yy,dim=1)) error stop 1
287 if (1 /= size(zz,dim=1)) error stop 1
288 if (1 /= size(zz,dim=2)) error stop 1
289 if (3 /= size(zz,dim=3)) error stop 1
290 if (3 /= ubound(xx,dim=1)) error stop 1
291 if (5 /= ubound(yy,dim=1)) error stop 1
292 if (6 /= ubound(zz,dim=1)) error stop 1
293 if (3 /= ubound(zz,dim=2)) error stop 1
294 if (5 /= ubound(zz,dim=3)) error stop 1
295 if (num == 1) then
296 if (xx(1) /= "abc") error stop 2
297 if (xx(2) /= "ghi") error stop 3
298 if (xx(3) /= "nop") error stop 4
299 if (yy(3) /= "abc") error stop 2
300 if (yy(4) /= "ghi") error stop 3
301 if (yy(5) /= "nop") error stop 4
302 if (zz(6,n,3) /= "abc") error stop 2
303 if (zz(6,n,4) /= "ghi") error stop 3
304 if (zz(6,n,5) /= "nop") error stop 4
305 else if (num == 2) then
306 if (xx(1) /= "def") error stop 2
307 if (xx(2) /= "ghi") error stop 3
308 if (xx(3) /= "jlm") error stop 4
309 if (yy(3) /= "def") error stop 2
310 if (yy(4) /= "ghi") error stop 3
311 if (yy(5) /= "jlm") error stop 4
312 if (zz(6,n,3) /= "def") error stop 2
313 if (zz(6,n,4) /= "ghi") error stop 3
314 if (zz(6,n,5) /= "jlm") error stop 4
315 else
316 error stop 8
317 endif
318 res%x = %loc(xx) ! { dg-warning "Legacy Extension" }
319 res%y = %loc(yy) ! { dg-warning "Legacy Extension" }
320 res%z = %loc(zz) ! { dg-warning "Legacy Extension" }
324 type(loc_t) function char_assumed_rank_f (xx, yy, zz, k, num) bind(c) result(res)
325 integer, value :: num, k
326 character(len=*) :: xx(..)
327 character(len=3) :: yy(..)
328 character(len=k) :: zz(..)
329 if (3 /= len(xx)) error stop 40
330 if (3 /= len(yy)) error stop 40
331 if (3 /= len(zz)) error stop 40
332 if (3 /= size(xx)) error stop 41
333 if (3 /= size(yy)) error stop 41
334 if (3 /= size(zz)) error stop 41
335 if (1 /= rank(xx)) error stop 49
336 if (1 /= rank(yy)) error stop 49
337 if (1 /= rank(zz)) error stop 49
338 if (1 /= lbound(xx, dim=1)) stop 49
339 if (1 /= lbound(yy, dim=1)) stop 49
340 if (1 /= lbound(zz, dim=1)) stop 49
341 if (3 /= ubound(xx, dim=1)) stop 49
342 if (3 /= ubound(yy, dim=1)) stop 49
343 if (3 /= ubound(zz, dim=1)) stop 49
344 if (num == 1) then
345 if (is_contiguous (xx)) error stop 49
346 if (is_contiguous (yy)) error stop 49
347 if (is_contiguous (zz)) error stop 49
348 else if (num == 2) then
349 if (.not. is_contiguous (xx)) error stop 49
350 if (.not. is_contiguous (yy)) error stop 49
351 if (.not. is_contiguous (zz)) error stop 49
352 else
353 error stop 48
354 end if
355 select rank (xx)
356 rank (1)
357 print *, xx(1:3)
358 if (num == 1) then
359 if (xx(1) /= "abc") error stop 42
360 if (xx(2) /= "ghi") error stop 43
361 if (xx(3) /= "nop") error stop 44
362 else if (num == 2) then
363 if (xx(1) /= "def") error stop 45
364 if (xx(2) /= "ghi") error stop 46
365 if (xx(3) /= "jlm") error stop 47
366 else
367 error stop 48
368 endif
369 xx(1) = "ABC"
370 xx(2) = "DEF"
371 xx(3) = "GHI"
372 res%x = get_loc (xx)
373 rank default
374 error stop 99
375 end select
376 select rank (yy)
377 rank (1)
378 print *, yy(1:3)
379 if (num == 1) then
380 if (yy(1) /= "abc") error stop 42
381 if (yy(2) /= "ghi") error stop 43
382 if (yy(3) /= "nop") error stop 44
383 else if (num == 2) then
384 if (yy(1) /= "def") error stop 45
385 if (yy(2) /= "ghi") error stop 46
386 if (yy(3) /= "jlm") error stop 47
387 else
388 error stop 48
389 endif
390 yy(1) = "ABC"
391 yy(2) = "DEF"
392 yy(3) = "GHI"
393 res%y = get_loc (yy)
394 rank default
395 error stop 99
396 end select
397 select rank (zz)
398 rank (1)
399 print *, zz(1:3)
400 if (num == 1) then
401 if (zz(1) /= "abc") error stop 42
402 if (zz(2) /= "ghi") error stop 43
403 if (zz(3) /= "nop") error stop 44
404 else if (num == 2) then
405 if (zz(1) /= "def") error stop 45
406 if (zz(2) /= "ghi") error stop 46
407 if (zz(3) /= "jlm") error stop 47
408 else
409 error stop 48
410 endif
411 zz(1) = "ABC"
412 zz(2) = "DEF"
413 zz(3) = "GHI"
414 res%z = get_loc (zz)
415 rank default
416 error stop 99
417 end select
418 contains
419 integer (c_intptr_t) function get_loc (arg)
420 character(len=*), target :: arg(:)
421 ! %loc does copy in/out if not simply contiguous
422 ! extra func needed because of 'target' attribute
423 get_loc = transfer (c_loc(arg), res%x)
427 type(loc_t) function char_assumed_rank_in_f (xx, yy, zz, k, num) bind(c) result(res)
428 integer, value :: num, k
429 character(len=*) :: xx(..)
430 character(len=3) :: yy(..)
431 character(len=k) :: zz(..)
432 intent(in) :: xx, yy, zz
433 if (3 /= size(yy)) error stop 50
434 if (3 /= len(yy)) error stop 51
435 if (1 /= rank(yy)) error stop 59
436 if (1 /= lbound(xx, dim=1)) stop 49
437 if (1 /= lbound(yy, dim=1)) stop 49
438 if (1 /= lbound(zz, dim=1)) stop 49
439 if (3 /= ubound(xx, dim=1)) stop 49
440 if (3 /= ubound(yy, dim=1)) stop 49
441 if (3 /= ubound(zz, dim=1)) stop 49
442 if (num == 1) then
443 if (is_contiguous (xx)) error stop 59
444 if (is_contiguous (yy)) error stop 59
445 if (is_contiguous (zz)) error stop 59
446 else if (num == 2) then
447 if (.not. is_contiguous (xx)) error stop 59
448 if (.not. is_contiguous (yy)) error stop 59
449 if (.not. is_contiguous (zz)) error stop 59
450 else
451 error stop 48
452 end if
453 select rank (xx)
454 rank (1)
455 print *, xx(1:3)
456 if (num == 1) then
457 if (xx(1) /= "abc") error stop 52
458 if (xx(2) /= "ghi") error stop 53
459 if (xx(3) /= "nop") error stop 54
460 else if (num == 2) then
461 if (xx(1) /= "def") error stop 55
462 if (xx(2) /= "ghi") error stop 56
463 if (xx(3) /= "jlm") error stop 57
464 else
465 error stop 58
466 endif
467 res%x = get_loc(xx)
468 rank default
469 error stop 99
470 end select
471 select rank (yy)
472 rank (1)
473 print *, yy(1:3)
474 if (num == 1) then
475 if (yy(1) /= "abc") error stop 52
476 if (yy(2) /= "ghi") error stop 53
477 if (yy(3) /= "nop") error stop 54
478 else if (num == 2) then
479 if (yy(1) /= "def") error stop 55
480 if (yy(2) /= "ghi") error stop 56
481 if (yy(3) /= "jlm") error stop 57
482 else
483 error stop 58
484 endif
485 res%y = get_loc(yy)
486 rank default
487 error stop 99
488 end select
489 select rank (zz)
490 rank (1)
491 print *, zz(1:3)
492 if (num == 1) then
493 if (zz(1) /= "abc") error stop 52
494 if (zz(2) /= "ghi") error stop 53
495 if (zz(3) /= "nop") error stop 54
496 else if (num == 2) then
497 if (zz(1) /= "def") error stop 55
498 if (zz(2) /= "ghi") error stop 56
499 if (zz(3) /= "jlm") error stop 57
500 else
501 error stop 58
502 endif
503 res%z = get_loc(zz)
504 rank default
505 error stop 99
506 end select
507 contains
508 integer (c_intptr_t) function get_loc (arg)
509 character(len=*), target :: arg(:)
510 ! %loc does copy in/out if not simply contiguous
511 ! extra func needed because of 'target' attribute
512 get_loc = transfer (c_loc(arg), res%x)
518 type(loc_t) function char_assumed_rank_cont_f (xx, yy, zz, k, num) bind(c) result(res)
519 integer, value :: num, k
520 character(len=*) :: xx(..)
521 character(len=3) :: yy(..)
522 character(len=k) :: zz(..)
523 contiguous :: xx, yy, zz
524 if (3 /= len(xx)) error stop 60
525 if (3 /= len(yy)) error stop 60
526 if (3 /= len(zz)) error stop 60
527 if (3 /= size(xx)) error stop 61
528 if (3 /= size(yy)) error stop 61
529 if (3 /= size(zz)) error stop 61
530 if (1 /= rank(xx)) error stop 69
531 if (1 /= rank(yy)) error stop 69
532 if (1 /= rank(zz)) error stop 69
533 if (1 /= lbound(xx, dim=1)) stop 49
534 if (1 /= lbound(yy, dim=1)) stop 49
535 if (1 /= lbound(zz, dim=1)) stop 49
536 if (3 /= ubound(xx, dim=1)) stop 49
537 if (3 /= ubound(yy, dim=1)) stop 49
538 if (3 /= ubound(zz, dim=1)) stop 49
539 select rank (xx)
540 rank (1)
541 print *, xx(1:3)
542 if (num == 1) then
543 if (xx(1) /= "abc") error stop 62
544 if (xx(2) /= "ghi") error stop 63
545 if (xx(3) /= "nop") error stop 64
546 else if (num == 2) then
547 if (xx(1) /= "def") error stop 65
548 if (xx(2) /= "ghi") error stop 66
549 if (xx(3) /= "jlm") error stop 67
550 else
551 error stop 68
552 endif
553 xx(1) = "ABC"
554 xx(2) = "DEF"
555 xx(3) = "GHI"
556 res%x = %loc(xx) ! { dg-warning "Legacy Extension" }
557 rank default
558 error stop 99
559 end select
560 select rank (yy)
561 rank (1)
562 print *, yy(1:3)
563 if (num == 1) then
564 if (yy(1) /= "abc") error stop 62
565 if (yy(2) /= "ghi") error stop 63
566 if (yy(3) /= "nop") error stop 64
567 else if (num == 2) then
568 if (yy(1) /= "def") error stop 65
569 if (yy(2) /= "ghi") error stop 66
570 if (yy(3) /= "jlm") error stop 67
571 else
572 error stop 68
573 endif
574 yy(1) = "ABC"
575 yy(2) = "DEF"
576 yy(3) = "GHI"
577 res%y = %loc(yy) ! { dg-warning "Legacy Extension" }
578 rank default
579 error stop 99
580 end select
581 select rank (zz)
582 rank (1)
583 print *, zz(1:3)
584 if (num == 1) then
585 if (zz(1) /= "abc") error stop 62
586 if (zz(2) /= "ghi") error stop 63
587 if (zz(3) /= "nop") error stop 64
588 else if (num == 2) then
589 if (zz(1) /= "def") error stop 65
590 if (zz(2) /= "ghi") error stop 66
591 if (zz(3) /= "jlm") error stop 67
592 else
593 error stop 68
594 endif
595 zz(1) = "ABC"
596 zz(2) = "DEF"
597 zz(3) = "GHI"
598 res%z = %loc(zz) ! { dg-warning "Legacy Extension" }
599 rank default
600 error stop 99
601 end select
604 type(loc_t) function char_assumed_rank_cont_in_f (xx, yy, zz, k, num) bind(c) result(res)
605 integer, value :: num, k
606 character(len=*) :: xx(..)
607 character(len=3) :: yy(..)
608 character(len=k) :: zz(..)
609 intent(in) :: xx, yy, zz
610 contiguous :: xx, yy, zz
611 if (3 /= size(xx)) error stop 30
612 if (3 /= size(yy)) error stop 30
613 if (3 /= size(zz)) error stop 30
614 if (3 /= len(xx)) error stop 31
615 if (3 /= len(yy)) error stop 31
616 if (3 /= len(zz)) error stop 31
617 if (1 /= rank(xx)) error stop 69
618 if (1 /= rank(yy)) error stop 69
619 if (1 /= rank(zz)) error stop 69
620 if (1 /= lbound(xx, dim=1)) stop 49
621 if (1 /= lbound(yy, dim=1)) stop 49
622 if (1 /= lbound(zz, dim=1)) stop 49
623 if (3 /= ubound(xx, dim=1)) stop 49
624 if (3 /= ubound(yy, dim=1)) stop 49
625 if (3 /= ubound(zz, dim=1)) stop 49
626 select rank (xx)
627 rank (1)
628 print *, xx(1:3)
629 if (num == 1) then
630 if (xx(1) /= "abc") error stop 62
631 if (xx(2) /= "ghi") error stop 63
632 if (xx(3) /= "nop") error stop 64
633 else if (num == 2) then
634 if (xx(1) /= "def") error stop 65
635 if (xx(2) /= "ghi") error stop 66
636 if (xx(3) /= "jlm") error stop 67
637 else
638 error stop 68
639 endif
640 res%x = %loc(xx) ! { dg-warning "Legacy Extension" }
641 rank default
642 error stop 99
643 end select
644 select rank (yy)
645 rank (1)
646 print *, yy(1:3)
647 if (num == 1) then
648 if (yy(1) /= "abc") error stop 62
649 if (yy(2) /= "ghi") error stop 63
650 if (yy(3) /= "nop") error stop 64
651 else if (num == 2) then
652 if (yy(1) /= "def") error stop 65
653 if (yy(2) /= "ghi") error stop 66
654 if (yy(3) /= "jlm") error stop 67
655 else
656 error stop 68
657 endif
658 res%y = %loc(yy) ! { dg-warning "Legacy Extension" }
659 rank default
660 error stop 99
661 end select
662 select rank (zz)
663 rank (1)
664 print *, zz(1:3)
665 if (num == 1) then
666 if (zz(1) /= "abc") error stop 62
667 if (zz(2) /= "ghi") error stop 63
668 if (zz(3) /= "nop") error stop 64
669 else if (num == 2) then
670 if (zz(1) /= "def") error stop 65
671 if (zz(2) /= "ghi") error stop 66
672 if (zz(3) /= "jlm") error stop 67
673 else
674 error stop 68
675 endif
676 res%z = %loc(zz) ! { dg-warning "Legacy Extension" }
677 rank default
678 error stop 99
679 end select
682 type(loc_t) function char_assumed_shape_f (xx, yy, zz, k, num) bind(c) result(res)
683 integer, value :: num, k
684 character(len=*) :: xx(:)
685 character(len=3) :: yy(5:)
686 character(len=k) :: zz(-k:)
687 print *, xx(1:3)
688 if (3 /= len(xx)) error stop 70
689 if (3 /= len(yy)) error stop 70
690 if (3 /= len(zz)) error stop 70
691 if (3 /= size(xx)) error stop 71
692 if (3 /= size(yy)) error stop 71
693 if (3 /= size(zz)) error stop 71
694 if (1 /= lbound(xx, dim=1)) stop 49
695 if (5 /= lbound(yy, dim=1)) stop 49
696 if (-k /= lbound(zz, dim=1)) stop 49
697 if (3 /= ubound(xx, dim=1)) stop 49
698 if (7 /= ubound(yy, dim=1)) stop 49
699 if (-k+2 /= ubound(zz, dim=1)) stop 49
700 if (num == 1) then
701 if (is_contiguous (xx)) error stop 79
702 if (is_contiguous (yy)) error stop 79
703 if (is_contiguous (zz)) error stop 79
704 if (xx(1) /= "abc") error stop 72
705 if (xx(2) /= "ghi") error stop 73
706 if (xx(3) /= "nop") error stop 74
707 if (yy(5) /= "abc") error stop 72
708 if (yy(6) /= "ghi") error stop 73
709 if (yy(7) /= "nop") error stop 74
710 if (zz(-k) /= "abc") error stop 72
711 if (zz(-k+1) /= "ghi") error stop 73
712 if (zz(-k+2) /= "nop") error stop 74
713 else if (num == 2) then
714 if (.not.is_contiguous (xx)) error stop 79
715 if (.not.is_contiguous (yy)) error stop 79
716 if (.not.is_contiguous (zz)) error stop 79
717 if (xx(1) /= "def") error stop 72
718 if (xx(2) /= "ghi") error stop 73
719 if (xx(3) /= "jlm") error stop 74
720 if (yy(5) /= "def") error stop 72
721 if (yy(6) /= "ghi") error stop 73
722 if (yy(7) /= "jlm") error stop 74
723 if (zz(-k) /= "def") error stop 72
724 if (zz(-k+1) /= "ghi") error stop 73
725 if (zz(-k+2) /= "jlm") error stop 74
726 else
727 error stop 78
728 endif
729 xx(1) = "ABC"
730 xx(2) = "DEF"
731 xx(3) = "GHI"
732 yy(5) = "ABC"
733 yy(6) = "DEF"
734 yy(7) = "GHI"
735 zz(-k) = "ABC"
736 zz(-k+1) = "DEF"
737 zz(-k+2) = "GHI"
738 res%x = get_loc(xx)
739 res%y = get_loc(yy)
740 res%z = get_loc(zz)
741 contains
742 integer (c_intptr_t) function get_loc (arg)
743 character(len=*), target :: arg(:)
744 ! %loc does copy in/out if not simply contiguous
745 ! extra func needed because of 'target' attribute
746 get_loc = transfer (c_loc(arg), res%x)
750 type(loc_t) function char_assumed_shape_in_f (xx, yy, zz, k, num) bind(c) result(res)
751 integer, value :: num, k
752 character(len=*) :: xx(:)
753 character(len=3) :: yy(5:)
754 character(len=k) :: zz(-k:)
755 intent(in) :: xx, yy, zz
756 print *, xx(1:3)
757 if (3 /= size(xx)) error stop 80
758 if (3 /= size(yy)) error stop 80
759 if (3 /= size(zz)) error stop 80
760 if (3 /= len(xx)) error stop 81
761 if (3 /= len(yy)) error stop 81
762 if (3 /= len(zz)) error stop 81
763 if (1 /= lbound(xx, dim=1)) stop 49
764 if (5 /= lbound(yy, dim=1)) stop 49
765 if (-k /= lbound(zz, dim=1)) stop 49
766 if (3 /= ubound(xx, dim=1)) stop 49
767 if (7 /= ubound(yy, dim=1)) stop 49
768 if (-k+2 /= ubound(zz, dim=1)) stop 49
769 if (num == 1) then
770 if (is_contiguous (xx)) error stop 89
771 if (is_contiguous (yy)) error stop 89
772 if (is_contiguous (zz)) error stop 89
773 if (xx(1) /= "abc") error stop 82
774 if (xx(2) /= "ghi") error stop 83
775 if (xx(3) /= "nop") error stop 84
776 if (yy(5) /= "abc") error stop 82
777 if (yy(6) /= "ghi") error stop 83
778 if (yy(7) /= "nop") error stop 84
779 if (zz(-k) /= "abc") error stop 82
780 if (zz(-k+1) /= "ghi") error stop 83
781 if (zz(-k+2) /= "nop") error stop 84
782 else if (num == 2) then
783 if (.not.is_contiguous (xx)) error stop 89
784 if (.not.is_contiguous (yy)) error stop 89
785 if (.not.is_contiguous (zz)) error stop 89
786 if (xx(1) /= "def") error stop 85
787 if (xx(2) /= "ghi") error stop 86
788 if (xx(3) /= "jlm") error stop 87
789 if (yy(5) /= "def") error stop 85
790 if (yy(6) /= "ghi") error stop 86
791 if (yy(7) /= "jlm") error stop 87
792 if (zz(-k) /= "def") error stop 85
793 if (zz(-k+1) /= "ghi") error stop 86
794 if (zz(-k+2) /= "jlm") error stop 87
795 else
796 error stop 88
797 endif
798 res%x = get_loc(xx)
799 res%y = get_loc(yy)
800 res%z = get_loc(zz)
801 contains
802 integer (c_intptr_t) function get_loc (arg)
803 character(len=*), target :: arg(:)
804 ! %loc does copy in/out if not simply contiguous
805 ! extra func needed because of 'target' attribute
806 get_loc = transfer (c_loc(arg), res%x)
812 type(loc_t) function char_assumed_shape_cont_f (xx, yy, zz, k, num) bind(c) result(res)
813 integer, value :: num, k
814 character(len=*) :: xx(:)
815 character(len=3) :: yy(5:)
816 character(len=k) :: zz(-k:)
817 contiguous :: xx, yy, zz
818 print *, xx(1:3)
819 if (3 /= len(xx)) error stop 90
820 if (3 /= len(yy)) error stop 90
821 if (3 /= len(zz)) error stop 90
822 if (3 /= size(xx)) error stop 91
823 if (3 /= size(yy)) error stop 91
824 if (3 /= size(zz)) error stop 91
825 if (1 /= lbound(xx, dim=1)) stop 49
826 if (5 /= lbound(yy, dim=1)) stop 49
827 if (-k /= lbound(zz, dim=1)) stop 49
828 if (3 /= ubound(xx, dim=1)) stop 49
829 if (7 /= ubound(yy, dim=1)) stop 49
830 if (-k+2 /= ubound(zz, dim=1)) stop 49
831 if (num == 1) then
832 if (xx(1) /= "abc") error stop 92
833 if (xx(2) /= "ghi") error stop 93
834 if (xx(3) /= "nop") error stop 94
835 if (yy(5) /= "abc") error stop 92
836 if (yy(6) /= "ghi") error stop 93
837 if (yy(7) /= "nop") error stop 94
838 if (zz(-k) /= "abc") error stop 92
839 if (zz(-k+1) /= "ghi") error stop 93
840 if (zz(-k+2) /= "nop") error stop 94
841 else if (num == 2) then
842 if (xx(1) /= "def") error stop 92
843 if (xx(2) /= "ghi") error stop 93
844 if (xx(3) /= "jlm") error stop 94
845 if (yy(5) /= "def") error stop 92
846 if (yy(6) /= "ghi") error stop 93
847 if (yy(7) /= "jlm") error stop 94
848 if (zz(-k) /= "def") error stop 92
849 if (zz(-k+1) /= "ghi") error stop 93
850 if (zz(-k+2) /= "jlm") error stop 94
851 else
852 error stop 98
853 endif
854 xx(1) = "ABC"
855 xx(2) = "DEF"
856 xx(3) = "GHI"
857 yy(5) = "ABC"
858 yy(6) = "DEF"
859 yy(7) = "GHI"
860 zz(-k) = "ABC"
861 zz(-k+1) = "DEF"
862 zz(-k+2) = "GHI"
863 res%x = %loc(xx) ! { dg-warning "Legacy Extension" }
864 res%y = %loc(yy) ! { dg-warning "Legacy Extension" }
865 res%z = %loc(zz) ! { dg-warning "Legacy Extension" }
868 type(loc_t) function char_assumed_shape_cont_in_f (xx, yy, zz, k, num) bind(c) result(res)
869 integer, value :: num, k
870 character(len=*) :: xx(:)
871 character(len=3) :: yy(5:)
872 character(len=k) :: zz(-k:)
873 intent(in) :: xx, yy, zz
874 contiguous :: xx, yy, zz
875 print *, xx(1:3)
876 if (3 /= size(xx)) error stop 100
877 if (3 /= size(yy)) error stop 100
878 if (3 /= size(zz)) error stop 100
879 if (3 /= len(xx)) error stop 101
880 if (3 /= len(yy)) error stop 101
881 if (3 /= len(zz)) error stop 101
882 if (1 /= lbound(xx, dim=1)) stop 49
883 if (5 /= lbound(yy, dim=1)) stop 49
884 if (-k /= lbound(zz, dim=1)) stop 49
885 if (3 /= ubound(xx, dim=1)) stop 49
886 if (7 /= ubound(yy, dim=1)) stop 49
887 if (-k+2 /= ubound(zz, dim=1)) stop 49
888 if (num == 1) then
889 if (xx(1) /= "abc") error stop 102
890 if (xx(2) /= "ghi") error stop 103
891 if (xx(3) /= "nop") error stop 104
892 if (yy(5) /= "abc") error stop 102
893 if (yy(6) /= "ghi") error stop 103
894 if (yy(7) /= "nop") error stop 104
895 if (zz(-k) /= "abc") error stop 102
896 if (zz(-k+1) /= "ghi") error stop 103
897 if (zz(-k+2) /= "nop") error stop 104
898 else if (num == 2) then
899 if (xx(1) /= "def") error stop 105
900 if (xx(2) /= "ghi") error stop 106
901 if (xx(3) /= "jlm") error stop 107
902 if (yy(5) /= "def") error stop 105
903 if (yy(6) /= "ghi") error stop 106
904 if (yy(7) /= "jlm") error stop 107
905 if (zz(-k) /= "def") error stop 105
906 if (zz(-k+1) /= "ghi") error stop 106
907 if (zz(-k+2) /= "jlm") error stop 107
908 else
909 error stop 108
910 endif
911 res%x = %loc(xx) ! { dg-warning "Legacy Extension" }
912 res%y = %loc(yy) ! { dg-warning "Legacy Extension" }
913 res%z = %loc(zz) ! { dg-warning "Legacy Extension" }
916 end module
919 use m
920 implicit none (type, external)
921 character(len=3) :: a(6), a2(6), a3(6), a_init(6)
922 type(loc_t) :: loc3
924 a_init = ['abc', 'def', 'ghi', 'jlm', 'nop', 'qrs']
926 ! -- Fortran: assumed size
927 a = a_init; a2 = a_init; a3 = a_init
928 loc3 = char_assumed_size_f (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning
929 if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
930 if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
931 if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
932 if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
933 if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
934 if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
936 a = a_init; a2 = a_init; a3 = a_init
937 loc3 = char_assumed_size_f (a(2:4), a2(2:4), a3(2:4), size(a(2:4)), num=2)
938 if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
939 if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
940 if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
941 if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
942 if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
943 if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
945 a = a_init; a2 = a_init; a3 = a_init
946 loc3 = char_assumed_size_in_f (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning
947 if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
948 if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
949 if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
950 if (any (a /= a_init)) error stop 56
951 if (any (a2 /= a_init)) error stop 58
952 if (any (a3 /= a_init)) error stop 58
954 a = a_init; a2 = a_init; a3 = a_init
955 loc3 = char_assumed_size_in_f (a(2:4), a2(2:4), a3(2:4), size(a(2:4)), num=2)
956 if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
957 if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
958 if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
959 if (any (a /= a_init)) error stop 58
960 if (any (a2 /= a_init)) error stop 58
961 if (any (a3 /= a_init)) error stop 58
963 ! -- Fortran: explicit shape
964 a = a_init; a2 = a_init; a3 = a_init
965 loc3 = char_expl_size_f (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning
966 if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
967 if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
968 if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
969 if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
970 if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
971 if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
973 a = a_init; a2 = a_init; a3 = a_init
974 loc3 = char_expl_size_f (a(2:4), a2(2:4), a3(2:4), size(a(::2)), num=2)
975 if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
976 if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
977 if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
978 if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
979 if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
980 if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
982 a = a_init; a2 = a_init; a3 = a_init
983 loc3 = char_expl_size_in_f (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning
984 if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
985 if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
986 if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
987 if (any (a /= a_init)) error stop 56
988 if (any (a2 /= a_init)) error stop 58
989 if (any (a3 /= a_init)) error stop 58
991 a = a_init; a2 = a_init; a3 = a_init
992 loc3 = char_expl_size_in_f (a(2:4), a2(2:4), a3(2:4), size(a(::2)), num=2)
993 if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
994 if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
995 if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
996 if (any (a /= a_init)) error stop 58
997 if (any (a2 /= a_init)) error stop 58
998 if (any (a3 /= a_init)) error stop 58
1000 ! -- Fortran: assumed rank
1001 a = a_init; a2 = a_init; a3 = a_init
1002 loc3 = char_assumed_rank_f (a(::2), a2(::2), a3(::2), len(a), num=1)
1003 if (loc3%x /= %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
1004 if (loc3%y /= %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
1005 if (loc3%z /= %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
1006 if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
1007 if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
1008 if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
1010 a = a_init; a2 = a_init; a3 = a_init
1011 loc3 = char_assumed_rank_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
1012 if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
1013 if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" }
1014 if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" }
1015 if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
1016 if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
1017 if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
1019 a = a_init; a2 = a_init; a3 = a_init
1020 loc3 = char_assumed_rank_in_f (a(::2), a2(::2), a3(::2), len(a), num=1)
1021 if (loc3%x /= %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
1022 if (loc3%y /= %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" }
1023 if (loc3%z /= %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" }
1024 if (any (a /= a_init)) error stop 56
1025 if (any (a2 /= a_init)) error stop 56
1026 if (any (a3 /= a_init)) error stop 56
1028 a = a_init; a2 = a_init; a3 = a_init
1029 loc3 = char_assumed_rank_in_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
1030 if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
1031 if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" }
1032 if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" }
1033 if (any (a /= a_init)) error stop 58
1034 if (any (a2 /= a_init)) error stop 58
1035 if (any (a3 /= a_init)) error stop 58
1037 ! -- Fortran: assumed rank contiguous
1038 a = a_init; a2 = a_init; a3 = a_init
1039 loc3 = char_assumed_rank_cont_f (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning
1040 if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
1041 if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
1042 if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
1043 if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
1044 if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
1045 if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
1047 a = a_init; a2 = a_init; a3 = a_init
1048 loc3 = char_assumed_rank_cont_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
1049 if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
1050 if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" }
1051 if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" }
1052 if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
1053 if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
1054 if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
1056 a = a_init; a2 = a_init; a3 = a_init
1057 loc3 = char_assumed_rank_cont_in_f (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning
1058 if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
1059 if (loc3%y == %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" }
1060 if (loc3%z == %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" }
1061 if (any (a /= a_init)) error stop 56
1062 if (any (a2 /= a_init)) error stop 56
1063 if (any (a3 /= a_init)) error stop 56
1065 a = a_init; a2 = a_init; a3 = a_init
1066 loc3 = char_assumed_rank_cont_in_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
1067 if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
1068 if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" }
1069 if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" }
1070 if (any (a /= a_init)) error stop 58
1071 if (any (a2 /= a_init)) error stop 58
1072 if (any (a3 /= a_init)) error stop 58
1074 ! -- Fortran: assumed shape
1075 a = a_init; a2 = a_init; a3 = a_init
1076 loc3 = char_assumed_shape_f (a(::2), a2(::2), a3(::2), len(a), num=1)
1077 if (loc3%x /= %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
1078 if (loc3%y /= %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
1079 if (loc3%z /= %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
1080 if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
1081 if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
1082 if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
1084 a = a_init; a2 = a_init; a3 = a_init
1085 loc3 = char_assumed_shape_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
1086 if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
1087 if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" }
1088 if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" }
1089 if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
1090 if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
1091 if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
1093 a = a_init; a2 = a_init; a3 = a_init
1094 loc3 = char_assumed_shape_in_f (a(::2), a2(::2), a3(::2), len(a), num=1)
1095 if (loc3%x /= %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
1096 if (loc3%y /= %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" }
1097 if (loc3%z /= %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" }
1098 if (any (a /= a_init)) error stop 56
1099 if (any (a2 /= a_init)) error stop 56
1100 if (any (a3 /= a_init)) error stop 56
1102 a = a_init; a2 = a_init; a3 = a_init
1103 loc3 = char_assumed_shape_in_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
1104 if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
1105 if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" }
1106 if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" }
1107 if (any (a /= a_init)) error stop 58
1108 if (any (a2 /= a_init)) error stop 58
1109 if (any (a3 /= a_init)) error stop 58
1111 ! -- Fortran: assumed shape contiguous
1112 a = a_init; a2 = a_init; a3 = a_init
1113 loc3 = char_assumed_shape_cont_f (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning
1114 if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
1115 if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
1116 if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
1117 if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
1118 if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
1119 if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
1121 a = a_init; a2 = a_init; a3 = a_init
1122 loc3 = char_assumed_shape_cont_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
1123 if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
1124 if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" }
1125 if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" }
1126 if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
1127 if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
1128 if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
1130 a = a_init; a2 = a_init; a3 = a_init
1131 loc3 = char_assumed_shape_cont_in_f (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning
1132 if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
1133 if (loc3%y == %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" }
1134 if (loc3%z == %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" }
1135 if (any (a /= a_init)) error stop 56
1136 if (any (a2 /= a_init)) error stop 56
1137 if (any (a3 /= a_init)) error stop 56
1139 a = a_init; a2 = a_init; a3 = a_init
1140 loc3 = char_assumed_shape_cont_in_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
1141 if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
1142 if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" }
1143 if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" }
1144 if (any (a /= a_init)) error stop 58
1145 if (any (a2 /= a_init)) error stop 58
1146 if (any (a3 /= a_init)) error stop 58
1149 ! --- character - call C directly --
1151 ! -- C: assumed size
1152 a = a_init; a2 = a_init; a3 = a_init
1153 loc3 = char_assumed_size_c (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning
1154 if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
1155 if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
1156 if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
1157 if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
1158 if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
1159 if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
1161 a = a_init; a2 = a_init; a3 = a_init
1162 loc3 = char_assumed_size_c (a(2:4), a2(2:4), a3(2:4), size(a(2:4)), num=2)
1163 if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
1164 if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
1165 if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
1166 if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
1167 if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
1168 if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
1170 a = a_init; a2 = a_init; a3 = a_init
1171 loc3 = char_assumed_size_in_c (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning
1172 if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
1173 if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
1174 if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
1175 if (any (a /= a_init)) error stop 56
1176 if (any (a2 /= a_init)) error stop 58
1177 if (any (a3 /= a_init)) error stop 58
1179 a = a_init; a2 = a_init; a3 = a_init
1180 loc3 = char_assumed_size_in_c (a(2:4), a2(2:4), a3(2:4), size(a(2:4)), num=2)
1181 if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
1182 if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
1183 if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
1184 if (any (a /= a_init)) error stop 58
1185 if (any (a2 /= a_init)) error stop 58
1186 if (any (a3 /= a_init)) error stop 58
1188 ! -- C: explicit shape
1189 a = a_init; a2 = a_init; a3 = a_init
1190 loc3 = char_expl_size_c (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning
1191 if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
1192 if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
1193 if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
1194 if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
1195 if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
1196 if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
1198 a = a_init; a2 = a_init; a3 = a_init
1199 loc3 = char_expl_size_c (a(2:4), a2(2:4), a3(2:4), size(a(::2)), num=2)
1200 if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
1201 if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
1202 if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
1203 if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
1204 if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
1205 if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
1207 a = a_init; a2 = a_init; a3 = a_init
1208 loc3 = char_expl_size_in_c (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning
1209 if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
1210 if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
1211 if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
1212 if (any (a /= a_init)) error stop 56
1213 if (any (a2 /= a_init)) error stop 58
1214 if (any (a3 /= a_init)) error stop 58
1216 a = a_init; a2 = a_init; a3 = a_init
1217 loc3 = char_expl_size_in_c (a(2:4), a2(2:4), a3(2:4), size(a(::2)), num=2)
1218 if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
1219 if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
1220 if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
1221 if (any (a /= a_init)) error stop 58
1222 if (any (a2 /= a_init)) error stop 58
1223 if (any (a3 /= a_init)) error stop 58
1225 ! -- C: assumed rank
1226 a = a_init; a2 = a_init; a3 = a_init
1227 loc3 = char_assumed_rank_c (a(::2), a2(::2), a3(::2), len(a), num=1)
1228 if (loc3%x /= %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
1229 if (loc3%y /= %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
1230 if (loc3%z /= %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
1231 if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
1232 if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
1233 if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
1235 a = a_init; a2 = a_init; a3 = a_init
1236 loc3 = char_assumed_rank_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
1237 if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
1238 if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" }
1239 if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" }
1240 if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
1241 if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
1242 if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
1244 a = a_init; a2 = a_init; a3 = a_init
1245 loc3 = char_assumed_rank_in_c (a(::2), a2(::2), a3(::2), len(a), num=1)
1246 if (loc3%x /= %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
1247 if (loc3%y /= %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" }
1248 if (loc3%z /= %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" }
1249 if (any (a /= a_init)) error stop 56
1250 if (any (a2 /= a_init)) error stop 56
1251 if (any (a3 /= a_init)) error stop 56
1253 a = a_init; a2 = a_init; a3 = a_init
1254 loc3 = char_assumed_rank_in_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
1255 if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
1256 if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" }
1257 if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" }
1258 if (any (a /= a_init)) error stop 58
1259 if (any (a2 /= a_init)) error stop 58
1260 if (any (a3 /= a_init)) error stop 58
1262 ! -- C: assumed rank contiguous
1263 a = a_init; a2 = a_init; a3 = a_init
1264 loc3 = char_assumed_rank_cont_c (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning
1265 if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
1266 if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
1267 if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
1268 if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
1269 if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
1270 if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
1272 a = a_init; a2 = a_init; a3 = a_init
1273 loc3 = char_assumed_rank_cont_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
1274 if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
1275 if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" }
1276 if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" }
1277 if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
1278 if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
1279 if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
1281 a = a_init; a2 = a_init; a3 = a_init
1282 loc3 = char_assumed_rank_cont_in_c (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning
1283 if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
1284 if (loc3%y == %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" }
1285 if (loc3%z == %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" }
1286 if (any (a /= a_init)) error stop 56
1287 if (any (a2 /= a_init)) error stop 56
1288 if (any (a3 /= a_init)) error stop 56
1290 a = a_init; a2 = a_init; a3 = a_init
1291 loc3 = char_assumed_rank_cont_in_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
1292 if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
1293 if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" }
1294 if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" }
1295 if (any (a /= a_init)) error stop 58
1296 if (any (a2 /= a_init)) error stop 58
1297 if (any (a3 /= a_init)) error stop 58
1299 ! -- C: assumed shape
1300 a = a_init; a2 = a_init; a3 = a_init
1301 loc3 = char_assumed_shape_c (a(::2), a2(::2), a3(::2), len(a), num=1)
1302 if (loc3%x /= %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
1303 if (loc3%y /= %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
1304 if (loc3%z /= %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
1305 if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
1306 if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
1307 if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
1309 a = a_init; a2 = a_init; a3 = a_init
1310 loc3 = char_assumed_shape_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
1311 if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
1312 if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" }
1313 if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" }
1314 if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
1315 if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
1316 if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
1318 a = a_init; a2 = a_init; a3 = a_init
1319 loc3 = char_assumed_shape_in_c (a(::2), a2(::2), a3(::2), len(a), num=1)
1320 if (loc3%x /= %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
1321 if (loc3%y /= %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" }
1322 if (loc3%z /= %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" }
1323 if (any (a /= a_init)) error stop 56
1324 if (any (a2 /= a_init)) error stop 56
1325 if (any (a3 /= a_init)) error stop 56
1327 a = a_init; a2 = a_init; a3 = a_init
1328 loc3 = char_assumed_shape_in_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
1329 if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
1330 if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" }
1331 if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" }
1332 if (any (a /= a_init)) error stop 58
1333 if (any (a2 /= a_init)) error stop 58
1334 if (any (a3 /= a_init)) error stop 58
1336 ! -- C: assumed shape contiguous
1337 a = a_init; a2 = a_init; a3 = a_init
1338 loc3 = char_assumed_shape_cont_c (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning
1339 if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
1340 if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
1341 if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
1342 if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
1343 if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
1344 if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
1346 a = a_init; a2 = a_init; a3 = a_init
1347 loc3 = char_assumed_shape_cont_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
1348 if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
1349 if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" }
1350 if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" }
1351 if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
1352 if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
1353 if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
1355 a = a_init; a2 = a_init; a3 = a_init
1356 loc3 = char_assumed_shape_cont_in_c (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning
1357 if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
1358 if (loc3%y == %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" }
1359 if (loc3%z == %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" }
1360 if (any (a /= a_init)) error stop 56
1361 if (any (a2 /= a_init)) error stop 56
1362 if (any (a3 /= a_init)) error stop 56
1364 a = a_init; a2 = a_init; a3 = a_init
1365 loc3 = char_assumed_shape_cont_in_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
1366 if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
1367 if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" }
1368 if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" }
1369 if (any (a /= a_init)) error stop 58
1370 if (any (a2 /= a_init)) error stop 58
1371 if (any (a3 /= a_init)) error stop 58
1375 ! { dg-output "At line 928 of file .*bind-c-contiguous-1.f90(\r*\n+)" }"
1376 ! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_size_f'(\r*\n+)" }"
1377 ! { dg-output "At line 928 of file .*bind-c-contiguous-1.f90(\r*\n+)" }"
1378 ! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_size_f'(\r*\n+)" }"
1379 ! { dg-output "At line 928 of file .*bind-c-contiguous-1.f90(\r*\n+)" }"
1380 ! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_size_f'(\r*\n+)" }"
1381 ! { dg-output " abcghinop(\r*\n+)" }"
1382 ! { dg-output " defghijlm(\r*\n+)" }"
1383 ! { dg-output "At line 946 of file .*bind-c-contiguous-1.f90(\r*\n+)" }"
1384 ! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_size_in_f'(\r*\n+)" }"
1385 ! { dg-output "At line 946 of file .*bind-c-contiguous-1.f90(\r*\n+)" }"
1386 ! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_size_in_f'(\r*\n+)" }"
1387 ! { dg-output "At line 946 of file .*bind-c-contiguous-1.f90(\r*\n+)" }"
1388 ! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_size_in_f'(\r*\n+)" }"
1389 ! { dg-output " abcghinop(\r*\n+)" }"
1390 ! { dg-output " defghijlm(\r*\n+)" }"
1391 ! { dg-output "At line 965 of file .*bind-c-contiguous-1.f90(\r*\n+)" }"
1392 ! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_expl_size_f'(\r*\n+)" }"
1393 ! { dg-output "At line 965 of file .*bind-c-contiguous-1.f90(\r*\n+)" }"
1394 ! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_expl_size_f'(\r*\n+)" }"
1395 ! { dg-output "At line 965 of file .*bind-c-contiguous-1.f90(\r*\n+)" }"
1396 ! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_expl_size_f'(\r*\n+)" }"
1397 ! { dg-output " abcghinop(\r*\n+)" }"
1398 ! { dg-output " defghijlm(\r*\n+)" }"
1399 ! { dg-output "At line 983 of file .*bind-c-contiguous-1.f90(\r*\n+)" }"
1400 ! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_expl_size_in_f'(\r*\n+)" }"
1401 ! { dg-output "At line 983 of file .*bind-c-contiguous-1.f90(\r*\n+)" }"
1402 ! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_expl_size_in_f'(\r*\n+)" }"
1403 ! { dg-output "At line 983 of file .*bind-c-contiguous-1.f90(\r*\n+)" }"
1404 ! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_expl_size_in_f'(\r*\n+)" }"
1405 ! { dg-output " abcghinop(\r*\n+)" }"
1406 ! { dg-output " defghijlm(\r*\n+)" }"
1407 ! { dg-output " abcghinop(\r*\n+)" }"
1408 ! { dg-output " abcghinop(\r*\n+)" }"
1409 ! { dg-output " abcghinop(\r*\n+)" }"
1410 ! { dg-output " defghijlm(\r*\n+)" }"
1411 ! { dg-output " defghijlm(\r*\n+)" }"
1412 ! { dg-output " defghijlm(\r*\n+)" }"
1413 ! { dg-output " abcghinop(\r*\n+)" }"
1414 ! { dg-output " abcghinop(\r*\n+)" }"
1415 ! { dg-output " abcghinop(\r*\n+)" }"
1416 ! { dg-output " defghijlm(\r*\n+)" }"
1417 ! { dg-output " defghijlm(\r*\n+)" }"
1418 ! { dg-output " defghijlm(\r*\n+)" }"
1419 ! { dg-output "At line 1039 of file .*bind-c-contiguous-1.f90(\r*\n+)" }"
1420 ! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_rank_cont_f'(\r*\n+)" }"
1421 ! { dg-output "At line 1039 of file .*bind-c-contiguous-1.f90(\r*\n+)" }"
1422 ! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_rank_cont_f'(\r*\n+)" }"
1423 ! { dg-output "At line 1039 of file .*bind-c-contiguous-1.f90(\r*\n+)" }"
1424 ! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_rank_cont_f'(\r*\n+)" }"
1425 ! { dg-output " abcghinop(\r*\n+)" }"
1426 ! { dg-output " abcghinop(\r*\n+)" }"
1427 ! { dg-output " abcghinop(\r*\n+)" }"
1428 ! { dg-output " defghijlm(\r*\n+)" }"
1429 ! { dg-output " defghijlm(\r*\n+)" }"
1430 ! { dg-output " defghijlm(\r*\n+)" }"
1431 ! { dg-output "At line 1057 of file .*bind-c-contiguous-1.f90(\r*\n+)" }"
1432 ! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_rank_cont_in_f'(\r*\n+)" }"
1433 ! { dg-output "At line 1057 of file .*bind-c-contiguous-1.f90(\r*\n+)" }"
1434 ! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_rank_cont_in_f'(\r*\n+)" }"
1435 ! { dg-output "At line 1057 of file .*bind-c-contiguous-1.f90(\r*\n+)" }"
1436 ! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_rank_cont_in_f'(\r*\n+)" }"
1437 ! { dg-output " abcghinop(\r*\n+)" }"
1438 ! { dg-output " abcghinop(\r*\n+)" }"
1439 ! { dg-output " abcghinop(\r*\n+)" }"
1440 ! { dg-output " defghijlm(\r*\n+)" }"
1441 ! { dg-output " defghijlm(\r*\n+)" }"
1442 ! { dg-output " defghijlm(\r*\n+)" }"
1443 ! { dg-output " abcghinop(\r*\n+)" }"
1444 ! { dg-output " defghijlm(\r*\n+)" }"
1445 ! { dg-output " abcghinop(\r*\n+)" }"
1446 ! { dg-output " defghijlm(\r*\n+)" }"
1447 ! { dg-output "At line 1113 of file .*bind-c-contiguous-1.f90(\r*\n+)" }"
1448 ! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_shape_cont_f'(\r*\n+)" }"
1449 ! { dg-output "At line 1113 of file .*bind-c-contiguous-1.f90(\r*\n+)" }"
1450 ! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_shape_cont_f'(\r*\n+)" }"
1451 ! { dg-output "At line 1113 of file .*bind-c-contiguous-1.f90(\r*\n+)" }"
1452 ! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_shape_cont_f'(\r*\n+)" }"
1453 ! { dg-output " abcghinop(\r*\n+)" }"
1454 ! { dg-output " defghijlm(\r*\n+)" }"
1455 ! { dg-output "At line 1131 of file .*bind-c-contiguous-1.f90(\r*\n+)" }"
1456 ! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_shape_cont_in_f'(\r*\n+)" }"
1457 ! { dg-output "At line 1131 of file .*bind-c-contiguous-1.f90(\r*\n+)" }"
1458 ! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_shape_cont_in_f'(\r*\n+)" }"
1459 ! { dg-output "At line 1131 of file .*bind-c-contiguous-1.f90(\r*\n+)" }"
1460 ! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_shape_cont_in_f'(\r*\n+)" }"
1461 ! { dg-output " abcghinop(\r*\n+)" }"
1462 ! { dg-output " defghijlm(\r*\n+)" }"
1463 ! { dg-output "At line 1153 of file .*bind-c-contiguous-1.f90(\r*\n+)" }"
1464 ! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_size_c'(\r*\n+)" }"
1465 ! { dg-output "At line 1153 of file .*bind-c-contiguous-1.f90(\r*\n+)" }"
1466 ! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_size_c'(\r*\n+)" }"
1467 ! { dg-output "At line 1153 of file .*bind-c-contiguous-1.f90(\r*\n+)" }"
1468 ! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_size_c'(\r*\n+)" }"
1469 ! { dg-output " abcghinop(\r*\n+)" }"
1470 ! { dg-output " defghijlm(\r*\n+)" }"
1471 ! { dg-output "At line 1171 of file .*bind-c-contiguous-1.f90(\r*\n+)" }"
1472 ! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_size_in_c'(\r*\n+)" }"
1473 ! { dg-output "At line 1171 of file .*bind-c-contiguous-1.f90(\r*\n+)" }"
1474 ! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_size_in_c'(\r*\n+)" }"
1475 ! { dg-output "At line 1171 of file .*bind-c-contiguous-1.f90(\r*\n+)" }"
1476 ! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_size_in_c'(\r*\n+)" }"
1477 ! { dg-output " abcghinop(\r*\n+)" }"
1478 ! { dg-output " defghijlm(\r*\n+)" }"
1479 ! { dg-output "At line 1190 of file .*bind-c-contiguous-1.f90(\r*\n+)" }"
1480 ! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_expl_size_c'(\r*\n+)" }"
1481 ! { dg-output "At line 1190 of file .*bind-c-contiguous-1.f90(\r*\n+)" }"
1482 ! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_expl_size_c'(\r*\n+)" }"
1483 ! { dg-output "At line 1190 of file .*bind-c-contiguous-1.f90(\r*\n+)" }"
1484 ! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_expl_size_c'(\r*\n+)" }"
1485 ! { dg-output " abcghinop(\r*\n+)" }"
1486 ! { dg-output " defghijlm(\r*\n+)" }"
1487 ! { dg-output "At line 1208 of file .*bind-c-contiguous-1.f90(\r*\n+)" }"
1488 ! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_expl_size_in_c'(\r*\n+)" }"
1489 ! { dg-output "At line 1208 of file .*bind-c-contiguous-1.f90(\r*\n+)" }"
1490 ! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_expl_size_in_c'(\r*\n+)" }"
1491 ! { dg-output "At line 1208 of file .*bind-c-contiguous-1.f90(\r*\n+)" }"
1492 ! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_expl_size_in_c'(\r*\n+)" }"
1493 ! { dg-output " abcghinop(\r*\n+)" }"
1494 ! { dg-output " defghijlm(\r*\n+)" }"
1495 ! { dg-output " abcghinop(\r*\n+)" }"
1496 ! { dg-output " abcghinop(\r*\n+)" }"
1497 ! { dg-output " abcghinop(\r*\n+)" }"
1498 ! { dg-output " defghijlm(\r*\n+)" }"
1499 ! { dg-output " defghijlm(\r*\n+)" }"
1500 ! { dg-output " defghijlm(\r*\n+)" }"
1501 ! { dg-output " abcghinop(\r*\n+)" }"
1502 ! { dg-output " abcghinop(\r*\n+)" }"
1503 ! { dg-output " abcghinop(\r*\n+)" }"
1504 ! { dg-output " defghijlm(\r*\n+)" }"
1505 ! { dg-output " defghijlm(\r*\n+)" }"
1506 ! { dg-output " defghijlm(\r*\n+)" }"
1507 ! { dg-output "At line 1264 of file .*bind-c-contiguous-1.f90(\r*\n+)" }"
1508 ! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_rank_cont_c'(\r*\n+)" }"
1509 ! { dg-output "At line 1264 of file .*bind-c-contiguous-1.f90(\r*\n+)" }"
1510 ! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_rank_cont_c'(\r*\n+)" }"
1511 ! { dg-output "At line 1264 of file .*bind-c-contiguous-1.f90(\r*\n+)" }"
1512 ! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_rank_cont_c'(\r*\n+)" }"
1513 ! { dg-output " abcghinop(\r*\n+)" }"
1514 ! { dg-output " abcghinop(\r*\n+)" }"
1515 ! { dg-output " abcghinop(\r*\n+)" }"
1516 ! { dg-output " defghijlm(\r*\n+)" }"
1517 ! { dg-output " defghijlm(\r*\n+)" }"
1518 ! { dg-output " defghijlm(\r*\n+)" }"
1519 ! { dg-output "At line 1282 of file .*bind-c-contiguous-1.f90(\r*\n+)" }"
1520 ! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_rank_cont_in_c'(\r*\n+)" }"
1521 ! { dg-output "At line 1282 of file .*bind-c-contiguous-1.f90(\r*\n+)" }"
1522 ! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_rank_cont_in_c'(\r*\n+)" }"
1523 ! { dg-output "At line 1282 of file .*bind-c-contiguous-1.f90(\r*\n+)" }"
1524 ! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_rank_cont_in_c'(\r*\n+)" }"
1525 ! { dg-output " abcghinop(\r*\n+)" }"
1526 ! { dg-output " abcghinop(\r*\n+)" }"
1527 ! { dg-output " abcghinop(\r*\n+)" }"
1528 ! { dg-output " defghijlm(\r*\n+)" }"
1529 ! { dg-output " defghijlm(\r*\n+)" }"
1530 ! { dg-output " defghijlm(\r*\n+)" }"
1531 ! { dg-output " abcghinop(\r*\n+)" }"
1532 ! { dg-output " abcghinop(\r*\n+)" }"
1533 ! { dg-output " abcghinop(\r*\n+)" }"
1534 ! { dg-output " abcghinop(\r*\n+)" }"
1535 ! { dg-output " abcghinop(\r*\n+)" }"
1536 ! { dg-output " abcghinop(\r*\n+)" }"
1537 ! { dg-output " abcghinop(\r*\n+)" }"
1538 ! { dg-output " abcghinop(\r*\n+)" }"
1539 ! { dg-output " abcghinop(\r*\n+)" }"
1540 ! { dg-output " abcghinop(\r*\n+)" }"
1541 ! { dg-output " abcghinop(\r*\n+)" }"
1542 ! { dg-output " abcghinop(\r*\n+)" }"
1543 ! { dg-output " abcghinop(\r*\n+)" }"
1544 ! { dg-output " defghijlm(\r*\n+)" }"
1545 ! { dg-output " defghijlm(\r*\n+)" }"
1546 ! { dg-output " defghijlm(\r*\n+)" }"
1547 ! { dg-output " defghijlm(\r*\n+)" }"
1548 ! { dg-output " defghijlm(\r*\n+)" }"
1549 ! { dg-output " defghijlm(\r*\n+)" }"
1550 ! { dg-output " defghijlm(\r*\n+)" }"
1551 ! { dg-output " defghijlm(\r*\n+)" }"
1552 ! { dg-output " defghijlm(\r*\n+)" }"
1553 ! { dg-output " defghijlm(\r*\n+)" }"
1554 ! { dg-output " defghijlm(\r*\n+)" }"
1555 ! { dg-output " defghijlm(\r*\n+)" }"
1556 ! { dg-output " defghijlm(\r*\n+)" }"
1557 ! { dg-output " abcghinop(\r*\n+)" }"
1558 ! { dg-output " defghijlm(\r*\n+)" }"
1559 ! { dg-output "At line 1338 of file .*bind-c-contiguous-1.f90(\r*\n+)" }"
1560 ! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_shape_cont_c'(\r*\n+)" }"
1561 ! { dg-output "At line 1338 of file .*bind-c-contiguous-1.f90(\r*\n+)" }"
1562 ! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_shape_cont_c'(\r*\n+)" }"
1563 ! { dg-output "At line 1338 of file .*bind-c-contiguous-1.f90(\r*\n+)" }"
1564 ! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_shape_cont_c'(\r*\n+)" }"
1565 ! { dg-output " abcghinop(\r*\n+)" }"
1566 ! { dg-output " defghijlm(\r*\n+)" }"
1567 ! { dg-output "At line 1356 of file .*bind-c-contiguous-1.f90(\r*\n+)" }"
1568 ! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_shape_cont_in_c'(\r*\n+)" }"
1569 ! { dg-output "At line 1356 of file .*bind-c-contiguous-1.f90(\r*\n+)" }"
1570 ! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_shape_cont_in_c'(\r*\n+)" }"
1571 ! { dg-output "At line 1356 of file .*bind-c-contiguous-1.f90(\r*\n+)" }"
1572 ! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_shape_cont_in_c'(\r*\n+)" }"
1573 ! { dg-output " abcghinop(\r*\n+)" }"
1574 ! { dg-output " defghijlm(\r*\n+)" }"