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 58432 : gfc_array_dataptr_type (tree desc)
107 : {
108 58432 : 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 1999021 : gfc_get_descriptor_field (tree desc, unsigned field_idx)
248 : {
249 1999021 : tree type = TREE_TYPE (desc);
250 1999021 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
251 :
252 1999021 : tree field = gfc_advance_chain (TYPE_FIELDS (type), field_idx);
253 1999021 : gcc_assert (field != NULL_TREE);
254 :
255 1999021 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
256 1999021 : 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 280302 : gfc_conv_descriptor_data_get (tree desc)
264 : {
265 280302 : tree type = TREE_TYPE (desc);
266 280302 : if (TREE_CODE (type) == REFERENCE_TYPE)
267 0 : gcc_unreachable ();
268 :
269 280302 : tree field = gfc_get_descriptor_field (desc, DATA_FIELD);
270 280302 : 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 155874 : gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
277 : {
278 155874 : tree field = gfc_get_descriptor_field (desc, DATA_FIELD);
279 155874 : gfc_add_modify (block, field, fold_convert (TREE_TYPE (field), value));
280 155874 : }
281 :
282 :
283 : static tree
284 205591 : gfc_conv_descriptor_offset (tree desc)
285 : {
286 205591 : tree field = gfc_get_descriptor_field (desc, OFFSET_FIELD);
287 205591 : gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
288 205591 : return field;
289 : }
290 :
291 : tree
292 76585 : gfc_conv_descriptor_offset_get (tree desc)
293 : {
294 76585 : return gfc_conv_descriptor_offset (desc);
295 : }
296 :
297 : void
298 122646 : gfc_conv_descriptor_offset_set (stmtblock_t *block, tree desc,
299 : tree value)
300 : {
301 122646 : tree t = gfc_conv_descriptor_offset (desc);
302 122646 : gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
303 122646 : }
304 :
305 :
306 : tree
307 171999 : gfc_conv_descriptor_dtype (tree desc)
308 : {
309 171999 : tree field = gfc_get_descriptor_field (desc, DTYPE_FIELD);
310 171999 : gcc_assert (TREE_TYPE (field) == get_dtype_type_node ());
311 171999 : return field;
312 : }
313 :
314 : static tree
315 152626 : gfc_conv_descriptor_span (tree desc)
316 : {
317 152626 : tree field = gfc_get_descriptor_field (desc, SPAN_FIELD);
318 152626 : gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
319 152626 : return field;
320 : }
321 :
322 : tree
323 33750 : gfc_conv_descriptor_span_get (tree desc)
324 : {
325 33750 : return gfc_conv_descriptor_span (desc);
326 : }
327 :
328 : void
329 118876 : gfc_conv_descriptor_span_set (stmtblock_t *block, tree desc,
330 : tree value)
331 : {
332 118876 : tree t = gfc_conv_descriptor_span (desc);
333 118876 : gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
334 118876 : }
335 :
336 :
337 : tree
338 20895 : gfc_conv_descriptor_rank (tree desc)
339 : {
340 20895 : tree tmp;
341 20895 : tree dtype;
342 :
343 20895 : dtype = gfc_conv_descriptor_dtype (desc);
344 20895 : tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), GFC_DTYPE_RANK);
345 20895 : gcc_assert (tmp != NULL_TREE
346 : && TREE_TYPE (tmp) == signed_char_type_node);
347 20895 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
348 20895 : 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 9206 : gfc_conv_descriptor_elem_len (tree desc)
371 : {
372 9206 : tree tmp;
373 9206 : tree dtype;
374 :
375 9206 : dtype = gfc_conv_descriptor_dtype (desc);
376 9206 : tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)),
377 : GFC_DTYPE_ELEM_LEN);
378 9206 : gcc_assert (tmp != NULL_TREE
379 : && TREE_TYPE (tmp) == size_type_node);
380 9206 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
381 9206 : 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 1030380 : gfc_get_descriptor_dimension (tree desc)
416 : {
417 1030380 : tree field = gfc_get_descriptor_field (desc, DIMENSION_FIELD);
418 1030380 : gcc_assert (TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
419 : && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
420 1030380 : return field;
421 : }
422 :
423 :
424 : static tree
425 1026402 : gfc_conv_descriptor_dimension (tree desc, tree dim)
426 : {
427 1026402 : tree tmp;
428 :
429 1026402 : tmp = gfc_get_descriptor_dimension (desc);
430 :
431 1026402 : return gfc_build_array_ref (tmp, dim, NULL_TREE, true);
432 : }
433 :
434 :
435 : tree
436 2249 : gfc_conv_descriptor_token (tree desc)
437 : {
438 2249 : gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
439 2249 : tree field = gfc_get_descriptor_field (desc, CAF_TOKEN_FIELD);
440 : /* Should be a restricted pointer - except in the finalization wrapper. */
441 2249 : gcc_assert (TREE_TYPE (field) == prvoid_type_node
442 : || TREE_TYPE (field) == pvoid_type_node);
443 2249 : return field;
444 : }
445 :
446 : static tree
447 1026402 : gfc_conv_descriptor_subfield (tree desc, tree dim, unsigned field_idx)
448 : {
449 1026402 : tree tmp = gfc_conv_descriptor_dimension (desc, dim);
450 1026402 : tree field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), field_idx);
451 1026402 : gcc_assert (field != NULL_TREE);
452 :
453 1026402 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
454 1026402 : tmp, field, NULL_TREE);
455 : }
456 :
457 : static tree
458 274390 : gfc_conv_descriptor_stride (tree desc, tree dim)
459 : {
460 274390 : tree field = gfc_conv_descriptor_subfield (desc, dim, STRIDE_SUBFIELD);
461 274390 : gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
462 274390 : return field;
463 : }
464 :
465 : tree
466 168507 : gfc_conv_descriptor_stride_get (tree desc, tree dim)
467 : {
468 168507 : tree type = TREE_TYPE (desc);
469 168507 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
470 168507 : if (integer_zerop (dim)
471 168507 : && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
472 43058 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT
473 41989 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT
474 41839 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_ALLOCATABLE
475 41689 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_POINTER_CONT
476 41689 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
477 70937 : return gfc_index_one_node;
478 :
479 97570 : return gfc_conv_descriptor_stride (desc, dim);
480 : }
481 :
482 : void
483 176820 : gfc_conv_descriptor_stride_set (stmtblock_t *block, tree desc,
484 : tree dim, tree value)
485 : {
486 176820 : tree t = gfc_conv_descriptor_stride (desc, dim);
487 176820 : gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
488 176820 : }
489 :
490 : static tree
491 390503 : gfc_conv_descriptor_lbound (tree desc, tree dim)
492 : {
493 390503 : tree field = gfc_conv_descriptor_subfield (desc, dim, LBOUND_SUBFIELD);
494 390503 : gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
495 390503 : return field;
496 : }
497 :
498 : tree
499 209012 : gfc_conv_descriptor_lbound_get (tree desc, tree dim)
500 : {
501 209012 : return gfc_conv_descriptor_lbound (desc, dim);
502 : }
503 :
504 : void
505 181491 : gfc_conv_descriptor_lbound_set (stmtblock_t *block, tree desc,
506 : tree dim, tree value)
507 : {
508 181491 : tree t = gfc_conv_descriptor_lbound (desc, dim);
509 181491 : gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
510 181491 : }
511 :
512 : static tree
513 361509 : gfc_conv_descriptor_ubound (tree desc, tree dim)
514 : {
515 361509 : tree field = gfc_conv_descriptor_subfield (desc, dim, UBOUND_SUBFIELD);
516 361509 : gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
517 361509 : return field;
518 : }
519 :
520 : tree
521 180272 : gfc_conv_descriptor_ubound_get (tree desc, tree dim)
522 : {
523 180272 : return gfc_conv_descriptor_ubound (desc, dim);
524 : }
525 :
526 : void
527 181237 : gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree desc,
528 : tree dim, tree value)
529 : {
530 181237 : tree t = gfc_conv_descriptor_ubound (desc, dim);
531 181237 : gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
532 181237 : }
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 924 : gfc_conv_shift_descriptor_lbound (stmtblock_t* block, tree desc,
560 : int dim, tree new_lbound)
561 : {
562 924 : tree offs, ubound, lbound, stride;
563 924 : tree diff, offs_diff;
564 :
565 924 : new_lbound = fold_convert (gfc_array_index_type, new_lbound);
566 :
567 924 : offs = gfc_conv_descriptor_offset_get (desc);
568 924 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
569 924 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
570 924 : stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]);
571 :
572 : /* Get difference (new - old) by which to shift stuff. */
573 924 : 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 924 : ubound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
579 : ubound, diff);
580 924 : gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[dim], ubound);
581 924 : offs_diff = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
582 : diff, stride);
583 924 : offs = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
584 : offs, offs_diff);
585 924 : gfc_conv_descriptor_offset_set (block, desc, offs);
586 :
587 : /* Finally set lbound to value we want. */
588 924 : gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[dim], new_lbound);
589 924 : }
590 :
591 :
592 : /* Obtain offsets for trans-types.cc(gfc_get_array_descr_info). */
593 :
594 : void
595 270650 : 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 270650 : tree field;
602 270650 : tree type;
603 :
604 270650 : type = TYPE_MAIN_VARIANT (desc_type);
605 270650 : field = gfc_advance_chain (TYPE_FIELDS (type), DATA_FIELD);
606 270650 : *data_off = byte_position (field);
607 270650 : field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
608 270650 : *dtype_off = byte_position (field);
609 270650 : field = gfc_advance_chain (TYPE_FIELDS (type), SPAN_FIELD);
610 270650 : *span_off = byte_position (field);
611 270650 : field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
612 270650 : *dim_off = byte_position (field);
613 270650 : type = TREE_TYPE (TREE_TYPE (field));
614 270650 : *dim_size = TYPE_SIZE_UNIT (type);
615 270650 : field = gfc_advance_chain (TYPE_FIELDS (type), STRIDE_SUBFIELD);
616 270650 : *stride_suboff = byte_position (field);
617 270650 : field = gfc_advance_chain (TYPE_FIELDS (type), LBOUND_SUBFIELD);
618 270650 : *lower_suboff = byte_position (field);
619 270650 : field = gfc_advance_chain (TYPE_FIELDS (type), UBOUND_SUBFIELD);
620 270650 : *upper_suboff = byte_position (field);
621 270650 : }
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 169409 : gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
643 : {
644 398413 : for (; ss != gfc_ss_terminator; ss = ss->next)
645 229004 : ss->info->useflags = flags;
646 169409 : }
647 :
648 :
649 : /* Free a gfc_ss chain. */
650 :
651 : void
652 178843 : gfc_free_ss_chain (gfc_ss * ss)
653 : {
654 178843 : gfc_ss *next;
655 :
656 365904 : while (ss != gfc_ss_terminator)
657 : {
658 187061 : gcc_assert (ss != NULL);
659 187061 : next = ss->next;
660 187061 : gfc_free_ss (ss);
661 187061 : ss = next;
662 : }
663 178843 : }
664 :
665 :
666 : static void
667 485389 : free_ss_info (gfc_ss_info *ss_info)
668 : {
669 485389 : int n;
670 :
671 485389 : ss_info->refcount--;
672 485389 : if (ss_info->refcount > 0)
673 : return;
674 :
675 480642 : gcc_assert (ss_info->refcount == 0);
676 :
677 480642 : switch (ss_info->type)
678 : {
679 : case GFC_SS_SECTION:
680 5331984 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
681 4998735 : if (ss_info->data.array.subscript[n])
682 7368 : gfc_free_ss_chain (ss_info->data.array.subscript[n]);
683 : break;
684 :
685 : default:
686 : break;
687 : }
688 :
689 480642 : free (ss_info);
690 : }
691 :
692 :
693 : /* Free a SS. */
694 :
695 : void
696 485389 : gfc_free_ss (gfc_ss * ss)
697 : {
698 485389 : free_ss_info (ss->info);
699 485389 : free (ss);
700 485389 : }
701 :
702 :
703 : /* Creates and initializes an array type gfc_ss struct. */
704 :
705 : gfc_ss *
706 405800 : gfc_get_array_ss (gfc_ss *next, gfc_expr *expr, int dimen, gfc_ss_type type)
707 : {
708 405800 : gfc_ss *ss;
709 405800 : gfc_ss_info *ss_info;
710 405800 : int i;
711 :
712 405800 : ss_info = gfc_get_ss_info ();
713 405800 : ss_info->refcount++;
714 405800 : ss_info->type = type;
715 405800 : ss_info->expr = expr;
716 :
717 405800 : ss = gfc_get_ss ();
718 405800 : ss->info = ss_info;
719 405800 : ss->next = next;
720 405800 : ss->dimen = dimen;
721 858030 : for (i = 0; i < ss->dimen; i++)
722 452230 : ss->dim[i] = i;
723 :
724 405800 : return ss;
725 : }
726 :
727 :
728 : /* Creates and initializes a temporary type gfc_ss struct. */
729 :
730 : gfc_ss *
731 10990 : gfc_get_temp_ss (tree type, tree string_length, int dimen)
732 : {
733 10990 : gfc_ss *ss;
734 10990 : gfc_ss_info *ss_info;
735 10990 : int i;
736 :
737 10990 : ss_info = gfc_get_ss_info ();
738 10990 : ss_info->refcount++;
739 10990 : ss_info->type = GFC_SS_TEMP;
740 10990 : ss_info->string_length = string_length;
741 10990 : ss_info->data.temp.type = type;
742 :
743 10990 : ss = gfc_get_ss ();
744 10990 : ss->info = ss_info;
745 10990 : ss->next = gfc_ss_terminator;
746 10990 : ss->dimen = dimen;
747 24680 : for (i = 0; i < ss->dimen; i++)
748 13690 : ss->dim[i] = i;
749 :
750 10990 : return ss;
751 : }
752 :
753 :
754 : /* Creates and initializes a scalar type gfc_ss struct. */
755 :
756 : gfc_ss *
757 65881 : gfc_get_scalar_ss (gfc_ss *next, gfc_expr *expr)
758 : {
759 65881 : gfc_ss *ss;
760 65881 : gfc_ss_info *ss_info;
761 :
762 65881 : ss_info = gfc_get_ss_info ();
763 65881 : ss_info->refcount++;
764 65881 : ss_info->type = GFC_SS_SCALAR;
765 65881 : ss_info->expr = expr;
766 :
767 65881 : ss = gfc_get_ss ();
768 65881 : ss->info = ss_info;
769 65881 : ss->next = next;
770 :
771 65881 : return ss;
772 : }
773 :
774 :
775 : /* Free all the SS associated with a loop. */
776 :
777 : void
778 180028 : gfc_cleanup_loop (gfc_loopinfo * loop)
779 : {
780 180028 : gfc_loopinfo *loop_next, **ploop;
781 180028 : gfc_ss *ss;
782 180028 : gfc_ss *next;
783 :
784 180028 : ss = loop->ss;
785 477869 : while (ss != gfc_ss_terminator)
786 : {
787 297841 : gcc_assert (ss != NULL);
788 297841 : next = ss->loop_chain;
789 297841 : gfc_free_ss (ss);
790 297841 : ss = next;
791 : }
792 :
793 : /* Remove reference to self in the parent loop. */
794 180028 : 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 183392 : 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 180028 : }
810 :
811 :
812 : static void
813 244512 : set_ss_loop (gfc_ss *ss, gfc_loopinfo *loop)
814 : {
815 244512 : int n;
816 :
817 551116 : for (; ss != gfc_ss_terminator; ss = ss->next)
818 : {
819 306604 : ss->loop = loop;
820 :
821 306604 : if (ss->info->type == GFC_SS_SCALAR
822 : || ss->info->type == GFC_SS_REFERENCE
823 258681 : || ss->info->type == GFC_SS_TEMP)
824 58913 : continue;
825 :
826 3963056 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
827 3715365 : if (ss->info->data.array.subscript[n] != NULL)
828 7145 : set_ss_loop (ss->info->data.array.subscript[n], loop);
829 : }
830 244512 : }
831 :
832 :
833 : /* Associate a SS chain with a loop. */
834 :
835 : void
836 237367 : gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
837 : {
838 237367 : gfc_ss *ss;
839 237367 : gfc_loopinfo *nested_loop;
840 :
841 237367 : if (head == gfc_ss_terminator)
842 : return;
843 :
844 237367 : set_ss_loop (head, loop);
845 :
846 237367 : ss = head;
847 774193 : for (; ss && ss != gfc_ss_terminator; ss = ss->next)
848 : {
849 299459 : 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 299459 : if (ss->next == gfc_ss_terminator)
870 237367 : ss->loop_chain = loop->ss;
871 : else
872 62092 : ss->loop_chain = ss->next;
873 : }
874 237367 : gcc_assert (ss == gfc_ss_terminator);
875 237367 : loop->ss = head;
876 : }
877 :
878 :
879 : /* Returns true if the expression is an array pointer. */
880 :
881 : static bool
882 362758 : is_pointer_array (tree expr)
883 : {
884 362758 : if (expr == NULL_TREE
885 362758 : || !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr))
886 458316 : || GFC_CLASS_TYPE_P (TREE_TYPE (expr)))
887 : return false;
888 :
889 95558 : if (VAR_P (expr)
890 95558 : && GFC_DECL_PTR_ARRAY_P (expr))
891 : return true;
892 :
893 89214 : if (TREE_CODE (expr) == PARM_DECL
894 89214 : && GFC_DECL_PTR_ARRAY_P (expr))
895 : return true;
896 :
897 89214 : if (INDIRECT_REF_P (expr)
898 89214 : && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 0)))
899 : return true;
900 :
901 : /* The field declaration is marked as an pointer array. */
902 86786 : if (TREE_CODE (expr) == COMPONENT_REF
903 15020 : && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 1))
904 89645 : && !GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (expr, 1))))
905 2859 : return true;
906 :
907 : return false;
908 : }
909 :
910 :
911 : /* If the symbol or expression reference a CFI descriptor, return the
912 : pointer to the converted gfc descriptor. If an array reference is
913 : present as the last argument, check that it is the one applied to
914 : the CFI descriptor in the expression. Note that the CFI object is
915 : always the symbol in the expression! */
916 :
917 : static bool
918 365469 : get_CFI_desc (gfc_symbol *sym, gfc_expr *expr,
919 : tree *desc, gfc_array_ref *ar)
920 : {
921 365469 : tree tmp;
922 :
923 365469 : 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 1107 : 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 1107 : 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 1107 : 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 596 : return gfc_vptr_size_get (vptr);
963 : }
964 :
965 :
966 : /* Return the span of an array. */
967 :
968 : tree
969 57587 : gfc_get_array_span (tree desc, gfc_expr *expr)
970 : {
971 57587 : tree tmp;
972 57587 : gfc_symbol *sym = (expr && expr->expr_type == EXPR_VARIABLE) ?
973 50663 : expr->symtree->n.sym : NULL;
974 :
975 57587 : if (is_pointer_array (desc)
976 57587 : || (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 57029 : 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 56902 : else if (TREE_CODE (desc) == COMPONENT_REF
996 505 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
997 57031 : && 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 56846 : else if (sym && sym->ts.type == BT_CLASS
1002 1095 : && expr->ref->type == REF_COMPONENT
1003 1095 : && expr->ref->next->type == REF_ARRAY
1004 1095 : && expr->ref->next->next == NULL
1005 1077 : && CLASS_DATA (sym)->attr.dimension)
1006 : /* Having escaped the above, this can only be a class array dummy. */
1007 1051 : tmp = class_array_element_size (sym->backend_decl,
1008 1051 : 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 55795 : tmp = gfc_get_element_type (TREE_TYPE (desc));
1015 55795 : if (tmp && TREE_CODE (tmp) == ARRAY_TYPE && TYPE_STRING_FLAG (tmp))
1016 : {
1017 11047 : gcc_assert (expr->ts.type == BT_CHARACTER);
1018 :
1019 11047 : tmp = gfc_get_character_len_in_bytes (tmp);
1020 :
1021 11047 : if (tmp == NULL_TREE || integer_zerop (tmp))
1022 : {
1023 80 : tree bs;
1024 :
1025 80 : tmp = gfc_get_expr_charlen (expr);
1026 80 : tmp = fold_convert (gfc_array_index_type, tmp);
1027 80 : bs = build_int_cst (gfc_array_index_type, expr->ts.kind);
1028 80 : tmp = fold_build2_loc (input_location, MULT_EXPR,
1029 : gfc_array_index_type, tmp, bs);
1030 : }
1031 :
1032 22014 : tmp = (tmp && !integer_zerop (tmp))
1033 22014 : ? (fold_convert (gfc_array_index_type, tmp)) : (NULL_TREE);
1034 : }
1035 : else
1036 44748 : tmp = fold_convert (gfc_array_index_type,
1037 : size_in_bytes (tmp));
1038 : }
1039 57587 : return tmp;
1040 : }
1041 :
1042 :
1043 : /* Generate an initializer for a static pointer or allocatable array. */
1044 :
1045 : void
1046 279 : gfc_trans_static_array_pointer (gfc_symbol * sym)
1047 : {
1048 279 : tree type;
1049 :
1050 279 : gcc_assert (TREE_STATIC (sym->backend_decl));
1051 : /* Just zero the data member. */
1052 279 : type = TREE_TYPE (sym->backend_decl);
1053 279 : DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
1054 279 : }
1055 :
1056 :
1057 : /* If the bounds of SE's loop have not yet been set, see if they can be
1058 : determined from array spec AS, which is the array spec of a called
1059 : function. MAPPING maps the callee's dummy arguments to the values
1060 : that the caller is passing. Add any initialization and finalization
1061 : code to SE. */
1062 :
1063 : void
1064 8573 : gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
1065 : gfc_se * se, gfc_array_spec * as)
1066 : {
1067 8573 : int n, dim, total_dim;
1068 8573 : gfc_se tmpse;
1069 8573 : gfc_ss *ss;
1070 8573 : tree lower;
1071 8573 : tree upper;
1072 8573 : tree tmp;
1073 :
1074 8573 : total_dim = 0;
1075 :
1076 8573 : if (!as || as->type != AS_EXPLICIT)
1077 7448 : return;
1078 :
1079 2275 : for (ss = se->ss; ss; ss = ss->parent)
1080 : {
1081 1150 : total_dim += ss->loop->dimen;
1082 2655 : for (n = 0; n < ss->loop->dimen; n++)
1083 : {
1084 : /* The bound is known, nothing to do. */
1085 1505 : if (ss->loop->to[n] != NULL_TREE)
1086 485 : continue;
1087 :
1088 1020 : dim = ss->dim[n];
1089 1020 : gcc_assert (dim < as->rank);
1090 1020 : gcc_assert (ss->loop->dimen <= as->rank);
1091 :
1092 : /* Evaluate the lower bound. */
1093 1020 : gfc_init_se (&tmpse, NULL);
1094 1020 : gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
1095 1020 : gfc_add_block_to_block (&se->pre, &tmpse.pre);
1096 1020 : gfc_add_block_to_block (&se->post, &tmpse.post);
1097 1020 : lower = fold_convert (gfc_array_index_type, tmpse.expr);
1098 :
1099 : /* ...and the upper bound. */
1100 1020 : gfc_init_se (&tmpse, NULL);
1101 1020 : gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
1102 1020 : gfc_add_block_to_block (&se->pre, &tmpse.pre);
1103 1020 : gfc_add_block_to_block (&se->post, &tmpse.post);
1104 1020 : upper = fold_convert (gfc_array_index_type, tmpse.expr);
1105 :
1106 : /* Set the upper bound of the loop to UPPER - LOWER. */
1107 1020 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
1108 : gfc_array_index_type, upper, lower);
1109 1020 : tmp = gfc_evaluate_now (tmp, &se->pre);
1110 1020 : ss->loop->to[n] = tmp;
1111 : }
1112 : }
1113 :
1114 1125 : gcc_assert (total_dim == as->rank);
1115 : }
1116 :
1117 :
1118 : /* Generate code to allocate an array temporary, or create a variable to
1119 : hold the data. If size is NULL, zero the descriptor so that the
1120 : callee will allocate the array. If DEALLOC is true, also generate code to
1121 : free the array afterwards.
1122 :
1123 : If INITIAL is not NULL, it is packed using internal_pack and the result used
1124 : as data instead of allocating a fresh, unitialized area of memory.
1125 :
1126 : Initialization code is added to PRE and finalization code to POST.
1127 : DYNAMIC is true if the caller may want to extend the array later
1128 : using realloc. This prevents us from putting the array on the stack. */
1129 :
1130 : static void
1131 27181 : 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 27181 : tree tmp;
1136 27181 : tree desc;
1137 27181 : bool onstack;
1138 :
1139 27181 : desc = info->descriptor;
1140 27181 : info->offset = gfc_index_zero_node;
1141 27181 : if (size == NULL_TREE || (dynamic && integer_zerop (size)))
1142 : {
1143 : /* A callee allocated array. */
1144 2748 : gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
1145 2748 : onstack = false;
1146 : }
1147 : else
1148 : {
1149 : /* Allocate the temporary. */
1150 48866 : onstack = !dynamic && initial == NULL_TREE
1151 24433 : && (flag_stack_arrays
1152 24090 : || gfc_can_put_var_on_stack (size));
1153 :
1154 24433 : if (onstack)
1155 : {
1156 : /* Make a temporary variable to hold the data. */
1157 19497 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (nelem),
1158 : nelem, gfc_index_one_node);
1159 19497 : tmp = gfc_evaluate_now (tmp, pre);
1160 19497 : tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
1161 : tmp);
1162 19497 : tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
1163 : tmp);
1164 19497 : 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 19497 : 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 19497 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1173 19497 : gfc_conv_descriptor_data_set (pre, desc, tmp);
1174 : }
1175 : else
1176 : {
1177 : /* Allocate memory to hold the data or call internal_pack. */
1178 4936 : if (initial == NULL_TREE)
1179 : {
1180 4835 : tmp = gfc_call_malloc (pre, NULL, size);
1181 4835 : tmp = gfc_evaluate_now (tmp, pre);
1182 : }
1183 : else
1184 : {
1185 101 : tree packed;
1186 101 : tree source_data;
1187 101 : tree was_packed;
1188 101 : stmtblock_t do_copying;
1189 :
1190 101 : tmp = TREE_TYPE (initial); /* Pointer to descriptor. */
1191 101 : gcc_assert (TREE_CODE (tmp) == POINTER_TYPE);
1192 101 : tmp = TREE_TYPE (tmp); /* The descriptor itself. */
1193 101 : tmp = gfc_get_element_type (tmp);
1194 101 : packed = gfc_create_var (build_pointer_type (tmp), "data");
1195 :
1196 101 : tmp = build_call_expr_loc (input_location,
1197 : gfor_fndecl_in_pack, 1, initial);
1198 101 : tmp = fold_convert (TREE_TYPE (packed), tmp);
1199 101 : gfc_add_modify (pre, packed, tmp);
1200 :
1201 101 : tmp = build_fold_indirect_ref_loc (input_location,
1202 : initial);
1203 101 : source_data = gfc_conv_descriptor_data_get (tmp);
1204 :
1205 : /* internal_pack may return source->data without any allocation
1206 : or copying if it is already packed. If that's the case, we
1207 : need to allocate and copy manually. */
1208 :
1209 101 : gfc_start_block (&do_copying);
1210 101 : tmp = gfc_call_malloc (&do_copying, NULL, size);
1211 101 : tmp = fold_convert (TREE_TYPE (packed), tmp);
1212 101 : gfc_add_modify (&do_copying, packed, tmp);
1213 101 : tmp = gfc_build_memcpy_call (packed, source_data, size);
1214 101 : gfc_add_expr_to_block (&do_copying, tmp);
1215 :
1216 101 : was_packed = fold_build2_loc (input_location, EQ_EXPR,
1217 : logical_type_node, packed,
1218 : source_data);
1219 101 : tmp = gfc_finish_block (&do_copying);
1220 101 : tmp = build3_v (COND_EXPR, was_packed, tmp,
1221 : build_empty_stmt (input_location));
1222 101 : gfc_add_expr_to_block (pre, tmp);
1223 :
1224 101 : tmp = fold_convert (pvoid_type_node, packed);
1225 : }
1226 :
1227 4936 : gfc_conv_descriptor_data_set (pre, desc, tmp);
1228 : }
1229 : }
1230 27181 : 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 27181 : gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node);
1235 :
1236 27181 : if (dealloc && !onstack)
1237 : {
1238 : /* Free the temporary. */
1239 7434 : tmp = gfc_conv_descriptor_data_get (desc);
1240 7434 : tmp = gfc_call_free (tmp);
1241 7434 : gfc_add_expr_to_block (post, tmp);
1242 : }
1243 27181 : }
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 257438 : get_scalarizer_dim_for_array_dim (gfc_ss *ss, int array_dim)
1262 : {
1263 257438 : int array_ref_dim;
1264 257438 : int n;
1265 :
1266 257438 : array_ref_dim = 0;
1267 :
1268 521009 : for (; ss; ss = ss->parent)
1269 680383 : for (n = 0; n < ss->dimen; n++)
1270 416812 : if (ss->dim[n] < array_dim)
1271 76837 : array_ref_dim++;
1272 :
1273 257438 : return array_ref_dim;
1274 : }
1275 :
1276 :
1277 : static gfc_ss *
1278 217755 : innermost_ss (gfc_ss *ss)
1279 : {
1280 400077 : while (ss->nested_ss != NULL)
1281 : ss = ss->nested_ss;
1282 :
1283 391869 : 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 217755 : get_array_ref_dim_for_loop_dim (gfc_ss *ss, int loop_dim)
1296 : {
1297 217755 : return get_scalarizer_dim_for_array_dim (innermost_ss (ss),
1298 217755 : 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 309 : get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype,
1308 : gfc_ss **fcnss)
1309 : {
1310 309 : gfc_ss *loop_ss = ss->loop->ss;
1311 309 : gfc_ss *lhs_ss;
1312 309 : gfc_ss *rhs_ss;
1313 309 : gfc_ss *fcn_ss = NULL;
1314 309 : tree tmp;
1315 309 : tree tmp2;
1316 309 : tree vptr;
1317 309 : tree class_expr = NULL_TREE;
1318 309 : tree lhs_class_expr = NULL_TREE;
1319 309 : bool unlimited_rhs = false;
1320 309 : bool unlimited_lhs = false;
1321 309 : bool rhs_function = false;
1322 309 : bool unlimited_arg1 = false;
1323 309 : gfc_symbol *vtab;
1324 309 : 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 309 : rhs_ss = loop_ss->loop_chain;
1329 :
1330 309 : if (rhs_ss != gfc_ss_terminator
1331 285 : && rhs_ss->info
1332 285 : && rhs_ss->info->expr
1333 285 : && rhs_ss->info->expr->ts.type == BT_CLASS
1334 170 : && rhs_ss->info->data.array.descriptor)
1335 : {
1336 158 : 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 102 : class_expr = gfc_get_class_from_gfc_expr (rhs_ss->info->expr);
1341 158 : unlimited_rhs = UNLIMITED_POLY (rhs_ss->info->expr);
1342 158 : 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 309 : *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 309 : if (class_expr != NULL_TREE
1353 139 : && 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 309 : lhs_ss = rhs_ss->loop_chain;
1368 309 : if (lhs_ss && lhs_ss != gfc_ss_terminator
1369 219 : && lhs_ss->info && lhs_ss->info->expr
1370 219 : && lhs_ss->info->expr->expr_type ==EXPR_VARIABLE
1371 219 : && lhs_ss->info->expr->ts.type == BT_CLASS)
1372 : {
1373 219 : tmp = lhs_ss->info->data.array.descriptor;
1374 219 : unlimited_lhs = UNLIMITED_POLY (rhs_ss->info->expr);
1375 : }
1376 90 : 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 219 : if (tmp != NULL_TREE && lhs_ss->loop_chain == gfc_ss_terminator)
1394 207 : lhs_class_expr = gfc_get_class_from_expr (tmp);
1395 : else
1396 102 : return class_expr;
1397 :
1398 207 : gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (lhs_class_expr)));
1399 :
1400 : /* Set the lhs vptr and, if necessary, the _len field. */
1401 207 : 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 128 : else if (rhs_ss->info->data.array.descriptor)
1417 : {
1418 : /* lhs is class and rhs is intrinsic or derived type. */
1419 122 : *eltype = TREE_TYPE (rhs_ss->info->data.array.descriptor);
1420 122 : *eltype = gfc_get_element_type (*eltype);
1421 122 : vtab = gfc_find_vtab (&rhs_ss->info->expr->ts);
1422 122 : vptr = vtab->backend_decl;
1423 122 : if (vptr == NULL_TREE)
1424 24 : vptr = gfc_get_symbol_decl (vtab);
1425 122 : vptr = gfc_build_addr_expr (NULL_TREE, vptr);
1426 122 : tmp = gfc_class_vptr_get (lhs_class_expr);
1427 122 : gfc_add_modify (pre, tmp,
1428 122 : fold_convert (TREE_TYPE (tmp), vptr));
1429 :
1430 122 : 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 27181 : 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 27181 : gfc_loopinfo *loop;
1473 27181 : gfc_ss *s;
1474 27181 : gfc_array_info *info;
1475 27181 : tree from[GFC_MAX_DIMENSIONS], to[GFC_MAX_DIMENSIONS];
1476 27181 : tree type;
1477 27181 : tree desc;
1478 27181 : tree tmp;
1479 27181 : tree size;
1480 27181 : tree nelem;
1481 27181 : tree cond;
1482 27181 : tree or_expr;
1483 27181 : tree elemsize;
1484 27181 : tree class_expr = NULL_TREE;
1485 27181 : gfc_ss *fcn_ss = NULL;
1486 27181 : int n, dim, tmp_dim;
1487 27181 : 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 27181 : if (eltype == NULL_TREE && initial)
1492 : {
1493 6 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial)));
1494 6 : class_expr = build_fold_indirect_ref_loc (input_location, initial);
1495 : /* Obtain the structure (class) expression. */
1496 6 : class_expr = gfc_get_class_from_expr (class_expr);
1497 6 : gcc_assert (class_expr);
1498 : }
1499 :
1500 : /* Otherwise, some expressions, such as class functions, arising from
1501 : dependency checking in assignments come here with class element type.
1502 : The descriptor can be obtained from the ss->info and then converted
1503 : to the class object. */
1504 27175 : if (class_expr == NULL_TREE && GFC_CLASS_TYPE_P (eltype))
1505 309 : 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 27181 : if (eltype && GFC_CLASS_TYPE_P (eltype))
1509 187 : eltype = gfc_get_element_type (TREE_TYPE (TYPE_FIELDS (eltype)));
1510 :
1511 27181 : if (class_expr == NULL_TREE)
1512 27036 : 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 145 : tmp = gfc_class_vptr_get (class_expr);
1520 145 : tmp = fold_build2_loc (input_location, NE_EXPR,
1521 : logical_type_node,
1522 145 : tmp, build_int_cst (TREE_TYPE (tmp), 0));
1523 145 : 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 145 : elemsize = gfc_evaluate_now (elemsize, pre);
1529 145 : 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 145 : eltype = gfc_get_character_type_len (1, elemsize);
1533 : }
1534 :
1535 27181 : memset (from, 0, sizeof (from));
1536 27181 : memset (to, 0, sizeof (to));
1537 :
1538 27181 : info = &ss->info->data.array;
1539 :
1540 27181 : gcc_assert (ss->dimen > 0);
1541 27181 : gcc_assert (ss->loop->dimen == ss->dimen);
1542 :
1543 27181 : 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 54397 : for (s = ss; s; s = s->parent)
1549 : {
1550 27216 : loop = s->loop;
1551 :
1552 27216 : total_dim += loop->dimen;
1553 63615 : for (n = 0; n < loop->dimen; n++)
1554 : {
1555 36399 : dim = s->dim[n];
1556 :
1557 : /* Callee allocated arrays may not have a known bound yet. */
1558 36399 : if (loop->to[n])
1559 33120 : 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 36399 : 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 36399 : 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 36399 : tmp_dim = get_scalarizer_dim_for_array_dim (ss, dim);
1578 36399 : from[tmp_dim] = loop->from[n];
1579 36399 : to[tmp_dim] = loop->to[n];
1580 :
1581 36399 : info->delta[dim] = gfc_index_zero_node;
1582 36399 : info->start[dim] = gfc_index_zero_node;
1583 36399 : info->end[dim] = gfc_index_zero_node;
1584 36399 : info->stride[dim] = gfc_index_one_node;
1585 : }
1586 : }
1587 :
1588 : /* Initialize the descriptor. */
1589 27181 : type =
1590 27181 : gfc_get_array_type_bounds (eltype, total_dim, 0, from, to, 1,
1591 : GFC_ARRAY_UNKNOWN, true);
1592 27181 : desc = gfc_create_var (type, "atmp");
1593 27181 : 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 27181 : tree arraytype = TREE_TYPE (GFC_TYPE_ARRAY_DATAPTR_TYPE (type));
1599 27181 : if (! TYPE_NAME (arraytype))
1600 27181 : TYPE_NAME (arraytype) = build_decl (UNKNOWN_LOCATION, TYPE_DECL,
1601 : NULL_TREE, arraytype);
1602 27181 : gfc_add_expr_to_block (pre, build1 (DECL_EXPR,
1603 27181 : arraytype, TYPE_NAME (arraytype)));
1604 :
1605 27181 : 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 27181 : if (class_expr != NULL_TREE
1612 27036 : || (fcn_ss && fcn_ss->info && fcn_ss->info->class_container))
1613 : {
1614 175 : tree class_data;
1615 175 : tree dtype;
1616 175 : gfc_expr *expr1 = fcn_ss ? fcn_ss->info->expr : NULL;
1617 169 : 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 259 : && (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 175 : if (class_expr != NULL_TREE && !rank_changer)
1631 : {
1632 97 : tmp = gfc_create_var (TREE_TYPE (class_expr), "ctmp");
1633 97 : 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 175 : class_data = gfc_class_data_get (tmp);
1669 :
1670 175 : 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 175 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1688 175 : TREE_TYPE (desc), desc);
1689 175 : gfc_add_modify (pre, class_data, tmp);
1690 :
1691 : /* Point desc to the class _data field. */
1692 175 : desc = class_data;
1693 175 : }
1694 : else
1695 : {
1696 : /* Fill in the array dtype. */
1697 27006 : tmp = gfc_conv_descriptor_dtype (desc);
1698 27006 : gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
1699 : }
1700 :
1701 27181 : info->descriptor = desc;
1702 27181 : 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 27181 : or_expr = NULL_TREE;
1718 :
1719 : /* If there is at least one null loop->to[n], it is a callee allocated
1720 : array. */
1721 60301 : for (n = 0; n < total_dim; n++)
1722 35051 : if (to[n] == NULL_TREE)
1723 : {
1724 : size = NULL_TREE;
1725 : break;
1726 : }
1727 :
1728 27181 : if (size == NULL_TREE)
1729 3872 : for (s = ss; s; s = s->parent)
1730 5225 : for (n = 0; n < s->loop->dimen; n++)
1731 : {
1732 3284 : 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 3284 : 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 3284 : s->loop->to[n] = tmp;
1741 : }
1742 : else
1743 : {
1744 58365 : for (n = 0; n < total_dim; n++)
1745 : {
1746 : /* Store the stride and bound components in the descriptor. */
1747 33115 : gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size);
1748 :
1749 33115 : gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
1750 : gfc_index_zero_node);
1751 :
1752 33115 : gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], to[n]);
1753 :
1754 33115 : 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 33115 : cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
1760 : tmp, gfc_index_zero_node);
1761 33115 : cond = gfc_evaluate_now (cond, pre);
1762 :
1763 33115 : if (n == 0)
1764 : or_expr = cond;
1765 : else
1766 7865 : or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1767 : logical_type_node, or_expr, cond);
1768 :
1769 33115 : size = fold_build2_loc (input_location, MULT_EXPR,
1770 : gfc_array_index_type, size, tmp);
1771 33115 : size = gfc_evaluate_now (size, pre);
1772 : }
1773 : }
1774 :
1775 : /* Get the size of the array. */
1776 27181 : 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 25060 : size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
1781 : or_expr, gfc_index_zero_node, size);
1782 :
1783 25060 : nelem = size;
1784 25060 : 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 27181 : tmp = fold_convert (gfc_array_index_type, elemsize);
1795 27181 : gfc_conv_descriptor_span_set (pre, desc, tmp);
1796 :
1797 27181 : gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
1798 : dynamic, dealloc);
1799 :
1800 54397 : while (ss->parent)
1801 : ss = ss->parent;
1802 :
1803 27181 : if (ss->dimen > ss->loop->temp_dim)
1804 23483 : ss->loop->temp_dim = ss->dimen;
1805 :
1806 27181 : return size;
1807 : }
1808 :
1809 :
1810 : /* Return the number of iterations in a loop that starts at START,
1811 : ends at END, and has step STEP. */
1812 :
1813 : static tree
1814 1059 : gfc_get_iteration_count (tree start, tree end, tree step)
1815 : {
1816 1059 : tree tmp;
1817 1059 : tree type;
1818 :
1819 1059 : type = TREE_TYPE (step);
1820 1059 : tmp = fold_build2_loc (input_location, MINUS_EXPR, type, end, start);
1821 1059 : tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, type, tmp, step);
1822 1059 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp,
1823 : build_int_cst (type, 1));
1824 1059 : tmp = fold_build2_loc (input_location, MAX_EXPR, type, tmp,
1825 : build_int_cst (type, 0));
1826 1059 : return fold_convert (gfc_array_index_type, tmp);
1827 : }
1828 :
1829 :
1830 : /* Extend the data in array DESC by EXTRA elements. */
1831 :
1832 : static void
1833 1047 : gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
1834 : {
1835 1047 : tree arg0, arg1;
1836 1047 : tree tmp;
1837 1047 : tree size;
1838 1047 : tree ubound;
1839 :
1840 1047 : if (integer_zerop (extra))
1841 : return;
1842 :
1843 1017 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
1844 :
1845 : /* Add EXTRA to the upper bound. */
1846 1017 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1847 : ubound, extra);
1848 1017 : gfc_conv_descriptor_ubound_set (pblock, desc, gfc_rank_cst[0], tmp);
1849 :
1850 : /* Get the value of the current data pointer. */
1851 1017 : arg0 = gfc_conv_descriptor_data_get (desc);
1852 :
1853 : /* Calculate the new array size. */
1854 1017 : size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
1855 1017 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1856 : ubound, gfc_index_one_node);
1857 1017 : arg1 = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
1858 : fold_convert (size_type_node, tmp),
1859 : fold_convert (size_type_node, size));
1860 :
1861 : /* Call the realloc() function. */
1862 1017 : tmp = gfc_call_realloc (pblock, arg0, arg1);
1863 1017 : gfc_conv_descriptor_data_set (pblock, desc, tmp);
1864 : }
1865 :
1866 :
1867 : /* Return true if the bounds of iterator I can only be determined
1868 : at run time. */
1869 :
1870 : static inline bool
1871 2215 : gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
1872 : {
1873 2215 : return (i->start->expr_type != EXPR_CONSTANT
1874 1797 : || i->end->expr_type != EXPR_CONSTANT
1875 2388 : || i->step->expr_type != EXPR_CONSTANT);
1876 : }
1877 :
1878 :
1879 : /* Split the size of constructor element EXPR into the sum of two terms,
1880 : one of which can be determined at compile time and one of which must
1881 : be calculated at run time. Set *SIZE to the former and return true
1882 : if the latter might be nonzero. */
1883 :
1884 : static bool
1885 3252 : gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
1886 : {
1887 3252 : if (expr->expr_type == EXPR_ARRAY)
1888 666 : return gfc_get_array_constructor_size (size, expr->value.constructor);
1889 2586 : else if (expr->rank > 0)
1890 : {
1891 : /* Calculate everything at run time. */
1892 1031 : mpz_set_ui (*size, 0);
1893 1031 : return true;
1894 : }
1895 : else
1896 : {
1897 : /* A single element. */
1898 1555 : mpz_set_ui (*size, 1);
1899 1555 : return false;
1900 : }
1901 : }
1902 :
1903 :
1904 : /* Like gfc_get_array_constructor_element_size, but applied to the whole
1905 : of array constructor C. */
1906 :
1907 : static bool
1908 2882 : gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base)
1909 : {
1910 2882 : gfc_constructor *c;
1911 2882 : gfc_iterator *i;
1912 2882 : mpz_t val;
1913 2882 : mpz_t len;
1914 2882 : bool dynamic;
1915 :
1916 2882 : mpz_set_ui (*size, 0);
1917 2882 : mpz_init (len);
1918 2882 : mpz_init (val);
1919 :
1920 2882 : dynamic = false;
1921 7112 : for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1922 : {
1923 4230 : i = c->iterator;
1924 4230 : if (i && gfc_iterator_has_dynamic_bounds (i))
1925 : dynamic = true;
1926 : else
1927 : {
1928 2720 : dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
1929 2720 : if (i)
1930 : {
1931 : /* Multiply the static part of the element size by the
1932 : number of iterations. */
1933 128 : mpz_sub (val, i->end->value.integer, i->start->value.integer);
1934 128 : mpz_fdiv_q (val, val, i->step->value.integer);
1935 128 : mpz_add_ui (val, val, 1);
1936 128 : if (mpz_sgn (val) > 0)
1937 92 : mpz_mul (len, len, val);
1938 : else
1939 36 : mpz_set_ui (len, 0);
1940 : }
1941 2720 : mpz_add (*size, *size, len);
1942 : }
1943 : }
1944 2882 : mpz_clear (len);
1945 2882 : mpz_clear (val);
1946 2882 : return dynamic;
1947 : }
1948 :
1949 :
1950 : /* Make sure offset is a variable. */
1951 :
1952 : static void
1953 3163 : 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 3163 : gcc_assert (*offsetvar != NULL_TREE);
1959 3163 : gfc_add_modify (pblock, *offsetvar, *poffset);
1960 3163 : *poffset = *offsetvar;
1961 3163 : TREE_USED (*offsetvar) = 1;
1962 3163 : }
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 12229 : gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
1972 : tree offset, gfc_se * se, gfc_expr * expr)
1973 : {
1974 12229 : tree tmp, offset_eval;
1975 :
1976 12229 : gfc_conv_expr (se, expr);
1977 :
1978 : /* Store the value. */
1979 12229 : 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 12229 : offset_eval = gfc_evaluate_now (offset, &se->pre);
1984 12229 : tmp = gfc_build_array_ref (tmp, offset_eval, NULL);
1985 :
1986 12229 : if (expr->expr_type == EXPR_FUNCTION && expr->ts.type == BT_DERIVED
1987 66 : && expr->ts.u.derived->attr.alloc_comp)
1988 27 : gfc_add_expr_to_block (&se->finalblock,
1989 : gfc_deallocate_alloc_comp_no_caf (expr->ts.u.derived,
1990 : tmp, expr->rank,
1991 : true));
1992 :
1993 12229 : 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 10089 : else if (GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
2048 10089 : && !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 10065 : se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
2062 10065 : gfc_add_modify (&se->pre, tmp, se->expr);
2063 : }
2064 :
2065 12229 : gfc_add_block_to_block (pblock, &se->pre);
2066 12229 : gfc_add_block_to_block (pblock, &se->post);
2067 12229 : }
2068 :
2069 :
2070 : /* Add the contents of an array to the constructor. DYNAMIC is as for
2071 : gfc_trans_array_constructor_value. */
2072 :
2073 : static void
2074 1117 : gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
2075 : tree type ATTRIBUTE_UNUSED,
2076 : tree desc, gfc_expr * expr,
2077 : tree * poffset, tree * offsetvar,
2078 : bool dynamic)
2079 : {
2080 1117 : gfc_se se;
2081 1117 : gfc_ss *ss;
2082 1117 : gfc_loopinfo loop;
2083 1117 : stmtblock_t body;
2084 1117 : tree tmp;
2085 1117 : tree size;
2086 1117 : int n;
2087 :
2088 : /* We need this to be a variable so we can increment it. */
2089 1117 : gfc_put_offset_into_var (pblock, poffset, offsetvar);
2090 :
2091 1117 : gfc_init_se (&se, NULL);
2092 :
2093 : /* Walk the array expression. */
2094 1117 : ss = gfc_walk_expr (expr);
2095 1117 : gcc_assert (ss != gfc_ss_terminator);
2096 :
2097 : /* Initialize the scalarizer. */
2098 1117 : gfc_init_loopinfo (&loop);
2099 1117 : gfc_add_ss_to_loop (&loop, ss);
2100 :
2101 : /* Initialize the loop. */
2102 1117 : gfc_conv_ss_startstride (&loop);
2103 1117 : gfc_conv_loop_setup (&loop, &expr->where);
2104 :
2105 : /* Make sure the constructed array has room for the new data. */
2106 1117 : if (dynamic)
2107 : {
2108 : /* Set SIZE to the total number of elements in the subarray. */
2109 515 : size = gfc_index_one_node;
2110 1042 : for (n = 0; n < loop.dimen; n++)
2111 : {
2112 527 : tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
2113 : gfc_index_one_node);
2114 527 : size = fold_build2_loc (input_location, MULT_EXPR,
2115 : gfc_array_index_type, size, tmp);
2116 : }
2117 :
2118 : /* Grow the constructed array by SIZE elements. */
2119 515 : gfc_grow_array (&loop.pre, desc, size);
2120 : }
2121 :
2122 : /* Make the loop body. */
2123 1117 : gfc_mark_ss_chain_used (ss, 1);
2124 1117 : gfc_start_scalarized_body (&loop, &body);
2125 1117 : gfc_copy_loopinfo_to_se (&se, &loop);
2126 1117 : se.ss = ss;
2127 :
2128 1117 : gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
2129 1117 : gcc_assert (se.ss == gfc_ss_terminator);
2130 :
2131 : /* Increment the offset. */
2132 1117 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2133 : *poffset, gfc_index_one_node);
2134 1117 : gfc_add_modify (&body, *poffset, tmp);
2135 :
2136 : /* Finish the loop. */
2137 1117 : gfc_trans_scalarizing_loops (&loop, &body);
2138 1117 : gfc_add_block_to_block (&loop.pre, &loop.post);
2139 1117 : tmp = gfc_finish_block (&loop.pre);
2140 1117 : gfc_add_expr_to_block (pblock, tmp);
2141 :
2142 1117 : gfc_cleanup_loop (&loop);
2143 1117 : }
2144 :
2145 :
2146 : /* Assign the values to the elements of an array constructor. DYNAMIC
2147 : is true if descriptor DESC only contains enough data for the static
2148 : size calculated by gfc_get_array_constructor_size. When true, memory
2149 : for the dynamic parts must be allocated using realloc. */
2150 :
2151 : static void
2152 7940 : gfc_trans_array_constructor_value (stmtblock_t * pblock,
2153 : stmtblock_t * finalblock,
2154 : tree type, tree desc,
2155 : gfc_constructor_base base, tree * poffset,
2156 : tree * offsetvar, bool dynamic)
2157 : {
2158 7940 : tree tmp;
2159 7940 : tree start = NULL_TREE;
2160 7940 : tree end = NULL_TREE;
2161 7940 : tree step = NULL_TREE;
2162 7940 : stmtblock_t body;
2163 7940 : gfc_se se;
2164 7940 : mpz_t size;
2165 7940 : gfc_constructor *c;
2166 7940 : gfc_typespec ts;
2167 7940 : int ctr = 0;
2168 :
2169 7940 : tree shadow_loopvar = NULL_TREE;
2170 7940 : gfc_saved_var saved_loopvar;
2171 :
2172 7940 : ts.type = BT_UNKNOWN;
2173 7940 : mpz_init (size);
2174 21625 : for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
2175 : {
2176 13685 : ctr++;
2177 : /* If this is an iterator or an array, the offset must be a variable. */
2178 13685 : if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
2179 2046 : gfc_put_offset_into_var (pblock, poffset, offsetvar);
2180 :
2181 : /* Shadowing the iterator avoids changing its value and saves us from
2182 : keeping track of it. Further, it makes sure that there's always a
2183 : backend-decl for the symbol, even if there wasn't one before,
2184 : e.g. in the case of an iterator that appears in a specification
2185 : expression in an interface mapping. */
2186 13685 : if (c->iterator)
2187 : {
2188 1341 : gfc_symbol *sym;
2189 1341 : tree type;
2190 :
2191 : /* Evaluate loop bounds before substituting the loop variable
2192 : in case they depend on it. Such a case is invalid, but it is
2193 : not more expensive to do the right thing here.
2194 : See PR 44354. */
2195 1341 : gfc_init_se (&se, NULL);
2196 1341 : gfc_conv_expr_val (&se, c->iterator->start);
2197 1341 : gfc_add_block_to_block (pblock, &se.pre);
2198 1341 : start = gfc_evaluate_now (se.expr, pblock);
2199 :
2200 1341 : gfc_init_se (&se, NULL);
2201 1341 : gfc_conv_expr_val (&se, c->iterator->end);
2202 1341 : gfc_add_block_to_block (pblock, &se.pre);
2203 1341 : end = gfc_evaluate_now (se.expr, pblock);
2204 :
2205 1341 : gfc_init_se (&se, NULL);
2206 1341 : gfc_conv_expr_val (&se, c->iterator->step);
2207 1341 : gfc_add_block_to_block (pblock, &se.pre);
2208 1341 : step = gfc_evaluate_now (se.expr, pblock);
2209 :
2210 1341 : sym = c->iterator->var->symtree->n.sym;
2211 1341 : type = gfc_typenode_for_spec (&sym->ts);
2212 :
2213 1341 : shadow_loopvar = gfc_create_var (type, "shadow_loopvar");
2214 1341 : gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar);
2215 : }
2216 :
2217 13685 : gfc_start_block (&body);
2218 :
2219 13685 : if (c->expr->expr_type == EXPR_ARRAY)
2220 : {
2221 : /* Array constructors can be nested. */
2222 1351 : gfc_trans_array_constructor_value (&body, finalblock, type,
2223 : desc, c->expr->value.constructor,
2224 : poffset, offsetvar, dynamic);
2225 : }
2226 12334 : else if (c->expr->rank > 0)
2227 : {
2228 1117 : gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
2229 : poffset, offsetvar, dynamic);
2230 : }
2231 : else
2232 : {
2233 : /* This code really upsets the gimplifier so don't bother for now. */
2234 : gfc_constructor *p;
2235 : HOST_WIDE_INT n;
2236 : HOST_WIDE_INT size;
2237 :
2238 : p = c;
2239 : n = 0;
2240 13022 : while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
2241 : {
2242 1805 : p = gfc_constructor_next (p);
2243 1805 : n++;
2244 : }
2245 : /* Constructor with few constant elements, or element size not
2246 : known at compile time (e.g. deferred-length character). */
2247 11217 : if (n < 4 || !INTEGER_CST_P (TYPE_SIZE_UNIT (type)))
2248 : {
2249 : /* Scalar values. */
2250 11112 : gfc_init_se (&se, NULL);
2251 11112 : if (IS_PDT (c->expr) && c->expr->expr_type == EXPR_STRUCTURE)
2252 234 : c->expr->must_finalize = 1;
2253 :
2254 11112 : gfc_trans_array_ctor_element (&body, desc, *poffset,
2255 : &se, c->expr);
2256 :
2257 11112 : *poffset = fold_build2_loc (input_location, PLUS_EXPR,
2258 : gfc_array_index_type,
2259 : *poffset, gfc_index_one_node);
2260 11112 : if (finalblock)
2261 1202 : gfc_add_block_to_block (finalblock, &se.finalblock);
2262 : }
2263 : else
2264 : {
2265 : /* Collect multiple scalar constants into a constructor. */
2266 105 : vec<constructor_elt, va_gc> *v = NULL;
2267 105 : tree init;
2268 105 : tree bound;
2269 105 : tree tmptype;
2270 105 : HOST_WIDE_INT idx = 0;
2271 :
2272 105 : p = c;
2273 : /* Count the number of consecutive scalar constants. */
2274 837 : while (p && !(p->iterator
2275 745 : || p->expr->expr_type != EXPR_CONSTANT))
2276 : {
2277 732 : gfc_init_se (&se, NULL);
2278 732 : gfc_conv_constant (&se, p->expr);
2279 :
2280 732 : if (c->expr->ts.type != BT_CHARACTER)
2281 660 : se.expr = fold_convert (type, se.expr);
2282 : /* For constant character array constructors we build
2283 : an array of pointers. */
2284 72 : else if (POINTER_TYPE_P (type))
2285 0 : se.expr = gfc_build_addr_expr
2286 0 : (gfc_get_pchar_type (p->expr->ts.kind),
2287 : se.expr);
2288 :
2289 732 : CONSTRUCTOR_APPEND_ELT (v,
2290 : build_int_cst (gfc_array_index_type,
2291 : idx++),
2292 : se.expr);
2293 732 : c = p;
2294 732 : p = gfc_constructor_next (p);
2295 : }
2296 :
2297 105 : bound = size_int (n - 1);
2298 : /* Create an array type to hold them. */
2299 105 : tmptype = build_range_type (gfc_array_index_type,
2300 : gfc_index_zero_node, bound);
2301 105 : tmptype = build_array_type (type, tmptype);
2302 :
2303 105 : init = build_constructor (tmptype, v);
2304 105 : TREE_CONSTANT (init) = 1;
2305 105 : TREE_STATIC (init) = 1;
2306 : /* Create a static variable to hold the data. */
2307 105 : tmp = gfc_create_var (tmptype, "data");
2308 105 : TREE_STATIC (tmp) = 1;
2309 105 : TREE_CONSTANT (tmp) = 1;
2310 105 : TREE_READONLY (tmp) = 1;
2311 105 : DECL_INITIAL (tmp) = init;
2312 105 : init = tmp;
2313 :
2314 : /* Use BUILTIN_MEMCPY to assign the values. */
2315 105 : tmp = gfc_conv_descriptor_data_get (desc);
2316 105 : tmp = build_fold_indirect_ref_loc (input_location,
2317 : tmp);
2318 105 : tmp = gfc_build_array_ref (tmp, *poffset, NULL);
2319 105 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
2320 105 : init = gfc_build_addr_expr (NULL_TREE, init);
2321 :
2322 105 : size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
2323 105 : bound = build_int_cst (size_type_node, n * size);
2324 105 : tmp = build_call_expr_loc (input_location,
2325 : builtin_decl_explicit (BUILT_IN_MEMCPY),
2326 : 3, tmp, init, bound);
2327 105 : gfc_add_expr_to_block (&body, tmp);
2328 :
2329 105 : *poffset = fold_build2_loc (input_location, PLUS_EXPR,
2330 : gfc_array_index_type, *poffset,
2331 105 : build_int_cst (gfc_array_index_type, n));
2332 : }
2333 11217 : if (!INTEGER_CST_P (*poffset))
2334 : {
2335 1655 : gfc_add_modify (&body, *offsetvar, *poffset);
2336 1655 : *poffset = *offsetvar;
2337 : }
2338 :
2339 11217 : if (!c->iterator)
2340 11217 : ts = c->expr->ts;
2341 : }
2342 :
2343 : /* The frontend should already have done any expansions
2344 : at compile-time. */
2345 13685 : if (!c->iterator)
2346 : {
2347 : /* Pass the code as is. */
2348 12344 : tmp = gfc_finish_block (&body);
2349 12344 : gfc_add_expr_to_block (pblock, tmp);
2350 : }
2351 : else
2352 : {
2353 : /* Build the implied do-loop. */
2354 1341 : stmtblock_t implied_do_block;
2355 1341 : tree cond;
2356 1341 : tree exit_label;
2357 1341 : tree loopbody;
2358 1341 : tree tmp2;
2359 :
2360 1341 : loopbody = gfc_finish_block (&body);
2361 :
2362 : /* Create a new block that holds the implied-do loop. A temporary
2363 : loop-variable is used. */
2364 1341 : gfc_start_block(&implied_do_block);
2365 :
2366 : /* Initialize the loop. */
2367 1341 : gfc_add_modify (&implied_do_block, shadow_loopvar, start);
2368 :
2369 : /* If this array expands dynamically, and the number of iterations
2370 : is not constant, we won't have allocated space for the static
2371 : part of C->EXPR's size. Do that now. */
2372 1341 : if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
2373 : {
2374 : /* Get the number of iterations. */
2375 532 : tmp = gfc_get_iteration_count (shadow_loopvar, end, step);
2376 :
2377 : /* Get the static part of C->EXPR's size. */
2378 532 : gfc_get_array_constructor_element_size (&size, c->expr);
2379 532 : tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
2380 :
2381 : /* Grow the array by TMP * TMP2 elements. */
2382 532 : tmp = fold_build2_loc (input_location, MULT_EXPR,
2383 : gfc_array_index_type, tmp, tmp2);
2384 532 : gfc_grow_array (&implied_do_block, desc, tmp);
2385 : }
2386 :
2387 : /* Generate the loop body. */
2388 1341 : exit_label = gfc_build_label_decl (NULL_TREE);
2389 1341 : gfc_start_block (&body);
2390 :
2391 : /* Generate the exit condition. Depending on the sign of
2392 : the step variable we have to generate the correct
2393 : comparison. */
2394 1341 : tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2395 1341 : step, build_int_cst (TREE_TYPE (step), 0));
2396 1341 : cond = fold_build3_loc (input_location, COND_EXPR,
2397 : logical_type_node, tmp,
2398 : fold_build2_loc (input_location, GT_EXPR,
2399 : logical_type_node, shadow_loopvar, end),
2400 : fold_build2_loc (input_location, LT_EXPR,
2401 : logical_type_node, shadow_loopvar, end));
2402 1341 : tmp = build1_v (GOTO_EXPR, exit_label);
2403 1341 : TREE_USED (exit_label) = 1;
2404 1341 : tmp = build3_v (COND_EXPR, cond, tmp,
2405 : build_empty_stmt (input_location));
2406 1341 : gfc_add_expr_to_block (&body, tmp);
2407 :
2408 : /* The main loop body. */
2409 1341 : gfc_add_expr_to_block (&body, loopbody);
2410 :
2411 : /* Increase loop variable by step. */
2412 1341 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
2413 1341 : TREE_TYPE (shadow_loopvar), shadow_loopvar,
2414 : step);
2415 1341 : gfc_add_modify (&body, shadow_loopvar, tmp);
2416 :
2417 : /* Finish the loop. */
2418 1341 : tmp = gfc_finish_block (&body);
2419 1341 : tmp = build1_v (LOOP_EXPR, tmp);
2420 1341 : gfc_add_expr_to_block (&implied_do_block, tmp);
2421 :
2422 : /* Add the exit label. */
2423 1341 : tmp = build1_v (LABEL_EXPR, exit_label);
2424 1341 : gfc_add_expr_to_block (&implied_do_block, tmp);
2425 :
2426 : /* Finish the implied-do loop. */
2427 1341 : tmp = gfc_finish_block(&implied_do_block);
2428 1341 : gfc_add_expr_to_block(pblock, tmp);
2429 :
2430 1341 : gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar);
2431 : }
2432 : }
2433 :
2434 : /* F2008 4.5.6.3 para 5: If an executable construct references a structure
2435 : constructor or array constructor, the entity created by the constructor is
2436 : finalized after execution of the innermost executable construct containing
2437 : the reference. This, in fact, was later deleted by the Combined Techical
2438 : Corrigenda 1 TO 4 for fortran 2008 (f08/0011).
2439 :
2440 : Transmit finalization of this constructor through 'finalblock'. */
2441 7940 : if ((gfc_option.allow_std & (GFC_STD_F2008 | GFC_STD_F2003))
2442 7940 : && !(gfc_option.allow_std & GFC_STD_GNU)
2443 70 : && finalblock != NULL
2444 24 : && gfc_may_be_finalized (ts)
2445 18 : && ctr > 0 && desc != NULL_TREE
2446 7958 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
2447 : {
2448 18 : symbol_attribute attr;
2449 18 : gfc_se fse;
2450 18 : locus loc;
2451 18 : gfc_locus_from_location (&loc, input_location);
2452 18 : gfc_warning (0, "The structure constructor at %L has been"
2453 : " finalized. This feature was removed by f08/0011."
2454 : " Use -std=f2018 or -std=gnu to eliminate the"
2455 : " finalization.", &loc);
2456 18 : attr.pointer = attr.allocatable = 0;
2457 18 : gfc_init_se (&fse, NULL);
2458 18 : fse.expr = desc;
2459 18 : gfc_finalize_tree_expr (&fse, ts.u.derived, attr, 1);
2460 18 : gfc_add_block_to_block (finalblock, &fse.pre);
2461 18 : gfc_add_block_to_block (finalblock, &fse.finalblock);
2462 18 : gfc_add_block_to_block (finalblock, &fse.post);
2463 : }
2464 :
2465 7940 : mpz_clear (size);
2466 7940 : }
2467 :
2468 :
2469 : /* The array constructor code can create a string length with an operand
2470 : in the form of a temporary variable. This variable will retain its
2471 : context (current_function_decl). If we store this length tree in a
2472 : gfc_charlen structure which is shared by a variable in another
2473 : context, the resulting gfc_charlen structure with a variable in a
2474 : different context, we could trip the assertion in expand_expr_real_1
2475 : when it sees that a variable has been created in one context and
2476 : referenced in another.
2477 :
2478 : If this might be the case, we create a new gfc_charlen structure and
2479 : link it into the current namespace. */
2480 :
2481 : static void
2482 8419 : store_backend_decl (gfc_charlen **clp, tree len, bool force_new_cl)
2483 : {
2484 8419 : if (force_new_cl)
2485 : {
2486 8392 : gfc_charlen *new_cl = gfc_new_charlen (gfc_current_ns, *clp);
2487 8392 : *clp = new_cl;
2488 : }
2489 8419 : (*clp)->backend_decl = len;
2490 8419 : }
2491 :
2492 : /* A catch-all to obtain the string length for anything that is not
2493 : a substring of non-constant length, a constant, array or variable. */
2494 :
2495 : static void
2496 330 : get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
2497 : {
2498 330 : gfc_se se;
2499 :
2500 : /* Don't bother if we already know the length is a constant. */
2501 330 : if (*len && INTEGER_CST_P (*len))
2502 52 : return;
2503 :
2504 278 : if (!e->ref && e->ts.u.cl && e->ts.u.cl->length
2505 29 : && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
2506 : {
2507 : /* This is easy. */
2508 1 : gfc_conv_const_charlen (e->ts.u.cl);
2509 1 : *len = e->ts.u.cl->backend_decl;
2510 : }
2511 : else
2512 : {
2513 : /* Otherwise, be brutal even if inefficient. */
2514 277 : gfc_init_se (&se, NULL);
2515 :
2516 : /* No function call, in case of side effects. */
2517 277 : se.no_function_call = 1;
2518 277 : if (e->rank == 0)
2519 134 : gfc_conv_expr (&se, e);
2520 : else
2521 143 : gfc_conv_expr_descriptor (&se, e);
2522 :
2523 : /* Fix the value. */
2524 277 : *len = gfc_evaluate_now (se.string_length, &se.pre);
2525 :
2526 277 : gfc_add_block_to_block (block, &se.pre);
2527 277 : gfc_add_block_to_block (block, &se.post);
2528 :
2529 277 : store_backend_decl (&e->ts.u.cl, *len, true);
2530 : }
2531 : }
2532 :
2533 :
2534 : /* Figure out the string length of a variable reference expression.
2535 : Used by get_array_ctor_strlen. */
2536 :
2537 : static void
2538 930 : get_array_ctor_var_strlen (stmtblock_t *block, gfc_expr * expr, tree * len)
2539 : {
2540 930 : gfc_ref *ref;
2541 930 : gfc_typespec *ts;
2542 930 : mpz_t char_len;
2543 930 : gfc_se se;
2544 :
2545 : /* Don't bother if we already know the length is a constant. */
2546 930 : if (*len && INTEGER_CST_P (*len))
2547 557 : return;
2548 :
2549 468 : ts = &expr->symtree->n.sym->ts;
2550 747 : for (ref = expr->ref; ref; ref = ref->next)
2551 : {
2552 374 : switch (ref->type)
2553 : {
2554 234 : case REF_ARRAY:
2555 : /* Array references don't change the string length. */
2556 234 : if (ts->deferred)
2557 136 : get_array_ctor_all_strlen (block, expr, len);
2558 : break;
2559 :
2560 45 : case REF_COMPONENT:
2561 : /* Use the length of the component. */
2562 45 : ts = &ref->u.c.component->ts;
2563 45 : break;
2564 :
2565 95 : case REF_SUBSTRING:
2566 95 : if (ref->u.ss.end == NULL
2567 83 : || ref->u.ss.start->expr_type != EXPR_CONSTANT
2568 64 : || ref->u.ss.end->expr_type != EXPR_CONSTANT)
2569 : {
2570 : /* Note that this might evaluate expr. */
2571 64 : get_array_ctor_all_strlen (block, expr, len);
2572 64 : return;
2573 : }
2574 31 : mpz_init_set_ui (char_len, 1);
2575 31 : mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
2576 31 : mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
2577 31 : *len = gfc_conv_mpz_to_tree_type (char_len, gfc_charlen_type_node);
2578 31 : mpz_clear (char_len);
2579 31 : return;
2580 :
2581 : case REF_INQUIRY:
2582 : break;
2583 :
2584 0 : default:
2585 0 : gcc_unreachable ();
2586 : }
2587 : }
2588 :
2589 : /* A last ditch attempt that is sometimes needed for deferred characters. */
2590 373 : if (!ts->u.cl->backend_decl)
2591 : {
2592 19 : gfc_init_se (&se, NULL);
2593 19 : if (expr->rank)
2594 12 : gfc_conv_expr_descriptor (&se, expr);
2595 : else
2596 7 : gfc_conv_expr (&se, expr);
2597 19 : gcc_assert (se.string_length != NULL_TREE);
2598 19 : gfc_add_block_to_block (block, &se.pre);
2599 19 : ts->u.cl->backend_decl = se.string_length;
2600 : }
2601 :
2602 373 : *len = ts->u.cl->backend_decl;
2603 : }
2604 :
2605 :
2606 : /* Figure out the string length of a character array constructor.
2607 : If len is NULL, don't calculate the length; this happens for recursive calls
2608 : when a sub-array-constructor is an element but not at the first position,
2609 : so when we're not interested in the length.
2610 : Returns TRUE if all elements are character constants. */
2611 :
2612 : bool
2613 8850 : get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len)
2614 : {
2615 8850 : gfc_constructor *c;
2616 8850 : bool is_const;
2617 :
2618 8850 : is_const = true;
2619 :
2620 8850 : if (gfc_constructor_first (base) == NULL)
2621 : {
2622 315 : if (len)
2623 315 : *len = build_int_cstu (gfc_charlen_type_node, 0);
2624 315 : return is_const;
2625 : }
2626 :
2627 : /* Loop over all constructor elements to find out is_const, but in len we
2628 : want to store the length of the first, not the last, element. We can
2629 : of course exit the loop as soon as is_const is found to be false. */
2630 8535 : for (c = gfc_constructor_first (base);
2631 46390 : c && is_const; c = gfc_constructor_next (c))
2632 : {
2633 37855 : switch (c->expr->expr_type)
2634 : {
2635 36692 : case EXPR_CONSTANT:
2636 36692 : if (len && !(*len && INTEGER_CST_P (*len)))
2637 404 : *len = build_int_cstu (gfc_charlen_type_node,
2638 404 : c->expr->value.character.length);
2639 : break;
2640 :
2641 43 : case EXPR_ARRAY:
2642 43 : if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
2643 1151 : is_const = false;
2644 : break;
2645 :
2646 990 : case EXPR_VARIABLE:
2647 990 : is_const = false;
2648 990 : if (len)
2649 930 : get_array_ctor_var_strlen (block, c->expr, len);
2650 : break;
2651 :
2652 130 : default:
2653 130 : is_const = false;
2654 130 : if (len)
2655 130 : get_array_ctor_all_strlen (block, c->expr, len);
2656 : break;
2657 : }
2658 :
2659 : /* After the first iteration, we don't want the length modified. */
2660 37855 : len = NULL;
2661 : }
2662 :
2663 : return is_const;
2664 : }
2665 :
2666 : /* Check whether the array constructor C consists entirely of constant
2667 : elements, and if so returns the number of those elements, otherwise
2668 : return zero. Note, an empty or NULL array constructor returns zero. */
2669 :
2670 : unsigned HOST_WIDE_INT
2671 57998 : gfc_constant_array_constructor_p (gfc_constructor_base base)
2672 : {
2673 57998 : unsigned HOST_WIDE_INT nelem = 0;
2674 :
2675 57998 : gfc_constructor *c = gfc_constructor_first (base);
2676 511903 : while (c)
2677 : {
2678 402665 : if (c->iterator
2679 401253 : || c->expr->rank > 0
2680 400455 : || c->expr->expr_type != EXPR_CONSTANT)
2681 : return 0;
2682 395907 : c = gfc_constructor_next (c);
2683 395907 : nelem++;
2684 : }
2685 : return nelem;
2686 : }
2687 :
2688 :
2689 : /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
2690 : and the tree type of it's elements, TYPE, return a static constant
2691 : variable that is compile-time initialized. */
2692 :
2693 : tree
2694 41062 : gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
2695 : {
2696 41062 : tree tmptype, init, tmp;
2697 41062 : HOST_WIDE_INT nelem;
2698 41062 : gfc_constructor *c;
2699 41062 : gfc_array_spec as;
2700 41062 : gfc_se se;
2701 41062 : int i;
2702 41062 : vec<constructor_elt, va_gc> *v = NULL;
2703 :
2704 : /* First traverse the constructor list, converting the constants
2705 : to tree to build an initializer. */
2706 41062 : nelem = 0;
2707 41062 : c = gfc_constructor_first (expr->value.constructor);
2708 398214 : while (c)
2709 : {
2710 316090 : gfc_init_se (&se, NULL);
2711 316090 : gfc_conv_constant (&se, c->expr);
2712 316090 : if (c->expr->ts.type != BT_CHARACTER)
2713 280318 : se.expr = fold_convert (type, se.expr);
2714 35772 : else if (POINTER_TYPE_P (type))
2715 35772 : se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
2716 : se.expr);
2717 316090 : CONSTRUCTOR_APPEND_ELT (v, build_int_cst (gfc_array_index_type, nelem),
2718 : se.expr);
2719 316090 : c = gfc_constructor_next (c);
2720 316090 : nelem++;
2721 : }
2722 :
2723 : /* Next determine the tree type for the array. We use the gfortran
2724 : front-end's gfc_get_nodesc_array_type in order to create a suitable
2725 : GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
2726 :
2727 41062 : memset (&as, 0, sizeof (gfc_array_spec));
2728 :
2729 41062 : as.rank = expr->rank;
2730 41062 : as.type = AS_EXPLICIT;
2731 41062 : if (!expr->shape)
2732 : {
2733 4 : as.lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
2734 4 : as.upper[0] = gfc_get_int_expr (gfc_default_integer_kind,
2735 : NULL, nelem - 1);
2736 : }
2737 : else
2738 88675 : for (i = 0; i < expr->rank; i++)
2739 : {
2740 47617 : int tmp = (int) mpz_get_si (expr->shape[i]);
2741 47617 : as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
2742 47617 : as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind,
2743 47617 : NULL, tmp - 1);
2744 : }
2745 :
2746 41062 : tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
2747 :
2748 : /* as is not needed anymore. */
2749 129745 : for (i = 0; i < as.rank + as.corank; i++)
2750 : {
2751 47621 : gfc_free_expr (as.lower[i]);
2752 47621 : gfc_free_expr (as.upper[i]);
2753 : }
2754 :
2755 41062 : init = build_constructor (tmptype, v);
2756 :
2757 41062 : TREE_CONSTANT (init) = 1;
2758 41062 : TREE_STATIC (init) = 1;
2759 :
2760 41062 : tmp = build_decl (input_location, VAR_DECL, create_tmp_var_name ("A"),
2761 : tmptype);
2762 41062 : DECL_ARTIFICIAL (tmp) = 1;
2763 41062 : DECL_IGNORED_P (tmp) = 1;
2764 41062 : TREE_STATIC (tmp) = 1;
2765 41062 : TREE_CONSTANT (tmp) = 1;
2766 41062 : TREE_READONLY (tmp) = 1;
2767 41062 : DECL_INITIAL (tmp) = init;
2768 41062 : pushdecl (tmp);
2769 :
2770 41062 : return tmp;
2771 : }
2772 :
2773 :
2774 : /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
2775 : This mostly initializes the scalarizer state info structure with the
2776 : appropriate values to directly use the array created by the function
2777 : gfc_build_constant_array_constructor. */
2778 :
2779 : static void
2780 35350 : trans_constant_array_constructor (gfc_ss * ss, tree type)
2781 : {
2782 35350 : gfc_array_info *info;
2783 35350 : tree tmp;
2784 35350 : int i;
2785 :
2786 35350 : tmp = gfc_build_constant_array_constructor (ss->info->expr, type);
2787 :
2788 35350 : info = &ss->info->data.array;
2789 :
2790 35350 : info->descriptor = tmp;
2791 35350 : info->data = gfc_build_addr_expr (NULL_TREE, tmp);
2792 35350 : info->offset = gfc_index_zero_node;
2793 :
2794 74459 : for (i = 0; i < ss->dimen; i++)
2795 : {
2796 39109 : info->delta[i] = gfc_index_zero_node;
2797 39109 : info->start[i] = gfc_index_zero_node;
2798 39109 : info->end[i] = gfc_index_zero_node;
2799 39109 : info->stride[i] = gfc_index_one_node;
2800 : }
2801 35350 : }
2802 :
2803 :
2804 : static int
2805 35356 : get_rank (gfc_loopinfo *loop)
2806 : {
2807 35356 : int rank;
2808 :
2809 35356 : rank = 0;
2810 151918 : for (; loop; loop = loop->parent)
2811 75965 : rank += loop->dimen;
2812 :
2813 40597 : return rank;
2814 : }
2815 :
2816 :
2817 : /* Helper routine of gfc_trans_array_constructor to determine if the
2818 : bounds of the loop specified by LOOP are constant and simple enough
2819 : to use with trans_constant_array_constructor. Returns the
2820 : iteration count of the loop if suitable, and NULL_TREE otherwise. */
2821 :
2822 : static tree
2823 35356 : constant_array_constructor_loop_size (gfc_loopinfo * l)
2824 : {
2825 35356 : gfc_loopinfo *loop;
2826 35356 : tree size = gfc_index_one_node;
2827 35356 : tree tmp;
2828 35356 : int i, total_dim;
2829 :
2830 35356 : total_dim = get_rank (l);
2831 :
2832 70712 : for (loop = l; loop; loop = loop->parent)
2833 : {
2834 74483 : for (i = 0; i < loop->dimen; i++)
2835 : {
2836 : /* If the bounds aren't constant, return NULL_TREE. */
2837 39127 : if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
2838 : return NULL_TREE;
2839 39121 : if (!integer_zerop (loop->from[i]))
2840 : {
2841 : /* Only allow nonzero "from" in one-dimensional arrays. */
2842 0 : if (total_dim != 1)
2843 : return NULL_TREE;
2844 0 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2845 : gfc_array_index_type,
2846 : loop->to[i], loop->from[i]);
2847 : }
2848 : else
2849 39121 : tmp = loop->to[i];
2850 39121 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
2851 : gfc_array_index_type, tmp, gfc_index_one_node);
2852 39121 : size = fold_build2_loc (input_location, MULT_EXPR,
2853 : gfc_array_index_type, size, tmp);
2854 : }
2855 : }
2856 :
2857 : return size;
2858 : }
2859 :
2860 :
2861 : static tree *
2862 41939 : get_loop_upper_bound_for_array (gfc_ss *array, int array_dim)
2863 : {
2864 41939 : gfc_ss *ss;
2865 41939 : int n;
2866 :
2867 41939 : gcc_assert (array->nested_ss == NULL);
2868 :
2869 41939 : for (ss = array; ss; ss = ss->parent)
2870 41939 : for (n = 0; n < ss->loop->dimen; n++)
2871 41939 : if (array_dim == get_array_ref_dim_for_loop_dim (ss, n))
2872 41939 : return &(ss->loop->to[n]);
2873 :
2874 0 : gcc_unreachable ();
2875 : }
2876 :
2877 :
2878 : static gfc_loopinfo *
2879 694637 : outermost_loop (gfc_loopinfo * loop)
2880 : {
2881 900275 : while (loop->parent != NULL)
2882 : loop = loop->parent;
2883 :
2884 694637 : return loop;
2885 : }
2886 :
2887 :
2888 : /* Array constructors are handled by constructing a temporary, then using that
2889 : within the scalarization loop. This is not optimal, but seems by far the
2890 : simplest method. */
2891 :
2892 : static void
2893 41939 : trans_array_constructor (gfc_ss * ss, locus * where)
2894 : {
2895 41939 : gfc_constructor_base c;
2896 41939 : tree offset;
2897 41939 : tree offsetvar;
2898 41939 : tree desc;
2899 41939 : tree type;
2900 41939 : tree tmp;
2901 41939 : tree *loop_ubound0;
2902 41939 : bool dynamic;
2903 41939 : bool old_first_len, old_typespec_chararray_ctor;
2904 41939 : tree old_first_len_val;
2905 41939 : gfc_loopinfo *loop, *outer_loop;
2906 41939 : gfc_ss_info *ss_info;
2907 41939 : gfc_expr *expr;
2908 41939 : gfc_ss *s;
2909 41939 : tree neg_len;
2910 41939 : char *msg;
2911 41939 : stmtblock_t finalblock;
2912 41939 : bool finalize_required;
2913 :
2914 : /* Save the old values for nested checking. */
2915 41939 : old_first_len = first_len;
2916 41939 : old_first_len_val = first_len_val;
2917 41939 : old_typespec_chararray_ctor = typespec_chararray_ctor;
2918 :
2919 41939 : loop = ss->loop;
2920 41939 : outer_loop = outermost_loop (loop);
2921 41939 : ss_info = ss->info;
2922 41939 : expr = ss_info->expr;
2923 :
2924 : /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
2925 : typespec was given for the array constructor. */
2926 83878 : typespec_chararray_ctor = (expr->ts.type == BT_CHARACTER
2927 8142 : && expr->ts.u.cl
2928 50081 : && expr->ts.u.cl->length_from_typespec);
2929 :
2930 41939 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2931 2542 : && expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
2932 : {
2933 1468 : first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
2934 1468 : first_len = true;
2935 : }
2936 :
2937 41939 : gcc_assert (ss->dimen == ss->loop->dimen);
2938 :
2939 41939 : c = expr->value.constructor;
2940 41939 : if (expr->ts.type == BT_CHARACTER)
2941 : {
2942 8142 : bool const_string;
2943 8142 : bool force_new_cl = false;
2944 :
2945 : /* get_array_ctor_strlen walks the elements of the constructor, if a
2946 : typespec was given, we already know the string length and want the one
2947 : specified there. */
2948 8142 : if (typespec_chararray_ctor && expr->ts.u.cl->length
2949 500 : && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
2950 : {
2951 27 : gfc_se length_se;
2952 :
2953 27 : const_string = false;
2954 27 : gfc_init_se (&length_se, NULL);
2955 27 : gfc_conv_expr_type (&length_se, expr->ts.u.cl->length,
2956 : gfc_charlen_type_node);
2957 27 : ss_info->string_length = length_se.expr;
2958 :
2959 : /* Check if the character length is negative. If it is, then
2960 : set LEN = 0. */
2961 27 : neg_len = fold_build2_loc (input_location, LT_EXPR,
2962 : logical_type_node, ss_info->string_length,
2963 27 : build_zero_cst (TREE_TYPE
2964 : (ss_info->string_length)));
2965 : /* Print a warning if bounds checking is enabled. */
2966 27 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2967 : {
2968 18 : msg = xasprintf ("Negative character length treated as LEN = 0");
2969 18 : gfc_trans_runtime_check (false, true, neg_len, &length_se.pre,
2970 : where, msg);
2971 18 : free (msg);
2972 : }
2973 :
2974 27 : ss_info->string_length
2975 27 : = fold_build3_loc (input_location, COND_EXPR,
2976 : gfc_charlen_type_node, neg_len,
2977 : build_zero_cst
2978 27 : (TREE_TYPE (ss_info->string_length)),
2979 : ss_info->string_length);
2980 27 : ss_info->string_length = gfc_evaluate_now (ss_info->string_length,
2981 : &length_se.pre);
2982 27 : gfc_add_block_to_block (&outer_loop->pre, &length_se.pre);
2983 27 : gfc_add_block_to_block (&outer_loop->post, &length_se.post);
2984 27 : }
2985 : else
2986 : {
2987 8115 : const_string = get_array_ctor_strlen (&outer_loop->pre, c,
2988 : &ss_info->string_length);
2989 8115 : force_new_cl = true;
2990 :
2991 : /* Initialize "len" with string length for bounds checking. */
2992 8115 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2993 1486 : && !typespec_chararray_ctor
2994 1468 : && ss_info->string_length)
2995 : {
2996 1468 : gfc_se length_se;
2997 :
2998 1468 : gfc_init_se (&length_se, NULL);
2999 1468 : gfc_add_modify (&length_se.pre, first_len_val,
3000 1468 : fold_convert (TREE_TYPE (first_len_val),
3001 : ss_info->string_length));
3002 1468 : ss_info->string_length = gfc_evaluate_now (ss_info->string_length,
3003 : &length_se.pre);
3004 1468 : gfc_add_block_to_block (&outer_loop->pre, &length_se.pre);
3005 1468 : gfc_add_block_to_block (&outer_loop->post, &length_se.post);
3006 : }
3007 : }
3008 :
3009 : /* Complex character array constructors should have been taken care of
3010 : and not end up here. */
3011 8142 : gcc_assert (ss_info->string_length);
3012 :
3013 8142 : store_backend_decl (&expr->ts.u.cl, ss_info->string_length, force_new_cl);
3014 :
3015 8142 : type = gfc_get_character_type_len (expr->ts.kind, ss_info->string_length);
3016 8142 : if (const_string)
3017 7191 : type = build_pointer_type (type);
3018 : }
3019 : else
3020 33822 : type = gfc_typenode_for_spec (expr->ts.type == BT_CLASS
3021 25 : ? &CLASS_DATA (expr)->ts : &expr->ts);
3022 :
3023 : /* See if the constructor determines the loop bounds. */
3024 41939 : dynamic = false;
3025 :
3026 41939 : loop_ubound0 = get_loop_upper_bound_for_array (ss, 0);
3027 :
3028 82536 : if (expr->shape && get_rank (loop) > 1 && *loop_ubound0 == NULL_TREE)
3029 : {
3030 : /* We have a multidimensional parameter. */
3031 0 : for (s = ss; s; s = s->parent)
3032 : {
3033 : int n;
3034 0 : for (n = 0; n < s->loop->dimen; n++)
3035 : {
3036 0 : s->loop->from[n] = gfc_index_zero_node;
3037 0 : s->loop->to[n] = gfc_conv_mpz_to_tree (expr->shape[s->dim[n]],
3038 : gfc_index_integer_kind);
3039 0 : s->loop->to[n] = fold_build2_loc (input_location, MINUS_EXPR,
3040 : gfc_array_index_type,
3041 0 : s->loop->to[n],
3042 : gfc_index_one_node);
3043 : }
3044 : }
3045 : }
3046 :
3047 41939 : if (*loop_ubound0 == NULL_TREE)
3048 : {
3049 874 : mpz_t size;
3050 :
3051 : /* We should have a 1-dimensional, zero-based loop. */
3052 874 : gcc_assert (loop->parent == NULL && loop->nested == NULL);
3053 874 : gcc_assert (loop->dimen == 1);
3054 874 : gcc_assert (integer_zerop (loop->from[0]));
3055 :
3056 : /* Split the constructor size into a static part and a dynamic part.
3057 : Allocate the static size up-front and record whether the dynamic
3058 : size might be nonzero. */
3059 874 : mpz_init (size);
3060 874 : dynamic = gfc_get_array_constructor_size (&size, c);
3061 874 : mpz_sub_ui (size, size, 1);
3062 874 : loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
3063 874 : mpz_clear (size);
3064 : }
3065 :
3066 : /* Special case constant array constructors. */
3067 874 : if (!dynamic)
3068 : {
3069 41090 : unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
3070 41090 : if (nelem > 0)
3071 : {
3072 35356 : tree size = constant_array_constructor_loop_size (loop);
3073 35356 : if (size && compare_tree_int (size, nelem) == 0)
3074 : {
3075 35350 : trans_constant_array_constructor (ss, type);
3076 35350 : goto finish;
3077 : }
3078 : }
3079 : }
3080 :
3081 6589 : gfc_trans_create_temp_array (&outer_loop->pre, &outer_loop->post, ss, type,
3082 : NULL_TREE, dynamic, true, false, where);
3083 :
3084 6589 : desc = ss_info->data.array.descriptor;
3085 6589 : offset = gfc_index_zero_node;
3086 6589 : offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
3087 6589 : suppress_warning (offsetvar);
3088 6589 : TREE_USED (offsetvar) = 0;
3089 :
3090 6589 : gfc_init_block (&finalblock);
3091 6589 : finalize_required = expr->must_finalize;
3092 6589 : if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
3093 : finalize_required = true;
3094 :
3095 6589 : if (IS_PDT (expr))
3096 : finalize_required = true;
3097 :
3098 7037 : gfc_trans_array_constructor_value (&outer_loop->pre,
3099 : finalize_required ? &finalblock : NULL,
3100 : type, desc, c, &offset, &offsetvar,
3101 : dynamic);
3102 :
3103 : /* If the array grows dynamically, the upper bound of the loop variable
3104 : is determined by the array's final upper bound. */
3105 6589 : if (dynamic)
3106 : {
3107 849 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
3108 : gfc_array_index_type,
3109 : offsetvar, gfc_index_one_node);
3110 849 : tmp = gfc_evaluate_now (tmp, &outer_loop->pre);
3111 849 : if (*loop_ubound0 && VAR_P (*loop_ubound0))
3112 0 : gfc_add_modify (&outer_loop->pre, *loop_ubound0, tmp);
3113 : else
3114 849 : *loop_ubound0 = tmp;
3115 : }
3116 :
3117 6589 : if (TREE_USED (offsetvar))
3118 2046 : pushdecl (offsetvar);
3119 : else
3120 4543 : gcc_assert (INTEGER_CST_P (offset));
3121 :
3122 : #if 0
3123 : /* Disable bound checking for now because it's probably broken. */
3124 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3125 : {
3126 : gcc_unreachable ();
3127 : }
3128 : #endif
3129 :
3130 4543 : finish:
3131 : /* Restore old values of globals. */
3132 41939 : first_len = old_first_len;
3133 41939 : first_len_val = old_first_len_val;
3134 41939 : typespec_chararray_ctor = old_typespec_chararray_ctor;
3135 :
3136 : /* F2008 4.5.6.3 para 5: If an executable construct references a structure
3137 : constructor or array constructor, the entity created by the constructor is
3138 : finalized after execution of the innermost executable construct containing
3139 : the reference. */
3140 41939 : if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
3141 1652 : && finalblock.head != NULL_TREE)
3142 84 : gfc_prepend_expr_to_block (&loop->post, finalblock.head);
3143 41939 : }
3144 :
3145 :
3146 : /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
3147 : called after evaluating all of INFO's vector dimensions. Go through
3148 : each such vector dimension and see if we can now fill in any missing
3149 : loop bounds. */
3150 :
3151 : static void
3152 178036 : set_vector_loop_bounds (gfc_ss * ss)
3153 : {
3154 178036 : gfc_loopinfo *loop, *outer_loop;
3155 178036 : gfc_array_info *info;
3156 178036 : gfc_se se;
3157 178036 : tree tmp;
3158 178036 : tree desc;
3159 178036 : tree zero;
3160 178036 : int n;
3161 178036 : int dim;
3162 :
3163 178036 : outer_loop = outermost_loop (ss->loop);
3164 :
3165 178036 : info = &ss->info->data.array;
3166 :
3167 360708 : for (; ss; ss = ss->parent)
3168 : {
3169 182672 : loop = ss->loop;
3170 :
3171 436346 : for (n = 0; n < loop->dimen; n++)
3172 : {
3173 253674 : dim = ss->dim[n];
3174 253674 : if (info->ref->u.ar.dimen_type[dim] != DIMEN_VECTOR
3175 758 : || loop->to[n] != NULL)
3176 253506 : continue;
3177 :
3178 : /* Loop variable N indexes vector dimension DIM, and we don't
3179 : yet know the upper bound of loop variable N. Set it to the
3180 : difference between the vector's upper and lower bounds. */
3181 168 : gcc_assert (loop->from[n] == gfc_index_zero_node);
3182 168 : gcc_assert (info->subscript[dim]
3183 : && info->subscript[dim]->info->type == GFC_SS_VECTOR);
3184 :
3185 168 : gfc_init_se (&se, NULL);
3186 168 : desc = info->subscript[dim]->info->data.array.descriptor;
3187 168 : zero = gfc_rank_cst[0];
3188 168 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
3189 : gfc_array_index_type,
3190 : gfc_conv_descriptor_ubound_get (desc, zero),
3191 : gfc_conv_descriptor_lbound_get (desc, zero));
3192 168 : tmp = gfc_evaluate_now (tmp, &outer_loop->pre);
3193 168 : loop->to[n] = tmp;
3194 : }
3195 : }
3196 178036 : }
3197 :
3198 :
3199 : /* Tells whether a scalar argument to an elemental procedure is saved out
3200 : of a scalarization loop as a value or as a reference. */
3201 :
3202 : bool
3203 44963 : gfc_scalar_elemental_arg_saved_as_reference (gfc_ss_info * ss_info)
3204 : {
3205 44963 : if (ss_info->type != GFC_SS_REFERENCE)
3206 : return false;
3207 :
3208 10246 : if (ss_info->data.scalar.needs_temporary)
3209 : return false;
3210 :
3211 : /* If the actual argument can be absent (in other words, it can
3212 : be a NULL reference), don't try to evaluate it; pass instead
3213 : the reference directly. */
3214 9882 : if (ss_info->can_be_null_ref)
3215 : return true;
3216 :
3217 : /* If the expression is of polymorphic type, it's actual size is not known,
3218 : so we avoid copying it anywhere. */
3219 9206 : if (ss_info->data.scalar.dummy_arg
3220 1402 : && gfc_dummy_arg_get_typespec (*ss_info->data.scalar.dummy_arg).type
3221 : == BT_CLASS
3222 9330 : && ss_info->expr->ts.type == BT_CLASS)
3223 : return true;
3224 :
3225 : /* If the expression is a data reference of aggregate type,
3226 : and the data reference is not used on the left hand side,
3227 : avoid a copy by saving a reference to the content. */
3228 9182 : if (!ss_info->data.scalar.needs_temporary
3229 9182 : && (ss_info->expr->ts.type == BT_DERIVED
3230 8230 : || ss_info->expr->ts.type == BT_CLASS)
3231 10182 : && gfc_expr_is_variable (ss_info->expr))
3232 : return true;
3233 :
3234 : /* Otherwise the expression is evaluated to a temporary variable before the
3235 : scalarization loop. */
3236 : return false;
3237 : }
3238 :
3239 :
3240 : /* Add the pre and post chains for all the scalar expressions in a SS chain
3241 : to loop. This is called after the loop parameters have been calculated,
3242 : but before the actual scalarizing loops. */
3243 :
3244 : static void
3245 187257 : gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
3246 : locus * where)
3247 : {
3248 187257 : gfc_loopinfo *nested_loop, *outer_loop;
3249 187257 : gfc_se se;
3250 187257 : gfc_ss_info *ss_info;
3251 187257 : gfc_array_info *info;
3252 187257 : gfc_expr *expr;
3253 187257 : int n;
3254 :
3255 : /* Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise,
3256 : arguments could get evaluated multiple times. */
3257 187257 : if (ss->is_alloc_lhs)
3258 167 : return;
3259 :
3260 493302 : outer_loop = outermost_loop (loop);
3261 :
3262 : /* TODO: This can generate bad code if there are ordering dependencies,
3263 : e.g., a callee allocated function and an unknown size constructor. */
3264 : gcc_assert (ss != NULL);
3265 :
3266 493302 : for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
3267 : {
3268 306212 : gcc_assert (ss);
3269 :
3270 : /* Cross loop arrays are handled from within the most nested loop. */
3271 306212 : if (ss->nested_ss != NULL)
3272 4740 : continue;
3273 :
3274 301472 : ss_info = ss->info;
3275 301472 : expr = ss_info->expr;
3276 301472 : info = &ss_info->data.array;
3277 :
3278 301472 : switch (ss_info->type)
3279 : {
3280 42737 : case GFC_SS_SCALAR:
3281 : /* Scalar expression. Evaluate this now. This includes elemental
3282 : dimension indices, but not array section bounds. */
3283 42737 : gfc_init_se (&se, NULL);
3284 42737 : gfc_conv_expr (&se, expr);
3285 42737 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3286 :
3287 42737 : if (expr->ts.type != BT_CHARACTER
3288 42737 : && !gfc_is_alloc_class_scalar_function (expr))
3289 : {
3290 : /* Move the evaluation of scalar expressions outside the
3291 : scalarization loop, except for WHERE assignments. */
3292 38744 : if (subscript)
3293 6349 : se.expr = convert(gfc_array_index_type, se.expr);
3294 38744 : if (!ss_info->where)
3295 38330 : se.expr = gfc_evaluate_now (se.expr, &outer_loop->pre);
3296 38744 : gfc_add_block_to_block (&outer_loop->pre, &se.post);
3297 : }
3298 : else
3299 3993 : gfc_add_block_to_block (&outer_loop->post, &se.post);
3300 :
3301 42737 : ss_info->data.scalar.value = se.expr;
3302 42737 : ss_info->string_length = se.string_length;
3303 42737 : break;
3304 :
3305 5123 : case GFC_SS_REFERENCE:
3306 : /* Scalar argument to elemental procedure. */
3307 5123 : gfc_init_se (&se, NULL);
3308 5123 : if (gfc_scalar_elemental_arg_saved_as_reference (ss_info))
3309 826 : gfc_conv_expr_reference (&se, expr);
3310 : else
3311 : {
3312 : /* Evaluate the argument outside the loop and pass
3313 : a reference to the value. */
3314 4297 : gfc_conv_expr (&se, expr);
3315 : }
3316 :
3317 : /* Ensure that a pointer to the string is stored. */
3318 5123 : if (expr->ts.type == BT_CHARACTER)
3319 174 : gfc_conv_string_parameter (&se);
3320 :
3321 5123 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3322 5123 : gfc_add_block_to_block (&outer_loop->post, &se.post);
3323 5123 : if (gfc_is_class_scalar_expr (expr))
3324 : /* This is necessary because the dynamic type will always be
3325 : large than the declared type. In consequence, assigning
3326 : the value to a temporary could segfault.
3327 : OOP-TODO: see if this is generally correct or is the value
3328 : has to be written to an allocated temporary, whose address
3329 : is passed via ss_info. */
3330 48 : ss_info->data.scalar.value = se.expr;
3331 : else
3332 5075 : ss_info->data.scalar.value = gfc_evaluate_now (se.expr,
3333 : &outer_loop->pre);
3334 :
3335 5123 : ss_info->string_length = se.string_length;
3336 5123 : break;
3337 :
3338 : case GFC_SS_SECTION:
3339 : /* Add the expressions for scalar and vector subscripts. */
3340 2848576 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
3341 2670540 : if (info->subscript[n])
3342 7107 : gfc_add_loop_ss_code (loop, info->subscript[n], true, where);
3343 :
3344 178036 : set_vector_loop_bounds (ss);
3345 178036 : break;
3346 :
3347 758 : case GFC_SS_VECTOR:
3348 : /* Get the vector's descriptor and store it in SS. */
3349 758 : gfc_init_se (&se, NULL);
3350 758 : gfc_conv_expr_descriptor (&se, expr);
3351 758 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3352 758 : gfc_add_block_to_block (&outer_loop->post, &se.post);
3353 758 : info->descriptor = se.expr;
3354 758 : break;
3355 :
3356 11419 : case GFC_SS_INTRINSIC:
3357 11419 : gfc_add_intrinsic_ss_code (loop, ss);
3358 11419 : break;
3359 :
3360 9442 : case GFC_SS_FUNCTION:
3361 9442 : {
3362 : /* Array function return value. We call the function and save its
3363 : result in a temporary for use inside the loop. */
3364 9442 : gfc_init_se (&se, NULL);
3365 9442 : se.loop = loop;
3366 9442 : se.ss = ss;
3367 9442 : bool class_func = gfc_is_class_array_function (expr);
3368 9442 : if (class_func)
3369 183 : expr->must_finalize = 1;
3370 9442 : gfc_conv_expr (&se, expr);
3371 9442 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3372 9442 : if (class_func
3373 183 : && se.expr
3374 9625 : && GFC_CLASS_TYPE_P (TREE_TYPE (se.expr)))
3375 : {
3376 183 : tree tmp = gfc_class_data_get (se.expr);
3377 183 : info->descriptor = tmp;
3378 183 : info->data = gfc_conv_descriptor_data_get (tmp);
3379 183 : info->offset = gfc_conv_descriptor_offset_get (tmp);
3380 366 : for (gfc_ss *s = ss; s; s = s->parent)
3381 378 : for (int n = 0; n < s->dimen; n++)
3382 : {
3383 195 : int dim = s->dim[n];
3384 195 : tree tree_dim = gfc_rank_cst[dim];
3385 :
3386 195 : tree start;
3387 195 : start = gfc_conv_descriptor_lbound_get (tmp, tree_dim);
3388 195 : start = gfc_evaluate_now (start, &outer_loop->pre);
3389 195 : info->start[dim] = start;
3390 :
3391 195 : tree end;
3392 195 : end = gfc_conv_descriptor_ubound_get (tmp, tree_dim);
3393 195 : end = gfc_evaluate_now (end, &outer_loop->pre);
3394 195 : info->end[dim] = end;
3395 :
3396 195 : tree stride;
3397 195 : stride = gfc_conv_descriptor_stride_get (tmp, tree_dim);
3398 195 : stride = gfc_evaluate_now (stride, &outer_loop->pre);
3399 195 : info->stride[dim] = stride;
3400 : }
3401 : }
3402 9442 : gfc_add_block_to_block (&outer_loop->post, &se.post);
3403 9442 : gfc_add_block_to_block (&outer_loop->post, &se.finalblock);
3404 9442 : ss_info->string_length = se.string_length;
3405 : }
3406 9442 : break;
3407 :
3408 41939 : case GFC_SS_CONSTRUCTOR:
3409 41939 : if (expr->ts.type == BT_CHARACTER
3410 8142 : && ss_info->string_length == NULL
3411 8142 : && expr->ts.u.cl
3412 8142 : && expr->ts.u.cl->length
3413 7798 : && expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
3414 : {
3415 7747 : gfc_init_se (&se, NULL);
3416 7747 : gfc_conv_expr_type (&se, expr->ts.u.cl->length,
3417 : gfc_charlen_type_node);
3418 7747 : ss_info->string_length = se.expr;
3419 7747 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3420 7747 : gfc_add_block_to_block (&outer_loop->post, &se.post);
3421 : }
3422 41939 : trans_array_constructor (ss, where);
3423 41939 : break;
3424 :
3425 : case GFC_SS_TEMP:
3426 : case GFC_SS_COMPONENT:
3427 : /* Do nothing. These are handled elsewhere. */
3428 : break;
3429 :
3430 0 : default:
3431 0 : gcc_unreachable ();
3432 : }
3433 : }
3434 :
3435 187090 : if (!subscript)
3436 183347 : for (nested_loop = loop->nested; nested_loop;
3437 3364 : nested_loop = nested_loop->next)
3438 3364 : gfc_add_loop_ss_code (nested_loop, nested_loop->ss, subscript, where);
3439 : }
3440 :
3441 :
3442 : /* Given an array descriptor expression DESCR and its data pointer DATA, decide
3443 : whether to either save the data pointer to a variable and use the variable or
3444 : use the data pointer expression directly without any intermediary variable.
3445 : */
3446 :
3447 : static bool
3448 126221 : save_descriptor_data (tree descr, tree data)
3449 : {
3450 126221 : return !(DECL_P (data)
3451 115561 : || (TREE_CODE (data) == ADDR_EXPR
3452 68295 : && DECL_P (TREE_OPERAND (data, 0)))
3453 50311 : || (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (descr))
3454 46922 : && TREE_CODE (descr) == COMPONENT_REF
3455 10519 : && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (descr, 0)))));
3456 : }
3457 :
3458 :
3459 : /* Type of the DATA argument passed to walk_tree by substitute_subexpr_in_expr
3460 : and used by maybe_substitute_expr. */
3461 :
3462 : typedef struct
3463 : {
3464 : tree target, repl;
3465 : }
3466 : substitute_t;
3467 :
3468 :
3469 : /* Check if the expression in *TP is equal to the substitution target provided
3470 : in DATA->TARGET and replace it with DATA->REPL in that case. This is a
3471 : callback function for use with walk_tree. */
3472 :
3473 : static tree
3474 20885 : maybe_substitute_expr (tree *tp, int *walk_subtree, void *data)
3475 : {
3476 20885 : substitute_t *subst = (substitute_t *) data;
3477 20885 : if (*tp == subst->target)
3478 : {
3479 3972 : *tp = subst->repl;
3480 3972 : *walk_subtree = 0;
3481 : }
3482 :
3483 20885 : return NULL_TREE;
3484 : }
3485 :
3486 :
3487 : /* Substitute in EXPR any occurence of TARGET with REPLACEMENT. */
3488 :
3489 : static void
3490 3665 : substitute_subexpr_in_expr (tree target, tree replacement, tree expr)
3491 : {
3492 3665 : substitute_t subst;
3493 3665 : subst.target = target;
3494 3665 : subst.repl = replacement;
3495 :
3496 3665 : walk_tree (&expr, maybe_substitute_expr, &subst, nullptr);
3497 3665 : }
3498 :
3499 :
3500 : /* Save REF to a fresh variable in all of REPLACEMENT_ROOTS, appending extra
3501 : code to CODE. Before returning, add REF to REPLACEMENT_ROOTS and clear
3502 : REF. */
3503 :
3504 : static void
3505 3493 : save_ref (tree &code, tree &ref, vec<tree> &replacement_roots)
3506 : {
3507 3493 : stmtblock_t tmp_block;
3508 3493 : gfc_init_block (&tmp_block);
3509 3493 : tree var = gfc_evaluate_now (ref, &tmp_block);
3510 3493 : gfc_add_expr_to_block (&tmp_block, code);
3511 3493 : code = gfc_finish_block (&tmp_block);
3512 :
3513 3493 : unsigned i;
3514 3493 : tree repl_root;
3515 7158 : FOR_EACH_VEC_ELT (replacement_roots, i, repl_root)
3516 3665 : substitute_subexpr_in_expr (ref, var, repl_root);
3517 :
3518 3493 : replacement_roots.safe_push (ref);
3519 3493 : ref = NULL_TREE;
3520 3493 : }
3521 :
3522 :
3523 : /* Save the descriptor reference VALUE to storage pointed by DESC_PTR. Before
3524 : that, try to factor subexpressions of VALUE to variables, adding extra code
3525 : to BLOCK.
3526 :
3527 : The candidate references to factoring are dereferenced pointers because they
3528 : are cheap to copy and array descriptors because they are often the base of
3529 : multiple subreferences. */
3530 :
3531 : static void
3532 319594 : set_factored_descriptor_value (tree *desc_ptr, tree value, stmtblock_t *block)
3533 : {
3534 : /* As the reference is processed from outer to inner, variable definitions
3535 : will be generated in reversed order, so can't be put directly in BLOCK.
3536 : We use TMP_BLOCK instead. */
3537 319594 : tree accumulated_code = NULL_TREE;
3538 :
3539 : /* The current candidate to factoring. */
3540 319594 : tree saveable_ref = NULL_TREE;
3541 :
3542 : /* The root expressions in which we look for subexpressions to replace with
3543 : variables. */
3544 319594 : auto_vec<tree> replacement_roots;
3545 319594 : replacement_roots.safe_push (value);
3546 :
3547 319594 : tree data_ref = value;
3548 319594 : tree next_ref = NULL_TREE;
3549 :
3550 : /* If the candidate reference is not followed by a subreference, it can't be
3551 : saved to a variable as it may be reallocatable, and we have to keep the
3552 : parent reference to be able to store the new pointer value in case of
3553 : reallocation. */
3554 319594 : bool maybe_reallocatable = true;
3555 :
3556 423718 : while (true)
3557 : {
3558 423718 : if (!maybe_reallocatable
3559 423718 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (data_ref)))
3560 2323 : saveable_ref = data_ref;
3561 :
3562 423718 : if (TREE_CODE (data_ref) == INDIRECT_REF)
3563 : {
3564 56179 : next_ref = TREE_OPERAND (data_ref, 0);
3565 :
3566 56179 : if (!maybe_reallocatable)
3567 : {
3568 14107 : if (saveable_ref != NULL_TREE && saveable_ref != data_ref)
3569 : {
3570 : /* A reference worth saving has been seen, and now the pointer
3571 : to the current reference is also worth saving. If the
3572 : previous reference to save wasn't the current one, do save
3573 : it now. Otherwise drop it as we prefer saving the
3574 : pointer. */
3575 1689 : save_ref (accumulated_code, saveable_ref, replacement_roots);
3576 : }
3577 :
3578 : /* Don't evaluate the pointer to a variable yet; do it only if the
3579 : variable would be significantly more simple than the reference
3580 : it replaces. That is if the reference contains anything
3581 : different from NOPs, COMPONENTs and DECLs. */
3582 14107 : saveable_ref = next_ref;
3583 : }
3584 : }
3585 367539 : else if (TREE_CODE (data_ref) == COMPONENT_REF)
3586 : {
3587 39145 : maybe_reallocatable = false;
3588 39145 : next_ref = TREE_OPERAND (data_ref, 0);
3589 : }
3590 328394 : else if (TREE_CODE (data_ref) == NOP_EXPR)
3591 3564 : next_ref = TREE_OPERAND (data_ref, 0);
3592 : else
3593 : {
3594 324830 : if (DECL_P (data_ref))
3595 : break;
3596 :
3597 6766 : if (TREE_CODE (data_ref) == ARRAY_REF)
3598 : {
3599 5236 : maybe_reallocatable = false;
3600 5236 : next_ref = TREE_OPERAND (data_ref, 0);
3601 : }
3602 :
3603 6766 : if (saveable_ref != NULL_TREE)
3604 : /* We have seen a reference worth saving. Do it now. */
3605 1804 : save_ref (accumulated_code, saveable_ref, replacement_roots);
3606 :
3607 6766 : if (TREE_CODE (data_ref) != ARRAY_REF)
3608 : break;
3609 : }
3610 :
3611 : data_ref = next_ref;
3612 : }
3613 :
3614 319594 : *desc_ptr = value;
3615 319594 : gfc_add_expr_to_block (block, accumulated_code);
3616 319594 : }
3617 :
3618 :
3619 : /* Translate expressions for the descriptor and data pointer of a SS. */
3620 : /*GCC ARRAYS*/
3621 :
3622 : static void
3623 319594 : gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
3624 : {
3625 319594 : gfc_se se;
3626 319594 : gfc_ss_info *ss_info;
3627 319594 : gfc_array_info *info;
3628 319594 : tree tmp;
3629 :
3630 319594 : ss_info = ss->info;
3631 319594 : info = &ss_info->data.array;
3632 :
3633 : /* Get the descriptor for the array to be scalarized. */
3634 319594 : gcc_assert (ss_info->expr->expr_type == EXPR_VARIABLE);
3635 319594 : gfc_init_se (&se, NULL);
3636 319594 : se.descriptor_only = 1;
3637 319594 : gfc_conv_expr_lhs (&se, ss_info->expr);
3638 319594 : gfc_add_block_to_block (block, &se.pre);
3639 319594 : set_factored_descriptor_value (&info->descriptor, se.expr, block);
3640 319594 : ss_info->string_length = se.string_length;
3641 319594 : ss_info->class_container = se.class_container;
3642 :
3643 319594 : if (base)
3644 : {
3645 119861 : if (ss_info->expr->ts.type == BT_CHARACTER && !ss_info->expr->ts.deferred
3646 22732 : && ss_info->expr->ts.u.cl->length == NULL)
3647 : {
3648 : /* Emit a DECL_EXPR for the variable sized array type in
3649 : GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
3650 : sizes works correctly. */
3651 1097 : tree arraytype = TREE_TYPE (
3652 : GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (info->descriptor)));
3653 1097 : if (! TYPE_NAME (arraytype))
3654 899 : TYPE_NAME (arraytype) = build_decl (UNKNOWN_LOCATION, TYPE_DECL,
3655 : NULL_TREE, arraytype);
3656 1097 : gfc_add_expr_to_block (block, build1 (DECL_EXPR, arraytype,
3657 1097 : TYPE_NAME (arraytype)));
3658 : }
3659 : /* Also the data pointer. */
3660 119861 : tmp = gfc_conv_array_data (se.expr);
3661 : /* If this is a variable or address or a class array, use it directly.
3662 : Otherwise we must evaluate it now to avoid breaking dependency
3663 : analysis by pulling the expressions for elemental array indices
3664 : inside the loop. */
3665 119861 : if (save_descriptor_data (se.expr, tmp) && !ss->is_alloc_lhs)
3666 35603 : tmp = gfc_evaluate_now (tmp, block);
3667 119861 : info->data = tmp;
3668 :
3669 119861 : tmp = gfc_conv_array_offset (se.expr);
3670 119861 : if (!ss->is_alloc_lhs)
3671 113668 : tmp = gfc_evaluate_now (tmp, block);
3672 119861 : info->offset = tmp;
3673 :
3674 : /* Make absolutely sure that the saved_offset is indeed saved
3675 : so that the variable is still accessible after the loops
3676 : are translated. */
3677 119861 : info->saved_offset = info->offset;
3678 : }
3679 319594 : }
3680 :
3681 :
3682 : /* Initialize a gfc_loopinfo structure. */
3683 :
3684 : void
3685 186126 : gfc_init_loopinfo (gfc_loopinfo * loop)
3686 : {
3687 186126 : int n;
3688 :
3689 186126 : memset (loop, 0, sizeof (gfc_loopinfo));
3690 186126 : gfc_init_block (&loop->pre);
3691 186126 : gfc_init_block (&loop->post);
3692 :
3693 : /* Initially scalarize in order and default to no loop reversal. */
3694 3164142 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
3695 : {
3696 2791890 : loop->order[n] = n;
3697 2791890 : loop->reverse[n] = GFC_INHIBIT_REVERSE;
3698 : }
3699 :
3700 186126 : loop->ss = gfc_ss_terminator;
3701 186126 : }
3702 :
3703 :
3704 : /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
3705 : chain. */
3706 :
3707 : void
3708 186248 : gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
3709 : {
3710 186248 : se->loop = loop;
3711 186248 : }
3712 :
3713 :
3714 : /* Return an expression for the data pointer of an array. */
3715 :
3716 : tree
3717 326792 : gfc_conv_array_data (tree descriptor)
3718 : {
3719 326792 : tree type;
3720 :
3721 326792 : type = TREE_TYPE (descriptor);
3722 326792 : if (GFC_ARRAY_TYPE_P (type))
3723 : {
3724 229723 : if (TREE_CODE (type) == POINTER_TYPE)
3725 : return descriptor;
3726 : else
3727 : {
3728 : /* Descriptorless arrays. */
3729 172913 : return gfc_build_addr_expr (NULL_TREE, descriptor);
3730 : }
3731 : }
3732 : else
3733 97069 : return gfc_conv_descriptor_data_get (descriptor);
3734 : }
3735 :
3736 :
3737 : /* Return an expression for the base offset of an array. */
3738 :
3739 : tree
3740 243138 : gfc_conv_array_offset (tree descriptor)
3741 : {
3742 243138 : tree type;
3743 :
3744 243138 : type = TREE_TYPE (descriptor);
3745 243138 : if (GFC_ARRAY_TYPE_P (type))
3746 173362 : return GFC_TYPE_ARRAY_OFFSET (type);
3747 : else
3748 69776 : return gfc_conv_descriptor_offset_get (descriptor);
3749 : }
3750 :
3751 :
3752 : /* Get an expression for the array stride. */
3753 :
3754 : tree
3755 487237 : gfc_conv_array_stride (tree descriptor, int dim)
3756 : {
3757 487237 : tree tmp;
3758 487237 : tree type;
3759 :
3760 487237 : type = TREE_TYPE (descriptor);
3761 :
3762 : /* For descriptorless arrays use the array size. */
3763 487237 : tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
3764 487237 : if (tmp != NULL_TREE)
3765 : return tmp;
3766 :
3767 111847 : tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]);
3768 111847 : return tmp;
3769 : }
3770 :
3771 :
3772 : /* Like gfc_conv_array_stride, but for the lower bound. */
3773 :
3774 : tree
3775 314927 : gfc_conv_array_lbound (tree descriptor, int dim)
3776 : {
3777 314927 : tree tmp;
3778 314927 : tree type;
3779 :
3780 314927 : type = TREE_TYPE (descriptor);
3781 :
3782 314927 : tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
3783 314927 : if (tmp != NULL_TREE)
3784 : return tmp;
3785 :
3786 18441 : tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]);
3787 18441 : return tmp;
3788 : }
3789 :
3790 :
3791 : /* Like gfc_conv_array_stride, but for the upper bound. */
3792 :
3793 : tree
3794 203881 : gfc_conv_array_ubound (tree descriptor, int dim)
3795 : {
3796 203881 : tree tmp;
3797 203881 : tree type;
3798 :
3799 203881 : type = TREE_TYPE (descriptor);
3800 :
3801 203881 : tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
3802 203881 : if (tmp != NULL_TREE)
3803 : return tmp;
3804 :
3805 : /* This should only ever happen when passing an assumed shape array
3806 : as an actual parameter. The value will never be used. */
3807 7912 : if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
3808 554 : return gfc_index_zero_node;
3809 :
3810 7358 : tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]);
3811 7358 : return tmp;
3812 : }
3813 :
3814 :
3815 : /* Generate abridged name of a part-ref for use in bounds-check message.
3816 : Cases:
3817 : (1) for an ordinary array variable x return "x"
3818 : (2) for z a DT scalar and array component x (at level 1) return "z%%x"
3819 : (3) for z a DT scalar and array component x (at level > 1) or
3820 : for z a DT array and array x (at any number of levels): "z...%%x"
3821 : */
3822 :
3823 : static char *
3824 36147 : abridged_ref_name (gfc_expr * expr, gfc_array_ref * ar)
3825 : {
3826 36147 : gfc_ref *ref;
3827 36147 : gfc_symbol *sym;
3828 36147 : char *ref_name = NULL;
3829 36147 : const char *comp_name = NULL;
3830 36147 : int len_sym, last_len = 0, level = 0;
3831 36147 : bool sym_is_array;
3832 :
3833 36147 : gcc_assert (expr->expr_type == EXPR_VARIABLE && expr->ref != NULL);
3834 :
3835 36147 : sym = expr->symtree->n.sym;
3836 72027 : sym_is_array = (sym->ts.type != BT_CLASS
3837 36147 : ? sym->as != NULL
3838 267 : : IS_CLASS_ARRAY (sym));
3839 36147 : len_sym = strlen (sym->name);
3840 :
3841 : /* Scan ref chain to get name of the array component (when ar != NULL) or
3842 : array section, determine depth and remember its component name. */
3843 51289 : for (ref = expr->ref; ref; ref = ref->next)
3844 : {
3845 37272 : if (ref->type == REF_COMPONENT
3846 808 : && strcmp (ref->u.c.component->name, "_data") != 0)
3847 : {
3848 678 : level++;
3849 678 : comp_name = ref->u.c.component->name;
3850 678 : continue;
3851 : }
3852 :
3853 36594 : if (ref->type != REF_ARRAY)
3854 150 : continue;
3855 :
3856 36444 : if (ar)
3857 : {
3858 15555 : if (&ref->u.ar == ar)
3859 : break;
3860 : }
3861 20889 : else if (ref->u.ar.type == AR_SECTION)
3862 : break;
3863 : }
3864 :
3865 36147 : if (level > 0)
3866 644 : last_len = strlen (comp_name);
3867 :
3868 : /* Provide a buffer sufficiently large to hold "x...%%z". */
3869 36147 : ref_name = XNEWVEC (char, len_sym + last_len + 6);
3870 36147 : strcpy (ref_name, sym->name);
3871 :
3872 36147 : if (level == 1 && !sym_is_array)
3873 : {
3874 352 : strcat (ref_name, "%%");
3875 352 : strcat (ref_name, comp_name);
3876 : }
3877 35795 : else if (level > 0)
3878 : {
3879 292 : strcat (ref_name, "...%%");
3880 292 : strcat (ref_name, comp_name);
3881 : }
3882 :
3883 36147 : return ref_name;
3884 : }
3885 :
3886 :
3887 : /* Generate code to perform an array index bound check. */
3888 :
3889 : static tree
3890 5405 : trans_array_bound_check (gfc_se * se, gfc_ss *ss, tree index, int n,
3891 : locus * where, bool check_upper,
3892 : const char *compname = NULL)
3893 : {
3894 5405 : tree fault;
3895 5405 : tree tmp_lo, tmp_up;
3896 5405 : tree descriptor;
3897 5405 : char *msg;
3898 5405 : char *ref_name = NULL;
3899 5405 : const char * name = NULL;
3900 5405 : gfc_expr *expr;
3901 :
3902 5405 : if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
3903 : return index;
3904 :
3905 234 : descriptor = ss->info->data.array.descriptor;
3906 :
3907 234 : index = gfc_evaluate_now (index, &se->pre);
3908 :
3909 : /* We find a name for the error message. */
3910 234 : name = ss->info->expr->symtree->n.sym->name;
3911 234 : gcc_assert (name != NULL);
3912 :
3913 : /* When we have a component ref, get name of the array section.
3914 : Note that there can only be one part ref. */
3915 234 : expr = ss->info->expr;
3916 234 : if (expr->ref && !compname)
3917 160 : name = ref_name = abridged_ref_name (expr, NULL);
3918 :
3919 234 : if (VAR_P (descriptor))
3920 156 : name = IDENTIFIER_POINTER (DECL_NAME (descriptor));
3921 :
3922 : /* Use given (array component) name. */
3923 234 : if (compname)
3924 74 : name = compname;
3925 :
3926 : /* If upper bound is present, include both bounds in the error message. */
3927 234 : if (check_upper)
3928 : {
3929 207 : tmp_lo = gfc_conv_array_lbound (descriptor, n);
3930 207 : tmp_up = gfc_conv_array_ubound (descriptor, n);
3931 :
3932 207 : if (name)
3933 207 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3934 : "outside of expected range (%%ld:%%ld)", n+1, name);
3935 : else
3936 0 : msg = xasprintf ("Index '%%ld' of dimension %d "
3937 : "outside of expected range (%%ld:%%ld)", n+1);
3938 :
3939 207 : fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3940 : index, tmp_lo);
3941 207 : gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
3942 : fold_convert (long_integer_type_node, index),
3943 : fold_convert (long_integer_type_node, tmp_lo),
3944 : fold_convert (long_integer_type_node, tmp_up));
3945 207 : fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3946 : index, tmp_up);
3947 207 : gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
3948 : fold_convert (long_integer_type_node, index),
3949 : fold_convert (long_integer_type_node, tmp_lo),
3950 : fold_convert (long_integer_type_node, tmp_up));
3951 207 : free (msg);
3952 : }
3953 : else
3954 : {
3955 27 : tmp_lo = gfc_conv_array_lbound (descriptor, n);
3956 :
3957 27 : if (name)
3958 27 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3959 : "below lower bound of %%ld", n+1, name);
3960 : else
3961 0 : msg = xasprintf ("Index '%%ld' of dimension %d "
3962 : "below lower bound of %%ld", n+1);
3963 :
3964 27 : fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3965 : index, tmp_lo);
3966 27 : gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
3967 : fold_convert (long_integer_type_node, index),
3968 : fold_convert (long_integer_type_node, tmp_lo));
3969 27 : free (msg);
3970 : }
3971 :
3972 234 : free (ref_name);
3973 234 : return index;
3974 : }
3975 :
3976 :
3977 : /* Generate code for bounds checking for elemental dimensions. */
3978 :
3979 : static void
3980 6668 : array_bound_check_elemental (gfc_se * se, gfc_ss * ss, gfc_expr * expr)
3981 : {
3982 6668 : gfc_array_ref *ar;
3983 6668 : gfc_ref *ref;
3984 6668 : char *var_name = NULL;
3985 6668 : int dim;
3986 :
3987 6668 : if (expr->expr_type == EXPR_VARIABLE)
3988 : {
3989 12469 : for (ref = expr->ref; ref; ref = ref->next)
3990 : {
3991 6259 : if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
3992 : {
3993 3935 : ar = &ref->u.ar;
3994 3935 : var_name = abridged_ref_name (expr, ar);
3995 8104 : for (dim = 0; dim < ar->dimen; dim++)
3996 : {
3997 4169 : if (ar->dimen_type[dim] == DIMEN_ELEMENT)
3998 : {
3999 74 : gfc_se indexse;
4000 74 : gfc_init_se (&indexse, NULL);
4001 74 : gfc_conv_expr_type (&indexse, ar->start[dim],
4002 : gfc_array_index_type);
4003 74 : trans_array_bound_check (se, ss, indexse.expr, dim,
4004 : &ar->where,
4005 74 : ar->as->type != AS_ASSUMED_SIZE
4006 74 : || dim < ar->dimen - 1,
4007 : var_name);
4008 : }
4009 : }
4010 3935 : free (var_name);
4011 : }
4012 : }
4013 : }
4014 6668 : }
4015 :
4016 :
4017 : /* Return the offset for an index. Performs bound checking for elemental
4018 : dimensions. Single element references are processed separately.
4019 : DIM is the array dimension, I is the loop dimension. */
4020 :
4021 : static tree
4022 249137 : conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i,
4023 : gfc_array_ref * ar, tree stride)
4024 : {
4025 249137 : gfc_array_info *info;
4026 249137 : tree index;
4027 249137 : tree desc;
4028 249137 : tree data;
4029 :
4030 249137 : info = &ss->info->data.array;
4031 :
4032 : /* Get the index into the array for this dimension. */
4033 249137 : if (ar)
4034 : {
4035 177145 : gcc_assert (ar->type != AR_ELEMENT);
4036 177145 : switch (ar->dimen_type[dim])
4037 : {
4038 0 : case DIMEN_THIS_IMAGE:
4039 0 : gcc_unreachable ();
4040 4576 : break;
4041 4576 : case DIMEN_ELEMENT:
4042 : /* Elemental dimension. */
4043 4576 : gcc_assert (info->subscript[dim]
4044 : && info->subscript[dim]->info->type == GFC_SS_SCALAR);
4045 : /* We've already translated this value outside the loop. */
4046 4576 : index = info->subscript[dim]->info->data.scalar.value;
4047 :
4048 9152 : index = trans_array_bound_check (se, ss, index, dim, &ar->where,
4049 4576 : ar->as->type != AS_ASSUMED_SIZE
4050 4576 : || dim < ar->dimen - 1);
4051 4576 : break;
4052 :
4053 755 : case DIMEN_VECTOR:
4054 755 : gcc_assert (info && se->loop);
4055 755 : gcc_assert (info->subscript[dim]
4056 : && info->subscript[dim]->info->type == GFC_SS_VECTOR);
4057 755 : desc = info->subscript[dim]->info->data.array.descriptor;
4058 :
4059 : /* Get a zero-based index into the vector. */
4060 755 : index = fold_build2_loc (input_location, MINUS_EXPR,
4061 : gfc_array_index_type,
4062 : se->loop->loopvar[i], se->loop->from[i]);
4063 :
4064 : /* Multiply the index by the stride. */
4065 755 : index = fold_build2_loc (input_location, MULT_EXPR,
4066 : gfc_array_index_type,
4067 : index, gfc_conv_array_stride (desc, 0));
4068 :
4069 : /* Read the vector to get an index into info->descriptor. */
4070 755 : data = build_fold_indirect_ref_loc (input_location,
4071 : gfc_conv_array_data (desc));
4072 755 : index = gfc_build_array_ref (data, index, NULL);
4073 755 : index = gfc_evaluate_now (index, &se->pre);
4074 755 : index = fold_convert (gfc_array_index_type, index);
4075 :
4076 : /* Do any bounds checking on the final info->descriptor index. */
4077 1510 : index = trans_array_bound_check (se, ss, index, dim, &ar->where,
4078 755 : ar->as->type != AS_ASSUMED_SIZE
4079 755 : || dim < ar->dimen - 1);
4080 755 : break;
4081 :
4082 171814 : case DIMEN_RANGE:
4083 : /* Scalarized dimension. */
4084 171814 : gcc_assert (info && se->loop);
4085 :
4086 : /* Multiply the loop variable by the stride and delta. */
4087 171814 : index = se->loop->loopvar[i];
4088 171814 : if (!integer_onep (info->stride[dim]))
4089 6858 : index = fold_build2_loc (input_location, MULT_EXPR,
4090 : gfc_array_index_type, index,
4091 : info->stride[dim]);
4092 171814 : if (!integer_zerop (info->delta[dim]))
4093 65879 : index = fold_build2_loc (input_location, PLUS_EXPR,
4094 : gfc_array_index_type, index,
4095 : info->delta[dim]);
4096 : break;
4097 :
4098 0 : default:
4099 0 : gcc_unreachable ();
4100 : }
4101 : }
4102 : else
4103 : {
4104 : /* Temporary array or derived type component. */
4105 71992 : gcc_assert (se->loop);
4106 71992 : index = se->loop->loopvar[se->loop->order[i]];
4107 :
4108 : /* Pointer functions can have stride[0] different from unity.
4109 : Use the stride returned by the function call and stored in
4110 : the descriptor for the temporary. */
4111 71992 : if (se->ss && se->ss->info->type == GFC_SS_FUNCTION
4112 8001 : && se->ss->info->expr
4113 8001 : && se->ss->info->expr->symtree
4114 8001 : && se->ss->info->expr->symtree->n.sym->result
4115 7561 : && se->ss->info->expr->symtree->n.sym->result->attr.pointer)
4116 144 : stride = gfc_conv_descriptor_stride_get (info->descriptor,
4117 : gfc_rank_cst[dim]);
4118 :
4119 71992 : if (info->delta[dim] && !integer_zerop (info->delta[dim]))
4120 798 : index = fold_build2_loc (input_location, PLUS_EXPR,
4121 : gfc_array_index_type, index, info->delta[dim]);
4122 : }
4123 :
4124 : /* Multiply by the stride. */
4125 249137 : if (stride != NULL && !integer_onep (stride))
4126 76699 : index = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4127 : index, stride);
4128 :
4129 249137 : return index;
4130 : }
4131 :
4132 :
4133 : /* Build a scalarized array reference using the vptr 'size'. */
4134 :
4135 : static bool
4136 189830 : build_class_array_ref (gfc_se *se, tree base, tree index)
4137 : {
4138 189830 : tree size;
4139 189830 : tree decl = NULL_TREE;
4140 189830 : tree tmp;
4141 189830 : gfc_expr *expr = se->ss->info->expr;
4142 189830 : gfc_expr *class_expr;
4143 189830 : gfc_typespec *ts;
4144 189830 : gfc_symbol *sym;
4145 :
4146 189830 : tmp = !VAR_P (base) ? gfc_get_class_from_expr (base) : NULL_TREE;
4147 :
4148 88660 : if (tmp != NULL_TREE)
4149 : decl = tmp;
4150 : else
4151 : {
4152 : /* The base expression does not contain a class component, either
4153 : because it is a temporary array or array descriptor. Class
4154 : array functions are correctly resolved above. */
4155 186577 : if (!expr
4156 186577 : || (expr->ts.type != BT_CLASS
4157 173285 : && !gfc_is_class_array_ref (expr, NULL)))
4158 186190 : return false;
4159 :
4160 : /* Obtain the expression for the class entity or component that is
4161 : followed by an array reference, which is not an element, so that
4162 : the span of the array can be obtained. */
4163 387 : class_expr = gfc_find_and_cut_at_last_class_ref (expr, false, &ts);
4164 :
4165 387 : if (!ts)
4166 : return false;
4167 :
4168 362 : sym = (!class_expr && expr) ? expr->symtree->n.sym : NULL;
4169 0 : if (sym && sym->attr.function
4170 0 : && sym == sym->result
4171 0 : && sym->backend_decl == current_function_decl)
4172 : /* The temporary is the data field of the class data component
4173 : of the current function. */
4174 0 : decl = gfc_get_fake_result_decl (sym, 0);
4175 362 : else if (sym)
4176 : {
4177 0 : if (decl == NULL_TREE)
4178 0 : decl = expr->symtree->n.sym->backend_decl;
4179 : /* For class arrays the tree containing the class is stored in
4180 : GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl.
4181 : For all others it's sym's backend_decl directly. */
4182 0 : if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl))
4183 0 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
4184 : }
4185 : else
4186 362 : decl = gfc_get_class_from_gfc_expr (class_expr);
4187 :
4188 362 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
4189 0 : decl = build_fold_indirect_ref_loc (input_location, decl);
4190 :
4191 362 : if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl)))
4192 : return false;
4193 : }
4194 :
4195 3615 : se->class_vptr = gfc_evaluate_now (gfc_class_vptr_get (decl), &se->pre);
4196 :
4197 3615 : size = gfc_class_vtab_size_get (decl);
4198 : /* For unlimited polymorphic entities then _len component needs to be
4199 : multiplied with the size. */
4200 3615 : size = gfc_resize_class_size_with_len (&se->pre, decl, size);
4201 3615 : size = fold_convert (TREE_TYPE (index), size);
4202 :
4203 : /* Return the element in the se expression. */
4204 3615 : se->expr = gfc_build_spanned_array_ref (base, index, size);
4205 3615 : return true;
4206 : }
4207 :
4208 :
4209 : /* Indicates that the tree EXPR is a reference to an array that can’t
4210 : have any negative stride. */
4211 :
4212 : static bool
4213 307345 : non_negative_strides_array_p (tree expr)
4214 : {
4215 320076 : if (expr == NULL_TREE)
4216 : return false;
4217 :
4218 320076 : tree type = TREE_TYPE (expr);
4219 320076 : if (POINTER_TYPE_P (type))
4220 69761 : type = TREE_TYPE (type);
4221 :
4222 320076 : if (TYPE_LANG_SPECIFIC (type))
4223 : {
4224 320076 : gfc_array_kind array_kind = GFC_TYPE_ARRAY_AKIND (type);
4225 :
4226 320076 : if (array_kind == GFC_ARRAY_ALLOCATABLE
4227 320076 : || array_kind == GFC_ARRAY_ASSUMED_SHAPE_CONT)
4228 : return true;
4229 : }
4230 :
4231 : /* An array with descriptor can have negative strides.
4232 : We try to be conservative and return false by default here
4233 : if we don’t recognize a contiguous array instead of
4234 : returning false if we can identify a non-contiguous one. */
4235 264127 : if (!GFC_ARRAY_TYPE_P (type))
4236 : return false;
4237 :
4238 : /* If the array was originally a dummy with a descriptor, strides can be
4239 : negative. */
4240 231081 : if (DECL_P (expr)
4241 222300 : && DECL_LANG_SPECIFIC (expr)
4242 47280 : && GFC_DECL_SAVED_DESCRIPTOR (expr)
4243 243831 : && GFC_DECL_SAVED_DESCRIPTOR (expr) != expr)
4244 12731 : return non_negative_strides_array_p (GFC_DECL_SAVED_DESCRIPTOR (expr));
4245 :
4246 : return true;
4247 : }
4248 :
4249 :
4250 : /* Build a scalarized reference to an array. */
4251 :
4252 : static void
4253 189830 : gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar,
4254 : bool tmp_array = false)
4255 : {
4256 189830 : gfc_array_info *info;
4257 189830 : tree decl = NULL_TREE;
4258 189830 : tree index;
4259 189830 : tree base;
4260 189830 : gfc_ss *ss;
4261 189830 : gfc_expr *expr;
4262 189830 : int n;
4263 :
4264 189830 : ss = se->ss;
4265 189830 : expr = ss->info->expr;
4266 189830 : info = &ss->info->data.array;
4267 189830 : if (ar)
4268 129915 : n = se->loop->order[0];
4269 : else
4270 : n = 0;
4271 :
4272 189830 : index = conv_array_index_offset (se, ss, ss->dim[n], n, ar, info->stride0);
4273 : /* Add the offset for this dimension to the stored offset for all other
4274 : dimensions. */
4275 189830 : if (info->offset && !integer_zerop (info->offset))
4276 139543 : index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4277 : index, info->offset);
4278 :
4279 189830 : base = build_fold_indirect_ref_loc (input_location, info->data);
4280 :
4281 : /* Use the vptr 'size' field to access the element of a class array. */
4282 189830 : if (build_class_array_ref (se, base, index))
4283 3615 : return;
4284 :
4285 186215 : if (get_CFI_desc (NULL, expr, &decl, ar))
4286 442 : decl = build_fold_indirect_ref_loc (input_location, decl);
4287 :
4288 : /* A pointer array component can be detected from its field decl. Fix
4289 : the descriptor, mark the resulting variable decl and pass it to
4290 : gfc_build_array_ref. */
4291 186215 : if (is_pointer_array (info->descriptor)
4292 186215 : || (expr && expr->ts.deferred && info->descriptor
4293 2913 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info->descriptor))))
4294 : {
4295 9011 : if (TREE_CODE (info->descriptor) == COMPONENT_REF)
4296 1492 : decl = info->descriptor;
4297 7519 : else if (INDIRECT_REF_P (info->descriptor))
4298 1485 : decl = TREE_OPERAND (info->descriptor, 0);
4299 :
4300 9011 : if (decl == NULL_TREE)
4301 6034 : decl = info->descriptor;
4302 : }
4303 :
4304 186215 : bool non_negative_stride = tmp_array
4305 186215 : || non_negative_strides_array_p (info->descriptor);
4306 186215 : se->expr = gfc_build_array_ref (base, index, decl,
4307 : non_negative_stride);
4308 : }
4309 :
4310 :
4311 : /* Translate access of temporary array. */
4312 :
4313 : void
4314 59915 : gfc_conv_tmp_array_ref (gfc_se * se)
4315 : {
4316 59915 : se->string_length = se->ss->info->string_length;
4317 59915 : gfc_conv_scalarized_array_ref (se, NULL, true);
4318 59915 : gfc_advance_se_ss_chain (se);
4319 59915 : }
4320 :
4321 : /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
4322 :
4323 : static void
4324 271082 : add_to_offset (tree *cst_offset, tree *offset, tree t)
4325 : {
4326 271082 : if (TREE_CODE (t) == INTEGER_CST)
4327 137160 : *cst_offset = int_const_binop (PLUS_EXPR, *cst_offset, t);
4328 : else
4329 : {
4330 133922 : if (!integer_zerop (*offset))
4331 47203 : *offset = fold_build2_loc (input_location, PLUS_EXPR,
4332 : gfc_array_index_type, *offset, t);
4333 : else
4334 86719 : *offset = t;
4335 : }
4336 271082 : }
4337 :
4338 :
4339 : static tree
4340 180657 : build_array_ref (tree desc, tree offset, tree decl, tree vptr)
4341 : {
4342 180657 : tree tmp;
4343 180657 : tree type;
4344 180657 : tree cdesc;
4345 :
4346 : /* For class arrays the class declaration is stored in the saved
4347 : descriptor. */
4348 180657 : if (INDIRECT_REF_P (desc)
4349 7309 : && DECL_LANG_SPECIFIC (TREE_OPERAND (desc, 0))
4350 182955 : && GFC_DECL_SAVED_DESCRIPTOR (TREE_OPERAND (desc, 0)))
4351 863 : cdesc = gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (
4352 : TREE_OPERAND (desc, 0)));
4353 : else
4354 : cdesc = desc;
4355 :
4356 : /* Class container types do not always have the GFC_CLASS_TYPE_P
4357 : but the canonical type does. */
4358 180657 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdesc))
4359 180657 : && TREE_CODE (cdesc) == COMPONENT_REF)
4360 : {
4361 10886 : type = TREE_TYPE (TREE_OPERAND (cdesc, 0));
4362 10886 : if (TYPE_CANONICAL (type)
4363 10886 : && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type)))
4364 3305 : vptr = gfc_class_vptr_get (TREE_OPERAND (cdesc, 0));
4365 : }
4366 :
4367 180657 : tmp = gfc_conv_array_data (desc);
4368 180657 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
4369 180657 : tmp = gfc_build_array_ref (tmp, offset, decl,
4370 180657 : non_negative_strides_array_p (desc),
4371 : vptr);
4372 180657 : return tmp;
4373 : }
4374 :
4375 :
4376 : /* Build an array reference. se->expr already holds the array descriptor.
4377 : This should be either a variable, indirect variable reference or component
4378 : reference. For arrays which do not have a descriptor, se->expr will be
4379 : the data pointer.
4380 : a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
4381 :
4382 : void
4383 256620 : gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
4384 : locus * where)
4385 : {
4386 256620 : int n;
4387 256620 : tree offset, cst_offset;
4388 256620 : tree tmp;
4389 256620 : tree stride;
4390 256620 : tree decl = NULL_TREE;
4391 256620 : gfc_se indexse;
4392 256620 : gfc_se tmpse;
4393 256620 : gfc_symbol * sym = expr->symtree->n.sym;
4394 256620 : char *var_name = NULL;
4395 :
4396 256620 : if (ar->stat)
4397 : {
4398 3 : gfc_se statse;
4399 :
4400 3 : gfc_init_se (&statse, NULL);
4401 3 : gfc_conv_expr_lhs (&statse, ar->stat);
4402 3 : gfc_add_block_to_block (&se->pre, &statse.pre);
4403 3 : gfc_add_modify (&se->pre, statse.expr, integer_zero_node);
4404 : }
4405 256620 : if (ar->dimen == 0)
4406 : {
4407 4480 : gcc_assert (ar->codimen || sym->attr.select_rank_temporary
4408 : || (ar->as && ar->as->corank));
4409 :
4410 4480 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
4411 949 : se->expr = build_fold_indirect_ref (gfc_conv_array_data (se->expr));
4412 : else
4413 : {
4414 3531 : if (GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr))
4415 3531 : && TREE_CODE (TREE_TYPE (se->expr)) == POINTER_TYPE)
4416 2593 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
4417 :
4418 : /* Use the actual tree type and not the wrapped coarray. */
4419 3531 : if (!se->want_pointer)
4420 2563 : se->expr = fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se->expr)),
4421 : se->expr);
4422 : }
4423 :
4424 134395 : return;
4425 : }
4426 :
4427 : /* Handle scalarized references separately. */
4428 252140 : if (ar->type != AR_ELEMENT)
4429 : {
4430 129915 : gfc_conv_scalarized_array_ref (se, ar);
4431 129915 : gfc_advance_se_ss_chain (se);
4432 129915 : return;
4433 : }
4434 :
4435 122225 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
4436 11493 : var_name = abridged_ref_name (expr, ar);
4437 :
4438 122225 : decl = se->expr;
4439 122225 : if (UNLIMITED_POLY(sym)
4440 104 : && IS_CLASS_ARRAY (sym)
4441 103 : && sym->attr.dummy
4442 60 : && ar->as->type != AS_DEFERRED)
4443 48 : decl = sym->backend_decl;
4444 :
4445 122225 : cst_offset = offset = gfc_index_zero_node;
4446 122225 : add_to_offset (&cst_offset, &offset, gfc_conv_array_offset (decl));
4447 :
4448 : /* Calculate the offsets from all the dimensions. Make sure to associate
4449 : the final offset so that we form a chain of loop invariant summands. */
4450 271082 : for (n = ar->dimen - 1; n >= 0; n--)
4451 : {
4452 : /* Calculate the index for this dimension. */
4453 148857 : gfc_init_se (&indexse, se);
4454 148857 : gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
4455 148857 : gfc_add_block_to_block (&se->pre, &indexse.pre);
4456 :
4457 148857 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && ! expr->no_bounds_check)
4458 : {
4459 : /* Check array bounds. */
4460 15035 : tree cond;
4461 15035 : char *msg;
4462 :
4463 : /* Evaluate the indexse.expr only once. */
4464 15035 : indexse.expr = save_expr (indexse.expr);
4465 :
4466 : /* Lower bound. */
4467 15035 : tmp = gfc_conv_array_lbound (decl, n);
4468 15035 : if (sym->attr.temporary)
4469 : {
4470 18 : gfc_init_se (&tmpse, se);
4471 18 : gfc_conv_expr_type (&tmpse, ar->as->lower[n],
4472 : gfc_array_index_type);
4473 18 : gfc_add_block_to_block (&se->pre, &tmpse.pre);
4474 18 : tmp = tmpse.expr;
4475 : }
4476 :
4477 15035 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
4478 : indexse.expr, tmp);
4479 15035 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4480 : "below lower bound of %%ld", n+1, var_name);
4481 15035 : gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
4482 : fold_convert (long_integer_type_node,
4483 : indexse.expr),
4484 : fold_convert (long_integer_type_node, tmp));
4485 15035 : free (msg);
4486 :
4487 : /* Upper bound, but not for the last dimension of assumed-size
4488 : arrays. */
4489 15035 : if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE)
4490 : {
4491 13302 : tmp = gfc_conv_array_ubound (decl, n);
4492 13302 : if (sym->attr.temporary)
4493 : {
4494 18 : gfc_init_se (&tmpse, se);
4495 18 : gfc_conv_expr_type (&tmpse, ar->as->upper[n],
4496 : gfc_array_index_type);
4497 18 : gfc_add_block_to_block (&se->pre, &tmpse.pre);
4498 18 : tmp = tmpse.expr;
4499 : }
4500 :
4501 13302 : cond = fold_build2_loc (input_location, GT_EXPR,
4502 : logical_type_node, indexse.expr, tmp);
4503 13302 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4504 : "above upper bound of %%ld", n+1, var_name);
4505 13302 : gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
4506 : fold_convert (long_integer_type_node,
4507 : indexse.expr),
4508 : fold_convert (long_integer_type_node, tmp));
4509 13302 : free (msg);
4510 : }
4511 : }
4512 :
4513 : /* Multiply the index by the stride. */
4514 148857 : stride = gfc_conv_array_stride (decl, n);
4515 148857 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4516 : indexse.expr, stride);
4517 :
4518 : /* And add it to the total. */
4519 148857 : add_to_offset (&cst_offset, &offset, tmp);
4520 : }
4521 :
4522 122225 : if (!integer_zerop (cst_offset))
4523 65563 : offset = fold_build2_loc (input_location, PLUS_EXPR,
4524 : gfc_array_index_type, offset, cst_offset);
4525 :
4526 : /* A pointer array component can be detected from its field decl. Fix
4527 : the descriptor, mark the resulting variable decl and pass it to
4528 : build_array_ref. */
4529 122225 : decl = NULL_TREE;
4530 122225 : if (get_CFI_desc (sym, expr, &decl, ar))
4531 3589 : decl = build_fold_indirect_ref_loc (input_location, decl);
4532 121178 : if (!expr->ts.deferred && !sym->attr.codimension
4533 241181 : && is_pointer_array (se->expr))
4534 : {
4535 4879 : if (TREE_CODE (se->expr) == COMPONENT_REF)
4536 1454 : decl = se->expr;
4537 3425 : else if (INDIRECT_REF_P (se->expr))
4538 983 : decl = TREE_OPERAND (se->expr, 0);
4539 : else
4540 2442 : decl = se->expr;
4541 : }
4542 117346 : else if (expr->ts.deferred
4543 116299 : || (sym->ts.type == BT_CHARACTER
4544 15275 : && sym->attr.select_type_temporary))
4545 : {
4546 2751 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
4547 : {
4548 2595 : decl = se->expr;
4549 2595 : if (INDIRECT_REF_P (decl))
4550 20 : decl = TREE_OPERAND (decl, 0);
4551 : }
4552 : else
4553 156 : decl = sym->backend_decl;
4554 : }
4555 114595 : else if (sym->ts.type == BT_CLASS)
4556 : {
4557 2079 : if (UNLIMITED_POLY (sym))
4558 : {
4559 104 : gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr);
4560 104 : gfc_init_se (&tmpse, NULL);
4561 104 : gfc_conv_expr (&tmpse, class_expr);
4562 104 : if (!se->class_vptr)
4563 104 : se->class_vptr = gfc_class_vptr_get (tmpse.expr);
4564 104 : gfc_free_expr (class_expr);
4565 104 : decl = tmpse.expr;
4566 104 : }
4567 : else
4568 1975 : decl = NULL_TREE;
4569 : }
4570 :
4571 122225 : free (var_name);
4572 122225 : se->expr = build_array_ref (se->expr, offset, decl, se->class_vptr);
4573 : }
4574 :
4575 :
4576 : /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
4577 : LOOP_DIM dimension (if any) to array's offset. */
4578 :
4579 : static void
4580 59307 : add_array_offset (stmtblock_t *pblock, gfc_loopinfo *loop, gfc_ss *ss,
4581 : gfc_array_ref *ar, int array_dim, int loop_dim)
4582 : {
4583 59307 : gfc_se se;
4584 59307 : gfc_array_info *info;
4585 59307 : tree stride, index;
4586 :
4587 59307 : info = &ss->info->data.array;
4588 :
4589 59307 : gfc_init_se (&se, NULL);
4590 59307 : se.loop = loop;
4591 59307 : se.expr = info->descriptor;
4592 59307 : stride = gfc_conv_array_stride (info->descriptor, array_dim);
4593 59307 : index = conv_array_index_offset (&se, ss, array_dim, loop_dim, ar, stride);
4594 59307 : gfc_add_block_to_block (pblock, &se.pre);
4595 :
4596 59307 : info->offset = fold_build2_loc (input_location, PLUS_EXPR,
4597 : gfc_array_index_type,
4598 : info->offset, index);
4599 59307 : info->offset = gfc_evaluate_now (info->offset, pblock);
4600 59307 : }
4601 :
4602 :
4603 : /* Generate the code to be executed immediately before entering a
4604 : scalarization loop. */
4605 :
4606 : static void
4607 144039 : gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
4608 : stmtblock_t * pblock)
4609 : {
4610 144039 : tree stride;
4611 144039 : gfc_ss_info *ss_info;
4612 144039 : gfc_array_info *info;
4613 144039 : gfc_ss_type ss_type;
4614 144039 : gfc_ss *ss, *pss;
4615 144039 : gfc_loopinfo *ploop;
4616 144039 : gfc_array_ref *ar;
4617 :
4618 : /* This code will be executed before entering the scalarization loop
4619 : for this dimension. */
4620 439327 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4621 : {
4622 295288 : ss_info = ss->info;
4623 :
4624 295288 : if ((ss_info->useflags & flag) == 0)
4625 1476 : continue;
4626 :
4627 293812 : ss_type = ss_info->type;
4628 358779 : if (ss_type != GFC_SS_SECTION
4629 : && ss_type != GFC_SS_FUNCTION
4630 293812 : && ss_type != GFC_SS_CONSTRUCTOR
4631 293812 : && ss_type != GFC_SS_COMPONENT)
4632 64967 : continue;
4633 :
4634 228845 : info = &ss_info->data.array;
4635 :
4636 228845 : gcc_assert (dim < ss->dimen);
4637 228845 : gcc_assert (ss->dimen == loop->dimen);
4638 :
4639 228845 : if (info->ref)
4640 161418 : ar = &info->ref->u.ar;
4641 : else
4642 : ar = NULL;
4643 :
4644 228845 : if (dim == loop->dimen - 1 && loop->parent != NULL)
4645 : {
4646 : /* If we are in the outermost dimension of this loop, the previous
4647 : dimension shall be in the parent loop. */
4648 4687 : gcc_assert (ss->parent != NULL);
4649 :
4650 4687 : pss = ss->parent;
4651 4687 : ploop = loop->parent;
4652 :
4653 : /* ss and ss->parent are about the same array. */
4654 4687 : gcc_assert (ss_info == pss->info);
4655 : }
4656 : else
4657 : {
4658 : ploop = loop;
4659 : pss = ss;
4660 : }
4661 :
4662 228845 : if (dim == loop->dimen - 1 && loop->parent == NULL)
4663 : {
4664 174114 : gcc_assert (0 == ploop->order[0]);
4665 :
4666 348228 : stride = gfc_conv_array_stride (info->descriptor,
4667 174114 : innermost_ss (ss)->dim[0]);
4668 :
4669 : /* Calculate the stride of the innermost loop. Hopefully this will
4670 : allow the backend optimizers to do their stuff more effectively.
4671 : */
4672 174114 : info->stride0 = gfc_evaluate_now (stride, pblock);
4673 :
4674 : /* For the outermost loop calculate the offset due to any
4675 : elemental dimensions. It will have been initialized with the
4676 : base offset of the array. */
4677 174114 : if (info->ref)
4678 : {
4679 282384 : for (int i = 0; i < ar->dimen; i++)
4680 : {
4681 163620 : if (ar->dimen_type[i] != DIMEN_ELEMENT)
4682 159044 : continue;
4683 :
4684 4576 : add_array_offset (pblock, loop, ss, ar, i, /* unused */ -1);
4685 : }
4686 : }
4687 : }
4688 : else
4689 : {
4690 54731 : int i;
4691 :
4692 54731 : if (dim == loop->dimen - 1)
4693 : i = 0;
4694 : else
4695 50044 : i = dim + 1;
4696 :
4697 : /* For the time being, there is no loop reordering. */
4698 54731 : gcc_assert (i == ploop->order[i]);
4699 54731 : i = ploop->order[i];
4700 :
4701 : /* Add the offset for the previous loop dimension. */
4702 54731 : add_array_offset (pblock, ploop, ss, ar, pss->dim[i], i);
4703 : }
4704 :
4705 : /* Remember this offset for the second loop. */
4706 228845 : if (dim == loop->temp_dim - 1 && loop->parent == NULL)
4707 53208 : info->saved_offset = info->offset;
4708 : }
4709 144039 : }
4710 :
4711 :
4712 : /* Start a scalarized expression. Creates a scope and declares loop
4713 : variables. */
4714 :
4715 : void
4716 113765 : gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
4717 : {
4718 113765 : int dim;
4719 113765 : int n;
4720 113765 : int flags;
4721 :
4722 113765 : gcc_assert (!loop->array_parameter);
4723 :
4724 256224 : for (dim = loop->dimen - 1; dim >= 0; dim--)
4725 : {
4726 142459 : n = loop->order[dim];
4727 :
4728 142459 : gfc_start_block (&loop->code[n]);
4729 :
4730 : /* Create the loop variable. */
4731 142459 : loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
4732 :
4733 142459 : if (dim < loop->temp_dim)
4734 : flags = 3;
4735 : else
4736 97171 : flags = 1;
4737 : /* Calculate values that will be constant within this loop. */
4738 142459 : gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
4739 : }
4740 113765 : gfc_start_block (pbody);
4741 113765 : }
4742 :
4743 :
4744 : /* Generates the actual loop code for a scalarization loop. */
4745 :
4746 : static void
4747 157581 : gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
4748 : stmtblock_t * pbody)
4749 : {
4750 157581 : stmtblock_t block;
4751 157581 : tree cond;
4752 157581 : tree tmp;
4753 157581 : tree loopbody;
4754 157581 : tree exit_label;
4755 157581 : tree stmt;
4756 157581 : tree init;
4757 157581 : tree incr;
4758 :
4759 157581 : if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS
4760 : | OMPWS_SCALARIZER_BODY))
4761 : == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS)
4762 108 : && n == loop->dimen - 1)
4763 : {
4764 : /* We create an OMP_FOR construct for the outermost scalarized loop. */
4765 80 : init = make_tree_vec (1);
4766 80 : cond = make_tree_vec (1);
4767 80 : incr = make_tree_vec (1);
4768 :
4769 : /* Cycle statement is implemented with a goto. Exit statement must not
4770 : be present for this loop. */
4771 80 : exit_label = gfc_build_label_decl (NULL_TREE);
4772 80 : TREE_USED (exit_label) = 1;
4773 :
4774 : /* Label for cycle statements (if needed). */
4775 80 : tmp = build1_v (LABEL_EXPR, exit_label);
4776 80 : gfc_add_expr_to_block (pbody, tmp);
4777 :
4778 80 : stmt = make_node (OMP_FOR);
4779 :
4780 80 : TREE_TYPE (stmt) = void_type_node;
4781 80 : OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody);
4782 :
4783 80 : OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location,
4784 : OMP_CLAUSE_SCHEDULE);
4785 80 : OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt))
4786 80 : = OMP_CLAUSE_SCHEDULE_STATIC;
4787 80 : if (ompws_flags & OMPWS_NOWAIT)
4788 33 : OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt))
4789 66 : = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT);
4790 :
4791 : /* Initialize the loopvar. */
4792 80 : TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n],
4793 : loop->from[n]);
4794 80 : OMP_FOR_INIT (stmt) = init;
4795 : /* The exit condition. */
4796 80 : TREE_VEC_ELT (cond, 0) = build2_loc (input_location, LE_EXPR,
4797 : logical_type_node,
4798 : loop->loopvar[n], loop->to[n]);
4799 80 : SET_EXPR_LOCATION (TREE_VEC_ELT (cond, 0), input_location);
4800 80 : OMP_FOR_COND (stmt) = cond;
4801 : /* Increment the loopvar. */
4802 80 : tmp = build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4803 : loop->loopvar[n], gfc_index_one_node);
4804 80 : TREE_VEC_ELT (incr, 0) = fold_build2_loc (input_location, MODIFY_EXPR,
4805 : void_type_node, loop->loopvar[n], tmp);
4806 80 : OMP_FOR_INCR (stmt) = incr;
4807 :
4808 80 : ompws_flags &= ~OMPWS_CURR_SINGLEUNIT;
4809 80 : gfc_add_expr_to_block (&loop->code[n], stmt);
4810 : }
4811 : else
4812 : {
4813 315002 : bool reverse_loop = (loop->reverse[n] == GFC_REVERSE_SET)
4814 157501 : && (loop->temp_ss == NULL);
4815 :
4816 157501 : loopbody = gfc_finish_block (pbody);
4817 :
4818 157501 : if (reverse_loop)
4819 204 : std::swap (loop->from[n], loop->to[n]);
4820 :
4821 : /* Initialize the loopvar. */
4822 157501 : if (loop->loopvar[n] != loop->from[n])
4823 156680 : gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
4824 :
4825 157501 : exit_label = gfc_build_label_decl (NULL_TREE);
4826 :
4827 : /* Generate the loop body. */
4828 157501 : gfc_init_block (&block);
4829 :
4830 : /* The exit condition. */
4831 314798 : cond = fold_build2_loc (input_location, reverse_loop ? LT_EXPR : GT_EXPR,
4832 : logical_type_node, loop->loopvar[n], loop->to[n]);
4833 157501 : tmp = build1_v (GOTO_EXPR, exit_label);
4834 157501 : TREE_USED (exit_label) = 1;
4835 157501 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
4836 157501 : gfc_add_expr_to_block (&block, tmp);
4837 :
4838 : /* The main body. */
4839 157501 : gfc_add_expr_to_block (&block, loopbody);
4840 :
4841 : /* Increment the loopvar. */
4842 314798 : tmp = fold_build2_loc (input_location,
4843 : reverse_loop ? MINUS_EXPR : PLUS_EXPR,
4844 : gfc_array_index_type, loop->loopvar[n],
4845 : gfc_index_one_node);
4846 :
4847 157501 : gfc_add_modify (&block, loop->loopvar[n], tmp);
4848 :
4849 : /* Build the loop. */
4850 157501 : tmp = gfc_finish_block (&block);
4851 157501 : tmp = build1_v (LOOP_EXPR, tmp);
4852 157501 : gfc_add_expr_to_block (&loop->code[n], tmp);
4853 :
4854 : /* Add the exit label. */
4855 157501 : tmp = build1_v (LABEL_EXPR, exit_label);
4856 157501 : gfc_add_expr_to_block (&loop->code[n], tmp);
4857 : }
4858 :
4859 157581 : }
4860 :
4861 :
4862 : /* Finishes and generates the loops for a scalarized expression. */
4863 :
4864 : void
4865 119155 : gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
4866 : {
4867 119155 : int dim;
4868 119155 : int n;
4869 119155 : gfc_ss *ss;
4870 119155 : stmtblock_t *pblock;
4871 119155 : tree tmp;
4872 :
4873 119155 : pblock = body;
4874 : /* Generate the loops. */
4875 266995 : for (dim = 0; dim < loop->dimen; dim++)
4876 : {
4877 147840 : n = loop->order[dim];
4878 147840 : gfc_trans_scalarized_loop_end (loop, n, pblock);
4879 147840 : loop->loopvar[n] = NULL_TREE;
4880 147840 : pblock = &loop->code[n];
4881 : }
4882 :
4883 119155 : tmp = gfc_finish_block (pblock);
4884 119155 : gfc_add_expr_to_block (&loop->pre, tmp);
4885 :
4886 : /* Clear all the used flags. */
4887 350151 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4888 230996 : if (ss->parent == NULL)
4889 226246 : ss->info->useflags = 0;
4890 119155 : }
4891 :
4892 :
4893 : /* Finish the main body of a scalarized expression, and start the secondary
4894 : copying body. */
4895 :
4896 : void
4897 8161 : gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
4898 : {
4899 8161 : int dim;
4900 8161 : int n;
4901 8161 : stmtblock_t *pblock;
4902 8161 : gfc_ss *ss;
4903 :
4904 8161 : pblock = body;
4905 : /* We finish as many loops as are used by the temporary. */
4906 9741 : for (dim = 0; dim < loop->temp_dim - 1; dim++)
4907 : {
4908 1580 : n = loop->order[dim];
4909 1580 : gfc_trans_scalarized_loop_end (loop, n, pblock);
4910 1580 : loop->loopvar[n] = NULL_TREE;
4911 1580 : pblock = &loop->code[n];
4912 : }
4913 :
4914 : /* We don't want to finish the outermost loop entirely. */
4915 8161 : n = loop->order[loop->temp_dim - 1];
4916 8161 : gfc_trans_scalarized_loop_end (loop, n, pblock);
4917 :
4918 : /* Restore the initial offsets. */
4919 23325 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4920 : {
4921 15164 : gfc_ss_type ss_type;
4922 15164 : gfc_ss_info *ss_info;
4923 :
4924 15164 : ss_info = ss->info;
4925 :
4926 15164 : if ((ss_info->useflags & 2) == 0)
4927 4484 : continue;
4928 :
4929 10680 : ss_type = ss_info->type;
4930 10834 : if (ss_type != GFC_SS_SECTION
4931 : && ss_type != GFC_SS_FUNCTION
4932 10680 : && ss_type != GFC_SS_CONSTRUCTOR
4933 10680 : && ss_type != GFC_SS_COMPONENT)
4934 154 : continue;
4935 :
4936 10526 : ss_info->data.array.offset = ss_info->data.array.saved_offset;
4937 : }
4938 :
4939 : /* Restart all the inner loops we just finished. */
4940 9741 : for (dim = loop->temp_dim - 2; dim >= 0; dim--)
4941 : {
4942 1580 : n = loop->order[dim];
4943 :
4944 1580 : gfc_start_block (&loop->code[n]);
4945 :
4946 1580 : loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
4947 :
4948 1580 : gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
4949 : }
4950 :
4951 : /* Start a block for the secondary copying code. */
4952 8161 : gfc_start_block (body);
4953 8161 : }
4954 :
4955 :
4956 : /* Precalculate (either lower or upper) bound of an array section.
4957 : BLOCK: Block in which the (pre)calculation code will go.
4958 : BOUNDS[DIM]: Where the bound value will be stored once evaluated.
4959 : VALUES[DIM]: Specified bound (NULL <=> unspecified).
4960 : DESC: Array descriptor from which the bound will be picked if unspecified
4961 : (either lower or upper bound according to LBOUND). */
4962 :
4963 : static void
4964 508694 : evaluate_bound (stmtblock_t *block, tree *bounds, gfc_expr ** values,
4965 : tree desc, int dim, bool lbound, bool deferred, bool save_value)
4966 : {
4967 508694 : gfc_se se;
4968 508694 : gfc_expr * input_val = values[dim];
4969 508694 : tree *output = &bounds[dim];
4970 :
4971 508694 : if (input_val)
4972 : {
4973 : /* Specified section bound. */
4974 46986 : gfc_init_se (&se, NULL);
4975 46986 : gfc_conv_expr_type (&se, input_val, gfc_array_index_type);
4976 46986 : gfc_add_block_to_block (block, &se.pre);
4977 46986 : *output = se.expr;
4978 : }
4979 461708 : else if (deferred && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
4980 : {
4981 : /* The gfc_conv_array_lbound () routine returns a constant zero for
4982 : deferred length arrays, which in the scalarizer wreaks havoc, when
4983 : copying to a (newly allocated) one-based array.
4984 : Keep returning the actual result in sync for both bounds. */
4985 188528 : *output = lbound ? gfc_conv_descriptor_lbound_get (desc,
4986 : gfc_rank_cst[dim]):
4987 62952 : gfc_conv_descriptor_ubound_get (desc,
4988 : gfc_rank_cst[dim]);
4989 : }
4990 : else
4991 : {
4992 : /* No specific bound specified so use the bound of the array. */
4993 500808 : *output = lbound ? gfc_conv_array_lbound (desc, dim) :
4994 164676 : gfc_conv_array_ubound (desc, dim);
4995 : }
4996 508694 : if (save_value)
4997 490096 : *output = gfc_evaluate_now (*output, block);
4998 508694 : }
4999 :
5000 :
5001 : /* Calculate the lower bound of an array section. */
5002 :
5003 : static void
5004 254758 : gfc_conv_section_startstride (stmtblock_t * block, gfc_ss * ss, int dim)
5005 : {
5006 254758 : gfc_expr *stride = NULL;
5007 254758 : tree desc;
5008 254758 : gfc_se se;
5009 254758 : gfc_array_info *info;
5010 254758 : gfc_array_ref *ar;
5011 :
5012 254758 : gcc_assert (ss->info->type == GFC_SS_SECTION);
5013 :
5014 254758 : info = &ss->info->data.array;
5015 254758 : ar = &info->ref->u.ar;
5016 :
5017 254758 : if (ar->dimen_type[dim] == DIMEN_VECTOR)
5018 : {
5019 : /* We use a zero-based index to access the vector. */
5020 758 : info->start[dim] = gfc_index_zero_node;
5021 758 : info->end[dim] = NULL;
5022 758 : info->stride[dim] = gfc_index_one_node;
5023 758 : return;
5024 : }
5025 :
5026 254000 : gcc_assert (ar->dimen_type[dim] == DIMEN_RANGE
5027 : || ar->dimen_type[dim] == DIMEN_THIS_IMAGE);
5028 254000 : desc = info->descriptor;
5029 254000 : stride = ar->stride[dim];
5030 254000 : bool save_value = !ss->is_alloc_lhs;
5031 :
5032 : /* Calculate the start of the range. For vector subscripts this will
5033 : be the range of the vector. */
5034 254000 : evaluate_bound (block, info->start, ar->start, desc, dim, true,
5035 254000 : ar->as->type == AS_DEFERRED, save_value);
5036 :
5037 : /* Similarly calculate the end. Although this is not used in the
5038 : scalarizer, it is needed when checking bounds and where the end
5039 : is an expression with side-effects. */
5040 254000 : evaluate_bound (block, info->end, ar->end, desc, dim, false,
5041 254000 : ar->as->type == AS_DEFERRED, save_value);
5042 :
5043 :
5044 : /* Calculate the stride. */
5045 254000 : if (stride == NULL)
5046 241424 : info->stride[dim] = gfc_index_one_node;
5047 : else
5048 : {
5049 12576 : gfc_init_se (&se, NULL);
5050 12576 : gfc_conv_expr_type (&se, stride, gfc_array_index_type);
5051 12576 : gfc_add_block_to_block (block, &se.pre);
5052 12576 : tree value = se.expr;
5053 12576 : if (save_value)
5054 12576 : info->stride[dim] = gfc_evaluate_now (value, block);
5055 : else
5056 0 : info->stride[dim] = value;
5057 : }
5058 : }
5059 :
5060 :
5061 : /* Generate in INNER the bounds checking code along the dimension DIM for
5062 : the array associated with SS_INFO. */
5063 :
5064 : static void
5065 23989 : add_check_section_in_array_bounds (stmtblock_t *inner, gfc_ss_info *ss_info,
5066 : int dim)
5067 : {
5068 23989 : gfc_expr *expr = ss_info->expr;
5069 23989 : locus *expr_loc = &expr->where;
5070 23989 : const char *expr_name = expr->symtree->name;
5071 :
5072 23989 : gfc_array_info *info = &ss_info->data.array;
5073 :
5074 23989 : bool check_upper;
5075 23989 : if (dim == info->ref->u.ar.dimen - 1
5076 20386 : && info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
5077 : check_upper = false;
5078 : else
5079 23693 : check_upper = true;
5080 :
5081 : /* Zero stride is not allowed. */
5082 23989 : tree tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
5083 : info->stride[dim], gfc_index_zero_node);
5084 23989 : char * msg = xasprintf ("Zero stride is not allowed, for dimension %d "
5085 : "of array '%s'", dim + 1, expr_name);
5086 23989 : gfc_trans_runtime_check (true, false, tmp, inner, expr_loc, msg);
5087 23989 : free (msg);
5088 :
5089 23989 : tree desc = info->descriptor;
5090 :
5091 : /* This is the run-time equivalent of resolve.cc's
5092 : check_dimension. The logical is more readable there
5093 : than it is here, with all the trees. */
5094 23989 : tree lbound = gfc_conv_array_lbound (desc, dim);
5095 23989 : tree end = info->end[dim];
5096 23989 : tree ubound = check_upper ? gfc_conv_array_ubound (desc, dim) : NULL_TREE;
5097 :
5098 : /* non_zerosized is true when the selected range is not
5099 : empty. */
5100 23989 : tree stride_pos = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
5101 : info->stride[dim], gfc_index_zero_node);
5102 23989 : tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
5103 : info->start[dim], end);
5104 23989 : stride_pos = fold_build2_loc (input_location, TRUTH_AND_EXPR,
5105 : logical_type_node, stride_pos, tmp);
5106 :
5107 23989 : tree stride_neg = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
5108 : info->stride[dim], gfc_index_zero_node);
5109 23989 : tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
5110 : info->start[dim], end);
5111 23989 : stride_neg = fold_build2_loc (input_location, TRUTH_AND_EXPR,
5112 : logical_type_node, stride_neg, tmp);
5113 23989 : tree non_zerosized = fold_build2_loc (input_location, TRUTH_OR_EXPR,
5114 : logical_type_node, stride_pos,
5115 : stride_neg);
5116 :
5117 : /* Check the start of the range against the lower and upper
5118 : bounds of the array, if the range is not empty.
5119 : If upper bound is present, include both bounds in the
5120 : error message. */
5121 23989 : if (check_upper)
5122 : {
5123 23693 : tmp = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
5124 : info->start[dim], lbound);
5125 23693 : tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
5126 : non_zerosized, tmp);
5127 23693 : tree tmp2 = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
5128 : info->start[dim], ubound);
5129 23693 : tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
5130 : non_zerosized, tmp2);
5131 23693 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' outside of "
5132 : "expected range (%%ld:%%ld)", dim + 1, expr_name);
5133 23693 : gfc_trans_runtime_check (true, false, tmp, inner, expr_loc, msg,
5134 : fold_convert (long_integer_type_node, info->start[dim]),
5135 : fold_convert (long_integer_type_node, lbound),
5136 : fold_convert (long_integer_type_node, ubound));
5137 23693 : gfc_trans_runtime_check (true, false, tmp2, inner, expr_loc, msg,
5138 : fold_convert (long_integer_type_node, info->start[dim]),
5139 : fold_convert (long_integer_type_node, lbound),
5140 : fold_convert (long_integer_type_node, ubound));
5141 23693 : free (msg);
5142 : }
5143 : else
5144 : {
5145 296 : tmp = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
5146 : info->start[dim], lbound);
5147 296 : tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
5148 : non_zerosized, tmp);
5149 296 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' below "
5150 : "lower bound of %%ld", dim + 1, expr_name);
5151 296 : gfc_trans_runtime_check (true, false, tmp, inner, expr_loc, msg,
5152 : fold_convert (long_integer_type_node, info->start[dim]),
5153 : fold_convert (long_integer_type_node, lbound));
5154 296 : free (msg);
5155 : }
5156 :
5157 : /* Compute the last element of the range, which is not
5158 : necessarily "end" (think 0:5:3, which doesn't contain 5)
5159 : and check it against both lower and upper bounds. */
5160 :
5161 23989 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5162 : end, info->start[dim]);
5163 23989 : tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR, gfc_array_index_type,
5164 : tmp, info->stride[dim]);
5165 23989 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5166 : end, tmp);
5167 23989 : tree tmp2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
5168 : tmp, lbound);
5169 23989 : tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
5170 : non_zerosized, tmp2);
5171 23989 : if (check_upper)
5172 : {
5173 23693 : tree tmp3 = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
5174 : tmp, ubound);
5175 23693 : tmp3 = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
5176 : non_zerosized, tmp3);
5177 23693 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' outside of "
5178 : "expected range (%%ld:%%ld)", dim + 1, expr_name);
5179 23693 : gfc_trans_runtime_check (true, false, tmp2, inner, expr_loc, msg,
5180 : fold_convert (long_integer_type_node, tmp),
5181 : fold_convert (long_integer_type_node, ubound),
5182 : fold_convert (long_integer_type_node, lbound));
5183 23693 : gfc_trans_runtime_check (true, false, tmp3, inner, expr_loc, msg,
5184 : fold_convert (long_integer_type_node, tmp),
5185 : fold_convert (long_integer_type_node, ubound),
5186 : fold_convert (long_integer_type_node, lbound));
5187 23693 : free (msg);
5188 : }
5189 : else
5190 : {
5191 296 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' below "
5192 : "lower bound of %%ld", dim + 1, expr_name);
5193 296 : gfc_trans_runtime_check (true, false, tmp2, inner, expr_loc, msg,
5194 : fold_convert (long_integer_type_node, tmp),
5195 : fold_convert (long_integer_type_node, lbound));
5196 296 : free (msg);
5197 : }
5198 23989 : }
5199 :
5200 :
5201 : /* Tells whether we need to generate bounds checking code for the array
5202 : associated with SS. */
5203 :
5204 : bool
5205 24950 : bounds_check_needed (gfc_ss *ss)
5206 : {
5207 : /* Catch allocatable lhs in f2003. */
5208 24950 : if (flag_realloc_lhs && ss->no_bounds_check)
5209 : return false;
5210 :
5211 24673 : gfc_ss_info *ss_info = ss->info;
5212 24673 : if (ss_info->type == GFC_SS_SECTION)
5213 : return true;
5214 :
5215 4114 : if (!(ss_info->type == GFC_SS_INTRINSIC
5216 227 : && ss_info->expr
5217 227 : && ss_info->expr->expr_type == EXPR_FUNCTION))
5218 : return false;
5219 :
5220 227 : gfc_intrinsic_sym *isym = ss_info->expr->value.function.isym;
5221 227 : if (!(isym
5222 227 : && (isym->id == GFC_ISYM_MAXLOC
5223 203 : || isym->id == GFC_ISYM_MINLOC)))
5224 : return false;
5225 :
5226 34 : return gfc_inline_intrinsic_function_p (ss_info->expr);
5227 : }
5228 :
5229 :
5230 : /* Calculates the range start and stride for a SS chain. Also gets the
5231 : descriptor and data pointer. The range of vector subscripts is the size
5232 : of the vector. Array bounds are also checked. */
5233 :
5234 : void
5235 180150 : gfc_conv_ss_startstride (gfc_loopinfo * loop)
5236 : {
5237 180150 : int n;
5238 180150 : tree tmp;
5239 180150 : gfc_ss *ss;
5240 :
5241 180150 : gfc_loopinfo * const outer_loop = outermost_loop (loop);
5242 :
5243 180150 : loop->dimen = 0;
5244 : /* Determine the rank of the loop. */
5245 200063 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5246 : {
5247 200063 : switch (ss->info->type)
5248 : {
5249 168978 : case GFC_SS_SECTION:
5250 168978 : case GFC_SS_CONSTRUCTOR:
5251 168978 : case GFC_SS_FUNCTION:
5252 168978 : case GFC_SS_COMPONENT:
5253 168978 : loop->dimen = ss->dimen;
5254 168978 : goto done;
5255 :
5256 : /* As usual, lbound and ubound are exceptions!. */
5257 11172 : case GFC_SS_INTRINSIC:
5258 11172 : switch (ss->info->expr->value.function.isym->id)
5259 : {
5260 11172 : case GFC_ISYM_LBOUND:
5261 11172 : case GFC_ISYM_UBOUND:
5262 11172 : case GFC_ISYM_COSHAPE:
5263 11172 : case GFC_ISYM_LCOBOUND:
5264 11172 : case GFC_ISYM_UCOBOUND:
5265 11172 : case GFC_ISYM_MAXLOC:
5266 11172 : case GFC_ISYM_MINLOC:
5267 11172 : case GFC_ISYM_SHAPE:
5268 11172 : case GFC_ISYM_THIS_IMAGE:
5269 11172 : loop->dimen = ss->dimen;
5270 11172 : goto done;
5271 :
5272 : default:
5273 : break;
5274 : }
5275 :
5276 19913 : default:
5277 19913 : break;
5278 : }
5279 : }
5280 :
5281 : /* We should have determined the rank of the expression by now. If
5282 : not, that's bad news. */
5283 0 : gcc_unreachable ();
5284 :
5285 : done:
5286 : /* Loop over all the SS in the chain. */
5287 468599 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5288 : {
5289 288449 : gfc_ss_info *ss_info;
5290 288449 : gfc_array_info *info;
5291 288449 : gfc_expr *expr;
5292 :
5293 288449 : ss_info = ss->info;
5294 288449 : expr = ss_info->expr;
5295 288449 : info = &ss_info->data.array;
5296 :
5297 288449 : if (expr && expr->shape && !info->shape)
5298 167583 : info->shape = expr->shape;
5299 :
5300 288449 : switch (ss_info->type)
5301 : {
5302 182839 : case GFC_SS_SECTION:
5303 : /* Get the descriptor for the array. If it is a cross loops array,
5304 : we got the descriptor already in the outermost loop. */
5305 182839 : if (ss->parent == NULL)
5306 178203 : gfc_conv_ss_descriptor (&outer_loop->pre, ss,
5307 178203 : !loop->array_parameter);
5308 :
5309 436779 : for (n = 0; n < ss->dimen; n++)
5310 253940 : gfc_conv_section_startstride (&outer_loop->pre, ss, ss->dim[n]);
5311 : break;
5312 :
5313 11419 : case GFC_SS_INTRINSIC:
5314 11419 : switch (expr->value.function.isym->id)
5315 : {
5316 3281 : case GFC_ISYM_MINLOC:
5317 3281 : case GFC_ISYM_MAXLOC:
5318 3281 : {
5319 3281 : gfc_se se;
5320 3281 : gfc_init_se (&se, nullptr);
5321 3281 : se.loop = loop;
5322 3281 : se.ss = ss;
5323 3281 : gfc_conv_intrinsic_function (&se, expr);
5324 3281 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
5325 3281 : gfc_add_block_to_block (&outer_loop->post, &se.post);
5326 :
5327 3281 : info->descriptor = se.expr;
5328 :
5329 3281 : info->data = gfc_conv_array_data (info->descriptor);
5330 3281 : info->data = gfc_evaluate_now (info->data, &outer_loop->pre);
5331 :
5332 3281 : gfc_expr *array = expr->value.function.actual->expr;
5333 3281 : tree rank = build_int_cst (gfc_array_index_type, array->rank);
5334 :
5335 3281 : tree tmp = fold_build2_loc (input_location, MINUS_EXPR,
5336 : gfc_array_index_type, rank,
5337 : gfc_index_one_node);
5338 :
5339 3281 : info->end[0] = gfc_evaluate_now (tmp, &outer_loop->pre);
5340 3281 : info->start[0] = gfc_index_zero_node;
5341 3281 : info->stride[0] = gfc_index_one_node;
5342 3281 : info->offset = gfc_index_zero_node;
5343 3281 : continue;
5344 3281 : }
5345 :
5346 : /* Fall through to supply start and stride. */
5347 3004 : case GFC_ISYM_LBOUND:
5348 3004 : case GFC_ISYM_UBOUND:
5349 : /* This is the variant without DIM=... */
5350 3004 : gcc_assert (expr->value.function.actual->next->expr == NULL);
5351 : /* Fall through. */
5352 :
5353 7830 : case GFC_ISYM_SHAPE:
5354 7830 : {
5355 7830 : gfc_expr *arg;
5356 :
5357 7830 : arg = expr->value.function.actual->expr;
5358 7830 : if (arg->rank == -1)
5359 : {
5360 1157 : gfc_se se;
5361 1157 : tree rank, tmp;
5362 :
5363 : /* The rank (hence the return value's shape) is unknown,
5364 : we have to retrieve it. */
5365 1157 : gfc_init_se (&se, NULL);
5366 1157 : se.descriptor_only = 1;
5367 1157 : gfc_conv_expr (&se, arg);
5368 : /* This is a bare variable, so there is no preliminary
5369 : or cleanup code unless -std=f202y and bounds checking
5370 : is on. */
5371 1157 : if (!((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
5372 0 : && (gfc_option.allow_std & GFC_STD_F202Y)))
5373 1157 : gcc_assert (se.pre.head == NULL_TREE
5374 : && se.post.head == NULL_TREE);
5375 1157 : rank = gfc_conv_descriptor_rank (se.expr);
5376 1157 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
5377 : gfc_array_index_type,
5378 : fold_convert (gfc_array_index_type,
5379 : rank),
5380 : gfc_index_one_node);
5381 1157 : info->end[0] = gfc_evaluate_now (tmp, &outer_loop->pre);
5382 1157 : info->start[0] = gfc_index_zero_node;
5383 1157 : info->stride[0] = gfc_index_one_node;
5384 1157 : continue;
5385 1157 : }
5386 : /* Otherwise fall through GFC_SS_FUNCTION. */
5387 : gcc_fallthrough ();
5388 : }
5389 : case GFC_ISYM_COSHAPE:
5390 : case GFC_ISYM_LCOBOUND:
5391 : case GFC_ISYM_UCOBOUND:
5392 : case GFC_ISYM_THIS_IMAGE:
5393 : break;
5394 :
5395 0 : default:
5396 0 : continue;
5397 0 : }
5398 :
5399 : /* FALLTHRU */
5400 : case GFC_SS_CONSTRUCTOR:
5401 : case GFC_SS_FUNCTION:
5402 127422 : for (n = 0; n < ss->dimen; n++)
5403 : {
5404 68852 : int dim = ss->dim[n];
5405 :
5406 68852 : info->start[dim] = gfc_index_zero_node;
5407 68852 : if (ss_info->type != GFC_SS_FUNCTION)
5408 54565 : info->end[dim] = gfc_index_zero_node;
5409 68852 : info->stride[dim] = gfc_index_one_node;
5410 : }
5411 : break;
5412 :
5413 : default:
5414 : break;
5415 : }
5416 : }
5417 :
5418 : /* The rest is just runtime bounds checking. */
5419 180150 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
5420 : {
5421 16888 : stmtblock_t block;
5422 16888 : tree size[GFC_MAX_DIMENSIONS];
5423 16888 : tree tmp3;
5424 16888 : gfc_array_info *info;
5425 16888 : char *msg;
5426 16888 : int dim;
5427 :
5428 16888 : gfc_start_block (&block);
5429 :
5430 54080 : for (n = 0; n < loop->dimen; n++)
5431 20304 : size[n] = NULL_TREE;
5432 :
5433 : /* If there is a constructor involved, derive size[] from its shape. */
5434 39012 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5435 : {
5436 24604 : gfc_ss_info *ss_info;
5437 :
5438 24604 : ss_info = ss->info;
5439 24604 : info = &ss_info->data.array;
5440 :
5441 24604 : if (ss_info->type == GFC_SS_CONSTRUCTOR && info->shape)
5442 : {
5443 5224 : for (n = 0; n < loop->dimen; n++)
5444 : {
5445 2744 : if (size[n] == NULL)
5446 : {
5447 2744 : gcc_assert (info->shape[n]);
5448 2744 : size[n] = gfc_conv_mpz_to_tree (info->shape[n],
5449 : gfc_index_integer_kind);
5450 : }
5451 : }
5452 : break;
5453 : }
5454 : }
5455 :
5456 41838 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5457 : {
5458 24950 : stmtblock_t inner;
5459 24950 : gfc_ss_info *ss_info;
5460 24950 : gfc_expr *expr;
5461 24950 : locus *expr_loc;
5462 24950 : const char *expr_name;
5463 24950 : char *ref_name = NULL;
5464 :
5465 24950 : if (!bounds_check_needed (ss))
5466 4357 : continue;
5467 :
5468 20593 : ss_info = ss->info;
5469 20593 : expr = ss_info->expr;
5470 20593 : expr_loc = &expr->where;
5471 20593 : if (expr->ref)
5472 20559 : expr_name = ref_name = abridged_ref_name (expr, NULL);
5473 : else
5474 34 : expr_name = expr->symtree->name;
5475 :
5476 20593 : gfc_start_block (&inner);
5477 :
5478 : /* TODO: range checking for mapped dimensions. */
5479 20593 : info = &ss_info->data.array;
5480 :
5481 : /* This code only checks ranges. Elemental and vector
5482 : dimensions are checked later. */
5483 65223 : for (n = 0; n < loop->dimen; n++)
5484 : {
5485 24037 : dim = ss->dim[n];
5486 24037 : if (ss_info->type == GFC_SS_SECTION)
5487 : {
5488 24003 : if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
5489 14 : continue;
5490 :
5491 23989 : add_check_section_in_array_bounds (&inner, ss_info, dim);
5492 : }
5493 :
5494 : /* Check the section sizes match. */
5495 24023 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
5496 : gfc_array_index_type, info->end[dim],
5497 : info->start[dim]);
5498 24023 : tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
5499 : gfc_array_index_type, tmp,
5500 : info->stride[dim]);
5501 24023 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
5502 : gfc_array_index_type,
5503 : gfc_index_one_node, tmp);
5504 24023 : tmp = fold_build2_loc (input_location, MAX_EXPR,
5505 : gfc_array_index_type, tmp,
5506 : build_int_cst (gfc_array_index_type, 0));
5507 : /* We remember the size of the first section, and check all the
5508 : others against this. */
5509 24023 : if (size[n])
5510 : {
5511 7167 : tmp3 = fold_build2_loc (input_location, NE_EXPR,
5512 : logical_type_node, tmp, size[n]);
5513 7167 : if (ss_info->type == GFC_SS_INTRINSIC)
5514 0 : msg = xasprintf ("Extent mismatch for dimension %d of the "
5515 : "result of intrinsic '%s' (%%ld/%%ld)",
5516 : dim + 1, expr_name);
5517 : else
5518 7167 : msg = xasprintf ("Array bound mismatch for dimension %d "
5519 : "of array '%s' (%%ld/%%ld)",
5520 : dim + 1, expr_name);
5521 :
5522 7167 : gfc_trans_runtime_check (true, false, tmp3, &inner,
5523 : expr_loc, msg,
5524 : fold_convert (long_integer_type_node, tmp),
5525 : fold_convert (long_integer_type_node, size[n]));
5526 :
5527 7167 : free (msg);
5528 : }
5529 : else
5530 16856 : size[n] = gfc_evaluate_now (tmp, &inner);
5531 : }
5532 :
5533 20593 : tmp = gfc_finish_block (&inner);
5534 :
5535 : /* For optional arguments, only check bounds if the argument is
5536 : present. */
5537 20593 : if ((expr->symtree->n.sym->attr.optional
5538 20285 : || expr->symtree->n.sym->attr.not_always_present)
5539 308 : && expr->symtree->n.sym->attr.dummy)
5540 307 : tmp = build3_v (COND_EXPR,
5541 : gfc_conv_expr_present (expr->symtree->n.sym),
5542 : tmp, build_empty_stmt (input_location));
5543 :
5544 20593 : gfc_add_expr_to_block (&block, tmp);
5545 :
5546 20593 : free (ref_name);
5547 : }
5548 :
5549 16888 : tmp = gfc_finish_block (&block);
5550 16888 : gfc_add_expr_to_block (&outer_loop->pre, tmp);
5551 : }
5552 :
5553 183514 : for (loop = loop->nested; loop; loop = loop->next)
5554 3364 : gfc_conv_ss_startstride (loop);
5555 180150 : }
5556 :
5557 : /* Return true if both symbols could refer to the same data object. Does
5558 : not take account of aliasing due to equivalence statements. */
5559 :
5560 : static bool
5561 13394 : symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym, bool lsym_pointer,
5562 : bool lsym_target, bool rsym_pointer, bool rsym_target)
5563 : {
5564 : /* Aliasing isn't possible if the symbols have different base types,
5565 : except for complex types where an inquiry reference (%RE, %IM) could
5566 : alias with a real type with the same kind parameter. */
5567 13394 : if (!gfc_compare_types (&lsym->ts, &rsym->ts)
5568 13394 : && !(((lsym->ts.type == BT_COMPLEX && rsym->ts.type == BT_REAL)
5569 4743 : || (lsym->ts.type == BT_REAL && rsym->ts.type == BT_COMPLEX))
5570 76 : && lsym->ts.kind == rsym->ts.kind))
5571 : return false;
5572 :
5573 : /* Pointers can point to other pointers and target objects. */
5574 :
5575 8664 : if ((lsym_pointer && (rsym_pointer || rsym_target))
5576 8455 : || (rsym_pointer && (lsym_pointer || lsym_target)))
5577 : return true;
5578 :
5579 : /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
5580 : and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
5581 : checked above. */
5582 8541 : if (lsym_target && rsym_target
5583 14 : && ((lsym->attr.dummy && !lsym->attr.contiguous
5584 0 : && (!lsym->attr.dimension || lsym->as->type == AS_ASSUMED_SHAPE))
5585 14 : || (rsym->attr.dummy && !rsym->attr.contiguous
5586 6 : && (!rsym->attr.dimension
5587 6 : || rsym->as->type == AS_ASSUMED_SHAPE))))
5588 6 : return true;
5589 :
5590 : return false;
5591 : }
5592 :
5593 :
5594 : /* Return true if the two SS could be aliased, i.e. both point to the same data
5595 : object. */
5596 : /* TODO: resolve aliases based on frontend expressions. */
5597 :
5598 : static int
5599 11360 : gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
5600 : {
5601 11360 : gfc_ref *lref;
5602 11360 : gfc_ref *rref;
5603 11360 : gfc_expr *lexpr, *rexpr;
5604 11360 : gfc_symbol *lsym;
5605 11360 : gfc_symbol *rsym;
5606 11360 : bool lsym_pointer, lsym_target, rsym_pointer, rsym_target;
5607 :
5608 11360 : lexpr = lss->info->expr;
5609 11360 : rexpr = rss->info->expr;
5610 :
5611 11360 : lsym = lexpr->symtree->n.sym;
5612 11360 : rsym = rexpr->symtree->n.sym;
5613 :
5614 11360 : lsym_pointer = lsym->attr.pointer;
5615 11360 : lsym_target = lsym->attr.target;
5616 11360 : rsym_pointer = rsym->attr.pointer;
5617 11360 : rsym_target = rsym->attr.target;
5618 :
5619 11360 : if (symbols_could_alias (lsym, rsym, lsym_pointer, lsym_target,
5620 : rsym_pointer, rsym_target))
5621 : return 1;
5622 :
5623 11269 : if (rsym->ts.type != BT_DERIVED && rsym->ts.type != BT_CLASS
5624 10080 : && lsym->ts.type != BT_DERIVED && lsym->ts.type != BT_CLASS)
5625 : return 0;
5626 :
5627 : /* For derived types we must check all the component types. We can ignore
5628 : array references as these will have the same base type as the previous
5629 : component ref. */
5630 2500 : for (lref = lexpr->ref; lref != lss->info->data.array.ref; lref = lref->next)
5631 : {
5632 917 : if (lref->type != REF_COMPONENT)
5633 89 : continue;
5634 :
5635 828 : lsym_pointer = lsym_pointer || lref->u.c.sym->attr.pointer;
5636 828 : lsym_target = lsym_target || lref->u.c.sym->attr.target;
5637 :
5638 828 : if (symbols_could_alias (lref->u.c.sym, rsym, lsym_pointer, lsym_target,
5639 : rsym_pointer, rsym_target))
5640 : return 1;
5641 :
5642 828 : if ((lsym_pointer && (rsym_pointer || rsym_target))
5643 813 : || (rsym_pointer && (lsym_pointer || lsym_target)))
5644 : {
5645 6 : if (gfc_compare_types (&lref->u.c.component->ts,
5646 : &rsym->ts))
5647 : return 1;
5648 : }
5649 :
5650 1252 : for (rref = rexpr->ref; rref != rss->info->data.array.ref;
5651 430 : rref = rref->next)
5652 : {
5653 431 : if (rref->type != REF_COMPONENT)
5654 36 : continue;
5655 :
5656 395 : rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
5657 395 : rsym_target = lsym_target || rref->u.c.sym->attr.target;
5658 :
5659 395 : if (symbols_could_alias (lref->u.c.sym, rref->u.c.sym,
5660 : lsym_pointer, lsym_target,
5661 : rsym_pointer, rsym_target))
5662 : return 1;
5663 :
5664 394 : if ((lsym_pointer && (rsym_pointer || rsym_target))
5665 390 : || (rsym_pointer && (lsym_pointer || lsym_target)))
5666 : {
5667 0 : if (gfc_compare_types (&lref->u.c.component->ts,
5668 0 : &rref->u.c.sym->ts))
5669 : return 1;
5670 0 : if (gfc_compare_types (&lref->u.c.sym->ts,
5671 0 : &rref->u.c.component->ts))
5672 : return 1;
5673 0 : if (gfc_compare_types (&lref->u.c.component->ts,
5674 0 : &rref->u.c.component->ts))
5675 : return 1;
5676 : }
5677 : }
5678 : }
5679 :
5680 1583 : lsym_pointer = lsym->attr.pointer;
5681 1583 : lsym_target = lsym->attr.target;
5682 :
5683 2388 : for (rref = rexpr->ref; rref != rss->info->data.array.ref; rref = rref->next)
5684 : {
5685 958 : if (rref->type != REF_COMPONENT)
5686 : break;
5687 :
5688 811 : rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
5689 811 : rsym_target = lsym_target || rref->u.c.sym->attr.target;
5690 :
5691 811 : if (symbols_could_alias (rref->u.c.sym, lsym,
5692 : lsym_pointer, lsym_target,
5693 : rsym_pointer, rsym_target))
5694 : return 1;
5695 :
5696 811 : if ((lsym_pointer && (rsym_pointer || rsym_target))
5697 793 : || (rsym_pointer && (lsym_pointer || lsym_target)))
5698 : {
5699 6 : if (gfc_compare_types (&lsym->ts, &rref->u.c.component->ts))
5700 : return 1;
5701 : }
5702 : }
5703 :
5704 : return 0;
5705 : }
5706 :
5707 :
5708 : /* Resolve array data dependencies. Creates a temporary if required. */
5709 : /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
5710 : dependency.cc. */
5711 :
5712 : void
5713 37377 : gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
5714 : gfc_ss * rss)
5715 : {
5716 37377 : gfc_ss *ss;
5717 37377 : gfc_ref *lref;
5718 37377 : gfc_ref *rref;
5719 37377 : gfc_ss_info *ss_info;
5720 37377 : gfc_expr *dest_expr;
5721 37377 : gfc_expr *ss_expr;
5722 37377 : int nDepend = 0;
5723 37377 : int i, j;
5724 :
5725 37377 : loop->temp_ss = NULL;
5726 37377 : dest_expr = dest->info->expr;
5727 :
5728 80509 : for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
5729 : {
5730 44269 : ss_info = ss->info;
5731 44269 : ss_expr = ss_info->expr;
5732 :
5733 44269 : if (ss_info->array_outer_dependency)
5734 : {
5735 : nDepend = 1;
5736 : break;
5737 : }
5738 :
5739 44158 : if (ss_info->type != GFC_SS_SECTION)
5740 : {
5741 30187 : if (flag_realloc_lhs
5742 29155 : && dest_expr != ss_expr
5743 29155 : && gfc_is_reallocatable_lhs (dest_expr)
5744 37145 : && ss_expr->rank)
5745 3300 : nDepend = gfc_check_dependency (dest_expr, ss_expr, true);
5746 :
5747 : /* Check for cases like c(:)(1:2) = c(2)(2:3) */
5748 30187 : if (!nDepend && dest_expr->rank > 0
5749 29707 : && dest_expr->ts.type == BT_CHARACTER
5750 4748 : && ss_expr->expr_type == EXPR_VARIABLE)
5751 :
5752 165 : nDepend = gfc_check_dependency (dest_expr, ss_expr, false);
5753 :
5754 30187 : if (ss_info->type == GFC_SS_REFERENCE
5755 30187 : && gfc_check_dependency (dest_expr, ss_expr, false))
5756 182 : ss_info->data.scalar.needs_temporary = 1;
5757 :
5758 30187 : if (nDepend)
5759 : break;
5760 : else
5761 29695 : continue;
5762 : }
5763 :
5764 13971 : if (dest_expr->symtree->n.sym != ss_expr->symtree->n.sym)
5765 : {
5766 11360 : if (gfc_could_be_alias (dest, ss)
5767 11360 : || gfc_are_equivalenced_arrays (dest_expr, ss_expr))
5768 : {
5769 : nDepend = 1;
5770 : break;
5771 : }
5772 : }
5773 : else
5774 : {
5775 2611 : lref = dest_expr->ref;
5776 2611 : rref = ss_expr->ref;
5777 :
5778 2611 : nDepend = gfc_dep_resolver (lref, rref, &loop->reverse[0]);
5779 :
5780 2611 : if (nDepend == 1)
5781 : break;
5782 :
5783 5210 : for (i = 0; i < dest->dimen; i++)
5784 7202 : for (j = 0; j < ss->dimen; j++)
5785 4314 : if (i != j
5786 1363 : && dest->dim[i] == ss->dim[j])
5787 : {
5788 : /* If we don't access array elements in the same order,
5789 : there is a dependency. */
5790 63 : nDepend = 1;
5791 63 : goto temporary;
5792 : }
5793 : #if 0
5794 : /* TODO : loop shifting. */
5795 : if (nDepend == 1)
5796 : {
5797 : /* Mark the dimensions for LOOP SHIFTING */
5798 : for (n = 0; n < loop->dimen; n++)
5799 : {
5800 : int dim = dest->data.info.dim[n];
5801 :
5802 : if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
5803 : depends[n] = 2;
5804 : else if (! gfc_is_same_range (&lref->u.ar,
5805 : &rref->u.ar, dim, 0))
5806 : depends[n] = 1;
5807 : }
5808 :
5809 : /* Put all the dimensions with dependencies in the
5810 : innermost loops. */
5811 : dim = 0;
5812 : for (n = 0; n < loop->dimen; n++)
5813 : {
5814 : gcc_assert (loop->order[n] == n);
5815 : if (depends[n])
5816 : loop->order[dim++] = n;
5817 : }
5818 : for (n = 0; n < loop->dimen; n++)
5819 : {
5820 : if (! depends[n])
5821 : loop->order[dim++] = n;
5822 : }
5823 :
5824 : gcc_assert (dim == loop->dimen);
5825 : break;
5826 : }
5827 : #endif
5828 : }
5829 : }
5830 :
5831 781 : temporary:
5832 :
5833 37377 : if (nDepend == 1)
5834 : {
5835 1137 : tree base_type = gfc_typenode_for_spec (&dest_expr->ts);
5836 1137 : if (GFC_ARRAY_TYPE_P (base_type)
5837 1137 : || GFC_DESCRIPTOR_TYPE_P (base_type))
5838 0 : base_type = gfc_get_element_type (base_type);
5839 1137 : loop->temp_ss = gfc_get_temp_ss (base_type, dest->info->string_length,
5840 : loop->dimen);
5841 1137 : gfc_add_ss_to_loop (loop, loop->temp_ss);
5842 : }
5843 : else
5844 36240 : loop->temp_ss = NULL;
5845 37377 : }
5846 :
5847 :
5848 : /* Browse through each array's information from the scalarizer and set the loop
5849 : bounds according to the "best" one (per dimension), i.e. the one which
5850 : provides the most information (constant bounds, shape, etc.). */
5851 :
5852 : static void
5853 180150 : set_loop_bounds (gfc_loopinfo *loop)
5854 : {
5855 180150 : int n, dim, spec_dim;
5856 180150 : gfc_array_info *info;
5857 180150 : gfc_array_info *specinfo;
5858 180150 : gfc_ss *ss;
5859 180150 : tree tmp;
5860 180150 : gfc_ss **loopspec;
5861 180150 : bool dynamic[GFC_MAX_DIMENSIONS];
5862 180150 : mpz_t *cshape;
5863 180150 : mpz_t i;
5864 180150 : bool nonoptional_arr;
5865 :
5866 180150 : gfc_loopinfo * const outer_loop = outermost_loop (loop);
5867 :
5868 180150 : loopspec = loop->specloop;
5869 :
5870 180150 : mpz_init (i);
5871 425544 : for (n = 0; n < loop->dimen; n++)
5872 : {
5873 245394 : loopspec[n] = NULL;
5874 245394 : dynamic[n] = false;
5875 :
5876 : /* If there are both optional and nonoptional array arguments, scalarize
5877 : over the nonoptional; otherwise, it does not matter as then all
5878 : (optional) arrays have to be present per F2008, 125.2.12p3(6). */
5879 :
5880 245394 : nonoptional_arr = false;
5881 :
5882 286040 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5883 286020 : if (ss->info->type != GFC_SS_SCALAR && ss->info->type != GFC_SS_TEMP
5884 251941 : && ss->info->type != GFC_SS_REFERENCE && !ss->info->can_be_null_ref)
5885 : {
5886 : nonoptional_arr = true;
5887 : break;
5888 : }
5889 :
5890 : /* We use one SS term, and use that to determine the bounds of the
5891 : loop for this dimension. We try to pick the simplest term. */
5892 642508 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5893 : {
5894 397114 : gfc_ss_type ss_type;
5895 :
5896 397114 : ss_type = ss->info->type;
5897 466190 : if (ss_type == GFC_SS_SCALAR
5898 397114 : || ss_type == GFC_SS_TEMP
5899 337284 : || ss_type == GFC_SS_REFERENCE
5900 328315 : || (ss->info->can_be_null_ref && nonoptional_arr))
5901 69076 : continue;
5902 :
5903 328038 : info = &ss->info->data.array;
5904 328038 : dim = ss->dim[n];
5905 :
5906 328038 : if (loopspec[n] != NULL)
5907 : {
5908 82644 : specinfo = &loopspec[n]->info->data.array;
5909 82644 : spec_dim = loopspec[n]->dim[n];
5910 : }
5911 : else
5912 : {
5913 : /* Silence uninitialized warnings. */
5914 : specinfo = NULL;
5915 : spec_dim = 0;
5916 : }
5917 :
5918 328038 : if (info->shape)
5919 : {
5920 : /* The frontend has worked out the size for us. */
5921 222155 : if (!loopspec[n]
5922 58560 : || !specinfo->shape
5923 268295 : || !integer_zerop (specinfo->start[spec_dim]))
5924 : /* Prefer zero-based descriptors if possible. */
5925 205340 : loopspec[n] = ss;
5926 222155 : continue;
5927 : }
5928 :
5929 105883 : if (ss_type == GFC_SS_CONSTRUCTOR)
5930 : {
5931 1342 : gfc_constructor_base base;
5932 : /* An unknown size constructor will always be rank one.
5933 : Higher rank constructors will either have known shape,
5934 : or still be wrapped in a call to reshape. */
5935 1342 : gcc_assert (loop->dimen == 1);
5936 :
5937 : /* Always prefer to use the constructor bounds if the size
5938 : can be determined at compile time. Prefer not to otherwise,
5939 : since the general case involves realloc, and it's better to
5940 : avoid that overhead if possible. */
5941 1342 : base = ss->info->expr->value.constructor;
5942 1342 : dynamic[n] = gfc_get_array_constructor_size (&i, base);
5943 1342 : if (!dynamic[n] || !loopspec[n])
5944 1155 : loopspec[n] = ss;
5945 1342 : continue;
5946 1342 : }
5947 :
5948 : /* Avoid using an allocatable lhs in an assignment, since
5949 : there might be a reallocation coming. */
5950 104541 : if (loopspec[n] && ss->is_alloc_lhs)
5951 9299 : continue;
5952 :
5953 95242 : if (!loopspec[n])
5954 80644 : loopspec[n] = ss;
5955 : /* Criteria for choosing a loop specifier (most important first):
5956 : doesn't need realloc
5957 : stride of one
5958 : known stride
5959 : known lower bound
5960 : known upper bound
5961 : */
5962 14598 : else if (loopspec[n]->info->type == GFC_SS_CONSTRUCTOR && dynamic[n])
5963 180 : loopspec[n] = ss;
5964 14418 : else if (integer_onep (info->stride[dim])
5965 14418 : && !integer_onep (specinfo->stride[spec_dim]))
5966 120 : loopspec[n] = ss;
5967 14298 : else if (INTEGER_CST_P (info->stride[dim])
5968 14074 : && !INTEGER_CST_P (specinfo->stride[spec_dim]))
5969 0 : loopspec[n] = ss;
5970 14298 : else if (INTEGER_CST_P (info->start[dim])
5971 4345 : && !INTEGER_CST_P (specinfo->start[spec_dim])
5972 844 : && integer_onep (info->stride[dim])
5973 422 : == integer_onep (specinfo->stride[spec_dim])
5974 14298 : && INTEGER_CST_P (info->stride[dim])
5975 395 : == INTEGER_CST_P (specinfo->stride[spec_dim]))
5976 395 : loopspec[n] = ss;
5977 : /* We don't work out the upper bound.
5978 : else if (INTEGER_CST_P (info->finish[n])
5979 : && ! INTEGER_CST_P (specinfo->finish[n]))
5980 : loopspec[n] = ss; */
5981 : }
5982 :
5983 : /* We should have found the scalarization loop specifier. If not,
5984 : that's bad news. */
5985 245394 : gcc_assert (loopspec[n]);
5986 :
5987 245394 : info = &loopspec[n]->info->data.array;
5988 245394 : dim = loopspec[n]->dim[n];
5989 :
5990 : /* Set the extents of this range. */
5991 245394 : cshape = info->shape;
5992 245394 : if (cshape && INTEGER_CST_P (info->start[dim])
5993 175816 : && INTEGER_CST_P (info->stride[dim]))
5994 : {
5995 175816 : loop->from[n] = info->start[dim];
5996 175816 : mpz_set (i, cshape[get_array_ref_dim_for_loop_dim (loopspec[n], n)]);
5997 175816 : mpz_sub_ui (i, i, 1);
5998 : /* To = from + (size - 1) * stride. */
5999 175816 : tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
6000 175816 : if (!integer_onep (info->stride[dim]))
6001 8611 : tmp = fold_build2_loc (input_location, MULT_EXPR,
6002 : gfc_array_index_type, tmp,
6003 : info->stride[dim]);
6004 175816 : loop->to[n] = fold_build2_loc (input_location, PLUS_EXPR,
6005 : gfc_array_index_type,
6006 : loop->from[n], tmp);
6007 : }
6008 : else
6009 : {
6010 69578 : loop->from[n] = info->start[dim];
6011 69578 : switch (loopspec[n]->info->type)
6012 : {
6013 874 : case GFC_SS_CONSTRUCTOR:
6014 : /* The upper bound is calculated when we expand the
6015 : constructor. */
6016 874 : gcc_assert (loop->to[n] == NULL_TREE);
6017 : break;
6018 :
6019 63218 : case GFC_SS_SECTION:
6020 : /* Use the end expression if it exists and is not constant,
6021 : so that it is only evaluated once. */
6022 63218 : loop->to[n] = info->end[dim];
6023 63218 : break;
6024 :
6025 4719 : case GFC_SS_FUNCTION:
6026 : /* The loop bound will be set when we generate the call. */
6027 4719 : gcc_assert (loop->to[n] == NULL_TREE);
6028 : break;
6029 :
6030 755 : case GFC_SS_INTRINSIC:
6031 755 : {
6032 755 : gfc_expr *expr = loopspec[n]->info->expr;
6033 :
6034 : /* The {l,u}bound of an assumed rank. */
6035 755 : if (expr->value.function.isym->id == GFC_ISYM_SHAPE)
6036 243 : gcc_assert (expr->value.function.actual->expr->rank == -1);
6037 : else
6038 512 : gcc_assert ((expr->value.function.isym->id == GFC_ISYM_LBOUND
6039 : || expr->value.function.isym->id == GFC_ISYM_UBOUND)
6040 : && expr->value.function.actual->next->expr == NULL
6041 : && expr->value.function.actual->expr->rank == -1);
6042 :
6043 755 : loop->to[n] = info->end[dim];
6044 755 : break;
6045 : }
6046 :
6047 12 : case GFC_SS_COMPONENT:
6048 12 : {
6049 12 : if (info->end[dim] != NULL_TREE)
6050 : {
6051 12 : loop->to[n] = info->end[dim];
6052 12 : break;
6053 : }
6054 : else
6055 0 : gcc_unreachable ();
6056 : }
6057 :
6058 0 : default:
6059 0 : gcc_unreachable ();
6060 : }
6061 : }
6062 :
6063 : /* Transform everything so we have a simple incrementing variable. */
6064 245394 : if (integer_onep (info->stride[dim]))
6065 234668 : info->delta[dim] = gfc_index_zero_node;
6066 : else
6067 : {
6068 : /* Set the delta for this section. */
6069 10726 : info->delta[dim] = gfc_evaluate_now (loop->from[n], &outer_loop->pre);
6070 : /* Number of iterations is (end - start + step) / step.
6071 : with start = 0, this simplifies to
6072 : last = end / step;
6073 : for (i = 0; i<=last; i++){...}; */
6074 10726 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
6075 : gfc_array_index_type, loop->to[n],
6076 : loop->from[n]);
6077 10726 : tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
6078 : gfc_array_index_type, tmp, info->stride[dim]);
6079 10726 : tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
6080 : tmp, build_int_cst (gfc_array_index_type, -1));
6081 10726 : loop->to[n] = gfc_evaluate_now (tmp, &outer_loop->pre);
6082 : /* Make the loop variable start at 0. */
6083 10726 : loop->from[n] = gfc_index_zero_node;
6084 : }
6085 : }
6086 180150 : mpz_clear (i);
6087 :
6088 183514 : for (loop = loop->nested; loop; loop = loop->next)
6089 3364 : set_loop_bounds (loop);
6090 180150 : }
6091 :
6092 :
6093 : /* Last attempt to set the loop bounds, in case they depend on an allocatable
6094 : function result. */
6095 :
6096 : static void
6097 180150 : late_set_loop_bounds (gfc_loopinfo *loop)
6098 : {
6099 180150 : int n, dim;
6100 180150 : gfc_array_info *info;
6101 180150 : gfc_ss **loopspec;
6102 :
6103 180150 : loopspec = loop->specloop;
6104 :
6105 425544 : for (n = 0; n < loop->dimen; n++)
6106 : {
6107 : /* Set the extents of this range. */
6108 245394 : if (loop->from[n] == NULL_TREE
6109 245394 : || loop->to[n] == NULL_TREE)
6110 : {
6111 : /* We should have found the scalarization loop specifier. If not,
6112 : that's bad news. */
6113 419 : gcc_assert (loopspec[n]);
6114 :
6115 419 : info = &loopspec[n]->info->data.array;
6116 419 : dim = loopspec[n]->dim[n];
6117 :
6118 419 : if (loopspec[n]->info->type == GFC_SS_FUNCTION
6119 419 : && info->start[dim]
6120 419 : && info->end[dim])
6121 : {
6122 153 : loop->from[n] = info->start[dim];
6123 153 : loop->to[n] = info->end[dim];
6124 : }
6125 : }
6126 : }
6127 :
6128 183514 : for (loop = loop->nested; loop; loop = loop->next)
6129 3364 : late_set_loop_bounds (loop);
6130 180150 : }
6131 :
6132 :
6133 : /* Initialize the scalarization loop. Creates the loop variables. Determines
6134 : the range of the loop variables. Creates a temporary if required.
6135 : Also generates code for scalar expressions which have been
6136 : moved outside the loop. */
6137 :
6138 : void
6139 176786 : gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
6140 : {
6141 176786 : gfc_ss *tmp_ss;
6142 176786 : tree tmp;
6143 :
6144 176786 : set_loop_bounds (loop);
6145 :
6146 : /* Add all the scalar code that can be taken out of the loops.
6147 : This may include calculating the loop bounds, so do it before
6148 : allocating the temporary. */
6149 176786 : gfc_add_loop_ss_code (loop, loop->ss, false, where);
6150 :
6151 176786 : late_set_loop_bounds (loop);
6152 :
6153 176786 : tmp_ss = loop->temp_ss;
6154 : /* If we want a temporary then create it. */
6155 176786 : if (tmp_ss != NULL)
6156 : {
6157 10990 : gfc_ss_info *tmp_ss_info;
6158 :
6159 10990 : tmp_ss_info = tmp_ss->info;
6160 10990 : gcc_assert (tmp_ss_info->type == GFC_SS_TEMP);
6161 10990 : gcc_assert (loop->parent == NULL);
6162 :
6163 : /* Make absolutely sure that this is a complete type. */
6164 10990 : if (tmp_ss_info->string_length)
6165 2753 : tmp_ss_info->data.temp.type
6166 2753 : = gfc_get_character_type_len_for_eltype
6167 2753 : (TREE_TYPE (tmp_ss_info->data.temp.type),
6168 : tmp_ss_info->string_length);
6169 :
6170 10990 : tmp = tmp_ss_info->data.temp.type;
6171 10990 : memset (&tmp_ss_info->data.array, 0, sizeof (gfc_array_info));
6172 10990 : tmp_ss_info->type = GFC_SS_SECTION;
6173 :
6174 10990 : gcc_assert (tmp_ss->dimen != 0);
6175 :
6176 10990 : gfc_trans_create_temp_array (&loop->pre, &loop->post, tmp_ss, tmp,
6177 : NULL_TREE, false, true, false, where);
6178 : }
6179 :
6180 : /* For array parameters we don't have loop variables, so don't calculate the
6181 : translations. */
6182 176786 : if (!loop->array_parameter)
6183 110567 : gfc_set_delta (loop);
6184 176786 : }
6185 :
6186 :
6187 : /* Calculates how to transform from loop variables to array indices for each
6188 : array: once loop bounds are chosen, sets the difference (DELTA field) between
6189 : loop bounds and array reference bounds, for each array info. */
6190 :
6191 : void
6192 114362 : gfc_set_delta (gfc_loopinfo *loop)
6193 : {
6194 114362 : gfc_ss *ss, **loopspec;
6195 114362 : gfc_array_info *info;
6196 114362 : tree tmp;
6197 114362 : int n, dim;
6198 :
6199 114362 : gfc_loopinfo * const outer_loop = outermost_loop (loop);
6200 :
6201 114362 : loopspec = loop->specloop;
6202 :
6203 : /* Calculate the translation from loop variables to array indices. */
6204 346806 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
6205 : {
6206 232444 : gfc_ss_type ss_type;
6207 :
6208 232444 : ss_type = ss->info->type;
6209 60198 : if (!(ss_type == GFC_SS_SECTION
6210 232444 : || ss_type == GFC_SS_COMPONENT
6211 95219 : || ss_type == GFC_SS_CONSTRUCTOR
6212 : || (ss_type == GFC_SS_FUNCTION
6213 8201 : && gfc_is_class_array_function (ss->info->expr))))
6214 60046 : continue;
6215 :
6216 172398 : info = &ss->info->data.array;
6217 :
6218 388854 : for (n = 0; n < ss->dimen; n++)
6219 : {
6220 : /* If we are specifying the range the delta is already set. */
6221 216456 : if (loopspec[n] != ss)
6222 : {
6223 112601 : dim = ss->dim[n];
6224 :
6225 : /* Calculate the offset relative to the loop variable.
6226 : First multiply by the stride. */
6227 112601 : tmp = loop->from[n];
6228 112601 : if (!integer_onep (info->stride[dim]))
6229 2988 : tmp = fold_build2_loc (input_location, MULT_EXPR,
6230 : gfc_array_index_type,
6231 : tmp, info->stride[dim]);
6232 :
6233 : /* Then subtract this from our starting value. */
6234 112601 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
6235 : gfc_array_index_type,
6236 : info->start[dim], tmp);
6237 :
6238 112601 : if (ss->is_alloc_lhs)
6239 9299 : info->delta[dim] = tmp;
6240 : else
6241 103302 : info->delta[dim] = gfc_evaluate_now (tmp, &outer_loop->pre);
6242 : }
6243 : }
6244 : }
6245 :
6246 117814 : for (loop = loop->nested; loop; loop = loop->next)
6247 3452 : gfc_set_delta (loop);
6248 114362 : }
6249 :
6250 :
6251 : /* Calculate the size of a given array dimension from the bounds. This
6252 : is simply (ubound - lbound + 1) if this expression is positive
6253 : or 0 if it is negative (pick either one if it is zero). Optionally
6254 : (if or_expr is present) OR the (expression != 0) condition to it. */
6255 :
6256 : tree
6257 22947 : gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr)
6258 : {
6259 22947 : tree res;
6260 22947 : tree cond;
6261 :
6262 : /* Calculate (ubound - lbound + 1). */
6263 22947 : res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6264 : ubound, lbound);
6265 22947 : res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res,
6266 : gfc_index_one_node);
6267 :
6268 : /* Check whether the size for this dimension is negative. */
6269 22947 : cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, res,
6270 : gfc_index_zero_node);
6271 22947 : res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
6272 : gfc_index_zero_node, res);
6273 :
6274 : /* Build OR expression. */
6275 22947 : if (or_expr)
6276 17611 : *or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
6277 : logical_type_node, *or_expr, cond);
6278 :
6279 22947 : return res;
6280 : }
6281 :
6282 :
6283 : /* For an array descriptor, get the total number of elements. This is just
6284 : the product of the extents along from_dim to to_dim. */
6285 :
6286 : static tree
6287 1930 : gfc_conv_descriptor_size_1 (tree desc, int from_dim, int to_dim)
6288 : {
6289 1930 : tree res;
6290 1930 : int dim;
6291 :
6292 1930 : res = gfc_index_one_node;
6293 :
6294 4729 : for (dim = from_dim; dim < to_dim; ++dim)
6295 : {
6296 2799 : tree lbound;
6297 2799 : tree ubound;
6298 2799 : tree extent;
6299 :
6300 2799 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
6301 2799 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
6302 :
6303 2799 : extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
6304 2799 : res = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6305 : res, extent);
6306 : }
6307 :
6308 1930 : return res;
6309 : }
6310 :
6311 :
6312 : /* Full size of an array. */
6313 :
6314 : tree
6315 1866 : gfc_conv_descriptor_size (tree desc, int rank)
6316 : {
6317 1866 : return gfc_conv_descriptor_size_1 (desc, 0, rank);
6318 : }
6319 :
6320 :
6321 : /* Size of a coarray for all dimensions but the last. */
6322 :
6323 : tree
6324 64 : gfc_conv_descriptor_cosize (tree desc, int rank, int corank)
6325 : {
6326 64 : return gfc_conv_descriptor_size_1 (desc, rank, rank + corank - 1);
6327 : }
6328 :
6329 :
6330 : /* Fills in an array descriptor, and returns the size of the array.
6331 : The size will be a simple_val, ie a variable or a constant. Also
6332 : calculates the offset of the base. The pointer argument overflow,
6333 : which should be of integer type, will increase in value if overflow
6334 : occurs during the size calculation. Returns the size of the array.
6335 : {
6336 : stride = 1;
6337 : offset = 0;
6338 : for (n = 0; n < rank; n++)
6339 : {
6340 : a.lbound[n] = specified_lower_bound;
6341 : offset = offset + a.lbond[n] * stride;
6342 : size = 1 - lbound;
6343 : a.ubound[n] = specified_upper_bound;
6344 : a.stride[n] = stride;
6345 : size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
6346 : overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
6347 : stride = stride * size;
6348 : }
6349 : for (n = rank; n < rank+corank; n++)
6350 : (Set lcobound/ucobound as above.)
6351 : element_size = sizeof (array element);
6352 : if (!rank)
6353 : return element_size
6354 : stride = (size_t) stride;
6355 : overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
6356 : stride = stride * element_size;
6357 : return (stride);
6358 : } */
6359 : /*GCC ARRAYS*/
6360 :
6361 : static tree
6362 11980 : gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
6363 : gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
6364 : stmtblock_t * descriptor_block, tree * overflow,
6365 : tree expr3_elem_size, gfc_expr *expr3, tree expr3_desc,
6366 : bool e3_has_nodescriptor, gfc_expr *expr,
6367 : tree *element_size, bool explicit_ts)
6368 : {
6369 11980 : tree type;
6370 11980 : tree tmp;
6371 11980 : tree size;
6372 11980 : tree offset;
6373 11980 : tree stride;
6374 11980 : tree or_expr;
6375 11980 : tree thencase;
6376 11980 : tree elsecase;
6377 11980 : tree cond;
6378 11980 : tree var;
6379 11980 : stmtblock_t thenblock;
6380 11980 : stmtblock_t elseblock;
6381 11980 : gfc_expr *ubound;
6382 11980 : gfc_se se;
6383 11980 : int n;
6384 :
6385 11980 : type = TREE_TYPE (descriptor);
6386 :
6387 11980 : stride = gfc_index_one_node;
6388 11980 : offset = gfc_index_zero_node;
6389 :
6390 : /* Set the dtype before the alloc, because registration of coarrays needs
6391 : it initialized. */
6392 11980 : if (expr->ts.type == BT_CHARACTER
6393 1079 : && expr->ts.deferred
6394 545 : && VAR_P (expr->ts.u.cl->backend_decl))
6395 : {
6396 366 : type = gfc_typenode_for_spec (&expr->ts);
6397 366 : tmp = gfc_conv_descriptor_dtype (descriptor);
6398 366 : gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type));
6399 : }
6400 11614 : else if (expr->ts.type == BT_CHARACTER
6401 713 : && expr->ts.deferred
6402 179 : && TREE_CODE (descriptor) == COMPONENT_REF)
6403 : {
6404 : /* Deferred character components have their string length tucked away
6405 : in a hidden field of the derived type. Obtain that and use it to
6406 : set the dtype. The charlen backend decl is zero because the field
6407 : type is zero length. */
6408 161 : gfc_ref *ref;
6409 161 : tmp = NULL_TREE;
6410 161 : for (ref = expr->ref; ref; ref = ref->next)
6411 161 : if (ref->type == REF_COMPONENT
6412 161 : && gfc_deferred_strlen (ref->u.c.component, &tmp))
6413 : break;
6414 161 : gcc_assert (tmp != NULL_TREE);
6415 161 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
6416 161 : TREE_OPERAND (descriptor, 0), tmp, NULL_TREE);
6417 161 : tmp = fold_convert (gfc_charlen_type_node, tmp);
6418 161 : type = gfc_get_character_type_len (expr->ts.kind, tmp);
6419 161 : tmp = gfc_conv_descriptor_dtype (descriptor);
6420 161 : gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type));
6421 161 : }
6422 11453 : else if (expr3_desc && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr3_desc)))
6423 : {
6424 927 : tmp = gfc_conv_descriptor_dtype (descriptor);
6425 927 : gfc_add_modify (pblock, tmp, gfc_conv_descriptor_dtype (expr3_desc));
6426 : }
6427 10526 : else if (expr->ts.type == BT_CLASS && !explicit_ts
6428 1258 : && expr3 && expr3->ts.type != BT_CLASS
6429 343 : && expr3_elem_size != NULL_TREE && expr3_desc == NULL_TREE)
6430 : {
6431 343 : tmp = gfc_conv_descriptor_elem_len (descriptor);
6432 343 : gfc_add_modify (pblock, tmp,
6433 343 : fold_convert (TREE_TYPE (tmp), expr3_elem_size));
6434 : }
6435 : else
6436 : {
6437 10183 : tmp = gfc_conv_descriptor_dtype (descriptor);
6438 10183 : gfc_add_modify (pblock, tmp, gfc_get_dtype (type));
6439 : }
6440 :
6441 11980 : or_expr = logical_false_node;
6442 :
6443 29591 : for (n = 0; n < rank; n++)
6444 : {
6445 17611 : tree conv_lbound;
6446 17611 : tree conv_ubound;
6447 :
6448 : /* We have 3 possibilities for determining the size of the array:
6449 : lower == NULL => lbound = 1, ubound = upper[n]
6450 : upper[n] = NULL => lbound = 1, ubound = lower[n]
6451 : upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
6452 17611 : ubound = upper[n];
6453 :
6454 : /* Set lower bound. */
6455 17611 : gfc_init_se (&se, NULL);
6456 17611 : if (expr3_desc != NULL_TREE)
6457 : {
6458 1470 : if (e3_has_nodescriptor)
6459 : /* The lbound of nondescriptor arrays like array constructors,
6460 : nonallocatable/nonpointer function results/variables,
6461 : start at zero, but when allocating it, the standard expects
6462 : the array to start at one. */
6463 967 : se.expr = gfc_index_one_node;
6464 : else
6465 503 : se.expr = gfc_conv_descriptor_lbound_get (expr3_desc,
6466 : gfc_rank_cst[n]);
6467 : }
6468 16141 : else if (lower == NULL)
6469 12988 : se.expr = gfc_index_one_node;
6470 : else
6471 : {
6472 3153 : gcc_assert (lower[n]);
6473 3153 : if (ubound)
6474 : {
6475 2430 : gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
6476 2430 : gfc_add_block_to_block (pblock, &se.pre);
6477 : }
6478 : else
6479 : {
6480 723 : se.expr = gfc_index_one_node;
6481 723 : ubound = lower[n];
6482 : }
6483 : }
6484 17611 : gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
6485 : gfc_rank_cst[n], se.expr);
6486 17611 : conv_lbound = se.expr;
6487 :
6488 : /* Work out the offset for this component. */
6489 17611 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6490 : se.expr, stride);
6491 17611 : offset = fold_build2_loc (input_location, MINUS_EXPR,
6492 : gfc_array_index_type, offset, tmp);
6493 :
6494 : /* Set upper bound. */
6495 17611 : gfc_init_se (&se, NULL);
6496 17611 : if (expr3_desc != NULL_TREE)
6497 : {
6498 1470 : if (e3_has_nodescriptor)
6499 : {
6500 : /* The lbound of nondescriptor arrays like array constructors,
6501 : nonallocatable/nonpointer function results/variables,
6502 : start at zero, but when allocating it, the standard expects
6503 : the array to start at one. Therefore fix the upper bound to be
6504 : (desc.ubound - desc.lbound) + 1. */
6505 967 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
6506 : gfc_array_index_type,
6507 : gfc_conv_descriptor_ubound_get (
6508 : expr3_desc, gfc_rank_cst[n]),
6509 : gfc_conv_descriptor_lbound_get (
6510 : expr3_desc, gfc_rank_cst[n]));
6511 967 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
6512 : gfc_array_index_type, tmp,
6513 : gfc_index_one_node);
6514 967 : se.expr = gfc_evaluate_now (tmp, pblock);
6515 : }
6516 : else
6517 503 : se.expr = gfc_conv_descriptor_ubound_get (expr3_desc,
6518 : gfc_rank_cst[n]);
6519 : }
6520 : else
6521 : {
6522 16141 : gcc_assert (ubound);
6523 16141 : gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
6524 16141 : gfc_add_block_to_block (pblock, &se.pre);
6525 16141 : if (ubound->expr_type == EXPR_FUNCTION)
6526 744 : se.expr = gfc_evaluate_now (se.expr, pblock);
6527 : }
6528 17611 : gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
6529 : gfc_rank_cst[n], se.expr);
6530 17611 : conv_ubound = se.expr;
6531 :
6532 : /* Store the stride. */
6533 17611 : gfc_conv_descriptor_stride_set (descriptor_block, descriptor,
6534 : gfc_rank_cst[n], stride);
6535 :
6536 : /* Calculate size and check whether extent is negative. */
6537 17611 : size = gfc_conv_array_extent_dim (conv_lbound, conv_ubound, &or_expr);
6538 17611 : size = gfc_evaluate_now (size, pblock);
6539 :
6540 : /* Check whether multiplying the stride by the number of
6541 : elements in this dimension would overflow. We must also check
6542 : whether the current dimension has zero size in order to avoid
6543 : division by zero.
6544 : */
6545 17611 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
6546 : gfc_array_index_type,
6547 17611 : fold_convert (gfc_array_index_type,
6548 : TYPE_MAX_VALUE (gfc_array_index_type)),
6549 : size);
6550 17611 : cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
6551 : logical_type_node, tmp, stride),
6552 : PRED_FORTRAN_OVERFLOW);
6553 17611 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
6554 : integer_one_node, integer_zero_node);
6555 17611 : cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
6556 : logical_type_node, size,
6557 : gfc_index_zero_node),
6558 : PRED_FORTRAN_SIZE_ZERO);
6559 17611 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
6560 : integer_zero_node, tmp);
6561 17611 : tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
6562 : *overflow, tmp);
6563 17611 : *overflow = gfc_evaluate_now (tmp, pblock);
6564 :
6565 : /* Multiply the stride by the number of elements in this dimension. */
6566 17611 : stride = fold_build2_loc (input_location, MULT_EXPR,
6567 : gfc_array_index_type, stride, size);
6568 17611 : stride = gfc_evaluate_now (stride, pblock);
6569 : }
6570 :
6571 12618 : for (n = rank; n < rank + corank; n++)
6572 : {
6573 638 : ubound = upper[n];
6574 :
6575 : /* Set lower bound. */
6576 638 : gfc_init_se (&se, NULL);
6577 638 : if (lower == NULL || lower[n] == NULL)
6578 : {
6579 369 : gcc_assert (n == rank + corank - 1);
6580 369 : se.expr = gfc_index_one_node;
6581 : }
6582 : else
6583 : {
6584 269 : if (ubound || n == rank + corank - 1)
6585 : {
6586 175 : gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
6587 175 : gfc_add_block_to_block (pblock, &se.pre);
6588 : }
6589 : else
6590 : {
6591 94 : se.expr = gfc_index_one_node;
6592 94 : ubound = lower[n];
6593 : }
6594 : }
6595 638 : gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
6596 : gfc_rank_cst[n], se.expr);
6597 :
6598 638 : if (n < rank + corank - 1)
6599 : {
6600 178 : gfc_init_se (&se, NULL);
6601 178 : gcc_assert (ubound);
6602 178 : gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
6603 178 : gfc_add_block_to_block (pblock, &se.pre);
6604 178 : gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
6605 : gfc_rank_cst[n], se.expr);
6606 : }
6607 : }
6608 :
6609 : /* The stride is the number of elements in the array, so multiply by the
6610 : size of an element to get the total size. Obviously, if there is a
6611 : SOURCE expression (expr3) we must use its element size. */
6612 11980 : if (expr3_elem_size != NULL_TREE)
6613 2985 : tmp = expr3_elem_size;
6614 8995 : else if (expr3 != NULL)
6615 : {
6616 0 : if (expr3->ts.type == BT_CLASS)
6617 : {
6618 0 : gfc_se se_sz;
6619 0 : gfc_expr *sz = gfc_copy_expr (expr3);
6620 0 : gfc_add_vptr_component (sz);
6621 0 : gfc_add_size_component (sz);
6622 0 : gfc_init_se (&se_sz, NULL);
6623 0 : gfc_conv_expr (&se_sz, sz);
6624 0 : gfc_free_expr (sz);
6625 0 : tmp = se_sz.expr;
6626 : }
6627 : else
6628 : {
6629 0 : tmp = gfc_typenode_for_spec (&expr3->ts);
6630 0 : tmp = TYPE_SIZE_UNIT (tmp);
6631 : }
6632 : }
6633 : else
6634 8995 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
6635 :
6636 : /* Convert to size_t. */
6637 11980 : *element_size = fold_convert (size_type_node, tmp);
6638 :
6639 11980 : if (rank == 0)
6640 : return *element_size;
6641 :
6642 11780 : stride = fold_convert (size_type_node, stride);
6643 :
6644 : /* First check for overflow. Since an array of type character can
6645 : have zero element_size, we must check for that before
6646 : dividing. */
6647 11780 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
6648 : size_type_node,
6649 11780 : TYPE_MAX_VALUE (size_type_node), *element_size);
6650 11780 : cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
6651 : logical_type_node, tmp, stride),
6652 : PRED_FORTRAN_OVERFLOW);
6653 11780 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
6654 : integer_one_node, integer_zero_node);
6655 11780 : cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
6656 : logical_type_node, *element_size,
6657 : build_int_cst (size_type_node, 0)),
6658 : PRED_FORTRAN_SIZE_ZERO);
6659 11780 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
6660 : integer_zero_node, tmp);
6661 11780 : tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
6662 : *overflow, tmp);
6663 11780 : *overflow = gfc_evaluate_now (tmp, pblock);
6664 :
6665 11780 : size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
6666 : stride, *element_size);
6667 :
6668 11780 : if (poffset != NULL)
6669 : {
6670 11780 : offset = gfc_evaluate_now (offset, pblock);
6671 11780 : *poffset = offset;
6672 : }
6673 :
6674 11780 : if (integer_zerop (or_expr))
6675 : return size;
6676 3582 : if (integer_onep (or_expr))
6677 599 : return build_int_cst (size_type_node, 0);
6678 :
6679 2983 : var = gfc_create_var (TREE_TYPE (size), "size");
6680 2983 : gfc_start_block (&thenblock);
6681 2983 : gfc_add_modify (&thenblock, var, build_int_cst (size_type_node, 0));
6682 2983 : thencase = gfc_finish_block (&thenblock);
6683 :
6684 2983 : gfc_start_block (&elseblock);
6685 2983 : gfc_add_modify (&elseblock, var, size);
6686 2983 : elsecase = gfc_finish_block (&elseblock);
6687 :
6688 2983 : tmp = gfc_evaluate_now (or_expr, pblock);
6689 2983 : tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
6690 2983 : gfc_add_expr_to_block (pblock, tmp);
6691 :
6692 2983 : return var;
6693 : }
6694 :
6695 :
6696 : /* Retrieve the last ref from the chain. This routine is specific to
6697 : gfc_array_allocate ()'s needs. */
6698 :
6699 : bool
6700 18305 : retrieve_last_ref (gfc_ref **ref_in, gfc_ref **prev_ref_in)
6701 : {
6702 18305 : gfc_ref *ref, *prev_ref;
6703 :
6704 18305 : ref = *ref_in;
6705 : /* Prevent warnings for uninitialized variables. */
6706 18305 : prev_ref = *prev_ref_in;
6707 25190 : while (ref && ref->next != NULL)
6708 : {
6709 6885 : gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
6710 : || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
6711 : prev_ref = ref;
6712 : ref = ref->next;
6713 : }
6714 :
6715 18305 : if (ref == NULL || ref->type != REF_ARRAY)
6716 : return false;
6717 :
6718 13192 : *ref_in = ref;
6719 13192 : *prev_ref_in = prev_ref;
6720 13192 : return true;
6721 : }
6722 :
6723 : /* Initializes the descriptor and generates a call to _gfor_allocate. Does
6724 : the work for an ALLOCATE statement. */
6725 : /*GCC ARRAYS*/
6726 :
6727 : bool
6728 17093 : gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
6729 : tree errlen, tree label_finish, tree expr3_elem_size,
6730 : gfc_expr *expr3, tree e3_arr_desc, bool e3_has_nodescriptor,
6731 : gfc_omp_namelist *omp_alloc, bool explicit_ts)
6732 : {
6733 17093 : tree tmp;
6734 17093 : tree pointer;
6735 17093 : tree offset = NULL_TREE;
6736 17093 : tree token = NULL_TREE;
6737 17093 : tree size;
6738 17093 : tree msg;
6739 17093 : tree error = NULL_TREE;
6740 17093 : tree overflow; /* Boolean storing whether size calculation overflows. */
6741 17093 : tree var_overflow = NULL_TREE;
6742 17093 : tree cond;
6743 17093 : tree set_descriptor;
6744 17093 : tree not_prev_allocated = NULL_TREE;
6745 17093 : tree element_size = NULL_TREE;
6746 17093 : stmtblock_t set_descriptor_block;
6747 17093 : stmtblock_t elseblock;
6748 17093 : gfc_expr **lower;
6749 17093 : gfc_expr **upper;
6750 17093 : gfc_ref *ref, *prev_ref = NULL, *coref;
6751 17093 : bool allocatable, coarray, dimension, alloc_w_e3_arr_spec = false,
6752 : non_ulimate_coarray_ptr_comp;
6753 17093 : tree omp_cond = NULL_TREE, omp_alt_alloc = NULL_TREE;
6754 :
6755 17093 : ref = expr->ref;
6756 :
6757 : /* Find the last reference in the chain. */
6758 17093 : if (!retrieve_last_ref (&ref, &prev_ref))
6759 : return false;
6760 :
6761 : /* Take the allocatable and coarray properties solely from the expr-ref's
6762 : attributes and not from source=-expression. */
6763 11980 : if (!prev_ref)
6764 : {
6765 8266 : allocatable = expr->symtree->n.sym->attr.allocatable;
6766 8266 : dimension = expr->symtree->n.sym->attr.dimension;
6767 8266 : non_ulimate_coarray_ptr_comp = false;
6768 : }
6769 : else
6770 : {
6771 3714 : allocatable = prev_ref->u.c.component->attr.allocatable;
6772 : /* Pointer components in coarrayed derived types must be treated
6773 : specially in that they are registered without a check if the are
6774 : already associated. This does not hold for ultimate coarray
6775 : pointers. */
6776 7428 : non_ulimate_coarray_ptr_comp = (prev_ref->u.c.component->attr.pointer
6777 3714 : && !prev_ref->u.c.component->attr.codimension);
6778 3714 : dimension = prev_ref->u.c.component->attr.dimension;
6779 : }
6780 :
6781 : /* For allocatable/pointer arrays in derived types, one of the refs has to be
6782 : a coarray. In this case it does not matter whether we are on this_image
6783 : or not. */
6784 11980 : coarray = false;
6785 28554 : for (coref = expr->ref; coref; coref = coref->next)
6786 17206 : if (coref->type == REF_ARRAY && coref->u.ar.codimen > 0)
6787 : {
6788 : coarray = true;
6789 : break;
6790 : }
6791 :
6792 11980 : if (!dimension)
6793 200 : gcc_assert (coarray);
6794 :
6795 11980 : if (ref->u.ar.type == AR_FULL && expr3 != NULL)
6796 : {
6797 1212 : gfc_ref *old_ref = ref;
6798 : /* F08:C633: Array shape from expr3. */
6799 1212 : ref = expr3->ref;
6800 :
6801 : /* Find the last reference in the chain. */
6802 1212 : if (!retrieve_last_ref (&ref, &prev_ref))
6803 : {
6804 0 : if (expr3->expr_type == EXPR_FUNCTION
6805 0 : && gfc_expr_attr (expr3).dimension)
6806 0 : ref = old_ref;
6807 : else
6808 0 : return false;
6809 : }
6810 : alloc_w_e3_arr_spec = true;
6811 : }
6812 :
6813 : /* Figure out the size of the array. */
6814 11980 : switch (ref->u.ar.type)
6815 : {
6816 9119 : case AR_ELEMENT:
6817 9119 : if (!coarray)
6818 : {
6819 8539 : lower = NULL;
6820 8539 : upper = ref->u.ar.start;
6821 8539 : break;
6822 : }
6823 : /* Fall through. */
6824 :
6825 2260 : case AR_SECTION:
6826 2260 : lower = ref->u.ar.start;
6827 2260 : upper = ref->u.ar.end;
6828 2260 : break;
6829 :
6830 1181 : case AR_FULL:
6831 1181 : gcc_assert (ref->u.ar.as->type == AS_EXPLICIT
6832 : || alloc_w_e3_arr_spec);
6833 :
6834 1181 : lower = ref->u.ar.as->lower;
6835 1181 : upper = ref->u.ar.as->upper;
6836 1181 : break;
6837 :
6838 0 : default:
6839 0 : gcc_unreachable ();
6840 11980 : break;
6841 : }
6842 :
6843 11980 : overflow = integer_zero_node;
6844 :
6845 11980 : if (expr->ts.type == BT_CHARACTER
6846 1079 : && TREE_CODE (se->string_length) == COMPONENT_REF
6847 161 : && expr->ts.u.cl->backend_decl != se->string_length
6848 161 : && VAR_P (expr->ts.u.cl->backend_decl))
6849 0 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
6850 0 : fold_convert (TREE_TYPE (expr->ts.u.cl->backend_decl),
6851 : se->string_length));
6852 :
6853 11980 : gfc_init_block (&set_descriptor_block);
6854 : /* Take the corank only from the actual ref and not from the coref. The
6855 : later will mislead the generation of the array dimensions for allocatable/
6856 : pointer components in derived types. */
6857 23380 : size = gfc_array_init_size (se->expr, alloc_w_e3_arr_spec ? expr->rank
6858 10768 : : ref->u.ar.as->rank,
6859 632 : coarray ? ref->u.ar.as->corank : 0,
6860 : &offset, lower, upper,
6861 : &se->pre, &set_descriptor_block, &overflow,
6862 : expr3_elem_size, expr3, e3_arr_desc,
6863 : e3_has_nodescriptor, expr, &element_size,
6864 : explicit_ts);
6865 :
6866 11980 : if (dimension)
6867 : {
6868 11780 : var_overflow = gfc_create_var (integer_type_node, "overflow");
6869 11780 : gfc_add_modify (&se->pre, var_overflow, overflow);
6870 :
6871 11780 : if (status == NULL_TREE)
6872 : {
6873 : /* Generate the block of code handling overflow. */
6874 11558 : msg = gfc_build_addr_expr (pchar_type_node,
6875 : gfc_build_localized_cstring_const
6876 : ("Integer overflow when calculating the amount of "
6877 : "memory to allocate"));
6878 11558 : error = build_call_expr_loc (input_location,
6879 : gfor_fndecl_runtime_error, 1, msg);
6880 : }
6881 : else
6882 : {
6883 222 : tree status_type = TREE_TYPE (status);
6884 222 : stmtblock_t set_status_block;
6885 :
6886 222 : gfc_start_block (&set_status_block);
6887 222 : gfc_add_modify (&set_status_block, status,
6888 : build_int_cst (status_type, LIBERROR_ALLOCATION));
6889 222 : error = gfc_finish_block (&set_status_block);
6890 : }
6891 : }
6892 :
6893 : /* Allocate memory to store the data. */
6894 11980 : if (POINTER_TYPE_P (TREE_TYPE (se->expr)))
6895 0 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
6896 :
6897 11980 : if (coarray && flag_coarray == GFC_FCOARRAY_LIB)
6898 : {
6899 393 : pointer = non_ulimate_coarray_ptr_comp ? se->expr
6900 321 : : gfc_conv_descriptor_data_get (se->expr);
6901 393 : token = gfc_conv_descriptor_token (se->expr);
6902 393 : token = gfc_build_addr_expr (NULL_TREE, token);
6903 : }
6904 : else
6905 : {
6906 11587 : pointer = gfc_conv_descriptor_data_get (se->expr);
6907 11587 : if (omp_alloc)
6908 33 : omp_cond = boolean_true_node;
6909 : }
6910 11980 : STRIP_NOPS (pointer);
6911 :
6912 11980 : if (allocatable)
6913 : {
6914 9835 : not_prev_allocated = gfc_create_var (logical_type_node,
6915 : "not_prev_allocated");
6916 9835 : tmp = fold_build2_loc (input_location, EQ_EXPR,
6917 : logical_type_node, pointer,
6918 9835 : build_int_cst (TREE_TYPE (pointer), 0));
6919 :
6920 9835 : gfc_add_modify (&se->pre, not_prev_allocated, tmp);
6921 : }
6922 :
6923 11980 : gfc_start_block (&elseblock);
6924 :
6925 11980 : tree succ_add_expr = NULL_TREE;
6926 11980 : if (omp_cond)
6927 : {
6928 33 : tree align, alloc, sz;
6929 33 : gfc_se se2;
6930 33 : if (omp_alloc->u2.allocator)
6931 : {
6932 10 : gfc_init_se (&se2, NULL);
6933 10 : gfc_conv_expr (&se2, omp_alloc->u2.allocator);
6934 10 : gfc_add_block_to_block (&elseblock, &se2.pre);
6935 10 : alloc = gfc_evaluate_now (se2.expr, &elseblock);
6936 10 : gfc_add_block_to_block (&elseblock, &se2.post);
6937 : }
6938 : else
6939 23 : alloc = build_zero_cst (ptr_type_node);
6940 33 : tmp = TREE_TYPE (TREE_TYPE (pointer));
6941 33 : if (tmp == void_type_node)
6942 33 : tmp = gfc_typenode_for_spec (&expr->ts, 0);
6943 33 : if (omp_alloc->u.align)
6944 : {
6945 17 : gfc_init_se (&se2, NULL);
6946 17 : gfc_conv_expr (&se2, omp_alloc->u.align);
6947 17 : gcc_assert (CONSTANT_CLASS_P (se2.expr)
6948 : && se2.pre.head == NULL
6949 : && se2.post.head == NULL);
6950 17 : align = build_int_cst (size_type_node,
6951 17 : MAX (tree_to_uhwi (se2.expr),
6952 : TYPE_ALIGN_UNIT (tmp)));
6953 : }
6954 : else
6955 16 : align = build_int_cst (size_type_node, TYPE_ALIGN_UNIT (tmp));
6956 33 : sz = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
6957 : fold_convert (size_type_node, size),
6958 : build_int_cst (size_type_node, 1));
6959 33 : omp_alt_alloc = builtin_decl_explicit (BUILT_IN_GOMP_ALLOC);
6960 33 : DECL_ATTRIBUTES (omp_alt_alloc)
6961 33 : = tree_cons (get_identifier ("omp allocator"),
6962 : build_tree_list (NULL_TREE, alloc),
6963 33 : DECL_ATTRIBUTES (omp_alt_alloc));
6964 33 : omp_alt_alloc = build_call_expr (omp_alt_alloc, 3, align, sz, alloc);
6965 33 : succ_add_expr = fold_build2_loc (input_location, MODIFY_EXPR,
6966 : void_type_node,
6967 : gfc_conv_descriptor_version (se->expr),
6968 : build_int_cst (integer_type_node, 1));
6969 : }
6970 :
6971 : /* The allocatable variant takes the old pointer as first argument. */
6972 11980 : if (allocatable)
6973 10392 : gfc_allocate_allocatable (&elseblock, pointer, size, token,
6974 : status, errmsg, errlen, label_finish, expr,
6975 557 : coref != NULL ? coref->u.ar.as->corank : 0,
6976 : omp_cond, omp_alt_alloc, succ_add_expr);
6977 2145 : else if (non_ulimate_coarray_ptr_comp && token)
6978 : /* The token is set only for GFC_FCOARRAY_LIB mode. */
6979 72 : gfc_allocate_using_caf_lib (&elseblock, pointer, size, token, status,
6980 : errmsg, errlen,
6981 : GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY);
6982 : else
6983 2073 : gfc_allocate_using_malloc (&elseblock, pointer, size, status,
6984 : omp_cond, omp_alt_alloc, succ_add_expr);
6985 :
6986 11980 : if (dimension)
6987 : {
6988 11780 : cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
6989 : logical_type_node, var_overflow, integer_zero_node),
6990 : PRED_FORTRAN_OVERFLOW);
6991 11780 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6992 : error, gfc_finish_block (&elseblock));
6993 : }
6994 : else
6995 200 : tmp = gfc_finish_block (&elseblock);
6996 :
6997 11980 : gfc_add_expr_to_block (&se->pre, tmp);
6998 :
6999 : /* Update the array descriptor with the offset and the span. */
7000 11980 : if (dimension)
7001 : {
7002 11780 : gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
7003 11780 : tmp = fold_convert (gfc_array_index_type, element_size);
7004 11780 : gfc_conv_descriptor_span_set (&set_descriptor_block, se->expr, tmp);
7005 : }
7006 :
7007 11980 : set_descriptor = gfc_finish_block (&set_descriptor_block);
7008 11980 : if (status != NULL_TREE)
7009 : {
7010 238 : cond = fold_build2_loc (input_location, EQ_EXPR,
7011 : logical_type_node, status,
7012 238 : build_int_cst (TREE_TYPE (status), 0));
7013 :
7014 238 : if (not_prev_allocated != NULL_TREE)
7015 222 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
7016 : logical_type_node, cond, not_prev_allocated);
7017 :
7018 238 : gfc_add_expr_to_block (&se->pre,
7019 : fold_build3_loc (input_location, COND_EXPR, void_type_node,
7020 : cond,
7021 : set_descriptor,
7022 : build_empty_stmt (input_location)));
7023 : }
7024 : else
7025 11742 : gfc_add_expr_to_block (&se->pre, set_descriptor);
7026 :
7027 : return true;
7028 : }
7029 :
7030 :
7031 : /* Create an array constructor from an initialization expression.
7032 : We assume the frontend already did any expansions and conversions. */
7033 :
7034 : tree
7035 7589 : gfc_conv_array_initializer (tree type, gfc_expr * expr)
7036 : {
7037 7589 : gfc_constructor *c;
7038 7589 : tree tmp;
7039 7589 : gfc_se se;
7040 7589 : tree index, range;
7041 7589 : vec<constructor_elt, va_gc> *v = NULL;
7042 :
7043 7589 : if (expr->expr_type == EXPR_VARIABLE
7044 0 : && expr->symtree->n.sym->attr.flavor == FL_PARAMETER
7045 0 : && expr->symtree->n.sym->value)
7046 7589 : expr = expr->symtree->n.sym->value;
7047 :
7048 7589 : switch (expr->expr_type)
7049 : {
7050 1110 : case EXPR_CONSTANT:
7051 1110 : case EXPR_STRUCTURE:
7052 : /* A single scalar or derived type value. Create an array with all
7053 : elements equal to that value. */
7054 1110 : gfc_init_se (&se, NULL);
7055 :
7056 1110 : if (expr->expr_type == EXPR_CONSTANT)
7057 381 : gfc_conv_constant (&se, expr);
7058 : else
7059 729 : gfc_conv_structure (&se, expr, 1);
7060 :
7061 2220 : if (tree_int_cst_lt (TYPE_MAX_VALUE (TYPE_DOMAIN (type)),
7062 1110 : TYPE_MIN_VALUE (TYPE_DOMAIN (type))))
7063 : break;
7064 2196 : else if (tree_int_cst_equal (TYPE_MIN_VALUE (TYPE_DOMAIN (type)),
7065 1098 : TYPE_MAX_VALUE (TYPE_DOMAIN (type))))
7066 146 : range = TYPE_MIN_VALUE (TYPE_DOMAIN (type));
7067 : else
7068 1904 : range = build2 (RANGE_EXPR, gfc_array_index_type,
7069 952 : TYPE_MIN_VALUE (TYPE_DOMAIN (type)),
7070 952 : TYPE_MAX_VALUE (TYPE_DOMAIN (type)));
7071 1098 : CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
7072 1098 : break;
7073 :
7074 6479 : case EXPR_ARRAY:
7075 : /* Create a vector of all the elements. */
7076 6479 : for (c = gfc_constructor_first (expr->value.constructor);
7077 164062 : c && c->expr; c = gfc_constructor_next (c))
7078 : {
7079 157583 : if (c->iterator)
7080 : {
7081 : /* Problems occur when we get something like
7082 : integer :: a(lots) = (/(i, i=1, lots)/) */
7083 0 : gfc_fatal_error ("The number of elements in the array "
7084 : "constructor at %L requires an increase of "
7085 : "the allowed %d upper limit. See "
7086 : "%<-fmax-array-constructor%> option",
7087 : &expr->where, flag_max_array_constructor);
7088 : return NULL_TREE;
7089 : }
7090 157583 : if (mpz_cmp_si (c->offset, 0) != 0)
7091 151364 : index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
7092 : else
7093 : index = NULL_TREE;
7094 :
7095 157583 : if (mpz_cmp_si (c->repeat, 1) > 0)
7096 : {
7097 127 : tree tmp1, tmp2;
7098 127 : mpz_t maxval;
7099 :
7100 127 : mpz_init (maxval);
7101 127 : mpz_add (maxval, c->offset, c->repeat);
7102 127 : mpz_sub_ui (maxval, maxval, 1);
7103 127 : tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
7104 127 : if (mpz_cmp_si (c->offset, 0) != 0)
7105 : {
7106 27 : mpz_add_ui (maxval, c->offset, 1);
7107 27 : tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
7108 : }
7109 : else
7110 100 : tmp1 = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
7111 :
7112 127 : range = fold_build2 (RANGE_EXPR, gfc_array_index_type, tmp1, tmp2);
7113 127 : mpz_clear (maxval);
7114 : }
7115 : else
7116 : range = NULL;
7117 :
7118 157583 : gfc_init_se (&se, NULL);
7119 157583 : switch (c->expr->expr_type)
7120 : {
7121 156170 : case EXPR_CONSTANT:
7122 156170 : gfc_conv_constant (&se, c->expr);
7123 :
7124 : /* See gfortran.dg/charlen_15.f90 for instance. */
7125 156170 : if (TREE_CODE (se.expr) == STRING_CST
7126 5206 : && TREE_CODE (type) == ARRAY_TYPE)
7127 : {
7128 : tree atype = type;
7129 10412 : while (TREE_CODE (TREE_TYPE (atype)) == ARRAY_TYPE)
7130 5206 : atype = TREE_TYPE (atype);
7131 5206 : gcc_checking_assert (TREE_CODE (TREE_TYPE (atype))
7132 : == INTEGER_TYPE);
7133 5206 : gcc_checking_assert (TREE_TYPE (TREE_TYPE (se.expr))
7134 : == TREE_TYPE (atype));
7135 5206 : if (tree_to_uhwi (TYPE_SIZE_UNIT (TREE_TYPE (se.expr)))
7136 5206 : > tree_to_uhwi (TYPE_SIZE_UNIT (atype)))
7137 : {
7138 0 : unsigned HOST_WIDE_INT size
7139 0 : = tree_to_uhwi (TYPE_SIZE_UNIT (atype));
7140 0 : const char *p = TREE_STRING_POINTER (se.expr);
7141 :
7142 0 : se.expr = build_string (size, p);
7143 : }
7144 5206 : TREE_TYPE (se.expr) = atype;
7145 : }
7146 : break;
7147 :
7148 1413 : case EXPR_STRUCTURE:
7149 1413 : gfc_conv_structure (&se, c->expr, 1);
7150 1413 : break;
7151 :
7152 0 : default:
7153 : /* Catch those occasional beasts that do not simplify
7154 : for one reason or another, assuming that if they are
7155 : standard defying the frontend will catch them. */
7156 0 : gfc_conv_expr (&se, c->expr);
7157 0 : break;
7158 : }
7159 :
7160 157583 : if (range == NULL_TREE)
7161 157456 : CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
7162 : else
7163 : {
7164 127 : if (index != NULL_TREE)
7165 27 : CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
7166 157710 : CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
7167 : }
7168 : }
7169 : break;
7170 :
7171 0 : case EXPR_NULL:
7172 0 : return gfc_build_null_descriptor (type);
7173 :
7174 0 : default:
7175 0 : gcc_unreachable ();
7176 : }
7177 :
7178 : /* Create a constructor from the list of elements. */
7179 7589 : tmp = build_constructor (type, v);
7180 7589 : TREE_CONSTANT (tmp) = 1;
7181 7589 : return tmp;
7182 : }
7183 :
7184 :
7185 : /* Generate code to evaluate non-constant coarray cobounds. */
7186 :
7187 : void
7188 20481 : gfc_trans_array_cobounds (tree type, stmtblock_t * pblock,
7189 : const gfc_symbol *sym)
7190 : {
7191 20481 : int dim;
7192 20481 : tree ubound;
7193 20481 : tree lbound;
7194 20481 : gfc_se se;
7195 20481 : gfc_array_spec *as;
7196 :
7197 20481 : as = IS_CLASS_COARRAY_OR_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
7198 :
7199 21457 : for (dim = as->rank; dim < as->rank + as->corank; dim++)
7200 : {
7201 : /* Evaluate non-constant array bound expressions.
7202 : F2008 4.5.6.3 para 6: If a specification expression in a scoping unit
7203 : references a function, the result is finalized before execution of the
7204 : executable constructs in the scoping unit.
7205 : Adding the finalblocks enables this. */
7206 976 : lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
7207 976 : if (as->lower[dim] && !INTEGER_CST_P (lbound))
7208 : {
7209 114 : gfc_init_se (&se, NULL);
7210 114 : gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
7211 114 : gfc_add_block_to_block (pblock, &se.pre);
7212 114 : gfc_add_block_to_block (pblock, &se.finalblock);
7213 114 : gfc_add_modify (pblock, lbound, se.expr);
7214 : }
7215 976 : ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
7216 976 : if (as->upper[dim] && !INTEGER_CST_P (ubound))
7217 : {
7218 60 : gfc_init_se (&se, NULL);
7219 60 : gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
7220 60 : gfc_add_block_to_block (pblock, &se.pre);
7221 60 : gfc_add_block_to_block (pblock, &se.finalblock);
7222 60 : gfc_add_modify (pblock, ubound, se.expr);
7223 : }
7224 : }
7225 20481 : }
7226 :
7227 :
7228 : /* Generate code to evaluate non-constant array bounds. Sets *poffset and
7229 : returns the size (in elements) of the array. */
7230 :
7231 : tree
7232 13359 : gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
7233 : stmtblock_t * pblock)
7234 : {
7235 13359 : gfc_array_spec *as;
7236 13359 : tree size;
7237 13359 : tree stride;
7238 13359 : tree offset;
7239 13359 : tree ubound;
7240 13359 : tree lbound;
7241 13359 : tree tmp;
7242 13359 : gfc_se se;
7243 :
7244 13359 : int dim;
7245 :
7246 13359 : as = IS_CLASS_COARRAY_OR_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
7247 :
7248 13359 : size = gfc_index_one_node;
7249 13359 : offset = gfc_index_zero_node;
7250 13359 : stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
7251 13359 : if (stride && VAR_P (stride))
7252 124 : gfc_add_modify (pblock, stride, gfc_index_one_node);
7253 29963 : for (dim = 0; dim < as->rank; dim++)
7254 : {
7255 : /* Evaluate non-constant array bound expressions.
7256 : F2008 4.5.6.3 para 6: If a specification expression in a scoping unit
7257 : references a function, the result is finalized before execution of the
7258 : executable constructs in the scoping unit.
7259 : Adding the finalblocks enables this. */
7260 16604 : lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
7261 16604 : if (as->lower[dim] && !INTEGER_CST_P (lbound))
7262 : {
7263 475 : gfc_init_se (&se, NULL);
7264 475 : gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
7265 475 : gfc_add_block_to_block (pblock, &se.pre);
7266 475 : gfc_add_block_to_block (pblock, &se.finalblock);
7267 475 : gfc_add_modify (pblock, lbound, se.expr);
7268 : }
7269 16604 : ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
7270 16604 : if (as->upper[dim] && !INTEGER_CST_P (ubound))
7271 : {
7272 10094 : gfc_init_se (&se, NULL);
7273 10094 : gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
7274 10094 : gfc_add_block_to_block (pblock, &se.pre);
7275 10094 : gfc_add_block_to_block (pblock, &se.finalblock);
7276 10094 : gfc_add_modify (pblock, ubound, se.expr);
7277 : }
7278 : /* The offset of this dimension. offset = offset - lbound * stride. */
7279 16604 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7280 : lbound, size);
7281 16604 : offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7282 : offset, tmp);
7283 :
7284 : /* The size of this dimension, and the stride of the next. */
7285 16604 : if (dim + 1 < as->rank)
7286 3444 : stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
7287 : else
7288 13160 : stride = GFC_TYPE_ARRAY_SIZE (type);
7289 :
7290 16604 : if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
7291 : {
7292 : /* Calculate stride = size * (ubound + 1 - lbound). */
7293 10284 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
7294 : gfc_array_index_type,
7295 : gfc_index_one_node, lbound);
7296 10284 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
7297 : gfc_array_index_type, ubound, tmp);
7298 10284 : tmp = fold_build2_loc (input_location, MULT_EXPR,
7299 : gfc_array_index_type, size, tmp);
7300 10284 : if (stride)
7301 10284 : gfc_add_modify (pblock, stride, tmp);
7302 : else
7303 0 : stride = gfc_evaluate_now (tmp, pblock);
7304 :
7305 : /* Make sure that negative size arrays are translated
7306 : to being zero size. */
7307 10284 : tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
7308 : stride, gfc_index_zero_node);
7309 10284 : tmp = fold_build3_loc (input_location, COND_EXPR,
7310 : gfc_array_index_type, tmp,
7311 : stride, gfc_index_zero_node);
7312 10284 : gfc_add_modify (pblock, stride, tmp);
7313 : }
7314 :
7315 : size = stride;
7316 : }
7317 :
7318 13359 : gfc_trans_array_cobounds (type, pblock, sym);
7319 13359 : gfc_trans_vla_type_sizes (sym, pblock);
7320 :
7321 13359 : *poffset = offset;
7322 13359 : return size;
7323 : }
7324 :
7325 :
7326 : /* Generate code to initialize/allocate an array variable. */
7327 :
7328 : void
7329 31123 : gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
7330 : gfc_wrapped_block * block)
7331 : {
7332 31123 : stmtblock_t init;
7333 31123 : tree type;
7334 31123 : tree tmp = NULL_TREE;
7335 31123 : tree size;
7336 31123 : tree offset;
7337 31123 : tree space;
7338 31123 : tree inittree;
7339 31123 : bool onstack;
7340 31123 : bool back;
7341 :
7342 31123 : gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
7343 :
7344 : /* Do nothing for USEd variables. */
7345 31123 : if (sym->attr.use_assoc)
7346 25511 : return;
7347 :
7348 31081 : type = TREE_TYPE (decl);
7349 31081 : gcc_assert (GFC_ARRAY_TYPE_P (type));
7350 31081 : onstack = TREE_CODE (type) != POINTER_TYPE;
7351 :
7352 : /* In the case of non-dummy symbols with dependencies on an old-fashioned
7353 : function result (ie. proc_name = proc_name->result), gfc_add_init_cleanup
7354 : must be called with the last, optional argument false so that the alloc-
7355 : ation occurs after the processing of the result. */
7356 31081 : back = sym->fn_result_dep;
7357 :
7358 31081 : gfc_init_block (&init);
7359 :
7360 : /* Evaluate character string length. */
7361 31081 : if (sym->ts.type == BT_CHARACTER
7362 3029 : && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
7363 : {
7364 43 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7365 :
7366 43 : gfc_trans_vla_type_sizes (sym, &init);
7367 :
7368 : /* Emit a DECL_EXPR for this variable, which will cause the
7369 : gimplifier to allocate storage, and all that good stuff. */
7370 43 : tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
7371 43 : gfc_add_expr_to_block (&init, tmp);
7372 43 : if (sym->attr.omp_allocate)
7373 : {
7374 : /* Save location of size calculation to ensure GOMP_alloc is placed
7375 : after it. */
7376 0 : tree omp_alloc = lookup_attribute ("omp allocate",
7377 0 : DECL_ATTRIBUTES (decl));
7378 0 : TREE_CHAIN (TREE_CHAIN (TREE_VALUE (omp_alloc)))
7379 0 : = build_tree_list (NULL_TREE, tsi_stmt (tsi_last (init.head)));
7380 : }
7381 : }
7382 :
7383 30879 : if (onstack)
7384 : {
7385 25329 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE,
7386 : back);
7387 25329 : return;
7388 : }
7389 :
7390 5752 : type = TREE_TYPE (type);
7391 :
7392 5752 : gcc_assert (!sym->attr.use_assoc);
7393 5752 : gcc_assert (!sym->module);
7394 :
7395 5752 : if (sym->ts.type == BT_CHARACTER
7396 202 : && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
7397 94 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7398 :
7399 5752 : size = gfc_trans_array_bounds (type, sym, &offset, &init);
7400 :
7401 : /* Don't actually allocate space for Cray Pointees. */
7402 5752 : if (sym->attr.cray_pointee)
7403 : {
7404 140 : if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
7405 49 : gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
7406 :
7407 140 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
7408 140 : return;
7409 : }
7410 5612 : if (sym->attr.omp_allocate)
7411 : {
7412 : /* The size is the number of elements in the array, so multiply by the
7413 : size of an element to get the total size. */
7414 7 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
7415 7 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7416 : size, fold_convert (gfc_array_index_type, tmp));
7417 7 : size = gfc_evaluate_now (size, &init);
7418 :
7419 7 : tree omp_alloc = lookup_attribute ("omp allocate",
7420 7 : DECL_ATTRIBUTES (decl));
7421 7 : TREE_CHAIN (TREE_CHAIN (TREE_VALUE (omp_alloc)))
7422 7 : = build_tree_list (size, NULL_TREE);
7423 7 : space = NULL_TREE;
7424 : }
7425 5605 : else if (flag_stack_arrays)
7426 : {
7427 14 : gcc_assert (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE);
7428 14 : space = build_decl (gfc_get_location (&sym->declared_at),
7429 : VAR_DECL, create_tmp_var_name ("A"),
7430 14 : TREE_TYPE (TREE_TYPE (decl)));
7431 14 : gfc_trans_vla_type_sizes (sym, &init);
7432 : }
7433 : else
7434 : {
7435 : /* The size is the number of elements in the array, so multiply by the
7436 : size of an element to get the total size. */
7437 5591 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
7438 5591 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7439 : size, fold_convert (gfc_array_index_type, tmp));
7440 :
7441 : /* Allocate memory to hold the data. */
7442 5591 : tmp = gfc_call_malloc (&init, TREE_TYPE (decl), size);
7443 5591 : gfc_add_modify (&init, decl, tmp);
7444 :
7445 : /* Free the temporary. */
7446 5591 : tmp = gfc_call_free (decl);
7447 5591 : space = NULL_TREE;
7448 : }
7449 :
7450 : /* Set offset of the array. */
7451 5612 : if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
7452 378 : gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
7453 :
7454 : /* Automatic arrays should not have initializers. */
7455 5612 : gcc_assert (!sym->value);
7456 :
7457 5612 : inittree = gfc_finish_block (&init);
7458 :
7459 5612 : if (space)
7460 : {
7461 14 : tree addr;
7462 14 : pushdecl (space);
7463 :
7464 : /* Don't create new scope, emit the DECL_EXPR in exactly the scope
7465 : where also space is located. */
7466 14 : gfc_init_block (&init);
7467 14 : tmp = fold_build1_loc (input_location, DECL_EXPR,
7468 14 : TREE_TYPE (space), space);
7469 14 : gfc_add_expr_to_block (&init, tmp);
7470 14 : addr = fold_build1_loc (gfc_get_location (&sym->declared_at),
7471 14 : ADDR_EXPR, TREE_TYPE (decl), space);
7472 14 : gfc_add_modify (&init, decl, addr);
7473 14 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE,
7474 : back);
7475 14 : tmp = NULL_TREE;
7476 : }
7477 5612 : gfc_add_init_cleanup (block, inittree, tmp, back);
7478 : }
7479 :
7480 :
7481 : /* Generate entry and exit code for g77 calling convention arrays. */
7482 :
7483 : void
7484 7353 : gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block)
7485 : {
7486 7353 : tree parm;
7487 7353 : tree type;
7488 7353 : tree offset;
7489 7353 : tree tmp;
7490 7353 : tree stmt;
7491 7353 : stmtblock_t init;
7492 :
7493 7353 : location_t loc = input_location;
7494 7353 : input_location = gfc_get_location (&sym->declared_at);
7495 :
7496 : /* Descriptor type. */
7497 7353 : parm = sym->backend_decl;
7498 7353 : type = TREE_TYPE (parm);
7499 7353 : gcc_assert (GFC_ARRAY_TYPE_P (type));
7500 :
7501 7353 : gfc_start_block (&init);
7502 :
7503 7353 : if (sym->ts.type == BT_CHARACTER
7504 710 : && VAR_P (sym->ts.u.cl->backend_decl))
7505 79 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7506 :
7507 : /* Evaluate the bounds of the array. */
7508 7353 : gfc_trans_array_bounds (type, sym, &offset, &init);
7509 :
7510 : /* Set the offset. */
7511 7353 : if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
7512 1212 : gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
7513 :
7514 : /* Set the pointer itself if we aren't using the parameter directly. */
7515 7353 : if (TREE_CODE (parm) != PARM_DECL)
7516 : {
7517 612 : tmp = GFC_DECL_SAVED_DESCRIPTOR (parm);
7518 612 : if (sym->ts.type == BT_CLASS)
7519 : {
7520 243 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
7521 243 : tmp = gfc_class_data_get (tmp);
7522 243 : tmp = gfc_conv_descriptor_data_get (tmp);
7523 : }
7524 612 : tmp = convert (TREE_TYPE (parm), tmp);
7525 612 : gfc_add_modify (&init, parm, tmp);
7526 : }
7527 7353 : stmt = gfc_finish_block (&init);
7528 :
7529 7353 : input_location = loc;
7530 :
7531 : /* Add the initialization code to the start of the function. */
7532 :
7533 7353 : if ((sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.optional)
7534 7353 : || sym->attr.optional
7535 6871 : || sym->attr.not_always_present)
7536 : {
7537 539 : tree nullify;
7538 539 : if (TREE_CODE (parm) != PARM_DECL)
7539 105 : nullify = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
7540 : parm, null_pointer_node);
7541 : else
7542 434 : nullify = build_empty_stmt (input_location);
7543 539 : tmp = gfc_conv_expr_present (sym, true);
7544 539 : stmt = build3_v (COND_EXPR, tmp, stmt, nullify);
7545 : }
7546 :
7547 7353 : gfc_add_init_cleanup (block, stmt, NULL_TREE);
7548 7353 : }
7549 :
7550 :
7551 : /* Modify the descriptor of an array parameter so that it has the
7552 : correct lower bound. Also move the upper bound accordingly.
7553 : If the array is not packed, it will be copied into a temporary.
7554 : For each dimension we set the new lower and upper bounds. Then we copy the
7555 : stride and calculate the offset for this dimension. We also work out
7556 : what the stride of a packed array would be, and see it the two match.
7557 : If the array need repacking, we set the stride to the values we just
7558 : calculated, recalculate the offset and copy the array data.
7559 : Code is also added to copy the data back at the end of the function.
7560 : */
7561 :
7562 : void
7563 12755 : gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
7564 : gfc_wrapped_block * block)
7565 : {
7566 12755 : tree size;
7567 12755 : tree type;
7568 12755 : tree offset;
7569 12755 : stmtblock_t init;
7570 12755 : tree stmtInit, stmtCleanup;
7571 12755 : tree lbound;
7572 12755 : tree ubound;
7573 12755 : tree dubound;
7574 12755 : tree dlbound;
7575 12755 : tree dumdesc;
7576 12755 : tree tmp;
7577 12755 : tree stride, stride2;
7578 12755 : tree stmt_packed;
7579 12755 : tree stmt_unpacked;
7580 12755 : tree partial;
7581 12755 : gfc_se se;
7582 12755 : int n;
7583 12755 : int checkparm;
7584 12755 : int no_repack;
7585 12755 : bool optional_arg;
7586 12755 : gfc_array_spec *as;
7587 12755 : bool is_classarray = IS_CLASS_COARRAY_OR_ARRAY (sym);
7588 :
7589 : /* Do nothing for pointer and allocatable arrays. */
7590 12755 : if ((sym->ts.type != BT_CLASS && sym->attr.pointer)
7591 12658 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer)
7592 12658 : || sym->attr.allocatable
7593 12552 : || (is_classarray && CLASS_DATA (sym)->attr.allocatable))
7594 6035 : return;
7595 :
7596 772 : if ((!is_classarray
7597 772 : || (is_classarray && CLASS_DATA (sym)->as->type == AS_EXPLICIT))
7598 11964 : && sym->attr.dummy && !sym->attr.elemental && gfc_is_nodesc_array (sym))
7599 : {
7600 5832 : gfc_trans_g77_array (sym, block);
7601 5832 : return;
7602 : }
7603 :
7604 6720 : location_t loc = input_location;
7605 6720 : input_location = gfc_get_location (&sym->declared_at);
7606 :
7607 : /* Descriptor type. */
7608 6720 : type = TREE_TYPE (tmpdesc);
7609 6720 : gcc_assert (GFC_ARRAY_TYPE_P (type));
7610 6720 : dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
7611 6720 : if (is_classarray)
7612 : /* For a class array the dummy array descriptor is in the _class
7613 : component. */
7614 607 : dumdesc = gfc_class_data_get (dumdesc);
7615 : else
7616 6113 : dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc);
7617 6720 : as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
7618 6720 : gfc_start_block (&init);
7619 :
7620 6720 : if (sym->ts.type == BT_CHARACTER
7621 780 : && VAR_P (sym->ts.u.cl->backend_decl))
7622 87 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7623 :
7624 : /* TODO: Fix the exclusion of class arrays from extent checking. */
7625 1060 : checkparm = (as->type == AS_EXPLICIT && !is_classarray
7626 7761 : && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
7627 :
7628 6720 : no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
7629 6719 : || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
7630 :
7631 6720 : if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
7632 : {
7633 : /* For non-constant shape arrays we only check if the first dimension
7634 : is contiguous. Repacking higher dimensions wouldn't gain us
7635 : anything as we still don't know the array stride. */
7636 1 : partial = gfc_create_var (logical_type_node, "partial");
7637 1 : TREE_USED (partial) = 1;
7638 1 : tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
7639 1 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, tmp,
7640 : gfc_index_one_node);
7641 1 : gfc_add_modify (&init, partial, tmp);
7642 : }
7643 : else
7644 : partial = NULL_TREE;
7645 :
7646 : /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
7647 : here, however I think it does the right thing. */
7648 6720 : if (no_repack)
7649 : {
7650 : /* Set the first stride. */
7651 6718 : stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
7652 6718 : stride = gfc_evaluate_now (stride, &init);
7653 :
7654 6718 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7655 : stride, gfc_index_zero_node);
7656 6718 : tmp = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
7657 : tmp, gfc_index_one_node, stride);
7658 6718 : stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
7659 6718 : gfc_add_modify (&init, stride, tmp);
7660 :
7661 : /* Allow the user to disable array repacking. */
7662 6718 : stmt_unpacked = NULL_TREE;
7663 : }
7664 : else
7665 : {
7666 2 : gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
7667 : /* A library call to repack the array if necessary. */
7668 2 : tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
7669 2 : stmt_unpacked = build_call_expr_loc (input_location,
7670 : gfor_fndecl_in_pack, 1, tmp);
7671 :
7672 2 : stride = gfc_index_one_node;
7673 :
7674 2 : if (warn_array_temporaries)
7675 : {
7676 1 : locus where;
7677 1 : gfc_locus_from_location (&where, loc);
7678 1 : gfc_warning (OPT_Warray_temporaries,
7679 : "Creating array temporary at %L", &where);
7680 : }
7681 : }
7682 :
7683 : /* This is for the case where the array data is used directly without
7684 : calling the repack function. */
7685 6720 : if (no_repack || partial != NULL_TREE)
7686 6719 : stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
7687 : else
7688 : stmt_packed = NULL_TREE;
7689 :
7690 : /* Assign the data pointer. */
7691 6720 : if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
7692 : {
7693 : /* Don't repack unknown shape arrays when the first stride is 1. */
7694 1 : tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (stmt_packed),
7695 : partial, stmt_packed, stmt_unpacked);
7696 : }
7697 : else
7698 6719 : tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
7699 6720 : gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp));
7700 :
7701 6720 : offset = gfc_index_zero_node;
7702 6720 : size = gfc_index_one_node;
7703 :
7704 : /* Evaluate the bounds of the array. */
7705 15730 : for (n = 0; n < as->rank; n++)
7706 : {
7707 9010 : if (checkparm || !as->upper[n])
7708 : {
7709 : /* Get the bounds of the actual parameter. */
7710 7715 : dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]);
7711 7715 : dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]);
7712 : }
7713 : else
7714 : {
7715 : dubound = NULL_TREE;
7716 : dlbound = NULL_TREE;
7717 : }
7718 :
7719 9010 : lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
7720 9010 : if (!INTEGER_CST_P (lbound))
7721 : {
7722 46 : gfc_init_se (&se, NULL);
7723 46 : gfc_conv_expr_type (&se, as->lower[n],
7724 : gfc_array_index_type);
7725 46 : gfc_add_block_to_block (&init, &se.pre);
7726 46 : gfc_add_modify (&init, lbound, se.expr);
7727 : }
7728 :
7729 9010 : ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
7730 : /* Set the desired upper bound. */
7731 9010 : if (as->upper[n])
7732 : {
7733 : /* We know what we want the upper bound to be. */
7734 1353 : if (!INTEGER_CST_P (ubound))
7735 : {
7736 621 : gfc_init_se (&se, NULL);
7737 621 : gfc_conv_expr_type (&se, as->upper[n],
7738 : gfc_array_index_type);
7739 621 : gfc_add_block_to_block (&init, &se.pre);
7740 621 : gfc_add_modify (&init, ubound, se.expr);
7741 : }
7742 :
7743 : /* Check the sizes match. */
7744 1353 : if (checkparm)
7745 : {
7746 : /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
7747 58 : char * msg;
7748 58 : tree temp;
7749 58 : locus where;
7750 :
7751 58 : gfc_locus_from_location (&where, loc);
7752 58 : temp = fold_build2_loc (input_location, MINUS_EXPR,
7753 : gfc_array_index_type, ubound, lbound);
7754 58 : temp = fold_build2_loc (input_location, PLUS_EXPR,
7755 : gfc_array_index_type,
7756 : gfc_index_one_node, temp);
7757 58 : stride2 = fold_build2_loc (input_location, MINUS_EXPR,
7758 : gfc_array_index_type, dubound,
7759 : dlbound);
7760 58 : stride2 = fold_build2_loc (input_location, PLUS_EXPR,
7761 : gfc_array_index_type,
7762 : gfc_index_one_node, stride2);
7763 58 : tmp = fold_build2_loc (input_location, NE_EXPR,
7764 : gfc_array_index_type, temp, stride2);
7765 58 : msg = xasprintf ("Dimension %d of array '%s' has extent "
7766 : "%%ld instead of %%ld", n+1, sym->name);
7767 :
7768 58 : gfc_trans_runtime_check (true, false, tmp, &init, &where, msg,
7769 : fold_convert (long_integer_type_node, temp),
7770 : fold_convert (long_integer_type_node, stride2));
7771 :
7772 58 : free (msg);
7773 : }
7774 : }
7775 : else
7776 : {
7777 : /* For assumed shape arrays move the upper bound by the same amount
7778 : as the lower bound. */
7779 7657 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
7780 : gfc_array_index_type, dubound, dlbound);
7781 7657 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
7782 : gfc_array_index_type, tmp, lbound);
7783 7657 : gfc_add_modify (&init, ubound, tmp);
7784 : }
7785 : /* The offset of this dimension. offset = offset - lbound * stride. */
7786 9010 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7787 : lbound, stride);
7788 9010 : offset = fold_build2_loc (input_location, MINUS_EXPR,
7789 : gfc_array_index_type, offset, tmp);
7790 :
7791 : /* The size of this dimension, and the stride of the next. */
7792 9010 : if (n + 1 < as->rank)
7793 : {
7794 2290 : stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
7795 :
7796 2290 : if (no_repack || partial != NULL_TREE)
7797 2289 : stmt_unpacked =
7798 2289 : gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]);
7799 :
7800 : /* Figure out the stride if not a known constant. */
7801 2290 : if (!INTEGER_CST_P (stride))
7802 : {
7803 2289 : if (no_repack)
7804 : stmt_packed = NULL_TREE;
7805 : else
7806 : {
7807 : /* Calculate stride = size * (ubound + 1 - lbound). */
7808 0 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
7809 : gfc_array_index_type,
7810 : gfc_index_one_node, lbound);
7811 0 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
7812 : gfc_array_index_type, ubound, tmp);
7813 0 : size = fold_build2_loc (input_location, MULT_EXPR,
7814 : gfc_array_index_type, size, tmp);
7815 0 : stmt_packed = size;
7816 : }
7817 :
7818 : /* Assign the stride. */
7819 2289 : if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
7820 0 : tmp = fold_build3_loc (input_location, COND_EXPR,
7821 : gfc_array_index_type, partial,
7822 : stmt_unpacked, stmt_packed);
7823 : else
7824 2289 : tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
7825 2289 : gfc_add_modify (&init, stride, tmp);
7826 : }
7827 : }
7828 : else
7829 : {
7830 6720 : stride = GFC_TYPE_ARRAY_SIZE (type);
7831 :
7832 6720 : if (stride && !INTEGER_CST_P (stride))
7833 : {
7834 : /* Calculate size = stride * (ubound + 1 - lbound). */
7835 6719 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
7836 : gfc_array_index_type,
7837 : gfc_index_one_node, lbound);
7838 6719 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
7839 : gfc_array_index_type,
7840 : ubound, tmp);
7841 20157 : tmp = fold_build2_loc (input_location, MULT_EXPR,
7842 : gfc_array_index_type,
7843 6719 : GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
7844 6719 : gfc_add_modify (&init, stride, tmp);
7845 : }
7846 : }
7847 : }
7848 :
7849 6720 : gfc_trans_array_cobounds (type, &init, sym);
7850 :
7851 : /* Set the offset. */
7852 6720 : if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
7853 6718 : gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
7854 :
7855 6720 : gfc_trans_vla_type_sizes (sym, &init);
7856 :
7857 6720 : stmtInit = gfc_finish_block (&init);
7858 :
7859 : /* Only do the entry/initialization code if the arg is present. */
7860 6720 : dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
7861 6720 : optional_arg = (sym->attr.optional
7862 6720 : || (sym->ns->proc_name->attr.entry_master
7863 79 : && sym->attr.dummy));
7864 : if (optional_arg)
7865 : {
7866 717 : tree zero_init = fold_convert (TREE_TYPE (tmpdesc), null_pointer_node);
7867 717 : zero_init = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
7868 : tmpdesc, zero_init);
7869 717 : tmp = gfc_conv_expr_present (sym, true);
7870 717 : stmtInit = build3_v (COND_EXPR, tmp, stmtInit, zero_init);
7871 : }
7872 :
7873 : /* Cleanup code. */
7874 6720 : if (no_repack)
7875 : stmtCleanup = NULL_TREE;
7876 : else
7877 : {
7878 2 : stmtblock_t cleanup;
7879 2 : gfc_start_block (&cleanup);
7880 :
7881 2 : if (sym->attr.intent != INTENT_IN)
7882 : {
7883 : /* Copy the data back. */
7884 2 : tmp = build_call_expr_loc (input_location,
7885 : gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
7886 2 : gfc_add_expr_to_block (&cleanup, tmp);
7887 : }
7888 :
7889 : /* Free the temporary. */
7890 2 : tmp = gfc_call_free (tmpdesc);
7891 2 : gfc_add_expr_to_block (&cleanup, tmp);
7892 :
7893 2 : stmtCleanup = gfc_finish_block (&cleanup);
7894 :
7895 : /* Only do the cleanup if the array was repacked. */
7896 2 : if (is_classarray)
7897 : /* For a class array the dummy array descriptor is in the _class
7898 : component. */
7899 1 : tmp = gfc_class_data_get (dumdesc);
7900 : else
7901 1 : tmp = build_fold_indirect_ref_loc (input_location, dumdesc);
7902 2 : tmp = gfc_conv_descriptor_data_get (tmp);
7903 2 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
7904 : tmp, tmpdesc);
7905 2 : stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
7906 : build_empty_stmt (input_location));
7907 :
7908 2 : if (optional_arg)
7909 : {
7910 0 : tmp = gfc_conv_expr_present (sym);
7911 0 : stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
7912 : build_empty_stmt (input_location));
7913 : }
7914 : }
7915 :
7916 : /* We don't need to free any memory allocated by internal_pack as it will
7917 : be freed at the end of the function by pop_context. */
7918 6720 : gfc_add_init_cleanup (block, stmtInit, stmtCleanup);
7919 :
7920 6720 : input_location = loc;
7921 : }
7922 :
7923 :
7924 : /* Calculate the overall offset, including subreferences. */
7925 : void
7926 59359 : gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
7927 : bool subref, gfc_expr *expr)
7928 : {
7929 59359 : tree tmp;
7930 59359 : tree field;
7931 59359 : tree stride;
7932 59359 : tree index;
7933 59359 : gfc_ref *ref;
7934 59359 : gfc_se start;
7935 59359 : int n;
7936 :
7937 : /* If offset is NULL and this is not a subreferenced array, there is
7938 : nothing to do. */
7939 59359 : if (offset == NULL_TREE)
7940 : {
7941 1066 : if (subref)
7942 139 : offset = gfc_index_zero_node;
7943 : else
7944 927 : return;
7945 : }
7946 :
7947 58432 : tmp = build_array_ref (desc, offset, NULL, NULL);
7948 :
7949 : /* Offset the data pointer for pointer assignments from arrays with
7950 : subreferences; e.g. my_integer => my_type(:)%integer_component. */
7951 58432 : if (subref)
7952 : {
7953 : /* Go past the array reference. */
7954 844 : for (ref = expr->ref; ref; ref = ref->next)
7955 844 : if (ref->type == REF_ARRAY &&
7956 757 : ref->u.ar.type != AR_ELEMENT)
7957 : {
7958 733 : ref = ref->next;
7959 733 : break;
7960 : }
7961 :
7962 : /* Calculate the offset for each subsequent subreference. */
7963 1438 : for (; ref; ref = ref->next)
7964 : {
7965 705 : switch (ref->type)
7966 : {
7967 301 : case REF_COMPONENT:
7968 301 : field = ref->u.c.component->backend_decl;
7969 301 : gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
7970 602 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
7971 301 : TREE_TYPE (field),
7972 : tmp, field, NULL_TREE);
7973 301 : break;
7974 :
7975 320 : case REF_SUBSTRING:
7976 320 : gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
7977 320 : gfc_init_se (&start, NULL);
7978 320 : gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
7979 320 : gfc_add_block_to_block (block, &start.pre);
7980 320 : tmp = gfc_build_array_ref (tmp, start.expr, NULL);
7981 320 : break;
7982 :
7983 24 : case REF_ARRAY:
7984 24 : gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
7985 : && ref->u.ar.type == AR_ELEMENT);
7986 :
7987 : /* TODO - Add bounds checking. */
7988 24 : stride = gfc_index_one_node;
7989 24 : index = gfc_index_zero_node;
7990 55 : for (n = 0; n < ref->u.ar.dimen; n++)
7991 : {
7992 31 : tree itmp;
7993 31 : tree jtmp;
7994 :
7995 : /* Update the index. */
7996 31 : gfc_init_se (&start, NULL);
7997 31 : gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
7998 31 : itmp = gfc_evaluate_now (start.expr, block);
7999 31 : gfc_init_se (&start, NULL);
8000 31 : gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
8001 31 : jtmp = gfc_evaluate_now (start.expr, block);
8002 31 : itmp = fold_build2_loc (input_location, MINUS_EXPR,
8003 : gfc_array_index_type, itmp, jtmp);
8004 31 : itmp = fold_build2_loc (input_location, MULT_EXPR,
8005 : gfc_array_index_type, itmp, stride);
8006 31 : index = fold_build2_loc (input_location, PLUS_EXPR,
8007 : gfc_array_index_type, itmp, index);
8008 31 : index = gfc_evaluate_now (index, block);
8009 :
8010 : /* Update the stride. */
8011 31 : gfc_init_se (&start, NULL);
8012 31 : gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
8013 31 : itmp = fold_build2_loc (input_location, MINUS_EXPR,
8014 : gfc_array_index_type, start.expr,
8015 : jtmp);
8016 31 : itmp = fold_build2_loc (input_location, PLUS_EXPR,
8017 : gfc_array_index_type,
8018 : gfc_index_one_node, itmp);
8019 31 : stride = fold_build2_loc (input_location, MULT_EXPR,
8020 : gfc_array_index_type, stride, itmp);
8021 31 : stride = gfc_evaluate_now (stride, block);
8022 : }
8023 :
8024 : /* Apply the index to obtain the array element. */
8025 24 : tmp = gfc_build_array_ref (tmp, index, NULL);
8026 24 : break;
8027 :
8028 60 : case REF_INQUIRY:
8029 60 : switch (ref->u.i)
8030 : {
8031 54 : case INQUIRY_RE:
8032 108 : tmp = fold_build1_loc (input_location, REALPART_EXPR,
8033 54 : TREE_TYPE (TREE_TYPE (tmp)), tmp);
8034 54 : break;
8035 :
8036 6 : case INQUIRY_IM:
8037 12 : tmp = fold_build1_loc (input_location, IMAGPART_EXPR,
8038 6 : TREE_TYPE (TREE_TYPE (tmp)), tmp);
8039 6 : break;
8040 :
8041 : default:
8042 : break;
8043 : }
8044 : break;
8045 :
8046 0 : default:
8047 0 : gcc_unreachable ();
8048 705 : break;
8049 : }
8050 : }
8051 : }
8052 :
8053 : /* Set the target data pointer. */
8054 58432 : offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
8055 :
8056 : /* Check for optional dummy argument being present. Arguments of BIND(C)
8057 : procedures are excepted here since they are handled differently. */
8058 58432 : if (expr->expr_type == EXPR_VARIABLE
8059 51495 : && expr->symtree->n.sym->attr.dummy
8060 6164 : && expr->symtree->n.sym->attr.optional
8061 59424 : && !is_CFI_desc (NULL, expr))
8062 1624 : offset = build3_loc (input_location, COND_EXPR, TREE_TYPE (offset),
8063 812 : gfc_conv_expr_present (expr->symtree->n.sym), offset,
8064 812 : fold_convert (TREE_TYPE (offset), gfc_index_zero_node));
8065 :
8066 58432 : gfc_conv_descriptor_data_set (block, parm, offset);
8067 : }
8068 :
8069 :
8070 : /* gfc_conv_expr_descriptor needs the string length an expression
8071 : so that the size of the temporary can be obtained. This is done
8072 : by adding up the string lengths of all the elements in the
8073 : expression. Function with non-constant expressions have their
8074 : string lengths mapped onto the actual arguments using the
8075 : interface mapping machinery in trans-expr.cc. */
8076 : static void
8077 1563 : get_array_charlen (gfc_expr *expr, gfc_se *se)
8078 : {
8079 1563 : gfc_interface_mapping mapping;
8080 1563 : gfc_formal_arglist *formal;
8081 1563 : gfc_actual_arglist *arg;
8082 1563 : gfc_se tse;
8083 1563 : gfc_expr *e;
8084 :
8085 1563 : if (expr->ts.u.cl->length
8086 1563 : && gfc_is_constant_expr (expr->ts.u.cl->length))
8087 : {
8088 1219 : if (!expr->ts.u.cl->backend_decl)
8089 471 : gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
8090 1351 : return;
8091 : }
8092 :
8093 344 : switch (expr->expr_type)
8094 : {
8095 130 : case EXPR_ARRAY:
8096 :
8097 : /* This is somewhat brutal. The expression for the first
8098 : element of the array is evaluated and assigned to a
8099 : new string length for the original expression. */
8100 130 : e = gfc_constructor_first (expr->value.constructor)->expr;
8101 :
8102 130 : gfc_init_se (&tse, NULL);
8103 :
8104 : /* Avoid evaluating trailing array references since all we need is
8105 : the string length. */
8106 130 : if (e->rank)
8107 38 : tse.descriptor_only = 1;
8108 130 : if (e->rank && e->expr_type != EXPR_VARIABLE)
8109 1 : gfc_conv_expr_descriptor (&tse, e);
8110 : else
8111 129 : gfc_conv_expr (&tse, e);
8112 :
8113 130 : gfc_add_block_to_block (&se->pre, &tse.pre);
8114 130 : gfc_add_block_to_block (&se->post, &tse.post);
8115 :
8116 130 : if (!expr->ts.u.cl->backend_decl || !VAR_P (expr->ts.u.cl->backend_decl))
8117 : {
8118 87 : expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
8119 87 : expr->ts.u.cl->backend_decl =
8120 87 : gfc_create_var (gfc_charlen_type_node, "sln");
8121 : }
8122 :
8123 130 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
8124 : tse.string_length);
8125 :
8126 : /* Make sure that deferred length components point to the hidden
8127 : string_length component. */
8128 130 : if (TREE_CODE (tse.expr) == COMPONENT_REF
8129 25 : && TREE_CODE (tse.string_length) == COMPONENT_REF
8130 149 : && TREE_OPERAND (tse.expr, 0) == TREE_OPERAND (tse.string_length, 0))
8131 19 : e->ts.u.cl->backend_decl = expr->ts.u.cl->backend_decl;
8132 :
8133 : return;
8134 :
8135 90 : case EXPR_OP:
8136 90 : get_array_charlen (expr->value.op.op1, se);
8137 :
8138 : /* For parentheses the expression ts.u.cl should be identical. */
8139 90 : if (expr->value.op.op == INTRINSIC_PARENTHESES)
8140 : {
8141 2 : if (expr->value.op.op1->ts.u.cl != expr->ts.u.cl)
8142 2 : expr->ts.u.cl->backend_decl
8143 2 : = expr->value.op.op1->ts.u.cl->backend_decl;
8144 2 : return;
8145 : }
8146 :
8147 176 : expr->ts.u.cl->backend_decl =
8148 88 : gfc_create_var (gfc_charlen_type_node, "sln");
8149 :
8150 88 : if (expr->value.op.op2)
8151 : {
8152 88 : get_array_charlen (expr->value.op.op2, se);
8153 :
8154 88 : gcc_assert (expr->value.op.op == INTRINSIC_CONCAT);
8155 :
8156 : /* Add the string lengths and assign them to the expression
8157 : string length backend declaration. */
8158 88 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
8159 : fold_build2_loc (input_location, PLUS_EXPR,
8160 : gfc_charlen_type_node,
8161 88 : expr->value.op.op1->ts.u.cl->backend_decl,
8162 88 : expr->value.op.op2->ts.u.cl->backend_decl));
8163 : }
8164 : else
8165 0 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
8166 0 : expr->value.op.op1->ts.u.cl->backend_decl);
8167 : break;
8168 :
8169 43 : case EXPR_FUNCTION:
8170 43 : if (expr->value.function.esym == NULL
8171 37 : || expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
8172 : {
8173 6 : gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
8174 6 : break;
8175 : }
8176 :
8177 : /* Map expressions involving the dummy arguments onto the actual
8178 : argument expressions. */
8179 37 : gfc_init_interface_mapping (&mapping);
8180 37 : formal = gfc_sym_get_dummy_args (expr->symtree->n.sym);
8181 37 : arg = expr->value.function.actual;
8182 :
8183 : /* Set se = NULL in the calls to the interface mapping, to suppress any
8184 : backend stuff. */
8185 113 : for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
8186 : {
8187 38 : if (!arg->expr)
8188 0 : continue;
8189 38 : if (formal->sym)
8190 38 : gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
8191 : }
8192 :
8193 37 : gfc_init_se (&tse, NULL);
8194 :
8195 : /* Build the expression for the character length and convert it. */
8196 37 : gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length);
8197 :
8198 37 : gfc_add_block_to_block (&se->pre, &tse.pre);
8199 37 : gfc_add_block_to_block (&se->post, &tse.post);
8200 37 : tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
8201 74 : tse.expr = fold_build2_loc (input_location, MAX_EXPR,
8202 37 : TREE_TYPE (tse.expr), tse.expr,
8203 37 : build_zero_cst (TREE_TYPE (tse.expr)));
8204 37 : expr->ts.u.cl->backend_decl = tse.expr;
8205 37 : gfc_free_interface_mapping (&mapping);
8206 37 : break;
8207 :
8208 81 : default:
8209 81 : gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
8210 81 : break;
8211 : }
8212 : }
8213 :
8214 :
8215 : /* Helper function to check dimensions. */
8216 : static bool
8217 144 : transposed_dims (gfc_ss *ss)
8218 : {
8219 144 : int n;
8220 :
8221 173546 : for (n = 0; n < ss->dimen; n++)
8222 88284 : if (ss->dim[n] != n)
8223 : return true;
8224 : return false;
8225 : }
8226 :
8227 :
8228 : /* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
8229 : AR_FULL, suitable for the scalarizer. */
8230 :
8231 : static gfc_ss *
8232 1510 : walk_coarray (gfc_expr *e)
8233 : {
8234 1510 : gfc_ss *ss;
8235 :
8236 1510 : ss = gfc_walk_expr (e);
8237 :
8238 : /* Fix scalar coarray. */
8239 1510 : if (ss == gfc_ss_terminator)
8240 : {
8241 357 : gfc_ref *ref;
8242 :
8243 357 : ref = e->ref;
8244 508 : while (ref)
8245 : {
8246 508 : if (ref->type == REF_ARRAY
8247 357 : && ref->u.ar.codimen > 0)
8248 : break;
8249 :
8250 151 : ref = ref->next;
8251 : }
8252 :
8253 357 : gcc_assert (ref != NULL);
8254 357 : if (ref->u.ar.type == AR_ELEMENT)
8255 339 : ref->u.ar.type = AR_SECTION;
8256 357 : ss = gfc_reverse_ss (gfc_walk_array_ref (ss, e, ref, false));
8257 : }
8258 :
8259 1510 : return ss;
8260 : }
8261 :
8262 : gfc_array_spec *
8263 2177 : get_coarray_as (const gfc_expr *e)
8264 : {
8265 2177 : gfc_array_spec *as;
8266 2177 : gfc_symbol *sym = e->symtree->n.sym;
8267 2177 : gfc_component *comp;
8268 :
8269 2177 : if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.codimension)
8270 595 : as = CLASS_DATA (sym)->as;
8271 1582 : else if (sym->attr.codimension)
8272 1522 : as = sym->as;
8273 : else
8274 : as = nullptr;
8275 :
8276 5069 : for (gfc_ref *ref = e->ref; ref; ref = ref->next)
8277 : {
8278 2892 : switch (ref->type)
8279 : {
8280 715 : case REF_COMPONENT:
8281 715 : comp = ref->u.c.component;
8282 715 : if (comp->ts.type == BT_CLASS && CLASS_DATA (comp)->attr.codimension)
8283 18 : as = CLASS_DATA (comp)->as;
8284 697 : else if (comp->ts.type != BT_CLASS && comp->attr.codimension)
8285 655 : as = comp->as;
8286 : break;
8287 :
8288 : case REF_ARRAY:
8289 : case REF_SUBSTRING:
8290 : case REF_INQUIRY:
8291 : break;
8292 : }
8293 : }
8294 :
8295 2177 : return as;
8296 : }
8297 :
8298 : bool
8299 141112 : is_explicit_coarray (gfc_expr *expr)
8300 : {
8301 141112 : if (!gfc_is_coarray (expr))
8302 : return false;
8303 :
8304 2177 : gfc_array_spec *cas = get_coarray_as (expr);
8305 2177 : return cas && cas->cotype == AS_EXPLICIT;
8306 : }
8307 :
8308 : /* Convert an array for passing as an actual argument. Expressions and
8309 : vector subscripts are evaluated and stored in a temporary, which is then
8310 : passed. For whole arrays the descriptor is passed. For array sections
8311 : a modified copy of the descriptor is passed, but using the original data.
8312 :
8313 : This function is also used for array pointer assignments, and there
8314 : are three cases:
8315 :
8316 : - se->want_pointer && !se->direct_byref
8317 : EXPR is an actual argument. On exit, se->expr contains a
8318 : pointer to the array descriptor.
8319 :
8320 : - !se->want_pointer && !se->direct_byref
8321 : EXPR is an actual argument to an intrinsic function or the
8322 : left-hand side of a pointer assignment. On exit, se->expr
8323 : contains the descriptor for EXPR.
8324 :
8325 : - !se->want_pointer && se->direct_byref
8326 : EXPR is the right-hand side of a pointer assignment and
8327 : se->expr is the descriptor for the previously-evaluated
8328 : left-hand side. The function creates an assignment from
8329 : EXPR to se->expr.
8330 :
8331 :
8332 : The se->force_tmp flag disables the non-copying descriptor optimization
8333 : that is used for transpose. It may be used in cases where there is an
8334 : alias between the transpose argument and another argument in the same
8335 : function call. */
8336 :
8337 : void
8338 157026 : gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
8339 : {
8340 157026 : gfc_ss *ss;
8341 157026 : gfc_ss_type ss_type;
8342 157026 : gfc_ss_info *ss_info;
8343 157026 : gfc_loopinfo loop;
8344 157026 : gfc_array_info *info;
8345 157026 : int need_tmp;
8346 157026 : int n;
8347 157026 : tree tmp;
8348 157026 : tree desc;
8349 157026 : stmtblock_t block;
8350 157026 : tree start;
8351 157026 : int full;
8352 157026 : bool subref_array_target = false;
8353 157026 : bool deferred_array_component = false;
8354 157026 : bool substr = false;
8355 157026 : gfc_expr *arg, *ss_expr;
8356 :
8357 157026 : if (se->want_coarray || expr->rank == 0)
8358 1510 : ss = walk_coarray (expr);
8359 : else
8360 155516 : ss = gfc_walk_expr (expr);
8361 :
8362 157026 : gcc_assert (ss != NULL);
8363 157026 : gcc_assert (ss != gfc_ss_terminator);
8364 :
8365 157026 : ss_info = ss->info;
8366 157026 : ss_type = ss_info->type;
8367 157026 : ss_expr = ss_info->expr;
8368 :
8369 : /* Special case: TRANSPOSE which needs no temporary. */
8370 162268 : while (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym
8371 161998 : && (arg = gfc_get_noncopying_intrinsic_argument (expr)) != NULL)
8372 : {
8373 : /* This is a call to transpose which has already been handled by the
8374 : scalarizer, so that we just need to get its argument's descriptor. */
8375 408 : gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
8376 408 : expr = expr->value.function.actual->expr;
8377 : }
8378 :
8379 157026 : if (!se->direct_byref)
8380 301726 : se->unlimited_polymorphic = UNLIMITED_POLY (expr);
8381 :
8382 : /* Special case things we know we can pass easily. */
8383 157026 : switch (expr->expr_type)
8384 : {
8385 141391 : case EXPR_VARIABLE:
8386 : /* If we have a linear array section, we can pass it directly.
8387 : Otherwise we need to copy it into a temporary. */
8388 :
8389 141391 : gcc_assert (ss_type == GFC_SS_SECTION);
8390 141391 : gcc_assert (ss_expr == expr);
8391 141391 : info = &ss_info->data.array;
8392 :
8393 : /* Get the descriptor for the array. */
8394 141391 : gfc_conv_ss_descriptor (&se->pre, ss, 0);
8395 141391 : desc = info->descriptor;
8396 :
8397 : /* The charlen backend decl for deferred character components cannot
8398 : be used because it is fixed at zero. Instead, the hidden string
8399 : length component is used. */
8400 141391 : if (expr->ts.type == BT_CHARACTER
8401 20185 : && expr->ts.deferred
8402 2830 : && TREE_CODE (desc) == COMPONENT_REF)
8403 141391 : deferred_array_component = true;
8404 :
8405 141391 : substr = info->ref && info->ref->next
8406 142219 : && info->ref->next->type == REF_SUBSTRING;
8407 :
8408 141391 : subref_array_target = (is_subref_array (expr)
8409 141391 : && (se->direct_byref
8410 2596 : || expr->ts.type == BT_CHARACTER));
8411 141391 : need_tmp = (gfc_ref_needs_temporary_p (expr->ref)
8412 141391 : && !subref_array_target);
8413 :
8414 141391 : if (se->force_tmp)
8415 : need_tmp = 1;
8416 141208 : else if (se->force_no_tmp)
8417 : need_tmp = 0;
8418 :
8419 135071 : if (need_tmp)
8420 : full = 0;
8421 141112 : else if (is_explicit_coarray (expr))
8422 : full = 0;
8423 140292 : else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
8424 : {
8425 : /* Create a new descriptor if the array doesn't have one. */
8426 : full = 0;
8427 : }
8428 91343 : else if (info->ref->u.ar.type == AR_FULL || se->descriptor_only)
8429 : full = 1;
8430 7949 : else if (se->direct_byref)
8431 : full = 0;
8432 7586 : else if (info->ref->u.ar.dimen == 0 && !info->ref->next)
8433 : full = 1;
8434 7445 : else if (info->ref->u.ar.type == AR_SECTION && se->want_pointer)
8435 : full = 0;
8436 : else
8437 3559 : full = gfc_full_array_ref_p (info->ref, NULL);
8438 :
8439 170869 : if (full && !transposed_dims (ss))
8440 : {
8441 83718 : if (se->direct_byref && !se->byref_noassign)
8442 : {
8443 1054 : struct lang_type *lhs_ls
8444 1054 : = TYPE_LANG_SPECIFIC (TREE_TYPE (se->expr)),
8445 1054 : *rhs_ls = TYPE_LANG_SPECIFIC (TREE_TYPE (desc));
8446 : /* When only the array_kind differs, do a view_convert. */
8447 1450 : tmp = lhs_ls && rhs_ls && lhs_ls->rank == rhs_ls->rank
8448 1054 : && lhs_ls->akind != rhs_ls->akind
8449 1450 : ? build1 (VIEW_CONVERT_EXPR, TREE_TYPE (se->expr), desc)
8450 : : desc;
8451 : /* Copy the descriptor for pointer assignments. */
8452 1054 : gfc_add_modify (&se->pre, se->expr, tmp);
8453 :
8454 : /* Add any offsets from subreferences. */
8455 1054 : gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
8456 : subref_array_target, expr);
8457 :
8458 : /* ....and set the span field. */
8459 1054 : if (ss_info->expr->ts.type == BT_CHARACTER)
8460 141 : tmp = gfc_conv_descriptor_span_get (desc);
8461 : else
8462 913 : tmp = gfc_get_array_span (desc, expr);
8463 1054 : gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp);
8464 1054 : }
8465 82664 : else if (se->want_pointer)
8466 : {
8467 : /* We pass full arrays directly. This means that pointers and
8468 : allocatable arrays should also work. */
8469 13732 : se->expr = gfc_build_addr_expr (NULL_TREE, desc);
8470 : }
8471 : else
8472 : {
8473 68932 : se->expr = desc;
8474 : }
8475 :
8476 83718 : if (expr->ts.type == BT_CHARACTER && !deferred_array_component)
8477 8378 : se->string_length = gfc_get_expr_charlen (expr);
8478 : /* The ss_info string length is returned set to the value of the
8479 : hidden string length component. */
8480 75077 : else if (deferred_array_component)
8481 263 : se->string_length = ss_info->string_length;
8482 :
8483 83718 : se->class_container = ss_info->class_container;
8484 :
8485 83718 : gfc_free_ss_chain (ss);
8486 167562 : return;
8487 : }
8488 : break;
8489 :
8490 4834 : case EXPR_FUNCTION:
8491 : /* A transformational function return value will be a temporary
8492 : array descriptor. We still need to go through the scalarizer
8493 : to create the descriptor. Elemental functions are handled as
8494 : arbitrary expressions, i.e. copy to a temporary. */
8495 :
8496 4834 : if (se->direct_byref)
8497 : {
8498 126 : gcc_assert (ss_type == GFC_SS_FUNCTION && ss_expr == expr);
8499 :
8500 : /* For pointer assignments pass the descriptor directly. */
8501 126 : if (se->ss == NULL)
8502 126 : se->ss = ss;
8503 : else
8504 0 : gcc_assert (se->ss == ss);
8505 :
8506 126 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
8507 126 : gfc_conv_expr (se, expr);
8508 :
8509 126 : gfc_free_ss_chain (ss);
8510 126 : return;
8511 : }
8512 :
8513 4708 : if (ss_expr != expr || ss_type != GFC_SS_FUNCTION)
8514 : {
8515 3289 : if (ss_expr != expr)
8516 : /* Elemental function. */
8517 2564 : gcc_assert ((expr->value.function.esym != NULL
8518 : && expr->value.function.esym->attr.elemental)
8519 : || (expr->value.function.isym != NULL
8520 : && expr->value.function.isym->elemental)
8521 : || (gfc_expr_attr (expr).proc_pointer
8522 : && gfc_expr_attr (expr).elemental)
8523 : || gfc_inline_intrinsic_function_p (expr));
8524 :
8525 3289 : need_tmp = 1;
8526 3289 : if (expr->ts.type == BT_CHARACTER
8527 35 : && expr->ts.u.cl->length
8528 29 : && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
8529 13 : get_array_charlen (expr, se);
8530 :
8531 : info = NULL;
8532 : }
8533 : else
8534 : {
8535 : /* Transformational function. */
8536 1419 : info = &ss_info->data.array;
8537 1419 : need_tmp = 0;
8538 : }
8539 : break;
8540 :
8541 10093 : case EXPR_ARRAY:
8542 : /* Constant array constructors don't need a temporary. */
8543 10093 : if (ss_type == GFC_SS_CONSTRUCTOR
8544 10093 : && expr->ts.type != BT_CHARACTER
8545 18945 : && gfc_constant_array_constructor_p (expr->value.constructor))
8546 : {
8547 6924 : need_tmp = 0;
8548 6924 : info = &ss_info->data.array;
8549 : }
8550 : else
8551 : {
8552 : need_tmp = 1;
8553 : info = NULL;
8554 : }
8555 : break;
8556 :
8557 : default:
8558 : /* Something complicated. Copy it into a temporary. */
8559 : need_tmp = 1;
8560 : info = NULL;
8561 : break;
8562 : }
8563 :
8564 : /* If we are creating a temporary, we don't need to bother about aliases
8565 : anymore. */
8566 66016 : if (need_tmp)
8567 7445 : se->force_tmp = 0;
8568 :
8569 73182 : gfc_init_loopinfo (&loop);
8570 :
8571 : /* Associate the SS with the loop. */
8572 73182 : gfc_add_ss_to_loop (&loop, ss);
8573 :
8574 : /* Tell the scalarizer not to bother creating loop variables, etc. */
8575 73182 : if (!need_tmp)
8576 65737 : loop.array_parameter = 1;
8577 : else
8578 : /* The right-hand side of a pointer assignment mustn't use a temporary. */
8579 7445 : gcc_assert (!se->direct_byref);
8580 :
8581 : /* Do we need bounds checking or not? */
8582 73182 : ss->no_bounds_check = expr->no_bounds_check;
8583 :
8584 : /* Setup the scalarizing loops and bounds. */
8585 73182 : gfc_conv_ss_startstride (&loop);
8586 :
8587 : /* Add bounds-checking for elemental dimensions. */
8588 73182 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !expr->no_bounds_check)
8589 6668 : array_bound_check_elemental (se, ss, expr);
8590 :
8591 73182 : if (need_tmp)
8592 : {
8593 7445 : if (expr->ts.type == BT_CHARACTER
8594 1479 : && (!expr->ts.u.cl->backend_decl || expr->expr_type == EXPR_ARRAY))
8595 1372 : get_array_charlen (expr, se);
8596 :
8597 : /* Tell the scalarizer to make a temporary. */
8598 7445 : loop.temp_ss = gfc_get_temp_ss (gfc_typenode_for_spec (&expr->ts),
8599 7445 : ((expr->ts.type == BT_CHARACTER)
8600 1479 : ? expr->ts.u.cl->backend_decl
8601 : : NULL),
8602 : loop.dimen);
8603 :
8604 7445 : se->string_length = loop.temp_ss->info->string_length;
8605 7445 : gcc_assert (loop.temp_ss->dimen == loop.dimen);
8606 7445 : gfc_add_ss_to_loop (&loop, loop.temp_ss);
8607 : }
8608 :
8609 73182 : gfc_conv_loop_setup (&loop, & expr->where);
8610 :
8611 73182 : if (need_tmp)
8612 : {
8613 : /* Copy into a temporary and pass that. We don't need to copy the data
8614 : back because expressions and vector subscripts must be INTENT_IN. */
8615 : /* TODO: Optimize passing function return values. */
8616 7445 : gfc_se lse;
8617 7445 : gfc_se rse;
8618 7445 : bool deep_copy;
8619 :
8620 : /* Start the copying loops. */
8621 7445 : gfc_mark_ss_chain_used (loop.temp_ss, 1);
8622 7445 : gfc_mark_ss_chain_used (ss, 1);
8623 7445 : gfc_start_scalarized_body (&loop, &block);
8624 :
8625 : /* Copy each data element. */
8626 7445 : gfc_init_se (&lse, NULL);
8627 7445 : gfc_copy_loopinfo_to_se (&lse, &loop);
8628 7445 : gfc_init_se (&rse, NULL);
8629 7445 : gfc_copy_loopinfo_to_se (&rse, &loop);
8630 :
8631 7445 : lse.ss = loop.temp_ss;
8632 7445 : rse.ss = ss;
8633 :
8634 7445 : gfc_conv_tmp_array_ref (&lse);
8635 7445 : if (expr->ts.type == BT_CHARACTER)
8636 : {
8637 1479 : gfc_conv_expr (&rse, expr);
8638 1479 : if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
8639 1157 : rse.expr = build_fold_indirect_ref_loc (input_location,
8640 : rse.expr);
8641 : }
8642 : else
8643 5966 : gfc_conv_expr_val (&rse, expr);
8644 :
8645 7445 : gfc_add_block_to_block (&block, &rse.pre);
8646 7445 : gfc_add_block_to_block (&block, &lse.pre);
8647 :
8648 7445 : lse.string_length = rse.string_length;
8649 :
8650 14890 : deep_copy = !se->data_not_needed
8651 7445 : && (expr->expr_type == EXPR_VARIABLE
8652 6913 : || expr->expr_type == EXPR_ARRAY);
8653 7445 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts,
8654 : deep_copy, false);
8655 7445 : gfc_add_expr_to_block (&block, tmp);
8656 :
8657 : /* Finish the copying loops. */
8658 7445 : gfc_trans_scalarizing_loops (&loop, &block);
8659 :
8660 7445 : desc = loop.temp_ss->info->data.array.descriptor;
8661 : }
8662 67156 : else if (expr->expr_type == EXPR_FUNCTION && !transposed_dims (ss))
8663 : {
8664 1406 : desc = info->descriptor;
8665 1406 : se->string_length = ss_info->string_length;
8666 : }
8667 : else
8668 : {
8669 : /* We pass sections without copying to a temporary. Make a new
8670 : descriptor and point it at the section we want. The loop variable
8671 : limits will be the limits of the section.
8672 : A function may decide to repack the array to speed up access, but
8673 : we're not bothered about that here. */
8674 64331 : int dim, ndim, codim;
8675 64331 : tree parm;
8676 64331 : tree parmtype;
8677 64331 : tree dtype;
8678 64331 : tree stride;
8679 64331 : tree from;
8680 64331 : tree to;
8681 64331 : tree base;
8682 64331 : tree offset;
8683 :
8684 64331 : ndim = info->ref ? info->ref->u.ar.dimen : ss->dimen;
8685 :
8686 64331 : if (se->want_coarray)
8687 : {
8688 694 : gfc_array_ref *ar = &info->ref->u.ar;
8689 :
8690 694 : codim = expr->corank;
8691 1512 : for (n = 0; n < codim - 1; n++)
8692 : {
8693 : /* Make sure we are not lost somehow. */
8694 818 : gcc_assert (ar->dimen_type[n + ndim] == DIMEN_THIS_IMAGE);
8695 :
8696 : /* Make sure the call to gfc_conv_section_startstride won't
8697 : generate unnecessary code to calculate stride. */
8698 818 : gcc_assert (ar->stride[n + ndim] == NULL);
8699 :
8700 818 : gfc_conv_section_startstride (&loop.pre, ss, n + ndim);
8701 818 : loop.from[n + loop.dimen] = info->start[n + ndim];
8702 818 : loop.to[n + loop.dimen] = info->end[n + ndim];
8703 : }
8704 :
8705 694 : gcc_assert (n == codim - 1);
8706 694 : evaluate_bound (&loop.pre, info->start, ar->start,
8707 : info->descriptor, n + ndim, true,
8708 694 : ar->as->type == AS_DEFERRED, true);
8709 694 : loop.from[n + loop.dimen] = info->start[n + ndim];
8710 : }
8711 : else
8712 : codim = 0;
8713 :
8714 : /* Set the string_length for a character array. */
8715 64331 : if (expr->ts.type == BT_CHARACTER)
8716 : {
8717 11500 : if (deferred_array_component && !substr)
8718 37 : se->string_length = ss_info->string_length;
8719 : else
8720 11463 : se->string_length = gfc_get_expr_charlen (expr);
8721 :
8722 11500 : if (VAR_P (se->string_length)
8723 990 : && expr->ts.u.cl->backend_decl == se->string_length)
8724 984 : tmp = ss_info->string_length;
8725 : else
8726 : tmp = se->string_length;
8727 :
8728 11500 : if (expr->ts.deferred && expr->ts.u.cl->backend_decl
8729 217 : && VAR_P (expr->ts.u.cl->backend_decl))
8730 156 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, tmp);
8731 : else
8732 11344 : expr->ts.u.cl->backend_decl = tmp;
8733 : }
8734 :
8735 : /* If we have an array section, are assigning or passing an array
8736 : section argument make sure that the lower bound is 1. References
8737 : to the full array should otherwise keep the original bounds. */
8738 64331 : if (!info->ref || info->ref->u.ar.type != AR_FULL)
8739 82839 : for (dim = 0; dim < loop.dimen; dim++)
8740 50436 : if (!integer_onep (loop.from[dim]))
8741 : {
8742 27098 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
8743 : gfc_array_index_type, gfc_index_one_node,
8744 : loop.from[dim]);
8745 27098 : loop.to[dim] = fold_build2_loc (input_location, PLUS_EXPR,
8746 : gfc_array_index_type,
8747 : loop.to[dim], tmp);
8748 27098 : loop.from[dim] = gfc_index_one_node;
8749 : }
8750 :
8751 64331 : desc = info->descriptor;
8752 64331 : if (se->direct_byref && !se->byref_noassign)
8753 : {
8754 : /* For pointer assignments we fill in the destination. */
8755 2652 : parm = se->expr;
8756 2652 : parmtype = TREE_TYPE (parm);
8757 : }
8758 : else
8759 : {
8760 : /* Otherwise make a new one. */
8761 61679 : if (expr->ts.type == BT_CHARACTER)
8762 10848 : parmtype = gfc_typenode_for_spec (&expr->ts);
8763 : else
8764 50831 : parmtype = gfc_get_element_type (TREE_TYPE (desc));
8765 :
8766 61679 : parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, codim,
8767 : loop.from, loop.to, 0,
8768 : GFC_ARRAY_UNKNOWN, false);
8769 61679 : parm = gfc_create_var (parmtype, "parm");
8770 :
8771 : /* When expression is a class object, then add the class' handle to
8772 : the parm_decl. */
8773 61679 : if (expr->ts.type == BT_CLASS && expr->expr_type == EXPR_VARIABLE)
8774 : {
8775 1166 : gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr);
8776 1166 : gfc_se classse;
8777 :
8778 : /* class_expr can be NULL, when no _class ref is in expr.
8779 : We must not fix this here with a gfc_fix_class_ref (). */
8780 1166 : if (class_expr)
8781 : {
8782 1156 : gfc_init_se (&classse, NULL);
8783 1156 : gfc_conv_expr (&classse, class_expr);
8784 1156 : gfc_free_expr (class_expr);
8785 :
8786 1156 : gcc_assert (classse.pre.head == NULL_TREE
8787 : && classse.post.head == NULL_TREE);
8788 1156 : gfc_allocate_lang_decl (parm);
8789 1156 : GFC_DECL_SAVED_DESCRIPTOR (parm) = classse.expr;
8790 : }
8791 : }
8792 : }
8793 :
8794 64331 : if (expr->ts.type == BT_CHARACTER
8795 64331 : && VAR_P (TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (parm)))))
8796 : {
8797 0 : tree elem_len = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (parm)));
8798 0 : gfc_add_modify (&loop.pre, elem_len,
8799 0 : fold_convert (TREE_TYPE (elem_len),
8800 : gfc_get_array_span (desc, expr)));
8801 : }
8802 :
8803 : /* Set the span field. */
8804 64331 : tmp = NULL_TREE;
8805 64331 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
8806 7657 : tmp = gfc_conv_descriptor_span_get (desc);
8807 : else
8808 56674 : tmp = gfc_get_array_span (desc, expr);
8809 64331 : if (tmp)
8810 64251 : gfc_conv_descriptor_span_set (&loop.pre, parm, tmp);
8811 :
8812 : /* The following can be somewhat confusing. We have two
8813 : descriptors, a new one and the original array.
8814 : {parm, parmtype, dim} refer to the new one.
8815 : {desc, type, n, loop} refer to the original, which maybe
8816 : a descriptorless array.
8817 : The bounds of the scalarization are the bounds of the section.
8818 : We don't have to worry about numeric overflows when calculating
8819 : the offsets because all elements are within the array data. */
8820 :
8821 : /* Set the dtype. */
8822 64331 : tmp = gfc_conv_descriptor_dtype (parm);
8823 64331 : if (se->unlimited_polymorphic)
8824 613 : dtype = gfc_get_dtype (TREE_TYPE (desc), &loop.dimen);
8825 63718 : else if (expr->ts.type == BT_ASSUMED)
8826 : {
8827 127 : tree tmp2 = desc;
8828 127 : if (DECL_LANG_SPECIFIC (tmp2) && GFC_DECL_SAVED_DESCRIPTOR (tmp2))
8829 127 : tmp2 = GFC_DECL_SAVED_DESCRIPTOR (tmp2);
8830 127 : if (POINTER_TYPE_P (TREE_TYPE (tmp2)))
8831 127 : tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
8832 127 : dtype = gfc_conv_descriptor_dtype (tmp2);
8833 : }
8834 : else
8835 63591 : dtype = gfc_get_dtype (parmtype);
8836 64331 : gfc_add_modify (&loop.pre, tmp, dtype);
8837 :
8838 : /* The 1st element in the section. */
8839 64331 : base = gfc_index_zero_node;
8840 64331 : if (expr->ts.type == BT_CHARACTER && expr->rank == 0 && codim)
8841 6 : base = gfc_index_one_node;
8842 :
8843 : /* The offset from the 1st element in the section. */
8844 : offset = gfc_index_zero_node;
8845 :
8846 165468 : for (n = 0; n < ndim; n++)
8847 : {
8848 101137 : stride = gfc_conv_array_stride (desc, n);
8849 :
8850 : /* Work out the 1st element in the section. */
8851 101137 : if (info->ref
8852 93827 : && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
8853 : {
8854 1202 : gcc_assert (info->subscript[n]
8855 : && info->subscript[n]->info->type == GFC_SS_SCALAR);
8856 1202 : start = info->subscript[n]->info->data.scalar.value;
8857 : }
8858 : else
8859 : {
8860 : /* Evaluate and remember the start of the section. */
8861 99935 : start = info->start[n];
8862 99935 : stride = gfc_evaluate_now (stride, &loop.pre);
8863 : }
8864 :
8865 101137 : tmp = gfc_conv_array_lbound (desc, n);
8866 101137 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
8867 : start, tmp);
8868 101137 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
8869 : tmp, stride);
8870 101137 : base = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
8871 : base, tmp);
8872 :
8873 101137 : if (info->ref
8874 93827 : && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
8875 : {
8876 : /* For elemental dimensions, we only need the 1st
8877 : element in the section. */
8878 1202 : continue;
8879 : }
8880 :
8881 : /* Vector subscripts need copying and are handled elsewhere. */
8882 99935 : if (info->ref)
8883 92625 : gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
8884 :
8885 : /* look for the corresponding scalarizer dimension: dim. */
8886 150423 : for (dim = 0; dim < ndim; dim++)
8887 150423 : if (ss->dim[dim] == n)
8888 : break;
8889 :
8890 : /* loop exited early: the DIM being looked for has been found. */
8891 99935 : gcc_assert (dim < ndim);
8892 :
8893 : /* Set the new lower bound. */
8894 99935 : from = loop.from[dim];
8895 99935 : to = loop.to[dim];
8896 :
8897 99935 : gfc_conv_descriptor_lbound_set (&loop.pre, parm,
8898 : gfc_rank_cst[dim], from);
8899 :
8900 : /* Set the new upper bound. */
8901 99935 : gfc_conv_descriptor_ubound_set (&loop.pre, parm,
8902 : gfc_rank_cst[dim], to);
8903 :
8904 : /* Multiply the stride by the section stride to get the
8905 : total stride. */
8906 99935 : stride = fold_build2_loc (input_location, MULT_EXPR,
8907 : gfc_array_index_type,
8908 : stride, info->stride[n]);
8909 :
8910 99935 : tmp = fold_build2_loc (input_location, MULT_EXPR,
8911 99935 : TREE_TYPE (offset), stride, from);
8912 99935 : offset = fold_build2_loc (input_location, MINUS_EXPR,
8913 99935 : TREE_TYPE (offset), offset, tmp);
8914 :
8915 : /* Store the new stride. */
8916 99935 : gfc_conv_descriptor_stride_set (&loop.pre, parm,
8917 : gfc_rank_cst[dim], stride);
8918 : }
8919 :
8920 : /* For deferred-length character we need to take the dynamic length
8921 : into account for the dataptr offset. */
8922 64331 : if (expr->ts.type == BT_CHARACTER
8923 11500 : && expr->ts.deferred
8924 223 : && expr->ts.u.cl->backend_decl
8925 223 : && VAR_P (expr->ts.u.cl->backend_decl))
8926 : {
8927 156 : tree base_type = TREE_TYPE (base);
8928 156 : base = fold_build2_loc (input_location, MULT_EXPR, base_type, base,
8929 : fold_convert (base_type,
8930 : expr->ts.u.cl->backend_decl));
8931 : }
8932 :
8933 65843 : for (n = loop.dimen; n < loop.dimen + codim; n++)
8934 : {
8935 1512 : from = loop.from[n];
8936 1512 : to = loop.to[n];
8937 1512 : gfc_conv_descriptor_lbound_set (&loop.pre, parm,
8938 : gfc_rank_cst[n], from);
8939 1512 : if (n < loop.dimen + codim - 1)
8940 818 : gfc_conv_descriptor_ubound_set (&loop.pre, parm,
8941 : gfc_rank_cst[n], to);
8942 : }
8943 :
8944 64331 : if (se->data_not_needed)
8945 6038 : gfc_conv_descriptor_data_set (&loop.pre, parm,
8946 : gfc_index_zero_node);
8947 : else
8948 : /* Point the data pointer at the 1st element in the section. */
8949 58293 : gfc_get_dataptr_offset (&loop.pre, parm, desc, base,
8950 : subref_array_target, expr);
8951 :
8952 64331 : gfc_conv_descriptor_offset_set (&loop.pre, parm, offset);
8953 :
8954 64331 : if (flag_coarray == GFC_FCOARRAY_LIB && expr->corank)
8955 : {
8956 404 : tmp = INDIRECT_REF_P (desc) ? TREE_OPERAND (desc, 0) : desc;
8957 404 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
8958 : {
8959 24 : tmp = gfc_conv_descriptor_token (tmp);
8960 : }
8961 380 : else if (DECL_P (tmp) && DECL_LANG_SPECIFIC (tmp)
8962 460 : && GFC_DECL_TOKEN (tmp) != NULL_TREE)
8963 64 : tmp = GFC_DECL_TOKEN (tmp);
8964 : else
8965 : {
8966 316 : tmp = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (tmp));
8967 : }
8968 :
8969 404 : gfc_add_modify (&loop.pre, gfc_conv_descriptor_token (parm), tmp);
8970 : }
8971 : desc = parm;
8972 : }
8973 :
8974 : /* For class arrays add the class tree into the saved descriptor to
8975 : enable getting of _vptr and the like. */
8976 73182 : if (expr->expr_type == EXPR_VARIABLE && VAR_P (desc)
8977 56769 : && IS_CLASS_ARRAY (expr->symtree->n.sym))
8978 : {
8979 1138 : gfc_allocate_lang_decl (desc);
8980 1138 : GFC_DECL_SAVED_DESCRIPTOR (desc) =
8981 1138 : DECL_LANG_SPECIFIC (expr->symtree->n.sym->backend_decl) ?
8982 1052 : GFC_DECL_SAVED_DESCRIPTOR (expr->symtree->n.sym->backend_decl)
8983 : : expr->symtree->n.sym->backend_decl;
8984 : }
8985 72044 : else if (expr->expr_type == EXPR_ARRAY && VAR_P (desc)
8986 10093 : && IS_CLASS_ARRAY (expr))
8987 : {
8988 12 : tree vtype;
8989 12 : gfc_allocate_lang_decl (desc);
8990 12 : tmp = gfc_create_var (expr->ts.u.derived->backend_decl, "class");
8991 12 : GFC_DECL_SAVED_DESCRIPTOR (desc) = tmp;
8992 12 : vtype = gfc_class_vptr_get (tmp);
8993 12 : gfc_add_modify (&se->pre, vtype,
8994 12 : gfc_build_addr_expr (TREE_TYPE (vtype),
8995 12 : gfc_find_vtab (&expr->ts)->backend_decl));
8996 : }
8997 73182 : if (!se->direct_byref || se->byref_noassign)
8998 : {
8999 : /* Get a pointer to the new descriptor. */
9000 70530 : if (se->want_pointer)
9001 39865 : se->expr = gfc_build_addr_expr (NULL_TREE, desc);
9002 : else
9003 30665 : se->expr = desc;
9004 : }
9005 :
9006 73182 : gfc_add_block_to_block (&se->pre, &loop.pre);
9007 73182 : gfc_add_block_to_block (&se->post, &loop.post);
9008 :
9009 : /* Cleanup the scalarizer. */
9010 73182 : gfc_cleanup_loop (&loop);
9011 : }
9012 :
9013 :
9014 : /* Calculate the array size (number of elements); if dim != NULL_TREE,
9015 : return size for that dim (dim=0..rank-1; only for GFC_DESCRIPTOR_TYPE_P).
9016 : If !expr && descriptor array, the rank is taken from the descriptor. */
9017 : tree
9018 15163 : gfc_tree_array_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree dim)
9019 : {
9020 15163 : if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
9021 : {
9022 34 : gcc_assert (dim == NULL_TREE);
9023 34 : return GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
9024 : }
9025 15129 : tree size, tmp, rank = NULL_TREE, cond = NULL_TREE;
9026 15129 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
9027 15129 : enum gfc_array_kind akind = GFC_TYPE_ARRAY_AKIND (TREE_TYPE (desc));
9028 15129 : if (expr == NULL || expr->rank < 0)
9029 3363 : rank = fold_convert (signed_char_type_node,
9030 : gfc_conv_descriptor_rank (desc));
9031 : else
9032 11766 : rank = build_int_cst (signed_char_type_node, expr->rank);
9033 :
9034 15129 : if (dim || (expr && expr->rank == 1))
9035 : {
9036 4503 : if (!dim)
9037 4503 : dim = gfc_index_zero_node;
9038 13473 : tree ubound = gfc_conv_descriptor_ubound_get (desc, dim);
9039 13473 : tree lbound = gfc_conv_descriptor_lbound_get (desc, dim);
9040 :
9041 13473 : size = fold_build2_loc (input_location, MINUS_EXPR,
9042 : gfc_array_index_type, ubound, lbound);
9043 13473 : size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
9044 : size, gfc_index_one_node);
9045 : /* if (!allocatable && !pointer && assumed rank)
9046 : size = (idx == rank && ubound[rank-1] == -1 ? -1 : size;
9047 : else
9048 : size = max (0, size); */
9049 13473 : size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
9050 : size, gfc_index_zero_node);
9051 13473 : if (akind == GFC_ARRAY_ASSUMED_RANK_CONT
9052 13473 : || akind == GFC_ARRAY_ASSUMED_RANK)
9053 : {
9054 2676 : tmp = fold_build2_loc (input_location, MINUS_EXPR, signed_char_type_node,
9055 : rank, build_int_cst (signed_char_type_node, 1));
9056 2676 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
9057 : fold_convert (signed_char_type_node, dim),
9058 : tmp);
9059 2676 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
9060 : gfc_conv_descriptor_ubound_get (desc, dim),
9061 : build_int_cst (gfc_array_index_type, -1));
9062 2676 : cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
9063 : cond, tmp);
9064 2676 : tmp = build_int_cst (gfc_array_index_type, -1);
9065 2676 : size = build3_loc (input_location, COND_EXPR, gfc_array_index_type,
9066 : cond, tmp, size);
9067 : }
9068 13473 : return size;
9069 : }
9070 :
9071 : /* size = 1. */
9072 1656 : size = gfc_create_var (gfc_array_index_type, "size");
9073 1656 : gfc_add_modify (block, size, build_int_cst (TREE_TYPE (size), 1));
9074 1656 : tree extent = gfc_create_var (gfc_array_index_type, "extent");
9075 :
9076 1656 : stmtblock_t cond_block, loop_body;
9077 1656 : gfc_init_block (&cond_block);
9078 1656 : gfc_init_block (&loop_body);
9079 :
9080 : /* Loop: for (i = 0; i < rank; ++i). */
9081 1656 : tree idx = gfc_create_var (signed_char_type_node, "idx");
9082 : /* Loop body. */
9083 : /* #if (assumed-rank + !allocatable && !pointer)
9084 : if (idx == rank - 1 && dim[idx].ubound == -1)
9085 : extent = -1;
9086 : else
9087 : #endif
9088 : extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1
9089 : if (extent < 0)
9090 : extent = 0
9091 : size *= extent. */
9092 1656 : cond = NULL_TREE;
9093 1656 : if (akind == GFC_ARRAY_ASSUMED_RANK_CONT || akind == GFC_ARRAY_ASSUMED_RANK)
9094 : {
9095 459 : tmp = fold_build2_loc (input_location, MINUS_EXPR, signed_char_type_node,
9096 : rank, build_int_cst (signed_char_type_node, 1));
9097 459 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
9098 : idx, tmp);
9099 459 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
9100 : gfc_conv_descriptor_ubound_get (desc, idx),
9101 : build_int_cst (gfc_array_index_type, -1));
9102 459 : cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
9103 : cond, tmp);
9104 : }
9105 1656 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
9106 : gfc_conv_descriptor_ubound_get (desc, idx),
9107 : gfc_conv_descriptor_lbound_get (desc, idx));
9108 1656 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
9109 : tmp, gfc_index_one_node);
9110 1656 : gfc_add_modify (&cond_block, extent, tmp);
9111 1656 : tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
9112 : extent, gfc_index_zero_node);
9113 1656 : tmp = build3_v (COND_EXPR, tmp,
9114 : fold_build2_loc (input_location, MODIFY_EXPR,
9115 : gfc_array_index_type,
9116 : extent, gfc_index_zero_node),
9117 : build_empty_stmt (input_location));
9118 1656 : gfc_add_expr_to_block (&cond_block, tmp);
9119 1656 : tmp = gfc_finish_block (&cond_block);
9120 1656 : if (cond)
9121 459 : tmp = build3_v (COND_EXPR, cond,
9122 : fold_build2_loc (input_location, MODIFY_EXPR,
9123 : gfc_array_index_type, extent,
9124 : build_int_cst (gfc_array_index_type, -1)),
9125 : tmp);
9126 1656 : gfc_add_expr_to_block (&loop_body, tmp);
9127 : /* size *= extent. */
9128 1656 : gfc_add_modify (&loop_body, size,
9129 : fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9130 : size, extent));
9131 : /* Generate loop. */
9132 3312 : gfc_simple_for_loop (block, idx, build_int_cst (TREE_TYPE (idx), 0), rank, LT_EXPR,
9133 1656 : build_int_cst (TREE_TYPE (idx), 1),
9134 : gfc_finish_block (&loop_body));
9135 1656 : return size;
9136 : }
9137 :
9138 : /* Helper function for gfc_conv_array_parameter if array size needs to be
9139 : computed. */
9140 :
9141 : static void
9142 112 : array_parameter_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree *size)
9143 : {
9144 112 : tree elem;
9145 112 : *size = gfc_tree_array_size (block, desc, expr, NULL);
9146 112 : elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
9147 112 : *size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9148 : *size, fold_convert (gfc_array_index_type, elem));
9149 112 : }
9150 :
9151 : /* Helper function - return true if the argument is a pointer. */
9152 :
9153 : static bool
9154 737 : is_pointer (gfc_expr *e)
9155 : {
9156 737 : gfc_symbol *sym;
9157 :
9158 737 : if (e->expr_type != EXPR_VARIABLE || e->symtree == NULL)
9159 : return false;
9160 :
9161 737 : sym = e->symtree->n.sym;
9162 737 : if (sym == NULL)
9163 : return false;
9164 :
9165 737 : return sym->attr.pointer || sym->attr.proc_pointer;
9166 : }
9167 :
9168 : /* Convert an array for passing as an actual parameter. */
9169 :
9170 : void
9171 65373 : gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr, bool g77,
9172 : const gfc_symbol *fsym, const char *proc_name,
9173 : tree *size, tree *lbshift, tree *packed)
9174 : {
9175 65373 : tree ptr;
9176 65373 : tree desc;
9177 65373 : tree tmp = NULL_TREE;
9178 65373 : tree stmt;
9179 65373 : tree parent = DECL_CONTEXT (current_function_decl);
9180 65373 : tree ctree;
9181 65373 : tree pack_attr = NULL_TREE; /* Set when packing class arrays. */
9182 65373 : bool full_array_var;
9183 65373 : bool this_array_result;
9184 65373 : bool contiguous;
9185 65373 : bool no_pack;
9186 65373 : bool array_constructor;
9187 65373 : bool good_allocatable;
9188 65373 : bool ultimate_ptr_comp;
9189 65373 : bool ultimate_alloc_comp;
9190 65373 : bool readonly;
9191 65373 : gfc_symbol *sym;
9192 65373 : stmtblock_t block;
9193 65373 : gfc_ref *ref;
9194 :
9195 65373 : ultimate_ptr_comp = false;
9196 65373 : ultimate_alloc_comp = false;
9197 :
9198 66085 : for (ref = expr->ref; ref; ref = ref->next)
9199 : {
9200 54691 : if (ref->next == NULL)
9201 : break;
9202 :
9203 712 : if (ref->type == REF_COMPONENT)
9204 : {
9205 634 : ultimate_ptr_comp = ref->u.c.component->attr.pointer;
9206 634 : ultimate_alloc_comp = ref->u.c.component->attr.allocatable;
9207 : }
9208 : }
9209 :
9210 65373 : full_array_var = false;
9211 65373 : contiguous = false;
9212 :
9213 65373 : if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp)
9214 53887 : full_array_var = gfc_full_array_ref_p (ref, &contiguous);
9215 :
9216 53887 : sym = full_array_var ? expr->symtree->n.sym : NULL;
9217 :
9218 : /* The symbol should have an array specification. */
9219 62478 : gcc_assert (!sym || sym->as || ref->u.ar.as);
9220 :
9221 65373 : if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
9222 : {
9223 690 : get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
9224 690 : expr->ts.u.cl->backend_decl = tmp;
9225 690 : se->string_length = tmp;
9226 : }
9227 :
9228 : /* Is this the result of the enclosing procedure? */
9229 65373 : this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
9230 58 : if (this_array_result
9231 58 : && (sym->backend_decl != current_function_decl)
9232 0 : && (sym->backend_decl != parent))
9233 65373 : this_array_result = false;
9234 :
9235 : /* Passing an optional dummy argument as actual to an optional dummy? */
9236 65373 : bool pass_optional;
9237 65373 : pass_optional = fsym && fsym->attr.optional && sym && sym->attr.optional;
9238 :
9239 : /* Passing address of the array if it is not pointer or assumed-shape. */
9240 65373 : if (full_array_var && g77 && !this_array_result
9241 15860 : && sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
9242 : {
9243 12489 : tmp = gfc_get_symbol_decl (sym);
9244 :
9245 12489 : if (sym->ts.type == BT_CHARACTER)
9246 2773 : se->string_length = sym->ts.u.cl->backend_decl;
9247 :
9248 12489 : if (!sym->attr.pointer
9249 11984 : && sym->as
9250 11984 : && sym->as->type != AS_ASSUMED_SHAPE
9251 11739 : && sym->as->type != AS_DEFERRED
9252 10245 : && sym->as->type != AS_ASSUMED_RANK
9253 10169 : && !sym->attr.allocatable)
9254 : {
9255 : /* Some variables are declared directly, others are declared as
9256 : pointers and allocated on the heap. */
9257 9663 : if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
9258 2501 : se->expr = tmp;
9259 : else
9260 7162 : se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
9261 9663 : if (size)
9262 34 : array_parameter_size (&se->pre, tmp, expr, size);
9263 16730 : return;
9264 : }
9265 :
9266 2826 : if (sym->attr.allocatable)
9267 : {
9268 1880 : if (sym->attr.dummy || sym->attr.result)
9269 : {
9270 1176 : gfc_conv_expr_descriptor (se, expr);
9271 1176 : tmp = se->expr;
9272 : }
9273 1880 : if (size)
9274 14 : array_parameter_size (&se->pre, tmp, expr, size);
9275 1880 : se->expr = gfc_conv_array_data (tmp);
9276 1880 : if (pass_optional)
9277 : {
9278 18 : tree cond = gfc_conv_expr_present (sym);
9279 36 : se->expr = build3_loc (input_location, COND_EXPR,
9280 18 : TREE_TYPE (se->expr), cond, se->expr,
9281 18 : fold_convert (TREE_TYPE (se->expr),
9282 : null_pointer_node));
9283 : }
9284 1880 : return;
9285 : }
9286 : }
9287 :
9288 : /* A convenient reduction in scope. */
9289 53830 : contiguous = g77 && !this_array_result && contiguous;
9290 :
9291 : /* There is no need to pack and unpack the array, if it is contiguous
9292 : and not a deferred- or assumed-shape array, or if it is simply
9293 : contiguous. */
9294 53830 : no_pack = false;
9295 : // clang-format off
9296 53830 : if (sym)
9297 : {
9298 39539 : symbol_attribute *attr = &(IS_CLASS_ARRAY (sym)
9299 : ? CLASS_DATA (sym)->attr : sym->attr);
9300 39539 : gfc_array_spec *as = IS_CLASS_ARRAY (sym)
9301 39539 : ? CLASS_DATA (sym)->as : sym->as;
9302 39539 : no_pack = (as
9303 39267 : && !attr->pointer
9304 35994 : && as->type != AS_DEFERRED
9305 26424 : && as->type != AS_ASSUMED_RANK
9306 63034 : && as->type != AS_ASSUMED_SHAPE);
9307 : }
9308 53830 : if (ref && ref->u.ar.as)
9309 42434 : no_pack = no_pack
9310 42434 : || (ref->u.ar.as->type != AS_DEFERRED
9311 : && ref->u.ar.as->type != AS_ASSUMED_RANK
9312 : && ref->u.ar.as->type != AS_ASSUMED_SHAPE);
9313 107660 : no_pack = contiguous
9314 53830 : && (no_pack || gfc_is_simply_contiguous (expr, false, true));
9315 : // clang-format on
9316 :
9317 : /* If we have an EXPR_OP or a function returning an explicit-shaped
9318 : or allocatable array, an array temporary will be generated which
9319 : does not need to be packed / unpacked if passed to an
9320 : explicit-shape dummy array. */
9321 :
9322 53830 : if (g77)
9323 : {
9324 6252 : if (expr->expr_type == EXPR_OP)
9325 : no_pack = 1;
9326 6175 : else if (expr->expr_type == EXPR_FUNCTION && expr->value.function.esym)
9327 : {
9328 41 : gfc_symbol *result = expr->value.function.esym->result;
9329 41 : if (result->attr.dimension
9330 41 : && (result->as->type == AS_EXPLICIT
9331 14 : || result->attr.allocatable
9332 7 : || result->attr.contiguous))
9333 112 : no_pack = 1;
9334 : }
9335 : }
9336 :
9337 : /* Array constructors are always contiguous and do not need packing. */
9338 53830 : array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY;
9339 :
9340 : /* Same is true of contiguous sections from allocatable variables. */
9341 107660 : good_allocatable = contiguous
9342 4434 : && expr->symtree
9343 58264 : && expr->symtree->n.sym->attr.allocatable;
9344 :
9345 : /* Or ultimate allocatable components. */
9346 53830 : ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
9347 :
9348 53830 : if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp)
9349 : {
9350 4797 : gfc_conv_expr_descriptor (se, expr);
9351 : /* Deallocate the allocatable components of structures that are
9352 : not variable. */
9353 4797 : if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
9354 3286 : && expr->ts.u.derived->attr.alloc_comp
9355 1931 : && expr->expr_type != EXPR_VARIABLE)
9356 : {
9357 2 : tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, se->expr, expr->rank);
9358 :
9359 : /* The components shall be deallocated before their containing entity. */
9360 2 : gfc_prepend_expr_to_block (&se->post, tmp);
9361 : }
9362 4797 : if (expr->ts.type == BT_CHARACTER && expr->expr_type != EXPR_FUNCTION)
9363 279 : se->string_length = expr->ts.u.cl->backend_decl;
9364 4797 : if (size)
9365 34 : array_parameter_size (&se->pre, se->expr, expr, size);
9366 4797 : se->expr = gfc_conv_array_data (se->expr);
9367 4797 : return;
9368 : }
9369 :
9370 49033 : if (fsym && fsym->ts.type == BT_CLASS)
9371 : {
9372 1212 : gcc_assert (se->expr);
9373 : ctree = se->expr;
9374 : }
9375 : else
9376 : ctree = NULL_TREE;
9377 :
9378 49033 : if (this_array_result)
9379 : {
9380 : /* Result of the enclosing function. */
9381 58 : gfc_conv_expr_descriptor (se, expr);
9382 58 : if (size)
9383 0 : array_parameter_size (&se->pre, se->expr, expr, size);
9384 58 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
9385 :
9386 18 : if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
9387 76 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
9388 18 : se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location,
9389 : se->expr));
9390 :
9391 58 : return;
9392 : }
9393 : else
9394 : {
9395 : /* Every other type of array. */
9396 48975 : se->want_pointer = (ctree) ? 0 : 1;
9397 48975 : se->want_coarray = expr->corank;
9398 48975 : gfc_conv_expr_descriptor (se, expr);
9399 :
9400 48975 : if (size)
9401 30 : array_parameter_size (&se->pre,
9402 : build_fold_indirect_ref_loc (input_location,
9403 : se->expr),
9404 : expr, size);
9405 48975 : if (ctree)
9406 : {
9407 1212 : stmtblock_t block;
9408 :
9409 1212 : gfc_init_block (&block);
9410 1212 : if (lbshift && *lbshift)
9411 : {
9412 : /* Apply a shift of the lbound when supplied. */
9413 98 : for (int dim = 0; dim < expr->rank; ++dim)
9414 49 : gfc_conv_shift_descriptor_lbound (&block, se->expr, dim,
9415 : *lbshift);
9416 : }
9417 1212 : tmp = gfc_class_data_get (ctree);
9418 1212 : if (expr->rank > 1 && CLASS_DATA (fsym)->as->rank != expr->rank
9419 84 : && CLASS_DATA (fsym)->as->type == AS_EXPLICIT && !no_pack)
9420 : {
9421 36 : tree arr = gfc_create_var (TREE_TYPE (tmp), "parm");
9422 36 : gfc_conv_descriptor_data_set (&block, arr,
9423 : gfc_conv_descriptor_data_get (
9424 : se->expr));
9425 36 : gfc_conv_descriptor_lbound_set (&block, arr, gfc_index_zero_node,
9426 : gfc_index_zero_node);
9427 36 : gfc_conv_descriptor_ubound_set (
9428 : &block, arr, gfc_index_zero_node,
9429 : gfc_conv_descriptor_size (se->expr, expr->rank));
9430 36 : gfc_conv_descriptor_stride_set (
9431 : &block, arr, gfc_index_zero_node,
9432 : gfc_conv_descriptor_stride_get (se->expr, gfc_index_zero_node));
9433 36 : gfc_add_modify (&block, gfc_conv_descriptor_dtype (arr),
9434 : gfc_conv_descriptor_dtype (se->expr));
9435 36 : gfc_add_modify (&block, gfc_conv_descriptor_rank (arr),
9436 : build_int_cst (signed_char_type_node, 1));
9437 36 : gfc_conv_descriptor_span_set (&block, arr,
9438 : gfc_conv_descriptor_span_get (arr));
9439 36 : gfc_conv_descriptor_offset_set (&block, arr, gfc_index_zero_node);
9440 36 : se->expr = arr;
9441 : }
9442 1212 : gfc_class_array_data_assign (&block, tmp, se->expr, true);
9443 :
9444 : /* Handle optional. */
9445 1212 : if (fsym && fsym->attr.optional && sym && sym->attr.optional)
9446 348 : tmp = build3_v (COND_EXPR, gfc_conv_expr_present (sym),
9447 : gfc_finish_block (&block),
9448 : build_empty_stmt (input_location));
9449 : else
9450 864 : tmp = gfc_finish_block (&block);
9451 :
9452 1212 : gfc_add_expr_to_block (&se->pre, tmp);
9453 : }
9454 47763 : else if (pass_optional && full_array_var && sym->as && sym->as->rank != 0)
9455 : {
9456 : /* Perform calculation of bounds and strides of optional array dummy
9457 : only if the argument is present. */
9458 219 : tmp = build3_v (COND_EXPR, gfc_conv_expr_present (sym),
9459 : gfc_finish_block (&se->pre),
9460 : build_empty_stmt (input_location));
9461 219 : gfc_add_expr_to_block (&se->pre, tmp);
9462 : }
9463 : }
9464 :
9465 : /* Deallocate the allocatable components of structures that are
9466 : not variable, for descriptorless arguments.
9467 : Arguments with a descriptor are handled in gfc_conv_procedure_call. */
9468 48975 : if (g77 && (expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
9469 75 : && expr->ts.u.derived->attr.alloc_comp
9470 21 : && expr->expr_type != EXPR_VARIABLE)
9471 : {
9472 0 : tmp = build_fold_indirect_ref_loc (input_location, se->expr);
9473 0 : tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank);
9474 :
9475 : /* The components shall be deallocated before their containing entity. */
9476 0 : gfc_prepend_expr_to_block (&se->post, tmp);
9477 : }
9478 :
9479 47538 : if (g77 || (fsym && fsym->attr.contiguous
9480 1530 : && !gfc_is_simply_contiguous (expr, false, true)))
9481 : {
9482 1581 : tree origptr = NULL_TREE, packedptr = NULL_TREE;
9483 :
9484 1581 : desc = se->expr;
9485 :
9486 : /* For contiguous arrays, save the original value of the descriptor. */
9487 1581 : if (!g77 && !ctree)
9488 : {
9489 48 : origptr = gfc_create_var (pvoid_type_node, "origptr");
9490 48 : tmp = build_fold_indirect_ref_loc (input_location, desc);
9491 48 : tmp = gfc_conv_array_data (tmp);
9492 96 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
9493 48 : TREE_TYPE (origptr), origptr,
9494 48 : fold_convert (TREE_TYPE (origptr), tmp));
9495 48 : gfc_add_expr_to_block (&se->pre, tmp);
9496 : }
9497 :
9498 : /* Repack the array. */
9499 1581 : if (warn_array_temporaries)
9500 : {
9501 28 : if (fsym)
9502 18 : gfc_warning (OPT_Warray_temporaries,
9503 : "Creating array temporary at %L for argument %qs",
9504 18 : &expr->where, fsym->name);
9505 : else
9506 10 : gfc_warning (OPT_Warray_temporaries,
9507 : "Creating array temporary at %L", &expr->where);
9508 : }
9509 :
9510 : /* When optimizing, we can use gfc_conv_subref_array_arg for
9511 : making the packing and unpacking operation visible to the
9512 : optimizers. */
9513 :
9514 1437 : if (g77 && flag_inline_arg_packing && expr->expr_type == EXPR_VARIABLE
9515 737 : && !is_pointer (expr) && ! gfc_has_dimen_vector_ref (expr)
9516 353 : && !(expr->symtree->n.sym->as
9517 324 : && expr->symtree->n.sym->as->type == AS_ASSUMED_RANK)
9518 1934 : && (fsym == NULL || fsym->ts.type != BT_ASSUMED))
9519 : {
9520 332 : gfc_conv_subref_array_arg (se, expr, g77,
9521 141 : fsym ? fsym->attr.intent : INTENT_INOUT,
9522 : false, fsym, proc_name, sym, true);
9523 332 : return;
9524 : }
9525 :
9526 1249 : if (ctree)
9527 : {
9528 96 : packedptr
9529 96 : = gfc_build_addr_expr (NULL_TREE, gfc_create_var (TREE_TYPE (ctree),
9530 : "packed"));
9531 96 : if (fsym)
9532 : {
9533 96 : int pack_mask = 0;
9534 :
9535 : /* Set bit 0 to the mask, when this is an unlimited_poly
9536 : class. */
9537 96 : if (CLASS_DATA (fsym)->ts.u.derived->attr.unlimited_polymorphic)
9538 36 : pack_mask = 1 << 0;
9539 96 : pack_attr = build_int_cst (integer_type_node, pack_mask);
9540 : }
9541 : else
9542 0 : pack_attr = integer_zero_node;
9543 :
9544 96 : gfc_add_expr_to_block (
9545 : &se->pre,
9546 : build_call_expr_loc (input_location, gfor_fndecl_in_pack_class, 4,
9547 : packedptr,
9548 : gfc_build_addr_expr (NULL_TREE, ctree),
9549 96 : size_in_bytes (TREE_TYPE (ctree)), pack_attr));
9550 96 : ptr = gfc_conv_array_data (gfc_class_data_get (packedptr));
9551 96 : se->expr = packedptr;
9552 96 : if (packed)
9553 96 : *packed = packedptr;
9554 : }
9555 : else
9556 : {
9557 1153 : ptr = build_call_expr_loc (input_location, gfor_fndecl_in_pack, 1,
9558 : desc);
9559 :
9560 1153 : if (fsym && fsym->attr.optional && sym && sym->attr.optional)
9561 : {
9562 11 : tmp = gfc_conv_expr_present (sym);
9563 22 : ptr = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
9564 11 : tmp, fold_convert (TREE_TYPE (se->expr), ptr),
9565 11 : fold_convert (TREE_TYPE (se->expr),
9566 : null_pointer_node));
9567 : }
9568 :
9569 1153 : ptr = gfc_evaluate_now (ptr, &se->pre);
9570 : }
9571 :
9572 : /* Use the packed data for the actual argument, except for contiguous arrays,
9573 : where the descriptor's data component is set. */
9574 1249 : if (g77)
9575 1105 : se->expr = ptr;
9576 : else
9577 : {
9578 144 : tmp = build_fold_indirect_ref_loc (input_location, desc);
9579 :
9580 144 : gfc_ss * ss = gfc_walk_expr (expr);
9581 288 : if (!transposed_dims (ss))
9582 : {
9583 138 : if (!ctree)
9584 48 : gfc_conv_descriptor_data_set (&se->pre, tmp, ptr);
9585 : }
9586 6 : else if (!ctree)
9587 : {
9588 0 : tree old_field, new_field;
9589 :
9590 : /* The original descriptor has transposed dims so we can't reuse
9591 : it directly; we have to create a new one. */
9592 0 : tree old_desc = tmp;
9593 0 : tree new_desc = gfc_create_var (TREE_TYPE (old_desc), "arg_desc");
9594 :
9595 0 : old_field = gfc_conv_descriptor_dtype (old_desc);
9596 0 : new_field = gfc_conv_descriptor_dtype (new_desc);
9597 0 : gfc_add_modify (&se->pre, new_field, old_field);
9598 :
9599 0 : old_field = gfc_conv_descriptor_offset_get (old_desc);
9600 0 : gfc_conv_descriptor_offset_set (&se->pre, new_desc, old_field);
9601 :
9602 0 : for (int i = 0; i < expr->rank; i++)
9603 : {
9604 0 : old_field = gfc_conv_descriptor_dimension (old_desc,
9605 0 : gfc_rank_cst[get_array_ref_dim_for_loop_dim (ss, i)]);
9606 0 : new_field = gfc_conv_descriptor_dimension (new_desc,
9607 : gfc_rank_cst[i]);
9608 0 : gfc_add_modify (&se->pre, new_field, old_field);
9609 : }
9610 :
9611 0 : if (flag_coarray == GFC_FCOARRAY_LIB
9612 0 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (old_desc))
9613 0 : && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (old_desc))
9614 : == GFC_ARRAY_ALLOCATABLE)
9615 : {
9616 0 : old_field = gfc_conv_descriptor_token (old_desc);
9617 0 : new_field = gfc_conv_descriptor_token (new_desc);
9618 0 : gfc_add_modify (&se->pre, new_field, old_field);
9619 : }
9620 :
9621 0 : gfc_conv_descriptor_data_set (&se->pre, new_desc, ptr);
9622 0 : se->expr = gfc_build_addr_expr (NULL_TREE, new_desc);
9623 : }
9624 144 : gfc_free_ss (ss);
9625 : }
9626 :
9627 1249 : if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
9628 : {
9629 8 : char * msg;
9630 :
9631 8 : if (fsym && proc_name)
9632 8 : msg = xasprintf ("An array temporary was created for argument "
9633 8 : "'%s' of procedure '%s'", fsym->name, proc_name);
9634 : else
9635 0 : msg = xasprintf ("An array temporary was created");
9636 :
9637 8 : tmp = build_fold_indirect_ref_loc (input_location,
9638 : desc);
9639 8 : tmp = gfc_conv_array_data (tmp);
9640 8 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9641 8 : fold_convert (TREE_TYPE (tmp), ptr), tmp);
9642 :
9643 8 : if (pass_optional)
9644 6 : tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
9645 : logical_type_node,
9646 : gfc_conv_expr_present (sym), tmp);
9647 :
9648 8 : gfc_trans_runtime_check (false, true, tmp, &se->pre,
9649 : &expr->where, msg);
9650 8 : free (msg);
9651 : }
9652 :
9653 1249 : gfc_start_block (&block);
9654 :
9655 : /* Copy the data back. If input expr is read-only, e.g. a PARAMETER
9656 : array, copying back modified values is undefined behavior. */
9657 2498 : readonly = (expr->expr_type == EXPR_VARIABLE
9658 856 : && expr->symtree
9659 2105 : && expr->symtree->n.sym->attr.flavor == FL_PARAMETER);
9660 :
9661 1249 : if ((fsym == NULL || fsym->attr.intent != INTENT_IN) && !readonly)
9662 : {
9663 1116 : if (ctree)
9664 : {
9665 66 : tmp = gfc_build_addr_expr (NULL_TREE, ctree);
9666 66 : tmp = build_call_expr_loc (input_location,
9667 : gfor_fndecl_in_unpack_class, 4, tmp,
9668 : packedptr,
9669 66 : size_in_bytes (TREE_TYPE (ctree)),
9670 : pack_attr);
9671 : }
9672 : else
9673 1050 : tmp = build_call_expr_loc (input_location, gfor_fndecl_in_unpack, 2,
9674 : desc, ptr);
9675 1116 : gfc_add_expr_to_block (&block, tmp);
9676 : }
9677 133 : else if (ctree && fsym->attr.intent == INTENT_IN)
9678 : {
9679 : /* Need to free the memory for class arrays, that got packed. */
9680 30 : gfc_add_expr_to_block (&block, gfc_call_free (ptr));
9681 : }
9682 :
9683 : /* Free the temporary. */
9684 1146 : if (!ctree)
9685 1153 : gfc_add_expr_to_block (&block, gfc_call_free (ptr));
9686 :
9687 1249 : stmt = gfc_finish_block (&block);
9688 :
9689 1249 : gfc_init_block (&block);
9690 : /* Only if it was repacked. This code needs to be executed before the
9691 : loop cleanup code. */
9692 1249 : tmp = (ctree) ? desc : build_fold_indirect_ref_loc (input_location, desc);
9693 1249 : tmp = gfc_conv_array_data (tmp);
9694 1249 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9695 1249 : fold_convert (TREE_TYPE (tmp), ptr), tmp);
9696 :
9697 1249 : if (pass_optional)
9698 11 : tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
9699 : logical_type_node,
9700 : gfc_conv_expr_present (sym), tmp);
9701 :
9702 1249 : tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
9703 :
9704 1249 : gfc_add_expr_to_block (&block, tmp);
9705 1249 : gfc_add_block_to_block (&block, &se->post);
9706 :
9707 1249 : gfc_init_block (&se->post);
9708 :
9709 : /* Reset the descriptor pointer. */
9710 1249 : if (!g77 && !ctree)
9711 : {
9712 48 : tmp = build_fold_indirect_ref_loc (input_location, desc);
9713 48 : gfc_conv_descriptor_data_set (&se->post, tmp, origptr);
9714 : }
9715 :
9716 1249 : gfc_add_block_to_block (&se->post, &block);
9717 : }
9718 : }
9719 :
9720 :
9721 : /* This helper function calculates the size in words of a full array. */
9722 :
9723 : tree
9724 19729 : gfc_full_array_size (stmtblock_t *block, tree decl, int rank)
9725 : {
9726 19729 : tree idx;
9727 19729 : tree nelems;
9728 19729 : tree tmp;
9729 19729 : if (rank < 0)
9730 0 : idx = gfc_conv_descriptor_rank (decl);
9731 : else
9732 19729 : idx = gfc_rank_cst[rank - 1];
9733 19729 : nelems = gfc_conv_descriptor_ubound_get (decl, idx);
9734 19729 : tmp = gfc_conv_descriptor_lbound_get (decl, idx);
9735 19729 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
9736 : nelems, tmp);
9737 19729 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
9738 : tmp, gfc_index_one_node);
9739 19729 : tmp = gfc_evaluate_now (tmp, block);
9740 :
9741 19729 : nelems = gfc_conv_descriptor_stride_get (decl, idx);
9742 19729 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9743 : nelems, tmp);
9744 19729 : return gfc_evaluate_now (tmp, block);
9745 : }
9746 :
9747 :
9748 : /* Allocate dest to the same size as src, and copy src -> dest.
9749 : If no_malloc is set, only the copy is done. */
9750 :
9751 : static tree
9752 9480 : duplicate_allocatable (tree dest, tree src, tree type, int rank,
9753 : bool no_malloc, bool no_memcpy, tree str_sz,
9754 : tree add_when_allocated)
9755 : {
9756 9480 : tree tmp;
9757 9480 : tree eltype;
9758 9480 : tree size;
9759 9480 : tree nelems;
9760 9480 : tree null_cond;
9761 9480 : tree null_data;
9762 9480 : stmtblock_t block;
9763 :
9764 : /* If the source is null, set the destination to null. Then,
9765 : allocate memory to the destination. */
9766 9480 : gfc_init_block (&block);
9767 :
9768 9480 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
9769 : {
9770 2180 : gfc_add_modify (&block, dest, fold_convert (type, null_pointer_node));
9771 2180 : null_data = gfc_finish_block (&block);
9772 :
9773 2180 : gfc_init_block (&block);
9774 2180 : eltype = TREE_TYPE (type);
9775 2180 : if (str_sz != NULL_TREE)
9776 : size = str_sz;
9777 : else
9778 1837 : size = TYPE_SIZE_UNIT (eltype);
9779 :
9780 2180 : if (!no_malloc)
9781 : {
9782 2180 : tmp = gfc_call_malloc (&block, type, size);
9783 2180 : gfc_add_modify (&block, dest, fold_convert (type, tmp));
9784 : }
9785 :
9786 2180 : if (!no_memcpy)
9787 : {
9788 1755 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
9789 1755 : tmp = build_call_expr_loc (input_location, tmp, 3, dest, src,
9790 : fold_convert (size_type_node, size));
9791 1755 : gfc_add_expr_to_block (&block, tmp);
9792 : }
9793 : }
9794 : else
9795 : {
9796 7300 : gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
9797 7300 : null_data = gfc_finish_block (&block);
9798 :
9799 7300 : gfc_init_block (&block);
9800 7300 : if (rank)
9801 7285 : nelems = gfc_full_array_size (&block, src, rank);
9802 : else
9803 15 : nelems = gfc_index_one_node;
9804 :
9805 : /* If type is not the array type, then it is the element type. */
9806 7300 : if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type))
9807 7270 : eltype = gfc_get_element_type (type);
9808 : else
9809 : eltype = type;
9810 :
9811 7300 : if (str_sz != NULL_TREE)
9812 43 : tmp = fold_convert (gfc_array_index_type, str_sz);
9813 : else
9814 7257 : tmp = fold_convert (gfc_array_index_type,
9815 : TYPE_SIZE_UNIT (eltype));
9816 :
9817 7300 : tmp = gfc_evaluate_now (tmp, &block);
9818 7300 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9819 : nelems, tmp);
9820 7300 : if (!no_malloc)
9821 : {
9822 7244 : tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src));
9823 7244 : tmp = gfc_call_malloc (&block, tmp, size);
9824 7244 : gfc_conv_descriptor_data_set (&block, dest, tmp);
9825 : }
9826 :
9827 : /* We know the temporary and the value will be the same length,
9828 : so can use memcpy. */
9829 7300 : if (!no_memcpy)
9830 : {
9831 5940 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
9832 5940 : tmp = build_call_expr_loc (input_location, tmp, 3,
9833 : gfc_conv_descriptor_data_get (dest),
9834 : gfc_conv_descriptor_data_get (src),
9835 : fold_convert (size_type_node, size));
9836 5940 : gfc_add_expr_to_block (&block, tmp);
9837 : }
9838 : }
9839 :
9840 9480 : gfc_add_expr_to_block (&block, add_when_allocated);
9841 9480 : tmp = gfc_finish_block (&block);
9842 :
9843 : /* Null the destination if the source is null; otherwise do
9844 : the allocate and copy. */
9845 9480 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src)))
9846 : null_cond = src;
9847 : else
9848 7300 : null_cond = gfc_conv_descriptor_data_get (src);
9849 :
9850 9480 : null_cond = convert (pvoid_type_node, null_cond);
9851 9480 : null_cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9852 : null_cond, null_pointer_node);
9853 9480 : return build3_v (COND_EXPR, null_cond, tmp, null_data);
9854 : }
9855 :
9856 :
9857 : /* Allocate dest to the same size as src, and copy data src -> dest. */
9858 :
9859 : tree
9860 7100 : gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank,
9861 : tree add_when_allocated)
9862 : {
9863 7100 : return duplicate_allocatable (dest, src, type, rank, false, false,
9864 7100 : NULL_TREE, add_when_allocated);
9865 : }
9866 :
9867 :
9868 : /* Copy data src -> dest. */
9869 :
9870 : tree
9871 56 : gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
9872 : {
9873 56 : return duplicate_allocatable (dest, src, type, rank, true, false,
9874 56 : NULL_TREE, NULL_TREE);
9875 : }
9876 :
9877 : /* Allocate dest to the same size as src, but don't copy anything. */
9878 :
9879 : tree
9880 1785 : gfc_duplicate_allocatable_nocopy (tree dest, tree src, tree type, int rank)
9881 : {
9882 1785 : return duplicate_allocatable (dest, src, type, rank, false, true,
9883 1785 : NULL_TREE, NULL_TREE);
9884 : }
9885 :
9886 : static tree
9887 62 : duplicate_allocatable_coarray (tree dest, tree dest_tok, tree src, tree type,
9888 : int rank, tree add_when_allocated)
9889 : {
9890 62 : tree tmp;
9891 62 : tree size;
9892 62 : tree nelems;
9893 62 : tree null_cond;
9894 62 : tree null_data;
9895 62 : stmtblock_t block, globalblock;
9896 :
9897 : /* If the source is null, set the destination to null. Then,
9898 : allocate memory to the destination. */
9899 62 : gfc_init_block (&block);
9900 62 : gfc_init_block (&globalblock);
9901 :
9902 62 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
9903 : {
9904 18 : gfc_se se;
9905 18 : symbol_attribute attr;
9906 18 : tree dummy_desc;
9907 :
9908 18 : gfc_init_se (&se, NULL);
9909 18 : gfc_clear_attr (&attr);
9910 18 : attr.allocatable = 1;
9911 18 : dummy_desc = gfc_conv_scalar_to_descriptor (&se, dest, attr);
9912 18 : gfc_add_block_to_block (&globalblock, &se.pre);
9913 18 : size = TYPE_SIZE_UNIT (TREE_TYPE (type));
9914 :
9915 18 : gfc_add_modify (&block, dest, fold_convert (type, null_pointer_node));
9916 18 : gfc_allocate_using_caf_lib (&block, dummy_desc, size,
9917 : gfc_build_addr_expr (NULL_TREE, dest_tok),
9918 : NULL_TREE, NULL_TREE, NULL_TREE,
9919 : GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
9920 18 : gfc_add_modify (&block, dest, gfc_conv_descriptor_data_get (dummy_desc));
9921 18 : null_data = gfc_finish_block (&block);
9922 :
9923 18 : gfc_init_block (&block);
9924 :
9925 18 : gfc_allocate_using_caf_lib (&block, dummy_desc,
9926 : fold_convert (size_type_node, size),
9927 : gfc_build_addr_expr (NULL_TREE, dest_tok),
9928 : NULL_TREE, NULL_TREE, NULL_TREE,
9929 : GFC_CAF_COARRAY_ALLOC);
9930 18 : gfc_add_modify (&block, dest, gfc_conv_descriptor_data_get (dummy_desc));
9931 :
9932 18 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
9933 18 : tmp = build_call_expr_loc (input_location, tmp, 3, dest, src,
9934 : fold_convert (size_type_node, size));
9935 18 : gfc_add_expr_to_block (&block, tmp);
9936 : }
9937 : else
9938 : {
9939 : /* Set the rank or unitialized memory access may be reported. */
9940 44 : tmp = gfc_conv_descriptor_rank (dest);
9941 44 : gfc_add_modify (&globalblock, tmp, build_int_cst (TREE_TYPE (tmp), rank));
9942 :
9943 44 : if (rank)
9944 44 : nelems = gfc_full_array_size (&globalblock, src, rank);
9945 : else
9946 0 : nelems = integer_one_node;
9947 :
9948 44 : tmp = fold_convert (size_type_node,
9949 : TYPE_SIZE_UNIT (gfc_get_element_type (type)));
9950 44 : size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
9951 : fold_convert (size_type_node, nelems), tmp);
9952 :
9953 44 : gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
9954 44 : gfc_allocate_using_caf_lib (&block, dest, fold_convert (size_type_node,
9955 : size),
9956 : gfc_build_addr_expr (NULL_TREE, dest_tok),
9957 : NULL_TREE, NULL_TREE, NULL_TREE,
9958 : GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
9959 44 : null_data = gfc_finish_block (&block);
9960 :
9961 44 : gfc_init_block (&block);
9962 44 : gfc_allocate_using_caf_lib (&block, dest,
9963 : fold_convert (size_type_node, size),
9964 : gfc_build_addr_expr (NULL_TREE, dest_tok),
9965 : NULL_TREE, NULL_TREE, NULL_TREE,
9966 : GFC_CAF_COARRAY_ALLOC);
9967 :
9968 44 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
9969 44 : tmp = build_call_expr_loc (input_location, tmp, 3,
9970 : gfc_conv_descriptor_data_get (dest),
9971 : gfc_conv_descriptor_data_get (src),
9972 : fold_convert (size_type_node, size));
9973 44 : gfc_add_expr_to_block (&block, tmp);
9974 : }
9975 62 : gfc_add_expr_to_block (&block, add_when_allocated);
9976 62 : tmp = gfc_finish_block (&block);
9977 :
9978 : /* Null the destination if the source is null; otherwise do
9979 : the register and copy. */
9980 62 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src)))
9981 : null_cond = src;
9982 : else
9983 44 : null_cond = gfc_conv_descriptor_data_get (src);
9984 :
9985 62 : null_cond = convert (pvoid_type_node, null_cond);
9986 62 : null_cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9987 : null_cond, null_pointer_node);
9988 62 : gfc_add_expr_to_block (&globalblock, build3_v (COND_EXPR, null_cond, tmp,
9989 : null_data));
9990 62 : return gfc_finish_block (&globalblock);
9991 : }
9992 :
9993 :
9994 : /* Helper function to abstract whether coarray processing is enabled. */
9995 :
9996 : static bool
9997 75 : caf_enabled (int caf_mode)
9998 : {
9999 75 : return (caf_mode & GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY)
10000 75 : == GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY;
10001 : }
10002 :
10003 :
10004 : /* Helper function to abstract whether coarray processing is enabled
10005 : and we are in a derived type coarray. */
10006 :
10007 : static bool
10008 10596 : caf_in_coarray (int caf_mode)
10009 : {
10010 10596 : static const int pat = GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
10011 : | GFC_STRUCTURE_CAF_MODE_IN_COARRAY;
10012 10596 : return (caf_mode & pat) == pat;
10013 : }
10014 :
10015 :
10016 : /* Helper function to abstract whether coarray is to deallocate only. */
10017 :
10018 : bool
10019 352 : gfc_caf_is_dealloc_only (int caf_mode)
10020 : {
10021 352 : return (caf_mode & GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY)
10022 352 : == GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY;
10023 : }
10024 :
10025 :
10026 : /* Recursively traverse an object of derived type, generating code to
10027 : deallocate, nullify or copy allocatable components. This is the work horse
10028 : function for the functions named in this enum. */
10029 :
10030 : enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP,
10031 : COPY_ALLOC_COMP, COPY_ONLY_ALLOC_COMP, REASSIGN_CAF_COMP,
10032 : ALLOCATE_PDT_COMP, DEALLOCATE_PDT_COMP, CHECK_PDT_DUMMY,
10033 : BCAST_ALLOC_COMP};
10034 :
10035 : static gfc_actual_arglist *pdt_param_list;
10036 : static bool generating_copy_helper;
10037 : static hash_set<gfc_symbol *> seen_derived_types;
10038 :
10039 : /* Forward declaration of structure_alloc_comps for wrapper generator. */
10040 : static tree structure_alloc_comps (gfc_symbol *, tree, tree, int, int, int,
10041 : gfc_co_subroutines_args *, bool);
10042 :
10043 : /* Generate a wrapper function that performs element-wise deep copy for
10044 : recursive allocatable array components. This wrapper is passed as a
10045 : function pointer to the runtime helper _gfortran_cfi_deep_copy_array,
10046 : allowing recursion to happen at runtime instead of compile time. */
10047 :
10048 : static tree
10049 256 : get_copy_helper_function_type (void)
10050 : {
10051 256 : static tree fn_type = NULL_TREE;
10052 256 : if (fn_type == NULL_TREE)
10053 29 : fn_type = build_function_type_list (void_type_node,
10054 : pvoid_type_node,
10055 : pvoid_type_node,
10056 : NULL_TREE);
10057 256 : return fn_type;
10058 : }
10059 :
10060 : static tree
10061 1157 : get_copy_helper_pointer_type (void)
10062 : {
10063 1157 : static tree ptr_type = NULL_TREE;
10064 1157 : if (ptr_type == NULL_TREE)
10065 29 : ptr_type = build_pointer_type (get_copy_helper_function_type ());
10066 1157 : return ptr_type;
10067 : }
10068 :
10069 : static tree
10070 227 : generate_element_copy_wrapper (gfc_symbol *der_type, tree comp_type,
10071 : int purpose, int caf_mode)
10072 : {
10073 227 : tree fndecl, fntype, result_decl;
10074 227 : tree dest_parm, src_parm, dest_typed, src_typed;
10075 227 : tree der_type_ptr;
10076 227 : stmtblock_t block;
10077 227 : tree decls;
10078 227 : tree body;
10079 :
10080 227 : fntype = get_copy_helper_function_type ();
10081 :
10082 227 : fndecl = build_decl (input_location, FUNCTION_DECL,
10083 : create_tmp_var_name ("copy_element"),
10084 : fntype);
10085 :
10086 227 : TREE_STATIC (fndecl) = 1;
10087 227 : TREE_USED (fndecl) = 1;
10088 227 : DECL_ARTIFICIAL (fndecl) = 1;
10089 227 : DECL_IGNORED_P (fndecl) = 0;
10090 227 : TREE_PUBLIC (fndecl) = 0;
10091 227 : DECL_UNINLINABLE (fndecl) = 1;
10092 227 : DECL_EXTERNAL (fndecl) = 0;
10093 227 : DECL_CONTEXT (fndecl) = NULL_TREE;
10094 227 : DECL_INITIAL (fndecl) = make_node (BLOCK);
10095 227 : BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
10096 :
10097 227 : result_decl = build_decl (input_location, RESULT_DECL, NULL_TREE,
10098 : void_type_node);
10099 227 : DECL_ARTIFICIAL (result_decl) = 1;
10100 227 : DECL_IGNORED_P (result_decl) = 1;
10101 227 : DECL_CONTEXT (result_decl) = fndecl;
10102 227 : DECL_RESULT (fndecl) = result_decl;
10103 :
10104 227 : dest_parm = build_decl (input_location, PARM_DECL,
10105 : get_identifier ("dest"), pvoid_type_node);
10106 227 : src_parm = build_decl (input_location, PARM_DECL,
10107 : get_identifier ("src"), pvoid_type_node);
10108 :
10109 227 : DECL_ARTIFICIAL (dest_parm) = 1;
10110 227 : DECL_ARTIFICIAL (src_parm) = 1;
10111 227 : DECL_ARG_TYPE (dest_parm) = pvoid_type_node;
10112 227 : DECL_ARG_TYPE (src_parm) = pvoid_type_node;
10113 227 : DECL_CONTEXT (dest_parm) = fndecl;
10114 227 : DECL_CONTEXT (src_parm) = fndecl;
10115 :
10116 227 : DECL_ARGUMENTS (fndecl) = dest_parm;
10117 227 : TREE_CHAIN (dest_parm) = src_parm;
10118 :
10119 227 : push_struct_function (fndecl);
10120 227 : cfun->function_end_locus = input_location;
10121 :
10122 227 : pushlevel ();
10123 227 : gfc_init_block (&block);
10124 :
10125 227 : bool saved_generating = generating_copy_helper;
10126 227 : generating_copy_helper = true;
10127 :
10128 : /* When generating a wrapper, we need a fresh type tracking state to
10129 : avoid inheriting the parent context's seen_derived_types, which would
10130 : cause infinite recursion when the wrapper tries to handle the same
10131 : recursive type. Save elements, clear the set, generate wrapper, then
10132 : restore elements. */
10133 227 : vec<gfc_symbol *> saved_symbols = vNULL;
10134 227 : for (hash_set<gfc_symbol *>::iterator it = seen_derived_types.begin ();
10135 973 : it != seen_derived_types.end (); ++it)
10136 373 : saved_symbols.safe_push (*it);
10137 227 : seen_derived_types.empty ();
10138 :
10139 227 : der_type_ptr = build_pointer_type (comp_type);
10140 227 : dest_typed = fold_convert (der_type_ptr, dest_parm);
10141 227 : src_typed = fold_convert (der_type_ptr, src_parm);
10142 :
10143 227 : dest_typed = build_fold_indirect_ref (dest_typed);
10144 227 : src_typed = build_fold_indirect_ref (src_typed);
10145 :
10146 227 : body = structure_alloc_comps (der_type, src_typed, dest_typed,
10147 : 0, purpose, caf_mode, NULL, false);
10148 227 : gfc_add_expr_to_block (&block, body);
10149 :
10150 : /* Restore saved symbols. */
10151 227 : seen_derived_types.empty ();
10152 600 : for (unsigned i = 0; i < saved_symbols.length (); i++)
10153 373 : seen_derived_types.add (saved_symbols[i]);
10154 227 : saved_symbols.release ();
10155 227 : generating_copy_helper = saved_generating;
10156 :
10157 227 : body = gfc_finish_block (&block);
10158 227 : decls = getdecls ();
10159 :
10160 227 : poplevel (1, 1);
10161 :
10162 454 : DECL_SAVED_TREE (fndecl)
10163 227 : = fold_build3_loc (DECL_SOURCE_LOCATION (fndecl), BIND_EXPR,
10164 227 : void_type_node, decls, body, DECL_INITIAL (fndecl));
10165 :
10166 227 : pop_cfun ();
10167 :
10168 : /* Use finalize_function with no_collect=true to skip the ggc_collect
10169 : call that add_new_function would trigger. This function is called
10170 : during tree lowering of structure_alloc_comps where caller stack
10171 : frames hold locally-computed tree nodes (COMPONENT_REFs etc.) that
10172 : are not yet attached to any GC root. A collection at this point
10173 : would free those nodes and cause segfaults. PR124235. */
10174 227 : cgraph_node::finalize_function (fndecl, true);
10175 :
10176 227 : return build1 (ADDR_EXPR, get_copy_helper_pointer_type (), fndecl);
10177 : }
10178 :
10179 : static tree
10180 21350 : structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
10181 : int rank, int purpose, int caf_mode,
10182 : gfc_co_subroutines_args *args,
10183 : bool no_finalization = false)
10184 : {
10185 21350 : gfc_component *c;
10186 21350 : gfc_loopinfo loop;
10187 21350 : stmtblock_t fnblock;
10188 21350 : stmtblock_t loopbody;
10189 21350 : stmtblock_t tmpblock;
10190 21350 : tree decl_type;
10191 21350 : tree tmp;
10192 21350 : tree comp;
10193 21350 : tree dcmp;
10194 21350 : tree nelems;
10195 21350 : tree index;
10196 21350 : tree var;
10197 21350 : tree cdecl;
10198 21350 : tree ctype;
10199 21350 : tree vref, dref;
10200 21350 : tree null_cond = NULL_TREE;
10201 21350 : tree add_when_allocated;
10202 21350 : tree dealloc_fndecl;
10203 21350 : tree caf_token;
10204 21350 : gfc_symbol *vtab;
10205 21350 : int caf_dereg_mode;
10206 21350 : symbol_attribute *attr;
10207 21350 : bool deallocate_called;
10208 :
10209 21350 : gfc_init_block (&fnblock);
10210 :
10211 21350 : decl_type = TREE_TYPE (decl);
10212 :
10213 21350 : if ((POINTER_TYPE_P (decl_type))
10214 : || (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == 0))
10215 : {
10216 1494 : decl = build_fold_indirect_ref_loc (input_location, decl);
10217 : /* Deref dest in sync with decl, but only when it is not NULL. */
10218 1494 : if (dest)
10219 110 : dest = build_fold_indirect_ref_loc (input_location, dest);
10220 :
10221 : /* Update the decl_type because it got dereferenced. */
10222 1494 : decl_type = TREE_TYPE (decl);
10223 : }
10224 :
10225 : /* If this is an array of derived types with allocatable components
10226 : build a loop and recursively call this function. */
10227 21350 : if (TREE_CODE (decl_type) == ARRAY_TYPE
10228 21350 : || (GFC_DESCRIPTOR_TYPE_P (decl_type) && rank != 0))
10229 : {
10230 3796 : tmp = gfc_conv_array_data (decl);
10231 3796 : var = build_fold_indirect_ref_loc (input_location, tmp);
10232 :
10233 : /* Get the number of elements - 1 and set the counter. */
10234 3796 : if (GFC_DESCRIPTOR_TYPE_P (decl_type))
10235 : {
10236 : /* Use the descriptor for an allocatable array. Since this
10237 : is a full array reference, we only need the descriptor
10238 : information from dimension = rank. */
10239 2574 : tmp = gfc_full_array_size (&fnblock, decl, rank);
10240 2574 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
10241 : gfc_array_index_type, tmp,
10242 : gfc_index_one_node);
10243 :
10244 2574 : null_cond = gfc_conv_descriptor_data_get (decl);
10245 2574 : null_cond = fold_build2_loc (input_location, NE_EXPR,
10246 : logical_type_node, null_cond,
10247 2574 : build_int_cst (TREE_TYPE (null_cond), 0));
10248 : }
10249 : else
10250 : {
10251 : /* Otherwise use the TYPE_DOMAIN information. */
10252 1222 : tmp = array_type_nelts_minus_one (decl_type);
10253 1222 : tmp = fold_convert (gfc_array_index_type, tmp);
10254 : }
10255 :
10256 : /* Remember that this is, in fact, the no. of elements - 1. */
10257 3796 : nelems = gfc_evaluate_now (tmp, &fnblock);
10258 3796 : index = gfc_create_var (gfc_array_index_type, "S");
10259 :
10260 : /* Build the body of the loop. */
10261 3796 : gfc_init_block (&loopbody);
10262 :
10263 3796 : vref = gfc_build_array_ref (var, index, NULL);
10264 :
10265 3796 : if (purpose == COPY_ALLOC_COMP || purpose == COPY_ONLY_ALLOC_COMP)
10266 : {
10267 963 : tmp = build_fold_indirect_ref_loc (input_location,
10268 : gfc_conv_array_data (dest));
10269 963 : dref = gfc_build_array_ref (tmp, index, NULL);
10270 963 : tmp = structure_alloc_comps (der_type, vref, dref, rank,
10271 : COPY_ALLOC_COMP, caf_mode, args,
10272 : no_finalization);
10273 : }
10274 : else
10275 2833 : tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose,
10276 : caf_mode, args, no_finalization);
10277 :
10278 3796 : gfc_add_expr_to_block (&loopbody, tmp);
10279 :
10280 : /* Build the loop and return. */
10281 3796 : gfc_init_loopinfo (&loop);
10282 3796 : loop.dimen = 1;
10283 3796 : loop.from[0] = gfc_index_zero_node;
10284 3796 : loop.loopvar[0] = index;
10285 3796 : loop.to[0] = nelems;
10286 3796 : gfc_trans_scalarizing_loops (&loop, &loopbody);
10287 3796 : gfc_add_block_to_block (&fnblock, &loop.pre);
10288 :
10289 3796 : tmp = gfc_finish_block (&fnblock);
10290 : /* When copying allocateable components, the above implements the
10291 : deep copy. Nevertheless is a deep copy only allowed, when the current
10292 : component is allocated, for which code will be generated in
10293 : gfc_duplicate_allocatable (), where the deep copy code is just added
10294 : into the if's body, by adding tmp (the deep copy code) as last
10295 : argument to gfc_duplicate_allocatable (). */
10296 3796 : if (purpose == COPY_ALLOC_COMP && caf_mode == 0
10297 3796 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
10298 710 : tmp = gfc_duplicate_allocatable (dest, decl, decl_type, rank,
10299 : tmp);
10300 3086 : else if (null_cond != NULL_TREE)
10301 1864 : tmp = build3_v (COND_EXPR, null_cond, tmp,
10302 : build_empty_stmt (input_location));
10303 :
10304 3796 : return tmp;
10305 : }
10306 :
10307 17554 : if (purpose == DEALLOCATE_ALLOC_COMP && der_type->attr.pdt_type)
10308 : {
10309 290 : tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
10310 : DEALLOCATE_PDT_COMP, 0, args,
10311 : no_finalization);
10312 290 : gfc_add_expr_to_block (&fnblock, tmp);
10313 : }
10314 17264 : else if (purpose == ALLOCATE_PDT_COMP && der_type->attr.alloc_comp)
10315 : {
10316 121 : tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
10317 : NULLIFY_ALLOC_COMP, 0, args,
10318 : no_finalization);
10319 121 : gfc_add_expr_to_block (&fnblock, tmp);
10320 : }
10321 :
10322 : /* Still having a descriptor array of rank == 0 here, indicates an
10323 : allocatable coarrays. Dereference it correctly. */
10324 17554 : if (GFC_DESCRIPTOR_TYPE_P (decl_type))
10325 : {
10326 12 : decl = build_fold_indirect_ref (gfc_conv_array_data (decl));
10327 : }
10328 : /* Otherwise, act on the components or recursively call self to
10329 : act on a chain of components. */
10330 17554 : seen_derived_types.add (der_type);
10331 51012 : for (c = der_type->components; c; c = c->next)
10332 : {
10333 33458 : bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED
10334 33458 : || c->ts.type == BT_CLASS)
10335 33458 : && c->ts.u.derived->attr.alloc_comp;
10336 33458 : bool same_type
10337 : = (c->ts.type == BT_DERIVED
10338 8295 : && seen_derived_types.contains (c->ts.u.derived))
10339 39095 : || (c->ts.type == BT_CLASS
10340 2225 : && seen_derived_types.contains (CLASS_DATA (c)->ts.u.derived));
10341 33458 : bool inside_wrapper = generating_copy_helper;
10342 :
10343 33458 : bool is_pdt_type = IS_PDT (c);
10344 :
10345 33458 : cdecl = c->backend_decl;
10346 33458 : ctype = TREE_TYPE (cdecl);
10347 :
10348 33458 : switch (purpose)
10349 : {
10350 :
10351 3 : case BCAST_ALLOC_COMP:
10352 :
10353 3 : tree ubound;
10354 3 : tree cdesc;
10355 3 : stmtblock_t derived_type_block;
10356 :
10357 3 : gfc_init_block (&tmpblock);
10358 :
10359 3 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10360 : decl, cdecl, NULL_TREE);
10361 :
10362 : /* Shortcut to get the attributes of the component. */
10363 3 : if (c->ts.type == BT_CLASS)
10364 : {
10365 0 : attr = &CLASS_DATA (c)->attr;
10366 0 : if (attr->class_pointer)
10367 0 : continue;
10368 : }
10369 : else
10370 : {
10371 3 : attr = &c->attr;
10372 3 : if (attr->pointer)
10373 0 : continue;
10374 : }
10375 :
10376 : /* Do not broadcast a caf_token. These are local to the image. */
10377 3 : if (attr->caf_token)
10378 1 : continue;
10379 :
10380 2 : add_when_allocated = NULL_TREE;
10381 2 : if (cmp_has_alloc_comps
10382 0 : && !c->attr.pointer && !c->attr.proc_pointer)
10383 : {
10384 0 : if (c->ts.type == BT_CLASS)
10385 : {
10386 0 : rank = CLASS_DATA (c)->as ? CLASS_DATA (c)->as->rank : 0;
10387 0 : add_when_allocated
10388 0 : = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
10389 : comp, NULL_TREE, rank, purpose,
10390 : caf_mode, args, no_finalization);
10391 : }
10392 : else
10393 : {
10394 0 : rank = c->as ? c->as->rank : 0;
10395 0 : add_when_allocated = structure_alloc_comps (c->ts.u.derived,
10396 : comp, NULL_TREE,
10397 : rank, purpose,
10398 : caf_mode, args,
10399 : no_finalization);
10400 : }
10401 : }
10402 :
10403 2 : gfc_init_block (&derived_type_block);
10404 2 : if (add_when_allocated)
10405 0 : gfc_add_expr_to_block (&derived_type_block, add_when_allocated);
10406 2 : tmp = gfc_finish_block (&derived_type_block);
10407 2 : gfc_add_expr_to_block (&tmpblock, tmp);
10408 :
10409 : /* Convert the component into a rank 1 descriptor type. */
10410 2 : if (attr->dimension)
10411 : {
10412 0 : tmp = gfc_get_element_type (TREE_TYPE (comp));
10413 0 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
10414 0 : ubound = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (comp));
10415 : else
10416 0 : ubound = gfc_full_array_size (&tmpblock, comp,
10417 0 : c->ts.type == BT_CLASS
10418 0 : ? CLASS_DATA (c)->as->rank
10419 0 : : c->as->rank);
10420 : }
10421 : else
10422 : {
10423 2 : tmp = TREE_TYPE (comp);
10424 2 : ubound = build_int_cst (gfc_array_index_type, 1);
10425 : }
10426 :
10427 : /* Treat strings like arrays. Or the other way around, do not
10428 : * generate an additional array layer for scalar components. */
10429 2 : if (attr->dimension || c->ts.type == BT_CHARACTER)
10430 : {
10431 0 : cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node,
10432 : &ubound, 1,
10433 : GFC_ARRAY_ALLOCATABLE, false);
10434 :
10435 0 : cdesc = gfc_create_var (cdesc, "cdesc");
10436 0 : DECL_ARTIFICIAL (cdesc) = 1;
10437 :
10438 0 : gfc_add_modify (&tmpblock, gfc_conv_descriptor_dtype (cdesc),
10439 : gfc_get_dtype_rank_type (1, tmp));
10440 0 : gfc_conv_descriptor_lbound_set (&tmpblock, cdesc,
10441 : gfc_index_zero_node,
10442 : gfc_index_one_node);
10443 0 : gfc_conv_descriptor_stride_set (&tmpblock, cdesc,
10444 : gfc_index_zero_node,
10445 : gfc_index_one_node);
10446 0 : gfc_conv_descriptor_ubound_set (&tmpblock, cdesc,
10447 : gfc_index_zero_node, ubound);
10448 : }
10449 : else
10450 : /* Prevent warning. */
10451 : cdesc = NULL_TREE;
10452 :
10453 2 : if (attr->dimension)
10454 : {
10455 0 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
10456 0 : comp = gfc_conv_descriptor_data_get (comp);
10457 : else
10458 0 : comp = gfc_build_addr_expr (NULL_TREE, comp);
10459 : }
10460 : else
10461 : {
10462 2 : gfc_se se;
10463 :
10464 2 : gfc_init_se (&se, NULL);
10465 :
10466 2 : comp = gfc_conv_scalar_to_descriptor (&se, comp,
10467 2 : c->ts.type == BT_CLASS
10468 2 : ? CLASS_DATA (c)->attr
10469 : : c->attr);
10470 2 : if (c->ts.type == BT_CHARACTER)
10471 0 : comp = gfc_build_addr_expr (NULL_TREE, comp);
10472 2 : gfc_add_block_to_block (&tmpblock, &se.pre);
10473 : }
10474 :
10475 2 : if (attr->dimension || c->ts.type == BT_CHARACTER)
10476 0 : gfc_conv_descriptor_data_set (&tmpblock, cdesc, comp);
10477 : else
10478 2 : cdesc = comp;
10479 :
10480 2 : tree fndecl;
10481 :
10482 2 : fndecl = build_call_expr_loc (input_location,
10483 : gfor_fndecl_co_broadcast, 5,
10484 : gfc_build_addr_expr (pvoid_type_node,cdesc),
10485 : args->image_index,
10486 : null_pointer_node, null_pointer_node,
10487 : null_pointer_node);
10488 :
10489 2 : gfc_add_expr_to_block (&tmpblock, fndecl);
10490 2 : gfc_add_block_to_block (&fnblock, &tmpblock);
10491 :
10492 27428 : break;
10493 :
10494 12080 : case DEALLOCATE_ALLOC_COMP:
10495 :
10496 12080 : gfc_init_block (&tmpblock);
10497 :
10498 12080 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10499 : decl, cdecl, NULL_TREE);
10500 :
10501 : /* Shortcut to get the attributes of the component. */
10502 12080 : if (c->ts.type == BT_CLASS)
10503 : {
10504 1000 : attr = &CLASS_DATA (c)->attr;
10505 1000 : if (attr->class_pointer || c->attr.proc_pointer)
10506 18 : continue;
10507 : }
10508 : else
10509 : {
10510 11080 : attr = &c->attr;
10511 11080 : if (attr->pointer || attr->proc_pointer)
10512 142 : continue;
10513 : }
10514 :
10515 11920 : if (!no_finalization && ((c->ts.type == BT_DERIVED && !c->attr.pointer)
10516 8295 : || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer)))
10517 : /* Call the finalizer, which will free the memory and nullify the
10518 : pointer of an array. */
10519 3559 : deallocate_called = gfc_add_comp_finalizer_call (&tmpblock, comp, c,
10520 3559 : caf_enabled (caf_mode))
10521 3559 : && attr->dimension;
10522 : else
10523 : deallocate_called = false;
10524 :
10525 : /* Add the _class ref for classes. */
10526 11920 : if (c->ts.type == BT_CLASS && attr->allocatable)
10527 982 : comp = gfc_class_data_get (comp);
10528 :
10529 11920 : add_when_allocated = NULL_TREE;
10530 11920 : if (cmp_has_alloc_comps
10531 2854 : && !c->attr.pointer && !c->attr.proc_pointer
10532 : && !same_type
10533 2854 : && !deallocate_called)
10534 : {
10535 : /* Add checked deallocation of the components. This code is
10536 : obviously added because the finalizer is not trusted to free
10537 : all memory. */
10538 1556 : if (c->ts.type == BT_CLASS)
10539 : {
10540 241 : rank = CLASS_DATA (c)->as ? CLASS_DATA (c)->as->rank : 0;
10541 241 : add_when_allocated
10542 241 : = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
10543 : comp, NULL_TREE, rank, purpose,
10544 : caf_mode, args, no_finalization);
10545 : }
10546 : else
10547 : {
10548 1315 : rank = c->as ? c->as->rank : 0;
10549 1315 : add_when_allocated = structure_alloc_comps (c->ts.u.derived,
10550 : comp, NULL_TREE,
10551 : rank, purpose,
10552 : caf_mode, args,
10553 : no_finalization);
10554 : }
10555 : }
10556 :
10557 7993 : if (attr->allocatable && !same_type
10558 18890 : && (!attr->codimension || caf_enabled (caf_mode)))
10559 : {
10560 : /* Handle all types of components besides components of the
10561 : same_type as the current one, because those would create an
10562 : endless loop. */
10563 51 : caf_dereg_mode = (caf_in_coarray (caf_mode)
10564 58 : && (attr->dimension || c->caf_token))
10565 6906 : || attr->codimension
10566 7041 : ? (gfc_caf_is_dealloc_only (caf_mode)
10567 : ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
10568 : : GFC_CAF_COARRAY_DEREGISTER)
10569 : : GFC_CAF_COARRAY_NOCOARRAY;
10570 :
10571 6963 : caf_token = NULL_TREE;
10572 : /* Coarray components are handled directly by
10573 : deallocate_with_status. */
10574 6963 : if (!attr->codimension
10575 6942 : && caf_dereg_mode != GFC_CAF_COARRAY_NOCOARRAY)
10576 : {
10577 57 : if (c->caf_token)
10578 19 : caf_token
10579 19 : = fold_build3_loc (input_location, COMPONENT_REF,
10580 19 : TREE_TYPE (gfc_comp_caf_token (c)),
10581 : decl, gfc_comp_caf_token (c),
10582 : NULL_TREE);
10583 38 : else if (attr->dimension && !attr->proc_pointer)
10584 38 : caf_token = gfc_conv_descriptor_token (comp);
10585 : }
10586 :
10587 6963 : tmp = gfc_deallocate_with_status (comp, NULL_TREE, NULL_TREE,
10588 : NULL_TREE, NULL_TREE, true,
10589 : NULL, caf_dereg_mode, NULL_TREE,
10590 : add_when_allocated, caf_token);
10591 :
10592 6963 : gfc_add_expr_to_block (&tmpblock, tmp);
10593 : }
10594 4957 : else if (attr->allocatable && !attr->codimension
10595 1023 : && !deallocate_called)
10596 : {
10597 : /* Case of recursive allocatable derived types. */
10598 1023 : tree is_allocated;
10599 1023 : tree ubound;
10600 1023 : tree cdesc;
10601 1023 : stmtblock_t dealloc_block;
10602 :
10603 1023 : gfc_init_block (&dealloc_block);
10604 1023 : if (add_when_allocated)
10605 0 : gfc_add_expr_to_block (&dealloc_block, add_when_allocated);
10606 :
10607 : /* Convert the component into a rank 1 descriptor type. */
10608 1023 : if (attr->dimension)
10609 : {
10610 417 : tmp = gfc_get_element_type (TREE_TYPE (comp));
10611 417 : ubound = gfc_full_array_size (&dealloc_block, comp,
10612 417 : c->ts.type == BT_CLASS
10613 0 : ? CLASS_DATA (c)->as->rank
10614 417 : : c->as->rank);
10615 : }
10616 : else
10617 : {
10618 606 : tmp = TREE_TYPE (comp);
10619 606 : ubound = build_int_cst (gfc_array_index_type, 1);
10620 : }
10621 :
10622 1023 : cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node,
10623 : &ubound, 1,
10624 : GFC_ARRAY_ALLOCATABLE, false);
10625 :
10626 1023 : cdesc = gfc_create_var (cdesc, "cdesc");
10627 1023 : DECL_ARTIFICIAL (cdesc) = 1;
10628 :
10629 1023 : gfc_add_modify (&dealloc_block, gfc_conv_descriptor_dtype (cdesc),
10630 : gfc_get_dtype_rank_type (1, tmp));
10631 1023 : gfc_conv_descriptor_lbound_set (&dealloc_block, cdesc,
10632 : gfc_index_zero_node,
10633 : gfc_index_one_node);
10634 1023 : gfc_conv_descriptor_stride_set (&dealloc_block, cdesc,
10635 : gfc_index_zero_node,
10636 : gfc_index_one_node);
10637 1023 : gfc_conv_descriptor_ubound_set (&dealloc_block, cdesc,
10638 : gfc_index_zero_node, ubound);
10639 :
10640 1023 : if (attr->dimension)
10641 417 : comp = gfc_conv_descriptor_data_get (comp);
10642 :
10643 1023 : gfc_conv_descriptor_data_set (&dealloc_block, cdesc, comp);
10644 :
10645 : /* Now call the deallocator. */
10646 1023 : vtab = gfc_find_vtab (&c->ts);
10647 1023 : if (vtab->backend_decl == NULL)
10648 47 : gfc_get_symbol_decl (vtab);
10649 1023 : tmp = gfc_build_addr_expr (NULL_TREE, vtab->backend_decl);
10650 1023 : dealloc_fndecl = gfc_vptr_deallocate_get (tmp);
10651 1023 : dealloc_fndecl = build_fold_indirect_ref_loc (input_location,
10652 : dealloc_fndecl);
10653 1023 : tmp = build_int_cst (TREE_TYPE (comp), 0);
10654 1023 : is_allocated = fold_build2_loc (input_location, NE_EXPR,
10655 : logical_type_node, tmp,
10656 : comp);
10657 1023 : cdesc = gfc_build_addr_expr (NULL_TREE, cdesc);
10658 :
10659 1023 : tmp = build_call_expr_loc (input_location,
10660 : dealloc_fndecl, 1,
10661 : cdesc);
10662 1023 : gfc_add_expr_to_block (&dealloc_block, tmp);
10663 :
10664 1023 : tmp = gfc_finish_block (&dealloc_block);
10665 :
10666 1023 : tmp = fold_build3_loc (input_location, COND_EXPR,
10667 : void_type_node, is_allocated, tmp,
10668 : build_empty_stmt (input_location));
10669 :
10670 1023 : gfc_add_expr_to_block (&tmpblock, tmp);
10671 1023 : }
10672 3934 : else if (add_when_allocated)
10673 639 : gfc_add_expr_to_block (&tmpblock, add_when_allocated);
10674 :
10675 982 : if (c->ts.type == BT_CLASS && attr->allocatable
10676 12902 : && (!attr->codimension || !caf_enabled (caf_mode)))
10677 : {
10678 : /* Finally, reset the vptr to the declared type vtable and, if
10679 : necessary reset the _len field.
10680 :
10681 : First recover the reference to the component and obtain
10682 : the vptr. */
10683 967 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10684 : decl, cdecl, NULL_TREE);
10685 967 : tmp = gfc_class_vptr_get (comp);
10686 :
10687 967 : if (UNLIMITED_POLY (c))
10688 : {
10689 : /* Both vptr and _len field should be nulled. */
10690 211 : gfc_add_modify (&tmpblock, tmp,
10691 211 : build_int_cst (TREE_TYPE (tmp), 0));
10692 211 : tmp = gfc_class_len_get (comp);
10693 211 : gfc_add_modify (&tmpblock, tmp,
10694 211 : build_int_cst (TREE_TYPE (tmp), 0));
10695 : }
10696 : else
10697 : {
10698 : /* Build the vtable address and set the vptr with it. */
10699 756 : gfc_reset_vptr (&tmpblock, nullptr, tmp, c->ts.u.derived);
10700 : }
10701 : }
10702 :
10703 : /* Now add the deallocation of this component. */
10704 11920 : gfc_add_block_to_block (&fnblock, &tmpblock);
10705 11920 : break;
10706 :
10707 5240 : case NULLIFY_ALLOC_COMP:
10708 : /* Nullify
10709 : - allocatable components (regular or in class)
10710 : - components that have allocatable components
10711 : - pointer components when in a coarray.
10712 : Skip everything else especially proc_pointers, which may come
10713 : coupled with the regular pointer attribute. */
10714 7011 : if (c->attr.proc_pointer
10715 5240 : || !(c->attr.allocatable || (c->ts.type == BT_CLASS
10716 475 : && CLASS_DATA (c)->attr.allocatable)
10717 2218 : || (cmp_has_alloc_comps
10718 364 : && ((c->ts.type == BT_DERIVED && !c->attr.pointer)
10719 18 : || (c->ts.type == BT_CLASS
10720 12 : && !CLASS_DATA (c)->attr.class_pointer)))
10721 1872 : || (caf_in_coarray (caf_mode) && c->attr.pointer)))
10722 1771 : continue;
10723 :
10724 : /* Process class components first, because they always have the
10725 : pointer-attribute set which would be caught wrong else. */
10726 3469 : if (c->ts.type == BT_CLASS
10727 462 : && (CLASS_DATA (c)->attr.allocatable
10728 0 : || CLASS_DATA (c)->attr.class_pointer))
10729 : {
10730 462 : tree class_ref;
10731 :
10732 : /* Allocatable CLASS components. */
10733 462 : class_ref = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10734 : decl, cdecl, NULL_TREE);
10735 :
10736 462 : comp = gfc_class_data_get (class_ref);
10737 462 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
10738 251 : gfc_conv_descriptor_data_set (&fnblock, comp,
10739 : null_pointer_node);
10740 : else
10741 : {
10742 211 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
10743 : void_type_node, comp,
10744 211 : build_int_cst (TREE_TYPE (comp), 0));
10745 211 : gfc_add_expr_to_block (&fnblock, tmp);
10746 : }
10747 :
10748 : /* The dynamic type of a disassociated pointer or unallocated
10749 : allocatable variable is its declared type. An unlimited
10750 : polymorphic entity has no declared type. */
10751 462 : gfc_reset_vptr (&fnblock, nullptr, class_ref, c->ts.u.derived);
10752 :
10753 462 : cmp_has_alloc_comps = false;
10754 462 : }
10755 : /* Coarrays need the component to be nulled before the api-call
10756 : is made. */
10757 3007 : else if (c->attr.pointer || c->attr.allocatable)
10758 : {
10759 2661 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10760 : decl, cdecl, NULL_TREE);
10761 2661 : if (c->attr.dimension || c->attr.codimension)
10762 1826 : gfc_conv_descriptor_data_set (&fnblock, comp,
10763 : null_pointer_node);
10764 : else
10765 835 : gfc_add_modify (&fnblock, comp,
10766 835 : build_int_cst (TREE_TYPE (comp), 0));
10767 2661 : if (gfc_deferred_strlen (c, &comp))
10768 : {
10769 317 : comp = fold_build3_loc (input_location, COMPONENT_REF,
10770 317 : TREE_TYPE (comp),
10771 : decl, comp, NULL_TREE);
10772 634 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
10773 317 : TREE_TYPE (comp), comp,
10774 317 : build_int_cst (TREE_TYPE (comp), 0));
10775 317 : gfc_add_expr_to_block (&fnblock, tmp);
10776 : }
10777 : cmp_has_alloc_comps = false;
10778 : }
10779 :
10780 3469 : if (flag_coarray == GFC_FCOARRAY_LIB && caf_in_coarray (caf_mode))
10781 : {
10782 : /* Register a component of a derived type coarray with the
10783 : coarray library. Do not register ultimate component
10784 : coarrays here. They are treated like regular coarrays and
10785 : are either allocated on all images or on none. */
10786 132 : tree token;
10787 :
10788 132 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10789 : decl, cdecl, NULL_TREE);
10790 132 : if (c->attr.dimension)
10791 : {
10792 : /* Set the dtype, because caf_register needs it. */
10793 104 : gfc_add_modify (&fnblock, gfc_conv_descriptor_dtype (comp),
10794 104 : gfc_get_dtype (TREE_TYPE (comp)));
10795 104 : tmp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10796 : decl, cdecl, NULL_TREE);
10797 104 : token = gfc_conv_descriptor_token (tmp);
10798 : }
10799 : else
10800 : {
10801 28 : gfc_se se;
10802 :
10803 28 : gfc_init_se (&se, NULL);
10804 56 : token = fold_build3_loc (input_location, COMPONENT_REF,
10805 : pvoid_type_node, decl,
10806 28 : gfc_comp_caf_token (c), NULL_TREE);
10807 28 : comp = gfc_conv_scalar_to_descriptor (&se, comp,
10808 28 : c->ts.type == BT_CLASS
10809 28 : ? CLASS_DATA (c)->attr
10810 : : c->attr);
10811 28 : gfc_add_block_to_block (&fnblock, &se.pre);
10812 : }
10813 :
10814 132 : gfc_allocate_using_caf_lib (&fnblock, comp, size_zero_node,
10815 : gfc_build_addr_expr (NULL_TREE,
10816 : token),
10817 : NULL_TREE, NULL_TREE, NULL_TREE,
10818 : GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
10819 : }
10820 :
10821 3469 : if (cmp_has_alloc_comps)
10822 : {
10823 346 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10824 : decl, cdecl, NULL_TREE);
10825 346 : rank = c->as ? c->as->rank : 0;
10826 346 : tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
10827 : rank, purpose, caf_mode, args,
10828 : no_finalization);
10829 346 : gfc_add_expr_to_block (&fnblock, tmp);
10830 : }
10831 : break;
10832 :
10833 30 : case REASSIGN_CAF_COMP:
10834 30 : if (caf_enabled (caf_mode)
10835 30 : && (c->attr.codimension
10836 23 : || (c->ts.type == BT_CLASS
10837 2 : && (CLASS_DATA (c)->attr.coarray_comp
10838 2 : || caf_in_coarray (caf_mode)))
10839 21 : || (c->ts.type == BT_DERIVED
10840 7 : && (c->ts.u.derived->attr.coarray_comp
10841 6 : || caf_in_coarray (caf_mode))))
10842 46 : && !same_type)
10843 : {
10844 14 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10845 : decl, cdecl, NULL_TREE);
10846 14 : dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10847 : dest, cdecl, NULL_TREE);
10848 :
10849 14 : if (c->attr.codimension)
10850 : {
10851 7 : if (c->ts.type == BT_CLASS)
10852 : {
10853 0 : comp = gfc_class_data_get (comp);
10854 0 : dcmp = gfc_class_data_get (dcmp);
10855 : }
10856 7 : gfc_conv_descriptor_data_set (&fnblock, dcmp,
10857 : gfc_conv_descriptor_data_get (comp));
10858 : }
10859 : else
10860 : {
10861 7 : tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
10862 : rank, purpose, caf_mode
10863 : | GFC_STRUCTURE_CAF_MODE_IN_COARRAY,
10864 : args, no_finalization);
10865 7 : gfc_add_expr_to_block (&fnblock, tmp);
10866 : }
10867 : }
10868 : break;
10869 :
10870 11701 : case COPY_ALLOC_COMP:
10871 11701 : if (c->attr.pointer || c->attr.proc_pointer)
10872 183 : continue;
10873 :
10874 : /* We need source and destination components. */
10875 11518 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl,
10876 : cdecl, NULL_TREE);
10877 11518 : dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, dest,
10878 : cdecl, NULL_TREE);
10879 11518 : dcmp = fold_convert (TREE_TYPE (comp), dcmp);
10880 :
10881 11518 : if (IS_PDT (c) && !c->attr.allocatable)
10882 : {
10883 85 : tmp = gfc_copy_alloc_comp (c->ts.u.derived, comp, dcmp,
10884 : 0, 0);
10885 85 : gfc_add_expr_to_block (&fnblock, tmp);
10886 85 : continue;
10887 : }
10888 :
10889 11433 : if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
10890 : {
10891 720 : tree ftn_tree;
10892 720 : tree size;
10893 720 : tree dst_data;
10894 720 : tree src_data;
10895 720 : tree null_data;
10896 :
10897 720 : dst_data = gfc_class_data_get (dcmp);
10898 720 : src_data = gfc_class_data_get (comp);
10899 720 : size = fold_convert (size_type_node,
10900 : gfc_class_vtab_size_get (comp));
10901 :
10902 720 : if (CLASS_DATA (c)->attr.dimension)
10903 : {
10904 696 : nelems = gfc_conv_descriptor_size (src_data,
10905 348 : CLASS_DATA (c)->as->rank);
10906 348 : size = fold_build2_loc (input_location, MULT_EXPR,
10907 : size_type_node, size,
10908 : fold_convert (size_type_node,
10909 : nelems));
10910 : }
10911 : else
10912 372 : nelems = build_int_cst (size_type_node, 1);
10913 :
10914 720 : if (CLASS_DATA (c)->attr.dimension
10915 372 : || CLASS_DATA (c)->attr.codimension)
10916 : {
10917 356 : src_data = gfc_conv_descriptor_data_get (src_data);
10918 356 : dst_data = gfc_conv_descriptor_data_get (dst_data);
10919 : }
10920 :
10921 720 : gfc_init_block (&tmpblock);
10922 :
10923 720 : gfc_add_modify (&tmpblock, gfc_class_vptr_get (dcmp),
10924 : gfc_class_vptr_get (comp));
10925 :
10926 : /* Copy the unlimited '_len' field. If it is greater than zero
10927 : (ie. a character(_len)), multiply it by size and use this
10928 : for the malloc call. */
10929 720 : if (UNLIMITED_POLY (c))
10930 : {
10931 135 : gfc_add_modify (&tmpblock, gfc_class_len_get (dcmp),
10932 : gfc_class_len_get (comp));
10933 135 : size = gfc_resize_class_size_with_len (&tmpblock, comp, size);
10934 : }
10935 :
10936 : /* Coarray component have to have the same allocation status and
10937 : shape/type-parameter/effective-type on the LHS and RHS of an
10938 : intrinsic assignment. Hence, we did not deallocated them - and
10939 : do not allocate them here. */
10940 720 : if (!CLASS_DATA (c)->attr.codimension)
10941 : {
10942 705 : ftn_tree = builtin_decl_explicit (BUILT_IN_MALLOC);
10943 705 : tmp = build_call_expr_loc (input_location, ftn_tree, 1, size);
10944 705 : gfc_add_modify (&tmpblock, dst_data,
10945 705 : fold_convert (TREE_TYPE (dst_data), tmp));
10946 : }
10947 :
10948 1425 : tmp = gfc_copy_class_to_class (comp, dcmp, nelems,
10949 720 : UNLIMITED_POLY (c));
10950 720 : gfc_add_expr_to_block (&tmpblock, tmp);
10951 720 : tmp = gfc_finish_block (&tmpblock);
10952 :
10953 720 : gfc_init_block (&tmpblock);
10954 720 : gfc_add_modify (&tmpblock, dst_data,
10955 720 : fold_convert (TREE_TYPE (dst_data),
10956 : null_pointer_node));
10957 720 : null_data = gfc_finish_block (&tmpblock);
10958 :
10959 720 : null_cond = fold_build2_loc (input_location, NE_EXPR,
10960 : logical_type_node, src_data,
10961 : null_pointer_node);
10962 :
10963 720 : gfc_add_expr_to_block (&fnblock, build3_v (COND_EXPR, null_cond,
10964 : tmp, null_data));
10965 720 : continue;
10966 720 : }
10967 :
10968 : /* To implement guarded deep copy, i.e., deep copy only allocatable
10969 : components that are really allocated, the deep copy code has to
10970 : be generated first and then added to the if-block in
10971 : gfc_duplicate_allocatable (). */
10972 10713 : if (cmp_has_alloc_comps && !c->attr.proc_pointer && !same_type)
10973 : {
10974 1667 : rank = c->as ? c->as->rank : 0;
10975 1667 : tmp = fold_convert (TREE_TYPE (dcmp), comp);
10976 1667 : gfc_add_modify (&fnblock, dcmp, tmp);
10977 1667 : add_when_allocated = structure_alloc_comps (c->ts.u.derived,
10978 : comp, dcmp,
10979 : rank, purpose,
10980 : caf_mode, args,
10981 : no_finalization);
10982 : }
10983 : else
10984 : add_when_allocated = NULL_TREE;
10985 :
10986 10713 : if (gfc_deferred_strlen (c, &tmp))
10987 : {
10988 386 : tree len, size;
10989 386 : len = tmp;
10990 386 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
10991 386 : TREE_TYPE (len),
10992 : decl, len, NULL_TREE);
10993 386 : len = fold_build3_loc (input_location, COMPONENT_REF,
10994 386 : TREE_TYPE (len),
10995 : dest, len, NULL_TREE);
10996 386 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
10997 386 : TREE_TYPE (len), len, tmp);
10998 386 : gfc_add_expr_to_block (&fnblock, tmp);
10999 386 : size = size_of_string_in_bytes (c->ts.kind, len);
11000 : /* This component cannot have allocatable components,
11001 : therefore add_when_allocated of duplicate_allocatable ()
11002 : is always NULL. */
11003 386 : rank = c->as ? c->as->rank : 0;
11004 386 : tmp = duplicate_allocatable (dcmp, comp, ctype, rank,
11005 : false, false, size, NULL_TREE);
11006 386 : gfc_add_expr_to_block (&fnblock, tmp);
11007 : }
11008 10327 : else if (c->attr.pdt_array
11009 153 : && !c->attr.allocatable && !c->attr.pointer)
11010 : {
11011 153 : tmp = duplicate_allocatable (dcmp, comp, ctype,
11012 153 : c->as ? c->as->rank : 0,
11013 : false, false, NULL_TREE, NULL_TREE);
11014 153 : gfc_add_expr_to_block (&fnblock, tmp);
11015 : }
11016 : /* Special case: recursive allocatable array components require
11017 : runtime helpers to avoid compile-time infinite recursion. Generate
11018 : a call to _gfortran_cfi_deep_copy_array with an element copy
11019 : wrapper. When inside a wrapper, reuse current_function_decl. */
11020 5999 : else if (c->attr.allocatable && c->as && cmp_has_alloc_comps && same_type
11021 930 : && purpose == COPY_ALLOC_COMP && !c->attr.proc_pointer
11022 930 : && !c->attr.codimension && !caf_in_coarray (caf_mode)
11023 11104 : && c->ts.type == BT_DERIVED && c->ts.u.derived != NULL)
11024 : {
11025 930 : tree copy_wrapper, call, dest_addr, src_addr, elem_type;
11026 930 : tree helper_ptr_type;
11027 930 : tree alloc_expr;
11028 930 : int comp_rank;
11029 :
11030 : /* Get the element type from ctype (already the component
11031 : type). For arrays we need the element type, not the array
11032 : type. */
11033 930 : elem_type = ctype;
11034 930 : if (GFC_DESCRIPTOR_TYPE_P (ctype))
11035 930 : elem_type = gfc_get_element_type (ctype);
11036 0 : else if (TREE_CODE (ctype) == ARRAY_TYPE)
11037 0 : elem_type = TREE_TYPE (ctype);
11038 :
11039 930 : helper_ptr_type = get_copy_helper_pointer_type ();
11040 :
11041 930 : comp_rank = c->as ? c->as->rank : 0;
11042 930 : alloc_expr = gfc_duplicate_allocatable_nocopy (dcmp, comp, ctype,
11043 : comp_rank);
11044 930 : gfc_add_expr_to_block (&fnblock, alloc_expr);
11045 :
11046 : /* Generate or reuse the element copy helper. Inside an
11047 : existing helper we can reuse the current function to
11048 : prevent recursive generation. */
11049 930 : if (inside_wrapper)
11050 703 : copy_wrapper
11051 703 : = gfc_build_addr_expr (NULL_TREE, current_function_decl);
11052 : else
11053 227 : copy_wrapper
11054 227 : = generate_element_copy_wrapper (c->ts.u.derived, elem_type,
11055 : purpose, caf_mode);
11056 930 : copy_wrapper = fold_convert (helper_ptr_type, copy_wrapper);
11057 :
11058 : /* Build addresses of descriptors. */
11059 930 : dest_addr = gfc_build_addr_expr (pvoid_type_node, dcmp);
11060 930 : src_addr = gfc_build_addr_expr (pvoid_type_node, comp);
11061 :
11062 : /* Build call: _gfortran_cfi_deep_copy_array (&dcmp, &comp,
11063 : wrapper). */
11064 930 : call = build_call_expr_loc (input_location,
11065 : gfor_fndecl_cfi_deep_copy_array, 3,
11066 : dest_addr, src_addr,
11067 : copy_wrapper);
11068 930 : gfc_add_expr_to_block (&fnblock, call);
11069 : }
11070 : /* For allocatable arrays with nested allocatable components,
11071 : add_when_allocated already includes gfc_duplicate_allocatable
11072 : (from the recursive structure_alloc_comps call at line 10290-10293),
11073 : so we must not call it again here. PR121628 added an
11074 : add_when_allocated != NULL clause that was redundant for scalars
11075 : (already handled by !c->as) and wrong for arrays (double alloc). */
11076 5069 : else if (c->attr.allocatable && !c->attr.proc_pointer
11077 14313 : && (!cmp_has_alloc_comps
11078 798 : || !c->as
11079 573 : || c->attr.codimension
11080 570 : || caf_in_coarray (caf_mode)))
11081 : {
11082 4505 : rank = c->as ? c->as->rank : 0;
11083 4505 : if (c->attr.codimension)
11084 20 : tmp = gfc_copy_allocatable_data (dcmp, comp, ctype, rank);
11085 4485 : else if (flag_coarray == GFC_FCOARRAY_LIB
11086 4485 : && caf_in_coarray (caf_mode))
11087 : {
11088 62 : tree dst_tok;
11089 62 : if (c->as)
11090 44 : dst_tok = gfc_conv_descriptor_token (dcmp);
11091 : else
11092 : {
11093 18 : dst_tok
11094 18 : = fold_build3_loc (input_location, COMPONENT_REF,
11095 : pvoid_type_node, dest,
11096 18 : gfc_comp_caf_token (c), NULL_TREE);
11097 : }
11098 62 : tmp
11099 62 : = duplicate_allocatable_coarray (dcmp, dst_tok, comp, ctype,
11100 : rank, add_when_allocated);
11101 : }
11102 : else
11103 4423 : tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank,
11104 : add_when_allocated);
11105 4505 : gfc_add_expr_to_block (&fnblock, tmp);
11106 : }
11107 : else
11108 4739 : if (cmp_has_alloc_comps || is_pdt_type)
11109 1708 : gfc_add_expr_to_block (&fnblock, add_when_allocated);
11110 :
11111 : break;
11112 :
11113 1862 : case ALLOCATE_PDT_COMP:
11114 :
11115 1862 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
11116 : decl, cdecl, NULL_TREE);
11117 :
11118 : /* Set the PDT KIND and LEN fields. */
11119 1862 : if (c->attr.pdt_kind || c->attr.pdt_len)
11120 : {
11121 853 : gfc_se tse;
11122 853 : gfc_expr *c_expr = NULL;
11123 853 : gfc_actual_arglist *param = pdt_param_list;
11124 853 : gfc_init_se (&tse, NULL);
11125 3095 : for (; param; param = param->next)
11126 1389 : if (param->name && !strcmp (c->name, param->name))
11127 847 : c_expr = param->expr;
11128 :
11129 853 : if (!c_expr)
11130 24 : c_expr = c->initializer;
11131 :
11132 24 : if (c_expr)
11133 : {
11134 835 : gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp));
11135 835 : gfc_add_block_to_block (&fnblock, &tse.pre);
11136 835 : gfc_add_modify (&fnblock, comp, tse.expr);
11137 835 : gfc_add_block_to_block (&fnblock, &tse.post);
11138 : }
11139 853 : }
11140 1009 : else if (c->initializer && !c->attr.pdt_string && !c->attr.pdt_array
11141 139 : && !c->as && !IS_PDT (c)) /* Take care of arrays. */
11142 : {
11143 49 : gfc_se tse;
11144 49 : gfc_expr *c_expr;
11145 49 : gfc_init_se (&tse, NULL);
11146 49 : c_expr = c->initializer;
11147 49 : gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp));
11148 49 : gfc_add_block_to_block (&fnblock, &tse.pre);
11149 49 : gfc_add_modify (&fnblock, comp, tse.expr);
11150 49 : gfc_add_block_to_block (&fnblock, &tse.post);
11151 : }
11152 :
11153 1862 : if (c->attr.pdt_string)
11154 : {
11155 90 : gfc_se tse;
11156 90 : gfc_init_se (&tse, NULL);
11157 90 : tree strlen = NULL_TREE;
11158 90 : gfc_expr *e = gfc_copy_expr (c->ts.u.cl->length);
11159 : /* Convert the parameterized string length to its value. The
11160 : string length is stored in a hidden field in the same way as
11161 : deferred string lengths. */
11162 90 : gfc_insert_parameter_exprs (e, pdt_param_list);
11163 90 : if (gfc_deferred_strlen (c, &strlen) && strlen != NULL_TREE)
11164 : {
11165 90 : gfc_conv_expr_type (&tse, e,
11166 90 : TREE_TYPE (strlen));
11167 90 : strlen = fold_build3_loc (input_location, COMPONENT_REF,
11168 90 : TREE_TYPE (strlen),
11169 : decl, strlen, NULL_TREE);
11170 90 : gfc_add_block_to_block (&fnblock, &tse.pre);
11171 90 : gfc_add_modify (&fnblock, strlen, tse.expr);
11172 90 : gfc_add_block_to_block (&fnblock, &tse.post);
11173 90 : c->ts.u.cl->backend_decl = strlen;
11174 : }
11175 90 : gfc_free_expr (e);
11176 :
11177 : /* Scalar parameterized strings can be allocated now. */
11178 90 : if (!c->as)
11179 : {
11180 90 : tmp = fold_convert (gfc_array_index_type, strlen);
11181 90 : tmp = size_of_string_in_bytes (c->ts.kind, tmp);
11182 90 : tmp = gfc_evaluate_now (tmp, &fnblock);
11183 90 : tmp = gfc_call_malloc (&fnblock, TREE_TYPE (comp), tmp);
11184 90 : gfc_add_modify (&fnblock, comp, tmp);
11185 : }
11186 : }
11187 :
11188 : /* Allocate parameterized arrays of parameterized derived types. */
11189 1862 : if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT)
11190 1604 : && !(IS_PDT (c) || IS_CLASS_PDT (c)))
11191 1419 : continue;
11192 :
11193 443 : if (c->ts.type == BT_CLASS)
11194 0 : comp = gfc_class_data_get (comp);
11195 :
11196 443 : if (c->attr.pdt_array)
11197 : {
11198 258 : gfc_se tse;
11199 258 : int i;
11200 258 : tree size = gfc_index_one_node;
11201 258 : tree offset = gfc_index_zero_node;
11202 258 : tree lower, upper;
11203 258 : gfc_expr *e;
11204 :
11205 : /* This chunk takes the expressions for 'lower' and 'upper'
11206 : in the arrayspec and substitutes in the expressions for
11207 : the parameters from 'pdt_param_list'. The descriptor
11208 : fields can then be filled from the values so obtained. */
11209 258 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)));
11210 624 : for (i = 0; i < c->as->rank; i++)
11211 : {
11212 366 : gfc_init_se (&tse, NULL);
11213 366 : e = gfc_copy_expr (c->as->lower[i]);
11214 366 : gfc_insert_parameter_exprs (e, pdt_param_list);
11215 366 : gfc_conv_expr_type (&tse, e, gfc_array_index_type);
11216 366 : gfc_free_expr (e);
11217 366 : lower = tse.expr;
11218 366 : gfc_add_block_to_block (&fnblock, &tse.pre);
11219 366 : gfc_conv_descriptor_lbound_set (&fnblock, comp,
11220 : gfc_rank_cst[i],
11221 : lower);
11222 366 : gfc_add_block_to_block (&fnblock, &tse.post);
11223 366 : e = gfc_copy_expr (c->as->upper[i]);
11224 366 : gfc_insert_parameter_exprs (e, pdt_param_list);
11225 366 : gfc_conv_expr_type (&tse, e, gfc_array_index_type);
11226 366 : gfc_free_expr (e);
11227 366 : upper = tse.expr;
11228 366 : gfc_add_block_to_block (&fnblock, &tse.pre);
11229 366 : gfc_conv_descriptor_ubound_set (&fnblock, comp,
11230 : gfc_rank_cst[i],
11231 : upper);
11232 366 : gfc_add_block_to_block (&fnblock, &tse.post);
11233 366 : gfc_conv_descriptor_stride_set (&fnblock, comp,
11234 : gfc_rank_cst[i],
11235 : size);
11236 366 : size = gfc_evaluate_now (size, &fnblock);
11237 366 : offset = fold_build2_loc (input_location,
11238 : MINUS_EXPR,
11239 : gfc_array_index_type,
11240 : offset, size);
11241 366 : offset = gfc_evaluate_now (offset, &fnblock);
11242 366 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
11243 : gfc_array_index_type,
11244 : upper, lower);
11245 366 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
11246 : gfc_array_index_type,
11247 : tmp, gfc_index_one_node);
11248 366 : size = fold_build2_loc (input_location, MULT_EXPR,
11249 : gfc_array_index_type, size, tmp);
11250 : }
11251 258 : gfc_conv_descriptor_offset_set (&fnblock, comp, offset);
11252 258 : if (c->ts.type == BT_CLASS)
11253 : {
11254 0 : tmp = gfc_get_vptr_from_expr (comp);
11255 0 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
11256 0 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
11257 0 : tmp = gfc_vptr_size_get (tmp);
11258 : }
11259 : else
11260 258 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (ctype));
11261 258 : tmp = fold_convert (gfc_array_index_type, tmp);
11262 258 : size = fold_build2_loc (input_location, MULT_EXPR,
11263 : gfc_array_index_type, size, tmp);
11264 258 : size = gfc_evaluate_now (size, &fnblock);
11265 258 : tmp = gfc_call_malloc (&fnblock, NULL, size);
11266 258 : gfc_conv_descriptor_data_set (&fnblock, comp, tmp);
11267 258 : tmp = gfc_conv_descriptor_dtype (comp);
11268 258 : gfc_add_modify (&fnblock, tmp, gfc_get_dtype (ctype));
11269 :
11270 258 : if (c->initializer && c->initializer->rank)
11271 : {
11272 0 : gfc_init_se (&tse, NULL);
11273 0 : e = gfc_copy_expr (c->initializer);
11274 0 : gfc_insert_parameter_exprs (e, pdt_param_list);
11275 0 : gfc_conv_expr_descriptor (&tse, e);
11276 0 : gfc_add_block_to_block (&fnblock, &tse.pre);
11277 0 : gfc_free_expr (e);
11278 0 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
11279 0 : tmp = build_call_expr_loc (input_location, tmp, 3,
11280 : gfc_conv_descriptor_data_get (comp),
11281 : gfc_conv_descriptor_data_get (tse.expr),
11282 : fold_convert (size_type_node, size));
11283 0 : gfc_add_expr_to_block (&fnblock, tmp);
11284 0 : gfc_add_block_to_block (&fnblock, &tse.post);
11285 : }
11286 : }
11287 :
11288 : /* Recurse in to PDT components. */
11289 443 : if ((IS_PDT (c) || IS_CLASS_PDT (c))
11290 198 : && !(c->attr.pointer || c->attr.allocatable))
11291 : {
11292 103 : gfc_actual_arglist *tail = c->param_list;
11293 :
11294 260 : for (; tail; tail = tail->next)
11295 157 : if (tail->expr)
11296 133 : gfc_insert_parameter_exprs (tail->expr, pdt_param_list);
11297 :
11298 103 : tmp = gfc_allocate_pdt_comp (c->ts.u.derived, comp,
11299 103 : c->as ? c->as->rank : 0,
11300 103 : c->param_list);
11301 103 : gfc_add_expr_to_block (&fnblock, tmp);
11302 : }
11303 :
11304 : break;
11305 :
11306 2218 : case DEALLOCATE_PDT_COMP:
11307 : /* Deallocate array or parameterized string length components
11308 : of parameterized derived types. */
11309 2218 : if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT)
11310 1769 : && !c->attr.pdt_string
11311 1661 : && !(IS_PDT (c) || IS_CLASS_PDT (c)))
11312 1417 : continue;
11313 :
11314 801 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
11315 : decl, cdecl, NULL_TREE);
11316 801 : if (c->ts.type == BT_CLASS)
11317 0 : comp = gfc_class_data_get (comp);
11318 :
11319 : /* Recurse in to PDT components. */
11320 801 : if ((IS_PDT (c) || IS_CLASS_PDT (c))
11321 281 : && (!c->attr.pointer && !c->attr.allocatable))
11322 : {
11323 115 : tmp = gfc_deallocate_pdt_comp (c->ts.u.derived, comp,
11324 115 : c->as ? c->as->rank : 0);
11325 115 : gfc_add_expr_to_block (&fnblock, tmp);
11326 : }
11327 :
11328 801 : if (c->attr.pdt_array || c->attr.pdt_string)
11329 : {
11330 557 : tmp = comp;
11331 557 : if (c->attr.pdt_array)
11332 449 : tmp = gfc_conv_descriptor_data_get (comp);
11333 557 : null_cond = fold_build2_loc (input_location, NE_EXPR,
11334 : logical_type_node, tmp,
11335 557 : build_int_cst (TREE_TYPE (tmp), 0));
11336 557 : if (flag_openmp_allocators)
11337 : {
11338 0 : tree cd, t;
11339 0 : if (c->attr.pdt_array)
11340 0 : cd = fold_build2_loc (input_location, EQ_EXPR,
11341 : boolean_type_node,
11342 : gfc_conv_descriptor_version (comp),
11343 : build_int_cst (integer_type_node, 1));
11344 : else
11345 0 : cd = gfc_omp_call_is_alloc (tmp);
11346 0 : t = builtin_decl_explicit (BUILT_IN_GOMP_FREE);
11347 0 : t = build_call_expr_loc (input_location, t, 1, tmp);
11348 :
11349 0 : stmtblock_t tblock;
11350 0 : gfc_init_block (&tblock);
11351 0 : gfc_add_expr_to_block (&tblock, t);
11352 0 : if (c->attr.pdt_array)
11353 0 : gfc_add_modify (&tblock, gfc_conv_descriptor_version (comp),
11354 : integer_zero_node);
11355 0 : tmp = build3_loc (input_location, COND_EXPR, void_type_node,
11356 : cd, gfc_finish_block (&tblock),
11357 : gfc_call_free (tmp));
11358 : }
11359 : else
11360 557 : tmp = gfc_call_free (tmp);
11361 557 : tmp = build3_v (COND_EXPR, null_cond, tmp,
11362 : build_empty_stmt (input_location));
11363 557 : gfc_add_expr_to_block (&fnblock, tmp);
11364 :
11365 557 : if (c->attr.pdt_array)
11366 449 : gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
11367 : else
11368 : {
11369 108 : tmp = fold_convert (TREE_TYPE (comp), null_pointer_node);
11370 108 : gfc_add_modify (&fnblock, comp, tmp);
11371 : }
11372 : }
11373 :
11374 : break;
11375 :
11376 324 : case CHECK_PDT_DUMMY:
11377 :
11378 324 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
11379 : decl, cdecl, NULL_TREE);
11380 324 : if (c->ts.type == BT_CLASS)
11381 0 : comp = gfc_class_data_get (comp);
11382 :
11383 : /* Recurse in to PDT components. */
11384 324 : if (((c->ts.type == BT_DERIVED
11385 14 : && !c->attr.allocatable && !c->attr.pointer)
11386 312 : || (c->ts.type == BT_CLASS
11387 0 : && !CLASS_DATA (c)->attr.allocatable
11388 0 : && !CLASS_DATA (c)->attr.pointer))
11389 12 : && c->ts.u.derived && c->ts.u.derived->attr.pdt_type)
11390 : {
11391 12 : tmp = gfc_check_pdt_dummy (c->ts.u.derived, comp,
11392 12 : c->as ? c->as->rank : 0,
11393 : pdt_param_list);
11394 12 : gfc_add_expr_to_block (&fnblock, tmp);
11395 : }
11396 :
11397 324 : if (!c->attr.pdt_len)
11398 276 : continue;
11399 : else
11400 : {
11401 48 : gfc_se tse;
11402 48 : gfc_expr *c_expr = NULL;
11403 48 : gfc_actual_arglist *param = pdt_param_list;
11404 :
11405 48 : gfc_init_se (&tse, NULL);
11406 186 : for (; param; param = param->next)
11407 90 : if (!strcmp (c->name, param->name)
11408 48 : && param->spec_type == SPEC_EXPLICIT)
11409 30 : c_expr = param->expr;
11410 :
11411 48 : if (c_expr)
11412 : {
11413 30 : tree error, cond, cname;
11414 30 : gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp));
11415 30 : cond = fold_build2_loc (input_location, NE_EXPR,
11416 : logical_type_node,
11417 : comp, tse.expr);
11418 30 : cname = gfc_build_cstring_const (c->name);
11419 30 : cname = gfc_build_addr_expr (pchar_type_node, cname);
11420 30 : error = gfc_trans_runtime_error (true, NULL,
11421 : "The value of the PDT LEN "
11422 : "parameter '%s' does not "
11423 : "agree with that in the "
11424 : "dummy declaration",
11425 : cname);
11426 30 : tmp = fold_build3_loc (input_location, COND_EXPR,
11427 : void_type_node, cond, error,
11428 : build_empty_stmt (input_location));
11429 30 : gfc_add_expr_to_block (&fnblock, tmp);
11430 : }
11431 : }
11432 48 : break;
11433 :
11434 0 : default:
11435 0 : gcc_unreachable ();
11436 6032 : break;
11437 : }
11438 : }
11439 17554 : seen_derived_types.remove (der_type);
11440 :
11441 17554 : return gfc_finish_block (&fnblock);
11442 : }
11443 :
11444 : /* Recursively traverse an object of derived type, generating code to
11445 : nullify allocatable components. */
11446 :
11447 : tree
11448 2814 : gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
11449 : int caf_mode)
11450 : {
11451 2814 : return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11452 : NULLIFY_ALLOC_COMP,
11453 : GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode,
11454 2814 : NULL);
11455 : }
11456 :
11457 :
11458 : /* Recursively traverse an object of derived type, generating code to
11459 : deallocate allocatable components. */
11460 :
11461 : tree
11462 2847 : gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
11463 : int caf_mode, bool no_finalization)
11464 : {
11465 2847 : return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11466 : DEALLOCATE_ALLOC_COMP,
11467 : GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode,
11468 2847 : NULL, no_finalization);
11469 : }
11470 :
11471 : tree
11472 1 : gfc_bcast_alloc_comp (gfc_symbol *derived, gfc_expr *expr, int rank,
11473 : tree image_index, tree stat, tree errmsg,
11474 : tree errmsg_len)
11475 : {
11476 1 : tree tmp, array;
11477 1 : gfc_se argse;
11478 1 : stmtblock_t block, post_block;
11479 1 : gfc_co_subroutines_args args;
11480 :
11481 1 : args.image_index = image_index;
11482 1 : args.stat = stat;
11483 1 : args.errmsg = errmsg;
11484 1 : args.errmsg_len = errmsg_len;
11485 :
11486 1 : if (rank == 0)
11487 : {
11488 1 : gfc_start_block (&block);
11489 1 : gfc_init_block (&post_block);
11490 1 : gfc_init_se (&argse, NULL);
11491 1 : gfc_conv_expr (&argse, expr);
11492 1 : gfc_add_block_to_block (&block, &argse.pre);
11493 1 : gfc_add_block_to_block (&post_block, &argse.post);
11494 1 : array = argse.expr;
11495 : }
11496 : else
11497 : {
11498 0 : gfc_init_se (&argse, NULL);
11499 0 : argse.want_pointer = 1;
11500 0 : gfc_conv_expr_descriptor (&argse, expr);
11501 0 : array = argse.expr;
11502 : }
11503 :
11504 1 : tmp = structure_alloc_comps (derived, array, NULL_TREE, rank,
11505 : BCAST_ALLOC_COMP,
11506 : GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY,
11507 : &args);
11508 1 : return tmp;
11509 : }
11510 :
11511 : /* Recursively traverse an object of derived type, generating code to
11512 : deallocate allocatable components. But do not deallocate coarrays.
11513 : To be used for intrinsic assignment, which may not change the allocation
11514 : status of coarrays. */
11515 :
11516 : tree
11517 2114 : gfc_deallocate_alloc_comp_no_caf (gfc_symbol * der_type, tree decl, int rank,
11518 : bool no_finalization)
11519 : {
11520 2114 : return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11521 : DEALLOCATE_ALLOC_COMP, 0, NULL,
11522 2114 : no_finalization);
11523 : }
11524 :
11525 :
11526 : tree
11527 5 : gfc_reassign_alloc_comp_caf (gfc_symbol *der_type, tree decl, tree dest)
11528 : {
11529 5 : return structure_alloc_comps (der_type, decl, dest, 0, REASSIGN_CAF_COMP,
11530 : GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY,
11531 5 : NULL);
11532 : }
11533 :
11534 :
11535 : /* Recursively traverse an object of derived type, generating code to
11536 : copy it and its allocatable components. */
11537 :
11538 : tree
11539 4273 : gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank,
11540 : int caf_mode)
11541 : {
11542 4273 : return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP,
11543 4273 : caf_mode, NULL);
11544 : }
11545 :
11546 :
11547 : /* Recursively traverse an object of derived type, generating code to
11548 : copy it and its allocatable components, while suppressing any
11549 : finalization that might occur. This is used in the finalization of
11550 : function results. */
11551 :
11552 : tree
11553 38 : gfc_copy_alloc_comp_no_fini (gfc_symbol * der_type, tree decl, tree dest,
11554 : int rank, int caf_mode)
11555 : {
11556 38 : return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP,
11557 38 : caf_mode, NULL, true);
11558 : }
11559 :
11560 :
11561 : /* Recursively traverse an object of derived type, generating code to
11562 : copy only its allocatable components. */
11563 :
11564 : tree
11565 0 : gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
11566 : {
11567 0 : return structure_alloc_comps (der_type, decl, dest, rank,
11568 0 : COPY_ONLY_ALLOC_COMP, 0, NULL);
11569 : }
11570 :
11571 :
11572 : /* Recursively traverse an object of parameterized derived type, generating
11573 : code to allocate parameterized components. */
11574 :
11575 : tree
11576 670 : gfc_allocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank,
11577 : gfc_actual_arglist *param_list)
11578 : {
11579 670 : tree res;
11580 670 : gfc_actual_arglist *old_param_list = pdt_param_list;
11581 670 : pdt_param_list = param_list;
11582 670 : res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11583 : ALLOCATE_PDT_COMP, 0, NULL);
11584 670 : pdt_param_list = old_param_list;
11585 670 : return res;
11586 : }
11587 :
11588 : /* Recursively traverse an object of parameterized derived type, generating
11589 : code to deallocate parameterized components. */
11590 :
11591 : static bool
11592 1113 : has_parameterized_comps (gfc_symbol * der_type)
11593 : {
11594 : /* A type without parameterized components causes gimplifier problems. */
11595 1113 : bool parameterized_comps = false;
11596 4030 : for (gfc_component *c = der_type->components; c; c = c->next)
11597 2917 : if (c->attr.pdt_array || c->attr.pdt_string)
11598 : parameterized_comps = true;
11599 2341 : else if (IS_PDT (c) && strcmp (der_type->name, c->ts.u.derived->name))
11600 180 : parameterized_comps = has_parameterized_comps (c->ts.u.derived);
11601 1113 : return parameterized_comps;
11602 : }
11603 :
11604 : tree
11605 933 : gfc_deallocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank)
11606 : {
11607 933 : if (!has_parameterized_comps (der_type))
11608 : return NULL_TREE;
11609 :
11610 504 : return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11611 504 : DEALLOCATE_PDT_COMP, 0, NULL);
11612 : }
11613 :
11614 :
11615 : /* Recursively traverse a dummy of parameterized derived type to check the
11616 : values of LEN parameters. */
11617 :
11618 : tree
11619 74 : gfc_check_pdt_dummy (gfc_symbol * der_type, tree decl, int rank,
11620 : gfc_actual_arglist *param_list)
11621 : {
11622 74 : tree res;
11623 74 : gfc_actual_arglist *old_param_list = pdt_param_list;
11624 74 : pdt_param_list = param_list;
11625 74 : res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11626 : CHECK_PDT_DUMMY, 0, NULL);
11627 74 : pdt_param_list = old_param_list;
11628 74 : return res;
11629 : }
11630 :
11631 :
11632 : /* Returns the value of LBOUND for an expression. This could be broken out
11633 : from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
11634 : called by gfc_alloc_allocatable_for_assignment. */
11635 : static tree
11636 994 : get_std_lbound (gfc_expr *expr, tree desc, int dim, bool assumed_size)
11637 : {
11638 994 : tree lbound;
11639 994 : tree ubound;
11640 994 : tree stride;
11641 994 : tree cond, cond1, cond3, cond4;
11642 994 : tree tmp;
11643 994 : gfc_ref *ref;
11644 :
11645 994 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
11646 : {
11647 484 : tmp = gfc_rank_cst[dim];
11648 484 : lbound = gfc_conv_descriptor_lbound_get (desc, tmp);
11649 484 : ubound = gfc_conv_descriptor_ubound_get (desc, tmp);
11650 484 : stride = gfc_conv_descriptor_stride_get (desc, tmp);
11651 484 : cond1 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
11652 : ubound, lbound);
11653 484 : cond3 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
11654 : stride, gfc_index_zero_node);
11655 484 : cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
11656 : logical_type_node, cond3, cond1);
11657 484 : cond4 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
11658 : stride, gfc_index_zero_node);
11659 484 : if (assumed_size)
11660 0 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
11661 : tmp, build_int_cst (gfc_array_index_type,
11662 0 : expr->rank - 1));
11663 : else
11664 484 : cond = logical_false_node;
11665 :
11666 484 : cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
11667 : logical_type_node, cond3, cond4);
11668 484 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
11669 : logical_type_node, cond, cond1);
11670 :
11671 484 : return fold_build3_loc (input_location, COND_EXPR,
11672 : gfc_array_index_type, cond,
11673 484 : lbound, gfc_index_one_node);
11674 : }
11675 :
11676 510 : if (expr->expr_type == EXPR_FUNCTION)
11677 : {
11678 : /* A conversion function, so use the argument. */
11679 7 : gcc_assert (expr->value.function.isym
11680 : && expr->value.function.isym->conversion);
11681 7 : expr = expr->value.function.actual->expr;
11682 : }
11683 :
11684 510 : if (expr->expr_type == EXPR_VARIABLE)
11685 : {
11686 510 : tmp = TREE_TYPE (expr->symtree->n.sym->backend_decl);
11687 1334 : for (ref = expr->ref; ref; ref = ref->next)
11688 : {
11689 824 : if (ref->type == REF_COMPONENT
11690 265 : && ref->u.c.component->as
11691 216 : && ref->next
11692 216 : && ref->next->u.ar.type == AR_FULL)
11693 174 : tmp = TREE_TYPE (ref->u.c.component->backend_decl);
11694 : }
11695 510 : return GFC_TYPE_ARRAY_LBOUND(tmp, dim);
11696 : }
11697 :
11698 0 : return gfc_index_one_node;
11699 : }
11700 :
11701 :
11702 : /* Returns true if an expression represents an lhs that can be reallocated
11703 : on assignment. */
11704 :
11705 : bool
11706 342032 : gfc_is_reallocatable_lhs (gfc_expr *expr)
11707 : {
11708 342032 : gfc_ref * ref;
11709 342032 : gfc_symbol *sym;
11710 :
11711 342032 : if (!flag_realloc_lhs)
11712 : return false;
11713 :
11714 342032 : if (!expr->ref)
11715 : return false;
11716 :
11717 121029 : sym = expr->symtree->n.sym;
11718 :
11719 121029 : if (sym->attr.associate_var && !expr->ref)
11720 : return false;
11721 :
11722 : /* An allocatable class variable with no reference. */
11723 121029 : if (sym->ts.type == BT_CLASS
11724 3595 : && (!sym->attr.associate_var || sym->attr.select_rank_temporary)
11725 3507 : && CLASS_DATA (sym)->attr.allocatable
11726 : && expr->ref
11727 2295 : && ((expr->ref->type == REF_ARRAY && expr->ref->u.ar.type == AR_FULL
11728 0 : && expr->ref->next == NULL)
11729 2295 : || (expr->ref->type == REF_COMPONENT
11730 2295 : && strcmp (expr->ref->u.c.component->name, "_data") == 0
11731 1931 : && (expr->ref->next == NULL
11732 1931 : || (expr->ref->next->type == REF_ARRAY
11733 1931 : && expr->ref->next->u.ar.type == AR_FULL
11734 1647 : && expr->ref->next->next == NULL)))))
11735 : return true;
11736 :
11737 : /* An allocatable variable. */
11738 119522 : if (sym->attr.allocatable
11739 29415 : && (!sym->attr.associate_var || sym->attr.select_rank_temporary)
11740 : && expr->ref
11741 29415 : && expr->ref->type == REF_ARRAY
11742 28584 : && expr->ref->u.ar.type == AR_FULL)
11743 : return true;
11744 :
11745 : /* All that can be left are allocatable components. */
11746 100400 : if (sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
11747 : return false;
11748 :
11749 : /* Find a component ref followed by an array reference. */
11750 49328 : for (ref = expr->ref; ref; ref = ref->next)
11751 35396 : if (ref->next
11752 21464 : && ref->type == REF_COMPONENT
11753 12840 : && ref->next->type == REF_ARRAY
11754 10605 : && !ref->next->next)
11755 : break;
11756 :
11757 21683 : if (!ref)
11758 : return false;
11759 :
11760 : /* Return true if valid reallocatable lhs. */
11761 7751 : if (ref->u.c.component->attr.allocatable
11762 4002 : && ref->next->u.ar.type == AR_FULL)
11763 3148 : return true;
11764 :
11765 : return false;
11766 : }
11767 :
11768 :
11769 : static tree
11770 56 : concat_str_length (gfc_expr* expr)
11771 : {
11772 56 : tree type;
11773 56 : tree len1;
11774 56 : tree len2;
11775 56 : gfc_se se;
11776 :
11777 56 : type = gfc_typenode_for_spec (&expr->value.op.op1->ts);
11778 56 : len1 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
11779 56 : if (len1 == NULL_TREE)
11780 : {
11781 56 : if (expr->value.op.op1->expr_type == EXPR_OP)
11782 31 : len1 = concat_str_length (expr->value.op.op1);
11783 25 : else if (expr->value.op.op1->expr_type == EXPR_CONSTANT)
11784 25 : len1 = build_int_cst (gfc_charlen_type_node,
11785 25 : expr->value.op.op1->value.character.length);
11786 0 : else if (expr->value.op.op1->ts.u.cl->length)
11787 : {
11788 0 : gfc_init_se (&se, NULL);
11789 0 : gfc_conv_expr (&se, expr->value.op.op1->ts.u.cl->length);
11790 0 : len1 = se.expr;
11791 : }
11792 : else
11793 : {
11794 : /* Last resort! */
11795 0 : gfc_init_se (&se, NULL);
11796 0 : se.want_pointer = 1;
11797 0 : se.descriptor_only = 1;
11798 0 : gfc_conv_expr (&se, expr->value.op.op1);
11799 0 : len1 = se.string_length;
11800 : }
11801 : }
11802 :
11803 56 : type = gfc_typenode_for_spec (&expr->value.op.op2->ts);
11804 56 : len2 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
11805 56 : if (len2 == NULL_TREE)
11806 : {
11807 31 : if (expr->value.op.op2->expr_type == EXPR_OP)
11808 0 : len2 = concat_str_length (expr->value.op.op2);
11809 31 : else if (expr->value.op.op2->expr_type == EXPR_CONSTANT)
11810 25 : len2 = build_int_cst (gfc_charlen_type_node,
11811 25 : expr->value.op.op2->value.character.length);
11812 6 : else if (expr->value.op.op2->ts.u.cl->length)
11813 : {
11814 6 : gfc_init_se (&se, NULL);
11815 6 : gfc_conv_expr (&se, expr->value.op.op2->ts.u.cl->length);
11816 6 : len2 = se.expr;
11817 : }
11818 : else
11819 : {
11820 : /* Last resort! */
11821 0 : gfc_init_se (&se, NULL);
11822 0 : se.want_pointer = 1;
11823 0 : se.descriptor_only = 1;
11824 0 : gfc_conv_expr (&se, expr->value.op.op2);
11825 0 : len2 = se.string_length;
11826 : }
11827 : }
11828 :
11829 56 : gcc_assert(len1 && len2);
11830 56 : len1 = fold_convert (gfc_charlen_type_node, len1);
11831 56 : len2 = fold_convert (gfc_charlen_type_node, len2);
11832 :
11833 56 : return fold_build2_loc (input_location, PLUS_EXPR,
11834 56 : gfc_charlen_type_node, len1, len2);
11835 : }
11836 :
11837 :
11838 : /* Among the scalarization chain of LOOP, find the element associated with an
11839 : allocatable array on the lhs of an assignment and evaluate its fields
11840 : (bounds, offset, etc) to new variables, putting the new code in BLOCK. This
11841 : function is to be called after putting the reallocation code in BLOCK and
11842 : before the beginning of the scalarization loop body.
11843 :
11844 : The fields to be saved are expected to hold on entry to the function
11845 : expressions referencing the array descriptor. Especially the expressions
11846 : shouldn't be already temporary variable references as the value saved before
11847 : reallocation would be incorrect after reallocation.
11848 : At the end of the function, the expressions have been replaced with variable
11849 : references. */
11850 :
11851 : static void
11852 6360 : update_reallocated_descriptor (stmtblock_t *block, gfc_loopinfo *loop)
11853 : {
11854 22280 : for (gfc_ss *s = loop->ss; s != gfc_ss_terminator; s = s->loop_chain)
11855 : {
11856 15920 : if (!s->is_alloc_lhs)
11857 9560 : continue;
11858 :
11859 6360 : gcc_assert (s->info->type == GFC_SS_SECTION);
11860 6360 : gfc_array_info *info = &s->info->data.array;
11861 :
11862 : #define SAVE_VALUE(value) \
11863 : do \
11864 : { \
11865 : value = gfc_evaluate_now (value, block); \
11866 : } \
11867 : while (0)
11868 :
11869 6360 : if (save_descriptor_data (info->descriptor, info->data))
11870 5604 : SAVE_VALUE (info->data);
11871 6360 : SAVE_VALUE (info->offset);
11872 6360 : info->saved_offset = info->offset;
11873 15925 : for (int i = 0; i < s->dimen; i++)
11874 : {
11875 9565 : int dim = s->dim[i];
11876 9565 : SAVE_VALUE (info->start[dim]);
11877 9565 : SAVE_VALUE (info->end[dim]);
11878 9565 : SAVE_VALUE (info->stride[dim]);
11879 9565 : SAVE_VALUE (info->delta[dim]);
11880 : }
11881 :
11882 : #undef SAVE_VALUE
11883 : }
11884 6360 : }
11885 :
11886 :
11887 : /* Allocate the lhs of an assignment to an allocatable array, otherwise
11888 : reallocate it. */
11889 :
11890 : tree
11891 6360 : gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
11892 : gfc_expr *expr1,
11893 : gfc_expr *expr2)
11894 : {
11895 6360 : stmtblock_t realloc_block;
11896 6360 : stmtblock_t alloc_block;
11897 6360 : stmtblock_t fblock;
11898 6360 : stmtblock_t loop_pre_block;
11899 6360 : gfc_ref *ref;
11900 6360 : gfc_ss *rss;
11901 6360 : gfc_ss *lss;
11902 6360 : gfc_array_info *linfo;
11903 6360 : tree realloc_expr;
11904 6360 : tree alloc_expr;
11905 6360 : tree size1;
11906 6360 : tree size2;
11907 6360 : tree elemsize1;
11908 6360 : tree elemsize2;
11909 6360 : tree array1;
11910 6360 : tree cond_null;
11911 6360 : tree cond;
11912 6360 : tree tmp;
11913 6360 : tree tmp2;
11914 6360 : tree lbound;
11915 6360 : tree ubound;
11916 6360 : tree desc;
11917 6360 : tree old_desc;
11918 6360 : tree desc2;
11919 6360 : tree offset;
11920 6360 : tree jump_label1;
11921 6360 : tree jump_label2;
11922 6360 : tree lbd;
11923 6360 : tree class_expr2 = NULL_TREE;
11924 6360 : int n;
11925 6360 : gfc_array_spec * as;
11926 6360 : bool coarray = (flag_coarray == GFC_FCOARRAY_LIB
11927 6360 : && gfc_caf_attr (expr1, true).codimension);
11928 6360 : tree token;
11929 6360 : gfc_se caf_se;
11930 :
11931 : /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
11932 : Find the lhs expression in the loop chain and set expr1 and
11933 : expr2 accordingly. */
11934 6360 : if (expr1->expr_type == EXPR_FUNCTION && expr2 == NULL)
11935 : {
11936 167 : expr2 = expr1;
11937 : /* Find the ss for the lhs. */
11938 167 : lss = loop->ss;
11939 334 : for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
11940 334 : if (lss->info->expr && lss->info->expr->expr_type == EXPR_VARIABLE)
11941 : break;
11942 167 : if (lss == gfc_ss_terminator)
11943 : return NULL_TREE;
11944 167 : expr1 = lss->info->expr;
11945 : }
11946 :
11947 : /* Bail out if this is not a valid allocate on assignment. */
11948 6360 : if (!gfc_is_reallocatable_lhs (expr1)
11949 6360 : || (expr2 && !expr2->rank))
11950 : return NULL_TREE;
11951 :
11952 : /* Find the ss for the lhs. */
11953 6360 : lss = loop->ss;
11954 15920 : for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
11955 15920 : if (lss->info->expr == expr1)
11956 : break;
11957 :
11958 6360 : if (lss == gfc_ss_terminator)
11959 : return NULL_TREE;
11960 :
11961 6360 : linfo = &lss->info->data.array;
11962 :
11963 : /* Find an ss for the rhs. For operator expressions, we see the
11964 : ss's for the operands. Any one of these will do. */
11965 6360 : rss = loop->ss;
11966 6908 : for (; rss && rss != gfc_ss_terminator; rss = rss->loop_chain)
11967 6908 : if (rss->info->expr != expr1 && rss != loop->temp_ss)
11968 : break;
11969 :
11970 6360 : if (expr2 && rss == gfc_ss_terminator)
11971 : return NULL_TREE;
11972 :
11973 : /* Ensure that the string length from the current scope is used. */
11974 6360 : if (expr2->ts.type == BT_CHARACTER
11975 983 : && expr2->expr_type == EXPR_FUNCTION
11976 130 : && !expr2->value.function.isym)
11977 21 : expr2->ts.u.cl->backend_decl = rss->info->string_length;
11978 :
11979 : /* Since the lhs is allocatable, this must be a descriptor type.
11980 : Get the data and array size. */
11981 6360 : desc = linfo->descriptor;
11982 6360 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
11983 6360 : array1 = gfc_conv_descriptor_data_get (desc);
11984 :
11985 : /* If the data is null, set the descriptor bounds and offset. This suppresses
11986 : the maybe used uninitialized warning. Note that the always false variable
11987 : prevents this block from ever being executed, and makes sure that the
11988 : optimizers are able to remove it. Component references are not subject to
11989 : the warnings, so we don't uselessly complicate the generated code for them.
11990 : */
11991 11410 : for (ref = expr1->ref; ref; ref = ref->next)
11992 6555 : if (ref->type == REF_COMPONENT)
11993 : break;
11994 :
11995 6360 : if (!ref)
11996 : {
11997 4855 : stmtblock_t unalloc_init_block;
11998 4855 : gfc_init_block (&unalloc_init_block);
11999 4855 : tree guard = gfc_create_var (logical_type_node, "unallocated_init_guard");
12000 4855 : gfc_add_modify (&unalloc_init_block, guard, logical_false_node);
12001 :
12002 4855 : gfc_start_block (&loop_pre_block);
12003 17413 : for (n = 0; n < expr1->rank; n++)
12004 : {
12005 7703 : gfc_conv_descriptor_lbound_set (&loop_pre_block, desc,
12006 : gfc_rank_cst[n],
12007 : gfc_index_one_node);
12008 7703 : gfc_conv_descriptor_ubound_set (&loop_pre_block, desc,
12009 : gfc_rank_cst[n],
12010 : gfc_index_zero_node);
12011 7703 : gfc_conv_descriptor_stride_set (&loop_pre_block, desc,
12012 : gfc_rank_cst[n],
12013 : gfc_index_zero_node);
12014 : }
12015 :
12016 4855 : gfc_conv_descriptor_offset_set (&loop_pre_block, desc,
12017 : gfc_index_zero_node);
12018 :
12019 4855 : tmp = fold_build2_loc (input_location, EQ_EXPR,
12020 : logical_type_node, array1,
12021 4855 : build_int_cst (TREE_TYPE (array1), 0));
12022 4855 : tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
12023 : logical_type_node, tmp, guard);
12024 4855 : tmp = build3_v (COND_EXPR, tmp,
12025 : gfc_finish_block (&loop_pre_block),
12026 : build_empty_stmt (input_location));
12027 4855 : gfc_prepend_expr_to_block (&loop->pre, tmp);
12028 4855 : gfc_prepend_expr_to_block (&loop->pre,
12029 : gfc_finish_block (&unalloc_init_block));
12030 : }
12031 :
12032 6360 : gfc_start_block (&fblock);
12033 :
12034 6360 : if (expr2)
12035 6360 : desc2 = rss->info->data.array.descriptor;
12036 : else
12037 : desc2 = NULL_TREE;
12038 :
12039 : /* Get the old lhs element size for deferred character and class expr1. */
12040 6360 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12041 : {
12042 663 : if (expr1->ts.u.cl->backend_decl
12043 663 : && VAR_P (expr1->ts.u.cl->backend_decl))
12044 : elemsize1 = expr1->ts.u.cl->backend_decl;
12045 : else
12046 64 : elemsize1 = lss->info->string_length;
12047 663 : tree unit_size = TYPE_SIZE_UNIT (gfc_get_char_type (expr1->ts.kind));
12048 1326 : elemsize1 = fold_build2_loc (input_location, MULT_EXPR,
12049 663 : TREE_TYPE (elemsize1), elemsize1,
12050 663 : fold_convert (TREE_TYPE (elemsize1), unit_size));
12051 :
12052 663 : }
12053 5697 : else if (expr1->ts.type == BT_CLASS)
12054 : {
12055 : /* Unfortunately, the lhs vptr is set too early in many cases.
12056 : Play it safe by using the descriptor element length. */
12057 609 : tmp = gfc_conv_descriptor_elem_len (desc);
12058 609 : elemsize1 = fold_convert (gfc_array_index_type, tmp);
12059 : }
12060 : else
12061 : elemsize1 = NULL_TREE;
12062 1272 : if (elemsize1 != NULL_TREE)
12063 1272 : elemsize1 = gfc_evaluate_now (elemsize1, &fblock);
12064 :
12065 : /* Get the new lhs size in bytes. */
12066 6360 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12067 : {
12068 663 : if (expr2->ts.deferred)
12069 : {
12070 183 : if (expr2->ts.u.cl->backend_decl
12071 183 : && VAR_P (expr2->ts.u.cl->backend_decl))
12072 : tmp = expr2->ts.u.cl->backend_decl;
12073 : else
12074 0 : tmp = rss->info->string_length;
12075 : }
12076 : else
12077 : {
12078 480 : tmp = expr2->ts.u.cl->backend_decl;
12079 480 : if (!tmp && expr2->expr_type == EXPR_OP
12080 25 : && expr2->value.op.op == INTRINSIC_CONCAT)
12081 : {
12082 25 : tmp = concat_str_length (expr2);
12083 25 : expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
12084 : }
12085 12 : else if (!tmp && expr2->ts.u.cl->length)
12086 : {
12087 12 : gfc_se tmpse;
12088 12 : gfc_init_se (&tmpse, NULL);
12089 12 : gfc_conv_expr_type (&tmpse, expr2->ts.u.cl->length,
12090 : gfc_charlen_type_node);
12091 12 : tmp = tmpse.expr;
12092 12 : expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
12093 : }
12094 480 : tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
12095 : }
12096 :
12097 663 : if (expr1->ts.u.cl->backend_decl
12098 663 : && VAR_P (expr1->ts.u.cl->backend_decl))
12099 599 : gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
12100 : else
12101 64 : gfc_add_modify (&fblock, lss->info->string_length, tmp);
12102 :
12103 663 : if (expr1->ts.kind > 1)
12104 12 : tmp = fold_build2_loc (input_location, MULT_EXPR,
12105 6 : TREE_TYPE (tmp),
12106 6 : tmp, build_int_cst (TREE_TYPE (tmp),
12107 6 : expr1->ts.kind));
12108 : }
12109 5697 : else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
12110 : {
12111 271 : tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts)));
12112 271 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
12113 : fold_convert (gfc_array_index_type, tmp),
12114 271 : expr1->ts.u.cl->backend_decl);
12115 : }
12116 5426 : else if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS)
12117 164 : tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
12118 5262 : else if (expr1->ts.type == BT_CLASS && expr2->ts.type == BT_CLASS)
12119 : {
12120 268 : tmp = expr2->rank ? gfc_get_class_from_expr (desc2) : NULL_TREE;
12121 268 : if (tmp == NULL_TREE && expr2->expr_type == EXPR_VARIABLE)
12122 24 : tmp = class_expr2 = gfc_get_class_from_gfc_expr (expr2);
12123 :
12124 31 : if (tmp != NULL_TREE)
12125 261 : tmp = gfc_class_vtab_size_get (tmp);
12126 : else
12127 7 : tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&CLASS_DATA (expr2)->ts));
12128 : }
12129 : else
12130 4994 : tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
12131 6360 : elemsize2 = fold_convert (gfc_array_index_type, tmp);
12132 6360 : elemsize2 = gfc_evaluate_now (elemsize2, &fblock);
12133 :
12134 : /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
12135 : deallocated if expr is an array of different shape or any of the
12136 : corresponding length type parameter values of variable and expr
12137 : differ." This assures F95 compatibility. */
12138 6360 : jump_label1 = gfc_build_label_decl (NULL_TREE);
12139 6360 : jump_label2 = gfc_build_label_decl (NULL_TREE);
12140 :
12141 : /* Allocate if data is NULL. */
12142 6360 : cond_null = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
12143 6360 : array1, build_int_cst (TREE_TYPE (array1), 0));
12144 6360 : cond_null= gfc_evaluate_now (cond_null, &fblock);
12145 :
12146 6360 : tmp = build3_v (COND_EXPR, cond_null,
12147 : build1_v (GOTO_EXPR, jump_label1),
12148 : build_empty_stmt (input_location));
12149 6360 : gfc_add_expr_to_block (&fblock, tmp);
12150 :
12151 : /* Get arrayspec if expr is a full array. */
12152 6360 : if (expr2 && expr2->expr_type == EXPR_FUNCTION
12153 2748 : && expr2->value.function.isym
12154 2295 : && expr2->value.function.isym->conversion)
12155 : {
12156 : /* For conversion functions, take the arg. */
12157 245 : gfc_expr *arg = expr2->value.function.actual->expr;
12158 245 : as = gfc_get_full_arrayspec_from_expr (arg);
12159 245 : }
12160 : else if (expr2)
12161 6115 : as = gfc_get_full_arrayspec_from_expr (expr2);
12162 : else
12163 : as = NULL;
12164 :
12165 : /* If the lhs shape is not the same as the rhs jump to setting the
12166 : bounds and doing the reallocation....... */
12167 15925 : for (n = 0; n < expr1->rank; n++)
12168 : {
12169 : /* Check the shape. */
12170 9565 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
12171 9565 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
12172 9565 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
12173 : gfc_array_index_type,
12174 : loop->to[n], loop->from[n]);
12175 9565 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
12176 : gfc_array_index_type,
12177 : tmp, lbound);
12178 9565 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
12179 : gfc_array_index_type,
12180 : tmp, ubound);
12181 9565 : cond = fold_build2_loc (input_location, NE_EXPR,
12182 : logical_type_node,
12183 : tmp, gfc_index_zero_node);
12184 9565 : tmp = build3_v (COND_EXPR, cond,
12185 : build1_v (GOTO_EXPR, jump_label1),
12186 : build_empty_stmt (input_location));
12187 9565 : gfc_add_expr_to_block (&fblock, tmp);
12188 : }
12189 :
12190 : /* ...else if the element lengths are not the same also go to
12191 : setting the bounds and doing the reallocation.... */
12192 6360 : if (elemsize1 != NULL_TREE)
12193 : {
12194 1272 : cond = fold_build2_loc (input_location, NE_EXPR,
12195 : logical_type_node,
12196 : elemsize1, elemsize2);
12197 1272 : tmp = build3_v (COND_EXPR, cond,
12198 : build1_v (GOTO_EXPR, jump_label1),
12199 : build_empty_stmt (input_location));
12200 1272 : gfc_add_expr_to_block (&fblock, tmp);
12201 : }
12202 :
12203 : /* ....else jump past the (re)alloc code. */
12204 6360 : tmp = build1_v (GOTO_EXPR, jump_label2);
12205 6360 : gfc_add_expr_to_block (&fblock, tmp);
12206 :
12207 : /* Add the label to start automatic (re)allocation. */
12208 6360 : tmp = build1_v (LABEL_EXPR, jump_label1);
12209 6360 : gfc_add_expr_to_block (&fblock, tmp);
12210 :
12211 : /* Get the rhs size and fix it. */
12212 6360 : size2 = gfc_index_one_node;
12213 15925 : for (n = 0; n < expr2->rank; n++)
12214 : {
12215 9565 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
12216 : gfc_array_index_type,
12217 : loop->to[n], loop->from[n]);
12218 9565 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
12219 : gfc_array_index_type,
12220 : tmp, gfc_index_one_node);
12221 9565 : size2 = fold_build2_loc (input_location, MULT_EXPR,
12222 : gfc_array_index_type,
12223 : tmp, size2);
12224 : }
12225 6360 : size2 = gfc_evaluate_now (size2, &fblock);
12226 :
12227 : /* Deallocation of allocatable components will have to occur on
12228 : reallocation. Fix the old descriptor now. */
12229 6360 : if ((expr1->ts.type == BT_DERIVED)
12230 320 : && expr1->ts.u.derived->attr.alloc_comp)
12231 121 : old_desc = gfc_evaluate_now (desc, &fblock);
12232 : else
12233 : old_desc = NULL_TREE;
12234 :
12235 : /* Now modify the lhs descriptor and the associated scalarizer
12236 : variables. F2003 7.4.1.3: "If variable is or becomes an
12237 : unallocated allocatable variable, then it is allocated with each
12238 : deferred type parameter equal to the corresponding type parameters
12239 : of expr , with the shape of expr , and with each lower bound equal
12240 : to the corresponding element of LBOUND(expr)."
12241 : Reuse size1 to keep a dimension-by-dimension track of the
12242 : stride of the new array. */
12243 6360 : size1 = gfc_index_one_node;
12244 6360 : offset = gfc_index_zero_node;
12245 :
12246 15925 : for (n = 0; n < expr2->rank; n++)
12247 : {
12248 9565 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
12249 : gfc_array_index_type,
12250 : loop->to[n], loop->from[n]);
12251 9565 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
12252 : gfc_array_index_type,
12253 : tmp, gfc_index_one_node);
12254 :
12255 9565 : lbound = gfc_index_one_node;
12256 9565 : ubound = tmp;
12257 :
12258 9565 : if (as)
12259 : {
12260 1988 : lbd = get_std_lbound (expr2, desc2, n,
12261 994 : as->type == AS_ASSUMED_SIZE);
12262 994 : ubound = fold_build2_loc (input_location,
12263 : MINUS_EXPR,
12264 : gfc_array_index_type,
12265 : ubound, lbound);
12266 994 : ubound = fold_build2_loc (input_location,
12267 : PLUS_EXPR,
12268 : gfc_array_index_type,
12269 : ubound, lbd);
12270 994 : lbound = lbd;
12271 : }
12272 :
12273 9565 : gfc_conv_descriptor_lbound_set (&fblock, desc,
12274 : gfc_rank_cst[n],
12275 : lbound);
12276 9565 : gfc_conv_descriptor_ubound_set (&fblock, desc,
12277 : gfc_rank_cst[n],
12278 : ubound);
12279 9565 : gfc_conv_descriptor_stride_set (&fblock, desc,
12280 : gfc_rank_cst[n],
12281 : size1);
12282 9565 : lbound = gfc_conv_descriptor_lbound_get (desc,
12283 : gfc_rank_cst[n]);
12284 9565 : tmp2 = fold_build2_loc (input_location, MULT_EXPR,
12285 : gfc_array_index_type,
12286 : lbound, size1);
12287 9565 : offset = fold_build2_loc (input_location, MINUS_EXPR,
12288 : gfc_array_index_type,
12289 : offset, tmp2);
12290 9565 : size1 = fold_build2_loc (input_location, MULT_EXPR,
12291 : gfc_array_index_type,
12292 : tmp, size1);
12293 : }
12294 :
12295 : /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
12296 : the array offset is saved and the info.offset is used for a
12297 : running offset. Use the saved_offset instead. */
12298 6360 : tmp = gfc_conv_descriptor_offset (desc);
12299 6360 : gfc_add_modify (&fblock, tmp, offset);
12300 :
12301 : /* Take into account _len of unlimited polymorphic entities, so that span
12302 : for array descriptors and allocation sizes are computed correctly. */
12303 6360 : if (UNLIMITED_POLY (expr2))
12304 : {
12305 92 : tree len = gfc_class_len_get (TREE_OPERAND (desc2, 0));
12306 92 : len = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
12307 : fold_convert (size_type_node, len),
12308 : size_one_node);
12309 92 : elemsize2 = fold_build2_loc (input_location, MULT_EXPR,
12310 : gfc_array_index_type, elemsize2,
12311 : fold_convert (gfc_array_index_type, len));
12312 : }
12313 :
12314 6360 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
12315 6360 : gfc_conv_descriptor_span_set (&fblock, desc, elemsize2);
12316 :
12317 6360 : size2 = fold_build2_loc (input_location, MULT_EXPR,
12318 : gfc_array_index_type,
12319 : elemsize2, size2);
12320 6360 : size2 = fold_convert (size_type_node, size2);
12321 6360 : size2 = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
12322 : size2, size_one_node);
12323 6360 : size2 = gfc_evaluate_now (size2, &fblock);
12324 :
12325 : /* For deferred character length, the 'size' field of the dtype might
12326 : have changed so set the dtype. */
12327 6360 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
12328 6360 : && expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12329 : {
12330 663 : tree type;
12331 663 : tmp = gfc_conv_descriptor_dtype (desc);
12332 663 : if (expr2->ts.u.cl->backend_decl)
12333 663 : type = gfc_typenode_for_spec (&expr2->ts);
12334 : else
12335 0 : type = gfc_typenode_for_spec (&expr1->ts);
12336 :
12337 663 : gfc_add_modify (&fblock, tmp,
12338 : gfc_get_dtype_rank_type (expr1->rank,type));
12339 : }
12340 5697 : else if (expr1->ts.type == BT_CLASS)
12341 : {
12342 609 : tree type;
12343 609 : tmp = gfc_conv_descriptor_dtype (desc);
12344 :
12345 609 : if (expr2->ts.type != BT_CLASS)
12346 341 : type = gfc_typenode_for_spec (&expr2->ts);
12347 : else
12348 268 : type = gfc_get_character_type_len (1, elemsize2);
12349 :
12350 609 : gfc_add_modify (&fblock, tmp,
12351 : gfc_get_dtype_rank_type (expr2->rank,type));
12352 : /* Set the _len field as well... */
12353 609 : if (UNLIMITED_POLY (expr1))
12354 : {
12355 256 : tmp = gfc_class_len_get (TREE_OPERAND (desc, 0));
12356 256 : if (expr2->ts.type == BT_CHARACTER)
12357 49 : gfc_add_modify (&fblock, tmp,
12358 49 : fold_convert (TREE_TYPE (tmp),
12359 : TYPE_SIZE_UNIT (type)));
12360 207 : else if (UNLIMITED_POLY (expr2))
12361 92 : gfc_add_modify (&fblock, tmp,
12362 92 : gfc_class_len_get (TREE_OPERAND (desc2, 0)));
12363 : else
12364 115 : gfc_add_modify (&fblock, tmp,
12365 115 : build_int_cst (TREE_TYPE (tmp), 0));
12366 : }
12367 : /* ...and the vptr. */
12368 609 : tmp = gfc_class_vptr_get (TREE_OPERAND (desc, 0));
12369 609 : if (expr2->ts.type == BT_CLASS && !VAR_P (desc2)
12370 261 : && TREE_CODE (desc2) == COMPONENT_REF)
12371 : {
12372 237 : tmp2 = gfc_get_class_from_expr (desc2);
12373 237 : tmp2 = gfc_class_vptr_get (tmp2);
12374 : }
12375 372 : else if (expr2->ts.type == BT_CLASS && class_expr2 != NULL_TREE)
12376 24 : tmp2 = gfc_class_vptr_get (class_expr2);
12377 : else
12378 : {
12379 348 : tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts));
12380 348 : tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2);
12381 : }
12382 :
12383 609 : gfc_add_modify (&fblock, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
12384 : }
12385 5088 : else if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
12386 : {
12387 39 : gfc_add_modify (&fblock, gfc_conv_descriptor_dtype (desc),
12388 39 : gfc_get_dtype (TREE_TYPE (desc)));
12389 : }
12390 :
12391 : /* Realloc expression. Note that the scalarizer uses desc.data
12392 : in the array reference - (*desc.data)[<element>]. */
12393 6360 : gfc_init_block (&realloc_block);
12394 6360 : gfc_init_se (&caf_se, NULL);
12395 :
12396 6360 : if (coarray)
12397 : {
12398 39 : token = gfc_get_ultimate_alloc_ptr_comps_caf_token (&caf_se, expr1);
12399 39 : if (token == NULL_TREE)
12400 : {
12401 9 : tmp = gfc_get_tree_for_caf_expr (expr1);
12402 9 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
12403 6 : tmp = build_fold_indirect_ref (tmp);
12404 9 : gfc_get_caf_token_offset (&caf_se, &token, NULL, tmp, NULL_TREE,
12405 : expr1);
12406 9 : token = gfc_build_addr_expr (NULL_TREE, token);
12407 : }
12408 :
12409 39 : gfc_add_block_to_block (&realloc_block, &caf_se.pre);
12410 : }
12411 6360 : if ((expr1->ts.type == BT_DERIVED)
12412 320 : && expr1->ts.u.derived->attr.alloc_comp)
12413 : {
12414 121 : tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, old_desc,
12415 : expr1->rank, true);
12416 121 : gfc_add_expr_to_block (&realloc_block, tmp);
12417 : }
12418 :
12419 6360 : if (!coarray)
12420 : {
12421 6321 : tmp = build_call_expr_loc (input_location,
12422 : builtin_decl_explicit (BUILT_IN_REALLOC), 2,
12423 : fold_convert (pvoid_type_node, array1),
12424 : size2);
12425 6321 : if (flag_openmp_allocators)
12426 : {
12427 2 : tree cond, omp_tmp;
12428 2 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
12429 : gfc_conv_descriptor_version (desc),
12430 : build_int_cst (integer_type_node, 1));
12431 2 : omp_tmp = builtin_decl_explicit (BUILT_IN_GOMP_REALLOC);
12432 2 : omp_tmp = build_call_expr_loc (input_location, omp_tmp, 4,
12433 : fold_convert (pvoid_type_node, array1), size2,
12434 : build_zero_cst (ptr_type_node),
12435 : build_zero_cst (ptr_type_node));
12436 2 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond,
12437 : omp_tmp, tmp);
12438 : }
12439 :
12440 6321 : gfc_conv_descriptor_data_set (&realloc_block, desc, tmp);
12441 : }
12442 : else
12443 : {
12444 39 : tmp = build_call_expr_loc (input_location,
12445 : gfor_fndecl_caf_deregister, 5, token,
12446 : build_int_cst (integer_type_node,
12447 : GFC_CAF_COARRAY_DEALLOCATE_ONLY),
12448 : null_pointer_node, null_pointer_node,
12449 : integer_zero_node);
12450 39 : gfc_add_expr_to_block (&realloc_block, tmp);
12451 39 : tmp = build_call_expr_loc (input_location,
12452 : gfor_fndecl_caf_register,
12453 : 7, size2,
12454 : build_int_cst (integer_type_node,
12455 : GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY),
12456 : token, gfc_build_addr_expr (NULL_TREE, desc),
12457 : null_pointer_node, null_pointer_node,
12458 : integer_zero_node);
12459 39 : gfc_add_expr_to_block (&realloc_block, tmp);
12460 : }
12461 :
12462 6360 : if ((expr1->ts.type == BT_DERIVED)
12463 320 : && expr1->ts.u.derived->attr.alloc_comp)
12464 : {
12465 121 : tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc,
12466 : expr1->rank);
12467 121 : gfc_add_expr_to_block (&realloc_block, tmp);
12468 : }
12469 :
12470 6360 : gfc_add_block_to_block (&realloc_block, &caf_se.post);
12471 6360 : realloc_expr = gfc_finish_block (&realloc_block);
12472 :
12473 : /* Malloc expression. */
12474 6360 : gfc_init_block (&alloc_block);
12475 6360 : if (!coarray)
12476 : {
12477 6321 : tmp = build_call_expr_loc (input_location,
12478 : builtin_decl_explicit (BUILT_IN_MALLOC),
12479 : 1, size2);
12480 6321 : gfc_conv_descriptor_data_set (&alloc_block,
12481 : desc, tmp);
12482 : }
12483 : else
12484 : {
12485 39 : tmp = build_call_expr_loc (input_location,
12486 : gfor_fndecl_caf_register,
12487 : 7, size2,
12488 : build_int_cst (integer_type_node,
12489 : GFC_CAF_COARRAY_ALLOC),
12490 : token, gfc_build_addr_expr (NULL_TREE, desc),
12491 : null_pointer_node, null_pointer_node,
12492 : integer_zero_node);
12493 39 : gfc_add_expr_to_block (&alloc_block, tmp);
12494 : }
12495 :
12496 :
12497 : /* We already set the dtype in the case of deferred character
12498 : length arrays and class lvalues. */
12499 6360 : if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
12500 6360 : && ((expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12501 5697 : || coarray))
12502 12018 : && expr1->ts.type != BT_CLASS)
12503 : {
12504 5049 : tmp = gfc_conv_descriptor_dtype (desc);
12505 5049 : gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
12506 : }
12507 :
12508 6360 : if ((expr1->ts.type == BT_DERIVED)
12509 320 : && expr1->ts.u.derived->attr.alloc_comp)
12510 : {
12511 121 : tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc,
12512 : expr1->rank);
12513 121 : gfc_add_expr_to_block (&alloc_block, tmp);
12514 : }
12515 6360 : alloc_expr = gfc_finish_block (&alloc_block);
12516 :
12517 : /* Malloc if not allocated; realloc otherwise. */
12518 6360 : tmp = build3_v (COND_EXPR, cond_null, alloc_expr, realloc_expr);
12519 6360 : gfc_add_expr_to_block (&fblock, tmp);
12520 :
12521 : /* Add the label for same shape lhs and rhs. */
12522 6360 : tmp = build1_v (LABEL_EXPR, jump_label2);
12523 6360 : gfc_add_expr_to_block (&fblock, tmp);
12524 :
12525 6360 : tree realloc_code = gfc_finish_block (&fblock);
12526 :
12527 6360 : stmtblock_t result_block;
12528 6360 : gfc_init_block (&result_block);
12529 6360 : gfc_add_expr_to_block (&result_block, realloc_code);
12530 6360 : update_reallocated_descriptor (&result_block, loop);
12531 :
12532 6360 : return gfc_finish_block (&result_block);
12533 : }
12534 :
12535 :
12536 : /* Initialize class descriptor's TKR information. */
12537 :
12538 : void
12539 2862 : gfc_trans_class_array (gfc_symbol * sym, gfc_wrapped_block * block)
12540 : {
12541 2862 : tree type, etype;
12542 2862 : tree tmp;
12543 2862 : tree descriptor;
12544 2862 : stmtblock_t init;
12545 2862 : int rank;
12546 :
12547 : /* Make sure the frontend gets these right. */
12548 2862 : gcc_assert (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
12549 : && (CLASS_DATA (sym)->attr.class_pointer
12550 : || CLASS_DATA (sym)->attr.allocatable));
12551 :
12552 2862 : gcc_assert (VAR_P (sym->backend_decl)
12553 : || TREE_CODE (sym->backend_decl) == PARM_DECL);
12554 :
12555 2862 : if (sym->attr.dummy)
12556 1415 : return;
12557 :
12558 2862 : descriptor = gfc_class_data_get (sym->backend_decl);
12559 2862 : type = TREE_TYPE (descriptor);
12560 :
12561 2862 : if (type == NULL || !GFC_DESCRIPTOR_TYPE_P (type))
12562 : return;
12563 :
12564 1447 : location_t loc = input_location;
12565 1447 : input_location = gfc_get_location (&sym->declared_at);
12566 1447 : gfc_init_block (&init);
12567 :
12568 1447 : rank = CLASS_DATA (sym)->as ? (CLASS_DATA (sym)->as->rank) : (0);
12569 1447 : gcc_assert (rank>=0);
12570 1447 : tmp = gfc_conv_descriptor_dtype (descriptor);
12571 1447 : etype = gfc_get_element_type (type);
12572 1447 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (tmp), tmp,
12573 : gfc_get_dtype_rank_type (rank, etype));
12574 1447 : gfc_add_expr_to_block (&init, tmp);
12575 :
12576 1447 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
12577 1447 : input_location = loc;
12578 : }
12579 :
12580 :
12581 : /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
12582 : Do likewise, recursively if necessary, with the allocatable components of
12583 : derived types. This function is also called for assumed-rank arrays, which
12584 : are always dummy arguments. */
12585 :
12586 : void
12587 17601 : gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
12588 : {
12589 17601 : tree type;
12590 17601 : tree tmp;
12591 17601 : tree descriptor;
12592 17601 : stmtblock_t init;
12593 17601 : stmtblock_t cleanup;
12594 17601 : int rank;
12595 17601 : bool sym_has_alloc_comp, has_finalizer;
12596 :
12597 35202 : sym_has_alloc_comp = (sym->ts.type == BT_DERIVED
12598 10865 : || sym->ts.type == BT_CLASS)
12599 17601 : && sym->ts.u.derived->attr.alloc_comp;
12600 17601 : has_finalizer = gfc_may_be_finalized (sym->ts);
12601 :
12602 : /* Make sure the frontend gets these right. */
12603 17601 : gcc_assert (sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp
12604 : || has_finalizer
12605 : || (sym->as->type == AS_ASSUMED_RANK && sym->attr.dummy));
12606 :
12607 17601 : location_t loc = input_location;
12608 17601 : input_location = gfc_get_location (&sym->declared_at);
12609 17601 : gfc_init_block (&init);
12610 :
12611 17601 : gcc_assert (VAR_P (sym->backend_decl)
12612 : || TREE_CODE (sym->backend_decl) == PARM_DECL);
12613 :
12614 17601 : if (sym->ts.type == BT_CHARACTER
12615 1390 : && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
12616 : {
12617 812 : if (sym->ts.deferred && !sym->ts.u.cl->length && !sym->attr.dummy)
12618 : {
12619 607 : tree len_expr = sym->ts.u.cl->backend_decl;
12620 607 : tree init_val = build_zero_cst (TREE_TYPE (len_expr));
12621 607 : if (VAR_P (len_expr)
12622 607 : && sym->attr.save
12623 662 : && !DECL_INITIAL (len_expr))
12624 55 : DECL_INITIAL (len_expr) = init_val;
12625 : else
12626 552 : gfc_add_modify (&init, len_expr, init_val);
12627 : }
12628 812 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
12629 812 : gfc_trans_vla_type_sizes (sym, &init);
12630 :
12631 : /* Presence check of optional deferred-length character dummy. */
12632 812 : if (sym->ts.deferred && sym->attr.dummy && sym->attr.optional)
12633 : {
12634 43 : tmp = gfc_finish_block (&init);
12635 43 : tmp = build3_v (COND_EXPR, gfc_conv_expr_present (sym),
12636 : tmp, build_empty_stmt (input_location));
12637 43 : gfc_add_expr_to_block (&init, tmp);
12638 : }
12639 : }
12640 :
12641 : /* Dummy, use associated and result variables don't need anything special. */
12642 17601 : if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result)
12643 : {
12644 821 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
12645 821 : input_location = loc;
12646 1100 : return;
12647 : }
12648 :
12649 16780 : descriptor = sym->backend_decl;
12650 :
12651 : /* Although static, derived types with default initializers and
12652 : allocatable components must not be nulled wholesale; instead they
12653 : are treated component by component. */
12654 16780 : if (TREE_STATIC (descriptor) && !sym_has_alloc_comp && !has_finalizer)
12655 : {
12656 : /* SAVEd variables are not freed on exit. */
12657 279 : gfc_trans_static_array_pointer (sym);
12658 :
12659 279 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
12660 279 : input_location = loc;
12661 279 : return;
12662 : }
12663 :
12664 : /* Get the descriptor type. */
12665 16501 : type = TREE_TYPE (sym->backend_decl);
12666 :
12667 16501 : if ((sym_has_alloc_comp || (has_finalizer && sym->ts.type != BT_CLASS))
12668 5229 : && !(sym->attr.pointer || sym->attr.allocatable))
12669 : {
12670 2799 : if (!sym->attr.save
12671 2414 : && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program))
12672 : {
12673 2414 : if (sym->value == NULL
12674 2414 : || !gfc_has_default_initializer (sym->ts.u.derived))
12675 : {
12676 1995 : rank = sym->as ? sym->as->rank : 0;
12677 1995 : tmp = gfc_nullify_alloc_comp (sym->ts.u.derived,
12678 : descriptor, rank);
12679 1995 : gfc_add_expr_to_block (&init, tmp);
12680 : }
12681 : else
12682 419 : gfc_init_default_dt (sym, &init, false);
12683 : }
12684 : }
12685 13702 : else if (!GFC_DESCRIPTOR_TYPE_P (type))
12686 : {
12687 : /* If the backend_decl is not a descriptor, we must have a pointer
12688 : to one. */
12689 1928 : descriptor = build_fold_indirect_ref_loc (input_location,
12690 : sym->backend_decl);
12691 1928 : type = TREE_TYPE (descriptor);
12692 : }
12693 :
12694 : /* NULLIFY the data pointer for non-saved allocatables, or for non-saved
12695 : pointers when -fcheck=pointer is specified. */
12696 28275 : if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save
12697 28262 : && (sym->attr.allocatable
12698 3273 : || (sym->attr.pointer && (gfc_option.rtcheck & GFC_RTCHECK_POINTER))))
12699 : {
12700 8531 : gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node);
12701 8531 : if (flag_coarray == GFC_FCOARRAY_LIB && sym->attr.codimension)
12702 : {
12703 : /* Declare the variable static so its array descriptor stays present
12704 : after leaving the scope. It may still be accessed through another
12705 : image. This may happen, for example, with the caf_mpi
12706 : implementation. */
12707 158 : TREE_STATIC (descriptor) = 1;
12708 158 : tmp = gfc_conv_descriptor_token (descriptor);
12709 158 : gfc_add_modify (&init, tmp, fold_convert (TREE_TYPE (tmp),
12710 : null_pointer_node));
12711 : }
12712 : }
12713 :
12714 : /* Set initial TKR for pointers and allocatables */
12715 16501 : if (GFC_DESCRIPTOR_TYPE_P (type)
12716 16501 : && (sym->attr.pointer || sym->attr.allocatable))
12717 : {
12718 11774 : tree etype;
12719 :
12720 11774 : gcc_assert (sym->as && sym->as->rank>=0);
12721 11774 : tmp = gfc_conv_descriptor_dtype (descriptor);
12722 11774 : etype = gfc_get_element_type (type);
12723 11774 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
12724 11774 : TREE_TYPE (tmp), tmp,
12725 11774 : gfc_get_dtype_rank_type (sym->as->rank, etype));
12726 11774 : gfc_add_expr_to_block (&init, tmp);
12727 : }
12728 16501 : input_location = loc;
12729 16501 : gfc_init_block (&cleanup);
12730 :
12731 : /* Allocatable arrays need to be freed when they go out of scope.
12732 : The allocatable components of pointers must not be touched. */
12733 16501 : if (!sym->attr.allocatable && has_finalizer && sym->ts.type != BT_CLASS
12734 574 : && !sym->attr.pointer && !sym->attr.artificial && !sym->attr.save
12735 303 : && !sym->ns->proc_name->attr.is_main_program)
12736 : {
12737 264 : gfc_expr *e;
12738 264 : sym->attr.referenced = 1;
12739 264 : e = gfc_lval_expr_from_sym (sym);
12740 264 : gfc_add_finalizer_call (&cleanup, e);
12741 264 : gfc_free_expr (e);
12742 264 : }
12743 16237 : else if ((!sym->attr.allocatable || !has_finalizer)
12744 16113 : && sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
12745 4690 : && !sym->attr.pointer && !sym->attr.save
12746 2351 : && !(sym->attr.artificial && sym->name[0] == '_')
12747 2296 : && !sym->ns->proc_name->attr.is_main_program)
12748 : {
12749 643 : int rank;
12750 643 : rank = sym->as ? sym->as->rank : 0;
12751 643 : tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank,
12752 643 : (sym->attr.codimension
12753 3 : && flag_coarray == GFC_FCOARRAY_LIB)
12754 : ? GFC_STRUCTURE_CAF_MODE_IN_COARRAY
12755 : : 0);
12756 643 : gfc_add_expr_to_block (&cleanup, tmp);
12757 : }
12758 :
12759 16501 : if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension)
12760 8495 : && !sym->attr.save && !sym->attr.result
12761 8488 : && !sym->ns->proc_name->attr.is_main_program)
12762 : {
12763 4481 : gfc_expr *e;
12764 4481 : e = has_finalizer ? gfc_lval_expr_from_sym (sym) : NULL;
12765 8962 : tmp = gfc_deallocate_with_status (sym->backend_decl, NULL_TREE, NULL_TREE,
12766 : NULL_TREE, NULL_TREE, true, e,
12767 4481 : sym->attr.codimension
12768 : ? GFC_CAF_COARRAY_DEREGISTER
12769 : : GFC_CAF_COARRAY_NOCOARRAY,
12770 : NULL_TREE, gfc_finish_block (&cleanup));
12771 4481 : if (e)
12772 45 : gfc_free_expr (e);
12773 4481 : gfc_init_block (&cleanup);
12774 4481 : gfc_add_expr_to_block (&cleanup, tmp);
12775 : }
12776 :
12777 16501 : gfc_add_init_cleanup (block, gfc_finish_block (&init),
12778 : gfc_finish_block (&cleanup));
12779 : }
12780 :
12781 : /************ Expression Walking Functions ******************/
12782 :
12783 : /* Walk a variable reference.
12784 :
12785 : Possible extension - multiple component subscripts.
12786 : x(:,:) = foo%a(:)%b(:)
12787 : Transforms to
12788 : forall (i=..., j=...)
12789 : x(i,j) = foo%a(j)%b(i)
12790 : end forall
12791 : This adds a fair amount of complexity because you need to deal with more
12792 : than one ref. Maybe handle in a similar manner to vector subscripts.
12793 : Maybe not worth the effort. */
12794 :
12795 :
12796 : static gfc_ss *
12797 675773 : gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
12798 : {
12799 675773 : gfc_ref *ref;
12800 :
12801 675773 : gfc_fix_class_refs (expr);
12802 :
12803 788873 : for (ref = expr->ref; ref; ref = ref->next)
12804 436379 : if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
12805 : break;
12806 :
12807 675773 : return gfc_walk_array_ref (ss, expr, ref);
12808 : }
12809 :
12810 : gfc_ss *
12811 676130 : gfc_walk_array_ref (gfc_ss *ss, gfc_expr *expr, gfc_ref *ref, bool array_only)
12812 : {
12813 676130 : gfc_array_ref *ar;
12814 676130 : gfc_ss *newss;
12815 676130 : int n;
12816 :
12817 1007969 : for (; ref; ref = ref->next)
12818 : {
12819 331839 : if (ref->type == REF_SUBSTRING)
12820 : {
12821 1314 : ss = gfc_get_scalar_ss (ss, ref->u.ss.start);
12822 1314 : if (ref->u.ss.end)
12823 1288 : ss = gfc_get_scalar_ss (ss, ref->u.ss.end);
12824 : }
12825 :
12826 : /* We're only interested in array sections from now on. */
12827 331839 : if (ref->type != REF_ARRAY
12828 324046 : || (array_only && ref->u.ar.as && ref->u.ar.as->rank == 0))
12829 7904 : continue;
12830 :
12831 323935 : ar = &ref->u.ar;
12832 :
12833 323935 : switch (ar->type)
12834 : {
12835 326 : case AR_ELEMENT:
12836 699 : for (n = ar->dimen - 1; n >= 0; n--)
12837 373 : ss = gfc_get_scalar_ss (ss, ar->start[n]);
12838 : break;
12839 :
12840 268121 : case AR_FULL:
12841 : /* Assumed shape arrays from interface mapping need this fix. */
12842 268121 : if (!ar->as && expr->symtree->n.sym->as)
12843 : {
12844 6 : ar->as = gfc_get_array_spec();
12845 6 : *ar->as = *expr->symtree->n.sym->as;
12846 : }
12847 268121 : newss = gfc_get_array_ss (ss, expr, ar->as->rank, GFC_SS_SECTION);
12848 268121 : newss->info->data.array.ref = ref;
12849 :
12850 : /* Make sure array is the same as array(:,:), this way
12851 : we don't need to special case all the time. */
12852 268121 : ar->dimen = ar->as->rank;
12853 620286 : for (n = 0; n < ar->dimen; n++)
12854 : {
12855 352165 : ar->dimen_type[n] = DIMEN_RANGE;
12856 :
12857 352165 : gcc_assert (ar->start[n] == NULL);
12858 352165 : gcc_assert (ar->end[n] == NULL);
12859 352165 : gcc_assert (ar->stride[n] == NULL);
12860 : }
12861 : ss = newss;
12862 : break;
12863 :
12864 55488 : case AR_SECTION:
12865 55488 : newss = gfc_get_array_ss (ss, expr, 0, GFC_SS_SECTION);
12866 55488 : newss->info->data.array.ref = ref;
12867 :
12868 : /* We add SS chains for all the subscripts in the section. */
12869 143105 : for (n = 0; n < ar->dimen; n++)
12870 : {
12871 87617 : gfc_ss *indexss;
12872 :
12873 87617 : switch (ar->dimen_type[n])
12874 : {
12875 6633 : case DIMEN_ELEMENT:
12876 : /* Add SS for elemental (scalar) subscripts. */
12877 6633 : gcc_assert (ar->start[n]);
12878 6633 : indexss = gfc_get_scalar_ss (gfc_ss_terminator, ar->start[n]);
12879 6633 : indexss->loop_chain = gfc_ss_terminator;
12880 6633 : newss->info->data.array.subscript[n] = indexss;
12881 6633 : break;
12882 :
12883 80172 : case DIMEN_RANGE:
12884 : /* We don't add anything for sections, just remember this
12885 : dimension for later. */
12886 80172 : newss->dim[newss->dimen] = n;
12887 80172 : newss->dimen++;
12888 80172 : break;
12889 :
12890 812 : case DIMEN_VECTOR:
12891 : /* Create a GFC_SS_VECTOR index in which we can store
12892 : the vector's descriptor. */
12893 812 : indexss = gfc_get_array_ss (gfc_ss_terminator, ar->start[n],
12894 : 1, GFC_SS_VECTOR);
12895 812 : indexss->loop_chain = gfc_ss_terminator;
12896 812 : newss->info->data.array.subscript[n] = indexss;
12897 812 : newss->dim[newss->dimen] = n;
12898 812 : newss->dimen++;
12899 812 : break;
12900 :
12901 0 : default:
12902 : /* We should know what sort of section it is by now. */
12903 0 : gcc_unreachable ();
12904 : }
12905 : }
12906 : /* We should have at least one non-elemental dimension,
12907 : unless we are creating a descriptor for a (scalar) coarray. */
12908 55488 : gcc_assert (newss->dimen > 0
12909 : || newss->info->data.array.ref->u.ar.as->corank > 0);
12910 : ss = newss;
12911 : break;
12912 :
12913 0 : default:
12914 : /* We should know what sort of section it is by now. */
12915 0 : gcc_unreachable ();
12916 : }
12917 :
12918 : }
12919 676130 : return ss;
12920 : }
12921 :
12922 :
12923 : /* Walk an expression operator. If only one operand of a binary expression is
12924 : scalar, we must also add the scalar term to the SS chain. */
12925 :
12926 : static gfc_ss *
12927 56563 : gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
12928 : {
12929 56563 : gfc_ss *head;
12930 56563 : gfc_ss *head2;
12931 :
12932 56563 : head = gfc_walk_subexpr (ss, expr->value.op.op1);
12933 56563 : if (expr->value.op.op2 == NULL)
12934 : head2 = head;
12935 : else
12936 54019 : head2 = gfc_walk_subexpr (head, expr->value.op.op2);
12937 :
12938 : /* All operands are scalar. Pass back and let the caller deal with it. */
12939 56563 : if (head2 == ss)
12940 : return head2;
12941 :
12942 : /* All operands require scalarization. */
12943 50875 : if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
12944 : return head2;
12945 :
12946 : /* One of the operands needs scalarization, the other is scalar.
12947 : Create a gfc_ss for the scalar expression. */
12948 18921 : if (head == ss)
12949 : {
12950 : /* First operand is scalar. We build the chain in reverse order, so
12951 : add the scalar SS after the second operand. */
12952 : head = head2;
12953 2182 : while (head && head->next != ss)
12954 : head = head->next;
12955 : /* Check we haven't somehow broken the chain. */
12956 1939 : gcc_assert (head);
12957 1939 : head->next = gfc_get_scalar_ss (ss, expr->value.op.op1);
12958 : }
12959 : else /* head2 == head */
12960 : {
12961 16982 : gcc_assert (head2 == head);
12962 : /* Second operand is scalar. */
12963 16982 : head2 = gfc_get_scalar_ss (head2, expr->value.op.op2);
12964 : }
12965 :
12966 : return head2;
12967 : }
12968 :
12969 : static gfc_ss *
12970 36 : gfc_walk_conditional_expr (gfc_ss *ss, gfc_expr *expr)
12971 : {
12972 36 : gfc_ss *head;
12973 :
12974 36 : head = gfc_walk_subexpr (ss, expr->value.conditional.true_expr);
12975 36 : head = gfc_walk_subexpr (head, expr->value.conditional.false_expr);
12976 36 : return head;
12977 : }
12978 :
12979 : /* Reverse a SS chain. */
12980 :
12981 : gfc_ss *
12982 849936 : gfc_reverse_ss (gfc_ss * ss)
12983 : {
12984 849936 : gfc_ss *next;
12985 849936 : gfc_ss *head;
12986 :
12987 849936 : gcc_assert (ss != NULL);
12988 :
12989 : head = gfc_ss_terminator;
12990 1280791 : while (ss != gfc_ss_terminator)
12991 : {
12992 430855 : next = ss->next;
12993 : /* Check we didn't somehow break the chain. */
12994 430855 : gcc_assert (next != NULL);
12995 430855 : ss->next = head;
12996 430855 : head = ss;
12997 430855 : ss = next;
12998 : }
12999 :
13000 849936 : return (head);
13001 : }
13002 :
13003 :
13004 : /* Given an expression referring to a procedure, return the symbol of its
13005 : interface. We can't get the procedure symbol directly as we have to handle
13006 : the case of (deferred) type-bound procedures. */
13007 :
13008 : gfc_symbol *
13009 161 : gfc_get_proc_ifc_for_expr (gfc_expr *procedure_ref)
13010 : {
13011 161 : gfc_symbol *sym;
13012 161 : gfc_ref *ref;
13013 :
13014 161 : if (procedure_ref == NULL)
13015 : return NULL;
13016 :
13017 : /* Normal procedure case. */
13018 161 : if (procedure_ref->expr_type == EXPR_FUNCTION
13019 161 : && procedure_ref->value.function.esym)
13020 : sym = procedure_ref->value.function.esym;
13021 : else
13022 24 : sym = procedure_ref->symtree->n.sym;
13023 :
13024 : /* Typebound procedure case. */
13025 209 : for (ref = procedure_ref->ref; ref; ref = ref->next)
13026 : {
13027 48 : if (ref->type == REF_COMPONENT
13028 48 : && ref->u.c.component->attr.proc_pointer)
13029 24 : sym = ref->u.c.component->ts.interface;
13030 : else
13031 : sym = NULL;
13032 : }
13033 :
13034 : return sym;
13035 : }
13036 :
13037 :
13038 : /* Given an expression referring to an intrinsic function call,
13039 : return the intrinsic symbol. */
13040 :
13041 : gfc_intrinsic_sym *
13042 7814 : gfc_get_intrinsic_for_expr (gfc_expr *call)
13043 : {
13044 7814 : if (call == NULL)
13045 : return NULL;
13046 :
13047 : /* Normal procedure case. */
13048 2348 : if (call->expr_type == EXPR_FUNCTION)
13049 2242 : return call->value.function.isym;
13050 : else
13051 : return NULL;
13052 : }
13053 :
13054 :
13055 : /* Indicates whether an argument to an intrinsic function should be used in
13056 : scalarization. It is usually the case, except for some intrinsics
13057 : requiring the value to be constant, and using the value at compile time only.
13058 : As the value is not used at runtime in those cases, we don’t produce code
13059 : for it, and it should not be visible to the scalarizer.
13060 : FUNCTION is the intrinsic function being called, ACTUAL_ARG is the actual
13061 : argument being examined in that call, and ARG_NUM the index number
13062 : of ACTUAL_ARG in the list of arguments.
13063 : The intrinsic procedure’s dummy argument associated with ACTUAL_ARG is
13064 : identified using the name in ACTUAL_ARG if it is present (that is: if it’s
13065 : a keyword argument), otherwise using ARG_NUM. */
13066 :
13067 : static bool
13068 37346 : arg_evaluated_for_scalarization (gfc_intrinsic_sym *function,
13069 : gfc_dummy_arg *dummy_arg)
13070 : {
13071 37346 : if (function != NULL && dummy_arg != NULL)
13072 : {
13073 12419 : switch (function->id)
13074 : {
13075 241 : case GFC_ISYM_INDEX:
13076 241 : case GFC_ISYM_LEN_TRIM:
13077 241 : case GFC_ISYM_MASKL:
13078 241 : case GFC_ISYM_MASKR:
13079 241 : case GFC_ISYM_SCAN:
13080 241 : case GFC_ISYM_VERIFY:
13081 241 : if (strcmp ("kind", gfc_dummy_arg_get_name (*dummy_arg)) == 0)
13082 : return false;
13083 : /* Fallthrough. */
13084 :
13085 : default:
13086 : break;
13087 : }
13088 : }
13089 :
13090 : return true;
13091 : }
13092 :
13093 :
13094 : /* Walk the arguments of an elemental function.
13095 : PROC_EXPR is used to check whether an argument is permitted to be absent. If
13096 : it is NULL, we don't do the check and the argument is assumed to be present.
13097 : */
13098 :
13099 : gfc_ss *
13100 26549 : gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
13101 : gfc_intrinsic_sym *intrinsic_sym,
13102 : gfc_ss_type type)
13103 : {
13104 26549 : int scalar;
13105 26549 : gfc_ss *head;
13106 26549 : gfc_ss *tail;
13107 26549 : gfc_ss *newss;
13108 :
13109 26549 : head = gfc_ss_terminator;
13110 26549 : tail = NULL;
13111 :
13112 26549 : scalar = 1;
13113 65359 : for (; arg; arg = arg->next)
13114 : {
13115 38810 : gfc_dummy_arg * const dummy_arg = arg->associated_dummy;
13116 40307 : if (!arg->expr
13117 37496 : || arg->expr->expr_type == EXPR_NULL
13118 76156 : || !arg_evaluated_for_scalarization (intrinsic_sym, dummy_arg))
13119 1497 : continue;
13120 :
13121 37313 : newss = gfc_walk_subexpr (head, arg->expr);
13122 37313 : if (newss == head)
13123 : {
13124 : /* Scalar argument. */
13125 18472 : gcc_assert (type == GFC_SS_SCALAR || type == GFC_SS_REFERENCE);
13126 18472 : newss = gfc_get_scalar_ss (head, arg->expr);
13127 18472 : newss->info->type = type;
13128 18472 : if (dummy_arg)
13129 15463 : newss->info->data.scalar.dummy_arg = dummy_arg;
13130 : }
13131 : else
13132 : scalar = 0;
13133 :
13134 34304 : if (dummy_arg != NULL
13135 25916 : && gfc_dummy_arg_is_optional (*dummy_arg)
13136 2538 : && arg->expr->expr_type == EXPR_VARIABLE
13137 36008 : && (gfc_expr_attr (arg->expr).optional
13138 1223 : || gfc_expr_attr (arg->expr).allocatable
13139 37260 : || gfc_expr_attr (arg->expr).pointer))
13140 1005 : newss->info->can_be_null_ref = true;
13141 :
13142 37313 : head = newss;
13143 37313 : if (!tail)
13144 : {
13145 : tail = head;
13146 33183 : while (tail->next != gfc_ss_terminator)
13147 : tail = tail->next;
13148 : }
13149 : }
13150 :
13151 26549 : if (scalar)
13152 : {
13153 : /* If all the arguments are scalar we don't need the argument SS. */
13154 10252 : gfc_free_ss_chain (head);
13155 : /* Pass it back. */
13156 10252 : return ss;
13157 : }
13158 :
13159 : /* Add it onto the existing chain. */
13160 16297 : tail->next = ss;
13161 16297 : return head;
13162 : }
13163 :
13164 :
13165 : /* Walk a function call. Scalar functions are passed back, and taken out of
13166 : scalarization loops. For elemental functions we walk their arguments.
13167 : The result of functions returning arrays is stored in a temporary outside
13168 : the loop, so that the function is only called once. Hence we do not need
13169 : to walk their arguments. */
13170 :
13171 : static gfc_ss *
13172 62879 : gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
13173 : {
13174 62879 : gfc_intrinsic_sym *isym;
13175 62879 : gfc_symbol *sym;
13176 62879 : gfc_component *comp = NULL;
13177 :
13178 62879 : isym = expr->value.function.isym;
13179 :
13180 : /* Handle intrinsic functions separately. */
13181 62879 : if (isym)
13182 55219 : return gfc_walk_intrinsic_function (ss, expr, isym);
13183 :
13184 7660 : sym = expr->value.function.esym;
13185 7660 : if (!sym)
13186 546 : sym = expr->symtree->n.sym;
13187 :
13188 7660 : if (gfc_is_class_array_function (expr))
13189 234 : return gfc_get_array_ss (ss, expr,
13190 234 : CLASS_DATA (expr->value.function.esym->result)->as->rank,
13191 234 : GFC_SS_FUNCTION);
13192 :
13193 : /* A function that returns arrays. */
13194 7426 : comp = gfc_get_proc_ptr_comp (expr);
13195 7028 : if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
13196 7426 : || (comp && comp->attr.dimension))
13197 2632 : return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
13198 :
13199 : /* Walk the parameters of an elemental function. For now we always pass
13200 : by reference. */
13201 4794 : if (sym->attr.elemental || (comp && comp->attr.elemental))
13202 : {
13203 2206 : gfc_ss *old_ss = ss;
13204 :
13205 2206 : ss = gfc_walk_elemental_function_args (old_ss,
13206 : expr->value.function.actual,
13207 : gfc_get_intrinsic_for_expr (expr),
13208 : GFC_SS_REFERENCE);
13209 2206 : if (ss != old_ss
13210 1170 : && (comp
13211 1109 : || sym->attr.proc_pointer
13212 1109 : || sym->attr.if_source != IFSRC_DECL
13213 993 : || sym->attr.array_outer_dependency))
13214 225 : ss->info->array_outer_dependency = 1;
13215 : }
13216 :
13217 : /* Scalar functions are OK as these are evaluated outside the scalarization
13218 : loop. Pass back and let the caller deal with it. */
13219 : return ss;
13220 : }
13221 :
13222 :
13223 : /* An array temporary is constructed for array constructors. */
13224 :
13225 : static gfc_ss *
13226 49501 : gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
13227 : {
13228 0 : return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_CONSTRUCTOR);
13229 : }
13230 :
13231 :
13232 : /* Walk an expression. Add walked expressions to the head of the SS chain.
13233 : A wholly scalar expression will not be added. */
13234 :
13235 : gfc_ss *
13236 1002227 : gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
13237 : {
13238 1002227 : gfc_ss *head;
13239 :
13240 1002227 : switch (expr->expr_type)
13241 : {
13242 675773 : case EXPR_VARIABLE:
13243 675773 : head = gfc_walk_variable_expr (ss, expr);
13244 675773 : return head;
13245 :
13246 56563 : case EXPR_OP:
13247 56563 : head = gfc_walk_op_expr (ss, expr);
13248 56563 : return head;
13249 :
13250 36 : case EXPR_CONDITIONAL:
13251 36 : head = gfc_walk_conditional_expr (ss, expr);
13252 36 : return head;
13253 :
13254 62879 : case EXPR_FUNCTION:
13255 62879 : head = gfc_walk_function_expr (ss, expr);
13256 62879 : return head;
13257 :
13258 : case EXPR_CONSTANT:
13259 : case EXPR_NULL:
13260 : case EXPR_STRUCTURE:
13261 : /* Pass back and let the caller deal with it. */
13262 : break;
13263 :
13264 49501 : case EXPR_ARRAY:
13265 49501 : head = gfc_walk_array_constructor (ss, expr);
13266 49501 : return head;
13267 :
13268 : case EXPR_SUBSTRING:
13269 : /* Pass back and let the caller deal with it. */
13270 : break;
13271 :
13272 0 : default:
13273 0 : gfc_internal_error ("bad expression type during walk (%d)",
13274 : expr->expr_type);
13275 : }
13276 : return ss;
13277 : }
13278 :
13279 :
13280 : /* Entry point for expression walking.
13281 : A return value equal to the passed chain means this is
13282 : a scalar expression. It is up to the caller to take whatever action is
13283 : necessary to translate these. */
13284 :
13285 : gfc_ss *
13286 847345 : gfc_walk_expr (gfc_expr * expr)
13287 : {
13288 847345 : gfc_ss *res;
13289 :
13290 847345 : res = gfc_walk_subexpr (gfc_ss_terminator, expr);
13291 847345 : return gfc_reverse_ss (res);
13292 : }
|
