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
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)
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
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:*)
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:*)
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)
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)
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(..)
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(..)
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(..)
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(..)
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
:)
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
:)
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
:)
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
:)
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:*)
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
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
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
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
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
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)
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
556 res
%x
= %loc(xx
) ! { dg-warning "Legacy Extension" }
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
577 res
%y
= %loc(yy
) ! { dg-warning "Legacy Extension" }
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
598 res
%z
= %loc(zz
) ! { dg-warning "Legacy Extension" }
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
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
640 res
%x
= %loc(xx
) ! { dg-warning "Legacy Extension" }
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
658 res
%y
= %loc(yy
) ! { dg-warning "Legacy Extension" }
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
676 res
%z
= %loc(zz
) ! { dg-warning "Legacy Extension" }
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
:)
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
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
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
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
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
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
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
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
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
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
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
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" }
920 implicit none (type, external)
921 character(len
=3) :: a(6), a2(6), a3(6), a_init(6)
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+)" }"