Line data Source code
1 : /* Array translation routines
2 : Copyright (C) 2002-2026 Free Software Foundation, Inc.
3 : Contributed by Paul Brook <paul@nowt.org>
4 : and Steven Bosscher <s.bosscher@student.tudelft.nl>
5 :
6 : This file is part of GCC.
7 :
8 : GCC is free software; you can redistribute it and/or modify it under
9 : the terms of the GNU General Public License as published by the Free
10 : Software Foundation; either version 3, or (at your option) any later
11 : version.
12 :
13 : GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 : WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 : FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
16 : for more details.
17 :
18 : You should have received a copy of the GNU General Public License
19 : along with GCC; see the file COPYING3. If not see
20 : <http://www.gnu.org/licenses/>. */
21 :
22 : /* trans-array.cc-- Various array related code, including scalarization,
23 : allocation, initialization and other support routines. */
24 :
25 : /* How the scalarizer works.
26 : In gfortran, array expressions use the same core routines as scalar
27 : expressions.
28 : First, a Scalarization State (SS) chain is built. This is done by walking
29 : the expression tree, and building a linear list of the terms in the
30 : expression. As the tree is walked, scalar subexpressions are translated.
31 :
32 : The scalarization parameters are stored in a gfc_loopinfo structure.
33 : First the start and stride of each term is calculated by
34 : gfc_conv_ss_startstride. During this process the expressions for the array
35 : descriptors and data pointers are also translated.
36 :
37 : If the expression is an assignment, we must then resolve any dependencies.
38 : In Fortran all the rhs values of an assignment must be evaluated before
39 : any assignments take place. This can require a temporary array to store the
40 : values. We also require a temporary when we are passing array expressions
41 : or vector subscripts as procedure parameters.
42 :
43 : Array sections are passed without copying to a temporary. These use the
44 : scalarizer to determine the shape of the section. The flag
45 : loop->array_parameter tells the scalarizer that the actual values and loop
46 : variables will not be required.
47 :
48 : The function gfc_conv_loop_setup generates the scalarization setup code.
49 : It determines the range of the scalarizing loop variables. If a temporary
50 : is required, this is created and initialized. Code for scalar expressions
51 : taken outside the loop is also generated at this time. Next the offset and
52 : scaling required to translate from loop variables to array indices for each
53 : term is calculated.
54 :
55 : A call to gfc_start_scalarized_body marks the start of the scalarized
56 : expression. This creates a scope and declares the loop variables. Before
57 : calling this gfc_make_ss_chain_used must be used to indicate which terms
58 : will be used inside this loop.
59 :
60 : The scalar gfc_conv_* functions are then used to build the main body of the
61 : scalarization loop. Scalarization loop variables and precalculated scalar
62 : values are automatically substituted. Note that gfc_advance_se_ss_chain
63 : must be used, rather than changing the se->ss directly.
64 :
65 : For assignment expressions requiring a temporary two sub loops are
66 : generated. The first stores the result of the expression in the temporary,
67 : the second copies it to the result. A call to
68 : gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
69 : the start of the copying loop. The temporary may be less than full rank.
70 :
71 : Finally gfc_trans_scalarizing_loops is called to generate the implicit do
72 : loops. The loops are added to the pre chain of the loopinfo. The post
73 : chain may still contain cleanup code.
74 :
75 : After the loop code has been added into its parent scope gfc_cleanup_loop
76 : is called to free all the SS allocated by the scalarizer. */
77 :
78 : #include "config.h"
79 : #include "system.h"
80 : #include "coretypes.h"
81 : #include "options.h"
82 : #include "tree.h"
83 : #include "gfortran.h"
84 : #include "gimple-expr.h"
85 : #include "tree-iterator.h"
86 : #include "stringpool.h" /* Required by "attribs.h". */
87 : #include "attribs.h" /* For lookup_attribute. */
88 : #include "trans.h"
89 : #include "fold-const.h"
90 : #include "constructor.h"
91 : #include "trans-types.h"
92 : #include "trans-array.h"
93 : #include "trans-const.h"
94 : #include "dependency.h"
95 : #include "cgraph.h" /* For cgraph_node::add_new_function. */
96 : #include "function.h" /* For push_struct_function. */
97 :
98 : static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor_base);
99 :
100 : /* The contents of this structure aren't actually used, just the address. */
101 : static gfc_ss gfc_ss_terminator_var;
102 : gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var;
103 :
104 :
105 : static tree
106 58481 : gfc_array_dataptr_type (tree desc)
107 : {
108 58481 : return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
109 : }
110 :
111 : /* Build expressions to access members of the CFI descriptor. */
112 : #define CFI_FIELD_BASE_ADDR 0
113 : #define CFI_FIELD_ELEM_LEN 1
114 : #define CFI_FIELD_VERSION 2
115 : #define CFI_FIELD_RANK 3
116 : #define CFI_FIELD_ATTRIBUTE 4
117 : #define CFI_FIELD_TYPE 5
118 : #define CFI_FIELD_DIM 6
119 :
120 : #define CFI_DIM_FIELD_LOWER_BOUND 0
121 : #define CFI_DIM_FIELD_EXTENT 1
122 : #define CFI_DIM_FIELD_SM 2
123 :
124 : static tree
125 84943 : gfc_get_cfi_descriptor_field (tree desc, unsigned field_idx)
126 : {
127 84943 : tree type = TREE_TYPE (desc);
128 84943 : gcc_assert (TREE_CODE (type) == RECORD_TYPE
129 : && TYPE_FIELDS (type)
130 : && (strcmp ("base_addr",
131 : IDENTIFIER_POINTER (DECL_NAME (TYPE_FIELDS (type))))
132 : == 0));
133 84943 : tree field = gfc_advance_chain (TYPE_FIELDS (type), field_idx);
134 84943 : gcc_assert (field != NULL_TREE);
135 :
136 84943 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
137 84943 : desc, field, NULL_TREE);
138 : }
139 :
140 : tree
141 14201 : gfc_get_cfi_desc_base_addr (tree desc)
142 : {
143 14201 : return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_BASE_ADDR);
144 : }
145 :
146 : tree
147 10681 : gfc_get_cfi_desc_elem_len (tree desc)
148 : {
149 10681 : return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_ELEM_LEN);
150 : }
151 :
152 : tree
153 7191 : gfc_get_cfi_desc_version (tree desc)
154 : {
155 7191 : return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_VERSION);
156 : }
157 :
158 : tree
159 7816 : gfc_get_cfi_desc_rank (tree desc)
160 : {
161 7816 : return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_RANK);
162 : }
163 :
164 : tree
165 7283 : gfc_get_cfi_desc_type (tree desc)
166 : {
167 7283 : return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_TYPE);
168 : }
169 :
170 : tree
171 7191 : gfc_get_cfi_desc_attribute (tree desc)
172 : {
173 7191 : return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_ATTRIBUTE);
174 : }
175 :
176 : static tree
177 30580 : gfc_get_cfi_dim_item (tree desc, tree idx, unsigned field_idx)
178 : {
179 30580 : tree tmp = gfc_get_cfi_descriptor_field (desc, CFI_FIELD_DIM);
180 30580 : tmp = gfc_build_array_ref (tmp, idx, NULL_TREE, true);
181 30580 : tree field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), field_idx);
182 30580 : gcc_assert (field != NULL_TREE);
183 30580 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
184 30580 : tmp, field, NULL_TREE);
185 : }
186 :
187 : tree
188 6786 : gfc_get_cfi_dim_lbound (tree desc, tree idx)
189 : {
190 6786 : return gfc_get_cfi_dim_item (desc, idx, CFI_DIM_FIELD_LOWER_BOUND);
191 : }
192 :
193 : tree
194 11926 : gfc_get_cfi_dim_extent (tree desc, tree idx)
195 : {
196 11926 : return gfc_get_cfi_dim_item (desc, idx, CFI_DIM_FIELD_EXTENT);
197 : }
198 :
199 : tree
200 11868 : gfc_get_cfi_dim_sm (tree desc, tree idx)
201 : {
202 11868 : return gfc_get_cfi_dim_item (desc, idx, CFI_DIM_FIELD_SM);
203 : }
204 :
205 : #undef CFI_FIELD_BASE_ADDR
206 : #undef CFI_FIELD_ELEM_LEN
207 : #undef CFI_FIELD_VERSION
208 : #undef CFI_FIELD_RANK
209 : #undef CFI_FIELD_ATTRIBUTE
210 : #undef CFI_FIELD_TYPE
211 : #undef CFI_FIELD_DIM
212 :
213 : #undef CFI_DIM_FIELD_LOWER_BOUND
214 : #undef CFI_DIM_FIELD_EXTENT
215 : #undef CFI_DIM_FIELD_SM
216 :
217 : /* Build expressions to access the members of an array descriptor.
218 : It's surprisingly easy to mess up here, so never access
219 : an array descriptor by "brute force", always use these
220 : functions. This also avoids problems if we change the format
221 : of an array descriptor.
222 :
223 : To understand these magic numbers, look at the comments
224 : before gfc_build_array_type() in trans-types.cc.
225 :
226 : The code within these defines should be the only code which knows the format
227 : of an array descriptor.
228 :
229 : Any code just needing to read obtain the bounds of an array should use
230 : gfc_conv_array_* rather than the following functions as these will return
231 : know constant values, and work with arrays which do not have descriptors.
232 :
233 : Don't forget to #undef these! */
234 :
235 : #define DATA_FIELD 0
236 : #define OFFSET_FIELD 1
237 : #define DTYPE_FIELD 2
238 : #define SPAN_FIELD 3
239 : #define DIMENSION_FIELD 4
240 : #define CAF_TOKEN_FIELD 5
241 :
242 : #define STRIDE_SUBFIELD 0
243 : #define LBOUND_SUBFIELD 1
244 : #define UBOUND_SUBFIELD 2
245 :
246 : static tree
247 2004756 : gfc_get_descriptor_field (tree desc, unsigned field_idx)
248 : {
249 2004756 : tree type = TREE_TYPE (desc);
250 2004756 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
251 :
252 2004756 : tree field = gfc_advance_chain (TYPE_FIELDS (type), field_idx);
253 2004756 : gcc_assert (field != NULL_TREE);
254 :
255 2004756 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
256 2004756 : desc, field, NULL_TREE);
257 : }
258 :
259 : /* This provides READ-ONLY access to the data field. The field itself
260 : doesn't have the proper type. */
261 :
262 : tree
263 281586 : gfc_conv_descriptor_data_get (tree desc)
264 : {
265 281586 : tree type = TREE_TYPE (desc);
266 281586 : if (TREE_CODE (type) == REFERENCE_TYPE)
267 0 : gcc_unreachable ();
268 :
269 281586 : tree field = gfc_get_descriptor_field (desc, DATA_FIELD);
270 281586 : return fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), field);
271 : }
272 :
273 : /* This provides WRITE access to the data field. */
274 :
275 : void
276 156471 : gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
277 : {
278 156471 : tree field = gfc_get_descriptor_field (desc, DATA_FIELD);
279 156471 : gfc_add_modify (block, field, fold_convert (TREE_TYPE (field), value));
280 156471 : }
281 :
282 :
283 : static tree
284 206328 : gfc_conv_descriptor_offset (tree desc)
285 : {
286 206328 : tree field = gfc_get_descriptor_field (desc, OFFSET_FIELD);
287 206328 : gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
288 206328 : return field;
289 : }
290 :
291 : tree
292 76940 : gfc_conv_descriptor_offset_get (tree desc)
293 : {
294 76940 : return gfc_conv_descriptor_offset (desc);
295 : }
296 :
297 : void
298 122944 : gfc_conv_descriptor_offset_set (stmtblock_t *block, tree desc,
299 : tree value)
300 : {
301 122944 : tree t = gfc_conv_descriptor_offset (desc);
302 122944 : gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
303 122944 : }
304 :
305 :
306 : tree
307 172525 : gfc_conv_descriptor_dtype (tree desc)
308 : {
309 172525 : tree field = gfc_get_descriptor_field (desc, DTYPE_FIELD);
310 172525 : gcc_assert (TREE_TYPE (field) == get_dtype_type_node ());
311 172525 : return field;
312 : }
313 :
314 : static tree
315 152853 : gfc_conv_descriptor_span (tree desc)
316 : {
317 152853 : tree field = gfc_get_descriptor_field (desc, SPAN_FIELD);
318 152853 : gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
319 152853 : return field;
320 : }
321 :
322 : tree
323 33750 : gfc_conv_descriptor_span_get (tree desc)
324 : {
325 33750 : return gfc_conv_descriptor_span (desc);
326 : }
327 :
328 : void
329 119103 : gfc_conv_descriptor_span_set (stmtblock_t *block, tree desc,
330 : tree value)
331 : {
332 119103 : tree t = gfc_conv_descriptor_span (desc);
333 119103 : gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
334 119103 : }
335 :
336 :
337 : tree
338 21099 : gfc_conv_descriptor_rank (tree desc)
339 : {
340 21099 : tree tmp;
341 21099 : tree dtype;
342 :
343 21099 : dtype = gfc_conv_descriptor_dtype (desc);
344 21099 : tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), GFC_DTYPE_RANK);
345 21099 : gcc_assert (tmp != NULL_TREE
346 : && TREE_TYPE (tmp) == signed_char_type_node);
347 21099 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
348 21099 : dtype, tmp, NULL_TREE);
349 : }
350 :
351 :
352 : tree
353 127 : gfc_conv_descriptor_version (tree desc)
354 : {
355 127 : tree tmp;
356 127 : tree dtype;
357 :
358 127 : dtype = gfc_conv_descriptor_dtype (desc);
359 127 : tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), GFC_DTYPE_VERSION);
360 127 : gcc_assert (tmp != NULL_TREE
361 : && TREE_TYPE (tmp) == integer_type_node);
362 127 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
363 127 : dtype, tmp, NULL_TREE);
364 : }
365 :
366 :
367 : /* Return the element length from the descriptor dtype field. */
368 :
369 : tree
370 9234 : gfc_conv_descriptor_elem_len (tree desc)
371 : {
372 9234 : tree tmp;
373 9234 : tree dtype;
374 :
375 9234 : dtype = gfc_conv_descriptor_dtype (desc);
376 9234 : tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)),
377 : GFC_DTYPE_ELEM_LEN);
378 9234 : gcc_assert (tmp != NULL_TREE
379 : && TREE_TYPE (tmp) == size_type_node);
380 9234 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
381 9234 : dtype, tmp, NULL_TREE);
382 : }
383 :
384 :
385 : tree
386 0 : gfc_conv_descriptor_attribute (tree desc)
387 : {
388 0 : tree tmp;
389 0 : tree dtype;
390 :
391 0 : dtype = gfc_conv_descriptor_dtype (desc);
392 0 : tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)),
393 : GFC_DTYPE_ATTRIBUTE);
394 0 : gcc_assert (tmp!= NULL_TREE
395 : && TREE_TYPE (tmp) == short_integer_type_node);
396 0 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
397 0 : dtype, tmp, NULL_TREE);
398 : }
399 :
400 : tree
401 73 : gfc_conv_descriptor_type (tree desc)
402 : {
403 73 : tree tmp;
404 73 : tree dtype;
405 :
406 73 : dtype = gfc_conv_descriptor_dtype (desc);
407 73 : tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), GFC_DTYPE_TYPE);
408 73 : gcc_assert (tmp!= NULL_TREE
409 : && TREE_TYPE (tmp) == signed_char_type_node);
410 73 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
411 73 : dtype, tmp, NULL_TREE);
412 : }
413 :
414 : tree
415 1032741 : gfc_get_descriptor_dimension (tree desc)
416 : {
417 1032741 : tree field = gfc_get_descriptor_field (desc, DIMENSION_FIELD);
418 1032741 : gcc_assert (TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
419 : && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
420 1032741 : return field;
421 : }
422 :
423 :
424 : static tree
425 1028763 : gfc_conv_descriptor_dimension (tree desc, tree dim)
426 : {
427 1028763 : tree tmp;
428 :
429 1028763 : tmp = gfc_get_descriptor_dimension (desc);
430 :
431 1028763 : return gfc_build_array_ref (tmp, dim, NULL_TREE, true);
432 : }
433 :
434 :
435 : tree
436 2252 : gfc_conv_descriptor_token (tree desc)
437 : {
438 2252 : gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
439 2252 : tree field = gfc_get_descriptor_field (desc, CAF_TOKEN_FIELD);
440 : /* Should be a restricted pointer - except in the finalization wrapper. */
441 2252 : gcc_assert (TREE_TYPE (field) == prvoid_type_node
442 : || TREE_TYPE (field) == pvoid_type_node);
443 2252 : return field;
444 : }
445 :
446 : static tree
447 1028763 : gfc_conv_descriptor_subfield (tree desc, tree dim, unsigned field_idx)
448 : {
449 1028763 : tree tmp = gfc_conv_descriptor_dimension (desc, dim);
450 1028763 : tree field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), field_idx);
451 1028763 : gcc_assert (field != NULL_TREE);
452 :
453 1028763 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
454 1028763 : tmp, field, NULL_TREE);
455 : }
456 :
457 : static tree
458 274823 : gfc_conv_descriptor_stride (tree desc, tree dim)
459 : {
460 274823 : tree field = gfc_conv_descriptor_subfield (desc, dim, STRIDE_SUBFIELD);
461 274823 : gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
462 274823 : return field;
463 : }
464 :
465 : tree
466 169063 : gfc_conv_descriptor_stride_get (tree desc, tree dim)
467 : {
468 169063 : tree type = TREE_TYPE (desc);
469 169063 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
470 169063 : if (integer_zerop (dim)
471 169063 : && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
472 43177 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT
473 42108 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT
474 41958 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_ALLOCATABLE
475 41808 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_POINTER_CONT
476 41808 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
477 71334 : return gfc_index_one_node;
478 :
479 97729 : return gfc_conv_descriptor_stride (desc, dim);
480 : }
481 :
482 : void
483 177094 : gfc_conv_descriptor_stride_set (stmtblock_t *block, tree desc,
484 : tree dim, tree value)
485 : {
486 177094 : tree t = gfc_conv_descriptor_stride (desc, dim);
487 177094 : gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
488 177094 : }
489 :
490 : static tree
491 391517 : gfc_conv_descriptor_lbound (tree desc, tree dim)
492 : {
493 391517 : tree field = gfc_conv_descriptor_subfield (desc, dim, LBOUND_SUBFIELD);
494 391517 : gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
495 391517 : return field;
496 : }
497 :
498 : tree
499 209686 : gfc_conv_descriptor_lbound_get (tree desc, tree dim)
500 : {
501 209686 : return gfc_conv_descriptor_lbound (desc, dim);
502 : }
503 :
504 : void
505 181831 : gfc_conv_descriptor_lbound_set (stmtblock_t *block, tree desc,
506 : tree dim, tree value)
507 : {
508 181831 : tree t = gfc_conv_descriptor_lbound (desc, dim);
509 181831 : gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
510 181831 : }
511 :
512 : static tree
513 362423 : gfc_conv_descriptor_ubound (tree desc, tree dim)
514 : {
515 362423 : tree field = gfc_conv_descriptor_subfield (desc, dim, UBOUND_SUBFIELD);
516 362423 : gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
517 362423 : return field;
518 : }
519 :
520 : tree
521 180846 : gfc_conv_descriptor_ubound_get (tree desc, tree dim)
522 : {
523 180846 : return gfc_conv_descriptor_ubound (desc, dim);
524 : }
525 :
526 : void
527 181577 : gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree desc,
528 : tree dim, tree value)
529 : {
530 181577 : tree t = gfc_conv_descriptor_ubound (desc, dim);
531 181577 : gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
532 181577 : }
533 :
534 : /* Build a null array descriptor constructor. */
535 :
536 : tree
537 1085 : gfc_build_null_descriptor (tree type)
538 : {
539 1085 : tree field;
540 1085 : tree tmp;
541 :
542 1085 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
543 1085 : gcc_assert (DATA_FIELD == 0);
544 1085 : field = TYPE_FIELDS (type);
545 :
546 : /* Set a NULL data pointer. */
547 1085 : tmp = build_constructor_single (type, field, null_pointer_node);
548 1085 : TREE_CONSTANT (tmp) = 1;
549 : /* All other fields are ignored. */
550 :
551 1085 : return tmp;
552 : }
553 :
554 :
555 : /* Modify a descriptor such that the lbound of a given dimension is the value
556 : specified. This also updates ubound and offset accordingly. */
557 :
558 : void
559 948 : gfc_conv_shift_descriptor_lbound (stmtblock_t* block, tree desc,
560 : int dim, tree new_lbound)
561 : {
562 948 : tree offs, ubound, lbound, stride;
563 948 : tree diff, offs_diff;
564 :
565 948 : new_lbound = fold_convert (gfc_array_index_type, new_lbound);
566 :
567 948 : offs = gfc_conv_descriptor_offset_get (desc);
568 948 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
569 948 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
570 948 : stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]);
571 :
572 : /* Get difference (new - old) by which to shift stuff. */
573 948 : diff = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
574 : new_lbound, lbound);
575 :
576 : /* Shift ubound and offset accordingly. This has to be done before
577 : updating the lbound, as they depend on the lbound expression! */
578 948 : ubound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
579 : ubound, diff);
580 948 : gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[dim], ubound);
581 948 : offs_diff = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
582 : diff, stride);
583 948 : offs = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
584 : offs, offs_diff);
585 948 : gfc_conv_descriptor_offset_set (block, desc, offs);
586 :
587 : /* Finally set lbound to value we want. */
588 948 : gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[dim], new_lbound);
589 948 : }
590 :
591 :
592 : /* Obtain offsets for trans-types.cc(gfc_get_array_descr_info). */
593 :
594 : void
595 271119 : gfc_get_descriptor_offsets_for_info (const_tree desc_type, tree *data_off,
596 : tree *dtype_off, tree *span_off,
597 : tree *dim_off, tree *dim_size,
598 : tree *stride_suboff, tree *lower_suboff,
599 : tree *upper_suboff)
600 : {
601 271119 : tree field;
602 271119 : tree type;
603 :
604 271119 : type = TYPE_MAIN_VARIANT (desc_type);
605 271119 : field = gfc_advance_chain (TYPE_FIELDS (type), DATA_FIELD);
606 271119 : *data_off = byte_position (field);
607 271119 : field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
608 271119 : *dtype_off = byte_position (field);
609 271119 : field = gfc_advance_chain (TYPE_FIELDS (type), SPAN_FIELD);
610 271119 : *span_off = byte_position (field);
611 271119 : field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
612 271119 : *dim_off = byte_position (field);
613 271119 : type = TREE_TYPE (TREE_TYPE (field));
614 271119 : *dim_size = TYPE_SIZE_UNIT (type);
615 271119 : field = gfc_advance_chain (TYPE_FIELDS (type), STRIDE_SUBFIELD);
616 271119 : *stride_suboff = byte_position (field);
617 271119 : field = gfc_advance_chain (TYPE_FIELDS (type), LBOUND_SUBFIELD);
618 271119 : *lower_suboff = byte_position (field);
619 271119 : field = gfc_advance_chain (TYPE_FIELDS (type), UBOUND_SUBFIELD);
620 271119 : *upper_suboff = byte_position (field);
621 271119 : }
622 :
623 :
624 : /* Cleanup those #defines. */
625 :
626 : #undef DATA_FIELD
627 : #undef OFFSET_FIELD
628 : #undef DTYPE_FIELD
629 : #undef SPAN_FIELD
630 : #undef DIMENSION_FIELD
631 : #undef CAF_TOKEN_FIELD
632 : #undef STRIDE_SUBFIELD
633 : #undef LBOUND_SUBFIELD
634 : #undef UBOUND_SUBFIELD
635 :
636 :
637 : /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
638 : flags & 1 = Main loop body.
639 : flags & 2 = temp copy loop. */
640 :
641 : void
642 169742 : gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
643 : {
644 399169 : for (; ss != gfc_ss_terminator; ss = ss->next)
645 229427 : ss->info->useflags = flags;
646 169742 : }
647 :
648 :
649 : /* Free a gfc_ss chain. */
650 :
651 : void
652 179313 : gfc_free_ss_chain (gfc_ss * ss)
653 : {
654 179313 : gfc_ss *next;
655 :
656 366844 : while (ss != gfc_ss_terminator)
657 : {
658 187531 : gcc_assert (ss != NULL);
659 187531 : next = ss->next;
660 187531 : gfc_free_ss (ss);
661 187531 : ss = next;
662 : }
663 179313 : }
664 :
665 :
666 : static void
667 486373 : free_ss_info (gfc_ss_info *ss_info)
668 : {
669 486373 : int n;
670 :
671 486373 : ss_info->refcount--;
672 486373 : if (ss_info->refcount > 0)
673 : return;
674 :
675 481626 : gcc_assert (ss_info->refcount == 0);
676 :
677 481626 : switch (ss_info->type)
678 : {
679 : case GFC_SS_SECTION:
680 5344224 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
681 5010210 : if (ss_info->data.array.subscript[n])
682 7374 : gfc_free_ss_chain (ss_info->data.array.subscript[n]);
683 : break;
684 :
685 : default:
686 : break;
687 : }
688 :
689 481626 : free (ss_info);
690 : }
691 :
692 :
693 : /* Free a SS. */
694 :
695 : void
696 486373 : gfc_free_ss (gfc_ss * ss)
697 : {
698 486373 : free_ss_info (ss->info);
699 486373 : free (ss);
700 486373 : }
701 :
702 :
703 : /* Creates and initializes an array type gfc_ss struct. */
704 :
705 : gfc_ss *
706 406700 : gfc_get_array_ss (gfc_ss *next, gfc_expr *expr, int dimen, gfc_ss_type type)
707 : {
708 406700 : gfc_ss *ss;
709 406700 : gfc_ss_info *ss_info;
710 406700 : int i;
711 :
712 406700 : ss_info = gfc_get_ss_info ();
713 406700 : ss_info->refcount++;
714 406700 : ss_info->type = type;
715 406700 : ss_info->expr = expr;
716 :
717 406700 : ss = gfc_get_ss ();
718 406700 : ss->info = ss_info;
719 406700 : ss->next = next;
720 406700 : ss->dimen = dimen;
721 859584 : for (i = 0; i < ss->dimen; i++)
722 452884 : ss->dim[i] = i;
723 :
724 406700 : return ss;
725 : }
726 :
727 :
728 : /* Creates and initializes a temporary type gfc_ss struct. */
729 :
730 : gfc_ss *
731 11014 : gfc_get_temp_ss (tree type, tree string_length, int dimen)
732 : {
733 11014 : gfc_ss *ss;
734 11014 : gfc_ss_info *ss_info;
735 11014 : int i;
736 :
737 11014 : ss_info = gfc_get_ss_info ();
738 11014 : ss_info->refcount++;
739 11014 : ss_info->type = GFC_SS_TEMP;
740 11014 : ss_info->string_length = string_length;
741 11014 : ss_info->data.temp.type = type;
742 :
743 11014 : ss = gfc_get_ss ();
744 11014 : ss->info = ss_info;
745 11014 : ss->next = gfc_ss_terminator;
746 11014 : ss->dimen = dimen;
747 24728 : for (i = 0; i < ss->dimen; i++)
748 13714 : ss->dim[i] = i;
749 :
750 11014 : return ss;
751 : }
752 :
753 :
754 : /* Creates and initializes a scalar type gfc_ss struct. */
755 :
756 : gfc_ss *
757 65941 : gfc_get_scalar_ss (gfc_ss *next, gfc_expr *expr)
758 : {
759 65941 : gfc_ss *ss;
760 65941 : gfc_ss_info *ss_info;
761 :
762 65941 : ss_info = gfc_get_ss_info ();
763 65941 : ss_info->refcount++;
764 65941 : ss_info->type = GFC_SS_SCALAR;
765 65941 : ss_info->expr = expr;
766 :
767 65941 : ss = gfc_get_ss ();
768 65941 : ss->info = ss_info;
769 65941 : ss->next = next;
770 :
771 65941 : return ss;
772 : }
773 :
774 :
775 : /* Free all the SS associated with a loop. */
776 :
777 : void
778 180296 : gfc_cleanup_loop (gfc_loopinfo * loop)
779 : {
780 180296 : gfc_loopinfo *loop_next, **ploop;
781 180296 : gfc_ss *ss;
782 180296 : gfc_ss *next;
783 :
784 180296 : ss = loop->ss;
785 478651 : while (ss != gfc_ss_terminator)
786 : {
787 298355 : gcc_assert (ss != NULL);
788 298355 : next = ss->loop_chain;
789 298355 : gfc_free_ss (ss);
790 298355 : ss = next;
791 : }
792 :
793 : /* Remove reference to self in the parent loop. */
794 180296 : if (loop->parent)
795 3364 : for (ploop = &loop->parent->nested; *ploop; ploop = &(*ploop)->next)
796 3364 : if (*ploop == loop)
797 : {
798 3364 : *ploop = loop->next;
799 3364 : break;
800 : }
801 :
802 : /* Free non-freed nested loops. */
803 183660 : for (loop = loop->nested; loop; loop = loop_next)
804 : {
805 3364 : loop_next = loop->next;
806 3364 : gfc_cleanup_loop (loop);
807 3364 : free (loop);
808 : }
809 180296 : }
810 :
811 :
812 : static void
813 244942 : set_ss_loop (gfc_ss *ss, gfc_loopinfo *loop)
814 : {
815 244942 : int n;
816 :
817 552066 : for (; ss != gfc_ss_terminator; ss = ss->next)
818 : {
819 307124 : ss->loop = loop;
820 :
821 307124 : if (ss->info->type == GFC_SS_SCALAR
822 : || ss->info->type == GFC_SS_REFERENCE
823 259147 : || ss->info->type == GFC_SS_TEMP)
824 58991 : continue;
825 :
826 3970128 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
827 3721995 : if (ss->info->data.array.subscript[n] != NULL)
828 7151 : set_ss_loop (ss->info->data.array.subscript[n], loop);
829 : }
830 244942 : }
831 :
832 :
833 : /* Associate a SS chain with a loop. */
834 :
835 : void
836 237791 : gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
837 : {
838 237791 : gfc_ss *ss;
839 237791 : gfc_loopinfo *nested_loop;
840 :
841 237791 : if (head == gfc_ss_terminator)
842 : return;
843 :
844 237791 : set_ss_loop (head, loop);
845 :
846 237791 : ss = head;
847 775555 : for (; ss && ss != gfc_ss_terminator; ss = ss->next)
848 : {
849 299973 : if (ss->nested_ss)
850 : {
851 4740 : nested_loop = ss->nested_ss->loop;
852 :
853 : /* More than one ss can belong to the same loop. Hence, we add the
854 : loop to the chain only if it is different from the previously
855 : added one, to avoid duplicate nested loops. */
856 4740 : if (nested_loop != loop->nested)
857 : {
858 3364 : gcc_assert (nested_loop->parent == NULL);
859 3364 : nested_loop->parent = loop;
860 :
861 3364 : gcc_assert (nested_loop->next == NULL);
862 3364 : nested_loop->next = loop->nested;
863 3364 : loop->nested = nested_loop;
864 : }
865 : else
866 1376 : gcc_assert (nested_loop->parent == loop);
867 : }
868 :
869 299973 : if (ss->next == gfc_ss_terminator)
870 237791 : ss->loop_chain = loop->ss;
871 : else
872 62182 : ss->loop_chain = ss->next;
873 : }
874 237791 : gcc_assert (ss == gfc_ss_terminator);
875 237791 : loop->ss = head;
876 : }
877 :
878 :
879 : /* Returns true if the expression is an array pointer. */
880 :
881 : static bool
882 363493 : is_pointer_array (tree expr)
883 : {
884 363493 : if (expr == NULL_TREE
885 363493 : || !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr))
886 459352 : || GFC_CLASS_TYPE_P (TREE_TYPE (expr)))
887 : return false;
888 :
889 95859 : if (VAR_P (expr)
890 95859 : && GFC_DECL_PTR_ARRAY_P (expr))
891 : return true;
892 :
893 89515 : if (TREE_CODE (expr) == PARM_DECL
894 89515 : && GFC_DECL_PTR_ARRAY_P (expr))
895 : return true;
896 :
897 89515 : if (INDIRECT_REF_P (expr)
898 89515 : && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 0)))
899 : return true;
900 :
901 : /* The field declaration is marked as an pointer array. */
902 87087 : if (TREE_CODE (expr) == COMPONENT_REF
903 15152 : && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 1))
904 89946 : && !GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (expr, 1))))
905 2859 : return true;
906 :
907 : return false;
908 : }
909 :
910 :
911 : /* If the symbol or expression reference a CFI descriptor, return the
912 : pointer to the converted gfc descriptor. If an array reference is
913 : present as the last argument, check that it is the one applied to
914 : the CFI descriptor in the expression. Note that the CFI object is
915 : always the symbol in the expression! */
916 :
917 : static bool
918 366204 : get_CFI_desc (gfc_symbol *sym, gfc_expr *expr,
919 : tree *desc, gfc_array_ref *ar)
920 : {
921 366204 : tree tmp;
922 :
923 366204 : if (!is_CFI_desc (sym, expr))
924 : return false;
925 :
926 4727 : if (expr && ar)
927 : {
928 4061 : if (!(expr->ref && expr->ref->type == REF_ARRAY)
929 4043 : || (&expr->ref->u.ar != ar))
930 : return false;
931 : }
932 :
933 4697 : if (sym == NULL)
934 1108 : tmp = expr->symtree->n.sym->backend_decl;
935 : else
936 3589 : tmp = sym->backend_decl;
937 :
938 4697 : if (tmp && DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp))
939 0 : tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
940 :
941 4697 : *desc = tmp;
942 4697 : return true;
943 : }
944 :
945 :
946 : /* A helper function for gfc_get_array_span that returns the array element size
947 : of a class entity. */
948 : static tree
949 1113 : class_array_element_size (tree decl, bool unlimited)
950 : {
951 : /* Class dummys usually require extraction from the saved descriptor,
952 : which gfc_class_vptr_get does for us if necessary. This, of course,
953 : will be a component of the class object. */
954 1113 : tree vptr = gfc_class_vptr_get (decl);
955 : /* If this is an unlimited polymorphic entity with a character payload,
956 : the element size will be corrected for the string length. */
957 1113 : if (unlimited)
958 1022 : return gfc_resize_class_size_with_len (NULL,
959 511 : TREE_OPERAND (vptr, 0),
960 511 : gfc_vptr_size_get (vptr));
961 : else
962 602 : return gfc_vptr_size_get (vptr);
963 : }
964 :
965 :
966 : /* Return the span of an array. */
967 :
968 : tree
969 57642 : gfc_get_array_span (tree desc, gfc_expr *expr)
970 : {
971 57642 : tree tmp;
972 57642 : gfc_symbol *sym = (expr && expr->expr_type == EXPR_VARIABLE) ?
973 50676 : expr->symtree->n.sym : NULL;
974 :
975 57642 : if (is_pointer_array (desc)
976 57642 : || (get_CFI_desc (NULL, expr, &desc, NULL)
977 1332 : && (POINTER_TYPE_P (TREE_TYPE (desc))
978 666 : ? GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (desc)))
979 0 : : GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))))
980 : {
981 558 : if (POINTER_TYPE_P (TREE_TYPE (desc)))
982 0 : desc = build_fold_indirect_ref_loc (input_location, desc);
983 :
984 : /* This will have the span field set. */
985 558 : tmp = gfc_conv_descriptor_span_get (desc);
986 : }
987 57084 : else if (expr->ts.type == BT_ASSUMED)
988 : {
989 127 : if (DECL_LANG_SPECIFIC (desc) && GFC_DECL_SAVED_DESCRIPTOR (desc))
990 127 : desc = GFC_DECL_SAVED_DESCRIPTOR (desc);
991 127 : if (POINTER_TYPE_P (TREE_TYPE (desc)))
992 127 : desc = build_fold_indirect_ref_loc (input_location, desc);
993 127 : tmp = gfc_conv_descriptor_span_get (desc);
994 : }
995 56957 : else if (TREE_CODE (desc) == COMPONENT_REF
996 506 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
997 57086 : && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (desc, 0))))
998 : /* The descriptor is the _data field of a class object. */
999 56 : tmp = class_array_element_size (TREE_OPERAND (desc, 0),
1000 56 : UNLIMITED_POLY (expr));
1001 56901 : else if (sym && sym->ts.type == BT_CLASS
1002 1101 : && expr->ref->type == REF_COMPONENT
1003 1101 : && expr->ref->next->type == REF_ARRAY
1004 1101 : && expr->ref->next->next == NULL
1005 1083 : && CLASS_DATA (sym)->attr.dimension)
1006 : /* Having escaped the above, this can only be a class array dummy. */
1007 1057 : tmp = class_array_element_size (sym->backend_decl,
1008 1057 : UNLIMITED_POLY (sym));
1009 : else
1010 : {
1011 : /* If none of the fancy stuff works, the span is the element
1012 : size of the array. Attempt to deal with unbounded character
1013 : types if possible. Otherwise, return NULL_TREE. */
1014 55844 : tmp = gfc_get_element_type (TREE_TYPE (desc));
1015 55844 : if (tmp && TREE_CODE (tmp) == ARRAY_TYPE && TYPE_STRING_FLAG (tmp))
1016 : {
1017 11047 : gcc_assert (expr->ts.type == BT_CHARACTER);
1018 :
1019 11047 : tmp = gfc_get_character_len_in_bytes (tmp);
1020 :
1021 11047 : if (tmp == NULL_TREE || integer_zerop (tmp))
1022 : {
1023 80 : tree bs;
1024 :
1025 80 : tmp = gfc_get_expr_charlen (expr);
1026 80 : tmp = fold_convert (gfc_array_index_type, tmp);
1027 80 : bs = build_int_cst (gfc_array_index_type, expr->ts.kind);
1028 80 : tmp = fold_build2_loc (input_location, MULT_EXPR,
1029 : gfc_array_index_type, tmp, bs);
1030 : }
1031 :
1032 22014 : tmp = (tmp && !integer_zerop (tmp))
1033 22014 : ? (fold_convert (gfc_array_index_type, tmp)) : (NULL_TREE);
1034 : }
1035 : else
1036 44797 : tmp = fold_convert (gfc_array_index_type,
1037 : size_in_bytes (tmp));
1038 : }
1039 57642 : return tmp;
1040 : }
1041 :
1042 :
1043 : /* Generate an initializer for a static pointer or allocatable array. */
1044 :
1045 : void
1046 279 : gfc_trans_static_array_pointer (gfc_symbol * sym)
1047 : {
1048 279 : tree type;
1049 :
1050 279 : gcc_assert (TREE_STATIC (sym->backend_decl));
1051 : /* Just zero the data member. */
1052 279 : type = TREE_TYPE (sym->backend_decl);
1053 279 : DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
1054 279 : }
1055 :
1056 :
1057 : /* If the bounds of SE's loop have not yet been set, see if they can be
1058 : determined from array spec AS, which is the array spec of a called
1059 : function. MAPPING maps the callee's dummy arguments to the values
1060 : that the caller is passing. Add any initialization and finalization
1061 : code to SE. */
1062 :
1063 : void
1064 8609 : gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
1065 : gfc_se * se, gfc_array_spec * as)
1066 : {
1067 8609 : int n, dim, total_dim;
1068 8609 : gfc_se tmpse;
1069 8609 : gfc_ss *ss;
1070 8609 : tree lower;
1071 8609 : tree upper;
1072 8609 : tree tmp;
1073 :
1074 8609 : total_dim = 0;
1075 :
1076 8609 : if (!as || as->type != AS_EXPLICIT)
1077 7466 : return;
1078 :
1079 2311 : for (ss = se->ss; ss; ss = ss->parent)
1080 : {
1081 1168 : total_dim += ss->loop->dimen;
1082 2691 : for (n = 0; n < ss->loop->dimen; n++)
1083 : {
1084 : /* The bound is known, nothing to do. */
1085 1523 : if (ss->loop->to[n] != NULL_TREE)
1086 485 : continue;
1087 :
1088 1038 : dim = ss->dim[n];
1089 1038 : gcc_assert (dim < as->rank);
1090 1038 : gcc_assert (ss->loop->dimen <= as->rank);
1091 :
1092 : /* Evaluate the lower bound. */
1093 1038 : gfc_init_se (&tmpse, NULL);
1094 1038 : gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
1095 1038 : gfc_add_block_to_block (&se->pre, &tmpse.pre);
1096 1038 : gfc_add_block_to_block (&se->post, &tmpse.post);
1097 1038 : lower = fold_convert (gfc_array_index_type, tmpse.expr);
1098 :
1099 : /* ...and the upper bound. */
1100 1038 : gfc_init_se (&tmpse, NULL);
1101 1038 : gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
1102 1038 : gfc_add_block_to_block (&se->pre, &tmpse.pre);
1103 1038 : gfc_add_block_to_block (&se->post, &tmpse.post);
1104 1038 : upper = fold_convert (gfc_array_index_type, tmpse.expr);
1105 :
1106 : /* Set the upper bound of the loop to UPPER - LOWER. */
1107 1038 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
1108 : gfc_array_index_type, upper, lower);
1109 1038 : tmp = gfc_evaluate_now (tmp, &se->pre);
1110 1038 : ss->loop->to[n] = tmp;
1111 : }
1112 : }
1113 :
1114 1143 : gcc_assert (total_dim == as->rank);
1115 : }
1116 :
1117 :
1118 : /* Generate code to allocate an array temporary, or create a variable to
1119 : hold the data. If size is NULL, zero the descriptor so that the
1120 : callee will allocate the array. If DEALLOC is true, also generate code to
1121 : free the array afterwards.
1122 :
1123 : If INITIAL is not NULL, it is packed using internal_pack and the result used
1124 : as data instead of allocating a fresh, unitialized area of memory.
1125 :
1126 : Initialization code is added to PRE and finalization code to POST.
1127 : DYNAMIC is true if the caller may want to extend the array later
1128 : using realloc. This prevents us from putting the array on the stack. */
1129 :
1130 : static void
1131 27241 : gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
1132 : gfc_array_info * info, tree size, tree nelem,
1133 : tree initial, bool dynamic, bool dealloc)
1134 : {
1135 27241 : tree tmp;
1136 27241 : tree desc;
1137 27241 : bool onstack;
1138 :
1139 27241 : desc = info->descriptor;
1140 27241 : info->offset = gfc_index_zero_node;
1141 27241 : if (size == NULL_TREE || (dynamic && integer_zerop (size)))
1142 : {
1143 : /* A callee allocated array. */
1144 2754 : gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
1145 2754 : onstack = false;
1146 : }
1147 : else
1148 : {
1149 : /* Allocate the temporary. */
1150 48974 : onstack = !dynamic && initial == NULL_TREE
1151 24487 : && (flag_stack_arrays
1152 24144 : || gfc_can_put_var_on_stack (size));
1153 :
1154 24487 : if (onstack)
1155 : {
1156 : /* Make a temporary variable to hold the data. */
1157 19533 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (nelem),
1158 : nelem, gfc_index_one_node);
1159 19533 : tmp = gfc_evaluate_now (tmp, pre);
1160 19533 : tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
1161 : tmp);
1162 19533 : tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
1163 : tmp);
1164 19533 : tmp = gfc_create_var (tmp, "A");
1165 : /* If we're here only because of -fstack-arrays we have to
1166 : emit a DECL_EXPR to make the gimplifier emit alloca calls. */
1167 19533 : if (!gfc_can_put_var_on_stack (size))
1168 17 : gfc_add_expr_to_block (pre,
1169 : fold_build1_loc (input_location,
1170 17 : DECL_EXPR, TREE_TYPE (tmp),
1171 : tmp));
1172 19533 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1173 19533 : gfc_conv_descriptor_data_set (pre, desc, tmp);
1174 : }
1175 : else
1176 : {
1177 : /* Allocate memory to hold the data or call internal_pack. */
1178 4954 : if (initial == NULL_TREE)
1179 : {
1180 4853 : tmp = gfc_call_malloc (pre, NULL, size);
1181 4853 : tmp = gfc_evaluate_now (tmp, pre);
1182 : }
1183 : else
1184 : {
1185 101 : tree packed;
1186 101 : tree source_data;
1187 101 : tree was_packed;
1188 101 : stmtblock_t do_copying;
1189 :
1190 101 : tmp = TREE_TYPE (initial); /* Pointer to descriptor. */
1191 101 : gcc_assert (TREE_CODE (tmp) == POINTER_TYPE);
1192 101 : tmp = TREE_TYPE (tmp); /* The descriptor itself. */
1193 101 : tmp = gfc_get_element_type (tmp);
1194 101 : packed = gfc_create_var (build_pointer_type (tmp), "data");
1195 :
1196 101 : tmp = build_call_expr_loc (input_location,
1197 : gfor_fndecl_in_pack, 1, initial);
1198 101 : tmp = fold_convert (TREE_TYPE (packed), tmp);
1199 101 : gfc_add_modify (pre, packed, tmp);
1200 :
1201 101 : tmp = build_fold_indirect_ref_loc (input_location,
1202 : initial);
1203 101 : source_data = gfc_conv_descriptor_data_get (tmp);
1204 :
1205 : /* internal_pack may return source->data without any allocation
1206 : or copying if it is already packed. If that's the case, we
1207 : need to allocate and copy manually. */
1208 :
1209 101 : gfc_start_block (&do_copying);
1210 101 : tmp = gfc_call_malloc (&do_copying, NULL, size);
1211 101 : tmp = fold_convert (TREE_TYPE (packed), tmp);
1212 101 : gfc_add_modify (&do_copying, packed, tmp);
1213 101 : tmp = gfc_build_memcpy_call (packed, source_data, size);
1214 101 : gfc_add_expr_to_block (&do_copying, tmp);
1215 :
1216 101 : was_packed = fold_build2_loc (input_location, EQ_EXPR,
1217 : logical_type_node, packed,
1218 : source_data);
1219 101 : tmp = gfc_finish_block (&do_copying);
1220 101 : tmp = build3_v (COND_EXPR, was_packed, tmp,
1221 : build_empty_stmt (input_location));
1222 101 : gfc_add_expr_to_block (pre, tmp);
1223 :
1224 101 : tmp = fold_convert (pvoid_type_node, packed);
1225 : }
1226 :
1227 4954 : gfc_conv_descriptor_data_set (pre, desc, tmp);
1228 : }
1229 : }
1230 27241 : info->data = gfc_conv_descriptor_data_get (desc);
1231 :
1232 : /* The offset is zero because we create temporaries with a zero
1233 : lower bound. */
1234 27241 : gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node);
1235 :
1236 27241 : if (dealloc && !onstack)
1237 : {
1238 : /* Free the temporary. */
1239 7458 : tmp = gfc_conv_descriptor_data_get (desc);
1240 7458 : tmp = gfc_call_free (tmp);
1241 7458 : gfc_add_expr_to_block (post, tmp);
1242 : }
1243 27241 : }
1244 :
1245 :
1246 : /* Get the scalarizer array dimension corresponding to actual array dimension
1247 : given by ARRAY_DIM.
1248 :
1249 : For example, if SS represents the array ref a(1,:,:,1), it is a
1250 : bidimensional scalarizer array, and the result would be 0 for ARRAY_DIM=1,
1251 : and 1 for ARRAY_DIM=2.
1252 : If SS represents transpose(a(:,1,1,:)), it is again a bidimensional
1253 : scalarizer array, and the result would be 1 for ARRAY_DIM=0 and 0 for
1254 : ARRAY_DIM=3.
1255 : If SS represents sum(a(:,:,:,1), dim=1), it is a 2+1-dimensional scalarizer
1256 : array. If called on the inner ss, the result would be respectively 0,1,2 for
1257 : ARRAY_DIM=0,1,2. If called on the outer ss, the result would be 0,1
1258 : for ARRAY_DIM=1,2. */
1259 :
1260 : static int
1261 257796 : get_scalarizer_dim_for_array_dim (gfc_ss *ss, int array_dim)
1262 : {
1263 257796 : int array_ref_dim;
1264 257796 : int n;
1265 :
1266 257796 : array_ref_dim = 0;
1267 :
1268 521725 : for (; ss; ss = ss->parent)
1269 681123 : for (n = 0; n < ss->dimen; n++)
1270 417194 : if (ss->dim[n] < array_dim)
1271 76849 : array_ref_dim++;
1272 :
1273 257796 : return array_ref_dim;
1274 : }
1275 :
1276 :
1277 : static gfc_ss *
1278 218041 : innermost_ss (gfc_ss *ss)
1279 : {
1280 400720 : while (ss->nested_ss != NULL)
1281 : ss = ss->nested_ss;
1282 :
1283 392512 : return ss;
1284 : }
1285 :
1286 :
1287 :
1288 : /* Get the array reference dimension corresponding to the given loop dimension.
1289 : It is different from the true array dimension given by the dim array in
1290 : the case of a partial array reference (i.e. a(:,:,1,:) for example)
1291 : It is different from the loop dimension in the case of a transposed array.
1292 : */
1293 :
1294 : static int
1295 218041 : get_array_ref_dim_for_loop_dim (gfc_ss *ss, int loop_dim)
1296 : {
1297 218041 : return get_scalarizer_dim_for_array_dim (innermost_ss (ss),
1298 218041 : ss->dim[loop_dim]);
1299 : }
1300 :
1301 :
1302 : /* Use the information in the ss to obtain the required information about
1303 : the type and size of an array temporary, when the lhs in an assignment
1304 : is a class expression. */
1305 :
1306 : static tree
1307 321 : get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype,
1308 : gfc_ss **fcnss)
1309 : {
1310 321 : gfc_ss *loop_ss = ss->loop->ss;
1311 321 : gfc_ss *lhs_ss;
1312 321 : gfc_ss *rhs_ss;
1313 321 : gfc_ss *fcn_ss = NULL;
1314 321 : tree tmp;
1315 321 : tree tmp2;
1316 321 : tree vptr;
1317 321 : tree class_expr = NULL_TREE;
1318 321 : tree lhs_class_expr = NULL_TREE;
1319 321 : bool unlimited_rhs = false;
1320 321 : bool unlimited_lhs = false;
1321 321 : bool rhs_function = false;
1322 321 : bool unlimited_arg1 = false;
1323 321 : gfc_symbol *vtab;
1324 321 : tree cntnr = NULL_TREE;
1325 :
1326 : /* The second element in the loop chain contains the source for the
1327 : class temporary created in gfc_trans_create_temp_array. */
1328 321 : rhs_ss = loop_ss->loop_chain;
1329 :
1330 321 : if (rhs_ss != gfc_ss_terminator
1331 297 : && rhs_ss->info
1332 297 : && rhs_ss->info->expr
1333 297 : && rhs_ss->info->expr->ts.type == BT_CLASS
1334 176 : && rhs_ss->info->data.array.descriptor)
1335 : {
1336 164 : if (rhs_ss->info->expr->expr_type != EXPR_VARIABLE)
1337 56 : class_expr
1338 56 : = gfc_get_class_from_expr (rhs_ss->info->data.array.descriptor);
1339 : else
1340 108 : class_expr = gfc_get_class_from_gfc_expr (rhs_ss->info->expr);
1341 164 : unlimited_rhs = UNLIMITED_POLY (rhs_ss->info->expr);
1342 164 : if (rhs_ss->info->expr->expr_type == EXPR_FUNCTION)
1343 : rhs_function = true;
1344 : }
1345 :
1346 : /* Usually, ss points to the function. When the function call is an actual
1347 : argument, it is instead rhs_ss because the ss chain is shifted by one. */
1348 321 : *fcnss = fcn_ss = rhs_function ? rhs_ss : ss;
1349 :
1350 : /* If this is a transformational function with a class result, the info
1351 : class_container field points to the class container of arg1. */
1352 321 : if (class_expr != NULL_TREE
1353 145 : && fcn_ss->info && fcn_ss->info->expr
1354 91 : && fcn_ss->info->expr->expr_type == EXPR_FUNCTION
1355 91 : && fcn_ss->info->expr->value.function.isym
1356 60 : && fcn_ss->info->expr->value.function.isym->transformational)
1357 : {
1358 60 : cntnr = ss->info->class_container;
1359 60 : unlimited_arg1
1360 60 : = UNLIMITED_POLY (fcn_ss->info->expr->value.function.actual->expr);
1361 : }
1362 :
1363 : /* For an assignment the lhs is the next element in the loop chain.
1364 : If we have a class rhs, this had better be a class variable
1365 : expression! Otherwise, the class container from arg1 can be used
1366 : to set the vptr and len fields of the result class container. */
1367 321 : lhs_ss = rhs_ss->loop_chain;
1368 321 : if (lhs_ss && lhs_ss != gfc_ss_terminator
1369 225 : && lhs_ss->info && lhs_ss->info->expr
1370 225 : && lhs_ss->info->expr->expr_type ==EXPR_VARIABLE
1371 225 : && lhs_ss->info->expr->ts.type == BT_CLASS)
1372 : {
1373 225 : tmp = lhs_ss->info->data.array.descriptor;
1374 225 : unlimited_lhs = UNLIMITED_POLY (rhs_ss->info->expr);
1375 : }
1376 96 : else if (cntnr != NULL_TREE)
1377 : {
1378 54 : tmp = gfc_class_vptr_get (class_expr);
1379 54 : gfc_add_modify (pre, tmp, fold_convert (TREE_TYPE (tmp),
1380 : gfc_class_vptr_get (cntnr)));
1381 54 : if (unlimited_rhs)
1382 : {
1383 6 : tmp = gfc_class_len_get (class_expr);
1384 6 : if (unlimited_arg1)
1385 6 : gfc_add_modify (pre, tmp, gfc_class_len_get (cntnr));
1386 : }
1387 : tmp = NULL_TREE;
1388 : }
1389 : else
1390 : tmp = NULL_TREE;
1391 :
1392 : /* Get the lhs class expression. */
1393 225 : if (tmp != NULL_TREE && lhs_ss->loop_chain == gfc_ss_terminator)
1394 213 : lhs_class_expr = gfc_get_class_from_expr (tmp);
1395 : else
1396 108 : return class_expr;
1397 :
1398 213 : gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (lhs_class_expr)));
1399 :
1400 : /* Set the lhs vptr and, if necessary, the _len field. */
1401 213 : if (class_expr)
1402 : {
1403 : /* Both lhs and rhs are class expressions. */
1404 79 : tmp = gfc_class_vptr_get (lhs_class_expr);
1405 158 : gfc_add_modify (pre, tmp,
1406 79 : fold_convert (TREE_TYPE (tmp),
1407 : gfc_class_vptr_get (class_expr)));
1408 79 : if (unlimited_lhs)
1409 : {
1410 31 : gcc_assert (unlimited_rhs);
1411 31 : tmp = gfc_class_len_get (lhs_class_expr);
1412 31 : tmp2 = gfc_class_len_get (class_expr);
1413 31 : gfc_add_modify (pre, tmp, tmp2);
1414 : }
1415 : }
1416 134 : else if (rhs_ss->info->data.array.descriptor)
1417 : {
1418 : /* lhs is class and rhs is intrinsic or derived type. */
1419 128 : *eltype = TREE_TYPE (rhs_ss->info->data.array.descriptor);
1420 128 : *eltype = gfc_get_element_type (*eltype);
1421 128 : vtab = gfc_find_vtab (&rhs_ss->info->expr->ts);
1422 128 : vptr = vtab->backend_decl;
1423 128 : if (vptr == NULL_TREE)
1424 24 : vptr = gfc_get_symbol_decl (vtab);
1425 128 : vptr = gfc_build_addr_expr (NULL_TREE, vptr);
1426 128 : tmp = gfc_class_vptr_get (lhs_class_expr);
1427 128 : gfc_add_modify (pre, tmp,
1428 128 : fold_convert (TREE_TYPE (tmp), vptr));
1429 :
1430 128 : if (unlimited_lhs)
1431 : {
1432 0 : tmp = gfc_class_len_get (lhs_class_expr);
1433 0 : if (rhs_ss->info
1434 0 : && rhs_ss->info->expr
1435 0 : && rhs_ss->info->expr->ts.type == BT_CHARACTER)
1436 0 : tmp2 = build_int_cst (TREE_TYPE (tmp),
1437 0 : rhs_ss->info->expr->ts.kind);
1438 : else
1439 0 : tmp2 = build_int_cst (TREE_TYPE (tmp), 0);
1440 0 : gfc_add_modify (pre, tmp, tmp2);
1441 : }
1442 : }
1443 :
1444 : return class_expr;
1445 : }
1446 :
1447 :
1448 :
1449 : /* Generate code to create and initialize the descriptor for a temporary
1450 : array. This is used for both temporaries needed by the scalarizer, and
1451 : functions returning arrays. Adjusts the loop variables to be
1452 : zero-based, and calculates the loop bounds for callee allocated arrays.
1453 : Allocate the array unless it's callee allocated (we have a callee
1454 : allocated array if 'callee_alloc' is true, or if loop->to[n] is
1455 : NULL_TREE for any n). Also fills in the descriptor, data and offset
1456 : fields of info if known. Returns the size of the array, or NULL for a
1457 : callee allocated array.
1458 :
1459 : 'eltype' == NULL signals that the temporary should be a class object.
1460 : The 'initial' expression is used to obtain the size of the dynamic
1461 : type; otherwise the allocation and initialization proceeds as for any
1462 : other expression
1463 :
1464 : PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
1465 : gfc_trans_allocate_array_storage. */
1466 :
1467 : tree
1468 27241 : gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
1469 : tree eltype, tree initial, bool dynamic,
1470 : bool dealloc, bool callee_alloc, locus * where)
1471 : {
1472 27241 : gfc_loopinfo *loop;
1473 27241 : gfc_ss *s;
1474 27241 : gfc_array_info *info;
1475 27241 : tree from[GFC_MAX_DIMENSIONS], to[GFC_MAX_DIMENSIONS];
1476 27241 : tree type;
1477 27241 : tree desc;
1478 27241 : tree tmp;
1479 27241 : tree size;
1480 27241 : tree nelem;
1481 27241 : tree cond;
1482 27241 : tree or_expr;
1483 27241 : tree elemsize;
1484 27241 : tree class_expr = NULL_TREE;
1485 27241 : gfc_ss *fcn_ss = NULL;
1486 27241 : int n, dim, tmp_dim;
1487 27241 : int total_dim = 0;
1488 :
1489 : /* This signals a class array for which we need the size of the
1490 : dynamic type. Generate an eltype and then the class expression. */
1491 27241 : if (eltype == NULL_TREE && initial)
1492 : {
1493 6 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial)));
1494 6 : class_expr = build_fold_indirect_ref_loc (input_location, initial);
1495 : /* Obtain the structure (class) expression. */
1496 6 : class_expr = gfc_get_class_from_expr (class_expr);
1497 6 : gcc_assert (class_expr);
1498 : }
1499 :
1500 : /* Otherwise, some expressions, such as class functions, arising from
1501 : dependency checking in assignments come here with class element type.
1502 : The descriptor can be obtained from the ss->info and then converted
1503 : to the class object. */
1504 27235 : if (class_expr == NULL_TREE && GFC_CLASS_TYPE_P (eltype))
1505 321 : class_expr = get_class_info_from_ss (pre, ss, &eltype, &fcn_ss);
1506 :
1507 : /* If the dynamic type is not available, use the declared type. */
1508 27241 : if (eltype && GFC_CLASS_TYPE_P (eltype))
1509 193 : eltype = gfc_get_element_type (TREE_TYPE (TYPE_FIELDS (eltype)));
1510 :
1511 27241 : if (class_expr == NULL_TREE)
1512 27090 : elemsize = fold_convert (gfc_array_index_type,
1513 : TYPE_SIZE_UNIT (eltype));
1514 : else
1515 : {
1516 : /* Unlimited polymorphic entities are initialised with NULL vptr. They
1517 : can be tested for by checking if the len field is present. If so
1518 : test the vptr before using the vtable size. */
1519 151 : tmp = gfc_class_vptr_get (class_expr);
1520 151 : tmp = fold_build2_loc (input_location, NE_EXPR,
1521 : logical_type_node,
1522 151 : tmp, build_int_cst (TREE_TYPE (tmp), 0));
1523 151 : elemsize = fold_build3_loc (input_location, COND_EXPR,
1524 : gfc_array_index_type,
1525 : tmp,
1526 : gfc_class_vtab_size_get (class_expr),
1527 : gfc_index_zero_node);
1528 151 : elemsize = gfc_evaluate_now (elemsize, pre);
1529 151 : elemsize = gfc_resize_class_size_with_len (pre, class_expr, elemsize);
1530 : /* Casting the data as a character of the dynamic length ensures that
1531 : assignment of elements works when needed. */
1532 151 : eltype = gfc_get_character_type_len (1, elemsize);
1533 : }
1534 :
1535 27241 : memset (from, 0, sizeof (from));
1536 27241 : memset (to, 0, sizeof (to));
1537 :
1538 27241 : info = &ss->info->data.array;
1539 :
1540 27241 : gcc_assert (ss->dimen > 0);
1541 27241 : gcc_assert (ss->loop->dimen == ss->dimen);
1542 :
1543 27241 : if (warn_array_temporaries && where)
1544 207 : gfc_warning (OPT_Warray_temporaries,
1545 : "Creating array temporary at %L", where);
1546 :
1547 : /* Set the lower bound to zero. */
1548 54517 : for (s = ss; s; s = s->parent)
1549 : {
1550 27276 : loop = s->loop;
1551 :
1552 27276 : total_dim += loop->dimen;
1553 63741 : for (n = 0; n < loop->dimen; n++)
1554 : {
1555 36465 : dim = s->dim[n];
1556 :
1557 : /* Callee allocated arrays may not have a known bound yet. */
1558 36465 : if (loop->to[n])
1559 33180 : loop->to[n] = gfc_evaluate_now (
1560 : fold_build2_loc (input_location, MINUS_EXPR,
1561 : gfc_array_index_type,
1562 : loop->to[n], loop->from[n]),
1563 : pre);
1564 36465 : loop->from[n] = gfc_index_zero_node;
1565 :
1566 : /* We have just changed the loop bounds, we must clear the
1567 : corresponding specloop, so that delta calculation is not skipped
1568 : later in gfc_set_delta. */
1569 36465 : loop->specloop[n] = NULL;
1570 :
1571 : /* We are constructing the temporary's descriptor based on the loop
1572 : dimensions. As the dimensions may be accessed in arbitrary order
1573 : (think of transpose) the size taken from the n'th loop may not map
1574 : to the n'th dimension of the array. We need to reconstruct loop
1575 : infos in the right order before using it to set the descriptor
1576 : bounds. */
1577 36465 : tmp_dim = get_scalarizer_dim_for_array_dim (ss, dim);
1578 36465 : from[tmp_dim] = loop->from[n];
1579 36465 : to[tmp_dim] = loop->to[n];
1580 :
1581 36465 : info->delta[dim] = gfc_index_zero_node;
1582 36465 : info->start[dim] = gfc_index_zero_node;
1583 36465 : info->end[dim] = gfc_index_zero_node;
1584 36465 : info->stride[dim] = gfc_index_one_node;
1585 : }
1586 : }
1587 :
1588 : /* Initialize the descriptor. */
1589 27241 : type =
1590 27241 : gfc_get_array_type_bounds (eltype, total_dim, 0, from, to, 1,
1591 : GFC_ARRAY_UNKNOWN, true);
1592 27241 : desc = gfc_create_var (type, "atmp");
1593 27241 : GFC_DECL_PACKED_ARRAY (desc) = 1;
1594 :
1595 : /* Emit a DECL_EXPR for the variable sized array type in
1596 : GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
1597 : sizes works correctly. */
1598 27241 : tree arraytype = TREE_TYPE (GFC_TYPE_ARRAY_DATAPTR_TYPE (type));
1599 27241 : if (! TYPE_NAME (arraytype))
1600 27241 : TYPE_NAME (arraytype) = build_decl (UNKNOWN_LOCATION, TYPE_DECL,
1601 : NULL_TREE, arraytype);
1602 27241 : gfc_add_expr_to_block (pre, build1 (DECL_EXPR,
1603 27241 : arraytype, TYPE_NAME (arraytype)));
1604 :
1605 27241 : if (fcn_ss && fcn_ss->info && fcn_ss->info->class_container)
1606 : {
1607 90 : suppress_warning (desc);
1608 90 : TREE_USED (desc) = 0;
1609 : }
1610 :
1611 27241 : if (class_expr != NULL_TREE
1612 27090 : || (fcn_ss && fcn_ss->info && fcn_ss->info->class_container))
1613 : {
1614 181 : tree class_data;
1615 181 : tree dtype;
1616 181 : gfc_expr *expr1 = fcn_ss ? fcn_ss->info->expr : NULL;
1617 175 : bool rank_changer;
1618 :
1619 : /* Pick out these transformational functions because they change the rank
1620 : or shape of the first argument. This requires that the class type be
1621 : changed, the dtype updated and the correct rank used. */
1622 121 : rank_changer = expr1 && expr1->expr_type == EXPR_FUNCTION
1623 121 : && expr1->value.function.isym
1624 265 : && (expr1->value.function.isym->id == GFC_ISYM_RESHAPE
1625 : || expr1->value.function.isym->id == GFC_ISYM_SPREAD
1626 : || expr1->value.function.isym->id == GFC_ISYM_PACK
1627 : || expr1->value.function.isym->id == GFC_ISYM_UNPACK);
1628 :
1629 : /* Create a class temporary for the result using the lhs class object. */
1630 181 : if (class_expr != NULL_TREE && !rank_changer)
1631 : {
1632 103 : tmp = gfc_create_var (TREE_TYPE (class_expr), "ctmp");
1633 103 : gfc_add_modify (pre, tmp, class_expr);
1634 : }
1635 : else
1636 : {
1637 78 : tree vptr;
1638 78 : class_expr = fcn_ss->info->class_container;
1639 78 : gcc_assert (expr1);
1640 :
1641 : /* Build a new class container using the arg1 class object. The class
1642 : typespec must be rebuilt because the rank might have changed. */
1643 78 : gfc_typespec ts = CLASS_DATA (expr1)->ts;
1644 78 : symbol_attribute attr = CLASS_DATA (expr1)->attr;
1645 78 : gfc_change_class (&ts, &attr, NULL, expr1->rank, 0);
1646 78 : tmp = gfc_create_var (gfc_typenode_for_spec (&ts), "ctmp");
1647 78 : fcn_ss->info->class_container = tmp;
1648 :
1649 : /* Set the vptr and obtain the element size. */
1650 78 : vptr = gfc_class_vptr_get (tmp);
1651 156 : gfc_add_modify (pre, vptr,
1652 78 : fold_convert (TREE_TYPE (vptr),
1653 : gfc_class_vptr_get (class_expr)));
1654 78 : elemsize = gfc_class_vtab_size_get (class_expr);
1655 :
1656 : /* Set the _len field, if necessary. */
1657 78 : if (UNLIMITED_POLY (expr1))
1658 : {
1659 18 : gfc_add_modify (pre, gfc_class_len_get (tmp),
1660 : gfc_class_len_get (class_expr));
1661 18 : elemsize = gfc_resize_class_size_with_len (pre, class_expr,
1662 : elemsize);
1663 : }
1664 :
1665 78 : elemsize = gfc_evaluate_now (elemsize, pre);
1666 : }
1667 :
1668 181 : class_data = gfc_class_data_get (tmp);
1669 :
1670 181 : if (rank_changer)
1671 : {
1672 : /* Take the dtype from the class expression. */
1673 72 : dtype = gfc_conv_descriptor_dtype (gfc_class_data_get (class_expr));
1674 72 : tmp = gfc_conv_descriptor_dtype (desc);
1675 72 : gfc_add_modify (pre, tmp, dtype);
1676 :
1677 : /* These transformational functions change the rank. */
1678 72 : tmp = gfc_conv_descriptor_rank (desc);
1679 72 : gfc_add_modify (pre, tmp,
1680 72 : build_int_cst (TREE_TYPE (tmp), ss->loop->dimen));
1681 72 : fcn_ss->info->class_container = NULL_TREE;
1682 : }
1683 :
1684 : /* Assign the new descriptor to the _data field. This allows the
1685 : vptr _copy to be used for scalarized assignment since the class
1686 : temporary can be found from the descriptor. */
1687 181 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1688 181 : TREE_TYPE (desc), desc);
1689 181 : gfc_add_modify (pre, class_data, tmp);
1690 :
1691 : /* Point desc to the class _data field. */
1692 181 : desc = class_data;
1693 181 : }
1694 : else
1695 : {
1696 : /* Fill in the array dtype. */
1697 27060 : tmp = gfc_conv_descriptor_dtype (desc);
1698 27060 : gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
1699 : }
1700 :
1701 27241 : info->descriptor = desc;
1702 27241 : size = gfc_index_one_node;
1703 :
1704 : /*
1705 : Fill in the bounds and stride. This is a packed array, so:
1706 :
1707 : size = 1;
1708 : for (n = 0; n < rank; n++)
1709 : {
1710 : stride[n] = size
1711 : delta = ubound[n] + 1 - lbound[n];
1712 : size = size * delta;
1713 : }
1714 : size = size * sizeof(element);
1715 : */
1716 :
1717 27241 : or_expr = NULL_TREE;
1718 :
1719 : /* If there is at least one null loop->to[n], it is a callee allocated
1720 : array. */
1721 60421 : for (n = 0; n < total_dim; n++)
1722 35117 : if (to[n] == NULL_TREE)
1723 : {
1724 : size = NULL_TREE;
1725 : break;
1726 : }
1727 :
1728 27241 : if (size == NULL_TREE)
1729 3884 : for (s = ss; s; s = s->parent)
1730 5237 : for (n = 0; n < s->loop->dimen; n++)
1731 : {
1732 3290 : dim = get_scalarizer_dim_for_array_dim (ss, s->dim[n]);
1733 :
1734 : /* For a callee allocated array express the loop bounds in terms
1735 : of the descriptor fields. */
1736 3290 : tmp = fold_build2_loc (input_location,
1737 : MINUS_EXPR, gfc_array_index_type,
1738 : gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]),
1739 : gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]));
1740 3290 : s->loop->to[n] = tmp;
1741 : }
1742 : else
1743 : {
1744 58479 : for (n = 0; n < total_dim; n++)
1745 : {
1746 : /* Store the stride and bound components in the descriptor. */
1747 33175 : gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size);
1748 :
1749 33175 : gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
1750 : gfc_index_zero_node);
1751 :
1752 33175 : gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], to[n]);
1753 :
1754 33175 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
1755 : gfc_array_index_type,
1756 : to[n], gfc_index_one_node);
1757 :
1758 : /* Check whether the size for this dimension is negative. */
1759 33175 : cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
1760 : tmp, gfc_index_zero_node);
1761 33175 : cond = gfc_evaluate_now (cond, pre);
1762 :
1763 33175 : if (n == 0)
1764 : or_expr = cond;
1765 : else
1766 7871 : or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1767 : logical_type_node, or_expr, cond);
1768 :
1769 33175 : size = fold_build2_loc (input_location, MULT_EXPR,
1770 : gfc_array_index_type, size, tmp);
1771 33175 : size = gfc_evaluate_now (size, pre);
1772 : }
1773 : }
1774 :
1775 : /* Get the size of the array. */
1776 27241 : if (size && !callee_alloc)
1777 : {
1778 : /* If or_expr is true, then the extent in at least one
1779 : dimension is zero and the size is set to zero. */
1780 25114 : size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
1781 : or_expr, gfc_index_zero_node, size);
1782 :
1783 25114 : nelem = size;
1784 25114 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
1785 : size, elemsize);
1786 : }
1787 : else
1788 : {
1789 : nelem = size;
1790 : size = NULL_TREE;
1791 : }
1792 :
1793 : /* Set the span. */
1794 27241 : tmp = fold_convert (gfc_array_index_type, elemsize);
1795 27241 : gfc_conv_descriptor_span_set (pre, desc, tmp);
1796 :
1797 27241 : gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
1798 : dynamic, dealloc);
1799 :
1800 54517 : while (ss->parent)
1801 : ss = ss->parent;
1802 :
1803 27241 : if (ss->dimen > ss->loop->temp_dim)
1804 23531 : ss->loop->temp_dim = ss->dimen;
1805 :
1806 27241 : return size;
1807 : }
1808 :
1809 :
1810 : /* Return the number of iterations in a loop that starts at START,
1811 : ends at END, and has step STEP. */
1812 :
1813 : static tree
1814 1059 : gfc_get_iteration_count (tree start, tree end, tree step)
1815 : {
1816 1059 : tree tmp;
1817 1059 : tree type;
1818 :
1819 1059 : type = TREE_TYPE (step);
1820 1059 : tmp = fold_build2_loc (input_location, MINUS_EXPR, type, end, start);
1821 1059 : tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, type, tmp, step);
1822 1059 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp,
1823 : build_int_cst (type, 1));
1824 1059 : tmp = fold_build2_loc (input_location, MAX_EXPR, type, tmp,
1825 : build_int_cst (type, 0));
1826 1059 : return fold_convert (gfc_array_index_type, tmp);
1827 : }
1828 :
1829 :
1830 : /* Extend the data in array DESC by EXTRA elements. */
1831 :
1832 : static void
1833 1047 : gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
1834 : {
1835 1047 : tree arg0, arg1;
1836 1047 : tree tmp;
1837 1047 : tree size;
1838 1047 : tree ubound;
1839 :
1840 1047 : if (integer_zerop (extra))
1841 : return;
1842 :
1843 1017 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
1844 :
1845 : /* Add EXTRA to the upper bound. */
1846 1017 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1847 : ubound, extra);
1848 1017 : gfc_conv_descriptor_ubound_set (pblock, desc, gfc_rank_cst[0], tmp);
1849 :
1850 : /* Get the value of the current data pointer. */
1851 1017 : arg0 = gfc_conv_descriptor_data_get (desc);
1852 :
1853 : /* Calculate the new array size. */
1854 1017 : size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
1855 1017 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1856 : ubound, gfc_index_one_node);
1857 1017 : arg1 = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
1858 : fold_convert (size_type_node, tmp),
1859 : fold_convert (size_type_node, size));
1860 :
1861 : /* Call the realloc() function. */
1862 1017 : tmp = gfc_call_realloc (pblock, arg0, arg1);
1863 1017 : gfc_conv_descriptor_data_set (pblock, desc, tmp);
1864 : }
1865 :
1866 :
1867 : /* Return true if the bounds of iterator I can only be determined
1868 : at run time. */
1869 :
1870 : static inline bool
1871 2221 : gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
1872 : {
1873 2221 : return (i->start->expr_type != EXPR_CONSTANT
1874 1803 : || i->end->expr_type != EXPR_CONSTANT
1875 2394 : || i->step->expr_type != EXPR_CONSTANT);
1876 : }
1877 :
1878 :
1879 : /* Split the size of constructor element EXPR into the sum of two terms,
1880 : one of which can be determined at compile time and one of which must
1881 : be calculated at run time. Set *SIZE to the former and return true
1882 : if the latter might be nonzero. */
1883 :
1884 : static bool
1885 3252 : gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
1886 : {
1887 3252 : if (expr->expr_type == EXPR_ARRAY)
1888 666 : return gfc_get_array_constructor_size (size, expr->value.constructor);
1889 2586 : else if (expr->rank > 0)
1890 : {
1891 : /* Calculate everything at run time. */
1892 1031 : mpz_set_ui (*size, 0);
1893 1031 : return true;
1894 : }
1895 : else
1896 : {
1897 : /* A single element. */
1898 1555 : mpz_set_ui (*size, 1);
1899 1555 : return false;
1900 : }
1901 : }
1902 :
1903 :
1904 : /* Like gfc_get_array_constructor_element_size, but applied to the whole
1905 : of array constructor C. */
1906 :
1907 : static bool
1908 2888 : gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base)
1909 : {
1910 2888 : gfc_constructor *c;
1911 2888 : gfc_iterator *i;
1912 2888 : mpz_t val;
1913 2888 : mpz_t len;
1914 2888 : bool dynamic;
1915 :
1916 2888 : mpz_set_ui (*size, 0);
1917 2888 : mpz_init (len);
1918 2888 : mpz_init (val);
1919 :
1920 2888 : dynamic = false;
1921 7124 : for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1922 : {
1923 4236 : i = c->iterator;
1924 4236 : if (i && gfc_iterator_has_dynamic_bounds (i))
1925 : dynamic = true;
1926 : else
1927 : {
1928 2720 : dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
1929 2720 : if (i)
1930 : {
1931 : /* Multiply the static part of the element size by the
1932 : number of iterations. */
1933 128 : mpz_sub (val, i->end->value.integer, i->start->value.integer);
1934 128 : mpz_fdiv_q (val, val, i->step->value.integer);
1935 128 : mpz_add_ui (val, val, 1);
1936 128 : if (mpz_sgn (val) > 0)
1937 92 : mpz_mul (len, len, val);
1938 : else
1939 36 : mpz_set_ui (len, 0);
1940 : }
1941 2720 : mpz_add (*size, *size, len);
1942 : }
1943 : }
1944 2888 : mpz_clear (len);
1945 2888 : mpz_clear (val);
1946 2888 : return dynamic;
1947 : }
1948 :
1949 :
1950 : /* Make sure offset is a variable. */
1951 :
1952 : static void
1953 3169 : gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
1954 : tree * offsetvar)
1955 : {
1956 : /* We should have already created the offset variable. We cannot
1957 : create it here because we may be in an inner scope. */
1958 3169 : gcc_assert (*offsetvar != NULL_TREE);
1959 3169 : gfc_add_modify (pblock, *offsetvar, *poffset);
1960 3169 : *poffset = *offsetvar;
1961 3169 : TREE_USED (*offsetvar) = 1;
1962 3169 : }
1963 :
1964 :
1965 : /* Variables needed for bounds-checking. */
1966 : static bool first_len;
1967 : static tree first_len_val;
1968 : static bool typespec_chararray_ctor;
1969 :
1970 : static void
1971 12289 : gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
1972 : tree offset, gfc_se * se, gfc_expr * expr)
1973 : {
1974 12289 : tree tmp, offset_eval;
1975 :
1976 12289 : gfc_conv_expr (se, expr);
1977 :
1978 : /* Store the value. */
1979 12289 : tmp = build_fold_indirect_ref_loc (input_location,
1980 : gfc_conv_descriptor_data_get (desc));
1981 : /* The offset may change, so get its value now and use that to free memory.
1982 : */
1983 12289 : offset_eval = gfc_evaluate_now (offset, &se->pre);
1984 12289 : tmp = gfc_build_array_ref (tmp, offset_eval, NULL);
1985 :
1986 12289 : if (expr->expr_type == EXPR_FUNCTION && expr->ts.type == BT_DERIVED
1987 66 : && expr->ts.u.derived->attr.alloc_comp)
1988 27 : gfc_add_expr_to_block (&se->finalblock,
1989 : gfc_deallocate_alloc_comp_no_caf (expr->ts.u.derived,
1990 : tmp, expr->rank,
1991 : true));
1992 :
1993 12289 : if (expr->ts.type == BT_CHARACTER)
1994 : {
1995 2140 : int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
1996 2140 : tree esize;
1997 :
1998 2140 : esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)));
1999 2140 : esize = fold_convert (gfc_charlen_type_node, esize);
2000 4280 : esize = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
2001 2140 : TREE_TYPE (esize), esize,
2002 2140 : build_int_cst (TREE_TYPE (esize),
2003 2140 : gfc_character_kinds[i].bit_size / 8));
2004 :
2005 2140 : gfc_conv_string_parameter (se);
2006 2140 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
2007 : {
2008 : /* The temporary is an array of pointers. */
2009 6 : se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
2010 6 : gfc_add_modify (&se->pre, tmp, se->expr);
2011 : }
2012 : else
2013 : {
2014 : /* The temporary is an array of string values. */
2015 2134 : tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp);
2016 : /* We know the temporary and the value will be the same length,
2017 : so can use memcpy. */
2018 2134 : gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind,
2019 : se->string_length, se->expr, expr->ts.kind);
2020 : }
2021 2140 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !typespec_chararray_ctor)
2022 : {
2023 310 : if (first_len)
2024 : {
2025 130 : gfc_add_modify (&se->pre, first_len_val,
2026 130 : fold_convert (TREE_TYPE (first_len_val),
2027 : se->string_length));
2028 130 : first_len = false;
2029 : }
2030 : else
2031 : {
2032 : /* Verify that all constructor elements are of the same
2033 : length. */
2034 180 : tree rhs = fold_convert (TREE_TYPE (first_len_val),
2035 : se->string_length);
2036 180 : tree cond = fold_build2_loc (input_location, NE_EXPR,
2037 : logical_type_node, first_len_val,
2038 : rhs);
2039 180 : gfc_trans_runtime_check
2040 180 : (true, false, cond, &se->pre, &expr->where,
2041 : "Different CHARACTER lengths (%ld/%ld) in array constructor",
2042 : fold_convert (long_integer_type_node, first_len_val),
2043 : fold_convert (long_integer_type_node, se->string_length));
2044 : }
2045 : }
2046 : }
2047 10149 : else if (GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
2048 10149 : && !GFC_CLASS_TYPE_P (gfc_get_element_type (TREE_TYPE (desc))))
2049 : {
2050 : /* Assignment of a CLASS array constructor to a derived type array. */
2051 24 : if (expr->expr_type == EXPR_FUNCTION)
2052 18 : se->expr = gfc_evaluate_now (se->expr, pblock);
2053 24 : se->expr = gfc_class_data_get (se->expr);
2054 24 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
2055 24 : se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
2056 24 : gfc_add_modify (&se->pre, tmp, se->expr);
2057 : }
2058 : else
2059 : {
2060 : /* TODO: Should the frontend already have done this conversion? */
2061 10125 : se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
2062 10125 : gfc_add_modify (&se->pre, tmp, se->expr);
2063 : }
2064 :
2065 12289 : gfc_add_block_to_block (pblock, &se->pre);
2066 12289 : gfc_add_block_to_block (pblock, &se->post);
2067 12289 : }
2068 :
2069 :
2070 : /* Add the contents of an array to the constructor. DYNAMIC is as for
2071 : gfc_trans_array_constructor_value. */
2072 :
2073 : static void
2074 1117 : gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
2075 : tree type ATTRIBUTE_UNUSED,
2076 : tree desc, gfc_expr * expr,
2077 : tree * poffset, tree * offsetvar,
2078 : bool dynamic)
2079 : {
2080 1117 : gfc_se se;
2081 1117 : gfc_ss *ss;
2082 1117 : gfc_loopinfo loop;
2083 1117 : stmtblock_t body;
2084 1117 : tree tmp;
2085 1117 : tree size;
2086 1117 : int n;
2087 :
2088 : /* We need this to be a variable so we can increment it. */
2089 1117 : gfc_put_offset_into_var (pblock, poffset, offsetvar);
2090 :
2091 1117 : gfc_init_se (&se, NULL);
2092 :
2093 : /* Walk the array expression. */
2094 1117 : ss = gfc_walk_expr (expr);
2095 1117 : gcc_assert (ss != gfc_ss_terminator);
2096 :
2097 : /* Initialize the scalarizer. */
2098 1117 : gfc_init_loopinfo (&loop);
2099 1117 : gfc_add_ss_to_loop (&loop, ss);
2100 :
2101 : /* Initialize the loop. */
2102 1117 : gfc_conv_ss_startstride (&loop);
2103 1117 : gfc_conv_loop_setup (&loop, &expr->where);
2104 :
2105 : /* Make sure the constructed array has room for the new data. */
2106 1117 : if (dynamic)
2107 : {
2108 : /* Set SIZE to the total number of elements in the subarray. */
2109 515 : size = gfc_index_one_node;
2110 1042 : for (n = 0; n < loop.dimen; n++)
2111 : {
2112 527 : tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
2113 : gfc_index_one_node);
2114 527 : size = fold_build2_loc (input_location, MULT_EXPR,
2115 : gfc_array_index_type, size, tmp);
2116 : }
2117 :
2118 : /* Grow the constructed array by SIZE elements. */
2119 515 : gfc_grow_array (&loop.pre, desc, size);
2120 : }
2121 :
2122 : /* Make the loop body. */
2123 1117 : gfc_mark_ss_chain_used (ss, 1);
2124 1117 : gfc_start_scalarized_body (&loop, &body);
2125 1117 : gfc_copy_loopinfo_to_se (&se, &loop);
2126 1117 : se.ss = ss;
2127 :
2128 1117 : gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
2129 1117 : gcc_assert (se.ss == gfc_ss_terminator);
2130 :
2131 : /* Increment the offset. */
2132 1117 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2133 : *poffset, gfc_index_one_node);
2134 1117 : gfc_add_modify (&body, *poffset, tmp);
2135 :
2136 : /* Finish the loop. */
2137 1117 : gfc_trans_scalarizing_loops (&loop, &body);
2138 1117 : gfc_add_block_to_block (&loop.pre, &loop.post);
2139 1117 : tmp = gfc_finish_block (&loop.pre);
2140 1117 : gfc_add_expr_to_block (pblock, tmp);
2141 :
2142 1117 : gfc_cleanup_loop (&loop);
2143 1117 : }
2144 :
2145 :
2146 : /* Assign the values to the elements of an array constructor. DYNAMIC
2147 : is true if descriptor DESC only contains enough data for the static
2148 : size calculated by gfc_get_array_constructor_size. When true, memory
2149 : for the dynamic parts must be allocated using realloc. */
2150 :
2151 : static void
2152 7964 : gfc_trans_array_constructor_value (stmtblock_t * pblock,
2153 : stmtblock_t * finalblock,
2154 : tree type, tree desc,
2155 : gfc_constructor_base base, tree * poffset,
2156 : tree * offsetvar, bool dynamic)
2157 : {
2158 7964 : tree tmp;
2159 7964 : tree start = NULL_TREE;
2160 7964 : tree end = NULL_TREE;
2161 7964 : tree step = NULL_TREE;
2162 7964 : stmtblock_t body;
2163 7964 : gfc_se se;
2164 7964 : mpz_t size;
2165 7964 : gfc_constructor *c;
2166 7964 : gfc_typespec ts;
2167 7964 : int ctr = 0;
2168 :
2169 7964 : tree shadow_loopvar = NULL_TREE;
2170 7964 : gfc_saved_var saved_loopvar;
2171 :
2172 7964 : ts.type = BT_UNKNOWN;
2173 7964 : mpz_init (size);
2174 21715 : for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
2175 : {
2176 13751 : ctr++;
2177 : /* If this is an iterator or an array, the offset must be a variable. */
2178 13751 : if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
2179 2052 : gfc_put_offset_into_var (pblock, poffset, offsetvar);
2180 :
2181 : /* Shadowing the iterator avoids changing its value and saves us from
2182 : keeping track of it. Further, it makes sure that there's always a
2183 : backend-decl for the symbol, even if there wasn't one before,
2184 : e.g. in the case of an iterator that appears in a specification
2185 : expression in an interface mapping. */
2186 13751 : if (c->iterator)
2187 : {
2188 1347 : gfc_symbol *sym;
2189 1347 : tree type;
2190 :
2191 : /* Evaluate loop bounds before substituting the loop variable
2192 : in case they depend on it. Such a case is invalid, but it is
2193 : not more expensive to do the right thing here.
2194 : See PR 44354. */
2195 1347 : gfc_init_se (&se, NULL);
2196 1347 : gfc_conv_expr_val (&se, c->iterator->start);
2197 1347 : gfc_add_block_to_block (pblock, &se.pre);
2198 1347 : start = gfc_evaluate_now (se.expr, pblock);
2199 :
2200 1347 : gfc_init_se (&se, NULL);
2201 1347 : gfc_conv_expr_val (&se, c->iterator->end);
2202 1347 : gfc_add_block_to_block (pblock, &se.pre);
2203 1347 : end = gfc_evaluate_now (se.expr, pblock);
2204 :
2205 1347 : gfc_init_se (&se, NULL);
2206 1347 : gfc_conv_expr_val (&se, c->iterator->step);
2207 1347 : gfc_add_block_to_block (pblock, &se.pre);
2208 1347 : step = gfc_evaluate_now (se.expr, pblock);
2209 :
2210 1347 : sym = c->iterator->var->symtree->n.sym;
2211 1347 : type = gfc_typenode_for_spec (&sym->ts);
2212 :
2213 1347 : shadow_loopvar = gfc_create_var (type, "shadow_loopvar");
2214 1347 : gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar);
2215 : }
2216 :
2217 13751 : gfc_start_block (&body);
2218 :
2219 13751 : if (c->expr->expr_type == EXPR_ARRAY)
2220 : {
2221 : /* Array constructors can be nested. */
2222 1357 : gfc_trans_array_constructor_value (&body, finalblock, type,
2223 : desc, c->expr->value.constructor,
2224 : poffset, offsetvar, dynamic);
2225 : }
2226 12394 : else if (c->expr->rank > 0)
2227 : {
2228 1117 : gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
2229 : poffset, offsetvar, dynamic);
2230 : }
2231 : else
2232 : {
2233 : /* This code really upsets the gimplifier so don't bother for now. */
2234 : gfc_constructor *p;
2235 : HOST_WIDE_INT n;
2236 : HOST_WIDE_INT size;
2237 :
2238 : p = c;
2239 : n = 0;
2240 13082 : while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
2241 : {
2242 1805 : p = gfc_constructor_next (p);
2243 1805 : n++;
2244 : }
2245 : /* Constructor with few constant elements, or element size not
2246 : known at compile time (e.g. deferred-length character). */
2247 11277 : if (n < 4 || !INTEGER_CST_P (TYPE_SIZE_UNIT (type)))
2248 : {
2249 : /* Scalar values. */
2250 11172 : gfc_init_se (&se, NULL);
2251 11172 : if (IS_PDT (c->expr) && c->expr->expr_type == EXPR_STRUCTURE)
2252 276 : c->expr->must_finalize = 1;
2253 :
2254 11172 : gfc_trans_array_ctor_element (&body, desc, *poffset,
2255 : &se, c->expr);
2256 :
2257 11172 : *poffset = fold_build2_loc (input_location, PLUS_EXPR,
2258 : gfc_array_index_type,
2259 : *poffset, gfc_index_one_node);
2260 11172 : if (finalblock)
2261 1244 : gfc_add_block_to_block (finalblock, &se.finalblock);
2262 : }
2263 : else
2264 : {
2265 : /* Collect multiple scalar constants into a constructor. */
2266 105 : vec<constructor_elt, va_gc> *v = NULL;
2267 105 : tree init;
2268 105 : tree bound;
2269 105 : tree tmptype;
2270 105 : HOST_WIDE_INT idx = 0;
2271 :
2272 105 : p = c;
2273 : /* Count the number of consecutive scalar constants. */
2274 837 : while (p && !(p->iterator
2275 745 : || p->expr->expr_type != EXPR_CONSTANT))
2276 : {
2277 732 : gfc_init_se (&se, NULL);
2278 732 : gfc_conv_constant (&se, p->expr);
2279 :
2280 732 : if (c->expr->ts.type != BT_CHARACTER)
2281 660 : se.expr = fold_convert (type, se.expr);
2282 : /* For constant character array constructors we build
2283 : an array of pointers. */
2284 72 : else if (POINTER_TYPE_P (type))
2285 0 : se.expr = gfc_build_addr_expr
2286 0 : (gfc_get_pchar_type (p->expr->ts.kind),
2287 : se.expr);
2288 :
2289 732 : CONSTRUCTOR_APPEND_ELT (v,
2290 : build_int_cst (gfc_array_index_type,
2291 : idx++),
2292 : se.expr);
2293 732 : c = p;
2294 732 : p = gfc_constructor_next (p);
2295 : }
2296 :
2297 105 : bound = size_int (n - 1);
2298 : /* Create an array type to hold them. */
2299 105 : tmptype = build_range_type (gfc_array_index_type,
2300 : gfc_index_zero_node, bound);
2301 105 : tmptype = build_array_type (type, tmptype);
2302 :
2303 105 : init = build_constructor (tmptype, v);
2304 105 : TREE_CONSTANT (init) = 1;
2305 105 : TREE_STATIC (init) = 1;
2306 : /* Create a static variable to hold the data. */
2307 105 : tmp = gfc_create_var (tmptype, "data");
2308 105 : TREE_STATIC (tmp) = 1;
2309 105 : TREE_CONSTANT (tmp) = 1;
2310 105 : TREE_READONLY (tmp) = 1;
2311 105 : DECL_INITIAL (tmp) = init;
2312 105 : init = tmp;
2313 :
2314 : /* Use BUILTIN_MEMCPY to assign the values. */
2315 105 : tmp = gfc_conv_descriptor_data_get (desc);
2316 105 : tmp = build_fold_indirect_ref_loc (input_location,
2317 : tmp);
2318 105 : tmp = gfc_build_array_ref (tmp, *poffset, NULL);
2319 105 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
2320 105 : init = gfc_build_addr_expr (NULL_TREE, init);
2321 :
2322 105 : size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
2323 105 : bound = build_int_cst (size_type_node, n * size);
2324 105 : tmp = build_call_expr_loc (input_location,
2325 : builtin_decl_explicit (BUILT_IN_MEMCPY),
2326 : 3, tmp, init, bound);
2327 105 : gfc_add_expr_to_block (&body, tmp);
2328 :
2329 105 : *poffset = fold_build2_loc (input_location, PLUS_EXPR,
2330 : gfc_array_index_type, *poffset,
2331 105 : build_int_cst (gfc_array_index_type, n));
2332 : }
2333 11277 : if (!INTEGER_CST_P (*poffset))
2334 : {
2335 1661 : gfc_add_modify (&body, *offsetvar, *poffset);
2336 1661 : *poffset = *offsetvar;
2337 : }
2338 :
2339 11277 : if (!c->iterator)
2340 11277 : ts = c->expr->ts;
2341 : }
2342 :
2343 : /* The frontend should already have done any expansions
2344 : at compile-time. */
2345 13751 : if (!c->iterator)
2346 : {
2347 : /* Pass the code as is. */
2348 12404 : tmp = gfc_finish_block (&body);
2349 12404 : gfc_add_expr_to_block (pblock, tmp);
2350 : }
2351 : else
2352 : {
2353 : /* Build the implied do-loop. */
2354 1347 : stmtblock_t implied_do_block;
2355 1347 : tree cond;
2356 1347 : tree exit_label;
2357 1347 : tree loopbody;
2358 1347 : tree tmp2;
2359 :
2360 1347 : loopbody = gfc_finish_block (&body);
2361 :
2362 : /* Create a new block that holds the implied-do loop. A temporary
2363 : loop-variable is used. */
2364 1347 : gfc_start_block(&implied_do_block);
2365 :
2366 : /* Initialize the loop. */
2367 1347 : gfc_add_modify (&implied_do_block, shadow_loopvar, start);
2368 :
2369 : /* If this array expands dynamically, and the number of iterations
2370 : is not constant, we won't have allocated space for the static
2371 : part of C->EXPR's size. Do that now. */
2372 1347 : if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
2373 : {
2374 : /* Get the number of iterations. */
2375 532 : tmp = gfc_get_iteration_count (shadow_loopvar, end, step);
2376 :
2377 : /* Get the static part of C->EXPR's size. */
2378 532 : gfc_get_array_constructor_element_size (&size, c->expr);
2379 532 : tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
2380 :
2381 : /* Grow the array by TMP * TMP2 elements. */
2382 532 : tmp = fold_build2_loc (input_location, MULT_EXPR,
2383 : gfc_array_index_type, tmp, tmp2);
2384 532 : gfc_grow_array (&implied_do_block, desc, tmp);
2385 : }
2386 :
2387 : /* Generate the loop body. */
2388 1347 : exit_label = gfc_build_label_decl (NULL_TREE);
2389 1347 : gfc_start_block (&body);
2390 :
2391 : /* Generate the exit condition. Depending on the sign of
2392 : the step variable we have to generate the correct
2393 : comparison. */
2394 1347 : tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2395 1347 : step, build_int_cst (TREE_TYPE (step), 0));
2396 1347 : cond = fold_build3_loc (input_location, COND_EXPR,
2397 : logical_type_node, tmp,
2398 : fold_build2_loc (input_location, GT_EXPR,
2399 : logical_type_node, shadow_loopvar, end),
2400 : fold_build2_loc (input_location, LT_EXPR,
2401 : logical_type_node, shadow_loopvar, end));
2402 1347 : tmp = build1_v (GOTO_EXPR, exit_label);
2403 1347 : TREE_USED (exit_label) = 1;
2404 1347 : tmp = build3_v (COND_EXPR, cond, tmp,
2405 : build_empty_stmt (input_location));
2406 1347 : gfc_add_expr_to_block (&body, tmp);
2407 :
2408 : /* The main loop body. */
2409 1347 : gfc_add_expr_to_block (&body, loopbody);
2410 :
2411 : /* Increase loop variable by step. */
2412 1347 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
2413 1347 : TREE_TYPE (shadow_loopvar), shadow_loopvar,
2414 : step);
2415 1347 : gfc_add_modify (&body, shadow_loopvar, tmp);
2416 :
2417 : /* Finish the loop. */
2418 1347 : tmp = gfc_finish_block (&body);
2419 1347 : tmp = build1_v (LOOP_EXPR, tmp);
2420 1347 : gfc_add_expr_to_block (&implied_do_block, tmp);
2421 :
2422 : /* Add the exit label. */
2423 1347 : tmp = build1_v (LABEL_EXPR, exit_label);
2424 1347 : gfc_add_expr_to_block (&implied_do_block, tmp);
2425 :
2426 : /* Finish the implied-do loop. */
2427 1347 : tmp = gfc_finish_block(&implied_do_block);
2428 1347 : gfc_add_expr_to_block(pblock, tmp);
2429 :
2430 1347 : gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar);
2431 : }
2432 : }
2433 :
2434 : /* F2008 4.5.6.3 para 5: If an executable construct references a structure
2435 : constructor or array constructor, the entity created by the constructor is
2436 : finalized after execution of the innermost executable construct containing
2437 : the reference. This, in fact, was later deleted by the Combined Techical
2438 : Corrigenda 1 TO 4 for fortran 2008 (f08/0011).
2439 :
2440 : Transmit finalization of this constructor through 'finalblock'. */
2441 7964 : if ((gfc_option.allow_std & (GFC_STD_F2008 | GFC_STD_F2003))
2442 7964 : && !(gfc_option.allow_std & GFC_STD_GNU)
2443 70 : && finalblock != NULL
2444 24 : && gfc_may_be_finalized (ts)
2445 18 : && ctr > 0 && desc != NULL_TREE
2446 7982 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
2447 : {
2448 18 : symbol_attribute attr;
2449 18 : gfc_se fse;
2450 18 : locus loc;
2451 18 : gfc_locus_from_location (&loc, input_location);
2452 18 : gfc_warning (0, "The structure constructor at %L has been"
2453 : " finalized. This feature was removed by f08/0011."
2454 : " Use -std=f2018 or -std=gnu to eliminate the"
2455 : " finalization.", &loc);
2456 18 : attr.pointer = attr.allocatable = 0;
2457 18 : gfc_init_se (&fse, NULL);
2458 18 : fse.expr = desc;
2459 18 : gfc_finalize_tree_expr (&fse, ts.u.derived, attr, 1);
2460 18 : gfc_add_block_to_block (finalblock, &fse.pre);
2461 18 : gfc_add_block_to_block (finalblock, &fse.finalblock);
2462 18 : gfc_add_block_to_block (finalblock, &fse.post);
2463 : }
2464 :
2465 7964 : mpz_clear (size);
2466 7964 : }
2467 :
2468 :
2469 : /* The array constructor code can create a string length with an operand
2470 : in the form of a temporary variable. This variable will retain its
2471 : context (current_function_decl). If we store this length tree in a
2472 : gfc_charlen structure which is shared by a variable in another
2473 : context, the resulting gfc_charlen structure with a variable in a
2474 : different context, we could trip the assertion in expand_expr_real_1
2475 : when it sees that a variable has been created in one context and
2476 : referenced in another.
2477 :
2478 : If this might be the case, we create a new gfc_charlen structure and
2479 : link it into the current namespace. */
2480 :
2481 : static void
2482 8419 : store_backend_decl (gfc_charlen **clp, tree len, bool force_new_cl)
2483 : {
2484 8419 : if (force_new_cl)
2485 : {
2486 8392 : gfc_charlen *new_cl = gfc_new_charlen (gfc_current_ns, *clp);
2487 8392 : *clp = new_cl;
2488 : }
2489 8419 : (*clp)->backend_decl = len;
2490 8419 : }
2491 :
2492 : /* A catch-all to obtain the string length for anything that is not
2493 : a substring of non-constant length, a constant, array or variable. */
2494 :
2495 : static void
2496 330 : get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
2497 : {
2498 330 : gfc_se se;
2499 :
2500 : /* Don't bother if we already know the length is a constant. */
2501 330 : if (*len && INTEGER_CST_P (*len))
2502 52 : return;
2503 :
2504 278 : if (!e->ref && e->ts.u.cl && e->ts.u.cl->length
2505 29 : && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
2506 : {
2507 : /* This is easy. */
2508 1 : gfc_conv_const_charlen (e->ts.u.cl);
2509 1 : *len = e->ts.u.cl->backend_decl;
2510 : }
2511 : else
2512 : {
2513 : /* Otherwise, be brutal even if inefficient. */
2514 277 : gfc_init_se (&se, NULL);
2515 :
2516 : /* No function call, in case of side effects. */
2517 277 : se.no_function_call = 1;
2518 277 : if (e->rank == 0)
2519 134 : gfc_conv_expr (&se, e);
2520 : else
2521 143 : gfc_conv_expr_descriptor (&se, e);
2522 :
2523 : /* Fix the value. */
2524 277 : *len = gfc_evaluate_now (se.string_length, &se.pre);
2525 :
2526 277 : gfc_add_block_to_block (block, &se.pre);
2527 277 : gfc_add_block_to_block (block, &se.post);
2528 :
2529 277 : store_backend_decl (&e->ts.u.cl, *len, true);
2530 : }
2531 : }
2532 :
2533 :
2534 : /* Figure out the string length of a variable reference expression.
2535 : Used by get_array_ctor_strlen. */
2536 :
2537 : static void
2538 930 : get_array_ctor_var_strlen (stmtblock_t *block, gfc_expr * expr, tree * len)
2539 : {
2540 930 : gfc_ref *ref;
2541 930 : gfc_typespec *ts;
2542 930 : mpz_t char_len;
2543 930 : gfc_se se;
2544 :
2545 : /* Don't bother if we already know the length is a constant. */
2546 930 : if (*len && INTEGER_CST_P (*len))
2547 557 : return;
2548 :
2549 468 : ts = &expr->symtree->n.sym->ts;
2550 747 : for (ref = expr->ref; ref; ref = ref->next)
2551 : {
2552 374 : switch (ref->type)
2553 : {
2554 234 : case REF_ARRAY:
2555 : /* Array references don't change the string length. */
2556 234 : if (ts->deferred)
2557 136 : get_array_ctor_all_strlen (block, expr, len);
2558 : break;
2559 :
2560 45 : case REF_COMPONENT:
2561 : /* Use the length of the component. */
2562 45 : ts = &ref->u.c.component->ts;
2563 45 : break;
2564 :
2565 95 : case REF_SUBSTRING:
2566 95 : if (ref->u.ss.end == NULL
2567 83 : || ref->u.ss.start->expr_type != EXPR_CONSTANT
2568 64 : || ref->u.ss.end->expr_type != EXPR_CONSTANT)
2569 : {
2570 : /* Note that this might evaluate expr. */
2571 64 : get_array_ctor_all_strlen (block, expr, len);
2572 64 : return;
2573 : }
2574 31 : mpz_init_set_ui (char_len, 1);
2575 31 : mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
2576 31 : mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
2577 31 : *len = gfc_conv_mpz_to_tree_type (char_len, gfc_charlen_type_node);
2578 31 : mpz_clear (char_len);
2579 31 : return;
2580 :
2581 : case REF_INQUIRY:
2582 : break;
2583 :
2584 0 : default:
2585 0 : gcc_unreachable ();
2586 : }
2587 : }
2588 :
2589 : /* A last ditch attempt that is sometimes needed for deferred characters. */
2590 373 : if (!ts->u.cl->backend_decl)
2591 : {
2592 19 : gfc_init_se (&se, NULL);
2593 19 : if (expr->rank)
2594 12 : gfc_conv_expr_descriptor (&se, expr);
2595 : else
2596 7 : gfc_conv_expr (&se, expr);
2597 19 : gcc_assert (se.string_length != NULL_TREE);
2598 19 : gfc_add_block_to_block (block, &se.pre);
2599 19 : ts->u.cl->backend_decl = se.string_length;
2600 : }
2601 :
2602 373 : *len = ts->u.cl->backend_decl;
2603 : }
2604 :
2605 :
2606 : /* Figure out the string length of a character array constructor.
2607 : If len is NULL, don't calculate the length; this happens for recursive calls
2608 : when a sub-array-constructor is an element but not at the first position,
2609 : so when we're not interested in the length.
2610 : Returns TRUE if all elements are character constants. */
2611 :
2612 : bool
2613 8850 : get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len)
2614 : {
2615 8850 : gfc_constructor *c;
2616 8850 : bool is_const;
2617 :
2618 8850 : is_const = true;
2619 :
2620 8850 : if (gfc_constructor_first (base) == NULL)
2621 : {
2622 315 : if (len)
2623 315 : *len = build_int_cstu (gfc_charlen_type_node, 0);
2624 315 : return is_const;
2625 : }
2626 :
2627 : /* Loop over all constructor elements to find out is_const, but in len we
2628 : want to store the length of the first, not the last, element. We can
2629 : of course exit the loop as soon as is_const is found to be false. */
2630 8535 : for (c = gfc_constructor_first (base);
2631 46390 : c && is_const; c = gfc_constructor_next (c))
2632 : {
2633 37855 : switch (c->expr->expr_type)
2634 : {
2635 36692 : case EXPR_CONSTANT:
2636 36692 : if (len && !(*len && INTEGER_CST_P (*len)))
2637 404 : *len = build_int_cstu (gfc_charlen_type_node,
2638 404 : c->expr->value.character.length);
2639 : break;
2640 :
2641 43 : case EXPR_ARRAY:
2642 43 : if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
2643 1151 : is_const = false;
2644 : break;
2645 :
2646 990 : case EXPR_VARIABLE:
2647 990 : is_const = false;
2648 990 : if (len)
2649 930 : get_array_ctor_var_strlen (block, c->expr, len);
2650 : break;
2651 :
2652 130 : default:
2653 130 : is_const = false;
2654 130 : if (len)
2655 130 : get_array_ctor_all_strlen (block, c->expr, len);
2656 : break;
2657 : }
2658 :
2659 : /* After the first iteration, we don't want the length modified. */
2660 37855 : len = NULL;
2661 : }
2662 :
2663 : return is_const;
2664 : }
2665 :
2666 : /* Check whether the array constructor C consists entirely of constant
2667 : elements, and if so returns the number of those elements, otherwise
2668 : return zero. Note, an empty or NULL array constructor returns zero. */
2669 :
2670 : unsigned HOST_WIDE_INT
2671 58166 : gfc_constant_array_constructor_p (gfc_constructor_base base)
2672 : {
2673 58166 : unsigned HOST_WIDE_INT nelem = 0;
2674 :
2675 58166 : gfc_constructor *c = gfc_constructor_first (base);
2676 512467 : while (c)
2677 : {
2678 402917 : if (c->iterator
2679 401493 : || c->expr->rank > 0
2680 400695 : || c->expr->expr_type != EXPR_CONSTANT)
2681 : return 0;
2682 396135 : c = gfc_constructor_next (c);
2683 396135 : nelem++;
2684 : }
2685 : return nelem;
2686 : }
2687 :
2688 :
2689 : /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
2690 : and the tree type of it's elements, TYPE, return a static constant
2691 : variable that is compile-time initialized. */
2692 :
2693 : tree
2694 41164 : gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
2695 : {
2696 41164 : tree tmptype, init, tmp;
2697 41164 : HOST_WIDE_INT nelem;
2698 41164 : gfc_constructor *c;
2699 41164 : gfc_array_spec as;
2700 41164 : gfc_se se;
2701 41164 : int i;
2702 41164 : vec<constructor_elt, va_gc> *v = NULL;
2703 :
2704 : /* First traverse the constructor list, converting the constants
2705 : to tree to build an initializer. */
2706 41164 : nelem = 0;
2707 41164 : c = gfc_constructor_first (expr->value.constructor);
2708 398604 : while (c)
2709 : {
2710 316276 : gfc_init_se (&se, NULL);
2711 316276 : gfc_conv_constant (&se, c->expr);
2712 316276 : if (c->expr->ts.type != BT_CHARACTER)
2713 280504 : se.expr = fold_convert (type, se.expr);
2714 35772 : else if (POINTER_TYPE_P (type))
2715 35772 : se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
2716 : se.expr);
2717 316276 : CONSTRUCTOR_APPEND_ELT (v, build_int_cst (gfc_array_index_type, nelem),
2718 : se.expr);
2719 316276 : c = gfc_constructor_next (c);
2720 316276 : nelem++;
2721 : }
2722 :
2723 : /* Next determine the tree type for the array. We use the gfortran
2724 : front-end's gfc_get_nodesc_array_type in order to create a suitable
2725 : GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
2726 :
2727 41164 : memset (&as, 0, sizeof (gfc_array_spec));
2728 :
2729 41164 : as.rank = expr->rank;
2730 41164 : as.type = AS_EXPLICIT;
2731 41164 : if (!expr->shape)
2732 : {
2733 4 : as.lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
2734 4 : as.upper[0] = gfc_get_int_expr (gfc_default_integer_kind,
2735 : NULL, nelem - 1);
2736 : }
2737 : else
2738 88879 : for (i = 0; i < expr->rank; i++)
2739 : {
2740 47719 : int tmp = (int) mpz_get_si (expr->shape[i]);
2741 47719 : as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
2742 47719 : as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind,
2743 47719 : NULL, tmp - 1);
2744 : }
2745 :
2746 41164 : tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
2747 :
2748 : /* as is not needed anymore. */
2749 130051 : for (i = 0; i < as.rank + as.corank; i++)
2750 : {
2751 47723 : gfc_free_expr (as.lower[i]);
2752 47723 : gfc_free_expr (as.upper[i]);
2753 : }
2754 :
2755 41164 : init = build_constructor (tmptype, v);
2756 :
2757 41164 : TREE_CONSTANT (init) = 1;
2758 41164 : TREE_STATIC (init) = 1;
2759 :
2760 41164 : tmp = build_decl (input_location, VAR_DECL, create_tmp_var_name ("A"),
2761 : tmptype);
2762 41164 : DECL_ARTIFICIAL (tmp) = 1;
2763 41164 : DECL_IGNORED_P (tmp) = 1;
2764 41164 : TREE_STATIC (tmp) = 1;
2765 41164 : TREE_CONSTANT (tmp) = 1;
2766 41164 : TREE_READONLY (tmp) = 1;
2767 41164 : DECL_INITIAL (tmp) = init;
2768 41164 : pushdecl (tmp);
2769 :
2770 41164 : return tmp;
2771 : }
2772 :
2773 :
2774 : /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
2775 : This mostly initializes the scalarizer state info structure with the
2776 : appropriate values to directly use the array created by the function
2777 : gfc_build_constant_array_constructor. */
2778 :
2779 : static void
2780 35452 : trans_constant_array_constructor (gfc_ss * ss, tree type)
2781 : {
2782 35452 : gfc_array_info *info;
2783 35452 : tree tmp;
2784 35452 : int i;
2785 :
2786 35452 : tmp = gfc_build_constant_array_constructor (ss->info->expr, type);
2787 :
2788 35452 : info = &ss->info->data.array;
2789 :
2790 35452 : info->descriptor = tmp;
2791 35452 : info->data = gfc_build_addr_expr (NULL_TREE, tmp);
2792 35452 : info->offset = gfc_index_zero_node;
2793 :
2794 74663 : for (i = 0; i < ss->dimen; i++)
2795 : {
2796 39211 : info->delta[i] = gfc_index_zero_node;
2797 39211 : info->start[i] = gfc_index_zero_node;
2798 39211 : info->end[i] = gfc_index_zero_node;
2799 39211 : info->stride[i] = gfc_index_one_node;
2800 : }
2801 35452 : }
2802 :
2803 :
2804 : static int
2805 35458 : get_rank (gfc_loopinfo *loop)
2806 : {
2807 35458 : int rank;
2808 :
2809 35458 : rank = 0;
2810 152350 : for (; loop; loop = loop->parent)
2811 76181 : rank += loop->dimen;
2812 :
2813 40711 : return rank;
2814 : }
2815 :
2816 :
2817 : /* Helper routine of gfc_trans_array_constructor to determine if the
2818 : bounds of the loop specified by LOOP are constant and simple enough
2819 : to use with trans_constant_array_constructor. Returns the
2820 : iteration count of the loop if suitable, and NULL_TREE otherwise. */
2821 :
2822 : static tree
2823 35458 : constant_array_constructor_loop_size (gfc_loopinfo * l)
2824 : {
2825 35458 : gfc_loopinfo *loop;
2826 35458 : tree size = gfc_index_one_node;
2827 35458 : tree tmp;
2828 35458 : int i, total_dim;
2829 :
2830 35458 : total_dim = get_rank (l);
2831 :
2832 70916 : for (loop = l; loop; loop = loop->parent)
2833 : {
2834 74687 : for (i = 0; i < loop->dimen; i++)
2835 : {
2836 : /* If the bounds aren't constant, return NULL_TREE. */
2837 39229 : if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
2838 : return NULL_TREE;
2839 39223 : if (!integer_zerop (loop->from[i]))
2840 : {
2841 : /* Only allow nonzero "from" in one-dimensional arrays. */
2842 0 : if (total_dim != 1)
2843 : return NULL_TREE;
2844 0 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2845 : gfc_array_index_type,
2846 : loop->to[i], loop->from[i]);
2847 : }
2848 : else
2849 39223 : tmp = loop->to[i];
2850 39223 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
2851 : gfc_array_index_type, tmp, gfc_index_one_node);
2852 39223 : size = fold_build2_loc (input_location, MULT_EXPR,
2853 : gfc_array_index_type, size, tmp);
2854 : }
2855 : }
2856 :
2857 : return size;
2858 : }
2859 :
2860 :
2861 : static tree *
2862 42059 : get_loop_upper_bound_for_array (gfc_ss *array, int array_dim)
2863 : {
2864 42059 : gfc_ss *ss;
2865 42059 : int n;
2866 :
2867 42059 : gcc_assert (array->nested_ss == NULL);
2868 :
2869 42059 : for (ss = array; ss; ss = ss->parent)
2870 42059 : for (n = 0; n < ss->loop->dimen; n++)
2871 42059 : if (array_dim == get_array_ref_dim_for_loop_dim (ss, n))
2872 42059 : return &(ss->loop->to[n]);
2873 :
2874 0 : gcc_unreachable ();
2875 : }
2876 :
2877 :
2878 : static gfc_loopinfo *
2879 695753 : outermost_loop (gfc_loopinfo * loop)
2880 : {
2881 901647 : while (loop->parent != NULL)
2882 : loop = loop->parent;
2883 :
2884 695753 : return loop;
2885 : }
2886 :
2887 :
2888 : /* Array constructors are handled by constructing a temporary, then using that
2889 : within the scalarization loop. This is not optimal, but seems by far the
2890 : simplest method. */
2891 :
2892 : static void
2893 42059 : trans_array_constructor (gfc_ss * ss, locus * where)
2894 : {
2895 42059 : gfc_constructor_base c;
2896 42059 : tree offset;
2897 42059 : tree offsetvar;
2898 42059 : tree desc;
2899 42059 : tree type;
2900 42059 : tree tmp;
2901 42059 : tree *loop_ubound0;
2902 42059 : bool dynamic;
2903 42059 : bool old_first_len, old_typespec_chararray_ctor;
2904 42059 : tree old_first_len_val;
2905 42059 : gfc_loopinfo *loop, *outer_loop;
2906 42059 : gfc_ss_info *ss_info;
2907 42059 : gfc_expr *expr;
2908 42059 : gfc_ss *s;
2909 42059 : tree neg_len;
2910 42059 : char *msg;
2911 42059 : stmtblock_t finalblock;
2912 42059 : bool finalize_required;
2913 :
2914 : /* Save the old values for nested checking. */
2915 42059 : old_first_len = first_len;
2916 42059 : old_first_len_val = first_len_val;
2917 42059 : old_typespec_chararray_ctor = typespec_chararray_ctor;
2918 :
2919 42059 : loop = ss->loop;
2920 42059 : outer_loop = outermost_loop (loop);
2921 42059 : ss_info = ss->info;
2922 42059 : expr = ss_info->expr;
2923 :
2924 : /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
2925 : typespec was given for the array constructor. */
2926 84118 : typespec_chararray_ctor = (expr->ts.type == BT_CHARACTER
2927 8142 : && expr->ts.u.cl
2928 50201 : && expr->ts.u.cl->length_from_typespec);
2929 :
2930 42059 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2931 2542 : && expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
2932 : {
2933 1468 : first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
2934 1468 : first_len = true;
2935 : }
2936 :
2937 42059 : gcc_assert (ss->dimen == ss->loop->dimen);
2938 :
2939 42059 : c = expr->value.constructor;
2940 42059 : if (expr->ts.type == BT_CHARACTER)
2941 : {
2942 8142 : bool const_string;
2943 8142 : bool force_new_cl = false;
2944 :
2945 : /* get_array_ctor_strlen walks the elements of the constructor, if a
2946 : typespec was given, we already know the string length and want the one
2947 : specified there. */
2948 8142 : if (typespec_chararray_ctor && expr->ts.u.cl->length
2949 500 : && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
2950 : {
2951 27 : gfc_se length_se;
2952 :
2953 27 : const_string = false;
2954 27 : gfc_init_se (&length_se, NULL);
2955 27 : gfc_conv_expr_type (&length_se, expr->ts.u.cl->length,
2956 : gfc_charlen_type_node);
2957 27 : ss_info->string_length = length_se.expr;
2958 :
2959 : /* Check if the character length is negative. If it is, then
2960 : set LEN = 0. */
2961 27 : neg_len = fold_build2_loc (input_location, LT_EXPR,
2962 : logical_type_node, ss_info->string_length,
2963 27 : build_zero_cst (TREE_TYPE
2964 : (ss_info->string_length)));
2965 : /* Print a warning if bounds checking is enabled. */
2966 27 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2967 : {
2968 18 : msg = xasprintf ("Negative character length treated as LEN = 0");
2969 18 : gfc_trans_runtime_check (false, true, neg_len, &length_se.pre,
2970 : where, msg);
2971 18 : free (msg);
2972 : }
2973 :
2974 27 : ss_info->string_length
2975 27 : = fold_build3_loc (input_location, COND_EXPR,
2976 : gfc_charlen_type_node, neg_len,
2977 : build_zero_cst
2978 27 : (TREE_TYPE (ss_info->string_length)),
2979 : ss_info->string_length);
2980 27 : ss_info->string_length = gfc_evaluate_now (ss_info->string_length,
2981 : &length_se.pre);
2982 27 : gfc_add_block_to_block (&outer_loop->pre, &length_se.pre);
2983 27 : gfc_add_block_to_block (&outer_loop->post, &length_se.post);
2984 27 : }
2985 : else
2986 : {
2987 8115 : const_string = get_array_ctor_strlen (&outer_loop->pre, c,
2988 : &ss_info->string_length);
2989 8115 : force_new_cl = true;
2990 :
2991 : /* Initialize "len" with string length for bounds checking. */
2992 8115 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2993 1486 : && !typespec_chararray_ctor
2994 1468 : && ss_info->string_length)
2995 : {
2996 1468 : gfc_se length_se;
2997 :
2998 1468 : gfc_init_se (&length_se, NULL);
2999 1468 : gfc_add_modify (&length_se.pre, first_len_val,
3000 1468 : fold_convert (TREE_TYPE (first_len_val),
3001 : ss_info->string_length));
3002 1468 : ss_info->string_length = gfc_evaluate_now (ss_info->string_length,
3003 : &length_se.pre);
3004 1468 : gfc_add_block_to_block (&outer_loop->pre, &length_se.pre);
3005 1468 : gfc_add_block_to_block (&outer_loop->post, &length_se.post);
3006 : }
3007 : }
3008 :
3009 : /* Complex character array constructors should have been taken care of
3010 : and not end up here. */
3011 8142 : gcc_assert (ss_info->string_length);
3012 :
3013 8142 : store_backend_decl (&expr->ts.u.cl, ss_info->string_length, force_new_cl);
3014 :
3015 8142 : type = gfc_get_character_type_len (expr->ts.kind, ss_info->string_length);
3016 8142 : if (const_string)
3017 7191 : type = build_pointer_type (type);
3018 : }
3019 : else
3020 33942 : type = gfc_typenode_for_spec (expr->ts.type == BT_CLASS
3021 25 : ? &CLASS_DATA (expr)->ts : &expr->ts);
3022 :
3023 : /* See if the constructor determines the loop bounds. */
3024 42059 : dynamic = false;
3025 :
3026 42059 : loop_ubound0 = get_loop_upper_bound_for_array (ss, 0);
3027 :
3028 82770 : if (expr->shape && get_rank (loop) > 1 && *loop_ubound0 == NULL_TREE)
3029 : {
3030 : /* We have a multidimensional parameter. */
3031 0 : for (s = ss; s; s = s->parent)
3032 : {
3033 : int n;
3034 0 : for (n = 0; n < s->loop->dimen; n++)
3035 : {
3036 0 : s->loop->from[n] = gfc_index_zero_node;
3037 0 : s->loop->to[n] = gfc_conv_mpz_to_tree (expr->shape[s->dim[n]],
3038 : gfc_index_integer_kind);
3039 0 : s->loop->to[n] = fold_build2_loc (input_location, MINUS_EXPR,
3040 : gfc_array_index_type,
3041 0 : s->loop->to[n],
3042 : gfc_index_one_node);
3043 : }
3044 : }
3045 : }
3046 :
3047 42059 : if (*loop_ubound0 == NULL_TREE)
3048 : {
3049 874 : mpz_t size;
3050 :
3051 : /* We should have a 1-dimensional, zero-based loop. */
3052 874 : gcc_assert (loop->parent == NULL && loop->nested == NULL);
3053 874 : gcc_assert (loop->dimen == 1);
3054 874 : gcc_assert (integer_zerop (loop->from[0]));
3055 :
3056 : /* Split the constructor size into a static part and a dynamic part.
3057 : Allocate the static size up-front and record whether the dynamic
3058 : size might be nonzero. */
3059 874 : mpz_init (size);
3060 874 : dynamic = gfc_get_array_constructor_size (&size, c);
3061 874 : mpz_sub_ui (size, size, 1);
3062 874 : loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
3063 874 : mpz_clear (size);
3064 : }
3065 :
3066 : /* Special case constant array constructors. */
3067 874 : if (!dynamic)
3068 : {
3069 41210 : unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
3070 41210 : if (nelem > 0)
3071 : {
3072 35458 : tree size = constant_array_constructor_loop_size (loop);
3073 35458 : if (size && compare_tree_int (size, nelem) == 0)
3074 : {
3075 35452 : trans_constant_array_constructor (ss, type);
3076 35452 : goto finish;
3077 : }
3078 : }
3079 : }
3080 :
3081 6607 : gfc_trans_create_temp_array (&outer_loop->pre, &outer_loop->post, ss, type,
3082 : NULL_TREE, dynamic, true, false, where);
3083 :
3084 6607 : desc = ss_info->data.array.descriptor;
3085 6607 : offset = gfc_index_zero_node;
3086 6607 : offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
3087 6607 : suppress_warning (offsetvar);
3088 6607 : TREE_USED (offsetvar) = 0;
3089 :
3090 6607 : gfc_init_block (&finalblock);
3091 6607 : finalize_required = expr->must_finalize;
3092 6607 : if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
3093 : finalize_required = true;
3094 :
3095 6607 : if (IS_PDT (expr))
3096 : finalize_required = true;
3097 :
3098 7055 : gfc_trans_array_constructor_value (&outer_loop->pre,
3099 : finalize_required ? &finalblock : NULL,
3100 : type, desc, c, &offset, &offsetvar,
3101 : dynamic);
3102 :
3103 : /* If the array grows dynamically, the upper bound of the loop variable
3104 : is determined by the array's final upper bound. */
3105 6607 : if (dynamic)
3106 : {
3107 849 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
3108 : gfc_array_index_type,
3109 : offsetvar, gfc_index_one_node);
3110 849 : tmp = gfc_evaluate_now (tmp, &outer_loop->pre);
3111 849 : if (*loop_ubound0 && VAR_P (*loop_ubound0))
3112 0 : gfc_add_modify (&outer_loop->pre, *loop_ubound0, tmp);
3113 : else
3114 849 : *loop_ubound0 = tmp;
3115 : }
3116 :
3117 6607 : if (TREE_USED (offsetvar))
3118 2052 : pushdecl (offsetvar);
3119 : else
3120 4555 : gcc_assert (INTEGER_CST_P (offset));
3121 :
3122 : #if 0
3123 : /* Disable bound checking for now because it's probably broken. */
3124 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3125 : {
3126 : gcc_unreachable ();
3127 : }
3128 : #endif
3129 :
3130 4555 : finish:
3131 : /* Restore old values of globals. */
3132 42059 : first_len = old_first_len;
3133 42059 : first_len_val = old_first_len_val;
3134 42059 : typespec_chararray_ctor = old_typespec_chararray_ctor;
3135 :
3136 : /* F2008 4.5.6.3 para 5: If an executable construct references a structure
3137 : constructor or array constructor, the entity created by the constructor is
3138 : finalized after execution of the innermost executable construct containing
3139 : the reference. */
3140 42059 : if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
3141 1664 : && finalblock.head != NULL_TREE)
3142 84 : gfc_prepend_expr_to_block (&loop->post, finalblock.head);
3143 42059 : }
3144 :
3145 :
3146 : /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
3147 : called after evaluating all of INFO's vector dimensions. Go through
3148 : each such vector dimension and see if we can now fill in any missing
3149 : loop bounds. */
3150 :
3151 : static void
3152 178283 : set_vector_loop_bounds (gfc_ss * ss)
3153 : {
3154 178283 : gfc_loopinfo *loop, *outer_loop;
3155 178283 : gfc_array_info *info;
3156 178283 : gfc_se se;
3157 178283 : tree tmp;
3158 178283 : tree desc;
3159 178283 : tree zero;
3160 178283 : int n;
3161 178283 : int dim;
3162 :
3163 178283 : outer_loop = outermost_loop (ss->loop);
3164 :
3165 178283 : info = &ss->info->data.array;
3166 :
3167 361202 : for (; ss; ss = ss->parent)
3168 : {
3169 182919 : loop = ss->loop;
3170 :
3171 436846 : for (n = 0; n < loop->dimen; n++)
3172 : {
3173 253927 : dim = ss->dim[n];
3174 253927 : if (info->ref->u.ar.dimen_type[dim] != DIMEN_VECTOR
3175 758 : || loop->to[n] != NULL)
3176 253759 : continue;
3177 :
3178 : /* Loop variable N indexes vector dimension DIM, and we don't
3179 : yet know the upper bound of loop variable N. Set it to the
3180 : difference between the vector's upper and lower bounds. */
3181 168 : gcc_assert (loop->from[n] == gfc_index_zero_node);
3182 168 : gcc_assert (info->subscript[dim]
3183 : && info->subscript[dim]->info->type == GFC_SS_VECTOR);
3184 :
3185 168 : gfc_init_se (&se, NULL);
3186 168 : desc = info->subscript[dim]->info->data.array.descriptor;
3187 168 : zero = gfc_rank_cst[0];
3188 168 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
3189 : gfc_array_index_type,
3190 : gfc_conv_descriptor_ubound_get (desc, zero),
3191 : gfc_conv_descriptor_lbound_get (desc, zero));
3192 168 : tmp = gfc_evaluate_now (tmp, &outer_loop->pre);
3193 168 : loop->to[n] = tmp;
3194 : }
3195 : }
3196 178283 : }
3197 :
3198 :
3199 : /* Tells whether a scalar argument to an elemental procedure is saved out
3200 : of a scalarization loop as a value or as a reference. */
3201 :
3202 : bool
3203 45017 : gfc_scalar_elemental_arg_saved_as_reference (gfc_ss_info * ss_info)
3204 : {
3205 45017 : if (ss_info->type != GFC_SS_REFERENCE)
3206 : return false;
3207 :
3208 10258 : if (ss_info->data.scalar.needs_temporary)
3209 : return false;
3210 :
3211 : /* If the actual argument can be absent (in other words, it can
3212 : be a NULL reference), don't try to evaluate it; pass instead
3213 : the reference directly. */
3214 9894 : if (ss_info->can_be_null_ref)
3215 : return true;
3216 :
3217 : /* If the expression is of polymorphic type, it's actual size is not known,
3218 : so we avoid copying it anywhere. */
3219 9218 : if (ss_info->data.scalar.dummy_arg
3220 1402 : && gfc_dummy_arg_get_typespec (*ss_info->data.scalar.dummy_arg).type
3221 : == BT_CLASS
3222 9342 : && ss_info->expr->ts.type == BT_CLASS)
3223 : return true;
3224 :
3225 : /* If the expression is a data reference of aggregate type,
3226 : and the data reference is not used on the left hand side,
3227 : avoid a copy by saving a reference to the content. */
3228 9194 : if (!ss_info->data.scalar.needs_temporary
3229 9194 : && (ss_info->expr->ts.type == BT_DERIVED
3230 8230 : || ss_info->expr->ts.type == BT_CLASS)
3231 10206 : && gfc_expr_is_variable (ss_info->expr))
3232 : return true;
3233 :
3234 : /* Otherwise the expression is evaluated to a temporary variable before the
3235 : scalarization loop. */
3236 : return false;
3237 : }
3238 :
3239 :
3240 : /* Add the pre and post chains for all the scalar expressions in a SS chain
3241 : to loop. This is called after the loop parameters have been calculated,
3242 : but before the actual scalarizing loops. */
3243 :
3244 : static void
3245 187531 : gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
3246 : locus * where)
3247 : {
3248 187531 : gfc_loopinfo *nested_loop, *outer_loop;
3249 187531 : gfc_se se;
3250 187531 : gfc_ss_info *ss_info;
3251 187531 : gfc_array_info *info;
3252 187531 : gfc_expr *expr;
3253 187531 : int n;
3254 :
3255 : /* Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise,
3256 : arguments could get evaluated multiple times. */
3257 187531 : if (ss->is_alloc_lhs)
3258 185 : return;
3259 :
3260 494042 : outer_loop = outermost_loop (loop);
3261 :
3262 : /* TODO: This can generate bad code if there are ordering dependencies,
3263 : e.g., a callee allocated function and an unknown size constructor. */
3264 : gcc_assert (ss != NULL);
3265 :
3266 494042 : for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
3267 : {
3268 306696 : gcc_assert (ss);
3269 :
3270 : /* Cross loop arrays are handled from within the most nested loop. */
3271 306696 : if (ss->nested_ss != NULL)
3272 4740 : continue;
3273 :
3274 301956 : ss_info = ss->info;
3275 301956 : expr = ss_info->expr;
3276 301956 : info = &ss_info->data.array;
3277 :
3278 301956 : switch (ss_info->type)
3279 : {
3280 42785 : case GFC_SS_SCALAR:
3281 : /* Scalar expression. Evaluate this now. This includes elemental
3282 : dimension indices, but not array section bounds. */
3283 42785 : gfc_init_se (&se, NULL);
3284 42785 : gfc_conv_expr (&se, expr);
3285 42785 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3286 :
3287 42785 : if (expr->ts.type != BT_CHARACTER
3288 42785 : && !gfc_is_alloc_class_scalar_function (expr))
3289 : {
3290 : /* Move the evaluation of scalar expressions outside the
3291 : scalarization loop, except for WHERE assignments. */
3292 38792 : if (subscript)
3293 6355 : se.expr = convert(gfc_array_index_type, se.expr);
3294 38792 : if (!ss_info->where)
3295 38378 : se.expr = gfc_evaluate_now (se.expr, &outer_loop->pre);
3296 38792 : gfc_add_block_to_block (&outer_loop->pre, &se.post);
3297 : }
3298 : else
3299 3993 : gfc_add_block_to_block (&outer_loop->post, &se.post);
3300 :
3301 42785 : ss_info->data.scalar.value = se.expr;
3302 42785 : ss_info->string_length = se.string_length;
3303 42785 : break;
3304 :
3305 5129 : case GFC_SS_REFERENCE:
3306 : /* Scalar argument to elemental procedure. */
3307 5129 : gfc_init_se (&se, NULL);
3308 5129 : if (gfc_scalar_elemental_arg_saved_as_reference (ss_info))
3309 832 : gfc_conv_expr_reference (&se, expr);
3310 : else
3311 : {
3312 : /* Evaluate the argument outside the loop and pass
3313 : a reference to the value. */
3314 4297 : gfc_conv_expr (&se, expr);
3315 : }
3316 :
3317 : /* Ensure that a pointer to the string is stored. */
3318 5129 : if (expr->ts.type == BT_CHARACTER)
3319 174 : gfc_conv_string_parameter (&se);
3320 :
3321 5129 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3322 5129 : gfc_add_block_to_block (&outer_loop->post, &se.post);
3323 5129 : if (gfc_is_class_scalar_expr (expr))
3324 : /* This is necessary because the dynamic type will always be
3325 : large than the declared type. In consequence, assigning
3326 : the value to a temporary could segfault.
3327 : OOP-TODO: see if this is generally correct or is the value
3328 : has to be written to an allocated temporary, whose address
3329 : is passed via ss_info. */
3330 48 : ss_info->data.scalar.value = se.expr;
3331 : else
3332 5081 : ss_info->data.scalar.value = gfc_evaluate_now (se.expr,
3333 : &outer_loop->pre);
3334 :
3335 5129 : ss_info->string_length = se.string_length;
3336 5129 : break;
3337 :
3338 : case GFC_SS_SECTION:
3339 : /* Add the expressions for scalar and vector subscripts. */
3340 2852528 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
3341 2674245 : if (info->subscript[n])
3342 7113 : gfc_add_loop_ss_code (loop, info->subscript[n], true, where);
3343 :
3344 178283 : set_vector_loop_bounds (ss);
3345 178283 : break;
3346 :
3347 758 : case GFC_SS_VECTOR:
3348 : /* Get the vector's descriptor and store it in SS. */
3349 758 : gfc_init_se (&se, NULL);
3350 758 : gfc_conv_expr_descriptor (&se, expr);
3351 758 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3352 758 : gfc_add_block_to_block (&outer_loop->post, &se.post);
3353 758 : info->descriptor = se.expr;
3354 758 : break;
3355 :
3356 11437 : case GFC_SS_INTRINSIC:
3357 11437 : gfc_add_intrinsic_ss_code (loop, ss);
3358 11437 : break;
3359 :
3360 9460 : case GFC_SS_FUNCTION:
3361 9460 : {
3362 : /* Array function return value. We call the function and save its
3363 : result in a temporary for use inside the loop. */
3364 9460 : gfc_init_se (&se, NULL);
3365 9460 : se.loop = loop;
3366 9460 : se.ss = ss;
3367 9460 : bool class_func = gfc_is_class_array_function (expr);
3368 9460 : if (class_func)
3369 183 : expr->must_finalize = 1;
3370 9460 : gfc_conv_expr (&se, expr);
3371 9460 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3372 9460 : if (class_func
3373 183 : && se.expr
3374 9643 : && GFC_CLASS_TYPE_P (TREE_TYPE (se.expr)))
3375 : {
3376 183 : tree tmp = gfc_class_data_get (se.expr);
3377 183 : info->descriptor = tmp;
3378 183 : info->data = gfc_conv_descriptor_data_get (tmp);
3379 183 : info->offset = gfc_conv_descriptor_offset_get (tmp);
3380 366 : for (gfc_ss *s = ss; s; s = s->parent)
3381 378 : for (int n = 0; n < s->dimen; n++)
3382 : {
3383 195 : int dim = s->dim[n];
3384 195 : tree tree_dim = gfc_rank_cst[dim];
3385 :
3386 195 : tree start;
3387 195 : start = gfc_conv_descriptor_lbound_get (tmp, tree_dim);
3388 195 : start = gfc_evaluate_now (start, &outer_loop->pre);
3389 195 : info->start[dim] = start;
3390 :
3391 195 : tree end;
3392 195 : end = gfc_conv_descriptor_ubound_get (tmp, tree_dim);
3393 195 : end = gfc_evaluate_now (end, &outer_loop->pre);
3394 195 : info->end[dim] = end;
3395 :
3396 195 : tree stride;
3397 195 : stride = gfc_conv_descriptor_stride_get (tmp, tree_dim);
3398 195 : stride = gfc_evaluate_now (stride, &outer_loop->pre);
3399 195 : info->stride[dim] = stride;
3400 : }
3401 : }
3402 9460 : gfc_add_block_to_block (&outer_loop->post, &se.post);
3403 9460 : gfc_add_block_to_block (&outer_loop->post, &se.finalblock);
3404 9460 : ss_info->string_length = se.string_length;
3405 : }
3406 9460 : break;
3407 :
3408 42059 : case GFC_SS_CONSTRUCTOR:
3409 42059 : if (expr->ts.type == BT_CHARACTER
3410 8142 : && ss_info->string_length == NULL
3411 8142 : && expr->ts.u.cl
3412 8142 : && expr->ts.u.cl->length
3413 7798 : && expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
3414 : {
3415 7747 : gfc_init_se (&se, NULL);
3416 7747 : gfc_conv_expr_type (&se, expr->ts.u.cl->length,
3417 : gfc_charlen_type_node);
3418 7747 : ss_info->string_length = se.expr;
3419 7747 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3420 7747 : gfc_add_block_to_block (&outer_loop->post, &se.post);
3421 : }
3422 42059 : trans_array_constructor (ss, where);
3423 42059 : break;
3424 :
3425 : case GFC_SS_TEMP:
3426 : case GFC_SS_COMPONENT:
3427 : /* Do nothing. These are handled elsewhere. */
3428 : break;
3429 :
3430 0 : default:
3431 0 : gcc_unreachable ();
3432 : }
3433 : }
3434 :
3435 187346 : if (!subscript)
3436 183597 : for (nested_loop = loop->nested; nested_loop;
3437 3364 : nested_loop = nested_loop->next)
3438 3364 : gfc_add_loop_ss_code (nested_loop, nested_loop->ss, subscript, where);
3439 : }
3440 :
3441 :
3442 : /* Given an array descriptor expression DESCR and its data pointer DATA, decide
3443 : whether to either save the data pointer to a variable and use the variable or
3444 : use the data pointer expression directly without any intermediary variable.
3445 : */
3446 :
3447 : static bool
3448 126557 : save_descriptor_data (tree descr, tree data)
3449 : {
3450 126557 : return !(DECL_P (data)
3451 115867 : || (TREE_CODE (data) == ADDR_EXPR
3452 68313 : && DECL_P (TREE_OPERAND (data, 0)))
3453 50599 : || (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (descr))
3454 47192 : && TREE_CODE (descr) == COMPONENT_REF
3455 10669 : && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (descr, 0)))));
3456 : }
3457 :
3458 :
3459 : /* Type of the DATA argument passed to walk_tree by substitute_subexpr_in_expr
3460 : and used by maybe_substitute_expr. */
3461 :
3462 : typedef struct
3463 : {
3464 : tree target, repl;
3465 : }
3466 : substitute_t;
3467 :
3468 :
3469 : /* Check if the expression in *TP is equal to the substitution target provided
3470 : in DATA->TARGET and replace it with DATA->REPL in that case. This is a
3471 : callback function for use with walk_tree. */
3472 :
3473 : static tree
3474 20885 : maybe_substitute_expr (tree *tp, int *walk_subtree, void *data)
3475 : {
3476 20885 : substitute_t *subst = (substitute_t *) data;
3477 20885 : if (*tp == subst->target)
3478 : {
3479 3972 : *tp = subst->repl;
3480 3972 : *walk_subtree = 0;
3481 : }
3482 :
3483 20885 : return NULL_TREE;
3484 : }
3485 :
3486 :
3487 : /* Substitute in EXPR any occurence of TARGET with REPLACEMENT. */
3488 :
3489 : static void
3490 3665 : substitute_subexpr_in_expr (tree target, tree replacement, tree expr)
3491 : {
3492 3665 : substitute_t subst;
3493 3665 : subst.target = target;
3494 3665 : subst.repl = replacement;
3495 :
3496 3665 : walk_tree (&expr, maybe_substitute_expr, &subst, nullptr);
3497 3665 : }
3498 :
3499 :
3500 : /* Save REF to a fresh variable in all of REPLACEMENT_ROOTS, appending extra
3501 : code to CODE. Before returning, add REF to REPLACEMENT_ROOTS and clear
3502 : REF. */
3503 :
3504 : static void
3505 3493 : save_ref (tree &code, tree &ref, vec<tree> &replacement_roots)
3506 : {
3507 3493 : stmtblock_t tmp_block;
3508 3493 : gfc_init_block (&tmp_block);
3509 3493 : tree var = gfc_evaluate_now (ref, &tmp_block);
3510 3493 : gfc_add_expr_to_block (&tmp_block, code);
3511 3493 : code = gfc_finish_block (&tmp_block);
3512 :
3513 3493 : unsigned i;
3514 3493 : tree repl_root;
3515 7158 : FOR_EACH_VEC_ELT (replacement_roots, i, repl_root)
3516 3665 : substitute_subexpr_in_expr (ref, var, repl_root);
3517 :
3518 3493 : replacement_roots.safe_push (ref);
3519 3493 : ref = NULL_TREE;
3520 3493 : }
3521 :
3522 :
3523 : /* Save the descriptor reference VALUE to storage pointed by DESC_PTR. Before
3524 : that, try to factor subexpressions of VALUE to variables, adding extra code
3525 : to BLOCK.
3526 :
3527 : The candidate references to factoring are dereferenced pointers because they
3528 : are cheap to copy and array descriptors because they are often the base of
3529 : multiple subreferences. */
3530 :
3531 : static void
3532 320323 : set_factored_descriptor_value (tree *desc_ptr, tree value, stmtblock_t *block)
3533 : {
3534 : /* As the reference is processed from outer to inner, variable definitions
3535 : will be generated in reversed order, so can't be put directly in BLOCK.
3536 : We use TMP_BLOCK instead. */
3537 320323 : tree accumulated_code = NULL_TREE;
3538 :
3539 : /* The current candidate to factoring. */
3540 320323 : tree saveable_ref = NULL_TREE;
3541 :
3542 : /* The root expressions in which we look for subexpressions to replace with
3543 : variables. */
3544 320323 : auto_vec<tree> replacement_roots;
3545 320323 : replacement_roots.safe_push (value);
3546 :
3547 320323 : tree data_ref = value;
3548 320323 : tree next_ref = NULL_TREE;
3549 :
3550 : /* If the candidate reference is not followed by a subreference, it can't be
3551 : saved to a variable as it may be reallocatable, and we have to keep the
3552 : parent reference to be able to store the new pointer value in case of
3553 : reallocation. */
3554 320323 : bool maybe_reallocatable = true;
3555 :
3556 425111 : while (true)
3557 : {
3558 425111 : if (!maybe_reallocatable
3559 425111 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (data_ref)))
3560 2341 : saveable_ref = data_ref;
3561 :
3562 425111 : if (TREE_CODE (data_ref) == INDIRECT_REF)
3563 : {
3564 56497 : next_ref = TREE_OPERAND (data_ref, 0);
3565 :
3566 56497 : if (!maybe_reallocatable)
3567 : {
3568 14161 : if (saveable_ref != NULL_TREE && saveable_ref != data_ref)
3569 : {
3570 : /* A reference worth saving has been seen, and now the pointer
3571 : to the current reference is also worth saving. If the
3572 : previous reference to save wasn't the current one, do save
3573 : it now. Otherwise drop it as we prefer saving the
3574 : pointer. */
3575 1689 : save_ref (accumulated_code, saveable_ref, replacement_roots);
3576 : }
3577 :
3578 : /* Don't evaluate the pointer to a variable yet; do it only if the
3579 : variable would be significantly more simple than the reference
3580 : it replaces. That is if the reference contains anything
3581 : different from NOPs, COMPONENTs and DECLs. */
3582 14161 : saveable_ref = next_ref;
3583 : }
3584 : }
3585 368614 : else if (TREE_CODE (data_ref) == COMPONENT_REF)
3586 : {
3587 39453 : maybe_reallocatable = false;
3588 39453 : next_ref = TREE_OPERAND (data_ref, 0);
3589 : }
3590 329161 : else if (TREE_CODE (data_ref) == NOP_EXPR)
3591 3582 : next_ref = TREE_OPERAND (data_ref, 0);
3592 : else
3593 : {
3594 325579 : if (DECL_P (data_ref))
3595 : break;
3596 :
3597 6786 : if (TREE_CODE (data_ref) == ARRAY_REF)
3598 : {
3599 5256 : maybe_reallocatable = false;
3600 5256 : next_ref = TREE_OPERAND (data_ref, 0);
3601 : }
3602 :
3603 6786 : if (saveable_ref != NULL_TREE)
3604 : /* We have seen a reference worth saving. Do it now. */
3605 1804 : save_ref (accumulated_code, saveable_ref, replacement_roots);
3606 :
3607 6786 : if (TREE_CODE (data_ref) != ARRAY_REF)
3608 : break;
3609 : }
3610 :
3611 : data_ref = next_ref;
3612 : }
3613 :
3614 320323 : *desc_ptr = value;
3615 320323 : gfc_add_expr_to_block (block, accumulated_code);
3616 320323 : }
3617 :
3618 :
3619 : /* Translate expressions for the descriptor and data pointer of a SS. */
3620 : /*GCC ARRAYS*/
3621 :
3622 : static void
3623 320323 : gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
3624 : {
3625 320323 : gfc_se se;
3626 320323 : gfc_ss_info *ss_info;
3627 320323 : gfc_array_info *info;
3628 320323 : tree tmp;
3629 :
3630 320323 : ss_info = ss->info;
3631 320323 : info = &ss_info->data.array;
3632 :
3633 : /* Get the descriptor for the array to be scalarized. */
3634 320323 : gcc_assert (ss_info->expr->expr_type == EXPR_VARIABLE);
3635 320323 : gfc_init_se (&se, NULL);
3636 320323 : se.descriptor_only = 1;
3637 320323 : gfc_conv_expr_lhs (&se, ss_info->expr);
3638 320323 : gfc_add_block_to_block (block, &se.pre);
3639 320323 : set_factored_descriptor_value (&info->descriptor, se.expr, block);
3640 320323 : ss_info->string_length = se.string_length;
3641 320323 : ss_info->class_container = se.class_container;
3642 :
3643 320323 : if (base)
3644 : {
3645 120113 : if (ss_info->expr->ts.type == BT_CHARACTER && !ss_info->expr->ts.deferred
3646 22732 : && ss_info->expr->ts.u.cl->length == NULL)
3647 : {
3648 : /* Emit a DECL_EXPR for the variable sized array type in
3649 : GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
3650 : sizes works correctly. */
3651 1097 : tree arraytype = TREE_TYPE (
3652 : GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (info->descriptor)));
3653 1097 : if (! TYPE_NAME (arraytype))
3654 899 : TYPE_NAME (arraytype) = build_decl (UNKNOWN_LOCATION, TYPE_DECL,
3655 : NULL_TREE, arraytype);
3656 1097 : gfc_add_expr_to_block (block, build1 (DECL_EXPR, arraytype,
3657 1097 : TYPE_NAME (arraytype)));
3658 : }
3659 : /* Also the data pointer. */
3660 120113 : tmp = gfc_conv_array_data (se.expr);
3661 : /* If this is a variable or address or a class array, use it directly.
3662 : Otherwise we must evaluate it now to avoid breaking dependency
3663 : analysis by pulling the expressions for elemental array indices
3664 : inside the loop. */
3665 120113 : if (save_descriptor_data (se.expr, tmp) && !ss->is_alloc_lhs)
3666 35705 : tmp = gfc_evaluate_now (tmp, block);
3667 120113 : info->data = tmp;
3668 :
3669 120113 : tmp = gfc_conv_array_offset (se.expr);
3670 120113 : if (!ss->is_alloc_lhs)
3671 113854 : tmp = gfc_evaluate_now (tmp, block);
3672 120113 : info->offset = tmp;
3673 :
3674 : /* Make absolutely sure that the saved_offset is indeed saved
3675 : so that the variable is still accessible after the loops
3676 : are translated. */
3677 120113 : info->saved_offset = info->offset;
3678 : }
3679 320323 : }
3680 :
3681 :
3682 : /* Initialize a gfc_loopinfo structure. */
3683 :
3684 : void
3685 186442 : gfc_init_loopinfo (gfc_loopinfo * loop)
3686 : {
3687 186442 : int n;
3688 :
3689 186442 : memset (loop, 0, sizeof (gfc_loopinfo));
3690 186442 : gfc_init_block (&loop->pre);
3691 186442 : gfc_init_block (&loop->post);
3692 :
3693 : /* Initially scalarize in order and default to no loop reversal. */
3694 3169514 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
3695 : {
3696 2796630 : loop->order[n] = n;
3697 2796630 : loop->reverse[n] = GFC_INHIBIT_REVERSE;
3698 : }
3699 :
3700 186442 : loop->ss = gfc_ss_terminator;
3701 186442 : }
3702 :
3703 :
3704 : /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
3705 : chain. */
3706 :
3707 : void
3708 186617 : gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
3709 : {
3710 186617 : se->loop = loop;
3711 186617 : }
3712 :
3713 :
3714 : /* Return an expression for the data pointer of an array. */
3715 :
3716 : tree
3717 327543 : gfc_conv_array_data (tree descriptor)
3718 : {
3719 327543 : tree type;
3720 :
3721 327543 : type = TREE_TYPE (descriptor);
3722 327543 : if (GFC_ARRAY_TYPE_P (type))
3723 : {
3724 230109 : if (TREE_CODE (type) == POINTER_TYPE)
3725 : return descriptor;
3726 : else
3727 : {
3728 : /* Descriptorless arrays. */
3729 172999 : return gfc_build_addr_expr (NULL_TREE, descriptor);
3730 : }
3731 : }
3732 : else
3733 97434 : return gfc_conv_descriptor_data_get (descriptor);
3734 : }
3735 :
3736 :
3737 : /* Return an expression for the base offset of an array. */
3738 :
3739 : tree
3740 243764 : gfc_conv_array_offset (tree descriptor)
3741 : {
3742 243764 : tree type;
3743 :
3744 243764 : type = TREE_TYPE (descriptor);
3745 243764 : if (GFC_ARRAY_TYPE_P (type))
3746 173699 : return GFC_TYPE_ARRAY_OFFSET (type);
3747 : else
3748 70065 : return gfc_conv_descriptor_offset_get (descriptor);
3749 : }
3750 :
3751 :
3752 : /* Get an expression for the array stride. */
3753 :
3754 : tree
3755 488064 : gfc_conv_array_stride (tree descriptor, int dim)
3756 : {
3757 488064 : tree tmp;
3758 488064 : tree type;
3759 :
3760 488064 : type = TREE_TYPE (descriptor);
3761 :
3762 : /* For descriptorless arrays use the array size. */
3763 488064 : tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
3764 488064 : if (tmp != NULL_TREE)
3765 : return tmp;
3766 :
3767 112150 : tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]);
3768 112150 : return tmp;
3769 : }
3770 :
3771 :
3772 : /* Like gfc_conv_array_stride, but for the lower bound. */
3773 :
3774 : tree
3775 315082 : gfc_conv_array_lbound (tree descriptor, int dim)
3776 : {
3777 315082 : tree tmp;
3778 315082 : tree type;
3779 :
3780 315082 : type = TREE_TYPE (descriptor);
3781 :
3782 315082 : tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
3783 315082 : if (tmp != NULL_TREE)
3784 : return tmp;
3785 :
3786 18441 : tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]);
3787 18441 : return tmp;
3788 : }
3789 :
3790 :
3791 : /* Like gfc_conv_array_stride, but for the upper bound. */
3792 :
3793 : tree
3794 203972 : gfc_conv_array_ubound (tree descriptor, int dim)
3795 : {
3796 203972 : tree tmp;
3797 203972 : tree type;
3798 :
3799 203972 : type = TREE_TYPE (descriptor);
3800 :
3801 203972 : tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
3802 203972 : if (tmp != NULL_TREE)
3803 : return tmp;
3804 :
3805 : /* This should only ever happen when passing an assumed shape array
3806 : as an actual parameter. The value will never be used. */
3807 7912 : if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
3808 554 : return gfc_index_zero_node;
3809 :
3810 7358 : tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]);
3811 7358 : return tmp;
3812 : }
3813 :
3814 :
3815 : /* Generate abridged name of a part-ref for use in bounds-check message.
3816 : Cases:
3817 : (1) for an ordinary array variable x return "x"
3818 : (2) for z a DT scalar and array component x (at level 1) return "z%%x"
3819 : (3) for z a DT scalar and array component x (at level > 1) or
3820 : for z a DT array and array x (at any number of levels): "z...%%x"
3821 : */
3822 :
3823 : static char *
3824 36159 : abridged_ref_name (gfc_expr * expr, gfc_array_ref * ar)
3825 : {
3826 36159 : gfc_ref *ref;
3827 36159 : gfc_symbol *sym;
3828 36159 : char *ref_name = NULL;
3829 36159 : const char *comp_name = NULL;
3830 36159 : int len_sym, last_len = 0, level = 0;
3831 36159 : bool sym_is_array;
3832 :
3833 36159 : gcc_assert (expr->expr_type == EXPR_VARIABLE && expr->ref != NULL);
3834 :
3835 36159 : sym = expr->symtree->n.sym;
3836 72051 : sym_is_array = (sym->ts.type != BT_CLASS
3837 36159 : ? sym->as != NULL
3838 267 : : IS_CLASS_ARRAY (sym));
3839 36159 : len_sym = strlen (sym->name);
3840 :
3841 : /* Scan ref chain to get name of the array component (when ar != NULL) or
3842 : array section, determine depth and remember its component name. */
3843 51301 : for (ref = expr->ref; ref; ref = ref->next)
3844 : {
3845 37284 : if (ref->type == REF_COMPONENT
3846 808 : && strcmp (ref->u.c.component->name, "_data") != 0)
3847 : {
3848 678 : level++;
3849 678 : comp_name = ref->u.c.component->name;
3850 678 : continue;
3851 : }
3852 :
3853 36606 : if (ref->type != REF_ARRAY)
3854 150 : continue;
3855 :
3856 36456 : if (ar)
3857 : {
3858 15561 : if (&ref->u.ar == ar)
3859 : break;
3860 : }
3861 20895 : else if (ref->u.ar.type == AR_SECTION)
3862 : break;
3863 : }
3864 :
3865 36159 : if (level > 0)
3866 644 : last_len = strlen (comp_name);
3867 :
3868 : /* Provide a buffer sufficiently large to hold "x...%%z". */
3869 36159 : ref_name = XNEWVEC (char, len_sym + last_len + 6);
3870 36159 : strcpy (ref_name, sym->name);
3871 :
3872 36159 : if (level == 1 && !sym_is_array)
3873 : {
3874 352 : strcat (ref_name, "%%");
3875 352 : strcat (ref_name, comp_name);
3876 : }
3877 35807 : else if (level > 0)
3878 : {
3879 292 : strcat (ref_name, "...%%");
3880 292 : strcat (ref_name, comp_name);
3881 : }
3882 :
3883 36159 : return ref_name;
3884 : }
3885 :
3886 :
3887 : /* Generate code to perform an array index bound check. */
3888 :
3889 : static tree
3890 5411 : trans_array_bound_check (gfc_se * se, gfc_ss *ss, tree index, int n,
3891 : locus * where, bool check_upper,
3892 : const char *compname = NULL)
3893 : {
3894 5411 : tree fault;
3895 5411 : tree tmp_lo, tmp_up;
3896 5411 : tree descriptor;
3897 5411 : char *msg;
3898 5411 : char *ref_name = NULL;
3899 5411 : const char * name = NULL;
3900 5411 : gfc_expr *expr;
3901 :
3902 5411 : if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
3903 : return index;
3904 :
3905 240 : descriptor = ss->info->data.array.descriptor;
3906 :
3907 240 : index = gfc_evaluate_now (index, &se->pre);
3908 :
3909 : /* We find a name for the error message. */
3910 240 : name = ss->info->expr->symtree->n.sym->name;
3911 240 : gcc_assert (name != NULL);
3912 :
3913 : /* When we have a component ref, get name of the array section.
3914 : Note that there can only be one part ref. */
3915 240 : expr = ss->info->expr;
3916 240 : if (expr->ref && !compname)
3917 160 : name = ref_name = abridged_ref_name (expr, NULL);
3918 :
3919 240 : if (VAR_P (descriptor))
3920 162 : name = IDENTIFIER_POINTER (DECL_NAME (descriptor));
3921 :
3922 : /* Use given (array component) name. */
3923 240 : if (compname)
3924 80 : name = compname;
3925 :
3926 : /* If upper bound is present, include both bounds in the error message. */
3927 240 : if (check_upper)
3928 : {
3929 213 : tmp_lo = gfc_conv_array_lbound (descriptor, n);
3930 213 : tmp_up = gfc_conv_array_ubound (descriptor, n);
3931 :
3932 213 : if (name)
3933 213 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3934 : "outside of expected range (%%ld:%%ld)", n+1, name);
3935 : else
3936 0 : msg = xasprintf ("Index '%%ld' of dimension %d "
3937 : "outside of expected range (%%ld:%%ld)", n+1);
3938 :
3939 213 : fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3940 : index, tmp_lo);
3941 213 : gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
3942 : fold_convert (long_integer_type_node, index),
3943 : fold_convert (long_integer_type_node, tmp_lo),
3944 : fold_convert (long_integer_type_node, tmp_up));
3945 213 : fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3946 : index, tmp_up);
3947 213 : gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
3948 : fold_convert (long_integer_type_node, index),
3949 : fold_convert (long_integer_type_node, tmp_lo),
3950 : fold_convert (long_integer_type_node, tmp_up));
3951 213 : free (msg);
3952 : }
3953 : else
3954 : {
3955 27 : tmp_lo = gfc_conv_array_lbound (descriptor, n);
3956 :
3957 27 : if (name)
3958 27 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3959 : "below lower bound of %%ld", n+1, name);
3960 : else
3961 0 : msg = xasprintf ("Index '%%ld' of dimension %d "
3962 : "below lower bound of %%ld", n+1);
3963 :
3964 27 : fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3965 : index, tmp_lo);
3966 27 : gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
3967 : fold_convert (long_integer_type_node, index),
3968 : fold_convert (long_integer_type_node, tmp_lo));
3969 27 : free (msg);
3970 : }
3971 :
3972 240 : free (ref_name);
3973 240 : return index;
3974 : }
3975 :
3976 :
3977 : /* Helper functions to detect impure functions in an expression. */
3978 :
3979 : static const char *impure_name = NULL;
3980 : static bool
3981 96 : expr_contains_impure_fcn (gfc_expr *e, gfc_symbol* sym ATTRIBUTE_UNUSED,
3982 : int* g ATTRIBUTE_UNUSED)
3983 : {
3984 96 : if (e && e->expr_type == EXPR_FUNCTION
3985 6 : && !gfc_pure_function (e, &impure_name)
3986 99 : && !gfc_implicit_pure_function (e))
3987 : return true;
3988 :
3989 : return false;
3990 : }
3991 :
3992 : static bool
3993 80 : gfc_expr_contains_impure_fcn (gfc_expr *e)
3994 : {
3995 80 : impure_name = NULL;
3996 80 : return gfc_traverse_expr (e, NULL, &expr_contains_impure_fcn, 0);
3997 : }
3998 :
3999 :
4000 : /* Generate code for bounds checking for elemental dimensions. */
4001 :
4002 : static void
4003 6674 : array_bound_check_elemental (gfc_se * se, gfc_ss * ss, gfc_expr * expr)
4004 : {
4005 6674 : gfc_array_ref *ar;
4006 6674 : gfc_ref *ref;
4007 6674 : char *var_name = NULL;
4008 6674 : int dim;
4009 :
4010 6674 : if (expr->expr_type == EXPR_VARIABLE)
4011 : {
4012 12481 : for (ref = expr->ref; ref; ref = ref->next)
4013 : {
4014 6265 : if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
4015 : {
4016 3941 : ar = &ref->u.ar;
4017 3941 : var_name = abridged_ref_name (expr, ar);
4018 8122 : for (dim = 0; dim < ar->dimen; dim++)
4019 : {
4020 4181 : if (ar->dimen_type[dim] == DIMEN_ELEMENT)
4021 : {
4022 80 : if (gfc_expr_contains_impure_fcn (ar->start[dim]))
4023 3 : gfc_warning_now (0, "Bounds checking of the elemental "
4024 : "index at %L will cause two calls to "
4025 : "%qs, which is not declared to be "
4026 : "PURE or is not implicitly pure.",
4027 3 : &ar->start[dim]->where, impure_name);
4028 80 : gfc_se indexse;
4029 80 : gfc_init_se (&indexse, NULL);
4030 80 : gfc_conv_expr_type (&indexse, ar->start[dim],
4031 : gfc_array_index_type);
4032 80 : gfc_add_block_to_block (&se->pre, &indexse.pre);
4033 80 : trans_array_bound_check (se, ss, indexse.expr, dim,
4034 : &ar->where,
4035 80 : ar->as->type != AS_ASSUMED_SIZE
4036 80 : || dim < ar->dimen - 1,
4037 : var_name);
4038 : }
4039 : }
4040 3941 : free (var_name);
4041 : }
4042 : }
4043 : }
4044 6674 : }
4045 :
4046 :
4047 : /* Return the offset for an index. Performs bound checking for elemental
4048 : dimensions. Single element references are processed separately.
4049 : DIM is the array dimension, I is the loop dimension. */
4050 :
4051 : static tree
4052 249524 : conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i,
4053 : gfc_array_ref * ar, tree stride)
4054 : {
4055 249524 : gfc_array_info *info;
4056 249524 : tree index;
4057 249524 : tree desc;
4058 249524 : tree data;
4059 :
4060 249524 : info = &ss->info->data.array;
4061 :
4062 : /* Get the index into the array for this dimension. */
4063 249524 : if (ar)
4064 : {
4065 177385 : gcc_assert (ar->type != AR_ELEMENT);
4066 177385 : switch (ar->dimen_type[dim])
4067 : {
4068 0 : case DIMEN_THIS_IMAGE:
4069 0 : gcc_unreachable ();
4070 4576 : break;
4071 4576 : case DIMEN_ELEMENT:
4072 : /* Elemental dimension. */
4073 4576 : gcc_assert (info->subscript[dim]
4074 : && info->subscript[dim]->info->type == GFC_SS_SCALAR);
4075 : /* We've already translated this value outside the loop. */
4076 4576 : index = info->subscript[dim]->info->data.scalar.value;
4077 :
4078 9152 : index = trans_array_bound_check (se, ss, index, dim, &ar->where,
4079 4576 : ar->as->type != AS_ASSUMED_SIZE
4080 4576 : || dim < ar->dimen - 1);
4081 4576 : break;
4082 :
4083 755 : case DIMEN_VECTOR:
4084 755 : gcc_assert (info && se->loop);
4085 755 : gcc_assert (info->subscript[dim]
4086 : && info->subscript[dim]->info->type == GFC_SS_VECTOR);
4087 755 : desc = info->subscript[dim]->info->data.array.descriptor;
4088 :
4089 : /* Get a zero-based index into the vector. */
4090 755 : index = fold_build2_loc (input_location, MINUS_EXPR,
4091 : gfc_array_index_type,
4092 : se->loop->loopvar[i], se->loop->from[i]);
4093 :
4094 : /* Multiply the index by the stride. */
4095 755 : index = fold_build2_loc (input_location, MULT_EXPR,
4096 : gfc_array_index_type,
4097 : index, gfc_conv_array_stride (desc, 0));
4098 :
4099 : /* Read the vector to get an index into info->descriptor. */
4100 755 : data = build_fold_indirect_ref_loc (input_location,
4101 : gfc_conv_array_data (desc));
4102 755 : index = gfc_build_array_ref (data, index, NULL);
4103 755 : index = gfc_evaluate_now (index, &se->pre);
4104 755 : index = fold_convert (gfc_array_index_type, index);
4105 :
4106 : /* Do any bounds checking on the final info->descriptor index. */
4107 1510 : index = trans_array_bound_check (se, ss, index, dim, &ar->where,
4108 755 : ar->as->type != AS_ASSUMED_SIZE
4109 755 : || dim < ar->dimen - 1);
4110 755 : break;
4111 :
4112 172054 : case DIMEN_RANGE:
4113 : /* Scalarized dimension. */
4114 172054 : gcc_assert (info && se->loop);
4115 :
4116 : /* Multiply the loop variable by the stride and delta. */
4117 172054 : index = se->loop->loopvar[i];
4118 172054 : if (!integer_onep (info->stride[dim]))
4119 6858 : index = fold_build2_loc (input_location, MULT_EXPR,
4120 : gfc_array_index_type, index,
4121 : info->stride[dim]);
4122 172054 : if (!integer_zerop (info->delta[dim]))
4123 66023 : index = fold_build2_loc (input_location, PLUS_EXPR,
4124 : gfc_array_index_type, index,
4125 : info->delta[dim]);
4126 : break;
4127 :
4128 0 : default:
4129 0 : gcc_unreachable ();
4130 : }
4131 : }
4132 : else
4133 : {
4134 : /* Temporary array or derived type component. */
4135 72139 : gcc_assert (se->loop);
4136 72139 : index = se->loop->loopvar[se->loop->order[i]];
4137 :
4138 : /* Pointer functions can have stride[0] different from unity.
4139 : Use the stride returned by the function call and stored in
4140 : the descriptor for the temporary. */
4141 72139 : if (se->ss && se->ss->info->type == GFC_SS_FUNCTION
4142 8019 : && se->ss->info->expr
4143 8019 : && se->ss->info->expr->symtree
4144 8019 : && se->ss->info->expr->symtree->n.sym->result
4145 7579 : && se->ss->info->expr->symtree->n.sym->result->attr.pointer)
4146 144 : stride = gfc_conv_descriptor_stride_get (info->descriptor,
4147 : gfc_rank_cst[dim]);
4148 :
4149 72139 : if (info->delta[dim] && !integer_zerop (info->delta[dim]))
4150 798 : index = fold_build2_loc (input_location, PLUS_EXPR,
4151 : gfc_array_index_type, index, info->delta[dim]);
4152 : }
4153 :
4154 : /* Multiply by the stride. */
4155 249524 : if (stride != NULL && !integer_onep (stride))
4156 76753 : index = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4157 : index, stride);
4158 :
4159 249524 : return index;
4160 : }
4161 :
4162 :
4163 : /* Build a scalarized array reference using the vptr 'size'. */
4164 :
4165 : static bool
4166 190205 : build_class_array_ref (gfc_se *se, tree base, tree index)
4167 : {
4168 190205 : tree size;
4169 190205 : tree decl = NULL_TREE;
4170 190205 : tree tmp;
4171 190205 : gfc_expr *expr = se->ss->info->expr;
4172 190205 : gfc_expr *class_expr;
4173 190205 : gfc_typespec *ts;
4174 190205 : gfc_symbol *sym;
4175 :
4176 190205 : tmp = !VAR_P (base) ? gfc_get_class_from_expr (base) : NULL_TREE;
4177 :
4178 88957 : if (tmp != NULL_TREE)
4179 : decl = tmp;
4180 : else
4181 : {
4182 : /* The base expression does not contain a class component, either
4183 : because it is a temporary array or array descriptor. Class
4184 : array functions are correctly resolved above. */
4185 186904 : if (!expr
4186 186904 : || (expr->ts.type != BT_CLASS
4187 173555 : && !gfc_is_class_array_ref (expr, NULL)))
4188 186499 : return false;
4189 :
4190 : /* Obtain the expression for the class entity or component that is
4191 : followed by an array reference, which is not an element, so that
4192 : the span of the array can be obtained. */
4193 405 : class_expr = gfc_find_and_cut_at_last_class_ref (expr, false, &ts);
4194 :
4195 405 : if (!ts)
4196 : return false;
4197 :
4198 380 : sym = (!class_expr && expr) ? expr->symtree->n.sym : NULL;
4199 0 : if (sym && sym->attr.function
4200 0 : && sym == sym->result
4201 0 : && sym->backend_decl == current_function_decl)
4202 : /* The temporary is the data field of the class data component
4203 : of the current function. */
4204 0 : decl = gfc_get_fake_result_decl (sym, 0);
4205 380 : else if (sym)
4206 : {
4207 0 : if (decl == NULL_TREE)
4208 0 : decl = expr->symtree->n.sym->backend_decl;
4209 : /* For class arrays the tree containing the class is stored in
4210 : GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl.
4211 : For all others it's sym's backend_decl directly. */
4212 0 : if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl))
4213 0 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
4214 : }
4215 : else
4216 380 : decl = gfc_get_class_from_gfc_expr (class_expr);
4217 :
4218 380 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
4219 0 : decl = build_fold_indirect_ref_loc (input_location, decl);
4220 :
4221 380 : if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl)))
4222 : return false;
4223 : }
4224 :
4225 3681 : se->class_vptr = gfc_evaluate_now (gfc_class_vptr_get (decl), &se->pre);
4226 :
4227 3681 : size = gfc_class_vtab_size_get (decl);
4228 : /* For unlimited polymorphic entities then _len component needs to be
4229 : multiplied with the size. */
4230 3681 : size = gfc_resize_class_size_with_len (&se->pre, decl, size);
4231 3681 : size = fold_convert (TREE_TYPE (index), size);
4232 :
4233 : /* Return the element in the se expression. */
4234 3681 : se->expr = gfc_build_spanned_array_ref (base, index, size);
4235 3681 : return true;
4236 : }
4237 :
4238 :
4239 : /* Indicates that the tree EXPR is a reference to an array that can’t
4240 : have any negative stride. */
4241 :
4242 : static bool
4243 307939 : non_negative_strides_array_p (tree expr)
4244 : {
4245 320700 : if (expr == NULL_TREE)
4246 : return false;
4247 :
4248 320700 : tree type = TREE_TYPE (expr);
4249 320700 : if (POINTER_TYPE_P (type))
4250 70091 : type = TREE_TYPE (type);
4251 :
4252 320700 : if (TYPE_LANG_SPECIFIC (type))
4253 : {
4254 320700 : gfc_array_kind array_kind = GFC_TYPE_ARRAY_AKIND (type);
4255 :
4256 320700 : if (array_kind == GFC_ARRAY_ALLOCATABLE
4257 320700 : || array_kind == GFC_ARRAY_ASSUMED_SHAPE_CONT)
4258 : return true;
4259 : }
4260 :
4261 : /* An array with descriptor can have negative strides.
4262 : We try to be conservative and return false by default here
4263 : if we don’t recognize a contiguous array instead of
4264 : returning false if we can identify a non-contiguous one. */
4265 264540 : if (!GFC_ARRAY_TYPE_P (type))
4266 : return false;
4267 :
4268 : /* If the array was originally a dummy with a descriptor, strides can be
4269 : negative. */
4270 231446 : if (DECL_P (expr)
4271 222657 : && DECL_LANG_SPECIFIC (expr)
4272 47310 : && GFC_DECL_SAVED_DESCRIPTOR (expr)
4273 244226 : && GFC_DECL_SAVED_DESCRIPTOR (expr) != expr)
4274 12761 : return non_negative_strides_array_p (GFC_DECL_SAVED_DESCRIPTOR (expr));
4275 :
4276 : return true;
4277 : }
4278 :
4279 :
4280 : /* Build a scalarized reference to an array. */
4281 :
4282 : static void
4283 190205 : gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar,
4284 : bool tmp_array = false)
4285 : {
4286 190205 : gfc_array_info *info;
4287 190205 : tree decl = NULL_TREE;
4288 190205 : tree index;
4289 190205 : tree base;
4290 190205 : gfc_ss *ss;
4291 190205 : gfc_expr *expr;
4292 190205 : int n;
4293 :
4294 190205 : ss = se->ss;
4295 190205 : expr = ss->info->expr;
4296 190205 : info = &ss->info->data.array;
4297 190205 : if (ar)
4298 130149 : n = se->loop->order[0];
4299 : else
4300 : n = 0;
4301 :
4302 190205 : index = conv_array_index_offset (se, ss, ss->dim[n], n, ar, info->stride0);
4303 : /* Add the offset for this dimension to the stored offset for all other
4304 : dimensions. */
4305 190205 : if (info->offset && !integer_zerop (info->offset))
4306 139774 : index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4307 : index, info->offset);
4308 :
4309 190205 : base = build_fold_indirect_ref_loc (input_location, info->data);
4310 :
4311 : /* Use the vptr 'size' field to access the element of a class array. */
4312 190205 : if (build_class_array_ref (se, base, index))
4313 3681 : return;
4314 :
4315 186524 : if (get_CFI_desc (NULL, expr, &decl, ar))
4316 442 : decl = build_fold_indirect_ref_loc (input_location, decl);
4317 :
4318 : /* A pointer array component can be detected from its field decl. Fix
4319 : the descriptor, mark the resulting variable decl and pass it to
4320 : gfc_build_array_ref. */
4321 186524 : if (is_pointer_array (info->descriptor)
4322 186524 : || (expr && expr->ts.deferred && info->descriptor
4323 2913 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info->descriptor))))
4324 : {
4325 9011 : if (TREE_CODE (info->descriptor) == COMPONENT_REF)
4326 1492 : decl = info->descriptor;
4327 7519 : else if (INDIRECT_REF_P (info->descriptor))
4328 1485 : decl = TREE_OPERAND (info->descriptor, 0);
4329 :
4330 9011 : if (decl == NULL_TREE)
4331 6034 : decl = info->descriptor;
4332 : }
4333 :
4334 186524 : bool non_negative_stride = tmp_array
4335 186524 : || non_negative_strides_array_p (info->descriptor);
4336 186524 : se->expr = gfc_build_array_ref (base, index, decl,
4337 : non_negative_stride);
4338 : }
4339 :
4340 :
4341 : /* Translate access of temporary array. */
4342 :
4343 : void
4344 60056 : gfc_conv_tmp_array_ref (gfc_se * se)
4345 : {
4346 60056 : se->string_length = se->ss->info->string_length;
4347 60056 : gfc_conv_scalarized_array_ref (se, NULL, true);
4348 60056 : gfc_advance_se_ss_chain (se);
4349 60056 : }
4350 :
4351 : /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
4352 :
4353 : static void
4354 271824 : add_to_offset (tree *cst_offset, tree *offset, tree t)
4355 : {
4356 271824 : if (TREE_CODE (t) == INTEGER_CST)
4357 137529 : *cst_offset = int_const_binop (PLUS_EXPR, *cst_offset, t);
4358 : else
4359 : {
4360 134295 : if (!integer_zerop (*offset))
4361 47233 : *offset = fold_build2_loc (input_location, PLUS_EXPR,
4362 : gfc_array_index_type, *offset, t);
4363 : else
4364 87062 : *offset = t;
4365 : }
4366 271824 : }
4367 :
4368 :
4369 : static tree
4370 181077 : build_array_ref (tree desc, tree offset, tree decl, tree vptr)
4371 : {
4372 181077 : tree tmp;
4373 181077 : tree type;
4374 181077 : tree cdesc;
4375 :
4376 : /* For class arrays the class declaration is stored in the saved
4377 : descriptor. */
4378 181077 : if (INDIRECT_REF_P (desc)
4379 7316 : && DECL_LANG_SPECIFIC (TREE_OPERAND (desc, 0))
4380 183381 : && GFC_DECL_SAVED_DESCRIPTOR (TREE_OPERAND (desc, 0)))
4381 869 : cdesc = gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (
4382 : TREE_OPERAND (desc, 0)));
4383 : else
4384 : cdesc = desc;
4385 :
4386 : /* Class container types do not always have the GFC_CLASS_TYPE_P
4387 : but the canonical type does. */
4388 181077 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdesc))
4389 181077 : && TREE_CODE (cdesc) == COMPONENT_REF)
4390 : {
4391 10970 : type = TREE_TYPE (TREE_OPERAND (cdesc, 0));
4392 10970 : if (TYPE_CANONICAL (type)
4393 10970 : && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type)))
4394 3389 : vptr = gfc_class_vptr_get (TREE_OPERAND (cdesc, 0));
4395 : }
4396 :
4397 181077 : tmp = gfc_conv_array_data (desc);
4398 181077 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
4399 181077 : tmp = gfc_build_array_ref (tmp, offset, decl,
4400 181077 : non_negative_strides_array_p (desc),
4401 : vptr);
4402 181077 : return tmp;
4403 : }
4404 :
4405 :
4406 : /* Build an array reference. se->expr already holds the array descriptor.
4407 : This should be either a variable, indirect variable reference or component
4408 : reference. For arrays which do not have a descriptor, se->expr will be
4409 : the data pointer.
4410 : a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
4411 :
4412 : void
4413 257225 : gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
4414 : locus * where)
4415 : {
4416 257225 : int n;
4417 257225 : tree offset, cst_offset;
4418 257225 : tree tmp;
4419 257225 : tree stride;
4420 257225 : tree decl = NULL_TREE;
4421 257225 : gfc_se indexse;
4422 257225 : gfc_se tmpse;
4423 257225 : gfc_symbol * sym = expr->symtree->n.sym;
4424 257225 : char *var_name = NULL;
4425 :
4426 257225 : if (ar->stat)
4427 : {
4428 3 : gfc_se statse;
4429 :
4430 3 : gfc_init_se (&statse, NULL);
4431 3 : gfc_conv_expr_lhs (&statse, ar->stat);
4432 3 : gfc_add_block_to_block (&se->pre, &statse.pre);
4433 3 : gfc_add_modify (&se->pre, statse.expr, integer_zero_node);
4434 : }
4435 257225 : if (ar->dimen == 0)
4436 : {
4437 4480 : gcc_assert (ar->codimen || sym->attr.select_rank_temporary
4438 : || (ar->as && ar->as->corank));
4439 :
4440 4480 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
4441 949 : se->expr = build_fold_indirect_ref (gfc_conv_array_data (se->expr));
4442 : else
4443 : {
4444 3531 : if (GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr))
4445 3531 : && TREE_CODE (TREE_TYPE (se->expr)) == POINTER_TYPE)
4446 2593 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
4447 :
4448 : /* Use the actual tree type and not the wrapped coarray. */
4449 3531 : if (!se->want_pointer)
4450 2563 : se->expr = fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se->expr)),
4451 : se->expr);
4452 : }
4453 :
4454 134629 : return;
4455 : }
4456 :
4457 : /* Handle scalarized references separately. */
4458 252745 : if (ar->type != AR_ELEMENT)
4459 : {
4460 130149 : gfc_conv_scalarized_array_ref (se, ar);
4461 130149 : gfc_advance_se_ss_chain (se);
4462 130149 : return;
4463 : }
4464 :
4465 122596 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
4466 11493 : var_name = abridged_ref_name (expr, ar);
4467 :
4468 122596 : decl = se->expr;
4469 122596 : if (UNLIMITED_POLY(sym)
4470 104 : && IS_CLASS_ARRAY (sym)
4471 103 : && sym->attr.dummy
4472 60 : && ar->as->type != AS_DEFERRED)
4473 48 : decl = sym->backend_decl;
4474 :
4475 122596 : cst_offset = offset = gfc_index_zero_node;
4476 122596 : add_to_offset (&cst_offset, &offset, gfc_conv_array_offset (decl));
4477 :
4478 : /* Calculate the offsets from all the dimensions. Make sure to associate
4479 : the final offset so that we form a chain of loop invariant summands. */
4480 271824 : for (n = ar->dimen - 1; n >= 0; n--)
4481 : {
4482 : /* Calculate the index for this dimension. */
4483 149228 : gfc_init_se (&indexse, se);
4484 149228 : gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
4485 149228 : gfc_add_block_to_block (&se->pre, &indexse.pre);
4486 :
4487 149228 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && ! expr->no_bounds_check)
4488 : {
4489 : /* Check array bounds. */
4490 15035 : tree cond;
4491 15035 : char *msg;
4492 :
4493 : /* Evaluate the indexse.expr only once. */
4494 15035 : indexse.expr = save_expr (indexse.expr);
4495 :
4496 : /* Lower bound. */
4497 15035 : tmp = gfc_conv_array_lbound (decl, n);
4498 15035 : if (sym->attr.temporary)
4499 : {
4500 18 : gfc_init_se (&tmpse, se);
4501 18 : gfc_conv_expr_type (&tmpse, ar->as->lower[n],
4502 : gfc_array_index_type);
4503 18 : gfc_add_block_to_block (&se->pre, &tmpse.pre);
4504 18 : tmp = tmpse.expr;
4505 : }
4506 :
4507 15035 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
4508 : indexse.expr, tmp);
4509 15035 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4510 : "below lower bound of %%ld", n+1, var_name);
4511 15035 : gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
4512 : fold_convert (long_integer_type_node,
4513 : indexse.expr),
4514 : fold_convert (long_integer_type_node, tmp));
4515 15035 : free (msg);
4516 :
4517 : /* Upper bound, but not for the last dimension of assumed-size
4518 : arrays. */
4519 15035 : if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE)
4520 : {
4521 13302 : tmp = gfc_conv_array_ubound (decl, n);
4522 13302 : if (sym->attr.temporary)
4523 : {
4524 18 : gfc_init_se (&tmpse, se);
4525 18 : gfc_conv_expr_type (&tmpse, ar->as->upper[n],
4526 : gfc_array_index_type);
4527 18 : gfc_add_block_to_block (&se->pre, &tmpse.pre);
4528 18 : tmp = tmpse.expr;
4529 : }
4530 :
4531 13302 : cond = fold_build2_loc (input_location, GT_EXPR,
4532 : logical_type_node, indexse.expr, tmp);
4533 13302 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4534 : "above upper bound of %%ld", n+1, var_name);
4535 13302 : gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
4536 : fold_convert (long_integer_type_node,
4537 : indexse.expr),
4538 : fold_convert (long_integer_type_node, tmp));
4539 13302 : free (msg);
4540 : }
4541 : }
4542 :
4543 : /* Multiply the index by the stride. */
4544 149228 : stride = gfc_conv_array_stride (decl, n);
4545 149228 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4546 : indexse.expr, stride);
4547 :
4548 : /* And add it to the total. */
4549 149228 : add_to_offset (&cst_offset, &offset, tmp);
4550 : }
4551 :
4552 122596 : if (!integer_zerop (cst_offset))
4553 65714 : offset = fold_build2_loc (input_location, PLUS_EXPR,
4554 : gfc_array_index_type, offset, cst_offset);
4555 :
4556 : /* A pointer array component can be detected from its field decl. Fix
4557 : the descriptor, mark the resulting variable decl and pass it to
4558 : build_array_ref. */
4559 122596 : decl = NULL_TREE;
4560 122596 : if (get_CFI_desc (sym, expr, &decl, ar))
4561 3589 : decl = build_fold_indirect_ref_loc (input_location, decl);
4562 121549 : if (!expr->ts.deferred && !sym->attr.codimension
4563 241923 : && is_pointer_array (se->expr))
4564 : {
4565 4879 : if (TREE_CODE (se->expr) == COMPONENT_REF)
4566 1454 : decl = se->expr;
4567 3425 : else if (INDIRECT_REF_P (se->expr))
4568 983 : decl = TREE_OPERAND (se->expr, 0);
4569 : else
4570 2442 : decl = se->expr;
4571 : }
4572 117717 : else if (expr->ts.deferred
4573 116670 : || (sym->ts.type == BT_CHARACTER
4574 15275 : && sym->attr.select_type_temporary))
4575 : {
4576 2751 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
4577 : {
4578 2595 : decl = se->expr;
4579 2595 : if (INDIRECT_REF_P (decl))
4580 20 : decl = TREE_OPERAND (decl, 0);
4581 : }
4582 : else
4583 156 : decl = sym->backend_decl;
4584 : }
4585 114966 : else if (sym->ts.type == BT_CLASS)
4586 : {
4587 2097 : if (UNLIMITED_POLY (sym))
4588 : {
4589 104 : gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr);
4590 104 : gfc_init_se (&tmpse, NULL);
4591 104 : gfc_conv_expr (&tmpse, class_expr);
4592 104 : if (!se->class_vptr)
4593 104 : se->class_vptr = gfc_class_vptr_get (tmpse.expr);
4594 104 : gfc_free_expr (class_expr);
4595 104 : decl = tmpse.expr;
4596 104 : }
4597 : else
4598 1993 : decl = NULL_TREE;
4599 : }
4600 :
4601 122596 : free (var_name);
4602 122596 : se->expr = build_array_ref (se->expr, offset, decl, se->class_vptr);
4603 : }
4604 :
4605 :
4606 : /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
4607 : LOOP_DIM dimension (if any) to array's offset. */
4608 :
4609 : static void
4610 59319 : add_array_offset (stmtblock_t *pblock, gfc_loopinfo *loop, gfc_ss *ss,
4611 : gfc_array_ref *ar, int array_dim, int loop_dim)
4612 : {
4613 59319 : gfc_se se;
4614 59319 : gfc_array_info *info;
4615 59319 : tree stride, index;
4616 :
4617 59319 : info = &ss->info->data.array;
4618 :
4619 59319 : gfc_init_se (&se, NULL);
4620 59319 : se.loop = loop;
4621 59319 : se.expr = info->descriptor;
4622 59319 : stride = gfc_conv_array_stride (info->descriptor, array_dim);
4623 59319 : index = conv_array_index_offset (&se, ss, array_dim, loop_dim, ar, stride);
4624 59319 : gfc_add_block_to_block (pblock, &se.pre);
4625 :
4626 59319 : info->offset = fold_build2_loc (input_location, PLUS_EXPR,
4627 : gfc_array_index_type,
4628 : info->offset, index);
4629 59319 : info->offset = gfc_evaluate_now (info->offset, pblock);
4630 59319 : }
4631 :
4632 :
4633 : /* Generate the code to be executed immediately before entering a
4634 : scalarization loop. */
4635 :
4636 : static void
4637 144240 : gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
4638 : stmtblock_t * pblock)
4639 : {
4640 144240 : tree stride;
4641 144240 : gfc_ss_info *ss_info;
4642 144240 : gfc_array_info *info;
4643 144240 : gfc_ss_type ss_type;
4644 144240 : gfc_ss *ss, *pss;
4645 144240 : gfc_loopinfo *ploop;
4646 144240 : gfc_array_ref *ar;
4647 :
4648 : /* This code will be executed before entering the scalarization loop
4649 : for this dimension. */
4650 439963 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4651 : {
4652 295723 : ss_info = ss->info;
4653 :
4654 295723 : if ((ss_info->useflags & flag) == 0)
4655 1476 : continue;
4656 :
4657 294247 : ss_type = ss_info->type;
4658 359280 : if (ss_type != GFC_SS_SECTION
4659 : && ss_type != GFC_SS_FUNCTION
4660 294247 : && ss_type != GFC_SS_CONSTRUCTOR
4661 294247 : && ss_type != GFC_SS_COMPONENT)
4662 65033 : continue;
4663 :
4664 229214 : info = &ss_info->data.array;
4665 :
4666 229214 : gcc_assert (dim < ss->dimen);
4667 229214 : gcc_assert (ss->dimen == loop->dimen);
4668 :
4669 229214 : if (info->ref)
4670 161658 : ar = &info->ref->u.ar;
4671 : else
4672 : ar = NULL;
4673 :
4674 229214 : if (dim == loop->dimen - 1 && loop->parent != NULL)
4675 : {
4676 : /* If we are in the outermost dimension of this loop, the previous
4677 : dimension shall be in the parent loop. */
4678 4687 : gcc_assert (ss->parent != NULL);
4679 :
4680 4687 : pss = ss->parent;
4681 4687 : ploop = loop->parent;
4682 :
4683 : /* ss and ss->parent are about the same array. */
4684 4687 : gcc_assert (ss_info == pss->info);
4685 : }
4686 : else
4687 : {
4688 : ploop = loop;
4689 : pss = ss;
4690 : }
4691 :
4692 229214 : if (dim == loop->dimen - 1 && loop->parent == NULL)
4693 : {
4694 174471 : gcc_assert (0 == ploop->order[0]);
4695 :
4696 348942 : stride = gfc_conv_array_stride (info->descriptor,
4697 174471 : innermost_ss (ss)->dim[0]);
4698 :
4699 : /* Calculate the stride of the innermost loop. Hopefully this will
4700 : allow the backend optimizers to do their stuff more effectively.
4701 : */
4702 174471 : info->stride0 = gfc_evaluate_now (stride, pblock);
4703 :
4704 : /* For the outermost loop calculate the offset due to any
4705 : elemental dimensions. It will have been initialized with the
4706 : base offset of the array. */
4707 174471 : if (info->ref)
4708 : {
4709 282858 : for (int i = 0; i < ar->dimen; i++)
4710 : {
4711 163860 : if (ar->dimen_type[i] != DIMEN_ELEMENT)
4712 159284 : continue;
4713 :
4714 4576 : add_array_offset (pblock, loop, ss, ar, i, /* unused */ -1);
4715 : }
4716 : }
4717 : }
4718 : else
4719 : {
4720 54743 : int i;
4721 :
4722 54743 : if (dim == loop->dimen - 1)
4723 : i = 0;
4724 : else
4725 50056 : i = dim + 1;
4726 :
4727 : /* For the time being, there is no loop reordering. */
4728 54743 : gcc_assert (i == ploop->order[i]);
4729 54743 : i = ploop->order[i];
4730 :
4731 : /* Add the offset for the previous loop dimension. */
4732 54743 : add_array_offset (pblock, ploop, ss, ar, pss->dim[i], i);
4733 : }
4734 :
4735 : /* Remember this offset for the second loop. */
4736 229214 : if (dim == loop->temp_dim - 1 && loop->parent == NULL)
4737 53328 : info->saved_offset = info->offset;
4738 : }
4739 144240 : }
4740 :
4741 :
4742 : /* Start a scalarized expression. Creates a scope and declares loop
4743 : variables. */
4744 :
4745 : void
4746 113960 : gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
4747 : {
4748 113960 : int dim;
4749 113960 : int n;
4750 113960 : int flags;
4751 :
4752 113960 : gcc_assert (!loop->array_parameter);
4753 :
4754 256620 : for (dim = loop->dimen - 1; dim >= 0; dim--)
4755 : {
4756 142660 : n = loop->order[dim];
4757 :
4758 142660 : gfc_start_block (&loop->code[n]);
4759 :
4760 : /* Create the loop variable. */
4761 142660 : loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
4762 :
4763 142660 : if (dim < loop->temp_dim)
4764 : flags = 3;
4765 : else
4766 97318 : flags = 1;
4767 : /* Calculate values that will be constant within this loop. */
4768 142660 : gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
4769 : }
4770 113960 : gfc_start_block (pbody);
4771 113960 : }
4772 :
4773 :
4774 : /* Generates the actual loop code for a scalarization loop. */
4775 :
4776 : static void
4777 157848 : gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
4778 : stmtblock_t * pbody)
4779 : {
4780 157848 : stmtblock_t block;
4781 157848 : tree cond;
4782 157848 : tree tmp;
4783 157848 : tree loopbody;
4784 157848 : tree exit_label;
4785 157848 : tree stmt;
4786 157848 : tree init;
4787 157848 : tree incr;
4788 :
4789 157848 : if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS
4790 : | OMPWS_SCALARIZER_BODY))
4791 : == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS)
4792 108 : && n == loop->dimen - 1)
4793 : {
4794 : /* We create an OMP_FOR construct for the outermost scalarized loop. */
4795 80 : init = make_tree_vec (1);
4796 80 : cond = make_tree_vec (1);
4797 80 : incr = make_tree_vec (1);
4798 :
4799 : /* Cycle statement is implemented with a goto. Exit statement must not
4800 : be present for this loop. */
4801 80 : exit_label = gfc_build_label_decl (NULL_TREE);
4802 80 : TREE_USED (exit_label) = 1;
4803 :
4804 : /* Label for cycle statements (if needed). */
4805 80 : tmp = build1_v (LABEL_EXPR, exit_label);
4806 80 : gfc_add_expr_to_block (pbody, tmp);
4807 :
4808 80 : stmt = make_node (OMP_FOR);
4809 :
4810 80 : TREE_TYPE (stmt) = void_type_node;
4811 80 : OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody);
4812 :
4813 80 : OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location,
4814 : OMP_CLAUSE_SCHEDULE);
4815 80 : OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt))
4816 80 : = OMP_CLAUSE_SCHEDULE_STATIC;
4817 80 : if (ompws_flags & OMPWS_NOWAIT)
4818 33 : OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt))
4819 66 : = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT);
4820 :
4821 : /* Initialize the loopvar. */
4822 80 : TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n],
4823 : loop->from[n]);
4824 80 : OMP_FOR_INIT (stmt) = init;
4825 : /* The exit condition. */
4826 80 : TREE_VEC_ELT (cond, 0) = build2_loc (input_location, LE_EXPR,
4827 : logical_type_node,
4828 : loop->loopvar[n], loop->to[n]);
4829 80 : SET_EXPR_LOCATION (TREE_VEC_ELT (cond, 0), input_location);
4830 80 : OMP_FOR_COND (stmt) = cond;
4831 : /* Increment the loopvar. */
4832 80 : tmp = build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4833 : loop->loopvar[n], gfc_index_one_node);
4834 80 : TREE_VEC_ELT (incr, 0) = fold_build2_loc (input_location, MODIFY_EXPR,
4835 : void_type_node, loop->loopvar[n], tmp);
4836 80 : OMP_FOR_INCR (stmt) = incr;
4837 :
4838 80 : ompws_flags &= ~OMPWS_CURR_SINGLEUNIT;
4839 80 : gfc_add_expr_to_block (&loop->code[n], stmt);
4840 : }
4841 : else
4842 : {
4843 315536 : bool reverse_loop = (loop->reverse[n] == GFC_REVERSE_SET)
4844 157768 : && (loop->temp_ss == NULL);
4845 :
4846 157768 : loopbody = gfc_finish_block (pbody);
4847 :
4848 157768 : if (reverse_loop)
4849 204 : std::swap (loop->from[n], loop->to[n]);
4850 :
4851 : /* Initialize the loopvar. */
4852 157768 : if (loop->loopvar[n] != loop->from[n])
4853 156947 : gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
4854 :
4855 157768 : exit_label = gfc_build_label_decl (NULL_TREE);
4856 :
4857 : /* Generate the loop body. */
4858 157768 : gfc_init_block (&block);
4859 :
4860 : /* The exit condition. */
4861 315332 : cond = fold_build2_loc (input_location, reverse_loop ? LT_EXPR : GT_EXPR,
4862 : logical_type_node, loop->loopvar[n], loop->to[n]);
4863 157768 : tmp = build1_v (GOTO_EXPR, exit_label);
4864 157768 : TREE_USED (exit_label) = 1;
4865 157768 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
4866 157768 : gfc_add_expr_to_block (&block, tmp);
4867 :
4868 : /* The main body. */
4869 157768 : gfc_add_expr_to_block (&block, loopbody);
4870 :
4871 : /* Increment the loopvar. */
4872 315332 : tmp = fold_build2_loc (input_location,
4873 : reverse_loop ? MINUS_EXPR : PLUS_EXPR,
4874 : gfc_array_index_type, loop->loopvar[n],
4875 : gfc_index_one_node);
4876 :
4877 157768 : gfc_add_modify (&block, loop->loopvar[n], tmp);
4878 :
4879 : /* Build the loop. */
4880 157768 : tmp = gfc_finish_block (&block);
4881 157768 : tmp = build1_v (LOOP_EXPR, tmp);
4882 157768 : gfc_add_expr_to_block (&loop->code[n], tmp);
4883 :
4884 : /* Add the exit label. */
4885 157768 : tmp = build1_v (LABEL_EXPR, exit_label);
4886 157768 : gfc_add_expr_to_block (&loop->code[n], tmp);
4887 : }
4888 :
4889 157848 : }
4890 :
4891 :
4892 : /* Finishes and generates the loops for a scalarized expression. */
4893 :
4894 : void
4895 119398 : gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
4896 : {
4897 119398 : int dim;
4898 119398 : int n;
4899 119398 : gfc_ss *ss;
4900 119398 : stmtblock_t *pblock;
4901 119398 : tree tmp;
4902 :
4903 119398 : pblock = body;
4904 : /* Generate the loops. */
4905 267487 : for (dim = 0; dim < loop->dimen; dim++)
4906 : {
4907 148089 : n = loop->order[dim];
4908 148089 : gfc_trans_scalarized_loop_end (loop, n, pblock);
4909 148089 : loop->loopvar[n] = NULL_TREE;
4910 148089 : pblock = &loop->code[n];
4911 : }
4912 :
4913 119398 : tmp = gfc_finish_block (pblock);
4914 119398 : gfc_add_expr_to_block (&loop->pre, tmp);
4915 :
4916 : /* Clear all the used flags. */
4917 350817 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4918 231419 : if (ss->parent == NULL)
4919 226669 : ss->info->useflags = 0;
4920 119398 : }
4921 :
4922 :
4923 : /* Finish the main body of a scalarized expression, and start the secondary
4924 : copying body. */
4925 :
4926 : void
4927 8179 : gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
4928 : {
4929 8179 : int dim;
4930 8179 : int n;
4931 8179 : stmtblock_t *pblock;
4932 8179 : gfc_ss *ss;
4933 :
4934 8179 : pblock = body;
4935 : /* We finish as many loops as are used by the temporary. */
4936 9759 : for (dim = 0; dim < loop->temp_dim - 1; dim++)
4937 : {
4938 1580 : n = loop->order[dim];
4939 1580 : gfc_trans_scalarized_loop_end (loop, n, pblock);
4940 1580 : loop->loopvar[n] = NULL_TREE;
4941 1580 : pblock = &loop->code[n];
4942 : }
4943 :
4944 : /* We don't want to finish the outermost loop entirely. */
4945 8179 : n = loop->order[loop->temp_dim - 1];
4946 8179 : gfc_trans_scalarized_loop_end (loop, n, pblock);
4947 :
4948 : /* Restore the initial offsets. */
4949 23403 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4950 : {
4951 15224 : gfc_ss_type ss_type;
4952 15224 : gfc_ss_info *ss_info;
4953 :
4954 15224 : ss_info = ss->info;
4955 :
4956 15224 : if ((ss_info->useflags & 2) == 0)
4957 4508 : continue;
4958 :
4959 10716 : ss_type = ss_info->type;
4960 10870 : if (ss_type != GFC_SS_SECTION
4961 : && ss_type != GFC_SS_FUNCTION
4962 10716 : && ss_type != GFC_SS_CONSTRUCTOR
4963 10716 : && ss_type != GFC_SS_COMPONENT)
4964 154 : continue;
4965 :
4966 10562 : ss_info->data.array.offset = ss_info->data.array.saved_offset;
4967 : }
4968 :
4969 : /* Restart all the inner loops we just finished. */
4970 9759 : for (dim = loop->temp_dim - 2; dim >= 0; dim--)
4971 : {
4972 1580 : n = loop->order[dim];
4973 :
4974 1580 : gfc_start_block (&loop->code[n]);
4975 :
4976 1580 : loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
4977 :
4978 1580 : gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
4979 : }
4980 :
4981 : /* Start a block for the secondary copying code. */
4982 8179 : gfc_start_block (body);
4983 8179 : }
4984 :
4985 :
4986 : /* Precalculate (either lower or upper) bound of an array section.
4987 : BLOCK: Block in which the (pre)calculation code will go.
4988 : BOUNDS[DIM]: Where the bound value will be stored once evaluated.
4989 : VALUES[DIM]: Specified bound (NULL <=> unspecified).
4990 : DESC: Array descriptor from which the bound will be picked if unspecified
4991 : (either lower or upper bound according to LBOUND). */
4992 :
4993 : static void
4994 509236 : evaluate_bound (stmtblock_t *block, tree *bounds, gfc_expr ** values,
4995 : tree desc, int dim, bool lbound, bool deferred, bool save_value)
4996 : {
4997 509236 : gfc_se se;
4998 509236 : gfc_expr * input_val = values[dim];
4999 509236 : tree *output = &bounds[dim];
5000 :
5001 509236 : if (input_val)
5002 : {
5003 : /* Specified section bound. */
5004 47010 : gfc_init_se (&se, NULL);
5005 47010 : gfc_conv_expr_type (&se, input_val, gfc_array_index_type);
5006 47010 : gfc_add_block_to_block (block, &se.pre);
5007 47010 : *output = se.expr;
5008 : }
5009 462226 : else if (deferred && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
5010 : {
5011 : /* The gfc_conv_array_lbound () routine returns a constant zero for
5012 : deferred length arrays, which in the scalarizer wreaks havoc, when
5013 : copying to a (newly allocated) one-based array.
5014 : Keep returning the actual result in sync for both bounds. */
5015 189068 : *output = lbound ? gfc_conv_descriptor_lbound_get (desc,
5016 : gfc_rank_cst[dim]):
5017 63132 : gfc_conv_descriptor_ubound_get (desc,
5018 : gfc_rank_cst[dim]);
5019 : }
5020 : else
5021 : {
5022 : /* No specific bound specified so use the bound of the array. */
5023 501045 : *output = lbound ? gfc_conv_array_lbound (desc, dim) :
5024 164755 : gfc_conv_array_ubound (desc, dim);
5025 : }
5026 509236 : if (save_value)
5027 490506 : *output = gfc_evaluate_now (*output, block);
5028 509236 : }
5029 :
5030 :
5031 : /* Calculate the lower bound of an array section. */
5032 :
5033 : static void
5034 255029 : gfc_conv_section_startstride (stmtblock_t * block, gfc_ss * ss, int dim)
5035 : {
5036 255029 : gfc_expr *stride = NULL;
5037 255029 : tree desc;
5038 255029 : gfc_se se;
5039 255029 : gfc_array_info *info;
5040 255029 : gfc_array_ref *ar;
5041 :
5042 255029 : gcc_assert (ss->info->type == GFC_SS_SECTION);
5043 :
5044 255029 : info = &ss->info->data.array;
5045 255029 : ar = &info->ref->u.ar;
5046 :
5047 255029 : if (ar->dimen_type[dim] == DIMEN_VECTOR)
5048 : {
5049 : /* We use a zero-based index to access the vector. */
5050 758 : info->start[dim] = gfc_index_zero_node;
5051 758 : info->end[dim] = NULL;
5052 758 : info->stride[dim] = gfc_index_one_node;
5053 758 : return;
5054 : }
5055 :
5056 254271 : gcc_assert (ar->dimen_type[dim] == DIMEN_RANGE
5057 : || ar->dimen_type[dim] == DIMEN_THIS_IMAGE);
5058 254271 : desc = info->descriptor;
5059 254271 : stride = ar->stride[dim];
5060 254271 : bool save_value = !ss->is_alloc_lhs;
5061 :
5062 : /* Calculate the start of the range. For vector subscripts this will
5063 : be the range of the vector. */
5064 254271 : evaluate_bound (block, info->start, ar->start, desc, dim, true,
5065 254271 : ar->as->type == AS_DEFERRED, save_value);
5066 :
5067 : /* Similarly calculate the end. Although this is not used in the
5068 : scalarizer, it is needed when checking bounds and where the end
5069 : is an expression with side-effects. */
5070 254271 : evaluate_bound (block, info->end, ar->end, desc, dim, false,
5071 254271 : ar->as->type == AS_DEFERRED, save_value);
5072 :
5073 :
5074 : /* Calculate the stride. */
5075 254271 : if (stride == NULL)
5076 241695 : info->stride[dim] = gfc_index_one_node;
5077 : else
5078 : {
5079 12576 : gfc_init_se (&se, NULL);
5080 12576 : gfc_conv_expr_type (&se, stride, gfc_array_index_type);
5081 12576 : gfc_add_block_to_block (block, &se.pre);
5082 12576 : tree value = se.expr;
5083 12576 : if (save_value)
5084 12576 : info->stride[dim] = gfc_evaluate_now (value, block);
5085 : else
5086 0 : info->stride[dim] = value;
5087 : }
5088 : }
5089 :
5090 :
5091 : /* Generate in INNER the bounds checking code along the dimension DIM for
5092 : the array associated with SS_INFO. */
5093 :
5094 : static void
5095 23995 : add_check_section_in_array_bounds (stmtblock_t *inner, gfc_ss_info *ss_info,
5096 : int dim)
5097 : {
5098 23995 : gfc_expr *expr = ss_info->expr;
5099 23995 : locus *expr_loc = &expr->where;
5100 23995 : const char *expr_name = expr->symtree->name;
5101 :
5102 23995 : gfc_array_info *info = &ss_info->data.array;
5103 :
5104 23995 : bool check_upper;
5105 23995 : if (dim == info->ref->u.ar.dimen - 1
5106 20386 : && info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
5107 : check_upper = false;
5108 : else
5109 23699 : check_upper = true;
5110 :
5111 : /* Zero stride is not allowed. */
5112 23995 : tree tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
5113 : info->stride[dim], gfc_index_zero_node);
5114 23995 : char * msg = xasprintf ("Zero stride is not allowed, for dimension %d "
5115 : "of array '%s'", dim + 1, expr_name);
5116 23995 : gfc_trans_runtime_check (true, false, tmp, inner, expr_loc, msg);
5117 23995 : free (msg);
5118 :
5119 23995 : tree desc = info->descriptor;
5120 :
5121 : /* This is the run-time equivalent of resolve.cc's
5122 : check_dimension. The logical is more readable there
5123 : than it is here, with all the trees. */
5124 23995 : tree lbound = gfc_conv_array_lbound (desc, dim);
5125 23995 : tree end = info->end[dim];
5126 23995 : tree ubound = check_upper ? gfc_conv_array_ubound (desc, dim) : NULL_TREE;
5127 :
5128 : /* non_zerosized is true when the selected range is not
5129 : empty. */
5130 23995 : tree stride_pos = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
5131 : info->stride[dim], gfc_index_zero_node);
5132 23995 : tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
5133 : info->start[dim], end);
5134 23995 : stride_pos = fold_build2_loc (input_location, TRUTH_AND_EXPR,
5135 : logical_type_node, stride_pos, tmp);
5136 :
5137 23995 : tree stride_neg = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
5138 : info->stride[dim], gfc_index_zero_node);
5139 23995 : tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
5140 : info->start[dim], end);
5141 23995 : stride_neg = fold_build2_loc (input_location, TRUTH_AND_EXPR,
5142 : logical_type_node, stride_neg, tmp);
5143 23995 : tree non_zerosized = fold_build2_loc (input_location, TRUTH_OR_EXPR,
5144 : logical_type_node, stride_pos,
5145 : stride_neg);
5146 :
5147 : /* Check the start of the range against the lower and upper
5148 : bounds of the array, if the range is not empty.
5149 : If upper bound is present, include both bounds in the
5150 : error message. */
5151 23995 : if (check_upper)
5152 : {
5153 23699 : tmp = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
5154 : info->start[dim], lbound);
5155 23699 : tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
5156 : non_zerosized, tmp);
5157 23699 : tree tmp2 = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
5158 : info->start[dim], ubound);
5159 23699 : tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
5160 : non_zerosized, tmp2);
5161 23699 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' outside of "
5162 : "expected range (%%ld:%%ld)", dim + 1, expr_name);
5163 23699 : gfc_trans_runtime_check (true, false, tmp, inner, expr_loc, msg,
5164 : fold_convert (long_integer_type_node, info->start[dim]),
5165 : fold_convert (long_integer_type_node, lbound),
5166 : fold_convert (long_integer_type_node, ubound));
5167 23699 : gfc_trans_runtime_check (true, false, tmp2, inner, expr_loc, msg,
5168 : fold_convert (long_integer_type_node, info->start[dim]),
5169 : fold_convert (long_integer_type_node, lbound),
5170 : fold_convert (long_integer_type_node, ubound));
5171 23699 : free (msg);
5172 : }
5173 : else
5174 : {
5175 296 : tmp = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
5176 : info->start[dim], lbound);
5177 296 : tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
5178 : non_zerosized, tmp);
5179 296 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' below "
5180 : "lower bound of %%ld", dim + 1, expr_name);
5181 296 : gfc_trans_runtime_check (true, false, tmp, inner, expr_loc, msg,
5182 : fold_convert (long_integer_type_node, info->start[dim]),
5183 : fold_convert (long_integer_type_node, lbound));
5184 296 : free (msg);
5185 : }
5186 :
5187 : /* Compute the last element of the range, which is not
5188 : necessarily "end" (think 0:5:3, which doesn't contain 5)
5189 : and check it against both lower and upper bounds. */
5190 :
5191 23995 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5192 : end, info->start[dim]);
5193 23995 : tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR, gfc_array_index_type,
5194 : tmp, info->stride[dim]);
5195 23995 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5196 : end, tmp);
5197 23995 : tree tmp2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
5198 : tmp, lbound);
5199 23995 : tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
5200 : non_zerosized, tmp2);
5201 23995 : if (check_upper)
5202 : {
5203 23699 : tree tmp3 = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
5204 : tmp, ubound);
5205 23699 : tmp3 = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
5206 : non_zerosized, tmp3);
5207 23699 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' outside of "
5208 : "expected range (%%ld:%%ld)", dim + 1, expr_name);
5209 23699 : gfc_trans_runtime_check (true, false, tmp2, inner, expr_loc, msg,
5210 : fold_convert (long_integer_type_node, tmp),
5211 : fold_convert (long_integer_type_node, ubound),
5212 : fold_convert (long_integer_type_node, lbound));
5213 23699 : gfc_trans_runtime_check (true, false, tmp3, inner, expr_loc, msg,
5214 : fold_convert (long_integer_type_node, tmp),
5215 : fold_convert (long_integer_type_node, ubound),
5216 : fold_convert (long_integer_type_node, lbound));
5217 23699 : free (msg);
5218 : }
5219 : else
5220 : {
5221 296 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' below "
5222 : "lower bound of %%ld", dim + 1, expr_name);
5223 296 : gfc_trans_runtime_check (true, false, tmp2, inner, expr_loc, msg,
5224 : fold_convert (long_integer_type_node, tmp),
5225 : fold_convert (long_integer_type_node, lbound));
5226 296 : free (msg);
5227 : }
5228 23995 : }
5229 :
5230 :
5231 : /* Tells whether we need to generate bounds checking code for the array
5232 : associated with SS. */
5233 :
5234 : bool
5235 24956 : bounds_check_needed (gfc_ss *ss)
5236 : {
5237 : /* Catch allocatable lhs in f2003. */
5238 24956 : if (flag_realloc_lhs && ss->no_bounds_check)
5239 : return false;
5240 :
5241 24679 : gfc_ss_info *ss_info = ss->info;
5242 24679 : if (ss_info->type == GFC_SS_SECTION)
5243 : return true;
5244 :
5245 4114 : if (!(ss_info->type == GFC_SS_INTRINSIC
5246 227 : && ss_info->expr
5247 227 : && ss_info->expr->expr_type == EXPR_FUNCTION))
5248 : return false;
5249 :
5250 227 : gfc_intrinsic_sym *isym = ss_info->expr->value.function.isym;
5251 227 : if (!(isym
5252 227 : && (isym->id == GFC_ISYM_MAXLOC
5253 203 : || isym->id == GFC_ISYM_MINLOC)))
5254 : return false;
5255 :
5256 34 : return gfc_inline_intrinsic_function_p (ss_info->expr);
5257 : }
5258 :
5259 :
5260 : /* Calculates the range start and stride for a SS chain. Also gets the
5261 : descriptor and data pointer. The range of vector subscripts is the size
5262 : of the vector. Array bounds are also checked. */
5263 :
5264 : void
5265 180418 : gfc_conv_ss_startstride (gfc_loopinfo * loop)
5266 : {
5267 180418 : int n;
5268 180418 : tree tmp;
5269 180418 : gfc_ss *ss;
5270 :
5271 180418 : gfc_loopinfo * const outer_loop = outermost_loop (loop);
5272 :
5273 180418 : loop->dimen = 0;
5274 : /* Determine the rank of the loop. */
5275 200343 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5276 : {
5277 200343 : switch (ss->info->type)
5278 : {
5279 169228 : case GFC_SS_SECTION:
5280 169228 : case GFC_SS_CONSTRUCTOR:
5281 169228 : case GFC_SS_FUNCTION:
5282 169228 : case GFC_SS_COMPONENT:
5283 169228 : loop->dimen = ss->dimen;
5284 169228 : goto done;
5285 :
5286 : /* As usual, lbound and ubound are exceptions!. */
5287 11190 : case GFC_SS_INTRINSIC:
5288 11190 : switch (ss->info->expr->value.function.isym->id)
5289 : {
5290 11190 : case GFC_ISYM_LBOUND:
5291 11190 : case GFC_ISYM_UBOUND:
5292 11190 : case GFC_ISYM_COSHAPE:
5293 11190 : case GFC_ISYM_LCOBOUND:
5294 11190 : case GFC_ISYM_UCOBOUND:
5295 11190 : case GFC_ISYM_MAXLOC:
5296 11190 : case GFC_ISYM_MINLOC:
5297 11190 : case GFC_ISYM_SHAPE:
5298 11190 : case GFC_ISYM_THIS_IMAGE:
5299 11190 : loop->dimen = ss->dimen;
5300 11190 : goto done;
5301 :
5302 : default:
5303 : break;
5304 : }
5305 :
5306 19925 : default:
5307 19925 : break;
5308 : }
5309 : }
5310 :
5311 : /* We should have determined the rank of the expression by now. If
5312 : not, that's bad news. */
5313 0 : gcc_unreachable ();
5314 :
5315 : done:
5316 : /* Loop over all the SS in the chain. */
5317 469357 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5318 : {
5319 288939 : gfc_ss_info *ss_info;
5320 288939 : gfc_array_info *info;
5321 288939 : gfc_expr *expr;
5322 :
5323 288939 : ss_info = ss->info;
5324 288939 : expr = ss_info->expr;
5325 288939 : info = &ss_info->data.array;
5326 :
5327 288939 : if (expr && expr->shape && !info->shape)
5328 167758 : info->shape = expr->shape;
5329 :
5330 288939 : switch (ss_info->type)
5331 : {
5332 183104 : case GFC_SS_SECTION:
5333 : /* Get the descriptor for the array. If it is a cross loops array,
5334 : we got the descriptor already in the outermost loop. */
5335 183104 : if (ss->parent == NULL)
5336 178468 : gfc_conv_ss_descriptor (&outer_loop->pre, ss,
5337 178468 : !loop->array_parameter);
5338 :
5339 437315 : for (n = 0; n < ss->dimen; n++)
5340 254211 : gfc_conv_section_startstride (&outer_loop->pre, ss, ss->dim[n]);
5341 : break;
5342 :
5343 11437 : case GFC_SS_INTRINSIC:
5344 11437 : switch (expr->value.function.isym->id)
5345 : {
5346 3281 : case GFC_ISYM_MINLOC:
5347 3281 : case GFC_ISYM_MAXLOC:
5348 3281 : {
5349 3281 : gfc_se se;
5350 3281 : gfc_init_se (&se, nullptr);
5351 3281 : se.loop = loop;
5352 3281 : se.ss = ss;
5353 3281 : gfc_conv_intrinsic_function (&se, expr);
5354 3281 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
5355 3281 : gfc_add_block_to_block (&outer_loop->post, &se.post);
5356 :
5357 3281 : info->descriptor = se.expr;
5358 :
5359 3281 : info->data = gfc_conv_array_data (info->descriptor);
5360 3281 : info->data = gfc_evaluate_now (info->data, &outer_loop->pre);
5361 :
5362 3281 : gfc_expr *array = expr->value.function.actual->expr;
5363 3281 : tree rank = build_int_cst (gfc_array_index_type, array->rank);
5364 :
5365 3281 : tree tmp = fold_build2_loc (input_location, MINUS_EXPR,
5366 : gfc_array_index_type, rank,
5367 : gfc_index_one_node);
5368 :
5369 3281 : info->end[0] = gfc_evaluate_now (tmp, &outer_loop->pre);
5370 3281 : info->start[0] = gfc_index_zero_node;
5371 3281 : info->stride[0] = gfc_index_one_node;
5372 3281 : info->offset = gfc_index_zero_node;
5373 3281 : continue;
5374 3281 : }
5375 :
5376 : /* Fall through to supply start and stride. */
5377 3004 : case GFC_ISYM_LBOUND:
5378 3004 : case GFC_ISYM_UBOUND:
5379 : /* This is the variant without DIM=... */
5380 3004 : gcc_assert (expr->value.function.actual->next->expr == NULL);
5381 : /* Fall through. */
5382 :
5383 7848 : case GFC_ISYM_SHAPE:
5384 7848 : {
5385 7848 : gfc_expr *arg;
5386 :
5387 7848 : arg = expr->value.function.actual->expr;
5388 7848 : if (arg->rank == -1)
5389 : {
5390 1175 : gfc_se se;
5391 1175 : tree rank, tmp;
5392 :
5393 : /* The rank (hence the return value's shape) is unknown,
5394 : we have to retrieve it. */
5395 1175 : gfc_init_se (&se, NULL);
5396 1175 : se.descriptor_only = 1;
5397 1175 : gfc_conv_expr (&se, arg);
5398 : /* This is a bare variable, so there is no preliminary
5399 : or cleanup code unless -std=f202y and bounds checking
5400 : is on. */
5401 1175 : if (!((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
5402 0 : && (gfc_option.allow_std & GFC_STD_F202Y)))
5403 1175 : gcc_assert (se.pre.head == NULL_TREE
5404 : && se.post.head == NULL_TREE);
5405 1175 : rank = gfc_conv_descriptor_rank (se.expr);
5406 1175 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
5407 : gfc_array_index_type,
5408 : fold_convert (gfc_array_index_type,
5409 : rank),
5410 : gfc_index_one_node);
5411 1175 : info->end[0] = gfc_evaluate_now (tmp, &outer_loop->pre);
5412 1175 : info->start[0] = gfc_index_zero_node;
5413 1175 : info->stride[0] = gfc_index_one_node;
5414 1175 : continue;
5415 1175 : }
5416 : /* Otherwise fall through GFC_SS_FUNCTION. */
5417 : gcc_fallthrough ();
5418 : }
5419 : case GFC_ISYM_COSHAPE:
5420 : case GFC_ISYM_LCOBOUND:
5421 : case GFC_ISYM_UCOBOUND:
5422 : case GFC_ISYM_THIS_IMAGE:
5423 : break;
5424 :
5425 0 : default:
5426 0 : continue;
5427 0 : }
5428 :
5429 : /* FALLTHRU */
5430 : case GFC_SS_CONSTRUCTOR:
5431 : case GFC_SS_FUNCTION:
5432 127740 : for (n = 0; n < ss->dimen; n++)
5433 : {
5434 69014 : int dim = ss->dim[n];
5435 :
5436 69014 : info->start[dim] = gfc_index_zero_node;
5437 69014 : if (ss_info->type != GFC_SS_FUNCTION)
5438 54685 : info->end[dim] = gfc_index_zero_node;
5439 69014 : info->stride[dim] = gfc_index_one_node;
5440 : }
5441 : break;
5442 :
5443 : default:
5444 : break;
5445 : }
5446 : }
5447 :
5448 : /* The rest is just runtime bounds checking. */
5449 180418 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
5450 : {
5451 16894 : stmtblock_t block;
5452 16894 : tree size[GFC_MAX_DIMENSIONS];
5453 16894 : tree tmp3;
5454 16894 : gfc_array_info *info;
5455 16894 : char *msg;
5456 16894 : int dim;
5457 :
5458 16894 : gfc_start_block (&block);
5459 :
5460 54098 : for (n = 0; n < loop->dimen; n++)
5461 20310 : size[n] = NULL_TREE;
5462 :
5463 : /* If there is a constructor involved, derive size[] from its shape. */
5464 39024 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5465 : {
5466 24610 : gfc_ss_info *ss_info;
5467 :
5468 24610 : ss_info = ss->info;
5469 24610 : info = &ss_info->data.array;
5470 :
5471 24610 : if (ss_info->type == GFC_SS_CONSTRUCTOR && info->shape)
5472 : {
5473 5224 : for (n = 0; n < loop->dimen; n++)
5474 : {
5475 2744 : if (size[n] == NULL)
5476 : {
5477 2744 : gcc_assert (info->shape[n]);
5478 2744 : size[n] = gfc_conv_mpz_to_tree (info->shape[n],
5479 : gfc_index_integer_kind);
5480 : }
5481 : }
5482 : break;
5483 : }
5484 : }
5485 :
5486 41850 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5487 : {
5488 24956 : stmtblock_t inner;
5489 24956 : gfc_ss_info *ss_info;
5490 24956 : gfc_expr *expr;
5491 24956 : locus *expr_loc;
5492 24956 : const char *expr_name;
5493 24956 : char *ref_name = NULL;
5494 :
5495 24956 : if (!bounds_check_needed (ss))
5496 4357 : continue;
5497 :
5498 20599 : ss_info = ss->info;
5499 20599 : expr = ss_info->expr;
5500 20599 : expr_loc = &expr->where;
5501 20599 : if (expr->ref)
5502 20565 : expr_name = ref_name = abridged_ref_name (expr, NULL);
5503 : else
5504 34 : expr_name = expr->symtree->name;
5505 :
5506 20599 : gfc_start_block (&inner);
5507 :
5508 : /* TODO: range checking for mapped dimensions. */
5509 20599 : info = &ss_info->data.array;
5510 :
5511 : /* This code only checks ranges. Elemental and vector
5512 : dimensions are checked later. */
5513 65241 : for (n = 0; n < loop->dimen; n++)
5514 : {
5515 24043 : dim = ss->dim[n];
5516 24043 : if (ss_info->type == GFC_SS_SECTION)
5517 : {
5518 24009 : if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
5519 14 : continue;
5520 :
5521 23995 : add_check_section_in_array_bounds (&inner, ss_info, dim);
5522 : }
5523 :
5524 : /* Check the section sizes match. */
5525 24029 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
5526 : gfc_array_index_type, info->end[dim],
5527 : info->start[dim]);
5528 24029 : tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
5529 : gfc_array_index_type, tmp,
5530 : info->stride[dim]);
5531 24029 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
5532 : gfc_array_index_type,
5533 : gfc_index_one_node, tmp);
5534 24029 : tmp = fold_build2_loc (input_location, MAX_EXPR,
5535 : gfc_array_index_type, tmp,
5536 : build_int_cst (gfc_array_index_type, 0));
5537 : /* We remember the size of the first section, and check all the
5538 : others against this. */
5539 24029 : if (size[n])
5540 : {
5541 7167 : tmp3 = fold_build2_loc (input_location, NE_EXPR,
5542 : logical_type_node, tmp, size[n]);
5543 7167 : if (ss_info->type == GFC_SS_INTRINSIC)
5544 0 : msg = xasprintf ("Extent mismatch for dimension %d of the "
5545 : "result of intrinsic '%s' (%%ld/%%ld)",
5546 : dim + 1, expr_name);
5547 : else
5548 7167 : msg = xasprintf ("Array bound mismatch for dimension %d "
5549 : "of array '%s' (%%ld/%%ld)",
5550 : dim + 1, expr_name);
5551 :
5552 7167 : gfc_trans_runtime_check (true, false, tmp3, &inner,
5553 : expr_loc, msg,
5554 : fold_convert (long_integer_type_node, tmp),
5555 : fold_convert (long_integer_type_node, size[n]));
5556 :
5557 7167 : free (msg);
5558 : }
5559 : else
5560 16862 : size[n] = gfc_evaluate_now (tmp, &inner);
5561 : }
5562 :
5563 20599 : tmp = gfc_finish_block (&inner);
5564 :
5565 : /* For optional arguments, only check bounds if the argument is
5566 : present. */
5567 20599 : if ((expr->symtree->n.sym->attr.optional
5568 20291 : || expr->symtree->n.sym->attr.not_always_present)
5569 308 : && expr->symtree->n.sym->attr.dummy)
5570 307 : tmp = build3_v (COND_EXPR,
5571 : gfc_conv_expr_present (expr->symtree->n.sym),
5572 : tmp, build_empty_stmt (input_location));
5573 :
5574 20599 : gfc_add_expr_to_block (&block, tmp);
5575 :
5576 20599 : free (ref_name);
5577 : }
5578 :
5579 16894 : tmp = gfc_finish_block (&block);
5580 16894 : gfc_add_expr_to_block (&outer_loop->pre, tmp);
5581 : }
5582 :
5583 183782 : for (loop = loop->nested; loop; loop = loop->next)
5584 3364 : gfc_conv_ss_startstride (loop);
5585 180418 : }
5586 :
5587 : /* Return true if both symbols could refer to the same data object. Does
5588 : not take account of aliasing due to equivalence statements. */
5589 :
5590 : static bool
5591 13460 : symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym, bool lsym_pointer,
5592 : bool lsym_target, bool rsym_pointer, bool rsym_target)
5593 : {
5594 : /* Aliasing isn't possible if the symbols have different base types,
5595 : except for complex types where an inquiry reference (%RE, %IM) could
5596 : alias with a real type with the same kind parameter. */
5597 13460 : if (!gfc_compare_types (&lsym->ts, &rsym->ts)
5598 13460 : && !(((lsym->ts.type == BT_COMPLEX && rsym->ts.type == BT_REAL)
5599 4767 : || (lsym->ts.type == BT_REAL && rsym->ts.type == BT_COMPLEX))
5600 76 : && lsym->ts.kind == rsym->ts.kind))
5601 : return false;
5602 :
5603 : /* Pointers can point to other pointers and target objects. */
5604 :
5605 8706 : if ((lsym_pointer && (rsym_pointer || rsym_target))
5606 8497 : || (rsym_pointer && (lsym_pointer || lsym_target)))
5607 : return true;
5608 :
5609 : /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
5610 : and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
5611 : checked above. */
5612 8583 : if (lsym_target && rsym_target
5613 14 : && ((lsym->attr.dummy && !lsym->attr.contiguous
5614 0 : && (!lsym->attr.dimension || lsym->as->type == AS_ASSUMED_SHAPE))
5615 14 : || (rsym->attr.dummy && !rsym->attr.contiguous
5616 6 : && (!rsym->attr.dimension
5617 6 : || rsym->as->type == AS_ASSUMED_SHAPE))))
5618 6 : return true;
5619 :
5620 : return false;
5621 : }
5622 :
5623 :
5624 : /* Return true if the two SS could be aliased, i.e. both point to the same data
5625 : object. */
5626 : /* TODO: resolve aliases based on frontend expressions. */
5627 :
5628 : static int
5629 11402 : gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
5630 : {
5631 11402 : gfc_ref *lref;
5632 11402 : gfc_ref *rref;
5633 11402 : gfc_expr *lexpr, *rexpr;
5634 11402 : gfc_symbol *lsym;
5635 11402 : gfc_symbol *rsym;
5636 11402 : bool lsym_pointer, lsym_target, rsym_pointer, rsym_target;
5637 :
5638 11402 : lexpr = lss->info->expr;
5639 11402 : rexpr = rss->info->expr;
5640 :
5641 11402 : lsym = lexpr->symtree->n.sym;
5642 11402 : rsym = rexpr->symtree->n.sym;
5643 :
5644 11402 : lsym_pointer = lsym->attr.pointer;
5645 11402 : lsym_target = lsym->attr.target;
5646 11402 : rsym_pointer = rsym->attr.pointer;
5647 11402 : rsym_target = rsym->attr.target;
5648 :
5649 11402 : if (symbols_could_alias (lsym, rsym, lsym_pointer, lsym_target,
5650 : rsym_pointer, rsym_target))
5651 : return 1;
5652 :
5653 11311 : if (rsym->ts.type != BT_DERIVED && rsym->ts.type != BT_CLASS
5654 10080 : && lsym->ts.type != BT_DERIVED && lsym->ts.type != BT_CLASS)
5655 : return 0;
5656 :
5657 : /* For derived types we must check all the component types. We can ignore
5658 : array references as these will have the same base type as the previous
5659 : component ref. */
5660 2548 : for (lref = lexpr->ref; lref != lss->info->data.array.ref; lref = lref->next)
5661 : {
5662 923 : if (lref->type != REF_COMPONENT)
5663 89 : continue;
5664 :
5665 834 : lsym_pointer = lsym_pointer || lref->u.c.sym->attr.pointer;
5666 834 : lsym_target = lsym_target || lref->u.c.sym->attr.target;
5667 :
5668 834 : if (symbols_could_alias (lref->u.c.sym, rsym, lsym_pointer, lsym_target,
5669 : rsym_pointer, rsym_target))
5670 : return 1;
5671 :
5672 834 : if ((lsym_pointer && (rsym_pointer || rsym_target))
5673 819 : || (rsym_pointer && (lsym_pointer || lsym_target)))
5674 : {
5675 6 : if (gfc_compare_types (&lref->u.c.component->ts,
5676 : &rsym->ts))
5677 : return 1;
5678 : }
5679 :
5680 1264 : for (rref = rexpr->ref; rref != rss->info->data.array.ref;
5681 436 : rref = rref->next)
5682 : {
5683 437 : if (rref->type != REF_COMPONENT)
5684 36 : continue;
5685 :
5686 401 : rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
5687 401 : rsym_target = lsym_target || rref->u.c.sym->attr.target;
5688 :
5689 401 : if (symbols_could_alias (lref->u.c.sym, rref->u.c.sym,
5690 : lsym_pointer, lsym_target,
5691 : rsym_pointer, rsym_target))
5692 : return 1;
5693 :
5694 400 : if ((lsym_pointer && (rsym_pointer || rsym_target))
5695 396 : || (rsym_pointer && (lsym_pointer || lsym_target)))
5696 : {
5697 0 : if (gfc_compare_types (&lref->u.c.component->ts,
5698 0 : &rref->u.c.sym->ts))
5699 : return 1;
5700 0 : if (gfc_compare_types (&lref->u.c.sym->ts,
5701 0 : &rref->u.c.component->ts))
5702 : return 1;
5703 0 : if (gfc_compare_types (&lref->u.c.component->ts,
5704 0 : &rref->u.c.component->ts))
5705 : return 1;
5706 : }
5707 : }
5708 : }
5709 :
5710 1625 : lsym_pointer = lsym->attr.pointer;
5711 1625 : lsym_target = lsym->attr.target;
5712 :
5713 2442 : for (rref = rexpr->ref; rref != rss->info->data.array.ref; rref = rref->next)
5714 : {
5715 970 : if (rref->type != REF_COMPONENT)
5716 : break;
5717 :
5718 823 : rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
5719 823 : rsym_target = lsym_target || rref->u.c.sym->attr.target;
5720 :
5721 823 : if (symbols_could_alias (rref->u.c.sym, lsym,
5722 : lsym_pointer, lsym_target,
5723 : rsym_pointer, rsym_target))
5724 : return 1;
5725 :
5726 823 : if ((lsym_pointer && (rsym_pointer || rsym_target))
5727 805 : || (rsym_pointer && (lsym_pointer || lsym_target)))
5728 : {
5729 6 : if (gfc_compare_types (&lsym->ts, &rref->u.c.component->ts))
5730 : return 1;
5731 : }
5732 : }
5733 :
5734 : return 0;
5735 : }
5736 :
5737 :
5738 : /* Resolve array data dependencies. Creates a temporary if required. */
5739 : /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
5740 : dependency.cc. */
5741 :
5742 : void
5743 37479 : gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
5744 : gfc_ss * rss)
5745 : {
5746 37479 : gfc_ss *ss;
5747 37479 : gfc_ref *lref;
5748 37479 : gfc_ref *rref;
5749 37479 : gfc_ss_info *ss_info;
5750 37479 : gfc_expr *dest_expr;
5751 37479 : gfc_expr *ss_expr;
5752 37479 : int nDepend = 0;
5753 37479 : int i, j;
5754 :
5755 37479 : loop->temp_ss = NULL;
5756 37479 : dest_expr = dest->info->expr;
5757 :
5758 80707 : for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
5759 : {
5760 44383 : ss_info = ss->info;
5761 44383 : ss_expr = ss_info->expr;
5762 :
5763 44383 : if (ss_info->array_outer_dependency)
5764 : {
5765 : nDepend = 1;
5766 : break;
5767 : }
5768 :
5769 44266 : if (ss_info->type != GFC_SS_SECTION)
5770 : {
5771 30247 : if (flag_realloc_lhs
5772 29215 : && dest_expr != ss_expr
5773 29215 : && gfc_is_reallocatable_lhs (dest_expr)
5774 37235 : && ss_expr->rank)
5775 3330 : nDepend = gfc_check_dependency (dest_expr, ss_expr, true);
5776 :
5777 : /* Check for cases like c(:)(1:2) = c(2)(2:3) */
5778 30247 : if (!nDepend && dest_expr->rank > 0
5779 29755 : && dest_expr->ts.type == BT_CHARACTER
5780 4748 : && ss_expr->expr_type == EXPR_VARIABLE)
5781 :
5782 165 : nDepend = gfc_check_dependency (dest_expr, ss_expr, false);
5783 :
5784 30247 : if (ss_info->type == GFC_SS_REFERENCE
5785 30247 : && gfc_check_dependency (dest_expr, ss_expr, false))
5786 182 : ss_info->data.scalar.needs_temporary = 1;
5787 :
5788 30247 : if (nDepend)
5789 : break;
5790 : else
5791 29743 : continue;
5792 : }
5793 :
5794 14019 : if (dest_expr->symtree->n.sym != ss_expr->symtree->n.sym)
5795 : {
5796 11402 : if (gfc_could_be_alias (dest, ss)
5797 11402 : || gfc_are_equivalenced_arrays (dest_expr, ss_expr))
5798 : {
5799 : nDepend = 1;
5800 : break;
5801 : }
5802 : }
5803 : else
5804 : {
5805 2617 : lref = dest_expr->ref;
5806 2617 : rref = ss_expr->ref;
5807 :
5808 2617 : nDepend = gfc_dep_resolver (lref, rref, &loop->reverse[0]);
5809 :
5810 2617 : if (nDepend == 1)
5811 : break;
5812 :
5813 5222 : for (i = 0; i < dest->dimen; i++)
5814 7214 : for (j = 0; j < ss->dimen; j++)
5815 4320 : if (i != j
5816 1363 : && dest->dim[i] == ss->dim[j])
5817 : {
5818 : /* If we don't access array elements in the same order,
5819 : there is a dependency. */
5820 63 : nDepend = 1;
5821 63 : goto temporary;
5822 : }
5823 : #if 0
5824 : /* TODO : loop shifting. */
5825 : if (nDepend == 1)
5826 : {
5827 : /* Mark the dimensions for LOOP SHIFTING */
5828 : for (n = 0; n < loop->dimen; n++)
5829 : {
5830 : int dim = dest->data.info.dim[n];
5831 :
5832 : if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
5833 : depends[n] = 2;
5834 : else if (! gfc_is_same_range (&lref->u.ar,
5835 : &rref->u.ar, dim, 0))
5836 : depends[n] = 1;
5837 : }
5838 :
5839 : /* Put all the dimensions with dependencies in the
5840 : innermost loops. */
5841 : dim = 0;
5842 : for (n = 0; n < loop->dimen; n++)
5843 : {
5844 : gcc_assert (loop->order[n] == n);
5845 : if (depends[n])
5846 : loop->order[dim++] = n;
5847 : }
5848 : for (n = 0; n < loop->dimen; n++)
5849 : {
5850 : if (! depends[n])
5851 : loop->order[dim++] = n;
5852 : }
5853 :
5854 : gcc_assert (dim == loop->dimen);
5855 : break;
5856 : }
5857 : #endif
5858 : }
5859 : }
5860 :
5861 793 : temporary:
5862 :
5863 37479 : if (nDepend == 1)
5864 : {
5865 1155 : tree base_type = gfc_typenode_for_spec (&dest_expr->ts);
5866 1155 : if (GFC_ARRAY_TYPE_P (base_type)
5867 1155 : || GFC_DESCRIPTOR_TYPE_P (base_type))
5868 0 : base_type = gfc_get_element_type (base_type);
5869 1155 : loop->temp_ss = gfc_get_temp_ss (base_type, dest->info->string_length,
5870 : loop->dimen);
5871 1155 : gfc_add_ss_to_loop (loop, loop->temp_ss);
5872 : }
5873 : else
5874 36324 : loop->temp_ss = NULL;
5875 37479 : }
5876 :
5877 :
5878 : /* Browse through each array's information from the scalarizer and set the loop
5879 : bounds according to the "best" one (per dimension), i.e. the one which
5880 : provides the most information (constant bounds, shape, etc.). */
5881 :
5882 : static void
5883 180418 : set_loop_bounds (gfc_loopinfo *loop)
5884 : {
5885 180418 : int n, dim, spec_dim;
5886 180418 : gfc_array_info *info;
5887 180418 : gfc_array_info *specinfo;
5888 180418 : gfc_ss *ss;
5889 180418 : tree tmp;
5890 180418 : gfc_ss **loopspec;
5891 180418 : bool dynamic[GFC_MAX_DIMENSIONS];
5892 180418 : mpz_t *cshape;
5893 180418 : mpz_t i;
5894 180418 : bool nonoptional_arr;
5895 :
5896 180418 : gfc_loopinfo * const outer_loop = outermost_loop (loop);
5897 :
5898 180418 : loopspec = loop->specloop;
5899 :
5900 180418 : mpz_init (i);
5901 426086 : for (n = 0; n < loop->dimen; n++)
5902 : {
5903 245668 : loopspec[n] = NULL;
5904 245668 : dynamic[n] = false;
5905 :
5906 : /* If there are both optional and nonoptional array arguments, scalarize
5907 : over the nonoptional; otherwise, it does not matter as then all
5908 : (optional) arrays have to be present per F2008, 125.2.12p3(6). */
5909 :
5910 245668 : nonoptional_arr = false;
5911 :
5912 286350 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5913 286330 : if (ss->info->type != GFC_SS_SCALAR && ss->info->type != GFC_SS_TEMP
5914 252221 : && ss->info->type != GFC_SS_REFERENCE && !ss->info->can_be_null_ref)
5915 : {
5916 : nonoptional_arr = true;
5917 : break;
5918 : }
5919 :
5920 : /* We use one SS term, and use that to determine the bounds of the
5921 : loop for this dimension. We try to pick the simplest term. */
5922 643308 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5923 : {
5924 397640 : gfc_ss_type ss_type;
5925 :
5926 397640 : ss_type = ss->info->type;
5927 466788 : if (ss_type == GFC_SS_SCALAR
5928 397640 : || ss_type == GFC_SS_TEMP
5929 337744 : || ss_type == GFC_SS_REFERENCE
5930 328769 : || (ss->info->can_be_null_ref && nonoptional_arr))
5931 69148 : continue;
5932 :
5933 328492 : info = &ss->info->data.array;
5934 328492 : dim = ss->dim[n];
5935 :
5936 328492 : if (loopspec[n] != NULL)
5937 : {
5938 82824 : specinfo = &loopspec[n]->info->data.array;
5939 82824 : spec_dim = loopspec[n]->dim[n];
5940 : }
5941 : else
5942 : {
5943 : /* Silence uninitialized warnings. */
5944 : specinfo = NULL;
5945 : spec_dim = 0;
5946 : }
5947 :
5948 328492 : if (info->shape)
5949 : {
5950 : /* The frontend has worked out the size for us. */
5951 222345 : if (!loopspec[n]
5952 58632 : || !specinfo->shape
5953 268509 : || !integer_zerop (specinfo->start[spec_dim]))
5954 : /* Prefer zero-based descriptors if possible. */
5955 205512 : loopspec[n] = ss;
5956 222345 : continue;
5957 : }
5958 :
5959 106147 : if (ss_type == GFC_SS_CONSTRUCTOR)
5960 : {
5961 1348 : gfc_constructor_base base;
5962 : /* An unknown size constructor will always be rank one.
5963 : Higher rank constructors will either have known shape,
5964 : or still be wrapped in a call to reshape. */
5965 1348 : gcc_assert (loop->dimen == 1);
5966 :
5967 : /* Always prefer to use the constructor bounds if the size
5968 : can be determined at compile time. Prefer not to otherwise,
5969 : since the general case involves realloc, and it's better to
5970 : avoid that overhead if possible. */
5971 1348 : base = ss->info->expr->value.constructor;
5972 1348 : dynamic[n] = gfc_get_array_constructor_size (&i, base);
5973 1348 : if (!dynamic[n] || !loopspec[n])
5974 1161 : loopspec[n] = ss;
5975 1348 : continue;
5976 1348 : }
5977 :
5978 : /* Avoid using an allocatable lhs in an assignment, since
5979 : there might be a reallocation coming. */
5980 104799 : if (loopspec[n] && ss->is_alloc_lhs)
5981 9365 : continue;
5982 :
5983 95434 : if (!loopspec[n])
5984 80794 : loopspec[n] = ss;
5985 : /* Criteria for choosing a loop specifier (most important first):
5986 : doesn't need realloc
5987 : stride of one
5988 : known stride
5989 : known lower bound
5990 : known upper bound
5991 : */
5992 14640 : else if (loopspec[n]->info->type == GFC_SS_CONSTRUCTOR && dynamic[n])
5993 186 : loopspec[n] = ss;
5994 14454 : else if (integer_onep (info->stride[dim])
5995 14454 : && !integer_onep (specinfo->stride[spec_dim]))
5996 120 : loopspec[n] = ss;
5997 14334 : else if (INTEGER_CST_P (info->stride[dim])
5998 14110 : && !INTEGER_CST_P (specinfo->stride[spec_dim]))
5999 0 : loopspec[n] = ss;
6000 14334 : else if (INTEGER_CST_P (info->start[dim])
6001 4351 : && !INTEGER_CST_P (specinfo->start[spec_dim])
6002 844 : && integer_onep (info->stride[dim])
6003 422 : == integer_onep (specinfo->stride[spec_dim])
6004 14334 : && INTEGER_CST_P (info->stride[dim])
6005 395 : == INTEGER_CST_P (specinfo->stride[spec_dim]))
6006 395 : loopspec[n] = ss;
6007 : /* We don't work out the upper bound.
6008 : else if (INTEGER_CST_P (info->finish[n])
6009 : && ! INTEGER_CST_P (specinfo->finish[n]))
6010 : loopspec[n] = ss; */
6011 : }
6012 :
6013 : /* We should have found the scalarization loop specifier. If not,
6014 : that's bad news. */
6015 245668 : gcc_assert (loopspec[n]);
6016 :
6017 245668 : info = &loopspec[n]->info->data.array;
6018 245668 : dim = loopspec[n]->dim[n];
6019 :
6020 : /* Set the extents of this range. */
6021 245668 : cshape = info->shape;
6022 245668 : if (cshape && INTEGER_CST_P (info->start[dim])
6023 175982 : && INTEGER_CST_P (info->stride[dim]))
6024 : {
6025 175982 : loop->from[n] = info->start[dim];
6026 175982 : mpz_set (i, cshape[get_array_ref_dim_for_loop_dim (loopspec[n], n)]);
6027 175982 : mpz_sub_ui (i, i, 1);
6028 : /* To = from + (size - 1) * stride. */
6029 175982 : tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
6030 175982 : if (!integer_onep (info->stride[dim]))
6031 8611 : tmp = fold_build2_loc (input_location, MULT_EXPR,
6032 : gfc_array_index_type, tmp,
6033 : info->stride[dim]);
6034 175982 : loop->to[n] = fold_build2_loc (input_location, PLUS_EXPR,
6035 : gfc_array_index_type,
6036 : loop->from[n], tmp);
6037 : }
6038 : else
6039 : {
6040 69686 : loop->from[n] = info->start[dim];
6041 69686 : switch (loopspec[n]->info->type)
6042 : {
6043 874 : case GFC_SS_CONSTRUCTOR:
6044 : /* The upper bound is calculated when we expand the
6045 : constructor. */
6046 874 : gcc_assert (loop->to[n] == NULL_TREE);
6047 : break;
6048 :
6049 63290 : case GFC_SS_SECTION:
6050 : /* Use the end expression if it exists and is not constant,
6051 : so that it is only evaluated once. */
6052 63290 : loop->to[n] = info->end[dim];
6053 63290 : break;
6054 :
6055 4743 : case GFC_SS_FUNCTION:
6056 : /* The loop bound will be set when we generate the call. */
6057 4743 : gcc_assert (loop->to[n] == NULL_TREE);
6058 : break;
6059 :
6060 767 : case GFC_SS_INTRINSIC:
6061 767 : {
6062 767 : gfc_expr *expr = loopspec[n]->info->expr;
6063 :
6064 : /* The {l,u}bound of an assumed rank. */
6065 767 : if (expr->value.function.isym->id == GFC_ISYM_SHAPE)
6066 255 : gcc_assert (expr->value.function.actual->expr->rank == -1);
6067 : else
6068 512 : gcc_assert ((expr->value.function.isym->id == GFC_ISYM_LBOUND
6069 : || expr->value.function.isym->id == GFC_ISYM_UBOUND)
6070 : && expr->value.function.actual->next->expr == NULL
6071 : && expr->value.function.actual->expr->rank == -1);
6072 :
6073 767 : loop->to[n] = info->end[dim];
6074 767 : break;
6075 : }
6076 :
6077 12 : case GFC_SS_COMPONENT:
6078 12 : {
6079 12 : if (info->end[dim] != NULL_TREE)
6080 : {
6081 12 : loop->to[n] = info->end[dim];
6082 12 : break;
6083 : }
6084 : else
6085 0 : gcc_unreachable ();
6086 : }
6087 :
6088 0 : default:
6089 0 : gcc_unreachable ();
6090 : }
6091 : }
6092 :
6093 : /* Transform everything so we have a simple incrementing variable. */
6094 245668 : if (integer_onep (info->stride[dim]))
6095 234942 : info->delta[dim] = gfc_index_zero_node;
6096 : else
6097 : {
6098 : /* Set the delta for this section. */
6099 10726 : info->delta[dim] = gfc_evaluate_now (loop->from[n], &outer_loop->pre);
6100 : /* Number of iterations is (end - start + step) / step.
6101 : with start = 0, this simplifies to
6102 : last = end / step;
6103 : for (i = 0; i<=last; i++){...}; */
6104 10726 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
6105 : gfc_array_index_type, loop->to[n],
6106 : loop->from[n]);
6107 10726 : tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
6108 : gfc_array_index_type, tmp, info->stride[dim]);
6109 10726 : tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
6110 : tmp, build_int_cst (gfc_array_index_type, -1));
6111 10726 : loop->to[n] = gfc_evaluate_now (tmp, &outer_loop->pre);
6112 : /* Make the loop variable start at 0. */
6113 10726 : loop->from[n] = gfc_index_zero_node;
6114 : }
6115 : }
6116 180418 : mpz_clear (i);
6117 :
6118 183782 : for (loop = loop->nested; loop; loop = loop->next)
6119 3364 : set_loop_bounds (loop);
6120 180418 : }
6121 :
6122 :
6123 : /* Last attempt to set the loop bounds, in case they depend on an allocatable
6124 : function result. */
6125 :
6126 : static void
6127 180418 : late_set_loop_bounds (gfc_loopinfo *loop)
6128 : {
6129 180418 : int n, dim;
6130 180418 : gfc_array_info *info;
6131 180418 : gfc_ss **loopspec;
6132 :
6133 180418 : loopspec = loop->specloop;
6134 :
6135 426086 : for (n = 0; n < loop->dimen; n++)
6136 : {
6137 : /* Set the extents of this range. */
6138 245668 : if (loop->from[n] == NULL_TREE
6139 245668 : || loop->to[n] == NULL_TREE)
6140 : {
6141 : /* We should have found the scalarization loop specifier. If not,
6142 : that's bad news. */
6143 437 : gcc_assert (loopspec[n]);
6144 :
6145 437 : info = &loopspec[n]->info->data.array;
6146 437 : dim = loopspec[n]->dim[n];
6147 :
6148 437 : if (loopspec[n]->info->type == GFC_SS_FUNCTION
6149 437 : && info->start[dim]
6150 437 : && info->end[dim])
6151 : {
6152 153 : loop->from[n] = info->start[dim];
6153 153 : loop->to[n] = info->end[dim];
6154 : }
6155 : }
6156 : }
6157 :
6158 183782 : for (loop = loop->nested; loop; loop = loop->next)
6159 3364 : late_set_loop_bounds (loop);
6160 180418 : }
6161 :
6162 :
6163 : /* Initialize the scalarization loop. Creates the loop variables. Determines
6164 : the range of the loop variables. Creates a temporary if required.
6165 : Also generates code for scalar expressions which have been
6166 : moved outside the loop. */
6167 :
6168 : void
6169 177054 : gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
6170 : {
6171 177054 : gfc_ss *tmp_ss;
6172 177054 : tree tmp;
6173 :
6174 177054 : set_loop_bounds (loop);
6175 :
6176 : /* Add all the scalar code that can be taken out of the loops.
6177 : This may include calculating the loop bounds, so do it before
6178 : allocating the temporary. */
6179 177054 : gfc_add_loop_ss_code (loop, loop->ss, false, where);
6180 :
6181 177054 : late_set_loop_bounds (loop);
6182 :
6183 177054 : tmp_ss = loop->temp_ss;
6184 : /* If we want a temporary then create it. */
6185 177054 : if (tmp_ss != NULL)
6186 : {
6187 11014 : gfc_ss_info *tmp_ss_info;
6188 :
6189 11014 : tmp_ss_info = tmp_ss->info;
6190 11014 : gcc_assert (tmp_ss_info->type == GFC_SS_TEMP);
6191 11014 : gcc_assert (loop->parent == NULL);
6192 :
6193 : /* Make absolutely sure that this is a complete type. */
6194 11014 : if (tmp_ss_info->string_length)
6195 2753 : tmp_ss_info->data.temp.type
6196 2753 : = gfc_get_character_type_len_for_eltype
6197 2753 : (TREE_TYPE (tmp_ss_info->data.temp.type),
6198 : tmp_ss_info->string_length);
6199 :
6200 11014 : tmp = tmp_ss_info->data.temp.type;
6201 11014 : memset (&tmp_ss_info->data.array, 0, sizeof (gfc_array_info));
6202 11014 : tmp_ss_info->type = GFC_SS_SECTION;
6203 :
6204 11014 : gcc_assert (tmp_ss->dimen != 0);
6205 :
6206 11014 : gfc_trans_create_temp_array (&loop->pre, &loop->post, tmp_ss, tmp,
6207 : NULL_TREE, false, true, false, where);
6208 : }
6209 :
6210 : /* For array parameters we don't have loop variables, so don't calculate the
6211 : translations. */
6212 177054 : if (!loop->array_parameter)
6213 110780 : gfc_set_delta (loop);
6214 177054 : }
6215 :
6216 :
6217 : /* Calculates how to transform from loop variables to array indices for each
6218 : array: once loop bounds are chosen, sets the difference (DELTA field) between
6219 : loop bounds and array reference bounds, for each array info. */
6220 :
6221 : void
6222 114575 : gfc_set_delta (gfc_loopinfo *loop)
6223 : {
6224 114575 : gfc_ss *ss, **loopspec;
6225 114575 : gfc_array_info *info;
6226 114575 : tree tmp;
6227 114575 : int n, dim;
6228 :
6229 114575 : gfc_loopinfo * const outer_loop = outermost_loop (loop);
6230 :
6231 114575 : loopspec = loop->specloop;
6232 :
6233 : /* Calculate the translation from loop variables to array indices. */
6234 347478 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
6235 : {
6236 232903 : gfc_ss_type ss_type;
6237 :
6238 232903 : ss_type = ss->info->type;
6239 60300 : if (!(ss_type == GFC_SS_SECTION
6240 232903 : || ss_type == GFC_SS_COMPONENT
6241 95399 : || ss_type == GFC_SS_CONSTRUCTOR
6242 : || (ss_type == GFC_SS_FUNCTION
6243 8237 : && gfc_is_class_array_function (ss->info->expr))))
6244 60148 : continue;
6245 :
6246 172755 : info = &ss->info->data.array;
6247 :
6248 389574 : for (n = 0; n < ss->dimen; n++)
6249 : {
6250 : /* If we are specifying the range the delta is already set. */
6251 216819 : if (loopspec[n] != ss)
6252 : {
6253 112829 : dim = ss->dim[n];
6254 :
6255 : /* Calculate the offset relative to the loop variable.
6256 : First multiply by the stride. */
6257 112829 : tmp = loop->from[n];
6258 112829 : if (!integer_onep (info->stride[dim]))
6259 2988 : tmp = fold_build2_loc (input_location, MULT_EXPR,
6260 : gfc_array_index_type,
6261 : tmp, info->stride[dim]);
6262 :
6263 : /* Then subtract this from our starting value. */
6264 112829 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
6265 : gfc_array_index_type,
6266 : info->start[dim], tmp);
6267 :
6268 112829 : if (ss->is_alloc_lhs)
6269 9365 : info->delta[dim] = tmp;
6270 : else
6271 103464 : info->delta[dim] = gfc_evaluate_now (tmp, &outer_loop->pre);
6272 : }
6273 : }
6274 : }
6275 :
6276 118027 : for (loop = loop->nested; loop; loop = loop->next)
6277 3452 : gfc_set_delta (loop);
6278 114575 : }
6279 :
6280 :
6281 : /* Calculate the size of a given array dimension from the bounds. This
6282 : is simply (ubound - lbound + 1) if this expression is positive
6283 : or 0 if it is negative (pick either one if it is zero). Optionally
6284 : (if or_expr is present) OR the (expression != 0) condition to it. */
6285 :
6286 : tree
6287 22971 : gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr)
6288 : {
6289 22971 : tree res;
6290 22971 : tree cond;
6291 :
6292 : /* Calculate (ubound - lbound + 1). */
6293 22971 : res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6294 : ubound, lbound);
6295 22971 : res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res,
6296 : gfc_index_one_node);
6297 :
6298 : /* Check whether the size for this dimension is negative. */
6299 22971 : cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, res,
6300 : gfc_index_zero_node);
6301 22971 : res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
6302 : gfc_index_zero_node, res);
6303 :
6304 : /* Build OR expression. */
6305 22971 : if (or_expr)
6306 17635 : *or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
6307 : logical_type_node, *or_expr, cond);
6308 :
6309 22971 : return res;
6310 : }
6311 :
6312 :
6313 : /* For an array descriptor, get the total number of elements. This is just
6314 : the product of the extents along from_dim to to_dim. */
6315 :
6316 : static tree
6317 1930 : gfc_conv_descriptor_size_1 (tree desc, int from_dim, int to_dim)
6318 : {
6319 1930 : tree res;
6320 1930 : int dim;
6321 :
6322 1930 : res = gfc_index_one_node;
6323 :
6324 4729 : for (dim = from_dim; dim < to_dim; ++dim)
6325 : {
6326 2799 : tree lbound;
6327 2799 : tree ubound;
6328 2799 : tree extent;
6329 :
6330 2799 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
6331 2799 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
6332 :
6333 2799 : extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
6334 2799 : res = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6335 : res, extent);
6336 : }
6337 :
6338 1930 : return res;
6339 : }
6340 :
6341 :
6342 : /* Full size of an array. */
6343 :
6344 : tree
6345 1866 : gfc_conv_descriptor_size (tree desc, int rank)
6346 : {
6347 1866 : return gfc_conv_descriptor_size_1 (desc, 0, rank);
6348 : }
6349 :
6350 :
6351 : /* Size of a coarray for all dimensions but the last. */
6352 :
6353 : tree
6354 64 : gfc_conv_descriptor_cosize (tree desc, int rank, int corank)
6355 : {
6356 64 : return gfc_conv_descriptor_size_1 (desc, rank, rank + corank - 1);
6357 : }
6358 :
6359 :
6360 : /* Fills in an array descriptor, and returns the size of the array.
6361 : The size will be a simple_val, ie a variable or a constant. Also
6362 : calculates the offset of the base. The pointer argument overflow,
6363 : which should be of integer type, will increase in value if overflow
6364 : occurs during the size calculation. Returns the size of the array.
6365 : {
6366 : stride = 1;
6367 : offset = 0;
6368 : for (n = 0; n < rank; n++)
6369 : {
6370 : a.lbound[n] = specified_lower_bound;
6371 : offset = offset + a.lbond[n] * stride;
6372 : size = 1 - lbound;
6373 : a.ubound[n] = specified_upper_bound;
6374 : a.stride[n] = stride;
6375 : size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
6376 : overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
6377 : stride = stride * size;
6378 : }
6379 : for (n = rank; n < rank+corank; n++)
6380 : (Set lcobound/ucobound as above.)
6381 : element_size = sizeof (array element);
6382 : if (!rank)
6383 : return element_size
6384 : stride = (size_t) stride;
6385 : overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
6386 : stride = stride * element_size;
6387 : return (stride);
6388 : } */
6389 : /*GCC ARRAYS*/
6390 :
6391 : static tree
6392 12004 : gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
6393 : gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
6394 : stmtblock_t * descriptor_block, tree * overflow,
6395 : tree expr3_elem_size, gfc_expr *expr3, tree expr3_desc,
6396 : bool e3_has_nodescriptor, gfc_expr *expr,
6397 : tree *element_size, bool explicit_ts)
6398 : {
6399 12004 : tree type;
6400 12004 : tree tmp;
6401 12004 : tree size;
6402 12004 : tree offset;
6403 12004 : tree stride;
6404 12004 : tree or_expr;
6405 12004 : tree thencase;
6406 12004 : tree elsecase;
6407 12004 : tree cond;
6408 12004 : tree var;
6409 12004 : stmtblock_t thenblock;
6410 12004 : stmtblock_t elseblock;
6411 12004 : gfc_expr *ubound;
6412 12004 : gfc_se se;
6413 12004 : int n;
6414 :
6415 12004 : type = TREE_TYPE (descriptor);
6416 :
6417 12004 : stride = gfc_index_one_node;
6418 12004 : offset = gfc_index_zero_node;
6419 :
6420 : /* Set the dtype before the alloc, because registration of coarrays needs
6421 : it initialized. */
6422 12004 : if (expr->ts.type == BT_CHARACTER
6423 1079 : && expr->ts.deferred
6424 545 : && VAR_P (expr->ts.u.cl->backend_decl))
6425 : {
6426 366 : type = gfc_typenode_for_spec (&expr->ts);
6427 366 : tmp = gfc_conv_descriptor_dtype (descriptor);
6428 366 : gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type));
6429 : }
6430 11638 : else if (expr->ts.type == BT_CHARACTER
6431 713 : && expr->ts.deferred
6432 179 : && TREE_CODE (descriptor) == COMPONENT_REF)
6433 : {
6434 : /* Deferred character components have their string length tucked away
6435 : in a hidden field of the derived type. Obtain that and use it to
6436 : set the dtype. The charlen backend decl is zero because the field
6437 : type is zero length. */
6438 161 : gfc_ref *ref;
6439 161 : tmp = NULL_TREE;
6440 161 : for (ref = expr->ref; ref; ref = ref->next)
6441 161 : if (ref->type == REF_COMPONENT
6442 161 : && gfc_deferred_strlen (ref->u.c.component, &tmp))
6443 : break;
6444 161 : gcc_assert (tmp != NULL_TREE);
6445 161 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
6446 161 : TREE_OPERAND (descriptor, 0), tmp, NULL_TREE);
6447 161 : tmp = fold_convert (gfc_charlen_type_node, tmp);
6448 161 : type = gfc_get_character_type_len (expr->ts.kind, tmp);
6449 161 : tmp = gfc_conv_descriptor_dtype (descriptor);
6450 161 : gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type));
6451 161 : }
6452 11477 : else if (expr3_desc && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr3_desc)))
6453 : {
6454 933 : tmp = gfc_conv_descriptor_dtype (descriptor);
6455 933 : gfc_add_modify (pblock, tmp, gfc_conv_descriptor_dtype (expr3_desc));
6456 : }
6457 10544 : else if (expr->ts.type == BT_CLASS && !explicit_ts
6458 1276 : && expr3 && expr3->ts.type != BT_CLASS
6459 343 : && expr3_elem_size != NULL_TREE && expr3_desc == NULL_TREE)
6460 : {
6461 343 : tmp = gfc_conv_descriptor_elem_len (descriptor);
6462 343 : gfc_add_modify (pblock, tmp,
6463 343 : fold_convert (TREE_TYPE (tmp), expr3_elem_size));
6464 : }
6465 : else
6466 : {
6467 10201 : tmp = gfc_conv_descriptor_dtype (descriptor);
6468 10201 : gfc_add_modify (pblock, tmp, gfc_get_dtype (type));
6469 : }
6470 :
6471 12004 : or_expr = logical_false_node;
6472 :
6473 29639 : for (n = 0; n < rank; n++)
6474 : {
6475 17635 : tree conv_lbound;
6476 17635 : tree conv_ubound;
6477 :
6478 : /* We have 3 possibilities for determining the size of the array:
6479 : lower == NULL => lbound = 1, ubound = upper[n]
6480 : upper[n] = NULL => lbound = 1, ubound = lower[n]
6481 : upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
6482 17635 : ubound = upper[n];
6483 :
6484 : /* Set lower bound. */
6485 17635 : gfc_init_se (&se, NULL);
6486 17635 : if (expr3_desc != NULL_TREE)
6487 : {
6488 1476 : if (e3_has_nodescriptor)
6489 : /* The lbound of nondescriptor arrays like array constructors,
6490 : nonallocatable/nonpointer function results/variables,
6491 : start at zero, but when allocating it, the standard expects
6492 : the array to start at one. */
6493 967 : se.expr = gfc_index_one_node;
6494 : else
6495 509 : se.expr = gfc_conv_descriptor_lbound_get (expr3_desc,
6496 : gfc_rank_cst[n]);
6497 : }
6498 16159 : else if (lower == NULL)
6499 13006 : se.expr = gfc_index_one_node;
6500 : else
6501 : {
6502 3153 : gcc_assert (lower[n]);
6503 3153 : if (ubound)
6504 : {
6505 2430 : gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
6506 2430 : gfc_add_block_to_block (pblock, &se.pre);
6507 : }
6508 : else
6509 : {
6510 723 : se.expr = gfc_index_one_node;
6511 723 : ubound = lower[n];
6512 : }
6513 : }
6514 17635 : gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
6515 : gfc_rank_cst[n], se.expr);
6516 17635 : conv_lbound = se.expr;
6517 :
6518 : /* Work out the offset for this component. */
6519 17635 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6520 : se.expr, stride);
6521 17635 : offset = fold_build2_loc (input_location, MINUS_EXPR,
6522 : gfc_array_index_type, offset, tmp);
6523 :
6524 : /* Set upper bound. */
6525 17635 : gfc_init_se (&se, NULL);
6526 17635 : if (expr3_desc != NULL_TREE)
6527 : {
6528 1476 : if (e3_has_nodescriptor)
6529 : {
6530 : /* The lbound of nondescriptor arrays like array constructors,
6531 : nonallocatable/nonpointer function results/variables,
6532 : start at zero, but when allocating it, the standard expects
6533 : the array to start at one. Therefore fix the upper bound to be
6534 : (desc.ubound - desc.lbound) + 1. */
6535 967 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
6536 : gfc_array_index_type,
6537 : gfc_conv_descriptor_ubound_get (
6538 : expr3_desc, gfc_rank_cst[n]),
6539 : gfc_conv_descriptor_lbound_get (
6540 : expr3_desc, gfc_rank_cst[n]));
6541 967 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
6542 : gfc_array_index_type, tmp,
6543 : gfc_index_one_node);
6544 967 : se.expr = gfc_evaluate_now (tmp, pblock);
6545 : }
6546 : else
6547 509 : se.expr = gfc_conv_descriptor_ubound_get (expr3_desc,
6548 : gfc_rank_cst[n]);
6549 : }
6550 : else
6551 : {
6552 16159 : gcc_assert (ubound);
6553 16159 : gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
6554 16159 : gfc_add_block_to_block (pblock, &se.pre);
6555 16159 : if (ubound->expr_type == EXPR_FUNCTION)
6556 744 : se.expr = gfc_evaluate_now (se.expr, pblock);
6557 : }
6558 17635 : gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
6559 : gfc_rank_cst[n], se.expr);
6560 17635 : conv_ubound = se.expr;
6561 :
6562 : /* Store the stride. */
6563 17635 : gfc_conv_descriptor_stride_set (descriptor_block, descriptor,
6564 : gfc_rank_cst[n], stride);
6565 :
6566 : /* Calculate size and check whether extent is negative. */
6567 17635 : size = gfc_conv_array_extent_dim (conv_lbound, conv_ubound, &or_expr);
6568 17635 : size = gfc_evaluate_now (size, pblock);
6569 :
6570 : /* Check whether multiplying the stride by the number of
6571 : elements in this dimension would overflow. We must also check
6572 : whether the current dimension has zero size in order to avoid
6573 : division by zero.
6574 : */
6575 17635 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
6576 : gfc_array_index_type,
6577 17635 : fold_convert (gfc_array_index_type,
6578 : TYPE_MAX_VALUE (gfc_array_index_type)),
6579 : size);
6580 17635 : cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
6581 : logical_type_node, tmp, stride),
6582 : PRED_FORTRAN_OVERFLOW);
6583 17635 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
6584 : integer_one_node, integer_zero_node);
6585 17635 : cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
6586 : logical_type_node, size,
6587 : gfc_index_zero_node),
6588 : PRED_FORTRAN_SIZE_ZERO);
6589 17635 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
6590 : integer_zero_node, tmp);
6591 17635 : tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
6592 : *overflow, tmp);
6593 17635 : *overflow = gfc_evaluate_now (tmp, pblock);
6594 :
6595 : /* Multiply the stride by the number of elements in this dimension. */
6596 17635 : stride = fold_build2_loc (input_location, MULT_EXPR,
6597 : gfc_array_index_type, stride, size);
6598 17635 : stride = gfc_evaluate_now (stride, pblock);
6599 : }
6600 :
6601 12642 : for (n = rank; n < rank + corank; n++)
6602 : {
6603 638 : ubound = upper[n];
6604 :
6605 : /* Set lower bound. */
6606 638 : gfc_init_se (&se, NULL);
6607 638 : if (lower == NULL || lower[n] == NULL)
6608 : {
6609 369 : gcc_assert (n == rank + corank - 1);
6610 369 : se.expr = gfc_index_one_node;
6611 : }
6612 : else
6613 : {
6614 269 : if (ubound || n == rank + corank - 1)
6615 : {
6616 175 : gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
6617 175 : gfc_add_block_to_block (pblock, &se.pre);
6618 : }
6619 : else
6620 : {
6621 94 : se.expr = gfc_index_one_node;
6622 94 : ubound = lower[n];
6623 : }
6624 : }
6625 638 : gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
6626 : gfc_rank_cst[n], se.expr);
6627 :
6628 638 : if (n < rank + corank - 1)
6629 : {
6630 178 : gfc_init_se (&se, NULL);
6631 178 : gcc_assert (ubound);
6632 178 : gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
6633 178 : gfc_add_block_to_block (pblock, &se.pre);
6634 178 : gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
6635 : gfc_rank_cst[n], se.expr);
6636 : }
6637 : }
6638 :
6639 : /* The stride is the number of elements in the array, so multiply by the
6640 : size of an element to get the total size. Obviously, if there is a
6641 : SOURCE expression (expr3) we must use its element size. */
6642 12004 : if (expr3_elem_size != NULL_TREE)
6643 3003 : tmp = expr3_elem_size;
6644 9001 : else if (expr3 != NULL)
6645 : {
6646 0 : if (expr3->ts.type == BT_CLASS)
6647 : {
6648 0 : gfc_se se_sz;
6649 0 : gfc_expr *sz = gfc_copy_expr (expr3);
6650 0 : gfc_add_vptr_component (sz);
6651 0 : gfc_add_size_component (sz);
6652 0 : gfc_init_se (&se_sz, NULL);
6653 0 : gfc_conv_expr (&se_sz, sz);
6654 0 : gfc_free_expr (sz);
6655 0 : tmp = se_sz.expr;
6656 : }
6657 : else
6658 : {
6659 0 : tmp = gfc_typenode_for_spec (&expr3->ts);
6660 0 : tmp = TYPE_SIZE_UNIT (tmp);
6661 : }
6662 : }
6663 : else
6664 9001 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
6665 :
6666 : /* Convert to size_t. */
6667 12004 : *element_size = fold_convert (size_type_node, tmp);
6668 :
6669 12004 : if (rank == 0)
6670 : return *element_size;
6671 :
6672 11804 : stride = fold_convert (size_type_node, stride);
6673 :
6674 : /* First check for overflow. Since an array of type character can
6675 : have zero element_size, we must check for that before
6676 : dividing. */
6677 11804 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
6678 : size_type_node,
6679 11804 : TYPE_MAX_VALUE (size_type_node), *element_size);
6680 11804 : cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
6681 : logical_type_node, tmp, stride),
6682 : PRED_FORTRAN_OVERFLOW);
6683 11804 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
6684 : integer_one_node, integer_zero_node);
6685 11804 : cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
6686 : logical_type_node, *element_size,
6687 : build_int_cst (size_type_node, 0)),
6688 : PRED_FORTRAN_SIZE_ZERO);
6689 11804 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
6690 : integer_zero_node, tmp);
6691 11804 : tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
6692 : *overflow, tmp);
6693 11804 : *overflow = gfc_evaluate_now (tmp, pblock);
6694 :
6695 11804 : size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
6696 : stride, *element_size);
6697 :
6698 11804 : if (poffset != NULL)
6699 : {
6700 11804 : offset = gfc_evaluate_now (offset, pblock);
6701 11804 : *poffset = offset;
6702 : }
6703 :
6704 11804 : if (integer_zerop (or_expr))
6705 : return size;
6706 3588 : if (integer_onep (or_expr))
6707 599 : return build_int_cst (size_type_node, 0);
6708 :
6709 2989 : var = gfc_create_var (TREE_TYPE (size), "size");
6710 2989 : gfc_start_block (&thenblock);
6711 2989 : gfc_add_modify (&thenblock, var, build_int_cst (size_type_node, 0));
6712 2989 : thencase = gfc_finish_block (&thenblock);
6713 :
6714 2989 : gfc_start_block (&elseblock);
6715 2989 : gfc_add_modify (&elseblock, var, size);
6716 2989 : elsecase = gfc_finish_block (&elseblock);
6717 :
6718 2989 : tmp = gfc_evaluate_now (or_expr, pblock);
6719 2989 : tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
6720 2989 : gfc_add_expr_to_block (pblock, tmp);
6721 :
6722 2989 : return var;
6723 : }
6724 :
6725 :
6726 : /* Retrieve the last ref from the chain. This routine is specific to
6727 : gfc_array_allocate ()'s needs. */
6728 :
6729 : bool
6730 18367 : retrieve_last_ref (gfc_ref **ref_in, gfc_ref **prev_ref_in)
6731 : {
6732 18367 : gfc_ref *ref, *prev_ref;
6733 :
6734 18367 : ref = *ref_in;
6735 : /* Prevent warnings for uninitialized variables. */
6736 18367 : prev_ref = *prev_ref_in;
6737 25324 : while (ref && ref->next != NULL)
6738 : {
6739 6957 : gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
6740 : || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
6741 : prev_ref = ref;
6742 : ref = ref->next;
6743 : }
6744 :
6745 18367 : if (ref == NULL || ref->type != REF_ARRAY)
6746 : return false;
6747 :
6748 13222 : *ref_in = ref;
6749 13222 : *prev_ref_in = prev_ref;
6750 13222 : return true;
6751 : }
6752 :
6753 : /* Initializes the descriptor and generates a call to _gfor_allocate. Does
6754 : the work for an ALLOCATE statement. */
6755 : /*GCC ARRAYS*/
6756 :
6757 : bool
6758 17149 : gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
6759 : tree errlen, tree label_finish, tree expr3_elem_size,
6760 : gfc_expr *expr3, tree e3_arr_desc, bool e3_has_nodescriptor,
6761 : gfc_omp_namelist *omp_alloc, bool explicit_ts)
6762 : {
6763 17149 : tree tmp;
6764 17149 : tree pointer;
6765 17149 : tree offset = NULL_TREE;
6766 17149 : tree token = NULL_TREE;
6767 17149 : tree size;
6768 17149 : tree msg;
6769 17149 : tree error = NULL_TREE;
6770 17149 : tree overflow; /* Boolean storing whether size calculation overflows. */
6771 17149 : tree var_overflow = NULL_TREE;
6772 17149 : tree cond;
6773 17149 : tree set_descriptor;
6774 17149 : tree not_prev_allocated = NULL_TREE;
6775 17149 : tree element_size = NULL_TREE;
6776 17149 : stmtblock_t set_descriptor_block;
6777 17149 : stmtblock_t elseblock;
6778 17149 : gfc_expr **lower;
6779 17149 : gfc_expr **upper;
6780 17149 : gfc_ref *ref, *prev_ref = NULL, *coref;
6781 17149 : bool allocatable, coarray, dimension, alloc_w_e3_arr_spec = false,
6782 : non_ulimate_coarray_ptr_comp;
6783 17149 : tree omp_cond = NULL_TREE, omp_alt_alloc = NULL_TREE;
6784 :
6785 17149 : ref = expr->ref;
6786 :
6787 : /* Find the last reference in the chain. */
6788 17149 : if (!retrieve_last_ref (&ref, &prev_ref))
6789 : return false;
6790 :
6791 : /* Take the allocatable and coarray properties solely from the expr-ref's
6792 : attributes and not from source=-expression. */
6793 12004 : if (!prev_ref)
6794 : {
6795 8266 : allocatable = expr->symtree->n.sym->attr.allocatable;
6796 8266 : dimension = expr->symtree->n.sym->attr.dimension;
6797 8266 : non_ulimate_coarray_ptr_comp = false;
6798 : }
6799 : else
6800 : {
6801 3738 : allocatable = prev_ref->u.c.component->attr.allocatable;
6802 : /* Pointer components in coarrayed derived types must be treated
6803 : specially in that they are registered without a check if the are
6804 : already associated. This does not hold for ultimate coarray
6805 : pointers. */
6806 7476 : non_ulimate_coarray_ptr_comp = (prev_ref->u.c.component->attr.pointer
6807 3738 : && !prev_ref->u.c.component->attr.codimension);
6808 3738 : dimension = prev_ref->u.c.component->attr.dimension;
6809 : }
6810 :
6811 : /* For allocatable/pointer arrays in derived types, one of the refs has to be
6812 : a coarray. In this case it does not matter whether we are on this_image
6813 : or not. */
6814 12004 : coarray = false;
6815 28632 : for (coref = expr->ref; coref; coref = coref->next)
6816 17260 : if (coref->type == REF_ARRAY && coref->u.ar.codimen > 0)
6817 : {
6818 : coarray = true;
6819 : break;
6820 : }
6821 :
6822 12004 : if (!dimension)
6823 200 : gcc_assert (coarray);
6824 :
6825 12004 : if (ref->u.ar.type == AR_FULL && expr3 != NULL)
6826 : {
6827 1218 : gfc_ref *old_ref = ref;
6828 : /* F08:C633: Array shape from expr3. */
6829 1218 : ref = expr3->ref;
6830 :
6831 : /* Find the last reference in the chain. */
6832 1218 : if (!retrieve_last_ref (&ref, &prev_ref))
6833 : {
6834 0 : if (expr3->expr_type == EXPR_FUNCTION
6835 0 : && gfc_expr_attr (expr3).dimension)
6836 0 : ref = old_ref;
6837 : else
6838 0 : return false;
6839 : }
6840 : alloc_w_e3_arr_spec = true;
6841 : }
6842 :
6843 : /* Figure out the size of the array. */
6844 12004 : switch (ref->u.ar.type)
6845 : {
6846 9137 : case AR_ELEMENT:
6847 9137 : if (!coarray)
6848 : {
6849 8557 : lower = NULL;
6850 8557 : upper = ref->u.ar.start;
6851 8557 : break;
6852 : }
6853 : /* Fall through. */
6854 :
6855 2260 : case AR_SECTION:
6856 2260 : lower = ref->u.ar.start;
6857 2260 : upper = ref->u.ar.end;
6858 2260 : break;
6859 :
6860 1187 : case AR_FULL:
6861 1187 : gcc_assert (ref->u.ar.as->type == AS_EXPLICIT
6862 : || alloc_w_e3_arr_spec);
6863 :
6864 1187 : lower = ref->u.ar.as->lower;
6865 1187 : upper = ref->u.ar.as->upper;
6866 1187 : break;
6867 :
6868 0 : default:
6869 0 : gcc_unreachable ();
6870 12004 : break;
6871 : }
6872 :
6873 12004 : overflow = integer_zero_node;
6874 :
6875 12004 : if (expr->ts.type == BT_CHARACTER
6876 1079 : && TREE_CODE (se->string_length) == COMPONENT_REF
6877 161 : && expr->ts.u.cl->backend_decl != se->string_length
6878 161 : && VAR_P (expr->ts.u.cl->backend_decl))
6879 0 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
6880 0 : fold_convert (TREE_TYPE (expr->ts.u.cl->backend_decl),
6881 : se->string_length));
6882 :
6883 12004 : gfc_init_block (&set_descriptor_block);
6884 : /* Take the corank only from the actual ref and not from the coref. The
6885 : later will mislead the generation of the array dimensions for allocatable/
6886 : pointer components in derived types. */
6887 23422 : size = gfc_array_init_size (se->expr, alloc_w_e3_arr_spec ? expr->rank
6888 10786 : : ref->u.ar.as->rank,
6889 632 : coarray ? ref->u.ar.as->corank : 0,
6890 : &offset, lower, upper,
6891 : &se->pre, &set_descriptor_block, &overflow,
6892 : expr3_elem_size, expr3, e3_arr_desc,
6893 : e3_has_nodescriptor, expr, &element_size,
6894 : explicit_ts);
6895 :
6896 12004 : if (dimension)
6897 : {
6898 11804 : var_overflow = gfc_create_var (integer_type_node, "overflow");
6899 11804 : gfc_add_modify (&se->pre, var_overflow, overflow);
6900 :
6901 11804 : if (status == NULL_TREE)
6902 : {
6903 : /* Generate the block of code handling overflow. */
6904 11582 : msg = gfc_build_addr_expr (pchar_type_node,
6905 : gfc_build_localized_cstring_const
6906 : ("Integer overflow when calculating the amount of "
6907 : "memory to allocate"));
6908 11582 : error = build_call_expr_loc (input_location,
6909 : gfor_fndecl_runtime_error, 1, msg);
6910 : }
6911 : else
6912 : {
6913 222 : tree status_type = TREE_TYPE (status);
6914 222 : stmtblock_t set_status_block;
6915 :
6916 222 : gfc_start_block (&set_status_block);
6917 222 : gfc_add_modify (&set_status_block, status,
6918 : build_int_cst (status_type, LIBERROR_ALLOCATION));
6919 222 : error = gfc_finish_block (&set_status_block);
6920 : }
6921 : }
6922 :
6923 : /* Allocate memory to store the data. */
6924 12004 : if (POINTER_TYPE_P (TREE_TYPE (se->expr)))
6925 0 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
6926 :
6927 12004 : if (coarray && flag_coarray == GFC_FCOARRAY_LIB)
6928 : {
6929 393 : pointer = non_ulimate_coarray_ptr_comp ? se->expr
6930 321 : : gfc_conv_descriptor_data_get (se->expr);
6931 393 : token = gfc_conv_descriptor_token (se->expr);
6932 393 : token = gfc_build_addr_expr (NULL_TREE, token);
6933 : }
6934 : else
6935 : {
6936 11611 : pointer = gfc_conv_descriptor_data_get (se->expr);
6937 11611 : if (omp_alloc)
6938 33 : omp_cond = boolean_true_node;
6939 : }
6940 12004 : STRIP_NOPS (pointer);
6941 :
6942 12004 : if (allocatable)
6943 : {
6944 9859 : not_prev_allocated = gfc_create_var (logical_type_node,
6945 : "not_prev_allocated");
6946 9859 : tmp = fold_build2_loc (input_location, EQ_EXPR,
6947 : logical_type_node, pointer,
6948 9859 : build_int_cst (TREE_TYPE (pointer), 0));
6949 :
6950 9859 : gfc_add_modify (&se->pre, not_prev_allocated, tmp);
6951 : }
6952 :
6953 12004 : gfc_start_block (&elseblock);
6954 :
6955 12004 : tree succ_add_expr = NULL_TREE;
6956 12004 : if (omp_cond)
6957 : {
6958 33 : tree align, alloc, sz;
6959 33 : gfc_se se2;
6960 33 : if (omp_alloc->u2.allocator)
6961 : {
6962 10 : gfc_init_se (&se2, NULL);
6963 10 : gfc_conv_expr (&se2, omp_alloc->u2.allocator);
6964 10 : gfc_add_block_to_block (&elseblock, &se2.pre);
6965 10 : alloc = gfc_evaluate_now (se2.expr, &elseblock);
6966 10 : gfc_add_block_to_block (&elseblock, &se2.post);
6967 : }
6968 : else
6969 23 : alloc = build_zero_cst (ptr_type_node);
6970 33 : tmp = TREE_TYPE (TREE_TYPE (pointer));
6971 33 : if (tmp == void_type_node)
6972 33 : tmp = gfc_typenode_for_spec (&expr->ts, 0);
6973 33 : if (omp_alloc->u.align)
6974 : {
6975 17 : gfc_init_se (&se2, NULL);
6976 17 : gfc_conv_expr (&se2, omp_alloc->u.align);
6977 17 : gcc_assert (CONSTANT_CLASS_P (se2.expr)
6978 : && se2.pre.head == NULL
6979 : && se2.post.head == NULL);
6980 17 : align = build_int_cst (size_type_node,
6981 17 : MAX (tree_to_uhwi (se2.expr),
6982 : TYPE_ALIGN_UNIT (tmp)));
6983 : }
6984 : else
6985 16 : align = build_int_cst (size_type_node, TYPE_ALIGN_UNIT (tmp));
6986 33 : sz = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
6987 : fold_convert (size_type_node, size),
6988 : build_int_cst (size_type_node, 1));
6989 33 : omp_alt_alloc = builtin_decl_explicit (BUILT_IN_GOMP_ALLOC);
6990 33 : DECL_ATTRIBUTES (omp_alt_alloc)
6991 33 : = tree_cons (get_identifier ("omp allocator"),
6992 : build_tree_list (NULL_TREE, alloc),
6993 33 : DECL_ATTRIBUTES (omp_alt_alloc));
6994 33 : omp_alt_alloc = build_call_expr (omp_alt_alloc, 3, align, sz, alloc);
6995 33 : succ_add_expr = fold_build2_loc (input_location, MODIFY_EXPR,
6996 : void_type_node,
6997 : gfc_conv_descriptor_version (se->expr),
6998 : build_int_cst (integer_type_node, 1));
6999 : }
7000 :
7001 : /* The allocatable variant takes the old pointer as first argument. */
7002 12004 : if (allocatable)
7003 10416 : gfc_allocate_allocatable (&elseblock, pointer, size, token,
7004 : status, errmsg, errlen, label_finish, expr,
7005 557 : coref != NULL ? coref->u.ar.as->corank : 0,
7006 : omp_cond, omp_alt_alloc, succ_add_expr);
7007 2145 : else if (non_ulimate_coarray_ptr_comp && token)
7008 : /* The token is set only for GFC_FCOARRAY_LIB mode. */
7009 72 : gfc_allocate_using_caf_lib (&elseblock, pointer, size, token, status,
7010 : errmsg, errlen,
7011 : GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY);
7012 : else
7013 2073 : gfc_allocate_using_malloc (&elseblock, pointer, size, status,
7014 : omp_cond, omp_alt_alloc, succ_add_expr);
7015 :
7016 12004 : if (dimension)
7017 : {
7018 11804 : cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
7019 : logical_type_node, var_overflow, integer_zero_node),
7020 : PRED_FORTRAN_OVERFLOW);
7021 11804 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
7022 : error, gfc_finish_block (&elseblock));
7023 : }
7024 : else
7025 200 : tmp = gfc_finish_block (&elseblock);
7026 :
7027 12004 : gfc_add_expr_to_block (&se->pre, tmp);
7028 :
7029 : /* Update the array descriptor with the offset and the span. */
7030 12004 : if (dimension)
7031 : {
7032 11804 : gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
7033 11804 : tmp = fold_convert (gfc_array_index_type, element_size);
7034 11804 : gfc_conv_descriptor_span_set (&set_descriptor_block, se->expr, tmp);
7035 : }
7036 :
7037 12004 : set_descriptor = gfc_finish_block (&set_descriptor_block);
7038 12004 : if (status != NULL_TREE)
7039 : {
7040 238 : cond = fold_build2_loc (input_location, EQ_EXPR,
7041 : logical_type_node, status,
7042 238 : build_int_cst (TREE_TYPE (status), 0));
7043 :
7044 238 : if (not_prev_allocated != NULL_TREE)
7045 222 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
7046 : logical_type_node, cond, not_prev_allocated);
7047 :
7048 238 : gfc_add_expr_to_block (&se->pre,
7049 : fold_build3_loc (input_location, COND_EXPR, void_type_node,
7050 : cond,
7051 : set_descriptor,
7052 : build_empty_stmt (input_location)));
7053 : }
7054 : else
7055 11766 : gfc_add_expr_to_block (&se->pre, set_descriptor);
7056 :
7057 : return true;
7058 : }
7059 :
7060 :
7061 : /* Create an array constructor from an initialization expression.
7062 : We assume the frontend already did any expansions and conversions. */
7063 :
7064 : tree
7065 7592 : gfc_conv_array_initializer (tree type, gfc_expr * expr)
7066 : {
7067 7592 : gfc_constructor *c;
7068 7592 : tree tmp;
7069 7592 : gfc_se se;
7070 7592 : tree index, range;
7071 7592 : vec<constructor_elt, va_gc> *v = NULL;
7072 :
7073 7592 : if (expr->expr_type == EXPR_VARIABLE
7074 0 : && expr->symtree->n.sym->attr.flavor == FL_PARAMETER
7075 0 : && expr->symtree->n.sym->value)
7076 7592 : expr = expr->symtree->n.sym->value;
7077 :
7078 7592 : switch (expr->expr_type)
7079 : {
7080 1113 : case EXPR_CONSTANT:
7081 1113 : case EXPR_STRUCTURE:
7082 : /* A single scalar or derived type value. Create an array with all
7083 : elements equal to that value. */
7084 1113 : gfc_init_se (&se, NULL);
7085 :
7086 1113 : if (expr->expr_type == EXPR_CONSTANT)
7087 383 : gfc_conv_constant (&se, expr);
7088 : else
7089 730 : gfc_conv_structure (&se, expr, 1);
7090 :
7091 2226 : if (tree_int_cst_lt (TYPE_MAX_VALUE (TYPE_DOMAIN (type)),
7092 1113 : TYPE_MIN_VALUE (TYPE_DOMAIN (type))))
7093 : break;
7094 2202 : else if (tree_int_cst_equal (TYPE_MIN_VALUE (TYPE_DOMAIN (type)),
7095 1101 : TYPE_MAX_VALUE (TYPE_DOMAIN (type))))
7096 149 : range = TYPE_MIN_VALUE (TYPE_DOMAIN (type));
7097 : else
7098 1904 : range = build2 (RANGE_EXPR, gfc_array_index_type,
7099 952 : TYPE_MIN_VALUE (TYPE_DOMAIN (type)),
7100 952 : TYPE_MAX_VALUE (TYPE_DOMAIN (type)));
7101 1101 : CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
7102 1101 : break;
7103 :
7104 6479 : case EXPR_ARRAY:
7105 : /* Create a vector of all the elements. */
7106 6479 : for (c = gfc_constructor_first (expr->value.constructor);
7107 164062 : c && c->expr; c = gfc_constructor_next (c))
7108 : {
7109 157583 : if (c->iterator)
7110 : {
7111 : /* Problems occur when we get something like
7112 : integer :: a(lots) = (/(i, i=1, lots)/) */
7113 0 : gfc_fatal_error ("The number of elements in the array "
7114 : "constructor at %L requires an increase of "
7115 : "the allowed %d upper limit. See "
7116 : "%<-fmax-array-constructor%> option",
7117 : &expr->where, flag_max_array_constructor);
7118 : return NULL_TREE;
7119 : }
7120 157583 : if (mpz_cmp_si (c->offset, 0) != 0)
7121 151364 : index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
7122 : else
7123 : index = NULL_TREE;
7124 :
7125 157583 : if (mpz_cmp_si (c->repeat, 1) > 0)
7126 : {
7127 127 : tree tmp1, tmp2;
7128 127 : mpz_t maxval;
7129 :
7130 127 : mpz_init (maxval);
7131 127 : mpz_add (maxval, c->offset, c->repeat);
7132 127 : mpz_sub_ui (maxval, maxval, 1);
7133 127 : tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
7134 127 : if (mpz_cmp_si (c->offset, 0) != 0)
7135 : {
7136 27 : mpz_add_ui (maxval, c->offset, 1);
7137 27 : tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
7138 : }
7139 : else
7140 100 : tmp1 = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
7141 :
7142 127 : range = fold_build2 (RANGE_EXPR, gfc_array_index_type, tmp1, tmp2);
7143 127 : mpz_clear (maxval);
7144 : }
7145 : else
7146 : range = NULL;
7147 :
7148 157583 : gfc_init_se (&se, NULL);
7149 157583 : switch (c->expr->expr_type)
7150 : {
7151 156170 : case EXPR_CONSTANT:
7152 156170 : gfc_conv_constant (&se, c->expr);
7153 :
7154 : /* See gfortran.dg/charlen_15.f90 for instance. */
7155 156170 : if (TREE_CODE (se.expr) == STRING_CST
7156 5206 : && TREE_CODE (type) == ARRAY_TYPE)
7157 : {
7158 : tree atype = type;
7159 10412 : while (TREE_CODE (TREE_TYPE (atype)) == ARRAY_TYPE)
7160 5206 : atype = TREE_TYPE (atype);
7161 5206 : gcc_checking_assert (TREE_CODE (TREE_TYPE (atype))
7162 : == INTEGER_TYPE);
7163 5206 : gcc_checking_assert (TREE_TYPE (TREE_TYPE (se.expr))
7164 : == TREE_TYPE (atype));
7165 5206 : if (tree_to_uhwi (TYPE_SIZE_UNIT (TREE_TYPE (se.expr)))
7166 5206 : > tree_to_uhwi (TYPE_SIZE_UNIT (atype)))
7167 : {
7168 0 : unsigned HOST_WIDE_INT size
7169 0 : = tree_to_uhwi (TYPE_SIZE_UNIT (atype));
7170 0 : const char *p = TREE_STRING_POINTER (se.expr);
7171 :
7172 0 : se.expr = build_string (size, p);
7173 : }
7174 5206 : TREE_TYPE (se.expr) = atype;
7175 : }
7176 : break;
7177 :
7178 1413 : case EXPR_STRUCTURE:
7179 1413 : gfc_conv_structure (&se, c->expr, 1);
7180 1413 : break;
7181 :
7182 0 : default:
7183 : /* Catch those occasional beasts that do not simplify
7184 : for one reason or another, assuming that if they are
7185 : standard defying the frontend will catch them. */
7186 0 : gfc_conv_expr (&se, c->expr);
7187 0 : break;
7188 : }
7189 :
7190 157583 : if (range == NULL_TREE)
7191 157456 : CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
7192 : else
7193 : {
7194 127 : if (index != NULL_TREE)
7195 27 : CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
7196 157710 : CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
7197 : }
7198 : }
7199 : break;
7200 :
7201 0 : case EXPR_NULL:
7202 0 : return gfc_build_null_descriptor (type);
7203 :
7204 0 : default:
7205 0 : gcc_unreachable ();
7206 : }
7207 :
7208 : /* Create a constructor from the list of elements. */
7209 7592 : tmp = build_constructor (type, v);
7210 7592 : TREE_CONSTANT (tmp) = 1;
7211 7592 : return tmp;
7212 : }
7213 :
7214 :
7215 : /* Generate code to evaluate non-constant coarray cobounds. */
7216 :
7217 : void
7218 20559 : gfc_trans_array_cobounds (tree type, stmtblock_t * pblock,
7219 : const gfc_symbol *sym)
7220 : {
7221 20559 : int dim;
7222 20559 : tree ubound;
7223 20559 : tree lbound;
7224 20559 : gfc_se se;
7225 20559 : gfc_array_spec *as;
7226 :
7227 20559 : as = IS_CLASS_COARRAY_OR_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
7228 :
7229 21535 : for (dim = as->rank; dim < as->rank + as->corank; dim++)
7230 : {
7231 : /* Evaluate non-constant array bound expressions.
7232 : F2008 4.5.6.3 para 6: If a specification expression in a scoping unit
7233 : references a function, the result is finalized before execution of the
7234 : executable constructs in the scoping unit.
7235 : Adding the finalblocks enables this. */
7236 976 : lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
7237 976 : if (as->lower[dim] && !INTEGER_CST_P (lbound))
7238 : {
7239 114 : gfc_init_se (&se, NULL);
7240 114 : gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
7241 114 : gfc_add_block_to_block (pblock, &se.pre);
7242 114 : gfc_add_block_to_block (pblock, &se.finalblock);
7243 114 : gfc_add_modify (pblock, lbound, se.expr);
7244 : }
7245 976 : ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
7246 976 : if (as->upper[dim] && !INTEGER_CST_P (ubound))
7247 : {
7248 60 : gfc_init_se (&se, NULL);
7249 60 : gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
7250 60 : gfc_add_block_to_block (pblock, &se.pre);
7251 60 : gfc_add_block_to_block (pblock, &se.finalblock);
7252 60 : gfc_add_modify (pblock, ubound, se.expr);
7253 : }
7254 : }
7255 20559 : }
7256 :
7257 :
7258 : /* Generate code to evaluate non-constant array bounds. Sets *poffset and
7259 : returns the size (in elements) of the array. */
7260 :
7261 : tree
7262 13413 : gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
7263 : stmtblock_t * pblock)
7264 : {
7265 13413 : gfc_array_spec *as;
7266 13413 : tree size;
7267 13413 : tree stride;
7268 13413 : tree offset;
7269 13413 : tree ubound;
7270 13413 : tree lbound;
7271 13413 : tree tmp;
7272 13413 : gfc_se se;
7273 :
7274 13413 : int dim;
7275 :
7276 13413 : as = IS_CLASS_COARRAY_OR_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
7277 :
7278 13413 : size = gfc_index_one_node;
7279 13413 : offset = gfc_index_zero_node;
7280 13413 : stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
7281 13413 : if (stride && VAR_P (stride))
7282 124 : gfc_add_modify (pblock, stride, gfc_index_one_node);
7283 30071 : for (dim = 0; dim < as->rank; dim++)
7284 : {
7285 : /* Evaluate non-constant array bound expressions.
7286 : F2008 4.5.6.3 para 6: If a specification expression in a scoping unit
7287 : references a function, the result is finalized before execution of the
7288 : executable constructs in the scoping unit.
7289 : Adding the finalblocks enables this. */
7290 16658 : lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
7291 16658 : if (as->lower[dim] && !INTEGER_CST_P (lbound))
7292 : {
7293 475 : gfc_init_se (&se, NULL);
7294 475 : gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
7295 475 : gfc_add_block_to_block (pblock, &se.pre);
7296 475 : gfc_add_block_to_block (pblock, &se.finalblock);
7297 475 : gfc_add_modify (pblock, lbound, se.expr);
7298 : }
7299 16658 : ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
7300 16658 : if (as->upper[dim] && !INTEGER_CST_P (ubound))
7301 : {
7302 10148 : gfc_init_se (&se, NULL);
7303 10148 : gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
7304 10148 : gfc_add_block_to_block (pblock, &se.pre);
7305 10148 : gfc_add_block_to_block (pblock, &se.finalblock);
7306 10148 : gfc_add_modify (pblock, ubound, se.expr);
7307 : }
7308 : /* The offset of this dimension. offset = offset - lbound * stride. */
7309 16658 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7310 : lbound, size);
7311 16658 : offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7312 : offset, tmp);
7313 :
7314 : /* The size of this dimension, and the stride of the next. */
7315 16658 : if (dim + 1 < as->rank)
7316 3444 : stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
7317 : else
7318 13214 : stride = GFC_TYPE_ARRAY_SIZE (type);
7319 :
7320 16658 : if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
7321 : {
7322 : /* Calculate stride = size * (ubound + 1 - lbound). */
7323 10338 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
7324 : gfc_array_index_type,
7325 : gfc_index_one_node, lbound);
7326 10338 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
7327 : gfc_array_index_type, ubound, tmp);
7328 10338 : tmp = fold_build2_loc (input_location, MULT_EXPR,
7329 : gfc_array_index_type, size, tmp);
7330 10338 : if (stride)
7331 10338 : gfc_add_modify (pblock, stride, tmp);
7332 : else
7333 0 : stride = gfc_evaluate_now (tmp, pblock);
7334 :
7335 : /* Make sure that negative size arrays are translated
7336 : to being zero size. */
7337 10338 : tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
7338 : stride, gfc_index_zero_node);
7339 10338 : tmp = fold_build3_loc (input_location, COND_EXPR,
7340 : gfc_array_index_type, tmp,
7341 : stride, gfc_index_zero_node);
7342 10338 : gfc_add_modify (pblock, stride, tmp);
7343 : }
7344 :
7345 : size = stride;
7346 : }
7347 :
7348 13413 : gfc_trans_array_cobounds (type, pblock, sym);
7349 13413 : gfc_trans_vla_type_sizes (sym, pblock);
7350 :
7351 13413 : *poffset = offset;
7352 13413 : return size;
7353 : }
7354 :
7355 :
7356 : /* Generate code to initialize/allocate an array variable. */
7357 :
7358 : void
7359 31185 : gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
7360 : gfc_wrapped_block * block)
7361 : {
7362 31185 : stmtblock_t init;
7363 31185 : tree type;
7364 31185 : tree tmp = NULL_TREE;
7365 31185 : tree size;
7366 31185 : tree offset;
7367 31185 : tree space;
7368 31185 : tree inittree;
7369 31185 : bool onstack;
7370 31185 : bool back;
7371 :
7372 31185 : gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
7373 :
7374 : /* Do nothing for USEd variables. */
7375 31185 : if (sym->attr.use_assoc)
7376 25519 : return;
7377 :
7378 31143 : type = TREE_TYPE (decl);
7379 31143 : gcc_assert (GFC_ARRAY_TYPE_P (type));
7380 31143 : onstack = TREE_CODE (type) != POINTER_TYPE;
7381 :
7382 : /* In the case of non-dummy symbols with dependencies on an old-fashioned
7383 : function result (ie. proc_name = proc_name->result), gfc_add_init_cleanup
7384 : must be called with the last, optional argument false so that the alloc-
7385 : ation occurs after the processing of the result. */
7386 31143 : back = sym->fn_result_dep;
7387 :
7388 31143 : gfc_init_block (&init);
7389 :
7390 : /* Evaluate character string length. */
7391 31143 : if (sym->ts.type == BT_CHARACTER
7392 3029 : && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
7393 : {
7394 43 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7395 :
7396 43 : gfc_trans_vla_type_sizes (sym, &init);
7397 :
7398 : /* Emit a DECL_EXPR for this variable, which will cause the
7399 : gimplifier to allocate storage, and all that good stuff. */
7400 43 : tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
7401 43 : gfc_add_expr_to_block (&init, tmp);
7402 43 : if (sym->attr.omp_allocate)
7403 : {
7404 : /* Save location of size calculation to ensure GOMP_alloc is placed
7405 : after it. */
7406 0 : tree omp_alloc = lookup_attribute ("omp allocate",
7407 0 : DECL_ATTRIBUTES (decl));
7408 0 : TREE_CHAIN (TREE_CHAIN (TREE_VALUE (omp_alloc)))
7409 0 : = build_tree_list (NULL_TREE, tsi_stmt (tsi_last (init.head)));
7410 : }
7411 : }
7412 :
7413 30941 : if (onstack)
7414 : {
7415 25337 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE,
7416 : back);
7417 25337 : return;
7418 : }
7419 :
7420 5806 : type = TREE_TYPE (type);
7421 :
7422 5806 : gcc_assert (!sym->attr.use_assoc);
7423 5806 : gcc_assert (!sym->module);
7424 :
7425 5806 : if (sym->ts.type == BT_CHARACTER
7426 202 : && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
7427 94 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7428 :
7429 5806 : size = gfc_trans_array_bounds (type, sym, &offset, &init);
7430 :
7431 : /* Don't actually allocate space for Cray Pointees. */
7432 5806 : if (sym->attr.cray_pointee)
7433 : {
7434 140 : if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
7435 49 : gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
7436 :
7437 140 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
7438 140 : return;
7439 : }
7440 5666 : if (sym->attr.omp_allocate)
7441 : {
7442 : /* The size is the number of elements in the array, so multiply by the
7443 : size of an element to get the total size. */
7444 7 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
7445 7 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7446 : size, fold_convert (gfc_array_index_type, tmp));
7447 7 : size = gfc_evaluate_now (size, &init);
7448 :
7449 7 : tree omp_alloc = lookup_attribute ("omp allocate",
7450 7 : DECL_ATTRIBUTES (decl));
7451 7 : TREE_CHAIN (TREE_CHAIN (TREE_VALUE (omp_alloc)))
7452 7 : = build_tree_list (size, NULL_TREE);
7453 7 : space = NULL_TREE;
7454 : }
7455 5659 : else if (flag_stack_arrays)
7456 : {
7457 14 : gcc_assert (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE);
7458 14 : space = build_decl (gfc_get_location (&sym->declared_at),
7459 : VAR_DECL, create_tmp_var_name ("A"),
7460 14 : TREE_TYPE (TREE_TYPE (decl)));
7461 14 : gfc_trans_vla_type_sizes (sym, &init);
7462 : }
7463 : else
7464 : {
7465 : /* The size is the number of elements in the array, so multiply by the
7466 : size of an element to get the total size. */
7467 5645 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
7468 5645 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7469 : size, fold_convert (gfc_array_index_type, tmp));
7470 :
7471 : /* Allocate memory to hold the data. */
7472 5645 : tmp = gfc_call_malloc (&init, TREE_TYPE (decl), size);
7473 5645 : gfc_add_modify (&init, decl, tmp);
7474 :
7475 : /* Free the temporary. */
7476 5645 : tmp = gfc_call_free (decl);
7477 5645 : space = NULL_TREE;
7478 : }
7479 :
7480 : /* Set offset of the array. */
7481 5666 : if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
7482 378 : gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
7483 :
7484 : /* Automatic arrays should not have initializers. */
7485 5666 : gcc_assert (!sym->value);
7486 :
7487 5666 : inittree = gfc_finish_block (&init);
7488 :
7489 5666 : if (space)
7490 : {
7491 14 : tree addr;
7492 14 : pushdecl (space);
7493 :
7494 : /* Don't create new scope, emit the DECL_EXPR in exactly the scope
7495 : where also space is located. */
7496 14 : gfc_init_block (&init);
7497 14 : tmp = fold_build1_loc (input_location, DECL_EXPR,
7498 14 : TREE_TYPE (space), space);
7499 14 : gfc_add_expr_to_block (&init, tmp);
7500 14 : addr = fold_build1_loc (gfc_get_location (&sym->declared_at),
7501 14 : ADDR_EXPR, TREE_TYPE (decl), space);
7502 14 : gfc_add_modify (&init, decl, addr);
7503 14 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE,
7504 : back);
7505 14 : tmp = NULL_TREE;
7506 : }
7507 5666 : gfc_add_init_cleanup (block, inittree, tmp, back);
7508 : }
7509 :
7510 :
7511 : /* Generate entry and exit code for g77 calling convention arrays. */
7512 :
7513 : void
7514 7353 : gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block)
7515 : {
7516 7353 : tree parm;
7517 7353 : tree type;
7518 7353 : tree offset;
7519 7353 : tree tmp;
7520 7353 : tree stmt;
7521 7353 : stmtblock_t init;
7522 :
7523 7353 : location_t loc = input_location;
7524 7353 : input_location = gfc_get_location (&sym->declared_at);
7525 :
7526 : /* Descriptor type. */
7527 7353 : parm = sym->backend_decl;
7528 7353 : type = TREE_TYPE (parm);
7529 7353 : gcc_assert (GFC_ARRAY_TYPE_P (type));
7530 :
7531 7353 : gfc_start_block (&init);
7532 :
7533 7353 : if (sym->ts.type == BT_CHARACTER
7534 710 : && VAR_P (sym->ts.u.cl->backend_decl))
7535 79 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7536 :
7537 : /* Evaluate the bounds of the array. */
7538 7353 : gfc_trans_array_bounds (type, sym, &offset, &init);
7539 :
7540 : /* Set the offset. */
7541 7353 : if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
7542 1212 : gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
7543 :
7544 : /* Set the pointer itself if we aren't using the parameter directly. */
7545 7353 : if (TREE_CODE (parm) != PARM_DECL)
7546 : {
7547 612 : tmp = GFC_DECL_SAVED_DESCRIPTOR (parm);
7548 612 : if (sym->ts.type == BT_CLASS)
7549 : {
7550 243 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
7551 243 : tmp = gfc_class_data_get (tmp);
7552 243 : tmp = gfc_conv_descriptor_data_get (tmp);
7553 : }
7554 612 : tmp = convert (TREE_TYPE (parm), tmp);
7555 612 : gfc_add_modify (&init, parm, tmp);
7556 : }
7557 7353 : stmt = gfc_finish_block (&init);
7558 :
7559 7353 : input_location = loc;
7560 :
7561 : /* Add the initialization code to the start of the function. */
7562 :
7563 7353 : if ((sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.optional)
7564 7353 : || sym->attr.optional
7565 6871 : || sym->attr.not_always_present)
7566 : {
7567 539 : tree nullify;
7568 539 : if (TREE_CODE (parm) != PARM_DECL)
7569 105 : nullify = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
7570 : parm, null_pointer_node);
7571 : else
7572 434 : nullify = build_empty_stmt (input_location);
7573 539 : tmp = gfc_conv_expr_present (sym, true);
7574 539 : stmt = build3_v (COND_EXPR, tmp, stmt, nullify);
7575 : }
7576 :
7577 7353 : gfc_add_init_cleanup (block, stmt, NULL_TREE);
7578 7353 : }
7579 :
7580 :
7581 : /* Modify the descriptor of an array parameter so that it has the
7582 : correct lower bound. Also move the upper bound accordingly.
7583 : If the array is not packed, it will be copied into a temporary.
7584 : For each dimension we set the new lower and upper bounds. Then we copy the
7585 : stride and calculate the offset for this dimension. We also work out
7586 : what the stride of a packed array would be, and see it the two match.
7587 : If the array need repacking, we set the stride to the values we just
7588 : calculated, recalculate the offset and copy the array data.
7589 : Code is also added to copy the data back at the end of the function.
7590 : */
7591 :
7592 : void
7593 12779 : gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
7594 : gfc_wrapped_block * block)
7595 : {
7596 12779 : tree size;
7597 12779 : tree type;
7598 12779 : tree offset;
7599 12779 : stmtblock_t init;
7600 12779 : tree stmtInit, stmtCleanup;
7601 12779 : tree lbound;
7602 12779 : tree ubound;
7603 12779 : tree dubound;
7604 12779 : tree dlbound;
7605 12779 : tree dumdesc;
7606 12779 : tree tmp;
7607 12779 : tree stride, stride2;
7608 12779 : tree stmt_packed;
7609 12779 : tree stmt_unpacked;
7610 12779 : tree partial;
7611 12779 : gfc_se se;
7612 12779 : int n;
7613 12779 : int checkparm;
7614 12779 : int no_repack;
7615 12779 : bool optional_arg;
7616 12779 : gfc_array_spec *as;
7617 12779 : bool is_classarray = IS_CLASS_COARRAY_OR_ARRAY (sym);
7618 :
7619 : /* Do nothing for pointer and allocatable arrays. */
7620 12779 : if ((sym->ts.type != BT_CLASS && sym->attr.pointer)
7621 12682 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer)
7622 12682 : || sym->attr.allocatable
7623 12576 : || (is_classarray && CLASS_DATA (sym)->attr.allocatable))
7624 6035 : return;
7625 :
7626 784 : if ((!is_classarray
7627 784 : || (is_classarray && CLASS_DATA (sym)->as->type == AS_EXPLICIT))
7628 11976 : && sym->attr.dummy && !sym->attr.elemental && gfc_is_nodesc_array (sym))
7629 : {
7630 5832 : gfc_trans_g77_array (sym, block);
7631 5832 : return;
7632 : }
7633 :
7634 6744 : location_t loc = input_location;
7635 6744 : input_location = gfc_get_location (&sym->declared_at);
7636 :
7637 : /* Descriptor type. */
7638 6744 : type = TREE_TYPE (tmpdesc);
7639 6744 : gcc_assert (GFC_ARRAY_TYPE_P (type));
7640 6744 : dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
7641 6744 : if (is_classarray)
7642 : /* For a class array the dummy array descriptor is in the _class
7643 : component. */
7644 619 : dumdesc = gfc_class_data_get (dumdesc);
7645 : else
7646 6125 : dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc);
7647 6744 : as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
7648 6744 : gfc_start_block (&init);
7649 :
7650 6744 : if (sym->ts.type == BT_CHARACTER
7651 780 : && VAR_P (sym->ts.u.cl->backend_decl))
7652 87 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7653 :
7654 : /* TODO: Fix the exclusion of class arrays from extent checking. */
7655 1072 : checkparm = (as->type == AS_EXPLICIT && !is_classarray
7656 7797 : && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
7657 :
7658 6744 : no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
7659 6743 : || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
7660 :
7661 6744 : if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
7662 : {
7663 : /* For non-constant shape arrays we only check if the first dimension
7664 : is contiguous. Repacking higher dimensions wouldn't gain us
7665 : anything as we still don't know the array stride. */
7666 1 : partial = gfc_create_var (logical_type_node, "partial");
7667 1 : TREE_USED (partial) = 1;
7668 1 : tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
7669 1 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, tmp,
7670 : gfc_index_one_node);
7671 1 : gfc_add_modify (&init, partial, tmp);
7672 : }
7673 : else
7674 : partial = NULL_TREE;
7675 :
7676 : /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
7677 : here, however I think it does the right thing. */
7678 6744 : if (no_repack)
7679 : {
7680 : /* Set the first stride. */
7681 6742 : stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
7682 6742 : stride = gfc_evaluate_now (stride, &init);
7683 :
7684 6742 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7685 : stride, gfc_index_zero_node);
7686 6742 : tmp = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
7687 : tmp, gfc_index_one_node, stride);
7688 6742 : stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
7689 6742 : gfc_add_modify (&init, stride, tmp);
7690 :
7691 : /* Allow the user to disable array repacking. */
7692 6742 : stmt_unpacked = NULL_TREE;
7693 : }
7694 : else
7695 : {
7696 2 : gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
7697 : /* A library call to repack the array if necessary. */
7698 2 : tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
7699 2 : stmt_unpacked = build_call_expr_loc (input_location,
7700 : gfor_fndecl_in_pack, 1, tmp);
7701 :
7702 2 : stride = gfc_index_one_node;
7703 :
7704 2 : if (warn_array_temporaries)
7705 : {
7706 1 : locus where;
7707 1 : gfc_locus_from_location (&where, loc);
7708 1 : gfc_warning (OPT_Warray_temporaries,
7709 : "Creating array temporary at %L", &where);
7710 : }
7711 : }
7712 :
7713 : /* This is for the case where the array data is used directly without
7714 : calling the repack function. */
7715 6744 : if (no_repack || partial != NULL_TREE)
7716 6743 : stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
7717 : else
7718 : stmt_packed = NULL_TREE;
7719 :
7720 : /* Assign the data pointer. */
7721 6744 : if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
7722 : {
7723 : /* Don't repack unknown shape arrays when the first stride is 1. */
7724 1 : tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (stmt_packed),
7725 : partial, stmt_packed, stmt_unpacked);
7726 : }
7727 : else
7728 6743 : tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
7729 6744 : gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp));
7730 :
7731 6744 : offset = gfc_index_zero_node;
7732 6744 : size = gfc_index_one_node;
7733 :
7734 : /* Evaluate the bounds of the array. */
7735 15778 : for (n = 0; n < as->rank; n++)
7736 : {
7737 9034 : if (checkparm || !as->upper[n])
7738 : {
7739 : /* Get the bounds of the actual parameter. */
7740 7727 : dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]);
7741 7727 : dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]);
7742 : }
7743 : else
7744 : {
7745 : dubound = NULL_TREE;
7746 : dlbound = NULL_TREE;
7747 : }
7748 :
7749 9034 : lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
7750 9034 : if (!INTEGER_CST_P (lbound))
7751 : {
7752 46 : gfc_init_se (&se, NULL);
7753 46 : gfc_conv_expr_type (&se, as->lower[n],
7754 : gfc_array_index_type);
7755 46 : gfc_add_block_to_block (&init, &se.pre);
7756 46 : gfc_add_modify (&init, lbound, se.expr);
7757 : }
7758 :
7759 9034 : ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
7760 : /* Set the desired upper bound. */
7761 9034 : if (as->upper[n])
7762 : {
7763 : /* We know what we want the upper bound to be. */
7764 1365 : if (!INTEGER_CST_P (ubound))
7765 : {
7766 627 : gfc_init_se (&se, NULL);
7767 627 : gfc_conv_expr_type (&se, as->upper[n],
7768 : gfc_array_index_type);
7769 627 : gfc_add_block_to_block (&init, &se.pre);
7770 627 : gfc_add_modify (&init, ubound, se.expr);
7771 : }
7772 :
7773 : /* Check the sizes match. */
7774 1365 : if (checkparm)
7775 : {
7776 : /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
7777 58 : char * msg;
7778 58 : tree temp;
7779 58 : locus where;
7780 :
7781 58 : gfc_locus_from_location (&where, loc);
7782 58 : temp = fold_build2_loc (input_location, MINUS_EXPR,
7783 : gfc_array_index_type, ubound, lbound);
7784 58 : temp = fold_build2_loc (input_location, PLUS_EXPR,
7785 : gfc_array_index_type,
7786 : gfc_index_one_node, temp);
7787 58 : stride2 = fold_build2_loc (input_location, MINUS_EXPR,
7788 : gfc_array_index_type, dubound,
7789 : dlbound);
7790 58 : stride2 = fold_build2_loc (input_location, PLUS_EXPR,
7791 : gfc_array_index_type,
7792 : gfc_index_one_node, stride2);
7793 58 : tmp = fold_build2_loc (input_location, NE_EXPR,
7794 : gfc_array_index_type, temp, stride2);
7795 58 : msg = xasprintf ("Dimension %d of array '%s' has extent "
7796 : "%%ld instead of %%ld", n+1, sym->name);
7797 :
7798 58 : gfc_trans_runtime_check (true, false, tmp, &init, &where, msg,
7799 : fold_convert (long_integer_type_node, temp),
7800 : fold_convert (long_integer_type_node, stride2));
7801 :
7802 58 : free (msg);
7803 : }
7804 : }
7805 : else
7806 : {
7807 : /* For assumed shape arrays move the upper bound by the same amount
7808 : as the lower bound. */
7809 7669 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
7810 : gfc_array_index_type, dubound, dlbound);
7811 7669 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
7812 : gfc_array_index_type, tmp, lbound);
7813 7669 : gfc_add_modify (&init, ubound, tmp);
7814 : }
7815 : /* The offset of this dimension. offset = offset - lbound * stride. */
7816 9034 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7817 : lbound, stride);
7818 9034 : offset = fold_build2_loc (input_location, MINUS_EXPR,
7819 : gfc_array_index_type, offset, tmp);
7820 :
7821 : /* The size of this dimension, and the stride of the next. */
7822 9034 : if (n + 1 < as->rank)
7823 : {
7824 2290 : stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
7825 :
7826 2290 : if (no_repack || partial != NULL_TREE)
7827 2289 : stmt_unpacked =
7828 2289 : gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]);
7829 :
7830 : /* Figure out the stride if not a known constant. */
7831 2290 : if (!INTEGER_CST_P (stride))
7832 : {
7833 2289 : if (no_repack)
7834 : stmt_packed = NULL_TREE;
7835 : else
7836 : {
7837 : /* Calculate stride = size * (ubound + 1 - lbound). */
7838 0 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
7839 : gfc_array_index_type,
7840 : gfc_index_one_node, lbound);
7841 0 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
7842 : gfc_array_index_type, ubound, tmp);
7843 0 : size = fold_build2_loc (input_location, MULT_EXPR,
7844 : gfc_array_index_type, size, tmp);
7845 0 : stmt_packed = size;
7846 : }
7847 :
7848 : /* Assign the stride. */
7849 2289 : if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
7850 0 : tmp = fold_build3_loc (input_location, COND_EXPR,
7851 : gfc_array_index_type, partial,
7852 : stmt_unpacked, stmt_packed);
7853 : else
7854 2289 : tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
7855 2289 : gfc_add_modify (&init, stride, tmp);
7856 : }
7857 : }
7858 : else
7859 : {
7860 6744 : stride = GFC_TYPE_ARRAY_SIZE (type);
7861 :
7862 6744 : if (stride && !INTEGER_CST_P (stride))
7863 : {
7864 : /* Calculate size = stride * (ubound + 1 - lbound). */
7865 6743 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
7866 : gfc_array_index_type,
7867 : gfc_index_one_node, lbound);
7868 6743 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
7869 : gfc_array_index_type,
7870 : ubound, tmp);
7871 20229 : tmp = fold_build2_loc (input_location, MULT_EXPR,
7872 : gfc_array_index_type,
7873 6743 : GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
7874 6743 : gfc_add_modify (&init, stride, tmp);
7875 : }
7876 : }
7877 : }
7878 :
7879 6744 : gfc_trans_array_cobounds (type, &init, sym);
7880 :
7881 : /* Set the offset. */
7882 6744 : if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
7883 6742 : gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
7884 :
7885 6744 : gfc_trans_vla_type_sizes (sym, &init);
7886 :
7887 6744 : stmtInit = gfc_finish_block (&init);
7888 :
7889 : /* Only do the entry/initialization code if the arg is present. */
7890 6744 : dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
7891 6744 : optional_arg = (sym->attr.optional
7892 6744 : || (sym->ns->proc_name->attr.entry_master
7893 79 : && sym->attr.dummy));
7894 : if (optional_arg)
7895 : {
7896 717 : tree zero_init = fold_convert (TREE_TYPE (tmpdesc), null_pointer_node);
7897 717 : zero_init = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
7898 : tmpdesc, zero_init);
7899 717 : tmp = gfc_conv_expr_present (sym, true);
7900 717 : stmtInit = build3_v (COND_EXPR, tmp, stmtInit, zero_init);
7901 : }
7902 :
7903 : /* Cleanup code. */
7904 6744 : if (no_repack)
7905 : stmtCleanup = NULL_TREE;
7906 : else
7907 : {
7908 2 : stmtblock_t cleanup;
7909 2 : gfc_start_block (&cleanup);
7910 :
7911 2 : if (sym->attr.intent != INTENT_IN)
7912 : {
7913 : /* Copy the data back. */
7914 2 : tmp = build_call_expr_loc (input_location,
7915 : gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
7916 2 : gfc_add_expr_to_block (&cleanup, tmp);
7917 : }
7918 :
7919 : /* Free the temporary. */
7920 2 : tmp = gfc_call_free (tmpdesc);
7921 2 : gfc_add_expr_to_block (&cleanup, tmp);
7922 :
7923 2 : stmtCleanup = gfc_finish_block (&cleanup);
7924 :
7925 : /* Only do the cleanup if the array was repacked. */
7926 2 : if (is_classarray)
7927 : /* For a class array the dummy array descriptor is in the _class
7928 : component. */
7929 1 : tmp = gfc_class_data_get (dumdesc);
7930 : else
7931 1 : tmp = build_fold_indirect_ref_loc (input_location, dumdesc);
7932 2 : tmp = gfc_conv_descriptor_data_get (tmp);
7933 2 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
7934 : tmp, tmpdesc);
7935 2 : stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
7936 : build_empty_stmt (input_location));
7937 :
7938 2 : if (optional_arg)
7939 : {
7940 0 : tmp = gfc_conv_expr_present (sym);
7941 0 : stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
7942 : build_empty_stmt (input_location));
7943 : }
7944 : }
7945 :
7946 : /* We don't need to free any memory allocated by internal_pack as it will
7947 : be freed at the end of the function by pop_context. */
7948 6744 : gfc_add_init_cleanup (block, stmtInit, stmtCleanup);
7949 :
7950 6744 : input_location = loc;
7951 : }
7952 :
7953 :
7954 : /* Calculate the overall offset, including subreferences. */
7955 : void
7956 59408 : gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
7957 : bool subref, gfc_expr *expr)
7958 : {
7959 59408 : tree tmp;
7960 59408 : tree field;
7961 59408 : tree stride;
7962 59408 : tree index;
7963 59408 : gfc_ref *ref;
7964 59408 : gfc_se start;
7965 59408 : int n;
7966 :
7967 : /* If offset is NULL and this is not a subreferenced array, there is
7968 : nothing to do. */
7969 59408 : if (offset == NULL_TREE)
7970 : {
7971 1066 : if (subref)
7972 139 : offset = gfc_index_zero_node;
7973 : else
7974 927 : return;
7975 : }
7976 :
7977 58481 : tmp = build_array_ref (desc, offset, NULL, NULL);
7978 :
7979 : /* Offset the data pointer for pointer assignments from arrays with
7980 : subreferences; e.g. my_integer => my_type(:)%integer_component. */
7981 58481 : if (subref)
7982 : {
7983 : /* Go past the array reference. */
7984 844 : for (ref = expr->ref; ref; ref = ref->next)
7985 844 : if (ref->type == REF_ARRAY &&
7986 757 : ref->u.ar.type != AR_ELEMENT)
7987 : {
7988 733 : ref = ref->next;
7989 733 : break;
7990 : }
7991 :
7992 : /* Calculate the offset for each subsequent subreference. */
7993 1438 : for (; ref; ref = ref->next)
7994 : {
7995 705 : switch (ref->type)
7996 : {
7997 301 : case REF_COMPONENT:
7998 301 : field = ref->u.c.component->backend_decl;
7999 301 : gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
8000 602 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
8001 301 : TREE_TYPE (field),
8002 : tmp, field, NULL_TREE);
8003 301 : break;
8004 :
8005 320 : case REF_SUBSTRING:
8006 320 : gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
8007 320 : gfc_init_se (&start, NULL);
8008 320 : gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
8009 320 : gfc_add_block_to_block (block, &start.pre);
8010 320 : tmp = gfc_build_array_ref (tmp, start.expr, NULL);
8011 320 : break;
8012 :
8013 24 : case REF_ARRAY:
8014 24 : gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
8015 : && ref->u.ar.type == AR_ELEMENT);
8016 :
8017 : /* TODO - Add bounds checking. */
8018 24 : stride = gfc_index_one_node;
8019 24 : index = gfc_index_zero_node;
8020 55 : for (n = 0; n < ref->u.ar.dimen; n++)
8021 : {
8022 31 : tree itmp;
8023 31 : tree jtmp;
8024 :
8025 : /* Update the index. */
8026 31 : gfc_init_se (&start, NULL);
8027 31 : gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
8028 31 : itmp = gfc_evaluate_now (start.expr, block);
8029 31 : gfc_init_se (&start, NULL);
8030 31 : gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
8031 31 : jtmp = gfc_evaluate_now (start.expr, block);
8032 31 : itmp = fold_build2_loc (input_location, MINUS_EXPR,
8033 : gfc_array_index_type, itmp, jtmp);
8034 31 : itmp = fold_build2_loc (input_location, MULT_EXPR,
8035 : gfc_array_index_type, itmp, stride);
8036 31 : index = fold_build2_loc (input_location, PLUS_EXPR,
8037 : gfc_array_index_type, itmp, index);
8038 31 : index = gfc_evaluate_now (index, block);
8039 :
8040 : /* Update the stride. */
8041 31 : gfc_init_se (&start, NULL);
8042 31 : gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
8043 31 : itmp = fold_build2_loc (input_location, MINUS_EXPR,
8044 : gfc_array_index_type, start.expr,
8045 : jtmp);
8046 31 : itmp = fold_build2_loc (input_location, PLUS_EXPR,
8047 : gfc_array_index_type,
8048 : gfc_index_one_node, itmp);
8049 31 : stride = fold_build2_loc (input_location, MULT_EXPR,
8050 : gfc_array_index_type, stride, itmp);
8051 31 : stride = gfc_evaluate_now (stride, block);
8052 : }
8053 :
8054 : /* Apply the index to obtain the array element. */
8055 24 : tmp = gfc_build_array_ref (tmp, index, NULL);
8056 24 : break;
8057 :
8058 60 : case REF_INQUIRY:
8059 60 : switch (ref->u.i)
8060 : {
8061 54 : case INQUIRY_RE:
8062 108 : tmp = fold_build1_loc (input_location, REALPART_EXPR,
8063 54 : TREE_TYPE (TREE_TYPE (tmp)), tmp);
8064 54 : break;
8065 :
8066 6 : case INQUIRY_IM:
8067 12 : tmp = fold_build1_loc (input_location, IMAGPART_EXPR,
8068 6 : TREE_TYPE (TREE_TYPE (tmp)), tmp);
8069 6 : break;
8070 :
8071 : default:
8072 : break;
8073 : }
8074 : break;
8075 :
8076 0 : default:
8077 0 : gcc_unreachable ();
8078 705 : break;
8079 : }
8080 : }
8081 : }
8082 :
8083 : /* Set the target data pointer. */
8084 58481 : offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
8085 :
8086 : /* Check for optional dummy argument being present. Arguments of BIND(C)
8087 : procedures are excepted here since they are handled differently. */
8088 58481 : if (expr->expr_type == EXPR_VARIABLE
8089 51502 : && expr->symtree->n.sym->attr.dummy
8090 6170 : && expr->symtree->n.sym->attr.optional
8091 59473 : && !is_CFI_desc (NULL, expr))
8092 1624 : offset = build3_loc (input_location, COND_EXPR, TREE_TYPE (offset),
8093 812 : gfc_conv_expr_present (expr->symtree->n.sym), offset,
8094 812 : fold_convert (TREE_TYPE (offset), gfc_index_zero_node));
8095 :
8096 58481 : gfc_conv_descriptor_data_set (block, parm, offset);
8097 : }
8098 :
8099 :
8100 : /* gfc_conv_expr_descriptor needs the string length an expression
8101 : so that the size of the temporary can be obtained. This is done
8102 : by adding up the string lengths of all the elements in the
8103 : expression. Function with non-constant expressions have their
8104 : string lengths mapped onto the actual arguments using the
8105 : interface mapping machinery in trans-expr.cc. */
8106 : static void
8107 1563 : get_array_charlen (gfc_expr *expr, gfc_se *se)
8108 : {
8109 1563 : gfc_interface_mapping mapping;
8110 1563 : gfc_formal_arglist *formal;
8111 1563 : gfc_actual_arglist *arg;
8112 1563 : gfc_se tse;
8113 1563 : gfc_expr *e;
8114 :
8115 1563 : if (expr->ts.u.cl->length
8116 1563 : && gfc_is_constant_expr (expr->ts.u.cl->length))
8117 : {
8118 1219 : if (!expr->ts.u.cl->backend_decl)
8119 471 : gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
8120 1351 : return;
8121 : }
8122 :
8123 344 : switch (expr->expr_type)
8124 : {
8125 130 : case EXPR_ARRAY:
8126 :
8127 : /* This is somewhat brutal. The expression for the first
8128 : element of the array is evaluated and assigned to a
8129 : new string length for the original expression. */
8130 130 : e = gfc_constructor_first (expr->value.constructor)->expr;
8131 :
8132 130 : gfc_init_se (&tse, NULL);
8133 :
8134 : /* Avoid evaluating trailing array references since all we need is
8135 : the string length. */
8136 130 : if (e->rank)
8137 38 : tse.descriptor_only = 1;
8138 130 : if (e->rank && e->expr_type != EXPR_VARIABLE)
8139 1 : gfc_conv_expr_descriptor (&tse, e);
8140 : else
8141 129 : gfc_conv_expr (&tse, e);
8142 :
8143 130 : gfc_add_block_to_block (&se->pre, &tse.pre);
8144 130 : gfc_add_block_to_block (&se->post, &tse.post);
8145 :
8146 130 : if (!expr->ts.u.cl->backend_decl || !VAR_P (expr->ts.u.cl->backend_decl))
8147 : {
8148 87 : expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
8149 87 : expr->ts.u.cl->backend_decl =
8150 87 : gfc_create_var (gfc_charlen_type_node, "sln");
8151 : }
8152 :
8153 130 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
8154 : tse.string_length);
8155 :
8156 : /* Make sure that deferred length components point to the hidden
8157 : string_length component. */
8158 130 : if (TREE_CODE (tse.expr) == COMPONENT_REF
8159 25 : && TREE_CODE (tse.string_length) == COMPONENT_REF
8160 149 : && TREE_OPERAND (tse.expr, 0) == TREE_OPERAND (tse.string_length, 0))
8161 19 : e->ts.u.cl->backend_decl = expr->ts.u.cl->backend_decl;
8162 :
8163 : return;
8164 :
8165 90 : case EXPR_OP:
8166 90 : get_array_charlen (expr->value.op.op1, se);
8167 :
8168 : /* For parentheses the expression ts.u.cl should be identical. */
8169 90 : if (expr->value.op.op == INTRINSIC_PARENTHESES)
8170 : {
8171 2 : if (expr->value.op.op1->ts.u.cl != expr->ts.u.cl)
8172 2 : expr->ts.u.cl->backend_decl
8173 2 : = expr->value.op.op1->ts.u.cl->backend_decl;
8174 2 : return;
8175 : }
8176 :
8177 176 : expr->ts.u.cl->backend_decl =
8178 88 : gfc_create_var (gfc_charlen_type_node, "sln");
8179 :
8180 88 : if (expr->value.op.op2)
8181 : {
8182 88 : get_array_charlen (expr->value.op.op2, se);
8183 :
8184 88 : gcc_assert (expr->value.op.op == INTRINSIC_CONCAT);
8185 :
8186 : /* Add the string lengths and assign them to the expression
8187 : string length backend declaration. */
8188 88 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
8189 : fold_build2_loc (input_location, PLUS_EXPR,
8190 : gfc_charlen_type_node,
8191 88 : expr->value.op.op1->ts.u.cl->backend_decl,
8192 88 : expr->value.op.op2->ts.u.cl->backend_decl));
8193 : }
8194 : else
8195 0 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
8196 0 : expr->value.op.op1->ts.u.cl->backend_decl);
8197 : break;
8198 :
8199 43 : case EXPR_FUNCTION:
8200 43 : if (expr->value.function.esym == NULL
8201 37 : || expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
8202 : {
8203 6 : gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
8204 6 : break;
8205 : }
8206 :
8207 : /* Map expressions involving the dummy arguments onto the actual
8208 : argument expressions. */
8209 37 : gfc_init_interface_mapping (&mapping);
8210 37 : formal = gfc_sym_get_dummy_args (expr->symtree->n.sym);
8211 37 : arg = expr->value.function.actual;
8212 :
8213 : /* Set se = NULL in the calls to the interface mapping, to suppress any
8214 : backend stuff. */
8215 113 : for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
8216 : {
8217 38 : if (!arg->expr)
8218 0 : continue;
8219 38 : if (formal->sym)
8220 38 : gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
8221 : }
8222 :
8223 37 : gfc_init_se (&tse, NULL);
8224 :
8225 : /* Build the expression for the character length and convert it. */
8226 37 : gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length);
8227 :
8228 37 : gfc_add_block_to_block (&se->pre, &tse.pre);
8229 37 : gfc_add_block_to_block (&se->post, &tse.post);
8230 37 : tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
8231 74 : tse.expr = fold_build2_loc (input_location, MAX_EXPR,
8232 37 : TREE_TYPE (tse.expr), tse.expr,
8233 37 : build_zero_cst (TREE_TYPE (tse.expr)));
8234 37 : expr->ts.u.cl->backend_decl = tse.expr;
8235 37 : gfc_free_interface_mapping (&mapping);
8236 37 : break;
8237 :
8238 81 : default:
8239 81 : gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
8240 81 : break;
8241 : }
8242 : }
8243 :
8244 :
8245 : /* Helper function to check dimensions. */
8246 : static bool
8247 144 : transposed_dims (gfc_ss *ss)
8248 : {
8249 144 : int n;
8250 :
8251 174220 : for (n = 0; n < ss->dimen; n++)
8252 88507 : if (ss->dim[n] != n)
8253 : return true;
8254 : return false;
8255 : }
8256 :
8257 :
8258 : /* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
8259 : AR_FULL, suitable for the scalarizer. */
8260 :
8261 : static gfc_ss *
8262 1510 : walk_coarray (gfc_expr *e)
8263 : {
8264 1510 : gfc_ss *ss;
8265 :
8266 1510 : ss = gfc_walk_expr (e);
8267 :
8268 : /* Fix scalar coarray. */
8269 1510 : if (ss == gfc_ss_terminator)
8270 : {
8271 357 : gfc_ref *ref;
8272 :
8273 357 : ref = e->ref;
8274 508 : while (ref)
8275 : {
8276 508 : if (ref->type == REF_ARRAY
8277 357 : && ref->u.ar.codimen > 0)
8278 : break;
8279 :
8280 151 : ref = ref->next;
8281 : }
8282 :
8283 357 : gcc_assert (ref != NULL);
8284 357 : if (ref->u.ar.type == AR_ELEMENT)
8285 339 : ref->u.ar.type = AR_SECTION;
8286 357 : ss = gfc_reverse_ss (gfc_walk_array_ref (ss, e, ref, false));
8287 : }
8288 :
8289 1510 : return ss;
8290 : }
8291 :
8292 : gfc_array_spec *
8293 2177 : get_coarray_as (const gfc_expr *e)
8294 : {
8295 2177 : gfc_array_spec *as;
8296 2177 : gfc_symbol *sym = e->symtree->n.sym;
8297 2177 : gfc_component *comp;
8298 :
8299 2177 : if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.codimension)
8300 595 : as = CLASS_DATA (sym)->as;
8301 1582 : else if (sym->attr.codimension)
8302 1522 : as = sym->as;
8303 : else
8304 : as = nullptr;
8305 :
8306 5069 : for (gfc_ref *ref = e->ref; ref; ref = ref->next)
8307 : {
8308 2892 : switch (ref->type)
8309 : {
8310 715 : case REF_COMPONENT:
8311 715 : comp = ref->u.c.component;
8312 715 : if (comp->ts.type == BT_CLASS && CLASS_DATA (comp)->attr.codimension)
8313 18 : as = CLASS_DATA (comp)->as;
8314 697 : else if (comp->ts.type != BT_CLASS && comp->attr.codimension)
8315 655 : as = comp->as;
8316 : break;
8317 :
8318 : case REF_ARRAY:
8319 : case REF_SUBSTRING:
8320 : case REF_INQUIRY:
8321 : break;
8322 : }
8323 : }
8324 :
8325 2177 : return as;
8326 : }
8327 :
8328 : bool
8329 141576 : is_explicit_coarray (gfc_expr *expr)
8330 : {
8331 141576 : if (!gfc_is_coarray (expr))
8332 : return false;
8333 :
8334 2177 : gfc_array_spec *cas = get_coarray_as (expr);
8335 2177 : return cas && cas->cotype == AS_EXPLICIT;
8336 : }
8337 :
8338 : /* Convert an array for passing as an actual argument. Expressions and
8339 : vector subscripts are evaluated and stored in a temporary, which is then
8340 : passed. For whole arrays the descriptor is passed. For array sections
8341 : a modified copy of the descriptor is passed, but using the original data.
8342 :
8343 : This function is also used for array pointer assignments, and there
8344 : are three cases:
8345 :
8346 : - se->want_pointer && !se->direct_byref
8347 : EXPR is an actual argument. On exit, se->expr contains a
8348 : pointer to the array descriptor.
8349 :
8350 : - !se->want_pointer && !se->direct_byref
8351 : EXPR is an actual argument to an intrinsic function or the
8352 : left-hand side of a pointer assignment. On exit, se->expr
8353 : contains the descriptor for EXPR.
8354 :
8355 : - !se->want_pointer && se->direct_byref
8356 : EXPR is the right-hand side of a pointer assignment and
8357 : se->expr is the descriptor for the previously-evaluated
8358 : left-hand side. The function creates an assignment from
8359 : EXPR to se->expr.
8360 :
8361 :
8362 : The se->force_tmp flag disables the non-copying descriptor optimization
8363 : that is used for transpose. It may be used in cases where there is an
8364 : alias between the transpose argument and another argument in the same
8365 : function call. */
8366 :
8367 : void
8368 157538 : gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
8369 : {
8370 157538 : gfc_ss *ss;
8371 157538 : gfc_ss_type ss_type;
8372 157538 : gfc_ss_info *ss_info;
8373 157538 : gfc_loopinfo loop;
8374 157538 : gfc_array_info *info;
8375 157538 : int need_tmp;
8376 157538 : int n;
8377 157538 : tree tmp;
8378 157538 : tree desc;
8379 157538 : stmtblock_t block;
8380 157538 : tree start;
8381 157538 : int full;
8382 157538 : bool subref_array_target = false;
8383 157538 : bool deferred_array_component = false;
8384 157538 : bool substr = false;
8385 157538 : gfc_expr *arg, *ss_expr;
8386 :
8387 157538 : if (se->want_coarray || expr->rank == 0)
8388 1510 : ss = walk_coarray (expr);
8389 : else
8390 156028 : ss = gfc_walk_expr (expr);
8391 :
8392 157538 : gcc_assert (ss != NULL);
8393 157538 : gcc_assert (ss != gfc_ss_terminator);
8394 :
8395 157538 : ss_info = ss->info;
8396 157538 : ss_type = ss_info->type;
8397 157538 : ss_expr = ss_info->expr;
8398 :
8399 : /* Special case: TRANSPOSE which needs no temporary. */
8400 162780 : while (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym
8401 162510 : && (arg = gfc_get_noncopying_intrinsic_argument (expr)) != NULL)
8402 : {
8403 : /* This is a call to transpose which has already been handled by the
8404 : scalarizer, so that we just need to get its argument's descriptor. */
8405 408 : gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
8406 408 : expr = expr->value.function.actual->expr;
8407 : }
8408 :
8409 157538 : if (!se->direct_byref)
8410 302738 : se->unlimited_polymorphic = UNLIMITED_POLY (expr);
8411 :
8412 : /* Special case things we know we can pass easily. */
8413 157538 : switch (expr->expr_type)
8414 : {
8415 141855 : case EXPR_VARIABLE:
8416 : /* If we have a linear array section, we can pass it directly.
8417 : Otherwise we need to copy it into a temporary. */
8418 :
8419 141855 : gcc_assert (ss_type == GFC_SS_SECTION);
8420 141855 : gcc_assert (ss_expr == expr);
8421 141855 : info = &ss_info->data.array;
8422 :
8423 : /* Get the descriptor for the array. */
8424 141855 : gfc_conv_ss_descriptor (&se->pre, ss, 0);
8425 141855 : desc = info->descriptor;
8426 :
8427 : /* The charlen backend decl for deferred character components cannot
8428 : be used because it is fixed at zero. Instead, the hidden string
8429 : length component is used. */
8430 141855 : if (expr->ts.type == BT_CHARACTER
8431 20185 : && expr->ts.deferred
8432 2830 : && TREE_CODE (desc) == COMPONENT_REF)
8433 141855 : deferred_array_component = true;
8434 :
8435 141855 : substr = info->ref && info->ref->next
8436 142683 : && info->ref->next->type == REF_SUBSTRING;
8437 :
8438 141855 : subref_array_target = (is_subref_array (expr)
8439 141855 : && (se->direct_byref
8440 2596 : || expr->ts.type == BT_CHARACTER));
8441 141855 : need_tmp = (gfc_ref_needs_temporary_p (expr->ref)
8442 141855 : && !subref_array_target);
8443 :
8444 141855 : if (se->force_tmp)
8445 : need_tmp = 1;
8446 141672 : else if (se->force_no_tmp)
8447 : need_tmp = 0;
8448 :
8449 135535 : if (need_tmp)
8450 : full = 0;
8451 141576 : else if (is_explicit_coarray (expr))
8452 : full = 0;
8453 140756 : else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
8454 : {
8455 : /* Create a new descriptor if the array doesn't have one. */
8456 : full = 0;
8457 : }
8458 91794 : else if (info->ref->u.ar.type == AR_FULL || se->descriptor_only)
8459 : full = 1;
8460 7949 : else if (se->direct_byref)
8461 : full = 0;
8462 7586 : else if (info->ref->u.ar.dimen == 0 && !info->ref->next)
8463 : full = 1;
8464 7445 : else if (info->ref->u.ar.type == AR_SECTION && se->want_pointer)
8465 : full = 0;
8466 : else
8467 3559 : full = gfc_full_array_ref_p (info->ref, NULL);
8468 :
8469 171771 : if (full && !transposed_dims (ss))
8470 : {
8471 84169 : if (se->direct_byref && !se->byref_noassign)
8472 : {
8473 1054 : struct lang_type *lhs_ls
8474 1054 : = TYPE_LANG_SPECIFIC (TREE_TYPE (se->expr)),
8475 1054 : *rhs_ls = TYPE_LANG_SPECIFIC (TREE_TYPE (desc));
8476 : /* When only the array_kind differs, do a view_convert. */
8477 1450 : tmp = lhs_ls && rhs_ls && lhs_ls->rank == rhs_ls->rank
8478 1054 : && lhs_ls->akind != rhs_ls->akind
8479 1450 : ? build1 (VIEW_CONVERT_EXPR, TREE_TYPE (se->expr), desc)
8480 : : desc;
8481 : /* Copy the descriptor for pointer assignments. */
8482 1054 : gfc_add_modify (&se->pre, se->expr, tmp);
8483 :
8484 : /* Add any offsets from subreferences. */
8485 1054 : gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
8486 : subref_array_target, expr);
8487 :
8488 : /* ....and set the span field. */
8489 1054 : if (ss_info->expr->ts.type == BT_CHARACTER)
8490 141 : tmp = gfc_conv_descriptor_span_get (desc);
8491 : else
8492 913 : tmp = gfc_get_array_span (desc, expr);
8493 1054 : gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp);
8494 1054 : }
8495 83115 : else if (se->want_pointer)
8496 : {
8497 : /* We pass full arrays directly. This means that pointers and
8498 : allocatable arrays should also work. */
8499 13798 : se->expr = gfc_build_addr_expr (NULL_TREE, desc);
8500 : }
8501 : else
8502 : {
8503 69317 : se->expr = desc;
8504 : }
8505 :
8506 84169 : if (expr->ts.type == BT_CHARACTER && !deferred_array_component)
8507 8378 : se->string_length = gfc_get_expr_charlen (expr);
8508 : /* The ss_info string length is returned set to the value of the
8509 : hidden string length component. */
8510 75528 : else if (deferred_array_component)
8511 263 : se->string_length = ss_info->string_length;
8512 :
8513 84169 : se->class_container = ss_info->class_container;
8514 :
8515 84169 : gfc_free_ss_chain (ss);
8516 168464 : return;
8517 : }
8518 : break;
8519 :
8520 4834 : case EXPR_FUNCTION:
8521 : /* A transformational function return value will be a temporary
8522 : array descriptor. We still need to go through the scalarizer
8523 : to create the descriptor. Elemental functions are handled as
8524 : arbitrary expressions, i.e. copy to a temporary. */
8525 :
8526 4834 : if (se->direct_byref)
8527 : {
8528 126 : gcc_assert (ss_type == GFC_SS_FUNCTION && ss_expr == expr);
8529 :
8530 : /* For pointer assignments pass the descriptor directly. */
8531 126 : if (se->ss == NULL)
8532 126 : se->ss = ss;
8533 : else
8534 0 : gcc_assert (se->ss == ss);
8535 :
8536 126 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
8537 126 : gfc_conv_expr (se, expr);
8538 :
8539 126 : gfc_free_ss_chain (ss);
8540 126 : return;
8541 : }
8542 :
8543 4708 : if (ss_expr != expr || ss_type != GFC_SS_FUNCTION)
8544 : {
8545 3289 : if (ss_expr != expr)
8546 : /* Elemental function. */
8547 2564 : gcc_assert ((expr->value.function.esym != NULL
8548 : && expr->value.function.esym->attr.elemental)
8549 : || (expr->value.function.isym != NULL
8550 : && expr->value.function.isym->elemental)
8551 : || (gfc_expr_attr (expr).proc_pointer
8552 : && gfc_expr_attr (expr).elemental)
8553 : || gfc_inline_intrinsic_function_p (expr));
8554 :
8555 3289 : need_tmp = 1;
8556 3289 : if (expr->ts.type == BT_CHARACTER
8557 35 : && expr->ts.u.cl->length
8558 29 : && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
8559 13 : get_array_charlen (expr, se);
8560 :
8561 : info = NULL;
8562 : }
8563 : else
8564 : {
8565 : /* Transformational function. */
8566 1419 : info = &ss_info->data.array;
8567 1419 : need_tmp = 0;
8568 : }
8569 : break;
8570 :
8571 10135 : case EXPR_ARRAY:
8572 : /* Constant array constructors don't need a temporary. */
8573 10135 : if (ss_type == GFC_SS_CONSTRUCTOR
8574 10135 : && expr->ts.type != BT_CHARACTER
8575 19029 : && gfc_constant_array_constructor_p (expr->value.constructor))
8576 : {
8577 6966 : need_tmp = 0;
8578 6966 : info = &ss_info->data.array;
8579 : }
8580 : else
8581 : {
8582 : need_tmp = 1;
8583 : info = NULL;
8584 : }
8585 : break;
8586 :
8587 : default:
8588 : /* Something complicated. Copy it into a temporary. */
8589 : need_tmp = 1;
8590 : info = NULL;
8591 : break;
8592 : }
8593 :
8594 : /* If we are creating a temporary, we don't need to bother about aliases
8595 : anymore. */
8596 66071 : if (need_tmp)
8597 7451 : se->force_tmp = 0;
8598 :
8599 73243 : gfc_init_loopinfo (&loop);
8600 :
8601 : /* Associate the SS with the loop. */
8602 73243 : gfc_add_ss_to_loop (&loop, ss);
8603 :
8604 : /* Tell the scalarizer not to bother creating loop variables, etc. */
8605 73243 : if (!need_tmp)
8606 65792 : loop.array_parameter = 1;
8607 : else
8608 : /* The right-hand side of a pointer assignment mustn't use a temporary. */
8609 7451 : gcc_assert (!se->direct_byref);
8610 :
8611 : /* Do we need bounds checking or not? */
8612 73243 : ss->no_bounds_check = expr->no_bounds_check;
8613 :
8614 : /* Setup the scalarizing loops and bounds. */
8615 73243 : gfc_conv_ss_startstride (&loop);
8616 :
8617 : /* Add bounds-checking for elemental dimensions. */
8618 73243 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !expr->no_bounds_check)
8619 6674 : array_bound_check_elemental (se, ss, expr);
8620 :
8621 73243 : if (need_tmp)
8622 : {
8623 7451 : if (expr->ts.type == BT_CHARACTER
8624 1479 : && (!expr->ts.u.cl->backend_decl || expr->expr_type == EXPR_ARRAY))
8625 1372 : get_array_charlen (expr, se);
8626 :
8627 : /* Tell the scalarizer to make a temporary. */
8628 7451 : loop.temp_ss = gfc_get_temp_ss (gfc_typenode_for_spec (&expr->ts),
8629 7451 : ((expr->ts.type == BT_CHARACTER)
8630 1479 : ? expr->ts.u.cl->backend_decl
8631 : : NULL),
8632 : loop.dimen);
8633 :
8634 7451 : se->string_length = loop.temp_ss->info->string_length;
8635 7451 : gcc_assert (loop.temp_ss->dimen == loop.dimen);
8636 7451 : gfc_add_ss_to_loop (&loop, loop.temp_ss);
8637 : }
8638 :
8639 73243 : gfc_conv_loop_setup (&loop, & expr->where);
8640 :
8641 73243 : if (need_tmp)
8642 : {
8643 : /* Copy into a temporary and pass that. We don't need to copy the data
8644 : back because expressions and vector subscripts must be INTENT_IN. */
8645 : /* TODO: Optimize passing function return values. */
8646 7451 : gfc_se lse;
8647 7451 : gfc_se rse;
8648 7451 : bool deep_copy;
8649 :
8650 : /* Start the copying loops. */
8651 7451 : gfc_mark_ss_chain_used (loop.temp_ss, 1);
8652 7451 : gfc_mark_ss_chain_used (ss, 1);
8653 7451 : gfc_start_scalarized_body (&loop, &block);
8654 :
8655 : /* Copy each data element. */
8656 7451 : gfc_init_se (&lse, NULL);
8657 7451 : gfc_copy_loopinfo_to_se (&lse, &loop);
8658 7451 : gfc_init_se (&rse, NULL);
8659 7451 : gfc_copy_loopinfo_to_se (&rse, &loop);
8660 :
8661 7451 : lse.ss = loop.temp_ss;
8662 7451 : rse.ss = ss;
8663 :
8664 7451 : gfc_conv_tmp_array_ref (&lse);
8665 7451 : if (expr->ts.type == BT_CHARACTER)
8666 : {
8667 1479 : gfc_conv_expr (&rse, expr);
8668 1479 : if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
8669 1157 : rse.expr = build_fold_indirect_ref_loc (input_location,
8670 : rse.expr);
8671 : }
8672 : else
8673 5972 : gfc_conv_expr_val (&rse, expr);
8674 :
8675 7451 : gfc_add_block_to_block (&block, &rse.pre);
8676 7451 : gfc_add_block_to_block (&block, &lse.pre);
8677 :
8678 7451 : lse.string_length = rse.string_length;
8679 :
8680 14902 : deep_copy = !se->data_not_needed
8681 7451 : && (expr->expr_type == EXPR_VARIABLE
8682 6919 : || expr->expr_type == EXPR_ARRAY);
8683 7451 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts,
8684 : deep_copy, false);
8685 7451 : gfc_add_expr_to_block (&block, tmp);
8686 :
8687 : /* Finish the copying loops. */
8688 7451 : gfc_trans_scalarizing_loops (&loop, &block);
8689 :
8690 7451 : desc = loop.temp_ss->info->data.array.descriptor;
8691 : }
8692 67211 : else if (expr->expr_type == EXPR_FUNCTION && !transposed_dims (ss))
8693 : {
8694 1406 : desc = info->descriptor;
8695 1406 : se->string_length = ss_info->string_length;
8696 : }
8697 : else
8698 : {
8699 : /* We pass sections without copying to a temporary. Make a new
8700 : descriptor and point it at the section we want. The loop variable
8701 : limits will be the limits of the section.
8702 : A function may decide to repack the array to speed up access, but
8703 : we're not bothered about that here. */
8704 64386 : int dim, ndim, codim;
8705 64386 : tree parm;
8706 64386 : tree parmtype;
8707 64386 : tree dtype;
8708 64386 : tree stride;
8709 64386 : tree from;
8710 64386 : tree to;
8711 64386 : tree base;
8712 64386 : tree offset;
8713 :
8714 64386 : ndim = info->ref ? info->ref->u.ar.dimen : ss->dimen;
8715 :
8716 64386 : if (se->want_coarray)
8717 : {
8718 694 : gfc_array_ref *ar = &info->ref->u.ar;
8719 :
8720 694 : codim = expr->corank;
8721 1512 : for (n = 0; n < codim - 1; n++)
8722 : {
8723 : /* Make sure we are not lost somehow. */
8724 818 : gcc_assert (ar->dimen_type[n + ndim] == DIMEN_THIS_IMAGE);
8725 :
8726 : /* Make sure the call to gfc_conv_section_startstride won't
8727 : generate unnecessary code to calculate stride. */
8728 818 : gcc_assert (ar->stride[n + ndim] == NULL);
8729 :
8730 818 : gfc_conv_section_startstride (&loop.pre, ss, n + ndim);
8731 818 : loop.from[n + loop.dimen] = info->start[n + ndim];
8732 818 : loop.to[n + loop.dimen] = info->end[n + ndim];
8733 : }
8734 :
8735 694 : gcc_assert (n == codim - 1);
8736 694 : evaluate_bound (&loop.pre, info->start, ar->start,
8737 : info->descriptor, n + ndim, true,
8738 694 : ar->as->type == AS_DEFERRED, true);
8739 694 : loop.from[n + loop.dimen] = info->start[n + ndim];
8740 : }
8741 : else
8742 : codim = 0;
8743 :
8744 : /* Set the string_length for a character array. */
8745 64386 : if (expr->ts.type == BT_CHARACTER)
8746 : {
8747 11500 : if (deferred_array_component && !substr)
8748 37 : se->string_length = ss_info->string_length;
8749 : else
8750 11463 : se->string_length = gfc_get_expr_charlen (expr);
8751 :
8752 11500 : if (VAR_P (se->string_length)
8753 990 : && expr->ts.u.cl->backend_decl == se->string_length)
8754 984 : tmp = ss_info->string_length;
8755 : else
8756 : tmp = se->string_length;
8757 :
8758 11500 : if (expr->ts.deferred && expr->ts.u.cl->backend_decl
8759 217 : && VAR_P (expr->ts.u.cl->backend_decl))
8760 156 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, tmp);
8761 : else
8762 11344 : expr->ts.u.cl->backend_decl = tmp;
8763 : }
8764 :
8765 : /* If we have an array section, are assigning or passing an array
8766 : section argument make sure that the lower bound is 1. References
8767 : to the full array should otherwise keep the original bounds. */
8768 64386 : if (!info->ref || info->ref->u.ar.type != AR_FULL)
8769 82941 : for (dim = 0; dim < loop.dimen; dim++)
8770 50490 : if (!integer_onep (loop.from[dim]))
8771 : {
8772 27134 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
8773 : gfc_array_index_type, gfc_index_one_node,
8774 : loop.from[dim]);
8775 27134 : loop.to[dim] = fold_build2_loc (input_location, PLUS_EXPR,
8776 : gfc_array_index_type,
8777 : loop.to[dim], tmp);
8778 27134 : loop.from[dim] = gfc_index_one_node;
8779 : }
8780 :
8781 64386 : desc = info->descriptor;
8782 64386 : if (se->direct_byref && !se->byref_noassign)
8783 : {
8784 : /* For pointer assignments we fill in the destination. */
8785 2658 : parm = se->expr;
8786 2658 : parmtype = TREE_TYPE (parm);
8787 : }
8788 : else
8789 : {
8790 : /* Otherwise make a new one. */
8791 61728 : if (expr->ts.type == BT_CHARACTER)
8792 10848 : parmtype = gfc_typenode_for_spec (&expr->ts);
8793 : else
8794 50880 : parmtype = gfc_get_element_type (TREE_TYPE (desc));
8795 :
8796 61728 : parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, codim,
8797 : loop.from, loop.to, 0,
8798 : GFC_ARRAY_UNKNOWN, false);
8799 61728 : parm = gfc_create_var (parmtype, "parm");
8800 :
8801 : /* When expression is a class object, then add the class' handle to
8802 : the parm_decl. */
8803 61728 : if (expr->ts.type == BT_CLASS && expr->expr_type == EXPR_VARIABLE)
8804 : {
8805 1172 : gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr);
8806 1172 : gfc_se classse;
8807 :
8808 : /* class_expr can be NULL, when no _class ref is in expr.
8809 : We must not fix this here with a gfc_fix_class_ref (). */
8810 1172 : if (class_expr)
8811 : {
8812 1162 : gfc_init_se (&classse, NULL);
8813 1162 : gfc_conv_expr (&classse, class_expr);
8814 1162 : gfc_free_expr (class_expr);
8815 :
8816 1162 : gcc_assert (classse.pre.head == NULL_TREE
8817 : && classse.post.head == NULL_TREE);
8818 1162 : gfc_allocate_lang_decl (parm);
8819 1162 : GFC_DECL_SAVED_DESCRIPTOR (parm) = classse.expr;
8820 : }
8821 : }
8822 : }
8823 :
8824 64386 : if (expr->ts.type == BT_CHARACTER
8825 64386 : && VAR_P (TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (parm)))))
8826 : {
8827 0 : tree elem_len = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (parm)));
8828 0 : gfc_add_modify (&loop.pre, elem_len,
8829 0 : fold_convert (TREE_TYPE (elem_len),
8830 : gfc_get_array_span (desc, expr)));
8831 : }
8832 :
8833 : /* Set the span field. */
8834 64386 : tmp = NULL_TREE;
8835 64386 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
8836 7657 : tmp = gfc_conv_descriptor_span_get (desc);
8837 : else
8838 56729 : tmp = gfc_get_array_span (desc, expr);
8839 64386 : if (tmp)
8840 64306 : gfc_conv_descriptor_span_set (&loop.pre, parm, tmp);
8841 :
8842 : /* The following can be somewhat confusing. We have two
8843 : descriptors, a new one and the original array.
8844 : {parm, parmtype, dim} refer to the new one.
8845 : {desc, type, n, loop} refer to the original, which maybe
8846 : a descriptorless array.
8847 : The bounds of the scalarization are the bounds of the section.
8848 : We don't have to worry about numeric overflows when calculating
8849 : the offsets because all elements are within the array data. */
8850 :
8851 : /* Set the dtype. */
8852 64386 : tmp = gfc_conv_descriptor_dtype (parm);
8853 64386 : if (se->unlimited_polymorphic)
8854 613 : dtype = gfc_get_dtype (TREE_TYPE (desc), &loop.dimen);
8855 63773 : else if (expr->ts.type == BT_ASSUMED)
8856 : {
8857 127 : tree tmp2 = desc;
8858 127 : if (DECL_LANG_SPECIFIC (tmp2) && GFC_DECL_SAVED_DESCRIPTOR (tmp2))
8859 127 : tmp2 = GFC_DECL_SAVED_DESCRIPTOR (tmp2);
8860 127 : if (POINTER_TYPE_P (TREE_TYPE (tmp2)))
8861 127 : tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
8862 127 : dtype = gfc_conv_descriptor_dtype (tmp2);
8863 : }
8864 : else
8865 63646 : dtype = gfc_get_dtype (parmtype);
8866 64386 : gfc_add_modify (&loop.pre, tmp, dtype);
8867 :
8868 : /* The 1st element in the section. */
8869 64386 : base = gfc_index_zero_node;
8870 64386 : if (expr->ts.type == BT_CHARACTER && expr->rank == 0 && codim)
8871 6 : base = gfc_index_one_node;
8872 :
8873 : /* The offset from the 1st element in the section. */
8874 : offset = gfc_index_zero_node;
8875 :
8876 165584 : for (n = 0; n < ndim; n++)
8877 : {
8878 101198 : stride = gfc_conv_array_stride (desc, n);
8879 :
8880 : /* Work out the 1st element in the section. */
8881 101198 : if (info->ref
8882 93846 : && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
8883 : {
8884 1208 : gcc_assert (info->subscript[n]
8885 : && info->subscript[n]->info->type == GFC_SS_SCALAR);
8886 1208 : start = info->subscript[n]->info->data.scalar.value;
8887 : }
8888 : else
8889 : {
8890 : /* Evaluate and remember the start of the section. */
8891 99990 : start = info->start[n];
8892 99990 : stride = gfc_evaluate_now (stride, &loop.pre);
8893 : }
8894 :
8895 101198 : tmp = gfc_conv_array_lbound (desc, n);
8896 101198 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
8897 : start, tmp);
8898 101198 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
8899 : tmp, stride);
8900 101198 : base = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
8901 : base, tmp);
8902 :
8903 101198 : if (info->ref
8904 93846 : && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
8905 : {
8906 : /* For elemental dimensions, we only need the 1st
8907 : element in the section. */
8908 1208 : continue;
8909 : }
8910 :
8911 : /* Vector subscripts need copying and are handled elsewhere. */
8912 99990 : if (info->ref)
8913 92638 : gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
8914 :
8915 : /* look for the corresponding scalarizer dimension: dim. */
8916 150478 : for (dim = 0; dim < ndim; dim++)
8917 150478 : if (ss->dim[dim] == n)
8918 : break;
8919 :
8920 : /* loop exited early: the DIM being looked for has been found. */
8921 99990 : gcc_assert (dim < ndim);
8922 :
8923 : /* Set the new lower bound. */
8924 99990 : from = loop.from[dim];
8925 99990 : to = loop.to[dim];
8926 :
8927 99990 : gfc_conv_descriptor_lbound_set (&loop.pre, parm,
8928 : gfc_rank_cst[dim], from);
8929 :
8930 : /* Set the new upper bound. */
8931 99990 : gfc_conv_descriptor_ubound_set (&loop.pre, parm,
8932 : gfc_rank_cst[dim], to);
8933 :
8934 : /* Multiply the stride by the section stride to get the
8935 : total stride. */
8936 99990 : stride = fold_build2_loc (input_location, MULT_EXPR,
8937 : gfc_array_index_type,
8938 : stride, info->stride[n]);
8939 :
8940 99990 : tmp = fold_build2_loc (input_location, MULT_EXPR,
8941 99990 : TREE_TYPE (offset), stride, from);
8942 99990 : offset = fold_build2_loc (input_location, MINUS_EXPR,
8943 99990 : TREE_TYPE (offset), offset, tmp);
8944 :
8945 : /* Store the new stride. */
8946 99990 : gfc_conv_descriptor_stride_set (&loop.pre, parm,
8947 : gfc_rank_cst[dim], stride);
8948 : }
8949 :
8950 : /* For deferred-length character we need to take the dynamic length
8951 : into account for the dataptr offset. */
8952 64386 : if (expr->ts.type == BT_CHARACTER
8953 11500 : && expr->ts.deferred
8954 223 : && expr->ts.u.cl->backend_decl
8955 223 : && VAR_P (expr->ts.u.cl->backend_decl))
8956 : {
8957 156 : tree base_type = TREE_TYPE (base);
8958 156 : base = fold_build2_loc (input_location, MULT_EXPR, base_type, base,
8959 : fold_convert (base_type,
8960 : expr->ts.u.cl->backend_decl));
8961 : }
8962 :
8963 65898 : for (n = loop.dimen; n < loop.dimen + codim; n++)
8964 : {
8965 1512 : from = loop.from[n];
8966 1512 : to = loop.to[n];
8967 1512 : gfc_conv_descriptor_lbound_set (&loop.pre, parm,
8968 : gfc_rank_cst[n], from);
8969 1512 : if (n < loop.dimen + codim - 1)
8970 818 : gfc_conv_descriptor_ubound_set (&loop.pre, parm,
8971 : gfc_rank_cst[n], to);
8972 : }
8973 :
8974 64386 : if (se->data_not_needed)
8975 6044 : gfc_conv_descriptor_data_set (&loop.pre, parm,
8976 : gfc_index_zero_node);
8977 : else
8978 : /* Point the data pointer at the 1st element in the section. */
8979 58342 : gfc_get_dataptr_offset (&loop.pre, parm, desc, base,
8980 : subref_array_target, expr);
8981 :
8982 64386 : gfc_conv_descriptor_offset_set (&loop.pre, parm, offset);
8983 :
8984 64386 : if (flag_coarray == GFC_FCOARRAY_LIB && expr->corank)
8985 : {
8986 404 : tmp = INDIRECT_REF_P (desc) ? TREE_OPERAND (desc, 0) : desc;
8987 404 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
8988 : {
8989 24 : tmp = gfc_conv_descriptor_token (tmp);
8990 : }
8991 380 : else if (DECL_P (tmp) && DECL_LANG_SPECIFIC (tmp)
8992 460 : && GFC_DECL_TOKEN (tmp) != NULL_TREE)
8993 64 : tmp = GFC_DECL_TOKEN (tmp);
8994 : else
8995 : {
8996 316 : tmp = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (tmp));
8997 : }
8998 :
8999 404 : gfc_add_modify (&loop.pre, gfc_conv_descriptor_token (parm), tmp);
9000 : }
9001 : desc = parm;
9002 : }
9003 :
9004 : /* For class arrays add the class tree into the saved descriptor to
9005 : enable getting of _vptr and the like. */
9006 73243 : if (expr->expr_type == EXPR_VARIABLE && VAR_P (desc)
9007 56782 : && IS_CLASS_ARRAY (expr->symtree->n.sym))
9008 : {
9009 1144 : gfc_allocate_lang_decl (desc);
9010 1144 : GFC_DECL_SAVED_DESCRIPTOR (desc) =
9011 1144 : DECL_LANG_SPECIFIC (expr->symtree->n.sym->backend_decl) ?
9012 1058 : GFC_DECL_SAVED_DESCRIPTOR (expr->symtree->n.sym->backend_decl)
9013 : : expr->symtree->n.sym->backend_decl;
9014 : }
9015 72099 : else if (expr->expr_type == EXPR_ARRAY && VAR_P (desc)
9016 10135 : && IS_CLASS_ARRAY (expr))
9017 : {
9018 12 : tree vtype;
9019 12 : gfc_allocate_lang_decl (desc);
9020 12 : tmp = gfc_create_var (expr->ts.u.derived->backend_decl, "class");
9021 12 : GFC_DECL_SAVED_DESCRIPTOR (desc) = tmp;
9022 12 : vtype = gfc_class_vptr_get (tmp);
9023 12 : gfc_add_modify (&se->pre, vtype,
9024 12 : gfc_build_addr_expr (TREE_TYPE (vtype),
9025 12 : gfc_find_vtab (&expr->ts)->backend_decl));
9026 : }
9027 73243 : if (!se->direct_byref || se->byref_noassign)
9028 : {
9029 : /* Get a pointer to the new descriptor. */
9030 70585 : if (se->want_pointer)
9031 39859 : se->expr = gfc_build_addr_expr (NULL_TREE, desc);
9032 : else
9033 30726 : se->expr = desc;
9034 : }
9035 :
9036 73243 : gfc_add_block_to_block (&se->pre, &loop.pre);
9037 73243 : gfc_add_block_to_block (&se->post, &loop.post);
9038 :
9039 : /* Cleanup the scalarizer. */
9040 73243 : gfc_cleanup_loop (&loop);
9041 : }
9042 :
9043 :
9044 : /* Calculate the array size (number of elements); if dim != NULL_TREE,
9045 : return size for that dim (dim=0..rank-1; only for GFC_DESCRIPTOR_TYPE_P).
9046 : If !expr && descriptor array, the rank is taken from the descriptor. */
9047 : tree
9048 15202 : gfc_tree_array_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree dim)
9049 : {
9050 15202 : if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
9051 : {
9052 34 : gcc_assert (dim == NULL_TREE);
9053 34 : return GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
9054 : }
9055 15168 : tree size, tmp, rank = NULL_TREE, cond = NULL_TREE;
9056 15168 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
9057 15168 : enum gfc_array_kind akind = GFC_TYPE_ARRAY_AKIND (TREE_TYPE (desc));
9058 15168 : if (expr == NULL || expr->rank < 0)
9059 3390 : rank = fold_convert (signed_char_type_node,
9060 : gfc_conv_descriptor_rank (desc));
9061 : else
9062 11778 : rank = build_int_cst (signed_char_type_node, expr->rank);
9063 :
9064 15168 : if (dim || (expr && expr->rank == 1))
9065 : {
9066 4515 : if (!dim)
9067 4515 : dim = gfc_index_zero_node;
9068 13512 : tree ubound = gfc_conv_descriptor_ubound_get (desc, dim);
9069 13512 : tree lbound = gfc_conv_descriptor_lbound_get (desc, dim);
9070 :
9071 13512 : size = fold_build2_loc (input_location, MINUS_EXPR,
9072 : gfc_array_index_type, ubound, lbound);
9073 13512 : size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
9074 : size, gfc_index_one_node);
9075 : /* if (!allocatable && !pointer && assumed rank)
9076 : size = (idx == rank && ubound[rank-1] == -1 ? -1 : size;
9077 : else
9078 : size = max (0, size); */
9079 13512 : size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
9080 : size, gfc_index_zero_node);
9081 13512 : if (akind == GFC_ARRAY_ASSUMED_RANK_CONT
9082 13512 : || akind == GFC_ARRAY_ASSUMED_RANK)
9083 : {
9084 2703 : tmp = fold_build2_loc (input_location, MINUS_EXPR, signed_char_type_node,
9085 : rank, build_int_cst (signed_char_type_node, 1));
9086 2703 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
9087 : fold_convert (signed_char_type_node, dim),
9088 : tmp);
9089 2703 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
9090 : gfc_conv_descriptor_ubound_get (desc, dim),
9091 : build_int_cst (gfc_array_index_type, -1));
9092 2703 : cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
9093 : cond, tmp);
9094 2703 : tmp = build_int_cst (gfc_array_index_type, -1);
9095 2703 : size = build3_loc (input_location, COND_EXPR, gfc_array_index_type,
9096 : cond, tmp, size);
9097 : }
9098 13512 : return size;
9099 : }
9100 :
9101 : /* size = 1. */
9102 1656 : size = gfc_create_var (gfc_array_index_type, "size");
9103 1656 : gfc_add_modify (block, size, build_int_cst (TREE_TYPE (size), 1));
9104 1656 : tree extent = gfc_create_var (gfc_array_index_type, "extent");
9105 :
9106 1656 : stmtblock_t cond_block, loop_body;
9107 1656 : gfc_init_block (&cond_block);
9108 1656 : gfc_init_block (&loop_body);
9109 :
9110 : /* Loop: for (i = 0; i < rank; ++i). */
9111 1656 : tree idx = gfc_create_var (signed_char_type_node, "idx");
9112 : /* Loop body. */
9113 : /* #if (assumed-rank + !allocatable && !pointer)
9114 : if (idx == rank - 1 && dim[idx].ubound == -1)
9115 : extent = -1;
9116 : else
9117 : #endif
9118 : extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1
9119 : if (extent < 0)
9120 : extent = 0
9121 : size *= extent. */
9122 1656 : cond = NULL_TREE;
9123 1656 : if (akind == GFC_ARRAY_ASSUMED_RANK_CONT || akind == GFC_ARRAY_ASSUMED_RANK)
9124 : {
9125 459 : tmp = fold_build2_loc (input_location, MINUS_EXPR, signed_char_type_node,
9126 : rank, build_int_cst (signed_char_type_node, 1));
9127 459 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
9128 : idx, tmp);
9129 459 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
9130 : gfc_conv_descriptor_ubound_get (desc, idx),
9131 : build_int_cst (gfc_array_index_type, -1));
9132 459 : cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
9133 : cond, tmp);
9134 : }
9135 1656 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
9136 : gfc_conv_descriptor_ubound_get (desc, idx),
9137 : gfc_conv_descriptor_lbound_get (desc, idx));
9138 1656 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
9139 : tmp, gfc_index_one_node);
9140 1656 : gfc_add_modify (&cond_block, extent, tmp);
9141 1656 : tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
9142 : extent, gfc_index_zero_node);
9143 1656 : tmp = build3_v (COND_EXPR, tmp,
9144 : fold_build2_loc (input_location, MODIFY_EXPR,
9145 : gfc_array_index_type,
9146 : extent, gfc_index_zero_node),
9147 : build_empty_stmt (input_location));
9148 1656 : gfc_add_expr_to_block (&cond_block, tmp);
9149 1656 : tmp = gfc_finish_block (&cond_block);
9150 1656 : if (cond)
9151 459 : tmp = build3_v (COND_EXPR, cond,
9152 : fold_build2_loc (input_location, MODIFY_EXPR,
9153 : gfc_array_index_type, extent,
9154 : build_int_cst (gfc_array_index_type, -1)),
9155 : tmp);
9156 1656 : gfc_add_expr_to_block (&loop_body, tmp);
9157 : /* size *= extent. */
9158 1656 : gfc_add_modify (&loop_body, size,
9159 : fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9160 : size, extent));
9161 : /* Generate loop. */
9162 3312 : gfc_simple_for_loop (block, idx, build_int_cst (TREE_TYPE (idx), 0), rank, LT_EXPR,
9163 1656 : build_int_cst (TREE_TYPE (idx), 1),
9164 : gfc_finish_block (&loop_body));
9165 1656 : return size;
9166 : }
9167 :
9168 : /* Helper function for gfc_conv_array_parameter if array size needs to be
9169 : computed. */
9170 :
9171 : static void
9172 112 : array_parameter_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree *size)
9173 : {
9174 112 : tree elem;
9175 112 : *size = gfc_tree_array_size (block, desc, expr, NULL);
9176 112 : elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
9177 112 : *size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9178 : *size, fold_convert (gfc_array_index_type, elem));
9179 112 : }
9180 :
9181 : /* Helper function - return true if the argument is a pointer. */
9182 :
9183 : static bool
9184 737 : is_pointer (gfc_expr *e)
9185 : {
9186 737 : gfc_symbol *sym;
9187 :
9188 737 : if (e->expr_type != EXPR_VARIABLE || e->symtree == NULL)
9189 : return false;
9190 :
9191 737 : sym = e->symtree->n.sym;
9192 737 : if (sym == NULL)
9193 : return false;
9194 :
9195 737 : return sym->attr.pointer || sym->attr.proc_pointer;
9196 : }
9197 :
9198 : /* Convert an array for passing as an actual parameter. */
9199 :
9200 : void
9201 65406 : gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr, bool g77,
9202 : const gfc_symbol *fsym, const char *proc_name,
9203 : tree *size, tree *lbshift, tree *packed)
9204 : {
9205 65406 : tree ptr;
9206 65406 : tree desc;
9207 65406 : tree tmp = NULL_TREE;
9208 65406 : tree stmt;
9209 65406 : tree parent = DECL_CONTEXT (current_function_decl);
9210 65406 : tree ctree;
9211 65406 : tree pack_attr = NULL_TREE; /* Set when packing class arrays. */
9212 65406 : bool full_array_var;
9213 65406 : bool this_array_result;
9214 65406 : bool contiguous;
9215 65406 : bool no_pack;
9216 65406 : bool array_constructor;
9217 65406 : bool good_allocatable;
9218 65406 : bool ultimate_ptr_comp;
9219 65406 : bool ultimate_alloc_comp;
9220 65406 : bool readonly;
9221 65406 : gfc_symbol *sym;
9222 65406 : stmtblock_t block;
9223 65406 : gfc_ref *ref;
9224 :
9225 65406 : ultimate_ptr_comp = false;
9226 65406 : ultimate_alloc_comp = false;
9227 :
9228 66118 : for (ref = expr->ref; ref; ref = ref->next)
9229 : {
9230 54724 : if (ref->next == NULL)
9231 : break;
9232 :
9233 712 : if (ref->type == REF_COMPONENT)
9234 : {
9235 634 : ultimate_ptr_comp = ref->u.c.component->attr.pointer;
9236 634 : ultimate_alloc_comp = ref->u.c.component->attr.allocatable;
9237 : }
9238 : }
9239 :
9240 65406 : full_array_var = false;
9241 65406 : contiguous = false;
9242 :
9243 65406 : if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp)
9244 53920 : full_array_var = gfc_full_array_ref_p (ref, &contiguous);
9245 :
9246 53920 : sym = full_array_var ? expr->symtree->n.sym : NULL;
9247 :
9248 : /* The symbol should have an array specification. */
9249 62517 : gcc_assert (!sym || sym->as || ref->u.ar.as);
9250 :
9251 65406 : if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
9252 : {
9253 690 : get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
9254 690 : expr->ts.u.cl->backend_decl = tmp;
9255 690 : se->string_length = tmp;
9256 : }
9257 :
9258 : /* Is this the result of the enclosing procedure? */
9259 65406 : this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
9260 58 : if (this_array_result
9261 58 : && (sym->backend_decl != current_function_decl)
9262 0 : && (sym->backend_decl != parent))
9263 65406 : this_array_result = false;
9264 :
9265 : /* Passing an optional dummy argument as actual to an optional dummy? */
9266 65406 : bool pass_optional;
9267 65406 : pass_optional = fsym && fsym->attr.optional && sym && sym->attr.optional;
9268 :
9269 : /* Passing address of the array if it is not pointer or assumed-shape. */
9270 65406 : if (full_array_var && g77 && !this_array_result
9271 15887 : && sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
9272 : {
9273 12489 : tmp = gfc_get_symbol_decl (sym);
9274 :
9275 12489 : if (sym->ts.type == BT_CHARACTER)
9276 2773 : se->string_length = sym->ts.u.cl->backend_decl;
9277 :
9278 12489 : if (!sym->attr.pointer
9279 11984 : && sym->as
9280 11984 : && sym->as->type != AS_ASSUMED_SHAPE
9281 11739 : && sym->as->type != AS_DEFERRED
9282 10245 : && sym->as->type != AS_ASSUMED_RANK
9283 10169 : && !sym->attr.allocatable)
9284 : {
9285 : /* Some variables are declared directly, others are declared as
9286 : pointers and allocated on the heap. */
9287 9663 : if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
9288 2501 : se->expr = tmp;
9289 : else
9290 7162 : se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
9291 9663 : if (size)
9292 34 : array_parameter_size (&se->pre, tmp, expr, size);
9293 16757 : return;
9294 : }
9295 :
9296 2826 : if (sym->attr.allocatable)
9297 : {
9298 1880 : if (sym->attr.dummy || sym->attr.result)
9299 : {
9300 1176 : gfc_conv_expr_descriptor (se, expr);
9301 1176 : tmp = se->expr;
9302 : }
9303 1880 : if (size)
9304 14 : array_parameter_size (&se->pre, tmp, expr, size);
9305 1880 : se->expr = gfc_conv_array_data (tmp);
9306 1880 : if (pass_optional)
9307 : {
9308 18 : tree cond = gfc_conv_expr_present (sym);
9309 36 : se->expr = build3_loc (input_location, COND_EXPR,
9310 18 : TREE_TYPE (se->expr), cond, se->expr,
9311 18 : fold_convert (TREE_TYPE (se->expr),
9312 : null_pointer_node));
9313 : }
9314 1880 : return;
9315 : }
9316 : }
9317 :
9318 : /* A convenient reduction in scope. */
9319 53863 : contiguous = g77 && !this_array_result && contiguous;
9320 :
9321 : /* There is no need to pack and unpack the array, if it is contiguous
9322 : and not a deferred- or assumed-shape array, or if it is simply
9323 : contiguous. */
9324 53863 : no_pack = false;
9325 : // clang-format off
9326 53863 : if (sym)
9327 : {
9328 39578 : symbol_attribute *attr = &(IS_CLASS_ARRAY (sym)
9329 : ? CLASS_DATA (sym)->attr : sym->attr);
9330 39578 : gfc_array_spec *as = IS_CLASS_ARRAY (sym)
9331 39578 : ? CLASS_DATA (sym)->as : sym->as;
9332 39578 : no_pack = (as
9333 39306 : && !attr->pointer
9334 36033 : && as->type != AS_DEFERRED
9335 26445 : && as->type != AS_ASSUMED_RANK
9336 63067 : && as->type != AS_ASSUMED_SHAPE);
9337 : }
9338 53863 : if (ref && ref->u.ar.as)
9339 42467 : no_pack = no_pack
9340 42467 : || (ref->u.ar.as->type != AS_DEFERRED
9341 : && ref->u.ar.as->type != AS_ASSUMED_RANK
9342 : && ref->u.ar.as->type != AS_ASSUMED_SHAPE);
9343 107726 : no_pack = contiguous
9344 53863 : && (no_pack || gfc_is_simply_contiguous (expr, false, true));
9345 : // clang-format on
9346 :
9347 : /* If we have an EXPR_OP or a function returning an explicit-shaped
9348 : or allocatable array, an array temporary will be generated which
9349 : does not need to be packed / unpacked if passed to an
9350 : explicit-shape dummy array. */
9351 :
9352 53863 : if (g77)
9353 : {
9354 6279 : if (expr->expr_type == EXPR_OP)
9355 : no_pack = 1;
9356 6202 : else if (expr->expr_type == EXPR_FUNCTION && expr->value.function.esym)
9357 : {
9358 41 : gfc_symbol *result = expr->value.function.esym->result;
9359 41 : if (result->attr.dimension
9360 41 : && (result->as->type == AS_EXPLICIT
9361 14 : || result->attr.allocatable
9362 7 : || result->attr.contiguous))
9363 112 : no_pack = 1;
9364 : }
9365 : }
9366 :
9367 : /* Array constructors are always contiguous and do not need packing. */
9368 53863 : array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY;
9369 :
9370 : /* Same is true of contiguous sections from allocatable variables. */
9371 107726 : good_allocatable = contiguous
9372 4461 : && expr->symtree
9373 58324 : && expr->symtree->n.sym->attr.allocatable;
9374 :
9375 : /* Or ultimate allocatable components. */
9376 53863 : ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
9377 :
9378 53863 : if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp)
9379 : {
9380 4824 : gfc_conv_expr_descriptor (se, expr);
9381 : /* Deallocate the allocatable components of structures that are
9382 : not variable. */
9383 4824 : if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
9384 3313 : && expr->ts.u.derived->attr.alloc_comp
9385 1952 : && expr->expr_type != EXPR_VARIABLE)
9386 : {
9387 2 : tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, se->expr, expr->rank);
9388 :
9389 : /* The components shall be deallocated before their containing entity. */
9390 2 : gfc_prepend_expr_to_block (&se->post, tmp);
9391 : }
9392 4824 : if (expr->ts.type == BT_CHARACTER && expr->expr_type != EXPR_FUNCTION)
9393 279 : se->string_length = expr->ts.u.cl->backend_decl;
9394 4824 : if (size)
9395 34 : array_parameter_size (&se->pre, se->expr, expr, size);
9396 4824 : se->expr = gfc_conv_array_data (se->expr);
9397 4824 : return;
9398 : }
9399 :
9400 49039 : if (fsym && fsym->ts.type == BT_CLASS)
9401 : {
9402 1212 : gcc_assert (se->expr);
9403 : ctree = se->expr;
9404 : }
9405 : else
9406 : ctree = NULL_TREE;
9407 :
9408 49039 : if (this_array_result)
9409 : {
9410 : /* Result of the enclosing function. */
9411 58 : gfc_conv_expr_descriptor (se, expr);
9412 58 : if (size)
9413 0 : array_parameter_size (&se->pre, se->expr, expr, size);
9414 58 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
9415 :
9416 18 : if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
9417 76 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
9418 18 : se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location,
9419 : se->expr));
9420 :
9421 58 : return;
9422 : }
9423 : else
9424 : {
9425 : /* Every other type of array. */
9426 48981 : se->want_pointer = (ctree) ? 0 : 1;
9427 48981 : se->want_coarray = expr->corank;
9428 48981 : gfc_conv_expr_descriptor (se, expr);
9429 :
9430 48981 : if (size)
9431 30 : array_parameter_size (&se->pre,
9432 : build_fold_indirect_ref_loc (input_location,
9433 : se->expr),
9434 : expr, size);
9435 48981 : if (ctree)
9436 : {
9437 1212 : stmtblock_t block;
9438 :
9439 1212 : gfc_init_block (&block);
9440 1212 : if (lbshift && *lbshift)
9441 : {
9442 : /* Apply a shift of the lbound when supplied. */
9443 98 : for (int dim = 0; dim < expr->rank; ++dim)
9444 49 : gfc_conv_shift_descriptor_lbound (&block, se->expr, dim,
9445 : *lbshift);
9446 : }
9447 1212 : tmp = gfc_class_data_get (ctree);
9448 1212 : if (expr->rank > 1 && CLASS_DATA (fsym)->as->rank != expr->rank
9449 84 : && CLASS_DATA (fsym)->as->type == AS_EXPLICIT && !no_pack)
9450 : {
9451 36 : tree arr = gfc_create_var (TREE_TYPE (tmp), "parm");
9452 36 : gfc_conv_descriptor_data_set (&block, arr,
9453 : gfc_conv_descriptor_data_get (
9454 : se->expr));
9455 36 : gfc_conv_descriptor_lbound_set (&block, arr, gfc_index_zero_node,
9456 : gfc_index_zero_node);
9457 36 : gfc_conv_descriptor_ubound_set (
9458 : &block, arr, gfc_index_zero_node,
9459 : gfc_conv_descriptor_size (se->expr, expr->rank));
9460 36 : gfc_conv_descriptor_stride_set (
9461 : &block, arr, gfc_index_zero_node,
9462 : gfc_conv_descriptor_stride_get (se->expr, gfc_index_zero_node));
9463 36 : gfc_add_modify (&block, gfc_conv_descriptor_dtype (arr),
9464 : gfc_conv_descriptor_dtype (se->expr));
9465 36 : gfc_add_modify (&block, gfc_conv_descriptor_rank (arr),
9466 : build_int_cst (signed_char_type_node, 1));
9467 36 : gfc_conv_descriptor_span_set (&block, arr,
9468 : gfc_conv_descriptor_span_get (arr));
9469 36 : gfc_conv_descriptor_offset_set (&block, arr, gfc_index_zero_node);
9470 36 : se->expr = arr;
9471 : }
9472 1212 : gfc_class_array_data_assign (&block, tmp, se->expr, true);
9473 :
9474 : /* Handle optional. */
9475 1212 : if (fsym && fsym->attr.optional && sym && sym->attr.optional)
9476 348 : tmp = build3_v (COND_EXPR, gfc_conv_expr_present (sym),
9477 : gfc_finish_block (&block),
9478 : build_empty_stmt (input_location));
9479 : else
9480 864 : tmp = gfc_finish_block (&block);
9481 :
9482 1212 : gfc_add_expr_to_block (&se->pre, tmp);
9483 : }
9484 47769 : else if (pass_optional && full_array_var && sym->as && sym->as->rank != 0)
9485 : {
9486 : /* Perform calculation of bounds and strides of optional array dummy
9487 : only if the argument is present. */
9488 219 : tmp = build3_v (COND_EXPR, gfc_conv_expr_present (sym),
9489 : gfc_finish_block (&se->pre),
9490 : build_empty_stmt (input_location));
9491 219 : gfc_add_expr_to_block (&se->pre, tmp);
9492 : }
9493 : }
9494 :
9495 : /* Deallocate the allocatable components of structures that are
9496 : not variable, for descriptorless arguments.
9497 : Arguments with a descriptor are handled in gfc_conv_procedure_call. */
9498 48981 : if (g77 && (expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
9499 75 : && expr->ts.u.derived->attr.alloc_comp
9500 21 : && expr->expr_type != EXPR_VARIABLE)
9501 : {
9502 0 : tmp = build_fold_indirect_ref_loc (input_location, se->expr);
9503 0 : tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank);
9504 :
9505 : /* The components shall be deallocated before their containing entity. */
9506 0 : gfc_prepend_expr_to_block (&se->post, tmp);
9507 : }
9508 :
9509 47544 : if (g77 || (fsym && fsym->attr.contiguous
9510 1530 : && !gfc_is_simply_contiguous (expr, false, true)))
9511 : {
9512 1581 : tree origptr = NULL_TREE, packedptr = NULL_TREE;
9513 :
9514 1581 : desc = se->expr;
9515 :
9516 : /* For contiguous arrays, save the original value of the descriptor. */
9517 1581 : if (!g77 && !ctree)
9518 : {
9519 48 : origptr = gfc_create_var (pvoid_type_node, "origptr");
9520 48 : tmp = build_fold_indirect_ref_loc (input_location, desc);
9521 48 : tmp = gfc_conv_array_data (tmp);
9522 96 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
9523 48 : TREE_TYPE (origptr), origptr,
9524 48 : fold_convert (TREE_TYPE (origptr), tmp));
9525 48 : gfc_add_expr_to_block (&se->pre, tmp);
9526 : }
9527 :
9528 : /* Repack the array. */
9529 1581 : if (warn_array_temporaries)
9530 : {
9531 28 : if (fsym)
9532 18 : gfc_warning (OPT_Warray_temporaries,
9533 : "Creating array temporary at %L for argument %qs",
9534 18 : &expr->where, fsym->name);
9535 : else
9536 10 : gfc_warning (OPT_Warray_temporaries,
9537 : "Creating array temporary at %L", &expr->where);
9538 : }
9539 :
9540 : /* When optimizing, we can use gfc_conv_subref_array_arg for
9541 : making the packing and unpacking operation visible to the
9542 : optimizers. */
9543 :
9544 1437 : if (g77 && flag_inline_arg_packing && expr->expr_type == EXPR_VARIABLE
9545 737 : && !is_pointer (expr) && ! gfc_has_dimen_vector_ref (expr)
9546 353 : && !(expr->symtree->n.sym->as
9547 324 : && expr->symtree->n.sym->as->type == AS_ASSUMED_RANK)
9548 1934 : && (fsym == NULL || fsym->ts.type != BT_ASSUMED))
9549 : {
9550 332 : gfc_conv_subref_array_arg (se, expr, g77,
9551 141 : fsym ? fsym->attr.intent : INTENT_INOUT,
9552 : false, fsym, proc_name, sym, true);
9553 332 : return;
9554 : }
9555 :
9556 1249 : if (ctree)
9557 : {
9558 96 : packedptr
9559 96 : = gfc_build_addr_expr (NULL_TREE, gfc_create_var (TREE_TYPE (ctree),
9560 : "packed"));
9561 96 : if (fsym)
9562 : {
9563 96 : int pack_mask = 0;
9564 :
9565 : /* Set bit 0 to the mask, when this is an unlimited_poly
9566 : class. */
9567 96 : if (CLASS_DATA (fsym)->ts.u.derived->attr.unlimited_polymorphic)
9568 36 : pack_mask = 1 << 0;
9569 96 : pack_attr = build_int_cst (integer_type_node, pack_mask);
9570 : }
9571 : else
9572 0 : pack_attr = integer_zero_node;
9573 :
9574 96 : gfc_add_expr_to_block (
9575 : &se->pre,
9576 : build_call_expr_loc (input_location, gfor_fndecl_in_pack_class, 4,
9577 : packedptr,
9578 : gfc_build_addr_expr (NULL_TREE, ctree),
9579 96 : size_in_bytes (TREE_TYPE (ctree)), pack_attr));
9580 96 : ptr = gfc_conv_array_data (gfc_class_data_get (packedptr));
9581 96 : se->expr = packedptr;
9582 96 : if (packed)
9583 96 : *packed = packedptr;
9584 : }
9585 : else
9586 : {
9587 1153 : ptr = build_call_expr_loc (input_location, gfor_fndecl_in_pack, 1,
9588 : desc);
9589 :
9590 1153 : if (fsym && fsym->attr.optional && sym && sym->attr.optional)
9591 : {
9592 11 : tmp = gfc_conv_expr_present (sym);
9593 22 : ptr = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
9594 11 : tmp, fold_convert (TREE_TYPE (se->expr), ptr),
9595 11 : fold_convert (TREE_TYPE (se->expr),
9596 : null_pointer_node));
9597 : }
9598 :
9599 1153 : ptr = gfc_evaluate_now (ptr, &se->pre);
9600 : }
9601 :
9602 : /* Use the packed data for the actual argument, except for contiguous arrays,
9603 : where the descriptor's data component is set. */
9604 1249 : if (g77)
9605 1105 : se->expr = ptr;
9606 : else
9607 : {
9608 144 : tmp = build_fold_indirect_ref_loc (input_location, desc);
9609 :
9610 144 : gfc_ss * ss = gfc_walk_expr (expr);
9611 288 : if (!transposed_dims (ss))
9612 : {
9613 138 : if (!ctree)
9614 48 : gfc_conv_descriptor_data_set (&se->pre, tmp, ptr);
9615 : }
9616 6 : else if (!ctree)
9617 : {
9618 0 : tree old_field, new_field;
9619 :
9620 : /* The original descriptor has transposed dims so we can't reuse
9621 : it directly; we have to create a new one. */
9622 0 : tree old_desc = tmp;
9623 0 : tree new_desc = gfc_create_var (TREE_TYPE (old_desc), "arg_desc");
9624 :
9625 0 : old_field = gfc_conv_descriptor_dtype (old_desc);
9626 0 : new_field = gfc_conv_descriptor_dtype (new_desc);
9627 0 : gfc_add_modify (&se->pre, new_field, old_field);
9628 :
9629 0 : old_field = gfc_conv_descriptor_offset_get (old_desc);
9630 0 : gfc_conv_descriptor_offset_set (&se->pre, new_desc, old_field);
9631 :
9632 0 : for (int i = 0; i < expr->rank; i++)
9633 : {
9634 0 : old_field = gfc_conv_descriptor_dimension (old_desc,
9635 0 : gfc_rank_cst[get_array_ref_dim_for_loop_dim (ss, i)]);
9636 0 : new_field = gfc_conv_descriptor_dimension (new_desc,
9637 : gfc_rank_cst[i]);
9638 0 : gfc_add_modify (&se->pre, new_field, old_field);
9639 : }
9640 :
9641 0 : if (flag_coarray == GFC_FCOARRAY_LIB
9642 0 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (old_desc))
9643 0 : && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (old_desc))
9644 : == GFC_ARRAY_ALLOCATABLE)
9645 : {
9646 0 : old_field = gfc_conv_descriptor_token (old_desc);
9647 0 : new_field = gfc_conv_descriptor_token (new_desc);
9648 0 : gfc_add_modify (&se->pre, new_field, old_field);
9649 : }
9650 :
9651 0 : gfc_conv_descriptor_data_set (&se->pre, new_desc, ptr);
9652 0 : se->expr = gfc_build_addr_expr (NULL_TREE, new_desc);
9653 : }
9654 144 : gfc_free_ss (ss);
9655 : }
9656 :
9657 1249 : if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
9658 : {
9659 8 : char * msg;
9660 :
9661 8 : if (fsym && proc_name)
9662 8 : msg = xasprintf ("An array temporary was created for argument "
9663 8 : "'%s' of procedure '%s'", fsym->name, proc_name);
9664 : else
9665 0 : msg = xasprintf ("An array temporary was created");
9666 :
9667 8 : tmp = build_fold_indirect_ref_loc (input_location,
9668 : desc);
9669 8 : tmp = gfc_conv_array_data (tmp);
9670 8 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9671 8 : fold_convert (TREE_TYPE (tmp), ptr), tmp);
9672 :
9673 8 : if (pass_optional)
9674 6 : tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
9675 : logical_type_node,
9676 : gfc_conv_expr_present (sym), tmp);
9677 :
9678 8 : gfc_trans_runtime_check (false, true, tmp, &se->pre,
9679 : &expr->where, msg);
9680 8 : free (msg);
9681 : }
9682 :
9683 1249 : gfc_start_block (&block);
9684 :
9685 : /* Copy the data back. If input expr is read-only, e.g. a PARAMETER
9686 : array, copying back modified values is undefined behavior. */
9687 2498 : readonly = (expr->expr_type == EXPR_VARIABLE
9688 856 : && expr->symtree
9689 2105 : && expr->symtree->n.sym->attr.flavor == FL_PARAMETER);
9690 :
9691 1249 : if ((fsym == NULL || fsym->attr.intent != INTENT_IN) && !readonly)
9692 : {
9693 1116 : if (ctree)
9694 : {
9695 66 : tmp = gfc_build_addr_expr (NULL_TREE, ctree);
9696 66 : tmp = build_call_expr_loc (input_location,
9697 : gfor_fndecl_in_unpack_class, 4, tmp,
9698 : packedptr,
9699 66 : size_in_bytes (TREE_TYPE (ctree)),
9700 : pack_attr);
9701 : }
9702 : else
9703 1050 : tmp = build_call_expr_loc (input_location, gfor_fndecl_in_unpack, 2,
9704 : desc, ptr);
9705 1116 : gfc_add_expr_to_block (&block, tmp);
9706 : }
9707 133 : else if (ctree && fsym->attr.intent == INTENT_IN)
9708 : {
9709 : /* Need to free the memory for class arrays, that got packed. */
9710 30 : gfc_add_expr_to_block (&block, gfc_call_free (ptr));
9711 : }
9712 :
9713 : /* Free the temporary. */
9714 1146 : if (!ctree)
9715 1153 : gfc_add_expr_to_block (&block, gfc_call_free (ptr));
9716 :
9717 1249 : stmt = gfc_finish_block (&block);
9718 :
9719 1249 : gfc_init_block (&block);
9720 : /* Only if it was repacked. This code needs to be executed before the
9721 : loop cleanup code. */
9722 1249 : tmp = (ctree) ? desc : build_fold_indirect_ref_loc (input_location, desc);
9723 1249 : tmp = gfc_conv_array_data (tmp);
9724 1249 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9725 1249 : fold_convert (TREE_TYPE (tmp), ptr), tmp);
9726 :
9727 1249 : if (pass_optional)
9728 11 : tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
9729 : logical_type_node,
9730 : gfc_conv_expr_present (sym), tmp);
9731 :
9732 1249 : tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
9733 :
9734 1249 : gfc_add_expr_to_block (&block, tmp);
9735 1249 : gfc_add_block_to_block (&block, &se->post);
9736 :
9737 1249 : gfc_init_block (&se->post);
9738 :
9739 : /* Reset the descriptor pointer. */
9740 1249 : if (!g77 && !ctree)
9741 : {
9742 48 : tmp = build_fold_indirect_ref_loc (input_location, desc);
9743 48 : gfc_conv_descriptor_data_set (&se->post, tmp, origptr);
9744 : }
9745 :
9746 1249 : gfc_add_block_to_block (&se->post, &block);
9747 : }
9748 : }
9749 :
9750 :
9751 : /* This helper function calculates the size in words of a full array. */
9752 :
9753 : tree
9754 19853 : gfc_full_array_size (stmtblock_t *block, tree decl, int rank)
9755 : {
9756 19853 : tree idx;
9757 19853 : tree nelems;
9758 19853 : tree tmp;
9759 19853 : if (rank < 0)
9760 0 : idx = gfc_conv_descriptor_rank (decl);
9761 : else
9762 19853 : idx = gfc_rank_cst[rank - 1];
9763 19853 : nelems = gfc_conv_descriptor_ubound_get (decl, idx);
9764 19853 : tmp = gfc_conv_descriptor_lbound_get (decl, idx);
9765 19853 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
9766 : nelems, tmp);
9767 19853 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
9768 : tmp, gfc_index_one_node);
9769 19853 : tmp = gfc_evaluate_now (tmp, block);
9770 :
9771 19853 : nelems = gfc_conv_descriptor_stride_get (decl, idx);
9772 19853 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9773 : nelems, tmp);
9774 19853 : return gfc_evaluate_now (tmp, block);
9775 : }
9776 :
9777 :
9778 : /* Allocate dest to the same size as src, and copy src -> dest.
9779 : If no_malloc is set, only the copy is done. */
9780 :
9781 : static tree
9782 9563 : duplicate_allocatable (tree dest, tree src, tree type, int rank,
9783 : bool no_malloc, bool no_memcpy, tree str_sz,
9784 : tree add_when_allocated)
9785 : {
9786 9563 : tree tmp;
9787 9563 : tree eltype;
9788 9563 : tree size;
9789 9563 : tree nelems;
9790 9563 : tree null_cond;
9791 9563 : tree null_data;
9792 9563 : stmtblock_t block;
9793 :
9794 : /* If the source is null, set the destination to null. Then,
9795 : allocate memory to the destination. */
9796 9563 : gfc_init_block (&block);
9797 :
9798 9563 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
9799 : {
9800 2187 : gfc_add_modify (&block, dest, fold_convert (type, null_pointer_node));
9801 2187 : null_data = gfc_finish_block (&block);
9802 :
9803 2187 : gfc_init_block (&block);
9804 2187 : eltype = TREE_TYPE (type);
9805 2187 : if (str_sz != NULL_TREE)
9806 : size = str_sz;
9807 : else
9808 1844 : size = TYPE_SIZE_UNIT (eltype);
9809 :
9810 2187 : if (!no_malloc)
9811 : {
9812 2187 : tmp = gfc_call_malloc (&block, type, size);
9813 2187 : gfc_add_modify (&block, dest, fold_convert (type, tmp));
9814 : }
9815 :
9816 2187 : if (!no_memcpy)
9817 : {
9818 1762 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
9819 1762 : tmp = build_call_expr_loc (input_location, tmp, 3, dest, src,
9820 : fold_convert (size_type_node, size));
9821 1762 : gfc_add_expr_to_block (&block, tmp);
9822 : }
9823 : }
9824 : else
9825 : {
9826 7376 : gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
9827 7376 : null_data = gfc_finish_block (&block);
9828 :
9829 7376 : gfc_init_block (&block);
9830 7376 : if (rank)
9831 7361 : nelems = gfc_full_array_size (&block, src, rank);
9832 : else
9833 15 : nelems = gfc_index_one_node;
9834 :
9835 : /* If type is not the array type, then it is the element type. */
9836 7376 : if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type))
9837 7346 : eltype = gfc_get_element_type (type);
9838 : else
9839 : eltype = type;
9840 :
9841 7376 : if (str_sz != NULL_TREE)
9842 43 : tmp = fold_convert (gfc_array_index_type, str_sz);
9843 : else
9844 7333 : tmp = fold_convert (gfc_array_index_type,
9845 : TYPE_SIZE_UNIT (eltype));
9846 :
9847 7376 : tmp = gfc_evaluate_now (tmp, &block);
9848 7376 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9849 : nelems, tmp);
9850 7376 : if (!no_malloc)
9851 : {
9852 7320 : tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src));
9853 7320 : tmp = gfc_call_malloc (&block, tmp, size);
9854 7320 : gfc_conv_descriptor_data_set (&block, dest, tmp);
9855 : }
9856 :
9857 : /* We know the temporary and the value will be the same length,
9858 : so can use memcpy. */
9859 7376 : if (!no_memcpy)
9860 : {
9861 6016 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
9862 6016 : tmp = build_call_expr_loc (input_location, tmp, 3,
9863 : gfc_conv_descriptor_data_get (dest),
9864 : gfc_conv_descriptor_data_get (src),
9865 : fold_convert (size_type_node, size));
9866 6016 : gfc_add_expr_to_block (&block, tmp);
9867 : }
9868 : }
9869 :
9870 9563 : gfc_add_expr_to_block (&block, add_when_allocated);
9871 9563 : tmp = gfc_finish_block (&block);
9872 :
9873 : /* Null the destination if the source is null; otherwise do
9874 : the allocate and copy. */
9875 9563 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src)))
9876 : null_cond = src;
9877 : else
9878 7376 : null_cond = gfc_conv_descriptor_data_get (src);
9879 :
9880 9563 : null_cond = convert (pvoid_type_node, null_cond);
9881 9563 : null_cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9882 : null_cond, null_pointer_node);
9883 9563 : return build3_v (COND_EXPR, null_cond, tmp, null_data);
9884 : }
9885 :
9886 :
9887 : /* Allocate dest to the same size as src, and copy data src -> dest. */
9888 :
9889 : tree
9890 7179 : gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank,
9891 : tree add_when_allocated)
9892 : {
9893 7179 : return duplicate_allocatable (dest, src, type, rank, false, false,
9894 7179 : NULL_TREE, add_when_allocated);
9895 : }
9896 :
9897 :
9898 : /* Copy data src -> dest. */
9899 :
9900 : tree
9901 56 : gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
9902 : {
9903 56 : return duplicate_allocatable (dest, src, type, rank, true, false,
9904 56 : NULL_TREE, NULL_TREE);
9905 : }
9906 :
9907 : /* Allocate dest to the same size as src, but don't copy anything. */
9908 :
9909 : tree
9910 1785 : gfc_duplicate_allocatable_nocopy (tree dest, tree src, tree type, int rank)
9911 : {
9912 1785 : return duplicate_allocatable (dest, src, type, rank, false, true,
9913 1785 : NULL_TREE, NULL_TREE);
9914 : }
9915 :
9916 : static tree
9917 62 : duplicate_allocatable_coarray (tree dest, tree dest_tok, tree src, tree type,
9918 : int rank, tree add_when_allocated)
9919 : {
9920 62 : tree tmp;
9921 62 : tree size;
9922 62 : tree nelems;
9923 62 : tree null_cond;
9924 62 : tree null_data;
9925 62 : stmtblock_t block, globalblock;
9926 :
9927 : /* If the source is null, set the destination to null. Then,
9928 : allocate memory to the destination. */
9929 62 : gfc_init_block (&block);
9930 62 : gfc_init_block (&globalblock);
9931 :
9932 62 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
9933 : {
9934 18 : gfc_se se;
9935 18 : symbol_attribute attr;
9936 18 : tree dummy_desc;
9937 :
9938 18 : gfc_init_se (&se, NULL);
9939 18 : gfc_clear_attr (&attr);
9940 18 : attr.allocatable = 1;
9941 18 : dummy_desc = gfc_conv_scalar_to_descriptor (&se, dest, attr);
9942 18 : gfc_add_block_to_block (&globalblock, &se.pre);
9943 18 : size = TYPE_SIZE_UNIT (TREE_TYPE (type));
9944 :
9945 18 : gfc_add_modify (&block, dest, fold_convert (type, null_pointer_node));
9946 18 : gfc_allocate_using_caf_lib (&block, dummy_desc, size,
9947 : gfc_build_addr_expr (NULL_TREE, dest_tok),
9948 : NULL_TREE, NULL_TREE, NULL_TREE,
9949 : GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
9950 18 : gfc_add_modify (&block, dest, gfc_conv_descriptor_data_get (dummy_desc));
9951 18 : null_data = gfc_finish_block (&block);
9952 :
9953 18 : gfc_init_block (&block);
9954 :
9955 18 : gfc_allocate_using_caf_lib (&block, dummy_desc,
9956 : fold_convert (size_type_node, size),
9957 : gfc_build_addr_expr (NULL_TREE, dest_tok),
9958 : NULL_TREE, NULL_TREE, NULL_TREE,
9959 : GFC_CAF_COARRAY_ALLOC);
9960 18 : gfc_add_modify (&block, dest, gfc_conv_descriptor_data_get (dummy_desc));
9961 :
9962 18 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
9963 18 : tmp = build_call_expr_loc (input_location, tmp, 3, dest, src,
9964 : fold_convert (size_type_node, size));
9965 18 : gfc_add_expr_to_block (&block, tmp);
9966 : }
9967 : else
9968 : {
9969 : /* Set the rank or unitialized memory access may be reported. */
9970 44 : tmp = gfc_conv_descriptor_rank (dest);
9971 44 : gfc_add_modify (&globalblock, tmp, build_int_cst (TREE_TYPE (tmp), rank));
9972 :
9973 44 : if (rank)
9974 44 : nelems = gfc_full_array_size (&globalblock, src, rank);
9975 : else
9976 0 : nelems = integer_one_node;
9977 :
9978 44 : tmp = fold_convert (size_type_node,
9979 : TYPE_SIZE_UNIT (gfc_get_element_type (type)));
9980 44 : size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
9981 : fold_convert (size_type_node, nelems), tmp);
9982 :
9983 44 : gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
9984 44 : gfc_allocate_using_caf_lib (&block, dest, fold_convert (size_type_node,
9985 : size),
9986 : gfc_build_addr_expr (NULL_TREE, dest_tok),
9987 : NULL_TREE, NULL_TREE, NULL_TREE,
9988 : GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
9989 44 : null_data = gfc_finish_block (&block);
9990 :
9991 44 : gfc_init_block (&block);
9992 44 : gfc_allocate_using_caf_lib (&block, dest,
9993 : fold_convert (size_type_node, size),
9994 : gfc_build_addr_expr (NULL_TREE, dest_tok),
9995 : NULL_TREE, NULL_TREE, NULL_TREE,
9996 : GFC_CAF_COARRAY_ALLOC);
9997 :
9998 44 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
9999 44 : tmp = build_call_expr_loc (input_location, tmp, 3,
10000 : gfc_conv_descriptor_data_get (dest),
10001 : gfc_conv_descriptor_data_get (src),
10002 : fold_convert (size_type_node, size));
10003 44 : gfc_add_expr_to_block (&block, tmp);
10004 : }
10005 62 : gfc_add_expr_to_block (&block, add_when_allocated);
10006 62 : tmp = gfc_finish_block (&block);
10007 :
10008 : /* Null the destination if the source is null; otherwise do
10009 : the register and copy. */
10010 62 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src)))
10011 : null_cond = src;
10012 : else
10013 44 : null_cond = gfc_conv_descriptor_data_get (src);
10014 :
10015 62 : null_cond = convert (pvoid_type_node, null_cond);
10016 62 : null_cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10017 : null_cond, null_pointer_node);
10018 62 : gfc_add_expr_to_block (&globalblock, build3_v (COND_EXPR, null_cond, tmp,
10019 : null_data));
10020 62 : return gfc_finish_block (&globalblock);
10021 : }
10022 :
10023 :
10024 : /* Helper function to abstract whether coarray processing is enabled. */
10025 :
10026 : static bool
10027 75 : caf_enabled (int caf_mode)
10028 : {
10029 75 : return (caf_mode & GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY)
10030 75 : == GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY;
10031 : }
10032 :
10033 :
10034 : /* Helper function to abstract whether coarray processing is enabled
10035 : and we are in a derived type coarray. */
10036 :
10037 : static bool
10038 10681 : caf_in_coarray (int caf_mode)
10039 : {
10040 10681 : static const int pat = GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
10041 : | GFC_STRUCTURE_CAF_MODE_IN_COARRAY;
10042 10681 : return (caf_mode & pat) == pat;
10043 : }
10044 :
10045 :
10046 : /* Helper function to abstract whether coarray is to deallocate only. */
10047 :
10048 : bool
10049 352 : gfc_caf_is_dealloc_only (int caf_mode)
10050 : {
10051 352 : return (caf_mode & GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY)
10052 352 : == GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY;
10053 : }
10054 :
10055 :
10056 : /* Recursively traverse an object of derived type, generating code to
10057 : deallocate, nullify or copy allocatable components. This is the work horse
10058 : function for the functions named in this enum. */
10059 :
10060 : enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP,
10061 : COPY_ALLOC_COMP, COPY_ONLY_ALLOC_COMP, REASSIGN_CAF_COMP,
10062 : ALLOCATE_PDT_COMP, DEALLOCATE_PDT_COMP, CHECK_PDT_DUMMY,
10063 : BCAST_ALLOC_COMP};
10064 :
10065 : static gfc_actual_arglist *pdt_param_list;
10066 : static bool generating_copy_helper;
10067 : static hash_set<gfc_symbol *> seen_derived_types;
10068 :
10069 : /* Forward declaration of structure_alloc_comps for wrapper generator. */
10070 : static tree structure_alloc_comps (gfc_symbol *, tree, tree, int, int, int,
10071 : gfc_co_subroutines_args *, bool);
10072 :
10073 : /* Generate a wrapper function that performs element-wise deep copy for
10074 : recursive allocatable array components. This wrapper is passed as a
10075 : function pointer to the runtime helper _gfortran_cfi_deep_copy_array,
10076 : allowing recursion to happen at runtime instead of compile time. */
10077 :
10078 : static tree
10079 256 : get_copy_helper_function_type (void)
10080 : {
10081 256 : static tree fn_type = NULL_TREE;
10082 256 : if (fn_type == NULL_TREE)
10083 29 : fn_type = build_function_type_list (void_type_node,
10084 : pvoid_type_node,
10085 : pvoid_type_node,
10086 : NULL_TREE);
10087 256 : return fn_type;
10088 : }
10089 :
10090 : static tree
10091 1157 : get_copy_helper_pointer_type (void)
10092 : {
10093 1157 : static tree ptr_type = NULL_TREE;
10094 1157 : if (ptr_type == NULL_TREE)
10095 29 : ptr_type = build_pointer_type (get_copy_helper_function_type ());
10096 1157 : return ptr_type;
10097 : }
10098 :
10099 : static tree
10100 227 : generate_element_copy_wrapper (gfc_symbol *der_type, tree comp_type,
10101 : int purpose, int caf_mode)
10102 : {
10103 227 : tree fndecl, fntype, result_decl;
10104 227 : tree dest_parm, src_parm, dest_typed, src_typed;
10105 227 : tree der_type_ptr;
10106 227 : stmtblock_t block;
10107 227 : tree decls;
10108 227 : tree body;
10109 :
10110 227 : fntype = get_copy_helper_function_type ();
10111 :
10112 227 : fndecl = build_decl (input_location, FUNCTION_DECL,
10113 : create_tmp_var_name ("copy_element"),
10114 : fntype);
10115 :
10116 227 : TREE_STATIC (fndecl) = 1;
10117 227 : TREE_USED (fndecl) = 1;
10118 227 : DECL_ARTIFICIAL (fndecl) = 1;
10119 227 : DECL_IGNORED_P (fndecl) = 0;
10120 227 : TREE_PUBLIC (fndecl) = 0;
10121 227 : DECL_UNINLINABLE (fndecl) = 1;
10122 227 : DECL_EXTERNAL (fndecl) = 0;
10123 227 : DECL_CONTEXT (fndecl) = NULL_TREE;
10124 227 : DECL_INITIAL (fndecl) = make_node (BLOCK);
10125 227 : BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
10126 :
10127 227 : result_decl = build_decl (input_location, RESULT_DECL, NULL_TREE,
10128 : void_type_node);
10129 227 : DECL_ARTIFICIAL (result_decl) = 1;
10130 227 : DECL_IGNORED_P (result_decl) = 1;
10131 227 : DECL_CONTEXT (result_decl) = fndecl;
10132 227 : DECL_RESULT (fndecl) = result_decl;
10133 :
10134 227 : dest_parm = build_decl (input_location, PARM_DECL,
10135 : get_identifier ("dest"), pvoid_type_node);
10136 227 : src_parm = build_decl (input_location, PARM_DECL,
10137 : get_identifier ("src"), pvoid_type_node);
10138 :
10139 227 : DECL_ARTIFICIAL (dest_parm) = 1;
10140 227 : DECL_ARTIFICIAL (src_parm) = 1;
10141 227 : DECL_ARG_TYPE (dest_parm) = pvoid_type_node;
10142 227 : DECL_ARG_TYPE (src_parm) = pvoid_type_node;
10143 227 : DECL_CONTEXT (dest_parm) = fndecl;
10144 227 : DECL_CONTEXT (src_parm) = fndecl;
10145 :
10146 227 : DECL_ARGUMENTS (fndecl) = dest_parm;
10147 227 : TREE_CHAIN (dest_parm) = src_parm;
10148 :
10149 227 : push_struct_function (fndecl);
10150 227 : cfun->function_end_locus = input_location;
10151 :
10152 227 : pushlevel ();
10153 227 : gfc_init_block (&block);
10154 :
10155 227 : bool saved_generating = generating_copy_helper;
10156 227 : generating_copy_helper = true;
10157 :
10158 : /* When generating a wrapper, we need a fresh type tracking state to
10159 : avoid inheriting the parent context's seen_derived_types, which would
10160 : cause infinite recursion when the wrapper tries to handle the same
10161 : recursive type. Save elements, clear the set, generate wrapper, then
10162 : restore elements. */
10163 227 : vec<gfc_symbol *> saved_symbols = vNULL;
10164 227 : for (hash_set<gfc_symbol *>::iterator it = seen_derived_types.begin ();
10165 973 : it != seen_derived_types.end (); ++it)
10166 373 : saved_symbols.safe_push (*it);
10167 227 : seen_derived_types.empty ();
10168 :
10169 227 : der_type_ptr = build_pointer_type (comp_type);
10170 227 : dest_typed = fold_convert (der_type_ptr, dest_parm);
10171 227 : src_typed = fold_convert (der_type_ptr, src_parm);
10172 :
10173 227 : dest_typed = build_fold_indirect_ref (dest_typed);
10174 227 : src_typed = build_fold_indirect_ref (src_typed);
10175 :
10176 227 : body = structure_alloc_comps (der_type, src_typed, dest_typed,
10177 : 0, purpose, caf_mode, NULL, false);
10178 227 : gfc_add_expr_to_block (&block, body);
10179 :
10180 : /* Restore saved symbols. */
10181 227 : seen_derived_types.empty ();
10182 600 : for (unsigned i = 0; i < saved_symbols.length (); i++)
10183 373 : seen_derived_types.add (saved_symbols[i]);
10184 227 : saved_symbols.release ();
10185 227 : generating_copy_helper = saved_generating;
10186 :
10187 227 : body = gfc_finish_block (&block);
10188 227 : decls = getdecls ();
10189 :
10190 227 : poplevel (1, 1);
10191 :
10192 454 : DECL_SAVED_TREE (fndecl)
10193 227 : = fold_build3_loc (DECL_SOURCE_LOCATION (fndecl), BIND_EXPR,
10194 227 : void_type_node, decls, body, DECL_INITIAL (fndecl));
10195 :
10196 227 : pop_cfun ();
10197 :
10198 : /* Use finalize_function with no_collect=true to skip the ggc_collect
10199 : call that add_new_function would trigger. This function is called
10200 : during tree lowering of structure_alloc_comps where caller stack
10201 : frames hold locally-computed tree nodes (COMPONENT_REFs etc.) that
10202 : are not yet attached to any GC root. A collection at this point
10203 : would free those nodes and cause segfaults. PR124235. */
10204 227 : cgraph_node::finalize_function (fndecl, true);
10205 :
10206 227 : return build1 (ADDR_EXPR, get_copy_helper_pointer_type (), fndecl);
10207 : }
10208 :
10209 : static tree
10210 21339 : structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
10211 : int rank, int purpose, int caf_mode,
10212 : gfc_co_subroutines_args *args,
10213 : bool no_finalization = false)
10214 : {
10215 21339 : gfc_component *c;
10216 21339 : gfc_loopinfo loop;
10217 21339 : stmtblock_t fnblock;
10218 21339 : stmtblock_t loopbody;
10219 21339 : stmtblock_t tmpblock;
10220 21339 : tree decl_type;
10221 21339 : tree tmp;
10222 21339 : tree comp;
10223 21339 : tree dcmp;
10224 21339 : tree nelems;
10225 21339 : tree index;
10226 21339 : tree var;
10227 21339 : tree cdecl;
10228 21339 : tree ctype;
10229 21339 : tree vref, dref;
10230 21339 : tree null_cond = NULL_TREE;
10231 21339 : tree add_when_allocated;
10232 21339 : tree dealloc_fndecl;
10233 21339 : tree caf_token;
10234 21339 : gfc_symbol *vtab;
10235 21339 : int caf_dereg_mode;
10236 21339 : symbol_attribute *attr;
10237 21339 : bool deallocate_called;
10238 :
10239 21339 : gfc_init_block (&fnblock);
10240 :
10241 21339 : decl_type = TREE_TYPE (decl);
10242 :
10243 21339 : if ((POINTER_TYPE_P (decl_type))
10244 : || (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == 0))
10245 : {
10246 1494 : decl = build_fold_indirect_ref_loc (input_location, decl);
10247 : /* Deref dest in sync with decl, but only when it is not NULL. */
10248 1494 : if (dest)
10249 110 : dest = build_fold_indirect_ref_loc (input_location, dest);
10250 :
10251 : /* Update the decl_type because it got dereferenced. */
10252 1494 : decl_type = TREE_TYPE (decl);
10253 : }
10254 :
10255 : /* If this is an array of derived types with allocatable components
10256 : build a loop and recursively call this function. */
10257 21339 : if (TREE_CODE (decl_type) == ARRAY_TYPE
10258 21339 : || (GFC_DESCRIPTOR_TYPE_P (decl_type) && rank != 0))
10259 : {
10260 3844 : tmp = gfc_conv_array_data (decl);
10261 3844 : var = build_fold_indirect_ref_loc (input_location, tmp);
10262 :
10263 : /* Get the number of elements - 1 and set the counter. */
10264 3844 : if (GFC_DESCRIPTOR_TYPE_P (decl_type))
10265 : {
10266 : /* Use the descriptor for an allocatable array. Since this
10267 : is a full array reference, we only need the descriptor
10268 : information from dimension = rank. */
10269 2622 : tmp = gfc_full_array_size (&fnblock, decl, rank);
10270 2622 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
10271 : gfc_array_index_type, tmp,
10272 : gfc_index_one_node);
10273 :
10274 2622 : null_cond = gfc_conv_descriptor_data_get (decl);
10275 2622 : null_cond = fold_build2_loc (input_location, NE_EXPR,
10276 : logical_type_node, null_cond,
10277 2622 : build_int_cst (TREE_TYPE (null_cond), 0));
10278 : }
10279 : else
10280 : {
10281 : /* Otherwise use the TYPE_DOMAIN information. */
10282 1222 : tmp = array_type_nelts_minus_one (decl_type);
10283 1222 : tmp = fold_convert (gfc_array_index_type, tmp);
10284 : }
10285 :
10286 : /* Remember that this is, in fact, the no. of elements - 1. */
10287 3844 : nelems = gfc_evaluate_now (tmp, &fnblock);
10288 3844 : index = gfc_create_var (gfc_array_index_type, "S");
10289 :
10290 : /* Build the body of the loop. */
10291 3844 : gfc_init_block (&loopbody);
10292 :
10293 3844 : vref = gfc_build_array_ref (var, index, NULL);
10294 :
10295 3844 : if (purpose == COPY_ALLOC_COMP || purpose == COPY_ONLY_ALLOC_COMP)
10296 : {
10297 963 : tmp = build_fold_indirect_ref_loc (input_location,
10298 : gfc_conv_array_data (dest));
10299 963 : dref = gfc_build_array_ref (tmp, index, NULL);
10300 963 : tmp = structure_alloc_comps (der_type, vref, dref, rank,
10301 : COPY_ALLOC_COMP, caf_mode, args,
10302 : no_finalization);
10303 : }
10304 : else
10305 2881 : tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose,
10306 : caf_mode, args, no_finalization);
10307 :
10308 3844 : gfc_add_expr_to_block (&loopbody, tmp);
10309 :
10310 : /* Build the loop and return. */
10311 3844 : gfc_init_loopinfo (&loop);
10312 3844 : loop.dimen = 1;
10313 3844 : loop.from[0] = gfc_index_zero_node;
10314 3844 : loop.loopvar[0] = index;
10315 3844 : loop.to[0] = nelems;
10316 3844 : gfc_trans_scalarizing_loops (&loop, &loopbody);
10317 3844 : gfc_add_block_to_block (&fnblock, &loop.pre);
10318 :
10319 3844 : tmp = gfc_finish_block (&fnblock);
10320 : /* When copying allocateable components, the above implements the
10321 : deep copy. Nevertheless is a deep copy only allowed, when the current
10322 : component is allocated, for which code will be generated in
10323 : gfc_duplicate_allocatable (), where the deep copy code is just added
10324 : into the if's body, by adding tmp (the deep copy code) as last
10325 : argument to gfc_duplicate_allocatable (). */
10326 3844 : if (purpose == COPY_ALLOC_COMP && caf_mode == 0
10327 3844 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
10328 710 : tmp = gfc_duplicate_allocatable (dest, decl, decl_type, rank,
10329 : tmp);
10330 3134 : else if (null_cond != NULL_TREE)
10331 1912 : tmp = build3_v (COND_EXPR, null_cond, tmp,
10332 : build_empty_stmt (input_location));
10333 :
10334 3844 : return tmp;
10335 : }
10336 :
10337 17495 : if (purpose == DEALLOCATE_ALLOC_COMP && der_type->attr.pdt_type)
10338 : {
10339 295 : tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
10340 : DEALLOCATE_PDT_COMP, 0, args,
10341 : no_finalization);
10342 295 : gfc_add_expr_to_block (&fnblock, tmp);
10343 : }
10344 17200 : else if (purpose == ALLOCATE_PDT_COMP && der_type->attr.alloc_comp)
10345 : {
10346 119 : tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
10347 : NULLIFY_ALLOC_COMP, 0, args,
10348 : no_finalization);
10349 119 : gfc_add_expr_to_block (&fnblock, tmp);
10350 : }
10351 :
10352 : /* Still having a descriptor array of rank == 0 here, indicates an
10353 : allocatable coarrays. Dereference it correctly. */
10354 17495 : if (GFC_DESCRIPTOR_TYPE_P (decl_type))
10355 : {
10356 12 : decl = build_fold_indirect_ref (gfc_conv_array_data (decl));
10357 : }
10358 : /* Otherwise, act on the components or recursively call self to
10359 : act on a chain of components. */
10360 17495 : seen_derived_types.add (der_type);
10361 50780 : for (c = der_type->components; c; c = c->next)
10362 : {
10363 33285 : bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED
10364 33285 : || c->ts.type == BT_CLASS)
10365 33285 : && c->ts.u.derived->attr.alloc_comp;
10366 33285 : bool same_type
10367 : = (c->ts.type == BT_DERIVED
10368 8218 : && seen_derived_types.contains (c->ts.u.derived))
10369 38852 : || (c->ts.type == BT_CLASS
10370 2236 : && seen_derived_types.contains (CLASS_DATA (c)->ts.u.derived));
10371 33285 : bool inside_wrapper = generating_copy_helper;
10372 :
10373 33285 : bool is_pdt_type = IS_PDT (c);
10374 :
10375 33285 : cdecl = c->backend_decl;
10376 33285 : ctype = TREE_TYPE (cdecl);
10377 :
10378 33285 : switch (purpose)
10379 : {
10380 :
10381 3 : case BCAST_ALLOC_COMP:
10382 :
10383 3 : tree ubound;
10384 3 : tree cdesc;
10385 3 : stmtblock_t derived_type_block;
10386 :
10387 3 : gfc_init_block (&tmpblock);
10388 :
10389 3 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10390 : decl, cdecl, NULL_TREE);
10391 :
10392 : /* Shortcut to get the attributes of the component. */
10393 3 : if (c->ts.type == BT_CLASS)
10394 : {
10395 0 : attr = &CLASS_DATA (c)->attr;
10396 0 : if (attr->class_pointer)
10397 0 : continue;
10398 : }
10399 : else
10400 : {
10401 3 : attr = &c->attr;
10402 3 : if (attr->pointer)
10403 0 : continue;
10404 : }
10405 :
10406 : /* Do not broadcast a caf_token. These are local to the image. */
10407 3 : if (attr->caf_token)
10408 1 : continue;
10409 :
10410 2 : add_when_allocated = NULL_TREE;
10411 2 : if (cmp_has_alloc_comps
10412 0 : && !c->attr.pointer && !c->attr.proc_pointer)
10413 : {
10414 0 : if (c->ts.type == BT_CLASS)
10415 : {
10416 0 : rank = CLASS_DATA (c)->as ? CLASS_DATA (c)->as->rank : 0;
10417 0 : add_when_allocated
10418 0 : = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
10419 : comp, NULL_TREE, rank, purpose,
10420 : caf_mode, args, no_finalization);
10421 : }
10422 : else
10423 : {
10424 0 : rank = c->as ? c->as->rank : 0;
10425 0 : add_when_allocated = structure_alloc_comps (c->ts.u.derived,
10426 : comp, NULL_TREE,
10427 : rank, purpose,
10428 : caf_mode, args,
10429 : no_finalization);
10430 : }
10431 : }
10432 :
10433 2 : gfc_init_block (&derived_type_block);
10434 2 : if (add_when_allocated)
10435 0 : gfc_add_expr_to_block (&derived_type_block, add_when_allocated);
10436 2 : tmp = gfc_finish_block (&derived_type_block);
10437 2 : gfc_add_expr_to_block (&tmpblock, tmp);
10438 :
10439 : /* Convert the component into a rank 1 descriptor type. */
10440 2 : if (attr->dimension)
10441 : {
10442 0 : tmp = gfc_get_element_type (TREE_TYPE (comp));
10443 0 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
10444 0 : ubound = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (comp));
10445 : else
10446 0 : ubound = gfc_full_array_size (&tmpblock, comp,
10447 0 : c->ts.type == BT_CLASS
10448 0 : ? CLASS_DATA (c)->as->rank
10449 0 : : c->as->rank);
10450 : }
10451 : else
10452 : {
10453 2 : tmp = TREE_TYPE (comp);
10454 2 : ubound = build_int_cst (gfc_array_index_type, 1);
10455 : }
10456 :
10457 : /* Treat strings like arrays. Or the other way around, do not
10458 : * generate an additional array layer for scalar components. */
10459 2 : if (attr->dimension || c->ts.type == BT_CHARACTER)
10460 : {
10461 0 : cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node,
10462 : &ubound, 1,
10463 : GFC_ARRAY_ALLOCATABLE, false);
10464 :
10465 0 : cdesc = gfc_create_var (cdesc, "cdesc");
10466 0 : DECL_ARTIFICIAL (cdesc) = 1;
10467 :
10468 0 : gfc_add_modify (&tmpblock, gfc_conv_descriptor_dtype (cdesc),
10469 : gfc_get_dtype_rank_type (1, tmp));
10470 0 : gfc_conv_descriptor_lbound_set (&tmpblock, cdesc,
10471 : gfc_index_zero_node,
10472 : gfc_index_one_node);
10473 0 : gfc_conv_descriptor_stride_set (&tmpblock, cdesc,
10474 : gfc_index_zero_node,
10475 : gfc_index_one_node);
10476 0 : gfc_conv_descriptor_ubound_set (&tmpblock, cdesc,
10477 : gfc_index_zero_node, ubound);
10478 : }
10479 : else
10480 : /* Prevent warning. */
10481 : cdesc = NULL_TREE;
10482 :
10483 2 : if (attr->dimension)
10484 : {
10485 0 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
10486 0 : comp = gfc_conv_descriptor_data_get (comp);
10487 : else
10488 0 : comp = gfc_build_addr_expr (NULL_TREE, comp);
10489 : }
10490 : else
10491 : {
10492 2 : gfc_se se;
10493 :
10494 2 : gfc_init_se (&se, NULL);
10495 :
10496 2 : comp = gfc_conv_scalar_to_descriptor (&se, comp,
10497 2 : c->ts.type == BT_CLASS
10498 2 : ? CLASS_DATA (c)->attr
10499 : : c->attr);
10500 2 : if (c->ts.type == BT_CHARACTER)
10501 0 : comp = gfc_build_addr_expr (NULL_TREE, comp);
10502 2 : gfc_add_block_to_block (&tmpblock, &se.pre);
10503 : }
10504 :
10505 2 : if (attr->dimension || c->ts.type == BT_CHARACTER)
10506 0 : gfc_conv_descriptor_data_set (&tmpblock, cdesc, comp);
10507 : else
10508 2 : cdesc = comp;
10509 :
10510 2 : tree fndecl;
10511 :
10512 2 : fndecl = build_call_expr_loc (input_location,
10513 : gfor_fndecl_co_broadcast, 5,
10514 : gfc_build_addr_expr (pvoid_type_node,cdesc),
10515 : args->image_index,
10516 : null_pointer_node, null_pointer_node,
10517 : null_pointer_node);
10518 :
10519 2 : gfc_add_expr_to_block (&tmpblock, fndecl);
10520 2 : gfc_add_block_to_block (&fnblock, &tmpblock);
10521 :
10522 27277 : break;
10523 :
10524 12112 : case DEALLOCATE_ALLOC_COMP:
10525 :
10526 12112 : gfc_init_block (&tmpblock);
10527 :
10528 12112 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10529 : decl, cdecl, NULL_TREE);
10530 :
10531 : /* Shortcut to get the attributes of the component. */
10532 12112 : if (c->ts.type == BT_CLASS)
10533 : {
10534 1002 : attr = &CLASS_DATA (c)->attr;
10535 1002 : if (attr->class_pointer || c->attr.proc_pointer)
10536 18 : continue;
10537 : }
10538 : else
10539 : {
10540 11110 : attr = &c->attr;
10541 11110 : if (attr->pointer || attr->proc_pointer)
10542 130 : continue;
10543 : }
10544 :
10545 11964 : if (!no_finalization && ((c->ts.type == BT_DERIVED && !c->attr.pointer)
10546 8339 : || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer)))
10547 : /* Call the finalizer, which will free the memory and nullify the
10548 : pointer of an array. */
10549 3549 : deallocate_called = gfc_add_comp_finalizer_call (&tmpblock, comp, c,
10550 3549 : caf_enabled (caf_mode))
10551 3549 : && attr->dimension;
10552 : else
10553 : deallocate_called = false;
10554 :
10555 : /* Add the _class ref for classes. */
10556 11964 : if (c->ts.type == BT_CLASS && attr->allocatable)
10557 984 : comp = gfc_class_data_get (comp);
10558 :
10559 11964 : add_when_allocated = NULL_TREE;
10560 11964 : if (cmp_has_alloc_comps
10561 2842 : && !c->attr.pointer && !c->attr.proc_pointer
10562 : && !same_type
10563 2842 : && !deallocate_called)
10564 : {
10565 : /* Add checked deallocation of the components. This code is
10566 : obviously added because the finalizer is not trusted to free
10567 : all memory. */
10568 1544 : if (c->ts.type == BT_CLASS)
10569 : {
10570 241 : rank = CLASS_DATA (c)->as ? CLASS_DATA (c)->as->rank : 0;
10571 241 : add_when_allocated
10572 241 : = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
10573 : comp, NULL_TREE, rank, purpose,
10574 : caf_mode, args, no_finalization);
10575 : }
10576 : else
10577 : {
10578 1303 : rank = c->as ? c->as->rank : 0;
10579 1303 : add_when_allocated = structure_alloc_comps (c->ts.u.derived,
10580 : comp, NULL_TREE,
10581 : rank, purpose,
10582 : caf_mode, args,
10583 : no_finalization);
10584 : }
10585 : }
10586 :
10587 8056 : if (attr->allocatable && !same_type
10588 18997 : && (!attr->codimension || caf_enabled (caf_mode)))
10589 : {
10590 : /* Handle all types of components besides components of the
10591 : same_type as the current one, because those would create an
10592 : endless loop. */
10593 51 : caf_dereg_mode = (caf_in_coarray (caf_mode)
10594 58 : && (attr->dimension || c->caf_token))
10595 6969 : || attr->codimension
10596 7104 : ? (gfc_caf_is_dealloc_only (caf_mode)
10597 : ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
10598 : : GFC_CAF_COARRAY_DEREGISTER)
10599 : : GFC_CAF_COARRAY_NOCOARRAY;
10600 :
10601 7026 : caf_token = NULL_TREE;
10602 : /* Coarray components are handled directly by
10603 : deallocate_with_status. */
10604 7026 : if (!attr->codimension
10605 7005 : && caf_dereg_mode != GFC_CAF_COARRAY_NOCOARRAY)
10606 : {
10607 57 : if (c->caf_token)
10608 19 : caf_token
10609 19 : = fold_build3_loc (input_location, COMPONENT_REF,
10610 19 : TREE_TYPE (gfc_comp_caf_token (c)),
10611 : decl, gfc_comp_caf_token (c),
10612 : NULL_TREE);
10613 38 : else if (attr->dimension && !attr->proc_pointer)
10614 38 : caf_token = gfc_conv_descriptor_token (comp);
10615 : }
10616 :
10617 7026 : tmp = gfc_deallocate_with_status (comp, NULL_TREE, NULL_TREE,
10618 : NULL_TREE, NULL_TREE, true,
10619 : NULL, caf_dereg_mode, NULL_TREE,
10620 : add_when_allocated, caf_token);
10621 :
10622 7026 : gfc_add_expr_to_block (&tmpblock, tmp);
10623 : }
10624 4938 : else if (attr->allocatable && !attr->codimension
10625 1023 : && !deallocate_called)
10626 : {
10627 : /* Case of recursive allocatable derived types. */
10628 1023 : tree is_allocated;
10629 1023 : tree ubound;
10630 1023 : tree cdesc;
10631 1023 : stmtblock_t dealloc_block;
10632 :
10633 1023 : gfc_init_block (&dealloc_block);
10634 1023 : if (add_when_allocated)
10635 0 : gfc_add_expr_to_block (&dealloc_block, add_when_allocated);
10636 :
10637 : /* Convert the component into a rank 1 descriptor type. */
10638 1023 : if (attr->dimension)
10639 : {
10640 417 : tmp = gfc_get_element_type (TREE_TYPE (comp));
10641 417 : ubound = gfc_full_array_size (&dealloc_block, comp,
10642 417 : c->ts.type == BT_CLASS
10643 0 : ? CLASS_DATA (c)->as->rank
10644 417 : : c->as->rank);
10645 : }
10646 : else
10647 : {
10648 606 : tmp = TREE_TYPE (comp);
10649 606 : ubound = build_int_cst (gfc_array_index_type, 1);
10650 : }
10651 :
10652 1023 : cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node,
10653 : &ubound, 1,
10654 : GFC_ARRAY_ALLOCATABLE, false);
10655 :
10656 1023 : cdesc = gfc_create_var (cdesc, "cdesc");
10657 1023 : DECL_ARTIFICIAL (cdesc) = 1;
10658 :
10659 1023 : gfc_add_modify (&dealloc_block, gfc_conv_descriptor_dtype (cdesc),
10660 : gfc_get_dtype_rank_type (1, tmp));
10661 1023 : gfc_conv_descriptor_lbound_set (&dealloc_block, cdesc,
10662 : gfc_index_zero_node,
10663 : gfc_index_one_node);
10664 1023 : gfc_conv_descriptor_stride_set (&dealloc_block, cdesc,
10665 : gfc_index_zero_node,
10666 : gfc_index_one_node);
10667 1023 : gfc_conv_descriptor_ubound_set (&dealloc_block, cdesc,
10668 : gfc_index_zero_node, ubound);
10669 :
10670 1023 : if (attr->dimension)
10671 417 : comp = gfc_conv_descriptor_data_get (comp);
10672 :
10673 1023 : gfc_conv_descriptor_data_set (&dealloc_block, cdesc, comp);
10674 :
10675 : /* Now call the deallocator. */
10676 1023 : vtab = gfc_find_vtab (&c->ts);
10677 1023 : if (vtab->backend_decl == NULL)
10678 47 : gfc_get_symbol_decl (vtab);
10679 1023 : tmp = gfc_build_addr_expr (NULL_TREE, vtab->backend_decl);
10680 1023 : dealloc_fndecl = gfc_vptr_deallocate_get (tmp);
10681 1023 : dealloc_fndecl = build_fold_indirect_ref_loc (input_location,
10682 : dealloc_fndecl);
10683 1023 : tmp = build_int_cst (TREE_TYPE (comp), 0);
10684 1023 : is_allocated = fold_build2_loc (input_location, NE_EXPR,
10685 : logical_type_node, tmp,
10686 : comp);
10687 1023 : cdesc = gfc_build_addr_expr (NULL_TREE, cdesc);
10688 :
10689 1023 : tmp = build_call_expr_loc (input_location,
10690 : dealloc_fndecl, 1,
10691 : cdesc);
10692 1023 : gfc_add_expr_to_block (&dealloc_block, tmp);
10693 :
10694 1023 : tmp = gfc_finish_block (&dealloc_block);
10695 :
10696 1023 : tmp = fold_build3_loc (input_location, COND_EXPR,
10697 : void_type_node, is_allocated, tmp,
10698 : build_empty_stmt (input_location));
10699 :
10700 1023 : gfc_add_expr_to_block (&tmpblock, tmp);
10701 1023 : }
10702 3915 : else if (add_when_allocated)
10703 627 : gfc_add_expr_to_block (&tmpblock, add_when_allocated);
10704 :
10705 984 : if (c->ts.type == BT_CLASS && attr->allocatable
10706 12948 : && (!attr->codimension || !caf_enabled (caf_mode)))
10707 : {
10708 : /* Finally, reset the vptr to the declared type vtable and, if
10709 : necessary reset the _len field.
10710 :
10711 : First recover the reference to the component and obtain
10712 : the vptr. */
10713 969 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10714 : decl, cdecl, NULL_TREE);
10715 969 : tmp = gfc_class_vptr_get (comp);
10716 :
10717 969 : if (UNLIMITED_POLY (c))
10718 : {
10719 : /* Both vptr and _len field should be nulled. */
10720 213 : gfc_add_modify (&tmpblock, tmp,
10721 213 : build_int_cst (TREE_TYPE (tmp), 0));
10722 213 : tmp = gfc_class_len_get (comp);
10723 213 : gfc_add_modify (&tmpblock, tmp,
10724 213 : build_int_cst (TREE_TYPE (tmp), 0));
10725 : }
10726 : else
10727 : {
10728 : /* Build the vtable address and set the vptr with it. */
10729 756 : gfc_reset_vptr (&tmpblock, nullptr, tmp, c->ts.u.derived);
10730 : }
10731 : }
10732 :
10733 : /* Now add the deallocation of this component. */
10734 11964 : gfc_add_block_to_block (&fnblock, &tmpblock);
10735 11964 : break;
10736 :
10737 5293 : case NULLIFY_ALLOC_COMP:
10738 : /* Nullify
10739 : - allocatable components (regular or in class)
10740 : - components that have allocatable components
10741 : - pointer components when in a coarray.
10742 : Skip everything else especially proc_pointers, which may come
10743 : coupled with the regular pointer attribute. */
10744 7086 : if (c->attr.proc_pointer
10745 5293 : || !(c->attr.allocatable || (c->ts.type == BT_CLASS
10746 482 : && CLASS_DATA (c)->attr.allocatable)
10747 2240 : || (cmp_has_alloc_comps
10748 364 : && ((c->ts.type == BT_DERIVED && !c->attr.pointer)
10749 18 : || (c->ts.type == BT_CLASS
10750 12 : && !CLASS_DATA (c)->attr.class_pointer)))
10751 1894 : || (caf_in_coarray (caf_mode) && c->attr.pointer)))
10752 1793 : continue;
10753 :
10754 : /* Process class components first, because they always have the
10755 : pointer-attribute set which would be caught wrong else. */
10756 3500 : if (c->ts.type == BT_CLASS
10757 469 : && (CLASS_DATA (c)->attr.allocatable
10758 0 : || CLASS_DATA (c)->attr.class_pointer))
10759 : {
10760 469 : tree class_ref;
10761 :
10762 : /* Allocatable CLASS components. */
10763 469 : class_ref = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10764 : decl, cdecl, NULL_TREE);
10765 :
10766 469 : comp = gfc_class_data_get (class_ref);
10767 469 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
10768 257 : gfc_conv_descriptor_data_set (&fnblock, comp,
10769 : null_pointer_node);
10770 : else
10771 : {
10772 212 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
10773 : void_type_node, comp,
10774 212 : build_int_cst (TREE_TYPE (comp), 0));
10775 212 : gfc_add_expr_to_block (&fnblock, tmp);
10776 : }
10777 :
10778 : /* The dynamic type of a disassociated pointer or unallocated
10779 : allocatable variable is its declared type. An unlimited
10780 : polymorphic entity has no declared type. */
10781 469 : gfc_reset_vptr (&fnblock, nullptr, class_ref, c->ts.u.derived);
10782 :
10783 469 : cmp_has_alloc_comps = false;
10784 469 : }
10785 : /* Coarrays need the component to be nulled before the api-call
10786 : is made. */
10787 3031 : else if (c->attr.pointer || c->attr.allocatable)
10788 : {
10789 2685 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10790 : decl, cdecl, NULL_TREE);
10791 2685 : if (c->attr.dimension || c->attr.codimension)
10792 1848 : gfc_conv_descriptor_data_set (&fnblock, comp,
10793 : null_pointer_node);
10794 : else
10795 837 : gfc_add_modify (&fnblock, comp,
10796 837 : build_int_cst (TREE_TYPE (comp), 0));
10797 2685 : if (gfc_deferred_strlen (c, &comp))
10798 : {
10799 317 : comp = fold_build3_loc (input_location, COMPONENT_REF,
10800 317 : TREE_TYPE (comp),
10801 : decl, comp, NULL_TREE);
10802 634 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
10803 317 : TREE_TYPE (comp), comp,
10804 317 : build_int_cst (TREE_TYPE (comp), 0));
10805 317 : gfc_add_expr_to_block (&fnblock, tmp);
10806 : }
10807 : cmp_has_alloc_comps = false;
10808 : }
10809 :
10810 3500 : if (flag_coarray == GFC_FCOARRAY_LIB && caf_in_coarray (caf_mode))
10811 : {
10812 : /* Register a component of a derived type coarray with the
10813 : coarray library. Do not register ultimate component
10814 : coarrays here. They are treated like regular coarrays and
10815 : are either allocated on all images or on none. */
10816 132 : tree token;
10817 :
10818 132 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10819 : decl, cdecl, NULL_TREE);
10820 132 : if (c->attr.dimension)
10821 : {
10822 : /* Set the dtype, because caf_register needs it. */
10823 104 : gfc_add_modify (&fnblock, gfc_conv_descriptor_dtype (comp),
10824 104 : gfc_get_dtype (TREE_TYPE (comp)));
10825 104 : tmp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10826 : decl, cdecl, NULL_TREE);
10827 104 : token = gfc_conv_descriptor_token (tmp);
10828 : }
10829 : else
10830 : {
10831 28 : gfc_se se;
10832 :
10833 28 : gfc_init_se (&se, NULL);
10834 56 : token = fold_build3_loc (input_location, COMPONENT_REF,
10835 : pvoid_type_node, decl,
10836 28 : gfc_comp_caf_token (c), NULL_TREE);
10837 28 : comp = gfc_conv_scalar_to_descriptor (&se, comp,
10838 28 : c->ts.type == BT_CLASS
10839 28 : ? CLASS_DATA (c)->attr
10840 : : c->attr);
10841 28 : gfc_add_block_to_block (&fnblock, &se.pre);
10842 : }
10843 :
10844 132 : gfc_allocate_using_caf_lib (&fnblock, comp, size_zero_node,
10845 : gfc_build_addr_expr (NULL_TREE,
10846 : token),
10847 : NULL_TREE, NULL_TREE, NULL_TREE,
10848 : GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
10849 : }
10850 :
10851 3500 : if (cmp_has_alloc_comps)
10852 : {
10853 346 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10854 : decl, cdecl, NULL_TREE);
10855 346 : rank = c->as ? c->as->rank : 0;
10856 346 : tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
10857 : rank, purpose, caf_mode, args,
10858 : no_finalization);
10859 346 : gfc_add_expr_to_block (&fnblock, tmp);
10860 : }
10861 : break;
10862 :
10863 30 : case REASSIGN_CAF_COMP:
10864 30 : if (caf_enabled (caf_mode)
10865 30 : && (c->attr.codimension
10866 23 : || (c->ts.type == BT_CLASS
10867 2 : && (CLASS_DATA (c)->attr.coarray_comp
10868 2 : || caf_in_coarray (caf_mode)))
10869 21 : || (c->ts.type == BT_DERIVED
10870 7 : && (c->ts.u.derived->attr.coarray_comp
10871 6 : || caf_in_coarray (caf_mode))))
10872 46 : && !same_type)
10873 : {
10874 14 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10875 : decl, cdecl, NULL_TREE);
10876 14 : dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10877 : dest, cdecl, NULL_TREE);
10878 :
10879 14 : if (c->attr.codimension)
10880 : {
10881 7 : if (c->ts.type == BT_CLASS)
10882 : {
10883 0 : comp = gfc_class_data_get (comp);
10884 0 : dcmp = gfc_class_data_get (dcmp);
10885 : }
10886 7 : gfc_conv_descriptor_data_set (&fnblock, dcmp,
10887 : gfc_conv_descriptor_data_get (comp));
10888 : }
10889 : else
10890 : {
10891 7 : tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
10892 : rank, purpose, caf_mode
10893 : | GFC_STRUCTURE_CAF_MODE_IN_COARRAY,
10894 : args, no_finalization);
10895 7 : gfc_add_expr_to_block (&fnblock, tmp);
10896 : }
10897 : }
10898 : break;
10899 :
10900 11391 : case COPY_ALLOC_COMP:
10901 11391 : if (c->attr.pointer || c->attr.proc_pointer)
10902 153 : continue;
10903 :
10904 : /* We need source and destination components. */
10905 11238 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl,
10906 : cdecl, NULL_TREE);
10907 11238 : dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, dest,
10908 : cdecl, NULL_TREE);
10909 11238 : dcmp = fold_convert (TREE_TYPE (comp), dcmp);
10910 :
10911 11238 : if (IS_PDT (c) && !c->attr.allocatable)
10912 : {
10913 39 : tmp = gfc_copy_alloc_comp (c->ts.u.derived, comp, dcmp,
10914 : 0, 0);
10915 39 : gfc_add_expr_to_block (&fnblock, tmp);
10916 39 : continue;
10917 : }
10918 :
10919 11199 : if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
10920 : {
10921 722 : tree ftn_tree;
10922 722 : tree size;
10923 722 : tree dst_data;
10924 722 : tree src_data;
10925 722 : tree null_data;
10926 :
10927 722 : dst_data = gfc_class_data_get (dcmp);
10928 722 : src_data = gfc_class_data_get (comp);
10929 722 : size = fold_convert (size_type_node,
10930 : gfc_class_vtab_size_get (comp));
10931 :
10932 722 : if (CLASS_DATA (c)->attr.dimension)
10933 : {
10934 696 : nelems = gfc_conv_descriptor_size (src_data,
10935 348 : CLASS_DATA (c)->as->rank);
10936 348 : size = fold_build2_loc (input_location, MULT_EXPR,
10937 : size_type_node, size,
10938 : fold_convert (size_type_node,
10939 : nelems));
10940 : }
10941 : else
10942 374 : nelems = build_int_cst (size_type_node, 1);
10943 :
10944 722 : if (CLASS_DATA (c)->attr.dimension
10945 374 : || CLASS_DATA (c)->attr.codimension)
10946 : {
10947 356 : src_data = gfc_conv_descriptor_data_get (src_data);
10948 356 : dst_data = gfc_conv_descriptor_data_get (dst_data);
10949 : }
10950 :
10951 722 : gfc_init_block (&tmpblock);
10952 :
10953 722 : gfc_add_modify (&tmpblock, gfc_class_vptr_get (dcmp),
10954 : gfc_class_vptr_get (comp));
10955 :
10956 : /* Copy the unlimited '_len' field. If it is greater than zero
10957 : (ie. a character(_len)), multiply it by size and use this
10958 : for the malloc call. */
10959 722 : if (UNLIMITED_POLY (c))
10960 : {
10961 136 : gfc_add_modify (&tmpblock, gfc_class_len_get (dcmp),
10962 : gfc_class_len_get (comp));
10963 136 : size = gfc_resize_class_size_with_len (&tmpblock, comp, size);
10964 : }
10965 :
10966 : /* Coarray component have to have the same allocation status and
10967 : shape/type-parameter/effective-type on the LHS and RHS of an
10968 : intrinsic assignment. Hence, we did not deallocated them - and
10969 : do not allocate them here. */
10970 722 : if (!CLASS_DATA (c)->attr.codimension)
10971 : {
10972 707 : ftn_tree = builtin_decl_explicit (BUILT_IN_MALLOC);
10973 707 : tmp = build_call_expr_loc (input_location, ftn_tree, 1, size);
10974 707 : gfc_add_modify (&tmpblock, dst_data,
10975 707 : fold_convert (TREE_TYPE (dst_data), tmp));
10976 : }
10977 :
10978 1429 : tmp = gfc_copy_class_to_class (comp, dcmp, nelems,
10979 722 : UNLIMITED_POLY (c));
10980 722 : gfc_add_expr_to_block (&tmpblock, tmp);
10981 722 : tmp = gfc_finish_block (&tmpblock);
10982 :
10983 722 : gfc_init_block (&tmpblock);
10984 722 : gfc_add_modify (&tmpblock, dst_data,
10985 722 : fold_convert (TREE_TYPE (dst_data),
10986 : null_pointer_node));
10987 722 : null_data = gfc_finish_block (&tmpblock);
10988 :
10989 722 : null_cond = fold_build2_loc (input_location, NE_EXPR,
10990 : logical_type_node, src_data,
10991 : null_pointer_node);
10992 :
10993 722 : gfc_add_expr_to_block (&fnblock, build3_v (COND_EXPR, null_cond,
10994 : tmp, null_data));
10995 722 : continue;
10996 722 : }
10997 :
10998 : /* To implement guarded deep copy, i.e., deep copy only allocatable
10999 : components that are really allocated, the deep copy code has to
11000 : be generated first and then added to the if-block in
11001 : gfc_duplicate_allocatable (). */
11002 10477 : if (cmp_has_alloc_comps && !c->attr.proc_pointer && !same_type)
11003 : {
11004 1667 : rank = c->as ? c->as->rank : 0;
11005 1667 : tmp = fold_convert (TREE_TYPE (dcmp), comp);
11006 1667 : gfc_add_modify (&fnblock, dcmp, tmp);
11007 1667 : add_when_allocated = structure_alloc_comps (c->ts.u.derived,
11008 : comp, dcmp,
11009 : rank, purpose,
11010 : caf_mode, args,
11011 : no_finalization);
11012 : }
11013 : else
11014 : add_when_allocated = NULL_TREE;
11015 :
11016 10477 : if (gfc_deferred_strlen (c, &tmp))
11017 : {
11018 386 : tree len, size;
11019 386 : len = tmp;
11020 386 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
11021 386 : TREE_TYPE (len),
11022 : decl, len, NULL_TREE);
11023 386 : len = fold_build3_loc (input_location, COMPONENT_REF,
11024 386 : TREE_TYPE (len),
11025 : dest, len, NULL_TREE);
11026 386 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
11027 386 : TREE_TYPE (len), len, tmp);
11028 386 : gfc_add_expr_to_block (&fnblock, tmp);
11029 386 : size = size_of_string_in_bytes (c->ts.kind, len);
11030 : /* This component cannot have allocatable components,
11031 : therefore add_when_allocated of duplicate_allocatable ()
11032 : is always NULL. */
11033 386 : rank = c->as ? c->as->rank : 0;
11034 386 : tmp = duplicate_allocatable (dcmp, comp, ctype, rank,
11035 : false, false, size, NULL_TREE);
11036 386 : gfc_add_expr_to_block (&fnblock, tmp);
11037 : }
11038 10091 : else if (c->attr.pdt_array
11039 157 : && !c->attr.allocatable && !c->attr.pointer)
11040 : {
11041 157 : tmp = duplicate_allocatable (dcmp, comp, ctype,
11042 157 : c->as ? c->as->rank : 0,
11043 : false, false, NULL_TREE, NULL_TREE);
11044 157 : gfc_add_expr_to_block (&fnblock, tmp);
11045 : }
11046 : /* Special case: recursive allocatable array components require
11047 : runtime helpers to avoid compile-time infinite recursion. Generate
11048 : a call to _gfortran_cfi_deep_copy_array with an element copy
11049 : wrapper. When inside a wrapper, reuse current_function_decl. */
11050 6036 : else if (c->attr.allocatable && c->as && cmp_has_alloc_comps && same_type
11051 930 : && purpose == COPY_ALLOC_COMP && !c->attr.proc_pointer
11052 930 : && !c->attr.codimension && !caf_in_coarray (caf_mode)
11053 10864 : && c->ts.type == BT_DERIVED && c->ts.u.derived != NULL)
11054 : {
11055 930 : tree copy_wrapper, call, dest_addr, src_addr, elem_type;
11056 930 : tree helper_ptr_type;
11057 930 : tree alloc_expr;
11058 930 : int comp_rank;
11059 :
11060 : /* Get the element type from ctype (already the component
11061 : type). For arrays we need the element type, not the array
11062 : type. */
11063 930 : elem_type = ctype;
11064 930 : if (GFC_DESCRIPTOR_TYPE_P (ctype))
11065 930 : elem_type = gfc_get_element_type (ctype);
11066 0 : else if (TREE_CODE (ctype) == ARRAY_TYPE)
11067 0 : elem_type = TREE_TYPE (ctype);
11068 :
11069 930 : helper_ptr_type = get_copy_helper_pointer_type ();
11070 :
11071 930 : comp_rank = c->as ? c->as->rank : 0;
11072 930 : alloc_expr = gfc_duplicate_allocatable_nocopy (dcmp, comp, ctype,
11073 : comp_rank);
11074 930 : gfc_add_expr_to_block (&fnblock, alloc_expr);
11075 :
11076 : /* Generate or reuse the element copy helper. Inside an
11077 : existing helper we can reuse the current function to
11078 : prevent recursive generation. */
11079 930 : if (inside_wrapper)
11080 703 : copy_wrapper
11081 703 : = gfc_build_addr_expr (NULL_TREE, current_function_decl);
11082 : else
11083 227 : copy_wrapper
11084 227 : = generate_element_copy_wrapper (c->ts.u.derived, elem_type,
11085 : purpose, caf_mode);
11086 930 : copy_wrapper = fold_convert (helper_ptr_type, copy_wrapper);
11087 :
11088 : /* Build addresses of descriptors. */
11089 930 : dest_addr = gfc_build_addr_expr (pvoid_type_node, dcmp);
11090 930 : src_addr = gfc_build_addr_expr (pvoid_type_node, comp);
11091 :
11092 : /* Build call: _gfortran_cfi_deep_copy_array (&dcmp, &comp,
11093 : wrapper). */
11094 930 : call = build_call_expr_loc (input_location,
11095 : gfor_fndecl_cfi_deep_copy_array, 3,
11096 : dest_addr, src_addr,
11097 : copy_wrapper);
11098 930 : gfc_add_expr_to_block (&fnblock, call);
11099 : }
11100 : /* For allocatable arrays with nested allocatable components,
11101 : add_when_allocated already includes gfc_duplicate_allocatable
11102 : (from the recursive structure_alloc_comps call at line 10290-10293),
11103 : so we must not call it again here. PR121628 added an
11104 : add_when_allocated != NULL clause that was redundant for scalars
11105 : (already handled by !c->as) and wrong for arrays (double alloc). */
11106 5106 : else if (c->attr.allocatable && !c->attr.proc_pointer
11107 14110 : && (!cmp_has_alloc_comps
11108 798 : || !c->as
11109 573 : || c->attr.codimension
11110 570 : || caf_in_coarray (caf_mode)))
11111 : {
11112 4542 : rank = c->as ? c->as->rank : 0;
11113 4542 : if (c->attr.codimension)
11114 20 : tmp = gfc_copy_allocatable_data (dcmp, comp, ctype, rank);
11115 4522 : else if (flag_coarray == GFC_FCOARRAY_LIB
11116 4522 : && caf_in_coarray (caf_mode))
11117 : {
11118 62 : tree dst_tok;
11119 62 : if (c->as)
11120 44 : dst_tok = gfc_conv_descriptor_token (dcmp);
11121 : else
11122 : {
11123 18 : dst_tok
11124 18 : = fold_build3_loc (input_location, COMPONENT_REF,
11125 : pvoid_type_node, dest,
11126 18 : gfc_comp_caf_token (c), NULL_TREE);
11127 : }
11128 62 : tmp
11129 62 : = duplicate_allocatable_coarray (dcmp, dst_tok, comp, ctype,
11130 : rank, add_when_allocated);
11131 : }
11132 : else
11133 4460 : tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank,
11134 : add_when_allocated);
11135 4542 : gfc_add_expr_to_block (&fnblock, tmp);
11136 : }
11137 : else
11138 4462 : if (cmp_has_alloc_comps || is_pdt_type)
11139 1708 : gfc_add_expr_to_block (&fnblock, add_when_allocated);
11140 :
11141 : break;
11142 :
11143 1879 : case ALLOCATE_PDT_COMP:
11144 :
11145 1879 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
11146 : decl, cdecl, NULL_TREE);
11147 :
11148 : /* Set the PDT KIND and LEN fields. */
11149 1879 : if (c->attr.pdt_kind || c->attr.pdt_len)
11150 : {
11151 855 : gfc_se tse;
11152 855 : gfc_expr *c_expr = NULL;
11153 855 : gfc_actual_arglist *param = pdt_param_list;
11154 855 : gfc_init_se (&tse, NULL);
11155 3103 : for (; param; param = param->next)
11156 1393 : if (param->name && !strcmp (c->name, param->name))
11157 849 : c_expr = param->expr;
11158 :
11159 855 : if (!c_expr)
11160 24 : c_expr = c->initializer;
11161 :
11162 24 : if (c_expr)
11163 : {
11164 837 : gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp));
11165 837 : gfc_add_block_to_block (&fnblock, &tse.pre);
11166 837 : gfc_add_modify (&fnblock, comp, tse.expr);
11167 837 : gfc_add_block_to_block (&fnblock, &tse.post);
11168 : }
11169 855 : }
11170 1024 : else if (c->initializer && !c->attr.pdt_string && !c->attr.pdt_array
11171 139 : && !c->as && !IS_PDT (c)) /* Take care of arrays. */
11172 : {
11173 49 : gfc_se tse;
11174 49 : gfc_expr *c_expr;
11175 49 : gfc_init_se (&tse, NULL);
11176 49 : c_expr = c->initializer;
11177 49 : gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp));
11178 49 : gfc_add_block_to_block (&fnblock, &tse.pre);
11179 49 : gfc_add_modify (&fnblock, comp, tse.expr);
11180 49 : gfc_add_block_to_block (&fnblock, &tse.post);
11181 : }
11182 :
11183 1879 : if (c->attr.pdt_string)
11184 : {
11185 90 : gfc_se tse;
11186 90 : gfc_init_se (&tse, NULL);
11187 90 : tree strlen = NULL_TREE;
11188 90 : gfc_expr *e = gfc_copy_expr (c->ts.u.cl->length);
11189 : /* Convert the parameterized string length to its value. The
11190 : string length is stored in a hidden field in the same way as
11191 : deferred string lengths. */
11192 90 : gfc_insert_parameter_exprs (e, pdt_param_list);
11193 90 : if (gfc_deferred_strlen (c, &strlen) && strlen != NULL_TREE)
11194 : {
11195 90 : gfc_conv_expr_type (&tse, e,
11196 90 : TREE_TYPE (strlen));
11197 90 : strlen = fold_build3_loc (input_location, COMPONENT_REF,
11198 90 : TREE_TYPE (strlen),
11199 : decl, strlen, NULL_TREE);
11200 90 : gfc_add_block_to_block (&fnblock, &tse.pre);
11201 90 : gfc_add_modify (&fnblock, strlen, tse.expr);
11202 90 : gfc_add_block_to_block (&fnblock, &tse.post);
11203 90 : c->ts.u.cl->backend_decl = strlen;
11204 : }
11205 90 : gfc_free_expr (e);
11206 :
11207 : /* Scalar parameterized strings can be allocated now. */
11208 90 : if (!c->as)
11209 : {
11210 90 : tmp = fold_convert (gfc_array_index_type, strlen);
11211 90 : tmp = size_of_string_in_bytes (c->ts.kind, tmp);
11212 90 : tmp = gfc_evaluate_now (tmp, &fnblock);
11213 90 : tmp = gfc_call_malloc (&fnblock, TREE_TYPE (comp), tmp);
11214 90 : gfc_add_modify (&fnblock, comp, tmp);
11215 : }
11216 : }
11217 :
11218 : /* Allocate parameterized arrays of parameterized derived types. */
11219 1879 : if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT)
11220 1612 : && !(IS_PDT (c) || IS_CLASS_PDT (c)))
11221 1427 : continue;
11222 :
11223 452 : if (c->ts.type == BT_CLASS)
11224 0 : comp = gfc_class_data_get (comp);
11225 :
11226 452 : if (c->attr.pdt_array)
11227 : {
11228 267 : gfc_se tse;
11229 267 : int i;
11230 267 : tree size = gfc_index_one_node;
11231 267 : tree offset = gfc_index_zero_node;
11232 267 : tree lower, upper;
11233 267 : gfc_expr *e;
11234 :
11235 : /* This chunk takes the expressions for 'lower' and 'upper'
11236 : in the arrayspec and substitutes in the expressions for
11237 : the parameters from 'pdt_param_list'. The descriptor
11238 : fields can then be filled from the values so obtained. */
11239 267 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)));
11240 642 : for (i = 0; i < c->as->rank; i++)
11241 : {
11242 375 : gfc_init_se (&tse, NULL);
11243 375 : e = gfc_copy_expr (c->as->lower[i]);
11244 375 : gfc_insert_parameter_exprs (e, pdt_param_list);
11245 375 : gfc_conv_expr_type (&tse, e, gfc_array_index_type);
11246 375 : gfc_free_expr (e);
11247 375 : lower = tse.expr;
11248 375 : gfc_add_block_to_block (&fnblock, &tse.pre);
11249 375 : gfc_conv_descriptor_lbound_set (&fnblock, comp,
11250 : gfc_rank_cst[i],
11251 : lower);
11252 375 : gfc_add_block_to_block (&fnblock, &tse.post);
11253 375 : e = gfc_copy_expr (c->as->upper[i]);
11254 375 : gfc_insert_parameter_exprs (e, pdt_param_list);
11255 375 : gfc_conv_expr_type (&tse, e, gfc_array_index_type);
11256 375 : gfc_free_expr (e);
11257 375 : upper = tse.expr;
11258 375 : gfc_add_block_to_block (&fnblock, &tse.pre);
11259 375 : gfc_conv_descriptor_ubound_set (&fnblock, comp,
11260 : gfc_rank_cst[i],
11261 : upper);
11262 375 : gfc_add_block_to_block (&fnblock, &tse.post);
11263 375 : gfc_conv_descriptor_stride_set (&fnblock, comp,
11264 : gfc_rank_cst[i],
11265 : size);
11266 375 : size = gfc_evaluate_now (size, &fnblock);
11267 375 : offset = fold_build2_loc (input_location,
11268 : MINUS_EXPR,
11269 : gfc_array_index_type,
11270 : offset, size);
11271 375 : offset = gfc_evaluate_now (offset, &fnblock);
11272 375 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
11273 : gfc_array_index_type,
11274 : upper, lower);
11275 375 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
11276 : gfc_array_index_type,
11277 : tmp, gfc_index_one_node);
11278 375 : size = fold_build2_loc (input_location, MULT_EXPR,
11279 : gfc_array_index_type, size, tmp);
11280 : }
11281 267 : gfc_conv_descriptor_offset_set (&fnblock, comp, offset);
11282 267 : if (c->ts.type == BT_CLASS)
11283 : {
11284 0 : tmp = gfc_get_vptr_from_expr (comp);
11285 0 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
11286 0 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
11287 0 : tmp = gfc_vptr_size_get (tmp);
11288 : }
11289 : else
11290 267 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (ctype));
11291 267 : tmp = fold_convert (gfc_array_index_type, tmp);
11292 267 : size = fold_build2_loc (input_location, MULT_EXPR,
11293 : gfc_array_index_type, size, tmp);
11294 267 : size = gfc_evaluate_now (size, &fnblock);
11295 267 : tmp = gfc_call_malloc (&fnblock, NULL, size);
11296 267 : gfc_conv_descriptor_data_set (&fnblock, comp, tmp);
11297 267 : tmp = gfc_conv_descriptor_dtype (comp);
11298 267 : gfc_add_modify (&fnblock, tmp, gfc_get_dtype (ctype));
11299 :
11300 267 : if (c->initializer && c->initializer->rank)
11301 : {
11302 0 : gfc_init_se (&tse, NULL);
11303 0 : e = gfc_copy_expr (c->initializer);
11304 0 : gfc_insert_parameter_exprs (e, pdt_param_list);
11305 0 : gfc_conv_expr_descriptor (&tse, e);
11306 0 : gfc_add_block_to_block (&fnblock, &tse.pre);
11307 0 : gfc_free_expr (e);
11308 0 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
11309 0 : tmp = build_call_expr_loc (input_location, tmp, 3,
11310 : gfc_conv_descriptor_data_get (comp),
11311 : gfc_conv_descriptor_data_get (tse.expr),
11312 : fold_convert (size_type_node, size));
11313 0 : gfc_add_expr_to_block (&fnblock, tmp);
11314 0 : gfc_add_block_to_block (&fnblock, &tse.post);
11315 : }
11316 : }
11317 :
11318 : /* Recurse in to PDT components. */
11319 452 : if ((IS_PDT (c) || IS_CLASS_PDT (c))
11320 198 : && !(c->attr.pointer || c->attr.allocatable))
11321 : {
11322 103 : gfc_actual_arglist *tail = c->param_list;
11323 :
11324 260 : for (; tail; tail = tail->next)
11325 157 : if (tail->expr)
11326 133 : gfc_insert_parameter_exprs (tail->expr, pdt_param_list);
11327 :
11328 103 : tmp = gfc_allocate_pdt_comp (c->ts.u.derived, comp,
11329 103 : c->as ? c->as->rank : 0,
11330 103 : c->param_list);
11331 103 : gfc_add_expr_to_block (&fnblock, tmp);
11332 : }
11333 :
11334 : break;
11335 :
11336 2253 : case DEALLOCATE_PDT_COMP:
11337 : /* Deallocate array or parameterized string length components
11338 : of parameterized derived types. */
11339 2253 : if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT)
11340 1791 : && !c->attr.pdt_string
11341 1683 : && !(IS_PDT (c) || IS_CLASS_PDT (c)))
11342 1451 : continue;
11343 :
11344 802 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
11345 : decl, cdecl, NULL_TREE);
11346 802 : if (c->ts.type == BT_CLASS)
11347 0 : comp = gfc_class_data_get (comp);
11348 :
11349 : /* Recurse in to PDT components. */
11350 802 : if ((IS_PDT (c) || IS_CLASS_PDT (c))
11351 269 : && (!c->attr.pointer && !c->attr.allocatable))
11352 : {
11353 103 : tmp = gfc_deallocate_pdt_comp (c->ts.u.derived, comp,
11354 103 : c->as ? c->as->rank : 0);
11355 103 : gfc_add_expr_to_block (&fnblock, tmp);
11356 : }
11357 :
11358 802 : if (c->attr.pdt_array || c->attr.pdt_string)
11359 : {
11360 570 : tmp = comp;
11361 570 : if (c->attr.pdt_array)
11362 462 : tmp = gfc_conv_descriptor_data_get (comp);
11363 570 : null_cond = fold_build2_loc (input_location, NE_EXPR,
11364 : logical_type_node, tmp,
11365 570 : build_int_cst (TREE_TYPE (tmp), 0));
11366 570 : if (flag_openmp_allocators)
11367 : {
11368 0 : tree cd, t;
11369 0 : if (c->attr.pdt_array)
11370 0 : cd = fold_build2_loc (input_location, EQ_EXPR,
11371 : boolean_type_node,
11372 : gfc_conv_descriptor_version (comp),
11373 : build_int_cst (integer_type_node, 1));
11374 : else
11375 0 : cd = gfc_omp_call_is_alloc (tmp);
11376 0 : t = builtin_decl_explicit (BUILT_IN_GOMP_FREE);
11377 0 : t = build_call_expr_loc (input_location, t, 1, tmp);
11378 :
11379 0 : stmtblock_t tblock;
11380 0 : gfc_init_block (&tblock);
11381 0 : gfc_add_expr_to_block (&tblock, t);
11382 0 : if (c->attr.pdt_array)
11383 0 : gfc_add_modify (&tblock, gfc_conv_descriptor_version (comp),
11384 : integer_zero_node);
11385 0 : tmp = build3_loc (input_location, COND_EXPR, void_type_node,
11386 : cd, gfc_finish_block (&tblock),
11387 : gfc_call_free (tmp));
11388 : }
11389 : else
11390 570 : tmp = gfc_call_free (tmp);
11391 570 : tmp = build3_v (COND_EXPR, null_cond, tmp,
11392 : build_empty_stmt (input_location));
11393 570 : gfc_add_expr_to_block (&fnblock, tmp);
11394 :
11395 570 : if (c->attr.pdt_array)
11396 462 : gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
11397 : else
11398 : {
11399 108 : tmp = fold_convert (TREE_TYPE (comp), null_pointer_node);
11400 108 : gfc_add_modify (&fnblock, comp, tmp);
11401 : }
11402 : }
11403 :
11404 : break;
11405 :
11406 324 : case CHECK_PDT_DUMMY:
11407 :
11408 324 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
11409 : decl, cdecl, NULL_TREE);
11410 324 : if (c->ts.type == BT_CLASS)
11411 0 : comp = gfc_class_data_get (comp);
11412 :
11413 : /* Recurse in to PDT components. */
11414 324 : if (((c->ts.type == BT_DERIVED
11415 14 : && !c->attr.allocatable && !c->attr.pointer)
11416 312 : || (c->ts.type == BT_CLASS
11417 0 : && !CLASS_DATA (c)->attr.allocatable
11418 0 : && !CLASS_DATA (c)->attr.pointer))
11419 12 : && c->ts.u.derived && c->ts.u.derived->attr.pdt_type)
11420 : {
11421 12 : tmp = gfc_check_pdt_dummy (c->ts.u.derived, comp,
11422 12 : c->as ? c->as->rank : 0,
11423 : pdt_param_list);
11424 12 : gfc_add_expr_to_block (&fnblock, tmp);
11425 : }
11426 :
11427 324 : if (!c->attr.pdt_len)
11428 276 : continue;
11429 : else
11430 : {
11431 48 : gfc_se tse;
11432 48 : gfc_expr *c_expr = NULL;
11433 48 : gfc_actual_arglist *param = pdt_param_list;
11434 :
11435 48 : gfc_init_se (&tse, NULL);
11436 186 : for (; param; param = param->next)
11437 90 : if (!strcmp (c->name, param->name)
11438 48 : && param->spec_type == SPEC_EXPLICIT)
11439 30 : c_expr = param->expr;
11440 :
11441 48 : if (c_expr)
11442 : {
11443 30 : tree error, cond, cname;
11444 30 : gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp));
11445 30 : cond = fold_build2_loc (input_location, NE_EXPR,
11446 : logical_type_node,
11447 : comp, tse.expr);
11448 30 : cname = gfc_build_cstring_const (c->name);
11449 30 : cname = gfc_build_addr_expr (pchar_type_node, cname);
11450 30 : error = gfc_trans_runtime_error (true, NULL,
11451 : "The value of the PDT LEN "
11452 : "parameter '%s' does not "
11453 : "agree with that in the "
11454 : "dummy declaration",
11455 : cname);
11456 30 : tmp = fold_build3_loc (input_location, COND_EXPR,
11457 : void_type_node, cond, error,
11458 : build_empty_stmt (input_location));
11459 30 : gfc_add_expr_to_block (&fnblock, tmp);
11460 : }
11461 : }
11462 48 : break;
11463 :
11464 0 : default:
11465 0 : gcc_unreachable ();
11466 6010 : break;
11467 : }
11468 : }
11469 17495 : seen_derived_types.remove (der_type);
11470 :
11471 17495 : return gfc_finish_block (&fnblock);
11472 : }
11473 :
11474 : /* Recursively traverse an object of derived type, generating code to
11475 : nullify allocatable components. */
11476 :
11477 : tree
11478 2847 : gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
11479 : int caf_mode)
11480 : {
11481 2847 : return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11482 : NULLIFY_ALLOC_COMP,
11483 : GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode,
11484 2847 : NULL);
11485 : }
11486 :
11487 :
11488 : /* Recursively traverse an object of derived type, generating code to
11489 : deallocate allocatable components. */
11490 :
11491 : tree
11492 2878 : gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
11493 : int caf_mode, bool no_finalization)
11494 : {
11495 2878 : return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11496 : DEALLOCATE_ALLOC_COMP,
11497 : GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode,
11498 2878 : NULL, no_finalization);
11499 : }
11500 :
11501 : tree
11502 1 : gfc_bcast_alloc_comp (gfc_symbol *derived, gfc_expr *expr, int rank,
11503 : tree image_index, tree stat, tree errmsg,
11504 : tree errmsg_len)
11505 : {
11506 1 : tree tmp, array;
11507 1 : gfc_se argse;
11508 1 : stmtblock_t block, post_block;
11509 1 : gfc_co_subroutines_args args;
11510 :
11511 1 : args.image_index = image_index;
11512 1 : args.stat = stat;
11513 1 : args.errmsg = errmsg;
11514 1 : args.errmsg_len = errmsg_len;
11515 :
11516 1 : if (rank == 0)
11517 : {
11518 1 : gfc_start_block (&block);
11519 1 : gfc_init_block (&post_block);
11520 1 : gfc_init_se (&argse, NULL);
11521 1 : gfc_conv_expr (&argse, expr);
11522 1 : gfc_add_block_to_block (&block, &argse.pre);
11523 1 : gfc_add_block_to_block (&post_block, &argse.post);
11524 1 : array = argse.expr;
11525 : }
11526 : else
11527 : {
11528 0 : gfc_init_se (&argse, NULL);
11529 0 : argse.want_pointer = 1;
11530 0 : gfc_conv_expr_descriptor (&argse, expr);
11531 0 : array = argse.expr;
11532 : }
11533 :
11534 1 : tmp = structure_alloc_comps (derived, array, NULL_TREE, rank,
11535 : BCAST_ALLOC_COMP,
11536 : GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY,
11537 : &args);
11538 1 : return tmp;
11539 : }
11540 :
11541 : /* Recursively traverse an object of derived type, generating code to
11542 : deallocate allocatable components. But do not deallocate coarrays.
11543 : To be used for intrinsic assignment, which may not change the allocation
11544 : status of coarrays. */
11545 :
11546 : tree
11547 2127 : gfc_deallocate_alloc_comp_no_caf (gfc_symbol * der_type, tree decl, int rank,
11548 : bool no_finalization)
11549 : {
11550 2127 : return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11551 : DEALLOCATE_ALLOC_COMP, 0, NULL,
11552 2127 : no_finalization);
11553 : }
11554 :
11555 :
11556 : tree
11557 5 : gfc_reassign_alloc_comp_caf (gfc_symbol *der_type, tree decl, tree dest)
11558 : {
11559 5 : return structure_alloc_comps (der_type, decl, dest, 0, REASSIGN_CAF_COMP,
11560 : GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY,
11561 5 : NULL);
11562 : }
11563 :
11564 :
11565 : /* Recursively traverse an object of derived type, generating code to
11566 : copy it and its allocatable components. */
11567 :
11568 : tree
11569 4141 : gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank,
11570 : int caf_mode)
11571 : {
11572 4141 : return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP,
11573 4141 : caf_mode, NULL);
11574 : }
11575 :
11576 :
11577 : /* Recursively traverse an object of derived type, generating code to
11578 : copy it and its allocatable components, while suppressing any
11579 : finalization that might occur. This is used in the finalization of
11580 : function results. */
11581 :
11582 : tree
11583 38 : gfc_copy_alloc_comp_no_fini (gfc_symbol * der_type, tree decl, tree dest,
11584 : int rank, int caf_mode)
11585 : {
11586 38 : return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP,
11587 38 : caf_mode, NULL, true);
11588 : }
11589 :
11590 :
11591 : /* Recursively traverse an object of derived type, generating code to
11592 : copy only its allocatable components. */
11593 :
11594 : tree
11595 0 : gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
11596 : {
11597 0 : return structure_alloc_comps (der_type, decl, dest, rank,
11598 0 : COPY_ONLY_ALLOC_COMP, 0, NULL);
11599 : }
11600 :
11601 :
11602 : /* Recursively traverse an object of parameterized derived type, generating
11603 : code to allocate parameterized components. */
11604 :
11605 : tree
11606 671 : gfc_allocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank,
11607 : gfc_actual_arglist *param_list)
11608 : {
11609 671 : tree res;
11610 671 : gfc_actual_arglist *old_param_list = pdt_param_list;
11611 671 : pdt_param_list = param_list;
11612 671 : res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11613 : ALLOCATE_PDT_COMP, 0, NULL);
11614 671 : pdt_param_list = old_param_list;
11615 671 : return res;
11616 : }
11617 :
11618 : /* Recursively traverse an object of parameterized derived type, generating
11619 : code to deallocate parameterized components. */
11620 :
11621 : tree
11622 998 : gfc_deallocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank)
11623 : {
11624 : /* A type without parameterized components causes gimplifier problems. */
11625 998 : if (!has_parameterized_comps (der_type))
11626 : return NULL_TREE;
11627 :
11628 508 : return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11629 508 : DEALLOCATE_PDT_COMP, 0, NULL);
11630 : }
11631 :
11632 :
11633 : /* Recursively traverse a dummy of parameterized derived type to check the
11634 : values of LEN parameters. */
11635 :
11636 : tree
11637 74 : gfc_check_pdt_dummy (gfc_symbol * der_type, tree decl, int rank,
11638 : gfc_actual_arglist *param_list)
11639 : {
11640 74 : tree res;
11641 74 : gfc_actual_arglist *old_param_list = pdt_param_list;
11642 74 : pdt_param_list = param_list;
11643 74 : res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11644 : CHECK_PDT_DUMMY, 0, NULL);
11645 74 : pdt_param_list = old_param_list;
11646 74 : return res;
11647 : }
11648 :
11649 :
11650 : /* Returns the value of LBOUND for an expression. This could be broken out
11651 : from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
11652 : called by gfc_alloc_allocatable_for_assignment. */
11653 : static tree
11654 1012 : get_std_lbound (gfc_expr *expr, tree desc, int dim, bool assumed_size)
11655 : {
11656 1012 : tree lbound;
11657 1012 : tree ubound;
11658 1012 : tree stride;
11659 1012 : tree cond, cond1, cond3, cond4;
11660 1012 : tree tmp;
11661 1012 : gfc_ref *ref;
11662 :
11663 1012 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
11664 : {
11665 496 : tmp = gfc_rank_cst[dim];
11666 496 : lbound = gfc_conv_descriptor_lbound_get (desc, tmp);
11667 496 : ubound = gfc_conv_descriptor_ubound_get (desc, tmp);
11668 496 : stride = gfc_conv_descriptor_stride_get (desc, tmp);
11669 496 : cond1 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
11670 : ubound, lbound);
11671 496 : cond3 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
11672 : stride, gfc_index_zero_node);
11673 496 : cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
11674 : logical_type_node, cond3, cond1);
11675 496 : cond4 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
11676 : stride, gfc_index_zero_node);
11677 496 : if (assumed_size)
11678 0 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
11679 : tmp, build_int_cst (gfc_array_index_type,
11680 0 : expr->rank - 1));
11681 : else
11682 496 : cond = logical_false_node;
11683 :
11684 496 : cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
11685 : logical_type_node, cond3, cond4);
11686 496 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
11687 : logical_type_node, cond, cond1);
11688 :
11689 496 : return fold_build3_loc (input_location, COND_EXPR,
11690 : gfc_array_index_type, cond,
11691 496 : lbound, gfc_index_one_node);
11692 : }
11693 :
11694 516 : if (expr->expr_type == EXPR_FUNCTION)
11695 : {
11696 : /* A conversion function, so use the argument. */
11697 7 : gcc_assert (expr->value.function.isym
11698 : && expr->value.function.isym->conversion);
11699 7 : expr = expr->value.function.actual->expr;
11700 : }
11701 :
11702 516 : if (expr->expr_type == EXPR_VARIABLE)
11703 : {
11704 516 : tmp = TREE_TYPE (expr->symtree->n.sym->backend_decl);
11705 1352 : for (ref = expr->ref; ref; ref = ref->next)
11706 : {
11707 836 : if (ref->type == REF_COMPONENT
11708 271 : && ref->u.c.component->as
11709 222 : && ref->next
11710 222 : && ref->next->u.ar.type == AR_FULL)
11711 180 : tmp = TREE_TYPE (ref->u.c.component->backend_decl);
11712 : }
11713 516 : return GFC_TYPE_ARRAY_LBOUND(tmp, dim);
11714 : }
11715 :
11716 0 : return gfc_index_one_node;
11717 : }
11718 :
11719 :
11720 : /* Returns true if an expression represents an lhs that can be reallocated
11721 : on assignment. */
11722 :
11723 : bool
11724 342800 : gfc_is_reallocatable_lhs (gfc_expr *expr)
11725 : {
11726 342800 : gfc_ref * ref;
11727 342800 : gfc_symbol *sym;
11728 :
11729 342800 : if (!flag_realloc_lhs)
11730 : return false;
11731 :
11732 342800 : if (!expr->ref)
11733 : return false;
11734 :
11735 121377 : sym = expr->symtree->n.sym;
11736 :
11737 121377 : if (sym->attr.associate_var && !expr->ref)
11738 : return false;
11739 :
11740 : /* An allocatable class variable with no reference. */
11741 121377 : if (sym->ts.type == BT_CLASS
11742 3649 : && (!sym->attr.associate_var || sym->attr.select_rank_temporary)
11743 3561 : && CLASS_DATA (sym)->attr.allocatable
11744 : && expr->ref
11745 2349 : && ((expr->ref->type == REF_ARRAY && expr->ref->u.ar.type == AR_FULL
11746 0 : && expr->ref->next == NULL)
11747 2349 : || (expr->ref->type == REF_COMPONENT
11748 2349 : && strcmp (expr->ref->u.c.component->name, "_data") == 0
11749 1985 : && (expr->ref->next == NULL
11750 1985 : || (expr->ref->next->type == REF_ARRAY
11751 1985 : && expr->ref->next->u.ar.type == AR_FULL
11752 1701 : && expr->ref->next->next == NULL)))))
11753 : return true;
11754 :
11755 : /* An allocatable variable. */
11756 119816 : if (sym->attr.allocatable
11757 29505 : && (!sym->attr.associate_var || sym->attr.select_rank_temporary)
11758 : && expr->ref
11759 29505 : && expr->ref->type == REF_ARRAY
11760 28674 : && expr->ref->u.ar.type == AR_FULL)
11761 : return true;
11762 :
11763 : /* All that can be left are allocatable components. */
11764 100604 : if (sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
11765 : return false;
11766 :
11767 : /* Find a component ref followed by an array reference. */
11768 49502 : for (ref = expr->ref; ref; ref = ref->next)
11769 35531 : if (ref->next
11770 21560 : && ref->type == REF_COMPONENT
11771 12918 : && ref->next->type == REF_ARRAY
11772 10665 : && !ref->next->next)
11773 : break;
11774 :
11775 21776 : if (!ref)
11776 : return false;
11777 :
11778 : /* Return true if valid reallocatable lhs. */
11779 7805 : if (ref->u.c.component->attr.allocatable
11780 4056 : && ref->next->u.ar.type == AR_FULL)
11781 3202 : return true;
11782 :
11783 : return false;
11784 : }
11785 :
11786 :
11787 : static tree
11788 56 : concat_str_length (gfc_expr* expr)
11789 : {
11790 56 : tree type;
11791 56 : tree len1;
11792 56 : tree len2;
11793 56 : gfc_se se;
11794 :
11795 56 : type = gfc_typenode_for_spec (&expr->value.op.op1->ts);
11796 56 : len1 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
11797 56 : if (len1 == NULL_TREE)
11798 : {
11799 56 : if (expr->value.op.op1->expr_type == EXPR_OP)
11800 31 : len1 = concat_str_length (expr->value.op.op1);
11801 25 : else if (expr->value.op.op1->expr_type == EXPR_CONSTANT)
11802 25 : len1 = build_int_cst (gfc_charlen_type_node,
11803 25 : expr->value.op.op1->value.character.length);
11804 0 : else if (expr->value.op.op1->ts.u.cl->length)
11805 : {
11806 0 : gfc_init_se (&se, NULL);
11807 0 : gfc_conv_expr (&se, expr->value.op.op1->ts.u.cl->length);
11808 0 : len1 = se.expr;
11809 : }
11810 : else
11811 : {
11812 : /* Last resort! */
11813 0 : gfc_init_se (&se, NULL);
11814 0 : se.want_pointer = 1;
11815 0 : se.descriptor_only = 1;
11816 0 : gfc_conv_expr (&se, expr->value.op.op1);
11817 0 : len1 = se.string_length;
11818 : }
11819 : }
11820 :
11821 56 : type = gfc_typenode_for_spec (&expr->value.op.op2->ts);
11822 56 : len2 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
11823 56 : if (len2 == NULL_TREE)
11824 : {
11825 31 : if (expr->value.op.op2->expr_type == EXPR_OP)
11826 0 : len2 = concat_str_length (expr->value.op.op2);
11827 31 : else if (expr->value.op.op2->expr_type == EXPR_CONSTANT)
11828 25 : len2 = build_int_cst (gfc_charlen_type_node,
11829 25 : expr->value.op.op2->value.character.length);
11830 6 : else if (expr->value.op.op2->ts.u.cl->length)
11831 : {
11832 6 : gfc_init_se (&se, NULL);
11833 6 : gfc_conv_expr (&se, expr->value.op.op2->ts.u.cl->length);
11834 6 : len2 = se.expr;
11835 : }
11836 : else
11837 : {
11838 : /* Last resort! */
11839 0 : gfc_init_se (&se, NULL);
11840 0 : se.want_pointer = 1;
11841 0 : se.descriptor_only = 1;
11842 0 : gfc_conv_expr (&se, expr->value.op.op2);
11843 0 : len2 = se.string_length;
11844 : }
11845 : }
11846 :
11847 56 : gcc_assert(len1 && len2);
11848 56 : len1 = fold_convert (gfc_charlen_type_node, len1);
11849 56 : len2 = fold_convert (gfc_charlen_type_node, len2);
11850 :
11851 56 : return fold_build2_loc (input_location, PLUS_EXPR,
11852 56 : gfc_charlen_type_node, len1, len2);
11853 : }
11854 :
11855 :
11856 : /* Among the scalarization chain of LOOP, find the element associated with an
11857 : allocatable array on the lhs of an assignment and evaluate its fields
11858 : (bounds, offset, etc) to new variables, putting the new code in BLOCK. This
11859 : function is to be called after putting the reallocation code in BLOCK and
11860 : before the beginning of the scalarization loop body.
11861 :
11862 : The fields to be saved are expected to hold on entry to the function
11863 : expressions referencing the array descriptor. Especially the expressions
11864 : shouldn't be already temporary variable references as the value saved before
11865 : reallocation would be incorrect after reallocation.
11866 : At the end of the function, the expressions have been replaced with variable
11867 : references. */
11868 :
11869 : static void
11870 6444 : update_reallocated_descriptor (stmtblock_t *block, gfc_loopinfo *loop)
11871 : {
11872 22556 : for (gfc_ss *s = loop->ss; s != gfc_ss_terminator; s = s->loop_chain)
11873 : {
11874 16112 : if (!s->is_alloc_lhs)
11875 9668 : continue;
11876 :
11877 6444 : gcc_assert (s->info->type == GFC_SS_SECTION);
11878 6444 : gfc_array_info *info = &s->info->data.array;
11879 :
11880 : #define SAVE_VALUE(value) \
11881 : do \
11882 : { \
11883 : value = gfc_evaluate_now (value, block); \
11884 : } \
11885 : while (0)
11886 :
11887 6444 : if (save_descriptor_data (info->descriptor, info->data))
11888 5658 : SAVE_VALUE (info->data);
11889 6444 : SAVE_VALUE (info->offset);
11890 6444 : info->saved_offset = info->offset;
11891 16093 : for (int i = 0; i < s->dimen; i++)
11892 : {
11893 9649 : int dim = s->dim[i];
11894 9649 : SAVE_VALUE (info->start[dim]);
11895 9649 : SAVE_VALUE (info->end[dim]);
11896 9649 : SAVE_VALUE (info->stride[dim]);
11897 9649 : SAVE_VALUE (info->delta[dim]);
11898 : }
11899 :
11900 : #undef SAVE_VALUE
11901 : }
11902 6444 : }
11903 :
11904 :
11905 : /* Allocate the lhs of an assignment to an allocatable array, otherwise
11906 : reallocate it. */
11907 :
11908 : tree
11909 6444 : gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
11910 : gfc_expr *expr1,
11911 : gfc_expr *expr2)
11912 : {
11913 6444 : stmtblock_t realloc_block;
11914 6444 : stmtblock_t alloc_block;
11915 6444 : stmtblock_t fblock;
11916 6444 : stmtblock_t loop_pre_block;
11917 6444 : gfc_ref *ref;
11918 6444 : gfc_ss *rss;
11919 6444 : gfc_ss *lss;
11920 6444 : gfc_array_info *linfo;
11921 6444 : tree realloc_expr;
11922 6444 : tree alloc_expr;
11923 6444 : tree size1;
11924 6444 : tree size2;
11925 6444 : tree elemsize1;
11926 6444 : tree elemsize2;
11927 6444 : tree array1;
11928 6444 : tree cond_null;
11929 6444 : tree cond;
11930 6444 : tree tmp;
11931 6444 : tree tmp2;
11932 6444 : tree lbound;
11933 6444 : tree ubound;
11934 6444 : tree desc;
11935 6444 : tree old_desc;
11936 6444 : tree desc2;
11937 6444 : tree offset;
11938 6444 : tree jump_label1;
11939 6444 : tree jump_label2;
11940 6444 : tree lbd;
11941 6444 : tree class_expr2 = NULL_TREE;
11942 6444 : int n;
11943 6444 : gfc_array_spec * as;
11944 6444 : bool coarray = (flag_coarray == GFC_FCOARRAY_LIB
11945 6444 : && gfc_caf_attr (expr1, true).codimension);
11946 6444 : tree token;
11947 6444 : gfc_se caf_se;
11948 :
11949 : /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
11950 : Find the lhs expression in the loop chain and set expr1 and
11951 : expr2 accordingly. */
11952 6444 : if (expr1->expr_type == EXPR_FUNCTION && expr2 == NULL)
11953 : {
11954 185 : expr2 = expr1;
11955 : /* Find the ss for the lhs. */
11956 185 : lss = loop->ss;
11957 370 : for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
11958 370 : if (lss->info->expr && lss->info->expr->expr_type == EXPR_VARIABLE)
11959 : break;
11960 185 : if (lss == gfc_ss_terminator)
11961 : return NULL_TREE;
11962 185 : expr1 = lss->info->expr;
11963 : }
11964 :
11965 : /* Bail out if this is not a valid allocate on assignment. */
11966 6444 : if (!gfc_is_reallocatable_lhs (expr1)
11967 6444 : || (expr2 && !expr2->rank))
11968 : return NULL_TREE;
11969 :
11970 : /* Find the ss for the lhs. */
11971 6444 : lss = loop->ss;
11972 16112 : for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
11973 16112 : if (lss->info->expr == expr1)
11974 : break;
11975 :
11976 6444 : if (lss == gfc_ss_terminator)
11977 : return NULL_TREE;
11978 :
11979 6444 : linfo = &lss->info->data.array;
11980 :
11981 : /* Find an ss for the rhs. For operator expressions, we see the
11982 : ss's for the operands. Any one of these will do. */
11983 6444 : rss = loop->ss;
11984 7010 : for (; rss && rss != gfc_ss_terminator; rss = rss->loop_chain)
11985 7010 : if (rss->info->expr != expr1 && rss != loop->temp_ss)
11986 : break;
11987 :
11988 6444 : if (expr2 && rss == gfc_ss_terminator)
11989 : return NULL_TREE;
11990 :
11991 : /* Ensure that the string length from the current scope is used. */
11992 6444 : if (expr2->ts.type == BT_CHARACTER
11993 983 : && expr2->expr_type == EXPR_FUNCTION
11994 130 : && !expr2->value.function.isym)
11995 21 : expr2->ts.u.cl->backend_decl = rss->info->string_length;
11996 :
11997 : /* Since the lhs is allocatable, this must be a descriptor type.
11998 : Get the data and array size. */
11999 6444 : desc = linfo->descriptor;
12000 6444 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
12001 6444 : array1 = gfc_conv_descriptor_data_get (desc);
12002 :
12003 : /* If the data is null, set the descriptor bounds and offset. This suppresses
12004 : the maybe used uninitialized warning. Note that the always false variable
12005 : prevents this block from ever being executed, and makes sure that the
12006 : optimizers are able to remove it. Component references are not subject to
12007 : the warnings, so we don't uselessly complicate the generated code for them.
12008 : */
12009 11536 : for (ref = expr1->ref; ref; ref = ref->next)
12010 6639 : if (ref->type == REF_COMPONENT)
12011 : break;
12012 :
12013 6444 : if (!ref)
12014 : {
12015 4897 : stmtblock_t unalloc_init_block;
12016 4897 : gfc_init_block (&unalloc_init_block);
12017 4897 : tree guard = gfc_create_var (logical_type_node, "unallocated_init_guard");
12018 4897 : gfc_add_modify (&unalloc_init_block, guard, logical_false_node);
12019 :
12020 4897 : gfc_start_block (&loop_pre_block);
12021 17539 : for (n = 0; n < expr1->rank; n++)
12022 : {
12023 7745 : gfc_conv_descriptor_lbound_set (&loop_pre_block, desc,
12024 : gfc_rank_cst[n],
12025 : gfc_index_one_node);
12026 7745 : gfc_conv_descriptor_ubound_set (&loop_pre_block, desc,
12027 : gfc_rank_cst[n],
12028 : gfc_index_zero_node);
12029 7745 : gfc_conv_descriptor_stride_set (&loop_pre_block, desc,
12030 : gfc_rank_cst[n],
12031 : gfc_index_zero_node);
12032 : }
12033 :
12034 4897 : gfc_conv_descriptor_offset_set (&loop_pre_block, desc,
12035 : gfc_index_zero_node);
12036 :
12037 4897 : tmp = fold_build2_loc (input_location, EQ_EXPR,
12038 : logical_type_node, array1,
12039 4897 : build_int_cst (TREE_TYPE (array1), 0));
12040 4897 : tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
12041 : logical_type_node, tmp, guard);
12042 4897 : tmp = build3_v (COND_EXPR, tmp,
12043 : gfc_finish_block (&loop_pre_block),
12044 : build_empty_stmt (input_location));
12045 4897 : gfc_prepend_expr_to_block (&loop->pre, tmp);
12046 4897 : gfc_prepend_expr_to_block (&loop->pre,
12047 : gfc_finish_block (&unalloc_init_block));
12048 : }
12049 :
12050 6444 : gfc_start_block (&fblock);
12051 :
12052 6444 : if (expr2)
12053 6444 : desc2 = rss->info->data.array.descriptor;
12054 : else
12055 : desc2 = NULL_TREE;
12056 :
12057 : /* Get the old lhs element size for deferred character and class expr1. */
12058 6444 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12059 : {
12060 663 : if (expr1->ts.u.cl->backend_decl
12061 663 : && VAR_P (expr1->ts.u.cl->backend_decl))
12062 : elemsize1 = expr1->ts.u.cl->backend_decl;
12063 : else
12064 64 : elemsize1 = lss->info->string_length;
12065 663 : tree unit_size = TYPE_SIZE_UNIT (gfc_get_char_type (expr1->ts.kind));
12066 1326 : elemsize1 = fold_build2_loc (input_location, MULT_EXPR,
12067 663 : TREE_TYPE (elemsize1), elemsize1,
12068 663 : fold_convert (TREE_TYPE (elemsize1), unit_size));
12069 :
12070 663 : }
12071 5781 : else if (expr1->ts.type == BT_CLASS)
12072 : {
12073 : /* Unfortunately, the lhs vptr is set too early in many cases.
12074 : Play it safe by using the descriptor element length. */
12075 633 : tmp = gfc_conv_descriptor_elem_len (desc);
12076 633 : elemsize1 = fold_convert (gfc_array_index_type, tmp);
12077 : }
12078 : else
12079 : elemsize1 = NULL_TREE;
12080 1296 : if (elemsize1 != NULL_TREE)
12081 1296 : elemsize1 = gfc_evaluate_now (elemsize1, &fblock);
12082 :
12083 : /* Get the new lhs size in bytes. */
12084 6444 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12085 : {
12086 663 : if (expr2->ts.deferred)
12087 : {
12088 183 : if (expr2->ts.u.cl->backend_decl
12089 183 : && VAR_P (expr2->ts.u.cl->backend_decl))
12090 : tmp = expr2->ts.u.cl->backend_decl;
12091 : else
12092 0 : tmp = rss->info->string_length;
12093 : }
12094 : else
12095 : {
12096 480 : tmp = expr2->ts.u.cl->backend_decl;
12097 480 : if (!tmp && expr2->expr_type == EXPR_OP
12098 25 : && expr2->value.op.op == INTRINSIC_CONCAT)
12099 : {
12100 25 : tmp = concat_str_length (expr2);
12101 25 : expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
12102 : }
12103 12 : else if (!tmp && expr2->ts.u.cl->length)
12104 : {
12105 12 : gfc_se tmpse;
12106 12 : gfc_init_se (&tmpse, NULL);
12107 12 : gfc_conv_expr_type (&tmpse, expr2->ts.u.cl->length,
12108 : gfc_charlen_type_node);
12109 12 : tmp = tmpse.expr;
12110 12 : expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
12111 : }
12112 480 : tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
12113 : }
12114 :
12115 663 : if (expr1->ts.u.cl->backend_decl
12116 663 : && VAR_P (expr1->ts.u.cl->backend_decl))
12117 599 : gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
12118 : else
12119 64 : gfc_add_modify (&fblock, lss->info->string_length, tmp);
12120 :
12121 663 : if (expr1->ts.kind > 1)
12122 12 : tmp = fold_build2_loc (input_location, MULT_EXPR,
12123 6 : TREE_TYPE (tmp),
12124 6 : tmp, build_int_cst (TREE_TYPE (tmp),
12125 6 : expr1->ts.kind));
12126 : }
12127 5781 : else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
12128 : {
12129 271 : tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts)));
12130 271 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
12131 : fold_convert (gfc_array_index_type, tmp),
12132 271 : expr1->ts.u.cl->backend_decl);
12133 : }
12134 5510 : else if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS)
12135 164 : tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
12136 5346 : else if (expr1->ts.type == BT_CLASS && expr2->ts.type == BT_CLASS)
12137 : {
12138 274 : tmp = expr2->rank ? gfc_get_class_from_expr (desc2) : NULL_TREE;
12139 274 : if (tmp == NULL_TREE && expr2->expr_type == EXPR_VARIABLE)
12140 30 : tmp = class_expr2 = gfc_get_class_from_gfc_expr (expr2);
12141 :
12142 37 : if (tmp != NULL_TREE)
12143 267 : tmp = gfc_class_vtab_size_get (tmp);
12144 : else
12145 7 : tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&CLASS_DATA (expr2)->ts));
12146 : }
12147 : else
12148 5072 : tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
12149 6444 : elemsize2 = fold_convert (gfc_array_index_type, tmp);
12150 6444 : elemsize2 = gfc_evaluate_now (elemsize2, &fblock);
12151 :
12152 : /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
12153 : deallocated if expr is an array of different shape or any of the
12154 : corresponding length type parameter values of variable and expr
12155 : differ." This assures F95 compatibility. */
12156 6444 : jump_label1 = gfc_build_label_decl (NULL_TREE);
12157 6444 : jump_label2 = gfc_build_label_decl (NULL_TREE);
12158 :
12159 : /* Allocate if data is NULL. */
12160 6444 : cond_null = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
12161 6444 : array1, build_int_cst (TREE_TYPE (array1), 0));
12162 6444 : cond_null= gfc_evaluate_now (cond_null, &fblock);
12163 :
12164 6444 : tmp = build3_v (COND_EXPR, cond_null,
12165 : build1_v (GOTO_EXPR, jump_label1),
12166 : build_empty_stmt (input_location));
12167 6444 : gfc_add_expr_to_block (&fblock, tmp);
12168 :
12169 : /* Get arrayspec if expr is a full array. */
12170 6444 : if (expr2 && expr2->expr_type == EXPR_FUNCTION
12171 2772 : && expr2->value.function.isym
12172 2295 : && expr2->value.function.isym->conversion)
12173 : {
12174 : /* For conversion functions, take the arg. */
12175 245 : gfc_expr *arg = expr2->value.function.actual->expr;
12176 245 : as = gfc_get_full_arrayspec_from_expr (arg);
12177 245 : }
12178 : else if (expr2)
12179 6199 : as = gfc_get_full_arrayspec_from_expr (expr2);
12180 : else
12181 : as = NULL;
12182 :
12183 : /* If the lhs shape is not the same as the rhs jump to setting the
12184 : bounds and doing the reallocation....... */
12185 16093 : for (n = 0; n < expr1->rank; n++)
12186 : {
12187 : /* Check the shape. */
12188 9649 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
12189 9649 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
12190 9649 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
12191 : gfc_array_index_type,
12192 : loop->to[n], loop->from[n]);
12193 9649 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
12194 : gfc_array_index_type,
12195 : tmp, lbound);
12196 9649 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
12197 : gfc_array_index_type,
12198 : tmp, ubound);
12199 9649 : cond = fold_build2_loc (input_location, NE_EXPR,
12200 : logical_type_node,
12201 : tmp, gfc_index_zero_node);
12202 9649 : tmp = build3_v (COND_EXPR, cond,
12203 : build1_v (GOTO_EXPR, jump_label1),
12204 : build_empty_stmt (input_location));
12205 9649 : gfc_add_expr_to_block (&fblock, tmp);
12206 : }
12207 :
12208 : /* ...else if the element lengths are not the same also go to
12209 : setting the bounds and doing the reallocation.... */
12210 6444 : if (elemsize1 != NULL_TREE)
12211 : {
12212 1296 : cond = fold_build2_loc (input_location, NE_EXPR,
12213 : logical_type_node,
12214 : elemsize1, elemsize2);
12215 1296 : tmp = build3_v (COND_EXPR, cond,
12216 : build1_v (GOTO_EXPR, jump_label1),
12217 : build_empty_stmt (input_location));
12218 1296 : gfc_add_expr_to_block (&fblock, tmp);
12219 : }
12220 :
12221 : /* ....else jump past the (re)alloc code. */
12222 6444 : tmp = build1_v (GOTO_EXPR, jump_label2);
12223 6444 : gfc_add_expr_to_block (&fblock, tmp);
12224 :
12225 : /* Add the label to start automatic (re)allocation. */
12226 6444 : tmp = build1_v (LABEL_EXPR, jump_label1);
12227 6444 : gfc_add_expr_to_block (&fblock, tmp);
12228 :
12229 : /* Get the rhs size and fix it. */
12230 6444 : size2 = gfc_index_one_node;
12231 16093 : for (n = 0; n < expr2->rank; n++)
12232 : {
12233 9649 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
12234 : gfc_array_index_type,
12235 : loop->to[n], loop->from[n]);
12236 9649 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
12237 : gfc_array_index_type,
12238 : tmp, gfc_index_one_node);
12239 9649 : size2 = fold_build2_loc (input_location, MULT_EXPR,
12240 : gfc_array_index_type,
12241 : tmp, size2);
12242 : }
12243 6444 : size2 = gfc_evaluate_now (size2, &fblock);
12244 :
12245 : /* Deallocation of allocatable components will have to occur on
12246 : reallocation. Fix the old descriptor now. */
12247 6444 : if ((expr1->ts.type == BT_DERIVED)
12248 356 : && expr1->ts.u.derived->attr.alloc_comp)
12249 133 : old_desc = gfc_evaluate_now (desc, &fblock);
12250 : else
12251 : old_desc = NULL_TREE;
12252 :
12253 : /* Now modify the lhs descriptor and the associated scalarizer
12254 : variables. F2003 7.4.1.3: "If variable is or becomes an
12255 : unallocated allocatable variable, then it is allocated with each
12256 : deferred type parameter equal to the corresponding type parameters
12257 : of expr , with the shape of expr , and with each lower bound equal
12258 : to the corresponding element of LBOUND(expr)."
12259 : Reuse size1 to keep a dimension-by-dimension track of the
12260 : stride of the new array. */
12261 6444 : size1 = gfc_index_one_node;
12262 6444 : offset = gfc_index_zero_node;
12263 :
12264 16093 : for (n = 0; n < expr2->rank; n++)
12265 : {
12266 9649 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
12267 : gfc_array_index_type,
12268 : loop->to[n], loop->from[n]);
12269 9649 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
12270 : gfc_array_index_type,
12271 : tmp, gfc_index_one_node);
12272 :
12273 9649 : lbound = gfc_index_one_node;
12274 9649 : ubound = tmp;
12275 :
12276 9649 : if (as)
12277 : {
12278 2024 : lbd = get_std_lbound (expr2, desc2, n,
12279 1012 : as->type == AS_ASSUMED_SIZE);
12280 1012 : ubound = fold_build2_loc (input_location,
12281 : MINUS_EXPR,
12282 : gfc_array_index_type,
12283 : ubound, lbound);
12284 1012 : ubound = fold_build2_loc (input_location,
12285 : PLUS_EXPR,
12286 : gfc_array_index_type,
12287 : ubound, lbd);
12288 1012 : lbound = lbd;
12289 : }
12290 :
12291 9649 : gfc_conv_descriptor_lbound_set (&fblock, desc,
12292 : gfc_rank_cst[n],
12293 : lbound);
12294 9649 : gfc_conv_descriptor_ubound_set (&fblock, desc,
12295 : gfc_rank_cst[n],
12296 : ubound);
12297 9649 : gfc_conv_descriptor_stride_set (&fblock, desc,
12298 : gfc_rank_cst[n],
12299 : size1);
12300 9649 : lbound = gfc_conv_descriptor_lbound_get (desc,
12301 : gfc_rank_cst[n]);
12302 9649 : tmp2 = fold_build2_loc (input_location, MULT_EXPR,
12303 : gfc_array_index_type,
12304 : lbound, size1);
12305 9649 : offset = fold_build2_loc (input_location, MINUS_EXPR,
12306 : gfc_array_index_type,
12307 : offset, tmp2);
12308 9649 : size1 = fold_build2_loc (input_location, MULT_EXPR,
12309 : gfc_array_index_type,
12310 : tmp, size1);
12311 : }
12312 :
12313 : /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
12314 : the array offset is saved and the info.offset is used for a
12315 : running offset. Use the saved_offset instead. */
12316 6444 : tmp = gfc_conv_descriptor_offset (desc);
12317 6444 : gfc_add_modify (&fblock, tmp, offset);
12318 :
12319 : /* Take into account _len of unlimited polymorphic entities, so that span
12320 : for array descriptors and allocation sizes are computed correctly. */
12321 6444 : if (UNLIMITED_POLY (expr2))
12322 : {
12323 92 : tree len = gfc_class_len_get (TREE_OPERAND (desc2, 0));
12324 92 : len = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
12325 : fold_convert (size_type_node, len),
12326 : size_one_node);
12327 92 : elemsize2 = fold_build2_loc (input_location, MULT_EXPR,
12328 : gfc_array_index_type, elemsize2,
12329 : fold_convert (gfc_array_index_type, len));
12330 : }
12331 :
12332 6444 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
12333 6444 : gfc_conv_descriptor_span_set (&fblock, desc, elemsize2);
12334 :
12335 6444 : size2 = fold_build2_loc (input_location, MULT_EXPR,
12336 : gfc_array_index_type,
12337 : elemsize2, size2);
12338 6444 : size2 = fold_convert (size_type_node, size2);
12339 6444 : size2 = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
12340 : size2, size_one_node);
12341 6444 : size2 = gfc_evaluate_now (size2, &fblock);
12342 :
12343 : /* For deferred character length, the 'size' field of the dtype might
12344 : have changed so set the dtype. */
12345 6444 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
12346 6444 : && expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12347 : {
12348 663 : tree type;
12349 663 : tmp = gfc_conv_descriptor_dtype (desc);
12350 663 : if (expr2->ts.u.cl->backend_decl)
12351 663 : type = gfc_typenode_for_spec (&expr2->ts);
12352 : else
12353 0 : type = gfc_typenode_for_spec (&expr1->ts);
12354 :
12355 663 : gfc_add_modify (&fblock, tmp,
12356 : gfc_get_dtype_rank_type (expr1->rank,type));
12357 : }
12358 5781 : else if (expr1->ts.type == BT_CLASS)
12359 : {
12360 633 : tree type;
12361 633 : tmp = gfc_conv_descriptor_dtype (desc);
12362 :
12363 633 : if (expr2->ts.type != BT_CLASS)
12364 359 : type = gfc_typenode_for_spec (&expr2->ts);
12365 : else
12366 274 : type = gfc_get_character_type_len (1, elemsize2);
12367 :
12368 633 : gfc_add_modify (&fblock, tmp,
12369 : gfc_get_dtype_rank_type (expr2->rank,type));
12370 : /* Set the _len field as well... */
12371 633 : if (UNLIMITED_POLY (expr1))
12372 : {
12373 256 : tmp = gfc_class_len_get (TREE_OPERAND (desc, 0));
12374 256 : if (expr2->ts.type == BT_CHARACTER)
12375 49 : gfc_add_modify (&fblock, tmp,
12376 49 : fold_convert (TREE_TYPE (tmp),
12377 : TYPE_SIZE_UNIT (type)));
12378 207 : else if (UNLIMITED_POLY (expr2))
12379 92 : gfc_add_modify (&fblock, tmp,
12380 92 : gfc_class_len_get (TREE_OPERAND (desc2, 0)));
12381 : else
12382 115 : gfc_add_modify (&fblock, tmp,
12383 115 : build_int_cst (TREE_TYPE (tmp), 0));
12384 : }
12385 : /* ...and the vptr. */
12386 633 : tmp = gfc_class_vptr_get (TREE_OPERAND (desc, 0));
12387 633 : if (expr2->ts.type == BT_CLASS && !VAR_P (desc2)
12388 267 : && TREE_CODE (desc2) == COMPONENT_REF)
12389 : {
12390 237 : tmp2 = gfc_get_class_from_expr (desc2);
12391 237 : tmp2 = gfc_class_vptr_get (tmp2);
12392 : }
12393 396 : else if (expr2->ts.type == BT_CLASS && class_expr2 != NULL_TREE)
12394 30 : tmp2 = gfc_class_vptr_get (class_expr2);
12395 : else
12396 : {
12397 366 : tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts));
12398 366 : tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2);
12399 : }
12400 :
12401 633 : gfc_add_modify (&fblock, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
12402 : }
12403 5148 : else if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
12404 : {
12405 39 : gfc_add_modify (&fblock, gfc_conv_descriptor_dtype (desc),
12406 39 : gfc_get_dtype (TREE_TYPE (desc)));
12407 : }
12408 :
12409 : /* Realloc expression. Note that the scalarizer uses desc.data
12410 : in the array reference - (*desc.data)[<element>]. */
12411 6444 : gfc_init_block (&realloc_block);
12412 6444 : gfc_init_se (&caf_se, NULL);
12413 :
12414 6444 : if (coarray)
12415 : {
12416 39 : token = gfc_get_ultimate_alloc_ptr_comps_caf_token (&caf_se, expr1);
12417 39 : if (token == NULL_TREE)
12418 : {
12419 9 : tmp = gfc_get_tree_for_caf_expr (expr1);
12420 9 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
12421 6 : tmp = build_fold_indirect_ref (tmp);
12422 9 : gfc_get_caf_token_offset (&caf_se, &token, NULL, tmp, NULL_TREE,
12423 : expr1);
12424 9 : token = gfc_build_addr_expr (NULL_TREE, token);
12425 : }
12426 :
12427 39 : gfc_add_block_to_block (&realloc_block, &caf_se.pre);
12428 : }
12429 6444 : if ((expr1->ts.type == BT_DERIVED)
12430 356 : && expr1->ts.u.derived->attr.alloc_comp)
12431 : {
12432 133 : tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, old_desc,
12433 : expr1->rank, true);
12434 133 : gfc_add_expr_to_block (&realloc_block, tmp);
12435 : }
12436 :
12437 6444 : if (!coarray)
12438 : {
12439 6405 : tmp = build_call_expr_loc (input_location,
12440 : builtin_decl_explicit (BUILT_IN_REALLOC), 2,
12441 : fold_convert (pvoid_type_node, array1),
12442 : size2);
12443 6405 : if (flag_openmp_allocators)
12444 : {
12445 2 : tree cond, omp_tmp;
12446 2 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
12447 : gfc_conv_descriptor_version (desc),
12448 : build_int_cst (integer_type_node, 1));
12449 2 : omp_tmp = builtin_decl_explicit (BUILT_IN_GOMP_REALLOC);
12450 2 : omp_tmp = build_call_expr_loc (input_location, omp_tmp, 4,
12451 : fold_convert (pvoid_type_node, array1), size2,
12452 : build_zero_cst (ptr_type_node),
12453 : build_zero_cst (ptr_type_node));
12454 2 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond,
12455 : omp_tmp, tmp);
12456 : }
12457 :
12458 6405 : gfc_conv_descriptor_data_set (&realloc_block, desc, tmp);
12459 : }
12460 : else
12461 : {
12462 39 : tmp = build_call_expr_loc (input_location,
12463 : gfor_fndecl_caf_deregister, 5, token,
12464 : build_int_cst (integer_type_node,
12465 : GFC_CAF_COARRAY_DEALLOCATE_ONLY),
12466 : null_pointer_node, null_pointer_node,
12467 : integer_zero_node);
12468 39 : gfc_add_expr_to_block (&realloc_block, tmp);
12469 39 : tmp = build_call_expr_loc (input_location,
12470 : gfor_fndecl_caf_register,
12471 : 7, size2,
12472 : build_int_cst (integer_type_node,
12473 : GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY),
12474 : token, gfc_build_addr_expr (NULL_TREE, desc),
12475 : null_pointer_node, null_pointer_node,
12476 : integer_zero_node);
12477 39 : gfc_add_expr_to_block (&realloc_block, tmp);
12478 : }
12479 :
12480 6444 : if ((expr1->ts.type == BT_DERIVED)
12481 356 : && expr1->ts.u.derived->attr.alloc_comp)
12482 : {
12483 133 : tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc,
12484 : expr1->rank);
12485 133 : gfc_add_expr_to_block (&realloc_block, tmp);
12486 : }
12487 :
12488 6444 : gfc_add_block_to_block (&realloc_block, &caf_se.post);
12489 6444 : realloc_expr = gfc_finish_block (&realloc_block);
12490 :
12491 : /* Malloc expression. */
12492 6444 : gfc_init_block (&alloc_block);
12493 6444 : if (!coarray)
12494 : {
12495 6405 : tmp = build_call_expr_loc (input_location,
12496 : builtin_decl_explicit (BUILT_IN_MALLOC),
12497 : 1, size2);
12498 6405 : gfc_conv_descriptor_data_set (&alloc_block,
12499 : desc, tmp);
12500 : }
12501 : else
12502 : {
12503 39 : tmp = build_call_expr_loc (input_location,
12504 : gfor_fndecl_caf_register,
12505 : 7, size2,
12506 : build_int_cst (integer_type_node,
12507 : GFC_CAF_COARRAY_ALLOC),
12508 : token, gfc_build_addr_expr (NULL_TREE, desc),
12509 : null_pointer_node, null_pointer_node,
12510 : integer_zero_node);
12511 39 : gfc_add_expr_to_block (&alloc_block, tmp);
12512 : }
12513 :
12514 :
12515 : /* We already set the dtype in the case of deferred character
12516 : length arrays and class lvalues. */
12517 6444 : if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
12518 6444 : && ((expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12519 5781 : || coarray))
12520 12186 : && expr1->ts.type != BT_CLASS)
12521 : {
12522 5109 : tmp = gfc_conv_descriptor_dtype (desc);
12523 5109 : gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
12524 : }
12525 :
12526 6444 : if ((expr1->ts.type == BT_DERIVED)
12527 356 : && expr1->ts.u.derived->attr.alloc_comp)
12528 : {
12529 133 : tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc,
12530 : expr1->rank);
12531 133 : gfc_add_expr_to_block (&alloc_block, tmp);
12532 : }
12533 6444 : alloc_expr = gfc_finish_block (&alloc_block);
12534 :
12535 : /* Malloc if not allocated; realloc otherwise. */
12536 6444 : tmp = build3_v (COND_EXPR, cond_null, alloc_expr, realloc_expr);
12537 6444 : gfc_add_expr_to_block (&fblock, tmp);
12538 :
12539 : /* Add the label for same shape lhs and rhs. */
12540 6444 : tmp = build1_v (LABEL_EXPR, jump_label2);
12541 6444 : gfc_add_expr_to_block (&fblock, tmp);
12542 :
12543 6444 : tree realloc_code = gfc_finish_block (&fblock);
12544 :
12545 6444 : stmtblock_t result_block;
12546 6444 : gfc_init_block (&result_block);
12547 6444 : gfc_add_expr_to_block (&result_block, realloc_code);
12548 6444 : update_reallocated_descriptor (&result_block, loop);
12549 :
12550 6444 : return gfc_finish_block (&result_block);
12551 : }
12552 :
12553 :
12554 : /* Initialize class descriptor's TKR information. */
12555 :
12556 : void
12557 2889 : gfc_trans_class_array (gfc_symbol * sym, gfc_wrapped_block * block)
12558 : {
12559 2889 : tree type, etype;
12560 2889 : tree tmp;
12561 2889 : tree descriptor;
12562 2889 : stmtblock_t init;
12563 2889 : int rank;
12564 :
12565 : /* Make sure the frontend gets these right. */
12566 2889 : gcc_assert (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
12567 : && (CLASS_DATA (sym)->attr.class_pointer
12568 : || CLASS_DATA (sym)->attr.allocatable));
12569 :
12570 2889 : gcc_assert (VAR_P (sym->backend_decl)
12571 : || TREE_CODE (sym->backend_decl) == PARM_DECL);
12572 :
12573 2889 : if (sym->attr.dummy)
12574 1418 : return;
12575 :
12576 2889 : descriptor = gfc_class_data_get (sym->backend_decl);
12577 2889 : type = TREE_TYPE (descriptor);
12578 :
12579 2889 : if (type == NULL || !GFC_DESCRIPTOR_TYPE_P (type))
12580 : return;
12581 :
12582 1471 : location_t loc = input_location;
12583 1471 : input_location = gfc_get_location (&sym->declared_at);
12584 1471 : gfc_init_block (&init);
12585 :
12586 1471 : rank = CLASS_DATA (sym)->as ? (CLASS_DATA (sym)->as->rank) : (0);
12587 1471 : gcc_assert (rank>=0);
12588 1471 : tmp = gfc_conv_descriptor_dtype (descriptor);
12589 1471 : etype = gfc_get_element_type (type);
12590 1471 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (tmp), tmp,
12591 : gfc_get_dtype_rank_type (rank, etype));
12592 1471 : gfc_add_expr_to_block (&init, tmp);
12593 :
12594 1471 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
12595 1471 : input_location = loc;
12596 : }
12597 :
12598 :
12599 : /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
12600 : Do likewise, recursively if necessary, with the allocatable components of
12601 : derived types. This function is also called for assumed-rank arrays, which
12602 : are always dummy arguments. */
12603 :
12604 : void
12605 17676 : gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
12606 : {
12607 17676 : tree type;
12608 17676 : tree tmp;
12609 17676 : tree descriptor;
12610 17676 : stmtblock_t init;
12611 17676 : stmtblock_t cleanup;
12612 17676 : int rank;
12613 17676 : bool sym_has_alloc_comp, has_finalizer;
12614 :
12615 35352 : sym_has_alloc_comp = (sym->ts.type == BT_DERIVED
12616 10875 : || sym->ts.type == BT_CLASS)
12617 17676 : && sym->ts.u.derived->attr.alloc_comp;
12618 17676 : has_finalizer = gfc_may_be_finalized (sym->ts);
12619 :
12620 : /* Make sure the frontend gets these right. */
12621 17676 : gcc_assert (sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp
12622 : || has_finalizer
12623 : || (sym->as->type == AS_ASSUMED_RANK && sym->attr.dummy));
12624 :
12625 17676 : location_t loc = input_location;
12626 17676 : input_location = gfc_get_location (&sym->declared_at);
12627 17676 : gfc_init_block (&init);
12628 :
12629 17676 : gcc_assert (VAR_P (sym->backend_decl)
12630 : || TREE_CODE (sym->backend_decl) == PARM_DECL);
12631 :
12632 17676 : if (sym->ts.type == BT_CHARACTER
12633 1390 : && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
12634 : {
12635 812 : if (sym->ts.deferred && !sym->ts.u.cl->length && !sym->attr.dummy)
12636 : {
12637 607 : tree len_expr = sym->ts.u.cl->backend_decl;
12638 607 : tree init_val = build_zero_cst (TREE_TYPE (len_expr));
12639 607 : if (VAR_P (len_expr)
12640 607 : && sym->attr.save
12641 662 : && !DECL_INITIAL (len_expr))
12642 55 : DECL_INITIAL (len_expr) = init_val;
12643 : else
12644 552 : gfc_add_modify (&init, len_expr, init_val);
12645 : }
12646 812 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
12647 812 : gfc_trans_vla_type_sizes (sym, &init);
12648 :
12649 : /* Presence check of optional deferred-length character dummy. */
12650 812 : if (sym->ts.deferred && sym->attr.dummy && sym->attr.optional)
12651 : {
12652 43 : tmp = gfc_finish_block (&init);
12653 43 : tmp = build3_v (COND_EXPR, gfc_conv_expr_present (sym),
12654 : tmp, build_empty_stmt (input_location));
12655 43 : gfc_add_expr_to_block (&init, tmp);
12656 : }
12657 : }
12658 :
12659 : /* Dummy, use associated and result variables don't need anything special. */
12660 17676 : if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result)
12661 : {
12662 828 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
12663 828 : input_location = loc;
12664 1107 : return;
12665 : }
12666 :
12667 16848 : descriptor = sym->backend_decl;
12668 :
12669 : /* Although static, derived types with default initializers and
12670 : allocatable components must not be nulled wholesale; instead they
12671 : are treated component by component. */
12672 16848 : if (TREE_STATIC (descriptor) && !sym_has_alloc_comp && !has_finalizer)
12673 : {
12674 : /* SAVEd variables are not freed on exit. */
12675 279 : gfc_trans_static_array_pointer (sym);
12676 :
12677 279 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
12678 279 : input_location = loc;
12679 279 : return;
12680 : }
12681 :
12682 : /* Get the descriptor type. */
12683 16569 : type = TREE_TYPE (sym->backend_decl);
12684 :
12685 16569 : if ((sym_has_alloc_comp || (has_finalizer && sym->ts.type != BT_CLASS))
12686 5275 : && !(sym->attr.pointer || sym->attr.allocatable))
12687 : {
12688 2806 : if (!sym->attr.save
12689 2421 : && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program))
12690 : {
12691 2421 : if (sym->value == NULL
12692 2421 : || !gfc_has_default_initializer (sym->ts.u.derived))
12693 : {
12694 2002 : rank = sym->as ? sym->as->rank : 0;
12695 2002 : tmp = gfc_nullify_alloc_comp (sym->ts.u.derived,
12696 : descriptor, rank);
12697 2002 : gfc_add_expr_to_block (&init, tmp);
12698 : }
12699 : else
12700 419 : gfc_init_default_dt (sym, &init, false);
12701 : }
12702 : }
12703 13763 : else if (!GFC_DESCRIPTOR_TYPE_P (type))
12704 : {
12705 : /* If the backend_decl is not a descriptor, we must have a pointer
12706 : to one. */
12707 1955 : descriptor = build_fold_indirect_ref_loc (input_location,
12708 : sym->backend_decl);
12709 1955 : type = TREE_TYPE (descriptor);
12710 : }
12711 :
12712 : /* NULLIFY the data pointer for non-saved allocatables, or for non-saved
12713 : pointers when -fcheck=pointer is specified. */
12714 28377 : if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save
12715 28364 : && (sym->attr.allocatable
12716 3275 : || (sym->attr.pointer && (gfc_option.rtcheck & GFC_RTCHECK_POINTER))))
12717 : {
12718 8563 : gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node);
12719 8563 : if (flag_coarray == GFC_FCOARRAY_LIB && sym->attr.codimension)
12720 : {
12721 : /* Declare the variable static so its array descriptor stays present
12722 : after leaving the scope. It may still be accessed through another
12723 : image. This may happen, for example, with the caf_mpi
12724 : implementation. */
12725 159 : TREE_STATIC (descriptor) = 1;
12726 159 : tmp = gfc_conv_descriptor_token (descriptor);
12727 159 : gfc_add_modify (&init, tmp, fold_convert (TREE_TYPE (tmp),
12728 : null_pointer_node));
12729 : }
12730 : }
12731 :
12732 : /* Set initial TKR for pointers and allocatables */
12733 16569 : if (GFC_DESCRIPTOR_TYPE_P (type)
12734 16569 : && (sym->attr.pointer || sym->attr.allocatable))
12735 : {
12736 11808 : tree etype;
12737 :
12738 11808 : gcc_assert (sym->as && sym->as->rank>=0);
12739 11808 : tmp = gfc_conv_descriptor_dtype (descriptor);
12740 11808 : etype = gfc_get_element_type (type);
12741 11808 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
12742 11808 : TREE_TYPE (tmp), tmp,
12743 11808 : gfc_get_dtype_rank_type (sym->as->rank, etype));
12744 11808 : gfc_add_expr_to_block (&init, tmp);
12745 : }
12746 16569 : input_location = loc;
12747 16569 : gfc_init_block (&cleanup);
12748 :
12749 : /* Allocatable arrays need to be freed when they go out of scope.
12750 : The allocatable components of pointers must not be touched. */
12751 16569 : if (!sym->attr.allocatable && has_finalizer && sym->ts.type != BT_CLASS
12752 574 : && !sym->attr.pointer && !sym->attr.artificial && !sym->attr.save
12753 303 : && !sym->ns->proc_name->attr.is_main_program)
12754 : {
12755 264 : gfc_expr *e;
12756 264 : sym->attr.referenced = 1;
12757 264 : e = gfc_lval_expr_from_sym (sym);
12758 264 : gfc_add_finalizer_call (&cleanup, e);
12759 264 : gfc_free_expr (e);
12760 264 : }
12761 16305 : else if ((!sym->attr.allocatable || !has_finalizer)
12762 16181 : && sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
12763 4736 : && !sym->attr.pointer && !sym->attr.save
12764 2370 : && !(sym->attr.artificial && sym->name[0] == '_')
12765 2315 : && !sym->ns->proc_name->attr.is_main_program)
12766 : {
12767 644 : int rank;
12768 644 : rank = sym->as ? sym->as->rank : 0;
12769 644 : tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank,
12770 644 : (sym->attr.codimension
12771 3 : && flag_coarray == GFC_FCOARRAY_LIB)
12772 : ? GFC_STRUCTURE_CAF_MODE_IN_COARRAY
12773 : : 0);
12774 644 : gfc_add_expr_to_block (&cleanup, tmp);
12775 : }
12776 :
12777 16569 : if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension)
12778 8527 : && !sym->attr.save && !sym->attr.result
12779 8520 : && !sym->ns->proc_name->attr.is_main_program)
12780 : {
12781 4482 : gfc_expr *e;
12782 4482 : e = has_finalizer ? gfc_lval_expr_from_sym (sym) : NULL;
12783 8964 : tmp = gfc_deallocate_with_status (sym->backend_decl, NULL_TREE, NULL_TREE,
12784 : NULL_TREE, NULL_TREE, true, e,
12785 4482 : sym->attr.codimension
12786 : ? GFC_CAF_COARRAY_DEREGISTER
12787 : : GFC_CAF_COARRAY_NOCOARRAY,
12788 : NULL_TREE, gfc_finish_block (&cleanup));
12789 4482 : if (e)
12790 45 : gfc_free_expr (e);
12791 4482 : gfc_init_block (&cleanup);
12792 4482 : gfc_add_expr_to_block (&cleanup, tmp);
12793 : }
12794 :
12795 16569 : gfc_add_init_cleanup (block, gfc_finish_block (&init),
12796 : gfc_finish_block (&cleanup));
12797 : }
12798 :
12799 : /************ Expression Walking Functions ******************/
12800 :
12801 : /* Walk a variable reference.
12802 :
12803 : Possible extension - multiple component subscripts.
12804 : x(:,:) = foo%a(:)%b(:)
12805 : Transforms to
12806 : forall (i=..., j=...)
12807 : x(i,j) = foo%a(j)%b(i)
12808 : end forall
12809 : This adds a fair amount of complexity because you need to deal with more
12810 : than one ref. Maybe handle in a similar manner to vector subscripts.
12811 : Maybe not worth the effort. */
12812 :
12813 :
12814 : static gfc_ss *
12815 677181 : gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
12816 : {
12817 677181 : gfc_ref *ref;
12818 :
12819 677181 : gfc_fix_class_refs (expr);
12820 :
12821 790808 : for (ref = expr->ref; ref; ref = ref->next)
12822 437647 : if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
12823 : break;
12824 :
12825 677181 : return gfc_walk_array_ref (ss, expr, ref);
12826 : }
12827 :
12828 : gfc_ss *
12829 677538 : gfc_walk_array_ref (gfc_ss *ss, gfc_expr *expr, gfc_ref *ref, bool array_only)
12830 : {
12831 677538 : gfc_array_ref *ar;
12832 677538 : gfc_ss *newss;
12833 677538 : int n;
12834 :
12835 1010142 : for (; ref; ref = ref->next)
12836 : {
12837 332604 : if (ref->type == REF_SUBSTRING)
12838 : {
12839 1314 : ss = gfc_get_scalar_ss (ss, ref->u.ss.start);
12840 1314 : if (ref->u.ss.end)
12841 1288 : ss = gfc_get_scalar_ss (ss, ref->u.ss.end);
12842 : }
12843 :
12844 : /* We're only interested in array sections from now on. */
12845 332604 : if (ref->type != REF_ARRAY
12846 324787 : || (array_only && ref->u.ar.as && ref->u.ar.as->rank == 0))
12847 7928 : continue;
12848 :
12849 324676 : ar = &ref->u.ar;
12850 :
12851 324676 : switch (ar->type)
12852 : {
12853 326 : case AR_ELEMENT:
12854 699 : for (n = ar->dimen - 1; n >= 0; n--)
12855 373 : ss = gfc_get_scalar_ss (ss, ar->start[n]);
12856 : break;
12857 :
12858 268838 : case AR_FULL:
12859 : /* Assumed shape arrays from interface mapping need this fix. */
12860 268838 : if (!ar->as && expr->symtree->n.sym->as)
12861 : {
12862 6 : ar->as = gfc_get_array_spec();
12863 6 : *ar->as = *expr->symtree->n.sym->as;
12864 : }
12865 268838 : newss = gfc_get_array_ss (ss, expr, ar->as->rank, GFC_SS_SECTION);
12866 268838 : newss->info->data.array.ref = ref;
12867 :
12868 : /* Make sure array is the same as array(:,:), this way
12869 : we don't need to special case all the time. */
12870 268838 : ar->dimen = ar->as->rank;
12871 621498 : for (n = 0; n < ar->dimen; n++)
12872 : {
12873 352660 : ar->dimen_type[n] = DIMEN_RANGE;
12874 :
12875 352660 : gcc_assert (ar->start[n] == NULL);
12876 352660 : gcc_assert (ar->end[n] == NULL);
12877 352660 : gcc_assert (ar->stride[n] == NULL);
12878 : }
12879 : ss = newss;
12880 : break;
12881 :
12882 55512 : case AR_SECTION:
12883 55512 : newss = gfc_get_array_ss (ss, expr, 0, GFC_SS_SECTION);
12884 55512 : newss->info->data.array.ref = ref;
12885 :
12886 : /* We add SS chains for all the subscripts in the section. */
12887 143165 : for (n = 0; n < ar->dimen; n++)
12888 : {
12889 87653 : gfc_ss *indexss;
12890 :
12891 87653 : switch (ar->dimen_type[n])
12892 : {
12893 6639 : case DIMEN_ELEMENT:
12894 : /* Add SS for elemental (scalar) subscripts. */
12895 6639 : gcc_assert (ar->start[n]);
12896 6639 : indexss = gfc_get_scalar_ss (gfc_ss_terminator, ar->start[n]);
12897 6639 : indexss->loop_chain = gfc_ss_terminator;
12898 6639 : newss->info->data.array.subscript[n] = indexss;
12899 6639 : break;
12900 :
12901 80202 : case DIMEN_RANGE:
12902 : /* We don't add anything for sections, just remember this
12903 : dimension for later. */
12904 80202 : newss->dim[newss->dimen] = n;
12905 80202 : newss->dimen++;
12906 80202 : break;
12907 :
12908 812 : case DIMEN_VECTOR:
12909 : /* Create a GFC_SS_VECTOR index in which we can store
12910 : the vector's descriptor. */
12911 812 : indexss = gfc_get_array_ss (gfc_ss_terminator, ar->start[n],
12912 : 1, GFC_SS_VECTOR);
12913 812 : indexss->loop_chain = gfc_ss_terminator;
12914 812 : newss->info->data.array.subscript[n] = indexss;
12915 812 : newss->dim[newss->dimen] = n;
12916 812 : newss->dimen++;
12917 812 : break;
12918 :
12919 0 : default:
12920 : /* We should know what sort of section it is by now. */
12921 0 : gcc_unreachable ();
12922 : }
12923 : }
12924 : /* We should have at least one non-elemental dimension,
12925 : unless we are creating a descriptor for a (scalar) coarray. */
12926 55512 : gcc_assert (newss->dimen > 0
12927 : || newss->info->data.array.ref->u.ar.as->corank > 0);
12928 : ss = newss;
12929 : break;
12930 :
12931 0 : default:
12932 : /* We should know what sort of section it is by now. */
12933 0 : gcc_unreachable ();
12934 : }
12935 :
12936 : }
12937 677538 : return ss;
12938 : }
12939 :
12940 :
12941 : /* Walk an expression operator. If only one operand of a binary expression is
12942 : scalar, we must also add the scalar term to the SS chain. */
12943 :
12944 : static gfc_ss *
12945 56659 : gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
12946 : {
12947 56659 : gfc_ss *head;
12948 56659 : gfc_ss *head2;
12949 :
12950 56659 : head = gfc_walk_subexpr (ss, expr->value.op.op1);
12951 56659 : if (expr->value.op.op2 == NULL)
12952 : head2 = head;
12953 : else
12954 54103 : head2 = gfc_walk_subexpr (head, expr->value.op.op2);
12955 :
12956 : /* All operands are scalar. Pass back and let the caller deal with it. */
12957 56659 : if (head2 == ss)
12958 : return head2;
12959 :
12960 : /* All operands require scalarization. */
12961 50971 : if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
12962 : return head2;
12963 :
12964 : /* One of the operands needs scalarization, the other is scalar.
12965 : Create a gfc_ss for the scalar expression. */
12966 18963 : if (head == ss)
12967 : {
12968 : /* First operand is scalar. We build the chain in reverse order, so
12969 : add the scalar SS after the second operand. */
12970 : head = head2;
12971 2188 : while (head && head->next != ss)
12972 : head = head->next;
12973 : /* Check we haven't somehow broken the chain. */
12974 1945 : gcc_assert (head);
12975 1945 : head->next = gfc_get_scalar_ss (ss, expr->value.op.op1);
12976 : }
12977 : else /* head2 == head */
12978 : {
12979 17018 : gcc_assert (head2 == head);
12980 : /* Second operand is scalar. */
12981 17018 : head2 = gfc_get_scalar_ss (head2, expr->value.op.op2);
12982 : }
12983 :
12984 : return head2;
12985 : }
12986 :
12987 : static gfc_ss *
12988 36 : gfc_walk_conditional_expr (gfc_ss *ss, gfc_expr *expr)
12989 : {
12990 36 : gfc_ss *head;
12991 :
12992 36 : head = gfc_walk_subexpr (ss, expr->value.conditional.true_expr);
12993 36 : head = gfc_walk_subexpr (head, expr->value.conditional.false_expr);
12994 36 : return head;
12995 : }
12996 :
12997 : /* Reverse a SS chain. */
12998 :
12999 : gfc_ss *
13000 851459 : gfc_reverse_ss (gfc_ss * ss)
13001 : {
13002 851459 : gfc_ss *next;
13003 851459 : gfc_ss *head;
13004 :
13005 851459 : gcc_assert (ss != NULL);
13006 :
13007 : head = gfc_ss_terminator;
13008 1283253 : while (ss != gfc_ss_terminator)
13009 : {
13010 431794 : next = ss->next;
13011 : /* Check we didn't somehow break the chain. */
13012 431794 : gcc_assert (next != NULL);
13013 431794 : ss->next = head;
13014 431794 : head = ss;
13015 431794 : ss = next;
13016 : }
13017 :
13018 851459 : return (head);
13019 : }
13020 :
13021 :
13022 : /* Given an expression referring to a procedure, return the symbol of its
13023 : interface. We can't get the procedure symbol directly as we have to handle
13024 : the case of (deferred) type-bound procedures. */
13025 :
13026 : gfc_symbol *
13027 161 : gfc_get_proc_ifc_for_expr (gfc_expr *procedure_ref)
13028 : {
13029 161 : gfc_symbol *sym;
13030 161 : gfc_ref *ref;
13031 :
13032 161 : if (procedure_ref == NULL)
13033 : return NULL;
13034 :
13035 : /* Normal procedure case. */
13036 161 : if (procedure_ref->expr_type == EXPR_FUNCTION
13037 161 : && procedure_ref->value.function.esym)
13038 : sym = procedure_ref->value.function.esym;
13039 : else
13040 24 : sym = procedure_ref->symtree->n.sym;
13041 :
13042 : /* Typebound procedure case. */
13043 209 : for (ref = procedure_ref->ref; ref; ref = ref->next)
13044 : {
13045 48 : if (ref->type == REF_COMPONENT
13046 48 : && ref->u.c.component->attr.proc_pointer)
13047 24 : sym = ref->u.c.component->ts.interface;
13048 : else
13049 : sym = NULL;
13050 : }
13051 :
13052 : return sym;
13053 : }
13054 :
13055 :
13056 : /* Given an expression referring to an intrinsic function call,
13057 : return the intrinsic symbol. */
13058 :
13059 : gfc_intrinsic_sym *
13060 7826 : gfc_get_intrinsic_for_expr (gfc_expr *call)
13061 : {
13062 7826 : if (call == NULL)
13063 : return NULL;
13064 :
13065 : /* Normal procedure case. */
13066 2354 : if (call->expr_type == EXPR_FUNCTION)
13067 2248 : return call->value.function.isym;
13068 : else
13069 : return NULL;
13070 : }
13071 :
13072 :
13073 : /* Indicates whether an argument to an intrinsic function should be used in
13074 : scalarization. It is usually the case, except for some intrinsics
13075 : requiring the value to be constant, and using the value at compile time only.
13076 : As the value is not used at runtime in those cases, we don’t produce code
13077 : for it, and it should not be visible to the scalarizer.
13078 : FUNCTION is the intrinsic function being called, ACTUAL_ARG is the actual
13079 : argument being examined in that call, and ARG_NUM the index number
13080 : of ACTUAL_ARG in the list of arguments.
13081 : The intrinsic procedure’s dummy argument associated with ACTUAL_ARG is
13082 : identified using the name in ACTUAL_ARG if it is present (that is: if it’s
13083 : a keyword argument), otherwise using ARG_NUM. */
13084 :
13085 : static bool
13086 37406 : arg_evaluated_for_scalarization (gfc_intrinsic_sym *function,
13087 : gfc_dummy_arg *dummy_arg)
13088 : {
13089 37406 : if (function != NULL && dummy_arg != NULL)
13090 : {
13091 12443 : switch (function->id)
13092 : {
13093 241 : case GFC_ISYM_INDEX:
13094 241 : case GFC_ISYM_LEN_TRIM:
13095 241 : case GFC_ISYM_MASKL:
13096 241 : case GFC_ISYM_MASKR:
13097 241 : case GFC_ISYM_SCAN:
13098 241 : case GFC_ISYM_VERIFY:
13099 241 : if (strcmp ("kind", gfc_dummy_arg_get_name (*dummy_arg)) == 0)
13100 : return false;
13101 : /* Fallthrough. */
13102 :
13103 : default:
13104 : break;
13105 : }
13106 : }
13107 :
13108 : return true;
13109 : }
13110 :
13111 :
13112 : /* Walk the arguments of an elemental function.
13113 : PROC_EXPR is used to check whether an argument is permitted to be absent. If
13114 : it is NULL, we don't do the check and the argument is assumed to be present.
13115 : */
13116 :
13117 : gfc_ss *
13118 26603 : gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
13119 : gfc_intrinsic_sym *intrinsic_sym,
13120 : gfc_ss_type type)
13121 : {
13122 26603 : int scalar;
13123 26603 : gfc_ss *head;
13124 26603 : gfc_ss *tail;
13125 26603 : gfc_ss *newss;
13126 :
13127 26603 : head = gfc_ss_terminator;
13128 26603 : tail = NULL;
13129 :
13130 26603 : scalar = 1;
13131 65473 : for (; arg; arg = arg->next)
13132 : {
13133 38870 : gfc_dummy_arg * const dummy_arg = arg->associated_dummy;
13134 40367 : if (!arg->expr
13135 37556 : || arg->expr->expr_type == EXPR_NULL
13136 76276 : || !arg_evaluated_for_scalarization (intrinsic_sym, dummy_arg))
13137 1497 : continue;
13138 :
13139 37373 : newss = gfc_walk_subexpr (head, arg->expr);
13140 37373 : if (newss == head)
13141 : {
13142 : /* Scalar argument. */
13143 18478 : gcc_assert (type == GFC_SS_SCALAR || type == GFC_SS_REFERENCE);
13144 18478 : newss = gfc_get_scalar_ss (head, arg->expr);
13145 18478 : newss->info->type = type;
13146 18478 : if (dummy_arg)
13147 15463 : newss->info->data.scalar.dummy_arg = dummy_arg;
13148 : }
13149 : else
13150 : scalar = 0;
13151 :
13152 34358 : if (dummy_arg != NULL
13153 25952 : && gfc_dummy_arg_is_optional (*dummy_arg)
13154 2538 : && arg->expr->expr_type == EXPR_VARIABLE
13155 36062 : && (gfc_expr_attr (arg->expr).optional
13156 1223 : || gfc_expr_attr (arg->expr).allocatable
13157 37320 : || gfc_expr_attr (arg->expr).pointer))
13158 1005 : newss->info->can_be_null_ref = true;
13159 :
13160 37373 : head = newss;
13161 37373 : if (!tail)
13162 : {
13163 : tail = head;
13164 33255 : while (tail->next != gfc_ss_terminator)
13165 : tail = tail->next;
13166 : }
13167 : }
13168 :
13169 26603 : if (scalar)
13170 : {
13171 : /* If all the arguments are scalar we don't need the argument SS. */
13172 10258 : gfc_free_ss_chain (head);
13173 : /* Pass it back. */
13174 10258 : return ss;
13175 : }
13176 :
13177 : /* Add it onto the existing chain. */
13178 16345 : tail->next = ss;
13179 16345 : return head;
13180 : }
13181 :
13182 :
13183 : /* Walk a function call. Scalar functions are passed back, and taken out of
13184 : scalarization loops. For elemental functions we walk their arguments.
13185 : The result of functions returning arrays is stored in a temporary outside
13186 : the loop, so that the function is only called once. Hence we do not need
13187 : to walk their arguments. */
13188 :
13189 : static gfc_ss *
13190 62965 : gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
13191 : {
13192 62965 : gfc_intrinsic_sym *isym;
13193 62965 : gfc_symbol *sym;
13194 62965 : gfc_component *comp = NULL;
13195 :
13196 62965 : isym = expr->value.function.isym;
13197 :
13198 : /* Handle intrinsic functions separately. */
13199 62965 : if (isym)
13200 55279 : return gfc_walk_intrinsic_function (ss, expr, isym);
13201 :
13202 7686 : sym = expr->value.function.esym;
13203 7686 : if (!sym)
13204 546 : sym = expr->symtree->n.sym;
13205 :
13206 7686 : if (gfc_is_class_array_function (expr))
13207 234 : return gfc_get_array_ss (ss, expr,
13208 234 : CLASS_DATA (expr->value.function.esym->result)->as->rank,
13209 234 : GFC_SS_FUNCTION);
13210 :
13211 : /* A function that returns arrays. */
13212 7452 : comp = gfc_get_proc_ptr_comp (expr);
13213 7054 : if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
13214 7452 : || (comp && comp->attr.dimension))
13215 2650 : return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
13216 :
13217 : /* Walk the parameters of an elemental function. For now we always pass
13218 : by reference. */
13219 4802 : if (sym->attr.elemental || (comp && comp->attr.elemental))
13220 : {
13221 2212 : gfc_ss *old_ss = ss;
13222 :
13223 2212 : ss = gfc_walk_elemental_function_args (old_ss,
13224 : expr->value.function.actual,
13225 : gfc_get_intrinsic_for_expr (expr),
13226 : GFC_SS_REFERENCE);
13227 2212 : if (ss != old_ss
13228 1176 : && (comp
13229 1115 : || sym->attr.proc_pointer
13230 1115 : || sym->attr.if_source != IFSRC_DECL
13231 993 : || sym->attr.array_outer_dependency))
13232 231 : ss->info->array_outer_dependency = 1;
13233 : }
13234 :
13235 : /* Scalar functions are OK as these are evaluated outside the scalarization
13236 : loop. Pass back and let the caller deal with it. */
13237 : return ss;
13238 : }
13239 :
13240 :
13241 : /* An array temporary is constructed for array constructors. */
13242 :
13243 : static gfc_ss *
13244 49621 : gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
13245 : {
13246 0 : return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_CONSTRUCTOR);
13247 : }
13248 :
13249 :
13250 : /* Walk an expression. Add walked expressions to the head of the SS chain.
13251 : A wholly scalar expression will not be added. */
13252 :
13253 : gfc_ss *
13254 1003990 : gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
13255 : {
13256 1003990 : gfc_ss *head;
13257 :
13258 1003990 : switch (expr->expr_type)
13259 : {
13260 677181 : case EXPR_VARIABLE:
13261 677181 : head = gfc_walk_variable_expr (ss, expr);
13262 677181 : return head;
13263 :
13264 56659 : case EXPR_OP:
13265 56659 : head = gfc_walk_op_expr (ss, expr);
13266 56659 : return head;
13267 :
13268 36 : case EXPR_CONDITIONAL:
13269 36 : head = gfc_walk_conditional_expr (ss, expr);
13270 36 : return head;
13271 :
13272 62965 : case EXPR_FUNCTION:
13273 62965 : head = gfc_walk_function_expr (ss, expr);
13274 62965 : return head;
13275 :
13276 : case EXPR_CONSTANT:
13277 : case EXPR_NULL:
13278 : case EXPR_STRUCTURE:
13279 : /* Pass back and let the caller deal with it. */
13280 : break;
13281 :
13282 49621 : case EXPR_ARRAY:
13283 49621 : head = gfc_walk_array_constructor (ss, expr);
13284 49621 : return head;
13285 :
13286 : case EXPR_SUBSTRING:
13287 : /* Pass back and let the caller deal with it. */
13288 : break;
13289 :
13290 0 : default:
13291 0 : gfc_internal_error ("bad expression type during walk (%d)",
13292 : expr->expr_type);
13293 : }
13294 : return ss;
13295 : }
13296 :
13297 :
13298 : /* Entry point for expression walking.
13299 : A return value equal to the passed chain means this is
13300 : a scalar expression. It is up to the caller to take whatever action is
13301 : necessary to translate these. */
13302 :
13303 : gfc_ss *
13304 848868 : gfc_walk_expr (gfc_expr * expr)
13305 : {
13306 848868 : gfc_ss *res;
13307 :
13308 848868 : res = gfc_walk_subexpr (gfc_ss_terminator, expr);
13309 848868 : return gfc_reverse_ss (res);
13310 : }
|
