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 59047 : gfc_array_dataptr_type (tree desc)
107 : {
108 59047 : 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 2018555 : gfc_get_descriptor_field (tree desc, unsigned field_idx)
248 : {
249 2018555 : tree type = TREE_TYPE (desc);
250 2018555 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
251 :
252 2018555 : tree field = gfc_advance_chain (TYPE_FIELDS (type), field_idx);
253 2018555 : gcc_assert (field != NULL_TREE);
254 :
255 2018555 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
256 2018555 : 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 283794 : gfc_conv_descriptor_data_get (tree desc)
264 : {
265 283794 : tree type = TREE_TYPE (desc);
266 283794 : if (TREE_CODE (type) == REFERENCE_TYPE)
267 0 : gcc_unreachable ();
268 :
269 283794 : tree field = gfc_get_descriptor_field (desc, DATA_FIELD);
270 283794 : 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 157976 : gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
277 : {
278 157976 : tree field = gfc_get_descriptor_field (desc, DATA_FIELD);
279 157976 : gfc_add_modify (block, field, fold_convert (TREE_TYPE (field), value));
280 157976 : }
281 :
282 :
283 : static tree
284 207982 : gfc_conv_descriptor_offset (tree desc)
285 : {
286 207982 : tree field = gfc_get_descriptor_field (desc, OFFSET_FIELD);
287 207982 : gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
288 207982 : return field;
289 : }
290 :
291 : tree
292 77346 : gfc_conv_descriptor_offset_get (tree desc)
293 : {
294 77346 : return gfc_conv_descriptor_offset (desc);
295 : }
296 :
297 : void
298 124113 : gfc_conv_descriptor_offset_set (stmtblock_t *block, tree desc,
299 : tree value)
300 : {
301 124113 : tree t = gfc_conv_descriptor_offset (desc);
302 124113 : gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
303 124113 : }
304 :
305 :
306 : tree
307 174018 : gfc_conv_descriptor_dtype (tree desc)
308 : {
309 174018 : tree field = gfc_get_descriptor_field (desc, DTYPE_FIELD);
310 174018 : gcc_assert (TREE_TYPE (field) == get_dtype_type_node ());
311 174018 : return field;
312 : }
313 :
314 : static tree
315 153965 : gfc_conv_descriptor_span (tree desc)
316 : {
317 153965 : tree field = gfc_get_descriptor_field (desc, SPAN_FIELD);
318 153965 : gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
319 153965 : return field;
320 : }
321 :
322 : tree
323 33774 : gfc_conv_descriptor_span_get (tree desc)
324 : {
325 33774 : return gfc_conv_descriptor_span (desc);
326 : }
327 :
328 : void
329 120191 : gfc_conv_descriptor_span_set (stmtblock_t *block, tree desc,
330 : tree value)
331 : {
332 120191 : tree t = gfc_conv_descriptor_span (desc);
333 120191 : gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
334 120191 : }
335 :
336 :
337 : tree
338 21309 : gfc_conv_descriptor_rank (tree desc)
339 : {
340 21309 : tree tmp;
341 21309 : tree dtype;
342 :
343 21309 : dtype = gfc_conv_descriptor_dtype (desc);
344 21309 : tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), GFC_DTYPE_RANK);
345 21309 : gcc_assert (tmp != NULL_TREE
346 : && TREE_TYPE (tmp) == signed_char_type_node);
347 21309 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
348 21309 : 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 9246 : gfc_conv_descriptor_elem_len (tree desc)
371 : {
372 9246 : tree tmp;
373 9246 : tree dtype;
374 :
375 9246 : dtype = gfc_conv_descriptor_dtype (desc);
376 9246 : tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)),
377 : GFC_DTYPE_ELEM_LEN);
378 9246 : gcc_assert (tmp != NULL_TREE
379 : && TREE_TYPE (tmp) == size_type_node);
380 9246 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
381 9246 : 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 1038568 : gfc_get_descriptor_dimension (tree desc)
416 : {
417 1038568 : tree field = gfc_get_descriptor_field (desc, DIMENSION_FIELD);
418 1038568 : gcc_assert (TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
419 : && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
420 1038568 : return field;
421 : }
422 :
423 :
424 : static tree
425 1034518 : gfc_conv_descriptor_dimension (tree desc, tree dim)
426 : {
427 1034518 : tree tmp;
428 :
429 1034518 : tmp = gfc_get_descriptor_dimension (desc);
430 :
431 1034518 : return gfc_build_array_ref (tmp, dim, NULL_TREE, true);
432 : }
433 :
434 :
435 : tree
436 2252 : gfc_conv_descriptor_token (tree desc)
437 : {
438 2252 : gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
439 2252 : tree field = gfc_get_descriptor_field (desc, CAF_TOKEN_FIELD);
440 : /* Should be a restricted pointer - except in the finalization wrapper. */
441 2252 : gcc_assert (TREE_TYPE (field) == prvoid_type_node
442 : || TREE_TYPE (field) == pvoid_type_node);
443 2252 : return field;
444 : }
445 :
446 : static tree
447 1034518 : gfc_conv_descriptor_subfield (tree desc, tree dim, unsigned field_idx)
448 : {
449 1034518 : tree tmp = gfc_conv_descriptor_dimension (desc, dim);
450 1034518 : tree field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), field_idx);
451 1034518 : gcc_assert (field != NULL_TREE);
452 :
453 1034518 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
454 1034518 : tmp, field, NULL_TREE);
455 : }
456 :
457 : static tree
458 276260 : gfc_conv_descriptor_stride (tree desc, tree dim)
459 : {
460 276260 : tree field = gfc_conv_descriptor_subfield (desc, dim, STRIDE_SUBFIELD);
461 276260 : gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
462 276260 : return field;
463 : }
464 :
465 : tree
466 169977 : gfc_conv_descriptor_stride_get (tree desc, tree dim)
467 : {
468 169977 : tree type = TREE_TYPE (desc);
469 169977 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
470 169977 : if (integer_zerop (dim)
471 169977 : && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
472 43500 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT
473 42431 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT
474 42275 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_ALLOCATABLE
475 42125 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_POINTER_CONT
476 42125 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
477 71883 : return gfc_index_one_node;
478 :
479 98094 : return gfc_conv_descriptor_stride (desc, dim);
480 : }
481 :
482 : void
483 178166 : gfc_conv_descriptor_stride_set (stmtblock_t *block, tree desc,
484 : tree dim, tree value)
485 : {
486 178166 : tree t = gfc_conv_descriptor_stride (desc, dim);
487 178166 : gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
488 178166 : }
489 :
490 : static tree
491 393724 : gfc_conv_descriptor_lbound (tree desc, tree dim)
492 : {
493 393724 : tree field = gfc_conv_descriptor_subfield (desc, dim, LBOUND_SUBFIELD);
494 393724 : gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
495 393724 : return field;
496 : }
497 :
498 : tree
499 210802 : gfc_conv_descriptor_lbound_get (tree desc, tree dim)
500 : {
501 210802 : return gfc_conv_descriptor_lbound (desc, dim);
502 : }
503 :
504 : void
505 182922 : gfc_conv_descriptor_lbound_set (stmtblock_t *block, tree desc,
506 : tree dim, tree value)
507 : {
508 182922 : tree t = gfc_conv_descriptor_lbound (desc, dim);
509 182922 : gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
510 182922 : }
511 :
512 : static tree
513 364534 : gfc_conv_descriptor_ubound (tree desc, tree dim)
514 : {
515 364534 : tree field = gfc_conv_descriptor_subfield (desc, dim, UBOUND_SUBFIELD);
516 364534 : gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
517 364534 : return field;
518 : }
519 :
520 : tree
521 181866 : gfc_conv_descriptor_ubound_get (tree desc, tree dim)
522 : {
523 181866 : return gfc_conv_descriptor_ubound (desc, dim);
524 : }
525 :
526 : void
527 182668 : gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree desc,
528 : tree dim, tree value)
529 : {
530 182668 : tree t = gfc_conv_descriptor_ubound (desc, dim);
531 182668 : gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
532 182668 : }
533 :
534 : /* Build a null array descriptor constructor. */
535 :
536 : tree
537 1085 : gfc_build_null_descriptor (tree type)
538 : {
539 1085 : tree field;
540 1085 : tree tmp;
541 :
542 1085 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
543 1085 : gcc_assert (DATA_FIELD == 0);
544 1085 : field = TYPE_FIELDS (type);
545 :
546 : /* Set a NULL data pointer. */
547 1085 : tmp = build_constructor_single (type, field, null_pointer_node);
548 1085 : TREE_CONSTANT (tmp) = 1;
549 : /* All other fields are ignored. */
550 :
551 1085 : return tmp;
552 : }
553 :
554 :
555 : /* Modify a descriptor such that the lbound of a given dimension is the value
556 : specified. This also updates ubound and offset accordingly. */
557 :
558 : void
559 955 : gfc_conv_shift_descriptor_lbound (stmtblock_t* block, tree desc,
560 : int dim, tree new_lbound)
561 : {
562 955 : tree offs, ubound, lbound, stride;
563 955 : tree diff, offs_diff;
564 :
565 955 : new_lbound = fold_convert (gfc_array_index_type, new_lbound);
566 :
567 955 : offs = gfc_conv_descriptor_offset_get (desc);
568 955 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
569 955 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
570 955 : stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]);
571 :
572 : /* Get difference (new - old) by which to shift stuff. */
573 955 : diff = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
574 : new_lbound, lbound);
575 :
576 : /* Shift ubound and offset accordingly. This has to be done before
577 : updating the lbound, as they depend on the lbound expression! */
578 955 : ubound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
579 : ubound, diff);
580 955 : gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[dim], ubound);
581 955 : offs_diff = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
582 : diff, stride);
583 955 : offs = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
584 : offs, offs_diff);
585 955 : gfc_conv_descriptor_offset_set (block, desc, offs);
586 :
587 : /* Finally set lbound to value we want. */
588 955 : gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[dim], new_lbound);
589 955 : }
590 :
591 :
592 : /* Obtain offsets for trans-types.cc(gfc_get_array_descr_info). */
593 :
594 : void
595 273805 : 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 273805 : tree field;
602 273805 : tree type;
603 :
604 273805 : type = TYPE_MAIN_VARIANT (desc_type);
605 273805 : field = gfc_advance_chain (TYPE_FIELDS (type), DATA_FIELD);
606 273805 : *data_off = byte_position (field);
607 273805 : field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
608 273805 : *dtype_off = byte_position (field);
609 273805 : field = gfc_advance_chain (TYPE_FIELDS (type), SPAN_FIELD);
610 273805 : *span_off = byte_position (field);
611 273805 : field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
612 273805 : *dim_off = byte_position (field);
613 273805 : type = TREE_TYPE (TREE_TYPE (field));
614 273805 : *dim_size = TYPE_SIZE_UNIT (type);
615 273805 : field = gfc_advance_chain (TYPE_FIELDS (type), STRIDE_SUBFIELD);
616 273805 : *stride_suboff = byte_position (field);
617 273805 : field = gfc_advance_chain (TYPE_FIELDS (type), LBOUND_SUBFIELD);
618 273805 : *lower_suboff = byte_position (field);
619 273805 : field = gfc_advance_chain (TYPE_FIELDS (type), UBOUND_SUBFIELD);
620 273805 : *upper_suboff = byte_position (field);
621 273805 : }
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 171796 : gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
643 : {
644 403699 : for (; ss != gfc_ss_terminator; ss = ss->next)
645 231903 : ss->info->useflags = flags;
646 171796 : }
647 :
648 :
649 : /* Free a gfc_ss chain. */
650 :
651 : void
652 180584 : gfc_free_ss_chain (gfc_ss * ss)
653 : {
654 180584 : gfc_ss *next;
655 :
656 369386 : while (ss != gfc_ss_terminator)
657 : {
658 188802 : gcc_assert (ss != NULL);
659 188802 : next = ss->next;
660 188802 : gfc_free_ss (ss);
661 188802 : ss = next;
662 : }
663 180584 : }
664 :
665 :
666 : static void
667 490646 : free_ss_info (gfc_ss_info *ss_info)
668 : {
669 490646 : int n;
670 :
671 490646 : ss_info->refcount--;
672 490646 : if (ss_info->refcount > 0)
673 : return;
674 :
675 485899 : gcc_assert (ss_info->refcount == 0);
676 :
677 485899 : switch (ss_info->type)
678 : {
679 : case GFC_SS_SECTION:
680 5393568 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
681 5056470 : if (ss_info->data.array.subscript[n])
682 7627 : gfc_free_ss_chain (ss_info->data.array.subscript[n]);
683 : break;
684 :
685 : default:
686 : break;
687 : }
688 :
689 485899 : free (ss_info);
690 : }
691 :
692 :
693 : /* Free a SS. */
694 :
695 : void
696 490646 : gfc_free_ss (gfc_ss * ss)
697 : {
698 490646 : free_ss_info (ss->info);
699 490646 : free (ss);
700 490646 : }
701 :
702 :
703 : /* Creates and initializes an array type gfc_ss struct. */
704 :
705 : gfc_ss *
706 410352 : gfc_get_array_ss (gfc_ss *next, gfc_expr *expr, int dimen, gfc_ss_type type)
707 : {
708 410352 : gfc_ss *ss;
709 410352 : gfc_ss_info *ss_info;
710 410352 : int i;
711 :
712 410352 : ss_info = gfc_get_ss_info ();
713 410352 : ss_info->refcount++;
714 410352 : ss_info->type = type;
715 410352 : ss_info->expr = expr;
716 :
717 410352 : ss = gfc_get_ss ();
718 410352 : ss->info = ss_info;
719 410352 : ss->next = next;
720 410352 : ss->dimen = dimen;
721 866055 : for (i = 0; i < ss->dimen; i++)
722 455703 : ss->dim[i] = i;
723 :
724 410352 : return ss;
725 : }
726 :
727 :
728 : /* Creates and initializes a temporary type gfc_ss struct. */
729 :
730 : gfc_ss *
731 11243 : gfc_get_temp_ss (tree type, tree string_length, int dimen)
732 : {
733 11243 : gfc_ss *ss;
734 11243 : gfc_ss_info *ss_info;
735 11243 : int i;
736 :
737 11243 : ss_info = gfc_get_ss_info ();
738 11243 : ss_info->refcount++;
739 11243 : ss_info->type = GFC_SS_TEMP;
740 11243 : ss_info->string_length = string_length;
741 11243 : ss_info->data.temp.type = type;
742 :
743 11243 : ss = gfc_get_ss ();
744 11243 : ss->info = ss_info;
745 11243 : ss->next = gfc_ss_terminator;
746 11243 : ss->dimen = dimen;
747 25186 : for (i = 0; i < ss->dimen; i++)
748 13943 : ss->dim[i] = i;
749 :
750 11243 : return ss;
751 : }
752 :
753 :
754 : /* Creates and initializes a scalar type gfc_ss struct. */
755 :
756 : gfc_ss *
757 66369 : gfc_get_scalar_ss (gfc_ss *next, gfc_expr *expr)
758 : {
759 66369 : gfc_ss *ss;
760 66369 : gfc_ss_info *ss_info;
761 :
762 66369 : ss_info = gfc_get_ss_info ();
763 66369 : ss_info->refcount++;
764 66369 : ss_info->type = GFC_SS_SCALAR;
765 66369 : ss_info->expr = expr;
766 :
767 66369 : ss = gfc_get_ss ();
768 66369 : ss->info = ss_info;
769 66369 : ss->next = next;
770 :
771 66369 : return ss;
772 : }
773 :
774 :
775 : /* Free all the SS associated with a loop. */
776 :
777 : void
778 182219 : gfc_cleanup_loop (gfc_loopinfo * loop)
779 : {
780 182219 : gfc_loopinfo *loop_next, **ploop;
781 182219 : gfc_ss *ss;
782 182219 : gfc_ss *next;
783 :
784 182219 : ss = loop->ss;
785 483528 : while (ss != gfc_ss_terminator)
786 : {
787 301309 : gcc_assert (ss != NULL);
788 301309 : next = ss->loop_chain;
789 301309 : gfc_free_ss (ss);
790 301309 : ss = next;
791 : }
792 :
793 : /* Remove reference to self in the parent loop. */
794 182219 : 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 185583 : 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 182219 : }
810 :
811 :
812 : static void
813 247709 : set_ss_loop (gfc_ss *ss, gfc_loopinfo *loop)
814 : {
815 247709 : int n;
816 :
817 558022 : for (; ss != gfc_ss_terminator; ss = ss->next)
818 : {
819 310313 : ss->loop = loop;
820 :
821 310313 : if (ss->info->type == GFC_SS_SCALAR
822 : || ss->info->type == GFC_SS_REFERENCE
823 262016 : || ss->info->type == GFC_SS_TEMP)
824 59540 : continue;
825 :
826 4012368 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
827 3761595 : if (ss->info->data.array.subscript[n] != NULL)
828 7386 : set_ss_loop (ss->info->data.array.subscript[n], loop);
829 : }
830 247709 : }
831 :
832 :
833 : /* Associate a SS chain with a loop. */
834 :
835 : void
836 240323 : gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
837 : {
838 240323 : gfc_ss *ss;
839 240323 : gfc_loopinfo *nested_loop;
840 :
841 240323 : if (head == gfc_ss_terminator)
842 : return;
843 :
844 240323 : set_ss_loop (head, loop);
845 :
846 240323 : ss = head;
847 783573 : for (; ss && ss != gfc_ss_terminator; ss = ss->next)
848 : {
849 302927 : 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 302927 : if (ss->next == gfc_ss_terminator)
870 240323 : ss->loop_chain = loop->ss;
871 : else
872 62604 : ss->loop_chain = ss->next;
873 : }
874 240323 : gcc_assert (ss == gfc_ss_terminator);
875 240323 : loop->ss = head;
876 : }
877 :
878 :
879 : /* Returns true if the expression is an array pointer. */
880 :
881 : static bool
882 366336 : is_pointer_array (tree expr)
883 : {
884 366336 : if (expr == NULL_TREE
885 366336 : || !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr))
886 462771 : || GFC_CLASS_TYPE_P (TREE_TYPE (expr)))
887 : return false;
888 :
889 96435 : if (VAR_P (expr)
890 96435 : && GFC_DECL_PTR_ARRAY_P (expr))
891 : return true;
892 :
893 90085 : if (TREE_CODE (expr) == PARM_DECL
894 90085 : && GFC_DECL_PTR_ARRAY_P (expr))
895 : return true;
896 :
897 90085 : if (INDIRECT_REF_P (expr)
898 90085 : && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 0)))
899 : return true;
900 :
901 : /* The field declaration is marked as an pointer array. */
902 87657 : if (TREE_CODE (expr) == COMPONENT_REF
903 15250 : && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 1))
904 90516 : && !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 369047 : get_CFI_desc (gfc_symbol *sym, gfc_expr *expr,
919 : tree *desc, gfc_array_ref *ar)
920 : {
921 369047 : tree tmp;
922 :
923 369047 : if (!is_CFI_desc (sym, expr))
924 : return false;
925 :
926 4727 : if (expr && ar)
927 : {
928 4061 : if (!(expr->ref && expr->ref->type == REF_ARRAY)
929 4043 : || (&expr->ref->u.ar != ar))
930 : return false;
931 : }
932 :
933 4697 : if (sym == NULL)
934 1108 : tmp = expr->symtree->n.sym->backend_decl;
935 : else
936 3589 : tmp = sym->backend_decl;
937 :
938 4697 : if (tmp && DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp))
939 0 : tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
940 :
941 4697 : *desc = tmp;
942 4697 : return true;
943 : }
944 :
945 :
946 : /* A helper function for gfc_get_array_span that returns the array element size
947 : of a class entity. */
948 : static tree
949 1137 : class_array_element_size (tree decl, bool unlimited)
950 : {
951 : /* Class dummys usually require extraction from the saved descriptor,
952 : which gfc_class_vptr_get does for us if necessary. This, of course,
953 : will be a component of the class object. */
954 1137 : tree vptr = gfc_class_vptr_get (decl);
955 : /* If this is an unlimited polymorphic entity with a character payload,
956 : the element size will be corrected for the string length. */
957 1137 : if (unlimited)
958 1022 : return gfc_resize_class_size_with_len (NULL,
959 511 : TREE_OPERAND (vptr, 0),
960 511 : gfc_vptr_size_get (vptr));
961 : else
962 626 : return gfc_vptr_size_get (vptr);
963 : }
964 :
965 :
966 : /* Return the span of an array. */
967 :
968 : tree
969 58221 : gfc_get_array_span (tree desc, gfc_expr *expr)
970 : {
971 58221 : tree tmp;
972 58221 : gfc_symbol *sym = (expr && expr->expr_type == EXPR_VARIABLE) ?
973 51039 : expr->symtree->n.sym : NULL;
974 :
975 58221 : if (is_pointer_array (desc)
976 58221 : || (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 57663 : 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 57536 : else if (TREE_CODE (desc) == COMPONENT_REF
996 512 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
997 57665 : && 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 57480 : else if (sym && sym->ts.type == BT_CLASS
1002 1125 : && expr->ref->type == REF_COMPONENT
1003 1125 : && expr->ref->next->type == REF_ARRAY
1004 1125 : && expr->ref->next->next == NULL
1005 1107 : && CLASS_DATA (sym)->attr.dimension)
1006 : /* Having escaped the above, this can only be a class array dummy. */
1007 1081 : tmp = class_array_element_size (sym->backend_decl,
1008 1081 : UNLIMITED_POLY (sym));
1009 : else
1010 : {
1011 : /* If none of the fancy stuff works, the span is the element
1012 : size of the array. Attempt to deal with unbounded character
1013 : types if possible. Otherwise, return NULL_TREE. */
1014 56399 : tmp = gfc_get_element_type (TREE_TYPE (desc));
1015 56399 : 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 45352 : tmp = fold_convert (gfc_array_index_type,
1037 : size_in_bytes (tmp));
1038 : }
1039 58221 : 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 8725 : gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
1065 : gfc_se * se, gfc_array_spec * as)
1066 : {
1067 8725 : int n, dim, total_dim;
1068 8725 : gfc_se tmpse;
1069 8725 : gfc_ss *ss;
1070 8725 : tree lower;
1071 8725 : tree upper;
1072 8725 : tree tmp;
1073 :
1074 8725 : total_dim = 0;
1075 :
1076 8725 : if (!as || as->type != AS_EXPLICIT)
1077 7564 : return;
1078 :
1079 2347 : for (ss = se->ss; ss; ss = ss->parent)
1080 : {
1081 1186 : total_dim += ss->loop->dimen;
1082 2727 : for (n = 0; n < ss->loop->dimen; n++)
1083 : {
1084 : /* The bound is known, nothing to do. */
1085 1541 : if (ss->loop->to[n] != NULL_TREE)
1086 485 : continue;
1087 :
1088 1056 : dim = ss->dim[n];
1089 1056 : gcc_assert (dim < as->rank);
1090 1056 : gcc_assert (ss->loop->dimen <= as->rank);
1091 :
1092 : /* Evaluate the lower bound. */
1093 1056 : gfc_init_se (&tmpse, NULL);
1094 1056 : gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
1095 1056 : gfc_add_block_to_block (&se->pre, &tmpse.pre);
1096 1056 : gfc_add_block_to_block (&se->post, &tmpse.post);
1097 1056 : lower = fold_convert (gfc_array_index_type, tmpse.expr);
1098 :
1099 : /* ...and the upper bound. */
1100 1056 : gfc_init_se (&tmpse, NULL);
1101 1056 : gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
1102 1056 : gfc_add_block_to_block (&se->pre, &tmpse.pre);
1103 1056 : gfc_add_block_to_block (&se->post, &tmpse.post);
1104 1056 : upper = fold_convert (gfc_array_index_type, tmpse.expr);
1105 :
1106 : /* Set the upper bound of the loop to UPPER - LOWER. */
1107 1056 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
1108 : gfc_array_index_type, upper, lower);
1109 1056 : tmp = gfc_evaluate_now (tmp, &se->pre);
1110 1056 : ss->loop->to[n] = tmp;
1111 : }
1112 : }
1113 :
1114 1161 : gcc_assert (total_dim == as->rank);
1115 : }
1116 :
1117 :
1118 : /* Generate code to allocate an array temporary, or create a variable to
1119 : hold the data. If size is NULL, zero the descriptor so that the
1120 : callee will allocate the array. If DEALLOC is true, also generate code to
1121 : free the array afterwards.
1122 :
1123 : If INITIAL is not NULL, it is packed using internal_pack and the result used
1124 : as data instead of allocating a fresh, 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 27617 : 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 27617 : tree tmp;
1136 27617 : tree desc;
1137 27617 : bool onstack;
1138 :
1139 27617 : desc = info->descriptor;
1140 27617 : info->offset = gfc_index_zero_node;
1141 27617 : if (size == NULL_TREE || (dynamic && integer_zerop (size)))
1142 : {
1143 : /* A callee allocated array. */
1144 2852 : gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
1145 2852 : onstack = false;
1146 : }
1147 : else
1148 : {
1149 : /* Allocate the temporary. */
1150 49530 : onstack = !dynamic && initial == NULL_TREE
1151 24765 : && (flag_stack_arrays
1152 24380 : || gfc_can_put_var_on_stack (size));
1153 :
1154 24765 : if (onstack)
1155 : {
1156 : /* Make a temporary variable to hold the data. */
1157 19767 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (nelem),
1158 : nelem, gfc_index_one_node);
1159 19767 : tmp = gfc_evaluate_now (tmp, pre);
1160 19767 : tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
1161 : tmp);
1162 19767 : tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
1163 : tmp);
1164 19767 : 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 19767 : 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 19767 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1173 19767 : gfc_conv_descriptor_data_set (pre, desc, tmp);
1174 : }
1175 : else
1176 : {
1177 : /* Allocate memory to hold the data or call internal_pack. */
1178 4998 : if (initial == NULL_TREE)
1179 : {
1180 4855 : tmp = gfc_call_malloc (pre, NULL, size);
1181 4855 : tmp = gfc_evaluate_now (tmp, pre);
1182 : }
1183 : else
1184 : {
1185 143 : tree packed;
1186 143 : tree source_data;
1187 143 : tree was_packed;
1188 143 : stmtblock_t do_copying;
1189 :
1190 143 : tmp = TREE_TYPE (initial); /* Pointer to descriptor. */
1191 143 : gcc_assert (TREE_CODE (tmp) == POINTER_TYPE);
1192 143 : tmp = TREE_TYPE (tmp); /* The descriptor itself. */
1193 143 : tmp = gfc_get_element_type (tmp);
1194 143 : packed = gfc_create_var (build_pointer_type (tmp), "data");
1195 :
1196 143 : tmp = build_call_expr_loc (input_location,
1197 : gfor_fndecl_in_pack, 1, initial);
1198 143 : tmp = fold_convert (TREE_TYPE (packed), tmp);
1199 143 : gfc_add_modify (pre, packed, tmp);
1200 :
1201 143 : tmp = build_fold_indirect_ref_loc (input_location,
1202 : initial);
1203 143 : source_data = gfc_conv_descriptor_data_get (tmp);
1204 :
1205 : /* internal_pack may return source->data without any allocation
1206 : or copying if it is already packed. If that's the case, we
1207 : need to allocate and copy manually. */
1208 :
1209 143 : gfc_start_block (&do_copying);
1210 143 : tmp = gfc_call_malloc (&do_copying, NULL, size);
1211 143 : tmp = fold_convert (TREE_TYPE (packed), tmp);
1212 143 : gfc_add_modify (&do_copying, packed, tmp);
1213 143 : tmp = gfc_build_memcpy_call (packed, source_data, size);
1214 143 : gfc_add_expr_to_block (&do_copying, tmp);
1215 :
1216 143 : was_packed = fold_build2_loc (input_location, EQ_EXPR,
1217 : logical_type_node, packed,
1218 : source_data);
1219 143 : tmp = gfc_finish_block (&do_copying);
1220 143 : tmp = build3_v (COND_EXPR, was_packed, tmp,
1221 : build_empty_stmt (input_location));
1222 143 : gfc_add_expr_to_block (pre, tmp);
1223 :
1224 143 : tmp = fold_convert (pvoid_type_node, packed);
1225 : }
1226 :
1227 4998 : gfc_conv_descriptor_data_set (pre, desc, tmp);
1228 : }
1229 : }
1230 27617 : 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 27617 : gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node);
1235 :
1236 27617 : if (dealloc && !onstack)
1237 : {
1238 : /* Free the temporary. */
1239 7600 : tmp = gfc_conv_descriptor_data_get (desc);
1240 7600 : tmp = gfc_call_free (tmp);
1241 7600 : gfc_add_expr_to_block (post, tmp);
1242 : }
1243 27617 : }
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 260234 : get_scalarizer_dim_for_array_dim (gfc_ss *ss, int array_dim)
1262 : {
1263 260234 : int array_ref_dim;
1264 260234 : int n;
1265 :
1266 260234 : array_ref_dim = 0;
1267 :
1268 526601 : for (; ss; ss = ss->parent)
1269 686001 : for (n = 0; n < ss->dimen; n++)
1270 419634 : if (ss->dim[n] < array_dim)
1271 76850 : array_ref_dim++;
1272 :
1273 260234 : return array_ref_dim;
1274 : }
1275 :
1276 :
1277 : static gfc_ss *
1278 220005 : innermost_ss (gfc_ss *ss)
1279 : {
1280 404517 : while (ss->nested_ss != NULL)
1281 : ss = ss->nested_ss;
1282 :
1283 396309 : 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 220005 : get_array_ref_dim_for_loop_dim (gfc_ss *ss, int loop_dim)
1296 : {
1297 220005 : return get_scalarizer_dim_for_array_dim (innermost_ss (ss),
1298 220005 : ss->dim[loop_dim]);
1299 : }
1300 :
1301 :
1302 : /* Use the information in the ss to obtain the required information about
1303 : the type and size of an array temporary, when the lhs in an assignment
1304 : is a class expression. */
1305 :
1306 : static tree
1307 327 : get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype,
1308 : gfc_ss **fcnss)
1309 : {
1310 327 : gfc_ss *loop_ss = ss->loop->ss;
1311 327 : gfc_ss *lhs_ss;
1312 327 : gfc_ss *rhs_ss;
1313 327 : gfc_ss *fcn_ss = NULL;
1314 327 : tree tmp;
1315 327 : tree tmp2;
1316 327 : tree vptr;
1317 327 : tree class_expr = NULL_TREE;
1318 327 : tree lhs_class_expr = NULL_TREE;
1319 327 : bool unlimited_rhs = false;
1320 327 : bool unlimited_lhs = false;
1321 327 : bool rhs_function = false;
1322 327 : bool unlimited_arg1 = false;
1323 327 : gfc_symbol *vtab;
1324 327 : tree cntnr = NULL_TREE;
1325 :
1326 : /* The second element in the loop chain contains the source for the
1327 : class temporary created in gfc_trans_create_temp_array. */
1328 327 : rhs_ss = loop_ss->loop_chain;
1329 :
1330 327 : if (rhs_ss != gfc_ss_terminator
1331 303 : && rhs_ss->info
1332 303 : && rhs_ss->info->expr
1333 303 : && rhs_ss->info->expr->ts.type == BT_CLASS
1334 182 : && rhs_ss->info->data.array.descriptor)
1335 : {
1336 170 : if (rhs_ss->info->expr->expr_type != EXPR_VARIABLE)
1337 56 : class_expr
1338 56 : = gfc_get_class_from_expr (rhs_ss->info->data.array.descriptor);
1339 : else
1340 114 : class_expr = gfc_get_class_from_gfc_expr (rhs_ss->info->expr);
1341 170 : unlimited_rhs = UNLIMITED_POLY (rhs_ss->info->expr);
1342 170 : if (rhs_ss->info->expr->expr_type == EXPR_FUNCTION)
1343 : rhs_function = true;
1344 : }
1345 :
1346 : /* Usually, ss points to the function. When the function call is an actual
1347 : argument, it is instead rhs_ss because the ss chain is shifted by one. */
1348 327 : *fcnss = fcn_ss = rhs_function ? rhs_ss : ss;
1349 :
1350 : /* If this is a transformational function with a class result, the info
1351 : class_container field points to the class container of arg1. */
1352 327 : if (class_expr != NULL_TREE
1353 151 : && fcn_ss->info && fcn_ss->info->expr
1354 91 : && fcn_ss->info->expr->expr_type == EXPR_FUNCTION
1355 91 : && fcn_ss->info->expr->value.function.isym
1356 60 : && fcn_ss->info->expr->value.function.isym->transformational)
1357 : {
1358 60 : cntnr = ss->info->class_container;
1359 60 : unlimited_arg1
1360 60 : = UNLIMITED_POLY (fcn_ss->info->expr->value.function.actual->expr);
1361 : }
1362 :
1363 : /* For an assignment the lhs is the next element in the loop chain.
1364 : If we have a class rhs, this had better be a class variable
1365 : expression! Otherwise, the class container from arg1 can be used
1366 : to set the vptr and len fields of the result class container. */
1367 327 : lhs_ss = rhs_ss->loop_chain;
1368 327 : if (lhs_ss && lhs_ss != gfc_ss_terminator
1369 225 : && lhs_ss->info && lhs_ss->info->expr
1370 225 : && lhs_ss->info->expr->expr_type ==EXPR_VARIABLE
1371 225 : && lhs_ss->info->expr->ts.type == BT_CLASS)
1372 : {
1373 225 : tmp = lhs_ss->info->data.array.descriptor;
1374 225 : unlimited_lhs = UNLIMITED_POLY (rhs_ss->info->expr);
1375 : }
1376 102 : else if (cntnr != NULL_TREE)
1377 : {
1378 54 : tmp = gfc_class_vptr_get (class_expr);
1379 54 : gfc_add_modify (pre, tmp, fold_convert (TREE_TYPE (tmp),
1380 : gfc_class_vptr_get (cntnr)));
1381 54 : if (unlimited_rhs)
1382 : {
1383 6 : tmp = gfc_class_len_get (class_expr);
1384 6 : if (unlimited_arg1)
1385 6 : gfc_add_modify (pre, tmp, gfc_class_len_get (cntnr));
1386 : }
1387 : tmp = NULL_TREE;
1388 : }
1389 : else
1390 : tmp = NULL_TREE;
1391 :
1392 : /* Get the lhs class expression. */
1393 225 : if (tmp != NULL_TREE && lhs_ss->loop_chain == gfc_ss_terminator)
1394 213 : lhs_class_expr = gfc_get_class_from_expr (tmp);
1395 : else
1396 114 : return class_expr;
1397 :
1398 213 : gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (lhs_class_expr)));
1399 :
1400 : /* Set the lhs vptr and, if necessary, the _len field. */
1401 213 : if (class_expr)
1402 : {
1403 : /* Both lhs and rhs are class expressions. */
1404 79 : tmp = gfc_class_vptr_get (lhs_class_expr);
1405 158 : gfc_add_modify (pre, tmp,
1406 79 : fold_convert (TREE_TYPE (tmp),
1407 : gfc_class_vptr_get (class_expr)));
1408 79 : if (unlimited_lhs)
1409 : {
1410 31 : gcc_assert (unlimited_rhs);
1411 31 : tmp = gfc_class_len_get (lhs_class_expr);
1412 31 : tmp2 = gfc_class_len_get (class_expr);
1413 31 : gfc_add_modify (pre, tmp, tmp2);
1414 : }
1415 : }
1416 134 : else if (rhs_ss->info->data.array.descriptor)
1417 : {
1418 : /* lhs is class and rhs is intrinsic or derived type. */
1419 128 : *eltype = TREE_TYPE (rhs_ss->info->data.array.descriptor);
1420 128 : *eltype = gfc_get_element_type (*eltype);
1421 128 : vtab = gfc_find_vtab (&rhs_ss->info->expr->ts);
1422 128 : vptr = vtab->backend_decl;
1423 128 : if (vptr == NULL_TREE)
1424 24 : vptr = gfc_get_symbol_decl (vtab);
1425 128 : vptr = gfc_build_addr_expr (NULL_TREE, vptr);
1426 128 : tmp = gfc_class_vptr_get (lhs_class_expr);
1427 128 : gfc_add_modify (pre, tmp,
1428 128 : fold_convert (TREE_TYPE (tmp), vptr));
1429 :
1430 128 : if (unlimited_lhs)
1431 : {
1432 0 : tmp = gfc_class_len_get (lhs_class_expr);
1433 0 : if (rhs_ss->info
1434 0 : && rhs_ss->info->expr
1435 0 : && rhs_ss->info->expr->ts.type == BT_CHARACTER)
1436 0 : tmp2 = build_int_cst (TREE_TYPE (tmp),
1437 0 : rhs_ss->info->expr->ts.kind);
1438 : else
1439 0 : tmp2 = build_int_cst (TREE_TYPE (tmp), 0);
1440 0 : gfc_add_modify (pre, tmp, tmp2);
1441 : }
1442 : }
1443 :
1444 : return class_expr;
1445 : }
1446 :
1447 :
1448 :
1449 : /* Generate code to create and initialize the descriptor for a temporary
1450 : array. This is used for both temporaries needed by the scalarizer, and
1451 : functions returning arrays. Adjusts the loop variables to be
1452 : zero-based, and calculates the loop bounds for callee allocated arrays.
1453 : Allocate the array unless it's callee allocated (we have a callee
1454 : allocated array if 'callee_alloc' is true, or if loop->to[n] is
1455 : NULL_TREE for any n). Also fills in the descriptor, data and offset
1456 : fields of info if known. Returns the size of the array, or NULL for a
1457 : callee allocated array.
1458 :
1459 : 'eltype' == NULL signals that the temporary should be a class object.
1460 : The 'initial' expression is used to obtain the size of the dynamic
1461 : type; otherwise the allocation and initialization proceeds as for any
1462 : other expression
1463 :
1464 : PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
1465 : gfc_trans_allocate_array_storage. */
1466 :
1467 : tree
1468 27617 : 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 27617 : gfc_loopinfo *loop;
1473 27617 : gfc_ss *s;
1474 27617 : gfc_array_info *info;
1475 27617 : tree from[GFC_MAX_DIMENSIONS], to[GFC_MAX_DIMENSIONS];
1476 27617 : tree type;
1477 27617 : tree desc;
1478 27617 : tree tmp;
1479 27617 : tree size;
1480 27617 : tree nelem;
1481 27617 : tree cond;
1482 27617 : tree or_expr;
1483 27617 : tree elemsize;
1484 27617 : tree class_expr = NULL_TREE;
1485 27617 : gfc_ss *fcn_ss = NULL;
1486 27617 : int n, dim, tmp_dim;
1487 27617 : 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 27617 : if (eltype == NULL_TREE && initial)
1492 : {
1493 0 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial)));
1494 0 : class_expr = build_fold_indirect_ref_loc (input_location, initial);
1495 : /* Obtain the structure (class) expression. */
1496 0 : class_expr = gfc_get_class_from_expr (class_expr);
1497 0 : gcc_assert (class_expr);
1498 : }
1499 :
1500 : /* Otherwise, some expressions, such as class functions, arising from
1501 : dependency checking in assignments come here with class element type.
1502 : The descriptor can be obtained from the ss->info and then converted
1503 : to the class object. */
1504 27617 : if (class_expr == NULL_TREE && GFC_CLASS_TYPE_P (eltype))
1505 327 : class_expr = get_class_info_from_ss (pre, ss, &eltype, &fcn_ss);
1506 :
1507 : /* If the dynamic type is not available, use the declared type. */
1508 27617 : if (eltype && GFC_CLASS_TYPE_P (eltype))
1509 199 : eltype = gfc_get_element_type (TREE_TYPE (TYPE_FIELDS (eltype)));
1510 :
1511 27617 : if (class_expr == NULL_TREE)
1512 27466 : elemsize = fold_convert (gfc_array_index_type,
1513 : TYPE_SIZE_UNIT (eltype));
1514 : else
1515 : {
1516 : /* Unlimited polymorphic entities are initialised with NULL vptr. They
1517 : can be tested for by checking if the len field is present. If so
1518 : test the vptr before using the vtable size. */
1519 151 : tmp = gfc_class_vptr_get (class_expr);
1520 151 : tmp = fold_build2_loc (input_location, NE_EXPR,
1521 : logical_type_node,
1522 151 : tmp, build_int_cst (TREE_TYPE (tmp), 0));
1523 151 : elemsize = fold_build3_loc (input_location, COND_EXPR,
1524 : gfc_array_index_type,
1525 : tmp,
1526 : gfc_class_vtab_size_get (class_expr),
1527 : gfc_index_zero_node);
1528 151 : elemsize = gfc_evaluate_now (elemsize, pre);
1529 151 : elemsize = gfc_resize_class_size_with_len (pre, class_expr, elemsize);
1530 : /* Casting the data as a character of the dynamic length ensures that
1531 : assignment of elements works when needed. */
1532 151 : eltype = gfc_get_character_type_len (1, elemsize);
1533 : }
1534 :
1535 27617 : memset (from, 0, sizeof (from));
1536 27617 : memset (to, 0, sizeof (to));
1537 :
1538 27617 : info = &ss->info->data.array;
1539 :
1540 27617 : gcc_assert (ss->dimen > 0);
1541 27617 : gcc_assert (ss->loop->dimen == ss->dimen);
1542 :
1543 27617 : 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 55269 : for (s = ss; s; s = s->parent)
1549 : {
1550 27652 : loop = s->loop;
1551 :
1552 27652 : total_dim += loop->dimen;
1553 64493 : for (n = 0; n < loop->dimen; n++)
1554 : {
1555 36841 : dim = s->dim[n];
1556 :
1557 : /* Callee allocated arrays may not have a known bound yet. */
1558 36841 : if (loop->to[n])
1559 33458 : 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 36841 : 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 36841 : 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 36841 : tmp_dim = get_scalarizer_dim_for_array_dim (ss, dim);
1578 36841 : from[tmp_dim] = loop->from[n];
1579 36841 : to[tmp_dim] = loop->to[n];
1580 :
1581 36841 : info->delta[dim] = gfc_index_zero_node;
1582 36841 : info->start[dim] = gfc_index_zero_node;
1583 36841 : info->end[dim] = gfc_index_zero_node;
1584 36841 : info->stride[dim] = gfc_index_one_node;
1585 : }
1586 : }
1587 :
1588 : /* Initialize the descriptor. */
1589 27617 : type =
1590 27617 : gfc_get_array_type_bounds (eltype, total_dim, 0, from, to, 1,
1591 : GFC_ARRAY_UNKNOWN, true);
1592 27617 : desc = gfc_create_var (type, "atmp");
1593 27617 : 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 27617 : tree arraytype = TREE_TYPE (GFC_TYPE_ARRAY_DATAPTR_TYPE (type));
1599 27617 : if (! TYPE_NAME (arraytype))
1600 27617 : TYPE_NAME (arraytype) = build_decl (UNKNOWN_LOCATION, TYPE_DECL,
1601 : NULL_TREE, arraytype);
1602 27617 : gfc_add_expr_to_block (pre, build1 (DECL_EXPR,
1603 27617 : arraytype, TYPE_NAME (arraytype)));
1604 :
1605 27617 : 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 27617 : if (class_expr != NULL_TREE
1612 27466 : || (fcn_ss && fcn_ss->info && fcn_ss->info->class_container))
1613 : {
1614 181 : tree class_data;
1615 181 : tree dtype;
1616 181 : gfc_expr *expr1 = fcn_ss ? fcn_ss->info->expr : NULL;
1617 181 : bool rank_changer;
1618 :
1619 : /* Pick out these transformational functions because they change the rank
1620 : or shape of the first argument. This requires that the class type be
1621 : changed, the dtype updated and the correct rank used. */
1622 121 : rank_changer = expr1 && expr1->expr_type == EXPR_FUNCTION
1623 121 : && expr1->value.function.isym
1624 271 : && (expr1->value.function.isym->id == GFC_ISYM_RESHAPE
1625 : || expr1->value.function.isym->id == GFC_ISYM_SPREAD
1626 : || expr1->value.function.isym->id == GFC_ISYM_PACK
1627 : || expr1->value.function.isym->id == GFC_ISYM_UNPACK);
1628 :
1629 : /* Create a class temporary for the result using the lhs class object. */
1630 181 : if (class_expr != NULL_TREE && !rank_changer)
1631 : {
1632 103 : tmp = gfc_create_var (TREE_TYPE (class_expr), "ctmp");
1633 103 : gfc_add_modify (pre, tmp, class_expr);
1634 : }
1635 : else
1636 : {
1637 78 : tree vptr;
1638 78 : class_expr = fcn_ss->info->class_container;
1639 78 : gcc_assert (expr1);
1640 :
1641 : /* Build a new class container using the arg1 class object. The class
1642 : typespec must be rebuilt because the rank might have changed. */
1643 78 : gfc_typespec ts = CLASS_DATA (expr1)->ts;
1644 78 : symbol_attribute attr = CLASS_DATA (expr1)->attr;
1645 78 : gfc_change_class (&ts, &attr, NULL, expr1->rank, 0);
1646 78 : tmp = gfc_create_var (gfc_typenode_for_spec (&ts), "ctmp");
1647 78 : fcn_ss->info->class_container = tmp;
1648 :
1649 : /* Set the vptr and obtain the element size. */
1650 78 : vptr = gfc_class_vptr_get (tmp);
1651 156 : gfc_add_modify (pre, vptr,
1652 78 : fold_convert (TREE_TYPE (vptr),
1653 : gfc_class_vptr_get (class_expr)));
1654 78 : elemsize = gfc_class_vtab_size_get (class_expr);
1655 :
1656 : /* Set the _len field, if necessary. */
1657 78 : if (UNLIMITED_POLY (expr1))
1658 : {
1659 18 : gfc_add_modify (pre, gfc_class_len_get (tmp),
1660 : gfc_class_len_get (class_expr));
1661 18 : elemsize = gfc_resize_class_size_with_len (pre, class_expr,
1662 : elemsize);
1663 : }
1664 :
1665 78 : elemsize = gfc_evaluate_now (elemsize, pre);
1666 : }
1667 :
1668 181 : class_data = gfc_class_data_get (tmp);
1669 :
1670 181 : if (rank_changer)
1671 : {
1672 : /* Take the dtype from the class expression. */
1673 72 : dtype = gfc_conv_descriptor_dtype (gfc_class_data_get (class_expr));
1674 72 : tmp = gfc_conv_descriptor_dtype (desc);
1675 72 : gfc_add_modify (pre, tmp, dtype);
1676 :
1677 : /* These transformational functions change the rank. */
1678 72 : tmp = gfc_conv_descriptor_rank (desc);
1679 72 : gfc_add_modify (pre, tmp,
1680 72 : build_int_cst (TREE_TYPE (tmp), ss->loop->dimen));
1681 72 : fcn_ss->info->class_container = NULL_TREE;
1682 : }
1683 :
1684 : /* Assign the new descriptor to the _data field. This allows the
1685 : vptr _copy to be used for scalarized assignment since the class
1686 : temporary can be found from the descriptor. */
1687 181 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1688 181 : TREE_TYPE (desc), desc);
1689 181 : gfc_add_modify (pre, class_data, tmp);
1690 :
1691 : /* Point desc to the class _data field. */
1692 181 : desc = class_data;
1693 181 : }
1694 : else
1695 : {
1696 : /* Fill in the array dtype. */
1697 27436 : tmp = gfc_conv_descriptor_dtype (desc);
1698 27436 : gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
1699 : }
1700 :
1701 27617 : info->descriptor = desc;
1702 27617 : 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 27617 : or_expr = NULL_TREE;
1718 :
1719 : /* If there is at least one null loop->to[n], it is a callee allocated
1720 : array. */
1721 61075 : for (n = 0; n < total_dim; n++)
1722 35493 : if (to[n] == NULL_TREE)
1723 : {
1724 : size = NULL_TREE;
1725 : break;
1726 : }
1727 :
1728 27617 : if (size == NULL_TREE)
1729 4080 : for (s = ss; s; s = s->parent)
1730 5433 : for (n = 0; n < s->loop->dimen; n++)
1731 : {
1732 3388 : 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 3388 : 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 3388 : s->loop->to[n] = tmp;
1741 : }
1742 : else
1743 : {
1744 59035 : for (n = 0; n < total_dim; n++)
1745 : {
1746 : /* Store the stride and bound components in the descriptor. */
1747 33453 : gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size);
1748 :
1749 33453 : gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
1750 : gfc_index_zero_node);
1751 :
1752 33453 : gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], to[n]);
1753 :
1754 33453 : 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 33453 : cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
1760 : tmp, gfc_index_zero_node);
1761 33453 : cond = gfc_evaluate_now (cond, pre);
1762 :
1763 33453 : if (n == 0)
1764 : or_expr = cond;
1765 : else
1766 7871 : or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1767 : logical_type_node, or_expr, cond);
1768 :
1769 33453 : size = fold_build2_loc (input_location, MULT_EXPR,
1770 : gfc_array_index_type, size, tmp);
1771 33453 : size = gfc_evaluate_now (size, pre);
1772 : }
1773 : }
1774 :
1775 : /* Get the size of the array. */
1776 27617 : 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 25392 : size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
1781 : or_expr, gfc_index_zero_node, size);
1782 :
1783 25392 : nelem = size;
1784 25392 : 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 27617 : tmp = fold_convert (gfc_array_index_type, elemsize);
1795 27617 : gfc_conv_descriptor_span_set (pre, desc, tmp);
1796 :
1797 27617 : gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
1798 : dynamic, dealloc);
1799 :
1800 55269 : while (ss->parent)
1801 : ss = ss->parent;
1802 :
1803 27617 : if (ss->dimen > ss->loop->temp_dim)
1804 23894 : ss->loop->temp_dim = ss->dimen;
1805 :
1806 27617 : 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 2222 : gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
1872 : {
1873 2222 : return (i->start->expr_type != EXPR_CONSTANT
1874 1804 : || i->end->expr_type != EXPR_CONSTANT
1875 2395 : || 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 2889 : gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base)
1909 : {
1910 2889 : gfc_constructor *c;
1911 2889 : gfc_iterator *i;
1912 2889 : mpz_t val;
1913 2889 : mpz_t len;
1914 2889 : bool dynamic;
1915 :
1916 2889 : mpz_set_ui (*size, 0);
1917 2889 : mpz_init (len);
1918 2889 : mpz_init (val);
1919 :
1920 2889 : dynamic = false;
1921 7126 : for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1922 : {
1923 4237 : i = c->iterator;
1924 4237 : 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 2889 : mpz_clear (len);
1945 2889 : mpz_clear (val);
1946 2889 : return dynamic;
1947 : }
1948 :
1949 :
1950 : /* Make sure offset is a variable. */
1951 :
1952 : static void
1953 3200 : 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 3200 : gcc_assert (*offsetvar != NULL_TREE);
1959 3200 : gfc_add_modify (pblock, *offsetvar, *poffset);
1960 3200 : *poffset = *offsetvar;
1961 3200 : TREE_USED (*offsetvar) = 1;
1962 3200 : }
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 12326 : gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
1972 : tree offset, gfc_se * se, gfc_expr * expr)
1973 : {
1974 12326 : tree tmp, offset_eval;
1975 :
1976 12326 : gfc_conv_expr (se, expr);
1977 :
1978 : /* Store the value. */
1979 12326 : 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 12326 : offset_eval = gfc_evaluate_now (offset, &se->pre);
1984 12326 : tmp = gfc_build_array_ref (tmp, offset_eval, NULL);
1985 :
1986 12326 : 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 12326 : 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 10186 : else if (GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
2048 10186 : && !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 10162 : se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
2062 10162 : gfc_add_modify (&se->pre, tmp, se->expr);
2063 : }
2064 :
2065 12326 : gfc_add_block_to_block (pblock, &se->pre);
2066 12326 : gfc_add_block_to_block (pblock, &se->post);
2067 12326 : }
2068 :
2069 :
2070 : /* Add the contents of an array to the constructor. DYNAMIC is as for
2071 : gfc_trans_array_constructor_value. */
2072 :
2073 : static void
2074 1141 : gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
2075 : tree type ATTRIBUTE_UNUSED,
2076 : tree desc, gfc_expr * expr,
2077 : tree * poffset, tree * offsetvar,
2078 : bool dynamic)
2079 : {
2080 1141 : gfc_se se;
2081 1141 : gfc_ss *ss;
2082 1141 : gfc_loopinfo loop;
2083 1141 : stmtblock_t body;
2084 1141 : tree tmp;
2085 1141 : tree size;
2086 1141 : int n;
2087 :
2088 : /* We need this to be a variable so we can increment it. */
2089 1141 : gfc_put_offset_into_var (pblock, poffset, offsetvar);
2090 :
2091 1141 : gfc_init_se (&se, NULL);
2092 :
2093 : /* Walk the array expression. */
2094 1141 : ss = gfc_walk_expr (expr);
2095 1141 : gcc_assert (ss != gfc_ss_terminator);
2096 :
2097 : /* Initialize the scalarizer. */
2098 1141 : gfc_init_loopinfo (&loop);
2099 1141 : gfc_add_ss_to_loop (&loop, ss);
2100 :
2101 : /* Initialize the loop. */
2102 1141 : gfc_conv_ss_startstride (&loop);
2103 1141 : gfc_conv_loop_setup (&loop, &expr->where);
2104 :
2105 : /* Make sure the constructed array has room for the new data. */
2106 1141 : if (dynamic)
2107 : {
2108 : /* Set SIZE to the total number of elements in the subarray. */
2109 515 : size = gfc_index_one_node;
2110 1042 : for (n = 0; n < loop.dimen; n++)
2111 : {
2112 527 : tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
2113 : gfc_index_one_node);
2114 527 : size = fold_build2_loc (input_location, MULT_EXPR,
2115 : gfc_array_index_type, size, tmp);
2116 : }
2117 :
2118 : /* Grow the constructed array by SIZE elements. */
2119 515 : gfc_grow_array (&loop.pre, desc, size);
2120 : }
2121 :
2122 : /* Make the loop body. */
2123 1141 : gfc_mark_ss_chain_used (ss, 1);
2124 1141 : gfc_start_scalarized_body (&loop, &body);
2125 1141 : gfc_copy_loopinfo_to_se (&se, &loop);
2126 1141 : se.ss = ss;
2127 :
2128 1141 : gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
2129 1141 : gcc_assert (se.ss == gfc_ss_terminator);
2130 :
2131 : /* Increment the offset. */
2132 1141 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2133 : *poffset, gfc_index_one_node);
2134 1141 : gfc_add_modify (&body, *poffset, tmp);
2135 :
2136 : /* Finish the loop. */
2137 1141 : gfc_trans_scalarizing_loops (&loop, &body);
2138 1141 : gfc_add_block_to_block (&loop.pre, &loop.post);
2139 1141 : tmp = gfc_finish_block (&loop.pre);
2140 1141 : gfc_add_expr_to_block (pblock, tmp);
2141 :
2142 1141 : gfc_cleanup_loop (&loop);
2143 1141 : }
2144 :
2145 :
2146 : /* 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 7978 : 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 7978 : tree tmp;
2159 7978 : tree start = NULL_TREE;
2160 7978 : tree end = NULL_TREE;
2161 7978 : tree step = NULL_TREE;
2162 7978 : stmtblock_t body;
2163 7978 : gfc_se se;
2164 7978 : mpz_t size;
2165 7978 : gfc_constructor *c;
2166 7978 : gfc_typespec ts;
2167 7978 : int ctr = 0;
2168 :
2169 7978 : tree shadow_loopvar = NULL_TREE;
2170 7978 : gfc_saved_var saved_loopvar;
2171 :
2172 7978 : ts.type = BT_UNKNOWN;
2173 7978 : mpz_init (size);
2174 21767 : for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
2175 : {
2176 13789 : ctr++;
2177 : /* If this is an iterator or an array, the offset must be a variable. */
2178 13789 : if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
2179 2059 : 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 13789 : if (c->iterator)
2187 : {
2188 1348 : gfc_symbol *sym;
2189 1348 : 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 1348 : gfc_init_se (&se, NULL);
2196 1348 : gfc_conv_expr_val (&se, c->iterator->start);
2197 1348 : gfc_add_block_to_block (pblock, &se.pre);
2198 1348 : start = gfc_evaluate_now (se.expr, pblock);
2199 :
2200 1348 : gfc_init_se (&se, NULL);
2201 1348 : gfc_conv_expr_val (&se, c->iterator->end);
2202 1348 : gfc_add_block_to_block (pblock, &se.pre);
2203 1348 : end = gfc_evaluate_now (se.expr, pblock);
2204 :
2205 1348 : gfc_init_se (&se, NULL);
2206 1348 : gfc_conv_expr_val (&se, c->iterator->step);
2207 1348 : gfc_add_block_to_block (pblock, &se.pre);
2208 1348 : step = gfc_evaluate_now (se.expr, pblock);
2209 :
2210 1348 : sym = c->iterator->var->symtree->n.sym;
2211 1348 : type = gfc_typenode_for_spec (&sym->ts);
2212 :
2213 1348 : shadow_loopvar = gfc_create_var (type, "shadow_loopvar");
2214 1348 : gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar);
2215 : }
2216 :
2217 13789 : gfc_start_block (&body);
2218 :
2219 13789 : if (c->expr->expr_type == EXPR_ARRAY)
2220 : {
2221 : /* Array constructors can be nested. */
2222 1358 : gfc_trans_array_constructor_value (&body, finalblock, type,
2223 : desc, c->expr->value.constructor,
2224 : poffset, offsetvar, dynamic);
2225 : }
2226 12431 : else if (c->expr->rank > 0)
2227 : {
2228 1141 : 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 13095 : 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 11290 : if (n < 4 || !INTEGER_CST_P (TYPE_SIZE_UNIT (type)))
2248 : {
2249 : /* Scalar values. */
2250 11185 : gfc_init_se (&se, NULL);
2251 11185 : if (IS_PDT (c->expr) && c->expr->expr_type == EXPR_STRUCTURE)
2252 276 : c->expr->must_finalize = 1;
2253 :
2254 11185 : gfc_trans_array_ctor_element (&body, desc, *poffset,
2255 : &se, c->expr);
2256 :
2257 11185 : *poffset = fold_build2_loc (input_location, PLUS_EXPR,
2258 : gfc_array_index_type,
2259 : *poffset, gfc_index_one_node);
2260 11185 : if (finalblock)
2261 1256 : 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 11290 : if (!INTEGER_CST_P (*poffset))
2334 : {
2335 1662 : gfc_add_modify (&body, *offsetvar, *poffset);
2336 1662 : *poffset = *offsetvar;
2337 : }
2338 :
2339 11290 : if (!c->iterator)
2340 11290 : ts = c->expr->ts;
2341 : }
2342 :
2343 : /* The frontend should already have done any expansions
2344 : at compile-time. */
2345 13789 : if (!c->iterator)
2346 : {
2347 : /* Pass the code as is. */
2348 12441 : tmp = gfc_finish_block (&body);
2349 12441 : gfc_add_expr_to_block (pblock, tmp);
2350 : }
2351 : else
2352 : {
2353 : /* Build the implied do-loop. */
2354 1348 : stmtblock_t implied_do_block;
2355 1348 : tree cond;
2356 1348 : tree exit_label;
2357 1348 : tree loopbody;
2358 1348 : tree tmp2;
2359 :
2360 1348 : 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 1348 : gfc_start_block(&implied_do_block);
2365 :
2366 : /* Initialize the loop. */
2367 1348 : 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 1348 : 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 1348 : exit_label = gfc_build_label_decl (NULL_TREE);
2389 1348 : 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 1348 : tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2395 1348 : step, build_int_cst (TREE_TYPE (step), 0));
2396 1348 : 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 1348 : tmp = build1_v (GOTO_EXPR, exit_label);
2403 1348 : TREE_USED (exit_label) = 1;
2404 1348 : tmp = build3_v (COND_EXPR, cond, tmp,
2405 : build_empty_stmt (input_location));
2406 1348 : gfc_add_expr_to_block (&body, tmp);
2407 :
2408 : /* The main loop body. */
2409 1348 : gfc_add_expr_to_block (&body, loopbody);
2410 :
2411 : /* Increase loop variable by step. */
2412 1348 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
2413 1348 : TREE_TYPE (shadow_loopvar), shadow_loopvar,
2414 : step);
2415 1348 : gfc_add_modify (&body, shadow_loopvar, tmp);
2416 :
2417 : /* Finish the loop. */
2418 1348 : tmp = gfc_finish_block (&body);
2419 1348 : tmp = build1_v (LOOP_EXPR, tmp);
2420 1348 : gfc_add_expr_to_block (&implied_do_block, tmp);
2421 :
2422 : /* Add the exit label. */
2423 1348 : tmp = build1_v (LABEL_EXPR, exit_label);
2424 1348 : gfc_add_expr_to_block (&implied_do_block, tmp);
2425 :
2426 : /* Finish the implied-do loop. */
2427 1348 : tmp = gfc_finish_block(&implied_do_block);
2428 1348 : gfc_add_expr_to_block(pblock, tmp);
2429 :
2430 1348 : 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 7978 : if ((gfc_option.allow_std & (GFC_STD_F2008 | GFC_STD_F2003))
2442 7978 : && !(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 7996 : && 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 7978 : mpz_clear (size);
2466 7978 : }
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 58718 : gfc_constant_array_constructor_p (gfc_constructor_base base)
2672 : {
2673 58718 : unsigned HOST_WIDE_INT nelem = 0;
2674 :
2675 58718 : gfc_constructor *c = gfc_constructor_first (base);
2676 514946 : while (c)
2677 : {
2678 404312 : if (c->iterator
2679 402886 : || c->expr->rank > 0
2680 402076 : || c->expr->expr_type != EXPR_CONSTANT)
2681 : return 0;
2682 397510 : c = gfc_constructor_next (c);
2683 397510 : 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 41479 : gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
2695 : {
2696 41479 : tree tmptype, init, tmp;
2697 41479 : HOST_WIDE_INT nelem;
2698 41479 : gfc_constructor *c;
2699 41479 : gfc_array_spec as;
2700 41479 : gfc_se se;
2701 41479 : int i;
2702 41479 : 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 41479 : nelem = 0;
2707 41479 : c = gfc_constructor_first (expr->value.constructor);
2708 400155 : while (c)
2709 : {
2710 317197 : gfc_init_se (&se, NULL);
2711 317197 : gfc_conv_constant (&se, c->expr);
2712 317197 : if (c->expr->ts.type != BT_CHARACTER)
2713 281425 : 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 317197 : CONSTRUCTOR_APPEND_ELT (v, build_int_cst (gfc_array_index_type, nelem),
2718 : se.expr);
2719 317197 : c = gfc_constructor_next (c);
2720 317197 : 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 41479 : memset (&as, 0, sizeof (gfc_array_spec));
2728 :
2729 41479 : as.rank = expr->rank;
2730 41479 : as.type = AS_EXPLICIT;
2731 41479 : 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 89509 : for (i = 0; i < expr->rank; i++)
2739 : {
2740 48034 : int tmp = (int) mpz_get_si (expr->shape[i]);
2741 48034 : as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
2742 48034 : as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind,
2743 48034 : NULL, tmp - 1);
2744 : }
2745 :
2746 41479 : tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
2747 :
2748 : /* as is not needed anymore. */
2749 130996 : for (i = 0; i < as.rank + as.corank; i++)
2750 : {
2751 48038 : gfc_free_expr (as.lower[i]);
2752 48038 : gfc_free_expr (as.upper[i]);
2753 : }
2754 :
2755 41479 : init = build_constructor (tmptype, v);
2756 :
2757 41479 : TREE_CONSTANT (init) = 1;
2758 41479 : TREE_STATIC (init) = 1;
2759 :
2760 41479 : tmp = build_decl (input_location, VAR_DECL, create_tmp_var_name ("A"),
2761 : tmptype);
2762 41479 : DECL_ARTIFICIAL (tmp) = 1;
2763 41479 : DECL_IGNORED_P (tmp) = 1;
2764 41479 : TREE_STATIC (tmp) = 1;
2765 41479 : TREE_CONSTANT (tmp) = 1;
2766 41479 : TREE_READONLY (tmp) = 1;
2767 41479 : DECL_INITIAL (tmp) = init;
2768 41479 : pushdecl (tmp);
2769 :
2770 41479 : 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 35742 : trans_constant_array_constructor (gfc_ss * ss, tree type)
2781 : {
2782 35742 : gfc_array_info *info;
2783 35742 : tree tmp;
2784 35742 : int i;
2785 :
2786 35742 : tmp = gfc_build_constant_array_constructor (ss->info->expr, type);
2787 :
2788 35742 : info = &ss->info->data.array;
2789 :
2790 35742 : info->descriptor = tmp;
2791 35742 : info->data = gfc_build_addr_expr (NULL_TREE, tmp);
2792 35742 : info->offset = gfc_index_zero_node;
2793 :
2794 75243 : for (i = 0; i < ss->dimen; i++)
2795 : {
2796 39501 : info->delta[i] = gfc_index_zero_node;
2797 39501 : info->start[i] = gfc_index_zero_node;
2798 39501 : info->end[i] = gfc_index_zero_node;
2799 39501 : info->stride[i] = gfc_index_one_node;
2800 : }
2801 35742 : }
2802 :
2803 :
2804 : static int
2805 35748 : get_rank (gfc_loopinfo *loop)
2806 : {
2807 35748 : int rank;
2808 :
2809 35748 : rank = 0;
2810 153534 : for (; loop; loop = loop->parent)
2811 76773 : rank += loop->dimen;
2812 :
2813 41013 : 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 35748 : constant_array_constructor_loop_size (gfc_loopinfo * l)
2824 : {
2825 35748 : gfc_loopinfo *loop;
2826 35748 : tree size = gfc_index_one_node;
2827 35748 : tree tmp;
2828 35748 : int i, total_dim;
2829 :
2830 35748 : total_dim = get_rank (l);
2831 :
2832 71496 : for (loop = l; loop; loop = loop->parent)
2833 : {
2834 75267 : for (i = 0; i < loop->dimen; i++)
2835 : {
2836 : /* If the bounds aren't constant, return NULL_TREE. */
2837 39519 : if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
2838 : return NULL_TREE;
2839 39513 : 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 39513 : tmp = loop->to[i];
2850 39513 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
2851 : gfc_array_index_type, tmp, gfc_index_one_node);
2852 39513 : 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 42362 : get_loop_upper_bound_for_array (gfc_ss *array, int array_dim)
2863 : {
2864 42362 : gfc_ss *ss;
2865 42362 : int n;
2866 :
2867 42362 : gcc_assert (array->nested_ss == NULL);
2868 :
2869 42362 : for (ss = array; ss; ss = ss->parent)
2870 42362 : for (n = 0; n < ss->loop->dimen; n++)
2871 42362 : if (array_dim == get_array_ref_dim_for_loop_dim (ss, n))
2872 42362 : return &(ss->loop->to[n]);
2873 :
2874 0 : gcc_unreachable ();
2875 : }
2876 :
2877 :
2878 : static gfc_loopinfo *
2879 703064 : outermost_loop (gfc_loopinfo * loop)
2880 : {
2881 911098 : while (loop->parent != NULL)
2882 : loop = loop->parent;
2883 :
2884 703064 : 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 42362 : trans_array_constructor (gfc_ss * ss, locus * where)
2894 : {
2895 42362 : gfc_constructor_base c;
2896 42362 : tree offset;
2897 42362 : tree offsetvar;
2898 42362 : tree desc;
2899 42362 : tree type;
2900 42362 : tree tmp;
2901 42362 : tree *loop_ubound0;
2902 42362 : bool dynamic;
2903 42362 : bool old_first_len, old_typespec_chararray_ctor;
2904 42362 : tree old_first_len_val;
2905 42362 : gfc_loopinfo *loop, *outer_loop;
2906 42362 : gfc_ss_info *ss_info;
2907 42362 : gfc_expr *expr;
2908 42362 : gfc_ss *s;
2909 42362 : tree neg_len;
2910 42362 : char *msg;
2911 42362 : stmtblock_t finalblock;
2912 42362 : bool finalize_required;
2913 :
2914 : /* Save the old values for nested checking. */
2915 42362 : old_first_len = first_len;
2916 42362 : old_first_len_val = first_len_val;
2917 42362 : old_typespec_chararray_ctor = typespec_chararray_ctor;
2918 :
2919 42362 : loop = ss->loop;
2920 42362 : outer_loop = outermost_loop (loop);
2921 42362 : ss_info = ss->info;
2922 42362 : 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 84724 : typespec_chararray_ctor = (expr->ts.type == BT_CHARACTER
2927 8142 : && expr->ts.u.cl
2928 50504 : && expr->ts.u.cl->length_from_typespec);
2929 :
2930 42362 : 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 42362 : gcc_assert (ss->dimen == ss->loop->dimen);
2938 :
2939 42362 : c = expr->value.constructor;
2940 42362 : 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 34245 : 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 42362 : dynamic = false;
3025 :
3026 42362 : loop_ubound0 = get_loop_upper_bound_for_array (ss, 0);
3027 :
3028 83375 : 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 42362 : 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 41513 : unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
3070 41513 : if (nelem > 0)
3071 : {
3072 35748 : tree size = constant_array_constructor_loop_size (loop);
3073 35748 : if (size && compare_tree_int (size, nelem) == 0)
3074 : {
3075 35742 : trans_constant_array_constructor (ss, type);
3076 35742 : goto finish;
3077 : }
3078 : }
3079 : }
3080 :
3081 6620 : gfc_trans_create_temp_array (&outer_loop->pre, &outer_loop->post, ss, type,
3082 : NULL_TREE, dynamic, true, false, where);
3083 :
3084 6620 : desc = ss_info->data.array.descriptor;
3085 6620 : offset = gfc_index_zero_node;
3086 6620 : offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
3087 6620 : suppress_warning (offsetvar);
3088 6620 : TREE_USED (offsetvar) = 0;
3089 :
3090 6620 : gfc_init_block (&finalblock);
3091 6620 : finalize_required = expr->must_finalize;
3092 6620 : if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
3093 : finalize_required = true;
3094 :
3095 6620 : if (IS_PDT (expr))
3096 : finalize_required = true;
3097 :
3098 7074 : 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 6620 : 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 6620 : if (TREE_USED (offsetvar))
3118 2059 : pushdecl (offsetvar);
3119 : else
3120 4561 : 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 4561 : finish:
3131 : /* Restore old values of globals. */
3132 42362 : first_len = old_first_len;
3133 42362 : first_len_val = old_first_len_val;
3134 42362 : 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 42362 : if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
3141 1670 : && finalblock.head != NULL_TREE)
3142 84 : gfc_prepend_expr_to_block (&loop->post, finalblock.head);
3143 42362 : }
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 180168 : set_vector_loop_bounds (gfc_ss * ss)
3153 : {
3154 180168 : gfc_loopinfo *loop, *outer_loop;
3155 180168 : gfc_array_info *info;
3156 180168 : gfc_se se;
3157 180168 : tree tmp;
3158 180168 : tree desc;
3159 180168 : tree zero;
3160 180168 : int n;
3161 180168 : int dim;
3162 :
3163 180168 : outer_loop = outermost_loop (ss->loop);
3164 :
3165 180168 : info = &ss->info->data.array;
3166 :
3167 364972 : for (; ss; ss = ss->parent)
3168 : {
3169 184804 : loop = ss->loop;
3170 :
3171 440617 : for (n = 0; n < loop->dimen; n++)
3172 : {
3173 255813 : dim = ss->dim[n];
3174 255813 : if (info->ref->u.ar.dimen_type[dim] != DIMEN_VECTOR
3175 980 : || loop->to[n] != NULL)
3176 255633 : 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 180 : gcc_assert (loop->from[n] == gfc_index_zero_node);
3182 180 : gcc_assert (info->subscript[dim]
3183 : && info->subscript[dim]->info->type == GFC_SS_VECTOR);
3184 :
3185 180 : gfc_init_se (&se, NULL);
3186 180 : desc = info->subscript[dim]->info->data.array.descriptor;
3187 180 : zero = gfc_rank_cst[0];
3188 180 : 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 180 : tmp = gfc_evaluate_now (tmp, &outer_loop->pre);
3193 180 : loop->to[n] = tmp;
3194 : }
3195 : }
3196 180168 : }
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 45336 : gfc_scalar_elemental_arg_saved_as_reference (gfc_ss_info * ss_info)
3204 : {
3205 45336 : if (ss_info->type != GFC_SS_REFERENCE)
3206 : return false;
3207 :
3208 10282 : 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 9906 : 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 9230 : 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 9354 : && 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 9206 : if (!ss_info->data.scalar.needs_temporary
3229 9206 : && (ss_info->expr->ts.type == BT_DERIVED
3230 8230 : || ss_info->expr->ts.type == BT_CLASS)
3231 10230 : && 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 189689 : gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
3246 : locus * where)
3247 : {
3248 189689 : gfc_loopinfo *nested_loop, *outer_loop;
3249 189689 : gfc_se se;
3250 189689 : gfc_ss_info *ss_info;
3251 189689 : gfc_array_info *info;
3252 189689 : gfc_expr *expr;
3253 189689 : 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 189689 : if (ss->is_alloc_lhs)
3258 203 : return;
3259 :
3260 499335 : 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 499335 : for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
3267 : {
3268 309849 : gcc_assert (ss);
3269 :
3270 : /* Cross loop arrays are handled from within the most nested loop. */
3271 309849 : if (ss->nested_ss != NULL)
3272 4740 : continue;
3273 :
3274 305109 : ss_info = ss->info;
3275 305109 : expr = ss_info->expr;
3276 305109 : info = &ss_info->data.array;
3277 :
3278 305109 : switch (ss_info->type)
3279 : {
3280 43093 : case GFC_SS_SCALAR:
3281 : /* Scalar expression. Evaluate this now. This includes elemental
3282 : dimension indices, but not array section bounds. */
3283 43093 : gfc_init_se (&se, NULL);
3284 43093 : gfc_conv_expr (&se, expr);
3285 43093 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3286 :
3287 43093 : if (expr->ts.type != BT_CHARACTER
3288 43093 : && !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 39099 : if (subscript)
3293 6368 : se.expr = convert(gfc_array_index_type, se.expr);
3294 39099 : if (!ss_info->where)
3295 38685 : se.expr = gfc_evaluate_now (se.expr, &outer_loop->pre);
3296 39099 : gfc_add_block_to_block (&outer_loop->pre, &se.post);
3297 : }
3298 : else
3299 3994 : gfc_add_block_to_block (&outer_loop->post, &se.post);
3300 :
3301 43093 : ss_info->data.scalar.value = se.expr;
3302 43093 : ss_info->string_length = se.string_length;
3303 43093 : break;
3304 :
3305 5141 : case GFC_SS_REFERENCE:
3306 : /* Scalar argument to elemental procedure. */
3307 5141 : gfc_init_se (&se, NULL);
3308 5141 : if (gfc_scalar_elemental_arg_saved_as_reference (ss_info))
3309 838 : 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 4303 : gfc_conv_expr (&se, expr);
3315 : }
3316 :
3317 : /* Ensure that a pointer to the string is stored. */
3318 5141 : if (expr->ts.type == BT_CHARACTER)
3319 174 : gfc_conv_string_parameter (&se);
3320 :
3321 5141 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3322 5141 : gfc_add_block_to_block (&outer_loop->post, &se.post);
3323 5141 : 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 5093 : ss_info->data.scalar.value = gfc_evaluate_now (se.expr,
3333 : &outer_loop->pre);
3334 :
3335 5141 : ss_info->string_length = se.string_length;
3336 5141 : break;
3337 :
3338 : case GFC_SS_SECTION:
3339 : /* Add the expressions for scalar and vector subscripts. */
3340 2882688 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
3341 2702520 : if (info->subscript[n])
3342 7348 : gfc_add_loop_ss_code (loop, info->subscript[n], true, where);
3343 :
3344 180168 : set_vector_loop_bounds (ss);
3345 180168 : break;
3346 :
3347 980 : case GFC_SS_VECTOR:
3348 : /* Get the vector's descriptor and store it in SS. */
3349 980 : gfc_init_se (&se, NULL);
3350 980 : gfc_conv_expr_descriptor (&se, expr);
3351 980 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3352 980 : gfc_add_block_to_block (&outer_loop->post, &se.post);
3353 980 : info->descriptor = se.expr;
3354 980 : break;
3355 :
3356 11533 : case GFC_SS_INTRINSIC:
3357 11533 : gfc_add_intrinsic_ss_code (loop, ss);
3358 11533 : break;
3359 :
3360 9558 : case GFC_SS_FUNCTION:
3361 9558 : {
3362 : /* Array function return value. We call the function and save its
3363 : result in a temporary for use inside the loop. */
3364 9558 : gfc_init_se (&se, NULL);
3365 9558 : se.loop = loop;
3366 9558 : se.ss = ss;
3367 9558 : bool class_func = gfc_is_class_array_function (expr);
3368 9558 : if (class_func)
3369 183 : expr->must_finalize = 1;
3370 9558 : gfc_conv_expr (&se, expr);
3371 9558 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3372 9558 : if (class_func
3373 183 : && se.expr
3374 9741 : && 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 9558 : gfc_add_block_to_block (&outer_loop->post, &se.post);
3403 9558 : gfc_add_block_to_block (&outer_loop->post, &se.finalblock);
3404 9558 : ss_info->string_length = se.string_length;
3405 : }
3406 9558 : break;
3407 :
3408 42362 : case GFC_SS_CONSTRUCTOR:
3409 42362 : 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 42362 : trans_array_constructor (ss, where);
3423 42362 : 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 189486 : if (!subscript)
3436 185502 : 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 128170 : save_descriptor_data (tree descr, tree data)
3449 : {
3450 128170 : return !(DECL_P (data)
3451 117430 : || (TREE_CODE (data) == ADDR_EXPR
3452 69573 : && DECL_P (TREE_OPERAND (data, 0)))
3453 50926 : || (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (descr))
3454 47465 : && TREE_CODE (descr) == COMPONENT_REF
3455 10736 : && 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 20913 : maybe_substitute_expr (tree *tp, int *walk_subtree, void *data)
3475 : {
3476 20913 : substitute_t *subst = (substitute_t *) data;
3477 20913 : if (*tp == subst->target)
3478 : {
3479 3979 : *tp = subst->repl;
3480 3979 : *walk_subtree = 0;
3481 : }
3482 :
3483 20913 : return NULL_TREE;
3484 : }
3485 :
3486 :
3487 : /* Substitute in EXPR any occurence of TARGET with REPLACEMENT. */
3488 :
3489 : static void
3490 3672 : substitute_subexpr_in_expr (tree target, tree replacement, tree expr)
3491 : {
3492 3672 : substitute_t subst;
3493 3672 : subst.target = target;
3494 3672 : subst.repl = replacement;
3495 :
3496 3672 : walk_tree (&expr, maybe_substitute_expr, &subst, nullptr);
3497 3672 : }
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 3500 : save_ref (tree &code, tree &ref, vec<tree> &replacement_roots)
3506 : {
3507 3500 : stmtblock_t tmp_block;
3508 3500 : gfc_init_block (&tmp_block);
3509 3500 : tree var = gfc_evaluate_now (ref, &tmp_block);
3510 3500 : gfc_add_expr_to_block (&tmp_block, code);
3511 3500 : code = gfc_finish_block (&tmp_block);
3512 :
3513 3500 : unsigned i;
3514 3500 : tree repl_root;
3515 7172 : FOR_EACH_VEC_ELT (replacement_roots, i, repl_root)
3516 3672 : substitute_subexpr_in_expr (ref, var, repl_root);
3517 :
3518 3500 : replacement_roots.safe_push (ref);
3519 3500 : ref = NULL_TREE;
3520 3500 : }
3521 :
3522 :
3523 : /* If REF isn't shared with code in PREVIOUS_CODE, replace it with a fresh
3524 : variable in all of REPLACEMENT_ROOTS, appending extra code to CODE. */
3525 :
3526 : static void
3527 3572 : maybe_save_ref (tree &code, tree &ref, vec<tree> &replacement_roots,
3528 : stmtblock_t *previous_code)
3529 : {
3530 3572 : if (find_tree (previous_code->head, ref))
3531 : return;
3532 :
3533 3500 : save_ref (code, ref, replacement_roots);
3534 : }
3535 :
3536 :
3537 : /* Save the descriptor reference VALUE to storage pointed by DESC_PTR. Before
3538 : that, try to create fresh variables to factor subexpressions of VALUE, if
3539 : those subexpressions aren't shared with code in PRELIMINARY_CODE. Add any
3540 : necessary additional code (initialization of variables typically) to BLOCK.
3541 :
3542 : The candidate references to factoring are dereferenced pointers because they
3543 : are cheap to copy and array descriptors because they are often the base of
3544 : multiple subreferences. */
3545 :
3546 : static void
3547 322993 : set_factored_descriptor_value (tree *desc_ptr, tree value, stmtblock_t *block,
3548 : stmtblock_t *preliminary_code)
3549 : {
3550 : /* As the reference is processed from outer to inner, variable definitions
3551 : will be generated in reversed order, so can't be put directly in BLOCK.
3552 : We use temporary blocks instead, which we save in ACCUMULATED_CODE, and
3553 : only append to BLOCK at the end. */
3554 322993 : tree accumulated_code = NULL_TREE;
3555 :
3556 : /* The current candidate to factoring. */
3557 322993 : tree saveable_ref = NULL_TREE;
3558 :
3559 : /* The root expressions in which we look for subexpressions to replace with
3560 : variables. */
3561 322993 : auto_vec<tree> replacement_roots;
3562 322993 : replacement_roots.safe_push (value);
3563 :
3564 322993 : tree data_ref = value;
3565 322993 : tree next_ref = NULL_TREE;
3566 :
3567 : /* If the candidate reference is not followed by a subreference, it can't be
3568 : saved to a variable as it may be reallocatable, and we have to keep the
3569 : parent reference to be able to store the new pointer value in case of
3570 : reallocation. */
3571 322993 : bool maybe_reallocatable = true;
3572 :
3573 428587 : while (true)
3574 : {
3575 428587 : if (!maybe_reallocatable
3576 428587 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (data_ref)))
3577 2389 : saveable_ref = data_ref;
3578 :
3579 428587 : if (TREE_CODE (data_ref) == INDIRECT_REF)
3580 : {
3581 56960 : next_ref = TREE_OPERAND (data_ref, 0);
3582 :
3583 56960 : if (!maybe_reallocatable)
3584 : {
3585 14264 : if (saveable_ref != NULL_TREE && saveable_ref != data_ref)
3586 : {
3587 : /* A reference worth saving has been seen, and now the pointer
3588 : to the current reference is also worth saving. If the
3589 : previous reference to save wasn't the current one, do save
3590 : it now. Otherwise drop it as we prefer saving the
3591 : pointer. */
3592 1755 : maybe_save_ref (accumulated_code, saveable_ref,
3593 : replacement_roots, preliminary_code);
3594 : }
3595 :
3596 : /* Don't evaluate the pointer to a variable yet; do it only if the
3597 : variable would be significantly more simple than the reference
3598 : it replaces. That is if the reference contains anything
3599 : different from NOPs, COMPONENTs and DECLs. */
3600 14264 : saveable_ref = next_ref;
3601 : }
3602 : }
3603 371627 : else if (TREE_CODE (data_ref) == COMPONENT_REF)
3604 : {
3605 39700 : maybe_reallocatable = false;
3606 39700 : next_ref = TREE_OPERAND (data_ref, 0);
3607 : }
3608 331927 : else if (TREE_CODE (data_ref) == NOP_EXPR)
3609 3630 : next_ref = TREE_OPERAND (data_ref, 0);
3610 : else
3611 : {
3612 328297 : if (DECL_P (data_ref))
3613 : break;
3614 :
3615 6835 : if (TREE_CODE (data_ref) == ARRAY_REF)
3616 : {
3617 5304 : maybe_reallocatable = false;
3618 5304 : next_ref = TREE_OPERAND (data_ref, 0);
3619 : }
3620 :
3621 6835 : if (saveable_ref != NULL_TREE)
3622 : /* We have seen a reference worth saving. Do it now. */
3623 1817 : maybe_save_ref (accumulated_code, saveable_ref, replacement_roots,
3624 : preliminary_code);
3625 :
3626 6835 : if (TREE_CODE (data_ref) != ARRAY_REF)
3627 : break;
3628 : }
3629 :
3630 : data_ref = next_ref;
3631 : }
3632 :
3633 322993 : *desc_ptr = value;
3634 322993 : gfc_add_expr_to_block (block, accumulated_code);
3635 322993 : }
3636 :
3637 :
3638 : /* Translate expressions for the descriptor and data pointer of a SS. */
3639 : /*GCC ARRAYS*/
3640 :
3641 : static void
3642 322993 : gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
3643 : {
3644 322993 : gfc_se se;
3645 322993 : gfc_ss_info *ss_info;
3646 322993 : gfc_array_info *info;
3647 322993 : tree tmp;
3648 :
3649 322993 : ss_info = ss->info;
3650 322993 : info = &ss_info->data.array;
3651 :
3652 : /* Get the descriptor for the array to be scalarized. */
3653 322993 : gcc_assert (ss_info->expr->expr_type == EXPR_VARIABLE);
3654 322993 : gfc_init_se (&se, NULL);
3655 322993 : se.descriptor_only = 1;
3656 322993 : gfc_conv_expr_lhs (&se, ss_info->expr);
3657 322993 : stmtblock_t tmp_block;
3658 322993 : gfc_init_block (&tmp_block);
3659 322993 : set_factored_descriptor_value (&info->descriptor, se.expr, &tmp_block,
3660 : &se.pre);
3661 322993 : gfc_add_block_to_block (block, &se.pre);
3662 322993 : gfc_add_block_to_block (block, &tmp_block);
3663 322993 : ss_info->string_length = se.string_length;
3664 322993 : ss_info->class_container = se.class_container;
3665 :
3666 322993 : if (base)
3667 : {
3668 121647 : if (ss_info->expr->ts.type == BT_CHARACTER && !ss_info->expr->ts.deferred
3669 22732 : && ss_info->expr->ts.u.cl->length == NULL)
3670 : {
3671 : /* Emit a DECL_EXPR for the variable sized array type in
3672 : GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
3673 : sizes works correctly. */
3674 1097 : tree arraytype = TREE_TYPE (
3675 : GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (info->descriptor)));
3676 1097 : if (! TYPE_NAME (arraytype))
3677 899 : TYPE_NAME (arraytype) = build_decl (UNKNOWN_LOCATION, TYPE_DECL,
3678 : NULL_TREE, arraytype);
3679 1097 : gfc_add_expr_to_block (block, build1 (DECL_EXPR, arraytype,
3680 1097 : TYPE_NAME (arraytype)));
3681 : }
3682 : /* Also the data pointer. */
3683 121647 : tmp = gfc_conv_array_data (se.expr);
3684 : /* If this is a variable or address or a class array, use it directly.
3685 : Otherwise we must evaluate it now to avoid breaking dependency
3686 : analysis by pulling the expressions for elemental array indices
3687 : inside the loop. */
3688 121647 : if (save_descriptor_data (se.expr, tmp) && !ss->is_alloc_lhs)
3689 35886 : tmp = gfc_evaluate_now (tmp, block);
3690 121647 : info->data = tmp;
3691 :
3692 121647 : tmp = gfc_conv_array_offset (se.expr);
3693 121647 : if (!ss->is_alloc_lhs)
3694 115327 : tmp = gfc_evaluate_now (tmp, block);
3695 121647 : info->offset = tmp;
3696 :
3697 : /* Make absolutely sure that the saved_offset is indeed saved
3698 : so that the variable is still accessible after the loops
3699 : are translated. */
3700 121647 : info->saved_offset = info->offset;
3701 : }
3702 322993 : }
3703 :
3704 :
3705 : /* Initialize a gfc_loopinfo structure. */
3706 :
3707 : void
3708 188517 : gfc_init_loopinfo (gfc_loopinfo * loop)
3709 : {
3710 188517 : int n;
3711 :
3712 188517 : memset (loop, 0, sizeof (gfc_loopinfo));
3713 188517 : gfc_init_block (&loop->pre);
3714 188517 : gfc_init_block (&loop->post);
3715 :
3716 : /* Initially scalarize in order and default to no loop reversal. */
3717 3204789 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
3718 : {
3719 2827755 : loop->order[n] = n;
3720 2827755 : loop->reverse[n] = GFC_INHIBIT_REVERSE;
3721 : }
3722 :
3723 188517 : loop->ss = gfc_ss_terminator;
3724 188517 : }
3725 :
3726 :
3727 : /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
3728 : chain. */
3729 :
3730 : void
3731 188659 : gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
3732 : {
3733 188659 : se->loop = loop;
3734 188659 : }
3735 :
3736 :
3737 : /* Return an expression for the data pointer of an array. */
3738 :
3739 : tree
3740 330574 : gfc_conv_array_data (tree descriptor)
3741 : {
3742 330574 : tree type;
3743 :
3744 330574 : type = TREE_TYPE (descriptor);
3745 330574 : if (GFC_ARRAY_TYPE_P (type))
3746 : {
3747 232379 : if (TREE_CODE (type) == POINTER_TYPE)
3748 : return descriptor;
3749 : else
3750 : {
3751 : /* Descriptorless arrays. */
3752 174911 : return gfc_build_addr_expr (NULL_TREE, descriptor);
3753 : }
3754 : }
3755 : else
3756 98195 : return gfc_conv_descriptor_data_get (descriptor);
3757 : }
3758 :
3759 :
3760 : /* Return an expression for the base offset of an array. */
3761 :
3762 : tree
3763 245795 : gfc_conv_array_offset (tree descriptor)
3764 : {
3765 245795 : tree type;
3766 :
3767 245795 : type = TREE_TYPE (descriptor);
3768 245795 : if (GFC_ARRAY_TYPE_P (type))
3769 175391 : return GFC_TYPE_ARRAY_OFFSET (type);
3770 : else
3771 70404 : return gfc_conv_descriptor_offset_get (descriptor);
3772 : }
3773 :
3774 :
3775 : /* Get an expression for the array stride. */
3776 :
3777 : tree
3778 491228 : gfc_conv_array_stride (tree descriptor, int dim)
3779 : {
3780 491228 : tree tmp;
3781 491228 : tree type;
3782 :
3783 491228 : type = TREE_TYPE (descriptor);
3784 :
3785 : /* For descriptorless arrays use the array size. */
3786 491228 : tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
3787 491228 : if (tmp != NULL_TREE)
3788 : return tmp;
3789 :
3790 112723 : tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]);
3791 112723 : return tmp;
3792 : }
3793 :
3794 :
3795 : /* Like gfc_conv_array_stride, but for the lower bound. */
3796 :
3797 : tree
3798 317194 : gfc_conv_array_lbound (tree descriptor, int dim)
3799 : {
3800 317194 : tree tmp;
3801 317194 : tree type;
3802 :
3803 317194 : type = TREE_TYPE (descriptor);
3804 :
3805 317194 : tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
3806 317194 : if (tmp != NULL_TREE)
3807 : return tmp;
3808 :
3809 18525 : tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]);
3810 18525 : return tmp;
3811 : }
3812 :
3813 :
3814 : /* Like gfc_conv_array_stride, but for the upper bound. */
3815 :
3816 : tree
3817 205485 : gfc_conv_array_ubound (tree descriptor, int dim)
3818 : {
3819 205485 : tree tmp;
3820 205485 : tree type;
3821 :
3822 205485 : type = TREE_TYPE (descriptor);
3823 :
3824 205485 : tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
3825 205485 : if (tmp != NULL_TREE)
3826 : return tmp;
3827 :
3828 : /* This should only ever happen when passing an assumed shape array
3829 : as an actual parameter. The value will never be used. */
3830 7979 : if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
3831 554 : return gfc_index_zero_node;
3832 :
3833 7425 : tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]);
3834 7425 : return tmp;
3835 : }
3836 :
3837 :
3838 : /* Generate abridged name of a part-ref for use in bounds-check message.
3839 : Cases:
3840 : (1) for an ordinary array variable x return "x"
3841 : (2) for z a DT scalar and array component x (at level 1) return "z%%x"
3842 : (3) for z a DT scalar and array component x (at level > 1) or
3843 : for z a DT array and array x (at any number of levels): "z...%%x"
3844 : */
3845 :
3846 : static char *
3847 36477 : abridged_ref_name (gfc_expr * expr, gfc_array_ref * ar)
3848 : {
3849 36477 : gfc_ref *ref;
3850 36477 : gfc_symbol *sym;
3851 36477 : char *ref_name = NULL;
3852 36477 : const char *comp_name = NULL;
3853 36477 : int len_sym, last_len = 0, level = 0;
3854 36477 : bool sym_is_array;
3855 :
3856 36477 : gcc_assert (expr->expr_type == EXPR_VARIABLE && expr->ref != NULL);
3857 :
3858 36477 : sym = expr->symtree->n.sym;
3859 72585 : sym_is_array = (sym->ts.type != BT_CLASS
3860 36477 : ? sym->as != NULL
3861 369 : : IS_CLASS_ARRAY (sym));
3862 36477 : len_sym = strlen (sym->name);
3863 :
3864 : /* Scan ref chain to get name of the array component (when ar != NULL) or
3865 : array section, determine depth and remember its component name. */
3866 51919 : for (ref = expr->ref; ref; ref = ref->next)
3867 : {
3868 37848 : if (ref->type == REF_COMPONENT
3869 982 : && strcmp (ref->u.c.component->name, "_data") != 0)
3870 : {
3871 852 : level++;
3872 852 : comp_name = ref->u.c.component->name;
3873 852 : continue;
3874 : }
3875 :
3876 36996 : if (ref->type != REF_ARRAY)
3877 150 : continue;
3878 :
3879 36846 : if (ar)
3880 : {
3881 15861 : if (&ref->u.ar == ar)
3882 : break;
3883 : }
3884 20985 : else if (ref->u.ar.type == AR_SECTION)
3885 : break;
3886 : }
3887 :
3888 36477 : if (level > 0)
3889 746 : last_len = strlen (comp_name);
3890 :
3891 : /* Provide a buffer sufficiently large to hold "x...%%z". */
3892 36477 : ref_name = XNEWVEC (char, len_sym + last_len + 6);
3893 36477 : strcpy (ref_name, sym->name);
3894 :
3895 36477 : if (level == 1 && !sym_is_array)
3896 : {
3897 400 : strcat (ref_name, "%%");
3898 400 : strcat (ref_name, comp_name);
3899 : }
3900 36077 : else if (level > 0)
3901 : {
3902 346 : strcat (ref_name, "...%%");
3903 346 : strcat (ref_name, comp_name);
3904 : }
3905 :
3906 36477 : return ref_name;
3907 : }
3908 :
3909 :
3910 : /* Generate code to perform an array index bound check. */
3911 :
3912 : static tree
3913 5633 : trans_array_bound_check (gfc_se * se, gfc_ss *ss, tree index, int n,
3914 : locus * where, bool check_upper,
3915 : const char *compname = NULL)
3916 : {
3917 5633 : tree fault;
3918 5633 : tree tmp_lo, tmp_up;
3919 5633 : tree descriptor;
3920 5633 : char *msg;
3921 5633 : char *ref_name = NULL;
3922 5633 : const char * name = NULL;
3923 5633 : gfc_expr *expr;
3924 :
3925 5633 : if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
3926 : return index;
3927 :
3928 240 : descriptor = ss->info->data.array.descriptor;
3929 :
3930 240 : index = gfc_evaluate_now (index, &se->pre);
3931 :
3932 : /* We find a name for the error message. */
3933 240 : name = ss->info->expr->symtree->n.sym->name;
3934 240 : gcc_assert (name != NULL);
3935 :
3936 : /* When we have a component ref, get name of the array section.
3937 : Note that there can only be one part ref. */
3938 240 : expr = ss->info->expr;
3939 240 : if (expr->ref && !compname)
3940 160 : name = ref_name = abridged_ref_name (expr, NULL);
3941 :
3942 240 : if (VAR_P (descriptor))
3943 162 : name = IDENTIFIER_POINTER (DECL_NAME (descriptor));
3944 :
3945 : /* Use given (array component) name. */
3946 240 : if (compname)
3947 80 : name = compname;
3948 :
3949 : /* If upper bound is present, include both bounds in the error message. */
3950 240 : if (check_upper)
3951 : {
3952 213 : tmp_lo = gfc_conv_array_lbound (descriptor, n);
3953 213 : tmp_up = gfc_conv_array_ubound (descriptor, n);
3954 :
3955 213 : if (name)
3956 213 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3957 : "outside of expected range (%%ld:%%ld)", n+1, name);
3958 : else
3959 0 : msg = xasprintf ("Index '%%ld' of dimension %d "
3960 : "outside of expected range (%%ld:%%ld)", n+1);
3961 :
3962 213 : fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3963 : index, tmp_lo);
3964 213 : gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
3965 : fold_convert (long_integer_type_node, index),
3966 : fold_convert (long_integer_type_node, tmp_lo),
3967 : fold_convert (long_integer_type_node, tmp_up));
3968 213 : fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3969 : index, tmp_up);
3970 213 : gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
3971 : fold_convert (long_integer_type_node, index),
3972 : fold_convert (long_integer_type_node, tmp_lo),
3973 : fold_convert (long_integer_type_node, tmp_up));
3974 213 : free (msg);
3975 : }
3976 : else
3977 : {
3978 27 : tmp_lo = gfc_conv_array_lbound (descriptor, n);
3979 :
3980 27 : if (name)
3981 27 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3982 : "below lower bound of %%ld", n+1, name);
3983 : else
3984 0 : msg = xasprintf ("Index '%%ld' of dimension %d "
3985 : "below lower bound of %%ld", n+1);
3986 :
3987 27 : fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3988 : index, tmp_lo);
3989 27 : gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
3990 : fold_convert (long_integer_type_node, index),
3991 : fold_convert (long_integer_type_node, tmp_lo));
3992 27 : free (msg);
3993 : }
3994 :
3995 240 : free (ref_name);
3996 240 : return index;
3997 : }
3998 :
3999 :
4000 : /* Helper functions to detect impure functions in an expression. */
4001 :
4002 : static const char *impure_name = NULL;
4003 : static bool
4004 96 : expr_contains_impure_fcn (gfc_expr *e, gfc_symbol* sym ATTRIBUTE_UNUSED,
4005 : int* g ATTRIBUTE_UNUSED)
4006 : {
4007 96 : if (e && e->expr_type == EXPR_FUNCTION
4008 6 : && !gfc_pure_function (e, &impure_name)
4009 99 : && !gfc_implicit_pure_function (e))
4010 : return true;
4011 :
4012 : return false;
4013 : }
4014 :
4015 : static bool
4016 80 : gfc_expr_contains_impure_fcn (gfc_expr *e)
4017 : {
4018 80 : impure_name = NULL;
4019 80 : return gfc_traverse_expr (e, NULL, &expr_contains_impure_fcn, 0);
4020 : }
4021 :
4022 :
4023 : /* Generate code for bounds checking for elemental dimensions. */
4024 :
4025 : static void
4026 6674 : array_bound_check_elemental (gfc_se * se, gfc_ss * ss, gfc_expr * expr)
4027 : {
4028 6674 : gfc_array_ref *ar;
4029 6674 : gfc_ref *ref;
4030 6674 : char *var_name = NULL;
4031 6674 : int dim;
4032 :
4033 6674 : if (expr->expr_type == EXPR_VARIABLE)
4034 : {
4035 12481 : for (ref = expr->ref; ref; ref = ref->next)
4036 : {
4037 6265 : if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
4038 : {
4039 3941 : ar = &ref->u.ar;
4040 3941 : var_name = abridged_ref_name (expr, ar);
4041 8122 : for (dim = 0; dim < ar->dimen; dim++)
4042 : {
4043 4181 : if (ar->dimen_type[dim] == DIMEN_ELEMENT)
4044 : {
4045 80 : if (gfc_expr_contains_impure_fcn (ar->start[dim]))
4046 3 : gfc_warning_now (0, "Bounds checking of the elemental "
4047 : "index at %L will cause two calls to "
4048 : "%qs, which is not declared to be "
4049 : "PURE or is not implicitly pure.",
4050 3 : &ar->start[dim]->where, impure_name);
4051 80 : gfc_se indexse;
4052 80 : gfc_init_se (&indexse, NULL);
4053 80 : gfc_conv_expr_type (&indexse, ar->start[dim],
4054 : gfc_array_index_type);
4055 80 : gfc_add_block_to_block (&se->pre, &indexse.pre);
4056 80 : trans_array_bound_check (se, ss, indexse.expr, dim,
4057 : &ar->where,
4058 80 : ar->as->type != AS_ASSUMED_SIZE
4059 80 : || dim < ar->dimen - 1,
4060 : var_name);
4061 : }
4062 : }
4063 3941 : free (var_name);
4064 : }
4065 : }
4066 : }
4067 6674 : }
4068 :
4069 :
4070 : /* Return the offset for an index. Performs bound checking for elemental
4071 : dimensions. Single element references are processed separately.
4072 : DIM is the array dimension, I is the loop dimension. */
4073 :
4074 : static tree
4075 251363 : conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i,
4076 : gfc_array_ref * ar, tree stride)
4077 : {
4078 251363 : gfc_array_info *info;
4079 251363 : tree index;
4080 251363 : tree desc;
4081 251363 : tree data;
4082 :
4083 251363 : info = &ss->info->data.array;
4084 :
4085 : /* Get the index into the array for this dimension. */
4086 251363 : if (ar)
4087 : {
4088 178865 : gcc_assert (ar->type != AR_ELEMENT);
4089 178865 : switch (ar->dimen_type[dim])
4090 : {
4091 0 : case DIMEN_THIS_IMAGE:
4092 0 : gcc_unreachable ();
4093 4576 : break;
4094 4576 : case DIMEN_ELEMENT:
4095 : /* Elemental dimension. */
4096 4576 : gcc_assert (info->subscript[dim]
4097 : && info->subscript[dim]->info->type == GFC_SS_SCALAR);
4098 : /* We've already translated this value outside the loop. */
4099 4576 : index = info->subscript[dim]->info->data.scalar.value;
4100 :
4101 9152 : index = trans_array_bound_check (se, ss, index, dim, &ar->where,
4102 4576 : ar->as->type != AS_ASSUMED_SIZE
4103 4576 : || dim < ar->dimen - 1);
4104 4576 : break;
4105 :
4106 977 : case DIMEN_VECTOR:
4107 977 : gcc_assert (info && se->loop);
4108 977 : gcc_assert (info->subscript[dim]
4109 : && info->subscript[dim]->info->type == GFC_SS_VECTOR);
4110 977 : desc = info->subscript[dim]->info->data.array.descriptor;
4111 :
4112 : /* Get a zero-based index into the vector. */
4113 977 : index = fold_build2_loc (input_location, MINUS_EXPR,
4114 : gfc_array_index_type,
4115 : se->loop->loopvar[i], se->loop->from[i]);
4116 :
4117 : /* Multiply the index by the stride. */
4118 977 : index = fold_build2_loc (input_location, MULT_EXPR,
4119 : gfc_array_index_type,
4120 : index, gfc_conv_array_stride (desc, 0));
4121 :
4122 : /* Read the vector to get an index into info->descriptor. */
4123 977 : data = build_fold_indirect_ref_loc (input_location,
4124 : gfc_conv_array_data (desc));
4125 977 : index = gfc_build_array_ref (data, index, NULL);
4126 977 : index = gfc_evaluate_now (index, &se->pre);
4127 977 : index = fold_convert (gfc_array_index_type, index);
4128 :
4129 : /* Do any bounds checking on the final info->descriptor index. */
4130 1954 : index = trans_array_bound_check (se, ss, index, dim, &ar->where,
4131 977 : ar->as->type != AS_ASSUMED_SIZE
4132 977 : || dim < ar->dimen - 1);
4133 977 : break;
4134 :
4135 173312 : case DIMEN_RANGE:
4136 : /* Scalarized dimension. */
4137 173312 : gcc_assert (info && se->loop);
4138 :
4139 : /* Multiply the loop variable by the stride and delta. */
4140 173312 : index = se->loop->loopvar[i];
4141 173312 : if (!integer_onep (info->stride[dim]))
4142 6906 : index = fold_build2_loc (input_location, MULT_EXPR,
4143 : gfc_array_index_type, index,
4144 : info->stride[dim]);
4145 173312 : if (!integer_zerop (info->delta[dim]))
4146 66548 : index = fold_build2_loc (input_location, PLUS_EXPR,
4147 : gfc_array_index_type, index,
4148 : info->delta[dim]);
4149 : break;
4150 :
4151 0 : default:
4152 0 : gcc_unreachable ();
4153 : }
4154 : }
4155 : else
4156 : {
4157 : /* Temporary array or derived type component. */
4158 72498 : gcc_assert (se->loop);
4159 72498 : index = se->loop->loopvar[se->loop->order[i]];
4160 :
4161 : /* Pointer functions can have stride[0] different from unity.
4162 : Use the stride returned by the function call and stored in
4163 : the descriptor for the temporary. */
4164 72498 : if (se->ss && se->ss->info->type == GFC_SS_FUNCTION
4165 8020 : && se->ss->info->expr
4166 8020 : && se->ss->info->expr->symtree
4167 8020 : && se->ss->info->expr->symtree->n.sym->result
4168 7580 : && se->ss->info->expr->symtree->n.sym->result->attr.pointer)
4169 144 : stride = gfc_conv_descriptor_stride_get (info->descriptor,
4170 : gfc_rank_cst[dim]);
4171 :
4172 72498 : if (info->delta[dim] && !integer_zerop (info->delta[dim]))
4173 798 : index = fold_build2_loc (input_location, PLUS_EXPR,
4174 : gfc_array_index_type, index, info->delta[dim]);
4175 : }
4176 :
4177 : /* Multiply by the stride. */
4178 251363 : if (stride != NULL && !integer_onep (stride))
4179 76834 : index = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4180 : index, stride);
4181 :
4182 251363 : return index;
4183 : }
4184 :
4185 :
4186 : /* Build a scalarized array reference using the vptr 'size'. */
4187 :
4188 : static bool
4189 192044 : build_class_array_ref (gfc_se *se, tree base, tree index)
4190 : {
4191 192044 : tree size;
4192 192044 : tree decl = NULL_TREE;
4193 192044 : tree tmp;
4194 192044 : gfc_expr *expr = se->ss->info->expr;
4195 192044 : gfc_expr *class_expr;
4196 192044 : gfc_typespec *ts;
4197 192044 : gfc_symbol *sym;
4198 :
4199 192044 : tmp = !VAR_P (base) ? gfc_get_class_from_expr (base) : NULL_TREE;
4200 :
4201 89534 : if (tmp != NULL_TREE)
4202 : decl = tmp;
4203 : else
4204 : {
4205 : /* The base expression does not contain a class component, either
4206 : because it is a temporary array or array descriptor. Class
4207 : array functions are correctly resolved above. */
4208 188701 : if (!expr
4209 188701 : || (expr->ts.type != BT_CLASS
4210 175093 : && !gfc_is_class_array_ref (expr, NULL)))
4211 188266 : return false;
4212 :
4213 : /* Obtain the expression for the class entity or component that is
4214 : followed by an array reference, which is not an element, so that
4215 : the span of the array can be obtained. */
4216 435 : class_expr = gfc_find_and_cut_at_last_class_ref (expr, false, &ts);
4217 :
4218 435 : if (!ts)
4219 : return false;
4220 :
4221 410 : sym = (!class_expr && expr) ? expr->symtree->n.sym : NULL;
4222 0 : if (sym && sym->attr.function
4223 0 : && sym == sym->result
4224 0 : && sym->backend_decl == current_function_decl)
4225 : /* The temporary is the data field of the class data component
4226 : of the current function. */
4227 0 : decl = gfc_get_fake_result_decl (sym, 0);
4228 410 : else if (sym)
4229 : {
4230 0 : if (decl == NULL_TREE)
4231 0 : decl = expr->symtree->n.sym->backend_decl;
4232 : /* For class arrays the tree containing the class is stored in
4233 : GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl.
4234 : For all others it's sym's backend_decl directly. */
4235 0 : if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl))
4236 0 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
4237 : }
4238 : else
4239 410 : decl = gfc_get_class_from_gfc_expr (class_expr);
4240 :
4241 410 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
4242 0 : decl = build_fold_indirect_ref_loc (input_location, decl);
4243 :
4244 410 : if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl)))
4245 : return false;
4246 : }
4247 :
4248 3753 : se->class_vptr = gfc_evaluate_now (gfc_class_vptr_get (decl), &se->pre);
4249 :
4250 3753 : size = gfc_class_vtab_size_get (decl);
4251 : /* For unlimited polymorphic entities then _len component needs to be
4252 : multiplied with the size. */
4253 3753 : size = gfc_resize_class_size_with_len (&se->pre, decl, size);
4254 3753 : size = fold_convert (TREE_TYPE (index), size);
4255 :
4256 : /* Return the element in the se expression. */
4257 3753 : se->expr = gfc_build_spanned_array_ref (base, index, size);
4258 3753 : return true;
4259 : }
4260 :
4261 :
4262 : /* Indicates that the tree EXPR is a reference to an array that can’t
4263 : have any negative stride. */
4264 :
4265 : static bool
4266 310410 : non_negative_strides_array_p (tree expr)
4267 : {
4268 323222 : if (expr == NULL_TREE)
4269 : return false;
4270 :
4271 323222 : tree type = TREE_TYPE (expr);
4272 323222 : if (POINTER_TYPE_P (type))
4273 70500 : type = TREE_TYPE (type);
4274 :
4275 323222 : if (TYPE_LANG_SPECIFIC (type))
4276 : {
4277 323222 : gfc_array_kind array_kind = GFC_TYPE_ARRAY_AKIND (type);
4278 :
4279 323222 : if (array_kind == GFC_ARRAY_ALLOCATABLE
4280 323222 : || array_kind == GFC_ARRAY_ASSUMED_SHAPE_CONT)
4281 : return true;
4282 : }
4283 :
4284 : /* An array with descriptor can have negative strides.
4285 : We try to be conservative and return false by default here
4286 : if we don’t recognize a contiguous array instead of
4287 : returning false if we can identify a non-contiguous one. */
4288 266779 : if (!GFC_ARRAY_TYPE_P (type))
4289 : return false;
4290 :
4291 : /* If the array was originally a dummy with a descriptor, strides can be
4292 : negative. */
4293 233620 : if (DECL_P (expr)
4294 224783 : && DECL_LANG_SPECIFIC (expr)
4295 47361 : && GFC_DECL_SAVED_DESCRIPTOR (expr)
4296 246451 : && GFC_DECL_SAVED_DESCRIPTOR (expr) != expr)
4297 12812 : return non_negative_strides_array_p (GFC_DECL_SAVED_DESCRIPTOR (expr));
4298 :
4299 : return true;
4300 : }
4301 :
4302 :
4303 : /* Build a scalarized reference to an array. */
4304 :
4305 : static void
4306 192044 : gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar,
4307 : bool tmp_array = false)
4308 : {
4309 192044 : gfc_array_info *info;
4310 192044 : tree decl = NULL_TREE;
4311 192044 : tree index;
4312 192044 : tree base;
4313 192044 : gfc_ss *ss;
4314 192044 : gfc_expr *expr;
4315 192044 : int n;
4316 :
4317 192044 : ss = se->ss;
4318 192044 : expr = ss->info->expr;
4319 192044 : info = &ss->info->data.array;
4320 192044 : if (ar)
4321 131629 : n = se->loop->order[0];
4322 : else
4323 : n = 0;
4324 :
4325 192044 : index = conv_array_index_offset (se, ss, ss->dim[n], n, ar, info->stride0);
4326 : /* Add the offset for this dimension to the stored offset for all other
4327 : dimensions. */
4328 192044 : if (info->offset && !integer_zerop (info->offset))
4329 141254 : index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4330 : index, info->offset);
4331 :
4332 192044 : base = build_fold_indirect_ref_loc (input_location, info->data);
4333 :
4334 : /* Use the vptr 'size' field to access the element of a class array. */
4335 192044 : if (build_class_array_ref (se, base, index))
4336 3753 : return;
4337 :
4338 188291 : if (get_CFI_desc (NULL, expr, &decl, ar))
4339 442 : decl = build_fold_indirect_ref_loc (input_location, decl);
4340 :
4341 : /* A pointer array component can be detected from its field decl. Fix
4342 : the descriptor, mark the resulting variable decl and pass it to
4343 : gfc_build_array_ref. */
4344 188291 : if (is_pointer_array (info->descriptor)
4345 188291 : || (expr && expr->ts.deferred && info->descriptor
4346 2913 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info->descriptor))))
4347 : {
4348 9017 : if (TREE_CODE (info->descriptor) == COMPONENT_REF)
4349 1492 : decl = info->descriptor;
4350 7525 : else if (INDIRECT_REF_P (info->descriptor))
4351 1485 : decl = TREE_OPERAND (info->descriptor, 0);
4352 :
4353 9017 : if (decl == NULL_TREE)
4354 6040 : decl = info->descriptor;
4355 : }
4356 :
4357 188291 : bool non_negative_stride = tmp_array
4358 188291 : || non_negative_strides_array_p (info->descriptor);
4359 188291 : se->expr = gfc_build_array_ref (base, index, decl,
4360 : non_negative_stride);
4361 : }
4362 :
4363 :
4364 : /* Translate access of temporary array. */
4365 :
4366 : void
4367 60415 : gfc_conv_tmp_array_ref (gfc_se * se)
4368 : {
4369 60415 : se->string_length = se->ss->info->string_length;
4370 60415 : gfc_conv_scalarized_array_ref (se, NULL, true);
4371 60415 : gfc_advance_se_ss_chain (se);
4372 60415 : }
4373 :
4374 : /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
4375 :
4376 : static void
4377 272831 : add_to_offset (tree *cst_offset, tree *offset, tree t)
4378 : {
4379 272831 : if (TREE_CODE (t) == INTEGER_CST)
4380 138068 : *cst_offset = int_const_binop (PLUS_EXPR, *cst_offset, t);
4381 : else
4382 : {
4383 134763 : if (!integer_zerop (*offset))
4384 47282 : *offset = fold_build2_loc (input_location, PLUS_EXPR,
4385 : gfc_array_index_type, *offset, t);
4386 : else
4387 87481 : *offset = t;
4388 : }
4389 272831 : }
4390 :
4391 :
4392 : static tree
4393 182140 : build_array_ref (tree desc, tree offset, tree decl, tree vptr)
4394 : {
4395 182140 : tree tmp;
4396 182140 : tree type;
4397 182140 : tree cdesc;
4398 :
4399 : /* For class arrays the class declaration is stored in the saved
4400 : descriptor. */
4401 182140 : if (INDIRECT_REF_P (desc)
4402 7322 : && DECL_LANG_SPECIFIC (TREE_OPERAND (desc, 0))
4403 184450 : && GFC_DECL_SAVED_DESCRIPTOR (TREE_OPERAND (desc, 0)))
4404 875 : cdesc = gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (
4405 : TREE_OPERAND (desc, 0)));
4406 : else
4407 : cdesc = desc;
4408 :
4409 : /* Class container types do not always have the GFC_CLASS_TYPE_P
4410 : but the canonical type does. */
4411 182140 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdesc))
4412 182140 : && TREE_CODE (cdesc) == COMPONENT_REF)
4413 : {
4414 11055 : type = TREE_TYPE (TREE_OPERAND (cdesc, 0));
4415 11055 : if (TYPE_CANONICAL (type)
4416 11055 : && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type)))
4417 3413 : vptr = gfc_class_vptr_get (TREE_OPERAND (cdesc, 0));
4418 : }
4419 :
4420 182140 : tmp = gfc_conv_array_data (desc);
4421 182140 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
4422 182140 : tmp = gfc_build_array_ref (tmp, offset, decl,
4423 182140 : non_negative_strides_array_p (desc),
4424 : vptr);
4425 182140 : return tmp;
4426 : }
4427 :
4428 :
4429 : /* Build an array reference. se->expr already holds the array descriptor.
4430 : This should be either a variable, indirect variable reference or component
4431 : reference. For arrays which do not have a descriptor, se->expr will be
4432 : the data pointer.
4433 : a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
4434 :
4435 : void
4436 259203 : gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
4437 : locus * where)
4438 : {
4439 259203 : int n;
4440 259203 : tree offset, cst_offset;
4441 259203 : tree tmp;
4442 259203 : tree stride;
4443 259203 : tree decl = NULL_TREE;
4444 259203 : gfc_se indexse;
4445 259203 : gfc_se tmpse;
4446 259203 : gfc_symbol * sym = expr->symtree->n.sym;
4447 259203 : char *var_name = NULL;
4448 :
4449 259203 : if (ar->stat)
4450 : {
4451 3 : gfc_se statse;
4452 :
4453 3 : gfc_init_se (&statse, NULL);
4454 3 : gfc_conv_expr_lhs (&statse, ar->stat);
4455 3 : gfc_add_block_to_block (&se->pre, &statse.pre);
4456 3 : gfc_add_modify (&se->pre, statse.expr, integer_zero_node);
4457 : }
4458 259203 : if (ar->dimen == 0)
4459 : {
4460 4481 : gcc_assert (ar->codimen || sym->attr.select_rank_temporary
4461 : || (ar->as && ar->as->corank));
4462 :
4463 4481 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
4464 949 : se->expr = build_fold_indirect_ref (gfc_conv_array_data (se->expr));
4465 : else
4466 : {
4467 3532 : if (GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr))
4468 3532 : && TREE_CODE (TREE_TYPE (se->expr)) == POINTER_TYPE)
4469 2593 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
4470 :
4471 : /* Use the actual tree type and not the wrapped coarray. */
4472 3532 : if (!se->want_pointer)
4473 2563 : se->expr = fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se->expr)),
4474 : se->expr);
4475 : }
4476 :
4477 136110 : return;
4478 : }
4479 :
4480 : /* Handle scalarized references separately. */
4481 254722 : if (ar->type != AR_ELEMENT)
4482 : {
4483 131629 : gfc_conv_scalarized_array_ref (se, ar);
4484 131629 : gfc_advance_se_ss_chain (se);
4485 131629 : return;
4486 : }
4487 :
4488 123093 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
4489 11757 : var_name = abridged_ref_name (expr, ar);
4490 :
4491 123093 : decl = se->expr;
4492 123093 : if (UNLIMITED_POLY(sym)
4493 104 : && IS_CLASS_ARRAY (sym)
4494 103 : && sym->attr.dummy
4495 60 : && ar->as->type != AS_DEFERRED)
4496 48 : decl = sym->backend_decl;
4497 :
4498 123093 : cst_offset = offset = gfc_index_zero_node;
4499 123093 : add_to_offset (&cst_offset, &offset, gfc_conv_array_offset (decl));
4500 :
4501 : /* Calculate the offsets from all the dimensions. Make sure to associate
4502 : the final offset so that we form a chain of loop invariant summands. */
4503 272831 : for (n = ar->dimen - 1; n >= 0; n--)
4504 : {
4505 : /* Calculate the index for this dimension. */
4506 149738 : gfc_init_se (&indexse, se);
4507 149738 : gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
4508 149738 : gfc_add_block_to_block (&se->pre, &indexse.pre);
4509 :
4510 149738 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && ! expr->no_bounds_check)
4511 : {
4512 : /* Check array bounds. */
4513 15299 : tree cond;
4514 15299 : char *msg;
4515 :
4516 : /* Evaluate the indexse.expr only once. */
4517 15299 : indexse.expr = save_expr (indexse.expr);
4518 :
4519 : /* Lower bound. */
4520 15299 : tmp = gfc_conv_array_lbound (decl, n);
4521 15299 : if (sym->attr.temporary)
4522 : {
4523 18 : gfc_init_se (&tmpse, se);
4524 18 : gfc_conv_expr_type (&tmpse, ar->as->lower[n],
4525 : gfc_array_index_type);
4526 18 : gfc_add_block_to_block (&se->pre, &tmpse.pre);
4527 18 : tmp = tmpse.expr;
4528 : }
4529 :
4530 15299 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
4531 : indexse.expr, tmp);
4532 15299 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4533 : "below lower bound of %%ld", n+1, var_name);
4534 15299 : gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
4535 : fold_convert (long_integer_type_node,
4536 : indexse.expr),
4537 : fold_convert (long_integer_type_node, tmp));
4538 15299 : free (msg);
4539 :
4540 : /* Upper bound, but not for the last dimension of assumed-size
4541 : arrays. */
4542 15299 : if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE)
4543 : {
4544 13566 : tmp = gfc_conv_array_ubound (decl, n);
4545 13566 : if (sym->attr.temporary)
4546 : {
4547 18 : gfc_init_se (&tmpse, se);
4548 18 : gfc_conv_expr_type (&tmpse, ar->as->upper[n],
4549 : gfc_array_index_type);
4550 18 : gfc_add_block_to_block (&se->pre, &tmpse.pre);
4551 18 : tmp = tmpse.expr;
4552 : }
4553 :
4554 13566 : cond = fold_build2_loc (input_location, GT_EXPR,
4555 : logical_type_node, indexse.expr, tmp);
4556 13566 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4557 : "above upper bound of %%ld", n+1, var_name);
4558 13566 : gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
4559 : fold_convert (long_integer_type_node,
4560 : indexse.expr),
4561 : fold_convert (long_integer_type_node, tmp));
4562 13566 : free (msg);
4563 : }
4564 : }
4565 :
4566 : /* Multiply the index by the stride. */
4567 149738 : stride = gfc_conv_array_stride (decl, n);
4568 149738 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4569 : indexse.expr, stride);
4570 :
4571 : /* And add it to the total. */
4572 149738 : add_to_offset (&cst_offset, &offset, tmp);
4573 : }
4574 :
4575 123093 : if (!integer_zerop (cst_offset))
4576 65945 : offset = fold_build2_loc (input_location, PLUS_EXPR,
4577 : gfc_array_index_type, offset, cst_offset);
4578 :
4579 : /* A pointer array component can be detected from its field decl. Fix
4580 : the descriptor, mark the resulting variable decl and pass it to
4581 : build_array_ref. */
4582 123093 : decl = NULL_TREE;
4583 123093 : if (get_CFI_desc (sym, expr, &decl, ar))
4584 3589 : decl = build_fold_indirect_ref_loc (input_location, decl);
4585 122046 : if (!expr->ts.deferred && !sym->attr.codimension
4586 242917 : && is_pointer_array (se->expr))
4587 : {
4588 4879 : if (TREE_CODE (se->expr) == COMPONENT_REF)
4589 1454 : decl = se->expr;
4590 3425 : else if (INDIRECT_REF_P (se->expr))
4591 983 : decl = TREE_OPERAND (se->expr, 0);
4592 : else
4593 2442 : decl = se->expr;
4594 : }
4595 118214 : else if (expr->ts.deferred
4596 117167 : || (sym->ts.type == BT_CHARACTER
4597 15275 : && sym->attr.select_type_temporary))
4598 : {
4599 2751 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
4600 : {
4601 2595 : decl = se->expr;
4602 2595 : if (INDIRECT_REF_P (decl))
4603 20 : decl = TREE_OPERAND (decl, 0);
4604 : }
4605 : else
4606 156 : decl = sym->backend_decl;
4607 : }
4608 115463 : else if (sym->ts.type == BT_CLASS)
4609 : {
4610 2187 : if (UNLIMITED_POLY (sym))
4611 : {
4612 104 : gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr);
4613 104 : gfc_init_se (&tmpse, NULL);
4614 104 : gfc_conv_expr (&tmpse, class_expr);
4615 104 : if (!se->class_vptr)
4616 104 : se->class_vptr = gfc_class_vptr_get (tmpse.expr);
4617 104 : gfc_free_expr (class_expr);
4618 104 : decl = tmpse.expr;
4619 104 : }
4620 : else
4621 2083 : decl = NULL_TREE;
4622 : }
4623 :
4624 123093 : free (var_name);
4625 123093 : se->expr = build_array_ref (se->expr, offset, decl, se->class_vptr);
4626 : }
4627 :
4628 :
4629 : /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
4630 : LOOP_DIM dimension (if any) to array's offset. */
4631 :
4632 : static void
4633 59319 : add_array_offset (stmtblock_t *pblock, gfc_loopinfo *loop, gfc_ss *ss,
4634 : gfc_array_ref *ar, int array_dim, int loop_dim)
4635 : {
4636 59319 : gfc_se se;
4637 59319 : gfc_array_info *info;
4638 59319 : tree stride, index;
4639 :
4640 59319 : info = &ss->info->data.array;
4641 :
4642 59319 : gfc_init_se (&se, NULL);
4643 59319 : se.loop = loop;
4644 59319 : se.expr = info->descriptor;
4645 59319 : stride = gfc_conv_array_stride (info->descriptor, array_dim);
4646 59319 : index = conv_array_index_offset (&se, ss, array_dim, loop_dim, ar, stride);
4647 59319 : gfc_add_block_to_block (pblock, &se.pre);
4648 :
4649 59319 : info->offset = fold_build2_loc (input_location, PLUS_EXPR,
4650 : gfc_array_index_type,
4651 : info->offset, index);
4652 59319 : info->offset = gfc_evaluate_now (info->offset, pblock);
4653 59319 : }
4654 :
4655 :
4656 : /* Generate the code to be executed immediately before entering a
4657 : scalarization loop. */
4658 :
4659 : static void
4660 145463 : gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
4661 : stmtblock_t * pblock)
4662 : {
4663 145463 : tree stride;
4664 145463 : gfc_ss_info *ss_info;
4665 145463 : gfc_array_info *info;
4666 145463 : gfc_ss_type ss_type;
4667 145463 : gfc_ss *ss, *pss;
4668 145463 : gfc_loopinfo *ploop;
4669 145463 : gfc_array_ref *ar;
4670 :
4671 : /* This code will be executed before entering the scalarization loop
4672 : for this dimension. */
4673 443422 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4674 : {
4675 297959 : ss_info = ss->info;
4676 :
4677 297959 : if ((ss_info->useflags & flag) == 0)
4678 1476 : continue;
4679 :
4680 296483 : ss_type = ss_info->type;
4681 361919 : if (ss_type != GFC_SS_SECTION
4682 : && ss_type != GFC_SS_FUNCTION
4683 296483 : && ss_type != GFC_SS_CONSTRUCTOR
4684 296483 : && ss_type != GFC_SS_COMPONENT)
4685 65436 : continue;
4686 :
4687 231047 : info = &ss_info->data.array;
4688 :
4689 231047 : gcc_assert (dim < ss->dimen);
4690 231047 : gcc_assert (ss->dimen == loop->dimen);
4691 :
4692 231047 : if (info->ref)
4693 163138 : ar = &info->ref->u.ar;
4694 : else
4695 : ar = NULL;
4696 :
4697 231047 : if (dim == loop->dimen - 1 && loop->parent != NULL)
4698 : {
4699 : /* If we are in the outermost dimension of this loop, the previous
4700 : dimension shall be in the parent loop. */
4701 4687 : gcc_assert (ss->parent != NULL);
4702 :
4703 4687 : pss = ss->parent;
4704 4687 : ploop = loop->parent;
4705 :
4706 : /* ss and ss->parent are about the same array. */
4707 4687 : gcc_assert (ss_info == pss->info);
4708 : }
4709 : else
4710 : {
4711 : ploop = loop;
4712 : pss = ss;
4713 : }
4714 :
4715 231047 : if (dim == loop->dimen - 1 && loop->parent == NULL)
4716 : {
4717 176304 : gcc_assert (0 == ploop->order[0]);
4718 :
4719 352608 : stride = gfc_conv_array_stride (info->descriptor,
4720 176304 : innermost_ss (ss)->dim[0]);
4721 :
4722 : /* Calculate the stride of the innermost loop. Hopefully this will
4723 : allow the backend optimizers to do their stuff more effectively.
4724 : */
4725 176304 : info->stride0 = gfc_evaluate_now (stride, pblock);
4726 :
4727 : /* For the outermost loop calculate the offset due to any
4728 : elemental dimensions. It will have been initialized with the
4729 : base offset of the array. */
4730 176304 : if (info->ref)
4731 : {
4732 285818 : for (int i = 0; i < ar->dimen; i++)
4733 : {
4734 165340 : if (ar->dimen_type[i] != DIMEN_ELEMENT)
4735 160764 : continue;
4736 :
4737 4576 : add_array_offset (pblock, loop, ss, ar, i, /* unused */ -1);
4738 : }
4739 : }
4740 : }
4741 : else
4742 : {
4743 54743 : int i;
4744 :
4745 54743 : if (dim == loop->dimen - 1)
4746 : i = 0;
4747 : else
4748 50056 : i = dim + 1;
4749 :
4750 : /* For the time being, there is no loop reordering. */
4751 54743 : gcc_assert (i == ploop->order[i]);
4752 54743 : i = ploop->order[i];
4753 :
4754 : /* Add the offset for the previous loop dimension. */
4755 54743 : add_array_offset (pblock, ploop, ss, ar, pss->dim[i], i);
4756 : }
4757 :
4758 : /* Remember this offset for the second loop. */
4759 231047 : if (dim == loop->temp_dim - 1 && loop->parent == NULL)
4760 53866 : info->saved_offset = info->offset;
4761 : }
4762 145463 : }
4763 :
4764 :
4765 : /* Start a scalarized expression. Creates a scope and declares loop
4766 : variables. */
4767 :
4768 : void
4769 115183 : gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
4770 : {
4771 115183 : int dim;
4772 115183 : int n;
4773 115183 : int flags;
4774 :
4775 115183 : gcc_assert (!loop->array_parameter);
4776 :
4777 259066 : for (dim = loop->dimen - 1; dim >= 0; dim--)
4778 : {
4779 143883 : n = loop->order[dim];
4780 :
4781 143883 : gfc_start_block (&loop->code[n]);
4782 :
4783 : /* Create the loop variable. */
4784 143883 : loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
4785 :
4786 143883 : if (dim < loop->temp_dim)
4787 : flags = 3;
4788 : else
4789 98275 : flags = 1;
4790 : /* Calculate values that will be constant within this loop. */
4791 143883 : gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
4792 : }
4793 115183 : gfc_start_block (pbody);
4794 115183 : }
4795 :
4796 :
4797 : /* Generates the actual loop code for a scalarization loop. */
4798 :
4799 : static void
4800 159229 : gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
4801 : stmtblock_t * pbody)
4802 : {
4803 159229 : stmtblock_t block;
4804 159229 : tree cond;
4805 159229 : tree tmp;
4806 159229 : tree loopbody;
4807 159229 : tree exit_label;
4808 159229 : tree stmt;
4809 159229 : tree init;
4810 159229 : tree incr;
4811 :
4812 159229 : if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS
4813 : | OMPWS_SCALARIZER_BODY))
4814 : == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS)
4815 108 : && n == loop->dimen - 1)
4816 : {
4817 : /* We create an OMP_FOR construct for the outermost scalarized loop. */
4818 80 : init = make_tree_vec (1);
4819 80 : cond = make_tree_vec (1);
4820 80 : incr = make_tree_vec (1);
4821 :
4822 : /* Cycle statement is implemented with a goto. Exit statement must not
4823 : be present for this loop. */
4824 80 : exit_label = gfc_build_label_decl (NULL_TREE);
4825 80 : TREE_USED (exit_label) = 1;
4826 :
4827 : /* Label for cycle statements (if needed). */
4828 80 : tmp = build1_v (LABEL_EXPR, exit_label);
4829 80 : gfc_add_expr_to_block (pbody, tmp);
4830 :
4831 80 : stmt = make_node (OMP_FOR);
4832 :
4833 80 : TREE_TYPE (stmt) = void_type_node;
4834 80 : OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody);
4835 :
4836 80 : OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location,
4837 : OMP_CLAUSE_SCHEDULE);
4838 80 : OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt))
4839 80 : = OMP_CLAUSE_SCHEDULE_STATIC;
4840 80 : if (ompws_flags & OMPWS_NOWAIT)
4841 33 : OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt))
4842 66 : = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT);
4843 :
4844 : /* Initialize the loopvar. */
4845 80 : TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n],
4846 : loop->from[n]);
4847 80 : OMP_FOR_INIT (stmt) = init;
4848 : /* The exit condition. */
4849 80 : TREE_VEC_ELT (cond, 0) = build2_loc (input_location, LE_EXPR,
4850 : logical_type_node,
4851 : loop->loopvar[n], loop->to[n]);
4852 80 : SET_EXPR_LOCATION (TREE_VEC_ELT (cond, 0), input_location);
4853 80 : OMP_FOR_COND (stmt) = cond;
4854 : /* Increment the loopvar. */
4855 80 : tmp = build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4856 : loop->loopvar[n], gfc_index_one_node);
4857 80 : TREE_VEC_ELT (incr, 0) = fold_build2_loc (input_location, MODIFY_EXPR,
4858 : void_type_node, loop->loopvar[n], tmp);
4859 80 : OMP_FOR_INCR (stmt) = incr;
4860 :
4861 80 : ompws_flags &= ~OMPWS_CURR_SINGLEUNIT;
4862 80 : gfc_add_expr_to_block (&loop->code[n], stmt);
4863 : }
4864 : else
4865 : {
4866 318298 : bool reverse_loop = (loop->reverse[n] == GFC_REVERSE_SET)
4867 159149 : && (loop->temp_ss == NULL);
4868 :
4869 159149 : loopbody = gfc_finish_block (pbody);
4870 :
4871 159149 : if (reverse_loop)
4872 204 : std::swap (loop->from[n], loop->to[n]);
4873 :
4874 : /* Initialize the loopvar. */
4875 159149 : if (loop->loopvar[n] != loop->from[n])
4876 158328 : gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
4877 :
4878 159149 : exit_label = gfc_build_label_decl (NULL_TREE);
4879 :
4880 : /* Generate the loop body. */
4881 159149 : gfc_init_block (&block);
4882 :
4883 : /* The exit condition. */
4884 318094 : cond = fold_build2_loc (input_location, reverse_loop ? LT_EXPR : GT_EXPR,
4885 : logical_type_node, loop->loopvar[n], loop->to[n]);
4886 159149 : tmp = build1_v (GOTO_EXPR, exit_label);
4887 159149 : TREE_USED (exit_label) = 1;
4888 159149 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
4889 159149 : gfc_add_expr_to_block (&block, tmp);
4890 :
4891 : /* The main body. */
4892 159149 : gfc_add_expr_to_block (&block, loopbody);
4893 :
4894 : /* Increment the loopvar. */
4895 318094 : tmp = fold_build2_loc (input_location,
4896 : reverse_loop ? MINUS_EXPR : PLUS_EXPR,
4897 : gfc_array_index_type, loop->loopvar[n],
4898 : gfc_index_one_node);
4899 :
4900 159149 : gfc_add_modify (&block, loop->loopvar[n], tmp);
4901 :
4902 : /* Build the loop. */
4903 159149 : tmp = gfc_finish_block (&block);
4904 159149 : tmp = build1_v (LOOP_EXPR, tmp);
4905 159149 : gfc_add_expr_to_block (&loop->code[n], tmp);
4906 :
4907 : /* Add the exit label. */
4908 159149 : tmp = build1_v (LABEL_EXPR, exit_label);
4909 159149 : gfc_add_expr_to_block (&loop->code[n], tmp);
4910 : }
4911 :
4912 159229 : }
4913 :
4914 :
4915 : /* Finishes and generates the loops for a scalarized expression. */
4916 :
4917 : void
4918 120773 : gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
4919 : {
4920 120773 : int dim;
4921 120773 : int n;
4922 120773 : gfc_ss *ss;
4923 120773 : stmtblock_t *pblock;
4924 120773 : tree tmp;
4925 :
4926 120773 : pblock = body;
4927 : /* Generate the loops. */
4928 270237 : for (dim = 0; dim < loop->dimen; dim++)
4929 : {
4930 149464 : n = loop->order[dim];
4931 149464 : gfc_trans_scalarized_loop_end (loop, n, pblock);
4932 149464 : loop->loopvar[n] = NULL_TREE;
4933 149464 : pblock = &loop->code[n];
4934 : }
4935 :
4936 120773 : tmp = gfc_finish_block (pblock);
4937 120773 : gfc_add_expr_to_block (&loop->pre, tmp);
4938 :
4939 : /* Clear all the used flags. */
4940 354428 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4941 233655 : if (ss->parent == NULL)
4942 228905 : ss->info->useflags = 0;
4943 120773 : }
4944 :
4945 :
4946 : /* Finish the main body of a scalarized expression, and start the secondary
4947 : copying body. */
4948 :
4949 : void
4950 8185 : gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
4951 : {
4952 8185 : int dim;
4953 8185 : int n;
4954 8185 : stmtblock_t *pblock;
4955 8185 : gfc_ss *ss;
4956 :
4957 8185 : pblock = body;
4958 : /* We finish as many loops as are used by the temporary. */
4959 9765 : for (dim = 0; dim < loop->temp_dim - 1; dim++)
4960 : {
4961 1580 : n = loop->order[dim];
4962 1580 : gfc_trans_scalarized_loop_end (loop, n, pblock);
4963 1580 : loop->loopvar[n] = NULL_TREE;
4964 1580 : pblock = &loop->code[n];
4965 : }
4966 :
4967 : /* We don't want to finish the outermost loop entirely. */
4968 8185 : n = loop->order[loop->temp_dim - 1];
4969 8185 : gfc_trans_scalarized_loop_end (loop, n, pblock);
4970 :
4971 : /* Restore the initial offsets. */
4972 23427 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4973 : {
4974 15242 : gfc_ss_type ss_type;
4975 15242 : gfc_ss_info *ss_info;
4976 :
4977 15242 : ss_info = ss->info;
4978 :
4979 15242 : if ((ss_info->useflags & 2) == 0)
4980 4514 : continue;
4981 :
4982 10728 : ss_type = ss_info->type;
4983 10882 : if (ss_type != GFC_SS_SECTION
4984 : && ss_type != GFC_SS_FUNCTION
4985 10728 : && ss_type != GFC_SS_CONSTRUCTOR
4986 10728 : && ss_type != GFC_SS_COMPONENT)
4987 154 : continue;
4988 :
4989 10574 : ss_info->data.array.offset = ss_info->data.array.saved_offset;
4990 : }
4991 :
4992 : /* Restart all the inner loops we just finished. */
4993 9765 : for (dim = loop->temp_dim - 2; dim >= 0; dim--)
4994 : {
4995 1580 : n = loop->order[dim];
4996 :
4997 1580 : gfc_start_block (&loop->code[n]);
4998 :
4999 1580 : loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
5000 :
5001 1580 : gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
5002 : }
5003 :
5004 : /* Start a block for the secondary copying code. */
5005 8185 : gfc_start_block (body);
5006 8185 : }
5007 :
5008 :
5009 : /* Precalculate (either lower or upper) bound of an array section.
5010 : BLOCK: Block in which the (pre)calculation code will go.
5011 : BOUNDS[DIM]: Where the bound value will be stored once evaluated.
5012 : VALUES[DIM]: Specified bound (NULL <=> unspecified).
5013 : DESC: Array descriptor from which the bound will be picked if unspecified
5014 : (either lower or upper bound according to LBOUND). */
5015 :
5016 : static void
5017 512600 : evaluate_bound (stmtblock_t *block, tree *bounds, gfc_expr ** values,
5018 : tree desc, int dim, bool lbound, bool deferred, bool save_value)
5019 : {
5020 512600 : gfc_se se;
5021 512600 : gfc_expr * input_val = values[dim];
5022 512600 : tree *output = &bounds[dim];
5023 :
5024 512600 : if (input_val)
5025 : {
5026 : /* Specified section bound. */
5027 47544 : gfc_init_se (&se, NULL);
5028 47544 : gfc_conv_expr_type (&se, input_val, gfc_array_index_type);
5029 47544 : gfc_add_block_to_block (block, &se.pre);
5030 47544 : *output = se.expr;
5031 : }
5032 465056 : else if (deferred && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
5033 : {
5034 : /* The gfc_conv_array_lbound () routine returns a constant zero for
5035 : deferred length arrays, which in the scalarizer wreaks havoc, when
5036 : copying to a (newly allocated) one-based array.
5037 : Keep returning the actual result in sync for both bounds. */
5038 189725 : *output = lbound ? gfc_conv_descriptor_lbound_get (desc,
5039 : gfc_rank_cst[dim]):
5040 63349 : gfc_conv_descriptor_ubound_get (desc,
5041 : gfc_rank_cst[dim]);
5042 : }
5043 : else
5044 : {
5045 : /* No specific bound specified so use the bound of the array. */
5046 504630 : *output = lbound ? gfc_conv_array_lbound (desc, dim) :
5047 165950 : gfc_conv_array_ubound (desc, dim);
5048 : }
5049 512600 : if (save_value)
5050 493748 : *output = gfc_evaluate_now (*output, block);
5051 512600 : }
5052 :
5053 :
5054 : /* Calculate the lower bound of an array section. */
5055 :
5056 : static void
5057 256933 : gfc_conv_section_startstride (stmtblock_t * block, gfc_ss * ss, int dim)
5058 : {
5059 256933 : gfc_expr *stride = NULL;
5060 256933 : tree desc;
5061 256933 : gfc_se se;
5062 256933 : gfc_array_info *info;
5063 256933 : gfc_array_ref *ar;
5064 :
5065 256933 : gcc_assert (ss->info->type == GFC_SS_SECTION);
5066 :
5067 256933 : info = &ss->info->data.array;
5068 256933 : ar = &info->ref->u.ar;
5069 :
5070 256933 : if (ar->dimen_type[dim] == DIMEN_VECTOR)
5071 : {
5072 : /* We use a zero-based index to access the vector. */
5073 980 : info->start[dim] = gfc_index_zero_node;
5074 980 : info->end[dim] = NULL;
5075 980 : info->stride[dim] = gfc_index_one_node;
5076 980 : return;
5077 : }
5078 :
5079 255953 : gcc_assert (ar->dimen_type[dim] == DIMEN_RANGE
5080 : || ar->dimen_type[dim] == DIMEN_THIS_IMAGE);
5081 255953 : desc = info->descriptor;
5082 255953 : stride = ar->stride[dim];
5083 255953 : bool save_value = !ss->is_alloc_lhs;
5084 :
5085 : /* Calculate the start of the range. For vector subscripts this will
5086 : be the range of the vector. */
5087 255953 : evaluate_bound (block, info->start, ar->start, desc, dim, true,
5088 255953 : ar->as->type == AS_DEFERRED, save_value);
5089 :
5090 : /* Similarly calculate the end. Although this is not used in the
5091 : scalarizer, it is needed when checking bounds and where the end
5092 : is an expression with side-effects. */
5093 255953 : evaluate_bound (block, info->end, ar->end, desc, dim, false,
5094 255953 : ar->as->type == AS_DEFERRED, save_value);
5095 :
5096 :
5097 : /* Calculate the stride. */
5098 255953 : if (stride == NULL)
5099 243227 : info->stride[dim] = gfc_index_one_node;
5100 : else
5101 : {
5102 12726 : gfc_init_se (&se, NULL);
5103 12726 : gfc_conv_expr_type (&se, stride, gfc_array_index_type);
5104 12726 : gfc_add_block_to_block (block, &se.pre);
5105 12726 : tree value = se.expr;
5106 12726 : if (save_value)
5107 12726 : info->stride[dim] = gfc_evaluate_now (value, block);
5108 : else
5109 0 : info->stride[dim] = value;
5110 : }
5111 : }
5112 :
5113 :
5114 : /* Generate in INNER the bounds checking code along the dimension DIM for
5115 : the array associated with SS_INFO. */
5116 :
5117 : static void
5118 24049 : add_check_section_in_array_bounds (stmtblock_t *inner, gfc_ss_info *ss_info,
5119 : int dim)
5120 : {
5121 24049 : gfc_expr *expr = ss_info->expr;
5122 24049 : locus *expr_loc = &expr->where;
5123 24049 : const char *expr_name = expr->symtree->name;
5124 :
5125 24049 : gfc_array_info *info = &ss_info->data.array;
5126 :
5127 24049 : bool check_upper;
5128 24049 : if (dim == info->ref->u.ar.dimen - 1
5129 20440 : && info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
5130 : check_upper = false;
5131 : else
5132 23753 : check_upper = true;
5133 :
5134 : /* Zero stride is not allowed. */
5135 24049 : tree tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
5136 : info->stride[dim], gfc_index_zero_node);
5137 24049 : char * msg = xasprintf ("Zero stride is not allowed, for dimension %d "
5138 : "of array '%s'", dim + 1, expr_name);
5139 24049 : gfc_trans_runtime_check (true, false, tmp, inner, expr_loc, msg);
5140 24049 : free (msg);
5141 :
5142 24049 : tree desc = info->descriptor;
5143 :
5144 : /* This is the run-time equivalent of resolve.cc's
5145 : check_dimension. The logical is more readable there
5146 : than it is here, with all the trees. */
5147 24049 : tree lbound = gfc_conv_array_lbound (desc, dim);
5148 24049 : tree end = info->end[dim];
5149 24049 : tree ubound = check_upper ? gfc_conv_array_ubound (desc, dim) : NULL_TREE;
5150 :
5151 : /* non_zerosized is true when the selected range is not
5152 : empty. */
5153 24049 : tree stride_pos = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
5154 : info->stride[dim], gfc_index_zero_node);
5155 24049 : tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
5156 : info->start[dim], end);
5157 24049 : stride_pos = fold_build2_loc (input_location, TRUTH_AND_EXPR,
5158 : logical_type_node, stride_pos, tmp);
5159 :
5160 24049 : tree stride_neg = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
5161 : info->stride[dim], gfc_index_zero_node);
5162 24049 : tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
5163 : info->start[dim], end);
5164 24049 : stride_neg = fold_build2_loc (input_location, TRUTH_AND_EXPR,
5165 : logical_type_node, stride_neg, tmp);
5166 24049 : tree non_zerosized = fold_build2_loc (input_location, TRUTH_OR_EXPR,
5167 : logical_type_node, stride_pos,
5168 : stride_neg);
5169 :
5170 : /* Check the start of the range against the lower and upper
5171 : bounds of the array, if the range is not empty.
5172 : If upper bound is present, include both bounds in the
5173 : error message. */
5174 24049 : if (check_upper)
5175 : {
5176 23753 : tmp = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
5177 : info->start[dim], lbound);
5178 23753 : tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
5179 : non_zerosized, tmp);
5180 23753 : tree tmp2 = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
5181 : info->start[dim], ubound);
5182 23753 : tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
5183 : non_zerosized, tmp2);
5184 23753 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' outside of "
5185 : "expected range (%%ld:%%ld)", dim + 1, expr_name);
5186 23753 : gfc_trans_runtime_check (true, false, tmp, inner, expr_loc, msg,
5187 : fold_convert (long_integer_type_node, info->start[dim]),
5188 : fold_convert (long_integer_type_node, lbound),
5189 : fold_convert (long_integer_type_node, ubound));
5190 23753 : gfc_trans_runtime_check (true, false, tmp2, inner, expr_loc, msg,
5191 : fold_convert (long_integer_type_node, info->start[dim]),
5192 : fold_convert (long_integer_type_node, lbound),
5193 : fold_convert (long_integer_type_node, ubound));
5194 23753 : free (msg);
5195 : }
5196 : else
5197 : {
5198 296 : tmp = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
5199 : info->start[dim], lbound);
5200 296 : tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
5201 : non_zerosized, tmp);
5202 296 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' below "
5203 : "lower bound of %%ld", dim + 1, expr_name);
5204 296 : gfc_trans_runtime_check (true, false, tmp, inner, expr_loc, msg,
5205 : fold_convert (long_integer_type_node, info->start[dim]),
5206 : fold_convert (long_integer_type_node, lbound));
5207 296 : free (msg);
5208 : }
5209 :
5210 : /* Compute the last element of the range, which is not
5211 : necessarily "end" (think 0:5:3, which doesn't contain 5)
5212 : and check it against both lower and upper bounds. */
5213 :
5214 24049 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5215 : end, info->start[dim]);
5216 24049 : tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR, gfc_array_index_type,
5217 : tmp, info->stride[dim]);
5218 24049 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5219 : end, tmp);
5220 24049 : tree tmp2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
5221 : tmp, lbound);
5222 24049 : tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
5223 : non_zerosized, tmp2);
5224 24049 : if (check_upper)
5225 : {
5226 23753 : tree tmp3 = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
5227 : tmp, ubound);
5228 23753 : tmp3 = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
5229 : non_zerosized, tmp3);
5230 23753 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' outside of "
5231 : "expected range (%%ld:%%ld)", dim + 1, expr_name);
5232 23753 : gfc_trans_runtime_check (true, false, tmp2, inner, expr_loc, msg,
5233 : fold_convert (long_integer_type_node, tmp),
5234 : fold_convert (long_integer_type_node, ubound),
5235 : fold_convert (long_integer_type_node, lbound));
5236 23753 : gfc_trans_runtime_check (true, false, tmp3, inner, expr_loc, msg,
5237 : fold_convert (long_integer_type_node, tmp),
5238 : fold_convert (long_integer_type_node, ubound),
5239 : fold_convert (long_integer_type_node, lbound));
5240 23753 : free (msg);
5241 : }
5242 : else
5243 : {
5244 296 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' below "
5245 : "lower bound of %%ld", dim + 1, expr_name);
5246 296 : gfc_trans_runtime_check (true, false, tmp2, inner, expr_loc, msg,
5247 : fold_convert (long_integer_type_node, tmp),
5248 : fold_convert (long_integer_type_node, lbound));
5249 296 : free (msg);
5250 : }
5251 24049 : }
5252 :
5253 :
5254 : /* Tells whether we need to generate bounds checking code for the array
5255 : associated with SS. */
5256 :
5257 : bool
5258 25016 : bounds_check_needed (gfc_ss *ss)
5259 : {
5260 : /* Catch allocatable lhs in f2003. */
5261 25016 : if (flag_realloc_lhs && ss->no_bounds_check)
5262 : return false;
5263 :
5264 24739 : gfc_ss_info *ss_info = ss->info;
5265 24739 : if (ss_info->type == GFC_SS_SECTION)
5266 : return true;
5267 :
5268 4120 : if (!(ss_info->type == GFC_SS_INTRINSIC
5269 227 : && ss_info->expr
5270 227 : && ss_info->expr->expr_type == EXPR_FUNCTION))
5271 : return false;
5272 :
5273 227 : gfc_intrinsic_sym *isym = ss_info->expr->value.function.isym;
5274 227 : if (!(isym
5275 227 : && (isym->id == GFC_ISYM_MAXLOC
5276 203 : || isym->id == GFC_ISYM_MINLOC)))
5277 : return false;
5278 :
5279 34 : return gfc_inline_intrinsic_function_p (ss_info->expr);
5280 : }
5281 :
5282 :
5283 : /* Calculates the range start and stride for a SS chain. Also gets the
5284 : descriptor and data pointer. The range of vector subscripts is the size
5285 : of the vector. Array bounds are also checked. */
5286 :
5287 : void
5288 182341 : gfc_conv_ss_startstride (gfc_loopinfo * loop)
5289 : {
5290 182341 : int n;
5291 182341 : tree tmp;
5292 182341 : gfc_ss *ss;
5293 :
5294 182341 : gfc_loopinfo * const outer_loop = outermost_loop (loop);
5295 :
5296 182341 : loop->dimen = 0;
5297 : /* Determine the rank of the loop. */
5298 202476 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5299 : {
5300 202476 : switch (ss->info->type)
5301 : {
5302 171055 : case GFC_SS_SECTION:
5303 171055 : case GFC_SS_CONSTRUCTOR:
5304 171055 : case GFC_SS_FUNCTION:
5305 171055 : case GFC_SS_COMPONENT:
5306 171055 : loop->dimen = ss->dimen;
5307 171055 : goto done;
5308 :
5309 : /* As usual, lbound and ubound are exceptions!. */
5310 11286 : case GFC_SS_INTRINSIC:
5311 11286 : switch (ss->info->expr->value.function.isym->id)
5312 : {
5313 11286 : case GFC_ISYM_LBOUND:
5314 11286 : case GFC_ISYM_UBOUND:
5315 11286 : case GFC_ISYM_COSHAPE:
5316 11286 : case GFC_ISYM_LCOBOUND:
5317 11286 : case GFC_ISYM_UCOBOUND:
5318 11286 : case GFC_ISYM_MAXLOC:
5319 11286 : case GFC_ISYM_MINLOC:
5320 11286 : case GFC_ISYM_SHAPE:
5321 11286 : case GFC_ISYM_THIS_IMAGE:
5322 11286 : loop->dimen = ss->dimen;
5323 11286 : goto done;
5324 :
5325 : default:
5326 : break;
5327 : }
5328 :
5329 20135 : default:
5330 20135 : break;
5331 : }
5332 : }
5333 :
5334 : /* We should have determined the rank of the expression by now. If
5335 : not, that's bad news. */
5336 0 : gcc_unreachable ();
5337 :
5338 : done:
5339 : /* Loop over all the SS in the chain. */
5340 474005 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5341 : {
5342 291664 : gfc_ss_info *ss_info;
5343 291664 : gfc_array_info *info;
5344 291664 : gfc_expr *expr;
5345 :
5346 291664 : ss_info = ss->info;
5347 291664 : expr = ss_info->expr;
5348 291664 : info = &ss_info->data.array;
5349 :
5350 291664 : if (expr && expr->shape && !info->shape)
5351 169730 : info->shape = expr->shape;
5352 :
5353 291664 : switch (ss_info->type)
5354 : {
5355 185007 : case GFC_SS_SECTION:
5356 : /* Get the descriptor for the array. If it is a cross loops array,
5357 : we got the descriptor already in the outermost loop. */
5358 185007 : if (ss->parent == NULL)
5359 180371 : gfc_conv_ss_descriptor (&outer_loop->pre, ss,
5360 180371 : !loop->array_parameter);
5361 :
5362 441122 : for (n = 0; n < ss->dimen; n++)
5363 256115 : gfc_conv_section_startstride (&outer_loop->pre, ss, ss->dim[n]);
5364 : break;
5365 :
5366 11533 : case GFC_SS_INTRINSIC:
5367 11533 : switch (expr->value.function.isym->id)
5368 : {
5369 3281 : case GFC_ISYM_MINLOC:
5370 3281 : case GFC_ISYM_MAXLOC:
5371 3281 : {
5372 3281 : gfc_se se;
5373 3281 : gfc_init_se (&se, nullptr);
5374 3281 : se.loop = loop;
5375 3281 : se.ss = ss;
5376 3281 : gfc_conv_intrinsic_function (&se, expr);
5377 3281 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
5378 3281 : gfc_add_block_to_block (&outer_loop->post, &se.post);
5379 :
5380 3281 : info->descriptor = se.expr;
5381 :
5382 3281 : info->data = gfc_conv_array_data (info->descriptor);
5383 3281 : info->data = gfc_evaluate_now (info->data, &outer_loop->pre);
5384 :
5385 3281 : gfc_expr *array = expr->value.function.actual->expr;
5386 3281 : tree rank = build_int_cst (gfc_array_index_type, array->rank);
5387 :
5388 3281 : tree tmp = fold_build2_loc (input_location, MINUS_EXPR,
5389 : gfc_array_index_type, rank,
5390 : gfc_index_one_node);
5391 :
5392 3281 : info->end[0] = gfc_evaluate_now (tmp, &outer_loop->pre);
5393 3281 : info->start[0] = gfc_index_zero_node;
5394 3281 : info->stride[0] = gfc_index_one_node;
5395 3281 : info->offset = gfc_index_zero_node;
5396 3281 : continue;
5397 3281 : }
5398 :
5399 : /* Fall through to supply start and stride. */
5400 3004 : case GFC_ISYM_LBOUND:
5401 3004 : case GFC_ISYM_UBOUND:
5402 : /* This is the variant without DIM=... */
5403 3004 : gcc_assert (expr->value.function.actual->next->expr == NULL);
5404 : /* Fall through. */
5405 :
5406 7944 : case GFC_ISYM_SHAPE:
5407 7944 : {
5408 7944 : gfc_expr *arg;
5409 :
5410 7944 : arg = expr->value.function.actual->expr;
5411 7944 : if (arg->rank == -1)
5412 : {
5413 1175 : gfc_se se;
5414 1175 : tree rank, tmp;
5415 :
5416 : /* The rank (hence the return value's shape) is unknown,
5417 : we have to retrieve it. */
5418 1175 : gfc_init_se (&se, NULL);
5419 1175 : se.descriptor_only = 1;
5420 1175 : gfc_conv_expr (&se, arg);
5421 : /* This is a bare variable, so there is no preliminary
5422 : or cleanup code unless -std=f202y and bounds checking
5423 : is on. */
5424 1175 : if (!((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
5425 0 : && (gfc_option.allow_std & GFC_STD_F202Y)))
5426 1175 : gcc_assert (se.pre.head == NULL_TREE
5427 : && se.post.head == NULL_TREE);
5428 1175 : rank = gfc_conv_descriptor_rank (se.expr);
5429 1175 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
5430 : gfc_array_index_type,
5431 : fold_convert (gfc_array_index_type,
5432 : rank),
5433 : gfc_index_one_node);
5434 1175 : info->end[0] = gfc_evaluate_now (tmp, &outer_loop->pre);
5435 1175 : info->start[0] = gfc_index_zero_node;
5436 1175 : info->stride[0] = gfc_index_one_node;
5437 1175 : continue;
5438 1175 : }
5439 : /* Otherwise fall through GFC_SS_FUNCTION. */
5440 : gcc_fallthrough ();
5441 : }
5442 : case GFC_ISYM_COSHAPE:
5443 : case GFC_ISYM_LCOBOUND:
5444 : case GFC_ISYM_UCOBOUND:
5445 : case GFC_ISYM_THIS_IMAGE:
5446 : break;
5447 :
5448 0 : default:
5449 0 : continue;
5450 0 : }
5451 :
5452 : /* FALLTHRU */
5453 : case GFC_SS_CONSTRUCTOR:
5454 : case GFC_SS_FUNCTION:
5455 128770 : for (n = 0; n < ss->dimen; n++)
5456 : {
5457 69529 : int dim = ss->dim[n];
5458 :
5459 69529 : info->start[dim] = gfc_index_zero_node;
5460 69529 : if (ss_info->type != GFC_SS_FUNCTION)
5461 55084 : info->end[dim] = gfc_index_zero_node;
5462 69529 : info->stride[dim] = gfc_index_one_node;
5463 : }
5464 : break;
5465 :
5466 : default:
5467 : break;
5468 : }
5469 : }
5470 :
5471 : /* The rest is just runtime bounds checking. */
5472 182341 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
5473 : {
5474 16924 : stmtblock_t block;
5475 16924 : tree size[GFC_MAX_DIMENSIONS];
5476 16924 : tree tmp3;
5477 16924 : gfc_array_info *info;
5478 16924 : char *msg;
5479 16924 : int dim;
5480 :
5481 16924 : gfc_start_block (&block);
5482 :
5483 54188 : for (n = 0; n < loop->dimen; n++)
5484 20340 : size[n] = NULL_TREE;
5485 :
5486 : /* If there is a constructor involved, derive size[] from its shape. */
5487 39114 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5488 : {
5489 24670 : gfc_ss_info *ss_info;
5490 :
5491 24670 : ss_info = ss->info;
5492 24670 : info = &ss_info->data.array;
5493 :
5494 24670 : if (ss_info->type == GFC_SS_CONSTRUCTOR && info->shape)
5495 : {
5496 5224 : for (n = 0; n < loop->dimen; n++)
5497 : {
5498 2744 : if (size[n] == NULL)
5499 : {
5500 2744 : gcc_assert (info->shape[n]);
5501 2744 : size[n] = gfc_conv_mpz_to_tree (info->shape[n],
5502 : gfc_index_integer_kind);
5503 : }
5504 : }
5505 : break;
5506 : }
5507 : }
5508 :
5509 41940 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5510 : {
5511 25016 : stmtblock_t inner;
5512 25016 : gfc_ss_info *ss_info;
5513 25016 : gfc_expr *expr;
5514 25016 : locus *expr_loc;
5515 25016 : const char *expr_name;
5516 25016 : char *ref_name = NULL;
5517 :
5518 25016 : if (!bounds_check_needed (ss))
5519 4363 : continue;
5520 :
5521 20653 : ss_info = ss->info;
5522 20653 : expr = ss_info->expr;
5523 20653 : expr_loc = &expr->where;
5524 20653 : if (expr->ref)
5525 20619 : expr_name = ref_name = abridged_ref_name (expr, NULL);
5526 : else
5527 34 : expr_name = expr->symtree->name;
5528 :
5529 20653 : gfc_start_block (&inner);
5530 :
5531 : /* TODO: range checking for mapped dimensions. */
5532 20653 : info = &ss_info->data.array;
5533 :
5534 : /* This code only checks ranges. Elemental and vector
5535 : dimensions are checked later. */
5536 65403 : for (n = 0; n < loop->dimen; n++)
5537 : {
5538 24097 : dim = ss->dim[n];
5539 24097 : if (ss_info->type == GFC_SS_SECTION)
5540 : {
5541 24063 : if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
5542 14 : continue;
5543 :
5544 24049 : add_check_section_in_array_bounds (&inner, ss_info, dim);
5545 : }
5546 :
5547 : /* Check the section sizes match. */
5548 24083 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
5549 : gfc_array_index_type, info->end[dim],
5550 : info->start[dim]);
5551 24083 : tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
5552 : gfc_array_index_type, tmp,
5553 : info->stride[dim]);
5554 24083 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
5555 : gfc_array_index_type,
5556 : gfc_index_one_node, tmp);
5557 24083 : tmp = fold_build2_loc (input_location, MAX_EXPR,
5558 : gfc_array_index_type, tmp,
5559 : build_int_cst (gfc_array_index_type, 0));
5560 : /* We remember the size of the first section, and check all the
5561 : others against this. */
5562 24083 : if (size[n])
5563 : {
5564 7191 : tmp3 = fold_build2_loc (input_location, NE_EXPR,
5565 : logical_type_node, tmp, size[n]);
5566 7191 : if (ss_info->type == GFC_SS_INTRINSIC)
5567 0 : msg = xasprintf ("Extent mismatch for dimension %d of the "
5568 : "result of intrinsic '%s' (%%ld/%%ld)",
5569 : dim + 1, expr_name);
5570 : else
5571 7191 : msg = xasprintf ("Array bound mismatch for dimension %d "
5572 : "of array '%s' (%%ld/%%ld)",
5573 : dim + 1, expr_name);
5574 :
5575 7191 : gfc_trans_runtime_check (true, false, tmp3, &inner,
5576 : expr_loc, msg,
5577 : fold_convert (long_integer_type_node, tmp),
5578 : fold_convert (long_integer_type_node, size[n]));
5579 :
5580 7191 : free (msg);
5581 : }
5582 : else
5583 16892 : size[n] = gfc_evaluate_now (tmp, &inner);
5584 : }
5585 :
5586 20653 : tmp = gfc_finish_block (&inner);
5587 :
5588 : /* For optional arguments, only check bounds if the argument is
5589 : present. */
5590 20653 : if ((expr->symtree->n.sym->attr.optional
5591 20345 : || expr->symtree->n.sym->attr.not_always_present)
5592 308 : && expr->symtree->n.sym->attr.dummy)
5593 307 : tmp = build3_v (COND_EXPR,
5594 : gfc_conv_expr_present (expr->symtree->n.sym),
5595 : tmp, build_empty_stmt (input_location));
5596 :
5597 20653 : gfc_add_expr_to_block (&block, tmp);
5598 :
5599 20653 : free (ref_name);
5600 : }
5601 :
5602 16924 : tmp = gfc_finish_block (&block);
5603 16924 : gfc_add_expr_to_block (&outer_loop->pre, tmp);
5604 : }
5605 :
5606 185705 : for (loop = loop->nested; loop; loop = loop->next)
5607 3364 : gfc_conv_ss_startstride (loop);
5608 182341 : }
5609 :
5610 : /* Return true if both symbols could refer to the same data object. Does
5611 : not take account of aliasing due to equivalence statements. */
5612 :
5613 : static bool
5614 13676 : symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym, bool lsym_pointer,
5615 : bool lsym_target, bool rsym_pointer, bool rsym_target)
5616 : {
5617 : /* Aliasing isn't possible if the symbols have different base types,
5618 : except for complex types where an inquiry reference (%RE, %IM) could
5619 : alias with a real type with the same kind parameter. */
5620 13676 : if (!gfc_compare_types (&lsym->ts, &rsym->ts)
5621 13676 : && !(((lsym->ts.type == BT_COMPLEX && rsym->ts.type == BT_REAL)
5622 4833 : || (lsym->ts.type == BT_REAL && rsym->ts.type == BT_COMPLEX))
5623 76 : && lsym->ts.kind == rsym->ts.kind))
5624 : return false;
5625 :
5626 : /* Pointers can point to other pointers and target objects. */
5627 :
5628 8856 : if ((lsym_pointer && (rsym_pointer || rsym_target))
5629 8647 : || (rsym_pointer && (lsym_pointer || lsym_target)))
5630 : return true;
5631 :
5632 : /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
5633 : and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
5634 : checked above. */
5635 8733 : if (lsym_target && rsym_target
5636 14 : && ((lsym->attr.dummy && !lsym->attr.contiguous
5637 0 : && (!lsym->attr.dimension || lsym->as->type == AS_ASSUMED_SHAPE))
5638 14 : || (rsym->attr.dummy && !rsym->attr.contiguous
5639 6 : && (!rsym->attr.dimension
5640 6 : || rsym->as->type == AS_ASSUMED_SHAPE))))
5641 6 : return true;
5642 :
5643 : return false;
5644 : }
5645 :
5646 :
5647 : /* Return true if the two SS could be aliased, i.e. both point to the same data
5648 : object. */
5649 : /* TODO: resolve aliases based on frontend expressions. */
5650 :
5651 : static int
5652 11558 : gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
5653 : {
5654 11558 : gfc_ref *lref;
5655 11558 : gfc_ref *rref;
5656 11558 : gfc_expr *lexpr, *rexpr;
5657 11558 : gfc_symbol *lsym;
5658 11558 : gfc_symbol *rsym;
5659 11558 : bool lsym_pointer, lsym_target, rsym_pointer, rsym_target;
5660 :
5661 11558 : lexpr = lss->info->expr;
5662 11558 : rexpr = rss->info->expr;
5663 :
5664 11558 : lsym = lexpr->symtree->n.sym;
5665 11558 : rsym = rexpr->symtree->n.sym;
5666 :
5667 11558 : lsym_pointer = lsym->attr.pointer;
5668 11558 : lsym_target = lsym->attr.target;
5669 11558 : rsym_pointer = rsym->attr.pointer;
5670 11558 : rsym_target = rsym->attr.target;
5671 :
5672 11558 : if (symbols_could_alias (lsym, rsym, lsym_pointer, lsym_target,
5673 : rsym_pointer, rsym_target))
5674 : return 1;
5675 :
5676 11467 : if (rsym->ts.type != BT_DERIVED && rsym->ts.type != BT_CLASS
5677 10098 : && lsym->ts.type != BT_DERIVED && lsym->ts.type != BT_CLASS)
5678 : return 0;
5679 :
5680 : /* For derived types we must check all the component types. We can ignore
5681 : array references as these will have the same base type as the previous
5682 : component ref. */
5683 2758 : for (lref = lexpr->ref; lref != lss->info->data.array.ref; lref = lref->next)
5684 : {
5685 983 : if (lref->type != REF_COMPONENT)
5686 107 : continue;
5687 :
5688 876 : lsym_pointer = lsym_pointer || lref->u.c.sym->attr.pointer;
5689 876 : lsym_target = lsym_target || lref->u.c.sym->attr.target;
5690 :
5691 876 : if (symbols_could_alias (lref->u.c.sym, rsym, lsym_pointer, lsym_target,
5692 : rsym_pointer, rsym_target))
5693 : return 1;
5694 :
5695 876 : if ((lsym_pointer && (rsym_pointer || rsym_target))
5696 861 : || (rsym_pointer && (lsym_pointer || lsym_target)))
5697 : {
5698 6 : if (gfc_compare_types (&lref->u.c.component->ts,
5699 : &rsym->ts))
5700 : return 1;
5701 : }
5702 :
5703 1312 : for (rref = rexpr->ref; rref != rss->info->data.array.ref;
5704 442 : rref = rref->next)
5705 : {
5706 443 : if (rref->type != REF_COMPONENT)
5707 36 : continue;
5708 :
5709 407 : rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
5710 407 : rsym_target = lsym_target || rref->u.c.sym->attr.target;
5711 :
5712 407 : if (symbols_could_alias (lref->u.c.sym, rref->u.c.sym,
5713 : lsym_pointer, lsym_target,
5714 : rsym_pointer, rsym_target))
5715 : return 1;
5716 :
5717 406 : if ((lsym_pointer && (rsym_pointer || rsym_target))
5718 402 : || (rsym_pointer && (lsym_pointer || lsym_target)))
5719 : {
5720 0 : if (gfc_compare_types (&lref->u.c.component->ts,
5721 0 : &rref->u.c.sym->ts))
5722 : return 1;
5723 0 : if (gfc_compare_types (&lref->u.c.sym->ts,
5724 0 : &rref->u.c.component->ts))
5725 : return 1;
5726 0 : if (gfc_compare_types (&lref->u.c.component->ts,
5727 0 : &rref->u.c.component->ts))
5728 : return 1;
5729 : }
5730 : }
5731 : }
5732 :
5733 1775 : lsym_pointer = lsym->attr.pointer;
5734 1775 : lsym_target = lsym->attr.target;
5735 :
5736 2604 : for (rref = rexpr->ref; rref != rss->info->data.array.ref; rref = rref->next)
5737 : {
5738 982 : if (rref->type != REF_COMPONENT)
5739 : break;
5740 :
5741 835 : rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
5742 835 : rsym_target = lsym_target || rref->u.c.sym->attr.target;
5743 :
5744 835 : if (symbols_could_alias (rref->u.c.sym, lsym,
5745 : lsym_pointer, lsym_target,
5746 : rsym_pointer, rsym_target))
5747 : return 1;
5748 :
5749 835 : if ((lsym_pointer && (rsym_pointer || rsym_target))
5750 817 : || (rsym_pointer && (lsym_pointer || lsym_target)))
5751 : {
5752 6 : if (gfc_compare_types (&lsym->ts, &rref->u.c.component->ts))
5753 : return 1;
5754 : }
5755 : }
5756 :
5757 : return 0;
5758 : }
5759 :
5760 :
5761 : /* Resolve array data dependencies. Creates a temporary if required. */
5762 : /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
5763 : dependency.cc. */
5764 :
5765 : void
5766 37835 : gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
5767 : gfc_ss * rss)
5768 : {
5769 37835 : gfc_ss *ss;
5770 37835 : gfc_ref *lref;
5771 37835 : gfc_ref *rref;
5772 37835 : gfc_ss_info *ss_info;
5773 37835 : gfc_expr *dest_expr;
5774 37835 : gfc_expr *ss_expr;
5775 37835 : int nDepend = 0;
5776 37835 : int i, j;
5777 :
5778 37835 : loop->temp_ss = NULL;
5779 37835 : dest_expr = dest->info->expr;
5780 :
5781 81419 : for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
5782 : {
5783 44745 : ss_info = ss->info;
5784 44745 : ss_expr = ss_info->expr;
5785 :
5786 44745 : if (ss_info->array_outer_dependency)
5787 : {
5788 : nDepend = 1;
5789 : break;
5790 : }
5791 :
5792 44628 : if (ss_info->type != GFC_SS_SECTION)
5793 : {
5794 30453 : if (flag_realloc_lhs
5795 29403 : && dest_expr != ss_expr
5796 29403 : && gfc_is_reallocatable_lhs (dest_expr)
5797 37454 : && ss_expr->rank)
5798 3337 : nDepend = gfc_check_dependency (dest_expr, ss_expr, true);
5799 :
5800 : /* Check for cases like c(:)(1:2) = c(2)(2:3) */
5801 30453 : if (!nDepend && dest_expr->rank > 0
5802 29955 : && dest_expr->ts.type == BT_CHARACTER
5803 4748 : && ss_expr->expr_type == EXPR_VARIABLE)
5804 :
5805 165 : nDepend = gfc_check_dependency (dest_expr, ss_expr, false);
5806 :
5807 30453 : if (ss_info->type == GFC_SS_REFERENCE
5808 30453 : && gfc_check_dependency (dest_expr, ss_expr, false))
5809 188 : ss_info->data.scalar.needs_temporary = 1;
5810 :
5811 30453 : if (nDepend)
5812 : break;
5813 : else
5814 29943 : continue;
5815 : }
5816 :
5817 14175 : if (dest_expr->symtree->n.sym != ss_expr->symtree->n.sym)
5818 : {
5819 11558 : if (gfc_could_be_alias (dest, ss)
5820 11558 : || gfc_are_equivalenced_arrays (dest_expr, ss_expr))
5821 : {
5822 : nDepend = 1;
5823 : break;
5824 : }
5825 : }
5826 : else
5827 : {
5828 2617 : lref = dest_expr->ref;
5829 2617 : rref = ss_expr->ref;
5830 :
5831 2617 : nDepend = gfc_dep_resolver (lref, rref, &loop->reverse[0]);
5832 :
5833 2617 : if (nDepend == 1)
5834 : break;
5835 :
5836 5222 : for (i = 0; i < dest->dimen; i++)
5837 7214 : for (j = 0; j < ss->dimen; j++)
5838 4320 : if (i != j
5839 1363 : && dest->dim[i] == ss->dim[j])
5840 : {
5841 : /* If we don't access array elements in the same order,
5842 : there is a dependency. */
5843 63 : nDepend = 1;
5844 63 : goto temporary;
5845 : }
5846 : #if 0
5847 : /* TODO : loop shifting. */
5848 : if (nDepend == 1)
5849 : {
5850 : /* Mark the dimensions for LOOP SHIFTING */
5851 : for (n = 0; n < loop->dimen; n++)
5852 : {
5853 : int dim = dest->data.info.dim[n];
5854 :
5855 : if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
5856 : depends[n] = 2;
5857 : else if (! gfc_is_same_range (&lref->u.ar,
5858 : &rref->u.ar, dim, 0))
5859 : depends[n] = 1;
5860 : }
5861 :
5862 : /* Put all the dimensions with dependencies in the
5863 : innermost loops. */
5864 : dim = 0;
5865 : for (n = 0; n < loop->dimen; n++)
5866 : {
5867 : gcc_assert (loop->order[n] == n);
5868 : if (depends[n])
5869 : loop->order[dim++] = n;
5870 : }
5871 : for (n = 0; n < loop->dimen; n++)
5872 : {
5873 : if (! depends[n])
5874 : loop->order[dim++] = n;
5875 : }
5876 :
5877 : gcc_assert (dim == loop->dimen);
5878 : break;
5879 : }
5880 : #endif
5881 : }
5882 : }
5883 :
5884 799 : temporary:
5885 :
5886 37835 : if (nDepend == 1)
5887 : {
5888 1161 : tree base_type = gfc_typenode_for_spec (&dest_expr->ts);
5889 1161 : if (GFC_ARRAY_TYPE_P (base_type)
5890 1161 : || GFC_DESCRIPTOR_TYPE_P (base_type))
5891 0 : base_type = gfc_get_element_type (base_type);
5892 1161 : loop->temp_ss = gfc_get_temp_ss (base_type, dest->info->string_length,
5893 : loop->dimen);
5894 1161 : gfc_add_ss_to_loop (loop, loop->temp_ss);
5895 : }
5896 : else
5897 36674 : loop->temp_ss = NULL;
5898 37835 : }
5899 :
5900 :
5901 : /* Browse through each array's information from the scalarizer and set the loop
5902 : bounds according to the "best" one (per dimension), i.e. the one which
5903 : provides the most information (constant bounds, shape, etc.). */
5904 :
5905 : static void
5906 182341 : set_loop_bounds (gfc_loopinfo *loop)
5907 : {
5908 182341 : int n, dim, spec_dim;
5909 182341 : gfc_array_info *info;
5910 182341 : gfc_array_info *specinfo;
5911 182341 : gfc_ss *ss;
5912 182341 : tree tmp;
5913 182341 : gfc_ss **loopspec;
5914 182341 : bool dynamic[GFC_MAX_DIMENSIONS];
5915 182341 : mpz_t *cshape;
5916 182341 : mpz_t i;
5917 182341 : bool nonoptional_arr;
5918 :
5919 182341 : gfc_loopinfo * const outer_loop = outermost_loop (loop);
5920 :
5921 182341 : loopspec = loop->specloop;
5922 :
5923 182341 : mpz_init (i);
5924 429933 : for (n = 0; n < loop->dimen; n++)
5925 : {
5926 247592 : loopspec[n] = NULL;
5927 247592 : dynamic[n] = false;
5928 :
5929 : /* If there are both optional and nonoptional array arguments, scalarize
5930 : over the nonoptional; otherwise, it does not matter as then all
5931 : (optional) arrays have to be present per F2008, 125.2.12p3(6). */
5932 :
5933 247592 : nonoptional_arr = false;
5934 :
5935 288713 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5936 288693 : if (ss->info->type != GFC_SS_SCALAR && ss->info->type != GFC_SS_TEMP
5937 254157 : && ss->info->type != GFC_SS_REFERENCE && !ss->info->can_be_null_ref)
5938 : {
5939 : nonoptional_arr = true;
5940 : break;
5941 : }
5942 :
5943 : /* We use one SS term, and use that to determine the bounds of the
5944 : loop for this dimension. We try to pick the simplest term. */
5945 648187 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5946 : {
5947 400595 : gfc_ss_type ss_type;
5948 :
5949 400595 : ss_type = ss->info->type;
5950 470279 : if (ss_type == GFC_SS_SCALAR
5951 400595 : || ss_type == GFC_SS_TEMP
5952 340175 : || ss_type == GFC_SS_REFERENCE
5953 331188 : || (ss->info->can_be_null_ref && nonoptional_arr))
5954 69684 : continue;
5955 :
5956 330911 : info = &ss->info->data.array;
5957 330911 : dim = ss->dim[n];
5958 :
5959 330911 : if (loopspec[n] != NULL)
5960 : {
5961 83319 : specinfo = &loopspec[n]->info->data.array;
5962 83319 : spec_dim = loopspec[n]->dim[n];
5963 : }
5964 : else
5965 : {
5966 : /* Silence uninitialized warnings. */
5967 : specinfo = NULL;
5968 : spec_dim = 0;
5969 : }
5970 :
5971 330911 : if (info->shape)
5972 : {
5973 : /* The frontend has worked out the size for us. */
5974 224318 : if (!loopspec[n]
5975 58981 : || !specinfo->shape
5976 270794 : || !integer_zerop (specinfo->start[spec_dim]))
5977 : /* Prefer zero-based descriptors if possible. */
5978 207401 : loopspec[n] = ss;
5979 224318 : continue;
5980 : }
5981 :
5982 106593 : if (ss_type == GFC_SS_CONSTRUCTOR)
5983 : {
5984 1349 : gfc_constructor_base base;
5985 : /* An unknown size constructor will always be rank one.
5986 : Higher rank constructors will either have known shape,
5987 : or still be wrapped in a call to reshape. */
5988 1349 : gcc_assert (loop->dimen == 1);
5989 :
5990 : /* Always prefer to use the constructor bounds if the size
5991 : can be determined at compile time. Prefer not to otherwise,
5992 : since the general case involves realloc, and it's better to
5993 : avoid that overhead if possible. */
5994 1349 : base = ss->info->expr->value.constructor;
5995 1349 : dynamic[n] = gfc_get_array_constructor_size (&i, base);
5996 1349 : if (!dynamic[n] || !loopspec[n])
5997 1162 : loopspec[n] = ss;
5998 1349 : continue;
5999 1349 : }
6000 :
6001 : /* Avoid using an allocatable lhs in an assignment, since
6002 : there might be a reallocation coming. */
6003 105244 : if (loopspec[n] && ss->is_alloc_lhs)
6004 9426 : continue;
6005 :
6006 95818 : if (!loopspec[n])
6007 81093 : loopspec[n] = ss;
6008 : /* Criteria for choosing a loop specifier (most important first):
6009 : doesn't need realloc
6010 : stride of one
6011 : known stride
6012 : known lower bound
6013 : known upper bound
6014 : */
6015 14725 : else if (loopspec[n]->info->type == GFC_SS_CONSTRUCTOR && dynamic[n])
6016 187 : loopspec[n] = ss;
6017 14538 : else if (integer_onep (info->stride[dim])
6018 14538 : && !integer_onep (specinfo->stride[spec_dim]))
6019 120 : loopspec[n] = ss;
6020 14418 : else if (INTEGER_CST_P (info->stride[dim])
6021 14194 : && !INTEGER_CST_P (specinfo->stride[spec_dim]))
6022 0 : loopspec[n] = ss;
6023 14418 : else if (INTEGER_CST_P (info->start[dim])
6024 4375 : && !INTEGER_CST_P (specinfo->start[spec_dim])
6025 856 : && integer_onep (info->stride[dim])
6026 428 : == integer_onep (specinfo->stride[spec_dim])
6027 14418 : && INTEGER_CST_P (info->stride[dim])
6028 401 : == INTEGER_CST_P (specinfo->stride[spec_dim]))
6029 401 : loopspec[n] = ss;
6030 : /* We don't work out the upper bound.
6031 : else if (INTEGER_CST_P (info->finish[n])
6032 : && ! INTEGER_CST_P (specinfo->finish[n]))
6033 : loopspec[n] = ss; */
6034 : }
6035 :
6036 : /* We should have found the scalarization loop specifier. If not,
6037 : that's bad news. */
6038 247592 : gcc_assert (loopspec[n]);
6039 :
6040 247592 : info = &loopspec[n]->info->data.array;
6041 247592 : dim = loopspec[n]->dim[n];
6042 :
6043 : /* Set the extents of this range. */
6044 247592 : cshape = info->shape;
6045 247592 : if (cshape && INTEGER_CST_P (info->start[dim])
6046 177643 : && INTEGER_CST_P (info->stride[dim]))
6047 : {
6048 177643 : loop->from[n] = info->start[dim];
6049 177643 : mpz_set (i, cshape[get_array_ref_dim_for_loop_dim (loopspec[n], n)]);
6050 177643 : mpz_sub_ui (i, i, 1);
6051 : /* To = from + (size - 1) * stride. */
6052 177643 : tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
6053 177643 : if (!integer_onep (info->stride[dim]))
6054 8665 : tmp = fold_build2_loc (input_location, MULT_EXPR,
6055 : gfc_array_index_type, tmp,
6056 : info->stride[dim]);
6057 177643 : loop->to[n] = fold_build2_loc (input_location, PLUS_EXPR,
6058 : gfc_array_index_type,
6059 : loop->from[n], tmp);
6060 : }
6061 : else
6062 : {
6063 69949 : loop->from[n] = info->start[dim];
6064 69949 : switch (loopspec[n]->info->type)
6065 : {
6066 874 : case GFC_SS_CONSTRUCTOR:
6067 : /* The upper bound is calculated when we expand the
6068 : constructor. */
6069 874 : gcc_assert (loop->to[n] == NULL_TREE);
6070 : break;
6071 :
6072 63437 : case GFC_SS_SECTION:
6073 : /* Use the end expression if it exists and is not constant,
6074 : so that it is only evaluated once. */
6075 63437 : loop->to[n] = info->end[dim];
6076 63437 : break;
6077 :
6078 4859 : case GFC_SS_FUNCTION:
6079 : /* The loop bound will be set when we generate the call. */
6080 4859 : gcc_assert (loop->to[n] == NULL_TREE);
6081 : break;
6082 :
6083 767 : case GFC_SS_INTRINSIC:
6084 767 : {
6085 767 : gfc_expr *expr = loopspec[n]->info->expr;
6086 :
6087 : /* The {l,u}bound of an assumed rank. */
6088 767 : if (expr->value.function.isym->id == GFC_ISYM_SHAPE)
6089 255 : gcc_assert (expr->value.function.actual->expr->rank == -1);
6090 : else
6091 512 : gcc_assert ((expr->value.function.isym->id == GFC_ISYM_LBOUND
6092 : || expr->value.function.isym->id == GFC_ISYM_UBOUND)
6093 : && expr->value.function.actual->next->expr == NULL
6094 : && expr->value.function.actual->expr->rank == -1);
6095 :
6096 767 : loop->to[n] = info->end[dim];
6097 767 : break;
6098 : }
6099 :
6100 12 : case GFC_SS_COMPONENT:
6101 12 : {
6102 12 : if (info->end[dim] != NULL_TREE)
6103 : {
6104 12 : loop->to[n] = info->end[dim];
6105 12 : break;
6106 : }
6107 : else
6108 0 : gcc_unreachable ();
6109 : }
6110 :
6111 0 : default:
6112 0 : gcc_unreachable ();
6113 : }
6114 : }
6115 :
6116 : /* Transform everything so we have a simple incrementing variable. */
6117 247592 : if (integer_onep (info->stride[dim]))
6118 236812 : info->delta[dim] = gfc_index_zero_node;
6119 : else
6120 : {
6121 : /* Set the delta for this section. */
6122 10780 : info->delta[dim] = gfc_evaluate_now (loop->from[n], &outer_loop->pre);
6123 : /* Number of iterations is (end - start + step) / step.
6124 : with start = 0, this simplifies to
6125 : last = end / step;
6126 : for (i = 0; i<=last; i++){...}; */
6127 10780 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
6128 : gfc_array_index_type, loop->to[n],
6129 : loop->from[n]);
6130 10780 : tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
6131 : gfc_array_index_type, tmp, info->stride[dim]);
6132 10780 : tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
6133 : tmp, build_int_cst (gfc_array_index_type, -1));
6134 10780 : loop->to[n] = gfc_evaluate_now (tmp, &outer_loop->pre);
6135 : /* Make the loop variable start at 0. */
6136 10780 : loop->from[n] = gfc_index_zero_node;
6137 : }
6138 : }
6139 182341 : mpz_clear (i);
6140 :
6141 185705 : for (loop = loop->nested; loop; loop = loop->next)
6142 3364 : set_loop_bounds (loop);
6143 182341 : }
6144 :
6145 :
6146 : /* Last attempt to set the loop bounds, in case they depend on an allocatable
6147 : function result. */
6148 :
6149 : static void
6150 182341 : late_set_loop_bounds (gfc_loopinfo *loop)
6151 : {
6152 182341 : int n, dim;
6153 182341 : gfc_array_info *info;
6154 182341 : gfc_ss **loopspec;
6155 :
6156 182341 : loopspec = loop->specloop;
6157 :
6158 429933 : for (n = 0; n < loop->dimen; n++)
6159 : {
6160 : /* Set the extents of this range. */
6161 247592 : if (loop->from[n] == NULL_TREE
6162 247592 : || loop->to[n] == NULL_TREE)
6163 : {
6164 : /* We should have found the scalarization loop specifier. If not,
6165 : that's bad news. */
6166 455 : gcc_assert (loopspec[n]);
6167 :
6168 455 : info = &loopspec[n]->info->data.array;
6169 455 : dim = loopspec[n]->dim[n];
6170 :
6171 455 : if (loopspec[n]->info->type == GFC_SS_FUNCTION
6172 455 : && info->start[dim]
6173 455 : && info->end[dim])
6174 : {
6175 153 : loop->from[n] = info->start[dim];
6176 153 : loop->to[n] = info->end[dim];
6177 : }
6178 : }
6179 : }
6180 :
6181 185705 : for (loop = loop->nested; loop; loop = loop->next)
6182 3364 : late_set_loop_bounds (loop);
6183 182341 : }
6184 :
6185 :
6186 : /* Initialize the scalarization loop. Creates the loop variables. Determines
6187 : the range of the loop variables. Creates a temporary if required.
6188 : Also generates code for scalar expressions which have been
6189 : moved outside the loop. */
6190 :
6191 : void
6192 178977 : gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
6193 : {
6194 178977 : gfc_ss *tmp_ss;
6195 178977 : tree tmp;
6196 :
6197 178977 : set_loop_bounds (loop);
6198 :
6199 : /* Add all the scalar code that can be taken out of the loops.
6200 : This may include calculating the loop bounds, so do it before
6201 : allocating the temporary. */
6202 178977 : gfc_add_loop_ss_code (loop, loop->ss, false, where);
6203 :
6204 178977 : late_set_loop_bounds (loop);
6205 :
6206 178977 : tmp_ss = loop->temp_ss;
6207 : /* If we want a temporary then create it. */
6208 178977 : if (tmp_ss != NULL)
6209 : {
6210 11243 : gfc_ss_info *tmp_ss_info;
6211 :
6212 11243 : tmp_ss_info = tmp_ss->info;
6213 11243 : gcc_assert (tmp_ss_info->type == GFC_SS_TEMP);
6214 11243 : gcc_assert (loop->parent == NULL);
6215 :
6216 : /* Make absolutely sure that this is a complete type. */
6217 11243 : if (tmp_ss_info->string_length)
6218 2754 : tmp_ss_info->data.temp.type
6219 2754 : = gfc_get_character_type_len_for_eltype
6220 2754 : (TREE_TYPE (tmp_ss_info->data.temp.type),
6221 : tmp_ss_info->string_length);
6222 :
6223 11243 : tmp = tmp_ss_info->data.temp.type;
6224 11243 : memset (&tmp_ss_info->data.array, 0, sizeof (gfc_array_info));
6225 11243 : tmp_ss_info->type = GFC_SS_SECTION;
6226 :
6227 11243 : gcc_assert (tmp_ss->dimen != 0);
6228 :
6229 11243 : gfc_trans_create_temp_array (&loop->pre, &loop->post, tmp_ss, tmp,
6230 : NULL_TREE, false, true, false, where);
6231 : }
6232 :
6233 : /* For array parameters we don't have loop variables, so don't calculate the
6234 : translations. */
6235 178977 : if (!loop->array_parameter)
6236 112021 : gfc_set_delta (loop);
6237 178977 : }
6238 :
6239 :
6240 : /* Calculates how to transform from loop variables to array indices for each
6241 : array: once loop bounds are chosen, sets the difference (DELTA field) between
6242 : loop bounds and array reference bounds, for each array info. */
6243 :
6244 : void
6245 115852 : gfc_set_delta (gfc_loopinfo *loop)
6246 : {
6247 115852 : gfc_ss *ss, **loopspec;
6248 115852 : gfc_array_info *info;
6249 115852 : tree tmp;
6250 115852 : int n, dim;
6251 :
6252 115852 : gfc_loopinfo * const outer_loop = outermost_loop (loop);
6253 :
6254 115852 : loopspec = loop->specloop;
6255 :
6256 : /* Calculate the translation from loop variables to array indices. */
6257 351099 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
6258 : {
6259 235247 : gfc_ss_type ss_type;
6260 :
6261 235247 : ss_type = ss->info->type;
6262 60722 : if (!(ss_type == GFC_SS_SECTION
6263 235247 : || ss_type == GFC_SS_COMPONENT
6264 95908 : || ss_type == GFC_SS_CONSTRUCTOR
6265 : || (ss_type == GFC_SS_FUNCTION
6266 8256 : && gfc_is_class_array_function (ss->info->expr))))
6267 60570 : continue;
6268 :
6269 174677 : info = &ss->info->data.array;
6270 :
6271 393418 : for (n = 0; n < ss->dimen; n++)
6272 : {
6273 : /* If we are specifying the range the delta is already set. */
6274 218741 : if (loopspec[n] != ss)
6275 : {
6276 113854 : dim = ss->dim[n];
6277 :
6278 : /* Calculate the offset relative to the loop variable.
6279 : First multiply by the stride. */
6280 113854 : tmp = loop->from[n];
6281 113854 : if (!integer_onep (info->stride[dim]))
6282 3084 : tmp = fold_build2_loc (input_location, MULT_EXPR,
6283 : gfc_array_index_type,
6284 : tmp, info->stride[dim]);
6285 :
6286 : /* Then subtract this from our starting value. */
6287 113854 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
6288 : gfc_array_index_type,
6289 : info->start[dim], tmp);
6290 :
6291 113854 : if (ss->is_alloc_lhs)
6292 9426 : info->delta[dim] = tmp;
6293 : else
6294 104428 : info->delta[dim] = gfc_evaluate_now (tmp, &outer_loop->pre);
6295 : }
6296 : }
6297 : }
6298 :
6299 119304 : for (loop = loop->nested; loop; loop = loop->next)
6300 3452 : gfc_set_delta (loop);
6301 115852 : }
6302 :
6303 :
6304 : /* Calculate the size of a given array dimension from the bounds. This
6305 : is simply (ubound - lbound + 1) if this expression is positive
6306 : or 0 if it is negative (pick either one if it is zero). Optionally
6307 : (if or_expr is present) OR the (expression != 0) condition to it. */
6308 :
6309 : tree
6310 23019 : gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr)
6311 : {
6312 23019 : tree res;
6313 23019 : tree cond;
6314 :
6315 : /* Calculate (ubound - lbound + 1). */
6316 23019 : res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6317 : ubound, lbound);
6318 23019 : res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res,
6319 : gfc_index_one_node);
6320 :
6321 : /* Check whether the size for this dimension is negative. */
6322 23019 : cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, res,
6323 : gfc_index_zero_node);
6324 23019 : res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
6325 : gfc_index_zero_node, res);
6326 :
6327 : /* Build OR expression. */
6328 23019 : if (or_expr)
6329 17671 : *or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
6330 : logical_type_node, *or_expr, cond);
6331 :
6332 23019 : return res;
6333 : }
6334 :
6335 :
6336 : /* For an array descriptor, get the total number of elements. This is just
6337 : the product of the extents along from_dim to to_dim. */
6338 :
6339 : static tree
6340 1930 : gfc_conv_descriptor_size_1 (tree desc, int from_dim, int to_dim)
6341 : {
6342 1930 : tree res;
6343 1930 : int dim;
6344 :
6345 1930 : res = gfc_index_one_node;
6346 :
6347 4729 : for (dim = from_dim; dim < to_dim; ++dim)
6348 : {
6349 2799 : tree lbound;
6350 2799 : tree ubound;
6351 2799 : tree extent;
6352 :
6353 2799 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
6354 2799 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
6355 :
6356 2799 : extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
6357 2799 : res = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6358 : res, extent);
6359 : }
6360 :
6361 1930 : return res;
6362 : }
6363 :
6364 :
6365 : /* Full size of an array. */
6366 :
6367 : tree
6368 1866 : gfc_conv_descriptor_size (tree desc, int rank)
6369 : {
6370 1866 : return gfc_conv_descriptor_size_1 (desc, 0, rank);
6371 : }
6372 :
6373 :
6374 : /* Size of a coarray for all dimensions but the last. */
6375 :
6376 : tree
6377 64 : gfc_conv_descriptor_cosize (tree desc, int rank, int corank)
6378 : {
6379 64 : return gfc_conv_descriptor_size_1 (desc, rank, rank + corank - 1);
6380 : }
6381 :
6382 :
6383 : /* Fills in an array descriptor, and returns the size of the array.
6384 : The size will be a simple_val, ie a variable or a constant. Also
6385 : calculates the offset of the base. The pointer argument overflow,
6386 : which should be of integer type, will increase in value if overflow
6387 : occurs during the size calculation. Returns the size of the array.
6388 : {
6389 : stride = 1;
6390 : offset = 0;
6391 : for (n = 0; n < rank; n++)
6392 : {
6393 : a.lbound[n] = specified_lower_bound;
6394 : offset = offset + a.lbond[n] * stride;
6395 : size = 1 - lbound;
6396 : a.ubound[n] = specified_upper_bound;
6397 : a.stride[n] = stride;
6398 : size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
6399 : overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
6400 : stride = stride * size;
6401 : }
6402 : for (n = rank; n < rank+corank; n++)
6403 : (Set lcobound/ucobound as above.)
6404 : element_size = sizeof (array element);
6405 : if (!rank)
6406 : return element_size
6407 : stride = (size_t) stride;
6408 : overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
6409 : stride = stride * element_size;
6410 : return (stride);
6411 : } */
6412 : /*GCC ARRAYS*/
6413 :
6414 : static tree
6415 12040 : gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
6416 : gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
6417 : stmtblock_t * descriptor_block, tree * overflow,
6418 : tree expr3_elem_size, gfc_expr *expr3, tree expr3_desc,
6419 : bool e3_has_nodescriptor, gfc_expr *expr,
6420 : tree *element_size, bool explicit_ts)
6421 : {
6422 12040 : tree type;
6423 12040 : tree tmp;
6424 12040 : tree size;
6425 12040 : tree offset;
6426 12040 : tree stride;
6427 12040 : tree or_expr;
6428 12040 : tree thencase;
6429 12040 : tree elsecase;
6430 12040 : tree cond;
6431 12040 : tree var;
6432 12040 : stmtblock_t thenblock;
6433 12040 : stmtblock_t elseblock;
6434 12040 : gfc_expr *ubound;
6435 12040 : gfc_se se;
6436 12040 : int n;
6437 :
6438 12040 : type = TREE_TYPE (descriptor);
6439 :
6440 12040 : stride = gfc_index_one_node;
6441 12040 : offset = gfc_index_zero_node;
6442 :
6443 : /* Set the dtype before the alloc, because registration of coarrays needs
6444 : it initialized. */
6445 12040 : if (expr->ts.type == BT_CHARACTER
6446 1079 : && expr->ts.deferred
6447 545 : && VAR_P (expr->ts.u.cl->backend_decl))
6448 : {
6449 366 : type = gfc_typenode_for_spec (&expr->ts);
6450 366 : tmp = gfc_conv_descriptor_dtype (descriptor);
6451 366 : gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type));
6452 : }
6453 11674 : else if (expr->ts.type == BT_CHARACTER
6454 713 : && expr->ts.deferred
6455 179 : && TREE_CODE (descriptor) == COMPONENT_REF)
6456 : {
6457 : /* Deferred character components have their string length tucked away
6458 : in a hidden field of the derived type. Obtain that and use it to
6459 : set the dtype. The charlen backend decl is zero because the field
6460 : type is zero length. */
6461 161 : gfc_ref *ref;
6462 161 : tmp = NULL_TREE;
6463 161 : for (ref = expr->ref; ref; ref = ref->next)
6464 161 : if (ref->type == REF_COMPONENT
6465 161 : && gfc_deferred_strlen (ref->u.c.component, &tmp))
6466 : break;
6467 161 : gcc_assert (tmp != NULL_TREE);
6468 161 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
6469 161 : TREE_OPERAND (descriptor, 0), tmp, NULL_TREE);
6470 161 : tmp = fold_convert (gfc_charlen_type_node, tmp);
6471 161 : type = gfc_get_character_type_len (expr->ts.kind, tmp);
6472 161 : tmp = gfc_conv_descriptor_dtype (descriptor);
6473 161 : gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type));
6474 161 : }
6475 11513 : else if (expr3_desc && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr3_desc)))
6476 : {
6477 933 : tmp = gfc_conv_descriptor_dtype (descriptor);
6478 933 : gfc_add_modify (pblock, tmp, gfc_conv_descriptor_dtype (expr3_desc));
6479 : }
6480 10580 : else if (expr->ts.type == BT_CLASS && !explicit_ts
6481 1288 : && expr3 && expr3->ts.type != BT_CLASS
6482 343 : && expr3_elem_size != NULL_TREE && expr3_desc == NULL_TREE)
6483 : {
6484 343 : tmp = gfc_conv_descriptor_elem_len (descriptor);
6485 343 : gfc_add_modify (pblock, tmp,
6486 343 : fold_convert (TREE_TYPE (tmp), expr3_elem_size));
6487 : }
6488 : else
6489 : {
6490 10237 : tmp = gfc_conv_descriptor_dtype (descriptor);
6491 10237 : gfc_add_modify (pblock, tmp, gfc_get_dtype (type));
6492 : }
6493 :
6494 12040 : or_expr = logical_false_node;
6495 :
6496 29711 : for (n = 0; n < rank; n++)
6497 : {
6498 17671 : tree conv_lbound;
6499 17671 : tree conv_ubound;
6500 :
6501 : /* We have 3 possibilities for determining the size of the array:
6502 : lower == NULL => lbound = 1, ubound = upper[n]
6503 : upper[n] = NULL => lbound = 1, ubound = lower[n]
6504 : upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
6505 17671 : ubound = upper[n];
6506 :
6507 : /* Set lower bound. */
6508 17671 : gfc_init_se (&se, NULL);
6509 17671 : if (expr3_desc != NULL_TREE)
6510 : {
6511 1476 : if (e3_has_nodescriptor)
6512 : /* The lbound of nondescriptor arrays like array constructors,
6513 : nonallocatable/nonpointer function results/variables,
6514 : start at zero, but when allocating it, the standard expects
6515 : the array to start at one. */
6516 967 : se.expr = gfc_index_one_node;
6517 : else
6518 509 : se.expr = gfc_conv_descriptor_lbound_get (expr3_desc,
6519 : gfc_rank_cst[n]);
6520 : }
6521 16195 : else if (lower == NULL)
6522 13042 : se.expr = gfc_index_one_node;
6523 : else
6524 : {
6525 3153 : gcc_assert (lower[n]);
6526 3153 : if (ubound)
6527 : {
6528 2430 : gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
6529 2430 : gfc_add_block_to_block (pblock, &se.pre);
6530 : }
6531 : else
6532 : {
6533 723 : se.expr = gfc_index_one_node;
6534 723 : ubound = lower[n];
6535 : }
6536 : }
6537 17671 : gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
6538 : gfc_rank_cst[n], se.expr);
6539 17671 : conv_lbound = se.expr;
6540 :
6541 : /* Work out the offset for this component. */
6542 17671 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6543 : se.expr, stride);
6544 17671 : offset = fold_build2_loc (input_location, MINUS_EXPR,
6545 : gfc_array_index_type, offset, tmp);
6546 :
6547 : /* Set upper bound. */
6548 17671 : gfc_init_se (&se, NULL);
6549 17671 : if (expr3_desc != NULL_TREE)
6550 : {
6551 1476 : if (e3_has_nodescriptor)
6552 : {
6553 : /* The lbound of nondescriptor arrays like array constructors,
6554 : nonallocatable/nonpointer function results/variables,
6555 : start at zero, but when allocating it, the standard expects
6556 : the array to start at one. Therefore fix the upper bound to be
6557 : (desc.ubound - desc.lbound) + 1. */
6558 967 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
6559 : gfc_array_index_type,
6560 : gfc_conv_descriptor_ubound_get (
6561 : expr3_desc, gfc_rank_cst[n]),
6562 : gfc_conv_descriptor_lbound_get (
6563 : expr3_desc, gfc_rank_cst[n]));
6564 967 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
6565 : gfc_array_index_type, tmp,
6566 : gfc_index_one_node);
6567 967 : se.expr = gfc_evaluate_now (tmp, pblock);
6568 : }
6569 : else
6570 509 : se.expr = gfc_conv_descriptor_ubound_get (expr3_desc,
6571 : gfc_rank_cst[n]);
6572 : }
6573 : else
6574 : {
6575 16195 : gcc_assert (ubound);
6576 16195 : gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
6577 16195 : gfc_add_block_to_block (pblock, &se.pre);
6578 16195 : if (ubound->expr_type == EXPR_FUNCTION)
6579 750 : se.expr = gfc_evaluate_now (se.expr, pblock);
6580 : }
6581 17671 : gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
6582 : gfc_rank_cst[n], se.expr);
6583 17671 : conv_ubound = se.expr;
6584 :
6585 : /* Store the stride. */
6586 17671 : gfc_conv_descriptor_stride_set (descriptor_block, descriptor,
6587 : gfc_rank_cst[n], stride);
6588 :
6589 : /* Calculate size and check whether extent is negative. */
6590 17671 : size = gfc_conv_array_extent_dim (conv_lbound, conv_ubound, &or_expr);
6591 17671 : size = gfc_evaluate_now (size, pblock);
6592 :
6593 : /* Check whether multiplying the stride by the number of
6594 : elements in this dimension would overflow. We must also check
6595 : whether the current dimension has zero size in order to avoid
6596 : division by zero.
6597 : */
6598 17671 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
6599 : gfc_array_index_type,
6600 17671 : fold_convert (gfc_array_index_type,
6601 : TYPE_MAX_VALUE (gfc_array_index_type)),
6602 : size);
6603 17671 : cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
6604 : logical_type_node, tmp, stride),
6605 : PRED_FORTRAN_OVERFLOW);
6606 17671 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
6607 : integer_one_node, integer_zero_node);
6608 17671 : cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
6609 : logical_type_node, size,
6610 : gfc_index_zero_node),
6611 : PRED_FORTRAN_SIZE_ZERO);
6612 17671 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
6613 : integer_zero_node, tmp);
6614 17671 : tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
6615 : *overflow, tmp);
6616 17671 : *overflow = gfc_evaluate_now (tmp, pblock);
6617 :
6618 : /* Multiply the stride by the number of elements in this dimension. */
6619 17671 : stride = fold_build2_loc (input_location, MULT_EXPR,
6620 : gfc_array_index_type, stride, size);
6621 17671 : stride = gfc_evaluate_now (stride, pblock);
6622 : }
6623 :
6624 12678 : for (n = rank; n < rank + corank; n++)
6625 : {
6626 638 : ubound = upper[n];
6627 :
6628 : /* Set lower bound. */
6629 638 : gfc_init_se (&se, NULL);
6630 638 : if (lower == NULL || lower[n] == NULL)
6631 : {
6632 369 : gcc_assert (n == rank + corank - 1);
6633 369 : se.expr = gfc_index_one_node;
6634 : }
6635 : else
6636 : {
6637 269 : if (ubound || n == rank + corank - 1)
6638 : {
6639 175 : gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
6640 175 : gfc_add_block_to_block (pblock, &se.pre);
6641 : }
6642 : else
6643 : {
6644 94 : se.expr = gfc_index_one_node;
6645 94 : ubound = lower[n];
6646 : }
6647 : }
6648 638 : gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
6649 : gfc_rank_cst[n], se.expr);
6650 :
6651 638 : if (n < rank + corank - 1)
6652 : {
6653 178 : gfc_init_se (&se, NULL);
6654 178 : gcc_assert (ubound);
6655 178 : gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
6656 178 : gfc_add_block_to_block (pblock, &se.pre);
6657 178 : gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
6658 : gfc_rank_cst[n], se.expr);
6659 : }
6660 : }
6661 :
6662 : /* The stride is the number of elements in the array, so multiply by the
6663 : size of an element to get the total size. Obviously, if there is a
6664 : SOURCE expression (expr3) we must use its element size. */
6665 12040 : if (expr3_elem_size != NULL_TREE)
6666 3009 : tmp = expr3_elem_size;
6667 9031 : else if (expr3 != NULL)
6668 : {
6669 0 : if (expr3->ts.type == BT_CLASS)
6670 : {
6671 0 : gfc_se se_sz;
6672 0 : gfc_expr *sz = gfc_copy_expr (expr3);
6673 0 : gfc_add_vptr_component (sz);
6674 0 : gfc_add_size_component (sz);
6675 0 : gfc_init_se (&se_sz, NULL);
6676 0 : gfc_conv_expr (&se_sz, sz);
6677 0 : gfc_free_expr (sz);
6678 0 : tmp = se_sz.expr;
6679 : }
6680 : else
6681 : {
6682 0 : tmp = gfc_typenode_for_spec (&expr3->ts);
6683 0 : tmp = TYPE_SIZE_UNIT (tmp);
6684 : }
6685 : }
6686 : else
6687 9031 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
6688 :
6689 : /* Convert to size_t. */
6690 12040 : *element_size = fold_convert (size_type_node, tmp);
6691 :
6692 12040 : if (rank == 0)
6693 : return *element_size;
6694 :
6695 11840 : stride = fold_convert (size_type_node, stride);
6696 :
6697 : /* First check for overflow. Since an array of type character can
6698 : have zero element_size, we must check for that before
6699 : dividing. */
6700 11840 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
6701 : size_type_node,
6702 11840 : TYPE_MAX_VALUE (size_type_node), *element_size);
6703 11840 : cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
6704 : logical_type_node, tmp, stride),
6705 : PRED_FORTRAN_OVERFLOW);
6706 11840 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
6707 : integer_one_node, integer_zero_node);
6708 11840 : cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
6709 : logical_type_node, *element_size,
6710 : build_int_cst (size_type_node, 0)),
6711 : PRED_FORTRAN_SIZE_ZERO);
6712 11840 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
6713 : integer_zero_node, tmp);
6714 11840 : tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
6715 : *overflow, tmp);
6716 11840 : *overflow = gfc_evaluate_now (tmp, pblock);
6717 :
6718 11840 : size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
6719 : stride, *element_size);
6720 :
6721 11840 : if (poffset != NULL)
6722 : {
6723 11840 : offset = gfc_evaluate_now (offset, pblock);
6724 11840 : *poffset = offset;
6725 : }
6726 :
6727 11840 : if (integer_zerop (or_expr))
6728 : return size;
6729 3600 : if (integer_onep (or_expr))
6730 599 : return build_int_cst (size_type_node, 0);
6731 :
6732 3001 : var = gfc_create_var (TREE_TYPE (size), "size");
6733 3001 : gfc_start_block (&thenblock);
6734 3001 : gfc_add_modify (&thenblock, var, build_int_cst (size_type_node, 0));
6735 3001 : thencase = gfc_finish_block (&thenblock);
6736 :
6737 3001 : gfc_start_block (&elseblock);
6738 3001 : gfc_add_modify (&elseblock, var, size);
6739 3001 : elsecase = gfc_finish_block (&elseblock);
6740 :
6741 3001 : tmp = gfc_evaluate_now (or_expr, pblock);
6742 3001 : tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
6743 3001 : gfc_add_expr_to_block (pblock, tmp);
6744 :
6745 3001 : return var;
6746 : }
6747 :
6748 :
6749 : /* Retrieve the last ref from the chain. This routine is specific to
6750 : gfc_array_allocate ()'s needs. */
6751 :
6752 : bool
6753 18403 : retrieve_last_ref (gfc_ref **ref_in, gfc_ref **prev_ref_in)
6754 : {
6755 18403 : gfc_ref *ref, *prev_ref;
6756 :
6757 18403 : ref = *ref_in;
6758 : /* Prevent warnings for uninitialized variables. */
6759 18403 : prev_ref = *prev_ref_in;
6760 25402 : while (ref && ref->next != NULL)
6761 : {
6762 6999 : gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
6763 : || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
6764 : prev_ref = ref;
6765 : ref = ref->next;
6766 : }
6767 :
6768 18403 : if (ref == NULL || ref->type != REF_ARRAY)
6769 : return false;
6770 :
6771 13258 : *ref_in = ref;
6772 13258 : *prev_ref_in = prev_ref;
6773 13258 : return true;
6774 : }
6775 :
6776 : /* Initializes the descriptor and generates a call to _gfor_allocate. Does
6777 : the work for an ALLOCATE statement. */
6778 : /*GCC ARRAYS*/
6779 :
6780 : bool
6781 17185 : gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
6782 : tree errlen, tree label_finish, tree expr3_elem_size,
6783 : gfc_expr *expr3, tree e3_arr_desc, bool e3_has_nodescriptor,
6784 : gfc_omp_namelist *omp_alloc, bool explicit_ts)
6785 : {
6786 17185 : tree tmp;
6787 17185 : tree pointer;
6788 17185 : tree offset = NULL_TREE;
6789 17185 : tree token = NULL_TREE;
6790 17185 : tree size;
6791 17185 : tree msg;
6792 17185 : tree error = NULL_TREE;
6793 17185 : tree overflow; /* Boolean storing whether size calculation overflows. */
6794 17185 : tree var_overflow = NULL_TREE;
6795 17185 : tree cond;
6796 17185 : tree set_descriptor;
6797 17185 : tree not_prev_allocated = NULL_TREE;
6798 17185 : tree element_size = NULL_TREE;
6799 17185 : stmtblock_t set_descriptor_block;
6800 17185 : stmtblock_t elseblock;
6801 17185 : gfc_expr **lower;
6802 17185 : gfc_expr **upper;
6803 17185 : gfc_ref *ref, *prev_ref = NULL, *coref;
6804 17185 : bool allocatable, coarray, dimension, alloc_w_e3_arr_spec = false,
6805 : non_ulimate_coarray_ptr_comp;
6806 17185 : tree omp_cond = NULL_TREE, omp_alt_alloc = NULL_TREE;
6807 :
6808 17185 : ref = expr->ref;
6809 :
6810 : /* Find the last reference in the chain. */
6811 17185 : if (!retrieve_last_ref (&ref, &prev_ref))
6812 : return false;
6813 :
6814 : /* Take the allocatable and coarray properties solely from the expr-ref's
6815 : attributes and not from source=-expression. */
6816 12040 : if (!prev_ref)
6817 : {
6818 8272 : allocatable = expr->symtree->n.sym->attr.allocatable;
6819 8272 : dimension = expr->symtree->n.sym->attr.dimension;
6820 8272 : non_ulimate_coarray_ptr_comp = false;
6821 : }
6822 : else
6823 : {
6824 3768 : allocatable = prev_ref->u.c.component->attr.allocatable;
6825 : /* Pointer components in coarrayed derived types must be treated
6826 : specially in that they are registered without a check if the are
6827 : already associated. This does not hold for ultimate coarray
6828 : pointers. */
6829 7536 : non_ulimate_coarray_ptr_comp = (prev_ref->u.c.component->attr.pointer
6830 3768 : && !prev_ref->u.c.component->attr.codimension);
6831 3768 : dimension = prev_ref->u.c.component->attr.dimension;
6832 : }
6833 :
6834 : /* For allocatable/pointer arrays in derived types, one of the refs has to be
6835 : a coarray. In this case it does not matter whether we are on this_image
6836 : or not. */
6837 12040 : coarray = false;
6838 28746 : for (coref = expr->ref; coref; coref = coref->next)
6839 17338 : if (coref->type == REF_ARRAY && coref->u.ar.codimen > 0)
6840 : {
6841 : coarray = true;
6842 : break;
6843 : }
6844 :
6845 12040 : if (!dimension)
6846 200 : gcc_assert (coarray);
6847 :
6848 12040 : if (ref->u.ar.type == AR_FULL && expr3 != NULL)
6849 : {
6850 1218 : gfc_ref *old_ref = ref;
6851 : /* F08:C633: Array shape from expr3. */
6852 1218 : ref = expr3->ref;
6853 :
6854 : /* Find the last reference in the chain. */
6855 1218 : if (!retrieve_last_ref (&ref, &prev_ref))
6856 : {
6857 0 : if (expr3->expr_type == EXPR_FUNCTION
6858 0 : && gfc_expr_attr (expr3).dimension)
6859 0 : ref = old_ref;
6860 : else
6861 0 : return false;
6862 : }
6863 : alloc_w_e3_arr_spec = true;
6864 : }
6865 :
6866 : /* Figure out the size of the array. */
6867 12040 : switch (ref->u.ar.type)
6868 : {
6869 9173 : case AR_ELEMENT:
6870 9173 : if (!coarray)
6871 : {
6872 8593 : lower = NULL;
6873 8593 : upper = ref->u.ar.start;
6874 8593 : break;
6875 : }
6876 : /* Fall through. */
6877 :
6878 2260 : case AR_SECTION:
6879 2260 : lower = ref->u.ar.start;
6880 2260 : upper = ref->u.ar.end;
6881 2260 : break;
6882 :
6883 1187 : case AR_FULL:
6884 1187 : gcc_assert (ref->u.ar.as->type == AS_EXPLICIT
6885 : || alloc_w_e3_arr_spec);
6886 :
6887 1187 : lower = ref->u.ar.as->lower;
6888 1187 : upper = ref->u.ar.as->upper;
6889 1187 : break;
6890 :
6891 0 : default:
6892 0 : gcc_unreachable ();
6893 12040 : break;
6894 : }
6895 :
6896 12040 : overflow = integer_zero_node;
6897 :
6898 12040 : if (expr->ts.type == BT_CHARACTER
6899 1079 : && TREE_CODE (se->string_length) == COMPONENT_REF
6900 161 : && expr->ts.u.cl->backend_decl != se->string_length
6901 161 : && VAR_P (expr->ts.u.cl->backend_decl))
6902 0 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
6903 0 : fold_convert (TREE_TYPE (expr->ts.u.cl->backend_decl),
6904 : se->string_length));
6905 :
6906 12040 : gfc_init_block (&set_descriptor_block);
6907 : /* Take the corank only from the actual ref and not from the coref. The
6908 : later will mislead the generation of the array dimensions for allocatable/
6909 : pointer components in derived types. */
6910 23494 : size = gfc_array_init_size (se->expr, alloc_w_e3_arr_spec ? expr->rank
6911 10822 : : ref->u.ar.as->rank,
6912 632 : coarray ? ref->u.ar.as->corank : 0,
6913 : &offset, lower, upper,
6914 : &se->pre, &set_descriptor_block, &overflow,
6915 : expr3_elem_size, expr3, e3_arr_desc,
6916 : e3_has_nodescriptor, expr, &element_size,
6917 : explicit_ts);
6918 :
6919 12040 : if (dimension)
6920 : {
6921 11840 : var_overflow = gfc_create_var (integer_type_node, "overflow");
6922 11840 : gfc_add_modify (&se->pre, var_overflow, overflow);
6923 :
6924 11840 : if (status == NULL_TREE)
6925 : {
6926 : /* Generate the block of code handling overflow. */
6927 11618 : msg = gfc_build_addr_expr (pchar_type_node,
6928 : gfc_build_localized_cstring_const
6929 : ("Integer overflow when calculating the amount of "
6930 : "memory to allocate"));
6931 11618 : error = build_call_expr_loc (input_location,
6932 : gfor_fndecl_runtime_error, 1, msg);
6933 : }
6934 : else
6935 : {
6936 222 : tree status_type = TREE_TYPE (status);
6937 222 : stmtblock_t set_status_block;
6938 :
6939 222 : gfc_start_block (&set_status_block);
6940 222 : gfc_add_modify (&set_status_block, status,
6941 : build_int_cst (status_type, LIBERROR_ALLOCATION));
6942 222 : error = gfc_finish_block (&set_status_block);
6943 : }
6944 : }
6945 :
6946 : /* Allocate memory to store the data. */
6947 12040 : if (POINTER_TYPE_P (TREE_TYPE (se->expr)))
6948 0 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
6949 :
6950 12040 : if (coarray && flag_coarray == GFC_FCOARRAY_LIB)
6951 : {
6952 393 : pointer = non_ulimate_coarray_ptr_comp ? se->expr
6953 321 : : gfc_conv_descriptor_data_get (se->expr);
6954 393 : token = gfc_conv_descriptor_token (se->expr);
6955 393 : token = gfc_build_addr_expr (NULL_TREE, token);
6956 : }
6957 : else
6958 : {
6959 11647 : pointer = gfc_conv_descriptor_data_get (se->expr);
6960 11647 : if (omp_alloc)
6961 33 : omp_cond = boolean_true_node;
6962 : }
6963 12040 : STRIP_NOPS (pointer);
6964 :
6965 12040 : if (allocatable)
6966 : {
6967 9895 : not_prev_allocated = gfc_create_var (logical_type_node,
6968 : "not_prev_allocated");
6969 9895 : tmp = fold_build2_loc (input_location, EQ_EXPR,
6970 : logical_type_node, pointer,
6971 9895 : build_int_cst (TREE_TYPE (pointer), 0));
6972 :
6973 9895 : gfc_add_modify (&se->pre, not_prev_allocated, tmp);
6974 : }
6975 :
6976 12040 : gfc_start_block (&elseblock);
6977 :
6978 12040 : tree succ_add_expr = NULL_TREE;
6979 12040 : if (omp_cond)
6980 : {
6981 33 : tree align, alloc, sz;
6982 33 : gfc_se se2;
6983 33 : if (omp_alloc->u2.allocator)
6984 : {
6985 10 : gfc_init_se (&se2, NULL);
6986 10 : gfc_conv_expr (&se2, omp_alloc->u2.allocator);
6987 10 : gfc_add_block_to_block (&elseblock, &se2.pre);
6988 10 : alloc = gfc_evaluate_now (se2.expr, &elseblock);
6989 10 : gfc_add_block_to_block (&elseblock, &se2.post);
6990 : }
6991 : else
6992 23 : alloc = build_zero_cst (ptr_type_node);
6993 33 : tmp = TREE_TYPE (TREE_TYPE (pointer));
6994 33 : if (tmp == void_type_node)
6995 33 : tmp = gfc_typenode_for_spec (&expr->ts, 0);
6996 33 : if (omp_alloc->u.align)
6997 : {
6998 17 : gfc_init_se (&se2, NULL);
6999 17 : gfc_conv_expr (&se2, omp_alloc->u.align);
7000 17 : gcc_assert (CONSTANT_CLASS_P (se2.expr)
7001 : && se2.pre.head == NULL
7002 : && se2.post.head == NULL);
7003 17 : align = build_int_cst (size_type_node,
7004 17 : MAX (tree_to_uhwi (se2.expr),
7005 : TYPE_ALIGN_UNIT (tmp)));
7006 : }
7007 : else
7008 16 : align = build_int_cst (size_type_node, TYPE_ALIGN_UNIT (tmp));
7009 33 : sz = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
7010 : fold_convert (size_type_node, size),
7011 : build_int_cst (size_type_node, 1));
7012 33 : omp_alt_alloc = builtin_decl_explicit (BUILT_IN_GOMP_ALLOC);
7013 33 : DECL_ATTRIBUTES (omp_alt_alloc)
7014 33 : = tree_cons (get_identifier ("omp allocator"),
7015 : build_tree_list (NULL_TREE, alloc),
7016 33 : DECL_ATTRIBUTES (omp_alt_alloc));
7017 33 : omp_alt_alloc = build_call_expr (omp_alt_alloc, 3, align, sz, alloc);
7018 33 : succ_add_expr = fold_build2_loc (input_location, MODIFY_EXPR,
7019 : void_type_node,
7020 : gfc_conv_descriptor_version (se->expr),
7021 : build_int_cst (integer_type_node, 1));
7022 : }
7023 :
7024 : /* The allocatable variant takes the old pointer as first argument. */
7025 12040 : if (allocatable)
7026 10452 : gfc_allocate_allocatable (&elseblock, pointer, size, token,
7027 : status, errmsg, errlen, label_finish, expr,
7028 557 : coref != NULL ? coref->u.ar.as->corank : 0,
7029 : omp_cond, omp_alt_alloc, succ_add_expr);
7030 2145 : else if (non_ulimate_coarray_ptr_comp && token)
7031 : /* The token is set only for GFC_FCOARRAY_LIB mode. */
7032 72 : gfc_allocate_using_caf_lib (&elseblock, pointer, size, token, status,
7033 : errmsg, errlen,
7034 : GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY);
7035 : else
7036 2073 : gfc_allocate_using_malloc (&elseblock, pointer, size, status,
7037 : omp_cond, omp_alt_alloc, succ_add_expr);
7038 :
7039 12040 : if (dimension)
7040 : {
7041 11840 : cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
7042 : logical_type_node, var_overflow, integer_zero_node),
7043 : PRED_FORTRAN_OVERFLOW);
7044 11840 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
7045 : error, gfc_finish_block (&elseblock));
7046 : }
7047 : else
7048 200 : tmp = gfc_finish_block (&elseblock);
7049 :
7050 12040 : gfc_add_expr_to_block (&se->pre, tmp);
7051 :
7052 : /* Update the array descriptor with the offset and the span. */
7053 12040 : if (dimension)
7054 : {
7055 11840 : gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
7056 11840 : tmp = fold_convert (gfc_array_index_type, element_size);
7057 11840 : gfc_conv_descriptor_span_set (&set_descriptor_block, se->expr, tmp);
7058 : }
7059 :
7060 12040 : set_descriptor = gfc_finish_block (&set_descriptor_block);
7061 12040 : if (status != NULL_TREE)
7062 : {
7063 238 : cond = fold_build2_loc (input_location, EQ_EXPR,
7064 : logical_type_node, status,
7065 238 : build_int_cst (TREE_TYPE (status), 0));
7066 :
7067 238 : if (not_prev_allocated != NULL_TREE)
7068 222 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
7069 : logical_type_node, cond, not_prev_allocated);
7070 :
7071 238 : gfc_add_expr_to_block (&se->pre,
7072 : fold_build3_loc (input_location, COND_EXPR, void_type_node,
7073 : cond,
7074 : set_descriptor,
7075 : build_empty_stmt (input_location)));
7076 : }
7077 : else
7078 11802 : gfc_add_expr_to_block (&se->pre, set_descriptor);
7079 :
7080 : return true;
7081 : }
7082 :
7083 :
7084 : /* Create an array constructor from an initialization expression.
7085 : We assume the frontend already did any expansions and conversions. */
7086 :
7087 : tree
7088 7655 : gfc_conv_array_initializer (tree type, gfc_expr * expr)
7089 : {
7090 7655 : gfc_constructor *c;
7091 7655 : tree tmp;
7092 7655 : gfc_se se;
7093 7655 : tree index, range;
7094 7655 : vec<constructor_elt, va_gc> *v = NULL;
7095 :
7096 7655 : if (expr->expr_type == EXPR_VARIABLE
7097 0 : && expr->symtree->n.sym->attr.flavor == FL_PARAMETER
7098 0 : && expr->symtree->n.sym->value)
7099 7655 : expr = expr->symtree->n.sym->value;
7100 :
7101 : /* After parameter substitution the expression should be a constant, array
7102 : constructor, structure constructor, or NULL. Anything else is invalid
7103 : and must not ICE later in lowering. */
7104 7655 : if (expr->expr_type != EXPR_CONSTANT
7105 7271 : && expr->expr_type != EXPR_STRUCTURE
7106 6535 : && expr->expr_type != EXPR_ARRAY
7107 1 : && expr->expr_type != EXPR_NULL)
7108 : {
7109 1 : gfc_error ("Array initializer at %L does not reduce to a constant "
7110 : "expression", &expr->where);
7111 1 : return build_constructor (type, NULL);
7112 : }
7113 :
7114 7654 : switch (expr->expr_type)
7115 : {
7116 1120 : case EXPR_CONSTANT:
7117 1120 : case EXPR_STRUCTURE:
7118 : /* A single scalar or derived type value. Create an array with all
7119 : elements equal to that value. */
7120 1120 : gfc_init_se (&se, NULL);
7121 :
7122 1120 : if (expr->expr_type == EXPR_CONSTANT)
7123 384 : gfc_conv_constant (&se, expr);
7124 : else
7125 736 : gfc_conv_structure (&se, expr, 1);
7126 :
7127 2240 : if (tree_int_cst_lt (TYPE_MAX_VALUE (TYPE_DOMAIN (type)),
7128 1120 : TYPE_MIN_VALUE (TYPE_DOMAIN (type))))
7129 : break;
7130 2216 : else if (tree_int_cst_equal (TYPE_MIN_VALUE (TYPE_DOMAIN (type)),
7131 1108 : TYPE_MAX_VALUE (TYPE_DOMAIN (type))))
7132 155 : range = TYPE_MIN_VALUE (TYPE_DOMAIN (type));
7133 : else
7134 1906 : range = build2 (RANGE_EXPR, gfc_array_index_type,
7135 953 : TYPE_MIN_VALUE (TYPE_DOMAIN (type)),
7136 953 : TYPE_MAX_VALUE (TYPE_DOMAIN (type)));
7137 1108 : CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
7138 1108 : break;
7139 :
7140 6534 : case EXPR_ARRAY:
7141 : /* Create a vector of all the elements. */
7142 6534 : for (c = gfc_constructor_first (expr->value.constructor);
7143 164298 : c && c->expr; c = gfc_constructor_next (c))
7144 : {
7145 157764 : if (c->iterator)
7146 : {
7147 : /* Problems occur when we get something like
7148 : integer :: a(lots) = (/(i, i=1, lots)/) */
7149 0 : gfc_fatal_error ("The number of elements in the array "
7150 : "constructor at %L requires an increase of "
7151 : "the allowed %d upper limit. See "
7152 : "%<-fmax-array-constructor%> option",
7153 : &expr->where, flag_max_array_constructor);
7154 : return NULL_TREE;
7155 : }
7156 157764 : if (mpz_cmp_si (c->offset, 0) != 0)
7157 151490 : index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
7158 : else
7159 : index = NULL_TREE;
7160 :
7161 157764 : if (mpz_cmp_si (c->repeat, 1) > 0)
7162 : {
7163 127 : tree tmp1, tmp2;
7164 127 : mpz_t maxval;
7165 :
7166 127 : mpz_init (maxval);
7167 127 : mpz_add (maxval, c->offset, c->repeat);
7168 127 : mpz_sub_ui (maxval, maxval, 1);
7169 127 : tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
7170 127 : if (mpz_cmp_si (c->offset, 0) != 0)
7171 : {
7172 27 : mpz_add_ui (maxval, c->offset, 1);
7173 27 : tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
7174 : }
7175 : else
7176 100 : tmp1 = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
7177 :
7178 127 : range = fold_build2 (RANGE_EXPR, gfc_array_index_type, tmp1, tmp2);
7179 127 : mpz_clear (maxval);
7180 : }
7181 : else
7182 : range = NULL;
7183 :
7184 157764 : gfc_init_se (&se, NULL);
7185 157764 : switch (c->expr->expr_type)
7186 : {
7187 156302 : case EXPR_CONSTANT:
7188 156302 : gfc_conv_constant (&se, c->expr);
7189 :
7190 : /* See gfortran.dg/charlen_15.f90 for instance. */
7191 156302 : if (TREE_CODE (se.expr) == STRING_CST
7192 5206 : && TREE_CODE (type) == ARRAY_TYPE)
7193 : {
7194 : tree atype = type;
7195 10412 : while (TREE_CODE (TREE_TYPE (atype)) == ARRAY_TYPE)
7196 5206 : atype = TREE_TYPE (atype);
7197 5206 : gcc_checking_assert (TREE_CODE (TREE_TYPE (atype))
7198 : == INTEGER_TYPE);
7199 5206 : gcc_checking_assert (TREE_TYPE (TREE_TYPE (se.expr))
7200 : == TREE_TYPE (atype));
7201 5206 : if (tree_to_uhwi (TYPE_SIZE_UNIT (TREE_TYPE (se.expr)))
7202 5206 : > tree_to_uhwi (TYPE_SIZE_UNIT (atype)))
7203 : {
7204 0 : unsigned HOST_WIDE_INT size
7205 0 : = tree_to_uhwi (TYPE_SIZE_UNIT (atype));
7206 0 : const char *p = TREE_STRING_POINTER (se.expr);
7207 :
7208 0 : se.expr = build_string (size, p);
7209 : }
7210 5206 : TREE_TYPE (se.expr) = atype;
7211 : }
7212 : break;
7213 :
7214 1462 : case EXPR_STRUCTURE:
7215 1462 : gfc_conv_structure (&se, c->expr, 1);
7216 1462 : break;
7217 :
7218 0 : default:
7219 : /* Catch those occasional beasts that do not simplify
7220 : for one reason or another, assuming that if they are
7221 : standard defying the frontend will catch them. */
7222 0 : gfc_conv_expr (&se, c->expr);
7223 0 : break;
7224 : }
7225 :
7226 157764 : if (range == NULL_TREE)
7227 157637 : CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
7228 : else
7229 : {
7230 127 : if (index != NULL_TREE)
7231 27 : CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
7232 157891 : CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
7233 : }
7234 : }
7235 : break;
7236 :
7237 0 : case EXPR_NULL:
7238 0 : return gfc_build_null_descriptor (type);
7239 :
7240 0 : default:
7241 0 : gcc_unreachable ();
7242 : }
7243 :
7244 : /* Create a constructor from the list of elements. */
7245 7654 : tmp = build_constructor (type, v);
7246 7654 : TREE_CONSTANT (tmp) = 1;
7247 7654 : return tmp;
7248 : }
7249 :
7250 :
7251 : /* Generate code to evaluate non-constant coarray cobounds. */
7252 :
7253 : void
7254 20683 : gfc_trans_array_cobounds (tree type, stmtblock_t * pblock,
7255 : const gfc_symbol *sym)
7256 : {
7257 20683 : int dim;
7258 20683 : tree ubound;
7259 20683 : tree lbound;
7260 20683 : gfc_se se;
7261 20683 : gfc_array_spec *as;
7262 :
7263 20683 : as = IS_CLASS_COARRAY_OR_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
7264 :
7265 21659 : for (dim = as->rank; dim < as->rank + as->corank; dim++)
7266 : {
7267 : /* Evaluate non-constant array bound expressions.
7268 : F2008 4.5.6.3 para 6: If a specification expression in a scoping unit
7269 : references a function, the result is finalized before execution of the
7270 : executable constructs in the scoping unit.
7271 : Adding the finalblocks enables this. */
7272 976 : lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
7273 976 : if (as->lower[dim] && !INTEGER_CST_P (lbound))
7274 : {
7275 114 : gfc_init_se (&se, NULL);
7276 114 : gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
7277 114 : gfc_add_block_to_block (pblock, &se.pre);
7278 114 : gfc_add_block_to_block (pblock, &se.finalblock);
7279 114 : gfc_add_modify (pblock, lbound, se.expr);
7280 : }
7281 976 : ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
7282 976 : if (as->upper[dim] && !INTEGER_CST_P (ubound))
7283 : {
7284 60 : gfc_init_se (&se, NULL);
7285 60 : gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
7286 60 : gfc_add_block_to_block (pblock, &se.pre);
7287 60 : gfc_add_block_to_block (pblock, &se.finalblock);
7288 60 : gfc_add_modify (pblock, ubound, se.expr);
7289 : }
7290 : }
7291 20683 : }
7292 :
7293 :
7294 : /* Generate code to evaluate non-constant array bounds. Sets *poffset and
7295 : returns the size (in elements) of the array. */
7296 :
7297 : tree
7298 13476 : gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
7299 : stmtblock_t * pblock)
7300 : {
7301 13476 : gfc_array_spec *as;
7302 13476 : tree size;
7303 13476 : tree stride;
7304 13476 : tree offset;
7305 13476 : tree ubound;
7306 13476 : tree lbound;
7307 13476 : tree tmp;
7308 13476 : gfc_se se;
7309 :
7310 13476 : int dim;
7311 :
7312 13476 : as = IS_CLASS_COARRAY_OR_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
7313 :
7314 13476 : size = gfc_index_one_node;
7315 13476 : offset = gfc_index_zero_node;
7316 13476 : stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
7317 13476 : if (stride && VAR_P (stride))
7318 124 : gfc_add_modify (pblock, stride, gfc_index_one_node);
7319 30200 : for (dim = 0; dim < as->rank; dim++)
7320 : {
7321 : /* Evaluate non-constant array bound expressions.
7322 : F2008 4.5.6.3 para 6: If a specification expression in a scoping unit
7323 : references a function, the result is finalized before execution of the
7324 : executable constructs in the scoping unit.
7325 : Adding the finalblocks enables this. */
7326 16724 : lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
7327 16724 : if (as->lower[dim] && !INTEGER_CST_P (lbound))
7328 : {
7329 475 : gfc_init_se (&se, NULL);
7330 475 : gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
7331 475 : gfc_add_block_to_block (pblock, &se.pre);
7332 475 : gfc_add_block_to_block (pblock, &se.finalblock);
7333 475 : gfc_add_modify (pblock, lbound, se.expr);
7334 : }
7335 16724 : ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
7336 16724 : if (as->upper[dim] && !INTEGER_CST_P (ubound))
7337 : {
7338 10212 : gfc_init_se (&se, NULL);
7339 10212 : gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
7340 10212 : gfc_add_block_to_block (pblock, &se.pre);
7341 10212 : gfc_add_block_to_block (pblock, &se.finalblock);
7342 10212 : gfc_add_modify (pblock, ubound, se.expr);
7343 : }
7344 : /* The offset of this dimension. offset = offset - lbound * stride. */
7345 16724 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7346 : lbound, size);
7347 16724 : offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7348 : offset, tmp);
7349 :
7350 : /* The size of this dimension, and the stride of the next. */
7351 16724 : if (dim + 1 < as->rank)
7352 3447 : stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
7353 : else
7354 13277 : stride = GFC_TYPE_ARRAY_SIZE (type);
7355 :
7356 16724 : if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
7357 : {
7358 : /* Calculate stride = size * (ubound + 1 - lbound). */
7359 10402 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
7360 : gfc_array_index_type,
7361 : gfc_index_one_node, lbound);
7362 10402 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
7363 : gfc_array_index_type, ubound, tmp);
7364 10402 : tmp = fold_build2_loc (input_location, MULT_EXPR,
7365 : gfc_array_index_type, size, tmp);
7366 10402 : if (stride)
7367 10402 : gfc_add_modify (pblock, stride, tmp);
7368 : else
7369 0 : stride = gfc_evaluate_now (tmp, pblock);
7370 :
7371 : /* Make sure that negative size arrays are translated
7372 : to being zero size. */
7373 10402 : tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
7374 : stride, gfc_index_zero_node);
7375 10402 : tmp = fold_build3_loc (input_location, COND_EXPR,
7376 : gfc_array_index_type, tmp,
7377 : stride, gfc_index_zero_node);
7378 10402 : gfc_add_modify (pblock, stride, tmp);
7379 : }
7380 :
7381 : size = stride;
7382 : }
7383 :
7384 13476 : gfc_trans_array_cobounds (type, pblock, sym);
7385 13476 : gfc_trans_vla_type_sizes (sym, pblock);
7386 :
7387 13476 : *poffset = offset;
7388 13476 : return size;
7389 : }
7390 :
7391 :
7392 : /* Generate code to initialize/allocate an array variable. */
7393 :
7394 : void
7395 31308 : gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
7396 : gfc_wrapped_block * block)
7397 : {
7398 31308 : stmtblock_t init;
7399 31308 : tree type;
7400 31308 : tree tmp = NULL_TREE;
7401 31308 : tree size;
7402 31308 : tree offset;
7403 31308 : tree space;
7404 31308 : tree inittree;
7405 31308 : bool onstack;
7406 31308 : bool back;
7407 :
7408 31308 : gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
7409 :
7410 : /* Do nothing for USEd variables. */
7411 31308 : if (sym->attr.use_assoc)
7412 25582 : return;
7413 :
7414 31265 : type = TREE_TYPE (decl);
7415 31265 : gcc_assert (GFC_ARRAY_TYPE_P (type));
7416 31265 : onstack = TREE_CODE (type) != POINTER_TYPE;
7417 :
7418 : /* In the case of non-dummy symbols with dependencies on an old-fashioned
7419 : function result (ie. proc_name = proc_name->result), gfc_add_init_cleanup
7420 : must be called with the last, optional argument false so that the alloc-
7421 : ation occurs after the processing of the result. */
7422 31265 : back = sym->fn_result_dep;
7423 :
7424 31265 : gfc_init_block (&init);
7425 :
7426 : /* Evaluate character string length. */
7427 31265 : if (sym->ts.type == BT_CHARACTER
7428 3028 : && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
7429 : {
7430 43 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7431 :
7432 43 : gfc_trans_vla_type_sizes (sym, &init);
7433 :
7434 : /* Emit a DECL_EXPR for this variable, which will cause the
7435 : gimplifier to allocate storage, and all that good stuff. */
7436 43 : tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
7437 43 : gfc_add_expr_to_block (&init, tmp);
7438 43 : if (sym->attr.omp_allocate)
7439 : {
7440 : /* Save location of size calculation to ensure GOMP_alloc is placed
7441 : after it. */
7442 0 : tree omp_alloc = lookup_attribute ("omp allocate",
7443 0 : DECL_ATTRIBUTES (decl));
7444 0 : TREE_CHAIN (TREE_CHAIN (TREE_VALUE (omp_alloc)))
7445 0 : = build_tree_list (NULL_TREE, tsi_stmt (tsi_last (init.head)));
7446 : }
7447 : }
7448 :
7449 31063 : if (onstack)
7450 : {
7451 25399 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE,
7452 : back);
7453 25399 : return;
7454 : }
7455 :
7456 5866 : type = TREE_TYPE (type);
7457 :
7458 5866 : gcc_assert (!sym->attr.use_assoc);
7459 5866 : gcc_assert (!sym->module);
7460 :
7461 5866 : if (sym->ts.type == BT_CHARACTER
7462 202 : && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
7463 94 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7464 :
7465 5866 : size = gfc_trans_array_bounds (type, sym, &offset, &init);
7466 :
7467 : /* Don't actually allocate space for Cray Pointees. */
7468 5866 : if (sym->attr.cray_pointee)
7469 : {
7470 140 : if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
7471 49 : gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
7472 :
7473 140 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
7474 140 : return;
7475 : }
7476 5726 : if (sym->attr.omp_allocate)
7477 : {
7478 : /* The size is the number of elements in the array, so multiply by the
7479 : size of an element to get the total size. */
7480 7 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
7481 7 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7482 : size, fold_convert (gfc_array_index_type, tmp));
7483 7 : size = gfc_evaluate_now (size, &init);
7484 :
7485 7 : tree omp_alloc = lookup_attribute ("omp allocate",
7486 7 : DECL_ATTRIBUTES (decl));
7487 7 : TREE_CHAIN (TREE_CHAIN (TREE_VALUE (omp_alloc)))
7488 7 : = build_tree_list (size, NULL_TREE);
7489 7 : space = NULL_TREE;
7490 : }
7491 5719 : else if (flag_stack_arrays)
7492 : {
7493 14 : gcc_assert (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE);
7494 14 : space = build_decl (gfc_get_location (&sym->declared_at),
7495 : VAR_DECL, create_tmp_var_name ("A"),
7496 14 : TREE_TYPE (TREE_TYPE (decl)));
7497 14 : gfc_trans_vla_type_sizes (sym, &init);
7498 : }
7499 : else
7500 : {
7501 : /* The size is the number of elements in the array, so multiply by the
7502 : size of an element to get the total size. */
7503 5705 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
7504 5705 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7505 : size, fold_convert (gfc_array_index_type, tmp));
7506 :
7507 : /* Allocate memory to hold the data. */
7508 5705 : tmp = gfc_call_malloc (&init, TREE_TYPE (decl), size);
7509 5705 : gfc_add_modify (&init, decl, tmp);
7510 :
7511 : /* Free the temporary. */
7512 5705 : tmp = gfc_call_free (decl);
7513 5705 : space = NULL_TREE;
7514 : }
7515 :
7516 : /* Set offset of the array. */
7517 5726 : if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
7518 378 : gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
7519 :
7520 : /* Automatic arrays should not have initializers. */
7521 5726 : gcc_assert (!sym->value);
7522 :
7523 5726 : inittree = gfc_finish_block (&init);
7524 :
7525 5726 : if (space)
7526 : {
7527 14 : tree addr;
7528 14 : pushdecl (space);
7529 :
7530 : /* Don't create new scope, emit the DECL_EXPR in exactly the scope
7531 : where also space is located. */
7532 14 : gfc_init_block (&init);
7533 14 : tmp = fold_build1_loc (input_location, DECL_EXPR,
7534 14 : TREE_TYPE (space), space);
7535 14 : gfc_add_expr_to_block (&init, tmp);
7536 14 : addr = fold_build1_loc (gfc_get_location (&sym->declared_at),
7537 14 : ADDR_EXPR, TREE_TYPE (decl), space);
7538 14 : gfc_add_modify (&init, decl, addr);
7539 14 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE,
7540 : back);
7541 14 : tmp = NULL_TREE;
7542 : }
7543 5726 : gfc_add_init_cleanup (block, inittree, tmp, back);
7544 : }
7545 :
7546 :
7547 : /* Generate entry and exit code for g77 calling convention arrays. */
7548 :
7549 : void
7550 7356 : gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block)
7551 : {
7552 7356 : tree parm;
7553 7356 : tree type;
7554 7356 : tree offset;
7555 7356 : tree tmp;
7556 7356 : tree stmt;
7557 7356 : stmtblock_t init;
7558 :
7559 7356 : location_t loc = input_location;
7560 7356 : input_location = gfc_get_location (&sym->declared_at);
7561 :
7562 : /* Descriptor type. */
7563 7356 : parm = sym->backend_decl;
7564 7356 : type = TREE_TYPE (parm);
7565 7356 : gcc_assert (GFC_ARRAY_TYPE_P (type));
7566 :
7567 7356 : gfc_start_block (&init);
7568 :
7569 7356 : if (sym->ts.type == BT_CHARACTER
7570 710 : && VAR_P (sym->ts.u.cl->backend_decl))
7571 79 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7572 :
7573 : /* Evaluate the bounds of the array. */
7574 7356 : gfc_trans_array_bounds (type, sym, &offset, &init);
7575 :
7576 : /* Set the offset. */
7577 7356 : if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
7578 1214 : gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
7579 :
7580 : /* Set the pointer itself if we aren't using the parameter directly. */
7581 7356 : if (TREE_CODE (parm) != PARM_DECL)
7582 : {
7583 612 : tmp = GFC_DECL_SAVED_DESCRIPTOR (parm);
7584 612 : if (sym->ts.type == BT_CLASS)
7585 : {
7586 243 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
7587 243 : tmp = gfc_class_data_get (tmp);
7588 243 : tmp = gfc_conv_descriptor_data_get (tmp);
7589 : }
7590 612 : tmp = convert (TREE_TYPE (parm), tmp);
7591 612 : gfc_add_modify (&init, parm, tmp);
7592 : }
7593 7356 : stmt = gfc_finish_block (&init);
7594 :
7595 7356 : input_location = loc;
7596 :
7597 : /* Add the initialization code to the start of the function. */
7598 :
7599 7356 : if ((sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.optional)
7600 7356 : || sym->attr.optional
7601 6874 : || sym->attr.not_always_present)
7602 : {
7603 542 : tree nullify;
7604 542 : if (TREE_CODE (parm) != PARM_DECL)
7605 105 : nullify = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
7606 : parm, null_pointer_node);
7607 : else
7608 437 : nullify = build_empty_stmt (input_location);
7609 542 : tmp = gfc_conv_expr_present (sym, true);
7610 542 : stmt = build3_v (COND_EXPR, tmp, stmt, nullify);
7611 : }
7612 :
7613 7356 : gfc_add_init_cleanup (block, stmt, NULL_TREE);
7614 7356 : }
7615 :
7616 :
7617 : /* Modify the descriptor of an array parameter so that it has the
7618 : correct lower bound. Also move the upper bound accordingly.
7619 : If the array is not packed, it will be copied into a temporary.
7620 : For each dimension we set the new lower and upper bounds. Then we copy the
7621 : stride and calculate the offset for this dimension. We also work out
7622 : what the stride of a packed array would be, and see it the two match.
7623 : If the array need repacking, we set the stride to the values we just
7624 : calculated, recalculate the offset and copy the array data.
7625 : Code is also added to copy the data back at the end of the function.
7626 : */
7627 :
7628 : void
7629 12843 : gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
7630 : gfc_wrapped_block * block)
7631 : {
7632 12843 : tree size;
7633 12843 : tree type;
7634 12843 : tree offset;
7635 12843 : stmtblock_t init;
7636 12843 : tree stmtInit, stmtCleanup;
7637 12843 : tree lbound;
7638 12843 : tree ubound;
7639 12843 : tree dubound;
7640 12843 : tree dlbound;
7641 12843 : tree dumdesc;
7642 12843 : tree tmp;
7643 12843 : tree stride, stride2;
7644 12843 : tree stmt_packed;
7645 12843 : tree stmt_unpacked;
7646 12843 : tree partial;
7647 12843 : gfc_se se;
7648 12843 : int n;
7649 12843 : int checkparm;
7650 12843 : int no_repack;
7651 12843 : bool optional_arg;
7652 12843 : gfc_array_spec *as;
7653 12843 : bool is_classarray = IS_CLASS_COARRAY_OR_ARRAY (sym);
7654 :
7655 : /* Do nothing for pointer and allocatable arrays. */
7656 12843 : if ((sym->ts.type != BT_CLASS && sym->attr.pointer)
7657 12746 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer)
7658 12746 : || sym->attr.allocatable
7659 12640 : || (is_classarray && CLASS_DATA (sym)->attr.allocatable))
7660 6038 : return;
7661 :
7662 820 : if ((!is_classarray
7663 820 : || (is_classarray && CLASS_DATA (sym)->as->type == AS_EXPLICIT))
7664 12004 : && sym->attr.dummy && !sym->attr.elemental && gfc_is_nodesc_array (sym))
7665 : {
7666 5835 : gfc_trans_g77_array (sym, block);
7667 5835 : return;
7668 : }
7669 :
7670 6805 : location_t loc = input_location;
7671 6805 : input_location = gfc_get_location (&sym->declared_at);
7672 :
7673 : /* Descriptor type. */
7674 6805 : type = TREE_TYPE (tmpdesc);
7675 6805 : gcc_assert (GFC_ARRAY_TYPE_P (type));
7676 6805 : dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
7677 6805 : if (is_classarray)
7678 : /* For a class array the dummy array descriptor is in the _class
7679 : component. */
7680 655 : dumdesc = gfc_class_data_get (dumdesc);
7681 : else
7682 6150 : dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc);
7683 6805 : as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
7684 6805 : gfc_start_block (&init);
7685 :
7686 6805 : if (sym->ts.type == BT_CHARACTER
7687 780 : && VAR_P (sym->ts.u.cl->backend_decl))
7688 87 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7689 :
7690 : /* TODO: Fix the exclusion of class arrays from extent checking. */
7691 1084 : checkparm = (as->type == AS_EXPLICIT && !is_classarray
7692 7870 : && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
7693 :
7694 6805 : no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
7695 6804 : || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
7696 :
7697 6805 : if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
7698 : {
7699 : /* For non-constant shape arrays we only check if the first dimension
7700 : is contiguous. Repacking higher dimensions wouldn't gain us
7701 : anything as we still don't know the array stride. */
7702 1 : partial = gfc_create_var (logical_type_node, "partial");
7703 1 : TREE_USED (partial) = 1;
7704 1 : tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
7705 1 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, tmp,
7706 : gfc_index_one_node);
7707 1 : gfc_add_modify (&init, partial, tmp);
7708 : }
7709 : else
7710 : partial = NULL_TREE;
7711 :
7712 : /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
7713 : here, however I think it does the right thing. */
7714 6805 : if (no_repack)
7715 : {
7716 : /* Set the first stride. */
7717 6803 : stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
7718 6803 : stride = gfc_evaluate_now (stride, &init);
7719 :
7720 6803 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7721 : stride, gfc_index_zero_node);
7722 6803 : tmp = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
7723 : tmp, gfc_index_one_node, stride);
7724 6803 : stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
7725 6803 : gfc_add_modify (&init, stride, tmp);
7726 :
7727 : /* Allow the user to disable array repacking. */
7728 6803 : stmt_unpacked = NULL_TREE;
7729 : }
7730 : else
7731 : {
7732 2 : gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
7733 : /* A library call to repack the array if necessary. */
7734 2 : tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
7735 2 : stmt_unpacked = build_call_expr_loc (input_location,
7736 : gfor_fndecl_in_pack, 1, tmp);
7737 :
7738 2 : stride = gfc_index_one_node;
7739 :
7740 2 : if (warn_array_temporaries)
7741 : {
7742 1 : locus where;
7743 1 : gfc_locus_from_location (&where, loc);
7744 1 : gfc_warning (OPT_Warray_temporaries,
7745 : "Creating array temporary at %L", &where);
7746 : }
7747 : }
7748 :
7749 : /* This is for the case where the array data is used directly without
7750 : calling the repack function. */
7751 6805 : if (no_repack || partial != NULL_TREE)
7752 6804 : stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
7753 : else
7754 : stmt_packed = NULL_TREE;
7755 :
7756 : /* Assign the data pointer. */
7757 6805 : if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
7758 : {
7759 : /* Don't repack unknown shape arrays when the first stride is 1. */
7760 1 : tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (stmt_packed),
7761 : partial, stmt_packed, stmt_unpacked);
7762 : }
7763 : else
7764 6804 : tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
7765 6805 : gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp));
7766 :
7767 6805 : offset = gfc_index_zero_node;
7768 6805 : size = gfc_index_one_node;
7769 :
7770 : /* Evaluate the bounds of the array. */
7771 15900 : for (n = 0; n < as->rank; n++)
7772 : {
7773 9095 : if (checkparm || !as->upper[n])
7774 : {
7775 : /* Get the bounds of the actual parameter. */
7776 7776 : dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]);
7777 7776 : dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]);
7778 : }
7779 : else
7780 : {
7781 : dubound = NULL_TREE;
7782 : dlbound = NULL_TREE;
7783 : }
7784 :
7785 9095 : lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
7786 9095 : if (!INTEGER_CST_P (lbound))
7787 : {
7788 46 : gfc_init_se (&se, NULL);
7789 46 : gfc_conv_expr_type (&se, as->lower[n],
7790 : gfc_array_index_type);
7791 46 : gfc_add_block_to_block (&init, &se.pre);
7792 46 : gfc_add_modify (&init, lbound, se.expr);
7793 : }
7794 :
7795 9095 : ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
7796 : /* Set the desired upper bound. */
7797 9095 : if (as->upper[n])
7798 : {
7799 : /* We know what we want the upper bound to be. */
7800 1377 : if (!INTEGER_CST_P (ubound))
7801 : {
7802 639 : gfc_init_se (&se, NULL);
7803 639 : gfc_conv_expr_type (&se, as->upper[n],
7804 : gfc_array_index_type);
7805 639 : gfc_add_block_to_block (&init, &se.pre);
7806 639 : gfc_add_modify (&init, ubound, se.expr);
7807 : }
7808 :
7809 : /* Check the sizes match. */
7810 1377 : if (checkparm)
7811 : {
7812 : /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
7813 58 : char * msg;
7814 58 : tree temp;
7815 58 : locus where;
7816 :
7817 58 : gfc_locus_from_location (&where, loc);
7818 58 : temp = fold_build2_loc (input_location, MINUS_EXPR,
7819 : gfc_array_index_type, ubound, lbound);
7820 58 : temp = fold_build2_loc (input_location, PLUS_EXPR,
7821 : gfc_array_index_type,
7822 : gfc_index_one_node, temp);
7823 58 : stride2 = fold_build2_loc (input_location, MINUS_EXPR,
7824 : gfc_array_index_type, dubound,
7825 : dlbound);
7826 58 : stride2 = fold_build2_loc (input_location, PLUS_EXPR,
7827 : gfc_array_index_type,
7828 : gfc_index_one_node, stride2);
7829 58 : tmp = fold_build2_loc (input_location, NE_EXPR,
7830 : gfc_array_index_type, temp, stride2);
7831 58 : msg = xasprintf ("Dimension %d of array '%s' has extent "
7832 : "%%ld instead of %%ld", n+1, sym->name);
7833 :
7834 58 : gfc_trans_runtime_check (true, false, tmp, &init, &where, msg,
7835 : fold_convert (long_integer_type_node, temp),
7836 : fold_convert (long_integer_type_node, stride2));
7837 :
7838 58 : free (msg);
7839 : }
7840 : }
7841 : else
7842 : {
7843 : /* For assumed shape arrays move the upper bound by the same amount
7844 : as the lower bound. */
7845 7718 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
7846 : gfc_array_index_type, dubound, dlbound);
7847 7718 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
7848 : gfc_array_index_type, tmp, lbound);
7849 7718 : gfc_add_modify (&init, ubound, tmp);
7850 : }
7851 : /* The offset of this dimension. offset = offset - lbound * stride. */
7852 9095 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7853 : lbound, stride);
7854 9095 : offset = fold_build2_loc (input_location, MINUS_EXPR,
7855 : gfc_array_index_type, offset, tmp);
7856 :
7857 : /* The size of this dimension, and the stride of the next. */
7858 9095 : if (n + 1 < as->rank)
7859 : {
7860 2290 : stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
7861 :
7862 2290 : if (no_repack || partial != NULL_TREE)
7863 2289 : stmt_unpacked =
7864 2289 : gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]);
7865 :
7866 : /* Figure out the stride if not a known constant. */
7867 2290 : if (!INTEGER_CST_P (stride))
7868 : {
7869 2289 : if (no_repack)
7870 : stmt_packed = NULL_TREE;
7871 : else
7872 : {
7873 : /* Calculate stride = size * (ubound + 1 - lbound). */
7874 0 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
7875 : gfc_array_index_type,
7876 : gfc_index_one_node, lbound);
7877 0 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
7878 : gfc_array_index_type, ubound, tmp);
7879 0 : size = fold_build2_loc (input_location, MULT_EXPR,
7880 : gfc_array_index_type, size, tmp);
7881 0 : stmt_packed = size;
7882 : }
7883 :
7884 : /* Assign the stride. */
7885 2289 : if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
7886 0 : tmp = fold_build3_loc (input_location, COND_EXPR,
7887 : gfc_array_index_type, partial,
7888 : stmt_unpacked, stmt_packed);
7889 : else
7890 2289 : tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
7891 2289 : gfc_add_modify (&init, stride, tmp);
7892 : }
7893 : }
7894 : else
7895 : {
7896 6805 : stride = GFC_TYPE_ARRAY_SIZE (type);
7897 :
7898 6805 : if (stride && !INTEGER_CST_P (stride))
7899 : {
7900 : /* Calculate size = stride * (ubound + 1 - lbound). */
7901 6804 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
7902 : gfc_array_index_type,
7903 : gfc_index_one_node, lbound);
7904 6804 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
7905 : gfc_array_index_type,
7906 : ubound, tmp);
7907 20412 : tmp = fold_build2_loc (input_location, MULT_EXPR,
7908 : gfc_array_index_type,
7909 6804 : GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
7910 6804 : gfc_add_modify (&init, stride, tmp);
7911 : }
7912 : }
7913 : }
7914 :
7915 6805 : gfc_trans_array_cobounds (type, &init, sym);
7916 :
7917 : /* Set the offset. */
7918 6805 : if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
7919 6803 : gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
7920 :
7921 6805 : gfc_trans_vla_type_sizes (sym, &init);
7922 :
7923 6805 : stmtInit = gfc_finish_block (&init);
7924 :
7925 : /* Only do the entry/initialization code if the arg is present. */
7926 6805 : dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
7927 6805 : optional_arg = (sym->attr.optional
7928 6805 : || (sym->ns->proc_name->attr.entry_master
7929 79 : && sym->attr.dummy));
7930 : if (optional_arg)
7931 : {
7932 717 : tree zero_init = fold_convert (TREE_TYPE (tmpdesc), null_pointer_node);
7933 717 : zero_init = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
7934 : tmpdesc, zero_init);
7935 717 : tmp = gfc_conv_expr_present (sym, true);
7936 717 : stmtInit = build3_v (COND_EXPR, tmp, stmtInit, zero_init);
7937 : }
7938 :
7939 : /* Cleanup code. */
7940 6805 : if (no_repack)
7941 : stmtCleanup = NULL_TREE;
7942 : else
7943 : {
7944 2 : stmtblock_t cleanup;
7945 2 : gfc_start_block (&cleanup);
7946 :
7947 2 : if (sym->attr.intent != INTENT_IN)
7948 : {
7949 : /* Copy the data back. */
7950 2 : tmp = build_call_expr_loc (input_location,
7951 : gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
7952 2 : gfc_add_expr_to_block (&cleanup, tmp);
7953 : }
7954 :
7955 : /* Free the temporary. */
7956 2 : tmp = gfc_call_free (tmpdesc);
7957 2 : gfc_add_expr_to_block (&cleanup, tmp);
7958 :
7959 2 : stmtCleanup = gfc_finish_block (&cleanup);
7960 :
7961 : /* Only do the cleanup if the array was repacked. */
7962 2 : if (is_classarray)
7963 : /* For a class array the dummy array descriptor is in the _class
7964 : component. */
7965 1 : tmp = gfc_class_data_get (dumdesc);
7966 : else
7967 1 : tmp = build_fold_indirect_ref_loc (input_location, dumdesc);
7968 2 : tmp = gfc_conv_descriptor_data_get (tmp);
7969 2 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
7970 : tmp, tmpdesc);
7971 2 : stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
7972 : build_empty_stmt (input_location));
7973 :
7974 2 : if (optional_arg)
7975 : {
7976 0 : tmp = gfc_conv_expr_present (sym);
7977 0 : stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
7978 : build_empty_stmt (input_location));
7979 : }
7980 : }
7981 :
7982 : /* We don't need to free any memory allocated by internal_pack as it will
7983 : be freed at the end of the function by pop_context. */
7984 6805 : gfc_add_init_cleanup (block, stmtInit, stmtCleanup);
7985 :
7986 6805 : input_location = loc;
7987 : }
7988 :
7989 :
7990 : /* Calculate the overall offset, including subreferences. */
7991 : void
7992 59974 : gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
7993 : bool subref, gfc_expr *expr)
7994 : {
7995 59974 : tree tmp;
7996 59974 : tree field;
7997 59974 : tree stride;
7998 59974 : tree index;
7999 59974 : gfc_ref *ref;
8000 59974 : gfc_se start;
8001 59974 : int n;
8002 :
8003 : /* If offset is NULL and this is not a subreferenced array, there is
8004 : nothing to do. */
8005 59974 : if (offset == NULL_TREE)
8006 : {
8007 1066 : if (subref)
8008 139 : offset = gfc_index_zero_node;
8009 : else
8010 927 : return;
8011 : }
8012 :
8013 59047 : tmp = build_array_ref (desc, offset, NULL, NULL);
8014 :
8015 : /* Offset the data pointer for pointer assignments from arrays with
8016 : subreferences; e.g. my_integer => my_type(:)%integer_component. */
8017 59047 : if (subref)
8018 : {
8019 : /* Go past the array reference. */
8020 844 : for (ref = expr->ref; ref; ref = ref->next)
8021 844 : if (ref->type == REF_ARRAY &&
8022 757 : ref->u.ar.type != AR_ELEMENT)
8023 : {
8024 733 : ref = ref->next;
8025 733 : break;
8026 : }
8027 :
8028 : /* Calculate the offset for each subsequent subreference. */
8029 1438 : for (; ref; ref = ref->next)
8030 : {
8031 705 : switch (ref->type)
8032 : {
8033 301 : case REF_COMPONENT:
8034 301 : field = ref->u.c.component->backend_decl;
8035 301 : gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
8036 602 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
8037 301 : TREE_TYPE (field),
8038 : tmp, field, NULL_TREE);
8039 301 : break;
8040 :
8041 320 : case REF_SUBSTRING:
8042 320 : gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
8043 320 : gfc_init_se (&start, NULL);
8044 320 : gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
8045 320 : gfc_add_block_to_block (block, &start.pre);
8046 320 : tmp = gfc_build_array_ref (tmp, start.expr, NULL);
8047 320 : break;
8048 :
8049 24 : case REF_ARRAY:
8050 24 : gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
8051 : && ref->u.ar.type == AR_ELEMENT);
8052 :
8053 : /* TODO - Add bounds checking. */
8054 24 : stride = gfc_index_one_node;
8055 24 : index = gfc_index_zero_node;
8056 55 : for (n = 0; n < ref->u.ar.dimen; n++)
8057 : {
8058 31 : tree itmp;
8059 31 : tree jtmp;
8060 :
8061 : /* Update the index. */
8062 31 : gfc_init_se (&start, NULL);
8063 31 : gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
8064 31 : itmp = gfc_evaluate_now (start.expr, block);
8065 31 : gfc_init_se (&start, NULL);
8066 31 : gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
8067 31 : jtmp = gfc_evaluate_now (start.expr, block);
8068 31 : itmp = fold_build2_loc (input_location, MINUS_EXPR,
8069 : gfc_array_index_type, itmp, jtmp);
8070 31 : itmp = fold_build2_loc (input_location, MULT_EXPR,
8071 : gfc_array_index_type, itmp, stride);
8072 31 : index = fold_build2_loc (input_location, PLUS_EXPR,
8073 : gfc_array_index_type, itmp, index);
8074 31 : index = gfc_evaluate_now (index, block);
8075 :
8076 : /* Update the stride. */
8077 31 : gfc_init_se (&start, NULL);
8078 31 : gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
8079 31 : itmp = fold_build2_loc (input_location, MINUS_EXPR,
8080 : gfc_array_index_type, start.expr,
8081 : jtmp);
8082 31 : itmp = fold_build2_loc (input_location, PLUS_EXPR,
8083 : gfc_array_index_type,
8084 : gfc_index_one_node, itmp);
8085 31 : stride = fold_build2_loc (input_location, MULT_EXPR,
8086 : gfc_array_index_type, stride, itmp);
8087 31 : stride = gfc_evaluate_now (stride, block);
8088 : }
8089 :
8090 : /* Apply the index to obtain the array element. */
8091 24 : tmp = gfc_build_array_ref (tmp, index, NULL);
8092 24 : break;
8093 :
8094 60 : case REF_INQUIRY:
8095 60 : switch (ref->u.i)
8096 : {
8097 54 : case INQUIRY_RE:
8098 108 : tmp = fold_build1_loc (input_location, REALPART_EXPR,
8099 54 : TREE_TYPE (TREE_TYPE (tmp)), tmp);
8100 54 : break;
8101 :
8102 6 : case INQUIRY_IM:
8103 12 : tmp = fold_build1_loc (input_location, IMAGPART_EXPR,
8104 6 : TREE_TYPE (TREE_TYPE (tmp)), tmp);
8105 6 : break;
8106 :
8107 : default:
8108 : break;
8109 : }
8110 : break;
8111 :
8112 0 : default:
8113 0 : gcc_unreachable ();
8114 705 : break;
8115 : }
8116 : }
8117 : }
8118 :
8119 : /* Set the target data pointer. */
8120 59047 : offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
8121 :
8122 : /* Check for optional dummy argument being present. Arguments of BIND(C)
8123 : procedures are excepted here since they are handled differently. */
8124 59047 : if (expr->expr_type == EXPR_VARIABLE
8125 51852 : && expr->symtree->n.sym->attr.dummy
8126 6188 : && expr->symtree->n.sym->attr.optional
8127 60039 : && !is_CFI_desc (NULL, expr))
8128 1624 : offset = build3_loc (input_location, COND_EXPR, TREE_TYPE (offset),
8129 812 : gfc_conv_expr_present (expr->symtree->n.sym), offset,
8130 812 : fold_convert (TREE_TYPE (offset), gfc_index_zero_node));
8131 :
8132 59047 : gfc_conv_descriptor_data_set (block, parm, offset);
8133 : }
8134 :
8135 :
8136 : /* gfc_conv_expr_descriptor needs the string length an expression
8137 : so that the size of the temporary can be obtained. This is done
8138 : by adding up the string lengths of all the elements in the
8139 : expression. Function with non-constant expressions have their
8140 : string lengths mapped onto the actual arguments using the
8141 : interface mapping machinery in trans-expr.cc. */
8142 : static void
8143 1566 : get_array_charlen (gfc_expr *expr, gfc_se *se)
8144 : {
8145 1566 : gfc_interface_mapping mapping;
8146 1566 : gfc_formal_arglist *formal;
8147 1566 : gfc_actual_arglist *arg;
8148 1566 : gfc_se tse;
8149 1566 : gfc_expr *e;
8150 :
8151 1566 : if (expr->ts.u.cl->length
8152 1566 : && gfc_is_constant_expr (expr->ts.u.cl->length))
8153 : {
8154 1219 : if (!expr->ts.u.cl->backend_decl)
8155 471 : gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
8156 1351 : return;
8157 : }
8158 :
8159 347 : switch (expr->expr_type)
8160 : {
8161 130 : case EXPR_ARRAY:
8162 :
8163 : /* This is somewhat brutal. The expression for the first
8164 : element of the array is evaluated and assigned to a
8165 : new string length for the original expression. */
8166 130 : e = gfc_constructor_first (expr->value.constructor)->expr;
8167 :
8168 130 : gfc_init_se (&tse, NULL);
8169 :
8170 : /* Avoid evaluating trailing array references since all we need is
8171 : the string length. */
8172 130 : if (e->rank)
8173 38 : tse.descriptor_only = 1;
8174 130 : if (e->rank && e->expr_type != EXPR_VARIABLE)
8175 1 : gfc_conv_expr_descriptor (&tse, e);
8176 : else
8177 129 : gfc_conv_expr (&tse, e);
8178 :
8179 130 : gfc_add_block_to_block (&se->pre, &tse.pre);
8180 130 : gfc_add_block_to_block (&se->post, &tse.post);
8181 :
8182 130 : if (!expr->ts.u.cl->backend_decl || !VAR_P (expr->ts.u.cl->backend_decl))
8183 : {
8184 87 : expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
8185 87 : expr->ts.u.cl->backend_decl =
8186 87 : gfc_create_var (gfc_charlen_type_node, "sln");
8187 : }
8188 :
8189 130 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
8190 : tse.string_length);
8191 :
8192 : /* Make sure that deferred length components point to the hidden
8193 : string_length component. */
8194 130 : if (TREE_CODE (tse.expr) == COMPONENT_REF
8195 25 : && TREE_CODE (tse.string_length) == COMPONENT_REF
8196 149 : && TREE_OPERAND (tse.expr, 0) == TREE_OPERAND (tse.string_length, 0))
8197 19 : e->ts.u.cl->backend_decl = expr->ts.u.cl->backend_decl;
8198 :
8199 : return;
8200 :
8201 91 : case EXPR_OP:
8202 91 : get_array_charlen (expr->value.op.op1, se);
8203 :
8204 : /* For parentheses the expression ts.u.cl should be identical. */
8205 91 : if (expr->value.op.op == INTRINSIC_PARENTHESES)
8206 : {
8207 2 : if (expr->value.op.op1->ts.u.cl != expr->ts.u.cl)
8208 2 : expr->ts.u.cl->backend_decl
8209 2 : = expr->value.op.op1->ts.u.cl->backend_decl;
8210 2 : return;
8211 : }
8212 :
8213 178 : expr->ts.u.cl->backend_decl =
8214 89 : gfc_create_var (gfc_charlen_type_node, "sln");
8215 :
8216 89 : if (expr->value.op.op2)
8217 : {
8218 89 : get_array_charlen (expr->value.op.op2, se);
8219 :
8220 89 : gcc_assert (expr->value.op.op == INTRINSIC_CONCAT);
8221 :
8222 : /* Add the string lengths and assign them to the expression
8223 : string length backend declaration. */
8224 89 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
8225 : fold_build2_loc (input_location, PLUS_EXPR,
8226 : gfc_charlen_type_node,
8227 89 : expr->value.op.op1->ts.u.cl->backend_decl,
8228 89 : expr->value.op.op2->ts.u.cl->backend_decl));
8229 : }
8230 : else
8231 0 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
8232 0 : expr->value.op.op1->ts.u.cl->backend_decl);
8233 : break;
8234 :
8235 44 : case EXPR_FUNCTION:
8236 44 : if (expr->value.function.esym == NULL
8237 37 : || expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
8238 : {
8239 7 : gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
8240 7 : break;
8241 : }
8242 :
8243 : /* Map expressions involving the dummy arguments onto the actual
8244 : argument expressions. */
8245 37 : gfc_init_interface_mapping (&mapping);
8246 37 : formal = gfc_sym_get_dummy_args (expr->symtree->n.sym);
8247 37 : arg = expr->value.function.actual;
8248 :
8249 : /* Set se = NULL in the calls to the interface mapping, to suppress any
8250 : backend stuff. */
8251 113 : for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
8252 : {
8253 38 : if (!arg->expr)
8254 0 : continue;
8255 38 : if (formal->sym)
8256 38 : gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
8257 : }
8258 :
8259 37 : gfc_init_se (&tse, NULL);
8260 :
8261 : /* Build the expression for the character length and convert it. */
8262 37 : gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length);
8263 :
8264 37 : gfc_add_block_to_block (&se->pre, &tse.pre);
8265 37 : gfc_add_block_to_block (&se->post, &tse.post);
8266 37 : tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
8267 74 : tse.expr = fold_build2_loc (input_location, MAX_EXPR,
8268 37 : TREE_TYPE (tse.expr), tse.expr,
8269 37 : build_zero_cst (TREE_TYPE (tse.expr)));
8270 37 : expr->ts.u.cl->backend_decl = tse.expr;
8271 37 : gfc_free_interface_mapping (&mapping);
8272 37 : break;
8273 :
8274 82 : default:
8275 82 : gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
8276 82 : break;
8277 : }
8278 : }
8279 :
8280 :
8281 : /* Helper function to check dimensions. */
8282 : static bool
8283 156 : transposed_dims (gfc_ss *ss)
8284 : {
8285 156 : int n;
8286 :
8287 174940 : for (n = 0; n < ss->dimen; n++)
8288 88726 : if (ss->dim[n] != n)
8289 : return true;
8290 : return false;
8291 : }
8292 :
8293 :
8294 : /* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
8295 : AR_FULL, suitable for the scalarizer. */
8296 :
8297 : static gfc_ss *
8298 1510 : walk_coarray (gfc_expr *e)
8299 : {
8300 1510 : gfc_ss *ss;
8301 :
8302 1510 : ss = gfc_walk_expr (e);
8303 :
8304 : /* Fix scalar coarray. */
8305 1510 : if (ss == gfc_ss_terminator)
8306 : {
8307 357 : gfc_ref *ref;
8308 :
8309 357 : ref = e->ref;
8310 508 : while (ref)
8311 : {
8312 508 : if (ref->type == REF_ARRAY
8313 357 : && ref->u.ar.codimen > 0)
8314 : break;
8315 :
8316 151 : ref = ref->next;
8317 : }
8318 :
8319 357 : gcc_assert (ref != NULL);
8320 357 : if (ref->u.ar.type == AR_ELEMENT)
8321 339 : ref->u.ar.type = AR_SECTION;
8322 357 : ss = gfc_reverse_ss (gfc_walk_array_ref (ss, e, ref, false));
8323 : }
8324 :
8325 1510 : return ss;
8326 : }
8327 :
8328 : gfc_array_spec *
8329 2177 : get_coarray_as (const gfc_expr *e)
8330 : {
8331 2177 : gfc_array_spec *as;
8332 2177 : gfc_symbol *sym = e->symtree->n.sym;
8333 2177 : gfc_component *comp;
8334 :
8335 2177 : if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.codimension)
8336 595 : as = CLASS_DATA (sym)->as;
8337 1582 : else if (sym->attr.codimension)
8338 1522 : as = sym->as;
8339 : else
8340 : as = nullptr;
8341 :
8342 5069 : for (gfc_ref *ref = e->ref; ref; ref = ref->next)
8343 : {
8344 2892 : switch (ref->type)
8345 : {
8346 715 : case REF_COMPONENT:
8347 715 : comp = ref->u.c.component;
8348 715 : if (comp->ts.type == BT_CLASS && CLASS_DATA (comp)->attr.codimension)
8349 18 : as = CLASS_DATA (comp)->as;
8350 697 : else if (comp->ts.type != BT_CLASS && comp->attr.codimension)
8351 655 : as = comp->as;
8352 : break;
8353 :
8354 : case REF_ARRAY:
8355 : case REF_SUBSTRING:
8356 : case REF_INQUIRY:
8357 : break;
8358 : }
8359 : }
8360 :
8361 2177 : return as;
8362 : }
8363 :
8364 : bool
8365 142337 : is_explicit_coarray (gfc_expr *expr)
8366 : {
8367 142337 : if (!gfc_is_coarray (expr))
8368 : return false;
8369 :
8370 2177 : gfc_array_spec *cas = get_coarray_as (expr);
8371 2177 : return cas && cas->cotype == AS_EXPLICIT;
8372 : }
8373 :
8374 : /* Convert an array for passing as an actual argument. Expressions and
8375 : vector subscripts are evaluated and stored in a temporary, which is then
8376 : passed. For whole arrays the descriptor is passed. For array sections
8377 : a modified copy of the descriptor is passed, but using the original data.
8378 :
8379 : This function is also used for array pointer assignments, and there
8380 : are three cases:
8381 :
8382 : - se->want_pointer && !se->direct_byref
8383 : EXPR is an actual argument. On exit, se->expr contains a
8384 : pointer to the array descriptor.
8385 :
8386 : - !se->want_pointer && !se->direct_byref
8387 : EXPR is an actual argument to an intrinsic function or the
8388 : left-hand side of a pointer assignment. On exit, se->expr
8389 : contains the descriptor for EXPR.
8390 :
8391 : - !se->want_pointer && se->direct_byref
8392 : EXPR is the right-hand side of a pointer assignment and
8393 : se->expr is the descriptor for the previously-evaluated
8394 : left-hand side. The function creates an assignment from
8395 : EXPR to se->expr.
8396 :
8397 :
8398 : The se->force_tmp flag disables the non-copying descriptor optimization
8399 : that is used for transpose. It may be used in cases where there is an
8400 : alias between the transpose argument and another argument in the same
8401 : function call. */
8402 :
8403 : void
8404 158631 : gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
8405 : {
8406 158631 : gfc_ss *ss;
8407 158631 : gfc_ss_type ss_type;
8408 158631 : gfc_ss_info *ss_info;
8409 158631 : gfc_loopinfo loop;
8410 158631 : gfc_array_info *info;
8411 158631 : int need_tmp;
8412 158631 : int n;
8413 158631 : tree tmp;
8414 158631 : tree desc;
8415 158631 : stmtblock_t block;
8416 158631 : tree start;
8417 158631 : int full;
8418 158631 : bool subref_array_target = false;
8419 158631 : bool deferred_array_component = false;
8420 158631 : bool substr = false;
8421 158631 : gfc_expr *arg, *ss_expr;
8422 :
8423 158631 : if (se->want_coarray || expr->rank == 0)
8424 1510 : ss = walk_coarray (expr);
8425 : else
8426 157121 : ss = gfc_walk_expr (expr);
8427 :
8428 158631 : gcc_assert (ss != NULL);
8429 158631 : gcc_assert (ss != gfc_ss_terminator);
8430 :
8431 158631 : ss_info = ss->info;
8432 158631 : ss_type = ss_info->type;
8433 158631 : ss_expr = ss_info->expr;
8434 :
8435 : /* Special case: TRANSPOSE which needs no temporary. */
8436 163970 : while (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym
8437 163700 : && (arg = gfc_get_noncopying_intrinsic_argument (expr)) != NULL)
8438 : {
8439 : /* This is a call to transpose which has already been handled by the
8440 : scalarizer, so that we just need to get its argument's descriptor. */
8441 408 : gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
8442 408 : expr = expr->value.function.actual->expr;
8443 : }
8444 :
8445 158631 : if (!se->direct_byref)
8446 304924 : se->unlimited_polymorphic = UNLIMITED_POLY (expr);
8447 :
8448 : /* Special case things we know we can pass easily. */
8449 158631 : switch (expr->expr_type)
8450 : {
8451 142622 : case EXPR_VARIABLE:
8452 : /* If we have a linear array section, we can pass it directly.
8453 : Otherwise we need to copy it into a temporary. */
8454 :
8455 142622 : gcc_assert (ss_type == GFC_SS_SECTION);
8456 142622 : gcc_assert (ss_expr == expr);
8457 142622 : info = &ss_info->data.array;
8458 :
8459 : /* Get the descriptor for the array. */
8460 142622 : gfc_conv_ss_descriptor (&se->pre, ss, 0);
8461 142622 : desc = info->descriptor;
8462 :
8463 : /* The charlen backend decl for deferred character components cannot
8464 : be used because it is fixed at zero. Instead, the hidden string
8465 : length component is used. */
8466 142622 : if (expr->ts.type == BT_CHARACTER
8467 20186 : && expr->ts.deferred
8468 2831 : && TREE_CODE (desc) == COMPONENT_REF)
8469 142622 : deferred_array_component = true;
8470 :
8471 142622 : substr = info->ref && info->ref->next
8472 143450 : && info->ref->next->type == REF_SUBSTRING;
8473 :
8474 142622 : subref_array_target = (is_subref_array (expr)
8475 142622 : && (se->direct_byref
8476 2596 : || expr->ts.type == BT_CHARACTER));
8477 142622 : need_tmp = (gfc_ref_needs_temporary_p (expr->ref)
8478 142622 : && !subref_array_target);
8479 :
8480 142622 : if (se->force_tmp)
8481 : need_tmp = 1;
8482 142439 : else if (se->force_no_tmp)
8483 : need_tmp = 0;
8484 :
8485 136302 : if (need_tmp)
8486 : full = 0;
8487 142337 : else if (is_explicit_coarray (expr))
8488 : full = 0;
8489 141517 : else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
8490 : {
8491 : /* Create a new descriptor if the array doesn't have one. */
8492 : full = 0;
8493 : }
8494 92192 : else if (info->ref->u.ar.type == AR_FULL || se->descriptor_only)
8495 : full = 1;
8496 7955 : else if (se->direct_byref)
8497 : full = 0;
8498 7592 : else if (info->ref->u.ar.dimen == 0 && !info->ref->next)
8499 : full = 1;
8500 7451 : else if (info->ref->u.ar.type == AR_SECTION && se->want_pointer)
8501 : full = 0;
8502 : else
8503 3559 : full = gfc_full_array_ref_p (info->ref, NULL);
8504 :
8505 172555 : if (full && !transposed_dims (ss))
8506 : {
8507 84561 : if (se->direct_byref && !se->byref_noassign)
8508 : {
8509 1054 : struct lang_type *lhs_ls
8510 1054 : = TYPE_LANG_SPECIFIC (TREE_TYPE (se->expr)),
8511 1054 : *rhs_ls = TYPE_LANG_SPECIFIC (TREE_TYPE (desc));
8512 : /* When only the array_kind differs, do a view_convert. */
8513 1450 : tmp = lhs_ls && rhs_ls && lhs_ls->rank == rhs_ls->rank
8514 1054 : && lhs_ls->akind != rhs_ls->akind
8515 1450 : ? build1 (VIEW_CONVERT_EXPR, TREE_TYPE (se->expr), desc)
8516 : : desc;
8517 : /* Copy the descriptor for pointer assignments. */
8518 1054 : gfc_add_modify (&se->pre, se->expr, tmp);
8519 :
8520 : /* Add any offsets from subreferences. */
8521 1054 : gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
8522 : subref_array_target, expr);
8523 :
8524 : /* ....and set the span field. */
8525 1054 : if (ss_info->expr->ts.type == BT_CHARACTER)
8526 141 : tmp = gfc_conv_descriptor_span_get (desc);
8527 : else
8528 913 : tmp = gfc_get_array_span (desc, expr);
8529 1054 : gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp);
8530 1054 : }
8531 83507 : else if (se->want_pointer)
8532 : {
8533 : /* We pass full arrays directly. This means that pointers and
8534 : allocatable arrays should also work. */
8535 13907 : se->expr = gfc_build_addr_expr (NULL_TREE, desc);
8536 : }
8537 : else
8538 : {
8539 69600 : se->expr = desc;
8540 : }
8541 :
8542 84561 : if (expr->ts.type == BT_CHARACTER && !deferred_array_component)
8543 8379 : se->string_length = gfc_get_expr_charlen (expr);
8544 : /* The ss_info string length is returned set to the value of the
8545 : hidden string length component. */
8546 75919 : else if (deferred_array_component)
8547 263 : se->string_length = ss_info->string_length;
8548 :
8549 84561 : se->class_container = ss_info->class_container;
8550 :
8551 84561 : gfc_free_ss_chain (ss);
8552 169248 : return;
8553 : }
8554 : break;
8555 :
8556 4931 : case EXPR_FUNCTION:
8557 : /* A transformational function return value will be a temporary
8558 : array descriptor. We still need to go through the scalarizer
8559 : to create the descriptor. Elemental functions are handled as
8560 : arbitrary expressions, i.e. copy to a temporary. */
8561 :
8562 4931 : if (se->direct_byref)
8563 : {
8564 126 : gcc_assert (ss_type == GFC_SS_FUNCTION && ss_expr == expr);
8565 :
8566 : /* For pointer assignments pass the descriptor directly. */
8567 126 : if (se->ss == NULL)
8568 126 : se->ss = ss;
8569 : else
8570 0 : gcc_assert (se->ss == ss);
8571 :
8572 126 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
8573 126 : gfc_conv_expr (se, expr);
8574 :
8575 126 : gfc_free_ss_chain (ss);
8576 126 : return;
8577 : }
8578 :
8579 4805 : if (ss_expr != expr || ss_type != GFC_SS_FUNCTION)
8580 : {
8581 3289 : if (ss_expr != expr)
8582 : /* Elemental function. */
8583 2564 : gcc_assert ((expr->value.function.esym != NULL
8584 : && expr->value.function.esym->attr.elemental)
8585 : || (expr->value.function.isym != NULL
8586 : && expr->value.function.isym->elemental)
8587 : || (gfc_expr_attr (expr).proc_pointer
8588 : && gfc_expr_attr (expr).elemental)
8589 : || gfc_inline_intrinsic_function_p (expr));
8590 :
8591 3289 : need_tmp = 1;
8592 3289 : if (expr->ts.type == BT_CHARACTER
8593 35 : && expr->ts.u.cl->length
8594 29 : && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
8595 13 : get_array_charlen (expr, se);
8596 :
8597 : info = NULL;
8598 : }
8599 : else
8600 : {
8601 : /* Transformational function. */
8602 1516 : info = &ss_info->data.array;
8603 1516 : need_tmp = 0;
8604 : }
8605 : break;
8606 :
8607 10357 : case EXPR_ARRAY:
8608 : /* Constant array constructors don't need a temporary. */
8609 10357 : if (ss_type == GFC_SS_CONSTRUCTOR
8610 10357 : && expr->ts.type != BT_CHARACTER
8611 19473 : && gfc_constant_array_constructor_p (expr->value.constructor))
8612 : {
8613 7182 : need_tmp = 0;
8614 7182 : info = &ss_info->data.array;
8615 : }
8616 : else
8617 : {
8618 : need_tmp = 1;
8619 : info = NULL;
8620 : }
8621 : break;
8622 :
8623 : default:
8624 : /* Something complicated. Copy it into a temporary. */
8625 : need_tmp = 1;
8626 : info = NULL;
8627 : break;
8628 : }
8629 :
8630 : /* If we are creating a temporary, we don't need to bother about aliases
8631 : anymore. */
8632 66759 : if (need_tmp)
8633 7470 : se->force_tmp = 0;
8634 :
8635 73944 : gfc_init_loopinfo (&loop);
8636 :
8637 : /* Associate the SS with the loop. */
8638 73944 : gfc_add_ss_to_loop (&loop, ss);
8639 :
8640 : /* Tell the scalarizer not to bother creating loop variables, etc. */
8641 73944 : if (!need_tmp)
8642 66474 : loop.array_parameter = 1;
8643 : else
8644 : /* The right-hand side of a pointer assignment mustn't use a temporary. */
8645 7470 : gcc_assert (!se->direct_byref);
8646 :
8647 : /* Do we need bounds checking or not? */
8648 73944 : ss->no_bounds_check = expr->no_bounds_check;
8649 :
8650 : /* Setup the scalarizing loops and bounds. */
8651 73944 : gfc_conv_ss_startstride (&loop);
8652 :
8653 : /* Add bounds-checking for elemental dimensions. */
8654 73944 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !expr->no_bounds_check)
8655 6674 : array_bound_check_elemental (se, ss, expr);
8656 :
8657 73944 : if (need_tmp)
8658 : {
8659 7470 : if (expr->ts.type == BT_CHARACTER
8660 1480 : && (!expr->ts.u.cl->backend_decl || expr->expr_type == EXPR_ARRAY))
8661 1373 : get_array_charlen (expr, se);
8662 :
8663 : /* Tell the scalarizer to make a temporary. */
8664 7470 : loop.temp_ss = gfc_get_temp_ss (gfc_typenode_for_spec (&expr->ts),
8665 7470 : ((expr->ts.type == BT_CHARACTER)
8666 1480 : ? expr->ts.u.cl->backend_decl
8667 : : NULL),
8668 : loop.dimen);
8669 :
8670 7470 : se->string_length = loop.temp_ss->info->string_length;
8671 7470 : gcc_assert (loop.temp_ss->dimen == loop.dimen);
8672 7470 : gfc_add_ss_to_loop (&loop, loop.temp_ss);
8673 : }
8674 :
8675 73944 : gfc_conv_loop_setup (&loop, & expr->where);
8676 :
8677 73944 : if (need_tmp)
8678 : {
8679 : /* Copy into a temporary and pass that. We don't need to copy the data
8680 : back because expressions and vector subscripts must be INTENT_IN. */
8681 : /* TODO: Optimize passing function return values. */
8682 7470 : gfc_se lse;
8683 7470 : gfc_se rse;
8684 7470 : bool deep_copy;
8685 :
8686 : /* Start the copying loops. */
8687 7470 : gfc_mark_ss_chain_used (loop.temp_ss, 1);
8688 7470 : gfc_mark_ss_chain_used (ss, 1);
8689 7470 : gfc_start_scalarized_body (&loop, &block);
8690 :
8691 : /* Copy each data element. */
8692 7470 : gfc_init_se (&lse, NULL);
8693 7470 : gfc_copy_loopinfo_to_se (&lse, &loop);
8694 7470 : gfc_init_se (&rse, NULL);
8695 7470 : gfc_copy_loopinfo_to_se (&rse, &loop);
8696 :
8697 7470 : lse.ss = loop.temp_ss;
8698 7470 : rse.ss = ss;
8699 :
8700 7470 : gfc_conv_tmp_array_ref (&lse);
8701 7470 : if (expr->ts.type == BT_CHARACTER)
8702 : {
8703 1480 : gfc_conv_expr (&rse, expr);
8704 1480 : if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
8705 1158 : rse.expr = build_fold_indirect_ref_loc (input_location,
8706 : rse.expr);
8707 : }
8708 : else
8709 5990 : gfc_conv_expr_val (&rse, expr);
8710 :
8711 7470 : gfc_add_block_to_block (&block, &rse.pre);
8712 7470 : gfc_add_block_to_block (&block, &lse.pre);
8713 :
8714 7470 : lse.string_length = rse.string_length;
8715 :
8716 14940 : deep_copy = !se->data_not_needed
8717 7470 : && (expr->expr_type == EXPR_VARIABLE
8718 6932 : || expr->expr_type == EXPR_ARRAY);
8719 7470 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts,
8720 : deep_copy, false);
8721 7470 : gfc_add_expr_to_block (&block, tmp);
8722 :
8723 : /* Finish the copying loops. */
8724 7470 : gfc_trans_scalarizing_loops (&loop, &block);
8725 :
8726 7470 : desc = loop.temp_ss->info->data.array.descriptor;
8727 : }
8728 67990 : else if (expr->expr_type == EXPR_FUNCTION && !transposed_dims (ss))
8729 : {
8730 1503 : desc = info->descriptor;
8731 1503 : se->string_length = ss_info->string_length;
8732 : }
8733 : else
8734 : {
8735 : /* We pass sections without copying to a temporary. Make a new
8736 : descriptor and point it at the section we want. The loop variable
8737 : limits will be the limits of the section.
8738 : A function may decide to repack the array to speed up access, but
8739 : we're not bothered about that here. */
8740 64971 : int dim, ndim, codim;
8741 64971 : tree parm;
8742 64971 : tree parmtype;
8743 64971 : tree dtype;
8744 64971 : tree stride;
8745 64971 : tree from;
8746 64971 : tree to;
8747 64971 : tree base;
8748 64971 : tree offset;
8749 :
8750 64971 : ndim = info->ref ? info->ref->u.ar.dimen : ss->dimen;
8751 :
8752 64971 : if (se->want_coarray)
8753 : {
8754 694 : gfc_array_ref *ar = &info->ref->u.ar;
8755 :
8756 694 : codim = expr->corank;
8757 1512 : for (n = 0; n < codim - 1; n++)
8758 : {
8759 : /* Make sure we are not lost somehow. */
8760 818 : gcc_assert (ar->dimen_type[n + ndim] == DIMEN_THIS_IMAGE);
8761 :
8762 : /* Make sure the call to gfc_conv_section_startstride won't
8763 : generate unnecessary code to calculate stride. */
8764 818 : gcc_assert (ar->stride[n + ndim] == NULL);
8765 :
8766 818 : gfc_conv_section_startstride (&loop.pre, ss, n + ndim);
8767 818 : loop.from[n + loop.dimen] = info->start[n + ndim];
8768 818 : loop.to[n + loop.dimen] = info->end[n + ndim];
8769 : }
8770 :
8771 694 : gcc_assert (n == codim - 1);
8772 694 : evaluate_bound (&loop.pre, info->start, ar->start,
8773 : info->descriptor, n + ndim, true,
8774 694 : ar->as->type == AS_DEFERRED, true);
8775 694 : loop.from[n + loop.dimen] = info->start[n + ndim];
8776 : }
8777 : else
8778 : codim = 0;
8779 :
8780 : /* Set the string_length for a character array. */
8781 64971 : if (expr->ts.type == BT_CHARACTER)
8782 : {
8783 11500 : if (deferred_array_component && !substr)
8784 37 : se->string_length = ss_info->string_length;
8785 : else
8786 11463 : se->string_length = gfc_get_expr_charlen (expr);
8787 :
8788 11500 : if (VAR_P (se->string_length)
8789 990 : && expr->ts.u.cl->backend_decl == se->string_length)
8790 984 : tmp = ss_info->string_length;
8791 : else
8792 : tmp = se->string_length;
8793 :
8794 11500 : if (expr->ts.deferred && expr->ts.u.cl->backend_decl
8795 217 : && VAR_P (expr->ts.u.cl->backend_decl))
8796 156 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, tmp);
8797 : else
8798 11344 : expr->ts.u.cl->backend_decl = tmp;
8799 : }
8800 :
8801 : /* If we have an array section, are assigning or passing an array
8802 : section argument make sure that the lower bound is 1. References
8803 : to the full array should otherwise keep the original bounds. */
8804 64971 : if (!info->ref || info->ref->u.ar.type != AR_FULL)
8805 83519 : for (dim = 0; dim < loop.dimen; dim++)
8806 50779 : if (!integer_onep (loop.from[dim]))
8807 : {
8808 27411 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
8809 : gfc_array_index_type, gfc_index_one_node,
8810 : loop.from[dim]);
8811 27411 : loop.to[dim] = fold_build2_loc (input_location, PLUS_EXPR,
8812 : gfc_array_index_type,
8813 : loop.to[dim], tmp);
8814 27411 : loop.from[dim] = gfc_index_one_node;
8815 : }
8816 :
8817 64971 : desc = info->descriptor;
8818 64971 : if (se->direct_byref && !se->byref_noassign)
8819 : {
8820 : /* For pointer assignments we fill in the destination. */
8821 2658 : parm = se->expr;
8822 2658 : parmtype = TREE_TYPE (parm);
8823 : }
8824 : else
8825 : {
8826 : /* Otherwise make a new one. */
8827 62313 : if (expr->ts.type == BT_CHARACTER)
8828 10848 : parmtype = gfc_typenode_for_spec (&expr->ts);
8829 : else
8830 51465 : parmtype = gfc_get_element_type (TREE_TYPE (desc));
8831 :
8832 62313 : parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, codim,
8833 : loop.from, loop.to, 0,
8834 : GFC_ARRAY_UNKNOWN, false);
8835 62313 : parm = gfc_create_var (parmtype, "parm");
8836 :
8837 : /* When expression is a class object, then add the class' handle to
8838 : the parm_decl. */
8839 62313 : if (expr->ts.type == BT_CLASS && expr->expr_type == EXPR_VARIABLE)
8840 : {
8841 1196 : gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr);
8842 1196 : gfc_se classse;
8843 :
8844 : /* class_expr can be NULL, when no _class ref is in expr.
8845 : We must not fix this here with a gfc_fix_class_ref (). */
8846 1196 : if (class_expr)
8847 : {
8848 1186 : gfc_init_se (&classse, NULL);
8849 1186 : gfc_conv_expr (&classse, class_expr);
8850 1186 : gfc_free_expr (class_expr);
8851 :
8852 1186 : gcc_assert (classse.pre.head == NULL_TREE
8853 : && classse.post.head == NULL_TREE);
8854 1186 : gfc_allocate_lang_decl (parm);
8855 1186 : GFC_DECL_SAVED_DESCRIPTOR (parm) = classse.expr;
8856 : }
8857 : }
8858 : }
8859 :
8860 64971 : if (expr->ts.type == BT_CHARACTER
8861 64971 : && VAR_P (TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (parm)))))
8862 : {
8863 0 : tree elem_len = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (parm)));
8864 0 : gfc_add_modify (&loop.pre, elem_len,
8865 0 : fold_convert (TREE_TYPE (elem_len),
8866 : gfc_get_array_span (desc, expr)));
8867 : }
8868 :
8869 : /* Set the span field. */
8870 64971 : tmp = NULL_TREE;
8871 64971 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
8872 7663 : tmp = gfc_conv_descriptor_span_get (desc);
8873 : else
8874 57308 : tmp = gfc_get_array_span (desc, expr);
8875 64971 : if (tmp)
8876 64891 : gfc_conv_descriptor_span_set (&loop.pre, parm, tmp);
8877 :
8878 : /* The following can be somewhat confusing. We have two
8879 : descriptors, a new one and the original array.
8880 : {parm, parmtype, dim} refer to the new one.
8881 : {desc, type, n, loop} refer to the original, which maybe
8882 : a descriptorless array.
8883 : The bounds of the scalarization are the bounds of the section.
8884 : We don't have to worry about numeric overflows when calculating
8885 : the offsets because all elements are within the array data. */
8886 :
8887 : /* Set the dtype. */
8888 64971 : tmp = gfc_conv_descriptor_dtype (parm);
8889 64971 : if (se->unlimited_polymorphic)
8890 613 : dtype = gfc_get_dtype (TREE_TYPE (desc), &loop.dimen);
8891 64358 : else if (expr->ts.type == BT_ASSUMED)
8892 : {
8893 127 : tree tmp2 = desc;
8894 127 : if (DECL_LANG_SPECIFIC (tmp2) && GFC_DECL_SAVED_DESCRIPTOR (tmp2))
8895 127 : tmp2 = GFC_DECL_SAVED_DESCRIPTOR (tmp2);
8896 127 : if (POINTER_TYPE_P (TREE_TYPE (tmp2)))
8897 127 : tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
8898 127 : dtype = gfc_conv_descriptor_dtype (tmp2);
8899 : }
8900 : else
8901 64231 : dtype = gfc_get_dtype (parmtype);
8902 64971 : gfc_add_modify (&loop.pre, tmp, dtype);
8903 :
8904 : /* The 1st element in the section. */
8905 64971 : base = gfc_index_zero_node;
8906 64971 : if (expr->ts.type == BT_CHARACTER && expr->rank == 0 && codim)
8907 6 : base = gfc_index_one_node;
8908 :
8909 : /* The offset from the 1st element in the section. */
8910 : offset = gfc_index_zero_node;
8911 :
8912 166768 : for (n = 0; n < ndim; n++)
8913 : {
8914 101797 : stride = gfc_conv_array_stride (desc, n);
8915 :
8916 : /* Work out the 1st element in the section. */
8917 101797 : if (info->ref
8918 94229 : && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
8919 : {
8920 1221 : gcc_assert (info->subscript[n]
8921 : && info->subscript[n]->info->type == GFC_SS_SCALAR);
8922 1221 : start = info->subscript[n]->info->data.scalar.value;
8923 : }
8924 : else
8925 : {
8926 : /* Evaluate and remember the start of the section. */
8927 100576 : start = info->start[n];
8928 100576 : stride = gfc_evaluate_now (stride, &loop.pre);
8929 : }
8930 :
8931 101797 : tmp = gfc_conv_array_lbound (desc, n);
8932 101797 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
8933 : start, tmp);
8934 101797 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
8935 : tmp, stride);
8936 101797 : base = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
8937 : base, tmp);
8938 :
8939 101797 : if (info->ref
8940 94229 : && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
8941 : {
8942 : /* For elemental dimensions, we only need the 1st
8943 : element in the section. */
8944 1221 : continue;
8945 : }
8946 :
8947 : /* Vector subscripts need copying and are handled elsewhere. */
8948 100576 : if (info->ref)
8949 93008 : gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
8950 :
8951 : /* look for the corresponding scalarizer dimension: dim. */
8952 151065 : for (dim = 0; dim < ndim; dim++)
8953 151065 : if (ss->dim[dim] == n)
8954 : break;
8955 :
8956 : /* loop exited early: the DIM being looked for has been found. */
8957 100576 : gcc_assert (dim < ndim);
8958 :
8959 : /* Set the new lower bound. */
8960 100576 : from = loop.from[dim];
8961 100576 : to = loop.to[dim];
8962 :
8963 100576 : gfc_conv_descriptor_lbound_set (&loop.pre, parm,
8964 : gfc_rank_cst[dim], from);
8965 :
8966 : /* Set the new upper bound. */
8967 100576 : gfc_conv_descriptor_ubound_set (&loop.pre, parm,
8968 : gfc_rank_cst[dim], to);
8969 :
8970 : /* Multiply the stride by the section stride to get the
8971 : total stride. */
8972 100576 : stride = fold_build2_loc (input_location, MULT_EXPR,
8973 : gfc_array_index_type,
8974 : stride, info->stride[n]);
8975 :
8976 100576 : tmp = fold_build2_loc (input_location, MULT_EXPR,
8977 100576 : TREE_TYPE (offset), stride, from);
8978 100576 : offset = fold_build2_loc (input_location, MINUS_EXPR,
8979 100576 : TREE_TYPE (offset), offset, tmp);
8980 :
8981 : /* Store the new stride. */
8982 100576 : gfc_conv_descriptor_stride_set (&loop.pre, parm,
8983 : gfc_rank_cst[dim], stride);
8984 : }
8985 :
8986 : /* For deferred-length character we need to take the dynamic length
8987 : into account for the dataptr offset. */
8988 64971 : if (expr->ts.type == BT_CHARACTER
8989 11500 : && expr->ts.deferred
8990 223 : && expr->ts.u.cl->backend_decl
8991 223 : && VAR_P (expr->ts.u.cl->backend_decl))
8992 : {
8993 156 : tree base_type = TREE_TYPE (base);
8994 156 : base = fold_build2_loc (input_location, MULT_EXPR, base_type, base,
8995 : fold_convert (base_type,
8996 : expr->ts.u.cl->backend_decl));
8997 : }
8998 :
8999 66483 : for (n = loop.dimen; n < loop.dimen + codim; n++)
9000 : {
9001 1512 : from = loop.from[n];
9002 1512 : to = loop.to[n];
9003 1512 : gfc_conv_descriptor_lbound_set (&loop.pre, parm,
9004 : gfc_rank_cst[n], from);
9005 1512 : if (n < loop.dimen + codim - 1)
9006 818 : gfc_conv_descriptor_ubound_set (&loop.pre, parm,
9007 : gfc_rank_cst[n], to);
9008 : }
9009 :
9010 64971 : if (se->data_not_needed)
9011 6063 : gfc_conv_descriptor_data_set (&loop.pre, parm,
9012 : gfc_index_zero_node);
9013 : else
9014 : /* Point the data pointer at the 1st element in the section. */
9015 58908 : gfc_get_dataptr_offset (&loop.pre, parm, desc, base,
9016 : subref_array_target, expr);
9017 :
9018 64971 : gfc_conv_descriptor_offset_set (&loop.pre, parm, offset);
9019 :
9020 64971 : if (flag_coarray == GFC_FCOARRAY_LIB && expr->corank)
9021 : {
9022 404 : tmp = INDIRECT_REF_P (desc) ? TREE_OPERAND (desc, 0) : desc;
9023 404 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
9024 : {
9025 24 : tmp = gfc_conv_descriptor_token (tmp);
9026 : }
9027 380 : else if (DECL_P (tmp) && DECL_LANG_SPECIFIC (tmp)
9028 460 : && GFC_DECL_TOKEN (tmp) != NULL_TREE)
9029 64 : tmp = GFC_DECL_TOKEN (tmp);
9030 : else
9031 : {
9032 316 : tmp = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (tmp));
9033 : }
9034 :
9035 404 : gfc_add_modify (&loop.pre, gfc_conv_descriptor_token (parm), tmp);
9036 : }
9037 : desc = parm;
9038 : }
9039 :
9040 : /* For class arrays add the class tree into the saved descriptor to
9041 : enable getting of _vptr and the like. */
9042 73944 : if (expr->expr_type == EXPR_VARIABLE && VAR_P (desc)
9043 57157 : && IS_CLASS_ARRAY (expr->symtree->n.sym))
9044 : {
9045 1168 : gfc_allocate_lang_decl (desc);
9046 1168 : GFC_DECL_SAVED_DESCRIPTOR (desc) =
9047 1168 : DECL_LANG_SPECIFIC (expr->symtree->n.sym->backend_decl) ?
9048 1082 : GFC_DECL_SAVED_DESCRIPTOR (expr->symtree->n.sym->backend_decl)
9049 : : expr->symtree->n.sym->backend_decl;
9050 : }
9051 72776 : else if (expr->expr_type == EXPR_ARRAY && VAR_P (desc)
9052 10357 : && IS_CLASS_ARRAY (expr))
9053 : {
9054 12 : tree vtype;
9055 12 : gfc_allocate_lang_decl (desc);
9056 12 : tmp = gfc_create_var (expr->ts.u.derived->backend_decl, "class");
9057 12 : GFC_DECL_SAVED_DESCRIPTOR (desc) = tmp;
9058 12 : vtype = gfc_class_vptr_get (tmp);
9059 12 : gfc_add_modify (&se->pre, vtype,
9060 12 : gfc_build_addr_expr (TREE_TYPE (vtype),
9061 12 : gfc_find_vtab (&expr->ts)->backend_decl));
9062 : }
9063 73944 : if (!se->direct_byref || se->byref_noassign)
9064 : {
9065 : /* Get a pointer to the new descriptor. */
9066 71286 : if (se->want_pointer)
9067 40153 : se->expr = gfc_build_addr_expr (NULL_TREE, desc);
9068 : else
9069 31133 : se->expr = desc;
9070 : }
9071 :
9072 73944 : gfc_add_block_to_block (&se->pre, &loop.pre);
9073 73944 : gfc_add_block_to_block (&se->post, &loop.post);
9074 :
9075 : /* Cleanup the scalarizer. */
9076 73944 : gfc_cleanup_loop (&loop);
9077 : }
9078 :
9079 :
9080 : /* Calculate the array size (number of elements); if dim != NULL_TREE,
9081 : return size for that dim (dim=0..rank-1; only for GFC_DESCRIPTOR_TYPE_P).
9082 : If !expr && descriptor array, the rank is taken from the descriptor. */
9083 : tree
9084 15276 : gfc_tree_array_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree dim)
9085 : {
9086 15276 : if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
9087 : {
9088 34 : gcc_assert (dim == NULL_TREE);
9089 34 : return GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
9090 : }
9091 15242 : tree size, tmp, rank = NULL_TREE, cond = NULL_TREE;
9092 15242 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
9093 15242 : enum gfc_array_kind akind = GFC_TYPE_ARRAY_AKIND (TREE_TYPE (desc));
9094 15242 : if (expr == NULL || expr->rank < 0)
9095 3420 : rank = fold_convert (signed_char_type_node,
9096 : gfc_conv_descriptor_rank (desc));
9097 : else
9098 11822 : rank = build_int_cst (signed_char_type_node, expr->rank);
9099 :
9100 15242 : if (dim || (expr && expr->rank == 1))
9101 : {
9102 4559 : if (!dim)
9103 4559 : dim = gfc_index_zero_node;
9104 13586 : tree ubound = gfc_conv_descriptor_ubound_get (desc, dim);
9105 13586 : tree lbound = gfc_conv_descriptor_lbound_get (desc, dim);
9106 :
9107 13586 : size = fold_build2_loc (input_location, MINUS_EXPR,
9108 : gfc_array_index_type, ubound, lbound);
9109 13586 : size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
9110 : size, gfc_index_one_node);
9111 : /* if (!allocatable && !pointer && assumed rank)
9112 : size = (idx == rank && ubound[rank-1] == -1 ? -1 : size;
9113 : else
9114 : size = max (0, size); */
9115 13586 : size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
9116 : size, gfc_index_zero_node);
9117 13586 : if (akind == GFC_ARRAY_ASSUMED_RANK_CONT
9118 13586 : || akind == GFC_ARRAY_ASSUMED_RANK)
9119 : {
9120 2733 : tmp = fold_build2_loc (input_location, MINUS_EXPR, signed_char_type_node,
9121 : rank, build_int_cst (signed_char_type_node, 1));
9122 2733 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
9123 : fold_convert (signed_char_type_node, dim),
9124 : tmp);
9125 2733 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
9126 : gfc_conv_descriptor_ubound_get (desc, dim),
9127 : build_int_cst (gfc_array_index_type, -1));
9128 2733 : cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
9129 : cond, tmp);
9130 2733 : tmp = build_int_cst (gfc_array_index_type, -1);
9131 2733 : size = build3_loc (input_location, COND_EXPR, gfc_array_index_type,
9132 : cond, tmp, size);
9133 : }
9134 13586 : return size;
9135 : }
9136 :
9137 : /* size = 1. */
9138 1656 : size = gfc_create_var (gfc_array_index_type, "size");
9139 1656 : gfc_add_modify (block, size, build_int_cst (TREE_TYPE (size), 1));
9140 1656 : tree extent = gfc_create_var (gfc_array_index_type, "extent");
9141 :
9142 1656 : stmtblock_t cond_block, loop_body;
9143 1656 : gfc_init_block (&cond_block);
9144 1656 : gfc_init_block (&loop_body);
9145 :
9146 : /* Loop: for (i = 0; i < rank; ++i). */
9147 1656 : tree idx = gfc_create_var (signed_char_type_node, "idx");
9148 : /* Loop body. */
9149 : /* #if (assumed-rank + !allocatable && !pointer)
9150 : if (idx == rank - 1 && dim[idx].ubound == -1)
9151 : extent = -1;
9152 : else
9153 : #endif
9154 : extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1
9155 : if (extent < 0)
9156 : extent = 0
9157 : size *= extent. */
9158 1656 : cond = NULL_TREE;
9159 1656 : if (akind == GFC_ARRAY_ASSUMED_RANK_CONT || akind == GFC_ARRAY_ASSUMED_RANK)
9160 : {
9161 459 : tmp = fold_build2_loc (input_location, MINUS_EXPR, signed_char_type_node,
9162 : rank, build_int_cst (signed_char_type_node, 1));
9163 459 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
9164 : idx, tmp);
9165 459 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
9166 : gfc_conv_descriptor_ubound_get (desc, idx),
9167 : build_int_cst (gfc_array_index_type, -1));
9168 459 : cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
9169 : cond, tmp);
9170 : }
9171 1656 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
9172 : gfc_conv_descriptor_ubound_get (desc, idx),
9173 : gfc_conv_descriptor_lbound_get (desc, idx));
9174 1656 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
9175 : tmp, gfc_index_one_node);
9176 1656 : gfc_add_modify (&cond_block, extent, tmp);
9177 1656 : tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
9178 : extent, gfc_index_zero_node);
9179 1656 : tmp = build3_v (COND_EXPR, tmp,
9180 : fold_build2_loc (input_location, MODIFY_EXPR,
9181 : gfc_array_index_type,
9182 : extent, gfc_index_zero_node),
9183 : build_empty_stmt (input_location));
9184 1656 : gfc_add_expr_to_block (&cond_block, tmp);
9185 1656 : tmp = gfc_finish_block (&cond_block);
9186 1656 : if (cond)
9187 459 : tmp = build3_v (COND_EXPR, cond,
9188 : fold_build2_loc (input_location, MODIFY_EXPR,
9189 : gfc_array_index_type, extent,
9190 : build_int_cst (gfc_array_index_type, -1)),
9191 : tmp);
9192 1656 : gfc_add_expr_to_block (&loop_body, tmp);
9193 : /* size *= extent. */
9194 1656 : gfc_add_modify (&loop_body, size,
9195 : fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9196 : size, extent));
9197 : /* Generate loop. */
9198 3312 : gfc_simple_for_loop (block, idx, build_int_cst (TREE_TYPE (idx), 0), rank, LT_EXPR,
9199 1656 : build_int_cst (TREE_TYPE (idx), 1),
9200 : gfc_finish_block (&loop_body));
9201 1656 : return size;
9202 : }
9203 :
9204 : /* Helper function for gfc_conv_array_parameter if array size needs to be
9205 : computed. */
9206 :
9207 : static void
9208 112 : array_parameter_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree *size)
9209 : {
9210 112 : tree elem;
9211 112 : *size = gfc_tree_array_size (block, desc, expr, NULL);
9212 112 : elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
9213 112 : *size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9214 : *size, fold_convert (gfc_array_index_type, elem));
9215 112 : }
9216 :
9217 : /* Helper function - return true if the argument is a pointer. */
9218 :
9219 : static bool
9220 737 : is_pointer (gfc_expr *e)
9221 : {
9222 737 : gfc_symbol *sym;
9223 :
9224 737 : if (e->expr_type != EXPR_VARIABLE || e->symtree == NULL)
9225 : return false;
9226 :
9227 737 : sym = e->symtree->n.sym;
9228 737 : if (sym == NULL)
9229 : return false;
9230 :
9231 737 : return sym->attr.pointer || sym->attr.proc_pointer;
9232 : }
9233 :
9234 : /* Convert an array for passing as an actual parameter. */
9235 :
9236 : void
9237 65810 : gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr, bool g77,
9238 : const gfc_symbol *fsym, const char *proc_name,
9239 : tree *size, tree *lbshift, tree *packed)
9240 : {
9241 65810 : tree ptr;
9242 65810 : tree desc;
9243 65810 : tree tmp = NULL_TREE;
9244 65810 : tree stmt;
9245 65810 : tree parent = DECL_CONTEXT (current_function_decl);
9246 65810 : tree ctree;
9247 65810 : tree pack_attr = NULL_TREE; /* Set when packing class arrays. */
9248 65810 : bool full_array_var;
9249 65810 : bool this_array_result;
9250 65810 : bool contiguous;
9251 65810 : bool no_pack;
9252 65810 : bool array_constructor;
9253 65810 : bool good_allocatable;
9254 65810 : bool ultimate_ptr_comp;
9255 65810 : bool ultimate_alloc_comp;
9256 65810 : bool readonly;
9257 65810 : gfc_symbol *sym;
9258 65810 : stmtblock_t block;
9259 65810 : gfc_ref *ref;
9260 :
9261 65810 : ultimate_ptr_comp = false;
9262 65810 : ultimate_alloc_comp = false;
9263 :
9264 66528 : for (ref = expr->ref; ref; ref = ref->next)
9265 : {
9266 55122 : if (ref->next == NULL)
9267 : break;
9268 :
9269 718 : if (ref->type == REF_COMPONENT)
9270 : {
9271 640 : ultimate_ptr_comp = ref->u.c.component->attr.pointer;
9272 640 : ultimate_alloc_comp = ref->u.c.component->attr.allocatable;
9273 : }
9274 : }
9275 :
9276 65810 : full_array_var = false;
9277 65810 : contiguous = false;
9278 :
9279 65810 : if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp)
9280 54312 : full_array_var = gfc_full_array_ref_p (ref, &contiguous);
9281 :
9282 54312 : sym = full_array_var ? expr->symtree->n.sym : NULL;
9283 :
9284 : /* The symbol should have an array specification. */
9285 62897 : gcc_assert (!sym || sym->as || ref->u.ar.as);
9286 :
9287 65810 : if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
9288 : {
9289 690 : get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
9290 690 : expr->ts.u.cl->backend_decl = tmp;
9291 690 : se->string_length = tmp;
9292 : }
9293 :
9294 : /* Is this the result of the enclosing procedure? */
9295 65810 : this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
9296 58 : if (this_array_result
9297 58 : && (sym->backend_decl != current_function_decl)
9298 0 : && (sym->backend_decl != parent))
9299 65810 : this_array_result = false;
9300 :
9301 : /* Passing an optional dummy argument as actual to an optional dummy? */
9302 65810 : bool pass_optional;
9303 65810 : pass_optional = fsym && fsym->attr.optional && sym && sym->attr.optional;
9304 :
9305 : /* Passing address of the array if it is not pointer or assumed-shape. */
9306 65810 : if (full_array_var && g77 && !this_array_result
9307 15918 : && sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
9308 : {
9309 12490 : tmp = gfc_get_symbol_decl (sym);
9310 :
9311 12490 : if (sym->ts.type == BT_CHARACTER)
9312 2773 : se->string_length = sym->ts.u.cl->backend_decl;
9313 :
9314 12490 : if (!sym->attr.pointer
9315 11985 : && sym->as
9316 11985 : && sym->as->type != AS_ASSUMED_SHAPE
9317 11740 : && sym->as->type != AS_DEFERRED
9318 10246 : && sym->as->type != AS_ASSUMED_RANK
9319 10170 : && !sym->attr.allocatable)
9320 : {
9321 : /* Some variables are declared directly, others are declared as
9322 : pointers and allocated on the heap. */
9323 9664 : if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
9324 2502 : se->expr = tmp;
9325 : else
9326 7162 : se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
9327 9664 : if (size)
9328 34 : array_parameter_size (&se->pre, tmp, expr, size);
9329 16788 : return;
9330 : }
9331 :
9332 2826 : if (sym->attr.allocatable)
9333 : {
9334 1880 : if (sym->attr.dummy || sym->attr.result)
9335 : {
9336 1176 : gfc_conv_expr_descriptor (se, expr);
9337 1176 : tmp = se->expr;
9338 : }
9339 1880 : if (size)
9340 14 : array_parameter_size (&se->pre, tmp, expr, size);
9341 1880 : se->expr = gfc_conv_array_data (tmp);
9342 1880 : if (pass_optional)
9343 : {
9344 18 : tree cond = gfc_conv_expr_present (sym);
9345 36 : se->expr = build3_loc (input_location, COND_EXPR,
9346 18 : TREE_TYPE (se->expr), cond, se->expr,
9347 18 : fold_convert (TREE_TYPE (se->expr),
9348 : null_pointer_node));
9349 : }
9350 1880 : return;
9351 : }
9352 : }
9353 :
9354 : /* A convenient reduction in scope. */
9355 54266 : contiguous = g77 && !this_array_result && contiguous;
9356 :
9357 : /* There is no need to pack and unpack the array, if it is contiguous
9358 : and not a deferred- or assumed-shape array, or if it is simply
9359 : contiguous. */
9360 54266 : no_pack = false;
9361 : // clang-format off
9362 54266 : if (sym)
9363 : {
9364 39945 : symbol_attribute *attr = &(IS_CLASS_ARRAY (sym)
9365 : ? CLASS_DATA (sym)->attr : sym->attr);
9366 39945 : gfc_array_spec *as = IS_CLASS_ARRAY (sym)
9367 39945 : ? CLASS_DATA (sym)->as : sym->as;
9368 39945 : no_pack = (as
9369 39667 : && !attr->pointer
9370 36394 : && as->type != AS_DEFERRED
9371 26739 : && as->type != AS_ASSUMED_RANK
9372 63674 : && as->type != AS_ASSUMED_SHAPE);
9373 : }
9374 54266 : if (ref && ref->u.ar.as)
9375 42858 : no_pack = no_pack
9376 42858 : || (ref->u.ar.as->type != AS_DEFERRED
9377 : && ref->u.ar.as->type != AS_ASSUMED_RANK
9378 : && ref->u.ar.as->type != AS_ASSUMED_SHAPE);
9379 108532 : no_pack = contiguous
9380 54266 : && (no_pack || gfc_is_simply_contiguous (expr, false, true));
9381 : // clang-format on
9382 :
9383 : /* If we have an EXPR_OP or a function returning an explicit-shaped
9384 : or allocatable array, an array temporary will be generated which
9385 : does not need to be packed / unpacked if passed to an
9386 : explicit-shape dummy array. */
9387 :
9388 54266 : if (g77)
9389 : {
9390 6309 : if (expr->expr_type == EXPR_OP)
9391 : no_pack = 1;
9392 6232 : else if (expr->expr_type == EXPR_FUNCTION && expr->value.function.esym)
9393 : {
9394 41 : gfc_symbol *result = expr->value.function.esym->result;
9395 41 : if (result->attr.dimension
9396 41 : && (result->as->type == AS_EXPLICIT
9397 14 : || result->attr.allocatable
9398 7 : || result->attr.contiguous))
9399 112 : no_pack = 1;
9400 : }
9401 : }
9402 :
9403 : /* Array constructors are always contiguous and do not need packing. */
9404 54266 : array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY;
9405 :
9406 : /* Same is true of contiguous sections from allocatable variables. */
9407 108532 : good_allocatable = contiguous
9408 4491 : && expr->symtree
9409 58757 : && expr->symtree->n.sym->attr.allocatable;
9410 :
9411 : /* Or ultimate allocatable components. */
9412 54266 : ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
9413 :
9414 54266 : if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp)
9415 : {
9416 4854 : gfc_conv_expr_descriptor (se, expr);
9417 : /* Deallocate the allocatable components of structures that are
9418 : not variable. */
9419 4854 : if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
9420 3343 : && expr->ts.u.derived->attr.alloc_comp
9421 1982 : && expr->expr_type != EXPR_VARIABLE)
9422 : {
9423 2 : tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, se->expr, expr->rank);
9424 :
9425 : /* The components shall be deallocated before their containing entity. */
9426 2 : gfc_prepend_expr_to_block (&se->post, tmp);
9427 : }
9428 4854 : if (expr->ts.type == BT_CHARACTER && expr->expr_type != EXPR_FUNCTION)
9429 279 : se->string_length = expr->ts.u.cl->backend_decl;
9430 4854 : if (size)
9431 34 : array_parameter_size (&se->pre, se->expr, expr, size);
9432 4854 : se->expr = gfc_conv_array_data (se->expr);
9433 4854 : return;
9434 : }
9435 :
9436 49412 : if (fsym && fsym->ts.type == BT_CLASS)
9437 : {
9438 1248 : gcc_assert (se->expr);
9439 : ctree = se->expr;
9440 : }
9441 : else
9442 : ctree = NULL_TREE;
9443 :
9444 49412 : if (this_array_result)
9445 : {
9446 : /* Result of the enclosing function. */
9447 58 : gfc_conv_expr_descriptor (se, expr);
9448 58 : if (size)
9449 0 : array_parameter_size (&se->pre, se->expr, expr, size);
9450 58 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
9451 :
9452 18 : if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
9453 76 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
9454 18 : se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location,
9455 : se->expr));
9456 :
9457 58 : return;
9458 : }
9459 : else
9460 : {
9461 : /* Every other type of array. */
9462 49354 : se->want_pointer = (ctree) ? 0 : 1;
9463 49354 : se->want_coarray = expr->corank;
9464 49354 : gfc_conv_expr_descriptor (se, expr);
9465 :
9466 49354 : if (size)
9467 30 : array_parameter_size (&se->pre,
9468 : build_fold_indirect_ref_loc (input_location,
9469 : se->expr),
9470 : expr, size);
9471 49354 : if (ctree)
9472 : {
9473 1248 : stmtblock_t block;
9474 :
9475 1248 : gfc_init_block (&block);
9476 1248 : if (lbshift && *lbshift)
9477 : {
9478 : /* Apply a shift of the lbound when supplied. */
9479 98 : for (int dim = 0; dim < expr->rank; ++dim)
9480 49 : gfc_conv_shift_descriptor_lbound (&block, se->expr, dim,
9481 : *lbshift);
9482 : }
9483 1248 : tmp = gfc_class_data_get (ctree);
9484 1248 : if (expr->rank > 1 && CLASS_DATA (fsym)->as->rank != expr->rank
9485 84 : && CLASS_DATA (fsym)->as->type == AS_EXPLICIT && !no_pack)
9486 : {
9487 36 : tree arr = gfc_create_var (TREE_TYPE (tmp), "parm");
9488 36 : gfc_conv_descriptor_data_set (&block, arr,
9489 : gfc_conv_descriptor_data_get (
9490 : se->expr));
9491 36 : gfc_conv_descriptor_lbound_set (&block, arr, gfc_index_zero_node,
9492 : gfc_index_zero_node);
9493 36 : gfc_conv_descriptor_ubound_set (
9494 : &block, arr, gfc_index_zero_node,
9495 : gfc_conv_descriptor_size (se->expr, expr->rank));
9496 36 : gfc_conv_descriptor_stride_set (
9497 : &block, arr, gfc_index_zero_node,
9498 : gfc_conv_descriptor_stride_get (se->expr, gfc_index_zero_node));
9499 36 : gfc_add_modify (&block, gfc_conv_descriptor_dtype (arr),
9500 : gfc_conv_descriptor_dtype (se->expr));
9501 36 : gfc_add_modify (&block, gfc_conv_descriptor_rank (arr),
9502 : build_int_cst (signed_char_type_node, 1));
9503 36 : gfc_conv_descriptor_span_set (&block, arr,
9504 : gfc_conv_descriptor_span_get (arr));
9505 36 : gfc_conv_descriptor_offset_set (&block, arr, gfc_index_zero_node);
9506 36 : se->expr = arr;
9507 : }
9508 1248 : gfc_class_array_data_assign (&block, tmp, se->expr, true);
9509 :
9510 : /* Handle optional. */
9511 1248 : if (fsym && fsym->attr.optional && sym && sym->attr.optional)
9512 348 : tmp = build3_v (COND_EXPR, gfc_conv_expr_present (sym),
9513 : gfc_finish_block (&block),
9514 : build_empty_stmt (input_location));
9515 : else
9516 900 : tmp = gfc_finish_block (&block);
9517 :
9518 1248 : gfc_add_expr_to_block (&se->pre, tmp);
9519 : }
9520 48106 : else if (pass_optional && full_array_var && sym->as && sym->as->rank != 0)
9521 : {
9522 : /* Perform calculation of bounds and strides of optional array dummy
9523 : only if the argument is present. */
9524 219 : tmp = build3_v (COND_EXPR, gfc_conv_expr_present (sym),
9525 : gfc_finish_block (&se->pre),
9526 : build_empty_stmt (input_location));
9527 219 : gfc_add_expr_to_block (&se->pre, tmp);
9528 : }
9529 : }
9530 :
9531 : /* Deallocate the allocatable components of structures that are
9532 : not variable, for descriptorless arguments.
9533 : Arguments with a descriptor are handled in gfc_conv_procedure_call. */
9534 49354 : if (g77 && (expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
9535 75 : && expr->ts.u.derived->attr.alloc_comp
9536 21 : && expr->expr_type != EXPR_VARIABLE)
9537 : {
9538 0 : tmp = build_fold_indirect_ref_loc (input_location, se->expr);
9539 0 : tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank);
9540 :
9541 : /* The components shall be deallocated before their containing entity. */
9542 0 : gfc_prepend_expr_to_block (&se->post, tmp);
9543 : }
9544 :
9545 47917 : if (g77 || (fsym && fsym->attr.contiguous
9546 1548 : && !gfc_is_simply_contiguous (expr, false, true)))
9547 : {
9548 1593 : tree origptr = NULL_TREE, packedptr = NULL_TREE;
9549 :
9550 1593 : desc = se->expr;
9551 :
9552 : /* For contiguous arrays, save the original value of the descriptor. */
9553 1593 : if (!g77 && !ctree)
9554 : {
9555 60 : origptr = gfc_create_var (pvoid_type_node, "origptr");
9556 60 : tmp = build_fold_indirect_ref_loc (input_location, desc);
9557 60 : tmp = gfc_conv_array_data (tmp);
9558 120 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
9559 60 : TREE_TYPE (origptr), origptr,
9560 60 : fold_convert (TREE_TYPE (origptr), tmp));
9561 60 : gfc_add_expr_to_block (&se->pre, tmp);
9562 : }
9563 :
9564 : /* Repack the array. */
9565 1593 : if (warn_array_temporaries)
9566 : {
9567 28 : if (fsym)
9568 18 : gfc_warning (OPT_Warray_temporaries,
9569 : "Creating array temporary at %L for argument %qs",
9570 18 : &expr->where, fsym->name);
9571 : else
9572 10 : gfc_warning (OPT_Warray_temporaries,
9573 : "Creating array temporary at %L", &expr->where);
9574 : }
9575 :
9576 : /* When optimizing, we can use gfc_conv_subref_array_arg for
9577 : making the packing and unpacking operation visible to the
9578 : optimizers. */
9579 :
9580 1437 : if (g77 && flag_inline_arg_packing && expr->expr_type == EXPR_VARIABLE
9581 737 : && !is_pointer (expr) && ! gfc_has_dimen_vector_ref (expr)
9582 353 : && !(expr->symtree->n.sym->as
9583 324 : && expr->symtree->n.sym->as->type == AS_ASSUMED_RANK)
9584 1946 : && (fsym == NULL || fsym->ts.type != BT_ASSUMED))
9585 : {
9586 332 : gfc_conv_subref_array_arg (se, expr, g77,
9587 141 : fsym ? fsym->attr.intent : INTENT_INOUT,
9588 : false, fsym, proc_name, sym, true);
9589 332 : return;
9590 : }
9591 :
9592 1261 : if (ctree)
9593 : {
9594 96 : packedptr
9595 96 : = gfc_build_addr_expr (NULL_TREE, gfc_create_var (TREE_TYPE (ctree),
9596 : "packed"));
9597 96 : if (fsym)
9598 : {
9599 96 : int pack_mask = 0;
9600 :
9601 : /* Set bit 0 to the mask, when this is an unlimited_poly
9602 : class. */
9603 96 : if (CLASS_DATA (fsym)->ts.u.derived->attr.unlimited_polymorphic)
9604 36 : pack_mask = 1 << 0;
9605 96 : pack_attr = build_int_cst (integer_type_node, pack_mask);
9606 : }
9607 : else
9608 0 : pack_attr = integer_zero_node;
9609 :
9610 96 : gfc_add_expr_to_block (
9611 : &se->pre,
9612 : build_call_expr_loc (input_location, gfor_fndecl_in_pack_class, 4,
9613 : packedptr,
9614 : gfc_build_addr_expr (NULL_TREE, ctree),
9615 96 : size_in_bytes (TREE_TYPE (ctree)), pack_attr));
9616 96 : ptr = gfc_conv_array_data (gfc_class_data_get (packedptr));
9617 96 : se->expr = packedptr;
9618 96 : if (packed)
9619 96 : *packed = packedptr;
9620 : }
9621 : else
9622 : {
9623 1165 : ptr = build_call_expr_loc (input_location, gfor_fndecl_in_pack, 1,
9624 : desc);
9625 :
9626 1165 : if (fsym && fsym->attr.optional && sym && sym->attr.optional)
9627 : {
9628 11 : tmp = gfc_conv_expr_present (sym);
9629 22 : ptr = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
9630 11 : tmp, fold_convert (TREE_TYPE (se->expr), ptr),
9631 11 : fold_convert (TREE_TYPE (se->expr),
9632 : null_pointer_node));
9633 : }
9634 :
9635 1165 : ptr = gfc_evaluate_now (ptr, &se->pre);
9636 : }
9637 :
9638 : /* Use the packed data for the actual argument, except for contiguous arrays,
9639 : where the descriptor's data component is set. */
9640 1261 : if (g77)
9641 1105 : se->expr = ptr;
9642 : else
9643 : {
9644 156 : tmp = build_fold_indirect_ref_loc (input_location, desc);
9645 :
9646 156 : gfc_ss * ss = gfc_walk_expr (expr);
9647 312 : if (!transposed_dims (ss) && expr->rank != -1)
9648 : {
9649 138 : if (!ctree)
9650 48 : gfc_conv_descriptor_data_set (&se->pre, tmp, ptr);
9651 : }
9652 18 : else if (!ctree)
9653 : {
9654 12 : tree old_field, new_field;
9655 12 : tree old_desc = tmp;
9656 12 : tree new_desc = gfc_create_var (TREE_TYPE (old_desc), "arg_desc");
9657 :
9658 12 : old_field = gfc_conv_descriptor_dtype (old_desc);
9659 12 : new_field = gfc_conv_descriptor_dtype (new_desc);
9660 12 : gfc_add_modify (&se->pre, new_field, old_field);
9661 :
9662 12 : if (expr->rank == -1)
9663 : {
9664 12 : tree idx = gfc_create_var (TREE_TYPE (gfc_conv_descriptor_rank
9665 : (old_desc)),
9666 : "idx");
9667 12 : tree stride = gfc_create_var (gfc_array_index_type, "stride");
9668 12 : stmtblock_t loop_body;
9669 :
9670 12 : gfc_conv_descriptor_offset_set (&se->pre, new_desc,
9671 : gfc_index_zero_node);
9672 12 : gfc_conv_descriptor_span_set (&se->pre, new_desc,
9673 : gfc_conv_descriptor_span_get
9674 : (old_desc));
9675 12 : gfc_add_modify (&se->pre, stride, gfc_index_one_node);
9676 :
9677 12 : gfc_init_block (&loop_body);
9678 :
9679 12 : old_field = gfc_conv_descriptor_lbound_get (old_desc, idx);
9680 12 : gfc_conv_descriptor_lbound_set (&loop_body, new_desc, idx,
9681 : old_field);
9682 :
9683 12 : old_field = gfc_conv_descriptor_ubound_get (old_desc, idx);
9684 12 : gfc_conv_descriptor_ubound_set (&loop_body, new_desc, idx,
9685 : old_field);
9686 :
9687 12 : gfc_conv_descriptor_stride_set (&loop_body, new_desc, idx,
9688 : stride);
9689 :
9690 12 : tree offset = fold_build2_loc (input_location, MULT_EXPR,
9691 : gfc_array_index_type, stride,
9692 : gfc_conv_descriptor_lbound_get
9693 : (new_desc, idx));
9694 12 : offset = fold_build2_loc (input_location, MINUS_EXPR,
9695 : gfc_array_index_type,
9696 : gfc_conv_descriptor_offset_get
9697 : (new_desc), offset);
9698 12 : gfc_conv_descriptor_offset_set (&loop_body, new_desc, offset);
9699 :
9700 12 : tree extent = gfc_conv_array_extent_dim
9701 12 : (gfc_conv_descriptor_lbound_get (new_desc, idx),
9702 : gfc_conv_descriptor_ubound_get (new_desc, idx),
9703 : NULL);
9704 12 : extent = fold_build2_loc (input_location, MULT_EXPR,
9705 : gfc_array_index_type, stride,
9706 : extent);
9707 12 : gfc_add_modify (&loop_body, stride, extent);
9708 :
9709 36 : gfc_simple_for_loop (&se->pre, idx,
9710 12 : build_int_cst (TREE_TYPE (idx), 0),
9711 : gfc_conv_descriptor_rank (old_desc),
9712 : LT_EXPR,
9713 12 : build_int_cst (TREE_TYPE (idx), 1),
9714 : gfc_finish_block (&loop_body));
9715 : }
9716 : else
9717 : {
9718 : /* The original descriptor has transposed dims so we can't
9719 : reuse it directly; we have to create a new one. */
9720 0 : old_field = gfc_conv_descriptor_offset_get (old_desc);
9721 0 : gfc_conv_descriptor_offset_set (&se->pre, new_desc, old_field);
9722 :
9723 0 : for (int i = 0; i < expr->rank; i++)
9724 : {
9725 0 : old_field = gfc_conv_descriptor_dimension (old_desc,
9726 0 : gfc_rank_cst[get_array_ref_dim_for_loop_dim (ss, i)]);
9727 0 : new_field = gfc_conv_descriptor_dimension (new_desc,
9728 : gfc_rank_cst[i]);
9729 0 : gfc_add_modify (&se->pre, new_field, old_field);
9730 : }
9731 : }
9732 :
9733 12 : if (flag_coarray == GFC_FCOARRAY_LIB
9734 0 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (old_desc))
9735 12 : && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (old_desc))
9736 : == GFC_ARRAY_ALLOCATABLE)
9737 : {
9738 0 : old_field = gfc_conv_descriptor_token (old_desc);
9739 0 : new_field = gfc_conv_descriptor_token (new_desc);
9740 0 : gfc_add_modify (&se->pre, new_field, old_field);
9741 : }
9742 :
9743 12 : gfc_conv_descriptor_data_set (&se->pre, new_desc, ptr);
9744 12 : se->expr = gfc_build_addr_expr (NULL_TREE, new_desc);
9745 : }
9746 156 : gfc_free_ss (ss);
9747 : }
9748 :
9749 1261 : if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
9750 : {
9751 8 : char * msg;
9752 :
9753 8 : if (fsym && proc_name)
9754 8 : msg = xasprintf ("An array temporary was created for argument "
9755 8 : "'%s' of procedure '%s'", fsym->name, proc_name);
9756 : else
9757 0 : msg = xasprintf ("An array temporary was created");
9758 :
9759 8 : tmp = build_fold_indirect_ref_loc (input_location,
9760 : desc);
9761 8 : tmp = gfc_conv_array_data (tmp);
9762 8 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9763 8 : fold_convert (TREE_TYPE (tmp), ptr), tmp);
9764 :
9765 8 : if (pass_optional)
9766 6 : tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
9767 : logical_type_node,
9768 : gfc_conv_expr_present (sym), tmp);
9769 :
9770 8 : gfc_trans_runtime_check (false, true, tmp, &se->pre,
9771 : &expr->where, msg);
9772 8 : free (msg);
9773 : }
9774 :
9775 1261 : gfc_start_block (&block);
9776 :
9777 : /* Copy the data back. If input expr is read-only, e.g. a PARAMETER
9778 : array, copying back modified values is undefined behavior. */
9779 2522 : readonly = (expr->expr_type == EXPR_VARIABLE
9780 868 : && expr->symtree
9781 2129 : && expr->symtree->n.sym->attr.flavor == FL_PARAMETER);
9782 :
9783 1261 : if ((fsym == NULL || fsym->attr.intent != INTENT_IN) && !readonly)
9784 : {
9785 1128 : if (ctree)
9786 : {
9787 66 : tmp = gfc_build_addr_expr (NULL_TREE, ctree);
9788 66 : tmp = build_call_expr_loc (input_location,
9789 : gfor_fndecl_in_unpack_class, 4, tmp,
9790 : packedptr,
9791 66 : size_in_bytes (TREE_TYPE (ctree)),
9792 : pack_attr);
9793 : }
9794 : else
9795 1062 : tmp = build_call_expr_loc (input_location, gfor_fndecl_in_unpack, 2,
9796 : desc, ptr);
9797 1128 : gfc_add_expr_to_block (&block, tmp);
9798 : }
9799 133 : else if (ctree && fsym->attr.intent == INTENT_IN)
9800 : {
9801 : /* Need to free the memory for class arrays, that got packed. */
9802 30 : gfc_add_expr_to_block (&block, gfc_call_free (ptr));
9803 : }
9804 :
9805 : /* Free the temporary. */
9806 1158 : if (!ctree)
9807 1165 : gfc_add_expr_to_block (&block, gfc_call_free (ptr));
9808 :
9809 1261 : stmt = gfc_finish_block (&block);
9810 :
9811 1261 : gfc_init_block (&block);
9812 : /* Only if it was repacked. This code needs to be executed before the
9813 : loop cleanup code. */
9814 1261 : tmp = (ctree) ? desc : build_fold_indirect_ref_loc (input_location, desc);
9815 1261 : tmp = gfc_conv_array_data (tmp);
9816 1261 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9817 1261 : fold_convert (TREE_TYPE (tmp), ptr), tmp);
9818 :
9819 1261 : if (pass_optional)
9820 11 : tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
9821 : logical_type_node,
9822 : gfc_conv_expr_present (sym), tmp);
9823 :
9824 1261 : tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
9825 :
9826 1261 : gfc_add_expr_to_block (&block, tmp);
9827 1261 : gfc_add_block_to_block (&block, &se->post);
9828 :
9829 1261 : gfc_init_block (&se->post);
9830 :
9831 : /* Reset the descriptor pointer. */
9832 1261 : if (!g77 && !ctree)
9833 : {
9834 60 : tmp = build_fold_indirect_ref_loc (input_location, desc);
9835 60 : gfc_conv_descriptor_data_set (&se->post, tmp, origptr);
9836 : }
9837 :
9838 1261 : gfc_add_block_to_block (&se->post, &block);
9839 : }
9840 : }
9841 :
9842 :
9843 : /* This helper function calculates the size in words of a full array. */
9844 :
9845 : tree
9846 20060 : gfc_full_array_size (stmtblock_t *block, tree decl, int rank)
9847 : {
9848 20060 : tree idx;
9849 20060 : tree nelems;
9850 20060 : tree tmp;
9851 20060 : if (rank < 0)
9852 0 : idx = gfc_conv_descriptor_rank (decl);
9853 : else
9854 20060 : idx = gfc_rank_cst[rank - 1];
9855 20060 : nelems = gfc_conv_descriptor_ubound_get (decl, idx);
9856 20060 : tmp = gfc_conv_descriptor_lbound_get (decl, idx);
9857 20060 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
9858 : nelems, tmp);
9859 20060 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
9860 : tmp, gfc_index_one_node);
9861 20060 : tmp = gfc_evaluate_now (tmp, block);
9862 :
9863 20060 : nelems = gfc_conv_descriptor_stride_get (decl, idx);
9864 20060 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9865 : nelems, tmp);
9866 20060 : return gfc_evaluate_now (tmp, block);
9867 : }
9868 :
9869 :
9870 : /* Allocate dest to the same size as src, and copy src -> dest.
9871 : If no_malloc is set, only the copy is done. */
9872 :
9873 : static tree
9874 9660 : duplicate_allocatable (tree dest, tree src, tree type, int rank,
9875 : bool no_malloc, bool no_memcpy, tree str_sz,
9876 : tree add_when_allocated)
9877 : {
9878 9660 : tree tmp;
9879 9660 : tree eltype;
9880 9660 : tree size;
9881 9660 : tree nelems;
9882 9660 : tree null_cond;
9883 9660 : tree null_data;
9884 9660 : stmtblock_t block;
9885 :
9886 : /* If the source is null, set the destination to null. Then,
9887 : allocate memory to the destination. */
9888 9660 : gfc_init_block (&block);
9889 :
9890 9660 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
9891 : {
9892 2211 : gfc_add_modify (&block, dest, fold_convert (type, null_pointer_node));
9893 2211 : null_data = gfc_finish_block (&block);
9894 :
9895 2211 : gfc_init_block (&block);
9896 2211 : eltype = TREE_TYPE (type);
9897 2211 : if (str_sz != NULL_TREE)
9898 : size = str_sz;
9899 : else
9900 1868 : size = TYPE_SIZE_UNIT (eltype);
9901 :
9902 2211 : if (!no_malloc)
9903 : {
9904 2211 : tmp = gfc_call_malloc (&block, type, size);
9905 2211 : gfc_add_modify (&block, dest, fold_convert (type, tmp));
9906 : }
9907 :
9908 2211 : if (!no_memcpy)
9909 : {
9910 1786 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
9911 1786 : tmp = build_call_expr_loc (input_location, tmp, 3, dest, src,
9912 : fold_convert (size_type_node, size));
9913 1786 : gfc_add_expr_to_block (&block, tmp);
9914 : }
9915 : }
9916 : else
9917 : {
9918 7449 : gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
9919 7449 : null_data = gfc_finish_block (&block);
9920 :
9921 7449 : gfc_init_block (&block);
9922 7449 : if (rank)
9923 7434 : nelems = gfc_full_array_size (&block, src, rank);
9924 : else
9925 15 : nelems = gfc_index_one_node;
9926 :
9927 : /* If type is not the array type, then it is the element type. */
9928 7449 : if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type))
9929 7419 : eltype = gfc_get_element_type (type);
9930 : else
9931 : eltype = type;
9932 :
9933 7449 : if (str_sz != NULL_TREE)
9934 43 : tmp = fold_convert (gfc_array_index_type, str_sz);
9935 : else
9936 7406 : tmp = fold_convert (gfc_array_index_type,
9937 : TYPE_SIZE_UNIT (eltype));
9938 :
9939 7449 : tmp = gfc_evaluate_now (tmp, &block);
9940 7449 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9941 : nelems, tmp);
9942 7449 : if (!no_malloc)
9943 : {
9944 7393 : tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src));
9945 7393 : tmp = gfc_call_malloc (&block, tmp, size);
9946 7393 : gfc_conv_descriptor_data_set (&block, dest, tmp);
9947 : }
9948 :
9949 : /* We know the temporary and the value will be the same length,
9950 : so can use memcpy. */
9951 7449 : if (!no_memcpy)
9952 : {
9953 6088 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
9954 6088 : tmp = build_call_expr_loc (input_location, tmp, 3,
9955 : gfc_conv_descriptor_data_get (dest),
9956 : gfc_conv_descriptor_data_get (src),
9957 : fold_convert (size_type_node, size));
9958 6088 : gfc_add_expr_to_block (&block, tmp);
9959 : }
9960 : }
9961 :
9962 9660 : gfc_add_expr_to_block (&block, add_when_allocated);
9963 9660 : tmp = gfc_finish_block (&block);
9964 :
9965 : /* Null the destination if the source is null; otherwise do
9966 : the allocate and copy. */
9967 9660 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src)))
9968 : null_cond = src;
9969 : else
9970 7449 : null_cond = gfc_conv_descriptor_data_get (src);
9971 :
9972 9660 : null_cond = convert (pvoid_type_node, null_cond);
9973 9660 : null_cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9974 : null_cond, null_pointer_node);
9975 9660 : return build3_v (COND_EXPR, null_cond, tmp, null_data);
9976 : }
9977 :
9978 :
9979 : /* Allocate dest to the same size as src, and copy data src -> dest. */
9980 :
9981 : tree
9982 7275 : gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank,
9983 : tree add_when_allocated)
9984 : {
9985 7275 : return duplicate_allocatable (dest, src, type, rank, false, false,
9986 7275 : NULL_TREE, add_when_allocated);
9987 : }
9988 :
9989 :
9990 : /* Copy data src -> dest. */
9991 :
9992 : tree
9993 56 : gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
9994 : {
9995 56 : return duplicate_allocatable (dest, src, type, rank, true, false,
9996 56 : NULL_TREE, NULL_TREE);
9997 : }
9998 :
9999 : /* Allocate dest to the same size as src, but don't copy anything. */
10000 :
10001 : tree
10002 1786 : gfc_duplicate_allocatable_nocopy (tree dest, tree src, tree type, int rank)
10003 : {
10004 1786 : return duplicate_allocatable (dest, src, type, rank, false, true,
10005 1786 : NULL_TREE, NULL_TREE);
10006 : }
10007 :
10008 : static tree
10009 62 : duplicate_allocatable_coarray (tree dest, tree dest_tok, tree src, tree type,
10010 : int rank, tree add_when_allocated)
10011 : {
10012 62 : tree tmp;
10013 62 : tree size;
10014 62 : tree nelems;
10015 62 : tree null_cond;
10016 62 : tree null_data;
10017 62 : stmtblock_t block, globalblock;
10018 :
10019 : /* If the source is null, set the destination to null. Then,
10020 : allocate memory to the destination. */
10021 62 : gfc_init_block (&block);
10022 62 : gfc_init_block (&globalblock);
10023 :
10024 62 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
10025 : {
10026 18 : gfc_se se;
10027 18 : symbol_attribute attr;
10028 18 : tree dummy_desc;
10029 :
10030 18 : gfc_init_se (&se, NULL);
10031 18 : gfc_clear_attr (&attr);
10032 18 : attr.allocatable = 1;
10033 18 : dummy_desc = gfc_conv_scalar_to_descriptor (&se, dest, attr);
10034 18 : gfc_add_block_to_block (&globalblock, &se.pre);
10035 18 : size = TYPE_SIZE_UNIT (TREE_TYPE (type));
10036 :
10037 18 : gfc_add_modify (&block, dest, fold_convert (type, null_pointer_node));
10038 18 : gfc_allocate_using_caf_lib (&block, dummy_desc, size,
10039 : gfc_build_addr_expr (NULL_TREE, dest_tok),
10040 : NULL_TREE, NULL_TREE, NULL_TREE,
10041 : GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
10042 18 : gfc_add_modify (&block, dest, gfc_conv_descriptor_data_get (dummy_desc));
10043 18 : null_data = gfc_finish_block (&block);
10044 :
10045 18 : gfc_init_block (&block);
10046 :
10047 18 : gfc_allocate_using_caf_lib (&block, dummy_desc,
10048 : fold_convert (size_type_node, size),
10049 : gfc_build_addr_expr (NULL_TREE, dest_tok),
10050 : NULL_TREE, NULL_TREE, NULL_TREE,
10051 : GFC_CAF_COARRAY_ALLOC);
10052 18 : gfc_add_modify (&block, dest, gfc_conv_descriptor_data_get (dummy_desc));
10053 :
10054 18 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
10055 18 : tmp = build_call_expr_loc (input_location, tmp, 3, dest, src,
10056 : fold_convert (size_type_node, size));
10057 18 : gfc_add_expr_to_block (&block, tmp);
10058 : }
10059 : else
10060 : {
10061 : /* Set the rank or unitialized memory access may be reported. */
10062 44 : tmp = gfc_conv_descriptor_rank (dest);
10063 44 : gfc_add_modify (&globalblock, tmp, build_int_cst (TREE_TYPE (tmp), rank));
10064 :
10065 44 : if (rank)
10066 44 : nelems = gfc_full_array_size (&globalblock, src, rank);
10067 : else
10068 0 : nelems = integer_one_node;
10069 :
10070 44 : tmp = fold_convert (size_type_node,
10071 : TYPE_SIZE_UNIT (gfc_get_element_type (type)));
10072 44 : size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
10073 : fold_convert (size_type_node, nelems), tmp);
10074 :
10075 44 : gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
10076 44 : gfc_allocate_using_caf_lib (&block, dest, fold_convert (size_type_node,
10077 : size),
10078 : gfc_build_addr_expr (NULL_TREE, dest_tok),
10079 : NULL_TREE, NULL_TREE, NULL_TREE,
10080 : GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
10081 44 : null_data = gfc_finish_block (&block);
10082 :
10083 44 : gfc_init_block (&block);
10084 44 : gfc_allocate_using_caf_lib (&block, dest,
10085 : fold_convert (size_type_node, size),
10086 : gfc_build_addr_expr (NULL_TREE, dest_tok),
10087 : NULL_TREE, NULL_TREE, NULL_TREE,
10088 : GFC_CAF_COARRAY_ALLOC);
10089 :
10090 44 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
10091 44 : tmp = build_call_expr_loc (input_location, tmp, 3,
10092 : gfc_conv_descriptor_data_get (dest),
10093 : gfc_conv_descriptor_data_get (src),
10094 : fold_convert (size_type_node, size));
10095 44 : gfc_add_expr_to_block (&block, tmp);
10096 : }
10097 62 : gfc_add_expr_to_block (&block, add_when_allocated);
10098 62 : tmp = gfc_finish_block (&block);
10099 :
10100 : /* Null the destination if the source is null; otherwise do
10101 : the register and copy. */
10102 62 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src)))
10103 : null_cond = src;
10104 : else
10105 44 : null_cond = gfc_conv_descriptor_data_get (src);
10106 :
10107 62 : null_cond = convert (pvoid_type_node, null_cond);
10108 62 : null_cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10109 : null_cond, null_pointer_node);
10110 62 : gfc_add_expr_to_block (&globalblock, build3_v (COND_EXPR, null_cond, tmp,
10111 : null_data));
10112 62 : return gfc_finish_block (&globalblock);
10113 : }
10114 :
10115 :
10116 : /* Helper function to abstract whether coarray processing is enabled. */
10117 :
10118 : static bool
10119 75 : caf_enabled (int caf_mode)
10120 : {
10121 75 : return (caf_mode & GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY)
10122 75 : == GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY;
10123 : }
10124 :
10125 :
10126 : /* Helper function to abstract whether coarray processing is enabled
10127 : and we are in a derived type coarray. */
10128 :
10129 : static bool
10130 10808 : caf_in_coarray (int caf_mode)
10131 : {
10132 10808 : static const int pat = GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
10133 : | GFC_STRUCTURE_CAF_MODE_IN_COARRAY;
10134 10808 : return (caf_mode & pat) == pat;
10135 : }
10136 :
10137 :
10138 : /* Helper function to abstract whether coarray is to deallocate only. */
10139 :
10140 : bool
10141 352 : gfc_caf_is_dealloc_only (int caf_mode)
10142 : {
10143 352 : return (caf_mode & GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY)
10144 352 : == GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY;
10145 : }
10146 :
10147 :
10148 : /* Recursively traverse an object of derived type, generating code to
10149 : deallocate, nullify or copy allocatable components. This is the work horse
10150 : function for the functions named in this enum. */
10151 :
10152 : enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP,
10153 : COPY_ALLOC_COMP, COPY_ONLY_ALLOC_COMP, REASSIGN_CAF_COMP,
10154 : ALLOCATE_PDT_COMP, DEALLOCATE_PDT_COMP, CHECK_PDT_DUMMY,
10155 : BCAST_ALLOC_COMP};
10156 :
10157 : static gfc_actual_arglist *pdt_param_list;
10158 : static bool generating_copy_helper;
10159 : static hash_set<gfc_symbol *> seen_derived_types;
10160 :
10161 : /* Forward declaration of structure_alloc_comps for wrapper generator. */
10162 : static tree structure_alloc_comps (gfc_symbol *, tree, tree, int, int, int,
10163 : gfc_co_subroutines_args *, bool);
10164 :
10165 : /* Generate a wrapper function that performs element-wise deep copy for
10166 : recursive allocatable array components. This wrapper is passed as a
10167 : function pointer to the runtime helper _gfortran_cfi_deep_copy_array,
10168 : allowing recursion to happen at runtime instead of compile time. */
10169 :
10170 : static tree
10171 256 : get_copy_helper_function_type (void)
10172 : {
10173 256 : static tree fn_type = NULL_TREE;
10174 256 : if (fn_type == NULL_TREE)
10175 29 : fn_type = build_function_type_list (void_type_node,
10176 : pvoid_type_node,
10177 : pvoid_type_node,
10178 : NULL_TREE);
10179 256 : return fn_type;
10180 : }
10181 :
10182 : static tree
10183 1157 : get_copy_helper_pointer_type (void)
10184 : {
10185 1157 : static tree ptr_type = NULL_TREE;
10186 1157 : if (ptr_type == NULL_TREE)
10187 29 : ptr_type = build_pointer_type (get_copy_helper_function_type ());
10188 1157 : return ptr_type;
10189 : }
10190 :
10191 : static tree
10192 227 : generate_element_copy_wrapper (gfc_symbol *der_type, tree comp_type,
10193 : int purpose, int caf_mode)
10194 : {
10195 227 : tree fndecl, fntype, result_decl;
10196 227 : tree dest_parm, src_parm, dest_typed, src_typed;
10197 227 : tree der_type_ptr;
10198 227 : stmtblock_t block;
10199 227 : tree decls;
10200 227 : tree body;
10201 :
10202 227 : fntype = get_copy_helper_function_type ();
10203 :
10204 227 : fndecl = build_decl (input_location, FUNCTION_DECL,
10205 : create_tmp_var_name ("copy_element"),
10206 : fntype);
10207 :
10208 227 : TREE_STATIC (fndecl) = 1;
10209 227 : TREE_USED (fndecl) = 1;
10210 227 : DECL_ARTIFICIAL (fndecl) = 1;
10211 227 : DECL_IGNORED_P (fndecl) = 0;
10212 227 : TREE_PUBLIC (fndecl) = 0;
10213 227 : DECL_UNINLINABLE (fndecl) = 1;
10214 227 : DECL_EXTERNAL (fndecl) = 0;
10215 227 : DECL_CONTEXT (fndecl) = NULL_TREE;
10216 227 : DECL_INITIAL (fndecl) = make_node (BLOCK);
10217 227 : BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
10218 :
10219 227 : result_decl = build_decl (input_location, RESULT_DECL, NULL_TREE,
10220 : void_type_node);
10221 227 : DECL_ARTIFICIAL (result_decl) = 1;
10222 227 : DECL_IGNORED_P (result_decl) = 1;
10223 227 : DECL_CONTEXT (result_decl) = fndecl;
10224 227 : DECL_RESULT (fndecl) = result_decl;
10225 :
10226 227 : dest_parm = build_decl (input_location, PARM_DECL,
10227 : get_identifier ("dest"), pvoid_type_node);
10228 227 : src_parm = build_decl (input_location, PARM_DECL,
10229 : get_identifier ("src"), pvoid_type_node);
10230 :
10231 227 : DECL_ARTIFICIAL (dest_parm) = 1;
10232 227 : DECL_ARTIFICIAL (src_parm) = 1;
10233 227 : DECL_ARG_TYPE (dest_parm) = pvoid_type_node;
10234 227 : DECL_ARG_TYPE (src_parm) = pvoid_type_node;
10235 227 : DECL_CONTEXT (dest_parm) = fndecl;
10236 227 : DECL_CONTEXT (src_parm) = fndecl;
10237 :
10238 227 : DECL_ARGUMENTS (fndecl) = dest_parm;
10239 227 : TREE_CHAIN (dest_parm) = src_parm;
10240 :
10241 227 : push_struct_function (fndecl);
10242 227 : cfun->function_end_locus = input_location;
10243 :
10244 227 : pushlevel ();
10245 227 : gfc_init_block (&block);
10246 :
10247 227 : bool saved_generating = generating_copy_helper;
10248 227 : generating_copy_helper = true;
10249 :
10250 : /* When generating a wrapper, we need a fresh type tracking state to
10251 : avoid inheriting the parent context's seen_derived_types, which would
10252 : cause infinite recursion when the wrapper tries to handle the same
10253 : recursive type. Save elements, clear the set, generate wrapper, then
10254 : restore elements. */
10255 227 : vec<gfc_symbol *> saved_symbols = vNULL;
10256 227 : for (hash_set<gfc_symbol *>::iterator it = seen_derived_types.begin ();
10257 973 : it != seen_derived_types.end (); ++it)
10258 373 : saved_symbols.safe_push (*it);
10259 227 : seen_derived_types.empty ();
10260 :
10261 227 : der_type_ptr = build_pointer_type (comp_type);
10262 227 : dest_typed = fold_convert (der_type_ptr, dest_parm);
10263 227 : src_typed = fold_convert (der_type_ptr, src_parm);
10264 :
10265 227 : dest_typed = build_fold_indirect_ref (dest_typed);
10266 227 : src_typed = build_fold_indirect_ref (src_typed);
10267 :
10268 227 : body = structure_alloc_comps (der_type, src_typed, dest_typed,
10269 : 0, purpose, caf_mode, NULL, false);
10270 227 : gfc_add_expr_to_block (&block, body);
10271 :
10272 : /* Restore saved symbols. */
10273 227 : seen_derived_types.empty ();
10274 600 : for (unsigned i = 0; i < saved_symbols.length (); i++)
10275 373 : seen_derived_types.add (saved_symbols[i]);
10276 227 : saved_symbols.release ();
10277 227 : generating_copy_helper = saved_generating;
10278 :
10279 227 : body = gfc_finish_block (&block);
10280 227 : decls = getdecls ();
10281 :
10282 227 : poplevel (1, 1);
10283 :
10284 454 : DECL_SAVED_TREE (fndecl)
10285 227 : = fold_build3_loc (DECL_SOURCE_LOCATION (fndecl), BIND_EXPR,
10286 227 : void_type_node, decls, body, DECL_INITIAL (fndecl));
10287 :
10288 227 : pop_cfun ();
10289 :
10290 : /* Use finalize_function with no_collect=true to skip the ggc_collect
10291 : call that add_new_function would trigger. This function is called
10292 : during tree lowering of structure_alloc_comps where caller stack
10293 : frames hold locally-computed tree nodes (COMPONENT_REFs etc.) that
10294 : are not yet attached to any GC root. A collection at this point
10295 : would free those nodes and cause segfaults. PR124235. */
10296 227 : cgraph_node::finalize_function (fndecl, true);
10297 :
10298 227 : return build1 (ADDR_EXPR, get_copy_helper_pointer_type (), fndecl);
10299 : }
10300 :
10301 : static tree
10302 21778 : structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
10303 : int rank, int purpose, int caf_mode,
10304 : gfc_co_subroutines_args *args,
10305 : bool no_finalization = false)
10306 : {
10307 21778 : gfc_component *c;
10308 21778 : gfc_loopinfo loop;
10309 21778 : stmtblock_t fnblock;
10310 21778 : stmtblock_t loopbody;
10311 21778 : stmtblock_t tmpblock;
10312 21778 : tree decl_type;
10313 21778 : tree tmp;
10314 21778 : tree comp;
10315 21778 : tree dcmp;
10316 21778 : tree nelems;
10317 21778 : tree index;
10318 21778 : tree var;
10319 21778 : tree cdecl;
10320 21778 : tree ctype;
10321 21778 : tree vref, dref;
10322 21778 : tree null_cond = NULL_TREE;
10323 21778 : tree add_when_allocated;
10324 21778 : tree dealloc_fndecl;
10325 21778 : tree caf_token;
10326 21778 : gfc_symbol *vtab;
10327 21778 : int caf_dereg_mode;
10328 21778 : symbol_attribute *attr;
10329 21778 : bool deallocate_called;
10330 :
10331 21778 : gfc_init_block (&fnblock);
10332 :
10333 21778 : decl_type = TREE_TYPE (decl);
10334 :
10335 21778 : if ((POINTER_TYPE_P (decl_type))
10336 : || (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == 0))
10337 : {
10338 1506 : decl = build_fold_indirect_ref_loc (input_location, decl);
10339 : /* Deref dest in sync with decl, but only when it is not NULL. */
10340 1506 : if (dest)
10341 110 : dest = build_fold_indirect_ref_loc (input_location, dest);
10342 :
10343 : /* Update the decl_type because it got dereferenced. */
10344 1506 : decl_type = TREE_TYPE (decl);
10345 : }
10346 :
10347 : /* If this is an array of derived types with allocatable components
10348 : build a loop and recursively call this function. */
10349 21778 : if (TREE_CODE (decl_type) == ARRAY_TYPE
10350 21778 : || (GFC_DESCRIPTOR_TYPE_P (decl_type) && rank != 0))
10351 : {
10352 3996 : tmp = gfc_conv_array_data (decl);
10353 3996 : var = build_fold_indirect_ref_loc (input_location, tmp);
10354 :
10355 : /* Get the number of elements - 1 and set the counter. */
10356 3996 : if (GFC_DESCRIPTOR_TYPE_P (decl_type))
10357 : {
10358 : /* Use the descriptor for an allocatable array. Since this
10359 : is a full array reference, we only need the descriptor
10360 : information from dimension = rank. */
10361 2756 : tmp = gfc_full_array_size (&fnblock, decl, rank);
10362 2756 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
10363 : gfc_array_index_type, tmp,
10364 : gfc_index_one_node);
10365 :
10366 2756 : null_cond = gfc_conv_descriptor_data_get (decl);
10367 2756 : null_cond = fold_build2_loc (input_location, NE_EXPR,
10368 : logical_type_node, null_cond,
10369 2756 : build_int_cst (TREE_TYPE (null_cond), 0));
10370 : }
10371 : else
10372 : {
10373 : /* Otherwise use the TYPE_DOMAIN information. */
10374 1240 : tmp = array_type_nelts_minus_one (decl_type);
10375 1240 : tmp = fold_convert (gfc_array_index_type, tmp);
10376 : }
10377 :
10378 : /* Remember that this is, in fact, the no. of elements - 1. */
10379 3996 : nelems = gfc_evaluate_now (tmp, &fnblock);
10380 3996 : index = gfc_create_var (gfc_array_index_type, "S");
10381 :
10382 : /* Build the body of the loop. */
10383 3996 : gfc_init_block (&loopbody);
10384 :
10385 3996 : vref = gfc_build_array_ref (var, index, NULL);
10386 :
10387 3996 : if (purpose == COPY_ALLOC_COMP || purpose == COPY_ONLY_ALLOC_COMP)
10388 : {
10389 969 : tmp = build_fold_indirect_ref_loc (input_location,
10390 : gfc_conv_array_data (dest));
10391 969 : dref = gfc_build_array_ref (tmp, index, NULL);
10392 969 : tmp = structure_alloc_comps (der_type, vref, dref, rank,
10393 : COPY_ALLOC_COMP, caf_mode, args,
10394 : no_finalization);
10395 : }
10396 : else
10397 3027 : tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose,
10398 : caf_mode, args, no_finalization);
10399 :
10400 3996 : gfc_add_expr_to_block (&loopbody, tmp);
10401 :
10402 : /* Build the loop and return. */
10403 3996 : gfc_init_loopinfo (&loop);
10404 3996 : loop.dimen = 1;
10405 3996 : loop.from[0] = gfc_index_zero_node;
10406 3996 : loop.loopvar[0] = index;
10407 3996 : loop.to[0] = nelems;
10408 3996 : gfc_trans_scalarizing_loops (&loop, &loopbody);
10409 3996 : gfc_add_block_to_block (&fnblock, &loop.pre);
10410 :
10411 3996 : tmp = gfc_finish_block (&fnblock);
10412 : /* When copying allocateable components, the above implements the
10413 : deep copy. Nevertheless is a deep copy only allowed, when the current
10414 : component is allocated, for which code will be generated in
10415 : gfc_duplicate_allocatable (), where the deep copy code is just added
10416 : into the if's body, by adding tmp (the deep copy code) as last
10417 : argument to gfc_duplicate_allocatable (). */
10418 3996 : if (purpose == COPY_ALLOC_COMP && caf_mode == 0
10419 3996 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
10420 716 : tmp = gfc_duplicate_allocatable (dest, decl, decl_type, rank,
10421 : tmp);
10422 3280 : else if (null_cond != NULL_TREE)
10423 2040 : tmp = build3_v (COND_EXPR, null_cond, tmp,
10424 : build_empty_stmt (input_location));
10425 :
10426 3996 : return tmp;
10427 : }
10428 :
10429 17782 : if (purpose == DEALLOCATE_ALLOC_COMP && der_type->attr.pdt_type)
10430 : {
10431 295 : tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
10432 : DEALLOCATE_PDT_COMP, 0, args,
10433 : no_finalization);
10434 295 : gfc_add_expr_to_block (&fnblock, tmp);
10435 : }
10436 17487 : else if (purpose == ALLOCATE_PDT_COMP && der_type->attr.alloc_comp)
10437 : {
10438 119 : tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
10439 : NULLIFY_ALLOC_COMP, 0, args,
10440 : no_finalization);
10441 119 : gfc_add_expr_to_block (&fnblock, tmp);
10442 : }
10443 :
10444 : /* Still having a descriptor array of rank == 0 here, indicates an
10445 : allocatable coarrays. Dereference it correctly. */
10446 17782 : if (GFC_DESCRIPTOR_TYPE_P (decl_type))
10447 : {
10448 12 : decl = build_fold_indirect_ref (gfc_conv_array_data (decl));
10449 : }
10450 : /* Otherwise, act on the components or recursively call self to
10451 : act on a chain of components. */
10452 17782 : seen_derived_types.add (der_type);
10453 51371 : for (c = der_type->components; c; c = c->next)
10454 : {
10455 33589 : bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED
10456 33589 : || c->ts.type == BT_CLASS)
10457 33589 : && c->ts.u.derived->attr.alloc_comp;
10458 33589 : bool same_type
10459 : = (c->ts.type == BT_DERIVED
10460 8294 : && seen_derived_types.contains (c->ts.u.derived))
10461 39232 : || (c->ts.type == BT_CLASS
10462 2236 : && seen_derived_types.contains (CLASS_DATA (c)->ts.u.derived));
10463 33589 : bool inside_wrapper = generating_copy_helper;
10464 :
10465 33589 : bool is_pdt_type = IS_PDT (c);
10466 :
10467 33589 : cdecl = c->backend_decl;
10468 33589 : ctype = TREE_TYPE (cdecl);
10469 :
10470 33589 : switch (purpose)
10471 : {
10472 :
10473 3 : case BCAST_ALLOC_COMP:
10474 :
10475 3 : tree ubound;
10476 3 : tree cdesc;
10477 3 : stmtblock_t derived_type_block;
10478 :
10479 3 : gfc_init_block (&tmpblock);
10480 :
10481 3 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10482 : decl, cdecl, NULL_TREE);
10483 :
10484 : /* Shortcut to get the attributes of the component. */
10485 3 : if (c->ts.type == BT_CLASS)
10486 : {
10487 0 : attr = &CLASS_DATA (c)->attr;
10488 0 : if (attr->class_pointer)
10489 0 : continue;
10490 : }
10491 : else
10492 : {
10493 3 : attr = &c->attr;
10494 3 : if (attr->pointer)
10495 0 : continue;
10496 : }
10497 :
10498 : /* Do not broadcast a caf_token. These are local to the image. */
10499 3 : if (attr->caf_token)
10500 1 : continue;
10501 :
10502 2 : add_when_allocated = NULL_TREE;
10503 2 : if (cmp_has_alloc_comps
10504 0 : && !c->attr.pointer && !c->attr.proc_pointer)
10505 : {
10506 0 : if (c->ts.type == BT_CLASS)
10507 : {
10508 0 : rank = CLASS_DATA (c)->as ? CLASS_DATA (c)->as->rank : 0;
10509 0 : add_when_allocated
10510 0 : = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
10511 : comp, NULL_TREE, rank, purpose,
10512 : caf_mode, args, no_finalization);
10513 : }
10514 : else
10515 : {
10516 0 : rank = c->as ? c->as->rank : 0;
10517 0 : add_when_allocated = structure_alloc_comps (c->ts.u.derived,
10518 : comp, NULL_TREE,
10519 : rank, purpose,
10520 : caf_mode, args,
10521 : no_finalization);
10522 : }
10523 : }
10524 :
10525 2 : gfc_init_block (&derived_type_block);
10526 2 : if (add_when_allocated)
10527 0 : gfc_add_expr_to_block (&derived_type_block, add_when_allocated);
10528 2 : tmp = gfc_finish_block (&derived_type_block);
10529 2 : gfc_add_expr_to_block (&tmpblock, tmp);
10530 :
10531 : /* Convert the component into a rank 1 descriptor type. */
10532 2 : if (attr->dimension)
10533 : {
10534 0 : tmp = gfc_get_element_type (TREE_TYPE (comp));
10535 0 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
10536 0 : ubound = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (comp));
10537 : else
10538 0 : ubound = gfc_full_array_size (&tmpblock, comp,
10539 0 : c->ts.type == BT_CLASS
10540 0 : ? CLASS_DATA (c)->as->rank
10541 0 : : c->as->rank);
10542 : }
10543 : else
10544 : {
10545 2 : tmp = TREE_TYPE (comp);
10546 2 : ubound = build_int_cst (gfc_array_index_type, 1);
10547 : }
10548 :
10549 : /* Treat strings like arrays. Or the other way around, do not
10550 : * generate an additional array layer for scalar components. */
10551 2 : if (attr->dimension || c->ts.type == BT_CHARACTER)
10552 : {
10553 0 : cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node,
10554 : &ubound, 1,
10555 : GFC_ARRAY_ALLOCATABLE, false);
10556 :
10557 0 : cdesc = gfc_create_var (cdesc, "cdesc");
10558 0 : DECL_ARTIFICIAL (cdesc) = 1;
10559 :
10560 0 : gfc_add_modify (&tmpblock, gfc_conv_descriptor_dtype (cdesc),
10561 : gfc_get_dtype_rank_type (1, tmp));
10562 0 : gfc_conv_descriptor_lbound_set (&tmpblock, cdesc,
10563 : gfc_index_zero_node,
10564 : gfc_index_one_node);
10565 0 : gfc_conv_descriptor_stride_set (&tmpblock, cdesc,
10566 : gfc_index_zero_node,
10567 : gfc_index_one_node);
10568 0 : gfc_conv_descriptor_ubound_set (&tmpblock, cdesc,
10569 : gfc_index_zero_node, ubound);
10570 : }
10571 : else
10572 : /* Prevent warning. */
10573 : cdesc = NULL_TREE;
10574 :
10575 2 : if (attr->dimension)
10576 : {
10577 0 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
10578 0 : comp = gfc_conv_descriptor_data_get (comp);
10579 : else
10580 0 : comp = gfc_build_addr_expr (NULL_TREE, comp);
10581 : }
10582 : else
10583 : {
10584 2 : gfc_se se;
10585 :
10586 2 : gfc_init_se (&se, NULL);
10587 :
10588 2 : comp = gfc_conv_scalar_to_descriptor (&se, comp,
10589 2 : c->ts.type == BT_CLASS
10590 2 : ? CLASS_DATA (c)->attr
10591 : : c->attr);
10592 2 : if (c->ts.type == BT_CHARACTER)
10593 0 : comp = gfc_build_addr_expr (NULL_TREE, comp);
10594 2 : gfc_add_block_to_block (&tmpblock, &se.pre);
10595 : }
10596 :
10597 2 : if (attr->dimension || c->ts.type == BT_CHARACTER)
10598 0 : gfc_conv_descriptor_data_set (&tmpblock, cdesc, comp);
10599 : else
10600 2 : cdesc = comp;
10601 :
10602 2 : tree fndecl;
10603 :
10604 2 : fndecl = build_call_expr_loc (input_location,
10605 : gfor_fndecl_co_broadcast, 5,
10606 : gfc_build_addr_expr (pvoid_type_node,cdesc),
10607 : args->image_index,
10608 : null_pointer_node, null_pointer_node,
10609 : null_pointer_node);
10610 :
10611 2 : gfc_add_expr_to_block (&tmpblock, fndecl);
10612 2 : gfc_add_block_to_block (&fnblock, &tmpblock);
10613 :
10614 27564 : break;
10615 :
10616 12244 : case DEALLOCATE_ALLOC_COMP:
10617 :
10618 12244 : gfc_init_block (&tmpblock);
10619 :
10620 12244 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10621 : decl, cdecl, NULL_TREE);
10622 :
10623 : /* Shortcut to get the attributes of the component. */
10624 12244 : if (c->ts.type == BT_CLASS)
10625 : {
10626 1002 : attr = &CLASS_DATA (c)->attr;
10627 1002 : if (attr->class_pointer || c->attr.proc_pointer)
10628 18 : continue;
10629 : }
10630 : else
10631 : {
10632 11242 : attr = &c->attr;
10633 11242 : if (attr->pointer || attr->proc_pointer)
10634 142 : continue;
10635 : }
10636 :
10637 12084 : if (!no_finalization && ((c->ts.type == BT_DERIVED && !c->attr.pointer)
10638 8411 : || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer)))
10639 : /* Call the finalizer, which will free the memory and nullify the
10640 : pointer of an array. */
10641 3555 : deallocate_called = gfc_add_comp_finalizer_call (&tmpblock, comp, c,
10642 3555 : caf_enabled (caf_mode))
10643 3555 : && attr->dimension;
10644 : else
10645 : deallocate_called = false;
10646 :
10647 : /* Add the _class ref for classes. */
10648 12084 : if (c->ts.type == BT_CLASS && attr->allocatable)
10649 984 : comp = gfc_class_data_get (comp);
10650 :
10651 12084 : add_when_allocated = NULL_TREE;
10652 12084 : if (cmp_has_alloc_comps
10653 2848 : && !c->attr.pointer && !c->attr.proc_pointer
10654 : && !same_type
10655 2848 : && !deallocate_called)
10656 : {
10657 : /* Add checked deallocation of the components. This code is
10658 : obviously added because the finalizer is not trusted to free
10659 : all memory. */
10660 1550 : if (c->ts.type == BT_CLASS)
10661 : {
10662 241 : rank = CLASS_DATA (c)->as ? CLASS_DATA (c)->as->rank : 0;
10663 241 : add_when_allocated
10664 241 : = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
10665 : comp, NULL_TREE, rank, purpose,
10666 : caf_mode, args, no_finalization);
10667 : }
10668 : else
10669 : {
10670 1309 : rank = c->as ? c->as->rank : 0;
10671 1309 : add_when_allocated = structure_alloc_comps (c->ts.u.derived,
10672 : comp, NULL_TREE,
10673 : rank, purpose,
10674 : caf_mode, args,
10675 : no_finalization);
10676 : }
10677 : }
10678 :
10679 8176 : if (attr->allocatable && !same_type
10680 19237 : && (!attr->codimension || caf_enabled (caf_mode)))
10681 : {
10682 : /* Handle all types of components besides components of the
10683 : same_type as the current one, because those would create an
10684 : endless loop. */
10685 51 : caf_dereg_mode = (caf_in_coarray (caf_mode)
10686 58 : && (attr->dimension || c->caf_token))
10687 7089 : || attr->codimension
10688 7224 : ? (gfc_caf_is_dealloc_only (caf_mode)
10689 : ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
10690 : : GFC_CAF_COARRAY_DEREGISTER)
10691 : : GFC_CAF_COARRAY_NOCOARRAY;
10692 :
10693 7146 : caf_token = NULL_TREE;
10694 : /* Coarray components are handled directly by
10695 : deallocate_with_status. */
10696 7146 : if (!attr->codimension
10697 7125 : && caf_dereg_mode != GFC_CAF_COARRAY_NOCOARRAY)
10698 : {
10699 57 : if (c->caf_token)
10700 19 : caf_token
10701 19 : = fold_build3_loc (input_location, COMPONENT_REF,
10702 19 : TREE_TYPE (gfc_comp_caf_token (c)),
10703 : decl, gfc_comp_caf_token (c),
10704 : NULL_TREE);
10705 38 : else if (attr->dimension && !attr->proc_pointer)
10706 38 : caf_token = gfc_conv_descriptor_token (comp);
10707 : }
10708 :
10709 7146 : tmp = gfc_deallocate_with_status (comp, NULL_TREE, NULL_TREE,
10710 : NULL_TREE, NULL_TREE, true,
10711 : NULL, caf_dereg_mode, NULL_TREE,
10712 : add_when_allocated, caf_token);
10713 :
10714 7146 : gfc_add_expr_to_block (&tmpblock, tmp);
10715 : }
10716 4938 : else if (attr->allocatable && !attr->codimension
10717 1023 : && !deallocate_called)
10718 : {
10719 : /* Case of recursive allocatable derived types. */
10720 1023 : tree is_allocated;
10721 1023 : tree ubound;
10722 1023 : tree cdesc;
10723 1023 : stmtblock_t dealloc_block;
10724 :
10725 1023 : gfc_init_block (&dealloc_block);
10726 1023 : if (add_when_allocated)
10727 0 : gfc_add_expr_to_block (&dealloc_block, add_when_allocated);
10728 :
10729 : /* Convert the component into a rank 1 descriptor type. */
10730 1023 : if (attr->dimension)
10731 : {
10732 417 : tmp = gfc_get_element_type (TREE_TYPE (comp));
10733 417 : ubound = gfc_full_array_size (&dealloc_block, comp,
10734 417 : c->ts.type == BT_CLASS
10735 0 : ? CLASS_DATA (c)->as->rank
10736 417 : : c->as->rank);
10737 : }
10738 : else
10739 : {
10740 606 : tmp = TREE_TYPE (comp);
10741 606 : ubound = build_int_cst (gfc_array_index_type, 1);
10742 : }
10743 :
10744 1023 : cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node,
10745 : &ubound, 1,
10746 : GFC_ARRAY_ALLOCATABLE, false);
10747 :
10748 1023 : cdesc = gfc_create_var (cdesc, "cdesc");
10749 1023 : DECL_ARTIFICIAL (cdesc) = 1;
10750 :
10751 1023 : gfc_add_modify (&dealloc_block, gfc_conv_descriptor_dtype (cdesc),
10752 : gfc_get_dtype_rank_type (1, tmp));
10753 1023 : gfc_conv_descriptor_lbound_set (&dealloc_block, cdesc,
10754 : gfc_index_zero_node,
10755 : gfc_index_one_node);
10756 1023 : gfc_conv_descriptor_stride_set (&dealloc_block, cdesc,
10757 : gfc_index_zero_node,
10758 : gfc_index_one_node);
10759 1023 : gfc_conv_descriptor_ubound_set (&dealloc_block, cdesc,
10760 : gfc_index_zero_node, ubound);
10761 :
10762 1023 : if (attr->dimension)
10763 417 : comp = gfc_conv_descriptor_data_get (comp);
10764 :
10765 1023 : gfc_conv_descriptor_data_set (&dealloc_block, cdesc, comp);
10766 :
10767 : /* Now call the deallocator. */
10768 1023 : vtab = gfc_find_vtab (&c->ts);
10769 1023 : if (vtab->backend_decl == NULL)
10770 47 : gfc_get_symbol_decl (vtab);
10771 1023 : tmp = gfc_build_addr_expr (NULL_TREE, vtab->backend_decl);
10772 1023 : dealloc_fndecl = gfc_vptr_deallocate_get (tmp);
10773 1023 : dealloc_fndecl = build_fold_indirect_ref_loc (input_location,
10774 : dealloc_fndecl);
10775 1023 : tmp = build_int_cst (TREE_TYPE (comp), 0);
10776 1023 : is_allocated = fold_build2_loc (input_location, NE_EXPR,
10777 : logical_type_node, tmp,
10778 : comp);
10779 1023 : cdesc = gfc_build_addr_expr (NULL_TREE, cdesc);
10780 :
10781 1023 : tmp = build_call_expr_loc (input_location,
10782 : dealloc_fndecl, 1,
10783 : cdesc);
10784 1023 : gfc_add_expr_to_block (&dealloc_block, tmp);
10785 :
10786 1023 : tmp = gfc_finish_block (&dealloc_block);
10787 :
10788 1023 : tmp = fold_build3_loc (input_location, COND_EXPR,
10789 : void_type_node, is_allocated, tmp,
10790 : build_empty_stmt (input_location));
10791 :
10792 1023 : gfc_add_expr_to_block (&tmpblock, tmp);
10793 1023 : }
10794 3915 : else if (add_when_allocated)
10795 627 : gfc_add_expr_to_block (&tmpblock, add_when_allocated);
10796 :
10797 984 : if (c->ts.type == BT_CLASS && attr->allocatable
10798 13068 : && (!attr->codimension || !caf_enabled (caf_mode)))
10799 : {
10800 : /* Finally, reset the vptr to the declared type vtable and, if
10801 : necessary reset the _len field.
10802 :
10803 : First recover the reference to the component and obtain
10804 : the vptr. */
10805 969 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10806 : decl, cdecl, NULL_TREE);
10807 969 : tmp = gfc_class_vptr_get (comp);
10808 :
10809 969 : if (UNLIMITED_POLY (c))
10810 : {
10811 : /* Both vptr and _len field should be nulled. */
10812 213 : gfc_add_modify (&tmpblock, tmp,
10813 213 : build_int_cst (TREE_TYPE (tmp), 0));
10814 213 : tmp = gfc_class_len_get (comp);
10815 213 : gfc_add_modify (&tmpblock, tmp,
10816 213 : build_int_cst (TREE_TYPE (tmp), 0));
10817 : }
10818 : else
10819 : {
10820 : /* Build the vtable address and set the vptr with it. */
10821 756 : gfc_reset_vptr (&tmpblock, nullptr, tmp, c->ts.u.derived);
10822 : }
10823 : }
10824 :
10825 : /* Now add the deallocation of this component. */
10826 12084 : gfc_add_block_to_block (&fnblock, &tmpblock);
10827 12084 : break;
10828 :
10829 5373 : case NULLIFY_ALLOC_COMP:
10830 : /* Nullify
10831 : - allocatable components (regular or in class)
10832 : - components that have allocatable components
10833 : - pointer components when in a coarray.
10834 : Skip everything else especially proc_pointers, which may come
10835 : coupled with the regular pointer attribute. */
10836 7167 : if (c->attr.proc_pointer
10837 5373 : || !(c->attr.allocatable || (c->ts.type == BT_CLASS
10838 482 : && CLASS_DATA (c)->attr.allocatable)
10839 2241 : || (cmp_has_alloc_comps
10840 364 : && ((c->ts.type == BT_DERIVED && !c->attr.pointer)
10841 18 : || (c->ts.type == BT_CLASS
10842 12 : && !CLASS_DATA (c)->attr.class_pointer)))
10843 1895 : || (caf_in_coarray (caf_mode) && c->attr.pointer)))
10844 1794 : continue;
10845 :
10846 : /* Process class components first, because they always have the
10847 : pointer-attribute set which would be caught wrong else. */
10848 3579 : if (c->ts.type == BT_CLASS
10849 469 : && (CLASS_DATA (c)->attr.allocatable
10850 0 : || CLASS_DATA (c)->attr.class_pointer))
10851 : {
10852 469 : tree class_ref;
10853 :
10854 : /* Allocatable CLASS components. */
10855 469 : class_ref = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10856 : decl, cdecl, NULL_TREE);
10857 :
10858 469 : comp = gfc_class_data_get (class_ref);
10859 469 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
10860 257 : gfc_conv_descriptor_data_set (&fnblock, comp,
10861 : null_pointer_node);
10862 : else
10863 : {
10864 212 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
10865 : void_type_node, comp,
10866 212 : build_int_cst (TREE_TYPE (comp), 0));
10867 212 : gfc_add_expr_to_block (&fnblock, tmp);
10868 : }
10869 :
10870 : /* The dynamic type of a disassociated pointer or unallocated
10871 : allocatable variable is its declared type. An unlimited
10872 : polymorphic entity has no declared type. */
10873 469 : gfc_reset_vptr (&fnblock, nullptr, class_ref, c->ts.u.derived);
10874 :
10875 469 : cmp_has_alloc_comps = false;
10876 469 : }
10877 : /* Coarrays need the component to be nulled before the api-call
10878 : is made. */
10879 3110 : else if (c->attr.pointer || c->attr.allocatable)
10880 : {
10881 2764 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10882 : decl, cdecl, NULL_TREE);
10883 2764 : if (c->attr.dimension || c->attr.codimension)
10884 1891 : gfc_conv_descriptor_data_set (&fnblock, comp,
10885 : null_pointer_node);
10886 : else
10887 873 : gfc_add_modify (&fnblock, comp,
10888 873 : build_int_cst (TREE_TYPE (comp), 0));
10889 2764 : if (gfc_deferred_strlen (c, &comp))
10890 : {
10891 317 : comp = fold_build3_loc (input_location, COMPONENT_REF,
10892 317 : TREE_TYPE (comp),
10893 : decl, comp, NULL_TREE);
10894 634 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
10895 317 : TREE_TYPE (comp), comp,
10896 317 : build_int_cst (TREE_TYPE (comp), 0));
10897 317 : gfc_add_expr_to_block (&fnblock, tmp);
10898 : }
10899 : cmp_has_alloc_comps = false;
10900 : }
10901 :
10902 3579 : if (flag_coarray == GFC_FCOARRAY_LIB && caf_in_coarray (caf_mode))
10903 : {
10904 : /* Register a component of a derived type coarray with the
10905 : coarray library. Do not register ultimate component
10906 : coarrays here. They are treated like regular coarrays and
10907 : are either allocated on all images or on none. */
10908 132 : tree token;
10909 :
10910 132 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10911 : decl, cdecl, NULL_TREE);
10912 132 : if (c->attr.dimension)
10913 : {
10914 : /* Set the dtype, because caf_register needs it. */
10915 104 : gfc_add_modify (&fnblock, gfc_conv_descriptor_dtype (comp),
10916 104 : gfc_get_dtype (TREE_TYPE (comp)));
10917 104 : tmp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10918 : decl, cdecl, NULL_TREE);
10919 104 : token = gfc_conv_descriptor_token (tmp);
10920 : }
10921 : else
10922 : {
10923 28 : gfc_se se;
10924 :
10925 28 : gfc_init_se (&se, NULL);
10926 56 : token = fold_build3_loc (input_location, COMPONENT_REF,
10927 : pvoid_type_node, decl,
10928 28 : gfc_comp_caf_token (c), NULL_TREE);
10929 28 : comp = gfc_conv_scalar_to_descriptor (&se, comp,
10930 28 : c->ts.type == BT_CLASS
10931 28 : ? CLASS_DATA (c)->attr
10932 : : c->attr);
10933 28 : gfc_add_block_to_block (&fnblock, &se.pre);
10934 : }
10935 :
10936 132 : gfc_allocate_using_caf_lib (&fnblock, comp, size_zero_node,
10937 : gfc_build_addr_expr (NULL_TREE,
10938 : token),
10939 : NULL_TREE, NULL_TREE, NULL_TREE,
10940 : GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
10941 : }
10942 :
10943 3579 : if (cmp_has_alloc_comps)
10944 : {
10945 346 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10946 : decl, cdecl, NULL_TREE);
10947 346 : rank = c->as ? c->as->rank : 0;
10948 346 : tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
10949 : rank, purpose, caf_mode, args,
10950 : no_finalization);
10951 346 : gfc_add_expr_to_block (&fnblock, tmp);
10952 : }
10953 : break;
10954 :
10955 30 : case REASSIGN_CAF_COMP:
10956 30 : if (caf_enabled (caf_mode)
10957 30 : && (c->attr.codimension
10958 23 : || (c->ts.type == BT_CLASS
10959 2 : && (CLASS_DATA (c)->attr.coarray_comp
10960 2 : || caf_in_coarray (caf_mode)))
10961 21 : || (c->ts.type == BT_DERIVED
10962 7 : && (c->ts.u.derived->attr.coarray_comp
10963 6 : || caf_in_coarray (caf_mode))))
10964 46 : && !same_type)
10965 : {
10966 14 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10967 : decl, cdecl, NULL_TREE);
10968 14 : dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10969 : dest, cdecl, NULL_TREE);
10970 :
10971 14 : if (c->attr.codimension)
10972 : {
10973 7 : if (c->ts.type == BT_CLASS)
10974 : {
10975 0 : comp = gfc_class_data_get (comp);
10976 0 : dcmp = gfc_class_data_get (dcmp);
10977 : }
10978 7 : gfc_conv_descriptor_data_set (&fnblock, dcmp,
10979 : gfc_conv_descriptor_data_get (comp));
10980 : }
10981 : else
10982 : {
10983 7 : tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
10984 : rank, purpose, caf_mode
10985 : | GFC_STRUCTURE_CAF_MODE_IN_COARRAY,
10986 : args, no_finalization);
10987 7 : gfc_add_expr_to_block (&fnblock, tmp);
10988 : }
10989 : }
10990 : break;
10991 :
10992 11475 : case COPY_ALLOC_COMP:
10993 11475 : if (c->attr.pointer || c->attr.proc_pointer)
10994 153 : continue;
10995 :
10996 : /* We need source and destination components. */
10997 11322 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl,
10998 : cdecl, NULL_TREE);
10999 11322 : dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, dest,
11000 : cdecl, NULL_TREE);
11001 11322 : dcmp = fold_convert (TREE_TYPE (comp), dcmp);
11002 :
11003 11322 : if (IS_PDT (c) && !c->attr.allocatable)
11004 : {
11005 39 : tmp = gfc_copy_alloc_comp (c->ts.u.derived, comp, dcmp,
11006 : 0, 0);
11007 39 : gfc_add_expr_to_block (&fnblock, tmp);
11008 39 : continue;
11009 : }
11010 :
11011 11283 : if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
11012 : {
11013 722 : tree ftn_tree;
11014 722 : tree size;
11015 722 : tree dst_data;
11016 722 : tree src_data;
11017 722 : tree null_data;
11018 :
11019 722 : dst_data = gfc_class_data_get (dcmp);
11020 722 : src_data = gfc_class_data_get (comp);
11021 722 : size = fold_convert (size_type_node,
11022 : gfc_class_vtab_size_get (comp));
11023 :
11024 722 : if (CLASS_DATA (c)->attr.dimension)
11025 : {
11026 696 : nelems = gfc_conv_descriptor_size (src_data,
11027 348 : CLASS_DATA (c)->as->rank);
11028 348 : size = fold_build2_loc (input_location, MULT_EXPR,
11029 : size_type_node, size,
11030 : fold_convert (size_type_node,
11031 : nelems));
11032 : }
11033 : else
11034 374 : nelems = build_int_cst (size_type_node, 1);
11035 :
11036 722 : if (CLASS_DATA (c)->attr.dimension
11037 374 : || CLASS_DATA (c)->attr.codimension)
11038 : {
11039 356 : src_data = gfc_conv_descriptor_data_get (src_data);
11040 356 : dst_data = gfc_conv_descriptor_data_get (dst_data);
11041 : }
11042 :
11043 722 : gfc_init_block (&tmpblock);
11044 :
11045 722 : gfc_add_modify (&tmpblock, gfc_class_vptr_get (dcmp),
11046 : gfc_class_vptr_get (comp));
11047 :
11048 : /* Copy the unlimited '_len' field. If it is greater than zero
11049 : (ie. a character(_len)), multiply it by size and use this
11050 : for the malloc call. */
11051 722 : if (UNLIMITED_POLY (c))
11052 : {
11053 136 : gfc_add_modify (&tmpblock, gfc_class_len_get (dcmp),
11054 : gfc_class_len_get (comp));
11055 136 : size = gfc_resize_class_size_with_len (&tmpblock, comp, size);
11056 : }
11057 :
11058 : /* Coarray component have to have the same allocation status and
11059 : shape/type-parameter/effective-type on the LHS and RHS of an
11060 : intrinsic assignment. Hence, we did not deallocated them - and
11061 : do not allocate them here. */
11062 722 : if (!CLASS_DATA (c)->attr.codimension)
11063 : {
11064 707 : ftn_tree = builtin_decl_explicit (BUILT_IN_MALLOC);
11065 707 : tmp = build_call_expr_loc (input_location, ftn_tree, 1, size);
11066 707 : gfc_add_modify (&tmpblock, dst_data,
11067 707 : fold_convert (TREE_TYPE (dst_data), tmp));
11068 : }
11069 :
11070 1429 : tmp = gfc_copy_class_to_class (comp, dcmp, nelems,
11071 722 : UNLIMITED_POLY (c));
11072 722 : gfc_add_expr_to_block (&tmpblock, tmp);
11073 722 : tmp = gfc_finish_block (&tmpblock);
11074 :
11075 722 : gfc_init_block (&tmpblock);
11076 722 : gfc_add_modify (&tmpblock, dst_data,
11077 722 : fold_convert (TREE_TYPE (dst_data),
11078 : null_pointer_node));
11079 722 : null_data = gfc_finish_block (&tmpblock);
11080 :
11081 722 : null_cond = fold_build2_loc (input_location, NE_EXPR,
11082 : logical_type_node, src_data,
11083 : null_pointer_node);
11084 :
11085 722 : gfc_add_expr_to_block (&fnblock, build3_v (COND_EXPR, null_cond,
11086 : tmp, null_data));
11087 722 : continue;
11088 722 : }
11089 :
11090 : /* To implement guarded deep copy, i.e., deep copy only allocatable
11091 : components that are really allocated, the deep copy code has to
11092 : be generated first and then added to the if-block in
11093 : gfc_duplicate_allocatable (). */
11094 10561 : if (cmp_has_alloc_comps && !c->attr.proc_pointer && !same_type)
11095 : {
11096 1673 : rank = c->as ? c->as->rank : 0;
11097 1673 : tmp = fold_convert (TREE_TYPE (dcmp), comp);
11098 1673 : gfc_add_modify (&fnblock, dcmp, tmp);
11099 1673 : add_when_allocated = structure_alloc_comps (c->ts.u.derived,
11100 : comp, dcmp,
11101 : rank, purpose,
11102 : caf_mode, args,
11103 : no_finalization);
11104 : }
11105 : else
11106 : add_when_allocated = NULL_TREE;
11107 :
11108 10561 : if (gfc_deferred_strlen (c, &tmp))
11109 : {
11110 386 : tree len, size;
11111 386 : len = tmp;
11112 386 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
11113 386 : TREE_TYPE (len),
11114 : decl, len, NULL_TREE);
11115 386 : len = fold_build3_loc (input_location, COMPONENT_REF,
11116 386 : TREE_TYPE (len),
11117 : dest, len, NULL_TREE);
11118 386 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
11119 386 : TREE_TYPE (len), len, tmp);
11120 386 : gfc_add_expr_to_block (&fnblock, tmp);
11121 386 : size = size_of_string_in_bytes (c->ts.kind, len);
11122 : /* This component cannot have allocatable components,
11123 : therefore add_when_allocated of duplicate_allocatable ()
11124 : is always NULL. */
11125 386 : rank = c->as ? c->as->rank : 0;
11126 386 : tmp = duplicate_allocatable (dcmp, comp, ctype, rank,
11127 : false, false, size, NULL_TREE);
11128 386 : gfc_add_expr_to_block (&fnblock, tmp);
11129 : }
11130 10175 : else if (c->attr.pdt_array
11131 157 : && !c->attr.allocatable && !c->attr.pointer)
11132 : {
11133 157 : tmp = duplicate_allocatable (dcmp, comp, ctype,
11134 157 : c->as ? c->as->rank : 0,
11135 : false, false, NULL_TREE, NULL_TREE);
11136 157 : gfc_add_expr_to_block (&fnblock, tmp);
11137 : }
11138 : /* Special case: recursive allocatable array components require
11139 : runtime helpers to avoid compile-time infinite recursion. Generate
11140 : a call to _gfortran_cfi_deep_copy_array with an element copy
11141 : wrapper. When inside a wrapper, reuse current_function_decl. */
11142 6120 : else if (c->attr.allocatable && c->as && cmp_has_alloc_comps && same_type
11143 930 : && purpose == COPY_ALLOC_COMP && !c->attr.proc_pointer
11144 930 : && !c->attr.codimension && !caf_in_coarray (caf_mode)
11145 10948 : && c->ts.type == BT_DERIVED && c->ts.u.derived != NULL)
11146 : {
11147 930 : tree copy_wrapper, call, dest_addr, src_addr, elem_type;
11148 930 : tree helper_ptr_type;
11149 930 : tree alloc_expr;
11150 930 : int comp_rank;
11151 :
11152 : /* Get the element type from ctype (already the component
11153 : type). For arrays we need the element type, not the array
11154 : type. */
11155 930 : elem_type = ctype;
11156 930 : if (GFC_DESCRIPTOR_TYPE_P (ctype))
11157 930 : elem_type = gfc_get_element_type (ctype);
11158 0 : else if (TREE_CODE (ctype) == ARRAY_TYPE)
11159 0 : elem_type = TREE_TYPE (ctype);
11160 :
11161 930 : helper_ptr_type = get_copy_helper_pointer_type ();
11162 :
11163 930 : comp_rank = c->as ? c->as->rank : 0;
11164 930 : alloc_expr = gfc_duplicate_allocatable_nocopy (dcmp, comp, ctype,
11165 : comp_rank);
11166 930 : gfc_add_expr_to_block (&fnblock, alloc_expr);
11167 :
11168 : /* Generate or reuse the element copy helper. Inside an
11169 : existing helper we can reuse the current function to
11170 : prevent recursive generation. */
11171 930 : if (inside_wrapper)
11172 703 : copy_wrapper
11173 703 : = gfc_build_addr_expr (NULL_TREE, current_function_decl);
11174 : else
11175 227 : copy_wrapper
11176 227 : = generate_element_copy_wrapper (c->ts.u.derived, elem_type,
11177 : purpose, caf_mode);
11178 930 : copy_wrapper = fold_convert (helper_ptr_type, copy_wrapper);
11179 :
11180 : /* Build addresses of descriptors. */
11181 930 : dest_addr = gfc_build_addr_expr (pvoid_type_node, dcmp);
11182 930 : src_addr = gfc_build_addr_expr (pvoid_type_node, comp);
11183 :
11184 : /* Build call: _gfortran_cfi_deep_copy_array (&dcmp, &comp,
11185 : wrapper). */
11186 930 : call = build_call_expr_loc (input_location,
11187 : gfor_fndecl_cfi_deep_copy_array, 3,
11188 : dest_addr, src_addr,
11189 : copy_wrapper);
11190 930 : gfc_add_expr_to_block (&fnblock, call);
11191 : }
11192 : /* For allocatable arrays with nested allocatable components,
11193 : add_when_allocated already includes gfc_duplicate_allocatable
11194 : (from the recursive structure_alloc_comps call at line 10290-10293),
11195 : so we must not call it again here. PR121628 added an
11196 : add_when_allocated != NULL clause that was redundant for scalars
11197 : (already handled by !c->as) and wrong for arrays (double alloc). */
11198 5190 : else if (c->attr.allocatable && !c->attr.proc_pointer
11199 14278 : && (!cmp_has_alloc_comps
11200 804 : || !c->as
11201 579 : || c->attr.codimension
11202 576 : || caf_in_coarray (caf_mode)))
11203 : {
11204 4620 : rank = c->as ? c->as->rank : 0;
11205 4620 : if (c->attr.codimension)
11206 20 : tmp = gfc_copy_allocatable_data (dcmp, comp, ctype, rank);
11207 4600 : else if (flag_coarray == GFC_FCOARRAY_LIB
11208 4600 : && caf_in_coarray (caf_mode))
11209 : {
11210 62 : tree dst_tok;
11211 62 : if (c->as)
11212 44 : dst_tok = gfc_conv_descriptor_token (dcmp);
11213 : else
11214 : {
11215 18 : dst_tok
11216 18 : = fold_build3_loc (input_location, COMPONENT_REF,
11217 : pvoid_type_node, dest,
11218 18 : gfc_comp_caf_token (c), NULL_TREE);
11219 : }
11220 62 : tmp
11221 62 : = duplicate_allocatable_coarray (dcmp, dst_tok, comp, ctype,
11222 : rank, add_when_allocated);
11223 : }
11224 : else
11225 4538 : tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank,
11226 : add_when_allocated);
11227 4620 : gfc_add_expr_to_block (&fnblock, tmp);
11228 : }
11229 : else
11230 4468 : if (cmp_has_alloc_comps || is_pdt_type)
11231 1714 : gfc_add_expr_to_block (&fnblock, add_when_allocated);
11232 :
11233 : break;
11234 :
11235 1883 : case ALLOCATE_PDT_COMP:
11236 :
11237 1883 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
11238 : decl, cdecl, NULL_TREE);
11239 :
11240 : /* Set the PDT KIND and LEN fields. */
11241 1883 : if (c->attr.pdt_kind || c->attr.pdt_len)
11242 : {
11243 857 : gfc_se tse;
11244 857 : gfc_expr *c_expr = NULL;
11245 857 : gfc_actual_arglist *param = pdt_param_list;
11246 857 : gfc_init_se (&tse, NULL);
11247 3109 : for (; param; param = param->next)
11248 1395 : if (param->name && !strcmp (c->name, param->name))
11249 851 : c_expr = param->expr;
11250 :
11251 857 : if (!c_expr)
11252 24 : c_expr = c->initializer;
11253 :
11254 24 : if (c_expr)
11255 : {
11256 839 : gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp));
11257 839 : gfc_add_block_to_block (&fnblock, &tse.pre);
11258 839 : gfc_add_modify (&fnblock, comp, tse.expr);
11259 839 : gfc_add_block_to_block (&fnblock, &tse.post);
11260 : }
11261 857 : }
11262 1026 : else if (c->initializer && !c->attr.pdt_string && !c->attr.pdt_array
11263 139 : && !c->as && !IS_PDT (c)) /* Take care of arrays. */
11264 : {
11265 49 : gfc_se tse;
11266 49 : gfc_expr *c_expr;
11267 49 : gfc_init_se (&tse, NULL);
11268 49 : c_expr = c->initializer;
11269 49 : gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp));
11270 49 : gfc_add_block_to_block (&fnblock, &tse.pre);
11271 49 : gfc_add_modify (&fnblock, comp, tse.expr);
11272 49 : gfc_add_block_to_block (&fnblock, &tse.post);
11273 : }
11274 :
11275 1883 : if (c->attr.pdt_string)
11276 : {
11277 90 : gfc_se tse;
11278 90 : gfc_init_se (&tse, NULL);
11279 90 : tree strlen = NULL_TREE;
11280 90 : gfc_expr *e = gfc_copy_expr (c->ts.u.cl->length);
11281 : /* Convert the parameterized string length to its value. The
11282 : string length is stored in a hidden field in the same way as
11283 : deferred string lengths. */
11284 90 : gfc_insert_parameter_exprs (e, pdt_param_list);
11285 90 : if (gfc_deferred_strlen (c, &strlen) && strlen != NULL_TREE)
11286 : {
11287 90 : gfc_conv_expr_type (&tse, e,
11288 90 : TREE_TYPE (strlen));
11289 90 : strlen = fold_build3_loc (input_location, COMPONENT_REF,
11290 90 : TREE_TYPE (strlen),
11291 : decl, strlen, NULL_TREE);
11292 90 : gfc_add_block_to_block (&fnblock, &tse.pre);
11293 90 : gfc_add_modify (&fnblock, strlen, tse.expr);
11294 90 : gfc_add_block_to_block (&fnblock, &tse.post);
11295 90 : c->ts.u.cl->backend_decl = strlen;
11296 : }
11297 90 : gfc_free_expr (e);
11298 :
11299 : /* Scalar parameterized strings can be allocated now. */
11300 90 : if (!c->as)
11301 : {
11302 90 : tmp = fold_convert (gfc_array_index_type, strlen);
11303 90 : tmp = size_of_string_in_bytes (c->ts.kind, tmp);
11304 90 : tmp = gfc_evaluate_now (tmp, &fnblock);
11305 90 : tmp = gfc_call_malloc (&fnblock, TREE_TYPE (comp), tmp);
11306 90 : gfc_add_modify (&fnblock, comp, tmp);
11307 : }
11308 : }
11309 :
11310 : /* Allocate parameterized arrays of parameterized derived types. */
11311 1883 : if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT)
11312 1614 : && !(IS_PDT (c) || IS_CLASS_PDT (c)))
11313 1429 : continue;
11314 :
11315 454 : if (c->ts.type == BT_CLASS)
11316 0 : comp = gfc_class_data_get (comp);
11317 :
11318 454 : if (c->attr.pdt_array)
11319 : {
11320 269 : gfc_se tse;
11321 269 : int i;
11322 269 : tree size = gfc_index_one_node;
11323 269 : tree offset = gfc_index_zero_node;
11324 269 : tree lower, upper;
11325 269 : gfc_expr *e;
11326 :
11327 : /* This chunk takes the expressions for 'lower' and 'upper'
11328 : in the arrayspec and substitutes in the expressions for
11329 : the parameters from 'pdt_param_list'. The descriptor
11330 : fields can then be filled from the values so obtained. */
11331 269 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)));
11332 646 : for (i = 0; i < c->as->rank; i++)
11333 : {
11334 377 : gfc_init_se (&tse, NULL);
11335 377 : e = gfc_copy_expr (c->as->lower[i]);
11336 377 : gfc_insert_parameter_exprs (e, pdt_param_list);
11337 377 : gfc_conv_expr_type (&tse, e, gfc_array_index_type);
11338 377 : gfc_free_expr (e);
11339 377 : lower = tse.expr;
11340 377 : gfc_add_block_to_block (&fnblock, &tse.pre);
11341 377 : gfc_conv_descriptor_lbound_set (&fnblock, comp,
11342 : gfc_rank_cst[i],
11343 : lower);
11344 377 : gfc_add_block_to_block (&fnblock, &tse.post);
11345 377 : e = gfc_copy_expr (c->as->upper[i]);
11346 377 : gfc_insert_parameter_exprs (e, pdt_param_list);
11347 377 : gfc_conv_expr_type (&tse, e, gfc_array_index_type);
11348 377 : gfc_free_expr (e);
11349 377 : upper = tse.expr;
11350 377 : gfc_add_block_to_block (&fnblock, &tse.pre);
11351 377 : gfc_conv_descriptor_ubound_set (&fnblock, comp,
11352 : gfc_rank_cst[i],
11353 : upper);
11354 377 : gfc_add_block_to_block (&fnblock, &tse.post);
11355 377 : gfc_conv_descriptor_stride_set (&fnblock, comp,
11356 : gfc_rank_cst[i],
11357 : size);
11358 377 : size = gfc_evaluate_now (size, &fnblock);
11359 377 : offset = fold_build2_loc (input_location,
11360 : MINUS_EXPR,
11361 : gfc_array_index_type,
11362 : offset, size);
11363 377 : offset = gfc_evaluate_now (offset, &fnblock);
11364 377 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
11365 : gfc_array_index_type,
11366 : upper, lower);
11367 377 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
11368 : gfc_array_index_type,
11369 : tmp, gfc_index_one_node);
11370 377 : size = fold_build2_loc (input_location, MULT_EXPR,
11371 : gfc_array_index_type, size, tmp);
11372 : }
11373 269 : gfc_conv_descriptor_offset_set (&fnblock, comp, offset);
11374 269 : if (c->ts.type == BT_CLASS)
11375 : {
11376 0 : tmp = gfc_get_vptr_from_expr (comp);
11377 0 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
11378 0 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
11379 0 : tmp = gfc_vptr_size_get (tmp);
11380 : }
11381 : else
11382 269 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (ctype));
11383 269 : tmp = fold_convert (gfc_array_index_type, tmp);
11384 269 : size = fold_build2_loc (input_location, MULT_EXPR,
11385 : gfc_array_index_type, size, tmp);
11386 269 : size = gfc_evaluate_now (size, &fnblock);
11387 269 : tmp = gfc_call_malloc (&fnblock, NULL, size);
11388 269 : gfc_conv_descriptor_data_set (&fnblock, comp, tmp);
11389 269 : tmp = gfc_conv_descriptor_dtype (comp);
11390 269 : gfc_add_modify (&fnblock, tmp, gfc_get_dtype (ctype));
11391 :
11392 269 : if (c->initializer && c->initializer->rank)
11393 : {
11394 0 : gfc_init_se (&tse, NULL);
11395 0 : e = gfc_copy_expr (c->initializer);
11396 0 : gfc_insert_parameter_exprs (e, pdt_param_list);
11397 0 : gfc_conv_expr_descriptor (&tse, e);
11398 0 : gfc_add_block_to_block (&fnblock, &tse.pre);
11399 0 : gfc_free_expr (e);
11400 0 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
11401 0 : tmp = build_call_expr_loc (input_location, tmp, 3,
11402 : gfc_conv_descriptor_data_get (comp),
11403 : gfc_conv_descriptor_data_get (tse.expr),
11404 : fold_convert (size_type_node, size));
11405 0 : gfc_add_expr_to_block (&fnblock, tmp);
11406 0 : gfc_add_block_to_block (&fnblock, &tse.post);
11407 : }
11408 : }
11409 :
11410 : /* Recurse in to PDT components. */
11411 454 : if ((IS_PDT (c) || IS_CLASS_PDT (c))
11412 199 : && !(c->attr.pointer || c->attr.allocatable))
11413 : {
11414 104 : gfc_actual_arglist *tail = c->param_list;
11415 :
11416 262 : for (; tail; tail = tail->next)
11417 158 : if (tail->expr)
11418 134 : gfc_insert_parameter_exprs (tail->expr, pdt_param_list);
11419 :
11420 104 : tmp = gfc_allocate_pdt_comp (c->ts.u.derived, comp,
11421 104 : c->as ? c->as->rank : 0,
11422 104 : c->param_list);
11423 104 : gfc_add_expr_to_block (&fnblock, tmp);
11424 : }
11425 :
11426 : break;
11427 :
11428 2257 : case DEALLOCATE_PDT_COMP:
11429 : /* Deallocate array or parameterized string length components
11430 : of parameterized derived types. */
11431 2257 : if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT)
11432 1793 : && !c->attr.pdt_string
11433 1685 : && !(IS_PDT (c) || IS_CLASS_PDT (c)))
11434 1453 : continue;
11435 :
11436 804 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
11437 : decl, cdecl, NULL_TREE);
11438 804 : if (c->ts.type == BT_CLASS)
11439 0 : comp = gfc_class_data_get (comp);
11440 :
11441 : /* Recurse in to PDT components. */
11442 804 : if ((IS_PDT (c) || IS_CLASS_PDT (c))
11443 270 : && (!c->attr.pointer && !c->attr.allocatable))
11444 : {
11445 104 : tmp = gfc_deallocate_pdt_comp (c->ts.u.derived, comp,
11446 104 : c->as ? c->as->rank : 0);
11447 104 : gfc_add_expr_to_block (&fnblock, tmp);
11448 : }
11449 :
11450 804 : if (c->attr.pdt_array || c->attr.pdt_string)
11451 : {
11452 572 : tmp = comp;
11453 572 : if (c->attr.pdt_array)
11454 464 : tmp = gfc_conv_descriptor_data_get (comp);
11455 572 : null_cond = fold_build2_loc (input_location, NE_EXPR,
11456 : logical_type_node, tmp,
11457 572 : build_int_cst (TREE_TYPE (tmp), 0));
11458 572 : if (flag_openmp_allocators)
11459 : {
11460 0 : tree cd, t;
11461 0 : if (c->attr.pdt_array)
11462 0 : cd = fold_build2_loc (input_location, EQ_EXPR,
11463 : boolean_type_node,
11464 : gfc_conv_descriptor_version (comp),
11465 : build_int_cst (integer_type_node, 1));
11466 : else
11467 0 : cd = gfc_omp_call_is_alloc (tmp);
11468 0 : t = builtin_decl_explicit (BUILT_IN_GOMP_FREE);
11469 0 : t = build_call_expr_loc (input_location, t, 1, tmp);
11470 :
11471 0 : stmtblock_t tblock;
11472 0 : gfc_init_block (&tblock);
11473 0 : gfc_add_expr_to_block (&tblock, t);
11474 0 : if (c->attr.pdt_array)
11475 0 : gfc_add_modify (&tblock, gfc_conv_descriptor_version (comp),
11476 : integer_zero_node);
11477 0 : tmp = build3_loc (input_location, COND_EXPR, void_type_node,
11478 : cd, gfc_finish_block (&tblock),
11479 : gfc_call_free (tmp));
11480 : }
11481 : else
11482 572 : tmp = gfc_call_free (tmp);
11483 572 : tmp = build3_v (COND_EXPR, null_cond, tmp,
11484 : build_empty_stmt (input_location));
11485 572 : gfc_add_expr_to_block (&fnblock, tmp);
11486 :
11487 572 : if (c->attr.pdt_array)
11488 464 : gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
11489 : else
11490 : {
11491 108 : tmp = fold_convert (TREE_TYPE (comp), null_pointer_node);
11492 108 : gfc_add_modify (&fnblock, comp, tmp);
11493 : }
11494 : }
11495 :
11496 : break;
11497 :
11498 324 : case CHECK_PDT_DUMMY:
11499 :
11500 324 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
11501 : decl, cdecl, NULL_TREE);
11502 324 : if (c->ts.type == BT_CLASS)
11503 0 : comp = gfc_class_data_get (comp);
11504 :
11505 : /* Recurse in to PDT components. */
11506 324 : if (((c->ts.type == BT_DERIVED
11507 14 : && !c->attr.allocatable && !c->attr.pointer)
11508 312 : || (c->ts.type == BT_CLASS
11509 0 : && !CLASS_DATA (c)->attr.allocatable
11510 0 : && !CLASS_DATA (c)->attr.pointer))
11511 12 : && c->ts.u.derived && c->ts.u.derived->attr.pdt_type)
11512 : {
11513 12 : tmp = gfc_check_pdt_dummy (c->ts.u.derived, comp,
11514 12 : c->as ? c->as->rank : 0,
11515 : pdt_param_list);
11516 12 : gfc_add_expr_to_block (&fnblock, tmp);
11517 : }
11518 :
11519 324 : if (!c->attr.pdt_len)
11520 276 : continue;
11521 : else
11522 : {
11523 48 : gfc_se tse;
11524 48 : gfc_expr *c_expr = NULL;
11525 48 : gfc_actual_arglist *param = pdt_param_list;
11526 :
11527 48 : gfc_init_se (&tse, NULL);
11528 186 : for (; param; param = param->next)
11529 90 : if (!strcmp (c->name, param->name)
11530 48 : && param->spec_type == SPEC_EXPLICIT)
11531 30 : c_expr = param->expr;
11532 :
11533 48 : if (c_expr)
11534 : {
11535 30 : tree error, cond, cname;
11536 30 : gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp));
11537 30 : cond = fold_build2_loc (input_location, NE_EXPR,
11538 : logical_type_node,
11539 : comp, tse.expr);
11540 30 : cname = gfc_build_cstring_const (c->name);
11541 30 : cname = gfc_build_addr_expr (pchar_type_node, cname);
11542 30 : error = gfc_trans_runtime_error (true, NULL,
11543 : "The value of the PDT LEN "
11544 : "parameter '%s' does not "
11545 : "agree with that in the "
11546 : "dummy declaration",
11547 : cname);
11548 30 : tmp = fold_build3_loc (input_location, COND_EXPR,
11549 : void_type_node, cond, error,
11550 : build_empty_stmt (input_location));
11551 30 : gfc_add_expr_to_block (&fnblock, tmp);
11552 : }
11553 : }
11554 48 : break;
11555 :
11556 0 : default:
11557 0 : gcc_unreachable ();
11558 6027 : break;
11559 : }
11560 : }
11561 17782 : seen_derived_types.remove (der_type);
11562 :
11563 17782 : return gfc_finish_block (&fnblock);
11564 : }
11565 :
11566 : /* Recursively traverse an object of derived type, generating code to
11567 : nullify allocatable components. */
11568 :
11569 : tree
11570 2926 : gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
11571 : int caf_mode)
11572 : {
11573 2926 : return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11574 : NULLIFY_ALLOC_COMP,
11575 : GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode,
11576 2926 : NULL);
11577 : }
11578 :
11579 :
11580 : /* Recursively traverse an object of derived type, generating code to
11581 : deallocate allocatable components. */
11582 :
11583 : tree
11584 2908 : gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
11585 : int caf_mode, bool no_finalization)
11586 : {
11587 2908 : return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11588 : DEALLOCATE_ALLOC_COMP,
11589 : GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode,
11590 2908 : NULL, no_finalization);
11591 : }
11592 :
11593 : tree
11594 1 : gfc_bcast_alloc_comp (gfc_symbol *derived, gfc_expr *expr, int rank,
11595 : tree image_index, tree stat, tree errmsg,
11596 : tree errmsg_len)
11597 : {
11598 1 : tree tmp, array;
11599 1 : gfc_se argse;
11600 1 : stmtblock_t block, post_block;
11601 1 : gfc_co_subroutines_args args;
11602 :
11603 1 : args.image_index = image_index;
11604 1 : args.stat = stat;
11605 1 : args.errmsg = errmsg;
11606 1 : args.errmsg_len = errmsg_len;
11607 :
11608 1 : if (rank == 0)
11609 : {
11610 1 : gfc_start_block (&block);
11611 1 : gfc_init_block (&post_block);
11612 1 : gfc_init_se (&argse, NULL);
11613 1 : gfc_conv_expr (&argse, expr);
11614 1 : gfc_add_block_to_block (&block, &argse.pre);
11615 1 : gfc_add_block_to_block (&post_block, &argse.post);
11616 1 : array = argse.expr;
11617 : }
11618 : else
11619 : {
11620 0 : gfc_init_se (&argse, NULL);
11621 0 : argse.want_pointer = 1;
11622 0 : gfc_conv_expr_descriptor (&argse, expr);
11623 0 : array = argse.expr;
11624 : }
11625 :
11626 1 : tmp = structure_alloc_comps (derived, array, NULL_TREE, rank,
11627 : BCAST_ALLOC_COMP,
11628 : GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY,
11629 : &args);
11630 1 : return tmp;
11631 : }
11632 :
11633 : /* Recursively traverse an object of derived type, generating code to
11634 : deallocate allocatable components. But do not deallocate coarrays.
11635 : To be used for intrinsic assignment, which may not change the allocation
11636 : status of coarrays. */
11637 :
11638 : tree
11639 2211 : gfc_deallocate_alloc_comp_no_caf (gfc_symbol * der_type, tree decl, int rank,
11640 : bool no_finalization)
11641 : {
11642 2211 : return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11643 : DEALLOCATE_ALLOC_COMP, 0, NULL,
11644 2211 : no_finalization);
11645 : }
11646 :
11647 :
11648 : tree
11649 5 : gfc_reassign_alloc_comp_caf (gfc_symbol *der_type, tree decl, tree dest)
11650 : {
11651 5 : return structure_alloc_comps (der_type, decl, dest, 0, REASSIGN_CAF_COMP,
11652 : GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY,
11653 5 : NULL);
11654 : }
11655 :
11656 :
11657 : /* Recursively traverse an object of derived type, generating code to
11658 : copy it and its allocatable components. */
11659 :
11660 : tree
11661 4219 : gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank,
11662 : int caf_mode)
11663 : {
11664 4219 : return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP,
11665 4219 : caf_mode, NULL);
11666 : }
11667 :
11668 :
11669 : /* Recursively traverse an object of derived type, generating code to
11670 : copy it and its allocatable components, while suppressing any
11671 : finalization that might occur. This is used in the finalization of
11672 : function results. */
11673 :
11674 : tree
11675 38 : gfc_copy_alloc_comp_no_fini (gfc_symbol * der_type, tree decl, tree dest,
11676 : int rank, int caf_mode)
11677 : {
11678 38 : return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP,
11679 38 : caf_mode, NULL, true);
11680 : }
11681 :
11682 :
11683 : /* Recursively traverse an object of derived type, generating code to
11684 : copy only its allocatable components. */
11685 :
11686 : tree
11687 0 : gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
11688 : {
11689 0 : return structure_alloc_comps (der_type, decl, dest, rank,
11690 0 : COPY_ONLY_ALLOC_COMP, 0, NULL);
11691 : }
11692 :
11693 :
11694 : /* Recursively traverse an object of parameterized derived type, generating
11695 : code to allocate parameterized components. */
11696 :
11697 : tree
11698 673 : gfc_allocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank,
11699 : gfc_actual_arglist *param_list)
11700 : {
11701 673 : tree res;
11702 673 : gfc_actual_arglist *old_param_list = pdt_param_list;
11703 673 : pdt_param_list = param_list;
11704 673 : res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11705 : ALLOCATE_PDT_COMP, 0, NULL);
11706 673 : pdt_param_list = old_param_list;
11707 673 : return res;
11708 : }
11709 :
11710 : /* Recursively traverse an object of parameterized derived type, generating
11711 : code to deallocate parameterized components. */
11712 :
11713 : tree
11714 1000 : gfc_deallocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank)
11715 : {
11716 : /* A type without parameterized components causes gimplifier problems. */
11717 1000 : if (!has_parameterized_comps (der_type))
11718 : return NULL_TREE;
11719 :
11720 510 : return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11721 510 : DEALLOCATE_PDT_COMP, 0, NULL);
11722 : }
11723 :
11724 :
11725 : /* Recursively traverse a dummy of parameterized derived type to check the
11726 : values of LEN parameters. */
11727 :
11728 : tree
11729 74 : gfc_check_pdt_dummy (gfc_symbol * der_type, tree decl, int rank,
11730 : gfc_actual_arglist *param_list)
11731 : {
11732 74 : tree res;
11733 74 : gfc_actual_arglist *old_param_list = pdt_param_list;
11734 74 : pdt_param_list = param_list;
11735 74 : res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11736 : CHECK_PDT_DUMMY, 0, NULL);
11737 74 : pdt_param_list = old_param_list;
11738 74 : return res;
11739 : }
11740 :
11741 :
11742 : /* Returns the value of LBOUND for an expression. This could be broken out
11743 : from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
11744 : called by gfc_alloc_allocatable_for_assignment. */
11745 : static tree
11746 1024 : get_std_lbound (gfc_expr *expr, tree desc, int dim, bool assumed_size)
11747 : {
11748 1024 : tree lbound;
11749 1024 : tree ubound;
11750 1024 : tree stride;
11751 1024 : tree cond, cond1, cond3, cond4;
11752 1024 : tree tmp;
11753 1024 : gfc_ref *ref;
11754 :
11755 1024 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
11756 : {
11757 502 : tmp = gfc_rank_cst[dim];
11758 502 : lbound = gfc_conv_descriptor_lbound_get (desc, tmp);
11759 502 : ubound = gfc_conv_descriptor_ubound_get (desc, tmp);
11760 502 : stride = gfc_conv_descriptor_stride_get (desc, tmp);
11761 502 : cond1 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
11762 : ubound, lbound);
11763 502 : cond3 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
11764 : stride, gfc_index_zero_node);
11765 502 : cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
11766 : logical_type_node, cond3, cond1);
11767 502 : cond4 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
11768 : stride, gfc_index_zero_node);
11769 502 : if (assumed_size)
11770 0 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
11771 : tmp, build_int_cst (gfc_array_index_type,
11772 0 : expr->rank - 1));
11773 : else
11774 502 : cond = logical_false_node;
11775 :
11776 502 : cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
11777 : logical_type_node, cond3, cond4);
11778 502 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
11779 : logical_type_node, cond, cond1);
11780 :
11781 502 : return fold_build3_loc (input_location, COND_EXPR,
11782 : gfc_array_index_type, cond,
11783 502 : lbound, gfc_index_one_node);
11784 : }
11785 :
11786 522 : if (expr->expr_type == EXPR_FUNCTION)
11787 : {
11788 : /* A conversion function, so use the argument. */
11789 7 : gcc_assert (expr->value.function.isym
11790 : && expr->value.function.isym->conversion);
11791 7 : expr = expr->value.function.actual->expr;
11792 : }
11793 :
11794 522 : if (expr->expr_type == EXPR_VARIABLE)
11795 : {
11796 522 : tmp = TREE_TYPE (expr->symtree->n.sym->backend_decl);
11797 1370 : for (ref = expr->ref; ref; ref = ref->next)
11798 : {
11799 848 : if (ref->type == REF_COMPONENT
11800 277 : && ref->u.c.component->as
11801 228 : && ref->next
11802 228 : && ref->next->u.ar.type == AR_FULL)
11803 186 : tmp = TREE_TYPE (ref->u.c.component->backend_decl);
11804 : }
11805 522 : return GFC_TYPE_ARRAY_LBOUND(tmp, dim);
11806 : }
11807 :
11808 0 : return gfc_index_one_node;
11809 : }
11810 :
11811 :
11812 : /* Returns true if an expression represents an lhs that can be reallocated
11813 : on assignment. */
11814 :
11815 : bool
11816 344029 : gfc_is_reallocatable_lhs (gfc_expr *expr)
11817 : {
11818 344029 : gfc_ref * ref;
11819 344029 : gfc_symbol *sym;
11820 :
11821 344029 : if (!flag_realloc_lhs)
11822 : return false;
11823 :
11824 344029 : if (!expr->ref)
11825 : return false;
11826 :
11827 122163 : sym = expr->symtree->n.sym;
11828 :
11829 122163 : if (sym->attr.associate_var && !expr->ref)
11830 : return false;
11831 :
11832 : /* An allocatable class variable with no reference. */
11833 122163 : if (sym->ts.type == BT_CLASS
11834 3709 : && (!sym->attr.associate_var || sym->attr.select_rank_temporary)
11835 3621 : && CLASS_DATA (sym)->attr.allocatable
11836 : && expr->ref
11837 2379 : && ((expr->ref->type == REF_ARRAY && expr->ref->u.ar.type == AR_FULL
11838 0 : && expr->ref->next == NULL)
11839 2379 : || (expr->ref->type == REF_COMPONENT
11840 2379 : && strcmp (expr->ref->u.c.component->name, "_data") == 0
11841 2015 : && (expr->ref->next == NULL
11842 2015 : || (expr->ref->next->type == REF_ARRAY
11843 2015 : && expr->ref->next->u.ar.type == AR_FULL
11844 1725 : && expr->ref->next->next == NULL)))))
11845 : return true;
11846 :
11847 : /* An allocatable variable. */
11848 120578 : if (sym->attr.allocatable
11849 29664 : && (!sym->attr.associate_var || sym->attr.select_rank_temporary)
11850 : && expr->ref
11851 29664 : && expr->ref->type == REF_ARRAY
11852 28833 : && expr->ref->u.ar.type == AR_FULL)
11853 : return true;
11854 :
11855 : /* All that can be left are allocatable components. */
11856 101213 : if (sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
11857 : return false;
11858 :
11859 : /* Find a component ref followed by an array reference. */
11860 50914 : for (ref = expr->ref; ref; ref = ref->next)
11861 36456 : if (ref->next
11862 21998 : && ref->type == REF_COMPONENT
11863 12954 : && ref->next->type == REF_ARRAY
11864 10701 : && !ref->next->next)
11865 : break;
11866 :
11867 22275 : if (!ref)
11868 : return false;
11869 :
11870 : /* Return true if valid reallocatable lhs. */
11871 7817 : if (ref->u.c.component->attr.allocatable
11872 4056 : && ref->next->u.ar.type == AR_FULL)
11873 3202 : return true;
11874 :
11875 : return false;
11876 : }
11877 :
11878 :
11879 : static tree
11880 56 : concat_str_length (gfc_expr* expr)
11881 : {
11882 56 : tree type;
11883 56 : tree len1;
11884 56 : tree len2;
11885 56 : gfc_se se;
11886 :
11887 56 : type = gfc_typenode_for_spec (&expr->value.op.op1->ts);
11888 56 : len1 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
11889 56 : if (len1 == NULL_TREE)
11890 : {
11891 56 : if (expr->value.op.op1->expr_type == EXPR_OP)
11892 31 : len1 = concat_str_length (expr->value.op.op1);
11893 25 : else if (expr->value.op.op1->expr_type == EXPR_CONSTANT)
11894 25 : len1 = build_int_cst (gfc_charlen_type_node,
11895 25 : expr->value.op.op1->value.character.length);
11896 0 : else if (expr->value.op.op1->ts.u.cl->length)
11897 : {
11898 0 : gfc_init_se (&se, NULL);
11899 0 : gfc_conv_expr (&se, expr->value.op.op1->ts.u.cl->length);
11900 0 : len1 = se.expr;
11901 : }
11902 : else
11903 : {
11904 : /* Last resort! */
11905 0 : gfc_init_se (&se, NULL);
11906 0 : se.want_pointer = 1;
11907 0 : se.descriptor_only = 1;
11908 0 : gfc_conv_expr (&se, expr->value.op.op1);
11909 0 : len1 = se.string_length;
11910 : }
11911 : }
11912 :
11913 56 : type = gfc_typenode_for_spec (&expr->value.op.op2->ts);
11914 56 : len2 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
11915 56 : if (len2 == NULL_TREE)
11916 : {
11917 31 : if (expr->value.op.op2->expr_type == EXPR_OP)
11918 0 : len2 = concat_str_length (expr->value.op.op2);
11919 31 : else if (expr->value.op.op2->expr_type == EXPR_CONSTANT)
11920 25 : len2 = build_int_cst (gfc_charlen_type_node,
11921 25 : expr->value.op.op2->value.character.length);
11922 6 : else if (expr->value.op.op2->ts.u.cl->length)
11923 : {
11924 6 : gfc_init_se (&se, NULL);
11925 6 : gfc_conv_expr (&se, expr->value.op.op2->ts.u.cl->length);
11926 6 : len2 = se.expr;
11927 : }
11928 : else
11929 : {
11930 : /* Last resort! */
11931 0 : gfc_init_se (&se, NULL);
11932 0 : se.want_pointer = 1;
11933 0 : se.descriptor_only = 1;
11934 0 : gfc_conv_expr (&se, expr->value.op.op2);
11935 0 : len2 = se.string_length;
11936 : }
11937 : }
11938 :
11939 56 : gcc_assert(len1 && len2);
11940 56 : len1 = fold_convert (gfc_charlen_type_node, len1);
11941 56 : len2 = fold_convert (gfc_charlen_type_node, len2);
11942 :
11943 56 : return fold_build2_loc (input_location, PLUS_EXPR,
11944 56 : gfc_charlen_type_node, len1, len2);
11945 : }
11946 :
11947 :
11948 : /* Among the scalarization chain of LOOP, find the element associated with an
11949 : allocatable array on the lhs of an assignment and evaluate its fields
11950 : (bounds, offset, etc) to new variables, putting the new code in BLOCK. This
11951 : function is to be called after putting the reallocation code in BLOCK and
11952 : before the beginning of the scalarization loop body.
11953 :
11954 : The fields to be saved are expected to hold on entry to the function
11955 : expressions referencing the array descriptor. Especially the expressions
11956 : shouldn't be already temporary variable references as the value saved before
11957 : reallocation would be incorrect after reallocation.
11958 : At the end of the function, the expressions have been replaced with variable
11959 : references. */
11960 :
11961 : static void
11962 6523 : update_reallocated_descriptor (stmtblock_t *block, gfc_loopinfo *loop)
11963 : {
11964 22805 : for (gfc_ss *s = loop->ss; s != gfc_ss_terminator; s = s->loop_chain)
11965 : {
11966 16282 : if (!s->is_alloc_lhs)
11967 9759 : continue;
11968 :
11969 6523 : gcc_assert (s->info->type == GFC_SS_SECTION);
11970 6523 : gfc_array_info *info = &s->info->data.array;
11971 :
11972 : #define SAVE_VALUE(value) \
11973 : do \
11974 : { \
11975 : value = gfc_evaluate_now (value, block); \
11976 : } \
11977 : while (0)
11978 :
11979 6523 : if (save_descriptor_data (info->descriptor, info->data))
11980 5707 : SAVE_VALUE (info->data);
11981 6523 : SAVE_VALUE (info->offset);
11982 6523 : info->saved_offset = info->offset;
11983 16251 : for (int i = 0; i < s->dimen; i++)
11984 : {
11985 9728 : int dim = s->dim[i];
11986 9728 : SAVE_VALUE (info->start[dim]);
11987 9728 : SAVE_VALUE (info->end[dim]);
11988 9728 : SAVE_VALUE (info->stride[dim]);
11989 9728 : SAVE_VALUE (info->delta[dim]);
11990 : }
11991 :
11992 : #undef SAVE_VALUE
11993 : }
11994 6523 : }
11995 :
11996 :
11997 : /* Allocate the lhs of an assignment to an allocatable array, otherwise
11998 : reallocate it. */
11999 :
12000 : tree
12001 6523 : gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
12002 : gfc_expr *expr1,
12003 : gfc_expr *expr2)
12004 : {
12005 6523 : stmtblock_t realloc_block;
12006 6523 : stmtblock_t alloc_block;
12007 6523 : stmtblock_t fblock;
12008 6523 : stmtblock_t loop_pre_block;
12009 6523 : gfc_ref *ref;
12010 6523 : gfc_ss *rss;
12011 6523 : gfc_ss *lss;
12012 6523 : gfc_array_info *linfo;
12013 6523 : tree realloc_expr;
12014 6523 : tree alloc_expr;
12015 6523 : tree size1;
12016 6523 : tree size2;
12017 6523 : tree elemsize1;
12018 6523 : tree elemsize2;
12019 6523 : tree array1;
12020 6523 : tree cond_null;
12021 6523 : tree cond;
12022 6523 : tree tmp;
12023 6523 : tree tmp2;
12024 6523 : tree lbound;
12025 6523 : tree ubound;
12026 6523 : tree desc;
12027 6523 : tree old_desc;
12028 6523 : tree desc2;
12029 6523 : tree offset;
12030 6523 : tree jump_label1;
12031 6523 : tree jump_label2;
12032 6523 : tree lbd;
12033 6523 : tree class_expr2 = NULL_TREE;
12034 6523 : int n;
12035 6523 : gfc_array_spec * as;
12036 6523 : bool coarray = (flag_coarray == GFC_FCOARRAY_LIB
12037 6523 : && gfc_caf_attr (expr1, true).codimension);
12038 6523 : tree token;
12039 6523 : gfc_se caf_se;
12040 :
12041 : /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
12042 : Find the lhs expression in the loop chain and set expr1 and
12043 : expr2 accordingly. */
12044 6523 : if (expr1->expr_type == EXPR_FUNCTION && expr2 == NULL)
12045 : {
12046 203 : expr2 = expr1;
12047 : /* Find the ss for the lhs. */
12048 203 : lss = loop->ss;
12049 406 : for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
12050 406 : if (lss->info->expr && lss->info->expr->expr_type == EXPR_VARIABLE)
12051 : break;
12052 203 : if (lss == gfc_ss_terminator)
12053 : return NULL_TREE;
12054 203 : expr1 = lss->info->expr;
12055 : }
12056 :
12057 : /* Bail out if this is not a valid allocate on assignment. */
12058 6523 : if (!gfc_is_reallocatable_lhs (expr1)
12059 6523 : || (expr2 && !expr2->rank))
12060 : return NULL_TREE;
12061 :
12062 : /* Find the ss for the lhs. */
12063 6523 : lss = loop->ss;
12064 16282 : for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
12065 16282 : if (lss->info->expr == expr1)
12066 : break;
12067 :
12068 6523 : if (lss == gfc_ss_terminator)
12069 : return NULL_TREE;
12070 :
12071 6523 : linfo = &lss->info->data.array;
12072 :
12073 : /* Find an ss for the rhs. For operator expressions, we see the
12074 : ss's for the operands. Any one of these will do. */
12075 6523 : rss = loop->ss;
12076 7095 : for (; rss && rss != gfc_ss_terminator; rss = rss->loop_chain)
12077 7095 : if (rss->info->expr != expr1 && rss != loop->temp_ss)
12078 : break;
12079 :
12080 6523 : if (expr2 && rss == gfc_ss_terminator)
12081 : return NULL_TREE;
12082 :
12083 : /* Ensure that the string length from the current scope is used. */
12084 6523 : if (expr2->ts.type == BT_CHARACTER
12085 983 : && expr2->expr_type == EXPR_FUNCTION
12086 130 : && !expr2->value.function.isym)
12087 21 : expr2->ts.u.cl->backend_decl = rss->info->string_length;
12088 :
12089 : /* Since the lhs is allocatable, this must be a descriptor type.
12090 : Get the data and array size. */
12091 6523 : desc = linfo->descriptor;
12092 6523 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
12093 6523 : array1 = gfc_conv_descriptor_data_get (desc);
12094 :
12095 : /* If the data is null, set the descriptor bounds and offset. This suppresses
12096 : the maybe used uninitialized warning. Note that the always false variable
12097 : prevents this block from ever being executed, and makes sure that the
12098 : optimizers are able to remove it. Component references are not subject to
12099 : the warnings, so we don't uselessly complicate the generated code for them.
12100 : */
12101 11682 : for (ref = expr1->ref; ref; ref = ref->next)
12102 6718 : if (ref->type == REF_COMPONENT)
12103 : break;
12104 :
12105 6523 : if (!ref)
12106 : {
12107 4964 : stmtblock_t unalloc_init_block;
12108 4964 : gfc_init_block (&unalloc_init_block);
12109 4964 : tree guard = gfc_create_var (logical_type_node, "unallocated_init_guard");
12110 4964 : gfc_add_modify (&unalloc_init_block, guard, logical_false_node);
12111 :
12112 4964 : gfc_start_block (&loop_pre_block);
12113 17740 : for (n = 0; n < expr1->rank; n++)
12114 : {
12115 7812 : gfc_conv_descriptor_lbound_set (&loop_pre_block, desc,
12116 : gfc_rank_cst[n],
12117 : gfc_index_one_node);
12118 7812 : gfc_conv_descriptor_ubound_set (&loop_pre_block, desc,
12119 : gfc_rank_cst[n],
12120 : gfc_index_zero_node);
12121 7812 : gfc_conv_descriptor_stride_set (&loop_pre_block, desc,
12122 : gfc_rank_cst[n],
12123 : gfc_index_zero_node);
12124 : }
12125 :
12126 4964 : gfc_conv_descriptor_offset_set (&loop_pre_block, desc,
12127 : gfc_index_zero_node);
12128 :
12129 4964 : tmp = fold_build2_loc (input_location, EQ_EXPR,
12130 : logical_type_node, array1,
12131 4964 : build_int_cst (TREE_TYPE (array1), 0));
12132 4964 : tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
12133 : logical_type_node, tmp, guard);
12134 4964 : tmp = build3_v (COND_EXPR, tmp,
12135 : gfc_finish_block (&loop_pre_block),
12136 : build_empty_stmt (input_location));
12137 4964 : gfc_prepend_expr_to_block (&loop->pre, tmp);
12138 4964 : gfc_prepend_expr_to_block (&loop->pre,
12139 : gfc_finish_block (&unalloc_init_block));
12140 : }
12141 :
12142 6523 : gfc_start_block (&fblock);
12143 :
12144 6523 : if (expr2)
12145 6523 : desc2 = rss->info->data.array.descriptor;
12146 : else
12147 : desc2 = NULL_TREE;
12148 :
12149 : /* Get the old lhs element size for deferred character and class expr1. */
12150 6523 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12151 : {
12152 663 : if (expr1->ts.u.cl->backend_decl
12153 663 : && VAR_P (expr1->ts.u.cl->backend_decl))
12154 : elemsize1 = expr1->ts.u.cl->backend_decl;
12155 : else
12156 64 : elemsize1 = lss->info->string_length;
12157 663 : tree unit_size = TYPE_SIZE_UNIT (gfc_get_char_type (expr1->ts.kind));
12158 1326 : elemsize1 = fold_build2_loc (input_location, MULT_EXPR,
12159 663 : TREE_TYPE (elemsize1), elemsize1,
12160 663 : fold_convert (TREE_TYPE (elemsize1), unit_size));
12161 :
12162 663 : }
12163 5860 : else if (expr1->ts.type == BT_CLASS)
12164 : {
12165 : /* Unfortunately, the lhs vptr is set too early in many cases.
12166 : Play it safe by using the descriptor element length. */
12167 645 : tmp = gfc_conv_descriptor_elem_len (desc);
12168 645 : elemsize1 = fold_convert (gfc_array_index_type, tmp);
12169 : }
12170 : else
12171 : elemsize1 = NULL_TREE;
12172 1308 : if (elemsize1 != NULL_TREE)
12173 1308 : elemsize1 = gfc_evaluate_now (elemsize1, &fblock);
12174 :
12175 : /* Get the new lhs size in bytes. */
12176 6523 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12177 : {
12178 663 : if (expr2->ts.deferred)
12179 : {
12180 183 : if (expr2->ts.u.cl->backend_decl
12181 183 : && VAR_P (expr2->ts.u.cl->backend_decl))
12182 : tmp = expr2->ts.u.cl->backend_decl;
12183 : else
12184 0 : tmp = rss->info->string_length;
12185 : }
12186 : else
12187 : {
12188 480 : tmp = expr2->ts.u.cl->backend_decl;
12189 480 : if (!tmp && expr2->expr_type == EXPR_OP
12190 25 : && expr2->value.op.op == INTRINSIC_CONCAT)
12191 : {
12192 25 : tmp = concat_str_length (expr2);
12193 25 : expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
12194 : }
12195 12 : else if (!tmp && expr2->ts.u.cl->length)
12196 : {
12197 12 : gfc_se tmpse;
12198 12 : gfc_init_se (&tmpse, NULL);
12199 12 : gfc_conv_expr_type (&tmpse, expr2->ts.u.cl->length,
12200 : gfc_charlen_type_node);
12201 12 : tmp = tmpse.expr;
12202 12 : expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
12203 : }
12204 480 : tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
12205 : }
12206 :
12207 663 : if (expr1->ts.u.cl->backend_decl
12208 663 : && VAR_P (expr1->ts.u.cl->backend_decl))
12209 599 : gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
12210 : else
12211 64 : gfc_add_modify (&fblock, lss->info->string_length, tmp);
12212 :
12213 663 : if (expr1->ts.kind > 1)
12214 12 : tmp = fold_build2_loc (input_location, MULT_EXPR,
12215 6 : TREE_TYPE (tmp),
12216 6 : tmp, build_int_cst (TREE_TYPE (tmp),
12217 6 : expr1->ts.kind));
12218 : }
12219 5860 : else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
12220 : {
12221 271 : tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts)));
12222 271 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
12223 : fold_convert (gfc_array_index_type, tmp),
12224 271 : expr1->ts.u.cl->backend_decl);
12225 : }
12226 5589 : else if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS)
12227 164 : tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
12228 5425 : else if (expr1->ts.type == BT_CLASS && expr2->ts.type == BT_CLASS)
12229 : {
12230 280 : tmp = expr2->rank ? gfc_get_class_from_expr (desc2) : NULL_TREE;
12231 280 : if (tmp == NULL_TREE && expr2->expr_type == EXPR_VARIABLE)
12232 36 : tmp = class_expr2 = gfc_get_class_from_gfc_expr (expr2);
12233 :
12234 43 : if (tmp != NULL_TREE)
12235 273 : tmp = gfc_class_vtab_size_get (tmp);
12236 : else
12237 7 : tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&CLASS_DATA (expr2)->ts));
12238 : }
12239 : else
12240 5145 : tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
12241 6523 : elemsize2 = fold_convert (gfc_array_index_type, tmp);
12242 6523 : elemsize2 = gfc_evaluate_now (elemsize2, &fblock);
12243 :
12244 : /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
12245 : deallocated if expr is an array of different shape or any of the
12246 : corresponding length type parameter values of variable and expr
12247 : differ." This assures F95 compatibility. */
12248 6523 : jump_label1 = gfc_build_label_decl (NULL_TREE);
12249 6523 : jump_label2 = gfc_build_label_decl (NULL_TREE);
12250 :
12251 : /* Allocate if data is NULL. */
12252 6523 : cond_null = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
12253 6523 : array1, build_int_cst (TREE_TYPE (array1), 0));
12254 6523 : cond_null= gfc_evaluate_now (cond_null, &fblock);
12255 :
12256 6523 : tmp = build3_v (COND_EXPR, cond_null,
12257 : build1_v (GOTO_EXPR, jump_label1),
12258 : build_empty_stmt (input_location));
12259 6523 : gfc_add_expr_to_block (&fblock, tmp);
12260 :
12261 : /* Get arrayspec if expr is a full array. */
12262 6523 : if (expr2 && expr2->expr_type == EXPR_FUNCTION
12263 2802 : && expr2->value.function.isym
12264 2295 : && expr2->value.function.isym->conversion)
12265 : {
12266 : /* For conversion functions, take the arg. */
12267 245 : gfc_expr *arg = expr2->value.function.actual->expr;
12268 245 : as = gfc_get_full_arrayspec_from_expr (arg);
12269 245 : }
12270 : else if (expr2)
12271 6278 : as = gfc_get_full_arrayspec_from_expr (expr2);
12272 : else
12273 : as = NULL;
12274 :
12275 : /* If the lhs shape is not the same as the rhs jump to setting the
12276 : bounds and doing the reallocation....... */
12277 16251 : for (n = 0; n < expr1->rank; n++)
12278 : {
12279 : /* Check the shape. */
12280 9728 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
12281 9728 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
12282 9728 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
12283 : gfc_array_index_type,
12284 : loop->to[n], loop->from[n]);
12285 9728 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
12286 : gfc_array_index_type,
12287 : tmp, lbound);
12288 9728 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
12289 : gfc_array_index_type,
12290 : tmp, ubound);
12291 9728 : cond = fold_build2_loc (input_location, NE_EXPR,
12292 : logical_type_node,
12293 : tmp, gfc_index_zero_node);
12294 9728 : tmp = build3_v (COND_EXPR, cond,
12295 : build1_v (GOTO_EXPR, jump_label1),
12296 : build_empty_stmt (input_location));
12297 9728 : gfc_add_expr_to_block (&fblock, tmp);
12298 : }
12299 :
12300 : /* ...else if the element lengths are not the same also go to
12301 : setting the bounds and doing the reallocation.... */
12302 6523 : if (elemsize1 != NULL_TREE)
12303 : {
12304 1308 : cond = fold_build2_loc (input_location, NE_EXPR,
12305 : logical_type_node,
12306 : elemsize1, elemsize2);
12307 1308 : tmp = build3_v (COND_EXPR, cond,
12308 : build1_v (GOTO_EXPR, jump_label1),
12309 : build_empty_stmt (input_location));
12310 1308 : gfc_add_expr_to_block (&fblock, tmp);
12311 : }
12312 :
12313 : /* ....else jump past the (re)alloc code. */
12314 6523 : tmp = build1_v (GOTO_EXPR, jump_label2);
12315 6523 : gfc_add_expr_to_block (&fblock, tmp);
12316 :
12317 : /* Add the label to start automatic (re)allocation. */
12318 6523 : tmp = build1_v (LABEL_EXPR, jump_label1);
12319 6523 : gfc_add_expr_to_block (&fblock, tmp);
12320 :
12321 : /* Get the rhs size and fix it. */
12322 6523 : size2 = gfc_index_one_node;
12323 16251 : for (n = 0; n < expr2->rank; n++)
12324 : {
12325 9728 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
12326 : gfc_array_index_type,
12327 : loop->to[n], loop->from[n]);
12328 9728 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
12329 : gfc_array_index_type,
12330 : tmp, gfc_index_one_node);
12331 9728 : size2 = fold_build2_loc (input_location, MULT_EXPR,
12332 : gfc_array_index_type,
12333 : tmp, size2);
12334 : }
12335 6523 : size2 = gfc_evaluate_now (size2, &fblock);
12336 :
12337 : /* Deallocation of allocatable components will have to occur on
12338 : reallocation. Fix the old descriptor now. */
12339 6523 : if ((expr1->ts.type == BT_DERIVED)
12340 416 : && expr1->ts.u.derived->attr.alloc_comp)
12341 157 : old_desc = gfc_evaluate_now (desc, &fblock);
12342 : else
12343 : old_desc = NULL_TREE;
12344 :
12345 : /* Now modify the lhs descriptor and the associated scalarizer
12346 : variables. F2003 7.4.1.3: "If variable is or becomes an
12347 : unallocated allocatable variable, then it is allocated with each
12348 : deferred type parameter equal to the corresponding type parameters
12349 : of expr , with the shape of expr , and with each lower bound equal
12350 : to the corresponding element of LBOUND(expr)."
12351 : Reuse size1 to keep a dimension-by-dimension track of the
12352 : stride of the new array. */
12353 6523 : size1 = gfc_index_one_node;
12354 6523 : offset = gfc_index_zero_node;
12355 :
12356 16251 : for (n = 0; n < expr2->rank; n++)
12357 : {
12358 9728 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
12359 : gfc_array_index_type,
12360 : loop->to[n], loop->from[n]);
12361 9728 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
12362 : gfc_array_index_type,
12363 : tmp, gfc_index_one_node);
12364 :
12365 9728 : lbound = gfc_index_one_node;
12366 9728 : ubound = tmp;
12367 :
12368 9728 : if (as)
12369 : {
12370 2048 : lbd = get_std_lbound (expr2, desc2, n,
12371 1024 : as->type == AS_ASSUMED_SIZE);
12372 1024 : ubound = fold_build2_loc (input_location,
12373 : MINUS_EXPR,
12374 : gfc_array_index_type,
12375 : ubound, lbound);
12376 1024 : ubound = fold_build2_loc (input_location,
12377 : PLUS_EXPR,
12378 : gfc_array_index_type,
12379 : ubound, lbd);
12380 1024 : lbound = lbd;
12381 : }
12382 :
12383 9728 : gfc_conv_descriptor_lbound_set (&fblock, desc,
12384 : gfc_rank_cst[n],
12385 : lbound);
12386 9728 : gfc_conv_descriptor_ubound_set (&fblock, desc,
12387 : gfc_rank_cst[n],
12388 : ubound);
12389 9728 : gfc_conv_descriptor_stride_set (&fblock, desc,
12390 : gfc_rank_cst[n],
12391 : size1);
12392 9728 : lbound = gfc_conv_descriptor_lbound_get (desc,
12393 : gfc_rank_cst[n]);
12394 9728 : tmp2 = fold_build2_loc (input_location, MULT_EXPR,
12395 : gfc_array_index_type,
12396 : lbound, size1);
12397 9728 : offset = fold_build2_loc (input_location, MINUS_EXPR,
12398 : gfc_array_index_type,
12399 : offset, tmp2);
12400 9728 : size1 = fold_build2_loc (input_location, MULT_EXPR,
12401 : gfc_array_index_type,
12402 : tmp, size1);
12403 : }
12404 :
12405 : /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
12406 : the array offset is saved and the info.offset is used for a
12407 : running offset. Use the saved_offset instead. */
12408 6523 : tmp = gfc_conv_descriptor_offset (desc);
12409 6523 : gfc_add_modify (&fblock, tmp, offset);
12410 :
12411 : /* Take into account _len of unlimited polymorphic entities, so that span
12412 : for array descriptors and allocation sizes are computed correctly. */
12413 6523 : if (UNLIMITED_POLY (expr2))
12414 : {
12415 92 : tree len = gfc_class_len_get (TREE_OPERAND (desc2, 0));
12416 92 : len = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
12417 : fold_convert (size_type_node, len),
12418 : size_one_node);
12419 92 : elemsize2 = fold_build2_loc (input_location, MULT_EXPR,
12420 : gfc_array_index_type, elemsize2,
12421 : fold_convert (gfc_array_index_type, len));
12422 : }
12423 :
12424 6523 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
12425 6523 : gfc_conv_descriptor_span_set (&fblock, desc, elemsize2);
12426 :
12427 6523 : size2 = fold_build2_loc (input_location, MULT_EXPR,
12428 : gfc_array_index_type,
12429 : elemsize2, size2);
12430 6523 : size2 = fold_convert (size_type_node, size2);
12431 6523 : size2 = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
12432 : size2, size_one_node);
12433 6523 : size2 = gfc_evaluate_now (size2, &fblock);
12434 :
12435 : /* For deferred character length, the 'size' field of the dtype might
12436 : have changed so set the dtype. */
12437 6523 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
12438 6523 : && expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12439 : {
12440 663 : tree type;
12441 663 : tmp = gfc_conv_descriptor_dtype (desc);
12442 663 : if (expr2->ts.u.cl->backend_decl)
12443 663 : type = gfc_typenode_for_spec (&expr2->ts);
12444 : else
12445 0 : type = gfc_typenode_for_spec (&expr1->ts);
12446 :
12447 663 : gfc_add_modify (&fblock, tmp,
12448 : gfc_get_dtype_rank_type (expr1->rank,type));
12449 : }
12450 5860 : else if (expr1->ts.type == BT_CLASS)
12451 : {
12452 645 : tree type;
12453 645 : tmp = gfc_conv_descriptor_dtype (desc);
12454 :
12455 645 : if (expr2->ts.type != BT_CLASS)
12456 365 : type = gfc_typenode_for_spec (&expr2->ts);
12457 : else
12458 280 : type = gfc_get_character_type_len (1, elemsize2);
12459 :
12460 645 : gfc_add_modify (&fblock, tmp,
12461 : gfc_get_dtype_rank_type (expr2->rank,type));
12462 : /* Set the _len field as well... */
12463 645 : if (UNLIMITED_POLY (expr1))
12464 : {
12465 256 : tmp = gfc_class_len_get (TREE_OPERAND (desc, 0));
12466 256 : if (expr2->ts.type == BT_CHARACTER)
12467 49 : gfc_add_modify (&fblock, tmp,
12468 49 : fold_convert (TREE_TYPE (tmp),
12469 : TYPE_SIZE_UNIT (type)));
12470 207 : else if (UNLIMITED_POLY (expr2))
12471 92 : gfc_add_modify (&fblock, tmp,
12472 92 : gfc_class_len_get (TREE_OPERAND (desc2, 0)));
12473 : else
12474 115 : gfc_add_modify (&fblock, tmp,
12475 115 : build_int_cst (TREE_TYPE (tmp), 0));
12476 : }
12477 : /* ...and the vptr. */
12478 645 : tmp = gfc_class_vptr_get (TREE_OPERAND (desc, 0));
12479 645 : if (expr2->ts.type == BT_CLASS && !VAR_P (desc2)
12480 273 : && TREE_CODE (desc2) == COMPONENT_REF)
12481 : {
12482 237 : tmp2 = gfc_get_class_from_expr (desc2);
12483 237 : tmp2 = gfc_class_vptr_get (tmp2);
12484 : }
12485 408 : else if (expr2->ts.type == BT_CLASS && class_expr2 != NULL_TREE)
12486 36 : tmp2 = gfc_class_vptr_get (class_expr2);
12487 : else
12488 : {
12489 372 : tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts));
12490 372 : tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2);
12491 : }
12492 :
12493 645 : gfc_add_modify (&fblock, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
12494 : }
12495 5215 : else if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
12496 : {
12497 39 : gfc_add_modify (&fblock, gfc_conv_descriptor_dtype (desc),
12498 39 : gfc_get_dtype (TREE_TYPE (desc)));
12499 : }
12500 :
12501 : /* Realloc expression. Note that the scalarizer uses desc.data
12502 : in the array reference - (*desc.data)[<element>]. */
12503 6523 : gfc_init_block (&realloc_block);
12504 6523 : gfc_init_se (&caf_se, NULL);
12505 :
12506 6523 : if (coarray)
12507 : {
12508 39 : token = gfc_get_ultimate_alloc_ptr_comps_caf_token (&caf_se, expr1);
12509 39 : if (token == NULL_TREE)
12510 : {
12511 9 : tmp = gfc_get_tree_for_caf_expr (expr1);
12512 9 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
12513 6 : tmp = build_fold_indirect_ref (tmp);
12514 9 : gfc_get_caf_token_offset (&caf_se, &token, NULL, tmp, NULL_TREE,
12515 : expr1);
12516 9 : token = gfc_build_addr_expr (NULL_TREE, token);
12517 : }
12518 :
12519 39 : gfc_add_block_to_block (&realloc_block, &caf_se.pre);
12520 : }
12521 6523 : if ((expr1->ts.type == BT_DERIVED)
12522 416 : && expr1->ts.u.derived->attr.alloc_comp)
12523 : {
12524 157 : tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, old_desc,
12525 : expr1->rank, true);
12526 157 : gfc_add_expr_to_block (&realloc_block, tmp);
12527 : }
12528 :
12529 6523 : if (!coarray)
12530 : {
12531 6484 : tmp = build_call_expr_loc (input_location,
12532 : builtin_decl_explicit (BUILT_IN_REALLOC), 2,
12533 : fold_convert (pvoid_type_node, array1),
12534 : size2);
12535 6484 : if (flag_openmp_allocators)
12536 : {
12537 2 : tree cond, omp_tmp;
12538 2 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
12539 : gfc_conv_descriptor_version (desc),
12540 : build_int_cst (integer_type_node, 1));
12541 2 : omp_tmp = builtin_decl_explicit (BUILT_IN_GOMP_REALLOC);
12542 2 : omp_tmp = build_call_expr_loc (input_location, omp_tmp, 4,
12543 : fold_convert (pvoid_type_node, array1), size2,
12544 : build_zero_cst (ptr_type_node),
12545 : build_zero_cst (ptr_type_node));
12546 2 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond,
12547 : omp_tmp, tmp);
12548 : }
12549 :
12550 6484 : gfc_conv_descriptor_data_set (&realloc_block, desc, tmp);
12551 : }
12552 : else
12553 : {
12554 39 : tmp = build_call_expr_loc (input_location,
12555 : gfor_fndecl_caf_deregister, 5, token,
12556 : build_int_cst (integer_type_node,
12557 : GFC_CAF_COARRAY_DEALLOCATE_ONLY),
12558 : null_pointer_node, null_pointer_node,
12559 : integer_zero_node);
12560 39 : gfc_add_expr_to_block (&realloc_block, tmp);
12561 39 : tmp = build_call_expr_loc (input_location,
12562 : gfor_fndecl_caf_register,
12563 : 7, size2,
12564 : build_int_cst (integer_type_node,
12565 : GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY),
12566 : token, gfc_build_addr_expr (NULL_TREE, desc),
12567 : null_pointer_node, null_pointer_node,
12568 : integer_zero_node);
12569 39 : gfc_add_expr_to_block (&realloc_block, tmp);
12570 : }
12571 :
12572 6523 : if ((expr1->ts.type == BT_DERIVED)
12573 416 : && expr1->ts.u.derived->attr.alloc_comp)
12574 : {
12575 157 : tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc,
12576 : expr1->rank);
12577 157 : gfc_add_expr_to_block (&realloc_block, tmp);
12578 : }
12579 :
12580 6523 : gfc_add_block_to_block (&realloc_block, &caf_se.post);
12581 6523 : realloc_expr = gfc_finish_block (&realloc_block);
12582 :
12583 : /* Malloc expression. */
12584 6523 : gfc_init_block (&alloc_block);
12585 6523 : if (!coarray)
12586 : {
12587 6484 : tmp = build_call_expr_loc (input_location,
12588 : builtin_decl_explicit (BUILT_IN_MALLOC),
12589 : 1, size2);
12590 6484 : gfc_conv_descriptor_data_set (&alloc_block,
12591 : desc, tmp);
12592 : }
12593 : else
12594 : {
12595 39 : tmp = build_call_expr_loc (input_location,
12596 : gfor_fndecl_caf_register,
12597 : 7, size2,
12598 : build_int_cst (integer_type_node,
12599 : GFC_CAF_COARRAY_ALLOC),
12600 : token, gfc_build_addr_expr (NULL_TREE, desc),
12601 : null_pointer_node, null_pointer_node,
12602 : integer_zero_node);
12603 39 : gfc_add_expr_to_block (&alloc_block, tmp);
12604 : }
12605 :
12606 :
12607 : /* We already set the dtype in the case of deferred character
12608 : length arrays and class lvalues. */
12609 6523 : if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
12610 6523 : && ((expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12611 5860 : || coarray))
12612 12344 : && expr1->ts.type != BT_CLASS)
12613 : {
12614 5176 : tmp = gfc_conv_descriptor_dtype (desc);
12615 5176 : gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
12616 : }
12617 :
12618 6523 : if ((expr1->ts.type == BT_DERIVED)
12619 416 : && expr1->ts.u.derived->attr.alloc_comp)
12620 : {
12621 157 : tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc,
12622 : expr1->rank);
12623 157 : gfc_add_expr_to_block (&alloc_block, tmp);
12624 : }
12625 6523 : alloc_expr = gfc_finish_block (&alloc_block);
12626 :
12627 : /* Malloc if not allocated; realloc otherwise. */
12628 6523 : tmp = build3_v (COND_EXPR, cond_null, alloc_expr, realloc_expr);
12629 6523 : gfc_add_expr_to_block (&fblock, tmp);
12630 :
12631 : /* Add the label for same shape lhs and rhs. */
12632 6523 : tmp = build1_v (LABEL_EXPR, jump_label2);
12633 6523 : gfc_add_expr_to_block (&fblock, tmp);
12634 :
12635 6523 : tree realloc_code = gfc_finish_block (&fblock);
12636 :
12637 6523 : stmtblock_t result_block;
12638 6523 : gfc_init_block (&result_block);
12639 6523 : gfc_add_expr_to_block (&result_block, realloc_code);
12640 6523 : update_reallocated_descriptor (&result_block, loop);
12641 :
12642 6523 : return gfc_finish_block (&result_block);
12643 : }
12644 :
12645 :
12646 : /* Initialize class descriptor's TKR information. */
12647 :
12648 : void
12649 2907 : gfc_trans_class_array (gfc_symbol * sym, gfc_wrapped_block * block)
12650 : {
12651 2907 : tree type, etype;
12652 2907 : tree tmp;
12653 2907 : tree descriptor;
12654 2907 : stmtblock_t init;
12655 2907 : int rank;
12656 :
12657 : /* Make sure the frontend gets these right. */
12658 2907 : gcc_assert (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
12659 : && (CLASS_DATA (sym)->attr.class_pointer
12660 : || CLASS_DATA (sym)->attr.allocatable));
12661 :
12662 2907 : gcc_assert (VAR_P (sym->backend_decl)
12663 : || TREE_CODE (sym->backend_decl) == PARM_DECL);
12664 :
12665 2907 : if (sym->attr.dummy)
12666 1418 : return;
12667 :
12668 2907 : descriptor = gfc_class_data_get (sym->backend_decl);
12669 2907 : type = TREE_TYPE (descriptor);
12670 :
12671 2907 : if (type == NULL || !GFC_DESCRIPTOR_TYPE_P (type))
12672 : return;
12673 :
12674 1489 : location_t loc = input_location;
12675 1489 : input_location = gfc_get_location (&sym->declared_at);
12676 1489 : gfc_init_block (&init);
12677 :
12678 1489 : rank = CLASS_DATA (sym)->as ? (CLASS_DATA (sym)->as->rank) : (0);
12679 1489 : gcc_assert (rank>=0);
12680 1489 : tmp = gfc_conv_descriptor_dtype (descriptor);
12681 1489 : etype = gfc_get_element_type (type);
12682 1489 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (tmp), tmp,
12683 : gfc_get_dtype_rank_type (rank, etype));
12684 1489 : gfc_add_expr_to_block (&init, tmp);
12685 :
12686 1489 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
12687 1489 : input_location = loc;
12688 : }
12689 :
12690 :
12691 : /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
12692 : Do likewise, recursively if necessary, with the allocatable components of
12693 : derived types. This function is also called for assumed-rank arrays, which
12694 : are always dummy arguments. */
12695 :
12696 : void
12697 17816 : gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
12698 : {
12699 17816 : tree type;
12700 17816 : tree tmp;
12701 17816 : tree descriptor;
12702 17816 : stmtblock_t init;
12703 17816 : stmtblock_t cleanup;
12704 17816 : int rank;
12705 17816 : bool sym_has_alloc_comp, has_finalizer;
12706 :
12707 35632 : sym_has_alloc_comp = (sym->ts.type == BT_DERIVED
12708 10888 : || sym->ts.type == BT_CLASS)
12709 17816 : && sym->ts.u.derived->attr.alloc_comp;
12710 17816 : has_finalizer = gfc_may_be_finalized (sym->ts);
12711 :
12712 : /* Make sure the frontend gets these right. */
12713 17816 : gcc_assert (sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp
12714 : || has_finalizer
12715 : || (sym->as->type == AS_ASSUMED_RANK && sym->attr.dummy));
12716 :
12717 17816 : location_t loc = input_location;
12718 17816 : input_location = gfc_get_location (&sym->declared_at);
12719 17816 : gfc_init_block (&init);
12720 :
12721 17816 : gcc_assert (VAR_P (sym->backend_decl)
12722 : || TREE_CODE (sym->backend_decl) == PARM_DECL);
12723 :
12724 17816 : if (sym->ts.type == BT_CHARACTER
12725 1390 : && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
12726 : {
12727 812 : if (sym->ts.deferred && !sym->ts.u.cl->length && !sym->attr.dummy)
12728 : {
12729 607 : tree len_expr = sym->ts.u.cl->backend_decl;
12730 607 : tree init_val = build_zero_cst (TREE_TYPE (len_expr));
12731 607 : if (VAR_P (len_expr)
12732 607 : && sym->attr.save
12733 662 : && !DECL_INITIAL (len_expr))
12734 55 : DECL_INITIAL (len_expr) = init_val;
12735 : else
12736 552 : gfc_add_modify (&init, len_expr, init_val);
12737 : }
12738 812 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
12739 812 : gfc_trans_vla_type_sizes (sym, &init);
12740 :
12741 : /* Presence check of optional deferred-length character dummy. */
12742 812 : if (sym->ts.deferred && sym->attr.dummy && sym->attr.optional)
12743 : {
12744 43 : tmp = gfc_finish_block (&init);
12745 43 : tmp = build3_v (COND_EXPR, gfc_conv_expr_present (sym),
12746 : tmp, build_empty_stmt (input_location));
12747 43 : gfc_add_expr_to_block (&init, tmp);
12748 : }
12749 : }
12750 :
12751 : /* Dummy, use associated and result variables don't need anything special. */
12752 17816 : if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result)
12753 : {
12754 840 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
12755 840 : input_location = loc;
12756 1119 : return;
12757 : }
12758 :
12759 16976 : descriptor = sym->backend_decl;
12760 :
12761 : /* Although static, derived types with default initializers and
12762 : allocatable components must not be nulled wholesale; instead they
12763 : are treated component by component. */
12764 16976 : if (TREE_STATIC (descriptor) && !sym_has_alloc_comp && !has_finalizer)
12765 : {
12766 : /* SAVEd variables are not freed on exit. */
12767 279 : gfc_trans_static_array_pointer (sym);
12768 :
12769 279 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
12770 279 : input_location = loc;
12771 279 : return;
12772 : }
12773 :
12774 : /* Get the descriptor type. */
12775 16697 : type = TREE_TYPE (sym->backend_decl);
12776 :
12777 16697 : if ((sym_has_alloc_comp || (has_finalizer && sym->ts.type != BT_CLASS))
12778 5354 : && !(sym->attr.pointer || sym->attr.allocatable))
12779 : {
12780 2831 : if (!sym->attr.save
12781 2440 : && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program))
12782 : {
12783 2440 : if (sym->value == NULL
12784 2440 : || !gfc_has_default_initializer (sym->ts.u.derived))
12785 : {
12786 2021 : rank = sym->as ? sym->as->rank : 0;
12787 2021 : tmp = gfc_nullify_alloc_comp (sym->ts.u.derived,
12788 : descriptor, rank);
12789 2021 : gfc_add_expr_to_block (&init, tmp);
12790 : }
12791 : else
12792 419 : gfc_init_default_dt (sym, &init, false);
12793 : }
12794 : }
12795 13866 : else if (!GFC_DESCRIPTOR_TYPE_P (type))
12796 : {
12797 : /* If the backend_decl is not a descriptor, we must have a pointer
12798 : to one. */
12799 1985 : descriptor = build_fold_indirect_ref_loc (input_location,
12800 : sym->backend_decl);
12801 1985 : type = TREE_TYPE (descriptor);
12802 : }
12803 :
12804 : /* NULLIFY the data pointer for non-saved allocatables, or for non-saved
12805 : pointers when -fcheck=pointer is specified. */
12806 28578 : if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save
12807 28565 : && (sym->attr.allocatable
12808 3275 : || (sym->attr.pointer && (gfc_option.rtcheck & GFC_RTCHECK_POINTER))))
12809 : {
12810 8636 : gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node);
12811 8636 : if (flag_coarray == GFC_FCOARRAY_LIB && sym->attr.codimension)
12812 : {
12813 : /* Declare the variable static so its array descriptor stays present
12814 : after leaving the scope. It may still be accessed through another
12815 : image. This may happen, for example, with the caf_mpi
12816 : implementation. */
12817 159 : TREE_STATIC (descriptor) = 1;
12818 159 : tmp = gfc_conv_descriptor_token (descriptor);
12819 159 : gfc_add_modify (&init, tmp, fold_convert (TREE_TYPE (tmp),
12820 : null_pointer_node));
12821 : }
12822 : }
12823 :
12824 : /* Set initial TKR for pointers and allocatables */
12825 16697 : if (GFC_DESCRIPTOR_TYPE_P (type)
12826 16697 : && (sym->attr.pointer || sym->attr.allocatable))
12827 : {
12828 11881 : tree etype;
12829 :
12830 11881 : gcc_assert (sym->as && sym->as->rank>=0);
12831 11881 : tmp = gfc_conv_descriptor_dtype (descriptor);
12832 11881 : etype = gfc_get_element_type (type);
12833 11881 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
12834 11881 : TREE_TYPE (tmp), tmp,
12835 11881 : gfc_get_dtype_rank_type (sym->as->rank, etype));
12836 11881 : gfc_add_expr_to_block (&init, tmp);
12837 : }
12838 16697 : input_location = loc;
12839 16697 : gfc_init_block (&cleanup);
12840 :
12841 : /* Allocatable arrays need to be freed when they go out of scope.
12842 : The allocatable components of pointers must not be touched. */
12843 16697 : if (!sym->attr.allocatable && has_finalizer && sym->ts.type != BT_CLASS
12844 574 : && !sym->attr.pointer && !sym->attr.artificial && !sym->attr.save
12845 303 : && !sym->ns->proc_name->attr.is_main_program)
12846 : {
12847 264 : gfc_expr *e;
12848 264 : sym->attr.referenced = 1;
12849 264 : e = gfc_lval_expr_from_sym (sym);
12850 264 : gfc_add_finalizer_call (&cleanup, e);
12851 264 : gfc_free_expr (e);
12852 264 : }
12853 16433 : else if ((!sym->attr.allocatable || !has_finalizer)
12854 16309 : && sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
12855 4815 : && !sym->attr.pointer && !sym->attr.save
12856 2413 : && !(sym->attr.artificial && sym->name[0] == '_')
12857 2358 : && !sym->ns->proc_name->attr.is_main_program)
12858 : {
12859 650 : int rank;
12860 650 : rank = sym->as ? sym->as->rank : 0;
12861 650 : tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank,
12862 650 : (sym->attr.codimension
12863 3 : && flag_coarray == GFC_FCOARRAY_LIB)
12864 : ? GFC_STRUCTURE_CAF_MODE_IN_COARRAY
12865 : : 0);
12866 650 : gfc_add_expr_to_block (&cleanup, tmp);
12867 : }
12868 :
12869 16697 : if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension)
12870 8600 : && !sym->attr.save && !sym->attr.result
12871 8593 : && !sym->ns->proc_name->attr.is_main_program)
12872 : {
12873 4524 : gfc_expr *e;
12874 4524 : e = has_finalizer ? gfc_lval_expr_from_sym (sym) : NULL;
12875 9048 : tmp = gfc_deallocate_with_status (sym->backend_decl, NULL_TREE, NULL_TREE,
12876 : NULL_TREE, NULL_TREE, true, e,
12877 4524 : sym->attr.codimension
12878 : ? GFC_CAF_COARRAY_DEREGISTER
12879 : : GFC_CAF_COARRAY_NOCOARRAY,
12880 : NULL_TREE, gfc_finish_block (&cleanup));
12881 4524 : if (e)
12882 45 : gfc_free_expr (e);
12883 4524 : gfc_init_block (&cleanup);
12884 4524 : gfc_add_expr_to_block (&cleanup, tmp);
12885 : }
12886 :
12887 16697 : gfc_add_init_cleanup (block, gfc_finish_block (&init),
12888 : gfc_finish_block (&cleanup));
12889 : }
12890 :
12891 : /************ Expression Walking Functions ******************/
12892 :
12893 : /* Walk a variable reference.
12894 :
12895 : Possible extension - multiple component subscripts.
12896 : x(:,:) = foo%a(:)%b(:)
12897 : Transforms to
12898 : forall (i=..., j=...)
12899 : x(i,j) = foo%a(j)%b(i)
12900 : end forall
12901 : This adds a fair amount of complexity because you need to deal with more
12902 : than one ref. Maybe handle in a similar manner to vector subscripts.
12903 : Maybe not worth the effort. */
12904 :
12905 :
12906 : static gfc_ss *
12907 680984 : gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
12908 : {
12909 680984 : gfc_ref *ref;
12910 :
12911 680984 : gfc_fix_class_refs (expr);
12912 :
12913 795067 : for (ref = expr->ref; ref; ref = ref->next)
12914 440958 : if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
12915 : break;
12916 :
12917 680984 : return gfc_walk_array_ref (ss, expr, ref);
12918 : }
12919 :
12920 : gfc_ss *
12921 681341 : gfc_walk_array_ref (gfc_ss *ss, gfc_expr *expr, gfc_ref *ref, bool array_only)
12922 : {
12923 681341 : gfc_array_ref *ar;
12924 681341 : gfc_ss *newss;
12925 681341 : int n;
12926 :
12927 1017748 : for (; ref; ref = ref->next)
12928 : {
12929 336407 : if (ref->type == REF_SUBSTRING)
12930 : {
12931 1314 : ss = gfc_get_scalar_ss (ss, ref->u.ss.start);
12932 1314 : if (ref->u.ss.end)
12933 1288 : ss = gfc_get_scalar_ss (ss, ref->u.ss.end);
12934 : }
12935 :
12936 : /* We're only interested in array sections from now on. */
12937 336407 : if (ref->type != REF_ARRAY
12938 327642 : || (array_only && ref->u.ar.as && ref->u.ar.as->rank == 0))
12939 8876 : continue;
12940 :
12941 327531 : ar = &ref->u.ar;
12942 :
12943 327531 : switch (ar->type)
12944 : {
12945 326 : case AR_ELEMENT:
12946 699 : for (n = ar->dimen - 1; n >= 0; n--)
12947 373 : ss = gfc_get_scalar_ss (ss, ar->start[n]);
12948 : break;
12949 :
12950 271158 : case AR_FULL:
12951 : /* Assumed shape arrays from interface mapping need this fix. */
12952 271158 : if (!ar->as && expr->symtree->n.sym->as)
12953 : {
12954 6 : ar->as = gfc_get_array_spec();
12955 6 : *ar->as = *expr->symtree->n.sym->as;
12956 : }
12957 271158 : newss = gfc_get_array_ss (ss, expr, ar->as->rank, GFC_SS_SECTION);
12958 271158 : newss->info->data.array.ref = ref;
12959 :
12960 : /* Make sure array is the same as array(:,:), this way
12961 : we don't need to special case all the time. */
12962 271158 : ar->dimen = ar->as->rank;
12963 625834 : for (n = 0; n < ar->dimen; n++)
12964 : {
12965 354676 : ar->dimen_type[n] = DIMEN_RANGE;
12966 :
12967 354676 : gcc_assert (ar->start[n] == NULL);
12968 354676 : gcc_assert (ar->end[n] == NULL);
12969 354676 : gcc_assert (ar->stride[n] == NULL);
12970 : }
12971 : ss = newss;
12972 : break;
12973 :
12974 56047 : case AR_SECTION:
12975 56047 : newss = gfc_get_array_ss (ss, expr, 0, GFC_SS_SECTION);
12976 56047 : newss->info->data.array.ref = ref;
12977 :
12978 : /* We add SS chains for all the subscripts in the section. */
12979 144260 : for (n = 0; n < ar->dimen; n++)
12980 : {
12981 88213 : gfc_ss *indexss;
12982 :
12983 88213 : switch (ar->dimen_type[n])
12984 : {
12985 6664 : case DIMEN_ELEMENT:
12986 : /* Add SS for elemental (scalar) subscripts. */
12987 6664 : gcc_assert (ar->start[n]);
12988 6664 : indexss = gfc_get_scalar_ss (gfc_ss_terminator, ar->start[n]);
12989 6664 : indexss->loop_chain = gfc_ss_terminator;
12990 6664 : newss->info->data.array.subscript[n] = indexss;
12991 6664 : break;
12992 :
12993 80509 : case DIMEN_RANGE:
12994 : /* We don't add anything for sections, just remember this
12995 : dimension for later. */
12996 80509 : newss->dim[newss->dimen] = n;
12997 80509 : newss->dimen++;
12998 80509 : break;
12999 :
13000 1040 : case DIMEN_VECTOR:
13001 : /* Create a GFC_SS_VECTOR index in which we can store
13002 : the vector's descriptor. */
13003 1040 : indexss = gfc_get_array_ss (gfc_ss_terminator, ar->start[n],
13004 : 1, GFC_SS_VECTOR);
13005 1040 : indexss->loop_chain = gfc_ss_terminator;
13006 1040 : newss->info->data.array.subscript[n] = indexss;
13007 1040 : newss->dim[newss->dimen] = n;
13008 1040 : newss->dimen++;
13009 1040 : break;
13010 :
13011 0 : default:
13012 : /* We should know what sort of section it is by now. */
13013 0 : gcc_unreachable ();
13014 : }
13015 : }
13016 : /* We should have at least one non-elemental dimension,
13017 : unless we are creating a descriptor for a (scalar) coarray. */
13018 56047 : gcc_assert (newss->dimen > 0
13019 : || newss->info->data.array.ref->u.ar.as->corank > 0);
13020 : ss = newss;
13021 : break;
13022 :
13023 0 : default:
13024 : /* We should know what sort of section it is by now. */
13025 0 : gcc_unreachable ();
13026 : }
13027 :
13028 : }
13029 681341 : return ss;
13030 : }
13031 :
13032 :
13033 : /* Walk an expression operator. If only one operand of a binary expression is
13034 : scalar, we must also add the scalar term to the SS chain. */
13035 :
13036 : static gfc_ss *
13037 56955 : gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
13038 : {
13039 56955 : gfc_ss *head;
13040 56955 : gfc_ss *head2;
13041 :
13042 56955 : head = gfc_walk_subexpr (ss, expr->value.op.op1);
13043 56955 : if (expr->value.op.op2 == NULL)
13044 : head2 = head;
13045 : else
13046 54309 : head2 = gfc_walk_subexpr (head, expr->value.op.op2);
13047 :
13048 : /* All operands are scalar. Pass back and let the caller deal with it. */
13049 56955 : if (head2 == ss)
13050 : return head2;
13051 :
13052 : /* All operands require scalarization. */
13053 51267 : if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
13054 : return head2;
13055 :
13056 : /* One of the operands needs scalarization, the other is scalar.
13057 : Create a gfc_ss for the scalar expression. */
13058 19084 : if (head == ss)
13059 : {
13060 : /* First operand is scalar. We build the chain in reverse order, so
13061 : add the scalar SS after the second operand. */
13062 : head = head2;
13063 2212 : while (head && head->next != ss)
13064 : head = head->next;
13065 : /* Check we haven't somehow broken the chain. */
13066 1969 : gcc_assert (head);
13067 1969 : head->next = gfc_get_scalar_ss (ss, expr->value.op.op1);
13068 : }
13069 : else /* head2 == head */
13070 : {
13071 17115 : gcc_assert (head2 == head);
13072 : /* Second operand is scalar. */
13073 17115 : head2 = gfc_get_scalar_ss (head2, expr->value.op.op2);
13074 : }
13075 :
13076 : return head2;
13077 : }
13078 :
13079 : static gfc_ss *
13080 36 : gfc_walk_conditional_expr (gfc_ss *ss, gfc_expr *expr)
13081 : {
13082 36 : gfc_ss *head;
13083 :
13084 36 : head = gfc_walk_subexpr (ss, expr->value.conditional.true_expr);
13085 36 : head = gfc_walk_subexpr (head, expr->value.conditional.false_expr);
13086 36 : return head;
13087 : }
13088 :
13089 : /* Reverse a SS chain. */
13090 :
13091 : gfc_ss *
13092 856042 : gfc_reverse_ss (gfc_ss * ss)
13093 : {
13094 856042 : gfc_ss *next;
13095 856042 : gfc_ss *head;
13096 :
13097 856042 : gcc_assert (ss != NULL);
13098 :
13099 : head = gfc_ss_terminator;
13100 1291345 : while (ss != gfc_ss_terminator)
13101 : {
13102 435303 : next = ss->next;
13103 : /* Check we didn't somehow break the chain. */
13104 435303 : gcc_assert (next != NULL);
13105 435303 : ss->next = head;
13106 435303 : head = ss;
13107 435303 : ss = next;
13108 : }
13109 :
13110 856042 : return (head);
13111 : }
13112 :
13113 :
13114 : /* Given an expression referring to a procedure, return the symbol of its
13115 : interface. We can't get the procedure symbol directly as we have to handle
13116 : the case of (deferred) type-bound procedures. */
13117 :
13118 : gfc_symbol *
13119 161 : gfc_get_proc_ifc_for_expr (gfc_expr *procedure_ref)
13120 : {
13121 161 : gfc_symbol *sym;
13122 161 : gfc_ref *ref;
13123 :
13124 161 : if (procedure_ref == NULL)
13125 : return NULL;
13126 :
13127 : /* Normal procedure case. */
13128 161 : if (procedure_ref->expr_type == EXPR_FUNCTION
13129 161 : && procedure_ref->value.function.esym)
13130 : sym = procedure_ref->value.function.esym;
13131 : else
13132 24 : sym = procedure_ref->symtree->n.sym;
13133 :
13134 : /* Typebound procedure case. */
13135 209 : for (ref = procedure_ref->ref; ref; ref = ref->next)
13136 : {
13137 48 : if (ref->type == REF_COMPONENT
13138 48 : && ref->u.c.component->attr.proc_pointer)
13139 24 : sym = ref->u.c.component->ts.interface;
13140 : else
13141 : sym = NULL;
13142 : }
13143 :
13144 : return sym;
13145 : }
13146 :
13147 :
13148 : /* Given an expression referring to an intrinsic function call,
13149 : return the intrinsic symbol. */
13150 :
13151 : gfc_intrinsic_sym *
13152 7940 : gfc_get_intrinsic_for_expr (gfc_expr *call)
13153 : {
13154 7940 : if (call == NULL)
13155 : return NULL;
13156 :
13157 : /* Normal procedure case. */
13158 2366 : if (call->expr_type == EXPR_FUNCTION)
13159 2260 : return call->value.function.isym;
13160 : else
13161 : return NULL;
13162 : }
13163 :
13164 :
13165 : /* Indicates whether an argument to an intrinsic function should be used in
13166 : scalarization. It is usually the case, except for some intrinsics
13167 : requiring the value to be constant, and using the value at compile time only.
13168 : As the value is not used at runtime in those cases, we don’t produce code
13169 : for it, and it should not be visible to the scalarizer.
13170 : FUNCTION is the intrinsic function being called, ACTUAL_ARG is the actual
13171 : argument being examined in that call, and ARG_NUM the index number
13172 : of ACTUAL_ARG in the list of arguments.
13173 : The intrinsic procedure’s dummy argument associated with ACTUAL_ARG is
13174 : identified using the name in ACTUAL_ARG if it is present (that is: if it’s
13175 : a keyword argument), otherwise using ARG_NUM. */
13176 :
13177 : static bool
13178 37946 : arg_evaluated_for_scalarization (gfc_intrinsic_sym *function,
13179 : gfc_dummy_arg *dummy_arg)
13180 : {
13181 37946 : if (function != NULL && dummy_arg != NULL)
13182 : {
13183 12443 : switch (function->id)
13184 : {
13185 241 : case GFC_ISYM_INDEX:
13186 241 : case GFC_ISYM_LEN_TRIM:
13187 241 : case GFC_ISYM_MASKL:
13188 241 : case GFC_ISYM_MASKR:
13189 241 : case GFC_ISYM_SCAN:
13190 241 : case GFC_ISYM_VERIFY:
13191 241 : if (strcmp ("kind", gfc_dummy_arg_get_name (*dummy_arg)) == 0)
13192 : return false;
13193 : /* Fallthrough. */
13194 :
13195 : default:
13196 : break;
13197 : }
13198 : }
13199 :
13200 : return true;
13201 : }
13202 :
13203 :
13204 : /* Walk the arguments of an elemental function.
13205 : PROC_EXPR is used to check whether an argument is permitted to be absent. If
13206 : it is NULL, we don't do the check and the argument is assumed to be present.
13207 : */
13208 :
13209 : gfc_ss *
13210 26927 : gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
13211 : gfc_intrinsic_sym *intrinsic_sym,
13212 : gfc_ss_type type)
13213 : {
13214 26927 : int scalar;
13215 26927 : gfc_ss *head;
13216 26927 : gfc_ss *tail;
13217 26927 : gfc_ss *newss;
13218 :
13219 26927 : head = gfc_ss_terminator;
13220 26927 : tail = NULL;
13221 :
13222 26927 : scalar = 1;
13223 66337 : for (; arg; arg = arg->next)
13224 : {
13225 39410 : gfc_dummy_arg * const dummy_arg = arg->associated_dummy;
13226 40907 : if (!arg->expr
13227 38096 : || arg->expr->expr_type == EXPR_NULL
13228 77356 : || !arg_evaluated_for_scalarization (intrinsic_sym, dummy_arg))
13229 1497 : continue;
13230 :
13231 37913 : newss = gfc_walk_subexpr (head, arg->expr);
13232 37913 : if (newss == head)
13233 : {
13234 : /* Scalar argument. */
13235 18574 : gcc_assert (type == GFC_SS_SCALAR || type == GFC_SS_REFERENCE);
13236 18574 : newss = gfc_get_scalar_ss (head, arg->expr);
13237 18574 : newss->info->type = type;
13238 18574 : if (dummy_arg)
13239 15463 : newss->info->data.scalar.dummy_arg = dummy_arg;
13240 : }
13241 : else
13242 : scalar = 0;
13243 :
13244 34802 : if (dummy_arg != NULL
13245 26396 : && gfc_dummy_arg_is_optional (*dummy_arg)
13246 2538 : && arg->expr->expr_type == EXPR_VARIABLE
13247 36506 : && (gfc_expr_attr (arg->expr).optional
13248 1223 : || gfc_expr_attr (arg->expr).allocatable
13249 37860 : || gfc_expr_attr (arg->expr).pointer))
13250 1005 : newss->info->can_be_null_ref = true;
13251 :
13252 37913 : head = newss;
13253 37913 : if (!tail)
13254 : {
13255 : tail = head;
13256 33579 : while (tail->next != gfc_ss_terminator)
13257 : tail = tail->next;
13258 : }
13259 : }
13260 :
13261 26927 : if (scalar)
13262 : {
13263 : /* If all the arguments are scalar we don't need the argument SS. */
13264 10354 : gfc_free_ss_chain (head);
13265 : /* Pass it back. */
13266 10354 : return ss;
13267 : }
13268 :
13269 : /* Add it onto the existing chain. */
13270 16573 : tail->next = ss;
13271 16573 : return head;
13272 : }
13273 :
13274 :
13275 : /* Walk a function call. Scalar functions are passed back, and taken out of
13276 : scalarization loops. For elemental functions we walk their arguments.
13277 : The result of functions returning arrays is stored in a temporary outside
13278 : the loop, so that the function is only called once. Hence we do not need
13279 : to walk their arguments. */
13280 :
13281 : static gfc_ss *
13282 63299 : gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
13283 : {
13284 63299 : gfc_intrinsic_sym *isym;
13285 63299 : gfc_symbol *sym;
13286 63299 : gfc_component *comp = NULL;
13287 :
13288 63299 : isym = expr->value.function.isym;
13289 :
13290 : /* Handle intrinsic functions separately. */
13291 63299 : if (isym)
13292 55583 : return gfc_walk_intrinsic_function (ss, expr, isym);
13293 :
13294 7716 : sym = expr->value.function.esym;
13295 7716 : if (!sym)
13296 546 : sym = expr->symtree->n.sym;
13297 :
13298 7716 : if (gfc_is_class_array_function (expr))
13299 234 : return gfc_get_array_ss (ss, expr,
13300 234 : CLASS_DATA (expr->value.function.esym->result)->as->rank,
13301 234 : GFC_SS_FUNCTION);
13302 :
13303 : /* A function that returns arrays. */
13304 7482 : comp = gfc_get_proc_ptr_comp (expr);
13305 7084 : if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
13306 7482 : || (comp && comp->attr.dimension))
13307 2668 : return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
13308 :
13309 : /* Walk the parameters of an elemental function. For now we always pass
13310 : by reference. */
13311 4814 : if (sym->attr.elemental || (comp && comp->attr.elemental))
13312 : {
13313 2224 : gfc_ss *old_ss = ss;
13314 :
13315 2224 : ss = gfc_walk_elemental_function_args (old_ss,
13316 : expr->value.function.actual,
13317 : gfc_get_intrinsic_for_expr (expr),
13318 : GFC_SS_REFERENCE);
13319 2224 : if (ss != old_ss
13320 1188 : && (comp
13321 1127 : || sym->attr.proc_pointer
13322 1127 : || sym->attr.if_source != IFSRC_DECL
13323 1005 : || sym->attr.array_outer_dependency))
13324 231 : ss->info->array_outer_dependency = 1;
13325 : }
13326 :
13327 : /* Scalar functions are OK as these are evaluated outside the scalarization
13328 : loop. Pass back and let the caller deal with it. */
13329 : return ss;
13330 : }
13331 :
13332 :
13333 : /* An array temporary is constructed for array constructors. */
13334 :
13335 : static gfc_ss *
13336 49936 : gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
13337 : {
13338 0 : return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_CONSTRUCTOR);
13339 : }
13340 :
13341 :
13342 : /* Walk an expression. Add walked expressions to the head of the SS chain.
13343 : A wholly scalar expression will not be added. */
13344 :
13345 : gfc_ss *
13346 1009399 : gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
13347 : {
13348 1009399 : gfc_ss *head;
13349 :
13350 1009399 : switch (expr->expr_type)
13351 : {
13352 680984 : case EXPR_VARIABLE:
13353 680984 : head = gfc_walk_variable_expr (ss, expr);
13354 680984 : return head;
13355 :
13356 56955 : case EXPR_OP:
13357 56955 : head = gfc_walk_op_expr (ss, expr);
13358 56955 : return head;
13359 :
13360 36 : case EXPR_CONDITIONAL:
13361 36 : head = gfc_walk_conditional_expr (ss, expr);
13362 36 : return head;
13363 :
13364 63299 : case EXPR_FUNCTION:
13365 63299 : head = gfc_walk_function_expr (ss, expr);
13366 63299 : return head;
13367 :
13368 : case EXPR_CONSTANT:
13369 : case EXPR_NULL:
13370 : case EXPR_STRUCTURE:
13371 : /* Pass back and let the caller deal with it. */
13372 : break;
13373 :
13374 49936 : case EXPR_ARRAY:
13375 49936 : head = gfc_walk_array_constructor (ss, expr);
13376 49936 : return head;
13377 :
13378 : case EXPR_SUBSTRING:
13379 : /* Pass back and let the caller deal with it. */
13380 : break;
13381 :
13382 0 : default:
13383 0 : gfc_internal_error ("bad expression type during walk (%d)",
13384 : expr->expr_type);
13385 : }
13386 : return ss;
13387 : }
13388 :
13389 :
13390 : /* Entry point for expression walking.
13391 : A return value equal to the passed chain means this is
13392 : a scalar expression. It is up to the caller to take whatever action is
13393 : necessary to translate these. */
13394 :
13395 : gfc_ss *
13396 853235 : gfc_walk_expr (gfc_expr * expr)
13397 : {
13398 853235 : gfc_ss *res;
13399 :
13400 853235 : res = gfc_walk_subexpr (gfc_ss_terminator, expr);
13401 853235 : return gfc_reverse_ss (res);
13402 : }
|
