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 59294 : gfc_array_dataptr_type (tree desc)
107 : {
108 59294 : 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 2035063 : gfc_get_descriptor_field (tree desc, unsigned field_idx)
248 : {
249 2035063 : tree type = TREE_TYPE (desc);
250 2035063 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
251 :
252 2035063 : tree field = gfc_advance_chain (TYPE_FIELDS (type), field_idx);
253 2035063 : gcc_assert (field != NULL_TREE);
254 :
255 2035063 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
256 2035063 : 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 287183 : gfc_conv_descriptor_data_get (tree desc)
264 : {
265 287183 : tree type = TREE_TYPE (desc);
266 287183 : if (TREE_CODE (type) == REFERENCE_TYPE)
267 0 : gcc_unreachable ();
268 :
269 287183 : tree field = gfc_get_descriptor_field (desc, DATA_FIELD);
270 287183 : 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 159383 : gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
277 : {
278 159383 : tree field = gfc_get_descriptor_field (desc, DATA_FIELD);
279 159383 : gfc_add_modify (block, field, fold_convert (TREE_TYPE (field), value));
280 159383 : }
281 :
282 :
283 : static tree
284 209949 : gfc_conv_descriptor_offset (tree desc)
285 : {
286 209949 : tree field = gfc_get_descriptor_field (desc, OFFSET_FIELD);
287 209949 : gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
288 209949 : return field;
289 : }
290 :
291 : tree
292 78361 : gfc_conv_descriptor_offset_get (tree desc)
293 : {
294 78361 : return gfc_conv_descriptor_offset (desc);
295 : }
296 :
297 : void
298 124942 : gfc_conv_descriptor_offset_set (stmtblock_t *block, tree desc,
299 : tree value)
300 : {
301 124942 : tree t = gfc_conv_descriptor_offset (desc);
302 124942 : gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
303 124942 : }
304 :
305 :
306 : tree
307 175600 : gfc_conv_descriptor_dtype (tree desc)
308 : {
309 175600 : tree field = gfc_get_descriptor_field (desc, DTYPE_FIELD);
310 175600 : gcc_assert (TREE_TYPE (field) == get_dtype_type_node ());
311 175600 : return field;
312 : }
313 :
314 : static tree
315 155177 : gfc_conv_descriptor_span (tree desc)
316 : {
317 155177 : tree field = gfc_get_descriptor_field (desc, SPAN_FIELD);
318 155177 : gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
319 155177 : return field;
320 : }
321 :
322 : tree
323 34198 : gfc_conv_descriptor_span_get (tree desc)
324 : {
325 34198 : return gfc_conv_descriptor_span (desc);
326 : }
327 :
328 : void
329 120979 : gfc_conv_descriptor_span_set (stmtblock_t *block, tree desc,
330 : tree value)
331 : {
332 120979 : tree t = gfc_conv_descriptor_span (desc);
333 120979 : gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
334 120979 : }
335 :
336 :
337 : tree
338 21845 : gfc_conv_descriptor_rank (tree desc)
339 : {
340 21845 : tree tmp;
341 21845 : tree dtype;
342 :
343 21845 : dtype = gfc_conv_descriptor_dtype (desc);
344 21845 : tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), GFC_DTYPE_RANK);
345 21845 : gcc_assert (tmp != NULL_TREE
346 : && TREE_TYPE (tmp) == signed_char_type_node);
347 21845 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
348 21845 : 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 9253 : gfc_conv_descriptor_elem_len (tree desc)
371 : {
372 9253 : tree tmp;
373 9253 : tree dtype;
374 :
375 9253 : dtype = gfc_conv_descriptor_dtype (desc);
376 9253 : tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)),
377 : GFC_DTYPE_ELEM_LEN);
378 9253 : gcc_assert (tmp != NULL_TREE
379 : && TREE_TYPE (tmp) == size_type_node);
380 9253 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
381 9253 : 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 1045507 : gfc_get_descriptor_dimension (tree desc)
416 : {
417 1045507 : tree field = gfc_get_descriptor_field (desc, DIMENSION_FIELD);
418 1045507 : gcc_assert (TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
419 : && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
420 1045507 : return field;
421 : }
422 :
423 :
424 : static tree
425 1041289 : gfc_conv_descriptor_dimension (tree desc, tree dim)
426 : {
427 1041289 : tree tmp;
428 :
429 1041289 : tmp = gfc_get_descriptor_dimension (desc);
430 :
431 1041289 : return gfc_build_array_ref (tmp, dim, NULL_TREE, true);
432 : }
433 :
434 :
435 : tree
436 2264 : gfc_conv_descriptor_token (tree desc)
437 : {
438 2264 : gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
439 2264 : tree field = gfc_get_descriptor_field (desc, CAF_TOKEN_FIELD);
440 : /* Should be a restricted pointer - except in the finalization wrapper. */
441 2264 : gcc_assert (TREE_TYPE (field) == prvoid_type_node
442 : || TREE_TYPE (field) == pvoid_type_node);
443 2264 : return field;
444 : }
445 :
446 : static tree
447 1041289 : gfc_conv_descriptor_subfield (tree desc, tree dim, unsigned field_idx)
448 : {
449 1041289 : tree tmp = gfc_conv_descriptor_dimension (desc, dim);
450 1041289 : tree field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), field_idx);
451 1041289 : gcc_assert (field != NULL_TREE);
452 :
453 1041289 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
454 1041289 : tmp, field, NULL_TREE);
455 : }
456 :
457 : static tree
458 277883 : gfc_conv_descriptor_stride (tree desc, tree dim)
459 : {
460 277883 : tree field = gfc_conv_descriptor_subfield (desc, dim, STRIDE_SUBFIELD);
461 277883 : gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
462 277883 : return field;
463 : }
464 :
465 : tree
466 171470 : gfc_conv_descriptor_stride_get (tree desc, tree dim)
467 : {
468 171470 : tree type = TREE_TYPE (desc);
469 171470 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
470 171470 : if (integer_zerop (dim)
471 171470 : && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
472 44140 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT
473 43071 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT
474 42915 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_ALLOCATABLE
475 42765 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_POINTER_CONT
476 42765 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
477 72605 : return gfc_index_one_node;
478 :
479 98865 : return gfc_conv_descriptor_stride (desc, dim);
480 : }
481 :
482 : void
483 179018 : gfc_conv_descriptor_stride_set (stmtblock_t *block, tree desc,
484 : tree dim, tree value)
485 : {
486 179018 : tree t = gfc_conv_descriptor_stride (desc, dim);
487 179018 : gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
488 179018 : }
489 :
490 : static tree
491 396332 : gfc_conv_descriptor_lbound (tree desc, tree dim)
492 : {
493 396332 : tree field = gfc_conv_descriptor_subfield (desc, dim, LBOUND_SUBFIELD);
494 396332 : gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
495 396332 : return field;
496 : }
497 :
498 : tree
499 212543 : gfc_conv_descriptor_lbound_get (tree desc, tree dim)
500 : {
501 212543 : return gfc_conv_descriptor_lbound (desc, dim);
502 : }
503 :
504 : void
505 183789 : gfc_conv_descriptor_lbound_set (stmtblock_t *block, tree desc,
506 : tree dim, tree value)
507 : {
508 183789 : tree t = gfc_conv_descriptor_lbound (desc, dim);
509 183789 : gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
510 183789 : }
511 :
512 : static tree
513 367074 : gfc_conv_descriptor_ubound (tree desc, tree dim)
514 : {
515 367074 : tree field = gfc_conv_descriptor_subfield (desc, dim, UBOUND_SUBFIELD);
516 367074 : gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
517 367074 : return field;
518 : }
519 :
520 : tree
521 183529 : gfc_conv_descriptor_ubound_get (tree desc, tree dim)
522 : {
523 183529 : return gfc_conv_descriptor_ubound (desc, dim);
524 : }
525 :
526 : void
527 183545 : gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree desc,
528 : tree dim, tree value)
529 : {
530 183545 : tree t = gfc_conv_descriptor_ubound (desc, dim);
531 183545 : gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
532 183545 : }
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 955 : gfc_conv_shift_descriptor_lbound (stmtblock_t* block, tree desc,
560 : int dim, tree new_lbound)
561 : {
562 955 : tree offs, ubound, lbound, stride;
563 955 : tree diff, offs_diff;
564 :
565 955 : new_lbound = fold_convert (gfc_array_index_type, new_lbound);
566 :
567 955 : offs = gfc_conv_descriptor_offset_get (desc);
568 955 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
569 955 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
570 955 : stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]);
571 :
572 : /* Get difference (new - old) by which to shift stuff. */
573 955 : 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 955 : ubound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
579 : ubound, diff);
580 955 : gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[dim], ubound);
581 955 : offs_diff = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
582 : diff, stride);
583 955 : offs = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
584 : offs, offs_diff);
585 955 : gfc_conv_descriptor_offset_set (block, desc, offs);
586 :
587 : /* Finally set lbound to value we want. */
588 955 : gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[dim], new_lbound);
589 955 : }
590 :
591 :
592 : /* Obtain offsets for trans-types.cc(gfc_get_array_descr_info). */
593 :
594 : void
595 275809 : 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 275809 : tree field;
602 275809 : tree type;
603 :
604 275809 : type = TYPE_MAIN_VARIANT (desc_type);
605 275809 : field = gfc_advance_chain (TYPE_FIELDS (type), DATA_FIELD);
606 275809 : *data_off = byte_position (field);
607 275809 : field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
608 275809 : *dtype_off = byte_position (field);
609 275809 : field = gfc_advance_chain (TYPE_FIELDS (type), SPAN_FIELD);
610 275809 : *span_off = byte_position (field);
611 275809 : field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
612 275809 : *dim_off = byte_position (field);
613 275809 : type = TREE_TYPE (TREE_TYPE (field));
614 275809 : *dim_size = TYPE_SIZE_UNIT (type);
615 275809 : field = gfc_advance_chain (TYPE_FIELDS (type), STRIDE_SUBFIELD);
616 275809 : *stride_suboff = byte_position (field);
617 275809 : field = gfc_advance_chain (TYPE_FIELDS (type), LBOUND_SUBFIELD);
618 275809 : *lower_suboff = byte_position (field);
619 275809 : field = gfc_advance_chain (TYPE_FIELDS (type), UBOUND_SUBFIELD);
620 275809 : *upper_suboff = byte_position (field);
621 275809 : }
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 173353 : gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
643 : {
644 407492 : for (; ss != gfc_ss_terminator; ss = ss->next)
645 234139 : ss->info->useflags = flags;
646 173353 : }
647 :
648 :
649 : /* Free a gfc_ss chain. */
650 :
651 : void
652 181685 : gfc_free_ss_chain (gfc_ss * ss)
653 : {
654 181685 : gfc_ss *next;
655 :
656 371588 : while (ss != gfc_ss_terminator)
657 : {
658 189903 : gcc_assert (ss != NULL);
659 189903 : next = ss->next;
660 189903 : gfc_free_ss (ss);
661 189903 : ss = next;
662 : }
663 181685 : }
664 :
665 :
666 : static void
667 494312 : free_ss_info (gfc_ss_info *ss_info)
668 : {
669 494312 : int n;
670 :
671 494312 : ss_info->refcount--;
672 494312 : if (ss_info->refcount > 0)
673 : return;
674 :
675 489565 : gcc_assert (ss_info->refcount == 0);
676 :
677 489565 : switch (ss_info->type)
678 : {
679 : case GFC_SS_SECTION:
680 5433056 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
681 5093490 : if (ss_info->data.array.subscript[n])
682 7761 : gfc_free_ss_chain (ss_info->data.array.subscript[n]);
683 : break;
684 :
685 : default:
686 : break;
687 : }
688 :
689 489565 : free (ss_info);
690 : }
691 :
692 :
693 : /* Free a SS. */
694 :
695 : void
696 494312 : gfc_free_ss (gfc_ss * ss)
697 : {
698 494312 : free_ss_info (ss->info);
699 494312 : free (ss);
700 494312 : }
701 :
702 :
703 : /* Creates and initializes an array type gfc_ss struct. */
704 :
705 : gfc_ss *
706 413420 : gfc_get_array_ss (gfc_ss *next, gfc_expr *expr, int dimen, gfc_ss_type type)
707 : {
708 413420 : gfc_ss *ss;
709 413420 : gfc_ss_info *ss_info;
710 413420 : int i;
711 :
712 413420 : ss_info = gfc_get_ss_info ();
713 413420 : ss_info->refcount++;
714 413420 : ss_info->type = type;
715 413420 : ss_info->expr = expr;
716 :
717 413420 : ss = gfc_get_ss ();
718 413420 : ss->info = ss_info;
719 413420 : ss->next = next;
720 413420 : ss->dimen = dimen;
721 871308 : for (i = 0; i < ss->dimen; i++)
722 457888 : ss->dim[i] = i;
723 :
724 413420 : return ss;
725 : }
726 :
727 :
728 : /* Creates and initializes a temporary type gfc_ss struct. */
729 :
730 : gfc_ss *
731 11287 : gfc_get_temp_ss (tree type, tree string_length, int dimen)
732 : {
733 11287 : gfc_ss *ss;
734 11287 : gfc_ss_info *ss_info;
735 11287 : int i;
736 :
737 11287 : ss_info = gfc_get_ss_info ();
738 11287 : ss_info->refcount++;
739 11287 : ss_info->type = GFC_SS_TEMP;
740 11287 : ss_info->string_length = string_length;
741 11287 : ss_info->data.temp.type = type;
742 :
743 11287 : ss = gfc_get_ss ();
744 11287 : ss->info = ss_info;
745 11287 : ss->next = gfc_ss_terminator;
746 11287 : ss->dimen = dimen;
747 25265 : for (i = 0; i < ss->dimen; i++)
748 13978 : ss->dim[i] = i;
749 :
750 11287 : return ss;
751 : }
752 :
753 :
754 : /* Creates and initializes a scalar type gfc_ss struct. */
755 :
756 : gfc_ss *
757 66929 : gfc_get_scalar_ss (gfc_ss *next, gfc_expr *expr)
758 : {
759 66929 : gfc_ss *ss;
760 66929 : gfc_ss_info *ss_info;
761 :
762 66929 : ss_info = gfc_get_ss_info ();
763 66929 : ss_info->refcount++;
764 66929 : ss_info->type = GFC_SS_SCALAR;
765 66929 : ss_info->expr = expr;
766 :
767 66929 : ss = gfc_get_ss ();
768 66929 : ss->info = ss_info;
769 66929 : ss->next = next;
770 :
771 66929 : return ss;
772 : }
773 :
774 :
775 : /* Free all the SS associated with a loop. */
776 :
777 : void
778 183543 : gfc_cleanup_loop (gfc_loopinfo * loop)
779 : {
780 183543 : gfc_loopinfo *loop_next, **ploop;
781 183543 : gfc_ss *ss;
782 183543 : gfc_ss *next;
783 :
784 183543 : ss = loop->ss;
785 487417 : while (ss != gfc_ss_terminator)
786 : {
787 303874 : gcc_assert (ss != NULL);
788 303874 : next = ss->loop_chain;
789 303874 : gfc_free_ss (ss);
790 303874 : ss = next;
791 : }
792 :
793 : /* Remove reference to self in the parent loop. */
794 183543 : 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 186907 : 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 183543 : }
810 :
811 :
812 : static void
813 249695 : set_ss_loop (gfc_ss *ss, gfc_loopinfo *loop)
814 : {
815 249695 : int n;
816 :
817 562673 : for (; ss != gfc_ss_terminator; ss = ss->next)
818 : {
819 312978 : ss->loop = loop;
820 :
821 312978 : if (ss->info->type == GFC_SS_SCALAR
822 : || ss->info->type == GFC_SS_REFERENCE
823 264161 : || ss->info->type == GFC_SS_TEMP)
824 60104 : continue;
825 :
826 4045984 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
827 3793110 : if (ss->info->data.array.subscript[n] != NULL)
828 7486 : set_ss_loop (ss->info->data.array.subscript[n], loop);
829 : }
830 249695 : }
831 :
832 :
833 : /* Associate a SS chain with a loop. */
834 :
835 : void
836 242209 : gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
837 : {
838 242209 : gfc_ss *ss;
839 242209 : gfc_loopinfo *nested_loop;
840 :
841 242209 : if (head == gfc_ss_terminator)
842 : return;
843 :
844 242209 : set_ss_loop (head, loop);
845 :
846 242209 : ss = head;
847 789910 : for (; ss && ss != gfc_ss_terminator; ss = ss->next)
848 : {
849 305492 : 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 305492 : if (ss->next == gfc_ss_terminator)
870 242209 : ss->loop_chain = loop->ss;
871 : else
872 63283 : ss->loop_chain = ss->next;
873 : }
874 242209 : gcc_assert (ss == gfc_ss_terminator);
875 242209 : loop->ss = head;
876 : }
877 :
878 :
879 : /* Returns true if the expression is an array pointer. */
880 :
881 : static bool
882 369763 : is_pointer_array (tree expr)
883 : {
884 369763 : if (expr == NULL_TREE
885 369763 : || !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr))
886 467354 : || GFC_CLASS_TYPE_P (TREE_TYPE (expr)))
887 : return false;
888 :
889 97591 : if (VAR_P (expr)
890 97591 : && GFC_DECL_PTR_ARRAY_P (expr))
891 : return true;
892 :
893 91180 : if (TREE_CODE (expr) == PARM_DECL
894 91180 : && GFC_DECL_PTR_ARRAY_P (expr))
895 : return true;
896 :
897 91180 : if (INDIRECT_REF_P (expr)
898 91180 : && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 0)))
899 : return true;
900 :
901 : /* The field declaration is marked as an pointer array. */
902 88751 : if (TREE_CODE (expr) == COMPONENT_REF
903 15847 : && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 1))
904 91924 : && !GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (expr, 1))))
905 3173 : 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 372477 : get_CFI_desc (gfc_symbol *sym, gfc_expr *expr,
919 : tree *desc, gfc_array_ref *ar)
920 : {
921 372477 : tree tmp;
922 :
923 372477 : 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 1137 : 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 1137 : 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 1137 : 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 626 : return gfc_vptr_size_get (vptr);
963 : }
964 :
965 :
966 : /* Return the span of an array. */
967 :
968 : tree
969 58491 : gfc_get_array_span (tree desc, gfc_expr *expr)
970 : {
971 58491 : tree tmp;
972 58491 : gfc_symbol *sym = (expr && expr->expr_type == EXPR_VARIABLE) ?
973 51285 : expr->symtree->n.sym : NULL;
974 :
975 58491 : if (is_pointer_array (desc)
976 58491 : || (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 57933 : 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 57806 : else if (TREE_CODE (desc) == COMPONENT_REF
996 562 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
997 57935 : && 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 57750 : else if (sym && sym->ts.type == BT_CLASS
1002 1137 : && expr->ref->type == REF_COMPONENT
1003 1137 : && expr->ref->next->type == REF_ARRAY
1004 1137 : && expr->ref->next->next == NULL
1005 1119 : && CLASS_DATA (sym)->attr.dimension)
1006 : /* Having escaped the above, this can only be a class array dummy. */
1007 1081 : tmp = class_array_element_size (sym->backend_decl,
1008 1081 : 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 56669 : tmp = gfc_get_element_type (TREE_TYPE (desc));
1015 56669 : if (tmp && TREE_CODE (tmp) == ARRAY_TYPE && TYPE_STRING_FLAG (tmp))
1016 : {
1017 11071 : gcc_assert (expr->ts.type == BT_CHARACTER);
1018 :
1019 11071 : tmp = gfc_get_character_len_in_bytes (tmp);
1020 :
1021 11071 : 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 22062 : tmp = (tmp && !integer_zerop (tmp))
1033 22062 : ? (fold_convert (gfc_array_index_type, tmp)) : (NULL_TREE);
1034 : }
1035 : else
1036 45598 : tmp = fold_convert (gfc_array_index_type,
1037 : size_in_bytes (tmp));
1038 : }
1039 58491 : return tmp;
1040 : }
1041 :
1042 :
1043 : /* Generate an initializer for a static pointer or allocatable array. */
1044 :
1045 : void
1046 276 : gfc_trans_static_array_pointer (gfc_symbol * sym)
1047 : {
1048 276 : tree type;
1049 :
1050 276 : gcc_assert (TREE_STATIC (sym->backend_decl));
1051 : /* Just zero the data member. */
1052 276 : type = TREE_TYPE (sym->backend_decl);
1053 276 : DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
1054 276 : }
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 8737 : gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
1065 : gfc_se * se, gfc_array_spec * as)
1066 : {
1067 8737 : int n, dim, total_dim;
1068 8737 : gfc_se tmpse;
1069 8737 : gfc_ss *ss;
1070 8737 : tree lower;
1071 8737 : tree upper;
1072 8737 : tree tmp;
1073 :
1074 8737 : total_dim = 0;
1075 :
1076 8737 : if (!as || as->type != AS_EXPLICIT)
1077 7576 : return;
1078 :
1079 2347 : for (ss = se->ss; ss; ss = ss->parent)
1080 : {
1081 1186 : total_dim += ss->loop->dimen;
1082 2727 : for (n = 0; n < ss->loop->dimen; n++)
1083 : {
1084 : /* The bound is known, nothing to do. */
1085 1541 : if (ss->loop->to[n] != NULL_TREE)
1086 485 : continue;
1087 :
1088 1056 : dim = ss->dim[n];
1089 1056 : gcc_assert (dim < as->rank);
1090 1056 : gcc_assert (ss->loop->dimen <= as->rank);
1091 :
1092 : /* Evaluate the lower bound. */
1093 1056 : gfc_init_se (&tmpse, NULL);
1094 1056 : gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
1095 1056 : gfc_add_block_to_block (&se->pre, &tmpse.pre);
1096 1056 : gfc_add_block_to_block (&se->post, &tmpse.post);
1097 1056 : lower = fold_convert (gfc_array_index_type, tmpse.expr);
1098 :
1099 : /* ...and the upper bound. */
1100 1056 : gfc_init_se (&tmpse, NULL);
1101 1056 : gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
1102 1056 : gfc_add_block_to_block (&se->pre, &tmpse.pre);
1103 1056 : gfc_add_block_to_block (&se->post, &tmpse.post);
1104 1056 : upper = fold_convert (gfc_array_index_type, tmpse.expr);
1105 :
1106 : /* Set the upper bound of the loop to UPPER - LOWER. */
1107 1056 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
1108 : gfc_array_index_type, upper, lower);
1109 1056 : tmp = gfc_evaluate_now (tmp, &se->pre);
1110 1056 : ss->loop->to[n] = tmp;
1111 : }
1112 : }
1113 :
1114 1161 : 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, uninitialized 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 27836 : 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 27836 : tree tmp;
1136 27836 : tree desc;
1137 27836 : bool onstack;
1138 :
1139 27836 : desc = info->descriptor;
1140 27836 : info->offset = gfc_index_zero_node;
1141 27836 : if (size == NULL_TREE || (dynamic && integer_zerop (size)))
1142 : {
1143 : /* A callee allocated array. */
1144 2877 : gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
1145 2877 : onstack = false;
1146 : }
1147 : else
1148 : {
1149 : /* Allocate the temporary. */
1150 49918 : onstack = !dynamic && initial == NULL_TREE
1151 24959 : && (flag_stack_arrays
1152 24574 : || gfc_can_put_var_on_stack (size));
1153 :
1154 24959 : if (onstack)
1155 : {
1156 : /* Make a temporary variable to hold the data. */
1157 19873 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (nelem),
1158 : nelem, gfc_index_one_node);
1159 19873 : tmp = gfc_evaluate_now (tmp, pre);
1160 19873 : tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
1161 : tmp);
1162 19873 : tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
1163 : tmp);
1164 19873 : 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 19873 : 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 19873 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1173 19873 : gfc_conv_descriptor_data_set (pre, desc, tmp);
1174 : }
1175 : else
1176 : {
1177 : /* Allocate memory to hold the data or call internal_pack. */
1178 5086 : if (initial == NULL_TREE)
1179 : {
1180 4943 : tmp = gfc_call_malloc (pre, NULL, size);
1181 4943 : tmp = gfc_evaluate_now (tmp, pre);
1182 : }
1183 : else
1184 : {
1185 143 : tree packed;
1186 143 : tree source_data;
1187 143 : tree was_packed;
1188 143 : stmtblock_t do_copying;
1189 :
1190 143 : tmp = TREE_TYPE (initial); /* Pointer to descriptor. */
1191 143 : gcc_assert (TREE_CODE (tmp) == POINTER_TYPE);
1192 143 : tmp = TREE_TYPE (tmp); /* The descriptor itself. */
1193 143 : tmp = gfc_get_element_type (tmp);
1194 143 : packed = gfc_create_var (build_pointer_type (tmp), "data");
1195 :
1196 143 : tmp = build_call_expr_loc (input_location,
1197 : gfor_fndecl_in_pack, 1, initial);
1198 143 : tmp = fold_convert (TREE_TYPE (packed), tmp);
1199 143 : gfc_add_modify (pre, packed, tmp);
1200 :
1201 143 : tmp = build_fold_indirect_ref_loc (input_location,
1202 : initial);
1203 143 : 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 143 : gfc_start_block (&do_copying);
1210 143 : tmp = gfc_call_malloc (&do_copying, NULL, size);
1211 143 : tmp = fold_convert (TREE_TYPE (packed), tmp);
1212 143 : gfc_add_modify (&do_copying, packed, tmp);
1213 143 : tmp = gfc_build_memcpy_call (packed, source_data, size);
1214 143 : gfc_add_expr_to_block (&do_copying, tmp);
1215 :
1216 143 : was_packed = fold_build2_loc (input_location, EQ_EXPR,
1217 : logical_type_node, packed,
1218 : source_data);
1219 143 : tmp = gfc_finish_block (&do_copying);
1220 143 : tmp = build3_v (COND_EXPR, was_packed, tmp,
1221 : build_empty_stmt (input_location));
1222 143 : gfc_add_expr_to_block (pre, tmp);
1223 :
1224 143 : tmp = fold_convert (pvoid_type_node, packed);
1225 : }
1226 :
1227 5086 : gfc_conv_descriptor_data_set (pre, desc, tmp);
1228 : }
1229 : }
1230 27836 : 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 27836 : gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node);
1235 :
1236 27836 : if (dealloc && !onstack)
1237 : {
1238 : /* Free the temporary. */
1239 7713 : tmp = gfc_conv_descriptor_data_get (desc);
1240 7713 : tmp = gfc_call_free (tmp);
1241 7713 : gfc_add_expr_to_block (post, tmp);
1242 : }
1243 27836 : }
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 261823 : get_scalarizer_dim_for_array_dim (gfc_ss *ss, int array_dim)
1262 : {
1263 261823 : int array_ref_dim;
1264 261823 : int n;
1265 :
1266 261823 : array_ref_dim = 0;
1267 :
1268 529779 : for (; ss; ss = ss->parent)
1269 689179 : for (n = 0; n < ss->dimen; n++)
1270 421223 : if (ss->dim[n] < array_dim)
1271 76850 : array_ref_dim++;
1272 :
1273 261823 : return array_ref_dim;
1274 : }
1275 :
1276 :
1277 : static gfc_ss *
1278 221372 : innermost_ss (gfc_ss *ss)
1279 : {
1280 407711 : while (ss->nested_ss != NULL)
1281 : ss = ss->nested_ss;
1282 :
1283 399503 : 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 221372 : get_array_ref_dim_for_loop_dim (gfc_ss *ss, int loop_dim)
1296 : {
1297 221372 : return get_scalarizer_dim_for_array_dim (innermost_ss (ss),
1298 221372 : 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 327 : get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype,
1308 : gfc_ss **fcnss)
1309 : {
1310 327 : gfc_ss *loop_ss = ss->loop->ss;
1311 327 : gfc_ss *lhs_ss;
1312 327 : gfc_ss *rhs_ss;
1313 327 : gfc_ss *fcn_ss = NULL;
1314 327 : tree tmp;
1315 327 : tree tmp2;
1316 327 : tree vptr;
1317 327 : tree class_expr = NULL_TREE;
1318 327 : tree lhs_class_expr = NULL_TREE;
1319 327 : bool unlimited_rhs = false;
1320 327 : bool unlimited_lhs = false;
1321 327 : bool rhs_function = false;
1322 327 : bool unlimited_arg1 = false;
1323 327 : gfc_symbol *vtab;
1324 327 : 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 327 : rhs_ss = loop_ss->loop_chain;
1329 :
1330 327 : if (rhs_ss != gfc_ss_terminator
1331 303 : && rhs_ss->info
1332 303 : && rhs_ss->info->expr
1333 303 : && rhs_ss->info->expr->ts.type == BT_CLASS
1334 182 : && rhs_ss->info->data.array.descriptor)
1335 : {
1336 170 : 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 114 : class_expr = gfc_get_class_from_gfc_expr (rhs_ss->info->expr);
1341 170 : unlimited_rhs = UNLIMITED_POLY (rhs_ss->info->expr);
1342 170 : 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 327 : *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 327 : if (class_expr != NULL_TREE
1353 151 : && 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 327 : lhs_ss = rhs_ss->loop_chain;
1368 327 : 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 102 : 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 114 : 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 27836 : 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 27836 : gfc_loopinfo *loop;
1473 27836 : gfc_ss *s;
1474 27836 : gfc_array_info *info;
1475 27836 : tree from[GFC_MAX_DIMENSIONS], to[GFC_MAX_DIMENSIONS];
1476 27836 : tree type;
1477 27836 : tree desc;
1478 27836 : tree tmp;
1479 27836 : tree size;
1480 27836 : tree nelem;
1481 27836 : tree cond;
1482 27836 : tree or_expr;
1483 27836 : tree elemsize;
1484 27836 : tree class_expr = NULL_TREE;
1485 27836 : gfc_ss *fcn_ss = NULL;
1486 27836 : int n, dim, tmp_dim;
1487 27836 : 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 27836 : if (eltype == NULL_TREE && initial)
1492 : {
1493 0 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial)));
1494 0 : class_expr = build_fold_indirect_ref_loc (input_location, initial);
1495 : /* Obtain the structure (class) expression. */
1496 0 : class_expr = gfc_get_class_from_expr (class_expr);
1497 0 : 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 27836 : if (class_expr == NULL_TREE && GFC_CLASS_TYPE_P (eltype))
1505 327 : 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 27836 : if (eltype && GFC_CLASS_TYPE_P (eltype))
1509 199 : eltype = gfc_get_element_type (TREE_TYPE (TYPE_FIELDS (eltype)));
1510 :
1511 27836 : if (class_expr == NULL_TREE)
1512 27685 : 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 27836 : memset (from, 0, sizeof (from));
1536 27836 : memset (to, 0, sizeof (to));
1537 :
1538 27836 : info = &ss->info->data.array;
1539 :
1540 27836 : gcc_assert (ss->dimen > 0);
1541 27836 : gcc_assert (ss->loop->dimen == ss->dimen);
1542 :
1543 27836 : 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 55707 : for (s = ss; s; s = s->parent)
1549 : {
1550 27871 : loop = s->loop;
1551 :
1552 27871 : total_dim += loop->dimen;
1553 64922 : for (n = 0; n < loop->dimen; n++)
1554 : {
1555 37051 : dim = s->dim[n];
1556 :
1557 : /* Callee allocated arrays may not have a known bound yet. */
1558 37051 : if (loop->to[n])
1559 33656 : 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 37051 : 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 37051 : 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 37051 : tmp_dim = get_scalarizer_dim_for_array_dim (ss, dim);
1578 37051 : from[tmp_dim] = loop->from[n];
1579 37051 : to[tmp_dim] = loop->to[n];
1580 :
1581 37051 : info->delta[dim] = gfc_index_zero_node;
1582 37051 : info->start[dim] = gfc_index_zero_node;
1583 37051 : info->end[dim] = gfc_index_zero_node;
1584 37051 : info->stride[dim] = gfc_index_one_node;
1585 : }
1586 : }
1587 :
1588 : /* Initialize the descriptor. */
1589 27836 : type =
1590 27836 : gfc_get_array_type_bounds (eltype, total_dim, 0, from, to, 1,
1591 : GFC_ARRAY_UNKNOWN, true);
1592 27836 : desc = gfc_create_var (type, "atmp");
1593 27836 : 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 27836 : tree arraytype = TREE_TYPE (GFC_TYPE_ARRAY_DATAPTR_TYPE (type));
1599 27836 : if (! TYPE_NAME (arraytype))
1600 27836 : TYPE_NAME (arraytype) = build_decl (UNKNOWN_LOCATION, TYPE_DECL,
1601 : NULL_TREE, arraytype);
1602 27836 : gfc_add_expr_to_block (pre, build1 (DECL_EXPR,
1603 27836 : arraytype, TYPE_NAME (arraytype)));
1604 :
1605 27836 : 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 27836 : if (class_expr != NULL_TREE
1612 27685 : || (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 181 : 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 271 : && (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 27655 : tmp = gfc_conv_descriptor_dtype (desc);
1698 27655 : gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
1699 : }
1700 :
1701 27836 : info->descriptor = desc;
1702 27836 : 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 27836 : or_expr = NULL_TREE;
1718 :
1719 : /* If there is at least one null loop->to[n], it is a callee allocated
1720 : array. */
1721 61492 : for (n = 0; n < total_dim; n++)
1722 35703 : if (to[n] == NULL_TREE)
1723 : {
1724 : size = NULL_TREE;
1725 : break;
1726 : }
1727 :
1728 27836 : if (size == NULL_TREE)
1729 4104 : for (s = ss; s; s = s->parent)
1730 5457 : for (n = 0; n < s->loop->dimen; n++)
1731 : {
1732 3400 : 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 3400 : 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 3400 : s->loop->to[n] = tmp;
1741 : }
1742 : else
1743 : {
1744 59440 : for (n = 0; n < total_dim; n++)
1745 : {
1746 : /* Store the stride and bound components in the descriptor. */
1747 33651 : gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size);
1748 :
1749 33651 : gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
1750 : gfc_index_zero_node);
1751 :
1752 33651 : gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], to[n]);
1753 :
1754 33651 : 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 33651 : cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
1760 : tmp, gfc_index_zero_node);
1761 33651 : cond = gfc_evaluate_now (cond, pre);
1762 :
1763 33651 : if (n == 0)
1764 : or_expr = cond;
1765 : else
1766 7862 : or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1767 : logical_type_node, or_expr, cond);
1768 :
1769 33651 : size = fold_build2_loc (input_location, MULT_EXPR,
1770 : gfc_array_index_type, size, tmp);
1771 33651 : size = gfc_evaluate_now (size, pre);
1772 : }
1773 : }
1774 :
1775 : /* Get the size of the array. */
1776 27836 : 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 25599 : size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
1781 : or_expr, gfc_index_zero_node, size);
1782 :
1783 25599 : nelem = size;
1784 25599 : 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 27836 : tmp = fold_convert (gfc_array_index_type, elemsize);
1795 27836 : gfc_conv_descriptor_span_set (pre, desc, tmp);
1796 :
1797 27836 : gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
1798 : dynamic, dealloc);
1799 :
1800 55707 : while (ss->parent)
1801 : ss = ss->parent;
1802 :
1803 27836 : if (ss->dimen > ss->loop->temp_dim)
1804 24064 : ss->loop->temp_dim = ss->dimen;
1805 :
1806 27836 : 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 1072 : gfc_get_iteration_count (tree start, tree end, tree step)
1815 : {
1816 1072 : tree tmp;
1817 1072 : tree type;
1818 :
1819 1072 : type = TREE_TYPE (step);
1820 1072 : tmp = fold_build2_loc (input_location, MINUS_EXPR, type, end, start);
1821 1072 : tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, type, tmp, step);
1822 1072 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp,
1823 : build_int_cst (type, 1));
1824 1072 : tmp = fold_build2_loc (input_location, MAX_EXPR, type, tmp,
1825 : build_int_cst (type, 0));
1826 1072 : 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 1060 : gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
1834 : {
1835 1060 : tree arg0, arg1;
1836 1060 : tree tmp;
1837 1060 : tree size;
1838 1060 : tree ubound;
1839 :
1840 1060 : if (integer_zerop (extra))
1841 : return;
1842 :
1843 1030 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
1844 :
1845 : /* Add EXTRA to the upper bound. */
1846 1030 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1847 : ubound, extra);
1848 1030 : gfc_conv_descriptor_ubound_set (pblock, desc, gfc_rank_cst[0], tmp);
1849 :
1850 : /* Get the value of the current data pointer. */
1851 1030 : arg0 = gfc_conv_descriptor_data_get (desc);
1852 :
1853 : /* Calculate the new array size. */
1854 1030 : size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
1855 1030 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1856 : ubound, gfc_index_one_node);
1857 1030 : 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 1030 : tmp = gfc_call_realloc (pblock, arg0, arg1);
1863 1030 : 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 2345 : gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
1872 : {
1873 2345 : return (i->start->expr_type != EXPR_CONSTANT
1874 1927 : || i->end->expr_type != EXPR_CONSTANT
1875 2518 : || 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 3278 : gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
1886 : {
1887 3278 : if (expr->expr_type == EXPR_ARRAY)
1888 679 : return gfc_get_array_constructor_size (size, expr->value.constructor);
1889 2599 : 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 1568 : mpz_set_ui (*size, 1);
1899 1568 : 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 3012 : gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base)
1909 : {
1910 3012 : gfc_constructor *c;
1911 3012 : gfc_iterator *i;
1912 3012 : mpz_t val;
1913 3012 : mpz_t len;
1914 3012 : bool dynamic;
1915 :
1916 3012 : mpz_set_ui (*size, 0);
1917 3012 : mpz_init (len);
1918 3012 : mpz_init (val);
1919 :
1920 3012 : dynamic = false;
1921 7372 : for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1922 : {
1923 4360 : i = c->iterator;
1924 4360 : if (i && gfc_iterator_has_dynamic_bounds (i))
1925 : dynamic = true;
1926 : else
1927 : {
1928 2733 : dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
1929 2733 : 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 2733 : mpz_add (*size, *size, len);
1942 : }
1943 : }
1944 3012 : mpz_clear (len);
1945 3012 : mpz_clear (val);
1946 3012 : return dynamic;
1947 : }
1948 :
1949 :
1950 : /* Make sure offset is a variable. */
1951 :
1952 : static void
1953 3315 : 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 3315 : gcc_assert (*offsetvar != NULL_TREE);
1959 3315 : gfc_add_modify (pblock, *offsetvar, *poffset);
1960 3315 : *poffset = *offsetvar;
1961 3315 : TREE_USED (*offsetvar) = 1;
1962 3315 : }
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 12501 : gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
1972 : tree offset, gfc_se * se, gfc_expr * expr)
1973 : {
1974 12501 : tree tmp, offset_eval;
1975 :
1976 12501 : gfc_conv_expr (se, expr);
1977 :
1978 : /* Store the value. */
1979 12501 : 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 12501 : offset_eval = gfc_evaluate_now (offset, &se->pre);
1984 12501 : tmp = gfc_build_array_ref (tmp, offset_eval, NULL);
1985 :
1986 12501 : if (expr->expr_type == EXPR_FUNCTION && expr->ts.type == BT_DERIVED
1987 84 : && expr->ts.u.derived->attr.alloc_comp)
1988 45 : 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 12501 : 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 10361 : else if (GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
2048 10361 : && !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 10337 : se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
2062 10337 : gfc_add_modify (&se->pre, tmp, se->expr);
2063 : }
2064 :
2065 12501 : gfc_add_block_to_block (pblock, &se->pre);
2066 12501 : gfc_add_block_to_block (pblock, &se->post);
2067 12501 : }
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 1141 : 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 1141 : gfc_se se;
2081 1141 : gfc_ss *ss;
2082 1141 : gfc_loopinfo loop;
2083 1141 : stmtblock_t body;
2084 1141 : tree tmp;
2085 1141 : tree size;
2086 1141 : int n;
2087 :
2088 : /* We need this to be a variable so we can increment it. */
2089 1141 : gfc_put_offset_into_var (pblock, poffset, offsetvar);
2090 :
2091 1141 : gfc_init_se (&se, NULL);
2092 :
2093 : /* Walk the array expression. */
2094 1141 : ss = gfc_walk_expr (expr);
2095 1141 : gcc_assert (ss != gfc_ss_terminator);
2096 :
2097 : /* Initialize the scalarizer. */
2098 1141 : gfc_init_loopinfo (&loop);
2099 1141 : gfc_add_ss_to_loop (&loop, ss);
2100 :
2101 : /* Initialize the loop. */
2102 1141 : gfc_conv_ss_startstride (&loop);
2103 1141 : gfc_conv_loop_setup (&loop, &expr->where);
2104 :
2105 : /* Make sure the constructed array has room for the new data. */
2106 1141 : 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 1141 : gfc_mark_ss_chain_used (ss, 1);
2124 1141 : gfc_start_scalarized_body (&loop, &body);
2125 1141 : gfc_copy_loopinfo_to_se (&se, &loop);
2126 1141 : se.ss = ss;
2127 :
2128 1141 : gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
2129 1141 : gcc_assert (se.ss == gfc_ss_terminator);
2130 :
2131 : /* Increment the offset. */
2132 1141 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2133 : *poffset, gfc_index_one_node);
2134 1141 : gfc_add_modify (&body, *poffset, tmp);
2135 :
2136 : /* Finish the loop. */
2137 1141 : gfc_trans_scalarizing_loops (&loop, &body);
2138 1141 : gfc_add_block_to_block (&loop.pre, &loop.post);
2139 1141 : tmp = gfc_finish_block (&loop.pre);
2140 1141 : gfc_add_expr_to_block (pblock, tmp);
2141 :
2142 1141 : gfc_cleanup_loop (&loop);
2143 1141 : }
2144 :
2145 :
2146 : /* Return true if every leaf element of an array constructor is a function
2147 : reference returning derived type DER, which has allocatable components.
2148 : Such results are moved (shallow-copied) into the constructor temporary, so
2149 : the temporary owns their allocatable components and they can all be freed
2150 : in a single sweep over the whole temporary. Returns false as soon as an
2151 : element is anything else - notably a variable, whose allocatable components
2152 : are aliased rather than owned by the temporary and must not be freed. */
2153 :
2154 : static bool
2155 514 : gfc_constructor_is_owned_alloc_comp (gfc_constructor_base base,
2156 : gfc_symbol *der)
2157 : {
2158 514 : gfc_constructor *c;
2159 :
2160 514 : if (base == NULL)
2161 : return false;
2162 :
2163 595 : for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
2164 : {
2165 515 : gfc_expr *e = c->expr;
2166 515 : if (e->expr_type == EXPR_ARRAY)
2167 : {
2168 54 : if (!gfc_constructor_is_owned_alloc_comp (e->value.constructor, der))
2169 : return false;
2170 : }
2171 461 : else if (!(e->expr_type == EXPR_FUNCTION
2172 39 : && e->ts.type == BT_DERIVED
2173 39 : && e->ts.u.derived == der))
2174 : return false;
2175 : }
2176 : return true;
2177 : }
2178 :
2179 :
2180 : /* Assign the values to the elements of an array constructor. DYNAMIC
2181 : is true if descriptor DESC only contains enough data for the static
2182 : size calculated by gfc_get_array_constructor_size. When true, memory
2183 : for the dynamic parts must be allocated using realloc. OWNED_SWEEP is
2184 : true when the caller will free the allocatable components of every
2185 : constructor element in one sweep over the whole temporary; in that case
2186 : the per-element finalization built here is suppressed to avoid a double
2187 : free. */
2188 :
2189 : static void
2190 8280 : gfc_trans_array_constructor_value (stmtblock_t * pblock,
2191 : stmtblock_t * finalblock,
2192 : tree type, tree desc,
2193 : gfc_constructor_base base, tree * poffset,
2194 : tree * offsetvar, bool dynamic,
2195 : bool owned_sweep)
2196 : {
2197 8280 : tree tmp;
2198 8280 : tree start = NULL_TREE;
2199 8280 : tree end = NULL_TREE;
2200 8280 : tree step = NULL_TREE;
2201 8280 : stmtblock_t body;
2202 8280 : gfc_se se;
2203 8280 : mpz_t size;
2204 8280 : gfc_constructor *c;
2205 8280 : gfc_typespec ts;
2206 8280 : int ctr = 0;
2207 :
2208 8280 : tree shadow_loopvar = NULL_TREE;
2209 8280 : gfc_saved_var saved_loopvar;
2210 :
2211 8280 : ts.type = BT_UNKNOWN;
2212 8280 : mpz_init (size);
2213 22383 : for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
2214 : {
2215 14103 : ctr++;
2216 : /* If this is an iterator or an array, the offset must be a variable. */
2217 14103 : if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
2218 2174 : gfc_put_offset_into_var (pblock, poffset, offsetvar);
2219 :
2220 : /* Shadowing the iterator avoids changing its value and saves us from
2221 : keeping track of it. Further, it makes sure that there's always a
2222 : backend-decl for the symbol, even if there wasn't one before,
2223 : e.g. in the case of an iterator that appears in a specification
2224 : expression in an interface mapping. */
2225 14103 : if (c->iterator)
2226 : {
2227 1475 : gfc_symbol *sym;
2228 1475 : tree type;
2229 :
2230 : /* Evaluate loop bounds before substituting the loop variable
2231 : in case they depend on it. Such a case is invalid, but it is
2232 : not more expensive to do the right thing here.
2233 : See PR 44354. */
2234 1475 : gfc_init_se (&se, NULL);
2235 1475 : gfc_conv_expr_val (&se, c->iterator->start);
2236 1475 : gfc_add_block_to_block (pblock, &se.pre);
2237 1475 : start = gfc_evaluate_now (se.expr, pblock);
2238 :
2239 1475 : gfc_init_se (&se, NULL);
2240 1475 : gfc_conv_expr_val (&se, c->iterator->end);
2241 1475 : gfc_add_block_to_block (pblock, &se.pre);
2242 1475 : end = gfc_evaluate_now (se.expr, pblock);
2243 :
2244 1475 : gfc_init_se (&se, NULL);
2245 1475 : gfc_conv_expr_val (&se, c->iterator->step);
2246 1475 : gfc_add_block_to_block (pblock, &se.pre);
2247 1475 : step = gfc_evaluate_now (se.expr, pblock);
2248 :
2249 1475 : sym = c->iterator->var->symtree->n.sym;
2250 1475 : type = gfc_typenode_for_spec (&sym->ts);
2251 :
2252 1475 : shadow_loopvar = gfc_create_var (type, "shadow_loopvar");
2253 1475 : gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar);
2254 : }
2255 :
2256 14103 : gfc_start_block (&body);
2257 :
2258 14103 : if (c->expr->expr_type == EXPR_ARRAY)
2259 : {
2260 : /* Array constructors can be nested. */
2261 1497 : gfc_trans_array_constructor_value (&body, finalblock, type,
2262 : desc, c->expr->value.constructor,
2263 : poffset, offsetvar, dynamic,
2264 : owned_sweep);
2265 : }
2266 12606 : else if (c->expr->rank > 0)
2267 : {
2268 1141 : gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
2269 : poffset, offsetvar, dynamic);
2270 : }
2271 : else
2272 : {
2273 : /* This code really upsets the gimplifier so don't bother for now. */
2274 : gfc_constructor *p;
2275 : HOST_WIDE_INT n;
2276 : HOST_WIDE_INT size;
2277 :
2278 : p = c;
2279 : n = 0;
2280 13270 : while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
2281 : {
2282 1805 : p = gfc_constructor_next (p);
2283 1805 : n++;
2284 : }
2285 : /* Constructor with few constant elements, or element size not
2286 : known at compile time (e.g. deferred-length character). */
2287 11465 : if (n < 4 || !INTEGER_CST_P (TYPE_SIZE_UNIT (type)))
2288 : {
2289 : /* Scalar values. */
2290 11360 : gfc_init_se (&se, NULL);
2291 11360 : if (IS_PDT (c->expr) && c->expr->expr_type == EXPR_STRUCTURE)
2292 276 : c->expr->must_finalize = 1;
2293 :
2294 11360 : gfc_trans_array_ctor_element (&body, desc, *poffset,
2295 : &se, c->expr);
2296 :
2297 11360 : *poffset = fold_build2_loc (input_location, PLUS_EXPR,
2298 : gfc_array_index_type,
2299 : *poffset, gfc_index_one_node);
2300 : /* Unless the whole temporary is being swept by the caller, add
2301 : the per-element finalization. The sweep is used when every
2302 : element is an owned function result, which is the only way to
2303 : correctly free elements produced inside an implied-do loop. */
2304 11360 : if (finalblock && !owned_sweep)
2305 1243 : gfc_add_block_to_block (finalblock, &se.finalblock);
2306 : }
2307 : else
2308 : {
2309 : /* Collect multiple scalar constants into a constructor. */
2310 105 : vec<constructor_elt, va_gc> *v = NULL;
2311 105 : tree init;
2312 105 : tree bound;
2313 105 : tree tmptype;
2314 105 : HOST_WIDE_INT idx = 0;
2315 :
2316 105 : p = c;
2317 : /* Count the number of consecutive scalar constants. */
2318 837 : while (p && !(p->iterator
2319 745 : || p->expr->expr_type != EXPR_CONSTANT))
2320 : {
2321 732 : gfc_init_se (&se, NULL);
2322 732 : gfc_conv_constant (&se, p->expr);
2323 :
2324 732 : if (c->expr->ts.type != BT_CHARACTER)
2325 660 : se.expr = fold_convert (type, se.expr);
2326 : /* For constant character array constructors we build
2327 : an array of pointers. */
2328 72 : else if (POINTER_TYPE_P (type))
2329 0 : se.expr = gfc_build_addr_expr
2330 0 : (gfc_get_pchar_type (p->expr->ts.kind),
2331 : se.expr);
2332 :
2333 732 : CONSTRUCTOR_APPEND_ELT (v,
2334 : build_int_cst (gfc_array_index_type,
2335 : idx++),
2336 : se.expr);
2337 732 : c = p;
2338 732 : p = gfc_constructor_next (p);
2339 : }
2340 :
2341 105 : bound = size_int (n - 1);
2342 : /* Create an array type to hold them. */
2343 105 : tmptype = build_range_type (gfc_array_index_type,
2344 : gfc_index_zero_node, bound);
2345 105 : tmptype = build_array_type (type, tmptype);
2346 :
2347 105 : init = build_constructor (tmptype, v);
2348 105 : TREE_CONSTANT (init) = 1;
2349 105 : TREE_STATIC (init) = 1;
2350 : /* Create a static variable to hold the data. */
2351 105 : tmp = gfc_create_var (tmptype, "data");
2352 105 : TREE_STATIC (tmp) = 1;
2353 105 : TREE_CONSTANT (tmp) = 1;
2354 105 : TREE_READONLY (tmp) = 1;
2355 105 : DECL_INITIAL (tmp) = init;
2356 105 : init = tmp;
2357 :
2358 : /* Use BUILTIN_MEMCPY to assign the values. */
2359 105 : tmp = gfc_conv_descriptor_data_get (desc);
2360 105 : tmp = build_fold_indirect_ref_loc (input_location,
2361 : tmp);
2362 105 : tmp = gfc_build_array_ref (tmp, *poffset, NULL);
2363 105 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
2364 105 : init = gfc_build_addr_expr (NULL_TREE, init);
2365 :
2366 105 : size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
2367 105 : bound = build_int_cst (size_type_node, n * size);
2368 105 : tmp = build_call_expr_loc (input_location,
2369 : builtin_decl_explicit (BUILT_IN_MEMCPY),
2370 : 3, tmp, init, bound);
2371 105 : gfc_add_expr_to_block (&body, tmp);
2372 :
2373 105 : *poffset = fold_build2_loc (input_location, PLUS_EXPR,
2374 : gfc_array_index_type, *poffset,
2375 105 : build_int_cst (gfc_array_index_type, n));
2376 : }
2377 11465 : if (!INTEGER_CST_P (*poffset))
2378 : {
2379 1777 : gfc_add_modify (&body, *offsetvar, *poffset);
2380 1777 : *poffset = *offsetvar;
2381 : }
2382 :
2383 11465 : if (!c->iterator)
2384 11465 : ts = c->expr->ts;
2385 : }
2386 :
2387 : /* The frontend should already have done any expansions
2388 : at compile-time. */
2389 14103 : if (!c->iterator)
2390 : {
2391 : /* Pass the code as is. */
2392 12628 : tmp = gfc_finish_block (&body);
2393 12628 : gfc_add_expr_to_block (pblock, tmp);
2394 : }
2395 : else
2396 : {
2397 : /* Build the implied do-loop. */
2398 1475 : stmtblock_t implied_do_block;
2399 1475 : tree cond;
2400 1475 : tree exit_label;
2401 1475 : tree loopbody;
2402 1475 : tree tmp2;
2403 :
2404 1475 : loopbody = gfc_finish_block (&body);
2405 :
2406 : /* Create a new block that holds the implied-do loop. A temporary
2407 : loop-variable is used. */
2408 1475 : gfc_start_block(&implied_do_block);
2409 :
2410 : /* Initialize the loop. */
2411 1475 : gfc_add_modify (&implied_do_block, shadow_loopvar, start);
2412 :
2413 : /* If this array expands dynamically, and the number of iterations
2414 : is not constant, we won't have allocated space for the static
2415 : part of C->EXPR's size. Do that now. */
2416 1475 : if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
2417 : {
2418 : /* Get the number of iterations. */
2419 545 : tmp = gfc_get_iteration_count (shadow_loopvar, end, step);
2420 :
2421 : /* Get the static part of C->EXPR's size. */
2422 545 : gfc_get_array_constructor_element_size (&size, c->expr);
2423 545 : tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
2424 :
2425 : /* Grow the array by TMP * TMP2 elements. */
2426 545 : tmp = fold_build2_loc (input_location, MULT_EXPR,
2427 : gfc_array_index_type, tmp, tmp2);
2428 545 : gfc_grow_array (&implied_do_block, desc, tmp);
2429 : }
2430 :
2431 : /* Generate the loop body. */
2432 1475 : exit_label = gfc_build_label_decl (NULL_TREE);
2433 1475 : gfc_start_block (&body);
2434 :
2435 : /* Generate the exit condition. Depending on the sign of
2436 : the step variable we have to generate the correct
2437 : comparison. */
2438 1475 : tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2439 1475 : step, build_int_cst (TREE_TYPE (step), 0));
2440 1475 : cond = fold_build3_loc (input_location, COND_EXPR,
2441 : logical_type_node, tmp,
2442 : fold_build2_loc (input_location, GT_EXPR,
2443 : logical_type_node, shadow_loopvar, end),
2444 : fold_build2_loc (input_location, LT_EXPR,
2445 : logical_type_node, shadow_loopvar, end));
2446 1475 : tmp = build1_v (GOTO_EXPR, exit_label);
2447 1475 : TREE_USED (exit_label) = 1;
2448 1475 : tmp = build3_v (COND_EXPR, cond, tmp,
2449 : build_empty_stmt (input_location));
2450 1475 : gfc_add_expr_to_block (&body, tmp);
2451 :
2452 : /* The main loop body. */
2453 1475 : gfc_add_expr_to_block (&body, loopbody);
2454 :
2455 : /* Increase loop variable by step. */
2456 1475 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
2457 1475 : TREE_TYPE (shadow_loopvar), shadow_loopvar,
2458 : step);
2459 1475 : gfc_add_modify (&body, shadow_loopvar, tmp);
2460 :
2461 : /* Finish the loop. */
2462 1475 : tmp = gfc_finish_block (&body);
2463 1475 : tmp = build1_v (LOOP_EXPR, tmp);
2464 1475 : gfc_add_expr_to_block (&implied_do_block, tmp);
2465 :
2466 : /* Add the exit label. */
2467 1475 : tmp = build1_v (LABEL_EXPR, exit_label);
2468 1475 : gfc_add_expr_to_block (&implied_do_block, tmp);
2469 :
2470 : /* Finish the implied-do loop. */
2471 1475 : tmp = gfc_finish_block(&implied_do_block);
2472 1475 : gfc_add_expr_to_block(pblock, tmp);
2473 :
2474 1475 : gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar);
2475 : }
2476 : }
2477 :
2478 : /* F2008 4.5.6.3 para 5: If an executable construct references a structure
2479 : constructor or array constructor, the entity created by the constructor is
2480 : finalized after execution of the innermost executable construct containing
2481 : the reference. This, in fact, was later deleted by the Combined Technical
2482 : Corrigenda 1 TO 4 for fortran 2008 (f08/0011).
2483 :
2484 : Transmit finalization of this constructor through 'finalblock'. */
2485 8280 : if ((gfc_option.allow_std & (GFC_STD_F2008 | GFC_STD_F2003))
2486 8280 : && !(gfc_option.allow_std & GFC_STD_GNU)
2487 70 : && finalblock != NULL
2488 24 : && gfc_may_be_finalized (ts)
2489 18 : && ctr > 0 && desc != NULL_TREE
2490 8298 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
2491 : {
2492 18 : symbol_attribute attr;
2493 18 : gfc_se fse;
2494 18 : locus loc;
2495 18 : gfc_locus_from_location (&loc, input_location);
2496 18 : gfc_warning (0, "The structure constructor at %L has been"
2497 : " finalized. This feature was removed by f08/0011."
2498 : " Use -std=f2018 or -std=gnu to eliminate the"
2499 : " finalization.", &loc);
2500 18 : attr.pointer = attr.allocatable = 0;
2501 18 : gfc_init_se (&fse, NULL);
2502 18 : fse.expr = desc;
2503 18 : gfc_finalize_tree_expr (&fse, ts.u.derived, attr, 1);
2504 18 : gfc_add_block_to_block (finalblock, &fse.pre);
2505 18 : gfc_add_block_to_block (finalblock, &fse.finalblock);
2506 18 : gfc_add_block_to_block (finalblock, &fse.post);
2507 : }
2508 :
2509 8280 : mpz_clear (size);
2510 8280 : }
2511 :
2512 :
2513 : /* The array constructor code can create a string length with an operand
2514 : in the form of a temporary variable. This variable will retain its
2515 : context (current_function_decl). If we store this length tree in a
2516 : gfc_charlen structure which is shared by a variable in another
2517 : context, the resulting gfc_charlen structure with a variable in a
2518 : different context, we could trip the assertion in expand_expr_real_1
2519 : when it sees that a variable has been created in one context and
2520 : referenced in another.
2521 :
2522 : If this might be the case, we create a new gfc_charlen structure and
2523 : link it into the current namespace. */
2524 :
2525 : static void
2526 8447 : store_backend_decl (gfc_charlen **clp, tree len, bool force_new_cl)
2527 : {
2528 8447 : if (force_new_cl)
2529 : {
2530 8420 : gfc_charlen *new_cl = gfc_new_charlen (gfc_current_ns, *clp);
2531 8420 : *clp = new_cl;
2532 : }
2533 8447 : (*clp)->backend_decl = len;
2534 8447 : }
2535 :
2536 : /* A catch-all to obtain the string length for anything that is not
2537 : a substring of non-constant length, a constant, array or variable. */
2538 :
2539 : static void
2540 330 : get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
2541 : {
2542 330 : gfc_se se;
2543 :
2544 : /* Don't bother if we already know the length is a constant. */
2545 330 : if (*len && INTEGER_CST_P (*len))
2546 52 : return;
2547 :
2548 278 : if (!e->ref && e->ts.u.cl && e->ts.u.cl->length
2549 29 : && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
2550 : {
2551 : /* This is easy. */
2552 1 : gfc_conv_const_charlen (e->ts.u.cl);
2553 1 : *len = e->ts.u.cl->backend_decl;
2554 : }
2555 : else
2556 : {
2557 : /* Otherwise, be brutal even if inefficient. */
2558 277 : gfc_init_se (&se, NULL);
2559 :
2560 : /* No function call, in case of side effects. */
2561 277 : se.no_function_call = 1;
2562 277 : if (e->rank == 0)
2563 134 : gfc_conv_expr (&se, e);
2564 : else
2565 143 : gfc_conv_expr_descriptor (&se, e);
2566 :
2567 : /* Fix the value. */
2568 277 : *len = gfc_evaluate_now (se.string_length, &se.pre);
2569 :
2570 277 : gfc_add_block_to_block (block, &se.pre);
2571 277 : gfc_add_block_to_block (block, &se.post);
2572 :
2573 277 : store_backend_decl (&e->ts.u.cl, *len, true);
2574 : }
2575 : }
2576 :
2577 :
2578 : /* Figure out the string length of a variable reference expression.
2579 : Used by get_array_ctor_strlen. */
2580 :
2581 : static void
2582 930 : get_array_ctor_var_strlen (stmtblock_t *block, gfc_expr * expr, tree * len)
2583 : {
2584 930 : gfc_ref *ref;
2585 930 : gfc_typespec *ts;
2586 930 : mpz_t char_len;
2587 930 : gfc_se se;
2588 :
2589 : /* Don't bother if we already know the length is a constant. */
2590 930 : if (*len && INTEGER_CST_P (*len))
2591 557 : return;
2592 :
2593 468 : ts = &expr->symtree->n.sym->ts;
2594 747 : for (ref = expr->ref; ref; ref = ref->next)
2595 : {
2596 374 : switch (ref->type)
2597 : {
2598 234 : case REF_ARRAY:
2599 : /* Array references don't change the string length. */
2600 234 : if (ts->deferred)
2601 136 : get_array_ctor_all_strlen (block, expr, len);
2602 : break;
2603 :
2604 45 : case REF_COMPONENT:
2605 : /* Use the length of the component. */
2606 45 : ts = &ref->u.c.component->ts;
2607 45 : break;
2608 :
2609 95 : case REF_SUBSTRING:
2610 95 : if (ref->u.ss.end == NULL
2611 83 : || ref->u.ss.start->expr_type != EXPR_CONSTANT
2612 64 : || ref->u.ss.end->expr_type != EXPR_CONSTANT)
2613 : {
2614 : /* Note that this might evaluate expr. */
2615 64 : get_array_ctor_all_strlen (block, expr, len);
2616 64 : return;
2617 : }
2618 31 : mpz_init_set_ui (char_len, 1);
2619 31 : mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
2620 31 : mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
2621 31 : *len = gfc_conv_mpz_to_tree_type (char_len, gfc_charlen_type_node);
2622 31 : mpz_clear (char_len);
2623 31 : return;
2624 :
2625 : case REF_INQUIRY:
2626 : break;
2627 :
2628 0 : default:
2629 0 : gcc_unreachable ();
2630 : }
2631 : }
2632 :
2633 : /* A last ditch attempt that is sometimes needed for deferred characters. */
2634 373 : if (!ts->u.cl->backend_decl)
2635 : {
2636 19 : gfc_init_se (&se, NULL);
2637 19 : if (expr->rank)
2638 12 : gfc_conv_expr_descriptor (&se, expr);
2639 : else
2640 7 : gfc_conv_expr (&se, expr);
2641 19 : gcc_assert (se.string_length != NULL_TREE);
2642 19 : gfc_add_block_to_block (block, &se.pre);
2643 19 : ts->u.cl->backend_decl = se.string_length;
2644 : }
2645 :
2646 373 : *len = ts->u.cl->backend_decl;
2647 : }
2648 :
2649 :
2650 : /* Figure out the string length of a character array constructor.
2651 : If len is NULL, don't calculate the length; this happens for recursive calls
2652 : when a sub-array-constructor is an element but not at the first position,
2653 : so when we're not interested in the length.
2654 : Returns TRUE if all elements are character constants. */
2655 :
2656 : bool
2657 8878 : get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len)
2658 : {
2659 8878 : gfc_constructor *c;
2660 8878 : bool is_const;
2661 :
2662 8878 : is_const = true;
2663 :
2664 8878 : if (gfc_constructor_first (base) == NULL)
2665 : {
2666 315 : if (len)
2667 315 : *len = build_int_cstu (gfc_charlen_type_node, 0);
2668 315 : return is_const;
2669 : }
2670 :
2671 : /* Loop over all constructor elements to find out is_const, but in len we
2672 : want to store the length of the first, not the last, element. We can
2673 : of course exit the loop as soon as is_const is found to be false. */
2674 8563 : for (c = gfc_constructor_first (base);
2675 46764 : c && is_const; c = gfc_constructor_next (c))
2676 : {
2677 38201 : switch (c->expr->expr_type)
2678 : {
2679 37038 : case EXPR_CONSTANT:
2680 37038 : if (len && !(*len && INTEGER_CST_P (*len)))
2681 404 : *len = build_int_cstu (gfc_charlen_type_node,
2682 404 : c->expr->value.character.length);
2683 : break;
2684 :
2685 43 : case EXPR_ARRAY:
2686 43 : if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
2687 1151 : is_const = false;
2688 : break;
2689 :
2690 990 : case EXPR_VARIABLE:
2691 990 : is_const = false;
2692 990 : if (len)
2693 930 : get_array_ctor_var_strlen (block, c->expr, len);
2694 : break;
2695 :
2696 130 : default:
2697 130 : is_const = false;
2698 130 : if (len)
2699 130 : get_array_ctor_all_strlen (block, c->expr, len);
2700 : break;
2701 : }
2702 :
2703 : /* After the first iteration, we don't want the length modified. */
2704 38201 : len = NULL;
2705 : }
2706 :
2707 : return is_const;
2708 : }
2709 :
2710 : /* Check whether the array constructor C consists entirely of constant
2711 : elements, and if so returns the number of those elements, otherwise
2712 : return zero. Note, an empty or NULL array constructor returns zero. */
2713 :
2714 : unsigned HOST_WIDE_INT
2715 59495 : gfc_constant_array_constructor_p (gfc_constructor_base base)
2716 : {
2717 59495 : unsigned HOST_WIDE_INT nelem = 0;
2718 :
2719 59495 : gfc_constructor *c = gfc_constructor_first (base);
2720 540288 : while (c)
2721 : {
2722 428323 : if (c->iterator
2723 426728 : || c->expr->rank > 0
2724 425918 : || c->expr->expr_type != EXPR_CONSTANT)
2725 : return 0;
2726 421298 : c = gfc_constructor_next (c);
2727 421298 : nelem++;
2728 : }
2729 : return nelem;
2730 : }
2731 :
2732 :
2733 : /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
2734 : and the tree type of it's elements, TYPE, return a static constant
2735 : variable that is compile-time initialized. */
2736 :
2737 : tree
2738 41971 : gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
2739 : {
2740 41971 : tree tmptype, init, tmp;
2741 41971 : HOST_WIDE_INT nelem;
2742 41971 : gfc_constructor *c;
2743 41971 : gfc_array_spec as;
2744 41971 : gfc_se se;
2745 41971 : int i;
2746 41971 : vec<constructor_elt, va_gc> *v = NULL;
2747 :
2748 : /* First traverse the constructor list, converting the constants
2749 : to tree to build an initializer. */
2750 41971 : nelem = 0;
2751 41971 : c = gfc_constructor_first (expr->value.constructor);
2752 422395 : while (c)
2753 : {
2754 338453 : gfc_init_se (&se, NULL);
2755 338453 : gfc_conv_constant (&se, c->expr);
2756 338453 : if (c->expr->ts.type != BT_CHARACTER)
2757 302335 : se.expr = fold_convert (type, se.expr);
2758 36118 : else if (POINTER_TYPE_P (type))
2759 36118 : se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
2760 : se.expr);
2761 338453 : CONSTRUCTOR_APPEND_ELT (v, build_int_cst (gfc_array_index_type, nelem),
2762 : se.expr);
2763 338453 : c = gfc_constructor_next (c);
2764 338453 : nelem++;
2765 : }
2766 :
2767 : /* Next determine the tree type for the array. We use the gfortran
2768 : front-end's gfc_get_nodesc_array_type in order to create a suitable
2769 : GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
2770 :
2771 41971 : memset (&as, 0, sizeof (gfc_array_spec));
2772 :
2773 41971 : as.rank = expr->rank;
2774 41971 : as.type = AS_EXPLICIT;
2775 41971 : if (!expr->shape)
2776 : {
2777 4 : as.lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
2778 4 : as.upper[0] = gfc_get_int_expr (gfc_default_integer_kind,
2779 : NULL, nelem - 1);
2780 : }
2781 : else
2782 90493 : for (i = 0; i < expr->rank; i++)
2783 : {
2784 48526 : int tmp = (int) mpz_get_si (expr->shape[i]);
2785 48526 : as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
2786 48526 : as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind,
2787 48526 : NULL, tmp - 1);
2788 : }
2789 :
2790 41971 : tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
2791 :
2792 : /* as is not needed anymore. */
2793 132472 : for (i = 0; i < as.rank + as.corank; i++)
2794 : {
2795 48530 : gfc_free_expr (as.lower[i]);
2796 48530 : gfc_free_expr (as.upper[i]);
2797 : }
2798 :
2799 41971 : init = build_constructor (tmptype, v);
2800 :
2801 41971 : TREE_CONSTANT (init) = 1;
2802 41971 : TREE_STATIC (init) = 1;
2803 :
2804 41971 : tmp = build_decl (input_location, VAR_DECL, create_tmp_var_name ("A"),
2805 : tmptype);
2806 41971 : DECL_ARTIFICIAL (tmp) = 1;
2807 41971 : DECL_IGNORED_P (tmp) = 1;
2808 41971 : TREE_STATIC (tmp) = 1;
2809 41971 : TREE_CONSTANT (tmp) = 1;
2810 41971 : TREE_READONLY (tmp) = 1;
2811 41971 : DECL_INITIAL (tmp) = init;
2812 41971 : pushdecl (tmp);
2813 :
2814 41971 : return tmp;
2815 : }
2816 :
2817 :
2818 : /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
2819 : This mostly initializes the scalarizer state info structure with the
2820 : appropriate values to directly use the array created by the function
2821 : gfc_build_constant_array_constructor. */
2822 :
2823 : static void
2824 36144 : trans_constant_array_constructor (gfc_ss * ss, tree type)
2825 : {
2826 36144 : gfc_array_info *info;
2827 36144 : tree tmp;
2828 36144 : int i;
2829 :
2830 36144 : tmp = gfc_build_constant_array_constructor (ss->info->expr, type);
2831 :
2832 36144 : info = &ss->info->data.array;
2833 :
2834 36144 : info->descriptor = tmp;
2835 36144 : info->data = gfc_build_addr_expr (NULL_TREE, tmp);
2836 36144 : info->offset = gfc_index_zero_node;
2837 :
2838 76047 : for (i = 0; i < ss->dimen; i++)
2839 : {
2840 39903 : info->delta[i] = gfc_index_zero_node;
2841 39903 : info->start[i] = gfc_index_zero_node;
2842 39903 : info->end[i] = gfc_index_zero_node;
2843 39903 : info->stride[i] = gfc_index_one_node;
2844 : }
2845 36144 : }
2846 :
2847 :
2848 : static int
2849 36150 : get_rank (gfc_loopinfo *loop)
2850 : {
2851 36150 : int rank;
2852 :
2853 36150 : rank = 0;
2854 155274 : for (; loop; loop = loop->parent)
2855 77643 : rank += loop->dimen;
2856 :
2857 41481 : return rank;
2858 : }
2859 :
2860 :
2861 : /* Helper routine of gfc_trans_array_constructor to determine if the
2862 : bounds of the loop specified by LOOP are constant and simple enough
2863 : to use with trans_constant_array_constructor. Returns the
2864 : iteration count of the loop if suitable, and NULL_TREE otherwise. */
2865 :
2866 : static tree
2867 36150 : constant_array_constructor_loop_size (gfc_loopinfo * l)
2868 : {
2869 36150 : gfc_loopinfo *loop;
2870 36150 : tree size = gfc_index_one_node;
2871 36150 : tree tmp;
2872 36150 : int i, total_dim;
2873 :
2874 36150 : total_dim = get_rank (l);
2875 :
2876 72300 : for (loop = l; loop; loop = loop->parent)
2877 : {
2878 76071 : for (i = 0; i < loop->dimen; i++)
2879 : {
2880 : /* If the bounds aren't constant, return NULL_TREE. */
2881 39921 : if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
2882 : return NULL_TREE;
2883 39915 : if (!integer_zerop (loop->from[i]))
2884 : {
2885 : /* Only allow nonzero "from" in one-dimensional arrays. */
2886 0 : if (total_dim != 1)
2887 : return NULL_TREE;
2888 0 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2889 : gfc_array_index_type,
2890 : loop->to[i], loop->from[i]);
2891 : }
2892 : else
2893 39915 : tmp = loop->to[i];
2894 39915 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
2895 : gfc_array_index_type, tmp, gfc_index_one_node);
2896 39915 : size = fold_build2_loc (input_location, MULT_EXPR,
2897 : gfc_array_index_type, size, tmp);
2898 : }
2899 : }
2900 :
2901 : return size;
2902 : }
2903 :
2904 :
2905 : static tree *
2906 42927 : get_loop_upper_bound_for_array (gfc_ss *array, int array_dim)
2907 : {
2908 42927 : gfc_ss *ss;
2909 42927 : int n;
2910 :
2911 42927 : gcc_assert (array->nested_ss == NULL);
2912 :
2913 42927 : for (ss = array; ss; ss = ss->parent)
2914 42927 : for (n = 0; n < ss->loop->dimen; n++)
2915 42927 : if (array_dim == get_array_ref_dim_for_loop_dim (ss, n))
2916 42927 : return &(ss->loop->to[n]);
2917 :
2918 0 : gcc_unreachable ();
2919 : }
2920 :
2921 :
2922 : static gfc_loopinfo *
2923 708789 : outermost_loop (gfc_loopinfo * loop)
2924 : {
2925 924931 : while (loop->parent != NULL)
2926 : loop = loop->parent;
2927 :
2928 715477 : return loop;
2929 : }
2930 :
2931 :
2932 : /* Array constructors are handled by constructing a temporary, then using that
2933 : within the scalarization loop. This is not optimal, but seems by far the
2934 : simplest method. */
2935 :
2936 : static void
2937 42927 : trans_array_constructor (gfc_ss * ss, locus * where)
2938 : {
2939 42927 : gfc_constructor_base c;
2940 42927 : tree offset;
2941 42927 : tree offsetvar;
2942 42927 : tree desc;
2943 42927 : tree type;
2944 42927 : tree tmp;
2945 42927 : tree *loop_ubound0;
2946 42927 : bool dynamic;
2947 42927 : bool old_first_len, old_typespec_chararray_ctor;
2948 42927 : tree old_first_len_val;
2949 42927 : gfc_loopinfo *loop, *outer_loop;
2950 42927 : gfc_ss_info *ss_info;
2951 42927 : gfc_expr *expr;
2952 42927 : gfc_ss *s;
2953 42927 : tree neg_len;
2954 42927 : char *msg;
2955 42927 : stmtblock_t finalblock;
2956 42927 : bool finalize_required;
2957 42927 : bool owned_sweep = false;
2958 :
2959 : /* Save the old values for nested checking. */
2960 42927 : old_first_len = first_len;
2961 42927 : old_first_len_val = first_len_val;
2962 42927 : old_typespec_chararray_ctor = typespec_chararray_ctor;
2963 :
2964 42927 : loop = ss->loop;
2965 42927 : outer_loop = outermost_loop (loop);
2966 42927 : ss_info = ss->info;
2967 42927 : expr = ss_info->expr;
2968 :
2969 : /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
2970 : typespec was given for the array constructor. */
2971 85854 : typespec_chararray_ctor = (expr->ts.type == BT_CHARACTER
2972 8170 : && expr->ts.u.cl
2973 51097 : && expr->ts.u.cl->length_from_typespec);
2974 :
2975 42927 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2976 2542 : && expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
2977 : {
2978 1468 : first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
2979 1468 : first_len = true;
2980 : }
2981 :
2982 42927 : gcc_assert (ss->dimen == ss->loop->dimen);
2983 :
2984 42927 : c = expr->value.constructor;
2985 42927 : if (expr->ts.type == BT_CHARACTER)
2986 : {
2987 8170 : bool const_string;
2988 8170 : bool force_new_cl = false;
2989 :
2990 : /* get_array_ctor_strlen walks the elements of the constructor, if a
2991 : typespec was given, we already know the string length and want the one
2992 : specified there. */
2993 8170 : if (typespec_chararray_ctor && expr->ts.u.cl->length
2994 518 : && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
2995 : {
2996 27 : gfc_se length_se;
2997 :
2998 27 : const_string = false;
2999 27 : gfc_init_se (&length_se, NULL);
3000 27 : gfc_conv_expr_type (&length_se, expr->ts.u.cl->length,
3001 : gfc_charlen_type_node);
3002 27 : ss_info->string_length = length_se.expr;
3003 :
3004 : /* Check if the character length is negative. If it is, then
3005 : set LEN = 0. */
3006 27 : neg_len = fold_build2_loc (input_location, LT_EXPR,
3007 : logical_type_node, ss_info->string_length,
3008 27 : build_zero_cst (TREE_TYPE
3009 : (ss_info->string_length)));
3010 : /* Print a warning if bounds checking is enabled. */
3011 27 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3012 : {
3013 18 : msg = xasprintf ("Negative character length treated as LEN = 0");
3014 18 : gfc_trans_runtime_check (false, true, neg_len, &length_se.pre,
3015 : where, msg);
3016 18 : free (msg);
3017 : }
3018 :
3019 27 : ss_info->string_length
3020 27 : = fold_build3_loc (input_location, COND_EXPR,
3021 : gfc_charlen_type_node, neg_len,
3022 : build_zero_cst
3023 27 : (TREE_TYPE (ss_info->string_length)),
3024 : ss_info->string_length);
3025 27 : ss_info->string_length = gfc_evaluate_now (ss_info->string_length,
3026 : &length_se.pre);
3027 27 : gfc_add_block_to_block (&outer_loop->pre, &length_se.pre);
3028 27 : gfc_add_block_to_block (&outer_loop->post, &length_se.post);
3029 27 : }
3030 : else
3031 : {
3032 8143 : const_string = get_array_ctor_strlen (&outer_loop->pre, c,
3033 : &ss_info->string_length);
3034 8143 : force_new_cl = true;
3035 :
3036 : /* Initialize "len" with string length for bounds checking. */
3037 8143 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3038 1486 : && !typespec_chararray_ctor
3039 1468 : && ss_info->string_length)
3040 : {
3041 1468 : gfc_se length_se;
3042 :
3043 1468 : gfc_init_se (&length_se, NULL);
3044 1468 : gfc_add_modify (&length_se.pre, first_len_val,
3045 1468 : fold_convert (TREE_TYPE (first_len_val),
3046 : ss_info->string_length));
3047 1468 : ss_info->string_length = gfc_evaluate_now (ss_info->string_length,
3048 : &length_se.pre);
3049 1468 : gfc_add_block_to_block (&outer_loop->pre, &length_se.pre);
3050 1468 : gfc_add_block_to_block (&outer_loop->post, &length_se.post);
3051 : }
3052 : }
3053 :
3054 : /* Complex character array constructors should have been taken care of
3055 : and not end up here. */
3056 8170 : gcc_assert (ss_info->string_length);
3057 :
3058 8170 : store_backend_decl (&expr->ts.u.cl, ss_info->string_length, force_new_cl);
3059 :
3060 8170 : type = gfc_get_character_type_len (expr->ts.kind, ss_info->string_length);
3061 8170 : if (const_string)
3062 7219 : type = build_pointer_type (type);
3063 : }
3064 : else
3065 34782 : type = gfc_typenode_for_spec (expr->ts.type == BT_CLASS
3066 25 : ? &CLASS_DATA (expr)->ts : &expr->ts);
3067 :
3068 : /* See if the constructor determines the loop bounds. */
3069 42927 : dynamic = false;
3070 :
3071 42927 : loop_ubound0 = get_loop_upper_bound_for_array (ss, 0);
3072 :
3073 84408 : if (expr->shape && get_rank (loop) > 1 && *loop_ubound0 == NULL_TREE)
3074 : {
3075 : /* We have a multidimensional parameter. */
3076 0 : for (s = ss; s; s = s->parent)
3077 : {
3078 : int n;
3079 0 : for (n = 0; n < s->loop->dimen; n++)
3080 : {
3081 0 : s->loop->from[n] = gfc_index_zero_node;
3082 0 : s->loop->to[n] = gfc_conv_mpz_to_tree (expr->shape[s->dim[n]],
3083 : gfc_index_integer_kind);
3084 0 : s->loop->to[n] = fold_build2_loc (input_location, MINUS_EXPR,
3085 : gfc_array_index_type,
3086 0 : s->loop->to[n],
3087 : gfc_index_one_node);
3088 : }
3089 : }
3090 : }
3091 :
3092 42927 : if (*loop_ubound0 == NULL_TREE)
3093 : {
3094 887 : mpz_t size;
3095 :
3096 : /* We should have a 1-dimensional, zero-based loop. */
3097 887 : gcc_assert (loop->parent == NULL && loop->nested == NULL);
3098 887 : gcc_assert (loop->dimen == 1);
3099 887 : gcc_assert (integer_zerop (loop->from[0]));
3100 :
3101 : /* Split the constructor size into a static part and a dynamic part.
3102 : Allocate the static size up-front and record whether the dynamic
3103 : size might be nonzero. */
3104 887 : mpz_init (size);
3105 887 : dynamic = gfc_get_array_constructor_size (&size, c);
3106 887 : mpz_sub_ui (size, size, 1);
3107 887 : loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
3108 887 : mpz_clear (size);
3109 : }
3110 :
3111 : /* Special case constant array constructors. */
3112 887 : if (!dynamic)
3113 : {
3114 42065 : unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
3115 42065 : if (nelem > 0)
3116 : {
3117 36150 : tree size = constant_array_constructor_loop_size (loop);
3118 36150 : if (size && compare_tree_int (size, nelem) == 0)
3119 : {
3120 36144 : trans_constant_array_constructor (ss, type);
3121 36144 : goto finish;
3122 : }
3123 : }
3124 : }
3125 :
3126 6783 : gfc_trans_create_temp_array (&outer_loop->pre, &outer_loop->post, ss, type,
3127 : NULL_TREE, dynamic, true, false, where);
3128 :
3129 6783 : desc = ss_info->data.array.descriptor;
3130 6783 : offset = gfc_index_zero_node;
3131 6783 : offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
3132 6783 : suppress_warning (offsetvar);
3133 6783 : TREE_USED (offsetvar) = 0;
3134 :
3135 6783 : gfc_init_block (&finalblock);
3136 6783 : finalize_required = expr->must_finalize;
3137 6783 : if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
3138 : finalize_required = true;
3139 :
3140 6783 : if (IS_PDT (expr))
3141 : finalize_required = true;
3142 :
3143 : /* If every element of the constructor is a function result with allocatable
3144 : components, those components are owned by the temporary and are freed in a
3145 : single sweep over the whole array below. This is the only way to free the
3146 : elements produced inside an implied-do loop, where a single compile-time
3147 : element stands for many runtime elements. */
3148 14038 : owned_sweep = finalize_required
3149 545 : && expr->ts.type == BT_DERIVED
3150 545 : && expr->ts.u.derived->attr.alloc_comp
3151 7170 : && gfc_constructor_is_owned_alloc_comp (c, expr->ts.u.derived);
3152 :
3153 6783 : gfc_trans_array_constructor_value (&outer_loop->pre,
3154 : finalize_required ? &finalblock : NULL,
3155 : type, desc, c, &offset, &offsetvar,
3156 : dynamic, owned_sweep);
3157 :
3158 6783 : if (owned_sweep)
3159 38 : gfc_add_expr_to_block (&finalblock,
3160 38 : gfc_deallocate_alloc_comp_no_caf (expr->ts.u.derived,
3161 : desc, 1, true));
3162 :
3163 : /* If the array grows dynamically, the upper bound of the loop variable
3164 : is determined by the array's final upper bound. */
3165 6783 : if (dynamic)
3166 : {
3167 862 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
3168 : gfc_array_index_type,
3169 : offsetvar, gfc_index_one_node);
3170 862 : tmp = gfc_evaluate_now (tmp, &outer_loop->pre);
3171 862 : if (*loop_ubound0 && VAR_P (*loop_ubound0))
3172 0 : gfc_add_modify (&outer_loop->pre, *loop_ubound0, tmp);
3173 : else
3174 862 : *loop_ubound0 = tmp;
3175 : }
3176 :
3177 6783 : if (TREE_USED (offsetvar))
3178 2174 : pushdecl (offsetvar);
3179 : else
3180 4609 : gcc_assert (INTEGER_CST_P (offset));
3181 :
3182 : #if 0
3183 : /* Disable bound checking for now because it's probably broken. */
3184 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3185 : {
3186 : gcc_unreachable ();
3187 : }
3188 : #endif
3189 :
3190 4609 : finish:
3191 : /* Restore old values of globals. */
3192 42927 : first_len = old_first_len;
3193 42927 : first_len_val = old_first_len_val;
3194 42927 : typespec_chararray_ctor = old_typespec_chararray_ctor;
3195 :
3196 : /* F2008 4.5.6.3 para 5: If an executable construct references a structure
3197 : constructor or array constructor, the entity created by the constructor is
3198 : finalized after execution of the innermost executable construct containing
3199 : the reference. */
3200 42927 : if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
3201 1724 : && finalblock.head != NULL_TREE)
3202 110 : gfc_prepend_expr_to_block (&loop->post, finalblock.head);
3203 42927 : }
3204 :
3205 :
3206 : /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
3207 : called after evaluating all of INFO's vector dimensions. Go through
3208 : each such vector dimension and see if we can now fill in any missing
3209 : loop bounds. */
3210 :
3211 : static void
3212 181686 : set_vector_loop_bounds (gfc_ss * ss)
3213 : {
3214 181686 : gfc_loopinfo *loop, *outer_loop;
3215 181686 : gfc_array_info *info;
3216 181686 : gfc_se se;
3217 181686 : tree tmp;
3218 181686 : tree desc;
3219 181686 : tree zero;
3220 181686 : int n;
3221 181686 : int dim;
3222 :
3223 181686 : outer_loop = outermost_loop (ss->loop);
3224 :
3225 181686 : info = &ss->info->data.array;
3226 :
3227 368008 : for (; ss; ss = ss->parent)
3228 : {
3229 186322 : loop = ss->loop;
3230 :
3231 443650 : for (n = 0; n < loop->dimen; n++)
3232 : {
3233 257328 : dim = ss->dim[n];
3234 257328 : if (info->ref->u.ar.dimen_type[dim] != DIMEN_VECTOR
3235 980 : || loop->to[n] != NULL)
3236 257148 : continue;
3237 :
3238 : /* Loop variable N indexes vector dimension DIM, and we don't
3239 : yet know the upper bound of loop variable N. Set it to the
3240 : difference between the vector's upper and lower bounds. */
3241 180 : gcc_assert (loop->from[n] == gfc_index_zero_node);
3242 180 : gcc_assert (info->subscript[dim]
3243 : && info->subscript[dim]->info->type == GFC_SS_VECTOR);
3244 :
3245 180 : gfc_init_se (&se, NULL);
3246 180 : desc = info->subscript[dim]->info->data.array.descriptor;
3247 180 : zero = gfc_rank_cst[0];
3248 180 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
3249 : gfc_array_index_type,
3250 : gfc_conv_descriptor_ubound_get (desc, zero),
3251 : gfc_conv_descriptor_lbound_get (desc, zero));
3252 180 : tmp = gfc_evaluate_now (tmp, &outer_loop->pre);
3253 180 : loop->to[n] = tmp;
3254 : }
3255 : }
3256 181686 : }
3257 :
3258 :
3259 : /* Tells whether a scalar argument to an elemental procedure is saved out
3260 : of a scalarization loop as a value or as a reference. */
3261 :
3262 : bool
3263 45762 : gfc_scalar_elemental_arg_saved_as_reference (gfc_ss_info * ss_info)
3264 : {
3265 45762 : if (ss_info->type != GFC_SS_REFERENCE)
3266 : return false;
3267 :
3268 10294 : if (ss_info->data.scalar.needs_temporary)
3269 : return false;
3270 :
3271 : /* If the actual argument can be absent (in other words, it can
3272 : be a NULL reference), don't try to evaluate it; pass instead
3273 : the reference directly. */
3274 9918 : if (ss_info->can_be_null_ref)
3275 : return true;
3276 :
3277 : /* If the expression is of polymorphic type, it's actual size is not known,
3278 : so we avoid copying it anywhere. */
3279 9242 : if (ss_info->data.scalar.dummy_arg
3280 1402 : && gfc_dummy_arg_get_typespec (*ss_info->data.scalar.dummy_arg).type
3281 : == BT_CLASS
3282 9366 : && ss_info->expr->ts.type == BT_CLASS)
3283 : return true;
3284 :
3285 : /* If the expression is a data reference of aggregate type,
3286 : and the data reference is not used on the left hand side,
3287 : avoid a copy by saving a reference to the content. */
3288 9218 : if (!ss_info->data.scalar.needs_temporary
3289 9218 : && (ss_info->expr->ts.type == BT_DERIVED
3290 8230 : || ss_info->expr->ts.type == BT_CLASS)
3291 10254 : && gfc_expr_is_variable (ss_info->expr))
3292 : return true;
3293 :
3294 : /* Otherwise the expression is evaluated to a temporary variable before the
3295 : scalarization loop. */
3296 : return false;
3297 : }
3298 :
3299 :
3300 : /* Add the pre and post chains for all the scalar expressions in a SS chain
3301 : to loop. This is called after the loop parameters have been calculated,
3302 : but before the actual scalarizing loops. */
3303 :
3304 : static void
3305 191109 : gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
3306 : locus * where)
3307 : {
3308 191109 : gfc_loopinfo *nested_loop, *outer_loop;
3309 191109 : gfc_se se;
3310 191109 : gfc_ss_info *ss_info;
3311 191109 : gfc_array_info *info;
3312 191109 : gfc_expr *expr;
3313 191109 : int n;
3314 :
3315 : /* Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise,
3316 : arguments could get evaluated multiple times. */
3317 191109 : if (ss->is_alloc_lhs)
3318 203 : return;
3319 :
3320 503420 : outer_loop = outermost_loop (loop);
3321 :
3322 : /* TODO: This can generate bad code if there are ordering dependencies,
3323 : e.g., a callee allocated function and an unknown size constructor. */
3324 : gcc_assert (ss != NULL);
3325 :
3326 503420 : for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
3327 : {
3328 312514 : gcc_assert (ss);
3329 :
3330 : /* Cross loop arrays are handled from within the most nested loop. */
3331 312514 : if (ss->nested_ss != NULL)
3332 4740 : continue;
3333 :
3334 307774 : ss_info = ss->info;
3335 307774 : expr = ss_info->expr;
3336 307774 : info = &ss_info->data.array;
3337 :
3338 307774 : switch (ss_info->type)
3339 : {
3340 43607 : case GFC_SS_SCALAR:
3341 : /* Scalar expression. Evaluate this now. This includes elemental
3342 : dimension indices, but not array section bounds. */
3343 43607 : gfc_init_se (&se, NULL);
3344 43607 : gfc_conv_expr (&se, expr);
3345 43607 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3346 :
3347 43607 : if (expr->ts.type != BT_CHARACTER
3348 43607 : && !gfc_is_alloc_class_scalar_function (expr))
3349 : {
3350 : /* Move the evaluation of scalar expressions outside the
3351 : scalarization loop, except for WHERE assignments. */
3352 39613 : if (subscript)
3353 6468 : se.expr = convert(gfc_array_index_type, se.expr);
3354 39613 : if (!ss_info->where)
3355 39199 : se.expr = gfc_evaluate_now (se.expr, &outer_loop->pre);
3356 39613 : gfc_add_block_to_block (&outer_loop->pre, &se.post);
3357 : }
3358 : else
3359 3994 : gfc_add_block_to_block (&outer_loop->post, &se.post);
3360 :
3361 43607 : ss_info->data.scalar.value = se.expr;
3362 43607 : ss_info->string_length = se.string_length;
3363 43607 : break;
3364 :
3365 5147 : case GFC_SS_REFERENCE:
3366 : /* Scalar argument to elemental procedure. */
3367 5147 : gfc_init_se (&se, NULL);
3368 5147 : if (gfc_scalar_elemental_arg_saved_as_reference (ss_info))
3369 844 : gfc_conv_expr_reference (&se, expr);
3370 : else
3371 : {
3372 : /* Evaluate the argument outside the loop and pass
3373 : a reference to the value. */
3374 4303 : gfc_conv_expr (&se, expr);
3375 : }
3376 :
3377 : /* Ensure that a pointer to the string is stored. */
3378 5147 : if (expr->ts.type == BT_CHARACTER)
3379 174 : gfc_conv_string_parameter (&se);
3380 :
3381 5147 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3382 5147 : gfc_add_block_to_block (&outer_loop->post, &se.post);
3383 5147 : if (gfc_is_class_scalar_expr (expr))
3384 : /* This is necessary because the dynamic type will always be
3385 : large than the declared type. In consequence, assigning
3386 : the value to a temporary could segfault.
3387 : OOP-TODO: see if this is generally correct or is the value
3388 : has to be written to an allocated temporary, whose address
3389 : is passed via ss_info. */
3390 48 : ss_info->data.scalar.value = se.expr;
3391 : else
3392 5099 : ss_info->data.scalar.value = gfc_evaluate_now (se.expr,
3393 : &outer_loop->pre);
3394 :
3395 5147 : ss_info->string_length = se.string_length;
3396 5147 : break;
3397 :
3398 : case GFC_SS_SECTION:
3399 : /* Add the expressions for scalar and vector subscripts. */
3400 2906976 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
3401 2725290 : if (info->subscript[n])
3402 7448 : gfc_add_loop_ss_code (loop, info->subscript[n], true, where);
3403 :
3404 181686 : set_vector_loop_bounds (ss);
3405 181686 : break;
3406 :
3407 980 : case GFC_SS_VECTOR:
3408 : /* Get the vector's descriptor and store it in SS. */
3409 980 : gfc_init_se (&se, NULL);
3410 980 : gfc_conv_expr_descriptor (&se, expr);
3411 980 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3412 980 : gfc_add_block_to_block (&outer_loop->post, &se.post);
3413 980 : info->descriptor = se.expr;
3414 980 : break;
3415 :
3416 11533 : case GFC_SS_INTRINSIC:
3417 11533 : gfc_add_intrinsic_ss_code (loop, ss);
3418 11533 : break;
3419 :
3420 9570 : case GFC_SS_FUNCTION:
3421 9570 : {
3422 : /* Array function return value. We call the function and save its
3423 : result in a temporary for use inside the loop. */
3424 9570 : gfc_init_se (&se, NULL);
3425 9570 : se.loop = loop;
3426 9570 : se.ss = ss;
3427 9570 : bool class_func = gfc_is_class_array_function (expr);
3428 9570 : if (class_func)
3429 183 : expr->must_finalize = 1;
3430 9570 : gfc_conv_expr (&se, expr);
3431 9570 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3432 9570 : if (class_func
3433 183 : && se.expr
3434 9753 : && GFC_CLASS_TYPE_P (TREE_TYPE (se.expr)))
3435 : {
3436 183 : tree tmp = gfc_class_data_get (se.expr);
3437 183 : info->descriptor = tmp;
3438 183 : info->data = gfc_conv_descriptor_data_get (tmp);
3439 183 : info->offset = gfc_conv_descriptor_offset_get (tmp);
3440 366 : for (gfc_ss *s = ss; s; s = s->parent)
3441 378 : for (int n = 0; n < s->dimen; n++)
3442 : {
3443 195 : int dim = s->dim[n];
3444 195 : tree tree_dim = gfc_rank_cst[dim];
3445 :
3446 195 : tree start;
3447 195 : start = gfc_conv_descriptor_lbound_get (tmp, tree_dim);
3448 195 : start = gfc_evaluate_now (start, &outer_loop->pre);
3449 195 : info->start[dim] = start;
3450 :
3451 195 : tree end;
3452 195 : end = gfc_conv_descriptor_ubound_get (tmp, tree_dim);
3453 195 : end = gfc_evaluate_now (end, &outer_loop->pre);
3454 195 : info->end[dim] = end;
3455 :
3456 195 : tree stride;
3457 195 : stride = gfc_conv_descriptor_stride_get (tmp, tree_dim);
3458 195 : stride = gfc_evaluate_now (stride, &outer_loop->pre);
3459 195 : info->stride[dim] = stride;
3460 : }
3461 : }
3462 9570 : gfc_add_block_to_block (&outer_loop->post, &se.post);
3463 9570 : gfc_add_block_to_block (&outer_loop->post, &se.finalblock);
3464 9570 : ss_info->string_length = se.string_length;
3465 : }
3466 9570 : break;
3467 :
3468 42927 : case GFC_SS_CONSTRUCTOR:
3469 42927 : if (expr->ts.type == BT_CHARACTER
3470 8170 : && ss_info->string_length == NULL
3471 8170 : && expr->ts.u.cl
3472 8170 : && expr->ts.u.cl->length
3473 7826 : && expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
3474 : {
3475 7775 : gfc_init_se (&se, NULL);
3476 7775 : gfc_conv_expr_type (&se, expr->ts.u.cl->length,
3477 : gfc_charlen_type_node);
3478 7775 : ss_info->string_length = se.expr;
3479 7775 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3480 7775 : gfc_add_block_to_block (&outer_loop->post, &se.post);
3481 : }
3482 42927 : trans_array_constructor (ss, where);
3483 42927 : break;
3484 :
3485 : case GFC_SS_TEMP:
3486 : case GFC_SS_COMPONENT:
3487 : /* Do nothing. These are handled elsewhere. */
3488 : break;
3489 :
3490 0 : default:
3491 0 : gcc_unreachable ();
3492 : }
3493 : }
3494 :
3495 190906 : if (!subscript)
3496 186822 : for (nested_loop = loop->nested; nested_loop;
3497 3364 : nested_loop = nested_loop->next)
3498 3364 : gfc_add_loop_ss_code (nested_loop, nested_loop->ss, subscript, where);
3499 : }
3500 :
3501 :
3502 : /* Given an array descriptor expression DESCR and its data pointer DATA, decide
3503 : whether to either save the data pointer to a variable and use the variable or
3504 : use the data pointer expression directly without any intermediary variable.
3505 : */
3506 :
3507 : static bool
3508 129517 : save_descriptor_data (tree descr, tree data)
3509 : {
3510 129517 : return !(DECL_P (data)
3511 118481 : || (TREE_CODE (data) == ADDR_EXPR
3512 69964 : && DECL_P (TREE_OPERAND (data, 0)))
3513 51624 : || (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (descr))
3514 48125 : && TREE_CODE (descr) == COMPONENT_REF
3515 11129 : && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (descr, 0)))));
3516 : }
3517 :
3518 :
3519 : /* Type of the DATA argument passed to walk_tree by substitute_subexpr_in_expr
3520 : and used by maybe_substitute_expr. */
3521 :
3522 : typedef struct
3523 : {
3524 : tree target, repl;
3525 : }
3526 : substitute_t;
3527 :
3528 :
3529 : /* Check if the expression in *TP is equal to the substitution target provided
3530 : in DATA->TARGET and replace it with DATA->REPL in that case. This is a
3531 : callback function for use with walk_tree. */
3532 :
3533 : static tree
3534 21387 : maybe_substitute_expr (tree *tp, int *walk_subtree, void *data)
3535 : {
3536 21387 : substitute_t *subst = (substitute_t *) data;
3537 21387 : if (*tp == subst->target)
3538 : {
3539 4096 : *tp = subst->repl;
3540 4096 : *walk_subtree = 0;
3541 : }
3542 :
3543 21387 : return NULL_TREE;
3544 : }
3545 :
3546 :
3547 : /* Substitute in EXPR any occurrence of TARGET with REPLACEMENT. */
3548 :
3549 : static void
3550 3789 : substitute_subexpr_in_expr (tree target, tree replacement, tree expr)
3551 : {
3552 3789 : substitute_t subst;
3553 3789 : subst.target = target;
3554 3789 : subst.repl = replacement;
3555 :
3556 3789 : walk_tree (&expr, maybe_substitute_expr, &subst, nullptr);
3557 3789 : }
3558 :
3559 :
3560 : /* Save REF to a fresh variable in all of REPLACEMENT_ROOTS, appending extra
3561 : code to CODE. Before returning, add REF to REPLACEMENT_ROOTS and clear
3562 : REF. */
3563 :
3564 : static void
3565 3617 : save_ref (tree &code, tree &ref, vec<tree> &replacement_roots)
3566 : {
3567 3617 : stmtblock_t tmp_block;
3568 3617 : gfc_init_block (&tmp_block);
3569 3617 : tree var = gfc_evaluate_now (ref, &tmp_block);
3570 3617 : gfc_add_expr_to_block (&tmp_block, code);
3571 3617 : code = gfc_finish_block (&tmp_block);
3572 :
3573 3617 : unsigned i;
3574 3617 : tree repl_root;
3575 7406 : FOR_EACH_VEC_ELT (replacement_roots, i, repl_root)
3576 3789 : substitute_subexpr_in_expr (ref, var, repl_root);
3577 :
3578 3617 : replacement_roots.safe_push (ref);
3579 3617 : ref = NULL_TREE;
3580 3617 : }
3581 :
3582 :
3583 : /* If REF isn't shared with code in PREVIOUS_CODE, replace it with a fresh
3584 : variable in all of REPLACEMENT_ROOTS, appending extra code to CODE. */
3585 :
3586 : static void
3587 3689 : maybe_save_ref (tree &code, tree &ref, vec<tree> &replacement_roots,
3588 : stmtblock_t *previous_code)
3589 : {
3590 3689 : if (find_tree (previous_code->head, ref))
3591 : return;
3592 :
3593 3617 : save_ref (code, ref, replacement_roots);
3594 : }
3595 :
3596 :
3597 : /* Save the descriptor reference VALUE to storage pointed by DESC_PTR. Before
3598 : that, try to create fresh variables to factor subexpressions of VALUE, if
3599 : those subexpressions aren't shared with code in PRELIMINARY_CODE. Add any
3600 : necessary additional code (initialization of variables typically) to BLOCK.
3601 :
3602 : The candidate references to factoring are dereferenced pointers because they
3603 : are cheap to copy and array descriptors because they are often the base of
3604 : multiple subreferences. */
3605 :
3606 : static void
3607 325547 : set_factored_descriptor_value (tree *desc_ptr, tree value, stmtblock_t *block,
3608 : stmtblock_t *preliminary_code)
3609 : {
3610 : /* As the reference is processed from outer to inner, variable definitions
3611 : will be generated in reversed order, so can't be put directly in BLOCK.
3612 : We use temporary blocks instead, which we save in ACCUMULATED_CODE, and
3613 : only append to BLOCK at the end. */
3614 325547 : tree accumulated_code = NULL_TREE;
3615 :
3616 : /* The current candidate to factoring. */
3617 325547 : tree saveable_ref = NULL_TREE;
3618 :
3619 : /* The root expressions in which we look for subexpressions to replace with
3620 : variables. */
3621 325547 : auto_vec<tree> replacement_roots;
3622 325547 : replacement_roots.safe_push (value);
3623 :
3624 325547 : tree data_ref = value;
3625 325547 : tree next_ref = NULL_TREE;
3626 :
3627 : /* If the candidate reference is not followed by a subreference, it can't be
3628 : saved to a variable as it may be reallocatable, and we have to keep the
3629 : parent reference to be able to store the new pointer value in case of
3630 : reallocation. */
3631 325547 : bool maybe_reallocatable = true;
3632 :
3633 433133 : while (true)
3634 : {
3635 433133 : if (!maybe_reallocatable
3636 433133 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (data_ref)))
3637 2434 : saveable_ref = data_ref;
3638 :
3639 433133 : if (TREE_CODE (data_ref) == INDIRECT_REF)
3640 : {
3641 57862 : next_ref = TREE_OPERAND (data_ref, 0);
3642 :
3643 57862 : if (!maybe_reallocatable)
3644 : {
3645 14663 : if (saveable_ref != NULL_TREE && saveable_ref != data_ref)
3646 : {
3647 : /* A reference worth saving has been seen, and now the pointer
3648 : to the current reference is also worth saving. If the
3649 : previous reference to save wasn't the current one, do save
3650 : it now. Otherwise drop it as we prefer saving the
3651 : pointer. */
3652 1827 : maybe_save_ref (accumulated_code, saveable_ref,
3653 : replacement_roots, preliminary_code);
3654 : }
3655 :
3656 : /* Don't evaluate the pointer to a variable yet; do it only if the
3657 : variable would be significantly more simple than the reference
3658 : it replaces. That is if the reference contains anything
3659 : different from NOPs, COMPONENTs and DECLs. */
3660 14663 : saveable_ref = next_ref;
3661 : }
3662 : }
3663 375271 : else if (TREE_CODE (data_ref) == COMPONENT_REF)
3664 : {
3665 40617 : maybe_reallocatable = false;
3666 40617 : next_ref = TREE_OPERAND (data_ref, 0);
3667 : }
3668 334654 : else if (TREE_CODE (data_ref) == NOP_EXPR)
3669 3695 : next_ref = TREE_OPERAND (data_ref, 0);
3670 : else
3671 : {
3672 330959 : if (DECL_P (data_ref))
3673 : break;
3674 :
3675 6988 : if (TREE_CODE (data_ref) == ARRAY_REF)
3676 : {
3677 5412 : maybe_reallocatable = false;
3678 5412 : next_ref = TREE_OPERAND (data_ref, 0);
3679 : }
3680 :
3681 6988 : if (saveable_ref != NULL_TREE)
3682 : /* We have seen a reference worth saving. Do it now. */
3683 1862 : maybe_save_ref (accumulated_code, saveable_ref, replacement_roots,
3684 : preliminary_code);
3685 :
3686 6988 : if (TREE_CODE (data_ref) != ARRAY_REF)
3687 : break;
3688 : }
3689 :
3690 : data_ref = next_ref;
3691 : }
3692 :
3693 325547 : *desc_ptr = value;
3694 325547 : gfc_add_expr_to_block (block, accumulated_code);
3695 325547 : }
3696 :
3697 :
3698 : /* Translate expressions for the descriptor and data pointer of a SS. */
3699 : /*GCC ARRAYS*/
3700 :
3701 : static void
3702 325547 : gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
3703 : {
3704 325547 : gfc_se se;
3705 325547 : gfc_ss_info *ss_info;
3706 325547 : gfc_array_info *info;
3707 325547 : tree tmp;
3708 :
3709 325547 : ss_info = ss->info;
3710 325547 : info = &ss_info->data.array;
3711 :
3712 : /* Get the descriptor for the array to be scalarized. */
3713 325547 : gcc_assert (ss_info->expr->expr_type == EXPR_VARIABLE);
3714 325547 : gfc_init_se (&se, NULL);
3715 325547 : se.descriptor_only = 1;
3716 325547 : gfc_conv_expr_lhs (&se, ss_info->expr);
3717 325547 : stmtblock_t tmp_block;
3718 325547 : gfc_init_block (&tmp_block);
3719 325547 : set_factored_descriptor_value (&info->descriptor, se.expr, &tmp_block,
3720 : &se.pre);
3721 325547 : gfc_add_block_to_block (block, &se.pre);
3722 325547 : gfc_add_block_to_block (block, &tmp_block);
3723 325547 : ss_info->string_length = se.string_length;
3724 325547 : ss_info->class_container = se.class_container;
3725 :
3726 325547 : if (base)
3727 : {
3728 122871 : if (ss_info->expr->ts.type == BT_CHARACTER && !ss_info->expr->ts.deferred
3729 22772 : && ss_info->expr->ts.u.cl->length == NULL)
3730 : {
3731 : /* Emit a DECL_EXPR for the variable sized array type in
3732 : GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
3733 : sizes works correctly. */
3734 1097 : tree arraytype = TREE_TYPE (
3735 : GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (info->descriptor)));
3736 1097 : if (! TYPE_NAME (arraytype))
3737 899 : TYPE_NAME (arraytype) = build_decl (UNKNOWN_LOCATION, TYPE_DECL,
3738 : NULL_TREE, arraytype);
3739 1097 : gfc_add_expr_to_block (block, build1 (DECL_EXPR, arraytype,
3740 1097 : TYPE_NAME (arraytype)));
3741 : }
3742 : /* Also the data pointer. */
3743 122871 : tmp = gfc_conv_array_data (se.expr);
3744 : /* If this is a variable or address or a class array, use it directly.
3745 : Otherwise we must evaluate it now to avoid breaking dependency
3746 : analysis by pulling the expressions for elemental array indices
3747 : inside the loop. */
3748 122871 : if (save_descriptor_data (se.expr, tmp) && !ss->is_alloc_lhs)
3749 36332 : tmp = gfc_evaluate_now (tmp, block);
3750 122871 : info->data = tmp;
3751 :
3752 122871 : tmp = gfc_conv_array_offset (se.expr);
3753 122871 : if (!ss->is_alloc_lhs)
3754 116428 : tmp = gfc_evaluate_now (tmp, block);
3755 122871 : info->offset = tmp;
3756 :
3757 : /* Make absolutely sure that the saved_offset is indeed saved
3758 : so that the variable is still accessible after the loops
3759 : are translated. */
3760 122871 : info->saved_offset = info->offset;
3761 : }
3762 325547 : }
3763 :
3764 :
3765 : /* Initialize a gfc_loopinfo structure. */
3766 :
3767 : void
3768 189968 : gfc_init_loopinfo (gfc_loopinfo * loop)
3769 : {
3770 189968 : int n;
3771 :
3772 189968 : memset (loop, 0, sizeof (gfc_loopinfo));
3773 189968 : gfc_init_block (&loop->pre);
3774 189968 : gfc_init_block (&loop->post);
3775 :
3776 : /* Initially scalarize in order and default to no loop reversal. */
3777 3229456 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
3778 : {
3779 2849520 : loop->order[n] = n;
3780 2849520 : loop->reverse[n] = GFC_INHIBIT_REVERSE;
3781 : }
3782 :
3783 189968 : loop->ss = gfc_ss_terminator;
3784 189968 : }
3785 :
3786 :
3787 : /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
3788 : chain. */
3789 :
3790 : void
3791 190241 : gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
3792 : {
3793 190241 : se->loop = loop;
3794 190241 : }
3795 :
3796 :
3797 : /* Return an expression for the data pointer of an array. */
3798 :
3799 : tree
3800 333698 : gfc_conv_array_data (tree descriptor)
3801 : {
3802 333698 : tree type;
3803 :
3804 333698 : type = TREE_TYPE (descriptor);
3805 333698 : if (GFC_ARRAY_TYPE_P (type))
3806 : {
3807 234209 : if (TREE_CODE (type) == POINTER_TYPE)
3808 : return descriptor;
3809 : else
3810 : {
3811 : /* Descriptorless arrays. */
3812 175836 : return gfc_build_addr_expr (NULL_TREE, descriptor);
3813 : }
3814 : }
3815 : else
3816 99489 : return gfc_conv_descriptor_data_get (descriptor);
3817 : }
3818 :
3819 :
3820 : /* Return an expression for the base offset of an array. */
3821 :
3822 : tree
3823 248339 : gfc_conv_array_offset (tree descriptor)
3824 : {
3825 248339 : tree type;
3826 :
3827 248339 : type = TREE_TYPE (descriptor);
3828 248339 : if (GFC_ARRAY_TYPE_P (type))
3829 177016 : return GFC_TYPE_ARRAY_OFFSET (type);
3830 : else
3831 71323 : return gfc_conv_descriptor_offset_get (descriptor);
3832 : }
3833 :
3834 :
3835 : /* Get an expression for the array stride. */
3836 :
3837 : tree
3838 494881 : gfc_conv_array_stride (tree descriptor, int dim)
3839 : {
3840 494881 : tree tmp;
3841 494881 : tree type;
3842 :
3843 494881 : type = TREE_TYPE (descriptor);
3844 :
3845 : /* For descriptorless arrays use the array size. */
3846 494881 : tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
3847 494881 : if (tmp != NULL_TREE)
3848 : return tmp;
3849 :
3850 113719 : tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]);
3851 113719 : return tmp;
3852 : }
3853 :
3854 :
3855 : /* Like gfc_conv_array_stride, but for the lower bound. */
3856 :
3857 : tree
3858 318570 : gfc_conv_array_lbound (tree descriptor, int dim)
3859 : {
3860 318570 : tree tmp;
3861 318570 : tree type;
3862 :
3863 318570 : type = TREE_TYPE (descriptor);
3864 :
3865 318570 : tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
3866 318570 : if (tmp != NULL_TREE)
3867 : return tmp;
3868 :
3869 18651 : tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]);
3870 18651 : return tmp;
3871 : }
3872 :
3873 :
3874 : /* Like gfc_conv_array_stride, but for the upper bound. */
3875 :
3876 : tree
3877 206490 : gfc_conv_array_ubound (tree descriptor, int dim)
3878 : {
3879 206490 : tree tmp;
3880 206490 : tree type;
3881 :
3882 206490 : type = TREE_TYPE (descriptor);
3883 :
3884 206490 : tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
3885 206490 : if (tmp != NULL_TREE)
3886 : return tmp;
3887 :
3888 : /* This should only ever happen when passing an assumed shape array
3889 : as an actual parameter. The value will never be used. */
3890 8045 : if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
3891 554 : return gfc_index_zero_node;
3892 :
3893 7491 : tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]);
3894 7491 : return tmp;
3895 : }
3896 :
3897 :
3898 : /* Generate abridged name of a part-ref for use in bounds-check message.
3899 : Cases:
3900 : (1) for an ordinary array variable x return "x"
3901 : (2) for z a DT scalar and array component x (at level 1) return "z%%x"
3902 : (3) for z a DT scalar and array component x (at level > 1) or
3903 : for z a DT array and array x (at any number of levels): "z...%%x"
3904 : */
3905 :
3906 : static char *
3907 36604 : abridged_ref_name (gfc_expr * expr, gfc_array_ref * ar)
3908 : {
3909 36604 : gfc_ref *ref;
3910 36604 : gfc_symbol *sym;
3911 36604 : char *ref_name = NULL;
3912 36604 : const char *comp_name = NULL;
3913 36604 : int len_sym, last_len = 0, level = 0;
3914 36604 : bool sym_is_array;
3915 :
3916 36604 : gcc_assert (expr->expr_type == EXPR_VARIABLE && expr->ref != NULL);
3917 :
3918 36604 : sym = expr->symtree->n.sym;
3919 72821 : sym_is_array = (sym->ts.type != BT_CLASS
3920 36604 : ? sym->as != NULL
3921 387 : : IS_CLASS_ARRAY (sym));
3922 36604 : len_sym = strlen (sym->name);
3923 :
3924 : /* Scan ref chain to get name of the array component (when ar != NULL) or
3925 : array section, determine depth and remember its component name. */
3926 52135 : for (ref = expr->ref; ref; ref = ref->next)
3927 : {
3928 38053 : if (ref->type == REF_COMPONENT
3929 1048 : && strcmp (ref->u.c.component->name, "_data") != 0)
3930 : {
3931 918 : level++;
3932 918 : comp_name = ref->u.c.component->name;
3933 918 : continue;
3934 : }
3935 :
3936 37135 : if (ref->type != REF_ARRAY)
3937 150 : continue;
3938 :
3939 36985 : if (ar)
3940 : {
3941 15971 : if (&ref->u.ar == ar)
3942 : break;
3943 : }
3944 21014 : else if (ref->u.ar.type == AR_SECTION)
3945 : break;
3946 : }
3947 :
3948 36604 : if (level > 0)
3949 800 : last_len = strlen (comp_name);
3950 :
3951 : /* Provide a buffer sufficiently large to hold "x...%%z". */
3952 36604 : ref_name = XNEWVEC (char, len_sym + last_len + 6);
3953 36604 : strcpy (ref_name, sym->name);
3954 :
3955 36604 : if (level == 1 && !sym_is_array)
3956 : {
3957 442 : strcat (ref_name, "%%");
3958 442 : strcat (ref_name, comp_name);
3959 : }
3960 36162 : else if (level > 0)
3961 : {
3962 358 : strcat (ref_name, "...%%");
3963 358 : strcat (ref_name, comp_name);
3964 : }
3965 :
3966 36604 : return ref_name;
3967 : }
3968 :
3969 :
3970 : /* Generate code to perform an array index bound check. */
3971 :
3972 : static tree
3973 5701 : trans_array_bound_check (stmtblock_t *block, gfc_ss *ss, tree index, int n,
3974 : locus * where, bool check_upper,
3975 : const char *compname = NULL)
3976 : {
3977 5701 : tree fault;
3978 5701 : tree tmp_lo, tmp_up;
3979 5701 : tree descriptor;
3980 5701 : char *msg;
3981 5701 : char *ref_name = NULL;
3982 5701 : const char * name = NULL;
3983 5701 : gfc_expr *expr;
3984 :
3985 5701 : if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
3986 : return index;
3987 :
3988 252 : descriptor = ss->info->data.array.descriptor;
3989 :
3990 252 : index = gfc_evaluate_now (index, block);
3991 :
3992 : /* We find a name for the error message. */
3993 252 : name = ss->info->expr->symtree->n.sym->name;
3994 252 : gcc_assert (name != NULL);
3995 :
3996 : /* When we have a component ref, get name of the array section.
3997 : Note that there can only be one part ref. */
3998 252 : expr = ss->info->expr;
3999 252 : if (expr->ref && !compname)
4000 160 : name = ref_name = abridged_ref_name (expr, NULL);
4001 :
4002 252 : if (VAR_P (descriptor))
4003 162 : name = IDENTIFIER_POINTER (DECL_NAME (descriptor));
4004 :
4005 : /* Use given (array component) name. */
4006 252 : if (compname)
4007 92 : name = compname;
4008 :
4009 : /* If upper bound is present, include both bounds in the error message. */
4010 252 : if (check_upper)
4011 : {
4012 225 : tmp_lo = gfc_conv_array_lbound (descriptor, n);
4013 225 : tmp_up = gfc_conv_array_ubound (descriptor, n);
4014 :
4015 225 : if (name)
4016 225 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4017 : "outside of expected range (%%ld:%%ld)", n+1, name);
4018 : else
4019 0 : msg = xasprintf ("Index '%%ld' of dimension %d "
4020 : "outside of expected range (%%ld:%%ld)", n+1);
4021 :
4022 225 : fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
4023 : index, tmp_lo);
4024 225 : gfc_trans_runtime_check (true, false, fault, block, where, msg,
4025 : fold_convert (long_integer_type_node, index),
4026 : fold_convert (long_integer_type_node, tmp_lo),
4027 : fold_convert (long_integer_type_node, tmp_up));
4028 225 : fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
4029 : index, tmp_up);
4030 225 : gfc_trans_runtime_check (true, false, fault, block, where, msg,
4031 : fold_convert (long_integer_type_node, index),
4032 : fold_convert (long_integer_type_node, tmp_lo),
4033 : fold_convert (long_integer_type_node, tmp_up));
4034 225 : free (msg);
4035 : }
4036 : else
4037 : {
4038 27 : tmp_lo = gfc_conv_array_lbound (descriptor, n);
4039 :
4040 27 : if (name)
4041 27 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4042 : "below lower bound of %%ld", n+1, name);
4043 : else
4044 0 : msg = xasprintf ("Index '%%ld' of dimension %d "
4045 : "below lower bound of %%ld", n+1);
4046 :
4047 27 : fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
4048 : index, tmp_lo);
4049 27 : gfc_trans_runtime_check (true, false, fault, block, where, msg,
4050 : fold_convert (long_integer_type_node, index),
4051 : fold_convert (long_integer_type_node, tmp_lo));
4052 27 : free (msg);
4053 : }
4054 :
4055 252 : free (ref_name);
4056 252 : return index;
4057 : }
4058 :
4059 :
4060 : /* Helper functions to detect impure functions in an expression. */
4061 :
4062 : static const char *impure_name = NULL;
4063 : static bool
4064 108 : expr_contains_impure_fcn (gfc_expr *e, gfc_symbol* sym ATTRIBUTE_UNUSED,
4065 : int* g ATTRIBUTE_UNUSED)
4066 : {
4067 108 : if (e && e->expr_type == EXPR_FUNCTION
4068 6 : && !gfc_pure_function (e, &impure_name)
4069 111 : && !gfc_implicit_pure_function (e))
4070 : return true;
4071 :
4072 : return false;
4073 : }
4074 :
4075 : static bool
4076 92 : gfc_expr_contains_impure_fcn (gfc_expr *e)
4077 : {
4078 92 : impure_name = NULL;
4079 92 : return gfc_traverse_expr (e, NULL, &expr_contains_impure_fcn, 0);
4080 : }
4081 :
4082 :
4083 : /* Generate code for bounds checking for elemental dimensions. */
4084 :
4085 : static void
4086 6688 : array_bound_check_elemental (stmtblock_t *block, gfc_ss * ss, gfc_expr * expr)
4087 : {
4088 6688 : gfc_array_ref *ar;
4089 6688 : gfc_ref *ref;
4090 6688 : char *var_name = NULL;
4091 6688 : int dim;
4092 :
4093 6688 : if (expr->expr_type == EXPR_VARIABLE)
4094 : {
4095 12533 : for (ref = expr->ref; ref; ref = ref->next)
4096 : {
4097 6303 : if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
4098 : {
4099 3953 : ar = &ref->u.ar;
4100 3953 : var_name = abridged_ref_name (expr, ar);
4101 8158 : for (dim = 0; dim < ar->dimen; dim++)
4102 : {
4103 4205 : if (ar->dimen_type[dim] == DIMEN_ELEMENT)
4104 : {
4105 92 : if (gfc_expr_contains_impure_fcn (ar->start[dim]))
4106 3 : gfc_warning_now (0, "Bounds checking of the elemental "
4107 : "index at %L will cause two calls to "
4108 : "%qs, which is not declared to be "
4109 : "PURE or is not implicitly pure.",
4110 3 : &ar->start[dim]->where, impure_name);
4111 92 : gfc_se indexse;
4112 92 : gfc_init_se (&indexse, NULL);
4113 92 : gfc_conv_expr_type (&indexse, ar->start[dim],
4114 : gfc_array_index_type);
4115 92 : gfc_add_block_to_block (block, &indexse.pre);
4116 92 : trans_array_bound_check (block, ss, indexse.expr, dim,
4117 : &ar->where,
4118 92 : ar->as->type != AS_ASSUMED_SIZE
4119 92 : || dim < ar->dimen - 1,
4120 : var_name);
4121 : }
4122 : }
4123 3953 : free (var_name);
4124 : }
4125 : }
4126 : }
4127 6688 : }
4128 :
4129 :
4130 : /* Return the offset for an index. Performs bound checking for elemental
4131 : dimensions. Single element references are processed separately.
4132 : DIM is the array dimension, I is the loop dimension. */
4133 :
4134 : static tree
4135 253250 : conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i,
4136 : gfc_array_ref * ar, tree stride)
4137 : {
4138 253250 : gfc_array_info *info;
4139 253250 : tree index;
4140 253250 : tree desc;
4141 253250 : tree data;
4142 :
4143 253250 : info = &ss->info->data.array;
4144 :
4145 : /* Get the index into the array for this dimension. */
4146 253250 : if (ar)
4147 : {
4148 180133 : gcc_assert (ar->type != AR_ELEMENT);
4149 180133 : switch (ar->dimen_type[dim])
4150 : {
4151 0 : case DIMEN_THIS_IMAGE:
4152 0 : gcc_unreachable ();
4153 4632 : break;
4154 4632 : case DIMEN_ELEMENT:
4155 : /* Elemental dimension. */
4156 4632 : gcc_assert (info->subscript[dim]
4157 : && info->subscript[dim]->info->type == GFC_SS_SCALAR);
4158 : /* We've already translated this value outside the loop. */
4159 4632 : index = info->subscript[dim]->info->data.scalar.value;
4160 :
4161 9264 : index = trans_array_bound_check (&se->pre, ss, index, dim, &ar->where,
4162 4632 : ar->as->type != AS_ASSUMED_SIZE
4163 4632 : || dim < ar->dimen - 1);
4164 4632 : break;
4165 :
4166 977 : case DIMEN_VECTOR:
4167 977 : gcc_assert (info && se->loop);
4168 977 : gcc_assert (info->subscript[dim]
4169 : && info->subscript[dim]->info->type == GFC_SS_VECTOR);
4170 977 : desc = info->subscript[dim]->info->data.array.descriptor;
4171 :
4172 : /* Get a zero-based index into the vector. */
4173 977 : index = fold_build2_loc (input_location, MINUS_EXPR,
4174 : gfc_array_index_type,
4175 : se->loop->loopvar[i], se->loop->from[i]);
4176 :
4177 : /* Multiply the index by the stride. */
4178 977 : index = fold_build2_loc (input_location, MULT_EXPR,
4179 : gfc_array_index_type,
4180 : index, gfc_conv_array_stride (desc, 0));
4181 :
4182 : /* Read the vector to get an index into info->descriptor. */
4183 977 : data = build_fold_indirect_ref_loc (input_location,
4184 : gfc_conv_array_data (desc));
4185 977 : index = gfc_build_array_ref (data, index, NULL);
4186 977 : index = gfc_evaluate_now (index, &se->pre);
4187 977 : index = fold_convert (gfc_array_index_type, index);
4188 :
4189 : /* Do any bounds checking on the final info->descriptor index. */
4190 1954 : index = trans_array_bound_check (&se->pre, ss, index, dim, &ar->where,
4191 977 : ar->as->type != AS_ASSUMED_SIZE
4192 977 : || dim < ar->dimen - 1);
4193 977 : break;
4194 :
4195 174524 : case DIMEN_RANGE:
4196 : /* Scalarized dimension. */
4197 174524 : gcc_assert (info && se->loop);
4198 :
4199 : /* Multiply the loop variable by the stride and delta. */
4200 174524 : index = se->loop->loopvar[i];
4201 174524 : if (!integer_onep (info->stride[dim]))
4202 6906 : index = fold_build2_loc (input_location, MULT_EXPR,
4203 : gfc_array_index_type, index,
4204 : info->stride[dim]);
4205 174524 : if (!integer_zerop (info->delta[dim]))
4206 67165 : index = fold_build2_loc (input_location, PLUS_EXPR,
4207 : gfc_array_index_type, index,
4208 : info->delta[dim]);
4209 : break;
4210 :
4211 0 : default:
4212 0 : gcc_unreachable ();
4213 : }
4214 : }
4215 : else
4216 : {
4217 : /* Temporary array or derived type component. */
4218 73117 : gcc_assert (se->loop);
4219 73117 : index = se->loop->loopvar[se->loop->order[i]];
4220 :
4221 : /* Pointer functions can have stride[0] different from unity.
4222 : Use the stride returned by the function call and stored in
4223 : the descriptor for the temporary. */
4224 73117 : if (se->ss && se->ss->info->type == GFC_SS_FUNCTION
4225 8032 : && se->ss->info->expr
4226 8032 : && se->ss->info->expr->symtree
4227 8032 : && se->ss->info->expr->symtree->n.sym->result
4228 7592 : && se->ss->info->expr->symtree->n.sym->result->attr.pointer)
4229 144 : stride = gfc_conv_descriptor_stride_get (info->descriptor,
4230 : gfc_rank_cst[dim]);
4231 :
4232 73117 : if (info->delta[dim] && !integer_zerop (info->delta[dim]))
4233 804 : index = fold_build2_loc (input_location, PLUS_EXPR,
4234 : gfc_array_index_type, index, info->delta[dim]);
4235 : }
4236 :
4237 : /* Multiply by the stride. */
4238 253250 : if (stride != NULL && !integer_onep (stride))
4239 77237 : index = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4240 : index, stride);
4241 :
4242 253250 : return index;
4243 : }
4244 :
4245 :
4246 : /* Build a scalarized array reference using the vptr 'size'. */
4247 :
4248 : static bool
4249 193896 : build_class_array_ref (gfc_se *se, tree base, tree index)
4250 : {
4251 193896 : tree size;
4252 193896 : tree decl = NULL_TREE;
4253 193896 : tree tmp;
4254 193896 : gfc_expr *expr = se->ss->info->expr;
4255 193896 : gfc_expr *class_expr;
4256 193896 : gfc_typespec *ts;
4257 193896 : gfc_symbol *sym;
4258 :
4259 193896 : tmp = !VAR_P (base) ? gfc_get_class_from_expr (base) : NULL_TREE;
4260 :
4261 90655 : if (tmp != NULL_TREE)
4262 : decl = tmp;
4263 : else
4264 : {
4265 : /* The base expression does not contain a class component, either
4266 : because it is a temporary array or array descriptor. Class
4267 : array functions are correctly resolved above. */
4268 190547 : if (!expr
4269 190547 : || (expr->ts.type != BT_CLASS
4270 176864 : && !gfc_is_class_array_ref (expr, NULL)))
4271 190112 : return false;
4272 :
4273 : /* Obtain the expression for the class entity or component that is
4274 : followed by an array reference, which is not an element, so that
4275 : the span of the array can be obtained. */
4276 435 : class_expr = gfc_find_and_cut_at_last_class_ref (expr, false, &ts);
4277 :
4278 435 : if (!ts)
4279 : return false;
4280 :
4281 410 : sym = (!class_expr && expr) ? expr->symtree->n.sym : NULL;
4282 0 : if (sym && sym->attr.function
4283 0 : && sym == sym->result
4284 0 : && sym->backend_decl == current_function_decl)
4285 : /* The temporary is the data field of the class data component
4286 : of the current function. */
4287 0 : decl = gfc_get_fake_result_decl (sym, 0);
4288 410 : else if (sym)
4289 : {
4290 0 : if (decl == NULL_TREE)
4291 0 : decl = expr->symtree->n.sym->backend_decl;
4292 : /* For class arrays the tree containing the class is stored in
4293 : GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl.
4294 : For all others it's sym's backend_decl directly. */
4295 0 : if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl))
4296 0 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
4297 : }
4298 : else
4299 410 : decl = gfc_get_class_from_gfc_expr (class_expr);
4300 :
4301 410 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
4302 0 : decl = build_fold_indirect_ref_loc (input_location, decl);
4303 :
4304 410 : if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl)))
4305 : return false;
4306 : }
4307 :
4308 3759 : se->class_vptr = gfc_evaluate_now (gfc_class_vptr_get (decl), &se->pre);
4309 :
4310 3759 : size = gfc_class_vtab_size_get (decl);
4311 : /* For unlimited polymorphic entities then _len component needs to be
4312 : multiplied with the size. */
4313 3759 : size = gfc_resize_class_size_with_len (&se->pre, decl, size);
4314 3759 : size = fold_convert (TREE_TYPE (index), size);
4315 :
4316 : /* Return the element in the se expression. */
4317 3759 : se->expr = gfc_build_spanned_array_ref (base, index, size);
4318 3759 : return true;
4319 : }
4320 :
4321 :
4322 : /* Indicates that the tree EXPR is a reference to an array that can’t
4323 : have any negative stride. */
4324 :
4325 : static bool
4326 313189 : non_negative_strides_array_p (tree expr)
4327 : {
4328 326276 : if (expr == NULL_TREE)
4329 : return false;
4330 :
4331 326276 : tree type = TREE_TYPE (expr);
4332 326276 : if (POINTER_TYPE_P (type))
4333 71680 : type = TREE_TYPE (type);
4334 :
4335 326276 : if (TYPE_LANG_SPECIFIC (type))
4336 : {
4337 326276 : gfc_array_kind array_kind = GFC_TYPE_ARRAY_AKIND (type);
4338 :
4339 326276 : if (array_kind == GFC_ARRAY_ALLOCATABLE
4340 326276 : || array_kind == GFC_ARRAY_ASSUMED_SHAPE_CONT)
4341 : return true;
4342 : }
4343 :
4344 : /* An array with descriptor can have negative strides.
4345 : We try to be conservative and return false by default here
4346 : if we don’t recognize a contiguous array instead of
4347 : returning false if we can identify a non-contiguous one. */
4348 269275 : if (!GFC_ARRAY_TYPE_P (type))
4349 : return false;
4350 :
4351 : /* If the array was originally a dummy with a descriptor, strides can be
4352 : negative. */
4353 235438 : if (DECL_P (expr)
4354 226475 : && DECL_LANG_SPECIFIC (expr)
4355 47712 : && GFC_DECL_SAVED_DESCRIPTOR (expr)
4356 248544 : && GFC_DECL_SAVED_DESCRIPTOR (expr) != expr)
4357 13087 : return non_negative_strides_array_p (GFC_DECL_SAVED_DESCRIPTOR (expr));
4358 :
4359 : return true;
4360 : }
4361 :
4362 :
4363 : /* Build a scalarized reference to an array. */
4364 :
4365 : static void
4366 193896 : gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar,
4367 : bool tmp_array = false)
4368 : {
4369 193896 : gfc_array_info *info;
4370 193896 : tree decl = NULL_TREE;
4371 193896 : tree index;
4372 193896 : tree base;
4373 193896 : gfc_ss *ss;
4374 193896 : gfc_expr *expr;
4375 193896 : int n;
4376 :
4377 193896 : ss = se->ss;
4378 193896 : expr = ss->info->expr;
4379 193896 : info = &ss->info->data.array;
4380 193896 : if (ar)
4381 132853 : n = se->loop->order[0];
4382 : else
4383 : n = 0;
4384 :
4385 193896 : index = conv_array_index_offset (se, ss, ss->dim[n], n, ar, info->stride0);
4386 : /* Add the offset for this dimension to the stored offset for all other
4387 : dimensions. */
4388 193896 : if (info->offset && !integer_zerop (info->offset))
4389 142475 : index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4390 : index, info->offset);
4391 :
4392 193896 : base = build_fold_indirect_ref_loc (input_location, info->data);
4393 :
4394 : /* Use the vptr 'size' field to access the element of a class array. */
4395 193896 : if (build_class_array_ref (se, base, index))
4396 3759 : return;
4397 :
4398 190137 : if (get_CFI_desc (NULL, expr, &decl, ar))
4399 442 : decl = build_fold_indirect_ref_loc (input_location, decl);
4400 :
4401 : /* A pointer array component can be detected from its field decl. Fix
4402 : the descriptor, mark the resulting variable decl and pass it to
4403 : gfc_build_array_ref. */
4404 190137 : if (is_pointer_array (info->descriptor)
4405 190137 : || (expr && expr->ts.deferred && info->descriptor
4406 2913 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info->descriptor))))
4407 : {
4408 9143 : if (TREE_CODE (info->descriptor) == COMPONENT_REF)
4409 1588 : decl = info->descriptor;
4410 7555 : else if (INDIRECT_REF_P (info->descriptor))
4411 1485 : decl = TREE_OPERAND (info->descriptor, 0);
4412 :
4413 9143 : if (decl == NULL_TREE)
4414 6070 : decl = info->descriptor;
4415 : }
4416 :
4417 190137 : bool non_negative_stride = tmp_array
4418 190137 : || non_negative_strides_array_p (info->descriptor);
4419 190137 : se->expr = gfc_build_array_ref (base, index, decl,
4420 : non_negative_stride);
4421 : }
4422 :
4423 :
4424 : /* Translate access of temporary array. */
4425 :
4426 : void
4427 61043 : gfc_conv_tmp_array_ref (gfc_se * se)
4428 : {
4429 61043 : se->string_length = se->ss->info->string_length;
4430 61043 : gfc_conv_scalarized_array_ref (se, NULL, true);
4431 61043 : gfc_advance_se_ss_chain (se);
4432 61043 : }
4433 :
4434 : /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
4435 :
4436 : static void
4437 275533 : add_to_offset (tree *cst_offset, tree *offset, tree t)
4438 : {
4439 275533 : if (TREE_CODE (t) == INTEGER_CST)
4440 139269 : *cst_offset = int_const_binop (PLUS_EXPR, *cst_offset, t);
4441 : else
4442 : {
4443 136264 : if (!integer_zerop (*offset))
4444 47631 : *offset = fold_build2_loc (input_location, PLUS_EXPR,
4445 : gfc_array_index_type, *offset, t);
4446 : else
4447 88633 : *offset = t;
4448 : }
4449 275533 : }
4450 :
4451 :
4452 : static tree
4453 183701 : build_array_ref (tree desc, tree offset, tree decl, tree vptr)
4454 : {
4455 183701 : tree tmp;
4456 183701 : tree type;
4457 183701 : tree cdesc;
4458 :
4459 : /* For class arrays the class declaration is stored in the saved
4460 : descriptor. */
4461 183701 : if (INDIRECT_REF_P (desc)
4462 7329 : && DECL_LANG_SPECIFIC (TREE_OPERAND (desc, 0))
4463 186011 : && GFC_DECL_SAVED_DESCRIPTOR (TREE_OPERAND (desc, 0)))
4464 875 : cdesc = gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (
4465 : TREE_OPERAND (desc, 0)));
4466 : else
4467 : cdesc = desc;
4468 :
4469 : /* Class container types do not always have the GFC_CLASS_TYPE_P
4470 : but the canonical type does. */
4471 183701 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdesc))
4472 183701 : && TREE_CODE (cdesc) == COMPONENT_REF)
4473 : {
4474 11344 : type = TREE_TYPE (TREE_OPERAND (cdesc, 0));
4475 11344 : if (TYPE_CANONICAL (type)
4476 11344 : && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type)))
4477 3457 : vptr = gfc_class_vptr_get (TREE_OPERAND (cdesc, 0));
4478 : }
4479 :
4480 183701 : tmp = gfc_conv_array_data (desc);
4481 183701 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
4482 183701 : tmp = gfc_build_array_ref (tmp, offset, decl,
4483 183701 : non_negative_strides_array_p (desc),
4484 : vptr);
4485 183701 : return tmp;
4486 : }
4487 :
4488 :
4489 : /* Build an array reference. se->expr already holds the array descriptor.
4490 : This should be either a variable, indirect variable reference or component
4491 : reference. For arrays which do not have a descriptor, se->expr will be
4492 : the data pointer.
4493 : a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
4494 :
4495 : void
4496 261766 : gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
4497 : locus * where)
4498 : {
4499 261766 : int n;
4500 261766 : tree offset, cst_offset;
4501 261766 : tree tmp;
4502 261766 : tree stride;
4503 261766 : tree decl = NULL_TREE;
4504 261766 : gfc_se indexse;
4505 261766 : gfc_se tmpse;
4506 261766 : gfc_symbol * sym = expr->symtree->n.sym;
4507 261766 : char *var_name = NULL;
4508 :
4509 261766 : if (ar->stat)
4510 : {
4511 3 : gfc_se statse;
4512 :
4513 3 : gfc_init_se (&statse, NULL);
4514 3 : gfc_conv_expr_lhs (&statse, ar->stat);
4515 3 : gfc_add_block_to_block (&se->pre, &statse.pre);
4516 3 : gfc_add_modify (&se->pre, statse.expr, integer_zero_node);
4517 : }
4518 261766 : if (ar->dimen == 0)
4519 : {
4520 4506 : gcc_assert (ar->codimen || sym->attr.select_rank_temporary
4521 : || (ar->as && ar->as->corank));
4522 :
4523 4506 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
4524 961 : se->expr = build_fold_indirect_ref (gfc_conv_array_data (se->expr));
4525 : else
4526 : {
4527 3545 : if (GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr))
4528 3545 : && TREE_CODE (TREE_TYPE (se->expr)) == POINTER_TYPE)
4529 2598 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
4530 :
4531 : /* Use the actual tree type and not the wrapped coarray. */
4532 3545 : if (!se->want_pointer)
4533 2576 : se->expr = fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se->expr)),
4534 : se->expr);
4535 : }
4536 :
4537 137359 : return;
4538 : }
4539 :
4540 : /* Handle scalarized references separately. */
4541 257260 : if (ar->type != AR_ELEMENT)
4542 : {
4543 132853 : gfc_conv_scalarized_array_ref (se, ar);
4544 132853 : gfc_advance_se_ss_chain (se);
4545 132853 : return;
4546 : }
4547 :
4548 124407 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
4549 11849 : var_name = abridged_ref_name (expr, ar);
4550 :
4551 124407 : decl = se->expr;
4552 124407 : if (UNLIMITED_POLY(sym)
4553 104 : && IS_CLASS_ARRAY (sym)
4554 103 : && sym->attr.dummy
4555 60 : && ar->as->type != AS_DEFERRED)
4556 48 : decl = sym->backend_decl;
4557 :
4558 124407 : cst_offset = offset = gfc_index_zero_node;
4559 124407 : add_to_offset (&cst_offset, &offset, gfc_conv_array_offset (decl));
4560 :
4561 : /* Calculate the offsets from all the dimensions. Make sure to associate
4562 : the final offset so that we form a chain of loop invariant summands. */
4563 275533 : for (n = ar->dimen - 1; n >= 0; n--)
4564 : {
4565 : /* Calculate the index for this dimension. */
4566 151126 : gfc_init_se (&indexse, se);
4567 151126 : gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
4568 151126 : gfc_add_block_to_block (&se->pre, &indexse.pre);
4569 :
4570 151126 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && ! expr->no_bounds_check)
4571 : {
4572 : /* Check array bounds. */
4573 15389 : tree cond;
4574 15389 : char *msg;
4575 :
4576 : /* Evaluate the indexse.expr only once. */
4577 15389 : indexse.expr = save_expr (indexse.expr);
4578 :
4579 : /* Lower bound. */
4580 15389 : tmp = gfc_conv_array_lbound (decl, n);
4581 15389 : if (sym->attr.temporary)
4582 : {
4583 18 : gfc_init_se (&tmpse, se);
4584 18 : gfc_conv_expr_type (&tmpse, ar->as->lower[n],
4585 : gfc_array_index_type);
4586 18 : gfc_add_block_to_block (&se->pre, &tmpse.pre);
4587 18 : tmp = tmpse.expr;
4588 : }
4589 :
4590 15389 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
4591 : indexse.expr, tmp);
4592 15389 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4593 : "below lower bound of %%ld", n+1, var_name);
4594 15389 : gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
4595 : fold_convert (long_integer_type_node,
4596 : indexse.expr),
4597 : fold_convert (long_integer_type_node, tmp));
4598 15389 : free (msg);
4599 :
4600 : /* Upper bound, but not for the last dimension of assumed-size
4601 : arrays. */
4602 15389 : if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE)
4603 : {
4604 13656 : tmp = gfc_conv_array_ubound (decl, n);
4605 13656 : if (sym->attr.temporary)
4606 : {
4607 18 : gfc_init_se (&tmpse, se);
4608 18 : gfc_conv_expr_type (&tmpse, ar->as->upper[n],
4609 : gfc_array_index_type);
4610 18 : gfc_add_block_to_block (&se->pre, &tmpse.pre);
4611 18 : tmp = tmpse.expr;
4612 : }
4613 :
4614 13656 : cond = fold_build2_loc (input_location, GT_EXPR,
4615 : logical_type_node, indexse.expr, tmp);
4616 13656 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4617 : "above upper bound of %%ld", n+1, var_name);
4618 13656 : gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
4619 : fold_convert (long_integer_type_node,
4620 : indexse.expr),
4621 : fold_convert (long_integer_type_node, tmp));
4622 13656 : free (msg);
4623 : }
4624 : }
4625 :
4626 : /* Multiply the index by the stride. */
4627 151126 : stride = gfc_conv_array_stride (decl, n);
4628 151126 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4629 : indexse.expr, stride);
4630 :
4631 : /* And add it to the total. */
4632 151126 : add_to_offset (&cst_offset, &offset, tmp);
4633 : }
4634 :
4635 124407 : if (!integer_zerop (cst_offset))
4636 66500 : offset = fold_build2_loc (input_location, PLUS_EXPR,
4637 : gfc_array_index_type, offset, cst_offset);
4638 :
4639 : /* A pointer array component can be detected from its field decl. Fix
4640 : the descriptor, mark the resulting variable decl and pass it to
4641 : build_array_ref. */
4642 124407 : decl = NULL_TREE;
4643 124407 : if (get_CFI_desc (sym, expr, &decl, ar))
4644 3589 : decl = build_fold_indirect_ref_loc (input_location, decl);
4645 123360 : if (!expr->ts.deferred && !sym->attr.codimension
4646 245542 : && is_pointer_array (se->expr))
4647 : {
4648 5129 : if (TREE_CODE (se->expr) == COMPONENT_REF)
4649 1672 : decl = se->expr;
4650 3457 : else if (INDIRECT_REF_P (se->expr))
4651 984 : decl = TREE_OPERAND (se->expr, 0);
4652 : else
4653 2473 : decl = se->expr;
4654 : }
4655 119278 : else if (expr->ts.deferred
4656 118231 : || (sym->ts.type == BT_CHARACTER
4657 15323 : && sym->attr.select_type_temporary))
4658 : {
4659 2751 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
4660 : {
4661 2595 : decl = se->expr;
4662 2595 : if (INDIRECT_REF_P (decl))
4663 20 : decl = TREE_OPERAND (decl, 0);
4664 : }
4665 : else
4666 156 : decl = sym->backend_decl;
4667 : }
4668 116527 : else if (sym->ts.type == BT_CLASS)
4669 : {
4670 2237 : if (UNLIMITED_POLY (sym))
4671 : {
4672 104 : gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr);
4673 104 : gfc_init_se (&tmpse, NULL);
4674 104 : gfc_conv_expr (&tmpse, class_expr);
4675 104 : if (!se->class_vptr)
4676 104 : se->class_vptr = gfc_class_vptr_get (tmpse.expr);
4677 104 : gfc_free_expr (class_expr);
4678 104 : decl = tmpse.expr;
4679 104 : }
4680 : else
4681 2133 : decl = NULL_TREE;
4682 : }
4683 :
4684 124407 : free (var_name);
4685 124407 : se->expr = build_array_ref (se->expr, offset, decl, se->class_vptr);
4686 : }
4687 :
4688 :
4689 : /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
4690 : LOOP_DIM dimension (if any) to array's offset. */
4691 :
4692 : static void
4693 59354 : add_array_offset (stmtblock_t *pblock, gfc_loopinfo *loop, gfc_ss *ss,
4694 : gfc_array_ref *ar, int array_dim, int loop_dim)
4695 : {
4696 59354 : gfc_se se;
4697 59354 : gfc_array_info *info;
4698 59354 : tree stride, index;
4699 :
4700 59354 : info = &ss->info->data.array;
4701 :
4702 59354 : gfc_init_se (&se, NULL);
4703 59354 : se.loop = loop;
4704 59354 : se.expr = info->descriptor;
4705 59354 : stride = gfc_conv_array_stride (info->descriptor, array_dim);
4706 59354 : index = conv_array_index_offset (&se, ss, array_dim, loop_dim, ar, stride);
4707 59354 : gfc_add_block_to_block (pblock, &se.pre);
4708 :
4709 59354 : info->offset = fold_build2_loc (input_location, PLUS_EXPR,
4710 : gfc_array_index_type,
4711 : info->offset, index);
4712 59354 : info->offset = gfc_evaluate_now (info->offset, pblock);
4713 59354 : }
4714 :
4715 :
4716 : /* Generate the code to be executed immediately before entering a
4717 : scalarization loop. */
4718 :
4719 : static void
4720 146453 : gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
4721 : stmtblock_t * pblock)
4722 : {
4723 146453 : tree stride;
4724 146453 : gfc_ss_info *ss_info;
4725 146453 : gfc_array_info *info;
4726 146453 : gfc_ss_type ss_type;
4727 146453 : gfc_ss *ss, *pss;
4728 146453 : gfc_loopinfo *ploop;
4729 146453 : gfc_array_ref *ar;
4730 :
4731 : /* This code will be executed before entering the scalarization loop
4732 : for this dimension. */
4733 446644 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4734 : {
4735 300191 : ss_info = ss->info;
4736 :
4737 300191 : if ((ss_info->useflags & flag) == 0)
4738 1476 : continue;
4739 :
4740 298715 : ss_type = ss_info->type;
4741 364577 : if (ss_type != GFC_SS_SECTION
4742 : && ss_type != GFC_SS_FUNCTION
4743 298715 : && ss_type != GFC_SS_CONSTRUCTOR
4744 298715 : && ss_type != GFC_SS_COMPONENT)
4745 65862 : continue;
4746 :
4747 232853 : info = &ss_info->data.array;
4748 :
4749 232853 : gcc_assert (dim < ss->dimen);
4750 232853 : gcc_assert (ss->dimen == loop->dimen);
4751 :
4752 232853 : if (info->ref)
4753 164350 : ar = &info->ref->u.ar;
4754 : else
4755 : ar = NULL;
4756 :
4757 232853 : if (dim == loop->dimen - 1 && loop->parent != NULL)
4758 : {
4759 : /* If we are in the outermost dimension of this loop, the previous
4760 : dimension shall be in the parent loop. */
4761 4687 : gcc_assert (ss->parent != NULL);
4762 :
4763 4687 : pss = ss->parent;
4764 4687 : ploop = loop->parent;
4765 :
4766 : /* ss and ss->parent are about the same array. */
4767 4687 : gcc_assert (ss_info == pss->info);
4768 : }
4769 : else
4770 : {
4771 : ploop = loop;
4772 : pss = ss;
4773 : }
4774 :
4775 232853 : if (dim == loop->dimen - 1 && loop->parent == NULL)
4776 : {
4777 178131 : gcc_assert (0 == ploop->order[0]);
4778 :
4779 356262 : stride = gfc_conv_array_stride (info->descriptor,
4780 178131 : innermost_ss (ss)->dim[0]);
4781 :
4782 : /* Calculate the stride of the innermost loop. Hopefully this will
4783 : allow the backend optimizers to do their stuff more effectively.
4784 : */
4785 178131 : info->stride0 = gfc_evaluate_now (stride, pblock);
4786 :
4787 : /* For the outermost loop calculate the offset due to any
4788 : elemental dimensions. It will have been initialized with the
4789 : base offset of the array. */
4790 178131 : if (info->ref)
4791 : {
4792 288310 : for (int i = 0; i < ar->dimen; i++)
4793 : {
4794 166608 : if (ar->dimen_type[i] != DIMEN_ELEMENT)
4795 161976 : continue;
4796 :
4797 4632 : add_array_offset (pblock, loop, ss, ar, i, /* unused */ -1);
4798 : }
4799 : }
4800 : }
4801 : else
4802 : {
4803 54722 : int i;
4804 :
4805 54722 : if (dim == loop->dimen - 1)
4806 : i = 0;
4807 : else
4808 50035 : i = dim + 1;
4809 :
4810 : /* For the time being, there is no loop reordering. */
4811 54722 : gcc_assert (i == ploop->order[i]);
4812 54722 : i = ploop->order[i];
4813 :
4814 : /* Add the offset for the previous loop dimension. */
4815 54722 : add_array_offset (pblock, ploop, ss, ar, pss->dim[i], i);
4816 : }
4817 :
4818 : /* Remember this offset for the second loop. */
4819 232853 : if (dim == loop->temp_dim - 1 && loop->parent == NULL)
4820 54231 : info->saved_offset = info->offset;
4821 : }
4822 146453 : }
4823 :
4824 :
4825 : /* Start a scalarized expression. Creates a scope and declares loop
4826 : variables. */
4827 :
4828 : void
4829 116185 : gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
4830 : {
4831 116185 : int dim;
4832 116185 : int n;
4833 116185 : int flags;
4834 :
4835 116185 : gcc_assert (!loop->array_parameter);
4836 :
4837 261058 : for (dim = loop->dimen - 1; dim >= 0; dim--)
4838 : {
4839 144873 : n = loop->order[dim];
4840 :
4841 144873 : gfc_start_block (&loop->code[n]);
4842 :
4843 : /* Create the loop variable. */
4844 144873 : loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
4845 :
4846 144873 : if (dim < loop->temp_dim)
4847 : flags = 3;
4848 : else
4849 99104 : flags = 1;
4850 : /* Calculate values that will be constant within this loop. */
4851 144873 : gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
4852 : }
4853 116185 : gfc_start_block (pbody);
4854 116185 : }
4855 :
4856 :
4857 : /* Generates the actual loop code for a scalarization loop. */
4858 :
4859 : static void
4860 160375 : gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
4861 : stmtblock_t * pbody)
4862 : {
4863 160375 : stmtblock_t block;
4864 160375 : tree cond;
4865 160375 : tree tmp;
4866 160375 : tree loopbody;
4867 160375 : tree exit_label;
4868 160375 : tree stmt;
4869 160375 : tree init;
4870 160375 : tree incr;
4871 :
4872 160375 : if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS
4873 : | OMPWS_SCALARIZER_BODY))
4874 : == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS)
4875 108 : && n == loop->dimen - 1)
4876 : {
4877 : /* We create an OMP_FOR construct for the outermost scalarized loop. */
4878 80 : init = make_tree_vec (1);
4879 80 : cond = make_tree_vec (1);
4880 80 : incr = make_tree_vec (1);
4881 :
4882 : /* Cycle statement is implemented with a goto. Exit statement must not
4883 : be present for this loop. */
4884 80 : exit_label = gfc_build_label_decl (NULL_TREE);
4885 80 : TREE_USED (exit_label) = 1;
4886 :
4887 : /* Label for cycle statements (if needed). */
4888 80 : tmp = build1_v (LABEL_EXPR, exit_label);
4889 80 : gfc_add_expr_to_block (pbody, tmp);
4890 :
4891 80 : stmt = make_node (OMP_FOR);
4892 :
4893 80 : TREE_TYPE (stmt) = void_type_node;
4894 80 : OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody);
4895 :
4896 80 : OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location,
4897 : OMP_CLAUSE_SCHEDULE);
4898 80 : OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt))
4899 80 : = OMP_CLAUSE_SCHEDULE_STATIC;
4900 80 : if (ompws_flags & OMPWS_NOWAIT)
4901 33 : OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt))
4902 66 : = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT);
4903 :
4904 : /* Initialize the loopvar. */
4905 80 : TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n],
4906 : loop->from[n]);
4907 80 : OMP_FOR_INIT (stmt) = init;
4908 : /* The exit condition. */
4909 80 : TREE_VEC_ELT (cond, 0) = build2_loc (input_location, LE_EXPR,
4910 : logical_type_node,
4911 : loop->loopvar[n], loop->to[n]);
4912 80 : SET_EXPR_LOCATION (TREE_VEC_ELT (cond, 0), input_location);
4913 80 : OMP_FOR_COND (stmt) = cond;
4914 : /* Increment the loopvar. */
4915 80 : tmp = build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4916 : loop->loopvar[n], gfc_index_one_node);
4917 80 : TREE_VEC_ELT (incr, 0) = fold_build2_loc (input_location, MODIFY_EXPR,
4918 : void_type_node, loop->loopvar[n], tmp);
4919 80 : OMP_FOR_INCR (stmt) = incr;
4920 :
4921 80 : ompws_flags &= ~OMPWS_CURR_SINGLEUNIT;
4922 80 : gfc_add_expr_to_block (&loop->code[n], stmt);
4923 : }
4924 : else
4925 : {
4926 320590 : bool reverse_loop = (loop->reverse[n] == GFC_REVERSE_SET)
4927 160295 : && (loop->temp_ss == NULL);
4928 :
4929 160295 : loopbody = gfc_finish_block (pbody);
4930 :
4931 160295 : if (reverse_loop)
4932 204 : std::swap (loop->from[n], loop->to[n]);
4933 :
4934 : /* Initialize the loopvar. */
4935 160295 : if (loop->loopvar[n] != loop->from[n])
4936 159474 : gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
4937 :
4938 160295 : exit_label = gfc_build_label_decl (NULL_TREE);
4939 :
4940 : /* Generate the loop body. */
4941 160295 : gfc_init_block (&block);
4942 :
4943 : /* The exit condition. */
4944 320386 : cond = fold_build2_loc (input_location, reverse_loop ? LT_EXPR : GT_EXPR,
4945 : logical_type_node, loop->loopvar[n], loop->to[n]);
4946 160295 : tmp = build1_v (GOTO_EXPR, exit_label);
4947 160295 : TREE_USED (exit_label) = 1;
4948 160295 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
4949 160295 : gfc_add_expr_to_block (&block, tmp);
4950 :
4951 : /* The main body. */
4952 160295 : gfc_add_expr_to_block (&block, loopbody);
4953 :
4954 : /* Increment the loopvar. */
4955 320386 : tmp = fold_build2_loc (input_location,
4956 : reverse_loop ? MINUS_EXPR : PLUS_EXPR,
4957 : gfc_array_index_type, loop->loopvar[n],
4958 : gfc_index_one_node);
4959 :
4960 160295 : gfc_add_modify (&block, loop->loopvar[n], tmp);
4961 :
4962 : /* Build the loop. */
4963 160295 : tmp = gfc_finish_block (&block);
4964 160295 : tmp = build1_v (LOOP_EXPR, tmp);
4965 160295 : gfc_add_expr_to_block (&loop->code[n], tmp);
4966 :
4967 : /* Add the exit label. */
4968 160295 : tmp = build1_v (LABEL_EXPR, exit_label);
4969 160295 : gfc_add_expr_to_block (&loop->code[n], tmp);
4970 : }
4971 :
4972 160375 : }
4973 :
4974 :
4975 : /* Finishes and generates the loops for a scalarized expression. */
4976 :
4977 : void
4978 121906 : gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
4979 : {
4980 121906 : int dim;
4981 121906 : int n;
4982 121906 : gfc_ss *ss;
4983 121906 : stmtblock_t *pblock;
4984 121906 : tree tmp;
4985 :
4986 121906 : pblock = body;
4987 : /* Generate the loops. */
4988 272491 : for (dim = 0; dim < loop->dimen; dim++)
4989 : {
4990 150585 : n = loop->order[dim];
4991 150585 : gfc_trans_scalarized_loop_end (loop, n, pblock);
4992 150585 : loop->loopvar[n] = NULL_TREE;
4993 150585 : pblock = &loop->code[n];
4994 : }
4995 :
4996 121906 : tmp = gfc_finish_block (pblock);
4997 121906 : gfc_add_expr_to_block (&loop->pre, tmp);
4998 :
4999 : /* Clear all the used flags. */
5000 357808 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5001 235902 : if (ss->parent == NULL)
5002 231152 : ss->info->useflags = 0;
5003 121906 : }
5004 :
5005 :
5006 : /* Finish the main body of a scalarized expression, and start the secondary
5007 : copying body. */
5008 :
5009 : void
5010 8210 : gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
5011 : {
5012 8210 : int dim;
5013 8210 : int n;
5014 8210 : stmtblock_t *pblock;
5015 8210 : gfc_ss *ss;
5016 :
5017 8210 : pblock = body;
5018 : /* We finish as many loops as are used by the temporary. */
5019 9790 : for (dim = 0; dim < loop->temp_dim - 1; dim++)
5020 : {
5021 1580 : n = loop->order[dim];
5022 1580 : gfc_trans_scalarized_loop_end (loop, n, pblock);
5023 1580 : loop->loopvar[n] = NULL_TREE;
5024 1580 : pblock = &loop->code[n];
5025 : }
5026 :
5027 : /* We don't want to finish the outermost loop entirely. */
5028 8210 : n = loop->order[loop->temp_dim - 1];
5029 8210 : gfc_trans_scalarized_loop_end (loop, n, pblock);
5030 :
5031 : /* Restore the initial offsets. */
5032 23527 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5033 : {
5034 15317 : gfc_ss_type ss_type;
5035 15317 : gfc_ss_info *ss_info;
5036 :
5037 15317 : ss_info = ss->info;
5038 :
5039 15317 : if ((ss_info->useflags & 2) == 0)
5040 4539 : continue;
5041 :
5042 10778 : ss_type = ss_info->type;
5043 10932 : if (ss_type != GFC_SS_SECTION
5044 : && ss_type != GFC_SS_FUNCTION
5045 10778 : && ss_type != GFC_SS_CONSTRUCTOR
5046 10778 : && ss_type != GFC_SS_COMPONENT)
5047 154 : continue;
5048 :
5049 10624 : ss_info->data.array.offset = ss_info->data.array.saved_offset;
5050 : }
5051 :
5052 : /* Restart all the inner loops we just finished. */
5053 9790 : for (dim = loop->temp_dim - 2; dim >= 0; dim--)
5054 : {
5055 1580 : n = loop->order[dim];
5056 :
5057 1580 : gfc_start_block (&loop->code[n]);
5058 :
5059 1580 : loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
5060 :
5061 1580 : gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
5062 : }
5063 :
5064 : /* Start a block for the secondary copying code. */
5065 8210 : gfc_start_block (body);
5066 8210 : }
5067 :
5068 :
5069 : /* Precalculate (either lower or upper) bound of an array section.
5070 : BLOCK: Block in which the (pre)calculation code will go.
5071 : BOUNDS[DIM]: Where the bound value will be stored once evaluated.
5072 : VALUES[DIM]: Specified bound (NULL <=> unspecified).
5073 : DESC: Array descriptor from which the bound will be picked if unspecified
5074 : (either lower or upper bound according to LBOUND). */
5075 :
5076 : static void
5077 515630 : evaluate_bound (stmtblock_t *block, tree *bounds, gfc_expr ** values,
5078 : tree desc, int dim, bool lbound, bool deferred, bool save_value)
5079 : {
5080 515630 : gfc_se se;
5081 515630 : gfc_expr * input_val = values[dim];
5082 515630 : tree *output = &bounds[dim];
5083 :
5084 515630 : if (input_val)
5085 : {
5086 : /* Specified section bound. */
5087 47852 : gfc_init_se (&se, NULL);
5088 47852 : gfc_conv_expr_type (&se, input_val, gfc_array_index_type);
5089 47852 : gfc_add_block_to_block (block, &se.pre);
5090 47852 : *output = se.expr;
5091 : }
5092 467778 : else if (deferred && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
5093 : {
5094 : /* The gfc_conv_array_lbound () routine returns a constant zero for
5095 : deferred length arrays, which in the scalarizer wreaks havoc, when
5096 : copying to a (newly allocated) one-based array.
5097 : Keep returning the actual result in sync for both bounds. */
5098 191264 : *output = lbound ? gfc_conv_descriptor_lbound_get (desc,
5099 : gfc_rank_cst[dim]):
5100 63868 : gfc_conv_descriptor_ubound_get (desc,
5101 : gfc_rank_cst[dim]);
5102 : }
5103 : else
5104 : {
5105 : /* No specific bound specified so use the bound of the array. */
5106 507186 : *output = lbound ? gfc_conv_array_lbound (desc, dim) :
5107 166804 : gfc_conv_array_ubound (desc, dim);
5108 : }
5109 515630 : if (save_value)
5110 496532 : *output = gfc_evaluate_now (*output, block);
5111 515630 : }
5112 :
5113 :
5114 : /* Calculate the lower bound of an array section. */
5115 :
5116 : static void
5117 258448 : gfc_conv_section_startstride (stmtblock_t * block, gfc_ss * ss, int dim)
5118 : {
5119 258448 : gfc_expr *stride = NULL;
5120 258448 : tree desc;
5121 258448 : gfc_se se;
5122 258448 : gfc_array_info *info;
5123 258448 : gfc_array_ref *ar;
5124 :
5125 258448 : gcc_assert (ss->info->type == GFC_SS_SECTION);
5126 :
5127 258448 : info = &ss->info->data.array;
5128 258448 : ar = &info->ref->u.ar;
5129 :
5130 258448 : if (ar->dimen_type[dim] == DIMEN_VECTOR)
5131 : {
5132 : /* We use a zero-based index to access the vector. */
5133 980 : info->start[dim] = gfc_index_zero_node;
5134 980 : info->end[dim] = NULL;
5135 980 : info->stride[dim] = gfc_index_one_node;
5136 980 : return;
5137 : }
5138 :
5139 257468 : gcc_assert (ar->dimen_type[dim] == DIMEN_RANGE
5140 : || ar->dimen_type[dim] == DIMEN_THIS_IMAGE);
5141 257468 : desc = info->descriptor;
5142 257468 : stride = ar->stride[dim];
5143 257468 : bool save_value = !ss->is_alloc_lhs;
5144 :
5145 : /* Calculate the start of the range. For vector subscripts this will
5146 : be the range of the vector. */
5147 257468 : evaluate_bound (block, info->start, ar->start, desc, dim, true,
5148 257468 : ar->as->type == AS_DEFERRED, save_value);
5149 :
5150 : /* Similarly calculate the end. Although this is not used in the
5151 : scalarizer, it is needed when checking bounds and where the end
5152 : is an expression with side-effects. */
5153 257468 : evaluate_bound (block, info->end, ar->end, desc, dim, false,
5154 257468 : ar->as->type == AS_DEFERRED, save_value);
5155 :
5156 :
5157 : /* Calculate the stride. */
5158 257468 : if (stride == NULL)
5159 244742 : info->stride[dim] = gfc_index_one_node;
5160 : else
5161 : {
5162 12726 : gfc_init_se (&se, NULL);
5163 12726 : gfc_conv_expr_type (&se, stride, gfc_array_index_type);
5164 12726 : gfc_add_block_to_block (block, &se.pre);
5165 12726 : tree value = se.expr;
5166 12726 : if (save_value)
5167 12726 : info->stride[dim] = gfc_evaluate_now (value, block);
5168 : else
5169 0 : info->stride[dim] = value;
5170 : }
5171 : }
5172 :
5173 :
5174 : /* Generate in INNER the bounds checking code along the dimension DIM for
5175 : the array associated with SS_INFO. */
5176 :
5177 : static void
5178 24078 : add_check_section_in_array_bounds (stmtblock_t *inner, gfc_ss_info *ss_info,
5179 : int dim)
5180 : {
5181 24078 : gfc_expr *expr = ss_info->expr;
5182 24078 : locus *expr_loc = &expr->where;
5183 24078 : const char *expr_name = expr->symtree->name;
5184 :
5185 24078 : gfc_array_info *info = &ss_info->data.array;
5186 :
5187 24078 : bool check_upper;
5188 24078 : if (dim == info->ref->u.ar.dimen - 1
5189 20451 : && info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
5190 : check_upper = false;
5191 : else
5192 23782 : check_upper = true;
5193 :
5194 : /* Zero stride is not allowed. */
5195 24078 : tree tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
5196 : info->stride[dim], gfc_index_zero_node);
5197 24078 : char * msg = xasprintf ("Zero stride is not allowed, for dimension %d "
5198 : "of array '%s'", dim + 1, expr_name);
5199 24078 : gfc_trans_runtime_check (true, false, tmp, inner, expr_loc, msg);
5200 24078 : free (msg);
5201 :
5202 24078 : tree desc = info->descriptor;
5203 :
5204 : /* This is the run-time equivalent of resolve.cc's
5205 : check_dimension. The logical is more readable there
5206 : than it is here, with all the trees. */
5207 24078 : tree lbound = gfc_conv_array_lbound (desc, dim);
5208 24078 : tree end = info->end[dim];
5209 24078 : tree ubound = check_upper ? gfc_conv_array_ubound (desc, dim) : NULL_TREE;
5210 :
5211 : /* non_zerosized is true when the selected range is not
5212 : empty. */
5213 24078 : tree stride_pos = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
5214 : info->stride[dim], gfc_index_zero_node);
5215 24078 : tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
5216 : info->start[dim], end);
5217 24078 : stride_pos = fold_build2_loc (input_location, TRUTH_AND_EXPR,
5218 : logical_type_node, stride_pos, tmp);
5219 :
5220 24078 : tree stride_neg = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
5221 : info->stride[dim], gfc_index_zero_node);
5222 24078 : tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
5223 : info->start[dim], end);
5224 24078 : stride_neg = fold_build2_loc (input_location, TRUTH_AND_EXPR,
5225 : logical_type_node, stride_neg, tmp);
5226 24078 : tree non_zerosized = fold_build2_loc (input_location, TRUTH_OR_EXPR,
5227 : logical_type_node, stride_pos,
5228 : stride_neg);
5229 :
5230 : /* Check the start of the range against the lower and upper
5231 : bounds of the array, if the range is not empty.
5232 : If upper bound is present, include both bounds in the
5233 : error message. */
5234 24078 : if (check_upper)
5235 : {
5236 23782 : tmp = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
5237 : info->start[dim], lbound);
5238 23782 : tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
5239 : non_zerosized, tmp);
5240 23782 : tree tmp2 = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
5241 : info->start[dim], ubound);
5242 23782 : tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
5243 : non_zerosized, tmp2);
5244 23782 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' outside of "
5245 : "expected range (%%ld:%%ld)", dim + 1, expr_name);
5246 23782 : gfc_trans_runtime_check (true, false, tmp, inner, expr_loc, msg,
5247 : fold_convert (long_integer_type_node, info->start[dim]),
5248 : fold_convert (long_integer_type_node, lbound),
5249 : fold_convert (long_integer_type_node, ubound));
5250 23782 : gfc_trans_runtime_check (true, false, tmp2, inner, expr_loc, msg,
5251 : fold_convert (long_integer_type_node, info->start[dim]),
5252 : fold_convert (long_integer_type_node, lbound),
5253 : fold_convert (long_integer_type_node, ubound));
5254 23782 : free (msg);
5255 : }
5256 : else
5257 : {
5258 296 : tmp = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
5259 : info->start[dim], lbound);
5260 296 : tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
5261 : non_zerosized, tmp);
5262 296 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' below "
5263 : "lower bound of %%ld", dim + 1, expr_name);
5264 296 : gfc_trans_runtime_check (true, false, tmp, inner, expr_loc, msg,
5265 : fold_convert (long_integer_type_node, info->start[dim]),
5266 : fold_convert (long_integer_type_node, lbound));
5267 296 : free (msg);
5268 : }
5269 :
5270 : /* Compute the last element of the range, which is not
5271 : necessarily "end" (think 0:5:3, which doesn't contain 5)
5272 : and check it against both lower and upper bounds. */
5273 :
5274 24078 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5275 : end, info->start[dim]);
5276 24078 : tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR, gfc_array_index_type,
5277 : tmp, info->stride[dim]);
5278 24078 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5279 : end, tmp);
5280 24078 : tree tmp2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
5281 : tmp, lbound);
5282 24078 : tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
5283 : non_zerosized, tmp2);
5284 24078 : if (check_upper)
5285 : {
5286 23782 : tree tmp3 = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
5287 : tmp, ubound);
5288 23782 : tmp3 = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
5289 : non_zerosized, tmp3);
5290 23782 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' outside of "
5291 : "expected range (%%ld:%%ld)", dim + 1, expr_name);
5292 23782 : gfc_trans_runtime_check (true, false, tmp2, inner, expr_loc, msg,
5293 : fold_convert (long_integer_type_node, tmp),
5294 : fold_convert (long_integer_type_node, ubound),
5295 : fold_convert (long_integer_type_node, lbound));
5296 23782 : gfc_trans_runtime_check (true, false, tmp3, inner, expr_loc, msg,
5297 : fold_convert (long_integer_type_node, tmp),
5298 : fold_convert (long_integer_type_node, ubound),
5299 : fold_convert (long_integer_type_node, lbound));
5300 23782 : free (msg);
5301 : }
5302 : else
5303 : {
5304 296 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' below "
5305 : "lower bound of %%ld", dim + 1, expr_name);
5306 296 : gfc_trans_runtime_check (true, false, tmp2, inner, expr_loc, msg,
5307 : fold_convert (long_integer_type_node, tmp),
5308 : fold_convert (long_integer_type_node, lbound));
5309 296 : free (msg);
5310 : }
5311 24078 : }
5312 :
5313 :
5314 : /* Tells whether we need to generate bounds checking code for the array
5315 : associated with SS. */
5316 :
5317 : bool
5318 25045 : bounds_check_needed (gfc_ss *ss)
5319 : {
5320 : /* Catch allocatable lhs in f2003. */
5321 25045 : if (flag_realloc_lhs && ss->no_bounds_check)
5322 : return false;
5323 :
5324 24768 : gfc_ss_info *ss_info = ss->info;
5325 24768 : if (ss_info->type == GFC_SS_SECTION)
5326 : return true;
5327 :
5328 4126 : if (!(ss_info->type == GFC_SS_INTRINSIC
5329 227 : && ss_info->expr
5330 227 : && ss_info->expr->expr_type == EXPR_FUNCTION))
5331 : return false;
5332 :
5333 227 : gfc_intrinsic_sym *isym = ss_info->expr->value.function.isym;
5334 227 : if (!(isym
5335 227 : && (isym->id == GFC_ISYM_MAXLOC
5336 203 : || isym->id == GFC_ISYM_MINLOC)))
5337 : return false;
5338 :
5339 34 : return gfc_inline_intrinsic_function_p (ss_info->expr);
5340 : }
5341 :
5342 :
5343 : /* Calculates the range start and stride for a SS chain. Also gets the
5344 : descriptor and data pointer. The range of vector subscripts is the size
5345 : of the vector. Array bounds are also checked. */
5346 :
5347 : void
5348 183661 : gfc_conv_ss_startstride (gfc_loopinfo * loop)
5349 : {
5350 183661 : int n;
5351 183661 : tree tmp;
5352 183661 : gfc_ss *ss;
5353 :
5354 183661 : gfc_loopinfo * const outer_loop = outermost_loop (loop);
5355 :
5356 183661 : loop->dimen = 0;
5357 : /* Determine the rank of the loop. */
5358 203930 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5359 : {
5360 203930 : switch (ss->info->type)
5361 : {
5362 172375 : case GFC_SS_SECTION:
5363 172375 : case GFC_SS_CONSTRUCTOR:
5364 172375 : case GFC_SS_FUNCTION:
5365 172375 : case GFC_SS_COMPONENT:
5366 172375 : loop->dimen = ss->dimen;
5367 172375 : goto done;
5368 :
5369 : /* As usual, lbound and ubound are exceptions!. */
5370 11286 : case GFC_SS_INTRINSIC:
5371 11286 : switch (ss->info->expr->value.function.isym->id)
5372 : {
5373 11286 : case GFC_ISYM_LBOUND:
5374 11286 : case GFC_ISYM_UBOUND:
5375 11286 : case GFC_ISYM_COSHAPE:
5376 11286 : case GFC_ISYM_LCOBOUND:
5377 11286 : case GFC_ISYM_UCOBOUND:
5378 11286 : case GFC_ISYM_MAXLOC:
5379 11286 : case GFC_ISYM_MINLOC:
5380 11286 : case GFC_ISYM_SHAPE:
5381 11286 : case GFC_ISYM_THIS_IMAGE:
5382 11286 : loop->dimen = ss->dimen;
5383 11286 : goto done;
5384 :
5385 : default:
5386 : break;
5387 : }
5388 :
5389 20269 : default:
5390 20269 : break;
5391 : }
5392 : }
5393 :
5394 : /* We should have determined the rank of the expression by now. If
5395 : not, that's bad news. */
5396 0 : gcc_unreachable ();
5397 :
5398 : done:
5399 : /* Loop over all the SS in the chain. */
5400 477846 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5401 : {
5402 294185 : gfc_ss_info *ss_info;
5403 294185 : gfc_array_info *info;
5404 294185 : gfc_expr *expr;
5405 :
5406 294185 : ss_info = ss->info;
5407 294185 : expr = ss_info->expr;
5408 294185 : info = &ss_info->data.array;
5409 :
5410 294185 : if (expr && expr->shape && !info->shape)
5411 170781 : info->shape = expr->shape;
5412 :
5413 294185 : switch (ss_info->type)
5414 : {
5415 186525 : case GFC_SS_SECTION:
5416 : /* Get the descriptor for the array. If it is a cross loops array,
5417 : we got the descriptor already in the outermost loop. */
5418 186525 : if (ss->parent == NULL)
5419 181889 : gfc_conv_ss_descriptor (&outer_loop->pre, ss,
5420 181889 : !loop->array_parameter);
5421 :
5422 444155 : for (n = 0; n < ss->dimen; n++)
5423 257630 : gfc_conv_section_startstride (&outer_loop->pre, ss, ss->dim[n]);
5424 : break;
5425 :
5426 11533 : case GFC_SS_INTRINSIC:
5427 11533 : switch (expr->value.function.isym->id)
5428 : {
5429 3281 : case GFC_ISYM_MINLOC:
5430 3281 : case GFC_ISYM_MAXLOC:
5431 3281 : {
5432 3281 : gfc_se se;
5433 3281 : gfc_init_se (&se, nullptr);
5434 3281 : se.loop = loop;
5435 3281 : se.ss = ss;
5436 3281 : gfc_conv_intrinsic_function (&se, expr);
5437 3281 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
5438 3281 : gfc_add_block_to_block (&outer_loop->post, &se.post);
5439 :
5440 3281 : info->descriptor = se.expr;
5441 :
5442 3281 : info->data = gfc_conv_array_data (info->descriptor);
5443 3281 : info->data = gfc_evaluate_now (info->data, &outer_loop->pre);
5444 :
5445 3281 : gfc_expr *array = expr->value.function.actual->expr;
5446 3281 : tree rank = build_int_cst (gfc_array_index_type, array->rank);
5447 :
5448 3281 : tree tmp = fold_build2_loc (input_location, MINUS_EXPR,
5449 : gfc_array_index_type, rank,
5450 : gfc_index_one_node);
5451 :
5452 3281 : info->end[0] = gfc_evaluate_now (tmp, &outer_loop->pre);
5453 3281 : info->start[0] = gfc_index_zero_node;
5454 3281 : info->stride[0] = gfc_index_one_node;
5455 3281 : info->offset = gfc_index_zero_node;
5456 3281 : continue;
5457 3281 : }
5458 :
5459 : /* Fall through to supply start and stride. */
5460 3004 : case GFC_ISYM_LBOUND:
5461 3004 : case GFC_ISYM_UBOUND:
5462 : /* This is the variant without DIM=... */
5463 3004 : gcc_assert (expr->value.function.actual->next->expr == NULL);
5464 : /* Fall through. */
5465 :
5466 7944 : case GFC_ISYM_SHAPE:
5467 7944 : {
5468 7944 : gfc_expr *arg;
5469 :
5470 7944 : arg = expr->value.function.actual->expr;
5471 7944 : if (arg->rank == -1)
5472 : {
5473 1175 : gfc_se se;
5474 1175 : tree rank, tmp;
5475 :
5476 : /* The rank (hence the return value's shape) is unknown,
5477 : we have to retrieve it. */
5478 1175 : gfc_init_se (&se, NULL);
5479 1175 : se.descriptor_only = 1;
5480 1175 : gfc_conv_expr (&se, arg);
5481 : /* This is a bare variable, so there is no preliminary
5482 : or cleanup code unless -std=f202y and bounds checking
5483 : is on. */
5484 1175 : if (!((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
5485 0 : && (gfc_option.allow_std & GFC_STD_F202Y)))
5486 1175 : gcc_assert (se.pre.head == NULL_TREE
5487 : && se.post.head == NULL_TREE);
5488 1175 : rank = gfc_conv_descriptor_rank (se.expr);
5489 1175 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
5490 : gfc_array_index_type,
5491 : fold_convert (gfc_array_index_type,
5492 : rank),
5493 : gfc_index_one_node);
5494 1175 : info->end[0] = gfc_evaluate_now (tmp, &outer_loop->pre);
5495 1175 : info->start[0] = gfc_index_zero_node;
5496 1175 : info->stride[0] = gfc_index_one_node;
5497 1175 : continue;
5498 1175 : }
5499 : /* Otherwise fall through GFC_SS_FUNCTION. */
5500 : gcc_fallthrough ();
5501 : }
5502 : case GFC_ISYM_COSHAPE:
5503 : case GFC_ISYM_LCOBOUND:
5504 : case GFC_ISYM_UCOBOUND:
5505 : case GFC_ISYM_THIS_IMAGE:
5506 : break;
5507 :
5508 0 : default:
5509 0 : continue;
5510 0 : }
5511 :
5512 : /* FALLTHRU */
5513 : case GFC_SS_CONSTRUCTOR:
5514 : case GFC_SS_FUNCTION:
5515 129924 : for (n = 0; n < ss->dimen; n++)
5516 : {
5517 70106 : int dim = ss->dim[n];
5518 :
5519 70106 : info->start[dim] = gfc_index_zero_node;
5520 70106 : if (ss_info->type != GFC_SS_FUNCTION)
5521 55649 : info->end[dim] = gfc_index_zero_node;
5522 70106 : info->stride[dim] = gfc_index_one_node;
5523 : }
5524 : break;
5525 :
5526 : default:
5527 : break;
5528 : }
5529 : }
5530 :
5531 : /* The rest is just runtime bounds checking. */
5532 183661 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
5533 : {
5534 16945 : stmtblock_t block;
5535 16945 : tree size[GFC_MAX_DIMENSIONS];
5536 16945 : tree tmp3;
5537 16945 : gfc_array_info *info;
5538 16945 : char *msg;
5539 16945 : int dim;
5540 :
5541 16945 : gfc_start_block (&block);
5542 :
5543 54257 : for (n = 0; n < loop->dimen; n++)
5544 20367 : size[n] = NULL_TREE;
5545 :
5546 : /* If there is a constructor involved, derive size[] from its shape. */
5547 39164 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5548 : {
5549 24699 : gfc_ss_info *ss_info;
5550 :
5551 24699 : ss_info = ss->info;
5552 24699 : info = &ss_info->data.array;
5553 :
5554 24699 : if (ss_info->type == GFC_SS_CONSTRUCTOR && info->shape)
5555 : {
5556 5224 : for (n = 0; n < loop->dimen; n++)
5557 : {
5558 2744 : if (size[n] == NULL)
5559 : {
5560 2744 : gcc_assert (info->shape[n]);
5561 2744 : size[n] = gfc_conv_mpz_to_tree (info->shape[n],
5562 : gfc_index_integer_kind);
5563 : }
5564 : }
5565 : break;
5566 : }
5567 : }
5568 :
5569 41990 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5570 : {
5571 25045 : stmtblock_t inner;
5572 25045 : gfc_ss_info *ss_info;
5573 25045 : gfc_expr *expr;
5574 25045 : locus *expr_loc;
5575 25045 : const char *expr_name;
5576 25045 : char *ref_name = NULL;
5577 :
5578 25045 : if (!bounds_check_needed (ss))
5579 4369 : continue;
5580 :
5581 20676 : ss_info = ss->info;
5582 20676 : expr = ss_info->expr;
5583 20676 : expr_loc = &expr->where;
5584 20676 : if (expr->ref)
5585 20642 : expr_name = ref_name = abridged_ref_name (expr, NULL);
5586 : else
5587 34 : expr_name = expr->symtree->name;
5588 :
5589 20676 : gfc_start_block (&inner);
5590 :
5591 : /* TODO: range checking for mapped dimensions. */
5592 20676 : info = &ss_info->data.array;
5593 :
5594 : /* This code only checks ranges. Elemental and vector
5595 : dimensions are checked later. */
5596 65478 : for (n = 0; n < loop->dimen; n++)
5597 : {
5598 24126 : dim = ss->dim[n];
5599 24126 : if (ss_info->type == GFC_SS_SECTION)
5600 : {
5601 24092 : if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
5602 14 : continue;
5603 :
5604 24078 : add_check_section_in_array_bounds (&inner, ss_info, dim);
5605 : }
5606 :
5607 : /* Check the section sizes match. */
5608 24112 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
5609 : gfc_array_index_type, info->end[dim],
5610 : info->start[dim]);
5611 24112 : tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
5612 : gfc_array_index_type, tmp,
5613 : info->stride[dim]);
5614 24112 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
5615 : gfc_array_index_type,
5616 : gfc_index_one_node, tmp);
5617 24112 : tmp = fold_build2_loc (input_location, MAX_EXPR,
5618 : gfc_array_index_type, tmp,
5619 : build_int_cst (gfc_array_index_type, 0));
5620 : /* We remember the size of the first section, and check all the
5621 : others against this. */
5622 24112 : if (size[n])
5623 : {
5624 7193 : tmp3 = fold_build2_loc (input_location, NE_EXPR,
5625 : logical_type_node, tmp, size[n]);
5626 7193 : if (ss_info->type == GFC_SS_INTRINSIC)
5627 0 : msg = xasprintf ("Extent mismatch for dimension %d of the "
5628 : "result of intrinsic '%s' (%%ld/%%ld)",
5629 : dim + 1, expr_name);
5630 : else
5631 7193 : msg = xasprintf ("Array bound mismatch for dimension %d "
5632 : "of array '%s' (%%ld/%%ld)",
5633 : dim + 1, expr_name);
5634 :
5635 7193 : gfc_trans_runtime_check (true, false, tmp3, &inner,
5636 : expr_loc, msg,
5637 : fold_convert (long_integer_type_node, tmp),
5638 : fold_convert (long_integer_type_node, size[n]));
5639 :
5640 7193 : free (msg);
5641 : }
5642 : else
5643 16919 : size[n] = gfc_evaluate_now (tmp, &inner);
5644 : }
5645 :
5646 20676 : tmp = gfc_finish_block (&inner);
5647 :
5648 : /* For optional arguments, only check bounds if the argument is
5649 : present. */
5650 20676 : if ((expr->symtree->n.sym->attr.optional
5651 20368 : || expr->symtree->n.sym->attr.not_always_present)
5652 308 : && expr->symtree->n.sym->attr.dummy)
5653 307 : tmp = build3_v (COND_EXPR,
5654 : gfc_conv_expr_present (expr->symtree->n.sym),
5655 : tmp, build_empty_stmt (input_location));
5656 :
5657 20676 : gfc_add_expr_to_block (&block, tmp);
5658 :
5659 20676 : free (ref_name);
5660 : }
5661 :
5662 16945 : tmp = gfc_finish_block (&block);
5663 16945 : gfc_add_expr_to_block (&outer_loop->pre, tmp);
5664 : }
5665 :
5666 187025 : for (loop = loop->nested; loop; loop = loop->next)
5667 3364 : gfc_conv_ss_startstride (loop);
5668 183661 : }
5669 :
5670 : /* Return true if both symbols could refer to the same data object. Does
5671 : not take account of aliasing due to equivalence statements. */
5672 :
5673 : static bool
5674 13774 : symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym, bool lsym_pointer,
5675 : bool lsym_target, bool rsym_pointer, bool rsym_target)
5676 : {
5677 : /* Aliasing isn't possible if the symbols have different base types,
5678 : except for complex types where an inquiry reference (%RE, %IM) could
5679 : alias with a real type with the same kind parameter. */
5680 13774 : if (!gfc_compare_types (&lsym->ts, &rsym->ts)
5681 13774 : && !(((lsym->ts.type == BT_COMPLEX && rsym->ts.type == BT_REAL)
5682 4893 : || (lsym->ts.type == BT_REAL && rsym->ts.type == BT_COMPLEX))
5683 76 : && lsym->ts.kind == rsym->ts.kind))
5684 : return false;
5685 :
5686 : /* Pointers can point to other pointers and target objects. */
5687 :
5688 8894 : if ((lsym_pointer && (rsym_pointer || rsym_target))
5689 8685 : || (rsym_pointer && (lsym_pointer || lsym_target)))
5690 : return true;
5691 :
5692 : /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
5693 : and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
5694 : checked above. */
5695 8771 : if (lsym_target && rsym_target
5696 14 : && ((lsym->attr.dummy && !lsym->attr.contiguous
5697 0 : && (!lsym->attr.dimension || lsym->as->type == AS_ASSUMED_SHAPE))
5698 14 : || (rsym->attr.dummy && !rsym->attr.contiguous
5699 6 : && (!rsym->attr.dimension
5700 6 : || rsym->as->type == AS_ASSUMED_SHAPE))))
5701 6 : return true;
5702 :
5703 : return false;
5704 : }
5705 :
5706 :
5707 : /* Return true if the two SS could be aliased, i.e. both point to the same data
5708 : object. */
5709 : /* TODO: resolve aliases based on frontend expressions. */
5710 :
5711 : static int
5712 11602 : gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
5713 : {
5714 11602 : gfc_ref *lref;
5715 11602 : gfc_ref *rref;
5716 11602 : gfc_expr *lexpr, *rexpr;
5717 11602 : gfc_symbol *lsym;
5718 11602 : gfc_symbol *rsym;
5719 11602 : bool lsym_pointer, lsym_target, rsym_pointer, rsym_target;
5720 :
5721 11602 : lexpr = lss->info->expr;
5722 11602 : rexpr = rss->info->expr;
5723 :
5724 11602 : lsym = lexpr->symtree->n.sym;
5725 11602 : rsym = rexpr->symtree->n.sym;
5726 :
5727 11602 : lsym_pointer = lsym->attr.pointer;
5728 11602 : lsym_target = lsym->attr.target;
5729 11602 : rsym_pointer = rsym->attr.pointer;
5730 11602 : rsym_target = rsym->attr.target;
5731 :
5732 11602 : if (symbols_could_alias (lsym, rsym, lsym_pointer, lsym_target,
5733 : rsym_pointer, rsym_target))
5734 : return 1;
5735 :
5736 11511 : if (rsym->ts.type != BT_DERIVED && rsym->ts.type != BT_CLASS
5737 10130 : && lsym->ts.type != BT_DERIVED && lsym->ts.type != BT_CLASS)
5738 : return 0;
5739 :
5740 : /* For derived types we must check all the component types. We can ignore
5741 : array references as these will have the same base type as the previous
5742 : component ref. */
5743 2818 : for (lref = lexpr->ref; lref != lss->info->data.array.ref; lref = lref->next)
5744 : {
5745 1013 : if (lref->type != REF_COMPONENT)
5746 107 : continue;
5747 :
5748 906 : lsym_pointer = lsym_pointer || lref->u.c.sym->attr.pointer;
5749 906 : lsym_target = lsym_target || lref->u.c.sym->attr.target;
5750 :
5751 906 : if (symbols_could_alias (lref->u.c.sym, rsym, lsym_pointer, lsym_target,
5752 : rsym_pointer, rsym_target))
5753 : return 1;
5754 :
5755 906 : if ((lsym_pointer && (rsym_pointer || rsym_target))
5756 891 : || (rsym_pointer && (lsym_pointer || lsym_target)))
5757 : {
5758 6 : if (gfc_compare_types (&lref->u.c.component->ts,
5759 : &rsym->ts))
5760 : return 1;
5761 : }
5762 :
5763 1354 : for (rref = rexpr->ref; rref != rss->info->data.array.ref;
5764 454 : rref = rref->next)
5765 : {
5766 455 : if (rref->type != REF_COMPONENT)
5767 36 : continue;
5768 :
5769 419 : rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
5770 419 : rsym_target = lsym_target || rref->u.c.sym->attr.target;
5771 :
5772 419 : if (symbols_could_alias (lref->u.c.sym, rref->u.c.sym,
5773 : lsym_pointer, lsym_target,
5774 : rsym_pointer, rsym_target))
5775 : return 1;
5776 :
5777 418 : if ((lsym_pointer && (rsym_pointer || rsym_target))
5778 414 : || (rsym_pointer && (lsym_pointer || lsym_target)))
5779 : {
5780 0 : if (gfc_compare_types (&lref->u.c.component->ts,
5781 0 : &rref->u.c.sym->ts))
5782 : return 1;
5783 0 : if (gfc_compare_types (&lref->u.c.sym->ts,
5784 0 : &rref->u.c.component->ts))
5785 : return 1;
5786 0 : if (gfc_compare_types (&lref->u.c.component->ts,
5787 0 : &rref->u.c.component->ts))
5788 : return 1;
5789 : }
5790 : }
5791 : }
5792 :
5793 1805 : lsym_pointer = lsym->attr.pointer;
5794 1805 : lsym_target = lsym->attr.target;
5795 :
5796 2646 : for (rref = rexpr->ref; rref != rss->info->data.array.ref; rref = rref->next)
5797 : {
5798 994 : if (rref->type != REF_COMPONENT)
5799 : break;
5800 :
5801 847 : rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
5802 847 : rsym_target = lsym_target || rref->u.c.sym->attr.target;
5803 :
5804 847 : if (symbols_could_alias (rref->u.c.sym, lsym,
5805 : lsym_pointer, lsym_target,
5806 : rsym_pointer, rsym_target))
5807 : return 1;
5808 :
5809 847 : if ((lsym_pointer && (rsym_pointer || rsym_target))
5810 829 : || (rsym_pointer && (lsym_pointer || lsym_target)))
5811 : {
5812 6 : if (gfc_compare_types (&lsym->ts, &rref->u.c.component->ts))
5813 : return 1;
5814 : }
5815 : }
5816 :
5817 : return 0;
5818 : }
5819 :
5820 :
5821 : /* Resolve array data dependencies. Creates a temporary if required. */
5822 : /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
5823 : dependency.cc. */
5824 :
5825 : void
5826 38336 : gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
5827 : gfc_ss * rss)
5828 : {
5829 38336 : gfc_ss *ss;
5830 38336 : gfc_ref *lref;
5831 38336 : gfc_ref *rref;
5832 38336 : gfc_ss_info *ss_info;
5833 38336 : gfc_expr *dest_expr;
5834 38336 : gfc_expr *ss_expr;
5835 38336 : int nDepend = 0;
5836 38336 : int i, j;
5837 :
5838 38336 : loop->temp_ss = NULL;
5839 38336 : dest_expr = dest->info->expr;
5840 :
5841 82563 : for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
5842 : {
5843 45413 : ss_info = ss->info;
5844 45413 : ss_expr = ss_info->expr;
5845 :
5846 45413 : if (ss_info->array_outer_dependency)
5847 : {
5848 : nDepend = 1;
5849 : break;
5850 : }
5851 :
5852 45296 : if (ss_info->type != GFC_SS_SECTION)
5853 : {
5854 30911 : if (flag_realloc_lhs
5855 29860 : && dest_expr != ss_expr
5856 29860 : && gfc_is_reallocatable_lhs (dest_expr)
5857 38049 : && ss_expr->rank)
5858 3430 : nDepend = gfc_check_dependency (dest_expr, ss_expr, true);
5859 :
5860 : /* Check for cases like c(:)(1:2) = c(2)(2:3) */
5861 30911 : if (!nDepend && dest_expr->rank > 0
5862 30388 : && dest_expr->ts.type == BT_CHARACTER
5863 4772 : && ss_expr->expr_type == EXPR_VARIABLE)
5864 :
5865 165 : nDepend = gfc_check_dependency (dest_expr, ss_expr, false);
5866 :
5867 30911 : if (ss_info->type == GFC_SS_REFERENCE
5868 30911 : && gfc_check_dependency (dest_expr, ss_expr, false))
5869 188 : ss_info->data.scalar.needs_temporary = 1;
5870 :
5871 30911 : if (nDepend)
5872 : break;
5873 : else
5874 30376 : continue;
5875 : }
5876 :
5877 14385 : if (dest_expr->symtree->n.sym != ss_expr->symtree->n.sym)
5878 : {
5879 11602 : if (gfc_could_be_alias (dest, ss)
5880 11602 : || gfc_are_equivalenced_arrays (dest_expr, ss_expr))
5881 : {
5882 : nDepend = 1;
5883 : break;
5884 : }
5885 : }
5886 : else
5887 : {
5888 2783 : lref = dest_expr->ref;
5889 2783 : rref = ss_expr->ref;
5890 :
5891 2783 : nDepend = gfc_dep_resolver (lref, rref, &loop->reverse[0]);
5892 :
5893 2783 : if (nDepend == 1)
5894 : break;
5895 :
5896 5554 : for (i = 0; i < dest->dimen; i++)
5897 7546 : for (j = 0; j < ss->dimen; j++)
5898 4486 : if (i != j
5899 1363 : && dest->dim[i] == ss->dim[j])
5900 : {
5901 : /* If we don't access array elements in the same order,
5902 : there is a dependency. */
5903 63 : nDepend = 1;
5904 63 : goto temporary;
5905 : }
5906 : #if 0
5907 : /* TODO : loop shifting. */
5908 : if (nDepend == 1)
5909 : {
5910 : /* Mark the dimensions for LOOP SHIFTING */
5911 : for (n = 0; n < loop->dimen; n++)
5912 : {
5913 : int dim = dest->data.info.dim[n];
5914 :
5915 : if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
5916 : depends[n] = 2;
5917 : else if (! gfc_is_same_range (&lref->u.ar,
5918 : &rref->u.ar, dim, 0))
5919 : depends[n] = 1;
5920 : }
5921 :
5922 : /* Put all the dimensions with dependencies in the
5923 : innermost loops. */
5924 : dim = 0;
5925 : for (n = 0; n < loop->dimen; n++)
5926 : {
5927 : gcc_assert (loop->order[n] == n);
5928 : if (depends[n])
5929 : loop->order[dim++] = n;
5930 : }
5931 : for (n = 0; n < loop->dimen; n++)
5932 : {
5933 : if (! depends[n])
5934 : loop->order[dim++] = n;
5935 : }
5936 :
5937 : gcc_assert (dim == loop->dimen);
5938 : break;
5939 : }
5940 : #endif
5941 : }
5942 : }
5943 :
5944 824 : temporary:
5945 :
5946 38336 : if (nDepend == 1)
5947 : {
5948 1186 : tree base_type = gfc_typenode_for_spec (&dest_expr->ts);
5949 1186 : if (GFC_ARRAY_TYPE_P (base_type)
5950 1186 : || GFC_DESCRIPTOR_TYPE_P (base_type))
5951 0 : base_type = gfc_get_element_type (base_type);
5952 1186 : loop->temp_ss = gfc_get_temp_ss (base_type, dest->info->string_length,
5953 : loop->dimen);
5954 1186 : gfc_add_ss_to_loop (loop, loop->temp_ss);
5955 : }
5956 : else
5957 37150 : loop->temp_ss = NULL;
5958 38336 : }
5959 :
5960 :
5961 : /* Browse through each array's information from the scalarizer and set the loop
5962 : bounds according to the "best" one (per dimension), i.e. the one which
5963 : provides the most information (constant bounds, shape, etc.). */
5964 :
5965 : static void
5966 183661 : set_loop_bounds (gfc_loopinfo *loop)
5967 : {
5968 183661 : int n, dim, spec_dim;
5969 183661 : gfc_array_info *info;
5970 183661 : gfc_array_info *specinfo;
5971 183661 : gfc_ss *ss;
5972 183661 : tree tmp;
5973 183661 : gfc_ss **loopspec;
5974 183661 : bool dynamic[GFC_MAX_DIMENSIONS];
5975 183661 : mpz_t *cshape;
5976 183661 : mpz_t i;
5977 183661 : bool nonoptional_arr;
5978 :
5979 183661 : gfc_loopinfo * const outer_loop = outermost_loop (loop);
5980 :
5981 183661 : loopspec = loop->specloop;
5982 :
5983 183661 : mpz_init (i);
5984 432570 : for (n = 0; n < loop->dimen; n++)
5985 : {
5986 248909 : loopspec[n] = NULL;
5987 248909 : dynamic[n] = false;
5988 :
5989 : /* If there are both optional and nonoptional array arguments, scalarize
5990 : over the nonoptional; otherwise, it does not matter as then all
5991 : (optional) arrays have to be present per F2008, 125.2.12p3(6). */
5992 :
5993 248909 : nonoptional_arr = false;
5994 :
5995 290205 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5996 290185 : if (ss->info->type != GFC_SS_SCALAR && ss->info->type != GFC_SS_TEMP
5997 255480 : && ss->info->type != GFC_SS_REFERENCE && !ss->info->can_be_null_ref)
5998 : {
5999 : nonoptional_arr = true;
6000 : break;
6001 : }
6002 :
6003 : /* We use one SS term, and use that to determine the bounds of the
6004 : loop for this dimension. We try to pick the simplest term. */
6005 652063 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
6006 : {
6007 403154 : gfc_ss_type ss_type;
6008 :
6009 403154 : ss_type = ss->info->type;
6010 473299 : if (ss_type == GFC_SS_SCALAR
6011 403154 : || ss_type == GFC_SS_TEMP
6012 342279 : || ss_type == GFC_SS_REFERENCE
6013 333286 : || (ss->info->can_be_null_ref && nonoptional_arr))
6014 70145 : continue;
6015 :
6016 333009 : info = &ss->info->data.array;
6017 333009 : dim = ss->dim[n];
6018 :
6019 333009 : if (loopspec[n] != NULL)
6020 : {
6021 84100 : specinfo = &loopspec[n]->info->data.array;
6022 84100 : spec_dim = loopspec[n]->dim[n];
6023 : }
6024 : else
6025 : {
6026 : /* Silence uninitialized warnings. */
6027 : specinfo = NULL;
6028 : spec_dim = 0;
6029 : }
6030 :
6031 333009 : if (info->shape)
6032 : {
6033 : /* The frontend has worked out the size for us. */
6034 225384 : if (!loopspec[n]
6035 59443 : || !specinfo->shape
6036 272124 : || !integer_zerop (specinfo->start[spec_dim]))
6037 : /* Prefer zero-based descriptors if possible. */
6038 208405 : loopspec[n] = ss;
6039 225384 : continue;
6040 : }
6041 :
6042 107625 : if (ss_type == GFC_SS_CONSTRUCTOR)
6043 : {
6044 1446 : gfc_constructor_base base;
6045 : /* An unknown size constructor will always be rank one.
6046 : Higher rank constructors will either have known shape,
6047 : or still be wrapped in a call to reshape. */
6048 1446 : gcc_assert (loop->dimen == 1);
6049 :
6050 : /* Always prefer to use the constructor bounds if the size
6051 : can be determined at compile time. Prefer not to otherwise,
6052 : since the general case involves realloc, and it's better to
6053 : avoid that overhead if possible. */
6054 1446 : base = ss->info->expr->value.constructor;
6055 1446 : dynamic[n] = gfc_get_array_constructor_size (&i, base);
6056 1446 : if (!dynamic[n] || !loopspec[n])
6057 1223 : loopspec[n] = ss;
6058 1446 : continue;
6059 1446 : }
6060 :
6061 : /* Avoid using an allocatable lhs in an assignment, since
6062 : there might be a reallocation coming. */
6063 106179 : if (loopspec[n] && ss->is_alloc_lhs)
6064 9549 : continue;
6065 :
6066 96630 : if (!loopspec[n])
6067 81745 : loopspec[n] = ss;
6068 : /* Criteria for choosing a loop specifier (most important first):
6069 : doesn't need realloc
6070 : stride of one
6071 : known stride
6072 : known lower bound
6073 : known upper bound
6074 : */
6075 14885 : else if (loopspec[n]->info->type == GFC_SS_CONSTRUCTOR && dynamic[n])
6076 235 : loopspec[n] = ss;
6077 14650 : else if (integer_onep (info->stride[dim])
6078 14650 : && !integer_onep (specinfo->stride[spec_dim]))
6079 120 : loopspec[n] = ss;
6080 14530 : else if (INTEGER_CST_P (info->stride[dim])
6081 14306 : && !INTEGER_CST_P (specinfo->stride[spec_dim]))
6082 0 : loopspec[n] = ss;
6083 14530 : else if (INTEGER_CST_P (info->start[dim])
6084 4445 : && !INTEGER_CST_P (specinfo->start[spec_dim])
6085 856 : && integer_onep (info->stride[dim])
6086 428 : == integer_onep (specinfo->stride[spec_dim])
6087 14530 : && INTEGER_CST_P (info->stride[dim])
6088 401 : == INTEGER_CST_P (specinfo->stride[spec_dim]))
6089 401 : loopspec[n] = ss;
6090 : /* We don't work out the upper bound.
6091 : else if (INTEGER_CST_P (info->finish[n])
6092 : && ! INTEGER_CST_P (specinfo->finish[n]))
6093 : loopspec[n] = ss; */
6094 : }
6095 :
6096 : /* We should have found the scalarization loop specifier. If not,
6097 : that's bad news. */
6098 248909 : gcc_assert (loopspec[n]);
6099 :
6100 248909 : info = &loopspec[n]->info->data.array;
6101 248909 : dim = loopspec[n]->dim[n];
6102 :
6103 : /* Set the extents of this range. */
6104 248909 : cshape = info->shape;
6105 248909 : if (cshape && INTEGER_CST_P (info->start[dim])
6106 178445 : && INTEGER_CST_P (info->stride[dim]))
6107 : {
6108 178445 : loop->from[n] = info->start[dim];
6109 178445 : mpz_set (i, cshape[get_array_ref_dim_for_loop_dim (loopspec[n], n)]);
6110 178445 : mpz_sub_ui (i, i, 1);
6111 : /* To = from + (size - 1) * stride. */
6112 178445 : tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
6113 178445 : if (!integer_onep (info->stride[dim]))
6114 8665 : tmp = fold_build2_loc (input_location, MULT_EXPR,
6115 : gfc_array_index_type, tmp,
6116 : info->stride[dim]);
6117 178445 : loop->to[n] = fold_build2_loc (input_location, PLUS_EXPR,
6118 : gfc_array_index_type,
6119 : loop->from[n], tmp);
6120 : }
6121 : else
6122 : {
6123 70464 : loop->from[n] = info->start[dim];
6124 70464 : switch (loopspec[n]->info->type)
6125 : {
6126 887 : case GFC_SS_CONSTRUCTOR:
6127 : /* The upper bound is calculated when we expand the
6128 : constructor. */
6129 887 : gcc_assert (loop->to[n] == NULL_TREE);
6130 : break;
6131 :
6132 63927 : case GFC_SS_SECTION:
6133 : /* Use the end expression if it exists and is not constant,
6134 : so that it is only evaluated once. */
6135 63927 : loop->to[n] = info->end[dim];
6136 63927 : break;
6137 :
6138 4871 : case GFC_SS_FUNCTION:
6139 : /* The loop bound will be set when we generate the call. */
6140 4871 : gcc_assert (loop->to[n] == NULL_TREE);
6141 : break;
6142 :
6143 767 : case GFC_SS_INTRINSIC:
6144 767 : {
6145 767 : gfc_expr *expr = loopspec[n]->info->expr;
6146 :
6147 : /* The {l,u}bound of an assumed rank. */
6148 767 : if (expr->value.function.isym->id == GFC_ISYM_SHAPE)
6149 255 : gcc_assert (expr->value.function.actual->expr->rank == -1);
6150 : else
6151 512 : gcc_assert ((expr->value.function.isym->id == GFC_ISYM_LBOUND
6152 : || expr->value.function.isym->id == GFC_ISYM_UBOUND)
6153 : && expr->value.function.actual->next->expr == NULL
6154 : && expr->value.function.actual->expr->rank == -1);
6155 :
6156 767 : loop->to[n] = info->end[dim];
6157 767 : break;
6158 : }
6159 :
6160 12 : case GFC_SS_COMPONENT:
6161 12 : {
6162 12 : if (info->end[dim] != NULL_TREE)
6163 : {
6164 12 : loop->to[n] = info->end[dim];
6165 12 : break;
6166 : }
6167 : else
6168 0 : gcc_unreachable ();
6169 : }
6170 :
6171 0 : default:
6172 0 : gcc_unreachable ();
6173 : }
6174 : }
6175 :
6176 : /* Transform everything so we have a simple incrementing variable. */
6177 248909 : if (integer_onep (info->stride[dim]))
6178 238129 : info->delta[dim] = gfc_index_zero_node;
6179 : else
6180 : {
6181 : /* Set the delta for this section. */
6182 10780 : info->delta[dim] = gfc_evaluate_now (loop->from[n], &outer_loop->pre);
6183 : /* Number of iterations is (end - start + step) / step.
6184 : with start = 0, this simplifies to
6185 : last = end / step;
6186 : for (i = 0; i<=last; i++){...}; */
6187 10780 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
6188 : gfc_array_index_type, loop->to[n],
6189 : loop->from[n]);
6190 10780 : tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
6191 : gfc_array_index_type, tmp, info->stride[dim]);
6192 10780 : tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
6193 : tmp, build_int_cst (gfc_array_index_type, -1));
6194 10780 : loop->to[n] = gfc_evaluate_now (tmp, &outer_loop->pre);
6195 : /* Make the loop variable start at 0. */
6196 10780 : loop->from[n] = gfc_index_zero_node;
6197 : }
6198 : }
6199 183661 : mpz_clear (i);
6200 :
6201 187025 : for (loop = loop->nested; loop; loop = loop->next)
6202 3364 : set_loop_bounds (loop);
6203 183661 : }
6204 :
6205 :
6206 : /* Last attempt to set the loop bounds, in case they depend on an allocatable
6207 : function result. */
6208 :
6209 : static void
6210 183661 : late_set_loop_bounds (gfc_loopinfo *loop)
6211 : {
6212 183661 : int n, dim;
6213 183661 : gfc_array_info *info;
6214 183661 : gfc_ss **loopspec;
6215 :
6216 183661 : loopspec = loop->specloop;
6217 :
6218 432570 : for (n = 0; n < loop->dimen; n++)
6219 : {
6220 : /* Set the extents of this range. */
6221 248909 : if (loop->from[n] == NULL_TREE
6222 248909 : || loop->to[n] == NULL_TREE)
6223 : {
6224 : /* We should have found the scalarization loop specifier. If not,
6225 : that's bad news. */
6226 455 : gcc_assert (loopspec[n]);
6227 :
6228 455 : info = &loopspec[n]->info->data.array;
6229 455 : dim = loopspec[n]->dim[n];
6230 :
6231 455 : if (loopspec[n]->info->type == GFC_SS_FUNCTION
6232 455 : && info->start[dim]
6233 455 : && info->end[dim])
6234 : {
6235 153 : loop->from[n] = info->start[dim];
6236 153 : loop->to[n] = info->end[dim];
6237 : }
6238 : }
6239 : }
6240 :
6241 187025 : for (loop = loop->nested; loop; loop = loop->next)
6242 3364 : late_set_loop_bounds (loop);
6243 183661 : }
6244 :
6245 :
6246 : /* Initialize the scalarization loop. Creates the loop variables. Determines
6247 : the range of the loop variables. Creates a temporary if required.
6248 : Also generates code for scalar expressions which have been
6249 : moved outside the loop. */
6250 :
6251 : void
6252 180297 : gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
6253 : {
6254 180297 : gfc_ss *tmp_ss;
6255 180297 : tree tmp;
6256 :
6257 180297 : set_loop_bounds (loop);
6258 :
6259 : /* Add all the scalar code that can be taken out of the loops.
6260 : This may include calculating the loop bounds, so do it before
6261 : allocating the temporary. */
6262 180297 : gfc_add_loop_ss_code (loop, loop->ss, false, where);
6263 :
6264 180297 : late_set_loop_bounds (loop);
6265 :
6266 180297 : tmp_ss = loop->temp_ss;
6267 : /* If we want a temporary then create it. */
6268 180297 : if (tmp_ss != NULL)
6269 : {
6270 11287 : gfc_ss_info *tmp_ss_info;
6271 :
6272 11287 : tmp_ss_info = tmp_ss->info;
6273 11287 : gcc_assert (tmp_ss_info->type == GFC_SS_TEMP);
6274 11287 : gcc_assert (loop->parent == NULL);
6275 :
6276 : /* Make absolutely sure that this is a complete type. */
6277 11287 : if (tmp_ss_info->string_length)
6278 2754 : tmp_ss_info->data.temp.type
6279 2754 : = gfc_get_character_type_len_for_eltype
6280 2754 : (TREE_TYPE (tmp_ss_info->data.temp.type),
6281 : tmp_ss_info->string_length);
6282 :
6283 11287 : tmp = tmp_ss_info->data.temp.type;
6284 11287 : memset (&tmp_ss_info->data.array, 0, sizeof (gfc_array_info));
6285 11287 : tmp_ss_info->type = GFC_SS_SECTION;
6286 :
6287 11287 : gcc_assert (tmp_ss->dimen != 0);
6288 :
6289 11287 : gfc_trans_create_temp_array (&loop->pre, &loop->post, tmp_ss, tmp,
6290 : NULL_TREE, false, true, false, where);
6291 : }
6292 :
6293 : /* For array parameters we don't have loop variables, so don't calculate the
6294 : translations. */
6295 180297 : if (!loop->array_parameter)
6296 113023 : gfc_set_delta (loop);
6297 180297 : }
6298 :
6299 :
6300 : /* Calculates how to transform from loop variables to array indices for each
6301 : array: once loop bounds are chosen, sets the difference (DELTA field) between
6302 : loop bounds and array reference bounds, for each array info. */
6303 :
6304 : void
6305 116854 : gfc_set_delta (gfc_loopinfo *loop)
6306 : {
6307 116854 : gfc_ss *ss, **loopspec;
6308 116854 : gfc_array_info *info;
6309 116854 : tree tmp;
6310 116854 : int n, dim;
6311 :
6312 116854 : gfc_loopinfo * const outer_loop = outermost_loop (loop);
6313 :
6314 116854 : loopspec = loop->specloop;
6315 :
6316 : /* Calculate the translation from loop variables to array indices. */
6317 354348 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
6318 : {
6319 237494 : gfc_ss_type ss_type;
6320 :
6321 237494 : ss_type = ss->info->type;
6322 61154 : if (!(ss_type == GFC_SS_SECTION
6323 237494 : || ss_type == GFC_SS_COMPONENT
6324 96881 : || ss_type == GFC_SS_CONSTRUCTOR
6325 : || (ss_type == GFC_SS_FUNCTION
6326 8268 : && gfc_is_class_array_function (ss->info->expr))))
6327 61002 : continue;
6328 :
6329 176492 : info = &ss->info->data.array;
6330 :
6331 397027 : for (n = 0; n < ss->dimen; n++)
6332 : {
6333 : /* If we are specifying the range the delta is already set. */
6334 220535 : if (loopspec[n] != ss)
6335 : {
6336 114819 : dim = ss->dim[n];
6337 :
6338 : /* Calculate the offset relative to the loop variable.
6339 : First multiply by the stride. */
6340 114819 : tmp = loop->from[n];
6341 114819 : if (!integer_onep (info->stride[dim]))
6342 3084 : tmp = fold_build2_loc (input_location, MULT_EXPR,
6343 : gfc_array_index_type,
6344 : tmp, info->stride[dim]);
6345 :
6346 : /* Then subtract this from our starting value. */
6347 114819 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
6348 : gfc_array_index_type,
6349 : info->start[dim], tmp);
6350 :
6351 114819 : if (ss->is_alloc_lhs)
6352 9549 : info->delta[dim] = tmp;
6353 : else
6354 105270 : info->delta[dim] = gfc_evaluate_now (tmp, &outer_loop->pre);
6355 : }
6356 : }
6357 : }
6358 :
6359 120306 : for (loop = loop->nested; loop; loop = loop->next)
6360 3452 : gfc_set_delta (loop);
6361 116854 : }
6362 :
6363 :
6364 : /* Calculate the size of a given array dimension from the bounds. This
6365 : is simply (ubound - lbound + 1) if this expression is positive
6366 : or 0 if it is negative (pick either one if it is zero). Optionally
6367 : (if or_expr is present) OR the (expression != 0) condition to it. */
6368 :
6369 : tree
6370 23160 : gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr)
6371 : {
6372 23160 : tree res;
6373 23160 : tree cond;
6374 :
6375 : /* Calculate (ubound - lbound + 1). */
6376 23160 : res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6377 : ubound, lbound);
6378 23160 : res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res,
6379 : gfc_index_one_node);
6380 :
6381 : /* Check whether the size for this dimension is negative. */
6382 23160 : cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, res,
6383 : gfc_index_zero_node);
6384 23160 : res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
6385 : gfc_index_zero_node, res);
6386 :
6387 : /* Build OR expression. */
6388 23160 : if (or_expr)
6389 17806 : *or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
6390 : logical_type_node, *or_expr, cond);
6391 :
6392 23160 : return res;
6393 : }
6394 :
6395 :
6396 : /* For an array descriptor, get the total number of elements. This is just
6397 : the product of the extents along from_dim to to_dim. */
6398 :
6399 : static tree
6400 1936 : gfc_conv_descriptor_size_1 (tree desc, int from_dim, int to_dim)
6401 : {
6402 1936 : tree res;
6403 1936 : int dim;
6404 :
6405 1936 : res = gfc_index_one_node;
6406 :
6407 4741 : for (dim = from_dim; dim < to_dim; ++dim)
6408 : {
6409 2805 : tree lbound;
6410 2805 : tree ubound;
6411 2805 : tree extent;
6412 :
6413 2805 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
6414 2805 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
6415 :
6416 2805 : extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
6417 2805 : res = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6418 : res, extent);
6419 : }
6420 :
6421 1936 : return res;
6422 : }
6423 :
6424 :
6425 : /* Full size of an array. */
6426 :
6427 : tree
6428 1872 : gfc_conv_descriptor_size (tree desc, int rank)
6429 : {
6430 1872 : return gfc_conv_descriptor_size_1 (desc, 0, rank);
6431 : }
6432 :
6433 :
6434 : /* Size of a coarray for all dimensions but the last. */
6435 :
6436 : tree
6437 64 : gfc_conv_descriptor_cosize (tree desc, int rank, int corank)
6438 : {
6439 64 : return gfc_conv_descriptor_size_1 (desc, rank, rank + corank - 1);
6440 : }
6441 :
6442 :
6443 : /* Fills in an array descriptor, and returns the size of the array.
6444 : The size will be a simple_val, ie a variable or a constant. Also
6445 : calculates the offset of the base. The pointer argument overflow,
6446 : which should be of integer type, will increase in value if overflow
6447 : occurs during the size calculation. Returns the size of the array.
6448 : {
6449 : stride = 1;
6450 : offset = 0;
6451 : for (n = 0; n < rank; n++)
6452 : {
6453 : a.lbound[n] = specified_lower_bound;
6454 : offset = offset + a.lbond[n] * stride;
6455 : size = 1 - lbound;
6456 : a.ubound[n] = specified_upper_bound;
6457 : a.stride[n] = stride;
6458 : size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
6459 : overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
6460 : stride = stride * size;
6461 : }
6462 : for (n = rank; n < rank+corank; n++)
6463 : (Set lcobound/ucobound as above.)
6464 : element_size = sizeof (array element);
6465 : if (!rank)
6466 : return element_size
6467 : stride = (size_t) stride;
6468 : overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
6469 : stride = stride * element_size;
6470 : return (stride);
6471 : } */
6472 : /*GCC ARRAYS*/
6473 :
6474 : static tree
6475 12164 : gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
6476 : gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
6477 : stmtblock_t * descriptor_block, tree * overflow,
6478 : tree expr3_elem_size, gfc_expr *expr3, tree expr3_desc,
6479 : bool e3_has_nodescriptor, gfc_expr *expr,
6480 : tree *element_size, bool explicit_ts)
6481 : {
6482 12164 : tree type;
6483 12164 : tree tmp;
6484 12164 : tree size;
6485 12164 : tree offset;
6486 12164 : tree stride;
6487 12164 : tree or_expr;
6488 12164 : tree thencase;
6489 12164 : tree elsecase;
6490 12164 : tree cond;
6491 12164 : tree var;
6492 12164 : stmtblock_t thenblock;
6493 12164 : stmtblock_t elseblock;
6494 12164 : gfc_expr *ubound;
6495 12164 : gfc_se se;
6496 12164 : int n;
6497 :
6498 12164 : type = TREE_TYPE (descriptor);
6499 :
6500 12164 : stride = gfc_index_one_node;
6501 12164 : offset = gfc_index_zero_node;
6502 :
6503 : /* Set the dtype before the alloc, because registration of coarrays needs
6504 : it initialized. */
6505 12164 : if (expr->ts.type == BT_CHARACTER
6506 1079 : && expr->ts.deferred
6507 545 : && VAR_P (expr->ts.u.cl->backend_decl))
6508 : {
6509 366 : type = gfc_typenode_for_spec (&expr->ts);
6510 366 : tmp = gfc_conv_descriptor_dtype (descriptor);
6511 366 : gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type));
6512 : }
6513 11798 : else if (expr->ts.type == BT_CHARACTER
6514 713 : && expr->ts.deferred
6515 179 : && TREE_CODE (descriptor) == COMPONENT_REF)
6516 : {
6517 : /* Deferred character components have their string length tucked away
6518 : in a hidden field of the derived type. Obtain that and use it to
6519 : set the dtype. The charlen backend decl is zero because the field
6520 : type is zero length. */
6521 161 : gfc_ref *ref;
6522 161 : tmp = NULL_TREE;
6523 161 : for (ref = expr->ref; ref; ref = ref->next)
6524 161 : if (ref->type == REF_COMPONENT
6525 161 : && gfc_deferred_strlen (ref->u.c.component, &tmp))
6526 : break;
6527 161 : gcc_assert (tmp != NULL_TREE);
6528 161 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
6529 161 : TREE_OPERAND (descriptor, 0), tmp, NULL_TREE);
6530 161 : tmp = fold_convert (gfc_charlen_type_node, tmp);
6531 161 : type = gfc_get_character_type_len (expr->ts.kind, tmp);
6532 161 : tmp = gfc_conv_descriptor_dtype (descriptor);
6533 161 : gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type));
6534 161 : }
6535 11637 : else if (expr3_desc && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr3_desc)))
6536 : {
6537 934 : tmp = gfc_conv_descriptor_dtype (descriptor);
6538 934 : gfc_add_modify (pblock, tmp, gfc_conv_descriptor_dtype (expr3_desc));
6539 : }
6540 10703 : else if (expr->ts.type == BT_CLASS && !explicit_ts
6541 1294 : && expr3 && expr3->ts.type != BT_CLASS
6542 343 : && expr3_elem_size != NULL_TREE && expr3_desc == NULL_TREE)
6543 : {
6544 343 : tmp = gfc_conv_descriptor_elem_len (descriptor);
6545 343 : gfc_add_modify (pblock, tmp,
6546 343 : fold_convert (TREE_TYPE (tmp), expr3_elem_size));
6547 : }
6548 : else
6549 : {
6550 10360 : tmp = gfc_conv_descriptor_dtype (descriptor);
6551 10360 : gfc_add_modify (pblock, tmp, gfc_get_dtype (type));
6552 : }
6553 :
6554 12164 : or_expr = logical_false_node;
6555 :
6556 29970 : for (n = 0; n < rank; n++)
6557 : {
6558 17806 : tree conv_lbound;
6559 17806 : tree conv_ubound;
6560 :
6561 : /* We have 3 possibilities for determining the size of the array:
6562 : lower == NULL => lbound = 1, ubound = upper[n]
6563 : upper[n] = NULL => lbound = 1, ubound = lower[n]
6564 : upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
6565 17806 : ubound = upper[n];
6566 :
6567 : /* Set lower bound. */
6568 17806 : gfc_init_se (&se, NULL);
6569 17806 : if (expr3_desc != NULL_TREE)
6570 : {
6571 1477 : if (e3_has_nodescriptor)
6572 : /* The lbound of nondescriptor arrays like array constructors,
6573 : nonallocatable/nonpointer function results/variables,
6574 : start at zero, but when allocating it, the standard expects
6575 : the array to start at one. */
6576 967 : se.expr = gfc_index_one_node;
6577 : else
6578 510 : se.expr = gfc_conv_descriptor_lbound_get (expr3_desc,
6579 : gfc_rank_cst[n]);
6580 : }
6581 16329 : else if (lower == NULL)
6582 13146 : se.expr = gfc_index_one_node;
6583 : else
6584 : {
6585 3183 : gcc_assert (lower[n]);
6586 3183 : if (ubound)
6587 : {
6588 2457 : gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
6589 2457 : gfc_add_block_to_block (pblock, &se.pre);
6590 : }
6591 : else
6592 : {
6593 726 : se.expr = gfc_index_one_node;
6594 726 : ubound = lower[n];
6595 : }
6596 : }
6597 17806 : gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
6598 : gfc_rank_cst[n], se.expr);
6599 17806 : conv_lbound = se.expr;
6600 :
6601 : /* Work out the offset for this component. */
6602 17806 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6603 : se.expr, stride);
6604 17806 : offset = fold_build2_loc (input_location, MINUS_EXPR,
6605 : gfc_array_index_type, offset, tmp);
6606 :
6607 : /* Set upper bound. */
6608 17806 : gfc_init_se (&se, NULL);
6609 17806 : if (expr3_desc != NULL_TREE)
6610 : {
6611 1477 : if (e3_has_nodescriptor)
6612 : {
6613 : /* The lbound of nondescriptor arrays like array constructors,
6614 : nonallocatable/nonpointer function results/variables,
6615 : start at zero, but when allocating it, the standard expects
6616 : the array to start at one. Therefore fix the upper bound to be
6617 : (desc.ubound - desc.lbound) + 1. */
6618 967 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
6619 : gfc_array_index_type,
6620 : gfc_conv_descriptor_ubound_get (
6621 : expr3_desc, gfc_rank_cst[n]),
6622 : gfc_conv_descriptor_lbound_get (
6623 : expr3_desc, gfc_rank_cst[n]));
6624 967 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
6625 : gfc_array_index_type, tmp,
6626 : gfc_index_one_node);
6627 967 : se.expr = gfc_evaluate_now (tmp, pblock);
6628 : }
6629 : else
6630 510 : se.expr = gfc_conv_descriptor_ubound_get (expr3_desc,
6631 : gfc_rank_cst[n]);
6632 : }
6633 : else
6634 : {
6635 16329 : gcc_assert (ubound);
6636 16329 : gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
6637 16329 : gfc_add_block_to_block (pblock, &se.pre);
6638 16329 : if (ubound->expr_type == EXPR_FUNCTION)
6639 779 : se.expr = gfc_evaluate_now (se.expr, pblock);
6640 : }
6641 17806 : gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
6642 : gfc_rank_cst[n], se.expr);
6643 17806 : conv_ubound = se.expr;
6644 :
6645 : /* Store the stride. */
6646 17806 : gfc_conv_descriptor_stride_set (descriptor_block, descriptor,
6647 : gfc_rank_cst[n], stride);
6648 :
6649 : /* Calculate size and check whether extent is negative. */
6650 17806 : size = gfc_conv_array_extent_dim (conv_lbound, conv_ubound, &or_expr);
6651 17806 : size = gfc_evaluate_now (size, pblock);
6652 :
6653 : /* Check whether multiplying the stride by the number of
6654 : elements in this dimension would overflow. We must also check
6655 : whether the current dimension has zero size in order to avoid
6656 : division by zero.
6657 : */
6658 17806 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
6659 : gfc_array_index_type,
6660 17806 : fold_convert (gfc_array_index_type,
6661 : TYPE_MAX_VALUE (gfc_array_index_type)),
6662 : size);
6663 17806 : cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
6664 : logical_type_node, tmp, stride),
6665 : PRED_FORTRAN_OVERFLOW);
6666 17806 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
6667 : integer_one_node, integer_zero_node);
6668 17806 : cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
6669 : logical_type_node, size,
6670 : gfc_index_zero_node),
6671 : PRED_FORTRAN_SIZE_ZERO);
6672 17806 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
6673 : integer_zero_node, tmp);
6674 17806 : tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
6675 : *overflow, tmp);
6676 17806 : *overflow = gfc_evaluate_now (tmp, pblock);
6677 :
6678 : /* Multiply the stride by the number of elements in this dimension. */
6679 17806 : stride = fold_build2_loc (input_location, MULT_EXPR,
6680 : gfc_array_index_type, stride, size);
6681 17806 : stride = gfc_evaluate_now (stride, pblock);
6682 : }
6683 :
6684 12805 : for (n = rank; n < rank + corank; n++)
6685 : {
6686 641 : ubound = upper[n];
6687 :
6688 : /* Set lower bound. */
6689 641 : gfc_init_se (&se, NULL);
6690 641 : if (lower == NULL || lower[n] == NULL)
6691 : {
6692 372 : gcc_assert (n == rank + corank - 1);
6693 372 : se.expr = gfc_index_one_node;
6694 : }
6695 : else
6696 : {
6697 269 : if (ubound || n == rank + corank - 1)
6698 : {
6699 175 : gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
6700 175 : gfc_add_block_to_block (pblock, &se.pre);
6701 : }
6702 : else
6703 : {
6704 94 : se.expr = gfc_index_one_node;
6705 94 : ubound = lower[n];
6706 : }
6707 : }
6708 641 : gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
6709 : gfc_rank_cst[n], se.expr);
6710 :
6711 641 : if (n < rank + corank - 1)
6712 : {
6713 178 : gfc_init_se (&se, NULL);
6714 178 : gcc_assert (ubound);
6715 178 : gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
6716 178 : gfc_add_block_to_block (pblock, &se.pre);
6717 178 : gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
6718 : gfc_rank_cst[n], se.expr);
6719 : }
6720 : }
6721 :
6722 : /* The stride is the number of elements in the array, so multiply by the
6723 : size of an element to get the total size. Obviously, if there is a
6724 : SOURCE expression (expr3) we must use its element size. */
6725 12164 : if (expr3_elem_size != NULL_TREE)
6726 3025 : tmp = expr3_elem_size;
6727 9139 : else if (expr3 != NULL)
6728 : {
6729 0 : if (expr3->ts.type == BT_CLASS)
6730 : {
6731 0 : gfc_se se_sz;
6732 0 : gfc_expr *sz = gfc_copy_expr (expr3);
6733 0 : gfc_add_vptr_component (sz);
6734 0 : gfc_add_size_component (sz);
6735 0 : gfc_init_se (&se_sz, NULL);
6736 0 : gfc_conv_expr (&se_sz, sz);
6737 0 : gfc_free_expr (sz);
6738 0 : tmp = se_sz.expr;
6739 : }
6740 : else
6741 : {
6742 0 : tmp = gfc_typenode_for_spec (&expr3->ts);
6743 0 : tmp = TYPE_SIZE_UNIT (tmp);
6744 : }
6745 : }
6746 : else
6747 9139 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
6748 :
6749 : /* Convert to size_t. */
6750 12164 : *element_size = fold_convert (size_type_node, tmp);
6751 :
6752 12164 : if (rank == 0)
6753 : return *element_size;
6754 :
6755 11961 : stride = fold_convert (size_type_node, stride);
6756 :
6757 : /* First check for overflow. Since an array of type character can
6758 : have zero element_size, we must check for that before
6759 : dividing. */
6760 11961 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
6761 : size_type_node,
6762 11961 : TYPE_MAX_VALUE (size_type_node), *element_size);
6763 11961 : cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
6764 : logical_type_node, tmp, stride),
6765 : PRED_FORTRAN_OVERFLOW);
6766 11961 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
6767 : integer_one_node, integer_zero_node);
6768 11961 : cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
6769 : logical_type_node, *element_size,
6770 : build_int_cst (size_type_node, 0)),
6771 : PRED_FORTRAN_SIZE_ZERO);
6772 11961 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
6773 : integer_zero_node, tmp);
6774 11961 : tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
6775 : *overflow, tmp);
6776 11961 : *overflow = gfc_evaluate_now (tmp, pblock);
6777 :
6778 11961 : size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
6779 : stride, *element_size);
6780 :
6781 11961 : if (poffset != NULL)
6782 : {
6783 11961 : offset = gfc_evaluate_now (offset, pblock);
6784 11961 : *poffset = offset;
6785 : }
6786 :
6787 11961 : if (integer_zerop (or_expr))
6788 : return size;
6789 3635 : if (integer_onep (or_expr))
6790 599 : return build_int_cst (size_type_node, 0);
6791 :
6792 3036 : var = gfc_create_var (TREE_TYPE (size), "size");
6793 3036 : gfc_start_block (&thenblock);
6794 3036 : gfc_add_modify (&thenblock, var, build_int_cst (size_type_node, 0));
6795 3036 : thencase = gfc_finish_block (&thenblock);
6796 :
6797 3036 : gfc_start_block (&elseblock);
6798 3036 : gfc_add_modify (&elseblock, var, size);
6799 3036 : elsecase = gfc_finish_block (&elseblock);
6800 :
6801 3036 : tmp = gfc_evaluate_now (or_expr, pblock);
6802 3036 : tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
6803 3036 : gfc_add_expr_to_block (pblock, tmp);
6804 :
6805 3036 : return var;
6806 : }
6807 :
6808 :
6809 : /* Retrieve the last ref from the chain. This routine is specific to
6810 : gfc_array_allocate ()'s needs. */
6811 :
6812 : bool
6813 18544 : retrieve_last_ref (gfc_ref **ref_in, gfc_ref **prev_ref_in)
6814 : {
6815 18544 : gfc_ref *ref, *prev_ref;
6816 :
6817 18544 : ref = *ref_in;
6818 : /* Prevent warnings for uninitialized variables. */
6819 18544 : prev_ref = *prev_ref_in;
6820 25714 : while (ref && ref->next != NULL)
6821 : {
6822 7170 : gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
6823 : || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
6824 : prev_ref = ref;
6825 : ref = ref->next;
6826 : }
6827 :
6828 18544 : if (ref == NULL || ref->type != REF_ARRAY)
6829 : return false;
6830 :
6831 13383 : *ref_in = ref;
6832 13383 : *prev_ref_in = prev_ref;
6833 13383 : return true;
6834 : }
6835 :
6836 : /* Initializes the descriptor and generates a call to _gfor_allocate. Does
6837 : the work for an ALLOCATE statement. */
6838 : /*GCC ARRAYS*/
6839 :
6840 : bool
6841 17325 : gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
6842 : tree errlen, tree label_finish, tree expr3_elem_size,
6843 : gfc_expr *expr3, tree e3_arr_desc, bool e3_has_nodescriptor,
6844 : gfc_omp_namelist *omp_alloc, bool explicit_ts)
6845 : {
6846 17325 : tree tmp;
6847 17325 : tree pointer;
6848 17325 : tree offset = NULL_TREE;
6849 17325 : tree token = NULL_TREE;
6850 17325 : tree size;
6851 17325 : tree msg;
6852 17325 : tree error = NULL_TREE;
6853 17325 : tree overflow; /* Boolean storing whether size calculation overflows. */
6854 17325 : tree var_overflow = NULL_TREE;
6855 17325 : tree cond;
6856 17325 : tree set_descriptor;
6857 17325 : tree not_prev_allocated = NULL_TREE;
6858 17325 : tree element_size = NULL_TREE;
6859 17325 : stmtblock_t set_descriptor_block;
6860 17325 : stmtblock_t elseblock;
6861 17325 : gfc_expr **lower;
6862 17325 : gfc_expr **upper;
6863 17325 : gfc_ref *ref, *prev_ref = NULL, *coref;
6864 17325 : bool allocatable, coarray, dimension, alloc_w_e3_arr_spec = false,
6865 : non_ulimate_coarray_ptr_comp;
6866 17325 : tree omp_cond = NULL_TREE, omp_alt_alloc = NULL_TREE;
6867 :
6868 17325 : ref = expr->ref;
6869 :
6870 : /* Find the last reference in the chain. */
6871 17325 : if (!retrieve_last_ref (&ref, &prev_ref))
6872 : return false;
6873 :
6874 : /* Take the allocatable and coarray properties solely from the expr-ref's
6875 : attributes and not from source=-expression. */
6876 12164 : if (!prev_ref)
6877 : {
6878 8306 : allocatable = expr->symtree->n.sym->attr.allocatable;
6879 8306 : dimension = expr->symtree->n.sym->attr.dimension;
6880 8306 : non_ulimate_coarray_ptr_comp = false;
6881 : }
6882 : else
6883 : {
6884 3858 : allocatable = prev_ref->u.c.component->attr.allocatable;
6885 : /* Pointer components in coarrayed derived types must be treated
6886 : specially in that they are registered without a check if the are
6887 : already associated. This does not hold for ultimate coarray
6888 : pointers. */
6889 7716 : non_ulimate_coarray_ptr_comp = (prev_ref->u.c.component->attr.pointer
6890 3858 : && !prev_ref->u.c.component->attr.codimension);
6891 3858 : dimension = prev_ref->u.c.component->attr.dimension;
6892 : }
6893 :
6894 : /* For allocatable/pointer arrays in derived types, one of the refs has to be
6895 : a coarray. In this case it does not matter whether we are on this_image
6896 : or not. */
6897 12164 : coarray = false;
6898 29153 : for (coref = expr->ref; coref; coref = coref->next)
6899 17627 : if (coref->type == REF_ARRAY && coref->u.ar.codimen > 0)
6900 : {
6901 : coarray = true;
6902 : break;
6903 : }
6904 :
6905 12164 : if (!dimension)
6906 203 : gcc_assert (coarray);
6907 :
6908 12164 : if (ref->u.ar.type == AR_FULL && expr3 != NULL)
6909 : {
6910 1219 : gfc_ref *old_ref = ref;
6911 : /* F08:C633: Array shape from expr3. */
6912 1219 : ref = expr3->ref;
6913 :
6914 : /* Find the last reference in the chain. */
6915 1219 : if (!retrieve_last_ref (&ref, &prev_ref))
6916 : {
6917 0 : if (expr3->expr_type == EXPR_FUNCTION
6918 0 : && gfc_expr_attr (expr3).dimension)
6919 0 : ref = old_ref;
6920 : else
6921 0 : return false;
6922 : }
6923 : alloc_w_e3_arr_spec = true;
6924 : }
6925 :
6926 : /* Figure out the size of the array. */
6927 12164 : switch (ref->u.ar.type)
6928 : {
6929 9269 : case AR_ELEMENT:
6930 9269 : if (!coarray)
6931 : {
6932 8683 : lower = NULL;
6933 8683 : upper = ref->u.ar.start;
6934 8683 : break;
6935 : }
6936 : /* Fall through. */
6937 :
6938 2293 : case AR_SECTION:
6939 2293 : lower = ref->u.ar.start;
6940 2293 : upper = ref->u.ar.end;
6941 2293 : break;
6942 :
6943 1188 : case AR_FULL:
6944 1188 : gcc_assert (ref->u.ar.as->type == AS_EXPLICIT
6945 : || alloc_w_e3_arr_spec);
6946 :
6947 1188 : lower = ref->u.ar.as->lower;
6948 1188 : upper = ref->u.ar.as->upper;
6949 1188 : break;
6950 :
6951 0 : default:
6952 0 : gcc_unreachable ();
6953 12164 : break;
6954 : }
6955 :
6956 12164 : overflow = integer_zero_node;
6957 :
6958 12164 : if (expr->ts.type == BT_CHARACTER
6959 1079 : && TREE_CODE (se->string_length) == COMPONENT_REF
6960 161 : && expr->ts.u.cl->backend_decl != se->string_length
6961 161 : && VAR_P (expr->ts.u.cl->backend_decl))
6962 0 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
6963 0 : fold_convert (TREE_TYPE (expr->ts.u.cl->backend_decl),
6964 : se->string_length));
6965 :
6966 12164 : gfc_init_block (&set_descriptor_block);
6967 : /* Take the corank only from the actual ref and not from the coref. The
6968 : later will mislead the generation of the array dimensions for allocatable/
6969 : pointer components in derived types. */
6970 23747 : size = gfc_array_init_size (se->expr, alloc_w_e3_arr_spec ? expr->rank
6971 10945 : : ref->u.ar.as->rank,
6972 638 : coarray ? ref->u.ar.as->corank : 0,
6973 : &offset, lower, upper,
6974 : &se->pre, &set_descriptor_block, &overflow,
6975 : expr3_elem_size, expr3, e3_arr_desc,
6976 : e3_has_nodescriptor, expr, &element_size,
6977 : explicit_ts);
6978 :
6979 12164 : if (dimension)
6980 : {
6981 11961 : var_overflow = gfc_create_var (integer_type_node, "overflow");
6982 11961 : gfc_add_modify (&se->pre, var_overflow, overflow);
6983 :
6984 11961 : if (status == NULL_TREE)
6985 : {
6986 : /* Generate the block of code handling overflow. */
6987 11739 : msg = gfc_build_addr_expr (pchar_type_node,
6988 : gfc_build_localized_cstring_const
6989 : ("Integer overflow when calculating the amount of "
6990 : "memory to allocate"));
6991 11739 : error = build_call_expr_loc (input_location,
6992 : gfor_fndecl_runtime_error, 1, msg);
6993 : }
6994 : else
6995 : {
6996 222 : tree status_type = TREE_TYPE (status);
6997 222 : stmtblock_t set_status_block;
6998 :
6999 222 : gfc_start_block (&set_status_block);
7000 222 : gfc_add_modify (&set_status_block, status,
7001 : build_int_cst (status_type, LIBERROR_ALLOCATION));
7002 222 : error = gfc_finish_block (&set_status_block);
7003 : }
7004 : }
7005 :
7006 : /* Allocate memory to store the data. */
7007 12164 : if (POINTER_TYPE_P (TREE_TYPE (se->expr)))
7008 0 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
7009 :
7010 12164 : if (coarray && flag_coarray == GFC_FCOARRAY_LIB)
7011 : {
7012 397 : pointer = non_ulimate_coarray_ptr_comp ? se->expr
7013 325 : : gfc_conv_descriptor_data_get (se->expr);
7014 397 : token = gfc_conv_descriptor_token (se->expr);
7015 397 : token = gfc_build_addr_expr (NULL_TREE, token);
7016 : }
7017 : else
7018 : {
7019 11767 : pointer = gfc_conv_descriptor_data_get (se->expr);
7020 11767 : if (omp_alloc)
7021 33 : omp_cond = boolean_true_node;
7022 : }
7023 12164 : STRIP_NOPS (pointer);
7024 :
7025 12164 : if (allocatable)
7026 : {
7027 9968 : not_prev_allocated = gfc_create_var (logical_type_node,
7028 : "not_prev_allocated");
7029 9968 : tmp = fold_build2_loc (input_location, EQ_EXPR,
7030 : logical_type_node, pointer,
7031 9968 : build_int_cst (TREE_TYPE (pointer), 0));
7032 :
7033 9968 : gfc_add_modify (&se->pre, not_prev_allocated, tmp);
7034 : }
7035 :
7036 12164 : gfc_start_block (&elseblock);
7037 :
7038 12164 : tree succ_add_expr = NULL_TREE;
7039 12164 : if (omp_cond)
7040 : {
7041 33 : tree align, alloc, sz;
7042 33 : gfc_se se2;
7043 33 : if (omp_alloc->u2.allocator)
7044 : {
7045 10 : gfc_init_se (&se2, NULL);
7046 10 : gfc_conv_expr (&se2, omp_alloc->u2.allocator);
7047 10 : gfc_add_block_to_block (&elseblock, &se2.pre);
7048 10 : alloc = gfc_evaluate_now (se2.expr, &elseblock);
7049 10 : gfc_add_block_to_block (&elseblock, &se2.post);
7050 : }
7051 : else
7052 23 : alloc = build_zero_cst (ptr_type_node);
7053 33 : tmp = TREE_TYPE (TREE_TYPE (pointer));
7054 33 : if (tmp == void_type_node)
7055 33 : tmp = gfc_typenode_for_spec (&expr->ts, 0);
7056 33 : if (omp_alloc->u.align)
7057 : {
7058 17 : gfc_init_se (&se2, NULL);
7059 17 : gfc_conv_expr (&se2, omp_alloc->u.align);
7060 17 : gcc_assert (CONSTANT_CLASS_P (se2.expr)
7061 : && se2.pre.head == NULL
7062 : && se2.post.head == NULL);
7063 17 : align = build_int_cst (size_type_node,
7064 17 : MAX (tree_to_uhwi (se2.expr),
7065 : TYPE_ALIGN_UNIT (tmp)));
7066 : }
7067 : else
7068 16 : align = build_int_cst (size_type_node, TYPE_ALIGN_UNIT (tmp));
7069 33 : sz = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
7070 : fold_convert (size_type_node, size),
7071 : build_int_cst (size_type_node, 1));
7072 33 : omp_alt_alloc = builtin_decl_explicit (BUILT_IN_GOMP_ALLOC);
7073 33 : DECL_ATTRIBUTES (omp_alt_alloc)
7074 33 : = tree_cons (get_identifier ("omp allocator"),
7075 : build_tree_list (NULL_TREE, alloc),
7076 33 : DECL_ATTRIBUTES (omp_alt_alloc));
7077 33 : omp_alt_alloc = build_call_expr (omp_alt_alloc, 3, align, sz, alloc);
7078 33 : succ_add_expr = fold_build2_loc (input_location, MODIFY_EXPR,
7079 : void_type_node,
7080 : gfc_conv_descriptor_version (se->expr),
7081 : build_int_cst (integer_type_node, 1));
7082 : }
7083 :
7084 : /* The allocatable variant takes the old pointer as first argument. */
7085 12164 : if (allocatable)
7086 10531 : gfc_allocate_allocatable (&elseblock, pointer, size, token,
7087 : status, errmsg, errlen, label_finish, expr,
7088 563 : coref != NULL ? coref->u.ar.as->corank : 0,
7089 : omp_cond, omp_alt_alloc, succ_add_expr);
7090 2196 : else if (non_ulimate_coarray_ptr_comp && token)
7091 : /* The token is set only for GFC_FCOARRAY_LIB mode. */
7092 72 : gfc_allocate_using_caf_lib (&elseblock, pointer, size, token, status,
7093 : errmsg, errlen,
7094 : GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY);
7095 : else
7096 2124 : gfc_allocate_using_malloc (&elseblock, pointer, size, status,
7097 : omp_cond, omp_alt_alloc, succ_add_expr);
7098 :
7099 12164 : if (dimension)
7100 : {
7101 11961 : cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
7102 : logical_type_node, var_overflow, integer_zero_node),
7103 : PRED_FORTRAN_OVERFLOW);
7104 11961 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
7105 : error, gfc_finish_block (&elseblock));
7106 : }
7107 : else
7108 203 : tmp = gfc_finish_block (&elseblock);
7109 :
7110 12164 : gfc_add_expr_to_block (&se->pre, tmp);
7111 :
7112 : /* Update the array descriptor with the offset and the span. */
7113 12164 : if (dimension)
7114 : {
7115 11961 : gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
7116 11961 : tmp = fold_convert (gfc_array_index_type, element_size);
7117 11961 : gfc_conv_descriptor_span_set (&set_descriptor_block, se->expr, tmp);
7118 : }
7119 :
7120 12164 : set_descriptor = gfc_finish_block (&set_descriptor_block);
7121 12164 : if (status != NULL_TREE)
7122 : {
7123 238 : cond = fold_build2_loc (input_location, EQ_EXPR,
7124 : logical_type_node, status,
7125 238 : build_int_cst (TREE_TYPE (status), 0));
7126 :
7127 238 : if (not_prev_allocated != NULL_TREE)
7128 222 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
7129 : logical_type_node, cond, not_prev_allocated);
7130 :
7131 238 : gfc_add_expr_to_block (&se->pre,
7132 : fold_build3_loc (input_location, COND_EXPR, void_type_node,
7133 : cond,
7134 : set_descriptor,
7135 : build_empty_stmt (input_location)));
7136 : }
7137 : else
7138 11926 : gfc_add_expr_to_block (&se->pre, set_descriptor);
7139 :
7140 : return true;
7141 : }
7142 :
7143 :
7144 : /* Create an array constructor from an initialization expression.
7145 : We assume the frontend already did any expansions and conversions. */
7146 :
7147 : tree
7148 7679 : gfc_conv_array_initializer (tree type, gfc_expr * expr)
7149 : {
7150 7679 : gfc_constructor *c;
7151 7679 : tree tmp;
7152 7679 : gfc_se se;
7153 7679 : tree index, range;
7154 7679 : vec<constructor_elt, va_gc> *v = NULL;
7155 :
7156 7679 : if (expr->expr_type == EXPR_VARIABLE
7157 0 : && expr->symtree->n.sym->attr.flavor == FL_PARAMETER
7158 0 : && expr->symtree->n.sym->value)
7159 7679 : expr = expr->symtree->n.sym->value;
7160 :
7161 : /* After parameter substitution the expression should be a constant, array
7162 : constructor, structure constructor, or NULL. Anything else is invalid
7163 : and must not ICE later in lowering. */
7164 7679 : if (expr->expr_type != EXPR_CONSTANT
7165 7295 : && expr->expr_type != EXPR_STRUCTURE
7166 6541 : && expr->expr_type != EXPR_ARRAY
7167 1 : && expr->expr_type != EXPR_NULL)
7168 : {
7169 1 : gfc_error ("Array initializer at %L does not reduce to a constant "
7170 : "expression", &expr->where);
7171 1 : return build_constructor (type, NULL);
7172 : }
7173 :
7174 7678 : switch (expr->expr_type)
7175 : {
7176 1138 : case EXPR_CONSTANT:
7177 1138 : case EXPR_STRUCTURE:
7178 : /* A single scalar or derived type value. Create an array with all
7179 : elements equal to that value. */
7180 1138 : gfc_init_se (&se, NULL);
7181 :
7182 1138 : if (expr->expr_type == EXPR_CONSTANT)
7183 384 : gfc_conv_constant (&se, expr);
7184 : else
7185 754 : gfc_conv_structure (&se, expr, 1);
7186 :
7187 2276 : if (tree_int_cst_lt (TYPE_MAX_VALUE (TYPE_DOMAIN (type)),
7188 1138 : TYPE_MIN_VALUE (TYPE_DOMAIN (type))))
7189 : break;
7190 2252 : else if (tree_int_cst_equal (TYPE_MIN_VALUE (TYPE_DOMAIN (type)),
7191 1126 : TYPE_MAX_VALUE (TYPE_DOMAIN (type))))
7192 167 : range = TYPE_MIN_VALUE (TYPE_DOMAIN (type));
7193 : else
7194 1918 : range = build2 (RANGE_EXPR, gfc_array_index_type,
7195 959 : TYPE_MIN_VALUE (TYPE_DOMAIN (type)),
7196 959 : TYPE_MAX_VALUE (TYPE_DOMAIN (type)));
7197 1126 : CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
7198 1126 : break;
7199 :
7200 6540 : case EXPR_ARRAY:
7201 : /* Create a vector of all the elements. */
7202 6540 : for (c = gfc_constructor_first (expr->value.constructor);
7203 164322 : c && c->expr; c = gfc_constructor_next (c))
7204 : {
7205 157782 : if (c->iterator)
7206 : {
7207 : /* Problems occur when we get something like
7208 : integer :: a(lots) = (/(i, i=1, lots)/) */
7209 0 : gfc_fatal_error ("The number of elements in the array "
7210 : "constructor at %L requires an increase of "
7211 : "the allowed %d upper limit. See "
7212 : "%<-fmax-array-constructor%> option",
7213 : &expr->where, flag_max_array_constructor);
7214 : return NULL_TREE;
7215 : }
7216 157782 : if (mpz_cmp_si (c->offset, 0) != 0)
7217 151502 : index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
7218 : else
7219 : index = NULL_TREE;
7220 :
7221 157782 : if (mpz_cmp_si (c->repeat, 1) > 0)
7222 : {
7223 127 : tree tmp1, tmp2;
7224 127 : mpz_t maxval;
7225 :
7226 127 : mpz_init (maxval);
7227 127 : mpz_add (maxval, c->offset, c->repeat);
7228 127 : mpz_sub_ui (maxval, maxval, 1);
7229 127 : tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
7230 127 : if (mpz_cmp_si (c->offset, 0) != 0)
7231 : {
7232 27 : mpz_add_ui (maxval, c->offset, 1);
7233 27 : tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
7234 : }
7235 : else
7236 100 : tmp1 = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
7237 :
7238 127 : range = fold_build2 (RANGE_EXPR, gfc_array_index_type, tmp1, tmp2);
7239 127 : mpz_clear (maxval);
7240 : }
7241 : else
7242 : range = NULL;
7243 :
7244 157782 : gfc_init_se (&se, NULL);
7245 157782 : switch (c->expr->expr_type)
7246 : {
7247 156320 : case EXPR_CONSTANT:
7248 156320 : gfc_conv_constant (&se, c->expr);
7249 :
7250 : /* See gfortran.dg/charlen_15.f90 for instance. */
7251 156320 : if (TREE_CODE (se.expr) == STRING_CST
7252 5206 : && TREE_CODE (type) == ARRAY_TYPE)
7253 : {
7254 : tree atype = type;
7255 10412 : while (TREE_CODE (TREE_TYPE (atype)) == ARRAY_TYPE)
7256 5206 : atype = TREE_TYPE (atype);
7257 5206 : gcc_checking_assert (TREE_CODE (TREE_TYPE (atype))
7258 : == INTEGER_TYPE);
7259 5206 : gcc_checking_assert (TREE_TYPE (TREE_TYPE (se.expr))
7260 : == TREE_TYPE (atype));
7261 5206 : if (tree_to_uhwi (TYPE_SIZE_UNIT (TREE_TYPE (se.expr)))
7262 5206 : > tree_to_uhwi (TYPE_SIZE_UNIT (atype)))
7263 : {
7264 0 : unsigned HOST_WIDE_INT size
7265 0 : = tree_to_uhwi (TYPE_SIZE_UNIT (atype));
7266 0 : const char *p = TREE_STRING_POINTER (se.expr);
7267 :
7268 0 : se.expr = build_string (size, p);
7269 : }
7270 5206 : TREE_TYPE (se.expr) = atype;
7271 : }
7272 : break;
7273 :
7274 1462 : case EXPR_STRUCTURE:
7275 1462 : gfc_conv_structure (&se, c->expr, 1);
7276 1462 : break;
7277 :
7278 0 : default:
7279 : /* Catch those occasional beasts that do not simplify
7280 : for one reason or another, assuming that if they are
7281 : standard defying the frontend will catch them. */
7282 0 : gfc_conv_expr (&se, c->expr);
7283 0 : break;
7284 : }
7285 :
7286 157782 : if (range == NULL_TREE)
7287 157655 : CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
7288 : else
7289 : {
7290 127 : if (index != NULL_TREE)
7291 27 : CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
7292 157909 : CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
7293 : }
7294 : }
7295 : break;
7296 :
7297 0 : case EXPR_NULL:
7298 0 : return gfc_build_null_descriptor (type);
7299 :
7300 0 : default:
7301 0 : gcc_unreachable ();
7302 : }
7303 :
7304 : /* Create a constructor from the list of elements. */
7305 7678 : tmp = build_constructor (type, v);
7306 7678 : TREE_CONSTANT (tmp) = 1;
7307 7678 : return tmp;
7308 : }
7309 :
7310 :
7311 : /* Generate code to evaluate non-constant coarray cobounds. */
7312 :
7313 : void
7314 20885 : gfc_trans_array_cobounds (tree type, stmtblock_t * pblock,
7315 : const gfc_symbol *sym)
7316 : {
7317 20885 : int dim;
7318 20885 : tree ubound;
7319 20885 : tree lbound;
7320 20885 : gfc_se se;
7321 20885 : gfc_array_spec *as;
7322 :
7323 20885 : as = IS_CLASS_COARRAY_OR_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
7324 :
7325 21862 : for (dim = as->rank; dim < as->rank + as->corank; dim++)
7326 : {
7327 : /* Evaluate non-constant array bound expressions.
7328 : F2008 4.5.6.3 para 6: If a specification expression in a scoping unit
7329 : references a function, the result is finalized before execution of the
7330 : executable constructs in the scoping unit.
7331 : Adding the finalblocks enables this. */
7332 977 : lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
7333 977 : if (as->lower[dim] && !INTEGER_CST_P (lbound))
7334 : {
7335 114 : gfc_init_se (&se, NULL);
7336 114 : gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
7337 114 : gfc_add_block_to_block (pblock, &se.pre);
7338 114 : gfc_add_block_to_block (pblock, &se.finalblock);
7339 114 : gfc_add_modify (pblock, lbound, se.expr);
7340 : }
7341 977 : ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
7342 977 : if (as->upper[dim] && !INTEGER_CST_P (ubound))
7343 : {
7344 60 : gfc_init_se (&se, NULL);
7345 60 : gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
7346 60 : gfc_add_block_to_block (pblock, &se.pre);
7347 60 : gfc_add_block_to_block (pblock, &se.finalblock);
7348 60 : gfc_add_modify (pblock, ubound, se.expr);
7349 : }
7350 : }
7351 20885 : }
7352 :
7353 :
7354 : /* Generate code to evaluate non-constant array bounds. Sets *poffset and
7355 : returns the size (in elements) of the array. */
7356 :
7357 : tree
7358 13618 : gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
7359 : stmtblock_t * pblock)
7360 : {
7361 13618 : gfc_array_spec *as;
7362 13618 : tree size;
7363 13618 : tree stride;
7364 13618 : tree offset;
7365 13618 : tree ubound;
7366 13618 : tree lbound;
7367 13618 : tree tmp;
7368 13618 : gfc_se se;
7369 :
7370 13618 : int dim;
7371 :
7372 13618 : as = IS_CLASS_COARRAY_OR_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
7373 :
7374 13618 : size = gfc_index_one_node;
7375 13618 : offset = gfc_index_zero_node;
7376 13618 : stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
7377 13618 : if (stride && VAR_P (stride))
7378 124 : gfc_add_modify (pblock, stride, gfc_index_one_node);
7379 30487 : for (dim = 0; dim < as->rank; dim++)
7380 : {
7381 : /* Evaluate non-constant array bound expressions.
7382 : F2008 4.5.6.3 para 6: If a specification expression in a scoping unit
7383 : references a function, the result is finalized before execution of the
7384 : executable constructs in the scoping unit.
7385 : Adding the finalblocks enables this. */
7386 16869 : lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
7387 16869 : if (as->lower[dim] && !INTEGER_CST_P (lbound))
7388 : {
7389 475 : gfc_init_se (&se, NULL);
7390 475 : gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
7391 475 : gfc_add_block_to_block (pblock, &se.pre);
7392 475 : gfc_add_block_to_block (pblock, &se.finalblock);
7393 475 : gfc_add_modify (pblock, lbound, se.expr);
7394 : }
7395 16869 : ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
7396 16869 : if (as->upper[dim] && !INTEGER_CST_P (ubound))
7397 : {
7398 10326 : gfc_init_se (&se, NULL);
7399 10326 : gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
7400 10326 : gfc_add_block_to_block (pblock, &se.pre);
7401 10326 : gfc_add_block_to_block (pblock, &se.finalblock);
7402 10326 : gfc_add_modify (pblock, ubound, se.expr);
7403 : }
7404 : /* The offset of this dimension. offset = offset - lbound * stride. */
7405 16869 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7406 : lbound, size);
7407 16869 : offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7408 : offset, tmp);
7409 :
7410 : /* The size of this dimension, and the stride of the next. */
7411 16869 : if (dim + 1 < as->rank)
7412 3450 : stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
7413 : else
7414 13419 : stride = GFC_TYPE_ARRAY_SIZE (type);
7415 :
7416 16869 : if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
7417 : {
7418 : /* Calculate stride = size * (ubound + 1 - lbound). */
7419 10516 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
7420 : gfc_array_index_type,
7421 : gfc_index_one_node, lbound);
7422 10516 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
7423 : gfc_array_index_type, ubound, tmp);
7424 10516 : tmp = fold_build2_loc (input_location, MULT_EXPR,
7425 : gfc_array_index_type, size, tmp);
7426 10516 : if (stride)
7427 10516 : gfc_add_modify (pblock, stride, tmp);
7428 : else
7429 0 : stride = gfc_evaluate_now (tmp, pblock);
7430 :
7431 : /* Make sure that negative size arrays are translated
7432 : to being zero size. */
7433 10516 : tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
7434 : stride, gfc_index_zero_node);
7435 10516 : tmp = fold_build3_loc (input_location, COND_EXPR,
7436 : gfc_array_index_type, tmp,
7437 : stride, gfc_index_zero_node);
7438 10516 : gfc_add_modify (pblock, stride, tmp);
7439 : }
7440 :
7441 : size = stride;
7442 : }
7443 :
7444 13618 : gfc_trans_array_cobounds (type, pblock, sym);
7445 13618 : gfc_trans_vla_type_sizes (sym, pblock);
7446 :
7447 13618 : *poffset = offset;
7448 13618 : return size;
7449 : }
7450 :
7451 :
7452 : /* Generate code to initialize/allocate an array variable. */
7453 :
7454 : void
7455 31578 : gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
7456 : gfc_wrapped_block * block)
7457 : {
7458 31578 : stmtblock_t init;
7459 31578 : tree type;
7460 31578 : tree tmp = NULL_TREE;
7461 31578 : tree size;
7462 31578 : tree offset;
7463 31578 : tree space;
7464 31578 : tree inittree;
7465 31578 : bool onstack;
7466 31578 : bool back;
7467 :
7468 31578 : gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
7469 :
7470 : /* Do nothing for USEd variables. */
7471 31578 : if (sym->attr.use_assoc)
7472 25742 : return;
7473 :
7474 31535 : type = TREE_TYPE (decl);
7475 31535 : gcc_assert (GFC_ARRAY_TYPE_P (type));
7476 31535 : onstack = TREE_CODE (type) != POINTER_TYPE;
7477 :
7478 : /* In the case of non-dummy symbols with dependencies on an old-fashioned
7479 : function result (ie. proc_name = proc_name->result), gfc_add_init_cleanup
7480 : must be called with the last, optional argument false so that the alloc-
7481 : ation occurs after the processing of the result. */
7482 31535 : back = sym->fn_result_dep;
7483 :
7484 31535 : gfc_init_block (&init);
7485 :
7486 : /* Evaluate character string length. */
7487 31535 : if (sym->ts.type == BT_CHARACTER
7488 3056 : && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
7489 : {
7490 43 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7491 :
7492 43 : gfc_trans_vla_type_sizes (sym, &init);
7493 :
7494 : /* Emit a DECL_EXPR for this variable, which will cause the
7495 : gimplifier to allocate storage, and all that good stuff. */
7496 43 : tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
7497 43 : gfc_add_expr_to_block (&init, tmp);
7498 43 : if (sym->attr.omp_allocate)
7499 : {
7500 : /* Save location of size calculation to ensure GOMP_alloc is placed
7501 : after it. */
7502 0 : tree omp_alloc = lookup_attribute ("omp allocate",
7503 0 : DECL_ATTRIBUTES (decl));
7504 0 : TREE_CHAIN (TREE_CHAIN (TREE_VALUE (omp_alloc)))
7505 0 : = build_tree_list (NULL_TREE, tsi_stmt (tsi_last (init.head)));
7506 : }
7507 : }
7508 :
7509 31333 : if (onstack)
7510 : {
7511 25559 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE,
7512 : back);
7513 25559 : return;
7514 : }
7515 :
7516 5976 : type = TREE_TYPE (type);
7517 :
7518 5976 : gcc_assert (!sym->attr.use_assoc);
7519 5976 : gcc_assert (!sym->module);
7520 :
7521 5976 : if (sym->ts.type == BT_CHARACTER
7522 202 : && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
7523 94 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7524 :
7525 5976 : size = gfc_trans_array_bounds (type, sym, &offset, &init);
7526 :
7527 : /* Don't actually allocate space for Cray Pointees. */
7528 5976 : if (sym->attr.cray_pointee)
7529 : {
7530 140 : if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
7531 49 : gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
7532 :
7533 140 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
7534 140 : return;
7535 : }
7536 5836 : if (sym->attr.omp_allocate)
7537 : {
7538 : /* The size is the number of elements in the array, so multiply by the
7539 : size of an element to get the total size. */
7540 7 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
7541 7 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7542 : size, fold_convert (gfc_array_index_type, tmp));
7543 7 : size = gfc_evaluate_now (size, &init);
7544 :
7545 7 : tree omp_alloc = lookup_attribute ("omp allocate",
7546 7 : DECL_ATTRIBUTES (decl));
7547 7 : TREE_CHAIN (TREE_CHAIN (TREE_VALUE (omp_alloc)))
7548 7 : = build_tree_list (size, NULL_TREE);
7549 7 : space = NULL_TREE;
7550 : }
7551 5829 : else if (flag_stack_arrays)
7552 : {
7553 14 : gcc_assert (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE);
7554 14 : space = build_decl (gfc_get_location (&sym->declared_at),
7555 : VAR_DECL, create_tmp_var_name ("A"),
7556 14 : TREE_TYPE (TREE_TYPE (decl)));
7557 14 : gfc_trans_vla_type_sizes (sym, &init);
7558 : }
7559 : else
7560 : {
7561 : /* The size is the number of elements in the array, so multiply by the
7562 : size of an element to get the total size. */
7563 5815 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
7564 5815 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7565 : size, fold_convert (gfc_array_index_type, tmp));
7566 :
7567 : /* Allocate memory to hold the data. */
7568 5815 : tmp = gfc_call_malloc (&init, TREE_TYPE (decl), size);
7569 5815 : gfc_add_modify (&init, decl, tmp);
7570 :
7571 : /* Free the temporary. */
7572 5815 : tmp = gfc_call_free (decl);
7573 5815 : space = NULL_TREE;
7574 : }
7575 :
7576 : /* Set offset of the array. */
7577 5836 : if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
7578 378 : gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
7579 :
7580 : /* Automatic arrays should not have initializers. */
7581 5836 : gcc_assert (!sym->value);
7582 :
7583 5836 : inittree = gfc_finish_block (&init);
7584 :
7585 5836 : if (space)
7586 : {
7587 14 : tree addr;
7588 14 : pushdecl (space);
7589 :
7590 : /* Don't create new scope, emit the DECL_EXPR in exactly the scope
7591 : where also space is located. */
7592 14 : gfc_init_block (&init);
7593 14 : tmp = fold_build1_loc (input_location, DECL_EXPR,
7594 14 : TREE_TYPE (space), space);
7595 14 : gfc_add_expr_to_block (&init, tmp);
7596 14 : addr = fold_build1_loc (gfc_get_location (&sym->declared_at),
7597 14 : ADDR_EXPR, TREE_TYPE (decl), space);
7598 14 : gfc_add_modify (&init, decl, addr);
7599 14 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE,
7600 : back);
7601 14 : tmp = NULL_TREE;
7602 : }
7603 5836 : gfc_add_init_cleanup (block, inittree, tmp, back);
7604 : }
7605 :
7606 :
7607 : /* Generate entry and exit code for g77 calling convention arrays. */
7608 :
7609 : void
7610 7388 : gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block)
7611 : {
7612 7388 : tree parm;
7613 7388 : tree type;
7614 7388 : tree offset;
7615 7388 : tree tmp;
7616 7388 : tree stmt;
7617 7388 : stmtblock_t init;
7618 :
7619 7388 : location_t loc = input_location;
7620 7388 : input_location = gfc_get_location (&sym->declared_at);
7621 :
7622 : /* Descriptor type. */
7623 7388 : parm = sym->backend_decl;
7624 7388 : type = TREE_TYPE (parm);
7625 7388 : gcc_assert (GFC_ARRAY_TYPE_P (type));
7626 :
7627 7388 : gfc_start_block (&init);
7628 :
7629 7388 : if (sym->ts.type == BT_CHARACTER
7630 722 : && VAR_P (sym->ts.u.cl->backend_decl))
7631 79 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7632 :
7633 : /* Evaluate the bounds of the array. */
7634 7388 : gfc_trans_array_bounds (type, sym, &offset, &init);
7635 :
7636 : /* Set the offset. */
7637 7388 : if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
7638 1214 : gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
7639 :
7640 : /* Set the pointer itself if we aren't using the parameter directly. */
7641 7388 : if (TREE_CODE (parm) != PARM_DECL)
7642 : {
7643 612 : tmp = GFC_DECL_SAVED_DESCRIPTOR (parm);
7644 612 : if (sym->ts.type == BT_CLASS)
7645 : {
7646 243 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
7647 243 : tmp = gfc_class_data_get (tmp);
7648 243 : tmp = gfc_conv_descriptor_data_get (tmp);
7649 : }
7650 612 : tmp = convert (TREE_TYPE (parm), tmp);
7651 612 : gfc_add_modify (&init, parm, tmp);
7652 : }
7653 7388 : stmt = gfc_finish_block (&init);
7654 :
7655 7388 : input_location = loc;
7656 :
7657 : /* Add the initialization code to the start of the function. */
7658 :
7659 7388 : if ((sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.optional)
7660 7388 : || sym->attr.optional
7661 6906 : || sym->attr.not_always_present)
7662 : {
7663 542 : tree nullify;
7664 542 : if (TREE_CODE (parm) != PARM_DECL)
7665 105 : nullify = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
7666 : parm, null_pointer_node);
7667 : else
7668 437 : nullify = build_empty_stmt (input_location);
7669 542 : tmp = gfc_conv_expr_present (sym, true);
7670 542 : stmt = build3_v (COND_EXPR, tmp, stmt, nullify);
7671 : }
7672 :
7673 7388 : gfc_add_init_cleanup (block, stmt, NULL_TREE);
7674 7388 : }
7675 :
7676 :
7677 : /* Modify the descriptor of an array parameter so that it has the
7678 : correct lower bound. Also move the upper bound accordingly.
7679 : If the array is not packed, it will be copied into a temporary.
7680 : For each dimension we set the new lower and upper bounds. Then we copy the
7681 : stride and calculate the offset for this dimension. We also work out
7682 : what the stride of a packed array would be, and see it the two match.
7683 : If the array need repacking, we set the stride to the values we just
7684 : calculated, recalculate the offset and copy the array data.
7685 : Code is also added to copy the data back at the end of the function.
7686 : */
7687 :
7688 : void
7689 12922 : gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
7690 : gfc_wrapped_block * block)
7691 : {
7692 12922 : tree size;
7693 12922 : tree type;
7694 12922 : tree offset;
7695 12922 : stmtblock_t init;
7696 12922 : tree stmtInit, stmtCleanup;
7697 12922 : tree lbound;
7698 12922 : tree ubound;
7699 12922 : tree dubound;
7700 12922 : tree dlbound;
7701 12922 : tree dumdesc;
7702 12922 : tree tmp;
7703 12922 : tree stride, stride2;
7704 12922 : tree stmt_packed;
7705 12922 : tree stmt_unpacked;
7706 12922 : tree partial;
7707 12922 : gfc_se se;
7708 12922 : int n;
7709 12922 : int checkparm;
7710 12922 : int no_repack;
7711 12922 : bool optional_arg;
7712 12922 : gfc_array_spec *as;
7713 12922 : bool is_classarray = IS_CLASS_COARRAY_OR_ARRAY (sym);
7714 :
7715 : /* Do nothing for pointer and allocatable arrays. */
7716 12922 : if ((sym->ts.type != BT_CLASS && sym->attr.pointer)
7717 12825 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer)
7718 12825 : || sym->attr.allocatable
7719 12719 : || (is_classarray && CLASS_DATA (sym)->attr.allocatable))
7720 6058 : return;
7721 :
7722 820 : if ((!is_classarray
7723 820 : || (is_classarray && CLASS_DATA (sym)->as->type == AS_EXPLICIT))
7724 12083 : && sym->attr.dummy && !sym->attr.elemental && gfc_is_nodesc_array (sym))
7725 : {
7726 5855 : gfc_trans_g77_array (sym, block);
7727 5855 : return;
7728 : }
7729 :
7730 6864 : location_t loc = input_location;
7731 6864 : input_location = gfc_get_location (&sym->declared_at);
7732 :
7733 : /* Descriptor type. */
7734 6864 : type = TREE_TYPE (tmpdesc);
7735 6864 : gcc_assert (GFC_ARRAY_TYPE_P (type));
7736 6864 : dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
7737 6864 : if (is_classarray)
7738 : /* For a class array the dummy array descriptor is in the _class
7739 : component. */
7740 655 : dumdesc = gfc_class_data_get (dumdesc);
7741 : else
7742 6209 : dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc);
7743 6864 : as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
7744 6864 : gfc_start_block (&init);
7745 :
7746 6864 : if (sym->ts.type == BT_CHARACTER
7747 780 : && VAR_P (sym->ts.u.cl->backend_decl))
7748 87 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7749 :
7750 : /* TODO: Fix the exclusion of class arrays from extent checking. */
7751 1084 : checkparm = (as->type == AS_EXPLICIT && !is_classarray
7752 7929 : && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
7753 :
7754 6864 : no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
7755 6863 : || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
7756 :
7757 6864 : if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
7758 : {
7759 : /* For non-constant shape arrays we only check if the first dimension
7760 : is contiguous. Repacking higher dimensions wouldn't gain us
7761 : anything as we still don't know the array stride. */
7762 1 : partial = gfc_create_var (logical_type_node, "partial");
7763 1 : TREE_USED (partial) = 1;
7764 1 : tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
7765 1 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, tmp,
7766 : gfc_index_one_node);
7767 1 : gfc_add_modify (&init, partial, tmp);
7768 : }
7769 : else
7770 : partial = NULL_TREE;
7771 :
7772 : /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
7773 : here, however I think it does the right thing. */
7774 6864 : if (no_repack)
7775 : {
7776 : /* Set the first stride. */
7777 6862 : stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
7778 6862 : stride = gfc_evaluate_now (stride, &init);
7779 :
7780 6862 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7781 : stride, gfc_index_zero_node);
7782 6862 : tmp = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
7783 : tmp, gfc_index_one_node, stride);
7784 6862 : stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
7785 6862 : gfc_add_modify (&init, stride, tmp);
7786 :
7787 : /* Allow the user to disable array repacking. */
7788 6862 : stmt_unpacked = NULL_TREE;
7789 : }
7790 : else
7791 : {
7792 2 : gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
7793 : /* A library call to repack the array if necessary. */
7794 2 : tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
7795 2 : stmt_unpacked = build_call_expr_loc (input_location,
7796 : gfor_fndecl_in_pack, 1, tmp);
7797 :
7798 2 : stride = gfc_index_one_node;
7799 :
7800 2 : if (warn_array_temporaries)
7801 : {
7802 1 : locus where;
7803 1 : gfc_locus_from_location (&where, loc);
7804 1 : gfc_warning (OPT_Warray_temporaries,
7805 : "Creating array temporary at %L", &where);
7806 : }
7807 : }
7808 :
7809 : /* This is for the case where the array data is used directly without
7810 : calling the repack function. */
7811 6864 : if (no_repack || partial != NULL_TREE)
7812 6863 : stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
7813 : else
7814 : stmt_packed = NULL_TREE;
7815 :
7816 : /* Assign the data pointer. */
7817 6864 : if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
7818 : {
7819 : /* Don't repack unknown shape arrays when the first stride is 1. */
7820 1 : tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (stmt_packed),
7821 : partial, stmt_packed, stmt_unpacked);
7822 : }
7823 : else
7824 6863 : tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
7825 6864 : gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp));
7826 :
7827 6864 : offset = gfc_index_zero_node;
7828 6864 : size = gfc_index_one_node;
7829 :
7830 : /* Evaluate the bounds of the array. */
7831 16018 : for (n = 0; n < as->rank; n++)
7832 : {
7833 9154 : if (checkparm || !as->upper[n])
7834 : {
7835 : /* Get the bounds of the actual parameter. */
7836 7835 : dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]);
7837 7835 : dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]);
7838 : }
7839 : else
7840 : {
7841 : dubound = NULL_TREE;
7842 : dlbound = NULL_TREE;
7843 : }
7844 :
7845 9154 : lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
7846 9154 : if (!INTEGER_CST_P (lbound))
7847 : {
7848 46 : gfc_init_se (&se, NULL);
7849 46 : gfc_conv_expr_type (&se, as->lower[n],
7850 : gfc_array_index_type);
7851 46 : gfc_add_block_to_block (&init, &se.pre);
7852 46 : gfc_add_modify (&init, lbound, se.expr);
7853 : }
7854 :
7855 9154 : ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
7856 : /* Set the desired upper bound. */
7857 9154 : if (as->upper[n])
7858 : {
7859 : /* We know what we want the upper bound to be. */
7860 1377 : if (!INTEGER_CST_P (ubound))
7861 : {
7862 639 : gfc_init_se (&se, NULL);
7863 639 : gfc_conv_expr_type (&se, as->upper[n],
7864 : gfc_array_index_type);
7865 639 : gfc_add_block_to_block (&init, &se.pre);
7866 639 : gfc_add_modify (&init, ubound, se.expr);
7867 : }
7868 :
7869 : /* Check the sizes match. */
7870 1377 : if (checkparm)
7871 : {
7872 : /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
7873 58 : char * msg;
7874 58 : tree temp;
7875 58 : locus where;
7876 :
7877 58 : gfc_locus_from_location (&where, loc);
7878 58 : temp = fold_build2_loc (input_location, MINUS_EXPR,
7879 : gfc_array_index_type, ubound, lbound);
7880 58 : temp = fold_build2_loc (input_location, PLUS_EXPR,
7881 : gfc_array_index_type,
7882 : gfc_index_one_node, temp);
7883 58 : stride2 = fold_build2_loc (input_location, MINUS_EXPR,
7884 : gfc_array_index_type, dubound,
7885 : dlbound);
7886 58 : stride2 = fold_build2_loc (input_location, PLUS_EXPR,
7887 : gfc_array_index_type,
7888 : gfc_index_one_node, stride2);
7889 58 : tmp = fold_build2_loc (input_location, NE_EXPR,
7890 : gfc_array_index_type, temp, stride2);
7891 58 : msg = xasprintf ("Dimension %d of array '%s' has extent "
7892 : "%%ld instead of %%ld", n+1, sym->name);
7893 :
7894 58 : gfc_trans_runtime_check (true, false, tmp, &init, &where, msg,
7895 : fold_convert (long_integer_type_node, temp),
7896 : fold_convert (long_integer_type_node, stride2));
7897 :
7898 58 : free (msg);
7899 : }
7900 : }
7901 : else
7902 : {
7903 : /* For assumed shape arrays move the upper bound by the same amount
7904 : as the lower bound. */
7905 7777 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
7906 : gfc_array_index_type, dubound, dlbound);
7907 7777 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
7908 : gfc_array_index_type, tmp, lbound);
7909 7777 : gfc_add_modify (&init, ubound, tmp);
7910 : }
7911 : /* The offset of this dimension. offset = offset - lbound * stride. */
7912 9154 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7913 : lbound, stride);
7914 9154 : offset = fold_build2_loc (input_location, MINUS_EXPR,
7915 : gfc_array_index_type, offset, tmp);
7916 :
7917 : /* The size of this dimension, and the stride of the next. */
7918 9154 : if (n + 1 < as->rank)
7919 : {
7920 2290 : stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
7921 :
7922 2290 : if (no_repack || partial != NULL_TREE)
7923 2289 : stmt_unpacked =
7924 2289 : gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]);
7925 :
7926 : /* Figure out the stride if not a known constant. */
7927 2290 : if (!INTEGER_CST_P (stride))
7928 : {
7929 2289 : if (no_repack)
7930 : stmt_packed = NULL_TREE;
7931 : else
7932 : {
7933 : /* Calculate stride = size * (ubound + 1 - lbound). */
7934 0 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
7935 : gfc_array_index_type,
7936 : gfc_index_one_node, lbound);
7937 0 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
7938 : gfc_array_index_type, ubound, tmp);
7939 0 : size = fold_build2_loc (input_location, MULT_EXPR,
7940 : gfc_array_index_type, size, tmp);
7941 0 : stmt_packed = size;
7942 : }
7943 :
7944 : /* Assign the stride. */
7945 2289 : if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
7946 0 : tmp = fold_build3_loc (input_location, COND_EXPR,
7947 : gfc_array_index_type, partial,
7948 : stmt_unpacked, stmt_packed);
7949 : else
7950 2289 : tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
7951 2289 : gfc_add_modify (&init, stride, tmp);
7952 : }
7953 : }
7954 : else
7955 : {
7956 6864 : stride = GFC_TYPE_ARRAY_SIZE (type);
7957 :
7958 6864 : if (stride && !INTEGER_CST_P (stride))
7959 : {
7960 : /* Calculate size = stride * (ubound + 1 - lbound). */
7961 6863 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
7962 : gfc_array_index_type,
7963 : gfc_index_one_node, lbound);
7964 6863 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
7965 : gfc_array_index_type,
7966 : ubound, tmp);
7967 20589 : tmp = fold_build2_loc (input_location, MULT_EXPR,
7968 : gfc_array_index_type,
7969 6863 : GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
7970 6863 : gfc_add_modify (&init, stride, tmp);
7971 : }
7972 : }
7973 : }
7974 :
7975 6864 : gfc_trans_array_cobounds (type, &init, sym);
7976 :
7977 : /* Set the offset. */
7978 6864 : if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
7979 6862 : gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
7980 :
7981 6864 : gfc_trans_vla_type_sizes (sym, &init);
7982 :
7983 6864 : stmtInit = gfc_finish_block (&init);
7984 :
7985 : /* Only do the entry/initialization code if the arg is present. */
7986 6864 : dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
7987 6864 : optional_arg = (sym->attr.optional
7988 6864 : || (sym->ns->proc_name->attr.entry_master
7989 79 : && sym->attr.dummy));
7990 : if (optional_arg)
7991 : {
7992 717 : tree zero_init = fold_convert (TREE_TYPE (tmpdesc), null_pointer_node);
7993 717 : zero_init = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
7994 : tmpdesc, zero_init);
7995 717 : tmp = gfc_conv_expr_present (sym, true);
7996 717 : stmtInit = build3_v (COND_EXPR, tmp, stmtInit, zero_init);
7997 : }
7998 :
7999 : /* Cleanup code. */
8000 6864 : if (no_repack)
8001 : stmtCleanup = NULL_TREE;
8002 : else
8003 : {
8004 2 : stmtblock_t cleanup;
8005 2 : gfc_start_block (&cleanup);
8006 :
8007 2 : if (sym->attr.intent != INTENT_IN)
8008 : {
8009 : /* Copy the data back. */
8010 2 : tmp = build_call_expr_loc (input_location,
8011 : gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
8012 2 : gfc_add_expr_to_block (&cleanup, tmp);
8013 : }
8014 :
8015 : /* Free the temporary. */
8016 2 : tmp = gfc_call_free (tmpdesc);
8017 2 : gfc_add_expr_to_block (&cleanup, tmp);
8018 :
8019 2 : stmtCleanup = gfc_finish_block (&cleanup);
8020 :
8021 : /* Only do the cleanup if the array was repacked. */
8022 2 : if (is_classarray)
8023 : /* For a class array the dummy array descriptor is in the _class
8024 : component. */
8025 1 : tmp = gfc_class_data_get (dumdesc);
8026 : else
8027 1 : tmp = build_fold_indirect_ref_loc (input_location, dumdesc);
8028 2 : tmp = gfc_conv_descriptor_data_get (tmp);
8029 2 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
8030 : tmp, tmpdesc);
8031 2 : stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
8032 : build_empty_stmt (input_location));
8033 :
8034 2 : if (optional_arg)
8035 : {
8036 0 : tmp = gfc_conv_expr_present (sym);
8037 0 : stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
8038 : build_empty_stmt (input_location));
8039 : }
8040 : }
8041 :
8042 : /* We don't need to free any memory allocated by internal_pack as it will
8043 : be freed at the end of the function by pop_context. */
8044 6864 : gfc_add_init_cleanup (block, stmtInit, stmtCleanup);
8045 :
8046 6864 : input_location = loc;
8047 : }
8048 :
8049 :
8050 : /* Calculate the overall offset, including subreferences. */
8051 : void
8052 60221 : gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
8053 : bool subref, gfc_expr *expr)
8054 : {
8055 60221 : tree tmp;
8056 60221 : tree field;
8057 60221 : tree stride;
8058 60221 : tree index;
8059 60221 : gfc_ref *ref;
8060 60221 : gfc_se start;
8061 60221 : int n;
8062 :
8063 : /* If offset is NULL and this is not a subreferenced array, there is
8064 : nothing to do. */
8065 60221 : if (offset == NULL_TREE)
8066 : {
8067 1066 : if (subref)
8068 139 : offset = gfc_index_zero_node;
8069 : else
8070 927 : return;
8071 : }
8072 :
8073 59294 : tmp = build_array_ref (desc, offset, NULL, NULL);
8074 :
8075 : /* Offset the data pointer for pointer assignments from arrays with
8076 : subreferences; e.g. my_integer => my_type(:)%integer_component. */
8077 59294 : if (subref)
8078 : {
8079 : /* Go past the array reference. */
8080 844 : for (ref = expr->ref; ref; ref = ref->next)
8081 844 : if (ref->type == REF_ARRAY &&
8082 757 : ref->u.ar.type != AR_ELEMENT)
8083 : {
8084 733 : ref = ref->next;
8085 733 : break;
8086 : }
8087 :
8088 : /* Calculate the offset for each subsequent subreference. */
8089 1438 : for (; ref; ref = ref->next)
8090 : {
8091 705 : switch (ref->type)
8092 : {
8093 301 : case REF_COMPONENT:
8094 301 : field = ref->u.c.component->backend_decl;
8095 301 : gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
8096 602 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
8097 301 : TREE_TYPE (field),
8098 : tmp, field, NULL_TREE);
8099 301 : break;
8100 :
8101 320 : case REF_SUBSTRING:
8102 320 : gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
8103 320 : gfc_init_se (&start, NULL);
8104 320 : gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
8105 320 : gfc_add_block_to_block (block, &start.pre);
8106 320 : tmp = gfc_build_array_ref (tmp, start.expr, NULL);
8107 320 : break;
8108 :
8109 24 : case REF_ARRAY:
8110 24 : gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
8111 : && ref->u.ar.type == AR_ELEMENT);
8112 :
8113 : /* TODO - Add bounds checking. */
8114 24 : stride = gfc_index_one_node;
8115 24 : index = gfc_index_zero_node;
8116 55 : for (n = 0; n < ref->u.ar.dimen; n++)
8117 : {
8118 31 : tree itmp;
8119 31 : tree jtmp;
8120 :
8121 : /* Update the index. */
8122 31 : gfc_init_se (&start, NULL);
8123 31 : gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
8124 31 : itmp = gfc_evaluate_now (start.expr, block);
8125 31 : gfc_init_se (&start, NULL);
8126 31 : gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
8127 31 : jtmp = gfc_evaluate_now (start.expr, block);
8128 31 : itmp = fold_build2_loc (input_location, MINUS_EXPR,
8129 : gfc_array_index_type, itmp, jtmp);
8130 31 : itmp = fold_build2_loc (input_location, MULT_EXPR,
8131 : gfc_array_index_type, itmp, stride);
8132 31 : index = fold_build2_loc (input_location, PLUS_EXPR,
8133 : gfc_array_index_type, itmp, index);
8134 31 : index = gfc_evaluate_now (index, block);
8135 :
8136 : /* Update the stride. */
8137 31 : gfc_init_se (&start, NULL);
8138 31 : gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
8139 31 : itmp = fold_build2_loc (input_location, MINUS_EXPR,
8140 : gfc_array_index_type, start.expr,
8141 : jtmp);
8142 31 : itmp = fold_build2_loc (input_location, PLUS_EXPR,
8143 : gfc_array_index_type,
8144 : gfc_index_one_node, itmp);
8145 31 : stride = fold_build2_loc (input_location, MULT_EXPR,
8146 : gfc_array_index_type, stride, itmp);
8147 31 : stride = gfc_evaluate_now (stride, block);
8148 : }
8149 :
8150 : /* Apply the index to obtain the array element. */
8151 24 : tmp = gfc_build_array_ref (tmp, index, NULL);
8152 24 : break;
8153 :
8154 60 : case REF_INQUIRY:
8155 60 : switch (ref->u.i)
8156 : {
8157 54 : case INQUIRY_RE:
8158 108 : tmp = fold_build1_loc (input_location, REALPART_EXPR,
8159 54 : TREE_TYPE (TREE_TYPE (tmp)), tmp);
8160 54 : break;
8161 :
8162 6 : case INQUIRY_IM:
8163 12 : tmp = fold_build1_loc (input_location, IMAGPART_EXPR,
8164 6 : TREE_TYPE (TREE_TYPE (tmp)), tmp);
8165 6 : break;
8166 :
8167 : default:
8168 : break;
8169 : }
8170 : break;
8171 :
8172 0 : default:
8173 0 : gcc_unreachable ();
8174 705 : break;
8175 : }
8176 : }
8177 : }
8178 :
8179 : /* Set the target data pointer. */
8180 59294 : offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
8181 :
8182 : /* Check for optional dummy argument being present. Arguments of BIND(C)
8183 : procedures are excepted here since they are handled differently. */
8184 59294 : if (expr->expr_type == EXPR_VARIABLE
8185 52075 : && expr->symtree->n.sym->attr.dummy
8186 6254 : && expr->symtree->n.sym->attr.optional
8187 60286 : && !is_CFI_desc (NULL, expr))
8188 1624 : offset = build3_loc (input_location, COND_EXPR, TREE_TYPE (offset),
8189 812 : gfc_conv_expr_present (expr->symtree->n.sym), offset,
8190 812 : fold_convert (TREE_TYPE (offset), gfc_index_zero_node));
8191 :
8192 59294 : gfc_conv_descriptor_data_set (block, parm, offset);
8193 : }
8194 :
8195 :
8196 : /* gfc_conv_expr_descriptor needs the string length an expression
8197 : so that the size of the temporary can be obtained. This is done
8198 : by adding up the string lengths of all the elements in the
8199 : expression. Function with non-constant expressions have their
8200 : string lengths mapped onto the actual arguments using the
8201 : interface mapping machinery in trans-expr.cc. */
8202 : static void
8203 1566 : get_array_charlen (gfc_expr *expr, gfc_se *se)
8204 : {
8205 1566 : gfc_interface_mapping mapping;
8206 1566 : gfc_formal_arglist *formal;
8207 1566 : gfc_actual_arglist *arg;
8208 1566 : gfc_se tse;
8209 1566 : gfc_expr *e;
8210 :
8211 1566 : if (expr->ts.u.cl->length
8212 1566 : && gfc_is_constant_expr (expr->ts.u.cl->length))
8213 : {
8214 1219 : if (!expr->ts.u.cl->backend_decl)
8215 471 : gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
8216 1351 : return;
8217 : }
8218 :
8219 347 : switch (expr->expr_type)
8220 : {
8221 130 : case EXPR_ARRAY:
8222 :
8223 : /* This is somewhat brutal. The expression for the first
8224 : element of the array is evaluated and assigned to a
8225 : new string length for the original expression. */
8226 130 : e = gfc_constructor_first (expr->value.constructor)->expr;
8227 :
8228 130 : gfc_init_se (&tse, NULL);
8229 :
8230 : /* Avoid evaluating trailing array references since all we need is
8231 : the string length. */
8232 130 : if (e->rank)
8233 38 : tse.descriptor_only = 1;
8234 130 : if (e->rank && e->expr_type != EXPR_VARIABLE)
8235 1 : gfc_conv_expr_descriptor (&tse, e);
8236 : else
8237 129 : gfc_conv_expr (&tse, e);
8238 :
8239 130 : gfc_add_block_to_block (&se->pre, &tse.pre);
8240 130 : gfc_add_block_to_block (&se->post, &tse.post);
8241 :
8242 130 : if (!expr->ts.u.cl->backend_decl || !VAR_P (expr->ts.u.cl->backend_decl))
8243 : {
8244 87 : expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
8245 87 : expr->ts.u.cl->backend_decl =
8246 87 : gfc_create_var (gfc_charlen_type_node, "sln");
8247 : }
8248 :
8249 130 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
8250 : tse.string_length);
8251 :
8252 : /* Make sure that deferred length components point to the hidden
8253 : string_length component. */
8254 130 : if (TREE_CODE (tse.expr) == COMPONENT_REF
8255 25 : && TREE_CODE (tse.string_length) == COMPONENT_REF
8256 149 : && TREE_OPERAND (tse.expr, 0) == TREE_OPERAND (tse.string_length, 0))
8257 19 : e->ts.u.cl->backend_decl = expr->ts.u.cl->backend_decl;
8258 :
8259 : return;
8260 :
8261 91 : case EXPR_OP:
8262 91 : get_array_charlen (expr->value.op.op1, se);
8263 :
8264 : /* For parentheses the expression ts.u.cl should be identical. */
8265 91 : if (expr->value.op.op == INTRINSIC_PARENTHESES)
8266 : {
8267 2 : if (expr->value.op.op1->ts.u.cl != expr->ts.u.cl)
8268 2 : expr->ts.u.cl->backend_decl
8269 2 : = expr->value.op.op1->ts.u.cl->backend_decl;
8270 2 : return;
8271 : }
8272 :
8273 178 : expr->ts.u.cl->backend_decl =
8274 89 : gfc_create_var (gfc_charlen_type_node, "sln");
8275 :
8276 89 : if (expr->value.op.op2)
8277 : {
8278 89 : get_array_charlen (expr->value.op.op2, se);
8279 :
8280 89 : gcc_assert (expr->value.op.op == INTRINSIC_CONCAT);
8281 :
8282 : /* Add the string lengths and assign them to the expression
8283 : string length backend declaration. */
8284 89 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
8285 : fold_build2_loc (input_location, PLUS_EXPR,
8286 : gfc_charlen_type_node,
8287 89 : expr->value.op.op1->ts.u.cl->backend_decl,
8288 89 : expr->value.op.op2->ts.u.cl->backend_decl));
8289 : }
8290 : else
8291 0 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
8292 0 : expr->value.op.op1->ts.u.cl->backend_decl);
8293 : break;
8294 :
8295 44 : case EXPR_FUNCTION:
8296 44 : if (expr->value.function.esym == NULL
8297 37 : || expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
8298 : {
8299 7 : gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
8300 7 : break;
8301 : }
8302 :
8303 : /* Map expressions involving the dummy arguments onto the actual
8304 : argument expressions. */
8305 37 : gfc_init_interface_mapping (&mapping);
8306 37 : formal = gfc_sym_get_dummy_args (expr->symtree->n.sym);
8307 37 : arg = expr->value.function.actual;
8308 :
8309 : /* Set se = NULL in the calls to the interface mapping, to suppress any
8310 : backend stuff. */
8311 113 : for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
8312 : {
8313 38 : if (!arg->expr)
8314 0 : continue;
8315 38 : if (formal->sym)
8316 38 : gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
8317 : }
8318 :
8319 37 : gfc_init_se (&tse, NULL);
8320 :
8321 : /* Build the expression for the character length and convert it. */
8322 37 : gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length);
8323 :
8324 37 : gfc_add_block_to_block (&se->pre, &tse.pre);
8325 37 : gfc_add_block_to_block (&se->post, &tse.post);
8326 37 : tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
8327 74 : tse.expr = fold_build2_loc (input_location, MAX_EXPR,
8328 37 : TREE_TYPE (tse.expr), tse.expr,
8329 37 : build_zero_cst (TREE_TYPE (tse.expr)));
8330 37 : expr->ts.u.cl->backend_decl = tse.expr;
8331 37 : gfc_free_interface_mapping (&mapping);
8332 37 : break;
8333 :
8334 82 : default:
8335 82 : gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
8336 82 : break;
8337 : }
8338 : }
8339 :
8340 :
8341 : /* Helper function to check dimensions. */
8342 : static bool
8343 156 : transposed_dims (gfc_ss *ss)
8344 : {
8345 156 : int n;
8346 :
8347 175923 : for (n = 0; n < ss->dimen; n++)
8348 88967 : if (ss->dim[n] != n)
8349 : return true;
8350 : return false;
8351 : }
8352 :
8353 :
8354 : /* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
8355 : AR_FULL, suitable for the scalarizer. */
8356 :
8357 : static gfc_ss *
8358 1510 : walk_coarray (gfc_expr *e)
8359 : {
8360 1510 : gfc_ss *ss;
8361 :
8362 1510 : ss = gfc_walk_expr (e);
8363 :
8364 : /* Fix scalar coarray. */
8365 1510 : if (ss == gfc_ss_terminator)
8366 : {
8367 357 : gfc_ref *ref;
8368 :
8369 357 : ref = e->ref;
8370 508 : while (ref)
8371 : {
8372 508 : if (ref->type == REF_ARRAY
8373 357 : && ref->u.ar.codimen > 0)
8374 : break;
8375 :
8376 151 : ref = ref->next;
8377 : }
8378 :
8379 357 : gcc_assert (ref != NULL);
8380 357 : if (ref->u.ar.type == AR_ELEMENT)
8381 339 : ref->u.ar.type = AR_SECTION;
8382 357 : ss = gfc_reverse_ss (gfc_walk_array_ref (ss, e, ref, false));
8383 : }
8384 :
8385 1510 : return ss;
8386 : }
8387 :
8388 : gfc_array_spec *
8389 2177 : get_coarray_as (const gfc_expr *e)
8390 : {
8391 2177 : gfc_array_spec *as;
8392 2177 : gfc_symbol *sym = e->symtree->n.sym;
8393 2177 : gfc_component *comp;
8394 :
8395 2177 : if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.codimension)
8396 595 : as = CLASS_DATA (sym)->as;
8397 1582 : else if (sym->attr.codimension)
8398 1522 : as = sym->as;
8399 : else
8400 : as = nullptr;
8401 :
8402 5069 : for (gfc_ref *ref = e->ref; ref; ref = ref->next)
8403 : {
8404 2892 : switch (ref->type)
8405 : {
8406 715 : case REF_COMPONENT:
8407 715 : comp = ref->u.c.component;
8408 715 : if (comp->ts.type == BT_CLASS && CLASS_DATA (comp)->attr.codimension)
8409 18 : as = CLASS_DATA (comp)->as;
8410 697 : else if (comp->ts.type != BT_CLASS && comp->attr.codimension)
8411 655 : as = comp->as;
8412 : break;
8413 :
8414 : case REF_ARRAY:
8415 : case REF_SUBSTRING:
8416 : case REF_INQUIRY:
8417 : break;
8418 : }
8419 : }
8420 :
8421 2177 : return as;
8422 : }
8423 :
8424 : bool
8425 143373 : is_explicit_coarray (gfc_expr *expr)
8426 : {
8427 143373 : if (!gfc_is_coarray (expr))
8428 : return false;
8429 :
8430 2177 : gfc_array_spec *cas = get_coarray_as (expr);
8431 2177 : return cas && cas->cotype == AS_EXPLICIT;
8432 : }
8433 :
8434 : /* Convert an array for passing as an actual argument. Expressions and
8435 : vector subscripts are evaluated and stored in a temporary, which is then
8436 : passed. For whole arrays the descriptor is passed. For array sections
8437 : a modified copy of the descriptor is passed, but using the original data.
8438 :
8439 : This function is also used for array pointer assignments, and there
8440 : are three cases:
8441 :
8442 : - se->want_pointer && !se->direct_byref
8443 : EXPR is an actual argument. On exit, se->expr contains a
8444 : pointer to the array descriptor.
8445 :
8446 : - !se->want_pointer && !se->direct_byref
8447 : EXPR is an actual argument to an intrinsic function or the
8448 : left-hand side of a pointer assignment. On exit, se->expr
8449 : contains the descriptor for EXPR.
8450 :
8451 : - !se->want_pointer && se->direct_byref
8452 : EXPR is the right-hand side of a pointer assignment and
8453 : se->expr is the descriptor for the previously-evaluated
8454 : left-hand side. The function creates an assignment from
8455 : EXPR to se->expr.
8456 :
8457 :
8458 : The se->force_tmp flag disables the non-copying descriptor optimization
8459 : that is used for transpose. It may be used in cases where there is an
8460 : alias between the transpose argument and another argument in the same
8461 : function call. */
8462 :
8463 : void
8464 159721 : gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
8465 : {
8466 159721 : gfc_ss *ss;
8467 159721 : gfc_ss_type ss_type;
8468 159721 : gfc_ss_info *ss_info;
8469 159721 : gfc_loopinfo loop;
8470 159721 : gfc_array_info *info;
8471 159721 : int need_tmp;
8472 159721 : int n;
8473 159721 : tree tmp;
8474 159721 : tree desc;
8475 159721 : stmtblock_t block;
8476 159721 : tree start;
8477 159721 : int full;
8478 159721 : bool subref_array_target = false;
8479 159721 : bool deferred_array_component = false;
8480 159721 : bool substr = false;
8481 159721 : gfc_expr *arg, *ss_expr;
8482 :
8483 159721 : if (se->want_coarray || expr->rank == 0)
8484 1510 : ss = walk_coarray (expr);
8485 : else
8486 158211 : ss = gfc_walk_expr (expr);
8487 :
8488 159721 : gcc_assert (ss != NULL);
8489 159721 : gcc_assert (ss != gfc_ss_terminator);
8490 :
8491 159721 : ss_info = ss->info;
8492 159721 : ss_type = ss_info->type;
8493 159721 : ss_expr = ss_info->expr;
8494 :
8495 : /* Special case: TRANSPOSE which needs no temporary. */
8496 165060 : while (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym
8497 164790 : && (arg = gfc_get_noncopying_intrinsic_argument (expr)) != NULL)
8498 : {
8499 : /* This is a call to transpose which has already been handled by the
8500 : scalarizer, so that we just need to get its argument's descriptor. */
8501 408 : gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
8502 408 : expr = expr->value.function.actual->expr;
8503 : }
8504 :
8505 159721 : if (!se->direct_byref)
8506 307095 : se->unlimited_polymorphic = UNLIMITED_POLY (expr);
8507 :
8508 : /* Special case things we know we can pass easily. */
8509 159721 : switch (expr->expr_type)
8510 : {
8511 143658 : case EXPR_VARIABLE:
8512 : /* If we have a linear array section, we can pass it directly.
8513 : Otherwise we need to copy it into a temporary. */
8514 :
8515 143658 : gcc_assert (ss_type == GFC_SS_SECTION);
8516 143658 : gcc_assert (ss_expr == expr);
8517 143658 : info = &ss_info->data.array;
8518 :
8519 : /* Get the descriptor for the array. */
8520 143658 : gfc_conv_ss_descriptor (&se->pre, ss, 0);
8521 143658 : desc = info->descriptor;
8522 :
8523 : /* The charlen backend decl for deferred character components cannot
8524 : be used because it is fixed at zero. Instead, the hidden string
8525 : length component is used. */
8526 143658 : if (expr->ts.type == BT_CHARACTER
8527 20222 : && expr->ts.deferred
8528 2831 : && TREE_CODE (desc) == COMPONENT_REF)
8529 143658 : deferred_array_component = true;
8530 :
8531 143658 : substr = info->ref && info->ref->next
8532 144486 : && info->ref->next->type == REF_SUBSTRING;
8533 :
8534 143658 : subref_array_target = (is_subref_array (expr)
8535 143658 : && (se->direct_byref
8536 2596 : || expr->ts.type == BT_CHARACTER));
8537 143658 : need_tmp = (gfc_ref_needs_temporary_p (expr->ref)
8538 143658 : && !subref_array_target);
8539 :
8540 143658 : if (se->force_tmp)
8541 : need_tmp = 1;
8542 143475 : else if (se->force_no_tmp)
8543 : need_tmp = 0;
8544 :
8545 137338 : if (need_tmp)
8546 : full = 0;
8547 143373 : else if (is_explicit_coarray (expr))
8548 : full = 0;
8549 142553 : else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
8550 : {
8551 : /* Create a new descriptor if the array doesn't have one. */
8552 : full = 0;
8553 : }
8554 92982 : else if (info->ref->u.ar.type == AR_FULL || se->descriptor_only)
8555 : full = 1;
8556 8045 : else if (se->direct_byref)
8557 : full = 0;
8558 7682 : else if (info->ref->u.ar.dimen == 0 && !info->ref->next)
8559 : full = 1;
8560 7541 : else if (info->ref->u.ar.type == AR_SECTION && se->want_pointer)
8561 : full = 0;
8562 : else
8563 3643 : full = gfc_full_array_ref_p (info->ref, NULL);
8564 :
8565 174081 : if (full && !transposed_dims (ss))
8566 : {
8567 85303 : if (se->direct_byref && !se->byref_noassign)
8568 : {
8569 1054 : struct lang_type *lhs_ls
8570 1054 : = TYPE_LANG_SPECIFIC (TREE_TYPE (se->expr)),
8571 1054 : *rhs_ls = TYPE_LANG_SPECIFIC (TREE_TYPE (desc));
8572 : /* When only the array_kind differs, do a view_convert. */
8573 1450 : tmp = lhs_ls && rhs_ls && lhs_ls->rank == rhs_ls->rank
8574 1054 : && lhs_ls->akind != rhs_ls->akind
8575 1450 : ? build1 (VIEW_CONVERT_EXPR, TREE_TYPE (se->expr), desc)
8576 : : desc;
8577 : /* Copy the descriptor for pointer assignments. */
8578 1054 : gfc_add_modify (&se->pre, se->expr, tmp);
8579 :
8580 : /* Add any offsets from subreferences. */
8581 1054 : gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
8582 : subref_array_target, expr);
8583 :
8584 : /* ....and set the span field. */
8585 1054 : if (ss_info->expr->ts.type == BT_CHARACTER)
8586 141 : tmp = gfc_conv_descriptor_span_get (desc);
8587 : else
8588 913 : tmp = gfc_get_array_span (desc, expr);
8589 1054 : gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp);
8590 1054 : }
8591 84249 : else if (se->want_pointer)
8592 : {
8593 : /* We pass full arrays directly. This means that pointers and
8594 : allocatable arrays should also work. */
8595 13919 : se->expr = gfc_build_addr_expr (NULL_TREE, desc);
8596 : }
8597 : else
8598 : {
8599 70330 : se->expr = desc;
8600 : }
8601 :
8602 85303 : if (expr->ts.type == BT_CHARACTER && !deferred_array_component)
8603 8385 : se->string_length = gfc_get_expr_charlen (expr);
8604 : /* The ss_info string length is returned set to the value of the
8605 : hidden string length component. */
8606 76655 : else if (deferred_array_component)
8607 263 : se->string_length = ss_info->string_length;
8608 :
8609 85303 : se->class_container = ss_info->class_container;
8610 :
8611 85303 : gfc_free_ss_chain (ss);
8612 170732 : return;
8613 : }
8614 : break;
8615 :
8616 4931 : case EXPR_FUNCTION:
8617 : /* A transformational function return value will be a temporary
8618 : array descriptor. We still need to go through the scalarizer
8619 : to create the descriptor. Elemental functions are handled as
8620 : arbitrary expressions, i.e. copy to a temporary. */
8621 :
8622 4931 : if (se->direct_byref)
8623 : {
8624 126 : gcc_assert (ss_type == GFC_SS_FUNCTION && ss_expr == expr);
8625 :
8626 : /* For pointer assignments pass the descriptor directly. */
8627 126 : if (se->ss == NULL)
8628 126 : se->ss = ss;
8629 : else
8630 0 : gcc_assert (se->ss == ss);
8631 :
8632 126 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
8633 126 : gfc_conv_expr (se, expr);
8634 :
8635 126 : gfc_free_ss_chain (ss);
8636 126 : return;
8637 : }
8638 :
8639 4805 : if (ss_expr != expr || ss_type != GFC_SS_FUNCTION)
8640 : {
8641 3289 : if (ss_expr != expr)
8642 : /* Elemental function. */
8643 2564 : gcc_assert ((expr->value.function.esym != NULL
8644 : && expr->value.function.esym->attr.elemental)
8645 : || (expr->value.function.isym != NULL
8646 : && expr->value.function.isym->elemental)
8647 : || (gfc_expr_attr (expr).proc_pointer
8648 : && gfc_expr_attr (expr).elemental)
8649 : || gfc_inline_intrinsic_function_p (expr));
8650 :
8651 3289 : need_tmp = 1;
8652 3289 : if (expr->ts.type == BT_CHARACTER
8653 35 : && expr->ts.u.cl->length
8654 29 : && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
8655 13 : get_array_charlen (expr, se);
8656 :
8657 : info = NULL;
8658 : }
8659 : else
8660 : {
8661 : /* Transformational function. */
8662 1516 : info = &ss_info->data.array;
8663 1516 : need_tmp = 0;
8664 : }
8665 : break;
8666 :
8667 10405 : case EXPR_ARRAY:
8668 : /* Constant array constructors don't need a temporary. */
8669 10405 : if (ss_type == GFC_SS_CONSTRUCTOR
8670 10405 : && expr->ts.type != BT_CHARACTER
8671 19569 : && gfc_constant_array_constructor_p (expr->value.constructor))
8672 : {
8673 7206 : need_tmp = 0;
8674 7206 : info = &ss_info->data.array;
8675 : }
8676 : else
8677 : {
8678 : need_tmp = 1;
8679 : info = NULL;
8680 : }
8681 : break;
8682 :
8683 : default:
8684 : /* Something complicated. Copy it into a temporary. */
8685 : need_tmp = 1;
8686 : info = NULL;
8687 : break;
8688 : }
8689 :
8690 : /* If we are creating a temporary, we don't need to bother about aliases
8691 : anymore. */
8692 67077 : if (need_tmp)
8693 7500 : se->force_tmp = 0;
8694 :
8695 74292 : gfc_init_loopinfo (&loop);
8696 :
8697 : /* Associate the SS with the loop. */
8698 74292 : gfc_add_ss_to_loop (&loop, ss);
8699 :
8700 : /* Tell the scalarizer not to bother creating loop variables, etc. */
8701 74292 : if (!need_tmp)
8702 66792 : loop.array_parameter = 1;
8703 : else
8704 : /* The right-hand side of a pointer assignment mustn't use a temporary. */
8705 7500 : gcc_assert (!se->direct_byref);
8706 :
8707 : /* Do we need bounds checking or not? */
8708 74292 : ss->no_bounds_check = expr->no_bounds_check;
8709 :
8710 : /* Setup the scalarizing loops and bounds. */
8711 74292 : gfc_conv_ss_startstride (&loop);
8712 :
8713 : /* Add bounds-checking for elemental dimensions. */
8714 74292 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !expr->no_bounds_check)
8715 6688 : array_bound_check_elemental (&outermost_loop (&loop)->pre, ss, expr);
8716 :
8717 74292 : if (need_tmp)
8718 : {
8719 7500 : if (expr->ts.type == BT_CHARACTER
8720 1480 : && (!expr->ts.u.cl->backend_decl || expr->expr_type == EXPR_ARRAY))
8721 1373 : get_array_charlen (expr, se);
8722 :
8723 : /* Tell the scalarizer to make a temporary. */
8724 7500 : loop.temp_ss = gfc_get_temp_ss (gfc_typenode_for_spec (&expr->ts),
8725 7500 : ((expr->ts.type == BT_CHARACTER)
8726 1480 : ? expr->ts.u.cl->backend_decl
8727 : : NULL),
8728 : loop.dimen);
8729 :
8730 7500 : se->string_length = loop.temp_ss->info->string_length;
8731 7500 : gcc_assert (loop.temp_ss->dimen == loop.dimen);
8732 7500 : gfc_add_ss_to_loop (&loop, loop.temp_ss);
8733 : }
8734 :
8735 74292 : gfc_conv_loop_setup (&loop, & expr->where);
8736 :
8737 74292 : if (need_tmp)
8738 : {
8739 : /* Copy into a temporary and pass that. We don't need to copy the data
8740 : back because expressions and vector subscripts must be INTENT_IN. */
8741 : /* TODO: Optimize passing function return values. */
8742 7500 : gfc_se lse;
8743 7500 : gfc_se rse;
8744 7500 : bool deep_copy;
8745 :
8746 : /* Start the copying loops. */
8747 7500 : gfc_mark_ss_chain_used (loop.temp_ss, 1);
8748 7500 : gfc_mark_ss_chain_used (ss, 1);
8749 7500 : gfc_start_scalarized_body (&loop, &block);
8750 :
8751 : /* Copy each data element. */
8752 7500 : gfc_init_se (&lse, NULL);
8753 7500 : gfc_copy_loopinfo_to_se (&lse, &loop);
8754 7500 : gfc_init_se (&rse, NULL);
8755 7500 : gfc_copy_loopinfo_to_se (&rse, &loop);
8756 :
8757 7500 : lse.ss = loop.temp_ss;
8758 7500 : rse.ss = ss;
8759 :
8760 7500 : gfc_conv_tmp_array_ref (&lse);
8761 7500 : if (expr->ts.type == BT_CHARACTER)
8762 : {
8763 1480 : gfc_conv_expr (&rse, expr);
8764 1480 : if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
8765 1158 : rse.expr = build_fold_indirect_ref_loc (input_location,
8766 : rse.expr);
8767 : }
8768 : else
8769 6020 : gfc_conv_expr_val (&rse, expr);
8770 :
8771 7500 : gfc_add_block_to_block (&block, &rse.pre);
8772 7500 : gfc_add_block_to_block (&block, &lse.pre);
8773 :
8774 7500 : lse.string_length = rse.string_length;
8775 :
8776 15000 : deep_copy = !se->data_not_needed
8777 7500 : && (expr->expr_type == EXPR_VARIABLE
8778 6962 : || expr->expr_type == EXPR_ARRAY);
8779 7500 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts,
8780 : deep_copy, false);
8781 7500 : gfc_add_expr_to_block (&block, tmp);
8782 :
8783 : /* Finish the copying loops. */
8784 7500 : gfc_trans_scalarizing_loops (&loop, &block);
8785 :
8786 7500 : desc = loop.temp_ss->info->data.array.descriptor;
8787 : }
8788 68308 : else if (expr->expr_type == EXPR_FUNCTION && !transposed_dims (ss))
8789 : {
8790 1503 : desc = info->descriptor;
8791 1503 : se->string_length = ss_info->string_length;
8792 : }
8793 : else
8794 : {
8795 : /* We pass sections without copying to a temporary. Make a new
8796 : descriptor and point it at the section we want. The loop variable
8797 : limits will be the limits of the section.
8798 : A function may decide to repack the array to speed up access, but
8799 : we're not bothered about that here. */
8800 65289 : int dim, ndim, codim;
8801 65289 : tree parm;
8802 65289 : tree parmtype;
8803 65289 : tree dtype;
8804 65289 : tree stride;
8805 65289 : tree from;
8806 65289 : tree to;
8807 65289 : tree base;
8808 65289 : tree offset;
8809 :
8810 65289 : ndim = info->ref ? info->ref->u.ar.dimen : ss->dimen;
8811 :
8812 65289 : if (se->want_coarray)
8813 : {
8814 694 : gfc_array_ref *ar = &info->ref->u.ar;
8815 :
8816 694 : codim = expr->corank;
8817 1512 : for (n = 0; n < codim - 1; n++)
8818 : {
8819 : /* Make sure we are not lost somehow. */
8820 818 : gcc_assert (ar->dimen_type[n + ndim] == DIMEN_THIS_IMAGE);
8821 :
8822 : /* Make sure the call to gfc_conv_section_startstride won't
8823 : generate unnecessary code to calculate stride. */
8824 818 : gcc_assert (ar->stride[n + ndim] == NULL);
8825 :
8826 818 : gfc_conv_section_startstride (&loop.pre, ss, n + ndim);
8827 818 : loop.from[n + loop.dimen] = info->start[n + ndim];
8828 818 : loop.to[n + loop.dimen] = info->end[n + ndim];
8829 : }
8830 :
8831 694 : gcc_assert (n == codim - 1);
8832 694 : evaluate_bound (&loop.pre, info->start, ar->start,
8833 : info->descriptor, n + ndim, true,
8834 694 : ar->as->type == AS_DEFERRED, true);
8835 694 : loop.from[n + loop.dimen] = info->start[n + ndim];
8836 : }
8837 : else
8838 : codim = 0;
8839 :
8840 : /* Set the string_length for a character array. */
8841 65289 : if (expr->ts.type == BT_CHARACTER)
8842 : {
8843 11530 : if (deferred_array_component && !substr)
8844 37 : se->string_length = ss_info->string_length;
8845 : else
8846 11493 : se->string_length = gfc_get_expr_charlen (expr);
8847 :
8848 11530 : if (VAR_P (se->string_length)
8849 990 : && expr->ts.u.cl->backend_decl == se->string_length)
8850 984 : tmp = ss_info->string_length;
8851 : else
8852 : tmp = se->string_length;
8853 :
8854 11530 : if (expr->ts.deferred && expr->ts.u.cl->backend_decl
8855 217 : && VAR_P (expr->ts.u.cl->backend_decl))
8856 156 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, tmp);
8857 : else
8858 11374 : expr->ts.u.cl->backend_decl = tmp;
8859 : }
8860 :
8861 : /* If we have an array section, are assigning or passing an array
8862 : section argument make sure that the lower bound is 1. References
8863 : to the full array should otherwise keep the original bounds. */
8864 65289 : if (!info->ref || info->ref->u.ar.type != AR_FULL)
8865 83901 : for (dim = 0; dim < loop.dimen; dim++)
8866 50973 : if (!integer_onep (loop.from[dim]))
8867 : {
8868 27483 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
8869 : gfc_array_index_type, gfc_index_one_node,
8870 : loop.from[dim]);
8871 27483 : loop.to[dim] = fold_build2_loc (input_location, PLUS_EXPR,
8872 : gfc_array_index_type,
8873 : loop.to[dim], tmp);
8874 27483 : loop.from[dim] = gfc_index_one_node;
8875 : }
8876 :
8877 65289 : desc = info->descriptor;
8878 65289 : if (se->direct_byref && !se->byref_noassign)
8879 : {
8880 : /* For pointer assignments we fill in the destination. */
8881 2658 : parm = se->expr;
8882 2658 : parmtype = TREE_TYPE (parm);
8883 : }
8884 : else
8885 : {
8886 : /* Otherwise make a new one. */
8887 62631 : if (expr->ts.type == BT_CHARACTER)
8888 10878 : parmtype = gfc_typenode_for_spec (&expr->ts);
8889 : else
8890 51753 : parmtype = gfc_get_element_type (TREE_TYPE (desc));
8891 :
8892 62631 : parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, codim,
8893 : loop.from, loop.to, 0,
8894 : GFC_ARRAY_UNKNOWN, false);
8895 62631 : parm = gfc_create_var (parmtype, "parm");
8896 :
8897 : /* When expression is a class object, then add the class' handle to
8898 : the parm_decl. */
8899 62631 : if (expr->ts.type == BT_CLASS && expr->expr_type == EXPR_VARIABLE)
8900 : {
8901 1196 : gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr);
8902 1196 : gfc_se classse;
8903 :
8904 : /* class_expr can be NULL, when no _class ref is in expr.
8905 : We must not fix this here with a gfc_fix_class_ref (). */
8906 1196 : if (class_expr)
8907 : {
8908 1186 : gfc_init_se (&classse, NULL);
8909 1186 : gfc_conv_expr (&classse, class_expr);
8910 1186 : gfc_free_expr (class_expr);
8911 :
8912 1186 : gcc_assert (classse.pre.head == NULL_TREE
8913 : && classse.post.head == NULL_TREE);
8914 1186 : gfc_allocate_lang_decl (parm);
8915 1186 : GFC_DECL_SAVED_DESCRIPTOR (parm) = classse.expr;
8916 : }
8917 : }
8918 : }
8919 :
8920 65289 : if (expr->ts.type == BT_CHARACTER
8921 65289 : && VAR_P (TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (parm)))))
8922 : {
8923 0 : tree elem_len = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (parm)));
8924 0 : gfc_add_modify (&loop.pre, elem_len,
8925 0 : fold_convert (TREE_TYPE (elem_len),
8926 : gfc_get_array_span (desc, expr)));
8927 : }
8928 :
8929 : /* Set the span field. */
8930 65289 : tmp = NULL_TREE;
8931 65289 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
8932 7711 : tmp = gfc_conv_descriptor_span_get (desc);
8933 : else
8934 57578 : tmp = gfc_get_array_span (desc, expr);
8935 65289 : if (tmp)
8936 65209 : gfc_conv_descriptor_span_set (&loop.pre, parm, tmp);
8937 :
8938 : /* The following can be somewhat confusing. We have two
8939 : descriptors, a new one and the original array.
8940 : {parm, parmtype, dim} refer to the new one.
8941 : {desc, type, n, loop} refer to the original, which maybe
8942 : a descriptorless array.
8943 : The bounds of the scalarization are the bounds of the section.
8944 : We don't have to worry about numeric overflows when calculating
8945 : the offsets because all elements are within the array data. */
8946 :
8947 : /* Set the dtype. */
8948 65289 : tmp = gfc_conv_descriptor_dtype (parm);
8949 65289 : if (se->unlimited_polymorphic)
8950 613 : dtype = gfc_get_dtype (TREE_TYPE (desc), &loop.dimen);
8951 64676 : else if (expr->ts.type == BT_ASSUMED)
8952 : {
8953 127 : tree tmp2 = desc;
8954 127 : if (DECL_LANG_SPECIFIC (tmp2) && GFC_DECL_SAVED_DESCRIPTOR (tmp2))
8955 127 : tmp2 = GFC_DECL_SAVED_DESCRIPTOR (tmp2);
8956 127 : if (POINTER_TYPE_P (TREE_TYPE (tmp2)))
8957 127 : tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
8958 127 : dtype = gfc_conv_descriptor_dtype (tmp2);
8959 : }
8960 : else
8961 64549 : dtype = gfc_get_dtype (parmtype);
8962 65289 : gfc_add_modify (&loop.pre, tmp, dtype);
8963 :
8964 : /* The 1st element in the section. */
8965 65289 : base = gfc_index_zero_node;
8966 65289 : if (expr->ts.type == BT_CHARACTER && expr->rank == 0 && codim)
8967 6 : base = gfc_index_one_node;
8968 :
8969 : /* The offset from the 1st element in the section. */
8970 : offset = gfc_index_zero_node;
8971 :
8972 167457 : for (n = 0; n < ndim; n++)
8973 : {
8974 102168 : stride = gfc_conv_array_stride (desc, n);
8975 :
8976 : /* Work out the 1st element in the section. */
8977 102168 : if (info->ref
8978 94576 : && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
8979 : {
8980 1265 : gcc_assert (info->subscript[n]
8981 : && info->subscript[n]->info->type == GFC_SS_SCALAR);
8982 1265 : start = info->subscript[n]->info->data.scalar.value;
8983 : }
8984 : else
8985 : {
8986 : /* Evaluate and remember the start of the section. */
8987 100903 : start = info->start[n];
8988 100903 : stride = gfc_evaluate_now (stride, &loop.pre);
8989 : }
8990 :
8991 102168 : tmp = gfc_conv_array_lbound (desc, n);
8992 102168 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
8993 : start, tmp);
8994 102168 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
8995 : tmp, stride);
8996 102168 : base = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
8997 : base, tmp);
8998 :
8999 102168 : if (info->ref
9000 94576 : && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
9001 : {
9002 : /* For elemental dimensions, we only need the 1st
9003 : element in the section. */
9004 1265 : continue;
9005 : }
9006 :
9007 : /* Vector subscripts need copying and are handled elsewhere. */
9008 100903 : if (info->ref)
9009 93311 : gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
9010 :
9011 : /* look for the corresponding scalarizer dimension: dim. */
9012 151401 : for (dim = 0; dim < ndim; dim++)
9013 151401 : if (ss->dim[dim] == n)
9014 : break;
9015 :
9016 : /* loop exited early: the DIM being looked for has been found. */
9017 100903 : gcc_assert (dim < ndim);
9018 :
9019 : /* Set the new lower bound. */
9020 100903 : from = loop.from[dim];
9021 100903 : to = loop.to[dim];
9022 :
9023 100903 : gfc_conv_descriptor_lbound_set (&loop.pre, parm,
9024 : gfc_rank_cst[dim], from);
9025 :
9026 : /* Set the new upper bound. */
9027 100903 : gfc_conv_descriptor_ubound_set (&loop.pre, parm,
9028 : gfc_rank_cst[dim], to);
9029 :
9030 : /* Multiply the stride by the section stride to get the
9031 : total stride. */
9032 100903 : stride = fold_build2_loc (input_location, MULT_EXPR,
9033 : gfc_array_index_type,
9034 : stride, info->stride[n]);
9035 :
9036 100903 : tmp = fold_build2_loc (input_location, MULT_EXPR,
9037 100903 : TREE_TYPE (offset), stride, from);
9038 100903 : offset = fold_build2_loc (input_location, MINUS_EXPR,
9039 100903 : TREE_TYPE (offset), offset, tmp);
9040 :
9041 : /* Store the new stride. */
9042 100903 : gfc_conv_descriptor_stride_set (&loop.pre, parm,
9043 : gfc_rank_cst[dim], stride);
9044 : }
9045 :
9046 : /* For deferred-length character we need to take the dynamic length
9047 : into account for the dataptr offset. */
9048 65289 : if (expr->ts.type == BT_CHARACTER
9049 11530 : && expr->ts.deferred
9050 223 : && expr->ts.u.cl->backend_decl
9051 223 : && VAR_P (expr->ts.u.cl->backend_decl))
9052 : {
9053 156 : tree base_type = TREE_TYPE (base);
9054 156 : base = fold_build2_loc (input_location, MULT_EXPR, base_type, base,
9055 : fold_convert (base_type,
9056 : expr->ts.u.cl->backend_decl));
9057 : }
9058 :
9059 66801 : for (n = loop.dimen; n < loop.dimen + codim; n++)
9060 : {
9061 1512 : from = loop.from[n];
9062 1512 : to = loop.to[n];
9063 1512 : gfc_conv_descriptor_lbound_set (&loop.pre, parm,
9064 : gfc_rank_cst[n], from);
9065 1512 : if (n < loop.dimen + codim - 1)
9066 818 : gfc_conv_descriptor_ubound_set (&loop.pre, parm,
9067 : gfc_rank_cst[n], to);
9068 : }
9069 :
9070 65289 : if (se->data_not_needed)
9071 6134 : gfc_conv_descriptor_data_set (&loop.pre, parm,
9072 : gfc_index_zero_node);
9073 : else
9074 : /* Point the data pointer at the 1st element in the section. */
9075 59155 : gfc_get_dataptr_offset (&loop.pre, parm, desc, base,
9076 : subref_array_target, expr);
9077 :
9078 65289 : gfc_conv_descriptor_offset_set (&loop.pre, parm, offset);
9079 :
9080 65289 : if (flag_coarray == GFC_FCOARRAY_LIB && expr->corank)
9081 : {
9082 404 : tmp = INDIRECT_REF_P (desc) ? TREE_OPERAND (desc, 0) : desc;
9083 404 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
9084 : {
9085 24 : tmp = gfc_conv_descriptor_token (tmp);
9086 : }
9087 380 : else if (DECL_P (tmp) && DECL_LANG_SPECIFIC (tmp)
9088 460 : && GFC_DECL_TOKEN (tmp) != NULL_TREE)
9089 64 : tmp = GFC_DECL_TOKEN (tmp);
9090 : else
9091 : {
9092 316 : tmp = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (tmp));
9093 : }
9094 :
9095 404 : gfc_add_modify (&loop.pre, gfc_conv_descriptor_token (parm), tmp);
9096 : }
9097 : desc = parm;
9098 : }
9099 :
9100 : /* For class arrays add the class tree into the saved descriptor to
9101 : enable getting of _vptr and the like. */
9102 74292 : if (expr->expr_type == EXPR_VARIABLE && VAR_P (desc)
9103 57451 : && IS_CLASS_ARRAY (expr->symtree->n.sym))
9104 : {
9105 1168 : gfc_allocate_lang_decl (desc);
9106 1168 : GFC_DECL_SAVED_DESCRIPTOR (desc) =
9107 1168 : DECL_LANG_SPECIFIC (expr->symtree->n.sym->backend_decl) ?
9108 1082 : GFC_DECL_SAVED_DESCRIPTOR (expr->symtree->n.sym->backend_decl)
9109 : : expr->symtree->n.sym->backend_decl;
9110 : }
9111 73124 : else if (expr->expr_type == EXPR_ARRAY && VAR_P (desc)
9112 10405 : && IS_CLASS_ARRAY (expr))
9113 : {
9114 12 : tree vtype;
9115 12 : gfc_allocate_lang_decl (desc);
9116 12 : tmp = gfc_create_var (expr->ts.u.derived->backend_decl, "class");
9117 12 : GFC_DECL_SAVED_DESCRIPTOR (desc) = tmp;
9118 12 : vtype = gfc_class_vptr_get (tmp);
9119 12 : gfc_add_modify (&se->pre, vtype,
9120 12 : gfc_build_addr_expr (TREE_TYPE (vtype),
9121 12 : gfc_find_vtab (&expr->ts)->backend_decl));
9122 : }
9123 74292 : if (!se->direct_byref || se->byref_noassign)
9124 : {
9125 : /* Get a pointer to the new descriptor. */
9126 71634 : if (se->want_pointer)
9127 40285 : se->expr = gfc_build_addr_expr (NULL_TREE, desc);
9128 : else
9129 31349 : se->expr = desc;
9130 : }
9131 :
9132 74292 : gfc_add_block_to_block (&se->pre, &loop.pre);
9133 74292 : gfc_add_block_to_block (&se->post, &loop.post);
9134 :
9135 : /* Cleanup the scalarizer. */
9136 74292 : gfc_cleanup_loop (&loop);
9137 : }
9138 :
9139 :
9140 : /* Calculate the array size (number of elements); if dim != NULL_TREE,
9141 : return size for that dim (dim=0..rank-1; only for GFC_DESCRIPTOR_TYPE_P).
9142 : If !expr && descriptor array, the rank is taken from the descriptor. */
9143 : tree
9144 15479 : gfc_tree_array_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree dim)
9145 : {
9146 15479 : if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
9147 : {
9148 40 : gcc_assert (dim == NULL_TREE);
9149 40 : return GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
9150 : }
9151 15439 : tree size, tmp, rank = NULL_TREE, cond = NULL_TREE;
9152 15439 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
9153 15439 : enum gfc_array_kind akind = GFC_TYPE_ARRAY_AKIND (TREE_TYPE (desc));
9154 15439 : if (expr == NULL || expr->rank < 0)
9155 3508 : rank = fold_convert (signed_char_type_node,
9156 : gfc_conv_descriptor_rank (desc));
9157 : else
9158 11931 : rank = build_int_cst (signed_char_type_node, expr->rank);
9159 :
9160 15439 : if (dim || (expr && expr->rank == 1))
9161 : {
9162 4645 : if (!dim)
9163 4645 : dim = gfc_index_zero_node;
9164 13771 : tree ubound = gfc_conv_descriptor_ubound_get (desc, dim);
9165 13771 : tree lbound = gfc_conv_descriptor_lbound_get (desc, dim);
9166 :
9167 13771 : size = fold_build2_loc (input_location, MINUS_EXPR,
9168 : gfc_array_index_type, ubound, lbound);
9169 13771 : size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
9170 : size, gfc_index_one_node);
9171 : /* if (!allocatable && !pointer && assumed rank)
9172 : size = (idx == rank && ubound[rank-1] == -1 ? -1 : size;
9173 : else
9174 : size = max (0, size); */
9175 13771 : size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
9176 : size, gfc_index_zero_node);
9177 13771 : if (akind == GFC_ARRAY_ASSUMED_RANK_CONT
9178 13771 : || akind == GFC_ARRAY_ASSUMED_RANK)
9179 : {
9180 2809 : tmp = fold_build2_loc (input_location, MINUS_EXPR, signed_char_type_node,
9181 : rank, build_int_cst (signed_char_type_node, 1));
9182 2809 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
9183 : fold_convert (signed_char_type_node, dim),
9184 : tmp);
9185 2809 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
9186 : gfc_conv_descriptor_ubound_get (desc, dim),
9187 : build_int_cst (gfc_array_index_type, -1));
9188 2809 : cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
9189 : cond, tmp);
9190 2809 : tmp = build_int_cst (gfc_array_index_type, -1);
9191 2809 : size = build3_loc (input_location, COND_EXPR, gfc_array_index_type,
9192 : cond, tmp, size);
9193 : }
9194 13771 : return size;
9195 : }
9196 :
9197 : /* size = 1. */
9198 1668 : size = gfc_create_var (gfc_array_index_type, "size");
9199 1668 : gfc_add_modify (block, size, build_int_cst (TREE_TYPE (size), 1));
9200 1668 : tree extent = gfc_create_var (gfc_array_index_type, "extent");
9201 :
9202 1668 : stmtblock_t cond_block, loop_body;
9203 1668 : gfc_init_block (&cond_block);
9204 1668 : gfc_init_block (&loop_body);
9205 :
9206 : /* Loop: for (i = 0; i < rank; ++i). */
9207 1668 : tree idx = gfc_create_var (signed_char_type_node, "idx");
9208 : /* Loop body. */
9209 : /* #if (assumed-rank + !allocatable && !pointer)
9210 : if (idx == rank - 1 && dim[idx].ubound == -1)
9211 : extent = -1;
9212 : else
9213 : #endif
9214 : extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1
9215 : if (extent < 0)
9216 : extent = 0
9217 : size *= extent. */
9218 1668 : cond = NULL_TREE;
9219 1668 : if (akind == GFC_ARRAY_ASSUMED_RANK_CONT || akind == GFC_ARRAY_ASSUMED_RANK)
9220 : {
9221 471 : tmp = fold_build2_loc (input_location, MINUS_EXPR, signed_char_type_node,
9222 : rank, build_int_cst (signed_char_type_node, 1));
9223 471 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
9224 : idx, tmp);
9225 471 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
9226 : gfc_conv_descriptor_ubound_get (desc, idx),
9227 : build_int_cst (gfc_array_index_type, -1));
9228 471 : cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
9229 : cond, tmp);
9230 : }
9231 1668 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
9232 : gfc_conv_descriptor_ubound_get (desc, idx),
9233 : gfc_conv_descriptor_lbound_get (desc, idx));
9234 1668 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
9235 : tmp, gfc_index_one_node);
9236 1668 : gfc_add_modify (&cond_block, extent, tmp);
9237 1668 : tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
9238 : extent, gfc_index_zero_node);
9239 1668 : tmp = build3_v (COND_EXPR, tmp,
9240 : fold_build2_loc (input_location, MODIFY_EXPR,
9241 : gfc_array_index_type,
9242 : extent, gfc_index_zero_node),
9243 : build_empty_stmt (input_location));
9244 1668 : gfc_add_expr_to_block (&cond_block, tmp);
9245 1668 : tmp = gfc_finish_block (&cond_block);
9246 1668 : if (cond)
9247 471 : tmp = build3_v (COND_EXPR, cond,
9248 : fold_build2_loc (input_location, MODIFY_EXPR,
9249 : gfc_array_index_type, extent,
9250 : build_int_cst (gfc_array_index_type, -1)),
9251 : tmp);
9252 1668 : gfc_add_expr_to_block (&loop_body, tmp);
9253 : /* size *= extent. */
9254 1668 : gfc_add_modify (&loop_body, size,
9255 : fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9256 : size, extent));
9257 : /* Generate loop. */
9258 3336 : gfc_simple_for_loop (block, idx, build_int_cst (TREE_TYPE (idx), 0), rank, LT_EXPR,
9259 1668 : build_int_cst (TREE_TYPE (idx), 1),
9260 : gfc_finish_block (&loop_body));
9261 1668 : return size;
9262 : }
9263 :
9264 : /* Helper function for gfc_conv_array_parameter if array size needs to be
9265 : computed. */
9266 :
9267 : static void
9268 142 : array_parameter_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree *size)
9269 : {
9270 142 : tree elem;
9271 142 : *size = gfc_tree_array_size (block, desc, expr, NULL);
9272 142 : elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
9273 142 : *size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9274 : *size, fold_convert (gfc_array_index_type, elem));
9275 142 : }
9276 :
9277 : /* Helper function - return true if the argument is a pointer. */
9278 :
9279 : static bool
9280 712 : is_pointer (gfc_expr *e)
9281 : {
9282 712 : gfc_symbol *sym;
9283 :
9284 712 : if (e->expr_type != EXPR_VARIABLE || e->symtree == NULL)
9285 : return false;
9286 :
9287 712 : sym = e->symtree->n.sym;
9288 712 : if (sym == NULL)
9289 : return false;
9290 :
9291 712 : return sym->attr.pointer || sym->attr.proc_pointer;
9292 : }
9293 :
9294 : /* Assumed-rank actual argument: the caller only allocates storage for dtype
9295 : rank dimensions. Copying GFC_MAX_DIMENSIONS dim entries would read past the
9296 : physical end of the descriptor. Copy the header fields explicitly and use a
9297 : runtime-sized memcpy for the dim[] entries. */
9298 : void
9299 78 : gfc_resize_assumed_rank_dim_field (gfc_se *se, stmtblock_t *block, tree desc)
9300 : {
9301 78 : tree rank, dim_field, dim_size, copy_size, dst_ptr, src_ptr;
9302 :
9303 78 : gfc_conv_descriptor_data_set (block, desc,
9304 : gfc_conv_descriptor_data_get (se->expr));
9305 78 : gfc_conv_descriptor_offset_set (block, desc,
9306 : gfc_conv_descriptor_offset_get (se->expr));
9307 78 : gfc_add_modify (block, gfc_conv_descriptor_dtype (desc),
9308 : gfc_conv_descriptor_dtype (se->expr));
9309 78 : rank = fold_convert (size_type_node, gfc_conv_descriptor_rank (se->expr));
9310 78 : dim_field = gfc_get_descriptor_dimension (se->expr);
9311 78 : dim_size = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (dim_field)));
9312 78 : copy_size = fold_build2_loc (input_location, MULT_EXPR,
9313 : size_type_node, rank, dim_size);
9314 78 : dst_ptr = gfc_build_addr_expr (pvoid_type_node,
9315 : gfc_get_descriptor_dimension (desc));
9316 78 : src_ptr = gfc_build_addr_expr (pvoid_type_node, dim_field);
9317 78 : gfc_add_expr_to_block (block, build_call_expr_loc (input_location,
9318 : builtin_decl_explicit (BUILT_IN_MEMCPY),
9319 : 3, dst_ptr, src_ptr, copy_size));
9320 78 : }
9321 :
9322 : /* Convert an array for passing as an actual parameter. */
9323 :
9324 : void
9325 66111 : gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr, bool g77,
9326 : const gfc_symbol *fsym, const char *proc_name,
9327 : tree *size, tree *lbshift, tree *packed)
9328 : {
9329 66111 : tree ptr;
9330 66111 : tree desc;
9331 66111 : tree tmp = NULL_TREE;
9332 66111 : tree stmt;
9333 66111 : tree parent = DECL_CONTEXT (current_function_decl);
9334 66111 : tree ctree;
9335 66111 : tree pack_attr = NULL_TREE; /* Set when packing class arrays. */
9336 66111 : bool full_array_var;
9337 66111 : bool this_array_result;
9338 66111 : bool contiguous;
9339 66111 : bool no_pack;
9340 66111 : bool array_constructor;
9341 66111 : bool good_allocatable;
9342 66111 : bool ultimate_ptr_comp;
9343 66111 : bool ultimate_alloc_comp;
9344 66111 : bool readonly;
9345 66111 : gfc_symbol *sym;
9346 66111 : stmtblock_t block;
9347 66111 : gfc_ref *ref;
9348 :
9349 66111 : ultimate_ptr_comp = false;
9350 66111 : ultimate_alloc_comp = false;
9351 :
9352 66856 : for (ref = expr->ref; ref; ref = ref->next)
9353 : {
9354 55408 : if (ref->next == NULL)
9355 : break;
9356 :
9357 745 : if (ref->type == REF_COMPONENT)
9358 : {
9359 661 : ultimate_ptr_comp = ref->u.c.component->attr.pointer;
9360 661 : ultimate_alloc_comp = ref->u.c.component->attr.allocatable;
9361 : }
9362 : }
9363 :
9364 66111 : full_array_var = false;
9365 66111 : contiguous = false;
9366 :
9367 66111 : if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp)
9368 54580 : full_array_var = gfc_full_array_ref_p (ref, &contiguous);
9369 :
9370 54580 : sym = full_array_var ? expr->symtree->n.sym : NULL;
9371 :
9372 : /* The symbol should have an array specification. */
9373 63165 : gcc_assert (!sym || sym->as || ref->u.ar.as);
9374 :
9375 66111 : if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
9376 : {
9377 690 : get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
9378 690 : expr->ts.u.cl->backend_decl = tmp;
9379 690 : se->string_length = tmp;
9380 : }
9381 :
9382 : /* Is this the result of the enclosing procedure? */
9383 66111 : this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
9384 58 : if (this_array_result
9385 58 : && (sym->backend_decl != current_function_decl)
9386 0 : && (sym->backend_decl != parent))
9387 66111 : this_array_result = false;
9388 :
9389 : /* Passing an optional dummy argument as actual to an optional dummy? */
9390 66111 : bool pass_optional;
9391 66111 : pass_optional = fsym && fsym->attr.optional && sym && sym->attr.optional;
9392 :
9393 : /* Passing address of the array if it is not pointer or assumed-shape. */
9394 66111 : if (full_array_var && g77 && !this_array_result
9395 16071 : && sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
9396 : {
9397 12579 : tmp = gfc_get_symbol_decl (sym);
9398 :
9399 12579 : if (sym->ts.type == BT_CHARACTER)
9400 2809 : se->string_length = sym->ts.u.cl->backend_decl;
9401 :
9402 12579 : if (!sym->attr.pointer
9403 12088 : && sym->as
9404 12088 : && sym->as->type != AS_ASSUMED_SHAPE
9405 11843 : && sym->as->type != AS_DEFERRED
9406 10347 : && sym->as->type != AS_ASSUMED_RANK
9407 10271 : && !sym->attr.allocatable)
9408 : {
9409 : /* Some variables are declared directly, others are declared as
9410 : pointers and allocated on the heap. */
9411 9765 : if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
9412 2518 : se->expr = tmp;
9413 : else
9414 7247 : se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
9415 9765 : if (size)
9416 40 : array_parameter_size (&se->pre, tmp, expr, size);
9417 16968 : return;
9418 : }
9419 :
9420 2814 : if (sym->attr.allocatable)
9421 : {
9422 1882 : if (sym->attr.dummy || sym->attr.result)
9423 : {
9424 1176 : gfc_conv_expr_descriptor (se, expr);
9425 1176 : tmp = se->expr;
9426 : }
9427 1882 : if (size)
9428 14 : array_parameter_size (&se->pre, tmp, expr, size);
9429 1882 : se->expr = gfc_conv_array_data (tmp);
9430 1882 : if (pass_optional)
9431 : {
9432 18 : tree cond = gfc_conv_expr_present (sym);
9433 36 : se->expr = build3_loc (input_location, COND_EXPR,
9434 18 : TREE_TYPE (se->expr), cond, se->expr,
9435 18 : fold_convert (TREE_TYPE (se->expr),
9436 : null_pointer_node));
9437 : }
9438 1882 : return;
9439 : }
9440 : }
9441 :
9442 : /* A convenient reduction in scope. */
9443 54464 : contiguous = g77 && !this_array_result && contiguous;
9444 :
9445 : /* There is no need to pack and unpack the array, if it is contiguous
9446 : and not a deferred- or assumed-shape array, or if it is simply
9447 : contiguous. */
9448 54464 : no_pack = false;
9449 : // clang-format off
9450 54464 : if (sym)
9451 : {
9452 40068 : symbol_attribute *attr = &(IS_CLASS_ARRAY (sym)
9453 : ? CLASS_DATA (sym)->attr : sym->attr);
9454 40068 : gfc_array_spec *as = IS_CLASS_ARRAY (sym)
9455 40068 : ? CLASS_DATA (sym)->as : sym->as;
9456 40068 : no_pack = (as
9457 39778 : && !attr->pointer
9458 36518 : && as->type != AS_DEFERRED
9459 26840 : && as->type != AS_ASSUMED_RANK
9460 63839 : && as->type != AS_ASSUMED_SHAPE);
9461 : }
9462 54464 : if (ref && ref->u.ar.as)
9463 43014 : no_pack = no_pack
9464 43014 : || (ref->u.ar.as->type != AS_DEFERRED
9465 : && ref->u.ar.as->type != AS_ASSUMED_RANK
9466 : && ref->u.ar.as->type != AS_ASSUMED_SHAPE);
9467 108928 : no_pack = contiguous
9468 54464 : && (no_pack || gfc_is_simply_contiguous (expr, false, true));
9469 : // clang-format on
9470 :
9471 : /* If we have an EXPR_OP or a function returning an explicit-shaped
9472 : or allocatable array, an array temporary will be generated which
9473 : does not need to be packed / unpacked if passed to an
9474 : explicit-shape dummy array. */
9475 :
9476 54464 : if (g77)
9477 : {
9478 6368 : if (expr->expr_type == EXPR_OP)
9479 : no_pack = 1;
9480 6291 : else if (expr->expr_type == EXPR_FUNCTION && expr->value.function.esym)
9481 : {
9482 41 : gfc_symbol *result = expr->value.function.esym->result;
9483 41 : if (result->attr.dimension
9484 41 : && (result->as->type == AS_EXPLICIT
9485 14 : || result->attr.allocatable
9486 7 : || result->attr.contiguous))
9487 112 : no_pack = 1;
9488 : }
9489 : }
9490 :
9491 : /* Array constructors are always contiguous and do not need packing. */
9492 54464 : array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY;
9493 :
9494 : /* Same is true of contiguous sections from allocatable variables. */
9495 108928 : good_allocatable = contiguous
9496 4559 : && expr->symtree
9497 59023 : && expr->symtree->n.sym->attr.allocatable;
9498 :
9499 : /* Or ultimate allocatable components. */
9500 54464 : ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
9501 :
9502 54464 : if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp)
9503 : {
9504 4942 : gfc_conv_expr_descriptor (se, expr);
9505 : /* Deallocate the allocatable components of structures that are
9506 : not variable. */
9507 4942 : if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
9508 3401 : && expr->ts.u.derived->attr.alloc_comp
9509 2022 : && expr->expr_type != EXPR_VARIABLE)
9510 : {
9511 2 : tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, se->expr, expr->rank);
9512 :
9513 : /* The components shall be deallocated before their containing entity. */
9514 2 : gfc_prepend_expr_to_block (&se->post, tmp);
9515 : }
9516 4942 : if (expr->ts.type == BT_CHARACTER && expr->expr_type != EXPR_FUNCTION)
9517 309 : se->string_length = expr->ts.u.cl->backend_decl;
9518 4942 : if (size)
9519 58 : array_parameter_size (&se->pre, se->expr, expr, size);
9520 4942 : se->expr = gfc_conv_array_data (se->expr);
9521 4942 : return;
9522 : }
9523 :
9524 49522 : if (fsym && fsym->ts.type == BT_CLASS)
9525 : {
9526 1254 : gcc_assert (se->expr);
9527 : ctree = se->expr;
9528 : }
9529 : else
9530 : ctree = NULL_TREE;
9531 :
9532 49522 : if (this_array_result)
9533 : {
9534 : /* Result of the enclosing function. */
9535 58 : gfc_conv_expr_descriptor (se, expr);
9536 58 : if (size)
9537 0 : array_parameter_size (&se->pre, se->expr, expr, size);
9538 58 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
9539 :
9540 18 : if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
9541 76 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
9542 18 : se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location,
9543 : se->expr));
9544 :
9545 58 : return;
9546 : }
9547 : else
9548 : {
9549 : /* Every other type of array. */
9550 49464 : se->want_pointer = (ctree) ? 0 : 1;
9551 49464 : se->want_coarray = expr->corank;
9552 49464 : gfc_conv_expr_descriptor (se, expr);
9553 :
9554 49464 : if (size)
9555 30 : array_parameter_size (&se->pre,
9556 : build_fold_indirect_ref_loc (input_location,
9557 : se->expr),
9558 : expr, size);
9559 49464 : if (ctree)
9560 : {
9561 1254 : stmtblock_t block;
9562 :
9563 1254 : gfc_init_block (&block);
9564 1254 : if (lbshift && *lbshift)
9565 : {
9566 : /* Apply a shift of the lbound when supplied. */
9567 98 : for (int dim = 0; dim < expr->rank; ++dim)
9568 49 : gfc_conv_shift_descriptor_lbound (&block, se->expr, dim,
9569 : *lbshift);
9570 : }
9571 1254 : tmp = gfc_class_data_get (ctree);
9572 1254 : if (expr->rank > 1 && CLASS_DATA (fsym)->as->rank != expr->rank
9573 84 : && CLASS_DATA (fsym)->as->type == AS_EXPLICIT && !no_pack)
9574 : {
9575 36 : tree arr = gfc_create_var (TREE_TYPE (tmp), "parm");
9576 36 : gfc_conv_descriptor_data_set (&block, arr,
9577 : gfc_conv_descriptor_data_get (
9578 : se->expr));
9579 36 : gfc_conv_descriptor_lbound_set (&block, arr, gfc_index_zero_node,
9580 : gfc_index_zero_node);
9581 36 : gfc_conv_descriptor_ubound_set (
9582 : &block, arr, gfc_index_zero_node,
9583 : gfc_conv_descriptor_size (se->expr, expr->rank));
9584 36 : gfc_conv_descriptor_stride_set (
9585 : &block, arr, gfc_index_zero_node,
9586 : gfc_conv_descriptor_stride_get (se->expr, gfc_index_zero_node));
9587 36 : gfc_add_modify (&block, gfc_conv_descriptor_dtype (arr),
9588 : gfc_conv_descriptor_dtype (se->expr));
9589 36 : gfc_add_modify (&block, gfc_conv_descriptor_rank (arr),
9590 : build_int_cst (signed_char_type_node, 1));
9591 36 : gfc_conv_descriptor_span_set (&block, arr,
9592 : gfc_conv_descriptor_span_get (arr));
9593 36 : gfc_conv_descriptor_offset_set (&block, arr, gfc_index_zero_node);
9594 36 : se->expr = arr;
9595 : }
9596 1254 : if (expr->rank == -1)
9597 78 : gfc_resize_assumed_rank_dim_field (se, &block, tmp);
9598 1176 : else if (CLASS_DATA (fsym)->as->rank == -1)
9599 397 : gfc_class_array_data_assign (&block, tmp, se->expr, false);
9600 : else
9601 779 : gfc_class_array_data_assign (&block, tmp, se->expr, true);
9602 :
9603 : /* Handle optional. */
9604 1254 : if (fsym && fsym->attr.optional && sym && sym->attr.optional)
9605 348 : tmp = build3_v (COND_EXPR, gfc_conv_expr_present (sym),
9606 : gfc_finish_block (&block),
9607 : build_empty_stmt (input_location));
9608 : else
9609 906 : tmp = gfc_finish_block (&block);
9610 :
9611 1254 : gfc_add_expr_to_block (&se->pre, tmp);
9612 : }
9613 48210 : else if (pass_optional && full_array_var && sym->as && sym->as->rank != 0)
9614 : {
9615 : /* Perform calculation of bounds and strides of optional array dummy
9616 : only if the argument is present. */
9617 219 : tmp = build3_v (COND_EXPR, gfc_conv_expr_present (sym),
9618 : gfc_finish_block (&se->pre),
9619 : build_empty_stmt (input_location));
9620 219 : gfc_add_expr_to_block (&se->pre, tmp);
9621 : }
9622 : }
9623 :
9624 : /* Deallocate the allocatable components of structures that are
9625 : not variable, for descriptorless arguments.
9626 : Arguments with a descriptor are handled in gfc_conv_procedure_call. */
9627 49464 : if (g77 && (expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
9628 72 : && expr->ts.u.derived->attr.alloc_comp
9629 18 : && expr->expr_type != EXPR_VARIABLE)
9630 : {
9631 0 : tmp = build_fold_indirect_ref_loc (input_location, se->expr);
9632 0 : tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank);
9633 :
9634 : /* The components shall be deallocated before their containing entity. */
9635 0 : gfc_prepend_expr_to_block (&se->post, tmp);
9636 : }
9637 :
9638 48056 : if (g77 || (fsym && fsym->attr.contiguous
9639 1561 : && !gfc_is_simply_contiguous (expr, false, true)))
9640 : {
9641 1564 : tree origptr = NULL_TREE, packedptr = NULL_TREE;
9642 :
9643 1564 : desc = se->expr;
9644 :
9645 : /* For contiguous arrays, save the original value of the descriptor. */
9646 1564 : if (!g77 && !ctree)
9647 : {
9648 60 : origptr = gfc_create_var (pvoid_type_node, "origptr");
9649 60 : tmp = build_fold_indirect_ref_loc (input_location, desc);
9650 60 : tmp = gfc_conv_array_data (tmp);
9651 120 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
9652 60 : TREE_TYPE (origptr), origptr,
9653 60 : fold_convert (TREE_TYPE (origptr), tmp));
9654 60 : gfc_add_expr_to_block (&se->pre, tmp);
9655 : }
9656 :
9657 : /* Repack the array. */
9658 1564 : if (warn_array_temporaries)
9659 : {
9660 28 : if (fsym)
9661 18 : gfc_warning (OPT_Warray_temporaries,
9662 : "Creating array temporary at %L for argument %qs",
9663 18 : &expr->where, fsym->name);
9664 : else
9665 10 : gfc_warning (OPT_Warray_temporaries,
9666 : "Creating array temporary at %L", &expr->where);
9667 : }
9668 :
9669 : /* When optimizing, we can use gfc_conv_subref_array_arg for
9670 : making the packing and unpacking operation visible to the
9671 : optimizers. */
9672 :
9673 1408 : if (g77 && flag_inline_arg_packing && expr->expr_type == EXPR_VARIABLE
9674 712 : && !is_pointer (expr) && ! gfc_has_dimen_vector_ref (expr)
9675 342 : && !(expr->symtree->n.sym->as
9676 324 : && expr->symtree->n.sym->as->type == AS_ASSUMED_RANK)
9677 1906 : && (fsym == NULL || fsym->ts.type != BT_ASSUMED))
9678 : {
9679 321 : gfc_conv_subref_array_arg (se, expr, g77,
9680 145 : fsym ? fsym->attr.intent : INTENT_INOUT,
9681 : false, fsym, proc_name, sym, true);
9682 321 : return;
9683 : }
9684 :
9685 1243 : if (ctree)
9686 : {
9687 96 : packedptr
9688 96 : = gfc_build_addr_expr (NULL_TREE, gfc_create_var (TREE_TYPE (ctree),
9689 : "packed"));
9690 96 : if (fsym)
9691 : {
9692 96 : int pack_mask = 0;
9693 :
9694 : /* Set bit 0 to the mask, when this is an unlimited_poly
9695 : class. */
9696 96 : if (CLASS_DATA (fsym)->ts.u.derived->attr.unlimited_polymorphic)
9697 36 : pack_mask = 1 << 0;
9698 96 : pack_attr = build_int_cst (integer_type_node, pack_mask);
9699 : }
9700 : else
9701 0 : pack_attr = integer_zero_node;
9702 :
9703 96 : gfc_add_expr_to_block (
9704 : &se->pre,
9705 : build_call_expr_loc (input_location, gfor_fndecl_in_pack_class, 4,
9706 : packedptr,
9707 : gfc_build_addr_expr (NULL_TREE, ctree),
9708 96 : size_in_bytes (TREE_TYPE (ctree)), pack_attr));
9709 96 : ptr = gfc_conv_array_data (gfc_class_data_get (packedptr));
9710 96 : se->expr = packedptr;
9711 96 : if (packed)
9712 96 : *packed = packedptr;
9713 : }
9714 : else
9715 : {
9716 1147 : ptr = build_call_expr_loc (input_location, gfor_fndecl_in_pack, 1,
9717 : desc);
9718 :
9719 1147 : if (fsym && fsym->attr.optional && sym && sym->attr.optional)
9720 : {
9721 11 : tmp = gfc_conv_expr_present (sym);
9722 22 : ptr = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
9723 11 : tmp, fold_convert (TREE_TYPE (se->expr), ptr),
9724 11 : fold_convert (TREE_TYPE (se->expr),
9725 : null_pointer_node));
9726 : }
9727 :
9728 1147 : ptr = gfc_evaluate_now (ptr, &se->pre);
9729 : }
9730 :
9731 : /* Use the packed data for the actual argument, except for contiguous arrays,
9732 : where the descriptor's data component is set. */
9733 1243 : if (g77)
9734 1087 : se->expr = ptr;
9735 : else
9736 : {
9737 156 : tmp = build_fold_indirect_ref_loc (input_location, desc);
9738 :
9739 156 : gfc_ss * ss = gfc_walk_expr (expr);
9740 312 : if (!transposed_dims (ss) && expr->rank != -1)
9741 : {
9742 138 : if (!ctree)
9743 48 : gfc_conv_descriptor_data_set (&se->pre, tmp, ptr);
9744 : }
9745 18 : else if (!ctree)
9746 : {
9747 12 : tree old_field, new_field;
9748 12 : tree old_desc = tmp;
9749 12 : tree new_desc = gfc_create_var (TREE_TYPE (old_desc), "arg_desc");
9750 :
9751 12 : old_field = gfc_conv_descriptor_dtype (old_desc);
9752 12 : new_field = gfc_conv_descriptor_dtype (new_desc);
9753 12 : gfc_add_modify (&se->pre, new_field, old_field);
9754 :
9755 12 : if (expr->rank == -1)
9756 : {
9757 12 : tree idx = gfc_create_var (TREE_TYPE (gfc_conv_descriptor_rank
9758 : (old_desc)),
9759 : "idx");
9760 12 : tree stride = gfc_create_var (gfc_array_index_type, "stride");
9761 12 : stmtblock_t loop_body;
9762 :
9763 12 : gfc_conv_descriptor_offset_set (&se->pre, new_desc,
9764 : gfc_index_zero_node);
9765 12 : gfc_conv_descriptor_span_set (&se->pre, new_desc,
9766 : gfc_conv_descriptor_span_get
9767 : (old_desc));
9768 12 : gfc_add_modify (&se->pre, stride, gfc_index_one_node);
9769 :
9770 12 : gfc_init_block (&loop_body);
9771 :
9772 12 : old_field = gfc_conv_descriptor_lbound_get (old_desc, idx);
9773 12 : gfc_conv_descriptor_lbound_set (&loop_body, new_desc, idx,
9774 : old_field);
9775 :
9776 12 : old_field = gfc_conv_descriptor_ubound_get (old_desc, idx);
9777 12 : gfc_conv_descriptor_ubound_set (&loop_body, new_desc, idx,
9778 : old_field);
9779 :
9780 12 : gfc_conv_descriptor_stride_set (&loop_body, new_desc, idx,
9781 : stride);
9782 :
9783 12 : tree offset = fold_build2_loc (input_location, MULT_EXPR,
9784 : gfc_array_index_type, stride,
9785 : gfc_conv_descriptor_lbound_get
9786 : (new_desc, idx));
9787 12 : offset = fold_build2_loc (input_location, MINUS_EXPR,
9788 : gfc_array_index_type,
9789 : gfc_conv_descriptor_offset_get
9790 : (new_desc), offset);
9791 12 : gfc_conv_descriptor_offset_set (&loop_body, new_desc, offset);
9792 :
9793 12 : tree extent = gfc_conv_array_extent_dim
9794 12 : (gfc_conv_descriptor_lbound_get (new_desc, idx),
9795 : gfc_conv_descriptor_ubound_get (new_desc, idx),
9796 : NULL);
9797 12 : extent = fold_build2_loc (input_location, MULT_EXPR,
9798 : gfc_array_index_type, stride,
9799 : extent);
9800 12 : gfc_add_modify (&loop_body, stride, extent);
9801 :
9802 36 : gfc_simple_for_loop (&se->pre, idx,
9803 12 : build_int_cst (TREE_TYPE (idx), 0),
9804 : gfc_conv_descriptor_rank (old_desc),
9805 : LT_EXPR,
9806 12 : build_int_cst (TREE_TYPE (idx), 1),
9807 : gfc_finish_block (&loop_body));
9808 : }
9809 : else
9810 : {
9811 : /* The original descriptor has transposed dims so we can't
9812 : reuse it directly; we have to create a new one. */
9813 0 : old_field = gfc_conv_descriptor_offset_get (old_desc);
9814 0 : gfc_conv_descriptor_offset_set (&se->pre, new_desc, old_field);
9815 :
9816 0 : for (int i = 0; i < expr->rank; i++)
9817 : {
9818 0 : old_field = gfc_conv_descriptor_dimension (old_desc,
9819 0 : gfc_rank_cst[get_array_ref_dim_for_loop_dim (ss, i)]);
9820 0 : new_field = gfc_conv_descriptor_dimension (new_desc,
9821 : gfc_rank_cst[i]);
9822 0 : gfc_add_modify (&se->pre, new_field, old_field);
9823 : }
9824 : }
9825 :
9826 12 : if (flag_coarray == GFC_FCOARRAY_LIB
9827 0 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (old_desc))
9828 12 : && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (old_desc))
9829 : == GFC_ARRAY_ALLOCATABLE)
9830 : {
9831 0 : old_field = gfc_conv_descriptor_token (old_desc);
9832 0 : new_field = gfc_conv_descriptor_token (new_desc);
9833 0 : gfc_add_modify (&se->pre, new_field, old_field);
9834 : }
9835 :
9836 12 : gfc_conv_descriptor_data_set (&se->pre, new_desc, ptr);
9837 12 : se->expr = gfc_build_addr_expr (NULL_TREE, new_desc);
9838 : }
9839 156 : gfc_free_ss (ss);
9840 : }
9841 :
9842 1243 : if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
9843 : {
9844 8 : char * msg;
9845 :
9846 8 : if (fsym && proc_name)
9847 8 : msg = xasprintf ("An array temporary was created for argument "
9848 8 : "'%s' of procedure '%s'", fsym->name, proc_name);
9849 : else
9850 0 : msg = xasprintf ("An array temporary was created");
9851 :
9852 8 : tmp = build_fold_indirect_ref_loc (input_location,
9853 : desc);
9854 8 : tmp = gfc_conv_array_data (tmp);
9855 8 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9856 8 : fold_convert (TREE_TYPE (tmp), ptr), tmp);
9857 :
9858 8 : if (pass_optional)
9859 6 : tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
9860 : logical_type_node,
9861 : gfc_conv_expr_present (sym), tmp);
9862 :
9863 8 : gfc_trans_runtime_check (false, true, tmp, &se->pre,
9864 : &expr->where, msg);
9865 8 : free (msg);
9866 : }
9867 :
9868 1243 : gfc_start_block (&block);
9869 :
9870 : /* Copy the data back. If input expr is read-only, e.g. a PARAMETER
9871 : array, copying back modified values is undefined behavior. */
9872 2486 : readonly = (expr->expr_type == EXPR_VARIABLE
9873 850 : && expr->symtree
9874 2093 : && expr->symtree->n.sym->attr.flavor == FL_PARAMETER);
9875 :
9876 1243 : if ((fsym == NULL || fsym->attr.intent != INTENT_IN) && !readonly)
9877 : {
9878 1110 : if (ctree)
9879 : {
9880 66 : tmp = gfc_build_addr_expr (NULL_TREE, ctree);
9881 66 : tmp = build_call_expr_loc (input_location,
9882 : gfor_fndecl_in_unpack_class, 4, tmp,
9883 : packedptr,
9884 66 : size_in_bytes (TREE_TYPE (ctree)),
9885 : pack_attr);
9886 : }
9887 : else
9888 1044 : tmp = build_call_expr_loc (input_location, gfor_fndecl_in_unpack, 2,
9889 : desc, ptr);
9890 1110 : gfc_add_expr_to_block (&block, tmp);
9891 : }
9892 133 : else if (ctree && fsym->attr.intent == INTENT_IN)
9893 : {
9894 : /* Need to free the memory for class arrays, that got packed. */
9895 30 : gfc_add_expr_to_block (&block, gfc_call_free (ptr));
9896 : }
9897 :
9898 : /* Free the temporary. */
9899 1140 : if (!ctree)
9900 1147 : gfc_add_expr_to_block (&block, gfc_call_free (ptr));
9901 :
9902 1243 : stmt = gfc_finish_block (&block);
9903 :
9904 1243 : gfc_init_block (&block);
9905 : /* Only if it was repacked. This code needs to be executed before the
9906 : loop cleanup code. */
9907 1243 : tmp = (ctree) ? desc : build_fold_indirect_ref_loc (input_location, desc);
9908 1243 : tmp = gfc_conv_array_data (tmp);
9909 1243 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9910 1243 : fold_convert (TREE_TYPE (tmp), ptr), tmp);
9911 :
9912 1243 : if (pass_optional)
9913 11 : tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
9914 : logical_type_node,
9915 : gfc_conv_expr_present (sym), tmp);
9916 :
9917 1243 : tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
9918 :
9919 1243 : gfc_add_expr_to_block (&block, tmp);
9920 1243 : gfc_add_block_to_block (&block, &se->post);
9921 :
9922 1243 : gfc_init_block (&se->post);
9923 :
9924 : /* Reset the descriptor pointer. */
9925 1243 : if (!g77 && !ctree)
9926 : {
9927 60 : tmp = build_fold_indirect_ref_loc (input_location, desc);
9928 60 : gfc_conv_descriptor_data_set (&se->post, tmp, origptr);
9929 : }
9930 :
9931 1243 : gfc_add_block_to_block (&se->post, &block);
9932 : }
9933 : }
9934 :
9935 :
9936 : /* This helper function calculates the size in words of a full array. */
9937 :
9938 : tree
9939 20433 : gfc_full_array_size (stmtblock_t *block, tree decl, int rank)
9940 : {
9941 20433 : tree idx;
9942 20433 : tree nelems;
9943 20433 : tree tmp;
9944 20433 : if (rank < 0)
9945 0 : idx = gfc_conv_descriptor_rank (decl);
9946 : else
9947 20433 : idx = gfc_rank_cst[rank - 1];
9948 20433 : nelems = gfc_conv_descriptor_ubound_get (decl, idx);
9949 20433 : tmp = gfc_conv_descriptor_lbound_get (decl, idx);
9950 20433 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
9951 : nelems, tmp);
9952 20433 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
9953 : tmp, gfc_index_one_node);
9954 20433 : tmp = gfc_evaluate_now (tmp, block);
9955 :
9956 20433 : nelems = gfc_conv_descriptor_stride_get (decl, idx);
9957 20433 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9958 : nelems, tmp);
9959 20433 : return gfc_evaluate_now (tmp, block);
9960 : }
9961 :
9962 :
9963 : /* Allocate dest to the same size as src, and copy src -> dest.
9964 : If no_malloc is set, only the copy is done. */
9965 :
9966 : static tree
9967 9781 : duplicate_allocatable (tree dest, tree src, tree type, int rank,
9968 : bool no_malloc, bool no_memcpy, tree str_sz,
9969 : tree add_when_allocated)
9970 : {
9971 9781 : tree tmp;
9972 9781 : tree eltype;
9973 9781 : tree size;
9974 9781 : tree nelems;
9975 9781 : tree null_cond;
9976 9781 : tree null_data;
9977 9781 : stmtblock_t block;
9978 :
9979 : /* If the source is null, set the destination to null. Then,
9980 : allocate memory to the destination. */
9981 9781 : gfc_init_block (&block);
9982 :
9983 9781 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
9984 : {
9985 2212 : gfc_add_modify (&block, dest, fold_convert (type, null_pointer_node));
9986 2212 : null_data = gfc_finish_block (&block);
9987 :
9988 2212 : gfc_init_block (&block);
9989 2212 : eltype = TREE_TYPE (type);
9990 2212 : if (str_sz != NULL_TREE)
9991 : size = str_sz;
9992 : else
9993 1868 : size = TYPE_SIZE_UNIT (eltype);
9994 :
9995 2212 : if (!no_malloc)
9996 : {
9997 2212 : tmp = gfc_call_malloc (&block, type, size);
9998 2212 : gfc_add_modify (&block, dest, fold_convert (type, tmp));
9999 : }
10000 :
10001 2212 : if (!no_memcpy)
10002 : {
10003 1787 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
10004 1787 : tmp = build_call_expr_loc (input_location, tmp, 3, dest, src,
10005 : fold_convert (size_type_node, size));
10006 1787 : gfc_add_expr_to_block (&block, tmp);
10007 : }
10008 : }
10009 : else
10010 : {
10011 7569 : gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
10012 7569 : null_data = gfc_finish_block (&block);
10013 :
10014 7569 : gfc_init_block (&block);
10015 7569 : if (rank)
10016 7554 : nelems = gfc_full_array_size (&block, src, rank);
10017 : else
10018 15 : nelems = gfc_index_one_node;
10019 :
10020 : /* If type is not the array type, then it is the element type. */
10021 7569 : if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type))
10022 7539 : eltype = gfc_get_element_type (type);
10023 : else
10024 : eltype = type;
10025 :
10026 7569 : if (str_sz != NULL_TREE)
10027 43 : tmp = fold_convert (gfc_array_index_type, str_sz);
10028 : else
10029 7526 : tmp = fold_convert (gfc_array_index_type,
10030 : TYPE_SIZE_UNIT (eltype));
10031 :
10032 7569 : tmp = gfc_evaluate_now (tmp, &block);
10033 7569 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
10034 : nelems, tmp);
10035 7569 : if (!no_malloc)
10036 : {
10037 7501 : tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src));
10038 7501 : tmp = gfc_call_malloc (&block, tmp, size);
10039 7501 : gfc_conv_descriptor_data_set (&block, dest, tmp);
10040 : }
10041 :
10042 : /* We know the temporary and the value will be the same length,
10043 : so can use memcpy. */
10044 7569 : if (!no_memcpy)
10045 : {
10046 6208 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
10047 6208 : tmp = build_call_expr_loc (input_location, tmp, 3,
10048 : gfc_conv_descriptor_data_get (dest),
10049 : gfc_conv_descriptor_data_get (src),
10050 : fold_convert (size_type_node, size));
10051 6208 : gfc_add_expr_to_block (&block, tmp);
10052 : }
10053 : }
10054 :
10055 9781 : gfc_add_expr_to_block (&block, add_when_allocated);
10056 9781 : tmp = gfc_finish_block (&block);
10057 :
10058 : /* Null the destination if the source is null; otherwise do
10059 : the allocate and copy. */
10060 9781 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src)))
10061 : null_cond = src;
10062 : else
10063 7569 : null_cond = gfc_conv_descriptor_data_get (src);
10064 :
10065 9781 : null_cond = convert (pvoid_type_node, null_cond);
10066 9781 : null_cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10067 : null_cond, null_pointer_node);
10068 9781 : return build3_v (COND_EXPR, null_cond, tmp, null_data);
10069 : }
10070 :
10071 :
10072 : /* Allocate dest to the same size as src, and copy data src -> dest. */
10073 :
10074 : tree
10075 7383 : gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank,
10076 : tree add_when_allocated)
10077 : {
10078 7383 : return duplicate_allocatable (dest, src, type, rank, false, false,
10079 7383 : NULL_TREE, add_when_allocated);
10080 : }
10081 :
10082 :
10083 : /* Copy data src -> dest. */
10084 :
10085 : tree
10086 68 : gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
10087 : {
10088 68 : return duplicate_allocatable (dest, src, type, rank, true, false,
10089 68 : NULL_TREE, NULL_TREE);
10090 : }
10091 :
10092 : /* Allocate dest to the same size as src, but don't copy anything. */
10093 :
10094 : tree
10095 1786 : gfc_duplicate_allocatable_nocopy (tree dest, tree src, tree type, int rank)
10096 : {
10097 1786 : return duplicate_allocatable (dest, src, type, rank, false, true,
10098 1786 : NULL_TREE, NULL_TREE);
10099 : }
10100 :
10101 : static tree
10102 62 : duplicate_allocatable_coarray (tree dest, tree dest_tok, tree src, tree type,
10103 : int rank, tree add_when_allocated)
10104 : {
10105 62 : tree tmp;
10106 62 : tree size;
10107 62 : tree nelems;
10108 62 : tree null_cond;
10109 62 : tree null_data;
10110 62 : stmtblock_t block, globalblock;
10111 :
10112 : /* If the source is null, set the destination to null. Then,
10113 : allocate memory to the destination. */
10114 62 : gfc_init_block (&block);
10115 62 : gfc_init_block (&globalblock);
10116 :
10117 62 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
10118 : {
10119 18 : gfc_se se;
10120 18 : symbol_attribute attr;
10121 18 : tree dummy_desc;
10122 :
10123 18 : gfc_init_se (&se, NULL);
10124 18 : gfc_clear_attr (&attr);
10125 18 : attr.allocatable = 1;
10126 18 : dummy_desc = gfc_conv_scalar_to_descriptor (&se, dest, attr);
10127 18 : gfc_add_block_to_block (&globalblock, &se.pre);
10128 18 : size = TYPE_SIZE_UNIT (TREE_TYPE (type));
10129 :
10130 18 : gfc_add_modify (&block, dest, fold_convert (type, null_pointer_node));
10131 18 : gfc_allocate_using_caf_lib (&block, dummy_desc, size,
10132 : gfc_build_addr_expr (NULL_TREE, dest_tok),
10133 : NULL_TREE, NULL_TREE, NULL_TREE,
10134 : GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
10135 18 : gfc_add_modify (&block, dest, gfc_conv_descriptor_data_get (dummy_desc));
10136 18 : null_data = gfc_finish_block (&block);
10137 :
10138 18 : gfc_init_block (&block);
10139 :
10140 18 : gfc_allocate_using_caf_lib (&block, dummy_desc,
10141 : fold_convert (size_type_node, size),
10142 : gfc_build_addr_expr (NULL_TREE, dest_tok),
10143 : NULL_TREE, NULL_TREE, NULL_TREE,
10144 : GFC_CAF_COARRAY_ALLOC);
10145 18 : gfc_add_modify (&block, dest, gfc_conv_descriptor_data_get (dummy_desc));
10146 :
10147 18 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
10148 18 : tmp = build_call_expr_loc (input_location, tmp, 3, dest, src,
10149 : fold_convert (size_type_node, size));
10150 18 : gfc_add_expr_to_block (&block, tmp);
10151 : }
10152 : else
10153 : {
10154 : /* Set the rank or uninitialized memory access may be reported. */
10155 44 : tmp = gfc_conv_descriptor_rank (dest);
10156 44 : gfc_add_modify (&globalblock, tmp, build_int_cst (TREE_TYPE (tmp), rank));
10157 :
10158 44 : if (rank)
10159 44 : nelems = gfc_full_array_size (&globalblock, src, rank);
10160 : else
10161 0 : nelems = integer_one_node;
10162 :
10163 44 : tmp = fold_convert (size_type_node,
10164 : TYPE_SIZE_UNIT (gfc_get_element_type (type)));
10165 44 : size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
10166 : fold_convert (size_type_node, nelems), tmp);
10167 :
10168 44 : gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
10169 44 : gfc_allocate_using_caf_lib (&block, dest, fold_convert (size_type_node,
10170 : size),
10171 : gfc_build_addr_expr (NULL_TREE, dest_tok),
10172 : NULL_TREE, NULL_TREE, NULL_TREE,
10173 : GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
10174 44 : null_data = gfc_finish_block (&block);
10175 :
10176 44 : gfc_init_block (&block);
10177 44 : gfc_allocate_using_caf_lib (&block, dest,
10178 : fold_convert (size_type_node, size),
10179 : gfc_build_addr_expr (NULL_TREE, dest_tok),
10180 : NULL_TREE, NULL_TREE, NULL_TREE,
10181 : GFC_CAF_COARRAY_ALLOC);
10182 :
10183 44 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
10184 44 : tmp = build_call_expr_loc (input_location, tmp, 3,
10185 : gfc_conv_descriptor_data_get (dest),
10186 : gfc_conv_descriptor_data_get (src),
10187 : fold_convert (size_type_node, size));
10188 44 : gfc_add_expr_to_block (&block, tmp);
10189 : }
10190 62 : gfc_add_expr_to_block (&block, add_when_allocated);
10191 62 : tmp = gfc_finish_block (&block);
10192 :
10193 : /* Null the destination if the source is null; otherwise do
10194 : the register and copy. */
10195 62 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src)))
10196 : null_cond = src;
10197 : else
10198 44 : null_cond = gfc_conv_descriptor_data_get (src);
10199 :
10200 62 : null_cond = convert (pvoid_type_node, null_cond);
10201 62 : null_cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10202 : null_cond, null_pointer_node);
10203 62 : gfc_add_expr_to_block (&globalblock, build3_v (COND_EXPR, null_cond, tmp,
10204 : null_data));
10205 62 : return gfc_finish_block (&globalblock);
10206 : }
10207 :
10208 :
10209 : /* Helper function to abstract whether coarray processing is enabled. */
10210 :
10211 : static bool
10212 75 : caf_enabled (int caf_mode)
10213 : {
10214 75 : return (caf_mode & GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY)
10215 75 : == GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY;
10216 : }
10217 :
10218 :
10219 : /* Helper function to abstract whether coarray processing is enabled
10220 : and we are in a derived type coarray. */
10221 :
10222 : static bool
10223 10994 : caf_in_coarray (int caf_mode)
10224 : {
10225 10994 : static const int pat = GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
10226 : | GFC_STRUCTURE_CAF_MODE_IN_COARRAY;
10227 10994 : return (caf_mode & pat) == pat;
10228 : }
10229 :
10230 :
10231 : /* Helper function to abstract whether coarray is to deallocate only. */
10232 :
10233 : bool
10234 352 : gfc_caf_is_dealloc_only (int caf_mode)
10235 : {
10236 352 : return (caf_mode & GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY)
10237 352 : == GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY;
10238 : }
10239 :
10240 :
10241 : /* Recursively traverse an object of derived type, generating code to
10242 : deallocate, nullify or copy allocatable components. This is the work horse
10243 : function for the functions named in this enum. */
10244 :
10245 : enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP,
10246 : COPY_ALLOC_COMP, COPY_ONLY_ALLOC_COMP, REASSIGN_CAF_COMP,
10247 : ALLOCATE_PDT_COMP, DEALLOCATE_PDT_COMP, CHECK_PDT_DUMMY,
10248 : BCAST_ALLOC_COMP};
10249 :
10250 : static gfc_actual_arglist *pdt_param_list;
10251 : static bool generating_copy_helper;
10252 : static hash_set<gfc_symbol *> seen_derived_types;
10253 :
10254 : /* Forward declaration of structure_alloc_comps for wrapper generator. */
10255 : static tree structure_alloc_comps (gfc_symbol *, tree, tree, int, int, int,
10256 : gfc_co_subroutines_args *, bool);
10257 :
10258 : /* Generate a wrapper function that performs element-wise deep copy for
10259 : recursive allocatable array components. This wrapper is passed as a
10260 : function pointer to the runtime helper _gfortran_cfi_deep_copy_array,
10261 : allowing recursion to happen at runtime instead of compile time. */
10262 :
10263 : static tree
10264 256 : get_copy_helper_function_type (void)
10265 : {
10266 256 : static tree fn_type = NULL_TREE;
10267 256 : if (fn_type == NULL_TREE)
10268 29 : fn_type = build_function_type_list (void_type_node,
10269 : pvoid_type_node,
10270 : pvoid_type_node,
10271 : NULL_TREE);
10272 256 : return fn_type;
10273 : }
10274 :
10275 : static tree
10276 1157 : get_copy_helper_pointer_type (void)
10277 : {
10278 1157 : static tree ptr_type = NULL_TREE;
10279 1157 : if (ptr_type == NULL_TREE)
10280 29 : ptr_type = build_pointer_type (get_copy_helper_function_type ());
10281 1157 : return ptr_type;
10282 : }
10283 :
10284 : static tree
10285 227 : generate_element_copy_wrapper (gfc_symbol *der_type, tree comp_type,
10286 : int purpose, int caf_mode)
10287 : {
10288 227 : tree fndecl, fntype, result_decl;
10289 227 : tree dest_parm, src_parm, dest_typed, src_typed;
10290 227 : tree der_type_ptr;
10291 227 : stmtblock_t block;
10292 227 : tree decls;
10293 227 : tree body;
10294 :
10295 227 : fntype = get_copy_helper_function_type ();
10296 :
10297 227 : fndecl = build_decl (input_location, FUNCTION_DECL,
10298 : create_tmp_var_name ("copy_element"),
10299 : fntype);
10300 :
10301 227 : TREE_STATIC (fndecl) = 1;
10302 227 : TREE_USED (fndecl) = 1;
10303 227 : DECL_ARTIFICIAL (fndecl) = 1;
10304 227 : DECL_IGNORED_P (fndecl) = 0;
10305 227 : TREE_PUBLIC (fndecl) = 0;
10306 227 : DECL_UNINLINABLE (fndecl) = 1;
10307 227 : DECL_EXTERNAL (fndecl) = 0;
10308 227 : DECL_CONTEXT (fndecl) = NULL_TREE;
10309 227 : DECL_INITIAL (fndecl) = make_node (BLOCK);
10310 227 : BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
10311 :
10312 227 : result_decl = build_decl (input_location, RESULT_DECL, NULL_TREE,
10313 : void_type_node);
10314 227 : DECL_ARTIFICIAL (result_decl) = 1;
10315 227 : DECL_IGNORED_P (result_decl) = 1;
10316 227 : DECL_CONTEXT (result_decl) = fndecl;
10317 227 : DECL_RESULT (fndecl) = result_decl;
10318 :
10319 227 : dest_parm = build_decl (input_location, PARM_DECL,
10320 : get_identifier ("dest"), pvoid_type_node);
10321 227 : src_parm = build_decl (input_location, PARM_DECL,
10322 : get_identifier ("src"), pvoid_type_node);
10323 :
10324 227 : DECL_ARTIFICIAL (dest_parm) = 1;
10325 227 : DECL_ARTIFICIAL (src_parm) = 1;
10326 227 : DECL_ARG_TYPE (dest_parm) = pvoid_type_node;
10327 227 : DECL_ARG_TYPE (src_parm) = pvoid_type_node;
10328 227 : DECL_CONTEXT (dest_parm) = fndecl;
10329 227 : DECL_CONTEXT (src_parm) = fndecl;
10330 :
10331 227 : DECL_ARGUMENTS (fndecl) = dest_parm;
10332 227 : TREE_CHAIN (dest_parm) = src_parm;
10333 :
10334 227 : push_struct_function (fndecl);
10335 227 : cfun->function_end_locus = input_location;
10336 :
10337 227 : pushlevel ();
10338 227 : gfc_init_block (&block);
10339 :
10340 227 : bool saved_generating = generating_copy_helper;
10341 227 : generating_copy_helper = true;
10342 :
10343 : /* When generating a wrapper, we need a fresh type tracking state to
10344 : avoid inheriting the parent context's seen_derived_types, which would
10345 : cause infinite recursion when the wrapper tries to handle the same
10346 : recursive type. Save elements, clear the set, generate wrapper, then
10347 : restore elements. */
10348 227 : vec<gfc_symbol *> saved_symbols = vNULL;
10349 227 : for (hash_set<gfc_symbol *>::iterator it = seen_derived_types.begin ();
10350 973 : it != seen_derived_types.end (); ++it)
10351 373 : saved_symbols.safe_push (*it);
10352 227 : seen_derived_types.empty ();
10353 :
10354 227 : der_type_ptr = build_pointer_type (comp_type);
10355 227 : dest_typed = fold_convert (der_type_ptr, dest_parm);
10356 227 : src_typed = fold_convert (der_type_ptr, src_parm);
10357 :
10358 227 : dest_typed = build_fold_indirect_ref (dest_typed);
10359 227 : src_typed = build_fold_indirect_ref (src_typed);
10360 :
10361 227 : body = structure_alloc_comps (der_type, src_typed, dest_typed,
10362 : 0, purpose, caf_mode, NULL, false);
10363 227 : gfc_add_expr_to_block (&block, body);
10364 :
10365 : /* Restore saved symbols. */
10366 227 : seen_derived_types.empty ();
10367 600 : for (unsigned i = 0; i < saved_symbols.length (); i++)
10368 373 : seen_derived_types.add (saved_symbols[i]);
10369 227 : saved_symbols.release ();
10370 227 : generating_copy_helper = saved_generating;
10371 :
10372 227 : body = gfc_finish_block (&block);
10373 227 : decls = getdecls ();
10374 :
10375 227 : poplevel (1, 1);
10376 :
10377 454 : DECL_SAVED_TREE (fndecl)
10378 227 : = fold_build3_loc (DECL_SOURCE_LOCATION (fndecl), BIND_EXPR,
10379 227 : void_type_node, decls, body, DECL_INITIAL (fndecl));
10380 :
10381 227 : pop_cfun ();
10382 :
10383 : /* Use finalize_function with no_collect=true to skip the ggc_collect
10384 : call that add_new_function would trigger. This function is called
10385 : during tree lowering of structure_alloc_comps where caller stack
10386 : frames hold locally-computed tree nodes (COMPONENT_REFs etc.) that
10387 : are not yet attached to any GC root. A collection at this point
10388 : would free those nodes and cause segfaults. PR124235. */
10389 227 : cgraph_node::finalize_function (fndecl, true);
10390 :
10391 227 : return build1 (ADDR_EXPR, get_copy_helper_pointer_type (), fndecl);
10392 : }
10393 :
10394 : static tree
10395 22246 : structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
10396 : int rank, int purpose, int caf_mode,
10397 : gfc_co_subroutines_args *args,
10398 : bool no_finalization = false)
10399 : {
10400 22246 : gfc_component *c;
10401 22246 : gfc_loopinfo loop;
10402 22246 : stmtblock_t fnblock;
10403 22246 : stmtblock_t loopbody;
10404 22246 : stmtblock_t tmpblock;
10405 22246 : tree decl_type;
10406 22246 : tree tmp;
10407 22246 : tree comp;
10408 22246 : tree dcmp;
10409 22246 : tree nelems;
10410 22246 : tree index;
10411 22246 : tree var;
10412 22246 : tree cdecl;
10413 22246 : tree ctype;
10414 22246 : tree vref, dref;
10415 22246 : tree null_cond = NULL_TREE;
10416 22246 : tree add_when_allocated;
10417 22246 : tree dealloc_fndecl;
10418 22246 : tree caf_token;
10419 22246 : gfc_symbol *vtab;
10420 22246 : int caf_dereg_mode;
10421 22246 : symbol_attribute *attr;
10422 22246 : bool deallocate_called;
10423 :
10424 22246 : gfc_init_block (&fnblock);
10425 :
10426 22246 : decl_type = TREE_TYPE (decl);
10427 :
10428 22246 : if ((POINTER_TYPE_P (decl_type))
10429 : || (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == 0))
10430 : {
10431 1519 : decl = build_fold_indirect_ref_loc (input_location, decl);
10432 : /* Deref dest in sync with decl, but only when it is not NULL. */
10433 1519 : if (dest)
10434 110 : dest = build_fold_indirect_ref_loc (input_location, dest);
10435 :
10436 : /* Update the decl_type because it got dereferenced. */
10437 1519 : decl_type = TREE_TYPE (decl);
10438 : }
10439 :
10440 : /* If this is an array of derived types with allocatable components
10441 : build a loop and recursively call this function. */
10442 22246 : if (TREE_CODE (decl_type) == ARRAY_TYPE
10443 22246 : || (GFC_DESCRIPTOR_TYPE_P (decl_type) && rank != 0))
10444 : {
10445 4119 : tmp = gfc_conv_array_data (decl);
10446 4119 : var = build_fold_indirect_ref_loc (input_location, tmp);
10447 :
10448 : /* Get the number of elements - 1 and set the counter. */
10449 4119 : if (GFC_DESCRIPTOR_TYPE_P (decl_type))
10450 : {
10451 : /* Use the descriptor for an allocatable array. Since this
10452 : is a full array reference, we only need the descriptor
10453 : information from dimension = rank. */
10454 2873 : tmp = gfc_full_array_size (&fnblock, decl, rank);
10455 2873 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
10456 : gfc_array_index_type, tmp,
10457 : gfc_index_one_node);
10458 :
10459 2873 : null_cond = gfc_conv_descriptor_data_get (decl);
10460 2873 : null_cond = fold_build2_loc (input_location, NE_EXPR,
10461 : logical_type_node, null_cond,
10462 2873 : build_int_cst (TREE_TYPE (null_cond), 0));
10463 : }
10464 : else
10465 : {
10466 : /* Otherwise use the TYPE_DOMAIN information. */
10467 1246 : tmp = array_type_nelts_minus_one (decl_type);
10468 1246 : tmp = fold_convert (gfc_array_index_type, tmp);
10469 : }
10470 :
10471 : /* Remember that this is, in fact, the no. of elements - 1. */
10472 4119 : nelems = gfc_evaluate_now (tmp, &fnblock);
10473 4119 : index = gfc_create_var (gfc_array_index_type, "S");
10474 :
10475 : /* Build the body of the loop. */
10476 4119 : gfc_init_block (&loopbody);
10477 :
10478 4119 : vref = gfc_build_array_ref (var, index, NULL);
10479 :
10480 4119 : if (purpose == COPY_ALLOC_COMP || purpose == COPY_ONLY_ALLOC_COMP)
10481 : {
10482 981 : tmp = build_fold_indirect_ref_loc (input_location,
10483 : gfc_conv_array_data (dest));
10484 981 : dref = gfc_build_array_ref (tmp, index, NULL);
10485 981 : tmp = structure_alloc_comps (der_type, vref, dref, rank,
10486 : COPY_ALLOC_COMP, caf_mode, args,
10487 : no_finalization);
10488 : }
10489 : else
10490 3138 : tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose,
10491 : caf_mode, args, no_finalization);
10492 :
10493 4119 : gfc_add_expr_to_block (&loopbody, tmp);
10494 :
10495 : /* Build the loop and return. */
10496 4119 : gfc_init_loopinfo (&loop);
10497 4119 : loop.dimen = 1;
10498 4119 : loop.from[0] = gfc_index_zero_node;
10499 4119 : loop.loopvar[0] = index;
10500 4119 : loop.to[0] = nelems;
10501 4119 : gfc_trans_scalarizing_loops (&loop, &loopbody);
10502 4119 : gfc_add_block_to_block (&fnblock, &loop.pre);
10503 :
10504 4119 : tmp = gfc_finish_block (&fnblock);
10505 : /* When copying allocateable components, the above implements the
10506 : deep copy. Nevertheless is a deep copy only allowed, when the current
10507 : component is allocated, for which code will be generated in
10508 : gfc_duplicate_allocatable (), where the deep copy code is just added
10509 : into the if's body, by adding tmp (the deep copy code) as last
10510 : argument to gfc_duplicate_allocatable (). */
10511 4119 : if (purpose == COPY_ALLOC_COMP && caf_mode == 0
10512 4119 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
10513 728 : tmp = gfc_duplicate_allocatable (dest, decl, decl_type, rank,
10514 : tmp);
10515 3391 : else if (null_cond != NULL_TREE)
10516 2145 : tmp = build3_v (COND_EXPR, null_cond, tmp,
10517 : build_empty_stmt (input_location));
10518 :
10519 4119 : return tmp;
10520 : }
10521 :
10522 18127 : if (purpose == DEALLOCATE_ALLOC_COMP && der_type->attr.pdt_type)
10523 : {
10524 295 : tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
10525 : DEALLOCATE_PDT_COMP, 0, args,
10526 : no_finalization);
10527 295 : gfc_add_expr_to_block (&fnblock, tmp);
10528 : }
10529 17832 : else if (purpose == ALLOCATE_PDT_COMP && der_type->attr.alloc_comp)
10530 : {
10531 125 : tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
10532 : NULLIFY_ALLOC_COMP, 0, args,
10533 : no_finalization);
10534 125 : gfc_add_expr_to_block (&fnblock, tmp);
10535 : }
10536 :
10537 : /* Still having a descriptor array of rank == 0 here, indicates an
10538 : allocatable coarrays. Dereference it correctly. */
10539 18127 : if (GFC_DESCRIPTOR_TYPE_P (decl_type))
10540 : {
10541 5 : decl = build_fold_indirect_ref (gfc_conv_array_data (decl));
10542 : }
10543 : /* Otherwise, act on the components or recursively call self to
10544 : act on a chain of components. */
10545 18127 : seen_derived_types.add (der_type);
10546 52166 : for (c = der_type->components; c; c = c->next)
10547 : {
10548 34039 : bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED
10549 34039 : || c->ts.type == BT_CLASS)
10550 34039 : && c->ts.u.derived->attr.alloc_comp;
10551 34039 : bool same_type
10552 : = (c->ts.type == BT_DERIVED
10553 8317 : && seen_derived_types.contains (c->ts.u.derived))
10554 39705 : || (c->ts.type == BT_CLASS
10555 2242 : && seen_derived_types.contains (CLASS_DATA (c)->ts.u.derived));
10556 34039 : bool inside_wrapper = generating_copy_helper;
10557 :
10558 34039 : bool is_pdt_type = IS_PDT (c);
10559 :
10560 34039 : cdecl = c->backend_decl;
10561 34039 : ctype = TREE_TYPE (cdecl);
10562 :
10563 34039 : switch (purpose)
10564 : {
10565 :
10566 3 : case BCAST_ALLOC_COMP:
10567 :
10568 3 : tree ubound;
10569 3 : tree cdesc;
10570 3 : stmtblock_t derived_type_block;
10571 :
10572 3 : gfc_init_block (&tmpblock);
10573 :
10574 3 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10575 : decl, cdecl, NULL_TREE);
10576 :
10577 : /* Shortcut to get the attributes of the component. */
10578 3 : if (c->ts.type == BT_CLASS)
10579 : {
10580 0 : attr = &CLASS_DATA (c)->attr;
10581 0 : if (attr->class_pointer)
10582 0 : continue;
10583 : }
10584 : else
10585 : {
10586 3 : attr = &c->attr;
10587 3 : if (attr->pointer)
10588 0 : continue;
10589 : }
10590 :
10591 : /* Do not broadcast a caf_token. These are local to the image. */
10592 3 : if (attr->caf_token)
10593 1 : continue;
10594 :
10595 2 : add_when_allocated = NULL_TREE;
10596 2 : if (cmp_has_alloc_comps
10597 0 : && !c->attr.pointer && !c->attr.proc_pointer)
10598 : {
10599 0 : if (c->ts.type == BT_CLASS)
10600 : {
10601 0 : rank = CLASS_DATA (c)->as ? CLASS_DATA (c)->as->rank : 0;
10602 0 : add_when_allocated
10603 0 : = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
10604 : comp, NULL_TREE, rank, purpose,
10605 : caf_mode, args, no_finalization);
10606 : }
10607 : else
10608 : {
10609 0 : rank = c->as ? c->as->rank : 0;
10610 0 : add_when_allocated = structure_alloc_comps (c->ts.u.derived,
10611 : comp, NULL_TREE,
10612 : rank, purpose,
10613 : caf_mode, args,
10614 : no_finalization);
10615 : }
10616 : }
10617 :
10618 2 : gfc_init_block (&derived_type_block);
10619 2 : if (add_when_allocated)
10620 0 : gfc_add_expr_to_block (&derived_type_block, add_when_allocated);
10621 2 : tmp = gfc_finish_block (&derived_type_block);
10622 2 : gfc_add_expr_to_block (&tmpblock, tmp);
10623 :
10624 : /* Convert the component into a rank 1 descriptor type. */
10625 2 : if (attr->dimension)
10626 : {
10627 0 : tmp = gfc_get_element_type (TREE_TYPE (comp));
10628 0 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
10629 0 : ubound = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (comp));
10630 : else
10631 0 : ubound = gfc_full_array_size (&tmpblock, comp,
10632 0 : c->ts.type == BT_CLASS
10633 0 : ? CLASS_DATA (c)->as->rank
10634 0 : : c->as->rank);
10635 : }
10636 : else
10637 : {
10638 2 : tmp = TREE_TYPE (comp);
10639 2 : ubound = build_int_cst (gfc_array_index_type, 1);
10640 : }
10641 :
10642 : /* Treat strings like arrays. Or the other way around, do not
10643 : * generate an additional array layer for scalar components. */
10644 2 : if (attr->dimension || c->ts.type == BT_CHARACTER)
10645 : {
10646 0 : cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node,
10647 : &ubound, 1,
10648 : GFC_ARRAY_ALLOCATABLE, false);
10649 :
10650 0 : cdesc = gfc_create_var (cdesc, "cdesc");
10651 0 : DECL_ARTIFICIAL (cdesc) = 1;
10652 :
10653 0 : gfc_add_modify (&tmpblock, gfc_conv_descriptor_dtype (cdesc),
10654 : gfc_get_dtype_rank_type (1, tmp));
10655 0 : gfc_conv_descriptor_lbound_set (&tmpblock, cdesc,
10656 : gfc_index_zero_node,
10657 : gfc_index_one_node);
10658 0 : gfc_conv_descriptor_stride_set (&tmpblock, cdesc,
10659 : gfc_index_zero_node,
10660 : gfc_index_one_node);
10661 0 : gfc_conv_descriptor_ubound_set (&tmpblock, cdesc,
10662 : gfc_index_zero_node, ubound);
10663 : }
10664 : else
10665 : /* Prevent warning. */
10666 : cdesc = NULL_TREE;
10667 :
10668 2 : if (attr->dimension)
10669 : {
10670 0 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
10671 0 : comp = gfc_conv_descriptor_data_get (comp);
10672 : else
10673 0 : comp = gfc_build_addr_expr (NULL_TREE, comp);
10674 : }
10675 : else
10676 : {
10677 2 : gfc_se se;
10678 :
10679 2 : gfc_init_se (&se, NULL);
10680 :
10681 2 : comp = gfc_conv_scalar_to_descriptor (&se, comp,
10682 2 : c->ts.type == BT_CLASS
10683 2 : ? CLASS_DATA (c)->attr
10684 : : c->attr);
10685 2 : if (c->ts.type == BT_CHARACTER)
10686 0 : comp = gfc_build_addr_expr (NULL_TREE, comp);
10687 2 : gfc_add_block_to_block (&tmpblock, &se.pre);
10688 : }
10689 :
10690 2 : if (attr->dimension || c->ts.type == BT_CHARACTER)
10691 0 : gfc_conv_descriptor_data_set (&tmpblock, cdesc, comp);
10692 : else
10693 2 : cdesc = comp;
10694 :
10695 2 : tree fndecl;
10696 :
10697 2 : fndecl = build_call_expr_loc (input_location,
10698 : gfor_fndecl_co_broadcast, 5,
10699 : gfc_build_addr_expr (pvoid_type_node,cdesc),
10700 : args->image_index,
10701 : null_pointer_node, null_pointer_node,
10702 : null_pointer_node);
10703 :
10704 2 : gfc_add_expr_to_block (&tmpblock, fndecl);
10705 2 : gfc_add_block_to_block (&fnblock, &tmpblock);
10706 :
10707 27939 : break;
10708 :
10709 12453 : case DEALLOCATE_ALLOC_COMP:
10710 :
10711 12453 : gfc_init_block (&tmpblock);
10712 :
10713 12453 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10714 : decl, cdecl, NULL_TREE);
10715 :
10716 : /* Shortcut to get the attributes of the component. */
10717 12453 : if (c->ts.type == BT_CLASS)
10718 : {
10719 1004 : attr = &CLASS_DATA (c)->attr;
10720 1004 : if (attr->class_pointer || c->attr.proc_pointer)
10721 18 : continue;
10722 : }
10723 : else
10724 : {
10725 11449 : attr = &c->attr;
10726 11449 : if (attr->pointer || attr->proc_pointer)
10727 143 : continue;
10728 : }
10729 :
10730 12292 : if (!no_finalization && ((c->ts.type == BT_DERIVED && !c->attr.pointer)
10731 8522 : || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer)))
10732 : /* Call the finalizer, which will free the memory and nullify the
10733 : pointer of an array. */
10734 3555 : deallocate_called = gfc_add_comp_finalizer_call (&tmpblock, comp, c,
10735 3555 : caf_enabled (caf_mode))
10736 3555 : && attr->dimension;
10737 : else
10738 : deallocate_called = false;
10739 :
10740 : /* Add the _class ref for classes. */
10741 12292 : if (c->ts.type == BT_CLASS && attr->allocatable)
10742 986 : comp = gfc_class_data_get (comp);
10743 :
10744 12292 : add_when_allocated = NULL_TREE;
10745 12292 : if (cmp_has_alloc_comps
10746 2850 : && !c->attr.pointer && !c->attr.proc_pointer
10747 : && !same_type
10748 2850 : && !deallocate_called)
10749 : {
10750 : /* Add checked deallocation of the components. This code is
10751 : obviously added because the finalizer is not trusted to free
10752 : all memory. */
10753 1552 : if (c->ts.type == BT_CLASS)
10754 : {
10755 242 : rank = CLASS_DATA (c)->as ? CLASS_DATA (c)->as->rank : 0;
10756 242 : add_when_allocated
10757 242 : = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
10758 : comp, NULL_TREE, rank, purpose,
10759 : caf_mode, args, no_finalization);
10760 : }
10761 : else
10762 : {
10763 1310 : rank = c->as ? c->as->rank : 0;
10764 1310 : add_when_allocated = structure_alloc_comps (c->ts.u.derived,
10765 : comp, NULL_TREE,
10766 : rank, purpose,
10767 : caf_mode, args,
10768 : no_finalization);
10769 : }
10770 : }
10771 :
10772 8320 : if (attr->allocatable && !same_type
10773 19589 : && (!attr->codimension || caf_enabled (caf_mode)))
10774 : {
10775 : /* Handle all types of components besides components of the
10776 : same_type as the current one, because those would create an
10777 : endless loop. */
10778 51 : caf_dereg_mode = (caf_in_coarray (caf_mode)
10779 58 : && (attr->dimension || c->caf_token))
10780 7233 : || attr->codimension
10781 7368 : ? (gfc_caf_is_dealloc_only (caf_mode)
10782 : ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
10783 : : GFC_CAF_COARRAY_DEREGISTER)
10784 : : GFC_CAF_COARRAY_NOCOARRAY;
10785 :
10786 7290 : caf_token = NULL_TREE;
10787 : /* Coarray components are handled directly by
10788 : deallocate_with_status. */
10789 7290 : if (!attr->codimension
10790 7269 : && caf_dereg_mode != GFC_CAF_COARRAY_NOCOARRAY)
10791 : {
10792 57 : if (c->caf_token)
10793 19 : caf_token
10794 19 : = fold_build3_loc (input_location, COMPONENT_REF,
10795 19 : TREE_TYPE (gfc_comp_caf_token (c)),
10796 : decl, gfc_comp_caf_token (c),
10797 : NULL_TREE);
10798 38 : else if (attr->dimension && !attr->proc_pointer)
10799 38 : caf_token = gfc_conv_descriptor_token (comp);
10800 : }
10801 :
10802 7290 : tmp = gfc_deallocate_with_status (comp, NULL_TREE, NULL_TREE,
10803 : NULL_TREE, NULL_TREE, true,
10804 : NULL, caf_dereg_mode, NULL_TREE,
10805 : add_when_allocated, caf_token);
10806 :
10807 7290 : gfc_add_expr_to_block (&tmpblock, tmp);
10808 : }
10809 5002 : else if (attr->allocatable && !attr->codimension
10810 1023 : && !deallocate_called)
10811 : {
10812 : /* Case of recursive allocatable derived types. */
10813 1023 : tree is_allocated;
10814 1023 : tree ubound;
10815 1023 : tree cdesc;
10816 1023 : stmtblock_t dealloc_block;
10817 :
10818 1023 : gfc_init_block (&dealloc_block);
10819 1023 : if (add_when_allocated)
10820 0 : gfc_add_expr_to_block (&dealloc_block, add_when_allocated);
10821 :
10822 : /* Convert the component into a rank 1 descriptor type. */
10823 1023 : if (attr->dimension)
10824 : {
10825 417 : tmp = gfc_get_element_type (TREE_TYPE (comp));
10826 417 : ubound = gfc_full_array_size (&dealloc_block, comp,
10827 417 : c->ts.type == BT_CLASS
10828 0 : ? CLASS_DATA (c)->as->rank
10829 417 : : c->as->rank);
10830 : }
10831 : else
10832 : {
10833 606 : tmp = TREE_TYPE (comp);
10834 606 : ubound = build_int_cst (gfc_array_index_type, 1);
10835 : }
10836 :
10837 1023 : cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node,
10838 : &ubound, 1,
10839 : GFC_ARRAY_ALLOCATABLE, false);
10840 :
10841 1023 : cdesc = gfc_create_var (cdesc, "cdesc");
10842 1023 : DECL_ARTIFICIAL (cdesc) = 1;
10843 :
10844 1023 : gfc_add_modify (&dealloc_block, gfc_conv_descriptor_dtype (cdesc),
10845 : gfc_get_dtype_rank_type (1, tmp));
10846 1023 : gfc_conv_descriptor_lbound_set (&dealloc_block, cdesc,
10847 : gfc_index_zero_node,
10848 : gfc_index_one_node);
10849 1023 : gfc_conv_descriptor_stride_set (&dealloc_block, cdesc,
10850 : gfc_index_zero_node,
10851 : gfc_index_one_node);
10852 1023 : gfc_conv_descriptor_ubound_set (&dealloc_block, cdesc,
10853 : gfc_index_zero_node, ubound);
10854 :
10855 1023 : if (attr->dimension)
10856 417 : comp = gfc_conv_descriptor_data_get (comp);
10857 :
10858 1023 : gfc_conv_descriptor_data_set (&dealloc_block, cdesc, comp);
10859 :
10860 : /* Now call the deallocator. */
10861 1023 : vtab = gfc_find_vtab (&c->ts);
10862 1023 : if (vtab->backend_decl == NULL)
10863 47 : gfc_get_symbol_decl (vtab);
10864 1023 : tmp = gfc_build_addr_expr (NULL_TREE, vtab->backend_decl);
10865 1023 : dealloc_fndecl = gfc_vptr_deallocate_get (tmp);
10866 1023 : dealloc_fndecl = build_fold_indirect_ref_loc (input_location,
10867 : dealloc_fndecl);
10868 1023 : tmp = build_int_cst (TREE_TYPE (comp), 0);
10869 1023 : is_allocated = fold_build2_loc (input_location, NE_EXPR,
10870 : logical_type_node, tmp,
10871 : comp);
10872 1023 : cdesc = gfc_build_addr_expr (NULL_TREE, cdesc);
10873 :
10874 1023 : tmp = build_call_expr_loc (input_location,
10875 : dealloc_fndecl, 1,
10876 : cdesc);
10877 1023 : gfc_add_expr_to_block (&dealloc_block, tmp);
10878 :
10879 1023 : tmp = gfc_finish_block (&dealloc_block);
10880 :
10881 1023 : tmp = fold_build3_loc (input_location, COND_EXPR,
10882 : void_type_node, is_allocated, tmp,
10883 : build_empty_stmt (input_location));
10884 :
10885 1023 : gfc_add_expr_to_block (&tmpblock, tmp);
10886 1023 : }
10887 3979 : else if (add_when_allocated)
10888 628 : gfc_add_expr_to_block (&tmpblock, add_when_allocated);
10889 :
10890 986 : if (c->ts.type == BT_CLASS && attr->allocatable
10891 13278 : && (!attr->codimension || !caf_enabled (caf_mode)))
10892 : {
10893 : /* Finally, reset the vptr to the declared type vtable and, if
10894 : necessary reset the _len field.
10895 :
10896 : First recover the reference to the component and obtain
10897 : the vptr. */
10898 971 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10899 : decl, cdecl, NULL_TREE);
10900 971 : tmp = gfc_class_vptr_get (comp);
10901 :
10902 971 : if (UNLIMITED_POLY (c))
10903 : {
10904 : /* Both vptr and _len field should be nulled. */
10905 213 : gfc_add_modify (&tmpblock, tmp,
10906 213 : build_int_cst (TREE_TYPE (tmp), 0));
10907 213 : tmp = gfc_class_len_get (comp);
10908 213 : gfc_add_modify (&tmpblock, tmp,
10909 213 : build_int_cst (TREE_TYPE (tmp), 0));
10910 : }
10911 : else
10912 : {
10913 : /* Build the vtable address and set the vptr with it. */
10914 758 : gfc_reset_vptr (&tmpblock, nullptr, tmp, c->ts.u.derived);
10915 : }
10916 : }
10917 :
10918 : /* Now add the deallocation of this component. */
10919 12292 : gfc_add_block_to_block (&fnblock, &tmpblock);
10920 12292 : break;
10921 :
10922 5505 : case NULLIFY_ALLOC_COMP:
10923 : /* Nullify
10924 : - allocatable components (regular or in class)
10925 : - components that have allocatable components
10926 : - pointer components when in a coarray.
10927 : Skip everything else especially proc_pointers, which may come
10928 : coupled with the regular pointer attribute. */
10929 7341 : if (c->attr.proc_pointer
10930 5505 : || !(c->attr.allocatable || (c->ts.type == BT_CLASS
10931 482 : && CLASS_DATA (c)->attr.allocatable)
10932 2289 : || (cmp_has_alloc_comps
10933 370 : && ((c->ts.type == BT_DERIVED && !c->attr.pointer)
10934 18 : || (c->ts.type == BT_CLASS
10935 12 : && !CLASS_DATA (c)->attr.class_pointer)))
10936 1937 : || (caf_in_coarray (caf_mode) && c->attr.pointer)))
10937 1836 : continue;
10938 :
10939 : /* Process class components first, because they always have the
10940 : pointer-attribute set which would be caught wrong else. */
10941 3669 : if (c->ts.type == BT_CLASS
10942 469 : && (CLASS_DATA (c)->attr.allocatable
10943 0 : || CLASS_DATA (c)->attr.class_pointer))
10944 : {
10945 469 : tree class_ref;
10946 :
10947 : /* Allocatable CLASS components. */
10948 469 : class_ref = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10949 : decl, cdecl, NULL_TREE);
10950 :
10951 469 : comp = gfc_class_data_get (class_ref);
10952 469 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
10953 257 : gfc_conv_descriptor_data_set (&fnblock, comp,
10954 : null_pointer_node);
10955 : else
10956 : {
10957 212 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
10958 : void_type_node, comp,
10959 212 : build_int_cst (TREE_TYPE (comp), 0));
10960 212 : gfc_add_expr_to_block (&fnblock, tmp);
10961 : }
10962 :
10963 : /* The dynamic type of a disassociated pointer or unallocated
10964 : allocatable variable is its declared type. An unlimited
10965 : polymorphic entity has no declared type. */
10966 469 : gfc_reset_vptr (&fnblock, nullptr, class_ref, c->ts.u.derived);
10967 :
10968 469 : cmp_has_alloc_comps = false;
10969 469 : }
10970 : /* Coarrays need the component to be nulled before the api-call
10971 : is made. */
10972 3200 : else if (c->attr.pointer || c->attr.allocatable)
10973 : {
10974 2848 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10975 : decl, cdecl, NULL_TREE);
10976 2848 : if (c->attr.dimension || c->attr.codimension)
10977 1975 : gfc_conv_descriptor_data_set (&fnblock, comp,
10978 : null_pointer_node);
10979 : else
10980 873 : gfc_add_modify (&fnblock, comp,
10981 873 : build_int_cst (TREE_TYPE (comp), 0));
10982 2848 : if (gfc_deferred_strlen (c, &comp))
10983 : {
10984 317 : comp = fold_build3_loc (input_location, COMPONENT_REF,
10985 317 : TREE_TYPE (comp),
10986 : decl, comp, NULL_TREE);
10987 634 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
10988 317 : TREE_TYPE (comp), comp,
10989 317 : build_int_cst (TREE_TYPE (comp), 0));
10990 317 : gfc_add_expr_to_block (&fnblock, tmp);
10991 : }
10992 : cmp_has_alloc_comps = false;
10993 : }
10994 :
10995 3669 : if (flag_coarray == GFC_FCOARRAY_LIB && caf_in_coarray (caf_mode))
10996 : {
10997 : /* Register a component of a derived type coarray with the
10998 : coarray library. Do not register ultimate component
10999 : coarrays here. They are treated like regular coarrays and
11000 : are either allocated on all images or on none. */
11001 132 : tree token;
11002 :
11003 132 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
11004 : decl, cdecl, NULL_TREE);
11005 132 : if (c->attr.dimension)
11006 : {
11007 : /* Set the dtype, because caf_register needs it. */
11008 104 : gfc_add_modify (&fnblock, gfc_conv_descriptor_dtype (comp),
11009 104 : gfc_get_dtype (TREE_TYPE (comp)));
11010 104 : tmp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
11011 : decl, cdecl, NULL_TREE);
11012 104 : token = gfc_conv_descriptor_token (tmp);
11013 : }
11014 : else
11015 : {
11016 28 : gfc_se se;
11017 :
11018 28 : gfc_init_se (&se, NULL);
11019 56 : token = fold_build3_loc (input_location, COMPONENT_REF,
11020 : pvoid_type_node, decl,
11021 28 : gfc_comp_caf_token (c), NULL_TREE);
11022 28 : comp = gfc_conv_scalar_to_descriptor (&se, comp,
11023 28 : c->ts.type == BT_CLASS
11024 28 : ? CLASS_DATA (c)->attr
11025 : : c->attr);
11026 28 : gfc_add_block_to_block (&fnblock, &se.pre);
11027 : }
11028 :
11029 132 : gfc_allocate_using_caf_lib (&fnblock, comp, size_zero_node,
11030 : gfc_build_addr_expr (NULL_TREE,
11031 : token),
11032 : NULL_TREE, NULL_TREE, NULL_TREE,
11033 : GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
11034 : }
11035 :
11036 3669 : if (cmp_has_alloc_comps)
11037 : {
11038 352 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
11039 : decl, cdecl, NULL_TREE);
11040 352 : rank = c->as ? c->as->rank : 0;
11041 352 : tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
11042 : rank, purpose, caf_mode, args,
11043 : no_finalization);
11044 352 : gfc_add_expr_to_block (&fnblock, tmp);
11045 : }
11046 : break;
11047 :
11048 30 : case REASSIGN_CAF_COMP:
11049 30 : if (caf_enabled (caf_mode)
11050 30 : && (c->attr.codimension
11051 23 : || (c->ts.type == BT_CLASS
11052 2 : && (CLASS_DATA (c)->attr.coarray_comp
11053 2 : || caf_in_coarray (caf_mode)))
11054 21 : || (c->ts.type == BT_DERIVED
11055 7 : && (c->ts.u.derived->attr.coarray_comp
11056 6 : || caf_in_coarray (caf_mode))))
11057 46 : && !same_type)
11058 : {
11059 14 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
11060 : decl, cdecl, NULL_TREE);
11061 14 : dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
11062 : dest, cdecl, NULL_TREE);
11063 :
11064 14 : if (c->attr.codimension)
11065 : {
11066 7 : if (c->ts.type == BT_CLASS)
11067 : {
11068 0 : comp = gfc_class_data_get (comp);
11069 0 : dcmp = gfc_class_data_get (dcmp);
11070 : }
11071 7 : gfc_conv_descriptor_data_set (&fnblock, dcmp,
11072 : gfc_conv_descriptor_data_get (comp));
11073 : }
11074 : else
11075 : {
11076 7 : tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
11077 : rank, purpose, caf_mode
11078 : | GFC_STRUCTURE_CAF_MODE_IN_COARRAY,
11079 : args, no_finalization);
11080 7 : gfc_add_expr_to_block (&fnblock, tmp);
11081 : }
11082 : }
11083 : break;
11084 :
11085 11566 : case COPY_ALLOC_COMP:
11086 11566 : if (c->attr.pointer || c->attr.proc_pointer)
11087 153 : continue;
11088 :
11089 : /* We need source and destination components. */
11090 11413 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl,
11091 : cdecl, NULL_TREE);
11092 11413 : dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, dest,
11093 : cdecl, NULL_TREE);
11094 11413 : dcmp = fold_convert (TREE_TYPE (comp), dcmp);
11095 :
11096 11413 : if (IS_PDT (c) && !c->attr.allocatable)
11097 : {
11098 39 : tmp = gfc_copy_alloc_comp (c->ts.u.derived, comp, dcmp,
11099 : 0, 0);
11100 39 : gfc_add_expr_to_block (&fnblock, tmp);
11101 39 : continue;
11102 : }
11103 :
11104 11374 : if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
11105 : {
11106 726 : tree ftn_tree;
11107 726 : tree size;
11108 726 : tree dst_data;
11109 726 : tree src_data;
11110 726 : tree null_data;
11111 :
11112 726 : dst_data = gfc_class_data_get (dcmp);
11113 726 : src_data = gfc_class_data_get (comp);
11114 726 : size = fold_convert (size_type_node,
11115 : gfc_class_vtab_size_get (comp));
11116 :
11117 726 : if (CLASS_DATA (c)->attr.dimension)
11118 : {
11119 704 : nelems = gfc_conv_descriptor_size (src_data,
11120 352 : CLASS_DATA (c)->as->rank);
11121 352 : size = fold_build2_loc (input_location, MULT_EXPR,
11122 : size_type_node, size,
11123 : fold_convert (size_type_node,
11124 : nelems));
11125 : }
11126 : else
11127 374 : nelems = build_int_cst (size_type_node, 1);
11128 :
11129 726 : if (CLASS_DATA (c)->attr.dimension
11130 374 : || CLASS_DATA (c)->attr.codimension)
11131 : {
11132 360 : src_data = gfc_conv_descriptor_data_get (src_data);
11133 360 : dst_data = gfc_conv_descriptor_data_get (dst_data);
11134 : }
11135 :
11136 726 : gfc_init_block (&tmpblock);
11137 :
11138 726 : gfc_add_modify (&tmpblock, gfc_class_vptr_get (dcmp),
11139 : gfc_class_vptr_get (comp));
11140 :
11141 : /* Copy the unlimited '_len' field. If it is greater than zero
11142 : (ie. a character(_len)), multiply it by size and use this
11143 : for the malloc call. */
11144 726 : if (UNLIMITED_POLY (c))
11145 : {
11146 140 : gfc_add_modify (&tmpblock, gfc_class_len_get (dcmp),
11147 : gfc_class_len_get (comp));
11148 140 : size = gfc_resize_class_size_with_len (&tmpblock, comp, size);
11149 : }
11150 :
11151 : /* Coarray component have to have the same allocation status and
11152 : shape/type-parameter/effective-type on the LHS and RHS of an
11153 : intrinsic assignment. Hence, we did not deallocated them - and
11154 : do not allocate them here. */
11155 726 : if (!CLASS_DATA (c)->attr.codimension)
11156 : {
11157 711 : ftn_tree = builtin_decl_explicit (BUILT_IN_MALLOC);
11158 711 : tmp = build_call_expr_loc (input_location, ftn_tree, 1, size);
11159 711 : gfc_add_modify (&tmpblock, dst_data,
11160 711 : fold_convert (TREE_TYPE (dst_data), tmp));
11161 : }
11162 :
11163 1437 : tmp = gfc_copy_class_to_class (comp, dcmp, nelems,
11164 726 : UNLIMITED_POLY (c));
11165 726 : gfc_add_expr_to_block (&tmpblock, tmp);
11166 726 : tmp = gfc_finish_block (&tmpblock);
11167 :
11168 726 : gfc_init_block (&tmpblock);
11169 726 : gfc_add_modify (&tmpblock, dst_data,
11170 726 : fold_convert (TREE_TYPE (dst_data),
11171 : null_pointer_node));
11172 726 : null_data = gfc_finish_block (&tmpblock);
11173 :
11174 726 : null_cond = fold_build2_loc (input_location, NE_EXPR,
11175 : logical_type_node, src_data,
11176 : null_pointer_node);
11177 :
11178 726 : gfc_add_expr_to_block (&fnblock, build3_v (COND_EXPR, null_cond,
11179 : tmp, null_data));
11180 726 : continue;
11181 726 : }
11182 :
11183 : /* To implement guarded deep copy, i.e., deep copy only allocatable
11184 : components that are really allocated, the deep copy code has to
11185 : be generated first and then added to the if-block in
11186 : gfc_duplicate_allocatable (). */
11187 10648 : if (cmp_has_alloc_comps && !c->attr.proc_pointer && !same_type)
11188 : {
11189 1674 : rank = c->as ? c->as->rank : 0;
11190 1674 : tmp = fold_convert (TREE_TYPE (dcmp), comp);
11191 1674 : gfc_add_modify (&fnblock, dcmp, tmp);
11192 1674 : add_when_allocated = structure_alloc_comps (c->ts.u.derived,
11193 : comp, dcmp,
11194 : rank, purpose,
11195 : caf_mode, args,
11196 : no_finalization);
11197 : }
11198 : else
11199 : add_when_allocated = NULL_TREE;
11200 :
11201 10648 : if (gfc_deferred_strlen (c, &tmp))
11202 : {
11203 387 : tree len, size;
11204 387 : len = tmp;
11205 387 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
11206 387 : TREE_TYPE (len),
11207 : decl, len, NULL_TREE);
11208 387 : len = fold_build3_loc (input_location, COMPONENT_REF,
11209 387 : TREE_TYPE (len),
11210 : dest, len, NULL_TREE);
11211 387 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
11212 387 : TREE_TYPE (len), len, tmp);
11213 387 : gfc_add_expr_to_block (&fnblock, tmp);
11214 387 : size = size_of_string_in_bytes (c->ts.kind, len);
11215 : /* This component cannot have allocatable components,
11216 : therefore add_when_allocated of duplicate_allocatable ()
11217 : is always NULL. */
11218 387 : rank = c->as ? c->as->rank : 0;
11219 387 : tmp = duplicate_allocatable (dcmp, comp, ctype, rank,
11220 : false, false, size, NULL_TREE);
11221 387 : gfc_add_expr_to_block (&fnblock, tmp);
11222 : }
11223 10261 : else if (c->attr.pdt_array
11224 157 : && !c->attr.allocatable && !c->attr.pointer)
11225 : {
11226 157 : tmp = duplicate_allocatable (dcmp, comp, ctype,
11227 157 : c->as ? c->as->rank : 0,
11228 : false, false, NULL_TREE, NULL_TREE);
11229 157 : gfc_add_expr_to_block (&fnblock, tmp);
11230 : }
11231 : /* Special case: recursive allocatable array components require
11232 : runtime helpers to avoid compile-time infinite recursion. Generate
11233 : a call to _gfortran_cfi_deep_copy_array with an element copy
11234 : wrapper. When inside a wrapper, reuse current_function_decl. */
11235 6204 : else if (c->attr.allocatable && c->as && cmp_has_alloc_comps && same_type
11236 930 : && purpose == COPY_ALLOC_COMP && !c->attr.proc_pointer
11237 930 : && !c->attr.codimension && !caf_in_coarray (caf_mode)
11238 11034 : && c->ts.type == BT_DERIVED && c->ts.u.derived != NULL)
11239 : {
11240 930 : tree copy_wrapper, call, dest_addr, src_addr, elem_type;
11241 930 : tree helper_ptr_type;
11242 930 : tree alloc_expr;
11243 930 : int comp_rank;
11244 :
11245 : /* Get the element type from ctype (already the component
11246 : type). For arrays we need the element type, not the array
11247 : type. */
11248 930 : elem_type = ctype;
11249 930 : if (GFC_DESCRIPTOR_TYPE_P (ctype))
11250 930 : elem_type = gfc_get_element_type (ctype);
11251 0 : else if (TREE_CODE (ctype) == ARRAY_TYPE)
11252 0 : elem_type = TREE_TYPE (ctype);
11253 :
11254 930 : helper_ptr_type = get_copy_helper_pointer_type ();
11255 :
11256 930 : comp_rank = c->as ? c->as->rank : 0;
11257 930 : alloc_expr = gfc_duplicate_allocatable_nocopy (dcmp, comp, ctype,
11258 : comp_rank);
11259 930 : gfc_add_expr_to_block (&fnblock, alloc_expr);
11260 :
11261 : /* Generate or reuse the element copy helper. Inside an
11262 : existing helper we can reuse the current function to
11263 : prevent recursive generation. */
11264 930 : if (inside_wrapper)
11265 703 : copy_wrapper
11266 703 : = gfc_build_addr_expr (NULL_TREE, current_function_decl);
11267 : else
11268 227 : copy_wrapper
11269 227 : = generate_element_copy_wrapper (c->ts.u.derived, elem_type,
11270 : purpose, caf_mode);
11271 930 : copy_wrapper = fold_convert (helper_ptr_type, copy_wrapper);
11272 :
11273 : /* Build addresses of descriptors. */
11274 930 : dest_addr = gfc_build_addr_expr (pvoid_type_node, dcmp);
11275 930 : src_addr = gfc_build_addr_expr (pvoid_type_node, comp);
11276 :
11277 : /* Build call: _gfortran_cfi_deep_copy_array (&dcmp, &comp,
11278 : wrapper). */
11279 930 : call = build_call_expr_loc (input_location,
11280 : gfor_fndecl_cfi_deep_copy_array, 3,
11281 : dest_addr, src_addr,
11282 : copy_wrapper);
11283 930 : gfc_add_expr_to_block (&fnblock, call);
11284 : }
11285 : /* For allocatable arrays with nested allocatable components,
11286 : add_when_allocated already includes gfc_duplicate_allocatable
11287 : (from the recursive structure_alloc_comps call at line 10290-10293),
11288 : so we must not call it again here. PR121628 added an
11289 : add_when_allocated != NULL clause that was redundant for scalars
11290 : (already handled by !c->as) and wrong for arrays (double alloc). */
11291 5274 : else if (c->attr.allocatable && !c->attr.proc_pointer
11292 14448 : && (!cmp_has_alloc_comps
11293 804 : || !c->as
11294 579 : || c->attr.codimension
11295 576 : || caf_in_coarray (caf_mode)))
11296 : {
11297 4704 : rank = c->as ? c->as->rank : 0;
11298 4704 : if (c->attr.codimension)
11299 20 : tmp = gfc_copy_allocatable_data (dcmp, comp, ctype, rank);
11300 4684 : else if (flag_coarray == GFC_FCOARRAY_LIB
11301 4684 : && caf_in_coarray (caf_mode))
11302 : {
11303 62 : tree dst_tok;
11304 62 : if (c->as)
11305 44 : dst_tok = gfc_conv_descriptor_token (dcmp);
11306 : else
11307 : {
11308 18 : dst_tok
11309 18 : = fold_build3_loc (input_location, COMPONENT_REF,
11310 : pvoid_type_node, dest,
11311 18 : gfc_comp_caf_token (c), NULL_TREE);
11312 : }
11313 62 : tmp
11314 62 : = duplicate_allocatable_coarray (dcmp, dst_tok, comp, ctype,
11315 : rank, add_when_allocated);
11316 : }
11317 : else
11318 4622 : tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank,
11319 : add_when_allocated);
11320 4704 : gfc_add_expr_to_block (&fnblock, tmp);
11321 : }
11322 : else
11323 4470 : if (cmp_has_alloc_comps || is_pdt_type)
11324 1715 : gfc_add_expr_to_block (&fnblock, add_when_allocated);
11325 :
11326 : break;
11327 :
11328 1900 : case ALLOCATE_PDT_COMP:
11329 :
11330 1900 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
11331 : decl, cdecl, NULL_TREE);
11332 :
11333 : /* Set the PDT KIND and LEN fields. */
11334 1900 : if (c->attr.pdt_kind || c->attr.pdt_len)
11335 : {
11336 865 : gfc_se tse;
11337 865 : gfc_expr *c_expr = NULL;
11338 865 : gfc_actual_arglist *param = pdt_param_list;
11339 865 : gfc_init_se (&tse, NULL);
11340 3135 : for (; param; param = param->next)
11341 1405 : if (param->name && !strcmp (c->name, param->name))
11342 859 : c_expr = param->expr;
11343 :
11344 865 : if (!c_expr)
11345 24 : c_expr = c->initializer;
11346 :
11347 24 : if (c_expr)
11348 : {
11349 847 : gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp));
11350 847 : gfc_add_block_to_block (&fnblock, &tse.pre);
11351 847 : gfc_add_modify (&fnblock, comp, tse.expr);
11352 847 : gfc_add_block_to_block (&fnblock, &tse.post);
11353 : }
11354 865 : }
11355 1035 : else if (c->initializer && !c->attr.pdt_string && !c->attr.pdt_array
11356 139 : && !c->as && !IS_PDT (c)) /* Take care of arrays. */
11357 : {
11358 49 : gfc_se tse;
11359 49 : gfc_expr *c_expr;
11360 49 : gfc_init_se (&tse, NULL);
11361 49 : c_expr = c->initializer;
11362 49 : gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp));
11363 49 : gfc_add_block_to_block (&fnblock, &tse.pre);
11364 49 : gfc_add_modify (&fnblock, comp, tse.expr);
11365 49 : gfc_add_block_to_block (&fnblock, &tse.post);
11366 : }
11367 :
11368 1900 : if (c->attr.pdt_string)
11369 : {
11370 90 : gfc_se tse;
11371 90 : gfc_init_se (&tse, NULL);
11372 90 : tree strlen = NULL_TREE;
11373 90 : gfc_expr *e = gfc_copy_expr (c->ts.u.cl->length);
11374 : /* Convert the parameterized string length to its value. The
11375 : string length is stored in a hidden field in the same way as
11376 : deferred string lengths. */
11377 90 : gfc_insert_parameter_exprs (e, pdt_param_list);
11378 90 : if (gfc_deferred_strlen (c, &strlen) && strlen != NULL_TREE)
11379 : {
11380 90 : gfc_conv_expr_type (&tse, e,
11381 90 : TREE_TYPE (strlen));
11382 90 : strlen = fold_build3_loc (input_location, COMPONENT_REF,
11383 90 : TREE_TYPE (strlen),
11384 : decl, strlen, NULL_TREE);
11385 90 : gfc_add_block_to_block (&fnblock, &tse.pre);
11386 90 : gfc_add_modify (&fnblock, strlen, tse.expr);
11387 90 : gfc_add_block_to_block (&fnblock, &tse.post);
11388 90 : c->ts.u.cl->backend_decl = strlen;
11389 : }
11390 90 : gfc_free_expr (e);
11391 :
11392 : /* Scalar parameterized strings can be allocated now. */
11393 90 : if (!c->as)
11394 : {
11395 90 : tmp = fold_convert (gfc_array_index_type, strlen);
11396 90 : tmp = size_of_string_in_bytes (c->ts.kind, tmp);
11397 90 : tmp = gfc_evaluate_now (tmp, &fnblock);
11398 90 : tmp = gfc_call_malloc (&fnblock, TREE_TYPE (comp), tmp);
11399 90 : gfc_add_modify (&fnblock, comp, tmp);
11400 : }
11401 : }
11402 :
11403 : /* Allocate parameterized arrays of parameterized derived types. */
11404 1900 : if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT)
11405 1637 : && !(IS_PDT (c) || IS_CLASS_PDT (c)))
11406 1451 : continue;
11407 :
11408 449 : if (c->ts.type == BT_CLASS)
11409 0 : comp = gfc_class_data_get (comp);
11410 :
11411 449 : if (c->attr.pdt_array)
11412 : {
11413 263 : gfc_se tse;
11414 263 : int i;
11415 263 : tree size = gfc_index_one_node;
11416 263 : tree offset = gfc_index_zero_node;
11417 263 : tree lower, upper;
11418 263 : gfc_expr *e;
11419 :
11420 : /* This chunk takes the expressions for 'lower' and 'upper'
11421 : in the arrayspec and substitutes in the expressions for
11422 : the parameters from 'pdt_param_list'. The descriptor
11423 : fields can then be filled from the values so obtained. */
11424 263 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)));
11425 628 : for (i = 0; i < c->as->rank; i++)
11426 : {
11427 365 : gfc_init_se (&tse, NULL);
11428 365 : e = gfc_copy_expr (c->as->lower[i]);
11429 365 : gfc_insert_parameter_exprs (e, pdt_param_list);
11430 365 : gfc_conv_expr_type (&tse, e, gfc_array_index_type);
11431 365 : gfc_free_expr (e);
11432 365 : lower = tse.expr;
11433 365 : gfc_add_block_to_block (&fnblock, &tse.pre);
11434 365 : gfc_conv_descriptor_lbound_set (&fnblock, comp,
11435 : gfc_rank_cst[i],
11436 : lower);
11437 365 : gfc_add_block_to_block (&fnblock, &tse.post);
11438 365 : e = gfc_copy_expr (c->as->upper[i]);
11439 365 : gfc_insert_parameter_exprs (e, pdt_param_list);
11440 365 : gfc_conv_expr_type (&tse, e, gfc_array_index_type);
11441 365 : gfc_free_expr (e);
11442 365 : upper = tse.expr;
11443 365 : gfc_add_block_to_block (&fnblock, &tse.pre);
11444 365 : gfc_conv_descriptor_ubound_set (&fnblock, comp,
11445 : gfc_rank_cst[i],
11446 : upper);
11447 365 : gfc_add_block_to_block (&fnblock, &tse.post);
11448 365 : gfc_conv_descriptor_stride_set (&fnblock, comp,
11449 : gfc_rank_cst[i],
11450 : size);
11451 365 : size = gfc_evaluate_now (size, &fnblock);
11452 365 : offset = fold_build2_loc (input_location,
11453 : MINUS_EXPR,
11454 : gfc_array_index_type,
11455 : offset, size);
11456 365 : offset = gfc_evaluate_now (offset, &fnblock);
11457 365 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
11458 : gfc_array_index_type,
11459 : upper, lower);
11460 365 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
11461 : gfc_array_index_type,
11462 : tmp, gfc_index_one_node);
11463 365 : size = fold_build2_loc (input_location, MULT_EXPR,
11464 : gfc_array_index_type, size, tmp);
11465 : }
11466 263 : gfc_conv_descriptor_offset_set (&fnblock, comp, offset);
11467 263 : if (c->ts.type == BT_CLASS)
11468 : {
11469 0 : tmp = gfc_get_vptr_from_expr (comp);
11470 0 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
11471 0 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
11472 0 : tmp = gfc_vptr_size_get (tmp);
11473 : }
11474 : else
11475 263 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (ctype));
11476 263 : tmp = fold_convert (gfc_array_index_type, tmp);
11477 263 : size = fold_build2_loc (input_location, MULT_EXPR,
11478 : gfc_array_index_type, size, tmp);
11479 263 : size = gfc_evaluate_now (size, &fnblock);
11480 263 : tmp = gfc_call_malloc (&fnblock, NULL, size);
11481 263 : gfc_conv_descriptor_data_set (&fnblock, comp, tmp);
11482 263 : tmp = gfc_conv_descriptor_dtype (comp);
11483 263 : gfc_add_modify (&fnblock, tmp, gfc_get_dtype (ctype));
11484 :
11485 263 : if (c->initializer && c->initializer->rank)
11486 : {
11487 0 : gfc_init_se (&tse, NULL);
11488 0 : e = gfc_copy_expr (c->initializer);
11489 0 : gfc_insert_parameter_exprs (e, pdt_param_list);
11490 0 : gfc_conv_expr_descriptor (&tse, e);
11491 0 : gfc_add_block_to_block (&fnblock, &tse.pre);
11492 0 : gfc_free_expr (e);
11493 0 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
11494 0 : tmp = build_call_expr_loc (input_location, tmp, 3,
11495 : gfc_conv_descriptor_data_get (comp),
11496 : gfc_conv_descriptor_data_get (tse.expr),
11497 : fold_convert (size_type_node, size));
11498 0 : gfc_add_expr_to_block (&fnblock, tmp);
11499 0 : gfc_add_block_to_block (&fnblock, &tse.post);
11500 : }
11501 : }
11502 :
11503 : /* Recurse in to PDT components. */
11504 449 : if ((IS_PDT (c) || IS_CLASS_PDT (c))
11505 200 : && !(c->attr.pointer || c->attr.allocatable))
11506 : {
11507 104 : gfc_actual_arglist *tail = c->param_list;
11508 :
11509 262 : for (; tail; tail = tail->next)
11510 158 : if (tail->expr)
11511 134 : gfc_insert_parameter_exprs (tail->expr, pdt_param_list);
11512 :
11513 104 : tmp = gfc_allocate_pdt_comp (c->ts.u.derived, comp,
11514 104 : c->as ? c->as->rank : 0,
11515 104 : c->param_list);
11516 104 : gfc_add_expr_to_block (&fnblock, tmp);
11517 : }
11518 :
11519 : break;
11520 :
11521 2258 : case DEALLOCATE_PDT_COMP:
11522 : /* Deallocate array or parameterized string length components
11523 : of parameterized derived types. */
11524 2258 : if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT)
11525 1800 : && !c->attr.pdt_string
11526 1692 : && !(IS_PDT (c) || IS_CLASS_PDT (c)))
11527 1459 : continue;
11528 :
11529 799 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
11530 : decl, cdecl, NULL_TREE);
11531 799 : if (c->ts.type == BT_CLASS)
11532 0 : comp = gfc_class_data_get (comp);
11533 :
11534 : /* Recurse in to PDT components. */
11535 799 : if ((IS_PDT (c) || IS_CLASS_PDT (c))
11536 271 : && (!c->attr.pointer && !c->attr.allocatable))
11537 : {
11538 104 : tmp = gfc_deallocate_pdt_comp (c->ts.u.derived, comp,
11539 104 : c->as ? c->as->rank : 0);
11540 104 : gfc_add_expr_to_block (&fnblock, tmp);
11541 : }
11542 :
11543 799 : if (c->attr.pdt_array || c->attr.pdt_string)
11544 : {
11545 566 : tmp = comp;
11546 566 : if (c->attr.pdt_array)
11547 458 : tmp = gfc_conv_descriptor_data_get (comp);
11548 566 : null_cond = fold_build2_loc (input_location, NE_EXPR,
11549 : logical_type_node, tmp,
11550 566 : build_int_cst (TREE_TYPE (tmp), 0));
11551 566 : if (flag_openmp_allocators)
11552 : {
11553 0 : tree cd, t;
11554 0 : if (c->attr.pdt_array)
11555 0 : cd = fold_build2_loc (input_location, EQ_EXPR,
11556 : boolean_type_node,
11557 : gfc_conv_descriptor_version (comp),
11558 : build_int_cst (integer_type_node, 1));
11559 : else
11560 0 : cd = gfc_omp_call_is_alloc (tmp);
11561 0 : t = builtin_decl_explicit (BUILT_IN_GOMP_FREE);
11562 0 : t = build_call_expr_loc (input_location, t, 1, tmp);
11563 :
11564 0 : stmtblock_t tblock;
11565 0 : gfc_init_block (&tblock);
11566 0 : gfc_add_expr_to_block (&tblock, t);
11567 0 : if (c->attr.pdt_array)
11568 0 : gfc_add_modify (&tblock, gfc_conv_descriptor_version (comp),
11569 : integer_zero_node);
11570 0 : tmp = build3_loc (input_location, COND_EXPR, void_type_node,
11571 : cd, gfc_finish_block (&tblock),
11572 : gfc_call_free (tmp));
11573 : }
11574 : else
11575 566 : tmp = gfc_call_free (tmp);
11576 566 : tmp = build3_v (COND_EXPR, null_cond, tmp,
11577 : build_empty_stmt (input_location));
11578 566 : gfc_add_expr_to_block (&fnblock, tmp);
11579 :
11580 566 : if (c->attr.pdt_array)
11581 458 : gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
11582 : else
11583 : {
11584 108 : tmp = fold_convert (TREE_TYPE (comp), null_pointer_node);
11585 108 : gfc_add_modify (&fnblock, comp, tmp);
11586 : }
11587 : }
11588 :
11589 : break;
11590 :
11591 324 : case CHECK_PDT_DUMMY:
11592 :
11593 324 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
11594 : decl, cdecl, NULL_TREE);
11595 324 : if (c->ts.type == BT_CLASS)
11596 0 : comp = gfc_class_data_get (comp);
11597 :
11598 : /* Recurse in to PDT components. */
11599 324 : if (((c->ts.type == BT_DERIVED
11600 14 : && !c->attr.allocatable && !c->attr.pointer)
11601 312 : || (c->ts.type == BT_CLASS
11602 0 : && !CLASS_DATA (c)->attr.allocatable
11603 0 : && !CLASS_DATA (c)->attr.pointer))
11604 12 : && c->ts.u.derived && c->ts.u.derived->attr.pdt_type)
11605 : {
11606 12 : tmp = gfc_check_pdt_dummy (c->ts.u.derived, comp,
11607 12 : c->as ? c->as->rank : 0,
11608 : pdt_param_list);
11609 12 : gfc_add_expr_to_block (&fnblock, tmp);
11610 : }
11611 :
11612 324 : if (!c->attr.pdt_len)
11613 276 : continue;
11614 : else
11615 : {
11616 48 : gfc_se tse;
11617 48 : gfc_expr *c_expr = NULL;
11618 48 : gfc_actual_arglist *param = pdt_param_list;
11619 :
11620 48 : gfc_init_se (&tse, NULL);
11621 186 : for (; param; param = param->next)
11622 90 : if (!strcmp (c->name, param->name)
11623 48 : && param->spec_type == SPEC_EXPLICIT)
11624 30 : c_expr = param->expr;
11625 :
11626 48 : if (c_expr)
11627 : {
11628 30 : tree error, cond, cname;
11629 30 : gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp));
11630 30 : cond = fold_build2_loc (input_location, NE_EXPR,
11631 : logical_type_node,
11632 : comp, tse.expr);
11633 30 : cname = gfc_build_cstring_const (c->name);
11634 30 : cname = gfc_build_addr_expr (pchar_type_node, cname);
11635 30 : error = gfc_trans_runtime_error (true, NULL,
11636 : "The value of the PDT LEN "
11637 : "parameter '%s' does not "
11638 : "agree with that in the "
11639 : "dummy declaration",
11640 : cname);
11641 30 : tmp = fold_build3_loc (input_location, COND_EXPR,
11642 : void_type_node, cond, error,
11643 : build_empty_stmt (input_location));
11644 30 : gfc_add_expr_to_block (&fnblock, tmp);
11645 : }
11646 : }
11647 48 : break;
11648 :
11649 0 : default:
11650 0 : gcc_unreachable ();
11651 6102 : break;
11652 : }
11653 : }
11654 18127 : seen_derived_types.remove (der_type);
11655 :
11656 18127 : return gfc_finish_block (&fnblock);
11657 : }
11658 :
11659 : /* Recursively traverse an object of derived type, generating code to
11660 : nullify allocatable components. */
11661 :
11662 : tree
11663 2998 : gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
11664 : int caf_mode)
11665 : {
11666 2998 : return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11667 : NULLIFY_ALLOC_COMP,
11668 : GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode,
11669 2998 : NULL);
11670 : }
11671 :
11672 :
11673 : /* Recursively traverse an object of derived type, generating code to
11674 : deallocate allocatable components. */
11675 :
11676 : tree
11677 2950 : gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
11678 : int caf_mode, bool no_finalization)
11679 : {
11680 2950 : return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11681 : DEALLOCATE_ALLOC_COMP,
11682 : GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode,
11683 2950 : NULL, no_finalization);
11684 : }
11685 :
11686 : tree
11687 1 : gfc_bcast_alloc_comp (gfc_symbol *derived, gfc_expr *expr, int rank,
11688 : tree image_index, tree stat, tree errmsg,
11689 : tree errmsg_len)
11690 : {
11691 1 : tree tmp, array;
11692 1 : gfc_se argse;
11693 1 : stmtblock_t block, post_block;
11694 1 : gfc_co_subroutines_args args;
11695 :
11696 1 : args.image_index = image_index;
11697 1 : args.stat = stat;
11698 1 : args.errmsg = errmsg;
11699 1 : args.errmsg_len = errmsg_len;
11700 :
11701 1 : if (rank == 0)
11702 : {
11703 1 : gfc_start_block (&block);
11704 1 : gfc_init_block (&post_block);
11705 1 : gfc_init_se (&argse, NULL);
11706 1 : gfc_conv_expr (&argse, expr);
11707 1 : gfc_add_block_to_block (&block, &argse.pre);
11708 1 : gfc_add_block_to_block (&post_block, &argse.post);
11709 1 : array = argse.expr;
11710 : }
11711 : else
11712 : {
11713 0 : gfc_init_se (&argse, NULL);
11714 0 : argse.want_pointer = 1;
11715 0 : gfc_conv_expr_descriptor (&argse, expr);
11716 0 : array = argse.expr;
11717 : }
11718 :
11719 1 : tmp = structure_alloc_comps (derived, array, NULL_TREE, rank,
11720 : BCAST_ALLOC_COMP,
11721 : GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY,
11722 : &args);
11723 1 : return tmp;
11724 : }
11725 :
11726 : /* Recursively traverse an object of derived type, generating code to
11727 : deallocate allocatable components. But do not deallocate coarrays.
11728 : To be used for intrinsic assignment, which may not change the allocation
11729 : status of coarrays. */
11730 :
11731 : tree
11732 2330 : gfc_deallocate_alloc_comp_no_caf (gfc_symbol * der_type, tree decl, int rank,
11733 : bool no_finalization)
11734 : {
11735 2330 : return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11736 : DEALLOCATE_ALLOC_COMP, 0, NULL,
11737 2330 : no_finalization);
11738 : }
11739 :
11740 :
11741 : tree
11742 5 : gfc_reassign_alloc_comp_caf (gfc_symbol *der_type, tree decl, tree dest)
11743 : {
11744 5 : return structure_alloc_comps (der_type, decl, dest, 0, REASSIGN_CAF_COMP,
11745 : GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY,
11746 5 : NULL);
11747 : }
11748 :
11749 :
11750 : /* Recursively traverse an object of derived type, generating code to
11751 : copy it and its allocatable components. */
11752 :
11753 : tree
11754 4307 : gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank,
11755 : int caf_mode)
11756 : {
11757 4307 : return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP,
11758 4307 : caf_mode, NULL);
11759 : }
11760 :
11761 :
11762 : /* Recursively traverse an object of derived type, generating code to
11763 : copy it and its allocatable components, while suppressing any
11764 : finalization that might occur. This is used in the finalization of
11765 : function results. */
11766 :
11767 : tree
11768 38 : gfc_copy_alloc_comp_no_fini (gfc_symbol * der_type, tree decl, tree dest,
11769 : int rank, int caf_mode)
11770 : {
11771 38 : return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP,
11772 38 : caf_mode, NULL, true);
11773 : }
11774 :
11775 :
11776 : /* Recursively traverse an object of derived type, generating code to
11777 : copy only its allocatable components. */
11778 :
11779 : tree
11780 0 : gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
11781 : {
11782 0 : return structure_alloc_comps (der_type, decl, dest, rank,
11783 0 : COPY_ONLY_ALLOC_COMP, 0, NULL);
11784 : }
11785 :
11786 :
11787 : /* Recursively traverse an object of parameterized derived type, generating
11788 : code to allocate parameterized components. */
11789 :
11790 : tree
11791 681 : gfc_allocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank,
11792 : gfc_actual_arglist *param_list)
11793 : {
11794 681 : tree res;
11795 681 : gfc_actual_arglist *old_param_list = pdt_param_list;
11796 681 : pdt_param_list = param_list;
11797 681 : res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11798 : ALLOCATE_PDT_COMP, 0, NULL);
11799 681 : pdt_param_list = old_param_list;
11800 681 : return res;
11801 : }
11802 :
11803 : /* Recursively traverse an object of parameterized derived type, generating
11804 : code to deallocate parameterized components. */
11805 :
11806 : tree
11807 1002 : gfc_deallocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank)
11808 : {
11809 : /* A type without parameterized components causes gimplifier problems. */
11810 1002 : if (!has_parameterized_comps (der_type))
11811 : return NULL_TREE;
11812 :
11813 511 : return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11814 511 : DEALLOCATE_PDT_COMP, 0, NULL);
11815 : }
11816 :
11817 :
11818 : /* Recursively traverse a dummy of parameterized derived type to check the
11819 : values of LEN parameters. */
11820 :
11821 : tree
11822 74 : gfc_check_pdt_dummy (gfc_symbol * der_type, tree decl, int rank,
11823 : gfc_actual_arglist *param_list)
11824 : {
11825 74 : tree res;
11826 74 : gfc_actual_arglist *old_param_list = pdt_param_list;
11827 74 : pdt_param_list = param_list;
11828 74 : res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11829 : CHECK_PDT_DUMMY, 0, NULL);
11830 74 : pdt_param_list = old_param_list;
11831 74 : return res;
11832 : }
11833 :
11834 :
11835 : /* Returns the value of LBOUND for an expression. This could be broken out
11836 : from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
11837 : called by gfc_alloc_allocatable_for_assignment. */
11838 : static tree
11839 1054 : get_std_lbound (gfc_expr *expr, tree desc, int dim, bool assumed_size)
11840 : {
11841 1054 : tree lbound;
11842 1054 : tree ubound;
11843 1054 : tree stride;
11844 1054 : tree cond, cond1, cond3, cond4;
11845 1054 : tree tmp;
11846 1054 : gfc_ref *ref;
11847 :
11848 1054 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
11849 : {
11850 508 : tmp = gfc_rank_cst[dim];
11851 508 : lbound = gfc_conv_descriptor_lbound_get (desc, tmp);
11852 508 : ubound = gfc_conv_descriptor_ubound_get (desc, tmp);
11853 508 : stride = gfc_conv_descriptor_stride_get (desc, tmp);
11854 508 : cond1 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
11855 : ubound, lbound);
11856 508 : cond3 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
11857 : stride, gfc_index_zero_node);
11858 508 : cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
11859 : logical_type_node, cond3, cond1);
11860 508 : cond4 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
11861 : stride, gfc_index_zero_node);
11862 508 : if (assumed_size)
11863 0 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
11864 : tmp, build_int_cst (gfc_array_index_type,
11865 0 : expr->rank - 1));
11866 : else
11867 508 : cond = logical_false_node;
11868 :
11869 508 : cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
11870 : logical_type_node, cond3, cond4);
11871 508 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
11872 : logical_type_node, cond, cond1);
11873 :
11874 508 : return fold_build3_loc (input_location, COND_EXPR,
11875 : gfc_array_index_type, cond,
11876 508 : lbound, gfc_index_one_node);
11877 : }
11878 :
11879 546 : if (expr->expr_type == EXPR_FUNCTION)
11880 : {
11881 : /* A conversion function, so use the argument. */
11882 7 : gcc_assert (expr->value.function.isym
11883 : && expr->value.function.isym->conversion);
11884 7 : expr = expr->value.function.actual->expr;
11885 : }
11886 :
11887 546 : if (expr->expr_type == EXPR_VARIABLE)
11888 : {
11889 546 : tmp = TREE_TYPE (expr->symtree->n.sym->backend_decl);
11890 1418 : for (ref = expr->ref; ref; ref = ref->next)
11891 : {
11892 872 : if (ref->type == REF_COMPONENT
11893 277 : && ref->u.c.component->as
11894 228 : && ref->next
11895 228 : && ref->next->u.ar.type == AR_FULL)
11896 186 : tmp = TREE_TYPE (ref->u.c.component->backend_decl);
11897 : }
11898 546 : return GFC_TYPE_ARRAY_LBOUND(tmp, dim);
11899 : }
11900 :
11901 0 : return gfc_index_one_node;
11902 : }
11903 :
11904 :
11905 : /* Returns true if an expression represents an lhs that can be reallocated
11906 : on assignment. */
11907 :
11908 : bool
11909 633861 : gfc_is_reallocatable_lhs (gfc_expr *expr)
11910 : {
11911 633861 : gfc_ref * ref;
11912 633861 : gfc_symbol *sym;
11913 :
11914 633861 : if (!flag_realloc_lhs)
11915 : return false;
11916 :
11917 633361 : if (!expr->ref)
11918 : return false;
11919 :
11920 213003 : sym = expr->symtree->n.sym;
11921 :
11922 213003 : if (sym->attr.associate_var && !expr->ref)
11923 : return false;
11924 :
11925 : /* An allocatable class variable with no reference. */
11926 213003 : if (sym->ts.type == BT_CLASS
11927 6258 : && (!sym->attr.associate_var || sym->attr.select_rank_temporary)
11928 6098 : && CLASS_DATA (sym)->attr.allocatable
11929 : && expr->ref
11930 3650 : && ((expr->ref->type == REF_ARRAY && expr->ref->u.ar.type == AR_FULL
11931 690 : && expr->ref->next == NULL)
11932 3033 : || (expr->ref->type == REF_COMPONENT
11933 2776 : && strcmp (expr->ref->u.c.component->name, "_data") == 0
11934 2039 : && (expr->ref->next == NULL
11935 2039 : || (expr->ref->next->type == REF_ARRAY
11936 2039 : && expr->ref->next->u.ar.type == AR_FULL
11937 1725 : && expr->ref->next->next == NULL)))))
11938 : return true;
11939 :
11940 : /* An allocatable variable. */
11941 210801 : if (sym->attr.allocatable
11942 46522 : && (!sym->attr.associate_var || sym->attr.select_rank_temporary)
11943 : && expr->ref
11944 46522 : && expr->ref->type == REF_ARRAY
11945 45045 : && expr->ref->u.ar.type == AR_FULL)
11946 : return true;
11947 :
11948 : /* All that can be left are allocatable components. */
11949 182971 : if (sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
11950 : return false;
11951 :
11952 : /* Find a component ref followed by an array reference. */
11953 88685 : for (ref = expr->ref; ref; ref = ref->next)
11954 62086 : if (ref->next
11955 35487 : && ref->type == REF_COMPONENT
11956 20278 : && ref->next->type == REF_ARRAY
11957 16711 : && !ref->next->next)
11958 : break;
11959 :
11960 39203 : if (!ref)
11961 : return false;
11962 :
11963 : /* Return true if valid reallocatable lhs. */
11964 12604 : if (ref->u.c.component->attr.allocatable
11965 6240 : && ref->next->u.ar.type == AR_FULL)
11966 4626 : return true;
11967 :
11968 : return false;
11969 : }
11970 :
11971 :
11972 : static tree
11973 56 : concat_str_length (gfc_expr* expr)
11974 : {
11975 56 : tree type;
11976 56 : tree len1;
11977 56 : tree len2;
11978 56 : gfc_se se;
11979 :
11980 56 : type = gfc_typenode_for_spec (&expr->value.op.op1->ts);
11981 56 : len1 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
11982 56 : if (len1 == NULL_TREE)
11983 : {
11984 56 : if (expr->value.op.op1->expr_type == EXPR_OP)
11985 31 : len1 = concat_str_length (expr->value.op.op1);
11986 25 : else if (expr->value.op.op1->expr_type == EXPR_CONSTANT)
11987 25 : len1 = build_int_cst (gfc_charlen_type_node,
11988 25 : expr->value.op.op1->value.character.length);
11989 0 : else if (expr->value.op.op1->ts.u.cl->length)
11990 : {
11991 0 : gfc_init_se (&se, NULL);
11992 0 : gfc_conv_expr (&se, expr->value.op.op1->ts.u.cl->length);
11993 0 : len1 = se.expr;
11994 : }
11995 : else
11996 : {
11997 : /* Last resort! */
11998 0 : gfc_init_se (&se, NULL);
11999 0 : se.want_pointer = 1;
12000 0 : se.descriptor_only = 1;
12001 0 : gfc_conv_expr (&se, expr->value.op.op1);
12002 0 : len1 = se.string_length;
12003 : }
12004 : }
12005 :
12006 56 : type = gfc_typenode_for_spec (&expr->value.op.op2->ts);
12007 56 : len2 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
12008 56 : if (len2 == NULL_TREE)
12009 : {
12010 31 : if (expr->value.op.op2->expr_type == EXPR_OP)
12011 0 : len2 = concat_str_length (expr->value.op.op2);
12012 31 : else if (expr->value.op.op2->expr_type == EXPR_CONSTANT)
12013 25 : len2 = build_int_cst (gfc_charlen_type_node,
12014 25 : expr->value.op.op2->value.character.length);
12015 6 : else if (expr->value.op.op2->ts.u.cl->length)
12016 : {
12017 6 : gfc_init_se (&se, NULL);
12018 6 : gfc_conv_expr (&se, expr->value.op.op2->ts.u.cl->length);
12019 6 : len2 = se.expr;
12020 : }
12021 : else
12022 : {
12023 : /* Last resort! */
12024 0 : gfc_init_se (&se, NULL);
12025 0 : se.want_pointer = 1;
12026 0 : se.descriptor_only = 1;
12027 0 : gfc_conv_expr (&se, expr->value.op.op2);
12028 0 : len2 = se.string_length;
12029 : }
12030 : }
12031 :
12032 56 : gcc_assert(len1 && len2);
12033 56 : len1 = fold_convert (gfc_charlen_type_node, len1);
12034 56 : len2 = fold_convert (gfc_charlen_type_node, len2);
12035 :
12036 56 : return fold_build2_loc (input_location, PLUS_EXPR,
12037 56 : gfc_charlen_type_node, len1, len2);
12038 : }
12039 :
12040 :
12041 : /* Among the scalarization chain of LOOP, find the element associated with an
12042 : allocatable array on the lhs of an assignment and evaluate its fields
12043 : (bounds, offset, etc) to new variables, putting the new code in BLOCK. This
12044 : function is to be called after putting the reallocation code in BLOCK and
12045 : before the beginning of the scalarization loop body.
12046 :
12047 : The fields to be saved are expected to hold on entry to the function
12048 : expressions referencing the array descriptor. Especially the expressions
12049 : shouldn't be already temporary variable references as the value saved before
12050 : reallocation would be incorrect after reallocation.
12051 : At the end of the function, the expressions have been replaced with variable
12052 : references. */
12053 :
12054 : static void
12055 6646 : update_reallocated_descriptor (stmtblock_t *block, gfc_loopinfo *loop)
12056 : {
12057 23199 : for (gfc_ss *s = loop->ss; s != gfc_ss_terminator; s = s->loop_chain)
12058 : {
12059 16553 : if (!s->is_alloc_lhs)
12060 9907 : continue;
12061 :
12062 6646 : gcc_assert (s->info->type == GFC_SS_SECTION);
12063 6646 : gfc_array_info *info = &s->info->data.array;
12064 :
12065 : #define SAVE_VALUE(value) \
12066 : do \
12067 : { \
12068 : value = gfc_evaluate_now (value, block); \
12069 : } \
12070 : while (0)
12071 :
12072 6646 : if (save_descriptor_data (info->descriptor, info->data))
12073 5830 : SAVE_VALUE (info->data);
12074 6646 : SAVE_VALUE (info->offset);
12075 6646 : info->saved_offset = info->offset;
12076 16497 : for (int i = 0; i < s->dimen; i++)
12077 : {
12078 9851 : int dim = s->dim[i];
12079 9851 : SAVE_VALUE (info->start[dim]);
12080 9851 : SAVE_VALUE (info->end[dim]);
12081 9851 : SAVE_VALUE (info->stride[dim]);
12082 9851 : SAVE_VALUE (info->delta[dim]);
12083 : }
12084 :
12085 : #undef SAVE_VALUE
12086 : }
12087 6646 : }
12088 :
12089 :
12090 : /* Allocate the lhs of an assignment to an allocatable array, otherwise
12091 : reallocate it. */
12092 :
12093 : tree
12094 6646 : gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
12095 : gfc_expr *expr1,
12096 : gfc_expr *expr2)
12097 : {
12098 6646 : stmtblock_t realloc_block;
12099 6646 : stmtblock_t alloc_block;
12100 6646 : stmtblock_t fblock;
12101 6646 : stmtblock_t loop_pre_block;
12102 6646 : gfc_ref *ref;
12103 6646 : gfc_ss *rss;
12104 6646 : gfc_ss *lss;
12105 6646 : gfc_array_info *linfo;
12106 6646 : tree realloc_expr;
12107 6646 : tree alloc_expr;
12108 6646 : tree size1;
12109 6646 : tree size2;
12110 6646 : tree elemsize1;
12111 6646 : tree elemsize2;
12112 6646 : tree array1;
12113 6646 : tree cond_null;
12114 6646 : tree cond;
12115 6646 : tree tmp;
12116 6646 : tree tmp2;
12117 6646 : tree lbound;
12118 6646 : tree ubound;
12119 6646 : tree desc;
12120 6646 : tree old_desc;
12121 6646 : tree desc2;
12122 6646 : tree offset;
12123 6646 : tree jump_label1;
12124 6646 : tree jump_label2;
12125 6646 : tree lbd;
12126 6646 : tree class_expr2 = NULL_TREE;
12127 6646 : int n;
12128 6646 : gfc_array_spec * as;
12129 6646 : bool coarray = (flag_coarray == GFC_FCOARRAY_LIB
12130 6646 : && gfc_caf_attr (expr1, true).codimension);
12131 6646 : tree token;
12132 6646 : gfc_se caf_se;
12133 :
12134 : /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
12135 : Find the lhs expression in the loop chain and set expr1 and
12136 : expr2 accordingly. */
12137 6646 : if (expr1->expr_type == EXPR_FUNCTION && expr2 == NULL)
12138 : {
12139 203 : expr2 = expr1;
12140 : /* Find the ss for the lhs. */
12141 203 : lss = loop->ss;
12142 406 : for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
12143 406 : if (lss->info->expr && lss->info->expr->expr_type == EXPR_VARIABLE)
12144 : break;
12145 203 : if (lss == gfc_ss_terminator)
12146 : return NULL_TREE;
12147 203 : expr1 = lss->info->expr;
12148 : }
12149 :
12150 : /* Bail out if this is not a valid allocate on assignment. */
12151 6646 : if (!gfc_is_reallocatable_lhs (expr1)
12152 6646 : || (expr2 && !expr2->rank))
12153 : return NULL_TREE;
12154 :
12155 : /* Find the ss for the lhs. */
12156 6646 : lss = loop->ss;
12157 16553 : for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
12158 16553 : if (lss->info->expr == expr1)
12159 : break;
12160 :
12161 6646 : if (lss == gfc_ss_terminator)
12162 : return NULL_TREE;
12163 :
12164 6646 : linfo = &lss->info->data.array;
12165 :
12166 : /* Find an ss for the rhs. For operator expressions, we see the
12167 : ss's for the operands. Any one of these will do. */
12168 6646 : rss = loop->ss;
12169 7243 : for (; rss && rss != gfc_ss_terminator; rss = rss->loop_chain)
12170 7243 : if (rss->info->expr != expr1 && rss != loop->temp_ss)
12171 : break;
12172 :
12173 6646 : if (expr2 && rss == gfc_ss_terminator)
12174 : return NULL_TREE;
12175 :
12176 : /* Ensure that the string length from the current scope is used. */
12177 6646 : if (expr2->ts.type == BT_CHARACTER
12178 983 : && expr2->expr_type == EXPR_FUNCTION
12179 130 : && !expr2->value.function.isym)
12180 21 : expr2->ts.u.cl->backend_decl = rss->info->string_length;
12181 :
12182 : /* Since the lhs is allocatable, this must be a descriptor type.
12183 : Get the data and array size. */
12184 6646 : desc = linfo->descriptor;
12185 6646 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
12186 6646 : array1 = gfc_conv_descriptor_data_get (desc);
12187 :
12188 : /* If the data is null, set the descriptor bounds and offset. This suppresses
12189 : the maybe used uninitialized warning. Note that the always false variable
12190 : prevents this block from ever being executed, and makes sure that the
12191 : optimizers are able to remove it. Component references are not subject to
12192 : the warnings, so we don't uselessly complicate the generated code for them.
12193 : */
12194 11874 : for (ref = expr1->ref; ref; ref = ref->next)
12195 6853 : if (ref->type == REF_COMPONENT)
12196 : break;
12197 :
12198 6646 : if (!ref)
12199 : {
12200 5021 : stmtblock_t unalloc_init_block;
12201 5021 : gfc_init_block (&unalloc_init_block);
12202 5021 : tree guard = gfc_create_var (logical_type_node, "unallocated_init_guard");
12203 5021 : gfc_add_modify (&unalloc_init_block, guard, logical_false_node);
12204 :
12205 5021 : gfc_start_block (&loop_pre_block);
12206 17911 : for (n = 0; n < expr1->rank; n++)
12207 : {
12208 7869 : gfc_conv_descriptor_lbound_set (&loop_pre_block, desc,
12209 : gfc_rank_cst[n],
12210 : gfc_index_one_node);
12211 7869 : gfc_conv_descriptor_ubound_set (&loop_pre_block, desc,
12212 : gfc_rank_cst[n],
12213 : gfc_index_zero_node);
12214 7869 : gfc_conv_descriptor_stride_set (&loop_pre_block, desc,
12215 : gfc_rank_cst[n],
12216 : gfc_index_zero_node);
12217 : }
12218 :
12219 5021 : gfc_conv_descriptor_offset_set (&loop_pre_block, desc,
12220 : gfc_index_zero_node);
12221 :
12222 5021 : tmp = fold_build2_loc (input_location, EQ_EXPR,
12223 : logical_type_node, array1,
12224 5021 : build_int_cst (TREE_TYPE (array1), 0));
12225 5021 : tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
12226 : logical_type_node, tmp, guard);
12227 5021 : tmp = build3_v (COND_EXPR, tmp,
12228 : gfc_finish_block (&loop_pre_block),
12229 : build_empty_stmt (input_location));
12230 5021 : gfc_prepend_expr_to_block (&loop->pre, tmp);
12231 5021 : gfc_prepend_expr_to_block (&loop->pre,
12232 : gfc_finish_block (&unalloc_init_block));
12233 : }
12234 :
12235 6646 : gfc_start_block (&fblock);
12236 :
12237 6646 : if (expr2)
12238 6646 : desc2 = rss->info->data.array.descriptor;
12239 : else
12240 : desc2 = NULL_TREE;
12241 :
12242 : /* Get the old lhs element size for deferred character and class expr1. */
12243 6646 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12244 : {
12245 663 : if (expr1->ts.u.cl->backend_decl
12246 663 : && VAR_P (expr1->ts.u.cl->backend_decl))
12247 : elemsize1 = expr1->ts.u.cl->backend_decl;
12248 : else
12249 64 : elemsize1 = lss->info->string_length;
12250 663 : tree unit_size = TYPE_SIZE_UNIT (gfc_get_char_type (expr1->ts.kind));
12251 1326 : elemsize1 = fold_build2_loc (input_location, MULT_EXPR,
12252 663 : TREE_TYPE (elemsize1), elemsize1,
12253 663 : fold_convert (TREE_TYPE (elemsize1), unit_size));
12254 :
12255 663 : }
12256 5983 : else if (expr1->ts.type == BT_CLASS)
12257 : {
12258 : /* Unfortunately, the lhs vptr is set too early in many cases.
12259 : Play it safe by using the descriptor element length. */
12260 645 : tmp = gfc_conv_descriptor_elem_len (desc);
12261 645 : elemsize1 = fold_convert (gfc_array_index_type, tmp);
12262 : }
12263 : else
12264 : elemsize1 = NULL_TREE;
12265 1308 : if (elemsize1 != NULL_TREE)
12266 1308 : elemsize1 = gfc_evaluate_now (elemsize1, &fblock);
12267 :
12268 : /* Get the new lhs size in bytes. */
12269 6646 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12270 : {
12271 663 : if (expr2->ts.deferred)
12272 : {
12273 183 : if (expr2->ts.u.cl->backend_decl
12274 183 : && VAR_P (expr2->ts.u.cl->backend_decl))
12275 : tmp = expr2->ts.u.cl->backend_decl;
12276 : else
12277 0 : tmp = rss->info->string_length;
12278 : }
12279 : else
12280 : {
12281 480 : tmp = expr2->ts.u.cl->backend_decl;
12282 480 : if (!tmp && expr2->expr_type == EXPR_OP
12283 25 : && expr2->value.op.op == INTRINSIC_CONCAT)
12284 : {
12285 25 : tmp = concat_str_length (expr2);
12286 25 : expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
12287 : }
12288 12 : else if (!tmp && expr2->ts.u.cl->length)
12289 : {
12290 12 : gfc_se tmpse;
12291 12 : gfc_init_se (&tmpse, NULL);
12292 12 : gfc_conv_expr_type (&tmpse, expr2->ts.u.cl->length,
12293 : gfc_charlen_type_node);
12294 12 : tmp = tmpse.expr;
12295 12 : expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
12296 : }
12297 480 : tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
12298 : }
12299 :
12300 663 : if (expr1->ts.u.cl->backend_decl
12301 663 : && VAR_P (expr1->ts.u.cl->backend_decl))
12302 599 : gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
12303 : else
12304 64 : gfc_add_modify (&fblock, lss->info->string_length, tmp);
12305 :
12306 663 : if (expr1->ts.kind > 1)
12307 12 : tmp = fold_build2_loc (input_location, MULT_EXPR,
12308 6 : TREE_TYPE (tmp),
12309 6 : tmp, build_int_cst (TREE_TYPE (tmp),
12310 6 : expr1->ts.kind));
12311 : }
12312 5983 : else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
12313 : {
12314 271 : tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts)));
12315 271 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
12316 : fold_convert (gfc_array_index_type, tmp),
12317 271 : expr1->ts.u.cl->backend_decl);
12318 : }
12319 5712 : else if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS)
12320 164 : tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
12321 5548 : else if (expr1->ts.type == BT_CLASS && expr2->ts.type == BT_CLASS)
12322 : {
12323 280 : tmp = expr2->rank ? gfc_get_class_from_expr (desc2) : NULL_TREE;
12324 280 : if (tmp == NULL_TREE && expr2->expr_type == EXPR_VARIABLE)
12325 36 : tmp = class_expr2 = gfc_get_class_from_gfc_expr (expr2);
12326 :
12327 43 : if (tmp != NULL_TREE)
12328 273 : tmp = gfc_class_vtab_size_get (tmp);
12329 : else
12330 7 : tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&CLASS_DATA (expr2)->ts));
12331 : }
12332 : else
12333 5268 : tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
12334 6646 : elemsize2 = fold_convert (gfc_array_index_type, tmp);
12335 6646 : elemsize2 = gfc_evaluate_now (elemsize2, &fblock);
12336 :
12337 : /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
12338 : deallocated if expr is an array of different shape or any of the
12339 : corresponding length type parameter values of variable and expr
12340 : differ." This assures F95 compatibility. */
12341 6646 : jump_label1 = gfc_build_label_decl (NULL_TREE);
12342 6646 : jump_label2 = gfc_build_label_decl (NULL_TREE);
12343 :
12344 : /* Allocate if data is NULL. */
12345 6646 : cond_null = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
12346 6646 : array1, build_int_cst (TREE_TYPE (array1), 0));
12347 6646 : cond_null= gfc_evaluate_now (cond_null, &fblock);
12348 :
12349 6646 : tmp = build3_v (COND_EXPR, cond_null,
12350 : build1_v (GOTO_EXPR, jump_label1),
12351 : build_empty_stmt (input_location));
12352 6646 : gfc_add_expr_to_block (&fblock, tmp);
12353 :
12354 : /* Get arrayspec if expr is a full array. */
12355 6646 : if (expr2 && expr2->expr_type == EXPR_FUNCTION
12356 2814 : && expr2->value.function.isym
12357 2295 : && expr2->value.function.isym->conversion)
12358 : {
12359 : /* For conversion functions, take the arg. */
12360 245 : gfc_expr *arg = expr2->value.function.actual->expr;
12361 245 : as = gfc_get_full_arrayspec_from_expr (arg);
12362 245 : }
12363 : else if (expr2)
12364 6401 : as = gfc_get_full_arrayspec_from_expr (expr2);
12365 : else
12366 : as = NULL;
12367 :
12368 : /* If the lhs shape is not the same as the rhs jump to setting the
12369 : bounds and doing the reallocation....... */
12370 16497 : for (n = 0; n < expr1->rank; n++)
12371 : {
12372 : /* Check the shape. */
12373 9851 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
12374 9851 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
12375 9851 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
12376 : gfc_array_index_type,
12377 : loop->to[n], loop->from[n]);
12378 9851 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
12379 : gfc_array_index_type,
12380 : tmp, lbound);
12381 9851 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
12382 : gfc_array_index_type,
12383 : tmp, ubound);
12384 9851 : cond = fold_build2_loc (input_location, NE_EXPR,
12385 : logical_type_node,
12386 : tmp, gfc_index_zero_node);
12387 9851 : tmp = build3_v (COND_EXPR, cond,
12388 : build1_v (GOTO_EXPR, jump_label1),
12389 : build_empty_stmt (input_location));
12390 9851 : gfc_add_expr_to_block (&fblock, tmp);
12391 : }
12392 :
12393 : /* ...else if the element lengths are not the same also go to
12394 : setting the bounds and doing the reallocation.... */
12395 6646 : if (elemsize1 != NULL_TREE)
12396 : {
12397 1308 : cond = fold_build2_loc (input_location, NE_EXPR,
12398 : logical_type_node,
12399 : elemsize1, elemsize2);
12400 1308 : tmp = build3_v (COND_EXPR, cond,
12401 : build1_v (GOTO_EXPR, jump_label1),
12402 : build_empty_stmt (input_location));
12403 1308 : gfc_add_expr_to_block (&fblock, tmp);
12404 : }
12405 :
12406 : /* ....else jump past the (re)alloc code. */
12407 6646 : tmp = build1_v (GOTO_EXPR, jump_label2);
12408 6646 : gfc_add_expr_to_block (&fblock, tmp);
12409 :
12410 : /* Add the label to start automatic (re)allocation. */
12411 6646 : tmp = build1_v (LABEL_EXPR, jump_label1);
12412 6646 : gfc_add_expr_to_block (&fblock, tmp);
12413 :
12414 : /* Get the rhs size and fix it. */
12415 6646 : size2 = gfc_index_one_node;
12416 16497 : for (n = 0; n < expr2->rank; n++)
12417 : {
12418 9851 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
12419 : gfc_array_index_type,
12420 : loop->to[n], loop->from[n]);
12421 9851 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
12422 : gfc_array_index_type,
12423 : tmp, gfc_index_one_node);
12424 9851 : size2 = fold_build2_loc (input_location, MULT_EXPR,
12425 : gfc_array_index_type,
12426 : tmp, size2);
12427 : }
12428 6646 : size2 = gfc_evaluate_now (size2, &fblock);
12429 :
12430 : /* Deallocation of allocatable components will have to occur on
12431 : reallocation. Fix the old descriptor now. */
12432 6646 : if ((expr1->ts.type == BT_DERIVED)
12433 440 : && expr1->ts.u.derived->attr.alloc_comp)
12434 163 : old_desc = gfc_evaluate_now (desc, &fblock);
12435 : else
12436 : old_desc = NULL_TREE;
12437 :
12438 : /* Now modify the lhs descriptor and the associated scalarizer
12439 : variables. F2003 7.4.1.3: "If variable is or becomes an
12440 : unallocated allocatable variable, then it is allocated with each
12441 : deferred type parameter equal to the corresponding type parameters
12442 : of expr , with the shape of expr , and with each lower bound equal
12443 : to the corresponding element of LBOUND(expr)."
12444 : Reuse size1 to keep a dimension-by-dimension track of the
12445 : stride of the new array. */
12446 6646 : size1 = gfc_index_one_node;
12447 6646 : offset = gfc_index_zero_node;
12448 :
12449 16497 : for (n = 0; n < expr2->rank; n++)
12450 : {
12451 9851 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
12452 : gfc_array_index_type,
12453 : loop->to[n], loop->from[n]);
12454 9851 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
12455 : gfc_array_index_type,
12456 : tmp, gfc_index_one_node);
12457 :
12458 9851 : lbound = gfc_index_one_node;
12459 9851 : ubound = tmp;
12460 :
12461 9851 : if (as)
12462 : {
12463 2108 : lbd = get_std_lbound (expr2, desc2, n,
12464 1054 : as->type == AS_ASSUMED_SIZE);
12465 1054 : ubound = fold_build2_loc (input_location,
12466 : MINUS_EXPR,
12467 : gfc_array_index_type,
12468 : ubound, lbound);
12469 1054 : ubound = fold_build2_loc (input_location,
12470 : PLUS_EXPR,
12471 : gfc_array_index_type,
12472 : ubound, lbd);
12473 1054 : lbound = lbd;
12474 : }
12475 :
12476 9851 : gfc_conv_descriptor_lbound_set (&fblock, desc,
12477 : gfc_rank_cst[n],
12478 : lbound);
12479 9851 : gfc_conv_descriptor_ubound_set (&fblock, desc,
12480 : gfc_rank_cst[n],
12481 : ubound);
12482 9851 : gfc_conv_descriptor_stride_set (&fblock, desc,
12483 : gfc_rank_cst[n],
12484 : size1);
12485 9851 : lbound = gfc_conv_descriptor_lbound_get (desc,
12486 : gfc_rank_cst[n]);
12487 9851 : tmp2 = fold_build2_loc (input_location, MULT_EXPR,
12488 : gfc_array_index_type,
12489 : lbound, size1);
12490 9851 : offset = fold_build2_loc (input_location, MINUS_EXPR,
12491 : gfc_array_index_type,
12492 : offset, tmp2);
12493 9851 : size1 = fold_build2_loc (input_location, MULT_EXPR,
12494 : gfc_array_index_type,
12495 : tmp, size1);
12496 : }
12497 :
12498 : /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
12499 : the array offset is saved and the info.offset is used for a
12500 : running offset. Use the saved_offset instead. */
12501 6646 : tmp = gfc_conv_descriptor_offset (desc);
12502 6646 : gfc_add_modify (&fblock, tmp, offset);
12503 :
12504 : /* Take into account _len of unlimited polymorphic entities, so that span
12505 : for array descriptors and allocation sizes are computed correctly. */
12506 6646 : if (UNLIMITED_POLY (expr2))
12507 : {
12508 92 : tree len = gfc_class_len_get (TREE_OPERAND (desc2, 0));
12509 92 : len = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
12510 : fold_convert (size_type_node, len),
12511 : size_one_node);
12512 92 : elemsize2 = fold_build2_loc (input_location, MULT_EXPR,
12513 : gfc_array_index_type, elemsize2,
12514 : fold_convert (gfc_array_index_type, len));
12515 : }
12516 :
12517 6646 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
12518 6646 : gfc_conv_descriptor_span_set (&fblock, desc, elemsize2);
12519 :
12520 6646 : size2 = fold_build2_loc (input_location, MULT_EXPR,
12521 : gfc_array_index_type,
12522 : elemsize2, size2);
12523 6646 : size2 = fold_convert (size_type_node, size2);
12524 6646 : size2 = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
12525 : size2, size_one_node);
12526 6646 : size2 = gfc_evaluate_now (size2, &fblock);
12527 :
12528 : /* For deferred character length, the 'size' field of the dtype might
12529 : have changed so set the dtype. */
12530 6646 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
12531 6646 : && expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12532 : {
12533 663 : tree type;
12534 663 : tmp = gfc_conv_descriptor_dtype (desc);
12535 663 : if (expr2->ts.u.cl->backend_decl)
12536 663 : type = gfc_typenode_for_spec (&expr2->ts);
12537 : else
12538 0 : type = gfc_typenode_for_spec (&expr1->ts);
12539 :
12540 663 : gfc_add_modify (&fblock, tmp,
12541 : gfc_get_dtype_rank_type (expr1->rank,type));
12542 : }
12543 5983 : else if (expr1->ts.type == BT_CLASS)
12544 : {
12545 645 : tree type;
12546 645 : tmp = gfc_conv_descriptor_dtype (desc);
12547 :
12548 645 : if (expr2->ts.type != BT_CLASS)
12549 365 : type = gfc_typenode_for_spec (&expr2->ts);
12550 : else
12551 280 : type = gfc_get_character_type_len (1, elemsize2);
12552 :
12553 645 : gfc_add_modify (&fblock, tmp,
12554 : gfc_get_dtype_rank_type (expr2->rank,type));
12555 : /* Set the _len field as well... */
12556 645 : if (UNLIMITED_POLY (expr1))
12557 : {
12558 256 : tmp = gfc_class_len_get (TREE_OPERAND (desc, 0));
12559 256 : if (expr2->ts.type == BT_CHARACTER)
12560 49 : gfc_add_modify (&fblock, tmp,
12561 49 : fold_convert (TREE_TYPE (tmp),
12562 : TYPE_SIZE_UNIT (type)));
12563 207 : else if (UNLIMITED_POLY (expr2))
12564 92 : gfc_add_modify (&fblock, tmp,
12565 92 : gfc_class_len_get (TREE_OPERAND (desc2, 0)));
12566 : else
12567 115 : gfc_add_modify (&fblock, tmp,
12568 115 : build_int_cst (TREE_TYPE (tmp), 0));
12569 : }
12570 : /* ...and the vptr. */
12571 645 : tmp = gfc_class_vptr_get (TREE_OPERAND (desc, 0));
12572 645 : if (expr2->ts.type == BT_CLASS && !VAR_P (desc2)
12573 273 : && TREE_CODE (desc2) == COMPONENT_REF)
12574 : {
12575 237 : tmp2 = gfc_get_class_from_expr (desc2);
12576 237 : tmp2 = gfc_class_vptr_get (tmp2);
12577 : }
12578 408 : else if (expr2->ts.type == BT_CLASS && class_expr2 != NULL_TREE)
12579 36 : tmp2 = gfc_class_vptr_get (class_expr2);
12580 : else
12581 : {
12582 372 : tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts));
12583 372 : tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2);
12584 : }
12585 :
12586 645 : gfc_add_modify (&fblock, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
12587 : }
12588 5338 : else if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
12589 : {
12590 39 : gfc_add_modify (&fblock, gfc_conv_descriptor_dtype (desc),
12591 39 : gfc_get_dtype (TREE_TYPE (desc)));
12592 : }
12593 :
12594 : /* Realloc expression. Note that the scalarizer uses desc.data
12595 : in the array reference - (*desc.data)[<element>]. */
12596 6646 : gfc_init_block (&realloc_block);
12597 6646 : gfc_init_se (&caf_se, NULL);
12598 :
12599 6646 : if (coarray)
12600 : {
12601 39 : token = gfc_get_ultimate_alloc_ptr_comps_caf_token (&caf_se, expr1);
12602 39 : if (token == NULL_TREE)
12603 : {
12604 9 : tmp = gfc_get_tree_for_caf_expr (expr1);
12605 9 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
12606 6 : tmp = build_fold_indirect_ref (tmp);
12607 9 : gfc_get_caf_token_offset (&caf_se, &token, NULL, tmp, NULL_TREE,
12608 : expr1);
12609 9 : token = gfc_build_addr_expr (NULL_TREE, token);
12610 : }
12611 :
12612 39 : gfc_add_block_to_block (&realloc_block, &caf_se.pre);
12613 : }
12614 6646 : if ((expr1->ts.type == BT_DERIVED)
12615 440 : && expr1->ts.u.derived->attr.alloc_comp)
12616 : {
12617 163 : tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, old_desc,
12618 : expr1->rank, true);
12619 163 : gfc_add_expr_to_block (&realloc_block, tmp);
12620 : }
12621 :
12622 6646 : if (!coarray)
12623 : {
12624 6607 : tmp = build_call_expr_loc (input_location,
12625 : builtin_decl_explicit (BUILT_IN_REALLOC), 2,
12626 : fold_convert (pvoid_type_node, array1),
12627 : size2);
12628 6607 : if (flag_openmp_allocators)
12629 : {
12630 2 : tree cond, omp_tmp;
12631 2 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
12632 : gfc_conv_descriptor_version (desc),
12633 : build_int_cst (integer_type_node, 1));
12634 2 : omp_tmp = builtin_decl_explicit (BUILT_IN_GOMP_REALLOC);
12635 2 : omp_tmp = build_call_expr_loc (input_location, omp_tmp, 4,
12636 : fold_convert (pvoid_type_node, array1), size2,
12637 : build_zero_cst (ptr_type_node),
12638 : build_zero_cst (ptr_type_node));
12639 2 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond,
12640 : omp_tmp, tmp);
12641 : }
12642 :
12643 6607 : gfc_conv_descriptor_data_set (&realloc_block, desc, tmp);
12644 : }
12645 : else
12646 : {
12647 39 : tmp = build_call_expr_loc (input_location,
12648 : gfor_fndecl_caf_deregister, 5, token,
12649 : build_int_cst (integer_type_node,
12650 : GFC_CAF_COARRAY_DEALLOCATE_ONLY),
12651 : null_pointer_node, null_pointer_node,
12652 : integer_zero_node);
12653 39 : gfc_add_expr_to_block (&realloc_block, tmp);
12654 39 : tmp = build_call_expr_loc (input_location,
12655 : gfor_fndecl_caf_register,
12656 : 7, size2,
12657 : build_int_cst (integer_type_node,
12658 : GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY),
12659 : token, gfc_build_addr_expr (NULL_TREE, desc),
12660 : null_pointer_node, null_pointer_node,
12661 : integer_zero_node);
12662 39 : gfc_add_expr_to_block (&realloc_block, tmp);
12663 : }
12664 :
12665 6646 : if ((expr1->ts.type == BT_DERIVED)
12666 440 : && expr1->ts.u.derived->attr.alloc_comp)
12667 : {
12668 163 : tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc,
12669 : expr1->rank);
12670 163 : gfc_add_expr_to_block (&realloc_block, tmp);
12671 : }
12672 :
12673 6646 : gfc_add_block_to_block (&realloc_block, &caf_se.post);
12674 6646 : realloc_expr = gfc_finish_block (&realloc_block);
12675 :
12676 : /* Malloc expression. */
12677 6646 : gfc_init_block (&alloc_block);
12678 6646 : if (!coarray)
12679 : {
12680 6607 : tmp = build_call_expr_loc (input_location,
12681 : builtin_decl_explicit (BUILT_IN_MALLOC),
12682 : 1, size2);
12683 6607 : gfc_conv_descriptor_data_set (&alloc_block,
12684 : desc, tmp);
12685 : }
12686 : else
12687 : {
12688 39 : tmp = build_call_expr_loc (input_location,
12689 : gfor_fndecl_caf_register,
12690 : 7, size2,
12691 : build_int_cst (integer_type_node,
12692 : GFC_CAF_COARRAY_ALLOC),
12693 : token, gfc_build_addr_expr (NULL_TREE, desc),
12694 : null_pointer_node, null_pointer_node,
12695 : integer_zero_node);
12696 39 : gfc_add_expr_to_block (&alloc_block, tmp);
12697 : }
12698 :
12699 :
12700 : /* We already set the dtype in the case of deferred character
12701 : length arrays and class lvalues. */
12702 6646 : if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
12703 6646 : && ((expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12704 5983 : || coarray))
12705 12590 : && expr1->ts.type != BT_CLASS)
12706 : {
12707 5299 : tmp = gfc_conv_descriptor_dtype (desc);
12708 5299 : gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
12709 : }
12710 :
12711 6646 : if ((expr1->ts.type == BT_DERIVED)
12712 440 : && expr1->ts.u.derived->attr.alloc_comp)
12713 : {
12714 163 : tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc,
12715 : expr1->rank);
12716 163 : gfc_add_expr_to_block (&alloc_block, tmp);
12717 : }
12718 6646 : alloc_expr = gfc_finish_block (&alloc_block);
12719 :
12720 : /* Malloc if not allocated; realloc otherwise. */
12721 6646 : tmp = build3_v (COND_EXPR, cond_null, alloc_expr, realloc_expr);
12722 6646 : gfc_add_expr_to_block (&fblock, tmp);
12723 :
12724 : /* Add the label for same shape lhs and rhs. */
12725 6646 : tmp = build1_v (LABEL_EXPR, jump_label2);
12726 6646 : gfc_add_expr_to_block (&fblock, tmp);
12727 :
12728 6646 : tree realloc_code = gfc_finish_block (&fblock);
12729 :
12730 6646 : stmtblock_t result_block;
12731 6646 : gfc_init_block (&result_block);
12732 6646 : gfc_add_expr_to_block (&result_block, realloc_code);
12733 6646 : update_reallocated_descriptor (&result_block, loop);
12734 :
12735 6646 : return gfc_finish_block (&result_block);
12736 : }
12737 :
12738 :
12739 : /* Initialize class descriptor's TKR information. */
12740 :
12741 : void
12742 2926 : gfc_trans_class_array (gfc_symbol * sym, gfc_wrapped_block * block)
12743 : {
12744 2926 : tree type, etype;
12745 2926 : tree tmp;
12746 2926 : tree descriptor;
12747 2926 : stmtblock_t init;
12748 2926 : int rank;
12749 :
12750 : /* Make sure the frontend gets these right. */
12751 2926 : gcc_assert (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
12752 : && (CLASS_DATA (sym)->attr.class_pointer
12753 : || CLASS_DATA (sym)->attr.allocatable));
12754 :
12755 2926 : gcc_assert (VAR_P (sym->backend_decl)
12756 : || TREE_CODE (sym->backend_decl) == PARM_DECL);
12757 :
12758 2926 : if (sym->attr.dummy)
12759 1430 : return;
12760 :
12761 2926 : descriptor = gfc_class_data_get (sym->backend_decl);
12762 2926 : type = TREE_TYPE (descriptor);
12763 :
12764 2926 : if (type == NULL || !GFC_DESCRIPTOR_TYPE_P (type))
12765 : return;
12766 :
12767 1496 : location_t loc = input_location;
12768 1496 : input_location = gfc_get_location (&sym->declared_at);
12769 1496 : gfc_init_block (&init);
12770 :
12771 1496 : rank = CLASS_DATA (sym)->as ? (CLASS_DATA (sym)->as->rank) : (0);
12772 1496 : gcc_assert (rank>=0);
12773 1496 : tmp = gfc_conv_descriptor_dtype (descriptor);
12774 1496 : etype = gfc_get_element_type (type);
12775 1496 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (tmp), tmp,
12776 : gfc_get_dtype_rank_type (rank, etype));
12777 1496 : gfc_add_expr_to_block (&init, tmp);
12778 :
12779 1496 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
12780 1496 : input_location = loc;
12781 : }
12782 :
12783 :
12784 : /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
12785 : Do likewise, recursively if necessary, with the allocatable components of
12786 : derived types. This function is also called for assumed-rank arrays, which
12787 : are always dummy arguments. */
12788 :
12789 : void
12790 17986 : gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
12791 : {
12792 17986 : tree type;
12793 17986 : tree tmp;
12794 17986 : tree descriptor;
12795 17986 : stmtblock_t init;
12796 17986 : stmtblock_t cleanup;
12797 17986 : int rank;
12798 17986 : bool sym_has_alloc_comp, has_finalizer;
12799 :
12800 35972 : sym_has_alloc_comp = (sym->ts.type == BT_DERIVED
12801 10923 : || sym->ts.type == BT_CLASS)
12802 17986 : && sym->ts.u.derived->attr.alloc_comp;
12803 17986 : has_finalizer = gfc_may_be_finalized (sym->ts);
12804 :
12805 : /* Make sure the frontend gets these right. */
12806 17986 : gcc_assert (sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp
12807 : || has_finalizer
12808 : || (sym->as->type == AS_ASSUMED_RANK && sym->attr.dummy));
12809 :
12810 17986 : location_t loc = input_location;
12811 17986 : input_location = gfc_get_location (&sym->declared_at);
12812 17986 : gfc_init_block (&init);
12813 :
12814 17986 : gcc_assert (VAR_P (sym->backend_decl)
12815 : || TREE_CODE (sym->backend_decl) == PARM_DECL);
12816 :
12817 17986 : if (sym->ts.type == BT_CHARACTER
12818 1390 : && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
12819 : {
12820 812 : if (sym->ts.deferred && !sym->ts.u.cl->length && !sym->attr.dummy)
12821 : {
12822 607 : tree len_expr = sym->ts.u.cl->backend_decl;
12823 607 : tree init_val = build_zero_cst (TREE_TYPE (len_expr));
12824 607 : if (VAR_P (len_expr)
12825 607 : && sym->attr.save
12826 662 : && !DECL_INITIAL (len_expr))
12827 55 : DECL_INITIAL (len_expr) = init_val;
12828 : else
12829 552 : gfc_add_modify (&init, len_expr, init_val);
12830 : }
12831 812 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
12832 812 : gfc_trans_vla_type_sizes (sym, &init);
12833 :
12834 : /* Presence check of optional deferred-length character dummy. */
12835 812 : if (sym->ts.deferred && sym->attr.dummy && sym->attr.optional)
12836 : {
12837 43 : tmp = gfc_finish_block (&init);
12838 43 : tmp = build3_v (COND_EXPR, gfc_conv_expr_present (sym),
12839 : tmp, build_empty_stmt (input_location));
12840 43 : gfc_add_expr_to_block (&init, tmp);
12841 : }
12842 : }
12843 :
12844 : /* Dummy, use associated and result variables don't need anything special. */
12845 17986 : if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result)
12846 : {
12847 870 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
12848 870 : input_location = loc;
12849 1146 : return;
12850 : }
12851 :
12852 17116 : descriptor = sym->backend_decl;
12853 :
12854 : /* Although static, derived types with default initializers and
12855 : allocatable components must not be nulled wholesale; instead they
12856 : are treated component by component. */
12857 17116 : if (TREE_STATIC (descriptor) && !sym_has_alloc_comp && !has_finalizer)
12858 : {
12859 : /* SAVEd variables are not freed on exit. */
12860 276 : gfc_trans_static_array_pointer (sym);
12861 :
12862 276 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
12863 276 : input_location = loc;
12864 276 : return;
12865 : }
12866 :
12867 : /* Get the descriptor type. */
12868 16840 : type = TREE_TYPE (sym->backend_decl);
12869 :
12870 16840 : if ((sym_has_alloc_comp || (has_finalizer && sym->ts.type != BT_CLASS))
12871 5458 : && !(sym->attr.pointer || sym->attr.allocatable))
12872 : {
12873 2867 : if (!sym->attr.save
12874 2470 : && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program))
12875 : {
12876 2470 : if (sym->value == NULL
12877 2470 : || !gfc_has_default_initializer (sym->ts.u.derived))
12878 : {
12879 2045 : rank = sym->as ? sym->as->rank : 0;
12880 2045 : tmp = gfc_nullify_alloc_comp (sym->ts.u.derived,
12881 : descriptor, rank);
12882 2045 : gfc_add_expr_to_block (&init, tmp);
12883 : }
12884 : else
12885 425 : gfc_init_default_dt (sym, &init, false);
12886 : }
12887 : }
12888 13973 : else if (!GFC_DESCRIPTOR_TYPE_P (type))
12889 : {
12890 : /* If the backend_decl is not a descriptor, we must have a pointer
12891 : to one. */
12892 2026 : descriptor = build_fold_indirect_ref_loc (input_location,
12893 : sym->backend_decl);
12894 2026 : type = TREE_TYPE (descriptor);
12895 : }
12896 :
12897 : /* NULLIFY the data pointer for non-saved allocatables, or for non-saved
12898 : pointers when -fcheck=pointer is specified. */
12899 28787 : if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save
12900 28774 : && (sym->attr.allocatable
12901 3281 : || (sym->attr.pointer && (gfc_option.rtcheck & GFC_RTCHECK_POINTER))))
12902 : {
12903 8696 : gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node);
12904 8696 : if (flag_coarray == GFC_FCOARRAY_LIB && sym->attr.codimension)
12905 : {
12906 : /* Declare the variable static so its array descriptor stays present
12907 : after leaving the scope. It may still be accessed through another
12908 : image. This may happen, for example, with the caf_mpi
12909 : implementation. */
12910 161 : TREE_STATIC (descriptor) = 1;
12911 161 : tmp = gfc_conv_descriptor_token (descriptor);
12912 161 : gfc_add_modify (&init, tmp, fold_convert (TREE_TYPE (tmp),
12913 : null_pointer_node));
12914 : }
12915 : }
12916 :
12917 : /* Set initial TKR for pointers and allocatables */
12918 16840 : if (GFC_DESCRIPTOR_TYPE_P (type)
12919 16840 : && (sym->attr.pointer || sym->attr.allocatable))
12920 : {
12921 11947 : tree etype;
12922 :
12923 11947 : gcc_assert (sym->as && sym->as->rank>=0);
12924 11947 : tmp = gfc_conv_descriptor_dtype (descriptor);
12925 11947 : etype = gfc_get_element_type (type);
12926 11947 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
12927 11947 : TREE_TYPE (tmp), tmp,
12928 11947 : gfc_get_dtype_rank_type (sym->as->rank, etype));
12929 11947 : gfc_add_expr_to_block (&init, tmp);
12930 : }
12931 16840 : input_location = loc;
12932 16840 : gfc_init_block (&cleanup);
12933 :
12934 : /* Allocatable arrays need to be freed when they go out of scope.
12935 : The allocatable components of pointers must not be touched. */
12936 16840 : if (!sym->attr.allocatable && has_finalizer && sym->ts.type != BT_CLASS
12937 574 : && !sym->attr.pointer && !sym->attr.artificial && !sym->attr.save
12938 303 : && !sym->ns->proc_name->attr.is_main_program)
12939 : {
12940 264 : gfc_expr *e;
12941 264 : sym->attr.referenced = 1;
12942 264 : e = gfc_lval_expr_from_sym (sym);
12943 264 : gfc_add_finalizer_call (&cleanup, e);
12944 264 : gfc_free_expr (e);
12945 264 : }
12946 16576 : else if ((!sym->attr.allocatable || !has_finalizer)
12947 16452 : && sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
12948 4919 : && !sym->attr.pointer && !sym->attr.save
12949 2470 : && !(sym->attr.artificial && sym->name[0] == '_')
12950 2415 : && !sym->ns->proc_name->attr.is_main_program)
12951 : {
12952 656 : int rank;
12953 656 : rank = sym->as ? sym->as->rank : 0;
12954 656 : tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank,
12955 656 : (sym->attr.codimension
12956 3 : && flag_coarray == GFC_FCOARRAY_LIB)
12957 : ? GFC_STRUCTURE_CAF_MODE_IN_COARRAY
12958 : : 0);
12959 656 : gfc_add_expr_to_block (&cleanup, tmp);
12960 : }
12961 :
12962 16840 : if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension)
12963 8660 : && !sym->attr.save && !sym->attr.result
12964 8653 : && !sym->ns->proc_name->attr.is_main_program)
12965 : {
12966 4541 : gfc_expr *e;
12967 4541 : e = has_finalizer ? gfc_lval_expr_from_sym (sym) : NULL;
12968 9082 : tmp = gfc_deallocate_with_status (sym->backend_decl, NULL_TREE, NULL_TREE,
12969 : NULL_TREE, NULL_TREE, true, e,
12970 4541 : sym->attr.codimension
12971 : ? GFC_CAF_COARRAY_DEREGISTER
12972 : : GFC_CAF_COARRAY_NOCOARRAY,
12973 : NULL_TREE, gfc_finish_block (&cleanup));
12974 4541 : if (e)
12975 45 : gfc_free_expr (e);
12976 4541 : gfc_init_block (&cleanup);
12977 4541 : gfc_add_expr_to_block (&cleanup, tmp);
12978 : }
12979 :
12980 16840 : gfc_add_init_cleanup (block, gfc_finish_block (&init),
12981 : gfc_finish_block (&cleanup));
12982 : }
12983 :
12984 : /************ Expression Walking Functions ******************/
12985 :
12986 : /* Walk a variable reference.
12987 :
12988 : Possible extension - multiple component subscripts.
12989 : x(:,:) = foo%a(:)%b(:)
12990 : Transforms to
12991 : forall (i=..., j=...)
12992 : x(i,j) = foo%a(j)%b(i)
12993 : end forall
12994 : This adds a fair amount of complexity because you need to deal with more
12995 : than one ref. Maybe handle in a similar manner to vector subscripts.
12996 : Maybe not worth the effort. */
12997 :
12998 :
12999 : static gfc_ss *
13000 685530 : gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
13001 : {
13002 685530 : gfc_ref *ref;
13003 :
13004 685530 : gfc_fix_class_refs (expr);
13005 :
13006 801027 : for (ref = expr->ref; ref; ref = ref->next)
13007 444806 : if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
13008 : break;
13009 :
13010 685530 : return gfc_walk_array_ref (ss, expr, ref);
13011 : }
13012 :
13013 : gfc_ss *
13014 685887 : gfc_walk_array_ref (gfc_ss *ss, gfc_expr *expr, gfc_ref *ref, bool array_only)
13015 : {
13016 685887 : gfc_array_ref *ar;
13017 685887 : gfc_ss *newss;
13018 685887 : int n;
13019 :
13020 1024732 : for (; ref; ref = ref->next)
13021 : {
13022 338845 : if (ref->type == REF_SUBSTRING)
13023 : {
13024 1314 : ss = gfc_get_scalar_ss (ss, ref->u.ss.start);
13025 1314 : if (ref->u.ss.end)
13026 1288 : ss = gfc_get_scalar_ss (ss, ref->u.ss.end);
13027 : }
13028 :
13029 : /* We're only interested in array sections from now on. */
13030 338845 : if (ref->type != REF_ARRAY
13031 330076 : || (array_only && ref->u.ar.as && ref->u.ar.as->rank == 0))
13032 8884 : continue;
13033 :
13034 329961 : ar = &ref->u.ar;
13035 :
13036 329961 : switch (ar->type)
13037 : {
13038 326 : case AR_ELEMENT:
13039 699 : for (n = ar->dimen - 1; n >= 0; n--)
13040 373 : ss = gfc_get_scalar_ss (ss, ar->start[n]);
13041 : break;
13042 :
13043 273208 : case AR_FULL:
13044 : /* Assumed shape arrays from interface mapping need this fix. */
13045 273208 : if (!ar->as && expr->symtree->n.sym->as)
13046 : {
13047 6 : ar->as = gfc_get_array_spec();
13048 6 : *ar->as = *expr->symtree->n.sym->as;
13049 : }
13050 273208 : newss = gfc_get_array_ss (ss, expr, ar->as->rank, GFC_SS_SECTION);
13051 273208 : newss->info->data.array.ref = ref;
13052 :
13053 : /* Make sure array is the same as array(:,:), this way
13054 : we don't need to special case all the time. */
13055 273208 : ar->dimen = ar->as->rank;
13056 629418 : for (n = 0; n < ar->dimen; n++)
13057 : {
13058 356210 : ar->dimen_type[n] = DIMEN_RANGE;
13059 :
13060 356210 : gcc_assert (ar->start[n] == NULL);
13061 356210 : gcc_assert (ar->end[n] == NULL);
13062 356210 : gcc_assert (ar->stride[n] == NULL);
13063 : }
13064 : ss = newss;
13065 : break;
13066 :
13067 56427 : case AR_SECTION:
13068 56427 : newss = gfc_get_array_ss (ss, expr, 0, GFC_SS_SECTION);
13069 56427 : newss->info->data.array.ref = ref;
13070 :
13071 : /* We add SS chains for all the subscripts in the section. */
13072 145160 : for (n = 0; n < ar->dimen; n++)
13073 : {
13074 88733 : gfc_ss *indexss;
13075 :
13076 88733 : switch (ar->dimen_type[n])
13077 : {
13078 6798 : case DIMEN_ELEMENT:
13079 : /* Add SS for elemental (scalar) subscripts. */
13080 6798 : gcc_assert (ar->start[n]);
13081 6798 : indexss = gfc_get_scalar_ss (gfc_ss_terminator, ar->start[n]);
13082 6798 : indexss->loop_chain = gfc_ss_terminator;
13083 6798 : newss->info->data.array.subscript[n] = indexss;
13084 6798 : break;
13085 :
13086 80895 : case DIMEN_RANGE:
13087 : /* We don't add anything for sections, just remember this
13088 : dimension for later. */
13089 80895 : newss->dim[newss->dimen] = n;
13090 80895 : newss->dimen++;
13091 80895 : break;
13092 :
13093 1040 : case DIMEN_VECTOR:
13094 : /* Create a GFC_SS_VECTOR index in which we can store
13095 : the vector's descriptor. */
13096 1040 : indexss = gfc_get_array_ss (gfc_ss_terminator, ar->start[n],
13097 : 1, GFC_SS_VECTOR);
13098 1040 : indexss->loop_chain = gfc_ss_terminator;
13099 1040 : newss->info->data.array.subscript[n] = indexss;
13100 1040 : newss->dim[newss->dimen] = n;
13101 1040 : newss->dimen++;
13102 1040 : break;
13103 :
13104 0 : default:
13105 : /* We should know what sort of section it is by now. */
13106 0 : gcc_unreachable ();
13107 : }
13108 : }
13109 : /* We should have at least one non-elemental dimension,
13110 : unless we are creating a descriptor for a (scalar) coarray. */
13111 56427 : gcc_assert (newss->dimen > 0
13112 : || newss->info->data.array.ref->u.ar.as->corank > 0);
13113 : ss = newss;
13114 : break;
13115 :
13116 0 : default:
13117 : /* We should know what sort of section it is by now. */
13118 0 : gcc_unreachable ();
13119 : }
13120 :
13121 : }
13122 685887 : return ss;
13123 : }
13124 :
13125 :
13126 : /* Walk an expression operator. If only one operand of a binary expression is
13127 : scalar, we must also add the scalar term to the SS chain. */
13128 :
13129 : static gfc_ss *
13130 57641 : gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
13131 : {
13132 57641 : gfc_ss *head;
13133 57641 : gfc_ss *head2;
13134 :
13135 57641 : head = gfc_walk_subexpr (ss, expr->value.op.op1);
13136 57641 : if (expr->value.op.op2 == NULL)
13137 : head2 = head;
13138 : else
13139 54995 : head2 = gfc_walk_subexpr (head, expr->value.op.op2);
13140 :
13141 : /* All operands are scalar. Pass back and let the caller deal with it. */
13142 57641 : if (head2 == ss)
13143 : return head2;
13144 :
13145 : /* All operands require scalarization. */
13146 51946 : if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
13147 : return head2;
13148 :
13149 : /* One of the operands needs scalarization, the other is scalar.
13150 : Create a gfc_ss for the scalar expression. */
13151 19406 : if (head == ss)
13152 : {
13153 : /* First operand is scalar. We build the chain in reverse order, so
13154 : add the scalar SS after the second operand. */
13155 : head = head2;
13156 2248 : while (head && head->next != ss)
13157 : head = head->next;
13158 : /* Check we haven't somehow broken the chain. */
13159 2005 : gcc_assert (head);
13160 2005 : head->next = gfc_get_scalar_ss (ss, expr->value.op.op1);
13161 : }
13162 : else /* head2 == head */
13163 : {
13164 17401 : gcc_assert (head2 == head);
13165 : /* Second operand is scalar. */
13166 17401 : head2 = gfc_get_scalar_ss (head2, expr->value.op.op2);
13167 : }
13168 :
13169 : return head2;
13170 : }
13171 :
13172 : static gfc_ss *
13173 36 : gfc_walk_conditional_expr (gfc_ss *ss, gfc_expr *expr)
13174 : {
13175 36 : gfc_ss *head;
13176 :
13177 36 : head = gfc_walk_subexpr (ss, expr->value.conditional.true_expr);
13178 36 : head = gfc_walk_subexpr (head, expr->value.conditional.false_expr);
13179 36 : return head;
13180 : }
13181 :
13182 : /* Reverse a SS chain. */
13183 :
13184 : gfc_ss *
13185 861099 : gfc_reverse_ss (gfc_ss * ss)
13186 : {
13187 861099 : gfc_ss *next;
13188 861099 : gfc_ss *head;
13189 :
13190 861099 : gcc_assert (ss != NULL);
13191 :
13192 : head = gfc_ss_terminator;
13193 1299786 : while (ss != gfc_ss_terminator)
13194 : {
13195 438687 : next = ss->next;
13196 : /* Check we didn't somehow break the chain. */
13197 438687 : gcc_assert (next != NULL);
13198 438687 : ss->next = head;
13199 438687 : head = ss;
13200 438687 : ss = next;
13201 : }
13202 :
13203 861099 : return (head);
13204 : }
13205 :
13206 :
13207 : /* Given an expression referring to a procedure, return the symbol of its
13208 : interface. We can't get the procedure symbol directly as we have to handle
13209 : the case of (deferred) type-bound procedures. */
13210 :
13211 : gfc_symbol *
13212 161 : gfc_get_proc_ifc_for_expr (gfc_expr *procedure_ref)
13213 : {
13214 161 : gfc_symbol *sym;
13215 161 : gfc_ref *ref;
13216 :
13217 161 : if (procedure_ref == NULL)
13218 : return NULL;
13219 :
13220 : /* Normal procedure case. */
13221 161 : if (procedure_ref->expr_type == EXPR_FUNCTION
13222 161 : && procedure_ref->value.function.esym)
13223 : sym = procedure_ref->value.function.esym;
13224 : else
13225 24 : sym = procedure_ref->symtree->n.sym;
13226 :
13227 : /* Typebound procedure case. */
13228 209 : for (ref = procedure_ref->ref; ref; ref = ref->next)
13229 : {
13230 48 : if (ref->type == REF_COMPONENT
13231 48 : && ref->u.c.component->attr.proc_pointer)
13232 24 : sym = ref->u.c.component->ts.interface;
13233 : else
13234 : sym = NULL;
13235 : }
13236 :
13237 : return sym;
13238 : }
13239 :
13240 :
13241 : /* Given an expression referring to an intrinsic function call,
13242 : return the intrinsic symbol. */
13243 :
13244 : gfc_intrinsic_sym *
13245 7946 : gfc_get_intrinsic_for_expr (gfc_expr *call)
13246 : {
13247 7946 : if (call == NULL)
13248 : return NULL;
13249 :
13250 : /* Normal procedure case. */
13251 2366 : if (call->expr_type == EXPR_FUNCTION)
13252 2260 : return call->value.function.isym;
13253 : else
13254 : return NULL;
13255 : }
13256 :
13257 :
13258 : /* Indicates whether an argument to an intrinsic function should be used in
13259 : scalarization. It is usually the case, except for some intrinsics
13260 : requiring the value to be constant, and using the value at compile time only.
13261 : As the value is not used at runtime in those cases, we don’t produce code
13262 : for it, and it should not be visible to the scalarizer.
13263 : FUNCTION is the intrinsic function being called, ACTUAL_ARG is the actual
13264 : argument being examined in that call, and ARG_NUM the index number
13265 : of ACTUAL_ARG in the list of arguments.
13266 : The intrinsic procedure’s dummy argument associated with ACTUAL_ARG is
13267 : identified using the name in ACTUAL_ARG if it is present (that is: if it’s
13268 : a keyword argument), otherwise using ARG_NUM. */
13269 :
13270 : static bool
13271 37976 : arg_evaluated_for_scalarization (gfc_intrinsic_sym *function,
13272 : gfc_dummy_arg *dummy_arg)
13273 : {
13274 37976 : if (function != NULL && dummy_arg != NULL)
13275 : {
13276 12467 : switch (function->id)
13277 : {
13278 241 : case GFC_ISYM_INDEX:
13279 241 : case GFC_ISYM_LEN_TRIM:
13280 241 : case GFC_ISYM_MASKL:
13281 241 : case GFC_ISYM_MASKR:
13282 241 : case GFC_ISYM_SCAN:
13283 241 : case GFC_ISYM_VERIFY:
13284 241 : if (strcmp ("kind", gfc_dummy_arg_get_name (*dummy_arg)) == 0)
13285 : return false;
13286 : /* Fallthrough. */
13287 :
13288 : default:
13289 : break;
13290 : }
13291 : }
13292 :
13293 : return true;
13294 : }
13295 :
13296 :
13297 : /* Walk the arguments of an elemental function.
13298 : PROC_EXPR is used to check whether an argument is permitted to be absent. If
13299 : it is NULL, we don't do the check and the argument is assumed to be present.
13300 : */
13301 :
13302 : gfc_ss *
13303 26957 : gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
13304 : gfc_intrinsic_sym *intrinsic_sym,
13305 : gfc_ss_type type)
13306 : {
13307 26957 : int scalar;
13308 26957 : gfc_ss *head;
13309 26957 : gfc_ss *tail;
13310 26957 : gfc_ss *newss;
13311 :
13312 26957 : head = gfc_ss_terminator;
13313 26957 : tail = NULL;
13314 :
13315 26957 : scalar = 1;
13316 66397 : for (; arg; arg = arg->next)
13317 : {
13318 39440 : gfc_dummy_arg * const dummy_arg = arg->associated_dummy;
13319 40937 : if (!arg->expr
13320 38126 : || arg->expr->expr_type == EXPR_NULL
13321 77416 : || !arg_evaluated_for_scalarization (intrinsic_sym, dummy_arg))
13322 1497 : continue;
13323 :
13324 37943 : newss = gfc_walk_subexpr (head, arg->expr);
13325 37943 : if (newss == head)
13326 : {
13327 : /* Scalar argument. */
13328 18580 : gcc_assert (type == GFC_SS_SCALAR || type == GFC_SS_REFERENCE);
13329 18580 : newss = gfc_get_scalar_ss (head, arg->expr);
13330 18580 : newss->info->type = type;
13331 18580 : if (dummy_arg)
13332 15463 : newss->info->data.scalar.dummy_arg = dummy_arg;
13333 : }
13334 : else
13335 : scalar = 0;
13336 :
13337 34826 : if (dummy_arg != NULL
13338 26420 : && gfc_dummy_arg_is_optional (*dummy_arg)
13339 2538 : && arg->expr->expr_type == EXPR_VARIABLE
13340 36530 : && (gfc_expr_attr (arg->expr).optional
13341 1223 : || gfc_expr_attr (arg->expr).allocatable
13342 37890 : || gfc_expr_attr (arg->expr).pointer))
13343 1005 : newss->info->can_be_null_ref = true;
13344 :
13345 37943 : head = newss;
13346 37943 : if (!tail)
13347 : {
13348 : tail = head;
13349 33645 : while (tail->next != gfc_ss_terminator)
13350 : tail = tail->next;
13351 : }
13352 : }
13353 :
13354 26957 : if (scalar)
13355 : {
13356 : /* If all the arguments are scalar we don't need the argument SS. */
13357 10360 : gfc_free_ss_chain (head);
13358 : /* Pass it back. */
13359 10360 : return ss;
13360 : }
13361 :
13362 : /* Add it onto the existing chain. */
13363 16597 : tail->next = ss;
13364 16597 : return head;
13365 : }
13366 :
13367 :
13368 : /* Walk a function call. Scalar functions are passed back, and taken out of
13369 : scalarization loops. For elemental functions we walk their arguments.
13370 : The result of functions returning arrays is stored in a temporary outside
13371 : the loop, so that the function is only called once. Hence we do not need
13372 : to walk their arguments. */
13373 :
13374 : static gfc_ss *
13375 63386 : gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
13376 : {
13377 63386 : gfc_intrinsic_sym *isym;
13378 63386 : gfc_symbol *sym;
13379 63386 : gfc_component *comp = NULL;
13380 :
13381 63386 : isym = expr->value.function.isym;
13382 :
13383 : /* Handle intrinsic functions separately. */
13384 63386 : if (isym)
13385 55652 : return gfc_walk_intrinsic_function (ss, expr, isym);
13386 :
13387 7734 : sym = expr->value.function.esym;
13388 7734 : if (!sym)
13389 546 : sym = expr->symtree->n.sym;
13390 :
13391 7734 : if (gfc_is_class_array_function (expr))
13392 234 : return gfc_get_array_ss (ss, expr,
13393 234 : CLASS_DATA (expr->value.function.esym->result)->as->rank,
13394 234 : GFC_SS_FUNCTION);
13395 :
13396 : /* A function that returns arrays. */
13397 7500 : comp = gfc_get_proc_ptr_comp (expr);
13398 7102 : if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
13399 7500 : || (comp && comp->attr.dimension))
13400 2680 : return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
13401 :
13402 : /* Walk the parameters of an elemental function. For now we always pass
13403 : by reference. */
13404 4820 : if (sym->attr.elemental || (comp && comp->attr.elemental))
13405 : {
13406 2224 : gfc_ss *old_ss = ss;
13407 :
13408 2224 : ss = gfc_walk_elemental_function_args (old_ss,
13409 : expr->value.function.actual,
13410 : gfc_get_intrinsic_for_expr (expr),
13411 : GFC_SS_REFERENCE);
13412 2224 : if (ss != old_ss
13413 1188 : && (comp
13414 1127 : || sym->attr.proc_pointer
13415 1127 : || sym->attr.if_source != IFSRC_DECL
13416 1005 : || sym->attr.array_outer_dependency))
13417 231 : ss->info->array_outer_dependency = 1;
13418 : }
13419 :
13420 : /* Scalar functions are OK as these are evaluated outside the scalarization
13421 : loop. Pass back and let the caller deal with it. */
13422 : return ss;
13423 : }
13424 :
13425 :
13426 : /* An array temporary is constructed for array constructors. */
13427 :
13428 : static gfc_ss *
13429 50543 : gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
13430 : {
13431 0 : return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_CONSTRUCTOR);
13432 : }
13433 :
13434 :
13435 : /* Walk an expression. Add walked expressions to the head of the SS chain.
13436 : A wholly scalar expression will not be added. */
13437 :
13438 : gfc_ss *
13439 1015858 : gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
13440 : {
13441 1015858 : gfc_ss *head;
13442 :
13443 1015858 : switch (expr->expr_type)
13444 : {
13445 685530 : case EXPR_VARIABLE:
13446 685530 : head = gfc_walk_variable_expr (ss, expr);
13447 685530 : return head;
13448 :
13449 57641 : case EXPR_OP:
13450 57641 : head = gfc_walk_op_expr (ss, expr);
13451 57641 : return head;
13452 :
13453 36 : case EXPR_CONDITIONAL:
13454 36 : head = gfc_walk_conditional_expr (ss, expr);
13455 36 : return head;
13456 :
13457 63386 : case EXPR_FUNCTION:
13458 63386 : head = gfc_walk_function_expr (ss, expr);
13459 63386 : return head;
13460 :
13461 : case EXPR_CONSTANT:
13462 : case EXPR_NULL:
13463 : case EXPR_STRUCTURE:
13464 : /* Pass back and let the caller deal with it. */
13465 : break;
13466 :
13467 50543 : case EXPR_ARRAY:
13468 50543 : head = gfc_walk_array_constructor (ss, expr);
13469 50543 : return head;
13470 :
13471 : case EXPR_SUBSTRING:
13472 : /* Pass back and let the caller deal with it. */
13473 : break;
13474 :
13475 0 : default:
13476 0 : gfc_internal_error ("bad expression type during walk (%d)",
13477 : expr->expr_type);
13478 : }
13479 : return ss;
13480 : }
13481 :
13482 :
13483 : /* Entry point for expression walking.
13484 : A return value equal to the passed chain means this is
13485 : a scalar expression. It is up to the caller to take whatever action is
13486 : necessary to translate these. */
13487 :
13488 : gfc_ss *
13489 858292 : gfc_walk_expr (gfc_expr * expr)
13490 : {
13491 858292 : gfc_ss *res;
13492 :
13493 858292 : res = gfc_walk_subexpr (gfc_ss_terminator, expr);
13494 858292 : return gfc_reverse_ss (res);
13495 : }
|
