Branch data Line data Source code
1 : : /* Array translation routines
2 : : Copyright (C) 2002-2025 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 : 57991 : gfc_array_dataptr_type (tree desc)
107 : : {
108 : 57991 : 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 : 1947084 : gfc_get_descriptor_field (tree desc, unsigned field_idx)
248 : : {
249 : 1947084 : tree type = TREE_TYPE (desc);
250 : 1947084 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
251 : :
252 : 1947084 : tree field = gfc_advance_chain (TYPE_FIELDS (type), field_idx);
253 : 1947084 : gcc_assert (field != NULL_TREE);
254 : :
255 : 1947084 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
256 : 1947084 : 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 : 265415 : gfc_conv_descriptor_data_get (tree desc)
264 : : {
265 : 265415 : tree type = TREE_TYPE (desc);
266 : 265415 : if (TREE_CODE (type) == REFERENCE_TYPE)
267 : 0 : gcc_unreachable ();
268 : :
269 : 265415 : tree field = gfc_get_descriptor_field (desc, DATA_FIELD);
270 : 265415 : 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 : 149773 : gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
277 : : {
278 : 149773 : tree field = gfc_get_descriptor_field (desc, DATA_FIELD);
279 : 149773 : gfc_add_modify (block, field, fold_convert (TREE_TYPE (field), value));
280 : 149773 : }
281 : :
282 : :
283 : : static tree
284 : 201379 : gfc_conv_descriptor_offset (tree desc)
285 : : {
286 : 201379 : tree field = gfc_get_descriptor_field (desc, OFFSET_FIELD);
287 : 201379 : gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
288 : 201379 : return field;
289 : : }
290 : :
291 : : tree
292 : 73349 : gfc_conv_descriptor_offset_get (tree desc)
293 : : {
294 : 73349 : return gfc_conv_descriptor_offset (desc);
295 : : }
296 : :
297 : : void
298 : 122134 : gfc_conv_descriptor_offset_set (stmtblock_t *block, tree desc,
299 : : tree value)
300 : : {
301 : 122134 : tree t = gfc_conv_descriptor_offset (desc);
302 : 122134 : gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
303 : 122134 : }
304 : :
305 : :
306 : : tree
307 : 169078 : gfc_conv_descriptor_dtype (tree desc)
308 : : {
309 : 169078 : tree field = gfc_get_descriptor_field (desc, DTYPE_FIELD);
310 : 169078 : gcc_assert (TREE_TYPE (field) == get_dtype_type_node ());
311 : 169078 : return field;
312 : : }
313 : :
314 : : static tree
315 : 151827 : gfc_conv_descriptor_span (tree desc)
316 : : {
317 : 151827 : tree field = gfc_get_descriptor_field (desc, SPAN_FIELD);
318 : 151827 : gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
319 : 151827 : return field;
320 : : }
321 : :
322 : : tree
323 : 33375 : gfc_conv_descriptor_span_get (tree desc)
324 : : {
325 : 33375 : return gfc_conv_descriptor_span (desc);
326 : : }
327 : :
328 : : void
329 : 118452 : gfc_conv_descriptor_span_set (stmtblock_t *block, tree desc,
330 : : tree value)
331 : : {
332 : 118452 : tree t = gfc_conv_descriptor_span (desc);
333 : 118452 : gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
334 : 118452 : }
335 : :
336 : :
337 : : tree
338 : 19488 : gfc_conv_descriptor_rank (tree desc)
339 : : {
340 : 19488 : tree tmp;
341 : 19488 : tree dtype;
342 : :
343 : 19488 : dtype = gfc_conv_descriptor_dtype (desc);
344 : 19488 : tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), GFC_DTYPE_RANK);
345 : 19488 : gcc_assert (tmp != NULL_TREE
346 : : && TREE_TYPE (tmp) == signed_char_type_node);
347 : 19488 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
348 : 19488 : 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 : 8717 : gfc_conv_descriptor_elem_len (tree desc)
371 : : {
372 : 8717 : tree tmp;
373 : 8717 : tree dtype;
374 : :
375 : 8717 : dtype = gfc_conv_descriptor_dtype (desc);
376 : 8717 : tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)),
377 : : GFC_DTYPE_ELEM_LEN);
378 : 8717 : gcc_assert (tmp != NULL_TREE
379 : : && TREE_TYPE (tmp) == size_type_node);
380 : 8717 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
381 : 8717 : 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 : 1007995 : gfc_get_descriptor_dimension (tree desc)
416 : : {
417 : 1007995 : tree field = gfc_get_descriptor_field (desc, DIMENSION_FIELD);
418 : 1007995 : gcc_assert (TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
419 : : && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
420 : 1007995 : return field;
421 : : }
422 : :
423 : :
424 : : static tree
425 : 1004019 : gfc_conv_descriptor_dimension (tree desc, tree dim)
426 : : {
427 : 1004019 : tree tmp;
428 : :
429 : 1004019 : tmp = gfc_get_descriptor_dimension (desc);
430 : :
431 : 1004019 : return gfc_build_array_ref (tmp, dim, NULL_TREE, true);
432 : : }
433 : :
434 : :
435 : : tree
436 : 1617 : gfc_conv_descriptor_token (tree desc)
437 : : {
438 : 1617 : gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
439 : 1617 : tree field = gfc_get_descriptor_field (desc, CAF_TOKEN_FIELD);
440 : : /* Should be a restricted pointer - except in the finalization wrapper. */
441 : 1617 : gcc_assert (TREE_TYPE (field) == prvoid_type_node
442 : : || TREE_TYPE (field) == pvoid_type_node);
443 : 1617 : return field;
444 : : }
445 : :
446 : : static tree
447 : 1004019 : gfc_conv_descriptor_subfield (tree desc, tree dim, unsigned field_idx)
448 : : {
449 : 1004019 : tree tmp = gfc_conv_descriptor_dimension (desc, dim);
450 : 1004019 : tree field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), field_idx);
451 : 1004019 : gcc_assert (field != NULL_TREE);
452 : :
453 : 1004019 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
454 : 1004019 : tmp, field, NULL_TREE);
455 : : }
456 : :
457 : : static tree
458 : 271406 : gfc_conv_descriptor_stride (tree desc, tree dim)
459 : : {
460 : 271406 : tree field = gfc_conv_descriptor_subfield (desc, dim, STRIDE_SUBFIELD);
461 : 271406 : gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
462 : 271406 : return field;
463 : : }
464 : :
465 : : tree
466 : 160598 : gfc_conv_descriptor_stride_get (tree desc, tree dim)
467 : : {
468 : 160598 : tree type = TREE_TYPE (desc);
469 : 160598 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
470 : 160598 : if (integer_zerop (dim)
471 : 160598 : && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
472 : 42260 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT
473 : 41192 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT
474 : 41042 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_ALLOCATABLE
475 : 40892 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_POINTER_CONT
476 : 40892 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
477 : 65490 : return gfc_index_one_node;
478 : :
479 : 95108 : return gfc_conv_descriptor_stride (desc, dim);
480 : : }
481 : :
482 : : void
483 : 176298 : gfc_conv_descriptor_stride_set (stmtblock_t *block, tree desc,
484 : : tree dim, tree value)
485 : : {
486 : 176298 : tree t = gfc_conv_descriptor_stride (desc, dim);
487 : 176298 : gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
488 : 176298 : }
489 : :
490 : : static tree
491 : 380051 : gfc_conv_descriptor_lbound (tree desc, tree dim)
492 : : {
493 : 380051 : tree field = gfc_conv_descriptor_subfield (desc, dim, LBOUND_SUBFIELD);
494 : 380051 : gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
495 : 380051 : return field;
496 : : }
497 : :
498 : : tree
499 : 200010 : gfc_conv_descriptor_lbound_get (tree desc, tree dim)
500 : : {
501 : 200010 : return gfc_conv_descriptor_lbound (desc, dim);
502 : : }
503 : :
504 : : void
505 : 180041 : gfc_conv_descriptor_lbound_set (stmtblock_t *block, tree desc,
506 : : tree dim, tree value)
507 : : {
508 : 180041 : tree t = gfc_conv_descriptor_lbound (desc, dim);
509 : 180041 : gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
510 : 180041 : }
511 : :
512 : : static tree
513 : 352562 : gfc_conv_descriptor_ubound (tree desc, tree dim)
514 : : {
515 : 352562 : tree field = gfc_conv_descriptor_subfield (desc, dim, UBOUND_SUBFIELD);
516 : 352562 : gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
517 : 352562 : return field;
518 : : }
519 : :
520 : : tree
521 : 172420 : gfc_conv_descriptor_ubound_get (tree desc, tree dim)
522 : : {
523 : 172420 : return gfc_conv_descriptor_ubound (desc, dim);
524 : : }
525 : :
526 : : void
527 : 180142 : gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree desc,
528 : : tree dim, tree value)
529 : : {
530 : 180142 : tree t = gfc_conv_descriptor_ubound (desc, dim);
531 : 180142 : gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
532 : 180142 : }
533 : :
534 : : /* Build a null array descriptor constructor. */
535 : :
536 : : tree
537 : 1076 : gfc_build_null_descriptor (tree type)
538 : : {
539 : 1076 : tree field;
540 : 1076 : tree tmp;
541 : :
542 : 1076 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
543 : 1076 : gcc_assert (DATA_FIELD == 0);
544 : 1076 : field = TYPE_FIELDS (type);
545 : :
546 : : /* Set a NULL data pointer. */
547 : 1076 : tmp = build_constructor_single (type, field, null_pointer_node);
548 : 1076 : TREE_CONSTANT (tmp) = 1;
549 : : /* All other fields are ignored. */
550 : :
551 : 1076 : 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 : 923 : gfc_conv_shift_descriptor_lbound (stmtblock_t* block, tree desc,
560 : : int dim, tree new_lbound)
561 : : {
562 : 923 : tree offs, ubound, lbound, stride;
563 : 923 : tree diff, offs_diff;
564 : :
565 : 923 : new_lbound = fold_convert (gfc_array_index_type, new_lbound);
566 : :
567 : 923 : offs = gfc_conv_descriptor_offset_get (desc);
568 : 923 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
569 : 923 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
570 : 923 : stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]);
571 : :
572 : : /* Get difference (new - old) by which to shift stuff. */
573 : 923 : 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 : 923 : ubound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
579 : : ubound, diff);
580 : 923 : gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[dim], ubound);
581 : 923 : offs_diff = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
582 : : diff, stride);
583 : 923 : offs = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
584 : : offs, offs_diff);
585 : 923 : gfc_conv_descriptor_offset_set (block, desc, offs);
586 : :
587 : : /* Finally set lbound to value we want. */
588 : 923 : gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[dim], new_lbound);
589 : 923 : }
590 : :
591 : :
592 : : /* Obtain offsets for trans-types.cc(gfc_get_array_descr_info). */
593 : :
594 : : void
595 : 269613 : 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 : 269613 : tree field;
602 : 269613 : tree type;
603 : :
604 : 269613 : type = TYPE_MAIN_VARIANT (desc_type);
605 : 269613 : field = gfc_advance_chain (TYPE_FIELDS (type), DATA_FIELD);
606 : 269613 : *data_off = byte_position (field);
607 : 269613 : field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
608 : 269613 : *dtype_off = byte_position (field);
609 : 269613 : field = gfc_advance_chain (TYPE_FIELDS (type), SPAN_FIELD);
610 : 269613 : *span_off = byte_position (field);
611 : 269613 : field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
612 : 269613 : *dim_off = byte_position (field);
613 : 269613 : type = TREE_TYPE (TREE_TYPE (field));
614 : 269613 : *dim_size = TYPE_SIZE_UNIT (type);
615 : 269613 : field = gfc_advance_chain (TYPE_FIELDS (type), STRIDE_SUBFIELD);
616 : 269613 : *stride_suboff = byte_position (field);
617 : 269613 : field = gfc_advance_chain (TYPE_FIELDS (type), LBOUND_SUBFIELD);
618 : 269613 : *lower_suboff = byte_position (field);
619 : 269613 : field = gfc_advance_chain (TYPE_FIELDS (type), UBOUND_SUBFIELD);
620 : 269613 : *upper_suboff = byte_position (field);
621 : 269613 : }
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 : 168146 : gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
643 : : {
644 : 395161 : for (; ss != gfc_ss_terminator; ss = ss->next)
645 : 227015 : ss->info->useflags = flags;
646 : 168146 : }
647 : :
648 : :
649 : : /* Free a gfc_ss chain. */
650 : :
651 : : void
652 : 176597 : gfc_free_ss_chain (gfc_ss * ss)
653 : : {
654 : 176597 : gfc_ss *next;
655 : :
656 : 361401 : while (ss != gfc_ss_terminator)
657 : : {
658 : 184804 : gcc_assert (ss != NULL);
659 : 184804 : next = ss->next;
660 : 184804 : gfc_free_ss (ss);
661 : 184804 : ss = next;
662 : : }
663 : 176597 : }
664 : :
665 : :
666 : : static void
667 : 480659 : free_ss_info (gfc_ss_info *ss_info)
668 : : {
669 : 480659 : int n;
670 : :
671 : 480659 : ss_info->refcount--;
672 : 480659 : if (ss_info->refcount > 0)
673 : : return;
674 : :
675 : 475912 : gcc_assert (ss_info->refcount == 0);
676 : :
677 : 475912 : switch (ss_info->type)
678 : : {
679 : : case GFC_SS_SECTION:
680 : 5273088 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
681 : 4943520 : if (ss_info->data.array.subscript[n])
682 : 7300 : gfc_free_ss_chain (ss_info->data.array.subscript[n]);
683 : : break;
684 : :
685 : : default:
686 : : break;
687 : : }
688 : :
689 : 475912 : free (ss_info);
690 : : }
691 : :
692 : :
693 : : /* Free a SS. */
694 : :
695 : : void
696 : 480659 : gfc_free_ss (gfc_ss * ss)
697 : : {
698 : 480659 : free_ss_info (ss->info);
699 : 480659 : free (ss);
700 : 480659 : }
701 : :
702 : :
703 : : /* Creates and initializes an array type gfc_ss struct. */
704 : :
705 : : gfc_ss *
706 : 401698 : gfc_get_array_ss (gfc_ss *next, gfc_expr *expr, int dimen, gfc_ss_type type)
707 : : {
708 : 401698 : gfc_ss *ss;
709 : 401698 : gfc_ss_info *ss_info;
710 : 401698 : int i;
711 : :
712 : 401698 : ss_info = gfc_get_ss_info ();
713 : 401698 : ss_info->refcount++;
714 : 401698 : ss_info->type = type;
715 : 401698 : ss_info->expr = expr;
716 : :
717 : 401698 : ss = gfc_get_ss ();
718 : 401698 : ss->info = ss_info;
719 : 401698 : ss->next = next;
720 : 401698 : ss->dimen = dimen;
721 : 851820 : for (i = 0; i < ss->dimen; i++)
722 : 450122 : ss->dim[i] = i;
723 : :
724 : 401698 : return ss;
725 : : }
726 : :
727 : :
728 : : /* Creates and initializes a temporary type gfc_ss struct. */
729 : :
730 : : gfc_ss *
731 : 11308 : gfc_get_temp_ss (tree type, tree string_length, int dimen)
732 : : {
733 : 11308 : gfc_ss *ss;
734 : 11308 : gfc_ss_info *ss_info;
735 : 11308 : int i;
736 : :
737 : 11308 : ss_info = gfc_get_ss_info ();
738 : 11308 : ss_info->refcount++;
739 : 11308 : ss_info->type = GFC_SS_TEMP;
740 : 11308 : ss_info->string_length = string_length;
741 : 11308 : ss_info->data.temp.type = type;
742 : :
743 : 11308 : ss = gfc_get_ss ();
744 : 11308 : ss->info = ss_info;
745 : 11308 : ss->next = gfc_ss_terminator;
746 : 11308 : ss->dimen = dimen;
747 : 25293 : for (i = 0; i < ss->dimen; i++)
748 : 13985 : ss->dim[i] = i;
749 : :
750 : 11308 : return ss;
751 : : }
752 : :
753 : :
754 : : /* Creates and initializes a scalar type gfc_ss struct. */
755 : :
756 : : gfc_ss *
757 : 64934 : gfc_get_scalar_ss (gfc_ss *next, gfc_expr *expr)
758 : : {
759 : 64934 : gfc_ss *ss;
760 : 64934 : gfc_ss_info *ss_info;
761 : :
762 : 64934 : ss_info = gfc_get_ss_info ();
763 : 64934 : ss_info->refcount++;
764 : 64934 : ss_info->type = GFC_SS_SCALAR;
765 : 64934 : ss_info->expr = expr;
766 : :
767 : 64934 : ss = gfc_get_ss ();
768 : 64934 : ss->info = ss_info;
769 : 64934 : ss->next = next;
770 : :
771 : 64934 : return ss;
772 : : }
773 : :
774 : :
775 : : /* Free all the SS associated with a loop. */
776 : :
777 : : void
778 : 179088 : gfc_cleanup_loop (gfc_loopinfo * loop)
779 : : {
780 : 179088 : gfc_loopinfo *loop_next, **ploop;
781 : 179088 : gfc_ss *ss;
782 : 179088 : gfc_ss *next;
783 : :
784 : 179088 : ss = loop->ss;
785 : 474456 : while (ss != gfc_ss_terminator)
786 : : {
787 : 295368 : gcc_assert (ss != NULL);
788 : 295368 : next = ss->loop_chain;
789 : 295368 : gfc_free_ss (ss);
790 : 295368 : ss = next;
791 : : }
792 : :
793 : : /* Remove reference to self in the parent loop. */
794 : 179088 : 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 : 182452 : 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 : 179088 : }
810 : :
811 : :
812 : : static void
813 : 242706 : set_ss_loop (gfc_ss *ss, gfc_loopinfo *loop)
814 : : {
815 : 242706 : int n;
816 : :
817 : 546765 : for (; ss != gfc_ss_terminator; ss = ss->next)
818 : : {
819 : 304059 : ss->loop = loop;
820 : :
821 : 304059 : if (ss->info->type == GFC_SS_SCALAR
822 : : || ss->info->type == GFC_SS_REFERENCE
823 : 257048 : || ss->info->type == GFC_SS_TEMP)
824 : 58319 : continue;
825 : :
826 : 3931840 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
827 : 3686100 : if (ss->info->data.array.subscript[n] != NULL)
828 : 7079 : set_ss_loop (ss->info->data.array.subscript[n], loop);
829 : : }
830 : 242706 : }
831 : :
832 : :
833 : : /* Associate a SS chain with a loop. */
834 : :
835 : : void
836 : 235627 : gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
837 : : {
838 : 235627 : gfc_ss *ss;
839 : 235627 : gfc_loopinfo *nested_loop;
840 : :
841 : 235627 : if (head == gfc_ss_terminator)
842 : : return;
843 : :
844 : 235627 : set_ss_loop (head, loop);
845 : :
846 : 235627 : ss = head;
847 : 768234 : for (; ss && ss != gfc_ss_terminator; ss = ss->next)
848 : : {
849 : 296980 : 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 : 296980 : if (ss->next == gfc_ss_terminator)
870 : 235627 : ss->loop_chain = loop->ss;
871 : : else
872 : 61353 : ss->loop_chain = ss->next;
873 : : }
874 : 235627 : gcc_assert (ss == gfc_ss_terminator);
875 : 235627 : loop->ss = head;
876 : : }
877 : :
878 : :
879 : : /* Returns true if the expression is an array pointer. */
880 : :
881 : : static bool
882 : 357160 : is_pointer_array (tree expr)
883 : : {
884 : 357160 : if (expr == NULL_TREE
885 : 357160 : || !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr))
886 : 450831 : || GFC_CLASS_TYPE_P (TREE_TYPE (expr)))
887 : : return false;
888 : :
889 : 93671 : if (VAR_P (expr)
890 : 93671 : && GFC_DECL_PTR_ARRAY_P (expr))
891 : : return true;
892 : :
893 : 87328 : if (TREE_CODE (expr) == PARM_DECL
894 : 87328 : && GFC_DECL_PTR_ARRAY_P (expr))
895 : : return true;
896 : :
897 : 87328 : if (INDIRECT_REF_P (expr)
898 : 87328 : && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 0)))
899 : : return true;
900 : :
901 : : /* The field declaration is marked as an pointer array. */
902 : 84900 : if (TREE_CODE (expr) == COMPONENT_REF
903 : 12885 : && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 1))
904 : 87741 : && !GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (expr, 1))))
905 : 2841 : 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 : 359187 : get_CFI_desc (gfc_symbol *sym, gfc_expr *expr,
919 : : tree *desc, gfc_array_ref *ar)
920 : : {
921 : 359187 : tree tmp;
922 : :
923 : 359187 : 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 : 1078 : 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 : 1078 : 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 : 1078 : if (unlimited)
958 : 974 : return gfc_resize_class_size_with_len (NULL,
959 : 487 : TREE_OPERAND (vptr, 0),
960 : 487 : gfc_vptr_size_get (vptr));
961 : : else
962 : 591 : return gfc_vptr_size_get (vptr);
963 : : }
964 : :
965 : :
966 : : /* Return the span of an array. */
967 : :
968 : : tree
969 : 57136 : gfc_get_array_span (tree desc, gfc_expr *expr)
970 : : {
971 : 57136 : tree tmp;
972 : 57136 : gfc_symbol *sym = (expr && expr->expr_type == EXPR_VARIABLE) ?
973 : 50530 : expr->symtree->n.sym : NULL;
974 : :
975 : 57136 : if (is_pointer_array (desc)
976 : 57136 : || (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 : 557 : 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 : 557 : tmp = gfc_conv_descriptor_span_get (desc);
986 : : }
987 : 56579 : 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 : 56452 : else if (TREE_CODE (desc) == COMPONENT_REF
996 : 481 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
997 : 56577 : && 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 : 56396 : else if (sym && sym->ts.type == BT_CLASS
1002 : 1063 : && expr->ref->type == REF_COMPONENT
1003 : 1063 : && expr->ref->next->type == REF_ARRAY
1004 : 1063 : && expr->ref->next->next == NULL
1005 : 1045 : && CLASS_DATA (sym)->attr.dimension)
1006 : : /* Having escaped the above, this can only be a class array dummy. */
1007 : 1022 : tmp = class_array_element_size (sym->backend_decl,
1008 : 1022 : 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 : 55374 : tmp = gfc_get_element_type (TREE_TYPE (desc));
1015 : 55374 : if (tmp && TREE_CODE (tmp) == ARRAY_TYPE && TYPE_STRING_FLAG (tmp))
1016 : : {
1017 : 10980 : gcc_assert (expr->ts.type == BT_CHARACTER);
1018 : :
1019 : 10980 : tmp = gfc_get_character_len_in_bytes (tmp);
1020 : :
1021 : 10980 : 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 : 21880 : tmp = (tmp && !integer_zerop (tmp))
1033 : 21880 : ? (fold_convert (gfc_array_index_type, tmp)) : (NULL_TREE);
1034 : : }
1035 : : else
1036 : 44394 : tmp = fold_convert (gfc_array_index_type,
1037 : : size_in_bytes (tmp));
1038 : : }
1039 : 57136 : return tmp;
1040 : : }
1041 : :
1042 : :
1043 : : /* Generate an initializer for a static pointer or allocatable array. */
1044 : :
1045 : : void
1046 : 274 : gfc_trans_static_array_pointer (gfc_symbol * sym)
1047 : : {
1048 : 274 : tree type;
1049 : :
1050 : 274 : gcc_assert (TREE_STATIC (sym->backend_decl));
1051 : : /* Just zero the data member. */
1052 : 274 : type = TREE_TYPE (sym->backend_decl);
1053 : 274 : DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
1054 : 274 : }
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 : 8537 : gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
1065 : : gfc_se * se, gfc_array_spec * as)
1066 : : {
1067 : 8537 : int n, dim, total_dim;
1068 : 8537 : gfc_se tmpse;
1069 : 8537 : gfc_ss *ss;
1070 : 8537 : tree lower;
1071 : 8537 : tree upper;
1072 : 8537 : tree tmp;
1073 : :
1074 : 8537 : total_dim = 0;
1075 : :
1076 : 8537 : if (!as || as->type != AS_EXPLICIT)
1077 : 7419 : return;
1078 : :
1079 : 2261 : for (ss = se->ss; ss; ss = ss->parent)
1080 : : {
1081 : 1143 : total_dim += ss->loop->dimen;
1082 : 2641 : for (n = 0; n < ss->loop->dimen; n++)
1083 : : {
1084 : : /* The bound is known, nothing to do. */
1085 : 1498 : if (ss->loop->to[n] != NULL_TREE)
1086 : 485 : continue;
1087 : :
1088 : 1013 : dim = ss->dim[n];
1089 : 1013 : gcc_assert (dim < as->rank);
1090 : 1013 : gcc_assert (ss->loop->dimen <= as->rank);
1091 : :
1092 : : /* Evaluate the lower bound. */
1093 : 1013 : gfc_init_se (&tmpse, NULL);
1094 : 1013 : gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
1095 : 1013 : gfc_add_block_to_block (&se->pre, &tmpse.pre);
1096 : 1013 : gfc_add_block_to_block (&se->post, &tmpse.post);
1097 : 1013 : lower = fold_convert (gfc_array_index_type, tmpse.expr);
1098 : :
1099 : : /* ...and the upper bound. */
1100 : 1013 : gfc_init_se (&tmpse, NULL);
1101 : 1013 : gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
1102 : 1013 : gfc_add_block_to_block (&se->pre, &tmpse.pre);
1103 : 1013 : gfc_add_block_to_block (&se->post, &tmpse.post);
1104 : 1013 : upper = fold_convert (gfc_array_index_type, tmpse.expr);
1105 : :
1106 : : /* Set the upper bound of the loop to UPPER - LOWER. */
1107 : 1013 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
1108 : : gfc_array_index_type, upper, lower);
1109 : 1013 : tmp = gfc_evaluate_now (tmp, &se->pre);
1110 : 1013 : ss->loop->to[n] = tmp;
1111 : : }
1112 : : }
1113 : :
1114 : 1118 : 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 : 28099 : 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 : 28099 : tree tmp;
1136 : 28099 : tree desc;
1137 : 28099 : bool onstack;
1138 : :
1139 : 28099 : desc = info->descriptor;
1140 : 28099 : info->offset = gfc_index_zero_node;
1141 : 28099 : if (size == NULL_TREE || (dynamic && integer_zerop (size)))
1142 : : {
1143 : : /* A callee allocated array. */
1144 : 2701 : gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
1145 : 2701 : onstack = false;
1146 : : }
1147 : : else
1148 : : {
1149 : : /* Allocate the temporary. */
1150 : 50796 : onstack = !dynamic && initial == NULL_TREE
1151 : 25398 : && (flag_stack_arrays
1152 : 25065 : || gfc_can_put_var_on_stack (size));
1153 : :
1154 : 25398 : if (onstack)
1155 : : {
1156 : : /* Make a temporary variable to hold the data. */
1157 : 20571 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (nelem),
1158 : : nelem, gfc_index_one_node);
1159 : 20571 : tmp = gfc_evaluate_now (tmp, pre);
1160 : 20571 : tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
1161 : : tmp);
1162 : 20571 : tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
1163 : : tmp);
1164 : 20571 : 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 : 20571 : 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 : 20571 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1173 : 20571 : gfc_conv_descriptor_data_set (pre, desc, tmp);
1174 : : }
1175 : : else
1176 : : {
1177 : : /* Allocate memory to hold the data or call internal_pack. */
1178 : 4827 : if (initial == NULL_TREE)
1179 : : {
1180 : 4726 : tmp = gfc_call_malloc (pre, NULL, size);
1181 : 4726 : tmp = gfc_evaluate_now (tmp, pre);
1182 : : }
1183 : : else
1184 : : {
1185 : 101 : tree packed;
1186 : 101 : tree source_data;
1187 : 101 : tree was_packed;
1188 : 101 : stmtblock_t do_copying;
1189 : :
1190 : 101 : tmp = TREE_TYPE (initial); /* Pointer to descriptor. */
1191 : 101 : gcc_assert (TREE_CODE (tmp) == POINTER_TYPE);
1192 : 101 : tmp = TREE_TYPE (tmp); /* The descriptor itself. */
1193 : 101 : tmp = gfc_get_element_type (tmp);
1194 : 101 : packed = gfc_create_var (build_pointer_type (tmp), "data");
1195 : :
1196 : 101 : tmp = build_call_expr_loc (input_location,
1197 : : gfor_fndecl_in_pack, 1, initial);
1198 : 101 : tmp = fold_convert (TREE_TYPE (packed), tmp);
1199 : 101 : gfc_add_modify (pre, packed, tmp);
1200 : :
1201 : 101 : tmp = build_fold_indirect_ref_loc (input_location,
1202 : : initial);
1203 : 101 : source_data = gfc_conv_descriptor_data_get (tmp);
1204 : :
1205 : : /* internal_pack may return source->data without any allocation
1206 : : or copying if it is already packed. If that's the case, we
1207 : : need to allocate and copy manually. */
1208 : :
1209 : 101 : gfc_start_block (&do_copying);
1210 : 101 : tmp = gfc_call_malloc (&do_copying, NULL, size);
1211 : 101 : tmp = fold_convert (TREE_TYPE (packed), tmp);
1212 : 101 : gfc_add_modify (&do_copying, packed, tmp);
1213 : 101 : tmp = gfc_build_memcpy_call (packed, source_data, size);
1214 : 101 : gfc_add_expr_to_block (&do_copying, tmp);
1215 : :
1216 : 101 : was_packed = fold_build2_loc (input_location, EQ_EXPR,
1217 : : logical_type_node, packed,
1218 : : source_data);
1219 : 101 : tmp = gfc_finish_block (&do_copying);
1220 : 101 : tmp = build3_v (COND_EXPR, was_packed, tmp,
1221 : : build_empty_stmt (input_location));
1222 : 101 : gfc_add_expr_to_block (pre, tmp);
1223 : :
1224 : 101 : tmp = fold_convert (pvoid_type_node, packed);
1225 : : }
1226 : :
1227 : 4827 : gfc_conv_descriptor_data_set (pre, desc, tmp);
1228 : : }
1229 : : }
1230 : 28099 : 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 : 28099 : gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node);
1235 : :
1236 : 28099 : if (dealloc && !onstack)
1237 : : {
1238 : : /* Free the temporary. */
1239 : 7288 : tmp = gfc_conv_descriptor_data_get (desc);
1240 : 7288 : tmp = gfc_call_free (tmp);
1241 : 7288 : gfc_add_expr_to_block (post, tmp);
1242 : : }
1243 : 28099 : }
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 : 257623 : get_scalarizer_dim_for_array_dim (gfc_ss *ss, int array_dim)
1262 : : {
1263 : 257623 : int array_ref_dim;
1264 : 257623 : int n;
1265 : :
1266 : 257623 : array_ref_dim = 0;
1267 : :
1268 : 521379 : for (; ss; ss = ss->parent)
1269 : 680840 : for (n = 0; n < ss->dimen; n++)
1270 : 417084 : if (ss->dim[n] < array_dim)
1271 : 77060 : array_ref_dim++;
1272 : :
1273 : 257623 : return array_ref_dim;
1274 : : }
1275 : :
1276 : :
1277 : : static gfc_ss *
1278 : 217086 : innermost_ss (gfc_ss *ss)
1279 : : {
1280 : 398361 : while (ss->nested_ss != NULL)
1281 : : ss = ss->nested_ss;
1282 : :
1283 : 390153 : 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 : 217086 : get_array_ref_dim_for_loop_dim (gfc_ss *ss, int loop_dim)
1296 : : {
1297 : 217086 : return get_scalarizer_dim_for_array_dim (innermost_ss (ss),
1298 : 217086 : ss->dim[loop_dim]);
1299 : : }
1300 : :
1301 : :
1302 : : /* Use the information in the ss to obtain the required information about
1303 : : the type and size of an array temporary, when the lhs in an assignment
1304 : : is a class expression. */
1305 : :
1306 : : static tree
1307 : 309 : get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype,
1308 : : gfc_ss **fcnss)
1309 : : {
1310 : 309 : gfc_ss *loop_ss = ss->loop->ss;
1311 : 309 : gfc_ss *lhs_ss;
1312 : 309 : gfc_ss *rhs_ss;
1313 : 309 : gfc_ss *fcn_ss = NULL;
1314 : 309 : tree tmp;
1315 : 309 : tree tmp2;
1316 : 309 : tree vptr;
1317 : 309 : tree class_expr = NULL_TREE;
1318 : 309 : tree lhs_class_expr = NULL_TREE;
1319 : 309 : bool unlimited_rhs = false;
1320 : 309 : bool unlimited_lhs = false;
1321 : 309 : bool rhs_function = false;
1322 : 309 : bool unlimited_arg1 = false;
1323 : 309 : gfc_symbol *vtab;
1324 : 309 : tree cntnr = NULL_TREE;
1325 : :
1326 : : /* The second element in the loop chain contains the source for the
1327 : : class temporary created in gfc_trans_create_temp_array. */
1328 : 309 : rhs_ss = loop_ss->loop_chain;
1329 : :
1330 : 309 : if (rhs_ss != gfc_ss_terminator
1331 : 285 : && rhs_ss->info
1332 : 285 : && rhs_ss->info->expr
1333 : 285 : && rhs_ss->info->expr->ts.type == BT_CLASS
1334 : 170 : && rhs_ss->info->data.array.descriptor)
1335 : : {
1336 : 158 : if (rhs_ss->info->expr->expr_type != EXPR_VARIABLE)
1337 : 56 : class_expr
1338 : 56 : = gfc_get_class_from_expr (rhs_ss->info->data.array.descriptor);
1339 : : else
1340 : 102 : class_expr = gfc_get_class_from_gfc_expr (rhs_ss->info->expr);
1341 : 158 : unlimited_rhs = UNLIMITED_POLY (rhs_ss->info->expr);
1342 : 158 : if (rhs_ss->info->expr->expr_type == EXPR_FUNCTION)
1343 : : rhs_function = true;
1344 : : }
1345 : :
1346 : : /* Usually, ss points to the function. When the function call is an actual
1347 : : argument, it is instead rhs_ss because the ss chain is shifted by one. */
1348 : 309 : *fcnss = fcn_ss = rhs_function ? rhs_ss : ss;
1349 : :
1350 : : /* If this is a transformational function with a class result, the info
1351 : : class_container field points to the class container of arg1. */
1352 : 309 : if (class_expr != NULL_TREE
1353 : 139 : && fcn_ss->info && fcn_ss->info->expr
1354 : 91 : && fcn_ss->info->expr->expr_type == EXPR_FUNCTION
1355 : 91 : && fcn_ss->info->expr->value.function.isym
1356 : 60 : && fcn_ss->info->expr->value.function.isym->transformational)
1357 : : {
1358 : 60 : cntnr = ss->info->class_container;
1359 : 60 : unlimited_arg1
1360 : 60 : = UNLIMITED_POLY (fcn_ss->info->expr->value.function.actual->expr);
1361 : : }
1362 : :
1363 : : /* For an assignment the lhs is the next element in the loop chain.
1364 : : If we have a class rhs, this had better be a class variable
1365 : : expression! Otherwise, the class container from arg1 can be used
1366 : : to set the vptr and len fields of the result class container. */
1367 : 309 : lhs_ss = rhs_ss->loop_chain;
1368 : 309 : if (lhs_ss && lhs_ss != gfc_ss_terminator
1369 : 219 : && lhs_ss->info && lhs_ss->info->expr
1370 : 219 : && lhs_ss->info->expr->expr_type ==EXPR_VARIABLE
1371 : 219 : && lhs_ss->info->expr->ts.type == BT_CLASS)
1372 : : {
1373 : 219 : tmp = lhs_ss->info->data.array.descriptor;
1374 : 219 : unlimited_lhs = UNLIMITED_POLY (rhs_ss->info->expr);
1375 : : }
1376 : 90 : else if (cntnr != NULL_TREE)
1377 : : {
1378 : 54 : tmp = gfc_class_vptr_get (class_expr);
1379 : 54 : gfc_add_modify (pre, tmp, fold_convert (TREE_TYPE (tmp),
1380 : : gfc_class_vptr_get (cntnr)));
1381 : 54 : if (unlimited_rhs)
1382 : : {
1383 : 6 : tmp = gfc_class_len_get (class_expr);
1384 : 6 : if (unlimited_arg1)
1385 : 6 : gfc_add_modify (pre, tmp, gfc_class_len_get (cntnr));
1386 : : }
1387 : : tmp = NULL_TREE;
1388 : : }
1389 : : else
1390 : : tmp = NULL_TREE;
1391 : :
1392 : : /* Get the lhs class expression. */
1393 : 219 : if (tmp != NULL_TREE && lhs_ss->loop_chain == gfc_ss_terminator)
1394 : 207 : lhs_class_expr = gfc_get_class_from_expr (tmp);
1395 : : else
1396 : 102 : return class_expr;
1397 : :
1398 : 207 : gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (lhs_class_expr)));
1399 : :
1400 : : /* Set the lhs vptr and, if necessary, the _len field. */
1401 : 207 : if (class_expr)
1402 : : {
1403 : : /* Both lhs and rhs are class expressions. */
1404 : 79 : tmp = gfc_class_vptr_get (lhs_class_expr);
1405 : 158 : gfc_add_modify (pre, tmp,
1406 : 79 : fold_convert (TREE_TYPE (tmp),
1407 : : gfc_class_vptr_get (class_expr)));
1408 : 79 : if (unlimited_lhs)
1409 : : {
1410 : 31 : gcc_assert (unlimited_rhs);
1411 : 31 : tmp = gfc_class_len_get (lhs_class_expr);
1412 : 31 : tmp2 = gfc_class_len_get (class_expr);
1413 : 31 : gfc_add_modify (pre, tmp, tmp2);
1414 : : }
1415 : : }
1416 : 128 : else if (rhs_ss->info->data.array.descriptor)
1417 : : {
1418 : : /* lhs is class and rhs is intrinsic or derived type. */
1419 : 122 : *eltype = TREE_TYPE (rhs_ss->info->data.array.descriptor);
1420 : 122 : *eltype = gfc_get_element_type (*eltype);
1421 : 122 : vtab = gfc_find_vtab (&rhs_ss->info->expr->ts);
1422 : 122 : vptr = vtab->backend_decl;
1423 : 122 : if (vptr == NULL_TREE)
1424 : 24 : vptr = gfc_get_symbol_decl (vtab);
1425 : 122 : vptr = gfc_build_addr_expr (NULL_TREE, vptr);
1426 : 122 : tmp = gfc_class_vptr_get (lhs_class_expr);
1427 : 122 : gfc_add_modify (pre, tmp,
1428 : 122 : fold_convert (TREE_TYPE (tmp), vptr));
1429 : :
1430 : 122 : if (unlimited_lhs)
1431 : : {
1432 : 0 : tmp = gfc_class_len_get (lhs_class_expr);
1433 : 0 : if (rhs_ss->info
1434 : 0 : && rhs_ss->info->expr
1435 : 0 : && rhs_ss->info->expr->ts.type == BT_CHARACTER)
1436 : 0 : tmp2 = build_int_cst (TREE_TYPE (tmp),
1437 : 0 : rhs_ss->info->expr->ts.kind);
1438 : : else
1439 : 0 : tmp2 = build_int_cst (TREE_TYPE (tmp), 0);
1440 : 0 : gfc_add_modify (pre, tmp, tmp2);
1441 : : }
1442 : : }
1443 : :
1444 : : return class_expr;
1445 : : }
1446 : :
1447 : :
1448 : :
1449 : : /* Generate code to create and initialize the descriptor for a temporary
1450 : : array. This is used for both temporaries needed by the scalarizer, and
1451 : : functions returning arrays. Adjusts the loop variables to be
1452 : : zero-based, and calculates the loop bounds for callee allocated arrays.
1453 : : Allocate the array unless it's callee allocated (we have a callee
1454 : : allocated array if 'callee_alloc' is true, or if loop->to[n] is
1455 : : NULL_TREE for any n). Also fills in the descriptor, data and offset
1456 : : fields of info if known. Returns the size of the array, or NULL for a
1457 : : callee allocated array.
1458 : :
1459 : : 'eltype' == NULL signals that the temporary should be a class object.
1460 : : The 'initial' expression is used to obtain the size of the dynamic
1461 : : type; otherwise the allocation and initialization proceeds as for any
1462 : : other expression
1463 : :
1464 : : PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
1465 : : gfc_trans_allocate_array_storage. */
1466 : :
1467 : : tree
1468 : 28099 : 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 : 28099 : gfc_loopinfo *loop;
1473 : 28099 : gfc_ss *s;
1474 : 28099 : gfc_array_info *info;
1475 : 28099 : tree from[GFC_MAX_DIMENSIONS], to[GFC_MAX_DIMENSIONS];
1476 : 28099 : tree type;
1477 : 28099 : tree desc;
1478 : 28099 : tree tmp;
1479 : 28099 : tree size;
1480 : 28099 : tree nelem;
1481 : 28099 : tree cond;
1482 : 28099 : tree or_expr;
1483 : 28099 : tree elemsize;
1484 : 28099 : tree class_expr = NULL_TREE;
1485 : 28099 : gfc_ss *fcn_ss = NULL;
1486 : 28099 : int n, dim, tmp_dim;
1487 : 28099 : 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 : 28099 : if (eltype == NULL_TREE && initial)
1492 : : {
1493 : 6 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial)));
1494 : 6 : class_expr = build_fold_indirect_ref_loc (input_location, initial);
1495 : : /* Obtain the structure (class) expression. */
1496 : 6 : class_expr = gfc_get_class_from_expr (class_expr);
1497 : 6 : gcc_assert (class_expr);
1498 : : }
1499 : :
1500 : : /* Otherwise, some expressions, such as class functions, arising from
1501 : : dependency checking in assignments come here with class element type.
1502 : : The descriptor can be obtained from the ss->info and then converted
1503 : : to the class object. */
1504 : 28093 : if (class_expr == NULL_TREE && GFC_CLASS_TYPE_P (eltype))
1505 : 309 : class_expr = get_class_info_from_ss (pre, ss, &eltype, &fcn_ss);
1506 : :
1507 : : /* If the dynamic type is not available, use the declared type. */
1508 : 28099 : if (eltype && GFC_CLASS_TYPE_P (eltype))
1509 : 187 : eltype = gfc_get_element_type (TREE_TYPE (TYPE_FIELDS (eltype)));
1510 : :
1511 : 28099 : if (class_expr == NULL_TREE)
1512 : 27954 : elemsize = fold_convert (gfc_array_index_type,
1513 : : TYPE_SIZE_UNIT (eltype));
1514 : : else
1515 : : {
1516 : : /* Unlimited polymorphic entities are initialised with NULL vptr. They
1517 : : can be tested for by checking if the len field is present. If so
1518 : : test the vptr before using the vtable size. */
1519 : 145 : tmp = gfc_class_vptr_get (class_expr);
1520 : 145 : tmp = fold_build2_loc (input_location, NE_EXPR,
1521 : : logical_type_node,
1522 : 145 : tmp, build_int_cst (TREE_TYPE (tmp), 0));
1523 : 145 : elemsize = fold_build3_loc (input_location, COND_EXPR,
1524 : : gfc_array_index_type,
1525 : : tmp,
1526 : : gfc_class_vtab_size_get (class_expr),
1527 : : gfc_index_zero_node);
1528 : 145 : elemsize = gfc_evaluate_now (elemsize, pre);
1529 : 145 : elemsize = gfc_resize_class_size_with_len (pre, class_expr, elemsize);
1530 : : /* Casting the data as a character of the dynamic length ensures that
1531 : : assignment of elements works when needed. */
1532 : 145 : eltype = gfc_get_character_type_len (1, elemsize);
1533 : : }
1534 : :
1535 : 28099 : memset (from, 0, sizeof (from));
1536 : 28099 : memset (to, 0, sizeof (to));
1537 : :
1538 : 28099 : info = &ss->info->data.array;
1539 : :
1540 : 28099 : gcc_assert (ss->dimen > 0);
1541 : 28099 : gcc_assert (ss->loop->dimen == ss->dimen);
1542 : :
1543 : 28099 : if (warn_array_temporaries && where)
1544 : 205 : gfc_warning (OPT_Warray_temporaries,
1545 : : "Creating array temporary at %L", where);
1546 : :
1547 : : /* Set the lower bound to zero. */
1548 : 56233 : for (s = ss; s; s = s->parent)
1549 : : {
1550 : 28134 : loop = s->loop;
1551 : :
1552 : 28134 : total_dim += loop->dimen;
1553 : 65420 : for (n = 0; n < loop->dimen; n++)
1554 : : {
1555 : 37286 : dim = s->dim[n];
1556 : :
1557 : : /* Callee allocated arrays may not have a known bound yet. */
1558 : 37286 : if (loop->to[n])
1559 : 34040 : 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 : 37286 : 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 : 37286 : 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 : 37286 : tmp_dim = get_scalarizer_dim_for_array_dim (ss, dim);
1578 : 37286 : from[tmp_dim] = loop->from[n];
1579 : 37286 : to[tmp_dim] = loop->to[n];
1580 : :
1581 : 37286 : info->delta[dim] = gfc_index_zero_node;
1582 : 37286 : info->start[dim] = gfc_index_zero_node;
1583 : 37286 : info->end[dim] = gfc_index_zero_node;
1584 : 37286 : info->stride[dim] = gfc_index_one_node;
1585 : : }
1586 : : }
1587 : :
1588 : : /* Initialize the descriptor. */
1589 : 28099 : type =
1590 : 28099 : gfc_get_array_type_bounds (eltype, total_dim, 0, from, to, 1,
1591 : : GFC_ARRAY_UNKNOWN, true);
1592 : 28099 : desc = gfc_create_var (type, "atmp");
1593 : 28099 : 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 : 28099 : tree arraytype = TREE_TYPE (GFC_TYPE_ARRAY_DATAPTR_TYPE (type));
1599 : 28099 : if (! TYPE_NAME (arraytype))
1600 : 28099 : TYPE_NAME (arraytype) = build_decl (UNKNOWN_LOCATION, TYPE_DECL,
1601 : : NULL_TREE, arraytype);
1602 : 28099 : gfc_add_expr_to_block (pre, build1 (DECL_EXPR,
1603 : 28099 : arraytype, TYPE_NAME (arraytype)));
1604 : :
1605 : 28099 : 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 : 28099 : if (class_expr != NULL_TREE
1612 : 27954 : || (fcn_ss && fcn_ss->info && fcn_ss->info->class_container))
1613 : : {
1614 : 175 : tree class_data;
1615 : 175 : tree dtype;
1616 : 175 : gfc_expr *expr1 = fcn_ss ? fcn_ss->info->expr : NULL;
1617 : 169 : bool rank_changer;
1618 : :
1619 : : /* Pick out these transformational functions because they change the rank
1620 : : or shape of the first argument. This requires that the class type be
1621 : : changed, the dtype updated and the correct rank used. */
1622 : 121 : rank_changer = expr1 && expr1->expr_type == EXPR_FUNCTION
1623 : 121 : && expr1->value.function.isym
1624 : 259 : && (expr1->value.function.isym->id == GFC_ISYM_RESHAPE
1625 : : || expr1->value.function.isym->id == GFC_ISYM_SPREAD
1626 : : || expr1->value.function.isym->id == GFC_ISYM_PACK
1627 : : || expr1->value.function.isym->id == GFC_ISYM_UNPACK);
1628 : :
1629 : : /* Create a class temporary for the result using the lhs class object. */
1630 : 175 : if (class_expr != NULL_TREE && !rank_changer)
1631 : : {
1632 : 97 : tmp = gfc_create_var (TREE_TYPE (class_expr), "ctmp");
1633 : 97 : gfc_add_modify (pre, tmp, class_expr);
1634 : : }
1635 : : else
1636 : : {
1637 : 78 : tree vptr;
1638 : 78 : class_expr = fcn_ss->info->class_container;
1639 : 78 : gcc_assert (expr1);
1640 : :
1641 : : /* Build a new class container using the arg1 class object. The class
1642 : : typespec must be rebuilt because the rank might have changed. */
1643 : 78 : gfc_typespec ts = CLASS_DATA (expr1)->ts;
1644 : 78 : symbol_attribute attr = CLASS_DATA (expr1)->attr;
1645 : 78 : gfc_change_class (&ts, &attr, NULL, expr1->rank, 0);
1646 : 78 : tmp = gfc_create_var (gfc_typenode_for_spec (&ts), "ctmp");
1647 : 78 : fcn_ss->info->class_container = tmp;
1648 : :
1649 : : /* Set the vptr and obtain the element size. */
1650 : 78 : vptr = gfc_class_vptr_get (tmp);
1651 : 156 : gfc_add_modify (pre, vptr,
1652 : 78 : fold_convert (TREE_TYPE (vptr),
1653 : : gfc_class_vptr_get (class_expr)));
1654 : 78 : elemsize = gfc_class_vtab_size_get (class_expr);
1655 : :
1656 : : /* Set the _len field, if necessary. */
1657 : 78 : if (UNLIMITED_POLY (expr1))
1658 : : {
1659 : 18 : gfc_add_modify (pre, gfc_class_len_get (tmp),
1660 : : gfc_class_len_get (class_expr));
1661 : 18 : elemsize = gfc_resize_class_size_with_len (pre, class_expr,
1662 : : elemsize);
1663 : : }
1664 : :
1665 : 78 : elemsize = gfc_evaluate_now (elemsize, pre);
1666 : : }
1667 : :
1668 : 175 : class_data = gfc_class_data_get (tmp);
1669 : :
1670 : 175 : if (rank_changer)
1671 : : {
1672 : : /* Take the dtype from the class expression. */
1673 : 72 : dtype = gfc_conv_descriptor_dtype (gfc_class_data_get (class_expr));
1674 : 72 : tmp = gfc_conv_descriptor_dtype (desc);
1675 : 72 : gfc_add_modify (pre, tmp, dtype);
1676 : :
1677 : : /* These transformational functions change the rank. */
1678 : 72 : tmp = gfc_conv_descriptor_rank (desc);
1679 : 72 : gfc_add_modify (pre, tmp,
1680 : 72 : build_int_cst (TREE_TYPE (tmp), ss->loop->dimen));
1681 : 72 : fcn_ss->info->class_container = NULL_TREE;
1682 : : }
1683 : :
1684 : : /* Assign the new descriptor to the _data field. This allows the
1685 : : vptr _copy to be used for scalarized assignment since the class
1686 : : temporary can be found from the descriptor. */
1687 : 175 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1688 : 175 : TREE_TYPE (desc), desc);
1689 : 175 : gfc_add_modify (pre, class_data, tmp);
1690 : :
1691 : : /* Point desc to the class _data field. */
1692 : 175 : desc = class_data;
1693 : 175 : }
1694 : : else
1695 : : {
1696 : : /* Fill in the array dtype. */
1697 : 27924 : tmp = gfc_conv_descriptor_dtype (desc);
1698 : 27924 : gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
1699 : : }
1700 : :
1701 : 28099 : info->descriptor = desc;
1702 : 28099 : 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 : 28099 : or_expr = NULL_TREE;
1718 : :
1719 : : /* If there is at least one null loop->to[n], it is a callee allocated
1720 : : array. */
1721 : 62139 : for (n = 0; n < total_dim; n++)
1722 : 35942 : if (to[n] == NULL_TREE)
1723 : : {
1724 : : size = NULL_TREE;
1725 : : break;
1726 : : }
1727 : :
1728 : 28099 : if (size == NULL_TREE)
1729 : 3814 : for (s = ss; s; s = s->parent)
1730 : 5163 : for (n = 0; n < s->loop->dimen; n++)
1731 : : {
1732 : 3251 : 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 : 3251 : 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 : 3251 : s->loop->to[n] = tmp;
1741 : : }
1742 : : else
1743 : : {
1744 : 60232 : for (n = 0; n < total_dim; n++)
1745 : : {
1746 : : /* Store the stride and bound components in the descriptor. */
1747 : 34035 : gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size);
1748 : :
1749 : 34035 : gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
1750 : : gfc_index_zero_node);
1751 : :
1752 : 34035 : gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], to[n]);
1753 : :
1754 : 34035 : 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 : 34035 : cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
1760 : : tmp, gfc_index_zero_node);
1761 : 34035 : cond = gfc_evaluate_now (cond, pre);
1762 : :
1763 : 34035 : if (n == 0)
1764 : : or_expr = cond;
1765 : : else
1766 : 7838 : or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1767 : : logical_type_node, or_expr, cond);
1768 : :
1769 : 34035 : size = fold_build2_loc (input_location, MULT_EXPR,
1770 : : gfc_array_index_type, size, tmp);
1771 : 34035 : size = gfc_evaluate_now (size, pre);
1772 : : }
1773 : : }
1774 : :
1775 : : /* Get the size of the array. */
1776 : 28099 : 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 : 26007 : size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
1781 : : or_expr, gfc_index_zero_node, size);
1782 : :
1783 : 26007 : nelem = size;
1784 : 26007 : 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 : 28099 : tmp = fold_convert (gfc_array_index_type, elemsize);
1795 : 28099 : gfc_conv_descriptor_span_set (pre, desc, tmp);
1796 : :
1797 : 28099 : gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
1798 : : dynamic, dealloc);
1799 : :
1800 : 56233 : while (ss->parent)
1801 : : ss = ss->parent;
1802 : :
1803 : 28099 : if (ss->dimen > ss->loop->temp_dim)
1804 : 24006 : ss->loop->temp_dim = ss->dimen;
1805 : :
1806 : 28099 : 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 : 1032 : gfc_get_iteration_count (tree start, tree end, tree step)
1815 : : {
1816 : 1032 : tree tmp;
1817 : 1032 : tree type;
1818 : :
1819 : 1032 : type = TREE_TYPE (step);
1820 : 1032 : tmp = fold_build2_loc (input_location, MINUS_EXPR, type, end, start);
1821 : 1032 : tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, type, tmp, step);
1822 : 1032 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp,
1823 : : build_int_cst (type, 1));
1824 : 1032 : tmp = fold_build2_loc (input_location, MAX_EXPR, type, tmp,
1825 : : build_int_cst (type, 0));
1826 : 1032 : 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 : 1020 : gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
1834 : : {
1835 : 1020 : tree arg0, arg1;
1836 : 1020 : tree tmp;
1837 : 1020 : tree size;
1838 : 1020 : tree ubound;
1839 : :
1840 : 1020 : if (integer_zerop (extra))
1841 : : return;
1842 : :
1843 : 990 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
1844 : :
1845 : : /* Add EXTRA to the upper bound. */
1846 : 990 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1847 : : ubound, extra);
1848 : 990 : gfc_conv_descriptor_ubound_set (pblock, desc, gfc_rank_cst[0], tmp);
1849 : :
1850 : : /* Get the value of the current data pointer. */
1851 : 990 : arg0 = gfc_conv_descriptor_data_get (desc);
1852 : :
1853 : : /* Calculate the new array size. */
1854 : 990 : size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
1855 : 990 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1856 : : ubound, gfc_index_one_node);
1857 : 990 : 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 : 990 : tmp = gfc_call_realloc (pblock, arg0, arg1);
1863 : 990 : 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 : 2144 : gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
1872 : : {
1873 : 2144 : return (i->start->expr_type != EXPR_CONSTANT
1874 : 1726 : || i->end->expr_type != EXPR_CONSTANT
1875 : 2312 : || 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 : 3174 : gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
1886 : : {
1887 : 3174 : if (expr->expr_type == EXPR_ARRAY)
1888 : 642 : return gfc_get_array_constructor_size (size, expr->value.constructor);
1889 : 2532 : else if (expr->rank > 0)
1890 : : {
1891 : : /* Calculate everything at run time. */
1892 : 1017 : mpz_set_ui (*size, 0);
1893 : 1017 : return true;
1894 : : }
1895 : : else
1896 : : {
1897 : : /* A single element. */
1898 : 1515 : mpz_set_ui (*size, 1);
1899 : 1515 : 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 : 2784 : gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base)
1909 : : {
1910 : 2784 : gfc_constructor *c;
1911 : 2784 : gfc_iterator *i;
1912 : 2784 : mpz_t val;
1913 : 2784 : mpz_t len;
1914 : 2784 : bool dynamic;
1915 : :
1916 : 2784 : mpz_set_ui (*size, 0);
1917 : 2784 : mpz_init (len);
1918 : 2784 : mpz_init (val);
1919 : :
1920 : 2784 : dynamic = false;
1921 : 6910 : for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1922 : : {
1923 : 4126 : i = c->iterator;
1924 : 4126 : if (i && gfc_iterator_has_dynamic_bounds (i))
1925 : : dynamic = true;
1926 : : else
1927 : : {
1928 : 2662 : dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
1929 : 2662 : if (i)
1930 : : {
1931 : : /* Multiply the static part of the element size by the
1932 : : number of iterations. */
1933 : 124 : mpz_sub (val, i->end->value.integer, i->start->value.integer);
1934 : 124 : mpz_fdiv_q (val, val, i->step->value.integer);
1935 : 124 : mpz_add_ui (val, val, 1);
1936 : 124 : if (mpz_sgn (val) > 0)
1937 : 88 : mpz_mul (len, len, val);
1938 : : else
1939 : 36 : mpz_set_ui (len, 0);
1940 : : }
1941 : 2662 : mpz_add (*size, *size, len);
1942 : : }
1943 : : }
1944 : 2784 : mpz_clear (len);
1945 : 2784 : mpz_clear (val);
1946 : 2784 : return dynamic;
1947 : : }
1948 : :
1949 : :
1950 : : /* Make sure offset is a variable. */
1951 : :
1952 : : static void
1953 : 4754 : 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 : 4754 : gcc_assert (*offsetvar != NULL_TREE);
1959 : 4754 : gfc_add_modify (pblock, *offsetvar, *poffset);
1960 : 4754 : *poffset = *offsetvar;
1961 : 4754 : TREE_USED (*offsetvar) = 1;
1962 : 4754 : }
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 : 12717 : gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
1972 : : tree offset, gfc_se * se, gfc_expr * expr)
1973 : : {
1974 : 12717 : tree tmp, offset_eval;
1975 : :
1976 : 12717 : gfc_conv_expr (se, expr);
1977 : :
1978 : : /* Store the value. */
1979 : 12717 : 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 : 12717 : offset_eval = gfc_evaluate_now (offset, &se->pre);
1984 : 12717 : tmp = gfc_build_array_ref (tmp, offset_eval, NULL);
1985 : :
1986 : 12717 : if (expr->expr_type == EXPR_FUNCTION && expr->ts.type == BT_DERIVED
1987 : 53 : && expr->ts.u.derived->attr.alloc_comp)
1988 : 21 : 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 : 12717 : if (expr->ts.type == BT_CHARACTER)
1994 : : {
1995 : 2116 : int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
1996 : 2116 : tree esize;
1997 : :
1998 : 2116 : esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)));
1999 : 2116 : esize = fold_convert (gfc_charlen_type_node, esize);
2000 : 4232 : esize = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
2001 : 2116 : TREE_TYPE (esize), esize,
2002 : 2116 : build_int_cst (TREE_TYPE (esize),
2003 : 2116 : gfc_character_kinds[i].bit_size / 8));
2004 : :
2005 : 2116 : gfc_conv_string_parameter (se);
2006 : 2116 : 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 : 2110 : 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 : 2110 : gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind,
2019 : : se->string_length, se->expr, expr->ts.kind);
2020 : : }
2021 : 2116 : 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 : 10601 : else if (GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
2048 : 10601 : && !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 : 10577 : se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
2062 : 10577 : gfc_add_modify (&se->pre, tmp, se->expr);
2063 : : }
2064 : :
2065 : 12717 : gfc_add_block_to_block (pblock, &se->pre);
2066 : 12717 : gfc_add_block_to_block (pblock, &se->post);
2067 : 12717 : }
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 : 1929 : 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 : 1929 : gfc_se se;
2081 : 1929 : gfc_ss *ss;
2082 : 1929 : gfc_loopinfo loop;
2083 : 1929 : stmtblock_t body;
2084 : 1929 : tree tmp;
2085 : 1929 : tree size;
2086 : 1929 : int n;
2087 : :
2088 : : /* We need this to be a variable so we can increment it. */
2089 : 1929 : gfc_put_offset_into_var (pblock, poffset, offsetvar);
2090 : :
2091 : 1929 : gfc_init_se (&se, NULL);
2092 : :
2093 : : /* Walk the array expression. */
2094 : 1929 : ss = gfc_walk_expr (expr);
2095 : 1929 : gcc_assert (ss != gfc_ss_terminator);
2096 : :
2097 : : /* Initialize the scalarizer. */
2098 : 1929 : gfc_init_loopinfo (&loop);
2099 : 1929 : gfc_add_ss_to_loop (&loop, ss);
2100 : :
2101 : : /* Initialize the loop. */
2102 : 1929 : gfc_conv_ss_startstride (&loop);
2103 : 1929 : gfc_conv_loop_setup (&loop, &expr->where);
2104 : :
2105 : : /* Make sure the constructed array has room for the new data. */
2106 : 1929 : if (dynamic)
2107 : : {
2108 : : /* Set SIZE to the total number of elements in the subarray. */
2109 : 508 : size = gfc_index_one_node;
2110 : 1028 : for (n = 0; n < loop.dimen; n++)
2111 : : {
2112 : 520 : tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
2113 : : gfc_index_one_node);
2114 : 520 : 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 : 508 : gfc_grow_array (&loop.pre, desc, size);
2120 : : }
2121 : :
2122 : : /* Make the loop body. */
2123 : 1929 : gfc_mark_ss_chain_used (ss, 1);
2124 : 1929 : gfc_start_scalarized_body (&loop, &body);
2125 : 1929 : gfc_copy_loopinfo_to_se (&se, &loop);
2126 : 1929 : se.ss = ss;
2127 : :
2128 : 1929 : gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
2129 : 1929 : gcc_assert (se.ss == gfc_ss_terminator);
2130 : :
2131 : : /* Increment the offset. */
2132 : 1929 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2133 : : *poffset, gfc_index_one_node);
2134 : 1929 : gfc_add_modify (&body, *poffset, tmp);
2135 : :
2136 : : /* Finish the loop. */
2137 : 1929 : gfc_trans_scalarizing_loops (&loop, &body);
2138 : 1929 : gfc_add_block_to_block (&loop.pre, &loop.post);
2139 : 1929 : tmp = gfc_finish_block (&loop.pre);
2140 : 1929 : gfc_add_expr_to_block (pblock, tmp);
2141 : :
2142 : 1929 : gfc_cleanup_loop (&loop);
2143 : 1929 : }
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 : 8569 : 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 : 8569 : tree tmp;
2159 : 8569 : tree start = NULL_TREE;
2160 : 8569 : tree end = NULL_TREE;
2161 : 8569 : tree step = NULL_TREE;
2162 : 8569 : stmtblock_t body;
2163 : 8569 : gfc_se se;
2164 : 8569 : mpz_t size;
2165 : 8569 : gfc_constructor *c;
2166 : 8569 : gfc_typespec ts;
2167 : 8569 : int ctr = 0;
2168 : :
2169 : 8569 : tree shadow_loopvar = NULL_TREE;
2170 : 8569 : gfc_saved_var saved_loopvar;
2171 : :
2172 : 8569 : ts.type = BT_UNKNOWN;
2173 : 8569 : mpz_init (size);
2174 : 22708 : for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
2175 : : {
2176 : 14139 : ctr++;
2177 : : /* If this is an iterator or an array, the offset must be a variable. */
2178 : 14139 : if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
2179 : 2825 : 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 : 14139 : if (c->iterator)
2187 : : {
2188 : 1307 : gfc_symbol *sym;
2189 : 1307 : 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 : 1307 : gfc_init_se (&se, NULL);
2196 : 1307 : gfc_conv_expr_val (&se, c->iterator->start);
2197 : 1307 : gfc_add_block_to_block (pblock, &se.pre);
2198 : 1307 : start = gfc_evaluate_now (se.expr, pblock);
2199 : :
2200 : 1307 : gfc_init_se (&se, NULL);
2201 : 1307 : gfc_conv_expr_val (&se, c->iterator->end);
2202 : 1307 : gfc_add_block_to_block (pblock, &se.pre);
2203 : 1307 : end = gfc_evaluate_now (se.expr, pblock);
2204 : :
2205 : 1307 : gfc_init_se (&se, NULL);
2206 : 1307 : gfc_conv_expr_val (&se, c->iterator->step);
2207 : 1307 : gfc_add_block_to_block (pblock, &se.pre);
2208 : 1307 : step = gfc_evaluate_now (se.expr, pblock);
2209 : :
2210 : 1307 : sym = c->iterator->var->symtree->n.sym;
2211 : 1307 : type = gfc_typenode_for_spec (&sym->ts);
2212 : :
2213 : 1307 : shadow_loopvar = gfc_create_var (type, "shadow_loopvar");
2214 : 1307 : gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar);
2215 : : }
2216 : :
2217 : 14139 : gfc_start_block (&body);
2218 : :
2219 : 14139 : if (c->expr->expr_type == EXPR_ARRAY)
2220 : : {
2221 : : /* Array constructors can be nested. */
2222 : 1317 : gfc_trans_array_constructor_value (&body, finalblock, type,
2223 : : desc, c->expr->value.constructor,
2224 : : poffset, offsetvar, dynamic);
2225 : : }
2226 : 12822 : else if (c->expr->rank > 0)
2227 : : {
2228 : 1929 : 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 : 12680 : while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
2241 : : {
2242 : 1787 : p = gfc_constructor_next (p);
2243 : 1787 : n++;
2244 : : }
2245 : : /* Constructor with few constant elements, or element size not
2246 : : known at compile time (e.g. deferred-length character). */
2247 : 10893 : if (n < 4 || !INTEGER_CST_P (TYPE_SIZE_UNIT (type)))
2248 : : {
2249 : : /* Scalar values. */
2250 : 10788 : gfc_init_se (&se, NULL);
2251 : 10788 : gfc_trans_array_ctor_element (&body, desc, *poffset,
2252 : : &se, c->expr);
2253 : :
2254 : 10788 : *poffset = fold_build2_loc (input_location, PLUS_EXPR,
2255 : : gfc_array_index_type,
2256 : : *poffset, gfc_index_one_node);
2257 : 10788 : if (finalblock)
2258 : 953 : gfc_add_block_to_block (finalblock, &se.finalblock);
2259 : : }
2260 : : else
2261 : : {
2262 : : /* Collect multiple scalar constants into a constructor. */
2263 : 105 : vec<constructor_elt, va_gc> *v = NULL;
2264 : 105 : tree init;
2265 : 105 : tree bound;
2266 : 105 : tree tmptype;
2267 : 105 : HOST_WIDE_INT idx = 0;
2268 : :
2269 : 105 : p = c;
2270 : : /* Count the number of consecutive scalar constants. */
2271 : 837 : while (p && !(p->iterator
2272 : 745 : || p->expr->expr_type != EXPR_CONSTANT))
2273 : : {
2274 : 732 : gfc_init_se (&se, NULL);
2275 : 732 : gfc_conv_constant (&se, p->expr);
2276 : :
2277 : 732 : if (c->expr->ts.type != BT_CHARACTER)
2278 : 660 : se.expr = fold_convert (type, se.expr);
2279 : : /* For constant character array constructors we build
2280 : : an array of pointers. */
2281 : 72 : else if (POINTER_TYPE_P (type))
2282 : 0 : se.expr = gfc_build_addr_expr
2283 : 0 : (gfc_get_pchar_type (p->expr->ts.kind),
2284 : : se.expr);
2285 : :
2286 : 732 : CONSTRUCTOR_APPEND_ELT (v,
2287 : : build_int_cst (gfc_array_index_type,
2288 : : idx++),
2289 : : se.expr);
2290 : 732 : c = p;
2291 : 732 : p = gfc_constructor_next (p);
2292 : : }
2293 : :
2294 : 105 : bound = size_int (n - 1);
2295 : : /* Create an array type to hold them. */
2296 : 105 : tmptype = build_range_type (gfc_array_index_type,
2297 : : gfc_index_zero_node, bound);
2298 : 105 : tmptype = build_array_type (type, tmptype);
2299 : :
2300 : 105 : init = build_constructor (tmptype, v);
2301 : 105 : TREE_CONSTANT (init) = 1;
2302 : 105 : TREE_STATIC (init) = 1;
2303 : : /* Create a static variable to hold the data. */
2304 : 105 : tmp = gfc_create_var (tmptype, "data");
2305 : 105 : TREE_STATIC (tmp) = 1;
2306 : 105 : TREE_CONSTANT (tmp) = 1;
2307 : 105 : TREE_READONLY (tmp) = 1;
2308 : 105 : DECL_INITIAL (tmp) = init;
2309 : 105 : init = tmp;
2310 : :
2311 : : /* Use BUILTIN_MEMCPY to assign the values. */
2312 : 105 : tmp = gfc_conv_descriptor_data_get (desc);
2313 : 105 : tmp = build_fold_indirect_ref_loc (input_location,
2314 : : tmp);
2315 : 105 : tmp = gfc_build_array_ref (tmp, *poffset, NULL);
2316 : 105 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
2317 : 105 : init = gfc_build_addr_expr (NULL_TREE, init);
2318 : :
2319 : 105 : size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
2320 : 105 : bound = build_int_cst (size_type_node, n * size);
2321 : 105 : tmp = build_call_expr_loc (input_location,
2322 : : builtin_decl_explicit (BUILT_IN_MEMCPY),
2323 : : 3, tmp, init, bound);
2324 : 105 : gfc_add_expr_to_block (&body, tmp);
2325 : :
2326 : 105 : *poffset = fold_build2_loc (input_location, PLUS_EXPR,
2327 : : gfc_array_index_type, *poffset,
2328 : 105 : build_int_cst (gfc_array_index_type, n));
2329 : : }
2330 : 10893 : if (!INTEGER_CST_P (*poffset))
2331 : : {
2332 : 1622 : gfc_add_modify (&body, *offsetvar, *poffset);
2333 : 1622 : *poffset = *offsetvar;
2334 : : }
2335 : :
2336 : 10893 : if (!c->iterator)
2337 : 10893 : ts = c->expr->ts;
2338 : : }
2339 : :
2340 : : /* The frontend should already have done any expansions
2341 : : at compile-time. */
2342 : 14139 : if (!c->iterator)
2343 : : {
2344 : : /* Pass the code as is. */
2345 : 12832 : tmp = gfc_finish_block (&body);
2346 : 12832 : gfc_add_expr_to_block (pblock, tmp);
2347 : : }
2348 : : else
2349 : : {
2350 : : /* Build the implied do-loop. */
2351 : 1307 : stmtblock_t implied_do_block;
2352 : 1307 : tree cond;
2353 : 1307 : tree exit_label;
2354 : 1307 : tree loopbody;
2355 : 1307 : tree tmp2;
2356 : :
2357 : 1307 : loopbody = gfc_finish_block (&body);
2358 : :
2359 : : /* Create a new block that holds the implied-do loop. A temporary
2360 : : loop-variable is used. */
2361 : 1307 : gfc_start_block(&implied_do_block);
2362 : :
2363 : : /* Initialize the loop. */
2364 : 1307 : gfc_add_modify (&implied_do_block, shadow_loopvar, start);
2365 : :
2366 : : /* If this array expands dynamically, and the number of iterations
2367 : : is not constant, we won't have allocated space for the static
2368 : : part of C->EXPR's size. Do that now. */
2369 : 1307 : if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
2370 : : {
2371 : : /* Get the number of iterations. */
2372 : 512 : tmp = gfc_get_iteration_count (shadow_loopvar, end, step);
2373 : :
2374 : : /* Get the static part of C->EXPR's size. */
2375 : 512 : gfc_get_array_constructor_element_size (&size, c->expr);
2376 : 512 : tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
2377 : :
2378 : : /* Grow the array by TMP * TMP2 elements. */
2379 : 512 : tmp = fold_build2_loc (input_location, MULT_EXPR,
2380 : : gfc_array_index_type, tmp, tmp2);
2381 : 512 : gfc_grow_array (&implied_do_block, desc, tmp);
2382 : : }
2383 : :
2384 : : /* Generate the loop body. */
2385 : 1307 : exit_label = gfc_build_label_decl (NULL_TREE);
2386 : 1307 : gfc_start_block (&body);
2387 : :
2388 : : /* Generate the exit condition. Depending on the sign of
2389 : : the step variable we have to generate the correct
2390 : : comparison. */
2391 : 1307 : tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2392 : 1307 : step, build_int_cst (TREE_TYPE (step), 0));
2393 : 1307 : cond = fold_build3_loc (input_location, COND_EXPR,
2394 : : logical_type_node, tmp,
2395 : : fold_build2_loc (input_location, GT_EXPR,
2396 : : logical_type_node, shadow_loopvar, end),
2397 : : fold_build2_loc (input_location, LT_EXPR,
2398 : : logical_type_node, shadow_loopvar, end));
2399 : 1307 : tmp = build1_v (GOTO_EXPR, exit_label);
2400 : 1307 : TREE_USED (exit_label) = 1;
2401 : 1307 : tmp = build3_v (COND_EXPR, cond, tmp,
2402 : : build_empty_stmt (input_location));
2403 : 1307 : gfc_add_expr_to_block (&body, tmp);
2404 : :
2405 : : /* The main loop body. */
2406 : 1307 : gfc_add_expr_to_block (&body, loopbody);
2407 : :
2408 : : /* Increase loop variable by step. */
2409 : 1307 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
2410 : 1307 : TREE_TYPE (shadow_loopvar), shadow_loopvar,
2411 : : step);
2412 : 1307 : gfc_add_modify (&body, shadow_loopvar, tmp);
2413 : :
2414 : : /* Finish the loop. */
2415 : 1307 : tmp = gfc_finish_block (&body);
2416 : 1307 : tmp = build1_v (LOOP_EXPR, tmp);
2417 : 1307 : gfc_add_expr_to_block (&implied_do_block, tmp);
2418 : :
2419 : : /* Add the exit label. */
2420 : 1307 : tmp = build1_v (LABEL_EXPR, exit_label);
2421 : 1307 : gfc_add_expr_to_block (&implied_do_block, tmp);
2422 : :
2423 : : /* Finish the implied-do loop. */
2424 : 1307 : tmp = gfc_finish_block(&implied_do_block);
2425 : 1307 : gfc_add_expr_to_block(pblock, tmp);
2426 : :
2427 : 1307 : gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar);
2428 : : }
2429 : : }
2430 : :
2431 : : /* F2008 4.5.6.3 para 5: If an executable construct references a structure
2432 : : constructor or array constructor, the entity created by the constructor is
2433 : : finalized after execution of the innermost executable construct containing
2434 : : the reference. This, in fact, was later deleted by the Combined Techical
2435 : : Corrigenda 1 TO 4 for fortran 2008 (f08/0011).
2436 : :
2437 : : Transmit finalization of this constructor through 'finalblock'. */
2438 : 8569 : if ((gfc_option.allow_std & (GFC_STD_F2008 | GFC_STD_F2003))
2439 : 8569 : && !(gfc_option.allow_std & GFC_STD_GNU)
2440 : 70 : && finalblock != NULL
2441 : 24 : && gfc_may_be_finalized (ts)
2442 : 18 : && ctr > 0 && desc != NULL_TREE
2443 : 8587 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
2444 : : {
2445 : 18 : symbol_attribute attr;
2446 : 18 : gfc_se fse;
2447 : 18 : locus loc;
2448 : 18 : gfc_locus_from_location (&loc, input_location);
2449 : 18 : gfc_warning (0, "The structure constructor at %L has been"
2450 : : " finalized. This feature was removed by f08/0011."
2451 : : " Use -std=f2018 or -std=gnu to eliminate the"
2452 : : " finalization.", &loc);
2453 : 18 : attr.pointer = attr.allocatable = 0;
2454 : 18 : gfc_init_se (&fse, NULL);
2455 : 18 : fse.expr = desc;
2456 : 18 : gfc_finalize_tree_expr (&fse, ts.u.derived, attr, 1);
2457 : 18 : gfc_add_block_to_block (finalblock, &fse.pre);
2458 : 18 : gfc_add_block_to_block (finalblock, &fse.finalblock);
2459 : 18 : gfc_add_block_to_block (finalblock, &fse.post);
2460 : : }
2461 : :
2462 : 8569 : mpz_clear (size);
2463 : 8569 : }
2464 : :
2465 : :
2466 : : /* The array constructor code can create a string length with an operand
2467 : : in the form of a temporary variable. This variable will retain its
2468 : : context (current_function_decl). If we store this length tree in a
2469 : : gfc_charlen structure which is shared by a variable in another
2470 : : context, the resulting gfc_charlen structure with a variable in a
2471 : : different context, we could trip the assertion in expand_expr_real_1
2472 : : when it sees that a variable has been created in one context and
2473 : : referenced in another.
2474 : :
2475 : : If this might be the case, we create a new gfc_charlen structure and
2476 : : link it into the current namespace. */
2477 : :
2478 : : static void
2479 : 8157 : store_backend_decl (gfc_charlen **clp, tree len, bool force_new_cl)
2480 : : {
2481 : 8157 : if (force_new_cl)
2482 : : {
2483 : 8130 : gfc_charlen *new_cl = gfc_new_charlen (gfc_current_ns, *clp);
2484 : 8130 : *clp = new_cl;
2485 : : }
2486 : 8157 : (*clp)->backend_decl = len;
2487 : 8157 : }
2488 : :
2489 : : /* A catch-all to obtain the string length for anything that is not
2490 : : a substring of non-constant length, a constant, array or variable. */
2491 : :
2492 : : static void
2493 : 318 : get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
2494 : : {
2495 : 318 : gfc_se se;
2496 : :
2497 : : /* Don't bother if we already know the length is a constant. */
2498 : 318 : if (*len && INTEGER_CST_P (*len))
2499 : 40 : return;
2500 : :
2501 : 278 : if (!e->ref && e->ts.u.cl && e->ts.u.cl->length
2502 : 29 : && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
2503 : : {
2504 : : /* This is easy. */
2505 : 1 : gfc_conv_const_charlen (e->ts.u.cl);
2506 : 1 : *len = e->ts.u.cl->backend_decl;
2507 : : }
2508 : : else
2509 : : {
2510 : : /* Otherwise, be brutal even if inefficient. */
2511 : 277 : gfc_init_se (&se, NULL);
2512 : :
2513 : : /* No function call, in case of side effects. */
2514 : 277 : se.no_function_call = 1;
2515 : 277 : if (e->rank == 0)
2516 : 134 : gfc_conv_expr (&se, e);
2517 : : else
2518 : 143 : gfc_conv_expr_descriptor (&se, e);
2519 : :
2520 : : /* Fix the value. */
2521 : 277 : *len = gfc_evaluate_now (se.string_length, &se.pre);
2522 : :
2523 : 277 : gfc_add_block_to_block (block, &se.pre);
2524 : 277 : gfc_add_block_to_block (block, &se.post);
2525 : :
2526 : 277 : store_backend_decl (&e->ts.u.cl, *len, true);
2527 : : }
2528 : : }
2529 : :
2530 : :
2531 : : /* Figure out the string length of a variable reference expression.
2532 : : Used by get_array_ctor_strlen. */
2533 : :
2534 : : static void
2535 : 930 : get_array_ctor_var_strlen (stmtblock_t *block, gfc_expr * expr, tree * len)
2536 : : {
2537 : 930 : gfc_ref *ref;
2538 : 930 : gfc_typespec *ts;
2539 : 930 : mpz_t char_len;
2540 : 930 : gfc_se se;
2541 : :
2542 : : /* Don't bother if we already know the length is a constant. */
2543 : 930 : if (*len && INTEGER_CST_P (*len))
2544 : 557 : return;
2545 : :
2546 : 468 : ts = &expr->symtree->n.sym->ts;
2547 : 747 : for (ref = expr->ref; ref; ref = ref->next)
2548 : : {
2549 : 374 : switch (ref->type)
2550 : : {
2551 : 234 : case REF_ARRAY:
2552 : : /* Array references don't change the string length. */
2553 : 234 : if (ts->deferred)
2554 : 136 : get_array_ctor_all_strlen (block, expr, len);
2555 : : break;
2556 : :
2557 : 45 : case REF_COMPONENT:
2558 : : /* Use the length of the component. */
2559 : 45 : ts = &ref->u.c.component->ts;
2560 : 45 : break;
2561 : :
2562 : 95 : case REF_SUBSTRING:
2563 : 95 : if (ref->u.ss.end == NULL
2564 : 83 : || ref->u.ss.start->expr_type != EXPR_CONSTANT
2565 : 64 : || ref->u.ss.end->expr_type != EXPR_CONSTANT)
2566 : : {
2567 : : /* Note that this might evaluate expr. */
2568 : 64 : get_array_ctor_all_strlen (block, expr, len);
2569 : 64 : return;
2570 : : }
2571 : 31 : mpz_init_set_ui (char_len, 1);
2572 : 31 : mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
2573 : 31 : mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
2574 : 31 : *len = gfc_conv_mpz_to_tree_type (char_len, gfc_charlen_type_node);
2575 : 31 : mpz_clear (char_len);
2576 : 31 : return;
2577 : :
2578 : : case REF_INQUIRY:
2579 : : break;
2580 : :
2581 : 0 : default:
2582 : 0 : gcc_unreachable ();
2583 : : }
2584 : : }
2585 : :
2586 : : /* A last ditch attempt that is sometimes needed for deferred characters. */
2587 : 373 : if (!ts->u.cl->backend_decl)
2588 : : {
2589 : 19 : gfc_init_se (&se, NULL);
2590 : 19 : if (expr->rank)
2591 : 12 : gfc_conv_expr_descriptor (&se, expr);
2592 : : else
2593 : 7 : gfc_conv_expr (&se, expr);
2594 : 19 : gcc_assert (se.string_length != NULL_TREE);
2595 : 19 : gfc_add_block_to_block (block, &se.pre);
2596 : 19 : ts->u.cl->backend_decl = se.string_length;
2597 : : }
2598 : :
2599 : 373 : *len = ts->u.cl->backend_decl;
2600 : : }
2601 : :
2602 : :
2603 : : /* Figure out the string length of a character array constructor.
2604 : : If len is NULL, don't calculate the length; this happens for recursive calls
2605 : : when a sub-array-constructor is an element but not at the first position,
2606 : : so when we're not interested in the length.
2607 : : Returns TRUE if all elements are character constants. */
2608 : :
2609 : : bool
2610 : 8576 : get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len)
2611 : : {
2612 : 8576 : gfc_constructor *c;
2613 : 8576 : bool is_const;
2614 : :
2615 : 8576 : is_const = true;
2616 : :
2617 : 8576 : if (gfc_constructor_first (base) == NULL)
2618 : : {
2619 : 303 : if (len)
2620 : 303 : *len = build_int_cstu (gfc_charlen_type_node, 0);
2621 : 303 : return is_const;
2622 : : }
2623 : :
2624 : : /* Loop over all constructor elements to find out is_const, but in len we
2625 : : want to store the length of the first, not the last, element. We can
2626 : : of course exit the loop as soon as is_const is found to be false. */
2627 : 8273 : for (c = gfc_constructor_first (base);
2628 : 45584 : c && is_const; c = gfc_constructor_next (c))
2629 : : {
2630 : 37311 : switch (c->expr->expr_type)
2631 : : {
2632 : 36160 : case EXPR_CONSTANT:
2633 : 36160 : if (len && !(*len && INTEGER_CST_P (*len)))
2634 : 392 : *len = build_int_cstu (gfc_charlen_type_node,
2635 : 392 : c->expr->value.character.length);
2636 : : break;
2637 : :
2638 : 43 : case EXPR_ARRAY:
2639 : 43 : if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
2640 : 1139 : is_const = false;
2641 : : break;
2642 : :
2643 : 990 : case EXPR_VARIABLE:
2644 : 990 : is_const = false;
2645 : 990 : if (len)
2646 : 930 : get_array_ctor_var_strlen (block, c->expr, len);
2647 : : break;
2648 : :
2649 : 118 : default:
2650 : 118 : is_const = false;
2651 : 118 : if (len)
2652 : 118 : get_array_ctor_all_strlen (block, c->expr, len);
2653 : : break;
2654 : : }
2655 : :
2656 : : /* After the first iteration, we don't want the length modified. */
2657 : 37311 : len = NULL;
2658 : : }
2659 : :
2660 : : return is_const;
2661 : : }
2662 : :
2663 : : /* Check whether the array constructor C consists entirely of constant
2664 : : elements, and if so returns the number of those elements, otherwise
2665 : : return zero. Note, an empty or NULL array constructor returns zero. */
2666 : :
2667 : : unsigned HOST_WIDE_INT
2668 : 57155 : gfc_constant_array_constructor_p (gfc_constructor_base base)
2669 : : {
2670 : 57155 : unsigned HOST_WIDE_INT nelem = 0;
2671 : :
2672 : 57155 : gfc_constructor *c = gfc_constructor_first (base);
2673 : 458692 : while (c)
2674 : : {
2675 : 352596 : if (c->iterator
2676 : 351218 : || c->expr->rank > 0
2677 : 348788 : || c->expr->expr_type != EXPR_CONSTANT)
2678 : : return 0;
2679 : 344382 : c = gfc_constructor_next (c);
2680 : 344382 : nelem++;
2681 : : }
2682 : : return nelem;
2683 : : }
2684 : :
2685 : :
2686 : : /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
2687 : : and the tree type of it's elements, TYPE, return a static constant
2688 : : variable that is compile-time initialized. */
2689 : :
2690 : : tree
2691 : 39229 : gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
2692 : : {
2693 : 39229 : tree tmptype, init, tmp;
2694 : 39229 : HOST_WIDE_INT nelem;
2695 : 39229 : gfc_constructor *c;
2696 : 39229 : gfc_array_spec as;
2697 : 39229 : gfc_se se;
2698 : 39229 : int i;
2699 : 39229 : vec<constructor_elt, va_gc> *v = NULL;
2700 : :
2701 : : /* First traverse the constructor list, converting the constants
2702 : : to tree to build an initializer. */
2703 : 39229 : nelem = 0;
2704 : 39229 : c = gfc_constructor_first (expr->value.constructor);
2705 : 357848 : while (c)
2706 : : {
2707 : 279390 : gfc_init_se (&se, NULL);
2708 : 279390 : gfc_conv_constant (&se, c->expr);
2709 : 279390 : if (c->expr->ts.type != BT_CHARACTER)
2710 : 244132 : se.expr = fold_convert (type, se.expr);
2711 : 35258 : else if (POINTER_TYPE_P (type))
2712 : 35258 : se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
2713 : : se.expr);
2714 : 279390 : CONSTRUCTOR_APPEND_ELT (v, build_int_cst (gfc_array_index_type, nelem),
2715 : : se.expr);
2716 : 279390 : c = gfc_constructor_next (c);
2717 : 279390 : nelem++;
2718 : : }
2719 : :
2720 : : /* Next determine the tree type for the array. We use the gfortran
2721 : : front-end's gfc_get_nodesc_array_type in order to create a suitable
2722 : : GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
2723 : :
2724 : 39229 : memset (&as, 0, sizeof (gfc_array_spec));
2725 : :
2726 : 39229 : as.rank = expr->rank;
2727 : 39229 : as.type = AS_EXPLICIT;
2728 : 39229 : if (!expr->shape)
2729 : : {
2730 : 3 : as.lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
2731 : 3 : as.upper[0] = gfc_get_int_expr (gfc_default_integer_kind,
2732 : : NULL, nelem - 1);
2733 : : }
2734 : : else
2735 : 84107 : for (i = 0; i < expr->rank; i++)
2736 : : {
2737 : 44881 : int tmp = (int) mpz_get_si (expr->shape[i]);
2738 : 44881 : as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
2739 : 44881 : as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind,
2740 : 44881 : NULL, tmp - 1);
2741 : : }
2742 : :
2743 : 39229 : tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
2744 : :
2745 : : /* as is not needed anymore. */
2746 : 123342 : for (i = 0; i < as.rank + as.corank; i++)
2747 : : {
2748 : 44884 : gfc_free_expr (as.lower[i]);
2749 : 44884 : gfc_free_expr (as.upper[i]);
2750 : : }
2751 : :
2752 : 39229 : init = build_constructor (tmptype, v);
2753 : :
2754 : 39229 : TREE_CONSTANT (init) = 1;
2755 : 39229 : TREE_STATIC (init) = 1;
2756 : :
2757 : 39229 : tmp = build_decl (input_location, VAR_DECL, create_tmp_var_name ("A"),
2758 : : tmptype);
2759 : 39229 : DECL_ARTIFICIAL (tmp) = 1;
2760 : 39229 : DECL_IGNORED_P (tmp) = 1;
2761 : 39229 : TREE_STATIC (tmp) = 1;
2762 : 39229 : TREE_CONSTANT (tmp) = 1;
2763 : 39229 : TREE_READONLY (tmp) = 1;
2764 : 39229 : DECL_INITIAL (tmp) = init;
2765 : 39229 : pushdecl (tmp);
2766 : :
2767 : 39229 : return tmp;
2768 : : }
2769 : :
2770 : :
2771 : : /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
2772 : : This mostly initializes the scalarizer state info structure with the
2773 : : appropriate values to directly use the array created by the function
2774 : : gfc_build_constant_array_constructor. */
2775 : :
2776 : : static void
2777 : 34125 : trans_constant_array_constructor (gfc_ss * ss, tree type)
2778 : : {
2779 : 34125 : gfc_array_info *info;
2780 : 34125 : tree tmp;
2781 : 34125 : int i;
2782 : :
2783 : 34125 : tmp = gfc_build_constant_array_constructor (ss->info->expr, type);
2784 : :
2785 : 34125 : info = &ss->info->data.array;
2786 : :
2787 : 34125 : info->descriptor = tmp;
2788 : 34125 : info->data = gfc_build_addr_expr (NULL_TREE, tmp);
2789 : 34125 : info->offset = gfc_index_zero_node;
2790 : :
2791 : 71650 : for (i = 0; i < ss->dimen; i++)
2792 : : {
2793 : 37525 : info->delta[i] = gfc_index_zero_node;
2794 : 37525 : info->start[i] = gfc_index_zero_node;
2795 : 37525 : info->end[i] = gfc_index_zero_node;
2796 : 37525 : info->stride[i] = gfc_index_one_node;
2797 : : }
2798 : 34125 : }
2799 : :
2800 : :
2801 : : static int
2802 : 34131 : get_rank (gfc_loopinfo *loop)
2803 : : {
2804 : 34131 : int rank;
2805 : :
2806 : 34131 : rank = 0;
2807 : 148424 : for (; loop; loop = loop->parent)
2808 : 74218 : rank += loop->dimen;
2809 : :
2810 : 40075 : return rank;
2811 : : }
2812 : :
2813 : :
2814 : : /* Helper routine of gfc_trans_array_constructor to determine if the
2815 : : bounds of the loop specified by LOOP are constant and simple enough
2816 : : to use with trans_constant_array_constructor. Returns the
2817 : : iteration count of the loop if suitable, and NULL_TREE otherwise. */
2818 : :
2819 : : static tree
2820 : 34131 : constant_array_constructor_loop_size (gfc_loopinfo * l)
2821 : : {
2822 : 34131 : gfc_loopinfo *loop;
2823 : 34131 : tree size = gfc_index_one_node;
2824 : 34131 : tree tmp;
2825 : 34131 : int i, total_dim;
2826 : :
2827 : 34131 : total_dim = get_rank (l);
2828 : :
2829 : 68262 : for (loop = l; loop; loop = loop->parent)
2830 : : {
2831 : 71674 : for (i = 0; i < loop->dimen; i++)
2832 : : {
2833 : : /* If the bounds aren't constant, return NULL_TREE. */
2834 : 37543 : if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
2835 : : return NULL_TREE;
2836 : 37537 : if (!integer_zerop (loop->from[i]))
2837 : : {
2838 : : /* Only allow nonzero "from" in one-dimensional arrays. */
2839 : 0 : if (total_dim != 1)
2840 : : return NULL_TREE;
2841 : 0 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2842 : : gfc_array_index_type,
2843 : : loop->to[i], loop->from[i]);
2844 : : }
2845 : : else
2846 : 37537 : tmp = loop->to[i];
2847 : 37537 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
2848 : : gfc_array_index_type, tmp, gfc_index_one_node);
2849 : 37537 : size = fold_build2_loc (input_location, MULT_EXPR,
2850 : : gfc_array_index_type, size, tmp);
2851 : : }
2852 : : }
2853 : :
2854 : : return size;
2855 : : }
2856 : :
2857 : :
2858 : : static tree *
2859 : 41377 : get_loop_upper_bound_for_array (gfc_ss *array, int array_dim)
2860 : : {
2861 : 41377 : gfc_ss *ss;
2862 : 41377 : int n;
2863 : :
2864 : 41377 : gcc_assert (array->nested_ss == NULL);
2865 : :
2866 : 41377 : for (ss = array; ss; ss = ss->parent)
2867 : 41377 : for (n = 0; n < ss->loop->dimen; n++)
2868 : 41377 : if (array_dim == get_array_ref_dim_for_loop_dim (ss, n))
2869 : 41377 : return &(ss->loop->to[n]);
2870 : :
2871 : 0 : gcc_unreachable ();
2872 : : }
2873 : :
2874 : :
2875 : : static gfc_loopinfo *
2876 : 690508 : outermost_loop (gfc_loopinfo * loop)
2877 : : {
2878 : 895136 : while (loop->parent != NULL)
2879 : : loop = loop->parent;
2880 : :
2881 : 690508 : return loop;
2882 : : }
2883 : :
2884 : :
2885 : : /* Array constructors are handled by constructing a temporary, then using that
2886 : : within the scalarization loop. This is not optimal, but seems by far the
2887 : : simplest method. */
2888 : :
2889 : : static void
2890 : 41377 : trans_array_constructor (gfc_ss * ss, locus * where)
2891 : : {
2892 : 41377 : gfc_constructor_base c;
2893 : 41377 : tree offset;
2894 : 41377 : tree offsetvar;
2895 : 41377 : tree desc;
2896 : 41377 : tree type;
2897 : 41377 : tree tmp;
2898 : 41377 : tree *loop_ubound0;
2899 : 41377 : bool dynamic;
2900 : 41377 : bool old_first_len, old_typespec_chararray_ctor;
2901 : 41377 : tree old_first_len_val;
2902 : 41377 : gfc_loopinfo *loop, *outer_loop;
2903 : 41377 : gfc_ss_info *ss_info;
2904 : 41377 : gfc_expr *expr;
2905 : 41377 : gfc_ss *s;
2906 : 41377 : tree neg_len;
2907 : 41377 : char *msg;
2908 : 41377 : stmtblock_t finalblock;
2909 : 41377 : bool finalize_required;
2910 : :
2911 : : /* Save the old values for nested checking. */
2912 : 41377 : old_first_len = first_len;
2913 : 41377 : old_first_len_val = first_len_val;
2914 : 41377 : old_typespec_chararray_ctor = typespec_chararray_ctor;
2915 : :
2916 : 41377 : loop = ss->loop;
2917 : 41377 : outer_loop = outermost_loop (loop);
2918 : 41377 : ss_info = ss->info;
2919 : 41377 : expr = ss_info->expr;
2920 : :
2921 : : /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
2922 : : typespec was given for the array constructor. */
2923 : 82754 : typespec_chararray_ctor = (expr->ts.type == BT_CHARACTER
2924 : 7880 : && expr->ts.u.cl
2925 : 49257 : && expr->ts.u.cl->length_from_typespec);
2926 : :
2927 : 41377 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2928 : 2538 : && expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
2929 : : {
2930 : 1468 : first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
2931 : 1468 : first_len = true;
2932 : : }
2933 : :
2934 : 41377 : gcc_assert (ss->dimen == ss->loop->dimen);
2935 : :
2936 : 41377 : c = expr->value.constructor;
2937 : 41377 : if (expr->ts.type == BT_CHARACTER)
2938 : : {
2939 : 7880 : bool const_string;
2940 : 7880 : bool force_new_cl = false;
2941 : :
2942 : : /* get_array_ctor_strlen walks the elements of the constructor, if a
2943 : : typespec was given, we already know the string length and want the one
2944 : : specified there. */
2945 : 7880 : if (typespec_chararray_ctor && expr->ts.u.cl->length
2946 : 344 : && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
2947 : : {
2948 : 27 : gfc_se length_se;
2949 : :
2950 : 27 : const_string = false;
2951 : 27 : gfc_init_se (&length_se, NULL);
2952 : 27 : gfc_conv_expr_type (&length_se, expr->ts.u.cl->length,
2953 : : gfc_charlen_type_node);
2954 : 27 : ss_info->string_length = length_se.expr;
2955 : :
2956 : : /* Check if the character length is negative. If it is, then
2957 : : set LEN = 0. */
2958 : 27 : neg_len = fold_build2_loc (input_location, LT_EXPR,
2959 : : logical_type_node, ss_info->string_length,
2960 : 27 : build_zero_cst (TREE_TYPE
2961 : : (ss_info->string_length)));
2962 : : /* Print a warning if bounds checking is enabled. */
2963 : 27 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2964 : : {
2965 : 18 : msg = xasprintf ("Negative character length treated as LEN = 0");
2966 : 18 : gfc_trans_runtime_check (false, true, neg_len, &length_se.pre,
2967 : : where, msg);
2968 : 18 : free (msg);
2969 : : }
2970 : :
2971 : 27 : ss_info->string_length
2972 : 27 : = fold_build3_loc (input_location, COND_EXPR,
2973 : : gfc_charlen_type_node, neg_len,
2974 : : build_zero_cst
2975 : 27 : (TREE_TYPE (ss_info->string_length)),
2976 : : ss_info->string_length);
2977 : 27 : ss_info->string_length = gfc_evaluate_now (ss_info->string_length,
2978 : : &length_se.pre);
2979 : 27 : gfc_add_block_to_block (&outer_loop->pre, &length_se.pre);
2980 : 27 : gfc_add_block_to_block (&outer_loop->post, &length_se.post);
2981 : 27 : }
2982 : : else
2983 : : {
2984 : 7853 : const_string = get_array_ctor_strlen (&outer_loop->pre, c,
2985 : : &ss_info->string_length);
2986 : 7853 : force_new_cl = true;
2987 : :
2988 : : /* Initialize "len" with string length for bounds checking. */
2989 : 7853 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2990 : 1486 : && !typespec_chararray_ctor
2991 : 1468 : && ss_info->string_length)
2992 : : {
2993 : 1468 : gfc_se length_se;
2994 : :
2995 : 1468 : gfc_init_se (&length_se, NULL);
2996 : 1468 : gfc_add_modify (&length_se.pre, first_len_val,
2997 : 1468 : fold_convert (TREE_TYPE (first_len_val),
2998 : : ss_info->string_length));
2999 : 1468 : ss_info->string_length = gfc_evaluate_now (ss_info->string_length,
3000 : : &length_se.pre);
3001 : 1468 : gfc_add_block_to_block (&outer_loop->pre, &length_se.pre);
3002 : 1468 : gfc_add_block_to_block (&outer_loop->post, &length_se.post);
3003 : : }
3004 : : }
3005 : :
3006 : : /* Complex character array constructors should have been taken care of
3007 : : and not end up here. */
3008 : 7880 : gcc_assert (ss_info->string_length);
3009 : :
3010 : 7880 : store_backend_decl (&expr->ts.u.cl, ss_info->string_length, force_new_cl);
3011 : :
3012 : 7880 : type = gfc_get_character_type_len (expr->ts.kind, ss_info->string_length);
3013 : 7880 : if (const_string)
3014 : 6941 : type = build_pointer_type (type);
3015 : : }
3016 : : else
3017 : 33522 : type = gfc_typenode_for_spec (expr->ts.type == BT_CLASS
3018 : 25 : ? &CLASS_DATA (expr)->ts : &expr->ts);
3019 : :
3020 : : /* See if the constructor determines the loop bounds. */
3021 : 41377 : dynamic = false;
3022 : :
3023 : 41377 : loop_ubound0 = get_loop_upper_bound_for_array (ss, 0);
3024 : :
3025 : 81452 : if (expr->shape && get_rank (loop) > 1 && *loop_ubound0 == NULL_TREE)
3026 : : {
3027 : : /* We have a multidimensional parameter. */
3028 : 0 : for (s = ss; s; s = s->parent)
3029 : : {
3030 : : int n;
3031 : 0 : for (n = 0; n < s->loop->dimen; n++)
3032 : : {
3033 : 0 : s->loop->from[n] = gfc_index_zero_node;
3034 : 0 : s->loop->to[n] = gfc_conv_mpz_to_tree (expr->shape[s->dim[n]],
3035 : : gfc_index_integer_kind);
3036 : 0 : s->loop->to[n] = fold_build2_loc (input_location, MINUS_EXPR,
3037 : : gfc_array_index_type,
3038 : 0 : s->loop->to[n],
3039 : : gfc_index_one_node);
3040 : : }
3041 : : }
3042 : : }
3043 : :
3044 : 41377 : if (*loop_ubound0 == NULL_TREE)
3045 : : {
3046 : 840 : mpz_t size;
3047 : :
3048 : : /* We should have a 1-dimensional, zero-based loop. */
3049 : 840 : gcc_assert (loop->parent == NULL && loop->nested == NULL);
3050 : 840 : gcc_assert (loop->dimen == 1);
3051 : 840 : gcc_assert (integer_zerop (loop->from[0]));
3052 : :
3053 : : /* Split the constructor size into a static part and a dynamic part.
3054 : : Allocate the static size up-front and record whether the dynamic
3055 : : size might be nonzero. */
3056 : 840 : mpz_init (size);
3057 : 840 : dynamic = gfc_get_array_constructor_size (&size, c);
3058 : 840 : mpz_sub_ui (size, size, 1);
3059 : 840 : loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
3060 : 840 : mpz_clear (size);
3061 : : }
3062 : :
3063 : : /* Special case constant array constructors. */
3064 : 840 : if (!dynamic)
3065 : : {
3066 : 40555 : unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
3067 : 40555 : if (nelem > 0)
3068 : : {
3069 : 34131 : tree size = constant_array_constructor_loop_size (loop);
3070 : 34131 : if (size && compare_tree_int (size, nelem) == 0)
3071 : : {
3072 : 34125 : trans_constant_array_constructor (ss, type);
3073 : 34125 : goto finish;
3074 : : }
3075 : : }
3076 : : }
3077 : :
3078 : 7252 : gfc_trans_create_temp_array (&outer_loop->pre, &outer_loop->post, ss, type,
3079 : : NULL_TREE, dynamic, true, false, where);
3080 : :
3081 : 7252 : desc = ss_info->data.array.descriptor;
3082 : 7252 : offset = gfc_index_zero_node;
3083 : 7252 : offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
3084 : 7252 : suppress_warning (offsetvar);
3085 : 7252 : TREE_USED (offsetvar) = 0;
3086 : :
3087 : 7252 : gfc_init_block (&finalblock);
3088 : 7252 : finalize_required = expr->must_finalize;
3089 : 7252 : if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
3090 : : finalize_required = true;
3091 : 7282 : gfc_trans_array_constructor_value (&outer_loop->pre,
3092 : : finalize_required ? &finalblock : NULL,
3093 : : type, desc, c, &offset, &offsetvar,
3094 : : dynamic);
3095 : :
3096 : : /* If the array grows dynamically, the upper bound of the loop variable
3097 : : is determined by the array's final upper bound. */
3098 : 7252 : if (dynamic)
3099 : : {
3100 : 822 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
3101 : : gfc_array_index_type,
3102 : : offsetvar, gfc_index_one_node);
3103 : 822 : tmp = gfc_evaluate_now (tmp, &outer_loop->pre);
3104 : 822 : if (*loop_ubound0 && VAR_P (*loop_ubound0))
3105 : 0 : gfc_add_modify (&outer_loop->pre, *loop_ubound0, tmp);
3106 : : else
3107 : 822 : *loop_ubound0 = tmp;
3108 : : }
3109 : :
3110 : 7252 : if (TREE_USED (offsetvar))
3111 : 2825 : pushdecl (offsetvar);
3112 : : else
3113 : 4427 : gcc_assert (INTEGER_CST_P (offset));
3114 : :
3115 : : #if 0
3116 : : /* Disable bound checking for now because it's probably broken. */
3117 : : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3118 : : {
3119 : : gcc_unreachable ();
3120 : : }
3121 : : #endif
3122 : :
3123 : 4427 : finish:
3124 : : /* Restore old values of globals. */
3125 : 41377 : first_len = old_first_len;
3126 : 41377 : first_len_val = old_first_len_val;
3127 : 41377 : typespec_chararray_ctor = old_typespec_chararray_ctor;
3128 : :
3129 : : /* F2008 4.5.6.3 para 5: If an executable construct references a structure
3130 : : constructor or array constructor, the entity created by the constructor is
3131 : : finalized after execution of the innermost executable construct containing
3132 : : the reference. */
3133 : 41377 : if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
3134 : 1565 : && finalblock.head != NULL_TREE)
3135 : 36 : gfc_prepend_expr_to_block (&loop->post, finalblock.head);
3136 : 41377 : }
3137 : :
3138 : :
3139 : : /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
3140 : : called after evaluating all of INFO's vector dimensions. Go through
3141 : : each such vector dimension and see if we can now fill in any missing
3142 : : loop bounds. */
3143 : :
3144 : : static void
3145 : 176821 : set_vector_loop_bounds (gfc_ss * ss)
3146 : : {
3147 : 176821 : gfc_loopinfo *loop, *outer_loop;
3148 : 176821 : gfc_array_info *info;
3149 : 176821 : gfc_se se;
3150 : 176821 : tree tmp;
3151 : 176821 : tree desc;
3152 : 176821 : tree zero;
3153 : 176821 : int n;
3154 : 176821 : int dim;
3155 : :
3156 : 176821 : outer_loop = outermost_loop (ss->loop);
3157 : :
3158 : 176821 : info = &ss->info->data.array;
3159 : :
3160 : 358278 : for (; ss; ss = ss->parent)
3161 : : {
3162 : 181457 : loop = ss->loop;
3163 : :
3164 : 433546 : for (n = 0; n < loop->dimen; n++)
3165 : : {
3166 : 252089 : dim = ss->dim[n];
3167 : 252089 : if (info->ref->u.ar.dimen_type[dim] != DIMEN_VECTOR
3168 : 752 : || loop->to[n] != NULL)
3169 : 251922 : continue;
3170 : :
3171 : : /* Loop variable N indexes vector dimension DIM, and we don't
3172 : : yet know the upper bound of loop variable N. Set it to the
3173 : : difference between the vector's upper and lower bounds. */
3174 : 167 : gcc_assert (loop->from[n] == gfc_index_zero_node);
3175 : 167 : gcc_assert (info->subscript[dim]
3176 : : && info->subscript[dim]->info->type == GFC_SS_VECTOR);
3177 : :
3178 : 167 : gfc_init_se (&se, NULL);
3179 : 167 : desc = info->subscript[dim]->info->data.array.descriptor;
3180 : 167 : zero = gfc_rank_cst[0];
3181 : 167 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
3182 : : gfc_array_index_type,
3183 : : gfc_conv_descriptor_ubound_get (desc, zero),
3184 : : gfc_conv_descriptor_lbound_get (desc, zero));
3185 : 167 : tmp = gfc_evaluate_now (tmp, &outer_loop->pre);
3186 : 167 : loop->to[n] = tmp;
3187 : : }
3188 : : }
3189 : 176821 : }
3190 : :
3191 : :
3192 : : /* Tells whether a scalar argument to an elemental procedure is saved out
3193 : : of a scalarization loop as a value or as a reference. */
3194 : :
3195 : : bool
3196 : 44116 : gfc_scalar_elemental_arg_saved_as_reference (gfc_ss_info * ss_info)
3197 : : {
3198 : 44116 : if (ss_info->type != GFC_SS_REFERENCE)
3199 : : return false;
3200 : :
3201 : 10244 : if (ss_info->data.scalar.needs_temporary)
3202 : : return false;
3203 : :
3204 : : /* If the actual argument can be absent (in other words, it can
3205 : : be a NULL reference), don't try to evaluate it; pass instead
3206 : : the reference directly. */
3207 : 9880 : if (ss_info->can_be_null_ref)
3208 : : return true;
3209 : :
3210 : : /* If the expression is of polymorphic type, it's actual size is not known,
3211 : : so we avoid copying it anywhere. */
3212 : 9204 : if (ss_info->data.scalar.dummy_arg
3213 : 1400 : && gfc_dummy_arg_get_typespec (*ss_info->data.scalar.dummy_arg).type
3214 : : == BT_CLASS
3215 : 9326 : && ss_info->expr->ts.type == BT_CLASS)
3216 : : return true;
3217 : :
3218 : : /* If the expression is a data reference of aggregate type,
3219 : : and the data reference is not used on the left hand side,
3220 : : avoid a copy by saving a reference to the content. */
3221 : 9180 : if (!ss_info->data.scalar.needs_temporary
3222 : 9180 : && (ss_info->expr->ts.type == BT_DERIVED
3223 : 8230 : || ss_info->expr->ts.type == BT_CLASS)
3224 : 10178 : && gfc_expr_is_variable (ss_info->expr))
3225 : : return true;
3226 : :
3227 : : /* Otherwise the expression is evaluated to a temporary variable before the
3228 : : scalarization loop. */
3229 : : return false;
3230 : : }
3231 : :
3232 : :
3233 : : /* Add the pre and post chains for all the scalar expressions in a SS chain
3234 : : to loop. This is called after the loop parameters have been calculated,
3235 : : but before the actual scalarizing loops. */
3236 : :
3237 : : static void
3238 : 186246 : gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
3239 : : locus * where)
3240 : : {
3241 : 186246 : gfc_loopinfo *nested_loop, *outer_loop;
3242 : 186246 : gfc_se se;
3243 : 186246 : gfc_ss_info *ss_info;
3244 : 186246 : gfc_array_info *info;
3245 : 186246 : gfc_expr *expr;
3246 : 186246 : int n;
3247 : :
3248 : : /* Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise,
3249 : : arguments could get evaluated multiple times. */
3250 : 186246 : if (ss->is_alloc_lhs)
3251 : 166 : return;
3252 : :
3253 : 489749 : outer_loop = outermost_loop (loop);
3254 : :
3255 : : /* TODO: This can generate bad code if there are ordering dependencies,
3256 : : e.g., a callee allocated function and an unknown size constructor. */
3257 : : gcc_assert (ss != NULL);
3258 : :
3259 : 489749 : for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
3260 : : {
3261 : 303669 : gcc_assert (ss);
3262 : :
3263 : : /* Cross loop arrays are handled from within the most nested loop. */
3264 : 303669 : if (ss->nested_ss != NULL)
3265 : 4740 : continue;
3266 : :
3267 : 298929 : ss_info = ss->info;
3268 : 298929 : expr = ss_info->expr;
3269 : 298929 : info = &ss_info->data.array;
3270 : :
3271 : 298929 : switch (ss_info->type)
3272 : : {
3273 : 41826 : case GFC_SS_SCALAR:
3274 : : /* Scalar expression. Evaluate this now. This includes elemental
3275 : : dimension indices, but not array section bounds. */
3276 : 41826 : gfc_init_se (&se, NULL);
3277 : 41826 : gfc_conv_expr (&se, expr);
3278 : 41826 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3279 : :
3280 : 41826 : if (expr->ts.type != BT_CHARACTER
3281 : 41826 : && !gfc_is_alloc_class_scalar_function (expr))
3282 : : {
3283 : : /* Move the evaluation of scalar expressions outside the
3284 : : scalarization loop, except for WHERE assignments. */
3285 : 38154 : if (subscript)
3286 : 6289 : se.expr = convert(gfc_array_index_type, se.expr);
3287 : 38154 : if (!ss_info->where)
3288 : 37740 : se.expr = gfc_evaluate_now (se.expr, &outer_loop->pre);
3289 : 38154 : gfc_add_block_to_block (&outer_loop->pre, &se.post);
3290 : : }
3291 : : else
3292 : 3672 : gfc_add_block_to_block (&outer_loop->post, &se.post);
3293 : :
3294 : 41826 : ss_info->data.scalar.value = se.expr;
3295 : 41826 : ss_info->string_length = se.string_length;
3296 : 41826 : break;
3297 : :
3298 : 5122 : case GFC_SS_REFERENCE:
3299 : : /* Scalar argument to elemental procedure. */
3300 : 5122 : gfc_init_se (&se, NULL);
3301 : 5122 : if (gfc_scalar_elemental_arg_saved_as_reference (ss_info))
3302 : 825 : gfc_conv_expr_reference (&se, expr);
3303 : : else
3304 : : {
3305 : : /* Evaluate the argument outside the loop and pass
3306 : : a reference to the value. */
3307 : 4297 : gfc_conv_expr (&se, expr);
3308 : : }
3309 : :
3310 : : /* Ensure that a pointer to the string is stored. */
3311 : 5122 : if (expr->ts.type == BT_CHARACTER)
3312 : 174 : gfc_conv_string_parameter (&se);
3313 : :
3314 : 5122 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3315 : 5122 : gfc_add_block_to_block (&outer_loop->post, &se.post);
3316 : 5122 : if (gfc_is_class_scalar_expr (expr))
3317 : : /* This is necessary because the dynamic type will always be
3318 : : large than the declared type. In consequence, assigning
3319 : : the value to a temporary could segfault.
3320 : : OOP-TODO: see if this is generally correct or is the value
3321 : : has to be written to an allocated temporary, whose address
3322 : : is passed via ss_info. */
3323 : 48 : ss_info->data.scalar.value = se.expr;
3324 : : else
3325 : 5074 : ss_info->data.scalar.value = gfc_evaluate_now (se.expr,
3326 : : &outer_loop->pre);
3327 : :
3328 : 5122 : ss_info->string_length = se.string_length;
3329 : 5122 : break;
3330 : :
3331 : : case GFC_SS_SECTION:
3332 : : /* Add the expressions for scalar and vector subscripts. */
3333 : 2829136 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
3334 : 2652315 : if (info->subscript[n])
3335 : 7041 : gfc_add_loop_ss_code (loop, info->subscript[n], true, where);
3336 : :
3337 : 176821 : set_vector_loop_bounds (ss);
3338 : 176821 : break;
3339 : :
3340 : 752 : case GFC_SS_VECTOR:
3341 : : /* Get the vector's descriptor and store it in SS. */
3342 : 752 : gfc_init_se (&se, NULL);
3343 : 752 : gfc_conv_expr_descriptor (&se, expr);
3344 : 752 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3345 : 752 : gfc_add_block_to_block (&outer_loop->post, &se.post);
3346 : 752 : info->descriptor = se.expr;
3347 : 752 : break;
3348 : :
3349 : 11333 : case GFC_SS_INTRINSIC:
3350 : 11333 : gfc_add_intrinsic_ss_code (loop, ss);
3351 : 11333 : break;
3352 : :
3353 : 9379 : case GFC_SS_FUNCTION:
3354 : 9379 : {
3355 : : /* Array function return value. We call the function and save its
3356 : : result in a temporary for use inside the loop. */
3357 : 9379 : gfc_init_se (&se, NULL);
3358 : 9379 : se.loop = loop;
3359 : 9379 : se.ss = ss;
3360 : 9379 : bool class_func = gfc_is_class_array_function (expr);
3361 : 9379 : if (class_func)
3362 : 183 : expr->must_finalize = 1;
3363 : 9379 : gfc_conv_expr (&se, expr);
3364 : 9379 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3365 : 9379 : if (class_func
3366 : 183 : && se.expr
3367 : 9562 : && GFC_CLASS_TYPE_P (TREE_TYPE (se.expr)))
3368 : : {
3369 : 183 : tree tmp = gfc_class_data_get (se.expr);
3370 : 183 : info->descriptor = tmp;
3371 : 183 : info->data = gfc_conv_descriptor_data_get (tmp);
3372 : 183 : info->offset = gfc_conv_descriptor_offset_get (tmp);
3373 : 366 : for (gfc_ss *s = ss; s; s = s->parent)
3374 : 378 : for (int n = 0; n < s->dimen; n++)
3375 : : {
3376 : 195 : int dim = s->dim[n];
3377 : 195 : tree tree_dim = gfc_rank_cst[dim];
3378 : :
3379 : 195 : tree start;
3380 : 195 : start = gfc_conv_descriptor_lbound_get (tmp, tree_dim);
3381 : 195 : start = gfc_evaluate_now (start, &outer_loop->pre);
3382 : 195 : info->start[dim] = start;
3383 : :
3384 : 195 : tree end;
3385 : 195 : end = gfc_conv_descriptor_ubound_get (tmp, tree_dim);
3386 : 195 : end = gfc_evaluate_now (end, &outer_loop->pre);
3387 : 195 : info->end[dim] = end;
3388 : :
3389 : 195 : tree stride;
3390 : 195 : stride = gfc_conv_descriptor_stride_get (tmp, tree_dim);
3391 : 195 : stride = gfc_evaluate_now (stride, &outer_loop->pre);
3392 : 195 : info->stride[dim] = stride;
3393 : : }
3394 : : }
3395 : 9379 : gfc_add_block_to_block (&outer_loop->post, &se.post);
3396 : 9379 : gfc_add_block_to_block (&outer_loop->post, &se.finalblock);
3397 : 9379 : ss_info->string_length = se.string_length;
3398 : : }
3399 : 9379 : break;
3400 : :
3401 : 41377 : case GFC_SS_CONSTRUCTOR:
3402 : 41377 : if (expr->ts.type == BT_CHARACTER
3403 : 7880 : && ss_info->string_length == NULL
3404 : 7880 : && expr->ts.u.cl
3405 : 7880 : && expr->ts.u.cl->length
3406 : 7536 : && expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
3407 : : {
3408 : 7485 : gfc_init_se (&se, NULL);
3409 : 7485 : gfc_conv_expr_type (&se, expr->ts.u.cl->length,
3410 : : gfc_charlen_type_node);
3411 : 7485 : ss_info->string_length = se.expr;
3412 : 7485 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3413 : 7485 : gfc_add_block_to_block (&outer_loop->post, &se.post);
3414 : : }
3415 : 41377 : trans_array_constructor (ss, where);
3416 : 41377 : break;
3417 : :
3418 : : case GFC_SS_TEMP:
3419 : : case GFC_SS_COMPONENT:
3420 : : /* Do nothing. These are handled elsewhere. */
3421 : : break;
3422 : :
3423 : 0 : default:
3424 : 0 : gcc_unreachable ();
3425 : : }
3426 : : }
3427 : :
3428 : 186080 : if (!subscript)
3429 : 182403 : for (nested_loop = loop->nested; nested_loop;
3430 : 3364 : nested_loop = nested_loop->next)
3431 : 3364 : gfc_add_loop_ss_code (nested_loop, nested_loop->ss, subscript, where);
3432 : : }
3433 : :
3434 : :
3435 : : /* Given an array descriptor expression DESCR and its data pointer DATA, decide
3436 : : whether to either save the data pointer to a variable and use the variable or
3437 : : use the data pointer expression directly without any intermediary variable.
3438 : : */
3439 : :
3440 : : static bool
3441 : 124704 : save_descriptor_data (tree descr, tree data)
3442 : : {
3443 : 124704 : return !(DECL_P (data)
3444 : 114571 : || (TREE_CODE (data) == ADDR_EXPR
3445 : 69235 : && DECL_P (TREE_OPERAND (data, 0)))
3446 : 48664 : || (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (descr))
3447 : 44992 : && TREE_CODE (descr) == COMPONENT_REF
3448 : 9311 : && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (descr, 0)))));
3449 : : }
3450 : :
3451 : :
3452 : : /* Type of the DATA argument passed to walk_tree by substitute_subexpr_in_expr
3453 : : and used by maybe_substitute_expr. */
3454 : :
3455 : : typedef struct
3456 : : {
3457 : : tree target, repl;
3458 : : }
3459 : : substitute_t;
3460 : :
3461 : :
3462 : : /* Check if the expression in *TP is equal to the substitution target provided
3463 : : in DATA->TARGET and replace it with DATA->REPL in that case. This is a
3464 : : callback function for use with walk_tree. */
3465 : :
3466 : : static tree
3467 : 20880 : maybe_substitute_expr (tree *tp, int *walk_subtree, void *data)
3468 : : {
3469 : 20880 : substitute_t *subst = (substitute_t *) data;
3470 : 20880 : if (*tp == subst->target)
3471 : : {
3472 : 4069 : *tp = subst->repl;
3473 : 4069 : *walk_subtree = 0;
3474 : : }
3475 : :
3476 : 20880 : return NULL_TREE;
3477 : : }
3478 : :
3479 : :
3480 : : /* Substitute in EXPR any occurence of TARGET with REPLACEMENT. */
3481 : :
3482 : : static void
3483 : 3864 : substitute_subexpr_in_expr (tree target, tree replacement, tree expr)
3484 : : {
3485 : 3864 : substitute_t subst;
3486 : 3864 : subst.target = target;
3487 : 3864 : subst.repl = replacement;
3488 : :
3489 : 3864 : walk_tree (&expr, maybe_substitute_expr, &subst, nullptr);
3490 : 3864 : }
3491 : :
3492 : :
3493 : : /* Save REF to a fresh variable in all of REPLACEMENT_ROOTS, appending extra
3494 : : code to CODE. Before returning, add REF to REPLACEMENT_ROOTS and clear
3495 : : REF. */
3496 : :
3497 : : static void
3498 : 3668 : save_ref (tree &code, tree &ref, vec<tree> &replacement_roots)
3499 : : {
3500 : 3668 : stmtblock_t tmp_block;
3501 : 3668 : gfc_init_block (&tmp_block);
3502 : 3668 : tree var = gfc_evaluate_now (ref, &tmp_block);
3503 : 3668 : gfc_add_expr_to_block (&tmp_block, code);
3504 : 3668 : code = gfc_finish_block (&tmp_block);
3505 : :
3506 : 3668 : unsigned i;
3507 : 3668 : tree repl_root;
3508 : 7532 : FOR_EACH_VEC_ELT (replacement_roots, i, repl_root)
3509 : 3864 : substitute_subexpr_in_expr (ref, var, repl_root);
3510 : :
3511 : 3668 : replacement_roots.safe_push (ref);
3512 : 3668 : ref = NULL_TREE;
3513 : 3668 : }
3514 : :
3515 : :
3516 : : /* Save the descriptor reference VALUE to storage pointed by DESC_PTR. Before
3517 : : that, try to factor subexpressions of VALUE to variables, adding extra code
3518 : : to BLOCK.
3519 : :
3520 : : The candidate references to factoring are dereferenced pointers because they
3521 : : are cheap to copy and array descriptors because they are often the base of
3522 : : multiple subreferences. */
3523 : :
3524 : : static void
3525 : 315611 : set_factored_descriptor_value (tree *desc_ptr, tree value, stmtblock_t *block)
3526 : : {
3527 : : /* As the reference is processed from outer to inner, variable definitions
3528 : : will be generated in reversed order, so can't be put directly in BLOCK.
3529 : : We use TMP_BLOCK instead. */
3530 : 315611 : tree accumulated_code = NULL_TREE;
3531 : :
3532 : : /* The current candidate to factoring. */
3533 : 315611 : tree saveable_ref = NULL_TREE;
3534 : :
3535 : : /* The root expressions in which we look for subexpressions to replace with
3536 : : variables. */
3537 : 315611 : auto_vec<tree> replacement_roots;
3538 : 315611 : replacement_roots.safe_push (value);
3539 : :
3540 : 315611 : tree data_ref = value;
3541 : 315611 : tree next_ref = NULL_TREE;
3542 : :
3543 : : /* If the candidate reference is not followed by a subreference, it can't be
3544 : : saved to a variable as it may be reallocatable, and we have to keep the
3545 : : parent reference to be able to store the new pointer value in case of
3546 : : reallocation. */
3547 : 315611 : bool maybe_reallocatable = true;
3548 : :
3549 : 412788 : while (true)
3550 : : {
3551 : 412788 : if (!maybe_reallocatable
3552 : 412788 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (data_ref)))
3553 : 1500 : saveable_ref = data_ref;
3554 : :
3555 : 412788 : if (TREE_CODE (data_ref) == INDIRECT_REF)
3556 : : {
3557 : 53450 : next_ref = TREE_OPERAND (data_ref, 0);
3558 : :
3559 : 53450 : if (!maybe_reallocatable)
3560 : : {
3561 : 13552 : if (saveable_ref != NULL_TREE && saveable_ref != data_ref)
3562 : : {
3563 : : /* A reference worth saving has been seen, and now the pointer
3564 : : to the current reference is also worth saving. If the
3565 : : previous reference to save wasn't the current one, do save
3566 : : it now. Otherwise drop it as we prefer saving the
3567 : : pointer. */
3568 : 1786 : save_ref (accumulated_code, saveable_ref, replacement_roots);
3569 : : }
3570 : :
3571 : : /* Don't evaluate the pointer to a variable yet; do it only if the
3572 : : variable would be significantly more simple than the reference
3573 : : it replaces. That is if the reference contains anything
3574 : : different from NOPs, COMPONENTs and DECLs. */
3575 : 13552 : saveable_ref = next_ref;
3576 : : }
3577 : : }
3578 : 359338 : else if (TREE_CODE (data_ref) == COMPONENT_REF)
3579 : : {
3580 : 36578 : maybe_reallocatable = false;
3581 : 36578 : next_ref = TREE_OPERAND (data_ref, 0);
3582 : : }
3583 : 322760 : else if (TREE_CODE (data_ref) == NOP_EXPR)
3584 : 2730 : next_ref = TREE_OPERAND (data_ref, 0);
3585 : : else
3586 : : {
3587 : 320030 : if (DECL_P (data_ref))
3588 : : break;
3589 : :
3590 : 6105 : if (TREE_CODE (data_ref) == ARRAY_REF)
3591 : : {
3592 : 4419 : maybe_reallocatable = false;
3593 : 4419 : next_ref = TREE_OPERAND (data_ref, 0);
3594 : : }
3595 : :
3596 : 6105 : if (saveable_ref != NULL_TREE)
3597 : : /* We have seen a reference worth saving. Do it now. */
3598 : 1882 : save_ref (accumulated_code, saveable_ref, replacement_roots);
3599 : :
3600 : 6105 : if (TREE_CODE (data_ref) != ARRAY_REF)
3601 : : break;
3602 : : }
3603 : :
3604 : : data_ref = next_ref;
3605 : : }
3606 : :
3607 : 315611 : *desc_ptr = value;
3608 : 315611 : gfc_add_expr_to_block (block, accumulated_code);
3609 : 315611 : }
3610 : :
3611 : :
3612 : : /* Translate expressions for the descriptor and data pointer of a SS. */
3613 : : /*GCC ARRAYS*/
3614 : :
3615 : : static void
3616 : 315611 : gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
3617 : : {
3618 : 315611 : gfc_se se;
3619 : 315611 : gfc_ss_info *ss_info;
3620 : 315611 : gfc_array_info *info;
3621 : 315611 : tree tmp;
3622 : :
3623 : 315611 : ss_info = ss->info;
3624 : 315611 : info = &ss_info->data.array;
3625 : :
3626 : : /* Get the descriptor for the array to be scalarized. */
3627 : 315611 : gcc_assert (ss_info->expr->expr_type == EXPR_VARIABLE);
3628 : 315611 : gfc_init_se (&se, NULL);
3629 : 315611 : se.descriptor_only = 1;
3630 : 315611 : gfc_conv_expr_lhs (&se, ss_info->expr);
3631 : 315611 : gfc_add_block_to_block (block, &se.pre);
3632 : 315611 : set_factored_descriptor_value (&info->descriptor, se.expr, block);
3633 : 315611 : ss_info->string_length = se.string_length;
3634 : 315611 : ss_info->class_container = se.class_container;
3635 : :
3636 : 315611 : if (base)
3637 : : {
3638 : 118808 : if (ss_info->expr->ts.type == BT_CHARACTER && !ss_info->expr->ts.deferred
3639 : 22237 : && ss_info->expr->ts.u.cl->length == NULL)
3640 : : {
3641 : : /* Emit a DECL_EXPR for the variable sized array type in
3642 : : GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
3643 : : sizes works correctly. */
3644 : 1097 : tree arraytype = TREE_TYPE (
3645 : : GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (info->descriptor)));
3646 : 1097 : if (! TYPE_NAME (arraytype))
3647 : 899 : TYPE_NAME (arraytype) = build_decl (UNKNOWN_LOCATION, TYPE_DECL,
3648 : : NULL_TREE, arraytype);
3649 : 1097 : gfc_add_expr_to_block (block, build1 (DECL_EXPR, arraytype,
3650 : 1097 : TYPE_NAME (arraytype)));
3651 : : }
3652 : : /* Also the data pointer. */
3653 : 118808 : tmp = gfc_conv_array_data (se.expr);
3654 : : /* If this is a variable or address or a class array, use it directly.
3655 : : Otherwise we must evaluate it now to avoid breaking dependency
3656 : : analysis by pulling the expressions for elemental array indices
3657 : : inside the loop. */
3658 : 118808 : if (save_descriptor_data (se.expr, tmp) && !ss->is_alloc_lhs)
3659 : 34882 : tmp = gfc_evaluate_now (tmp, block);
3660 : 118808 : info->data = tmp;
3661 : :
3662 : 118808 : tmp = gfc_conv_array_offset (se.expr);
3663 : 118808 : if (!ss->is_alloc_lhs)
3664 : 113078 : tmp = gfc_evaluate_now (tmp, block);
3665 : 118808 : info->offset = tmp;
3666 : :
3667 : : /* Make absolutely sure that the saved_offset is indeed saved
3668 : : so that the variable is still accessible after the loops
3669 : : are translated. */
3670 : 118808 : info->saved_offset = info->offset;
3671 : : }
3672 : 315611 : }
3673 : :
3674 : :
3675 : : /* Initialize a gfc_loopinfo structure. */
3676 : :
3677 : : void
3678 : 184151 : gfc_init_loopinfo (gfc_loopinfo * loop)
3679 : : {
3680 : 184151 : int n;
3681 : :
3682 : 184151 : memset (loop, 0, sizeof (gfc_loopinfo));
3683 : 184151 : gfc_init_block (&loop->pre);
3684 : 184151 : gfc_init_block (&loop->post);
3685 : :
3686 : : /* Initially scalarize in order and default to no loop reversal. */
3687 : 3130567 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
3688 : : {
3689 : 2762265 : loop->order[n] = n;
3690 : 2762265 : loop->reverse[n] = GFC_INHIBIT_REVERSE;
3691 : : }
3692 : :
3693 : 184151 : loop->ss = gfc_ss_terminator;
3694 : 184151 : }
3695 : :
3696 : :
3697 : : /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
3698 : : chain. */
3699 : :
3700 : : void
3701 : 184939 : gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
3702 : : {
3703 : 184939 : se->loop = loop;
3704 : 184939 : }
3705 : :
3706 : :
3707 : : /* Return an expression for the data pointer of an array. */
3708 : :
3709 : : tree
3710 : 318431 : gfc_conv_array_data (tree descriptor)
3711 : : {
3712 : 318431 : tree type;
3713 : :
3714 : 318431 : type = TREE_TYPE (descriptor);
3715 : 318431 : if (GFC_ARRAY_TYPE_P (type))
3716 : : {
3717 : 225899 : if (TREE_CODE (type) == POINTER_TYPE)
3718 : : return descriptor;
3719 : : else
3720 : : {
3721 : : /* Descriptorless arrays. */
3722 : 172728 : return gfc_build_addr_expr (NULL_TREE, descriptor);
3723 : : }
3724 : : }
3725 : : else
3726 : 92532 : return gfc_conv_descriptor_data_get (descriptor);
3727 : : }
3728 : :
3729 : :
3730 : : /* Return an expression for the base offset of an array. */
3731 : :
3732 : : tree
3733 : 237280 : gfc_conv_array_offset (tree descriptor)
3734 : : {
3735 : 237280 : tree type;
3736 : :
3737 : 237280 : type = TREE_TYPE (descriptor);
3738 : 237280 : if (GFC_ARRAY_TYPE_P (type))
3739 : 170484 : return GFC_TYPE_ARRAY_OFFSET (type);
3740 : : else
3741 : 66796 : return gfc_conv_descriptor_offset_get (descriptor);
3742 : : }
3743 : :
3744 : :
3745 : : /* Get an expression for the array stride. */
3746 : :
3747 : : tree
3748 : 480019 : gfc_conv_array_stride (tree descriptor, int dim)
3749 : : {
3750 : 480019 : tree tmp;
3751 : 480019 : tree type;
3752 : :
3753 : 480019 : type = TREE_TYPE (descriptor);
3754 : :
3755 : : /* For descriptorless arrays use the array size. */
3756 : 480019 : tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
3757 : 480019 : if (tmp != NULL_TREE)
3758 : : return tmp;
3759 : :
3760 : 108052 : tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]);
3761 : 108052 : return tmp;
3762 : : }
3763 : :
3764 : :
3765 : : /* Like gfc_conv_array_stride, but for the lower bound. */
3766 : :
3767 : : tree
3768 : 315085 : gfc_conv_array_lbound (tree descriptor, int dim)
3769 : : {
3770 : 315085 : tree tmp;
3771 : 315085 : tree type;
3772 : :
3773 : 315085 : type = TREE_TYPE (descriptor);
3774 : :
3775 : 315085 : tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
3776 : 315085 : if (tmp != NULL_TREE)
3777 : : return tmp;
3778 : :
3779 : 18409 : tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]);
3780 : 18409 : return tmp;
3781 : : }
3782 : :
3783 : :
3784 : : /* Like gfc_conv_array_stride, but for the upper bound. */
3785 : :
3786 : : tree
3787 : 204226 : gfc_conv_array_ubound (tree descriptor, int dim)
3788 : : {
3789 : 204226 : tree tmp;
3790 : 204226 : tree type;
3791 : :
3792 : 204226 : type = TREE_TYPE (descriptor);
3793 : :
3794 : 204226 : tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
3795 : 204226 : if (tmp != NULL_TREE)
3796 : : return tmp;
3797 : :
3798 : : /* This should only ever happen when passing an assumed shape array
3799 : : as an actual parameter. The value will never be used. */
3800 : 7851 : if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
3801 : 553 : return gfc_index_zero_node;
3802 : :
3803 : 7298 : tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]);
3804 : 7298 : return tmp;
3805 : : }
3806 : :
3807 : :
3808 : : /* Generate abridged name of a part-ref for use in bounds-check message.
3809 : : Cases:
3810 : : (1) for an ordinary array variable x return "x"
3811 : : (2) for z a DT scalar and array component x (at level 1) return "z%%x"
3812 : : (3) for z a DT scalar and array component x (at level > 1) or
3813 : : for z a DT array and array x (at any number of levels): "z...%%x"
3814 : : */
3815 : :
3816 : : static char *
3817 : 36147 : abridged_ref_name (gfc_expr * expr, gfc_array_ref * ar)
3818 : : {
3819 : 36147 : gfc_ref *ref;
3820 : 36147 : gfc_symbol *sym;
3821 : 36147 : char *ref_name = NULL;
3822 : 36147 : const char *comp_name = NULL;
3823 : 36147 : int len_sym, last_len = 0, level = 0;
3824 : 36147 : bool sym_is_array;
3825 : :
3826 : 36147 : gcc_assert (expr->expr_type == EXPR_VARIABLE && expr->ref != NULL);
3827 : :
3828 : 36147 : sym = expr->symtree->n.sym;
3829 : 72027 : sym_is_array = (sym->ts.type != BT_CLASS
3830 : 36147 : ? sym->as != NULL
3831 : 267 : : IS_CLASS_ARRAY (sym));
3832 : 36147 : len_sym = strlen (sym->name);
3833 : :
3834 : : /* Scan ref chain to get name of the array component (when ar != NULL) or
3835 : : array section, determine depth and remember its component name. */
3836 : 51289 : for (ref = expr->ref; ref; ref = ref->next)
3837 : : {
3838 : 37272 : if (ref->type == REF_COMPONENT
3839 : 808 : && strcmp (ref->u.c.component->name, "_data") != 0)
3840 : : {
3841 : 678 : level++;
3842 : 678 : comp_name = ref->u.c.component->name;
3843 : 678 : continue;
3844 : : }
3845 : :
3846 : 36594 : if (ref->type != REF_ARRAY)
3847 : 150 : continue;
3848 : :
3849 : 36444 : if (ar)
3850 : : {
3851 : 15555 : if (&ref->u.ar == ar)
3852 : : break;
3853 : : }
3854 : 20889 : else if (ref->u.ar.type == AR_SECTION)
3855 : : break;
3856 : : }
3857 : :
3858 : 36147 : if (level > 0)
3859 : 644 : last_len = strlen (comp_name);
3860 : :
3861 : : /* Provide a buffer sufficiently large to hold "x...%%z". */
3862 : 36147 : ref_name = XNEWVEC (char, len_sym + last_len + 6);
3863 : 36147 : strcpy (ref_name, sym->name);
3864 : :
3865 : 36147 : if (level == 1 && !sym_is_array)
3866 : : {
3867 : 352 : strcat (ref_name, "%%");
3868 : 352 : strcat (ref_name, comp_name);
3869 : : }
3870 : 35795 : else if (level > 0)
3871 : : {
3872 : 292 : strcat (ref_name, "...%%");
3873 : 292 : strcat (ref_name, comp_name);
3874 : : }
3875 : :
3876 : 36147 : return ref_name;
3877 : : }
3878 : :
3879 : :
3880 : : /* Generate code to perform an array index bound check. */
3881 : :
3882 : : static tree
3883 : 5356 : trans_array_bound_check (gfc_se * se, gfc_ss *ss, tree index, int n,
3884 : : locus * where, bool check_upper,
3885 : : const char *compname = NULL)
3886 : : {
3887 : 5356 : tree fault;
3888 : 5356 : tree tmp_lo, tmp_up;
3889 : 5356 : tree descriptor;
3890 : 5356 : char *msg;
3891 : 5356 : char *ref_name = NULL;
3892 : 5356 : const char * name = NULL;
3893 : 5356 : gfc_expr *expr;
3894 : :
3895 : 5356 : if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
3896 : : return index;
3897 : :
3898 : 234 : descriptor = ss->info->data.array.descriptor;
3899 : :
3900 : 234 : index = gfc_evaluate_now (index, &se->pre);
3901 : :
3902 : : /* We find a name for the error message. */
3903 : 234 : name = ss->info->expr->symtree->n.sym->name;
3904 : 234 : gcc_assert (name != NULL);
3905 : :
3906 : : /* When we have a component ref, get name of the array section.
3907 : : Note that there can only be one part ref. */
3908 : 234 : expr = ss->info->expr;
3909 : 234 : if (expr->ref && !compname)
3910 : 160 : name = ref_name = abridged_ref_name (expr, NULL);
3911 : :
3912 : 234 : if (VAR_P (descriptor))
3913 : 156 : name = IDENTIFIER_POINTER (DECL_NAME (descriptor));
3914 : :
3915 : : /* Use given (array component) name. */
3916 : 234 : if (compname)
3917 : 74 : name = compname;
3918 : :
3919 : : /* If upper bound is present, include both bounds in the error message. */
3920 : 234 : if (check_upper)
3921 : : {
3922 : 207 : tmp_lo = gfc_conv_array_lbound (descriptor, n);
3923 : 207 : tmp_up = gfc_conv_array_ubound (descriptor, n);
3924 : :
3925 : 207 : if (name)
3926 : 207 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3927 : : "outside of expected range (%%ld:%%ld)", n+1, name);
3928 : : else
3929 : 0 : msg = xasprintf ("Index '%%ld' of dimension %d "
3930 : : "outside of expected range (%%ld:%%ld)", n+1);
3931 : :
3932 : 207 : fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3933 : : index, tmp_lo);
3934 : 207 : gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
3935 : : fold_convert (long_integer_type_node, index),
3936 : : fold_convert (long_integer_type_node, tmp_lo),
3937 : : fold_convert (long_integer_type_node, tmp_up));
3938 : 207 : fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3939 : : index, tmp_up);
3940 : 207 : gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
3941 : : fold_convert (long_integer_type_node, index),
3942 : : fold_convert (long_integer_type_node, tmp_lo),
3943 : : fold_convert (long_integer_type_node, tmp_up));
3944 : 207 : free (msg);
3945 : : }
3946 : : else
3947 : : {
3948 : 27 : tmp_lo = gfc_conv_array_lbound (descriptor, n);
3949 : :
3950 : 27 : if (name)
3951 : 27 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3952 : : "below lower bound of %%ld", n+1, name);
3953 : : else
3954 : 0 : msg = xasprintf ("Index '%%ld' of dimension %d "
3955 : : "below lower bound of %%ld", n+1);
3956 : :
3957 : 27 : fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3958 : : index, tmp_lo);
3959 : 27 : gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
3960 : : fold_convert (long_integer_type_node, index),
3961 : : fold_convert (long_integer_type_node, tmp_lo));
3962 : 27 : free (msg);
3963 : : }
3964 : :
3965 : 234 : free (ref_name);
3966 : 234 : return index;
3967 : : }
3968 : :
3969 : :
3970 : : /* Generate code for bounds checking for elemental dimensions. */
3971 : :
3972 : : static void
3973 : 6667 : array_bound_check_elemental (gfc_se * se, gfc_ss * ss, gfc_expr * expr)
3974 : : {
3975 : 6667 : gfc_array_ref *ar;
3976 : 6667 : gfc_ref *ref;
3977 : 6667 : char *var_name = NULL;
3978 : 6667 : int dim;
3979 : :
3980 : 6667 : if (expr->expr_type == EXPR_VARIABLE)
3981 : : {
3982 : 12469 : for (ref = expr->ref; ref; ref = ref->next)
3983 : : {
3984 : 6259 : if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
3985 : : {
3986 : 3935 : ar = &ref->u.ar;
3987 : 3935 : var_name = abridged_ref_name (expr, ar);
3988 : 8104 : for (dim = 0; dim < ar->dimen; dim++)
3989 : : {
3990 : 4169 : if (ar->dimen_type[dim] == DIMEN_ELEMENT)
3991 : : {
3992 : 74 : gfc_se indexse;
3993 : 74 : gfc_init_se (&indexse, NULL);
3994 : 74 : gfc_conv_expr_type (&indexse, ar->start[dim],
3995 : : gfc_array_index_type);
3996 : 74 : trans_array_bound_check (se, ss, indexse.expr, dim,
3997 : : &ar->where,
3998 : 74 : ar->as->type != AS_ASSUMED_SIZE
3999 : 74 : || dim < ar->dimen - 1,
4000 : : var_name);
4001 : : }
4002 : : }
4003 : 3935 : free (var_name);
4004 : : }
4005 : : }
4006 : : }
4007 : 6667 : }
4008 : :
4009 : :
4010 : : /* Return the offset for an index. Performs bound checking for elemental
4011 : : dimensions. Single element references are processed separately.
4012 : : DIM is the array dimension, I is the loop dimension. */
4013 : :
4014 : : static tree
4015 : 246781 : conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i,
4016 : : gfc_array_ref * ar, tree stride)
4017 : : {
4018 : 246781 : gfc_array_info *info;
4019 : 246781 : tree index;
4020 : 246781 : tree desc;
4021 : 246781 : tree data;
4022 : :
4023 : 246781 : info = &ss->info->data.array;
4024 : :
4025 : : /* Get the index into the array for this dimension. */
4026 : 246781 : if (ar)
4027 : : {
4028 : 175161 : gcc_assert (ar->type != AR_ELEMENT);
4029 : 175161 : switch (ar->dimen_type[dim])
4030 : : {
4031 : 0 : case DIMEN_THIS_IMAGE:
4032 : 0 : gcc_unreachable ();
4033 : 4533 : break;
4034 : 4533 : case DIMEN_ELEMENT:
4035 : : /* Elemental dimension. */
4036 : 4533 : gcc_assert (info->subscript[dim]
4037 : : && info->subscript[dim]->info->type == GFC_SS_SCALAR);
4038 : : /* We've already translated this value outside the loop. */
4039 : 4533 : index = info->subscript[dim]->info->data.scalar.value;
4040 : :
4041 : 9066 : index = trans_array_bound_check (se, ss, index, dim, &ar->where,
4042 : 4533 : ar->as->type != AS_ASSUMED_SIZE
4043 : 4533 : || dim < ar->dimen - 1);
4044 : 4533 : break;
4045 : :
4046 : 749 : case DIMEN_VECTOR:
4047 : 749 : gcc_assert (info && se->loop);
4048 : 749 : gcc_assert (info->subscript[dim]
4049 : : && info->subscript[dim]->info->type == GFC_SS_VECTOR);
4050 : 749 : desc = info->subscript[dim]->info->data.array.descriptor;
4051 : :
4052 : : /* Get a zero-based index into the vector. */
4053 : 749 : index = fold_build2_loc (input_location, MINUS_EXPR,
4054 : : gfc_array_index_type,
4055 : : se->loop->loopvar[i], se->loop->from[i]);
4056 : :
4057 : : /* Multiply the index by the stride. */
4058 : 749 : index = fold_build2_loc (input_location, MULT_EXPR,
4059 : : gfc_array_index_type,
4060 : : index, gfc_conv_array_stride (desc, 0));
4061 : :
4062 : : /* Read the vector to get an index into info->descriptor. */
4063 : 749 : data = build_fold_indirect_ref_loc (input_location,
4064 : : gfc_conv_array_data (desc));
4065 : 749 : index = gfc_build_array_ref (data, index, NULL);
4066 : 749 : index = gfc_evaluate_now (index, &se->pre);
4067 : 749 : index = fold_convert (gfc_array_index_type, index);
4068 : :
4069 : : /* Do any bounds checking on the final info->descriptor index. */
4070 : 1498 : index = trans_array_bound_check (se, ss, index, dim, &ar->where,
4071 : 749 : ar->as->type != AS_ASSUMED_SIZE
4072 : 749 : || dim < ar->dimen - 1);
4073 : 749 : break;
4074 : :
4075 : 169879 : case DIMEN_RANGE:
4076 : : /* Scalarized dimension. */
4077 : 169879 : gcc_assert (info && se->loop);
4078 : :
4079 : : /* Multiply the loop variable by the stride and delta. */
4080 : 169879 : index = se->loop->loopvar[i];
4081 : 169879 : if (!integer_onep (info->stride[dim]))
4082 : 6757 : index = fold_build2_loc (input_location, MULT_EXPR,
4083 : : gfc_array_index_type, index,
4084 : : info->stride[dim]);
4085 : 169879 : if (!integer_zerop (info->delta[dim]))
4086 : 64309 : index = fold_build2_loc (input_location, PLUS_EXPR,
4087 : : gfc_array_index_type, index,
4088 : : info->delta[dim]);
4089 : : break;
4090 : :
4091 : 0 : default:
4092 : 0 : gcc_unreachable ();
4093 : : }
4094 : : }
4095 : : else
4096 : : {
4097 : : /* Temporary array or derived type component. */
4098 : 71620 : gcc_assert (se->loop);
4099 : 71620 : index = se->loop->loopvar[se->loop->order[i]];
4100 : :
4101 : : /* Pointer functions can have stride[0] different from unity.
4102 : : Use the stride returned by the function call and stored in
4103 : : the descriptor for the temporary. */
4104 : 71620 : if (se->ss && se->ss->info->type == GFC_SS_FUNCTION
4105 : 7948 : && se->ss->info->expr
4106 : 7948 : && se->ss->info->expr->symtree
4107 : 7948 : && se->ss->info->expr->symtree->n.sym->result
4108 : 7535 : && se->ss->info->expr->symtree->n.sym->result->attr.pointer)
4109 : 144 : stride = gfc_conv_descriptor_stride_get (info->descriptor,
4110 : : gfc_rank_cst[dim]);
4111 : :
4112 : 71620 : if (info->delta[dim] && !integer_zerop (info->delta[dim]))
4113 : 788 : index = fold_build2_loc (input_location, PLUS_EXPR,
4114 : : gfc_array_index_type, index, info->delta[dim]);
4115 : : }
4116 : :
4117 : : /* Multiply by the stride. */
4118 : 246781 : if (stride != NULL && !integer_onep (stride))
4119 : 75270 : index = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4120 : : index, stride);
4121 : :
4122 : 246781 : return index;
4123 : : }
4124 : :
4125 : :
4126 : : /* Build a scalarized array reference using the vptr 'size'. */
4127 : :
4128 : : static bool
4129 : 188738 : build_class_array_ref (gfc_se *se, tree base, tree index)
4130 : : {
4131 : 188738 : tree size;
4132 : 188738 : tree decl = NULL_TREE;
4133 : 188738 : tree tmp;
4134 : 188738 : gfc_expr *expr = se->ss->info->expr;
4135 : 188738 : gfc_expr *class_expr;
4136 : 188738 : gfc_typespec *ts;
4137 : 188738 : gfc_symbol *sym;
4138 : :
4139 : 188738 : tmp = !VAR_P (base) ? gfc_get_class_from_expr (base) : NULL_TREE;
4140 : :
4141 : 87818 : if (tmp != NULL_TREE)
4142 : : decl = tmp;
4143 : : else
4144 : : {
4145 : : /* The base expression does not contain a class component, either
4146 : : because it is a temporary array or array descriptor. Class
4147 : : array functions are correctly resolved above. */
4148 : 185533 : if (!expr
4149 : 185533 : || (expr->ts.type != BT_CLASS
4150 : 171985 : && !gfc_is_class_array_ref (expr, NULL)))
4151 : 185146 : return false;
4152 : :
4153 : : /* Obtain the expression for the class entity or component that is
4154 : : followed by an array reference, which is not an element, so that
4155 : : the span of the array can be obtained. */
4156 : 387 : class_expr = gfc_find_and_cut_at_last_class_ref (expr, false, &ts);
4157 : :
4158 : 387 : if (!ts)
4159 : : return false;
4160 : :
4161 : 362 : sym = (!class_expr && expr) ? expr->symtree->n.sym : NULL;
4162 : 0 : if (sym && sym->attr.function
4163 : 0 : && sym == sym->result
4164 : 0 : && sym->backend_decl == current_function_decl)
4165 : : /* The temporary is the data field of the class data component
4166 : : of the current function. */
4167 : 0 : decl = gfc_get_fake_result_decl (sym, 0);
4168 : 362 : else if (sym)
4169 : : {
4170 : 0 : if (decl == NULL_TREE)
4171 : 0 : decl = expr->symtree->n.sym->backend_decl;
4172 : : /* For class arrays the tree containing the class is stored in
4173 : : GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl.
4174 : : For all others it's sym's backend_decl directly. */
4175 : 0 : if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl))
4176 : 0 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
4177 : : }
4178 : : else
4179 : 362 : decl = gfc_get_class_from_gfc_expr (class_expr);
4180 : :
4181 : 362 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
4182 : 0 : decl = build_fold_indirect_ref_loc (input_location, decl);
4183 : :
4184 : 362 : if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl)))
4185 : : return false;
4186 : : }
4187 : :
4188 : 3567 : se->class_vptr = gfc_evaluate_now (gfc_class_vptr_get (decl), &se->pre);
4189 : :
4190 : 3567 : size = gfc_class_vtab_size_get (decl);
4191 : : /* For unlimited polymorphic entities then _len component needs to be
4192 : : multiplied with the size. */
4193 : 3567 : size = gfc_resize_class_size_with_len (&se->pre, decl, size);
4194 : 3567 : size = fold_convert (TREE_TYPE (index), size);
4195 : :
4196 : : /* Return the element in the se expression. */
4197 : 3567 : se->expr = gfc_build_spanned_array_ref (base, index, size);
4198 : 3567 : return true;
4199 : : }
4200 : :
4201 : :
4202 : : /* Indicates that the tree EXPR is a reference to an array that can’t
4203 : : have any negative stride. */
4204 : :
4205 : : static bool
4206 : 301113 : non_negative_strides_array_p (tree expr)
4207 : : {
4208 : 313701 : if (expr == NULL_TREE)
4209 : : return false;
4210 : :
4211 : 313701 : tree type = TREE_TYPE (expr);
4212 : 313701 : if (POINTER_TYPE_P (type))
4213 : 65980 : type = TREE_TYPE (type);
4214 : :
4215 : 313701 : if (TYPE_LANG_SPECIFIC (type))
4216 : : {
4217 : 313701 : gfc_array_kind array_kind = GFC_TYPE_ARRAY_AKIND (type);
4218 : :
4219 : 313701 : if (array_kind == GFC_ARRAY_ALLOCATABLE
4220 : 313701 : || array_kind == GFC_ARRAY_ASSUMED_SHAPE_CONT)
4221 : : return true;
4222 : : }
4223 : :
4224 : : /* An array with descriptor can have negative strides.
4225 : : We try to be conservative and return false by default here
4226 : : if we don’t recognize a contiguous array instead of
4227 : : returning false if we can identify a non-contiguous one. */
4228 : 260514 : if (!GFC_ARRAY_TYPE_P (type))
4229 : : return false;
4230 : :
4231 : : /* If the array was originally a dummy with a descriptor, strides can be
4232 : : negative. */
4233 : 227765 : if (DECL_P (expr)
4234 : 218836 : && DECL_LANG_SPECIFIC (expr)
4235 : 45895 : && GFC_DECL_SAVED_DESCRIPTOR (expr)
4236 : 240372 : && GFC_DECL_SAVED_DESCRIPTOR (expr) != expr)
4237 : 12588 : return non_negative_strides_array_p (GFC_DECL_SAVED_DESCRIPTOR (expr));
4238 : :
4239 : : return true;
4240 : : }
4241 : :
4242 : :
4243 : : /* Build a scalarized reference to an array. */
4244 : :
4245 : : static void
4246 : 188738 : gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar,
4247 : : bool tmp_array = false)
4248 : : {
4249 : 188738 : gfc_array_info *info;
4250 : 188738 : tree decl = NULL_TREE;
4251 : 188738 : tree index;
4252 : 188738 : tree base;
4253 : 188738 : gfc_ss *ss;
4254 : 188738 : gfc_expr *expr;
4255 : 188738 : int n;
4256 : :
4257 : 188738 : ss = se->ss;
4258 : 188738 : expr = ss->info->expr;
4259 : 188738 : info = &ss->info->data.array;
4260 : 188738 : if (ar)
4261 : 128864 : n = se->loop->order[0];
4262 : : else
4263 : : n = 0;
4264 : :
4265 : 188738 : index = conv_array_index_offset (se, ss, ss->dim[n], n, ar, info->stride0);
4266 : : /* Add the offset for this dimension to the stored offset for all other
4267 : : dimensions. */
4268 : 188738 : if (info->offset && !integer_zerop (info->offset))
4269 : 138149 : index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4270 : : index, info->offset);
4271 : :
4272 : 188738 : base = build_fold_indirect_ref_loc (input_location, info->data);
4273 : :
4274 : : /* Use the vptr 'size' field to access the element of a class array. */
4275 : 188738 : if (build_class_array_ref (se, base, index))
4276 : 3567 : return;
4277 : :
4278 : 185171 : if (get_CFI_desc (NULL, expr, &decl, ar))
4279 : 442 : decl = build_fold_indirect_ref_loc (input_location, decl);
4280 : :
4281 : : /* A pointer array component can be detected from its field decl. Fix
4282 : : the descriptor, mark the resulting variable decl and pass it to
4283 : : gfc_build_array_ref. */
4284 : 185171 : if (is_pointer_array (info->descriptor)
4285 : 185171 : || (expr && expr->ts.deferred && info->descriptor
4286 : 2741 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info->descriptor))))
4287 : : {
4288 : 8869 : if (TREE_CODE (info->descriptor) == COMPONENT_REF)
4289 : 1474 : decl = info->descriptor;
4290 : 7395 : else if (INDIRECT_REF_P (info->descriptor))
4291 : 1457 : decl = TREE_OPERAND (info->descriptor, 0);
4292 : :
4293 : 8869 : if (decl == NULL_TREE)
4294 : 5938 : decl = info->descriptor;
4295 : : }
4296 : :
4297 : 185171 : bool non_negative_stride = tmp_array
4298 : 185171 : || non_negative_strides_array_p (info->descriptor);
4299 : 185171 : se->expr = gfc_build_array_ref (base, index, decl,
4300 : : non_negative_stride);
4301 : : }
4302 : :
4303 : :
4304 : : /* Translate access of temporary array. */
4305 : :
4306 : : void
4307 : 59874 : gfc_conv_tmp_array_ref (gfc_se * se)
4308 : : {
4309 : 59874 : se->string_length = se->ss->info->string_length;
4310 : 59874 : gfc_conv_scalarized_array_ref (se, NULL, true);
4311 : 59874 : gfc_advance_se_ss_chain (se);
4312 : 59874 : }
4313 : :
4314 : : /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
4315 : :
4316 : : static void
4317 : 261415 : add_to_offset (tree *cst_offset, tree *offset, tree t)
4318 : : {
4319 : 261415 : if (TREE_CODE (t) == INTEGER_CST)
4320 : 131512 : *cst_offset = int_const_binop (PLUS_EXPR, *cst_offset, t);
4321 : : else
4322 : : {
4323 : 129903 : if (!integer_zerop (*offset))
4324 : 46940 : *offset = fold_build2_loc (input_location, PLUS_EXPR,
4325 : : gfc_array_index_type, *offset, t);
4326 : : else
4327 : 82963 : *offset = t;
4328 : : }
4329 : 261415 : }
4330 : :
4331 : :
4332 : : static tree
4333 : 175428 : build_array_ref (tree desc, tree offset, tree decl, tree vptr)
4334 : : {
4335 : 175428 : tree tmp;
4336 : 175428 : tree type;
4337 : 175428 : tree cdesc;
4338 : :
4339 : : /* For class arrays the class declaration is stored in the saved
4340 : : descriptor. */
4341 : 175428 : if (INDIRECT_REF_P (desc)
4342 : 7265 : && DECL_LANG_SPECIFIC (TREE_OPERAND (desc, 0))
4343 : 177692 : && GFC_DECL_SAVED_DESCRIPTOR (TREE_OPERAND (desc, 0)))
4344 : 834 : cdesc = gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (
4345 : : TREE_OPERAND (desc, 0)));
4346 : : else
4347 : : cdesc = desc;
4348 : :
4349 : : /* Class container types do not always have the GFC_CLASS_TYPE_P
4350 : : but the canonical type does. */
4351 : 175428 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdesc))
4352 : 175428 : && TREE_CODE (cdesc) == COMPONENT_REF)
4353 : : {
4354 : 9625 : type = TREE_TYPE (TREE_OPERAND (cdesc, 0));
4355 : 9625 : if (TYPE_CANONICAL (type)
4356 : 9625 : && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type)))
4357 : 3435 : vptr = gfc_class_vptr_get (TREE_OPERAND (cdesc, 0));
4358 : : }
4359 : :
4360 : 175428 : tmp = gfc_conv_array_data (desc);
4361 : 175428 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
4362 : 175428 : tmp = gfc_build_array_ref (tmp, offset, decl,
4363 : 175428 : non_negative_strides_array_p (desc),
4364 : : vptr);
4365 : 175428 : return tmp;
4366 : : }
4367 : :
4368 : :
4369 : : /* Build an array reference. se->expr already holds the array descriptor.
4370 : : This should be either a variable, indirect variable reference or component
4371 : : reference. For arrays which do not have a descriptor, se->expr will be
4372 : : the data pointer.
4373 : : a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
4374 : :
4375 : : void
4376 : 249978 : gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
4377 : : locus * where)
4378 : : {
4379 : 249978 : int n;
4380 : 249978 : tree offset, cst_offset;
4381 : 249978 : tree tmp;
4382 : 249978 : tree stride;
4383 : 249978 : tree decl = NULL_TREE;
4384 : 249978 : gfc_se indexse;
4385 : 249978 : gfc_se tmpse;
4386 : 249978 : gfc_symbol * sym = expr->symtree->n.sym;
4387 : 249978 : char *var_name = NULL;
4388 : :
4389 : 249978 : if (ar->stat)
4390 : : {
4391 : 3 : gfc_se statse;
4392 : :
4393 : 3 : gfc_init_se (&statse, NULL);
4394 : 3 : gfc_conv_expr_lhs (&statse, ar->stat);
4395 : 3 : gfc_add_block_to_block (&se->pre, &statse.pre);
4396 : 3 : gfc_add_modify (&se->pre, statse.expr, integer_zero_node);
4397 : : }
4398 : 249978 : if (ar->dimen == 0)
4399 : : {
4400 : 3677 : gcc_assert (ar->codimen || sym->attr.select_rank_temporary
4401 : : || (ar->as && ar->as->corank));
4402 : :
4403 : 3677 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
4404 : 812 : se->expr = build_fold_indirect_ref (gfc_conv_array_data (se->expr));
4405 : : else
4406 : : {
4407 : 2865 : if (GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr))
4408 : 2865 : && TREE_CODE (TREE_TYPE (se->expr)) == POINTER_TYPE)
4409 : 1935 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
4410 : :
4411 : : /* Use the actual tree type and not the wrapped coarray. */
4412 : 2865 : if (!se->want_pointer)
4413 : 2042 : se->expr = fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se->expr)),
4414 : : se->expr);
4415 : : }
4416 : :
4417 : 132541 : return;
4418 : : }
4419 : :
4420 : : /* Handle scalarized references separately. */
4421 : 246301 : if (ar->type != AR_ELEMENT)
4422 : : {
4423 : 128864 : gfc_conv_scalarized_array_ref (se, ar);
4424 : 128864 : gfc_advance_se_ss_chain (se);
4425 : 128864 : return;
4426 : : }
4427 : :
4428 : 117437 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
4429 : 11493 : var_name = abridged_ref_name (expr, ar);
4430 : :
4431 : 117437 : decl = se->expr;
4432 : 117437 : if (UNLIMITED_POLY(sym)
4433 : 104 : && IS_CLASS_ARRAY (sym)
4434 : 103 : && sym->attr.dummy
4435 : 60 : && ar->as->type != AS_DEFERRED)
4436 : 48 : decl = sym->backend_decl;
4437 : :
4438 : 117437 : cst_offset = offset = gfc_index_zero_node;
4439 : 117437 : add_to_offset (&cst_offset, &offset, gfc_conv_array_offset (decl));
4440 : :
4441 : : /* Calculate the offsets from all the dimensions. Make sure to associate
4442 : : the final offset so that we form a chain of loop invariant summands. */
4443 : 261415 : for (n = ar->dimen - 1; n >= 0; n--)
4444 : : {
4445 : : /* Calculate the index for this dimension. */
4446 : 143978 : gfc_init_se (&indexse, se);
4447 : 143978 : gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
4448 : 143978 : gfc_add_block_to_block (&se->pre, &indexse.pre);
4449 : :
4450 : 143978 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && ! expr->no_bounds_check)
4451 : : {
4452 : : /* Check array bounds. */
4453 : 15035 : tree cond;
4454 : 15035 : char *msg;
4455 : :
4456 : : /* Evaluate the indexse.expr only once. */
4457 : 15035 : indexse.expr = save_expr (indexse.expr);
4458 : :
4459 : : /* Lower bound. */
4460 : 15035 : tmp = gfc_conv_array_lbound (decl, n);
4461 : 15035 : if (sym->attr.temporary)
4462 : : {
4463 : 18 : gfc_init_se (&tmpse, se);
4464 : 18 : gfc_conv_expr_type (&tmpse, ar->as->lower[n],
4465 : : gfc_array_index_type);
4466 : 18 : gfc_add_block_to_block (&se->pre, &tmpse.pre);
4467 : 18 : tmp = tmpse.expr;
4468 : : }
4469 : :
4470 : 15035 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
4471 : : indexse.expr, tmp);
4472 : 15035 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4473 : : "below lower bound of %%ld", n+1, var_name);
4474 : 15035 : gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
4475 : : fold_convert (long_integer_type_node,
4476 : : indexse.expr),
4477 : : fold_convert (long_integer_type_node, tmp));
4478 : 15035 : free (msg);
4479 : :
4480 : : /* Upper bound, but not for the last dimension of assumed-size
4481 : : arrays. */
4482 : 15035 : if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE)
4483 : : {
4484 : 13302 : tmp = gfc_conv_array_ubound (decl, n);
4485 : 13302 : if (sym->attr.temporary)
4486 : : {
4487 : 18 : gfc_init_se (&tmpse, se);
4488 : 18 : gfc_conv_expr_type (&tmpse, ar->as->upper[n],
4489 : : gfc_array_index_type);
4490 : 18 : gfc_add_block_to_block (&se->pre, &tmpse.pre);
4491 : 18 : tmp = tmpse.expr;
4492 : : }
4493 : :
4494 : 13302 : cond = fold_build2_loc (input_location, GT_EXPR,
4495 : : logical_type_node, indexse.expr, tmp);
4496 : 13302 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4497 : : "above upper bound of %%ld", n+1, var_name);
4498 : 13302 : gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
4499 : : fold_convert (long_integer_type_node,
4500 : : indexse.expr),
4501 : : fold_convert (long_integer_type_node, tmp));
4502 : 13302 : free (msg);
4503 : : }
4504 : : }
4505 : :
4506 : : /* Multiply the index by the stride. */
4507 : 143978 : stride = gfc_conv_array_stride (decl, n);
4508 : 143978 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4509 : : indexse.expr, stride);
4510 : :
4511 : : /* And add it to the total. */
4512 : 143978 : add_to_offset (&cst_offset, &offset, tmp);
4513 : : }
4514 : :
4515 : 117437 : if (!integer_zerop (cst_offset))
4516 : 62901 : offset = fold_build2_loc (input_location, PLUS_EXPR,
4517 : : gfc_array_index_type, offset, cst_offset);
4518 : :
4519 : : /* A pointer array component can be detected from its field decl. Fix
4520 : : the descriptor, mark the resulting variable decl and pass it to
4521 : : build_array_ref. */
4522 : 117437 : decl = NULL_TREE;
4523 : 117437 : if (get_CFI_desc (sym, expr, &decl, ar))
4524 : 3589 : decl = build_fold_indirect_ref_loc (input_location, decl);
4525 : 116555 : if (!expr->ts.deferred && !sym->attr.codimension
4526 : 232290 : && is_pointer_array (se->expr))
4527 : : {
4528 : 4879 : if (TREE_CODE (se->expr) == COMPONENT_REF)
4529 : 1454 : decl = se->expr;
4530 : 3425 : else if (INDIRECT_REF_P (se->expr))
4531 : 983 : decl = TREE_OPERAND (se->expr, 0);
4532 : : else
4533 : 2442 : decl = se->expr;
4534 : : }
4535 : 112558 : else if (expr->ts.deferred
4536 : 111676 : || (sym->ts.type == BT_CHARACTER
4537 : 14546 : && sym->attr.select_type_temporary))
4538 : : {
4539 : 2586 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
4540 : : {
4541 : 2430 : decl = se->expr;
4542 : 2430 : if (INDIRECT_REF_P (decl))
4543 : 20 : decl = TREE_OPERAND (decl, 0);
4544 : : }
4545 : : else
4546 : 156 : decl = sym->backend_decl;
4547 : : }
4548 : 109972 : else if (sym->ts.type == BT_CLASS)
4549 : : {
4550 : 2078 : if (UNLIMITED_POLY (sym))
4551 : : {
4552 : 104 : gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr);
4553 : 104 : gfc_init_se (&tmpse, NULL);
4554 : 104 : gfc_conv_expr (&tmpse, class_expr);
4555 : 104 : if (!se->class_vptr)
4556 : 104 : se->class_vptr = gfc_class_vptr_get (tmpse.expr);
4557 : 104 : gfc_free_expr (class_expr);
4558 : 104 : decl = tmpse.expr;
4559 : 104 : }
4560 : : else
4561 : 1974 : decl = NULL_TREE;
4562 : : }
4563 : :
4564 : 117437 : free (var_name);
4565 : 117437 : se->expr = build_array_ref (se->expr, offset, decl, se->class_vptr);
4566 : : }
4567 : :
4568 : :
4569 : : /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
4570 : : LOOP_DIM dimension (if any) to array's offset. */
4571 : :
4572 : : static void
4573 : 58043 : add_array_offset (stmtblock_t *pblock, gfc_loopinfo *loop, gfc_ss *ss,
4574 : : gfc_array_ref *ar, int array_dim, int loop_dim)
4575 : : {
4576 : 58043 : gfc_se se;
4577 : 58043 : gfc_array_info *info;
4578 : 58043 : tree stride, index;
4579 : :
4580 : 58043 : info = &ss->info->data.array;
4581 : :
4582 : 58043 : gfc_init_se (&se, NULL);
4583 : 58043 : se.loop = loop;
4584 : 58043 : se.expr = info->descriptor;
4585 : 58043 : stride = gfc_conv_array_stride (info->descriptor, array_dim);
4586 : 58043 : index = conv_array_index_offset (&se, ss, array_dim, loop_dim, ar, stride);
4587 : 58043 : gfc_add_block_to_block (pblock, &se.pre);
4588 : :
4589 : 58043 : info->offset = fold_build2_loc (input_location, PLUS_EXPR,
4590 : : gfc_array_index_type,
4591 : : info->offset, index);
4592 : 58043 : info->offset = gfc_evaluate_now (info->offset, pblock);
4593 : 58043 : }
4594 : :
4595 : :
4596 : : /* Generate the code to be executed immediately before entering a
4597 : : scalarization loop. */
4598 : :
4599 : : static void
4600 : 142902 : gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
4601 : : stmtblock_t * pblock)
4602 : : {
4603 : 142902 : tree stride;
4604 : 142902 : gfc_ss_info *ss_info;
4605 : 142902 : gfc_array_info *info;
4606 : 142902 : gfc_ss_type ss_type;
4607 : 142902 : gfc_ss *ss, *pss;
4608 : 142902 : gfc_loopinfo *ploop;
4609 : 142902 : gfc_array_ref *ar;
4610 : :
4611 : : /* This code will be executed before entering the scalarization loop
4612 : : for this dimension. */
4613 : 434746 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4614 : : {
4615 : 291844 : ss_info = ss->info;
4616 : :
4617 : 291844 : if ((ss_info->useflags & flag) == 0)
4618 : 1468 : continue;
4619 : :
4620 : 290376 : ss_type = ss_info->type;
4621 : 354175 : if (ss_type != GFC_SS_SECTION
4622 : : && ss_type != GFC_SS_FUNCTION
4623 : 290376 : && ss_type != GFC_SS_CONSTRUCTOR
4624 : 290376 : && ss_type != GFC_SS_COMPONENT)
4625 : 63799 : continue;
4626 : :
4627 : 226577 : info = &ss_info->data.array;
4628 : :
4629 : 226577 : gcc_assert (dim < ss->dimen);
4630 : 226577 : gcc_assert (ss->dimen == loop->dimen);
4631 : :
4632 : 226577 : if (info->ref)
4633 : 159477 : ar = &info->ref->u.ar;
4634 : : else
4635 : : ar = NULL;
4636 : :
4637 : 226577 : if (dim == loop->dimen - 1 && loop->parent != NULL)
4638 : : {
4639 : : /* If we are in the outermost dimension of this loop, the previous
4640 : : dimension shall be in the parent loop. */
4641 : 4687 : gcc_assert (ss->parent != NULL);
4642 : :
4643 : 4687 : pss = ss->parent;
4644 : 4687 : ploop = loop->parent;
4645 : :
4646 : : /* ss and ss->parent are about the same array. */
4647 : 4687 : gcc_assert (ss_info == pss->info);
4648 : : }
4649 : : else
4650 : : {
4651 : : ploop = loop;
4652 : : pss = ss;
4653 : : }
4654 : :
4655 : 226577 : if (dim == loop->dimen - 1 && loop->parent == NULL)
4656 : : {
4657 : 173067 : gcc_assert (0 == ploop->order[0]);
4658 : :
4659 : 346134 : stride = gfc_conv_array_stride (info->descriptor,
4660 : 173067 : innermost_ss (ss)->dim[0]);
4661 : :
4662 : : /* Calculate the stride of the innermost loop. Hopefully this will
4663 : : allow the backend optimizers to do their stuff more effectively.
4664 : : */
4665 : 173067 : info->stride0 = gfc_evaluate_now (stride, pblock);
4666 : :
4667 : : /* For the outermost loop calculate the offset due to any
4668 : : elemental dimensions. It will have been initialized with the
4669 : : base offset of the array. */
4670 : 173067 : if (info->ref)
4671 : : {
4672 : 279350 : for (int i = 0; i < ar->dimen; i++)
4673 : : {
4674 : 161637 : if (ar->dimen_type[i] != DIMEN_ELEMENT)
4675 : 157104 : continue;
4676 : :
4677 : 4533 : add_array_offset (pblock, loop, ss, ar, i, /* unused */ -1);
4678 : : }
4679 : : }
4680 : : }
4681 : : else
4682 : : {
4683 : 53510 : int i;
4684 : :
4685 : 53510 : if (dim == loop->dimen - 1)
4686 : : i = 0;
4687 : : else
4688 : 48823 : i = dim + 1;
4689 : :
4690 : : /* For the time being, there is no loop reordering. */
4691 : 53510 : gcc_assert (i == ploop->order[i]);
4692 : 53510 : i = ploop->order[i];
4693 : :
4694 : : /* Add the offset for the previous loop dimension. */
4695 : 53510 : add_array_offset (pblock, ploop, ss, ar, pss->dim[i], i);
4696 : : }
4697 : :
4698 : : /* Remember this offset for the second loop. */
4699 : 226577 : if (dim == loop->temp_dim - 1 && loop->parent == NULL)
4700 : 54244 : info->saved_offset = info->offset;
4701 : : }
4702 : 142902 : }
4703 : :
4704 : :
4705 : : /* Start a scalarized expression. Creates a scope and declares loop
4706 : : variables. */
4707 : :
4708 : : void
4709 : 113304 : gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
4710 : : {
4711 : 113304 : int dim;
4712 : 113304 : int n;
4713 : 113304 : int flags;
4714 : :
4715 : 113304 : gcc_assert (!loop->array_parameter);
4716 : :
4717 : 254627 : for (dim = loop->dimen - 1; dim >= 0; dim--)
4718 : : {
4719 : 141323 : n = loop->order[dim];
4720 : :
4721 : 141323 : gfc_start_block (&loop->code[n]);
4722 : :
4723 : : /* Create the loop variable. */
4724 : 141323 : loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
4725 : :
4726 : 141323 : if (dim < loop->temp_dim)
4727 : : flags = 3;
4728 : : else
4729 : 95534 : flags = 1;
4730 : : /* Calculate values that will be constant within this loop. */
4731 : 141323 : gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
4732 : : }
4733 : 113304 : gfc_start_block (pbody);
4734 : 113304 : }
4735 : :
4736 : :
4737 : : /* Generates the actual loop code for a scalarization loop. */
4738 : :
4739 : : static void
4740 : 155370 : gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
4741 : : stmtblock_t * pbody)
4742 : : {
4743 : 155370 : stmtblock_t block;
4744 : 155370 : tree cond;
4745 : 155370 : tree tmp;
4746 : 155370 : tree loopbody;
4747 : 155370 : tree exit_label;
4748 : 155370 : tree stmt;
4749 : 155370 : tree init;
4750 : 155370 : tree incr;
4751 : :
4752 : 155370 : if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS
4753 : : | OMPWS_SCALARIZER_BODY))
4754 : : == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS)
4755 : 108 : && n == loop->dimen - 1)
4756 : : {
4757 : : /* We create an OMP_FOR construct for the outermost scalarized loop. */
4758 : 80 : init = make_tree_vec (1);
4759 : 80 : cond = make_tree_vec (1);
4760 : 80 : incr = make_tree_vec (1);
4761 : :
4762 : : /* Cycle statement is implemented with a goto. Exit statement must not
4763 : : be present for this loop. */
4764 : 80 : exit_label = gfc_build_label_decl (NULL_TREE);
4765 : 80 : TREE_USED (exit_label) = 1;
4766 : :
4767 : : /* Label for cycle statements (if needed). */
4768 : 80 : tmp = build1_v (LABEL_EXPR, exit_label);
4769 : 80 : gfc_add_expr_to_block (pbody, tmp);
4770 : :
4771 : 80 : stmt = make_node (OMP_FOR);
4772 : :
4773 : 80 : TREE_TYPE (stmt) = void_type_node;
4774 : 80 : OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody);
4775 : :
4776 : 80 : OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location,
4777 : : OMP_CLAUSE_SCHEDULE);
4778 : 80 : OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt))
4779 : 80 : = OMP_CLAUSE_SCHEDULE_STATIC;
4780 : 80 : if (ompws_flags & OMPWS_NOWAIT)
4781 : 33 : OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt))
4782 : 66 : = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT);
4783 : :
4784 : : /* Initialize the loopvar. */
4785 : 80 : TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n],
4786 : : loop->from[n]);
4787 : 80 : OMP_FOR_INIT (stmt) = init;
4788 : : /* The exit condition. */
4789 : 80 : TREE_VEC_ELT (cond, 0) = build2_loc (input_location, LE_EXPR,
4790 : : logical_type_node,
4791 : : loop->loopvar[n], loop->to[n]);
4792 : 80 : SET_EXPR_LOCATION (TREE_VEC_ELT (cond, 0), input_location);
4793 : 80 : OMP_FOR_COND (stmt) = cond;
4794 : : /* Increment the loopvar. */
4795 : 80 : tmp = build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4796 : : loop->loopvar[n], gfc_index_one_node);
4797 : 80 : TREE_VEC_ELT (incr, 0) = fold_build2_loc (input_location, MODIFY_EXPR,
4798 : : void_type_node, loop->loopvar[n], tmp);
4799 : 80 : OMP_FOR_INCR (stmt) = incr;
4800 : :
4801 : 80 : ompws_flags &= ~OMPWS_CURR_SINGLEUNIT;
4802 : 80 : gfc_add_expr_to_block (&loop->code[n], stmt);
4803 : : }
4804 : : else
4805 : : {
4806 : 310580 : bool reverse_loop = (loop->reverse[n] == GFC_REVERSE_SET)
4807 : 155290 : && (loop->temp_ss == NULL);
4808 : :
4809 : 155290 : loopbody = gfc_finish_block (pbody);
4810 : :
4811 : 155290 : if (reverse_loop)
4812 : 202 : std::swap (loop->from[n], loop->to[n]);
4813 : :
4814 : : /* Initialize the loopvar. */
4815 : 155290 : if (loop->loopvar[n] != loop->from[n])
4816 : 154469 : gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
4817 : :
4818 : 155290 : exit_label = gfc_build_label_decl (NULL_TREE);
4819 : :
4820 : : /* Generate the loop body. */
4821 : 155290 : gfc_init_block (&block);
4822 : :
4823 : : /* The exit condition. */
4824 : 310378 : cond = fold_build2_loc (input_location, reverse_loop ? LT_EXPR : GT_EXPR,
4825 : : logical_type_node, loop->loopvar[n], loop->to[n]);
4826 : 155290 : tmp = build1_v (GOTO_EXPR, exit_label);
4827 : 155290 : TREE_USED (exit_label) = 1;
4828 : 155290 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
4829 : 155290 : gfc_add_expr_to_block (&block, tmp);
4830 : :
4831 : : /* The main body. */
4832 : 155290 : gfc_add_expr_to_block (&block, loopbody);
4833 : :
4834 : : /* Increment the loopvar. */
4835 : 310378 : tmp = fold_build2_loc (input_location,
4836 : : reverse_loop ? MINUS_EXPR : PLUS_EXPR,
4837 : : gfc_array_index_type, loop->loopvar[n],
4838 : : gfc_index_one_node);
4839 : :
4840 : 155290 : gfc_add_modify (&block, loop->loopvar[n], tmp);
4841 : :
4842 : : /* Build the loop. */
4843 : 155290 : tmp = gfc_finish_block (&block);
4844 : 155290 : tmp = build1_v (LOOP_EXPR, tmp);
4845 : 155290 : gfc_add_expr_to_block (&loop->code[n], tmp);
4846 : :
4847 : : /* Add the exit label. */
4848 : 155290 : tmp = build1_v (LABEL_EXPR, exit_label);
4849 : 155290 : gfc_add_expr_to_block (&loop->code[n], tmp);
4850 : : }
4851 : :
4852 : 155370 : }
4853 : :
4854 : :
4855 : : /* Finishes and generates the loops for a scalarized expression. */
4856 : :
4857 : : void
4858 : 117665 : gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
4859 : : {
4860 : 117665 : int dim;
4861 : 117665 : int n;
4862 : 117665 : gfc_ss *ss;
4863 : 117665 : stmtblock_t *pblock;
4864 : 117665 : tree tmp;
4865 : :
4866 : 117665 : pblock = body;
4867 : : /* Generate the loops. */
4868 : 263340 : for (dim = 0; dim < loop->dimen; dim++)
4869 : : {
4870 : 145675 : n = loop->order[dim];
4871 : 145675 : gfc_trans_scalarized_loop_end (loop, n, pblock);
4872 : 145675 : loop->loopvar[n] = NULL_TREE;
4873 : 145675 : pblock = &loop->code[n];
4874 : : }
4875 : :
4876 : 117665 : tmp = gfc_finish_block (pblock);
4877 : 117665 : gfc_add_expr_to_block (&loop->pre, tmp);
4878 : :
4879 : : /* Clear all the used flags. */
4880 : 346679 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4881 : 229014 : if (ss->parent == NULL)
4882 : 224264 : ss->info->useflags = 0;
4883 : 117665 : }
4884 : :
4885 : :
4886 : : /* Finish the main body of a scalarized expression, and start the secondary
4887 : : copying body. */
4888 : :
4889 : : void
4890 : 8116 : gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
4891 : : {
4892 : 8116 : int dim;
4893 : 8116 : int n;
4894 : 8116 : stmtblock_t *pblock;
4895 : 8116 : gfc_ss *ss;
4896 : :
4897 : 8116 : pblock = body;
4898 : : /* We finish as many loops as are used by the temporary. */
4899 : 9695 : for (dim = 0; dim < loop->temp_dim - 1; dim++)
4900 : : {
4901 : 1579 : n = loop->order[dim];
4902 : 1579 : gfc_trans_scalarized_loop_end (loop, n, pblock);
4903 : 1579 : loop->loopvar[n] = NULL_TREE;
4904 : 1579 : pblock = &loop->code[n];
4905 : : }
4906 : :
4907 : : /* We don't want to finish the outermost loop entirely. */
4908 : 8116 : n = loop->order[loop->temp_dim - 1];
4909 : 8116 : gfc_trans_scalarized_loop_end (loop, n, pblock);
4910 : :
4911 : : /* Restore the initial offsets. */
4912 : 23129 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4913 : : {
4914 : 15013 : gfc_ss_type ss_type;
4915 : 15013 : gfc_ss_info *ss_info;
4916 : :
4917 : 15013 : ss_info = ss->info;
4918 : :
4919 : 15013 : if ((ss_info->useflags & 2) == 0)
4920 : 4423 : continue;
4921 : :
4922 : 10590 : ss_type = ss_info->type;
4923 : 10744 : if (ss_type != GFC_SS_SECTION
4924 : : && ss_type != GFC_SS_FUNCTION
4925 : 10590 : && ss_type != GFC_SS_CONSTRUCTOR
4926 : 10590 : && ss_type != GFC_SS_COMPONENT)
4927 : 154 : continue;
4928 : :
4929 : 10436 : ss_info->data.array.offset = ss_info->data.array.saved_offset;
4930 : : }
4931 : :
4932 : : /* Restart all the inner loops we just finished. */
4933 : 9695 : for (dim = loop->temp_dim - 2; dim >= 0; dim--)
4934 : : {
4935 : 1579 : n = loop->order[dim];
4936 : :
4937 : 1579 : gfc_start_block (&loop->code[n]);
4938 : :
4939 : 1579 : loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
4940 : :
4941 : 1579 : gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
4942 : : }
4943 : :
4944 : : /* Start a block for the secondary copying code. */
4945 : 8116 : gfc_start_block (body);
4946 : 8116 : }
4947 : :
4948 : :
4949 : : /* Precalculate (either lower or upper) bound of an array section.
4950 : : BLOCK: Block in which the (pre)calculation code will go.
4951 : : BOUNDS[DIM]: Where the bound value will be stored once evaluated.
4952 : : VALUES[DIM]: Specified bound (NULL <=> unspecified).
4953 : : DESC: Array descriptor from which the bound will be picked if unspecified
4954 : : (either lower or upper bound according to LBOUND). */
4955 : :
4956 : : static void
4957 : 504841 : evaluate_bound (stmtblock_t *block, tree *bounds, gfc_expr ** values,
4958 : : tree desc, int dim, bool lbound, bool deferred, bool save_value)
4959 : : {
4960 : 504841 : gfc_se se;
4961 : 504841 : gfc_expr * input_val = values[dim];
4962 : 504841 : tree *output = &bounds[dim];
4963 : :
4964 : 504841 : if (input_val)
4965 : : {
4966 : : /* Specified section bound. */
4967 : 46602 : gfc_init_se (&se, NULL);
4968 : 46602 : gfc_conv_expr_type (&se, input_val, gfc_array_index_type);
4969 : 46602 : gfc_add_block_to_block (block, &se.pre);
4970 : 46602 : *output = se.expr;
4971 : : }
4972 : 458239 : else if (deferred && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
4973 : : {
4974 : : /* The gfc_conv_array_lbound () routine returns a constant zero for
4975 : : deferred length arrays, which in the scalarizer wreaks havoc, when
4976 : : copying to a (newly allocated) one-based array.
4977 : : Keep returning the actual result in sync for both bounds. */
4978 : 182516 : *output = lbound ? gfc_conv_descriptor_lbound_get (desc,
4979 : : gfc_rank_cst[dim]):
4980 : 60950 : gfc_conv_descriptor_ubound_get (desc,
4981 : : gfc_rank_cst[dim]);
4982 : : }
4983 : : else
4984 : : {
4985 : : /* No specific bound specified so use the bound of the array. */
4986 : 501694 : *output = lbound ? gfc_conv_array_lbound (desc, dim) :
4987 : 165021 : gfc_conv_array_ubound (desc, dim);
4988 : : }
4989 : 504841 : if (save_value)
4990 : 487489 : *output = gfc_evaluate_now (*output, block);
4991 : 504841 : }
4992 : :
4993 : :
4994 : : /* Calculate the lower bound of an array section. */
4995 : :
4996 : : static void
4997 : 252908 : gfc_conv_section_startstride (stmtblock_t * block, gfc_ss * ss, int dim)
4998 : : {
4999 : 252908 : gfc_expr *stride = NULL;
5000 : 252908 : tree desc;
5001 : 252908 : gfc_se se;
5002 : 252908 : gfc_array_info *info;
5003 : 252908 : gfc_array_ref *ar;
5004 : :
5005 : 252908 : gcc_assert (ss->info->type == GFC_SS_SECTION);
5006 : :
5007 : 252908 : info = &ss->info->data.array;
5008 : 252908 : ar = &info->ref->u.ar;
5009 : :
5010 : 252908 : if (ar->dimen_type[dim] == DIMEN_VECTOR)
5011 : : {
5012 : : /* We use a zero-based index to access the vector. */
5013 : 752 : info->start[dim] = gfc_index_zero_node;
5014 : 752 : info->end[dim] = NULL;
5015 : 752 : info->stride[dim] = gfc_index_one_node;
5016 : 752 : return;
5017 : : }
5018 : :
5019 : 252156 : gcc_assert (ar->dimen_type[dim] == DIMEN_RANGE
5020 : : || ar->dimen_type[dim] == DIMEN_THIS_IMAGE);
5021 : 252156 : desc = info->descriptor;
5022 : 252156 : stride = ar->stride[dim];
5023 : 252156 : bool save_value = !ss->is_alloc_lhs;
5024 : :
5025 : : /* Calculate the start of the range. For vector subscripts this will
5026 : : be the range of the vector. */
5027 : 252156 : evaluate_bound (block, info->start, ar->start, desc, dim, true,
5028 : 252156 : ar->as->type == AS_DEFERRED, save_value);
5029 : :
5030 : : /* Similarly calculate the end. Although this is not used in the
5031 : : scalarizer, it is needed when checking bounds and where the end
5032 : : is an expression with side-effects. */
5033 : 252156 : evaluate_bound (block, info->end, ar->end, desc, dim, false,
5034 : 252156 : ar->as->type == AS_DEFERRED, save_value);
5035 : :
5036 : :
5037 : : /* Calculate the stride. */
5038 : 252156 : if (stride == NULL)
5039 : 239688 : info->stride[dim] = gfc_index_one_node;
5040 : : else
5041 : : {
5042 : 12468 : gfc_init_se (&se, NULL);
5043 : 12468 : gfc_conv_expr_type (&se, stride, gfc_array_index_type);
5044 : 12468 : gfc_add_block_to_block (block, &se.pre);
5045 : 12468 : tree value = se.expr;
5046 : 12468 : if (save_value)
5047 : 12468 : info->stride[dim] = gfc_evaluate_now (value, block);
5048 : : else
5049 : 0 : info->stride[dim] = value;
5050 : : }
5051 : : }
5052 : :
5053 : :
5054 : : /* Generate in INNER the bounds checking code along the dimension DIM for
5055 : : the array associated with SS_INFO. */
5056 : :
5057 : : static void
5058 : 23989 : add_check_section_in_array_bounds (stmtblock_t *inner, gfc_ss_info *ss_info,
5059 : : int dim)
5060 : : {
5061 : 23989 : gfc_expr *expr = ss_info->expr;
5062 : 23989 : locus *expr_loc = &expr->where;
5063 : 23989 : const char *expr_name = expr->symtree->name;
5064 : :
5065 : 23989 : gfc_array_info *info = &ss_info->data.array;
5066 : :
5067 : 23989 : bool check_upper;
5068 : 23989 : if (dim == info->ref->u.ar.dimen - 1
5069 : 20386 : && info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
5070 : : check_upper = false;
5071 : : else
5072 : 23693 : check_upper = true;
5073 : :
5074 : : /* Zero stride is not allowed. */
5075 : 23989 : tree tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
5076 : : info->stride[dim], gfc_index_zero_node);
5077 : 23989 : char * msg = xasprintf ("Zero stride is not allowed, for dimension %d "
5078 : : "of array '%s'", dim + 1, expr_name);
5079 : 23989 : gfc_trans_runtime_check (true, false, tmp, inner, expr_loc, msg);
5080 : 23989 : free (msg);
5081 : :
5082 : 23989 : tree desc = info->descriptor;
5083 : :
5084 : : /* This is the run-time equivalent of resolve.cc's
5085 : : check_dimension. The logical is more readable there
5086 : : than it is here, with all the trees. */
5087 : 23989 : tree lbound = gfc_conv_array_lbound (desc, dim);
5088 : 23989 : tree end = info->end[dim];
5089 : 23989 : tree ubound = check_upper ? gfc_conv_array_ubound (desc, dim) : NULL_TREE;
5090 : :
5091 : : /* non_zerosized is true when the selected range is not
5092 : : empty. */
5093 : 23989 : tree stride_pos = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
5094 : : info->stride[dim], gfc_index_zero_node);
5095 : 23989 : tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
5096 : : info->start[dim], end);
5097 : 23989 : stride_pos = fold_build2_loc (input_location, TRUTH_AND_EXPR,
5098 : : logical_type_node, stride_pos, tmp);
5099 : :
5100 : 23989 : tree stride_neg = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
5101 : : info->stride[dim], gfc_index_zero_node);
5102 : 23989 : tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
5103 : : info->start[dim], end);
5104 : 23989 : stride_neg = fold_build2_loc (input_location, TRUTH_AND_EXPR,
5105 : : logical_type_node, stride_neg, tmp);
5106 : 23989 : tree non_zerosized = fold_build2_loc (input_location, TRUTH_OR_EXPR,
5107 : : logical_type_node, stride_pos,
5108 : : stride_neg);
5109 : :
5110 : : /* Check the start of the range against the lower and upper
5111 : : bounds of the array, if the range is not empty.
5112 : : If upper bound is present, include both bounds in the
5113 : : error message. */
5114 : 23989 : if (check_upper)
5115 : : {
5116 : 23693 : tmp = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
5117 : : info->start[dim], lbound);
5118 : 23693 : tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
5119 : : non_zerosized, tmp);
5120 : 23693 : tree tmp2 = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
5121 : : info->start[dim], ubound);
5122 : 23693 : tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
5123 : : non_zerosized, tmp2);
5124 : 23693 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' outside of "
5125 : : "expected range (%%ld:%%ld)", dim + 1, expr_name);
5126 : 23693 : gfc_trans_runtime_check (true, false, tmp, inner, expr_loc, msg,
5127 : : fold_convert (long_integer_type_node, info->start[dim]),
5128 : : fold_convert (long_integer_type_node, lbound),
5129 : : fold_convert (long_integer_type_node, ubound));
5130 : 23693 : gfc_trans_runtime_check (true, false, tmp2, inner, expr_loc, msg,
5131 : : fold_convert (long_integer_type_node, info->start[dim]),
5132 : : fold_convert (long_integer_type_node, lbound),
5133 : : fold_convert (long_integer_type_node, ubound));
5134 : 23693 : free (msg);
5135 : : }
5136 : : else
5137 : : {
5138 : 296 : tmp = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
5139 : : info->start[dim], lbound);
5140 : 296 : tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
5141 : : non_zerosized, tmp);
5142 : 296 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' below "
5143 : : "lower bound of %%ld", dim + 1, expr_name);
5144 : 296 : gfc_trans_runtime_check (true, false, tmp, inner, expr_loc, msg,
5145 : : fold_convert (long_integer_type_node, info->start[dim]),
5146 : : fold_convert (long_integer_type_node, lbound));
5147 : 296 : free (msg);
5148 : : }
5149 : :
5150 : : /* Compute the last element of the range, which is not
5151 : : necessarily "end" (think 0:5:3, which doesn't contain 5)
5152 : : and check it against both lower and upper bounds. */
5153 : :
5154 : 23989 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5155 : : end, info->start[dim]);
5156 : 23989 : tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR, gfc_array_index_type,
5157 : : tmp, info->stride[dim]);
5158 : 23989 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5159 : : end, tmp);
5160 : 23989 : tree tmp2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
5161 : : tmp, lbound);
5162 : 23989 : tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
5163 : : non_zerosized, tmp2);
5164 : 23989 : if (check_upper)
5165 : : {
5166 : 23693 : tree tmp3 = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
5167 : : tmp, ubound);
5168 : 23693 : tmp3 = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
5169 : : non_zerosized, tmp3);
5170 : 23693 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' outside of "
5171 : : "expected range (%%ld:%%ld)", dim + 1, expr_name);
5172 : 23693 : gfc_trans_runtime_check (true, false, tmp2, inner, expr_loc, msg,
5173 : : fold_convert (long_integer_type_node, tmp),
5174 : : fold_convert (long_integer_type_node, ubound),
5175 : : fold_convert (long_integer_type_node, lbound));
5176 : 23693 : gfc_trans_runtime_check (true, false, tmp3, inner, expr_loc, msg,
5177 : : fold_convert (long_integer_type_node, tmp),
5178 : : fold_convert (long_integer_type_node, ubound),
5179 : : fold_convert (long_integer_type_node, lbound));
5180 : 23693 : free (msg);
5181 : : }
5182 : : else
5183 : : {
5184 : 296 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' below "
5185 : : "lower bound of %%ld", dim + 1, expr_name);
5186 : 296 : gfc_trans_runtime_check (true, false, tmp2, inner, expr_loc, msg,
5187 : : fold_convert (long_integer_type_node, tmp),
5188 : : fold_convert (long_integer_type_node, lbound));
5189 : 296 : free (msg);
5190 : : }
5191 : 23989 : }
5192 : :
5193 : :
5194 : : /* Tells whether we need to generate bounds checking code for the array
5195 : : associated with SS. */
5196 : :
5197 : : bool
5198 : 24943 : bounds_check_needed (gfc_ss *ss)
5199 : : {
5200 : : /* Catch allocatable lhs in f2003. */
5201 : 24943 : if (flag_realloc_lhs && ss->no_bounds_check)
5202 : : return false;
5203 : :
5204 : 24669 : gfc_ss_info *ss_info = ss->info;
5205 : 24669 : if (ss_info->type == GFC_SS_SECTION)
5206 : : return true;
5207 : :
5208 : 4110 : if (!(ss_info->type == GFC_SS_INTRINSIC
5209 : 227 : && ss_info->expr
5210 : 227 : && ss_info->expr->expr_type == EXPR_FUNCTION))
5211 : : return false;
5212 : :
5213 : 227 : gfc_intrinsic_sym *isym = ss_info->expr->value.function.isym;
5214 : 227 : if (!(isym
5215 : 227 : && (isym->id == GFC_ISYM_MAXLOC
5216 : 203 : || isym->id == GFC_ISYM_MINLOC)))
5217 : : return false;
5218 : :
5219 : 34 : return gfc_inline_intrinsic_function_p (ss_info->expr);
5220 : : }
5221 : :
5222 : :
5223 : : /* Calculates the range start and stride for a SS chain. Also gets the
5224 : : descriptor and data pointer. The range of vector subscripts is the size
5225 : : of the vector. Array bounds are also checked. */
5226 : :
5227 : : void
5228 : 179205 : gfc_conv_ss_startstride (gfc_loopinfo * loop)
5229 : : {
5230 : 179205 : int n;
5231 : 179205 : tree tmp;
5232 : 179205 : gfc_ss *ss;
5233 : :
5234 : 179205 : gfc_loopinfo * const outer_loop = outermost_loop (loop);
5235 : :
5236 : 179205 : loop->dimen = 0;
5237 : : /* Determine the rank of the loop. */
5238 : 198642 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5239 : : {
5240 : 198642 : switch (ss->info->type)
5241 : : {
5242 : 168109 : case GFC_SS_SECTION:
5243 : 168109 : case GFC_SS_CONSTRUCTOR:
5244 : 168109 : case GFC_SS_FUNCTION:
5245 : 168109 : case GFC_SS_COMPONENT:
5246 : 168109 : loop->dimen = ss->dimen;
5247 : 168109 : goto done;
5248 : :
5249 : : /* As usual, lbound and ubound are exceptions!. */
5250 : 11096 : case GFC_SS_INTRINSIC:
5251 : 11096 : switch (ss->info->expr->value.function.isym->id)
5252 : : {
5253 : 11096 : case GFC_ISYM_LBOUND:
5254 : 11096 : case GFC_ISYM_UBOUND:
5255 : 11096 : case GFC_ISYM_LCOBOUND:
5256 : 11096 : case GFC_ISYM_UCOBOUND:
5257 : 11096 : case GFC_ISYM_MAXLOC:
5258 : 11096 : case GFC_ISYM_MINLOC:
5259 : 11096 : case GFC_ISYM_SHAPE:
5260 : 11096 : case GFC_ISYM_THIS_IMAGE:
5261 : 11096 : loop->dimen = ss->dimen;
5262 : 11096 : goto done;
5263 : :
5264 : : default:
5265 : : break;
5266 : : }
5267 : :
5268 : 19437 : default:
5269 : 19437 : break;
5270 : : }
5271 : : }
5272 : :
5273 : : /* We should have determined the rank of the expression by now. If
5274 : : not, that's bad news. */
5275 : 0 : gcc_unreachable ();
5276 : :
5277 : : done:
5278 : : /* Loop over all the SS in the chain. */
5279 : 464857 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5280 : : {
5281 : 285652 : gfc_ss_info *ss_info;
5282 : 285652 : gfc_array_info *info;
5283 : 285652 : gfc_expr *expr;
5284 : :
5285 : 285652 : ss_info = ss->info;
5286 : 285652 : expr = ss_info->expr;
5287 : 285652 : info = &ss_info->data.array;
5288 : :
5289 : 285652 : if (expr && expr->shape && !info->shape)
5290 : 167559 : info->shape = expr->shape;
5291 : :
5292 : 285652 : switch (ss_info->type)
5293 : : {
5294 : 181623 : case GFC_SS_SECTION:
5295 : : /* Get the descriptor for the array. If it is a cross loops array,
5296 : : we got the descriptor already in the outermost loop. */
5297 : 181623 : if (ss->parent == NULL)
5298 : 176987 : gfc_conv_ss_descriptor (&outer_loop->pre, ss,
5299 : 176987 : !loop->array_parameter);
5300 : :
5301 : 433977 : for (n = 0; n < ss->dimen; n++)
5302 : 252354 : gfc_conv_section_startstride (&outer_loop->pre, ss, ss->dim[n]);
5303 : : break;
5304 : :
5305 : 11333 : case GFC_SS_INTRINSIC:
5306 : 11333 : switch (expr->value.function.isym->id)
5307 : : {
5308 : 3281 : case GFC_ISYM_MINLOC:
5309 : 3281 : case GFC_ISYM_MAXLOC:
5310 : 3281 : {
5311 : 3281 : gfc_se se;
5312 : 3281 : gfc_init_se (&se, nullptr);
5313 : 3281 : se.loop = loop;
5314 : 3281 : se.ss = ss;
5315 : 3281 : gfc_conv_intrinsic_function (&se, expr);
5316 : 3281 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
5317 : 3281 : gfc_add_block_to_block (&outer_loop->post, &se.post);
5318 : :
5319 : 3281 : info->descriptor = se.expr;
5320 : :
5321 : 3281 : info->data = gfc_conv_array_data (info->descriptor);
5322 : 3281 : info->data = gfc_evaluate_now (info->data, &outer_loop->pre);
5323 : :
5324 : 3281 : gfc_expr *array = expr->value.function.actual->expr;
5325 : 3281 : tree rank = build_int_cst (gfc_array_index_type, array->rank);
5326 : :
5327 : 3281 : tree tmp = fold_build2_loc (input_location, MINUS_EXPR,
5328 : : gfc_array_index_type, rank,
5329 : : gfc_index_one_node);
5330 : :
5331 : 3281 : info->end[0] = gfc_evaluate_now (tmp, &outer_loop->pre);
5332 : 3281 : info->start[0] = gfc_index_zero_node;
5333 : 3281 : info->stride[0] = gfc_index_one_node;
5334 : 3281 : info->offset = gfc_index_zero_node;
5335 : 3281 : continue;
5336 : 3281 : }
5337 : :
5338 : : /* Fall through to supply start and stride. */
5339 : 3004 : case GFC_ISYM_LBOUND:
5340 : 3004 : case GFC_ISYM_UBOUND:
5341 : : /* This is the variant without DIM=... */
5342 : 3004 : gcc_assert (expr->value.function.actual->next->expr == NULL);
5343 : : /* Fall through. */
5344 : :
5345 : 7827 : case GFC_ISYM_SHAPE:
5346 : 7827 : {
5347 : 7827 : gfc_expr *arg;
5348 : :
5349 : 7827 : arg = expr->value.function.actual->expr;
5350 : 7827 : if (arg->rank == -1)
5351 : : {
5352 : 1157 : gfc_se se;
5353 : 1157 : tree rank, tmp;
5354 : :
5355 : : /* The rank (hence the return value's shape) is unknown,
5356 : : we have to retrieve it. */
5357 : 1157 : gfc_init_se (&se, NULL);
5358 : 1157 : se.descriptor_only = 1;
5359 : 1157 : gfc_conv_expr (&se, arg);
5360 : : /* This is a bare variable, so there is no preliminary
5361 : : or cleanup code unless -std=f202y and bounds checking
5362 : : is on. */
5363 : 1157 : if (!((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
5364 : 0 : && (gfc_option.allow_std & GFC_STD_F202Y)))
5365 : 1157 : gcc_assert (se.pre.head == NULL_TREE
5366 : : && se.post.head == NULL_TREE);
5367 : 1157 : rank = gfc_conv_descriptor_rank (se.expr);
5368 : 1157 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
5369 : : gfc_array_index_type,
5370 : : fold_convert (gfc_array_index_type,
5371 : : rank),
5372 : : gfc_index_one_node);
5373 : 1157 : info->end[0] = gfc_evaluate_now (tmp, &outer_loop->pre);
5374 : 1157 : info->start[0] = gfc_index_zero_node;
5375 : 1157 : info->stride[0] = gfc_index_one_node;
5376 : 1157 : continue;
5377 : 1157 : }
5378 : : /* Otherwise fall through GFC_SS_FUNCTION. */
5379 : : gcc_fallthrough ();
5380 : : }
5381 : : case GFC_ISYM_LCOBOUND:
5382 : : case GFC_ISYM_UCOBOUND:
5383 : : case GFC_ISYM_THIS_IMAGE:
5384 : : break;
5385 : :
5386 : 0 : default:
5387 : 0 : continue;
5388 : 0 : }
5389 : :
5390 : : /* FALLTHRU */
5391 : : case GFC_SS_CONSTRUCTOR:
5392 : : case GFC_SS_FUNCTION:
5393 : 125631 : for (n = 0; n < ss->dimen; n++)
5394 : : {
5395 : 67773 : int dim = ss->dim[n];
5396 : :
5397 : 67773 : info->start[dim] = gfc_index_zero_node;
5398 : 67773 : if (ss_info->type != GFC_SS_FUNCTION)
5399 : 53558 : info->end[dim] = gfc_index_zero_node;
5400 : 67773 : info->stride[dim] = gfc_index_one_node;
5401 : : }
5402 : : break;
5403 : :
5404 : : default:
5405 : : break;
5406 : : }
5407 : : }
5408 : :
5409 : : /* The rest is just runtime bounds checking. */
5410 : 179205 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
5411 : : {
5412 : 16884 : stmtblock_t block;
5413 : 16884 : tree size[GFC_MAX_DIMENSIONS];
5414 : 16884 : tree tmp3;
5415 : 16884 : gfc_array_info *info;
5416 : 16884 : char *msg;
5417 : 16884 : int dim;
5418 : :
5419 : 16884 : gfc_start_block (&block);
5420 : :
5421 : 54068 : for (n = 0; n < loop->dimen; n++)
5422 : 20300 : size[n] = NULL_TREE;
5423 : :
5424 : : /* If there is a constructor involved, derive size[] from its shape. */
5425 : 39004 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5426 : : {
5427 : 24598 : gfc_ss_info *ss_info;
5428 : :
5429 : 24598 : ss_info = ss->info;
5430 : 24598 : info = &ss_info->data.array;
5431 : :
5432 : 24598 : if (ss_info->type == GFC_SS_CONSTRUCTOR && info->shape)
5433 : : {
5434 : 5220 : for (n = 0; n < loop->dimen; n++)
5435 : : {
5436 : 2742 : if (size[n] == NULL)
5437 : : {
5438 : 2742 : gcc_assert (info->shape[n]);
5439 : 2742 : size[n] = gfc_conv_mpz_to_tree (info->shape[n],
5440 : : gfc_index_integer_kind);
5441 : : }
5442 : : }
5443 : : break;
5444 : : }
5445 : : }
5446 : :
5447 : 41827 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5448 : : {
5449 : 24943 : stmtblock_t inner;
5450 : 24943 : gfc_ss_info *ss_info;
5451 : 24943 : gfc_expr *expr;
5452 : 24943 : locus *expr_loc;
5453 : 24943 : const char *expr_name;
5454 : 24943 : char *ref_name = NULL;
5455 : :
5456 : 24943 : if (!bounds_check_needed (ss))
5457 : 4350 : continue;
5458 : :
5459 : 20593 : ss_info = ss->info;
5460 : 20593 : expr = ss_info->expr;
5461 : 20593 : expr_loc = &expr->where;
5462 : 20593 : if (expr->ref)
5463 : 20559 : expr_name = ref_name = abridged_ref_name (expr, NULL);
5464 : : else
5465 : 34 : expr_name = expr->symtree->name;
5466 : :
5467 : 20593 : gfc_start_block (&inner);
5468 : :
5469 : : /* TODO: range checking for mapped dimensions. */
5470 : 20593 : info = &ss_info->data.array;
5471 : :
5472 : : /* This code only checks ranges. Elemental and vector
5473 : : dimensions are checked later. */
5474 : 65223 : for (n = 0; n < loop->dimen; n++)
5475 : : {
5476 : 24037 : dim = ss->dim[n];
5477 : 24037 : if (ss_info->type == GFC_SS_SECTION)
5478 : : {
5479 : 24003 : if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
5480 : 14 : continue;
5481 : :
5482 : 23989 : add_check_section_in_array_bounds (&inner, ss_info, dim);
5483 : : }
5484 : :
5485 : : /* Check the section sizes match. */
5486 : 24023 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
5487 : : gfc_array_index_type, info->end[dim],
5488 : : info->start[dim]);
5489 : 24023 : tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
5490 : : gfc_array_index_type, tmp,
5491 : : info->stride[dim]);
5492 : 24023 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
5493 : : gfc_array_index_type,
5494 : : gfc_index_one_node, tmp);
5495 : 24023 : tmp = fold_build2_loc (input_location, MAX_EXPR,
5496 : : gfc_array_index_type, tmp,
5497 : : build_int_cst (gfc_array_index_type, 0));
5498 : : /* We remember the size of the first section, and check all the
5499 : : others against this. */
5500 : 24023 : if (size[n])
5501 : : {
5502 : 7167 : tmp3 = fold_build2_loc (input_location, NE_EXPR,
5503 : : logical_type_node, tmp, size[n]);
5504 : 7167 : if (ss_info->type == GFC_SS_INTRINSIC)
5505 : 0 : msg = xasprintf ("Extent mismatch for dimension %d of the "
5506 : : "result of intrinsic '%s' (%%ld/%%ld)",
5507 : : dim + 1, expr_name);
5508 : : else
5509 : 7167 : msg = xasprintf ("Array bound mismatch for dimension %d "
5510 : : "of array '%s' (%%ld/%%ld)",
5511 : : dim + 1, expr_name);
5512 : :
5513 : 7167 : gfc_trans_runtime_check (true, false, tmp3, &inner,
5514 : : expr_loc, msg,
5515 : : fold_convert (long_integer_type_node, tmp),
5516 : : fold_convert (long_integer_type_node, size[n]));
5517 : :
5518 : 7167 : free (msg);
5519 : : }
5520 : : else
5521 : 16856 : size[n] = gfc_evaluate_now (tmp, &inner);
5522 : : }
5523 : :
5524 : 20593 : tmp = gfc_finish_block (&inner);
5525 : :
5526 : : /* For optional arguments, only check bounds if the argument is
5527 : : present. */
5528 : 20593 : if ((expr->symtree->n.sym->attr.optional
5529 : 20285 : || expr->symtree->n.sym->attr.not_always_present)
5530 : 308 : && expr->symtree->n.sym->attr.dummy)
5531 : 307 : tmp = build3_v (COND_EXPR,
5532 : : gfc_conv_expr_present (expr->symtree->n.sym),
5533 : : tmp, build_empty_stmt (input_location));
5534 : :
5535 : 20593 : gfc_add_expr_to_block (&block, tmp);
5536 : :
5537 : 20593 : free (ref_name);
5538 : : }
5539 : :
5540 : 16884 : tmp = gfc_finish_block (&block);
5541 : 16884 : gfc_add_expr_to_block (&outer_loop->pre, tmp);
5542 : : }
5543 : :
5544 : 182569 : for (loop = loop->nested; loop; loop = loop->next)
5545 : 3364 : gfc_conv_ss_startstride (loop);
5546 : 179205 : }
5547 : :
5548 : : /* Return true if both symbols could refer to the same data object. Does
5549 : : not take account of aliasing due to equivalence statements. */
5550 : :
5551 : : static bool
5552 : 13259 : symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym, bool lsym_pointer,
5553 : : bool lsym_target, bool rsym_pointer, bool rsym_target)
5554 : : {
5555 : : /* Aliasing isn't possible if the symbols have different base types,
5556 : : except for complex types where an inquiry reference (%RE, %IM) could
5557 : : alias with a real type with the same kind parameter. */
5558 : 13259 : if (!gfc_compare_types (&lsym->ts, &rsym->ts)
5559 : 13259 : && !(((lsym->ts.type == BT_COMPLEX && rsym->ts.type == BT_REAL)
5560 : 4696 : || (lsym->ts.type == BT_REAL && rsym->ts.type == BT_COMPLEX))
5561 : 76 : && lsym->ts.kind == rsym->ts.kind))
5562 : : return false;
5563 : :
5564 : : /* Pointers can point to other pointers and target objects. */
5565 : :
5566 : 8576 : if ((lsym_pointer && (rsym_pointer || rsym_target))
5567 : 8367 : || (rsym_pointer && (lsym_pointer || lsym_target)))
5568 : : return true;
5569 : :
5570 : : /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
5571 : : and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
5572 : : checked above. */
5573 : 8453 : if (lsym_target && rsym_target
5574 : 14 : && ((lsym->attr.dummy && !lsym->attr.contiguous
5575 : 0 : && (!lsym->attr.dimension || lsym->as->type == AS_ASSUMED_SHAPE))
5576 : 14 : || (rsym->attr.dummy && !rsym->attr.contiguous
5577 : 6 : && (!rsym->attr.dimension
5578 : 6 : || rsym->as->type == AS_ASSUMED_SHAPE))))
5579 : 6 : return true;
5580 : :
5581 : : return false;
5582 : : }
5583 : :
5584 : :
5585 : : /* Return true if the two SS could be aliased, i.e. both point to the same data
5586 : : object. */
5587 : : /* TODO: resolve aliases based on frontend expressions. */
5588 : :
5589 : : static int
5590 : 11243 : gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
5591 : : {
5592 : 11243 : gfc_ref *lref;
5593 : 11243 : gfc_ref *rref;
5594 : 11243 : gfc_expr *lexpr, *rexpr;
5595 : 11243 : gfc_symbol *lsym;
5596 : 11243 : gfc_symbol *rsym;
5597 : 11243 : bool lsym_pointer, lsym_target, rsym_pointer, rsym_target;
5598 : :
5599 : 11243 : lexpr = lss->info->expr;
5600 : 11243 : rexpr = rss->info->expr;
5601 : :
5602 : 11243 : lsym = lexpr->symtree->n.sym;
5603 : 11243 : rsym = rexpr->symtree->n.sym;
5604 : :
5605 : 11243 : lsym_pointer = lsym->attr.pointer;
5606 : 11243 : lsym_target = lsym->attr.target;
5607 : 11243 : rsym_pointer = rsym->attr.pointer;
5608 : 11243 : rsym_target = rsym->attr.target;
5609 : :
5610 : 11243 : if (symbols_could_alias (lsym, rsym, lsym_pointer, lsym_target,
5611 : : rsym_pointer, rsym_target))
5612 : : return 1;
5613 : :
5614 : 11152 : if (rsym->ts.type != BT_DERIVED && rsym->ts.type != BT_CLASS
5615 : 9981 : && lsym->ts.type != BT_DERIVED && lsym->ts.type != BT_CLASS)
5616 : : return 0;
5617 : :
5618 : : /* For derived types we must check all the component types. We can ignore
5619 : : array references as these will have the same base type as the previous
5620 : : component ref. */
5621 : 2468 : for (lref = lexpr->ref; lref != lss->info->data.array.ref; lref = lref->next)
5622 : : {
5623 : 904 : if (lref->type != REF_COMPONENT)
5624 : 89 : continue;
5625 : :
5626 : 815 : lsym_pointer = lsym_pointer || lref->u.c.sym->attr.pointer;
5627 : 815 : lsym_target = lsym_target || lref->u.c.sym->attr.target;
5628 : :
5629 : 815 : if (symbols_could_alias (lref->u.c.sym, rsym, lsym_pointer, lsym_target,
5630 : : rsym_pointer, rsym_target))
5631 : : return 1;
5632 : :
5633 : 815 : if ((lsym_pointer && (rsym_pointer || rsym_target))
5634 : 800 : || (rsym_pointer && (lsym_pointer || lsym_target)))
5635 : : {
5636 : 6 : if (gfc_compare_types (&lref->u.c.component->ts,
5637 : : &rsym->ts))
5638 : : return 1;
5639 : : }
5640 : :
5641 : 1239 : for (rref = rexpr->ref; rref != rss->info->data.array.ref;
5642 : 430 : rref = rref->next)
5643 : : {
5644 : 431 : if (rref->type != REF_COMPONENT)
5645 : 36 : continue;
5646 : :
5647 : 395 : rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
5648 : 395 : rsym_target = lsym_target || rref->u.c.sym->attr.target;
5649 : :
5650 : 395 : if (symbols_could_alias (lref->u.c.sym, rref->u.c.sym,
5651 : : lsym_pointer, lsym_target,
5652 : : rsym_pointer, rsym_target))
5653 : : return 1;
5654 : :
5655 : 394 : if ((lsym_pointer && (rsym_pointer || rsym_target))
5656 : 390 : || (rsym_pointer && (lsym_pointer || lsym_target)))
5657 : : {
5658 : 0 : if (gfc_compare_types (&lref->u.c.component->ts,
5659 : 0 : &rref->u.c.sym->ts))
5660 : : return 1;
5661 : 0 : if (gfc_compare_types (&lref->u.c.sym->ts,
5662 : 0 : &rref->u.c.component->ts))
5663 : : return 1;
5664 : 0 : if (gfc_compare_types (&lref->u.c.component->ts,
5665 : 0 : &rref->u.c.component->ts))
5666 : : return 1;
5667 : : }
5668 : : }
5669 : : }
5670 : :
5671 : 1564 : lsym_pointer = lsym->attr.pointer;
5672 : 1564 : lsym_target = lsym->attr.target;
5673 : :
5674 : 2364 : for (rref = rexpr->ref; rref != rss->info->data.array.ref; rref = rref->next)
5675 : : {
5676 : 953 : if (rref->type != REF_COMPONENT)
5677 : : break;
5678 : :
5679 : 806 : rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
5680 : 806 : rsym_target = lsym_target || rref->u.c.sym->attr.target;
5681 : :
5682 : 806 : if (symbols_could_alias (rref->u.c.sym, lsym,
5683 : : lsym_pointer, lsym_target,
5684 : : rsym_pointer, rsym_target))
5685 : : return 1;
5686 : :
5687 : 806 : if ((lsym_pointer && (rsym_pointer || rsym_target))
5688 : 788 : || (rsym_pointer && (lsym_pointer || lsym_target)))
5689 : : {
5690 : 6 : if (gfc_compare_types (&lsym->ts, &rref->u.c.component->ts))
5691 : : return 1;
5692 : : }
5693 : : }
5694 : :
5695 : : return 0;
5696 : : }
5697 : :
5698 : :
5699 : : /* Resolve array data dependencies. Creates a temporary if required. */
5700 : : /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
5701 : : dependency.cc. */
5702 : :
5703 : : void
5704 : 36311 : gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
5705 : : gfc_ss * rss)
5706 : : {
5707 : 36311 : gfc_ss *ss;
5708 : 36311 : gfc_ref *lref;
5709 : 36311 : gfc_ref *rref;
5710 : 36311 : gfc_ss_info *ss_info;
5711 : 36311 : gfc_expr *dest_expr;
5712 : 36311 : gfc_expr *ss_expr;
5713 : 36311 : int nDepend = 0;
5714 : 36311 : int i, j;
5715 : :
5716 : 36311 : loop->temp_ss = NULL;
5717 : 36311 : dest_expr = dest->info->expr;
5718 : :
5719 : 78334 : for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
5720 : : {
5721 : 43115 : ss_info = ss->info;
5722 : 43115 : ss_expr = ss_info->expr;
5723 : :
5724 : 43115 : if (ss_info->array_outer_dependency)
5725 : : {
5726 : : nDepend = 1;
5727 : : break;
5728 : : }
5729 : :
5730 : 43005 : if (ss_info->type != GFC_SS_SECTION)
5731 : : {
5732 : 29225 : if (flag_realloc_lhs
5733 : 28276 : && dest_expr != ss_expr
5734 : 28276 : && gfc_is_reallocatable_lhs (dest_expr)
5735 : 35595 : && ss_expr->rank)
5736 : 2892 : nDepend = gfc_check_dependency (dest_expr, ss_expr, true);
5737 : :
5738 : : /* Check for cases like c(:)(1:2) = c(2)(2:3) */
5739 : 29225 : if (!nDepend && dest_expr->rank > 0
5740 : 28786 : && dest_expr->ts.type == BT_CHARACTER
5741 : 4199 : && ss_expr->expr_type == EXPR_VARIABLE)
5742 : :
5743 : 157 : nDepend = gfc_check_dependency (dest_expr, ss_expr, false);
5744 : :
5745 : 29225 : if (ss_info->type == GFC_SS_REFERENCE
5746 : 29225 : && gfc_check_dependency (dest_expr, ss_expr, false))
5747 : 182 : ss_info->data.scalar.needs_temporary = 1;
5748 : :
5749 : 29225 : if (nDepend)
5750 : : break;
5751 : : else
5752 : 28774 : continue;
5753 : : }
5754 : :
5755 : 13780 : if (dest_expr->symtree->n.sym != ss_expr->symtree->n.sym)
5756 : : {
5757 : 11243 : if (gfc_could_be_alias (dest, ss)
5758 : 11243 : || gfc_are_equivalenced_arrays (dest_expr, ss_expr))
5759 : : {
5760 : : nDepend = 1;
5761 : : break;
5762 : : }
5763 : : }
5764 : : else
5765 : : {
5766 : 2537 : lref = dest_expr->ref;
5767 : 2537 : rref = ss_expr->ref;
5768 : :
5769 : 2537 : nDepend = gfc_dep_resolver (lref, rref, &loop->reverse[0]);
5770 : :
5771 : 2537 : if (nDepend == 1)
5772 : : break;
5773 : :
5774 : 4955 : for (i = 0; i < dest->dimen; i++)
5775 : 6608 : for (j = 0; j < ss->dimen; j++)
5776 : 3904 : if (i != j
5777 : 1137 : && dest->dim[i] == ss->dim[j])
5778 : : {
5779 : : /* If we don't access array elements in the same order,
5780 : : there is a dependency. */
5781 : 63 : nDepend = 1;
5782 : 63 : goto temporary;
5783 : : }
5784 : : #if 0
5785 : : /* TODO : loop shifting. */
5786 : : if (nDepend == 1)
5787 : : {
5788 : : /* Mark the dimensions for LOOP SHIFTING */
5789 : : for (n = 0; n < loop->dimen; n++)
5790 : : {
5791 : : int dim = dest->data.info.dim[n];
5792 : :
5793 : : if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
5794 : : depends[n] = 2;
5795 : : else if (! gfc_is_same_range (&lref->u.ar,
5796 : : &rref->u.ar, dim, 0))
5797 : : depends[n] = 1;
5798 : : }
5799 : :
5800 : : /* Put all the dimensions with dependencies in the
5801 : : innermost loops. */
5802 : : dim = 0;
5803 : : for (n = 0; n < loop->dimen; n++)
5804 : : {
5805 : : gcc_assert (loop->order[n] == n);
5806 : : if (depends[n])
5807 : : loop->order[dim++] = n;
5808 : : }
5809 : : for (n = 0; n < loop->dimen; n++)
5810 : : {
5811 : : if (! depends[n])
5812 : : loop->order[dim++] = n;
5813 : : }
5814 : :
5815 : : gcc_assert (dim == loop->dimen);
5816 : : break;
5817 : : }
5818 : : #endif
5819 : : }
5820 : : }
5821 : :
5822 : 737 : temporary:
5823 : :
5824 : 36311 : if (nDepend == 1)
5825 : : {
5826 : 1092 : tree base_type = gfc_typenode_for_spec (&dest_expr->ts);
5827 : 1092 : if (GFC_ARRAY_TYPE_P (base_type)
5828 : 1092 : || GFC_DESCRIPTOR_TYPE_P (base_type))
5829 : 0 : base_type = gfc_get_element_type (base_type);
5830 : 1092 : loop->temp_ss = gfc_get_temp_ss (base_type, dest->info->string_length,
5831 : : loop->dimen);
5832 : 1092 : gfc_add_ss_to_loop (loop, loop->temp_ss);
5833 : : }
5834 : : else
5835 : 35219 : loop->temp_ss = NULL;
5836 : 36311 : }
5837 : :
5838 : :
5839 : : /* Browse through each array's information from the scalarizer and set the loop
5840 : : bounds according to the "best" one (per dimension), i.e. the one which
5841 : : provides the most information (constant bounds, shape, etc.). */
5842 : :
5843 : : static void
5844 : 179205 : set_loop_bounds (gfc_loopinfo *loop)
5845 : : {
5846 : 179205 : int n, dim, spec_dim;
5847 : 179205 : gfc_array_info *info;
5848 : 179205 : gfc_array_info *specinfo;
5849 : 179205 : gfc_ss *ss;
5850 : 179205 : tree tmp;
5851 : 179205 : gfc_ss **loopspec;
5852 : 179205 : bool dynamic[GFC_MAX_DIMENSIONS];
5853 : 179205 : mpz_t *cshape;
5854 : 179205 : mpz_t i;
5855 : 179205 : bool nonoptional_arr;
5856 : :
5857 : 179205 : gfc_loopinfo * const outer_loop = outermost_loop (loop);
5858 : :
5859 : 179205 : loopspec = loop->specloop;
5860 : :
5861 : 179205 : mpz_init (i);
5862 : 423440 : for (n = 0; n < loop->dimen; n++)
5863 : : {
5864 : 244235 : loopspec[n] = NULL;
5865 : 244235 : dynamic[n] = false;
5866 : :
5867 : : /* If there are both optional and nonoptional array arguments, scalarize
5868 : : over the nonoptional; otherwise, it does not matter as then all
5869 : : (optional) arrays have to be present per F2008, 125.2.12p3(6). */
5870 : :
5871 : 244235 : nonoptional_arr = false;
5872 : :
5873 : 284586 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5874 : 284566 : if (ss->info->type != GFC_SS_SCALAR && ss->info->type != GFC_SS_TEMP
5875 : 250781 : && ss->info->type != GFC_SS_REFERENCE && !ss->info->can_be_null_ref)
5876 : : {
5877 : : nonoptional_arr = true;
5878 : : break;
5879 : : }
5880 : :
5881 : : /* We use one SS term, and use that to determine the bounds of the
5882 : : loop for this dimension. We try to pick the simplest term. */
5883 : 637868 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5884 : : {
5885 : 393633 : gfc_ss_type ss_type;
5886 : :
5887 : 393633 : ss_type = ss->info->type;
5888 : 461910 : if (ss_type == GFC_SS_SCALAR
5889 : 393633 : || ss_type == GFC_SS_TEMP
5890 : 334601 : || ss_type == GFC_SS_REFERENCE
5891 : 325633 : || (ss->info->can_be_null_ref && nonoptional_arr))
5892 : 68277 : continue;
5893 : :
5894 : 325356 : info = &ss->info->data.array;
5895 : 325356 : dim = ss->dim[n];
5896 : :
5897 : 325356 : if (loopspec[n] != NULL)
5898 : : {
5899 : 81121 : specinfo = &loopspec[n]->info->data.array;
5900 : 81121 : spec_dim = loopspec[n]->dim[n];
5901 : : }
5902 : : else
5903 : : {
5904 : : /* Silence uninitialized warnings. */
5905 : : specinfo = NULL;
5906 : : spec_dim = 0;
5907 : : }
5908 : :
5909 : 325356 : if (info->shape)
5910 : : {
5911 : : /* The frontend has worked out the size for us. */
5912 : 222086 : if (!loopspec[n]
5913 : 58126 : || !specinfo->shape
5914 : 268264 : || !integer_zerop (specinfo->start[spec_dim]))
5915 : : /* Prefer zero-based descriptors if possible. */
5916 : 205277 : loopspec[n] = ss;
5917 : 222086 : continue;
5918 : : }
5919 : :
5920 : 103270 : if (ss_type == GFC_SS_CONSTRUCTOR)
5921 : : {
5922 : 1302 : gfc_constructor_base base;
5923 : : /* An unknown size constructor will always be rank one.
5924 : : Higher rank constructors will either have known shape,
5925 : : or still be wrapped in a call to reshape. */
5926 : 1302 : gcc_assert (loop->dimen == 1);
5927 : :
5928 : : /* Always prefer to use the constructor bounds if the size
5929 : : can be determined at compile time. Prefer not to otherwise,
5930 : : since the general case involves realloc, and it's better to
5931 : : avoid that overhead if possible. */
5932 : 1302 : base = ss->info->expr->value.constructor;
5933 : 1302 : dynamic[n] = gfc_get_array_constructor_size (&i, base);
5934 : 1302 : if (!dynamic[n] || !loopspec[n])
5935 : 1115 : loopspec[n] = ss;
5936 : 1302 : continue;
5937 : 1302 : }
5938 : :
5939 : : /* Avoid using an allocatable lhs in an assignment, since
5940 : : there might be a reallocation coming. */
5941 : 101968 : if (loopspec[n] && ss->is_alloc_lhs)
5942 : 8676 : continue;
5943 : :
5944 : 93292 : if (!loopspec[n])
5945 : 79160 : loopspec[n] = ss;
5946 : : /* Criteria for choosing a loop specifier (most important first):
5947 : : doesn't need realloc
5948 : : stride of one
5949 : : known stride
5950 : : known lower bound
5951 : : known upper bound
5952 : : */
5953 : 14132 : else if (loopspec[n]->info->type == GFC_SS_CONSTRUCTOR && dynamic[n])
5954 : 174 : loopspec[n] = ss;
5955 : 13958 : else if (integer_onep (info->stride[dim])
5956 : 13958 : && !integer_onep (specinfo->stride[spec_dim]))
5957 : 120 : loopspec[n] = ss;
5958 : 13838 : else if (INTEGER_CST_P (info->stride[dim])
5959 : 13650 : && !INTEGER_CST_P (specinfo->stride[spec_dim]))
5960 : 0 : loopspec[n] = ss;
5961 : 13838 : else if (INTEGER_CST_P (info->start[dim])
5962 : 4274 : && !INTEGER_CST_P (specinfo->start[spec_dim])
5963 : 744 : && integer_onep (info->stride[dim])
5964 : 372 : == integer_onep (specinfo->stride[spec_dim])
5965 : 13838 : && INTEGER_CST_P (info->stride[dim])
5966 : 345 : == INTEGER_CST_P (specinfo->stride[spec_dim]))
5967 : 345 : loopspec[n] = ss;
5968 : : /* We don't work out the upper bound.
5969 : : else if (INTEGER_CST_P (info->finish[n])
5970 : : && ! INTEGER_CST_P (specinfo->finish[n]))
5971 : : loopspec[n] = ss; */
5972 : : }
5973 : :
5974 : : /* We should have found the scalarization loop specifier. If not,
5975 : : that's bad news. */
5976 : 244235 : gcc_assert (loopspec[n]);
5977 : :
5978 : 244235 : info = &loopspec[n]->info->data.array;
5979 : 244235 : dim = loopspec[n]->dim[n];
5980 : :
5981 : : /* Set the extents of this range. */
5982 : 244235 : cshape = info->shape;
5983 : 244235 : if (cshape && INTEGER_CST_P (info->start[dim])
5984 : 175709 : && INTEGER_CST_P (info->stride[dim]))
5985 : : {
5986 : 175709 : loop->from[n] = info->start[dim];
5987 : 175709 : mpz_set (i, cshape[get_array_ref_dim_for_loop_dim (loopspec[n], n)]);
5988 : 175709 : mpz_sub_ui (i, i, 1);
5989 : : /* To = from + (size - 1) * stride. */
5990 : 175709 : tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
5991 : 175709 : if (!integer_onep (info->stride[dim]))
5992 : 8592 : tmp = fold_build2_loc (input_location, MULT_EXPR,
5993 : : gfc_array_index_type, tmp,
5994 : : info->stride[dim]);
5995 : 175709 : loop->to[n] = fold_build2_loc (input_location, PLUS_EXPR,
5996 : : gfc_array_index_type,
5997 : : loop->from[n], tmp);
5998 : : }
5999 : : else
6000 : : {
6001 : 68526 : loop->from[n] = info->start[dim];
6002 : 68526 : switch (loopspec[n]->info->type)
6003 : : {
6004 : 840 : case GFC_SS_CONSTRUCTOR:
6005 : : /* The upper bound is calculated when we expand the
6006 : : constructor. */
6007 : 840 : gcc_assert (loop->to[n] == NULL_TREE);
6008 : : break;
6009 : :
6010 : 62240 : case GFC_SS_SECTION:
6011 : : /* Use the end expression if it exists and is not constant,
6012 : : so that it is only evaluated once. */
6013 : 62240 : loop->to[n] = info->end[dim];
6014 : 62240 : break;
6015 : :
6016 : 4679 : case GFC_SS_FUNCTION:
6017 : : /* The loop bound will be set when we generate the call. */
6018 : 4679 : gcc_assert (loop->to[n] == NULL_TREE);
6019 : : break;
6020 : :
6021 : 755 : case GFC_SS_INTRINSIC:
6022 : 755 : {
6023 : 755 : gfc_expr *expr = loopspec[n]->info->expr;
6024 : :
6025 : : /* The {l,u}bound of an assumed rank. */
6026 : 755 : if (expr->value.function.isym->id == GFC_ISYM_SHAPE)
6027 : 243 : gcc_assert (expr->value.function.actual->expr->rank == -1);
6028 : : else
6029 : 512 : gcc_assert ((expr->value.function.isym->id == GFC_ISYM_LBOUND
6030 : : || expr->value.function.isym->id == GFC_ISYM_UBOUND)
6031 : : && expr->value.function.actual->next->expr == NULL
6032 : : && expr->value.function.actual->expr->rank == -1);
6033 : :
6034 : 755 : loop->to[n] = info->end[dim];
6035 : 755 : break;
6036 : : }
6037 : :
6038 : 12 : case GFC_SS_COMPONENT:
6039 : 12 : {
6040 : 12 : if (info->end[dim] != NULL_TREE)
6041 : : {
6042 : 12 : loop->to[n] = info->end[dim];
6043 : 12 : break;
6044 : : }
6045 : : else
6046 : 0 : gcc_unreachable ();
6047 : : }
6048 : :
6049 : 0 : default:
6050 : 0 : gcc_unreachable ();
6051 : : }
6052 : : }
6053 : :
6054 : : /* Transform everything so we have a simple incrementing variable. */
6055 : 244235 : if (integer_onep (info->stride[dim]))
6056 : 233580 : info->delta[dim] = gfc_index_zero_node;
6057 : : else
6058 : : {
6059 : : /* Set the delta for this section. */
6060 : 10655 : info->delta[dim] = gfc_evaluate_now (loop->from[n], &outer_loop->pre);
6061 : : /* Number of iterations is (end - start + step) / step.
6062 : : with start = 0, this simplifies to
6063 : : last = end / step;
6064 : : for (i = 0; i<=last; i++){...}; */
6065 : 10655 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
6066 : : gfc_array_index_type, loop->to[n],
6067 : : loop->from[n]);
6068 : 10655 : tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
6069 : : gfc_array_index_type, tmp, info->stride[dim]);
6070 : 10655 : tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
6071 : : tmp, build_int_cst (gfc_array_index_type, -1));
6072 : 10655 : loop->to[n] = gfc_evaluate_now (tmp, &outer_loop->pre);
6073 : : /* Make the loop variable start at 0. */
6074 : 10655 : loop->from[n] = gfc_index_zero_node;
6075 : : }
6076 : : }
6077 : 179205 : mpz_clear (i);
6078 : :
6079 : 182569 : for (loop = loop->nested; loop; loop = loop->next)
6080 : 3364 : set_loop_bounds (loop);
6081 : 179205 : }
6082 : :
6083 : :
6084 : : /* Last attempt to set the loop bounds, in case they depend on an allocatable
6085 : : function result. */
6086 : :
6087 : : static void
6088 : 179205 : late_set_loop_bounds (gfc_loopinfo *loop)
6089 : : {
6090 : 179205 : int n, dim;
6091 : 179205 : gfc_array_info *info;
6092 : 179205 : gfc_ss **loopspec;
6093 : :
6094 : 179205 : loopspec = loop->specloop;
6095 : :
6096 : 423440 : for (n = 0; n < loop->dimen; n++)
6097 : : {
6098 : : /* Set the extents of this range. */
6099 : 244235 : if (loop->from[n] == NULL_TREE
6100 : 244235 : || loop->to[n] == NULL_TREE)
6101 : : {
6102 : : /* We should have found the scalarization loop specifier. If not,
6103 : : that's bad news. */
6104 : 418 : gcc_assert (loopspec[n]);
6105 : :
6106 : 418 : info = &loopspec[n]->info->data.array;
6107 : 418 : dim = loopspec[n]->dim[n];
6108 : :
6109 : 418 : if (loopspec[n]->info->type == GFC_SS_FUNCTION
6110 : 418 : && info->start[dim]
6111 : 418 : && info->end[dim])
6112 : : {
6113 : 153 : loop->from[n] = info->start[dim];
6114 : 153 : loop->to[n] = info->end[dim];
6115 : : }
6116 : : }
6117 : : }
6118 : :
6119 : 182569 : for (loop = loop->nested; loop; loop = loop->next)
6120 : 3364 : late_set_loop_bounds (loop);
6121 : 179205 : }
6122 : :
6123 : :
6124 : : /* Initialize the scalarization loop. Creates the loop variables. Determines
6125 : : the range of the loop variables. Creates a temporary if required.
6126 : : Also generates code for scalar expressions which have been
6127 : : moved outside the loop. */
6128 : :
6129 : : void
6130 : 175841 : gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
6131 : : {
6132 : 175841 : gfc_ss *tmp_ss;
6133 : 175841 : tree tmp;
6134 : :
6135 : 175841 : set_loop_bounds (loop);
6136 : :
6137 : : /* Add all the scalar code that can be taken out of the loops.
6138 : : This may include calculating the loop bounds, so do it before
6139 : : allocating the temporary. */
6140 : 175841 : gfc_add_loop_ss_code (loop, loop->ss, false, where);
6141 : :
6142 : 175841 : late_set_loop_bounds (loop);
6143 : :
6144 : 175841 : tmp_ss = loop->temp_ss;
6145 : : /* If we want a temporary then create it. */
6146 : 175841 : if (tmp_ss != NULL)
6147 : : {
6148 : 11308 : gfc_ss_info *tmp_ss_info;
6149 : :
6150 : 11308 : tmp_ss_info = tmp_ss->info;
6151 : 11308 : gcc_assert (tmp_ss_info->type == GFC_SS_TEMP);
6152 : 11308 : gcc_assert (loop->parent == NULL);
6153 : :
6154 : : /* Make absolutely sure that this is a complete type. */
6155 : 11308 : if (tmp_ss_info->string_length)
6156 : 2733 : tmp_ss_info->data.temp.type
6157 : 2733 : = gfc_get_character_type_len_for_eltype
6158 : 2733 : (TREE_TYPE (tmp_ss_info->data.temp.type),
6159 : : tmp_ss_info->string_length);
6160 : :
6161 : 11308 : tmp = tmp_ss_info->data.temp.type;
6162 : 11308 : memset (&tmp_ss_info->data.array, 0, sizeof (gfc_array_info));
6163 : 11308 : tmp_ss_info->type = GFC_SS_SECTION;
6164 : :
6165 : 11308 : gcc_assert (tmp_ss->dimen != 0);
6166 : :
6167 : 11308 : gfc_trans_create_temp_array (&loop->pre, &loop->post, tmp_ss, tmp,
6168 : : NULL_TREE, false, true, false, where);
6169 : : }
6170 : :
6171 : : /* For array parameters we don't have loop variables, so don't calculate the
6172 : : translations. */
6173 : 175841 : if (!loop->array_parameter)
6174 : 110105 : gfc_set_delta (loop);
6175 : 175841 : }
6176 : :
6177 : :
6178 : : /* Calculates how to transform from loop variables to array indices for each
6179 : : array: once loop bounds are chosen, sets the difference (DELTA field) between
6180 : : loop bounds and array reference bounds, for each array info. */
6181 : :
6182 : : void
6183 : 113900 : gfc_set_delta (gfc_loopinfo *loop)
6184 : : {
6185 : 113900 : gfc_ss *ss, **loopspec;
6186 : 113900 : gfc_array_info *info;
6187 : 113900 : tree tmp;
6188 : 113900 : int n, dim;
6189 : :
6190 : 113900 : gfc_loopinfo * const outer_loop = outermost_loop (loop);
6191 : :
6192 : 113900 : loopspec = loop->specloop;
6193 : :
6194 : : /* Calculate the translation from loop variables to array indices. */
6195 : 344360 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
6196 : : {
6197 : 230460 : gfc_ss_type ss_type;
6198 : :
6199 : 230460 : ss_type = ss->info->type;
6200 : 59210 : if (!(ss_type == GFC_SS_SECTION
6201 : 230460 : || ss_type == GFC_SS_COMPONENT
6202 : 93987 : || ss_type == GFC_SS_CONSTRUCTOR
6203 : : || (ss_type == GFC_SS_FUNCTION
6204 : 8147 : && gfc_is_class_array_function (ss->info->expr))))
6205 : 59058 : continue;
6206 : :
6207 : 171402 : info = &ss->info->data.array;
6208 : :
6209 : 385650 : for (n = 0; n < ss->dimen; n++)
6210 : : {
6211 : : /* If we are specifying the range the delta is already set. */
6212 : 214248 : if (loopspec[n] != ss)
6213 : : {
6214 : 111960 : dim = ss->dim[n];
6215 : :
6216 : : /* Calculate the offset relative to the loop variable.
6217 : : First multiply by the stride. */
6218 : 111960 : tmp = loop->from[n];
6219 : 111960 : if (!integer_onep (info->stride[dim]))
6220 : 2945 : tmp = fold_build2_loc (input_location, MULT_EXPR,
6221 : : gfc_array_index_type,
6222 : : tmp, info->stride[dim]);
6223 : :
6224 : : /* Then subtract this from our starting value. */
6225 : 111960 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
6226 : : gfc_array_index_type,
6227 : : info->start[dim], tmp);
6228 : :
6229 : 111960 : if (ss->is_alloc_lhs)
6230 : 8676 : info->delta[dim] = tmp;
6231 : : else
6232 : 103284 : info->delta[dim] = gfc_evaluate_now (tmp, &outer_loop->pre);
6233 : : }
6234 : : }
6235 : : }
6236 : :
6237 : 117352 : for (loop = loop->nested; loop; loop = loop->next)
6238 : 3452 : gfc_set_delta (loop);
6239 : 113900 : }
6240 : :
6241 : :
6242 : : /* Calculate the size of a given array dimension from the bounds. This
6243 : : is simply (ubound - lbound + 1) if this expression is positive
6244 : : or 0 if it is negative (pick either one if it is zero). Optionally
6245 : : (if or_expr is present) OR the (expression != 0) condition to it. */
6246 : :
6247 : : tree
6248 : 22334 : gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr)
6249 : : {
6250 : 22334 : tree res;
6251 : 22334 : tree cond;
6252 : :
6253 : : /* Calculate (ubound - lbound + 1). */
6254 : 22334 : res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6255 : : ubound, lbound);
6256 : 22334 : res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res,
6257 : : gfc_index_one_node);
6258 : :
6259 : : /* Check whether the size for this dimension is negative. */
6260 : 22334 : cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, res,
6261 : : gfc_index_zero_node);
6262 : 22334 : res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
6263 : : gfc_index_zero_node, res);
6264 : :
6265 : : /* Build OR expression. */
6266 : 22334 : if (or_expr)
6267 : 17371 : *or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
6268 : : logical_type_node, *or_expr, cond);
6269 : :
6270 : 22334 : return res;
6271 : : }
6272 : :
6273 : :
6274 : : /* For an array descriptor, get the total number of elements. This is just
6275 : : the product of the extents along from_dim to to_dim. */
6276 : :
6277 : : static tree
6278 : 1837 : gfc_conv_descriptor_size_1 (tree desc, int from_dim, int to_dim)
6279 : : {
6280 : 1837 : tree res;
6281 : 1837 : int dim;
6282 : :
6283 : 1837 : res = gfc_index_one_node;
6284 : :
6285 : 4474 : for (dim = from_dim; dim < to_dim; ++dim)
6286 : : {
6287 : 2637 : tree lbound;
6288 : 2637 : tree ubound;
6289 : 2637 : tree extent;
6290 : :
6291 : 2637 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
6292 : 2637 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
6293 : :
6294 : 2637 : extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
6295 : 2637 : res = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6296 : : res, extent);
6297 : : }
6298 : :
6299 : 1837 : return res;
6300 : : }
6301 : :
6302 : :
6303 : : /* Full size of an array. */
6304 : :
6305 : : tree
6306 : 1807 : gfc_conv_descriptor_size (tree desc, int rank)
6307 : : {
6308 : 1807 : return gfc_conv_descriptor_size_1 (desc, 0, rank);
6309 : : }
6310 : :
6311 : :
6312 : : /* Size of a coarray for all dimensions but the last. */
6313 : :
6314 : : tree
6315 : 30 : gfc_conv_descriptor_cosize (tree desc, int rank, int corank)
6316 : : {
6317 : 30 : return gfc_conv_descriptor_size_1 (desc, rank, rank + corank - 1);
6318 : : }
6319 : :
6320 : :
6321 : : /* Fills in an array descriptor, and returns the size of the array.
6322 : : The size will be a simple_val, ie a variable or a constant. Also
6323 : : calculates the offset of the base. The pointer argument overflow,
6324 : : which should be of integer type, will increase in value if overflow
6325 : : occurs during the size calculation. Returns the size of the array.
6326 : : {
6327 : : stride = 1;
6328 : : offset = 0;
6329 : : for (n = 0; n < rank; n++)
6330 : : {
6331 : : a.lbound[n] = specified_lower_bound;
6332 : : offset = offset + a.lbond[n] * stride;
6333 : : size = 1 - lbound;
6334 : : a.ubound[n] = specified_upper_bound;
6335 : : a.stride[n] = stride;
6336 : : size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
6337 : : overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
6338 : : stride = stride * size;
6339 : : }
6340 : : for (n = rank; n < rank+corank; n++)
6341 : : (Set lcobound/ucobound as above.)
6342 : : element_size = sizeof (array element);
6343 : : if (!rank)
6344 : : return element_size
6345 : : stride = (size_t) stride;
6346 : : overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
6347 : : stride = stride * element_size;
6348 : : return (stride);
6349 : : } */
6350 : : /*GCC ARRAYS*/
6351 : :
6352 : : static tree
6353 : 11728 : gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
6354 : : gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
6355 : : stmtblock_t * descriptor_block, tree * overflow,
6356 : : tree expr3_elem_size, gfc_expr *expr3, tree expr3_desc,
6357 : : bool e3_has_nodescriptor, gfc_expr *expr,
6358 : : tree *element_size, bool explicit_ts)
6359 : : {
6360 : 11728 : tree type;
6361 : 11728 : tree tmp;
6362 : 11728 : tree size;
6363 : 11728 : tree offset;
6364 : 11728 : tree stride;
6365 : 11728 : tree or_expr;
6366 : 11728 : tree thencase;
6367 : 11728 : tree elsecase;
6368 : 11728 : tree cond;
6369 : 11728 : tree var;
6370 : 11728 : stmtblock_t thenblock;
6371 : 11728 : stmtblock_t elseblock;
6372 : 11728 : gfc_expr *ubound;
6373 : 11728 : gfc_se se;
6374 : 11728 : int n;
6375 : :
6376 : 11728 : type = TREE_TYPE (descriptor);
6377 : :
6378 : 11728 : stride = gfc_index_one_node;
6379 : 11728 : offset = gfc_index_zero_node;
6380 : :
6381 : : /* Set the dtype before the alloc, because registration of coarrays needs
6382 : : it initialized. */
6383 : 11728 : if (expr->ts.type == BT_CHARACTER
6384 : 1067 : && expr->ts.deferred
6385 : 536 : && VAR_P (expr->ts.u.cl->backend_decl))
6386 : : {
6387 : 357 : type = gfc_typenode_for_spec (&expr->ts);
6388 : 357 : tmp = gfc_conv_descriptor_dtype (descriptor);
6389 : 357 : gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type));
6390 : : }
6391 : 11371 : else if (expr->ts.type == BT_CHARACTER
6392 : 710 : && expr->ts.deferred
6393 : 179 : && TREE_CODE (descriptor) == COMPONENT_REF)
6394 : : {
6395 : : /* Deferred character components have their string length tucked away
6396 : : in a hidden field of the derived type. Obtain that and use it to
6397 : : set the dtype. The charlen backend decl is zero because the field
6398 : : type is zero length. */
6399 : 161 : gfc_ref *ref;
6400 : 161 : tmp = NULL_TREE;
6401 : 161 : for (ref = expr->ref; ref; ref = ref->next)
6402 : 161 : if (ref->type == REF_COMPONENT
6403 : 161 : && gfc_deferred_strlen (ref->u.c.component, &tmp))
6404 : : break;
6405 : 161 : gcc_assert (tmp != NULL_TREE);
6406 : 161 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
6407 : 161 : TREE_OPERAND (descriptor, 0), tmp, NULL_TREE);
6408 : 161 : tmp = fold_convert (gfc_charlen_type_node, tmp);
6409 : 161 : type = gfc_get_character_type_len (expr->ts.kind, tmp);
6410 : 161 : tmp = gfc_conv_descriptor_dtype (descriptor);
6411 : 161 : gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type));
6412 : 161 : }
6413 : 11210 : else if (expr3_desc && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr3_desc)))
6414 : : {
6415 : 913 : tmp = gfc_conv_descriptor_dtype (descriptor);
6416 : 913 : gfc_add_modify (pblock, tmp, gfc_conv_descriptor_dtype (expr3_desc));
6417 : : }
6418 : 10297 : else if (expr->ts.type == BT_CLASS && !explicit_ts
6419 : 1251 : && expr3 && expr3->ts.type != BT_CLASS
6420 : 343 : && expr3_elem_size != NULL_TREE && expr3_desc == NULL_TREE)
6421 : : {
6422 : 343 : tmp = gfc_conv_descriptor_elem_len (descriptor);
6423 : 343 : gfc_add_modify (pblock, tmp,
6424 : 343 : fold_convert (TREE_TYPE (tmp), expr3_elem_size));
6425 : : }
6426 : : else
6427 : : {
6428 : 9954 : tmp = gfc_conv_descriptor_dtype (descriptor);
6429 : 9954 : gfc_add_modify (pblock, tmp, gfc_get_dtype (type));
6430 : : }
6431 : :
6432 : 11728 : or_expr = logical_false_node;
6433 : :
6434 : 29099 : for (n = 0; n < rank; n++)
6435 : : {
6436 : 17371 : tree conv_lbound;
6437 : 17371 : tree conv_ubound;
6438 : :
6439 : : /* We have 3 possibilities for determining the size of the array:
6440 : : lower == NULL => lbound = 1, ubound = upper[n]
6441 : : upper[n] = NULL => lbound = 1, ubound = lower[n]
6442 : : upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
6443 : 17371 : ubound = upper[n];
6444 : :
6445 : : /* Set lower bound. */
6446 : 17371 : gfc_init_se (&se, NULL);
6447 : 17371 : if (expr3_desc != NULL_TREE)
6448 : : {
6449 : 1454 : if (e3_has_nodescriptor)
6450 : : /* The lbound of nondescriptor arrays like array constructors,
6451 : : nonallocatable/nonpointer function results/variables,
6452 : : start at zero, but when allocating it, the standard expects
6453 : : the array to start at one. */
6454 : 953 : se.expr = gfc_index_one_node;
6455 : : else
6456 : 501 : se.expr = gfc_conv_descriptor_lbound_get (expr3_desc,
6457 : : gfc_rank_cst[n]);
6458 : : }
6459 : 15917 : else if (lower == NULL)
6460 : 12852 : se.expr = gfc_index_one_node;
6461 : : else
6462 : : {
6463 : 3065 : gcc_assert (lower[n]);
6464 : 3065 : if (ubound)
6465 : : {
6466 : 2400 : gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
6467 : 2400 : gfc_add_block_to_block (pblock, &se.pre);
6468 : : }
6469 : : else
6470 : : {
6471 : 665 : se.expr = gfc_index_one_node;
6472 : 665 : ubound = lower[n];
6473 : : }
6474 : : }
6475 : 17371 : gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
6476 : : gfc_rank_cst[n], se.expr);
6477 : 17371 : conv_lbound = se.expr;
6478 : :
6479 : : /* Work out the offset for this component. */
6480 : 17371 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6481 : : se.expr, stride);
6482 : 17371 : offset = fold_build2_loc (input_location, MINUS_EXPR,
6483 : : gfc_array_index_type, offset, tmp);
6484 : :
6485 : : /* Set upper bound. */
6486 : 17371 : gfc_init_se (&se, NULL);
6487 : 17371 : if (expr3_desc != NULL_TREE)
6488 : : {
6489 : 1454 : if (e3_has_nodescriptor)
6490 : : {
6491 : : /* The lbound of nondescriptor arrays like array constructors,
6492 : : nonallocatable/nonpointer function results/variables,
6493 : : start at zero, but when allocating it, the standard expects
6494 : : the array to start at one. Therefore fix the upper bound to be
6495 : : (desc.ubound - desc.lbound) + 1. */
6496 : 953 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
6497 : : gfc_array_index_type,
6498 : : gfc_conv_descriptor_ubound_get (
6499 : : expr3_desc, gfc_rank_cst[n]),
6500 : : gfc_conv_descriptor_lbound_get (
6501 : : expr3_desc, gfc_rank_cst[n]));
6502 : 953 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
6503 : : gfc_array_index_type, tmp,
6504 : : gfc_index_one_node);
6505 : 953 : se.expr = gfc_evaluate_now (tmp, pblock);
6506 : : }
6507 : : else
6508 : 501 : se.expr = gfc_conv_descriptor_ubound_get (expr3_desc,
6509 : : gfc_rank_cst[n]);
6510 : : }
6511 : : else
6512 : : {
6513 : 15917 : gcc_assert (ubound);
6514 : 15917 : gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
6515 : 15917 : gfc_add_block_to_block (pblock, &se.pre);
6516 : 15917 : if (ubound->expr_type == EXPR_FUNCTION)
6517 : 712 : se.expr = gfc_evaluate_now (se.expr, pblock);
6518 : : }
6519 : 17371 : gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
6520 : : gfc_rank_cst[n], se.expr);
6521 : 17371 : conv_ubound = se.expr;
6522 : :
6523 : : /* Store the stride. */
6524 : 17371 : gfc_conv_descriptor_stride_set (descriptor_block, descriptor,
6525 : : gfc_rank_cst[n], stride);
6526 : :
6527 : : /* Calculate size and check whether extent is negative. */
6528 : 17371 : size = gfc_conv_array_extent_dim (conv_lbound, conv_ubound, &or_expr);
6529 : 17371 : size = gfc_evaluate_now (size, pblock);
6530 : :
6531 : : /* Check whether multiplying the stride by the number of
6532 : : elements in this dimension would overflow. We must also check
6533 : : whether the current dimension has zero size in order to avoid
6534 : : division by zero.
6535 : : */
6536 : 17371 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
6537 : : gfc_array_index_type,
6538 : 17371 : fold_convert (gfc_array_index_type,
6539 : : TYPE_MAX_VALUE (gfc_array_index_type)),
6540 : : size);
6541 : 17371 : cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
6542 : : logical_type_node, tmp, stride),
6543 : : PRED_FORTRAN_OVERFLOW);
6544 : 17371 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
6545 : : integer_one_node, integer_zero_node);
6546 : 17371 : cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
6547 : : logical_type_node, size,
6548 : : gfc_index_zero_node),
6549 : : PRED_FORTRAN_SIZE_ZERO);
6550 : 17371 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
6551 : : integer_zero_node, tmp);
6552 : 17371 : tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
6553 : : *overflow, tmp);
6554 : 17371 : *overflow = gfc_evaluate_now (tmp, pblock);
6555 : :
6556 : : /* Multiply the stride by the number of elements in this dimension. */
6557 : 17371 : stride = fold_build2_loc (input_location, MULT_EXPR,
6558 : : gfc_array_index_type, stride, size);
6559 : 17371 : stride = gfc_evaluate_now (stride, pblock);
6560 : : }
6561 : :
6562 : 12257 : for (n = rank; n < rank + corank; n++)
6563 : : {
6564 : 529 : ubound = upper[n];
6565 : :
6566 : : /* Set lower bound. */
6567 : 529 : gfc_init_se (&se, NULL);
6568 : 529 : if (lower == NULL || lower[n] == NULL)
6569 : : {
6570 : 305 : gcc_assert (n == rank + corank - 1);
6571 : 305 : se.expr = gfc_index_one_node;
6572 : : }
6573 : : else
6574 : : {
6575 : 224 : if (ubound || n == rank + corank - 1)
6576 : : {
6577 : 142 : gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
6578 : 142 : gfc_add_block_to_block (pblock, &se.pre);
6579 : : }
6580 : : else
6581 : : {
6582 : 82 : se.expr = gfc_index_one_node;
6583 : 82 : ubound = lower[n];
6584 : : }
6585 : : }
6586 : 529 : gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
6587 : : gfc_rank_cst[n], se.expr);
6588 : :
6589 : 529 : if (n < rank + corank - 1)
6590 : : {
6591 : 151 : gfc_init_se (&se, NULL);
6592 : 151 : gcc_assert (ubound);
6593 : 151 : gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
6594 : 151 : gfc_add_block_to_block (pblock, &se.pre);
6595 : 151 : gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
6596 : : gfc_rank_cst[n], se.expr);
6597 : : }
6598 : : }
6599 : :
6600 : : /* The stride is the number of elements in the array, so multiply by the
6601 : : size of an element to get the total size. Obviously, if there is a
6602 : : SOURCE expression (expr3) we must use its element size. */
6603 : 11728 : if (expr3_elem_size != NULL_TREE)
6604 : 2947 : tmp = expr3_elem_size;
6605 : 8781 : else if (expr3 != NULL)
6606 : : {
6607 : 0 : if (expr3->ts.type == BT_CLASS)
6608 : : {
6609 : 0 : gfc_se se_sz;
6610 : 0 : gfc_expr *sz = gfc_copy_expr (expr3);
6611 : 0 : gfc_add_vptr_component (sz);
6612 : 0 : gfc_add_size_component (sz);
6613 : 0 : gfc_init_se (&se_sz, NULL);
6614 : 0 : gfc_conv_expr (&se_sz, sz);
6615 : 0 : gfc_free_expr (sz);
6616 : 0 : tmp = se_sz.expr;
6617 : : }
6618 : : else
6619 : : {
6620 : 0 : tmp = gfc_typenode_for_spec (&expr3->ts);
6621 : 0 : tmp = TYPE_SIZE_UNIT (tmp);
6622 : : }
6623 : : }
6624 : : else
6625 : 8781 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
6626 : :
6627 : : /* Convert to size_t. */
6628 : 11728 : *element_size = fold_convert (size_type_node, tmp);
6629 : :
6630 : 11728 : if (rank == 0)
6631 : : return *element_size;
6632 : :
6633 : 11565 : stride = fold_convert (size_type_node, stride);
6634 : :
6635 : : /* First check for overflow. Since an array of type character can
6636 : : have zero element_size, we must check for that before
6637 : : dividing. */
6638 : 11565 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
6639 : : size_type_node,
6640 : 11565 : TYPE_MAX_VALUE (size_type_node), *element_size);
6641 : 11565 : cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
6642 : : logical_type_node, tmp, stride),
6643 : : PRED_FORTRAN_OVERFLOW);
6644 : 11565 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
6645 : : integer_one_node, integer_zero_node);
6646 : 11565 : cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
6647 : : logical_type_node, *element_size,
6648 : : build_int_cst (size_type_node, 0)),
6649 : : PRED_FORTRAN_SIZE_ZERO);
6650 : 11565 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
6651 : : integer_zero_node, tmp);
6652 : 11565 : tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
6653 : : *overflow, tmp);
6654 : 11565 : *overflow = gfc_evaluate_now (tmp, pblock);
6655 : :
6656 : 11565 : size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
6657 : : stride, *element_size);
6658 : :
6659 : 11565 : if (poffset != NULL)
6660 : : {
6661 : 11565 : offset = gfc_evaluate_now (offset, pblock);
6662 : 11565 : *poffset = offset;
6663 : : }
6664 : :
6665 : 11565 : if (integer_zerop (or_expr))
6666 : : return size;
6667 : 3528 : if (integer_onep (or_expr))
6668 : 599 : return build_int_cst (size_type_node, 0);
6669 : :
6670 : 2929 : var = gfc_create_var (TREE_TYPE (size), "size");
6671 : 2929 : gfc_start_block (&thenblock);
6672 : 2929 : gfc_add_modify (&thenblock, var, build_int_cst (size_type_node, 0));
6673 : 2929 : thencase = gfc_finish_block (&thenblock);
6674 : :
6675 : 2929 : gfc_start_block (&elseblock);
6676 : 2929 : gfc_add_modify (&elseblock, var, size);
6677 : 2929 : elsecase = gfc_finish_block (&elseblock);
6678 : :
6679 : 2929 : tmp = gfc_evaluate_now (or_expr, pblock);
6680 : 2929 : tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
6681 : 2929 : gfc_add_expr_to_block (pblock, tmp);
6682 : :
6683 : 2929 : return var;
6684 : : }
6685 : :
6686 : :
6687 : : /* Retrieve the last ref from the chain. This routine is specific to
6688 : : gfc_array_allocate ()'s needs. */
6689 : :
6690 : : bool
6691 : 18002 : retrieve_last_ref (gfc_ref **ref_in, gfc_ref **prev_ref_in)
6692 : : {
6693 : 18002 : gfc_ref *ref, *prev_ref;
6694 : :
6695 : 18002 : ref = *ref_in;
6696 : : /* Prevent warnings for uninitialized variables. */
6697 : 18002 : prev_ref = *prev_ref_in;
6698 : 24614 : while (ref && ref->next != NULL)
6699 : : {
6700 : 6612 : gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
6701 : : || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
6702 : : prev_ref = ref;
6703 : : ref = ref->next;
6704 : : }
6705 : :
6706 : 18002 : if (ref == NULL || ref->type != REF_ARRAY)
6707 : : return false;
6708 : :
6709 : 12924 : *ref_in = ref;
6710 : 12924 : *prev_ref_in = prev_ref;
6711 : 12924 : return true;
6712 : : }
6713 : :
6714 : : /* Initializes the descriptor and generates a call to _gfor_allocate. Does
6715 : : the work for an ALLOCATE statement. */
6716 : : /*GCC ARRAYS*/
6717 : :
6718 : : bool
6719 : 16806 : gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
6720 : : tree errlen, tree label_finish, tree expr3_elem_size,
6721 : : gfc_expr *expr3, tree e3_arr_desc, bool e3_has_nodescriptor,
6722 : : gfc_omp_namelist *omp_alloc, bool explicit_ts)
6723 : : {
6724 : 16806 : tree tmp;
6725 : 16806 : tree pointer;
6726 : 16806 : tree offset = NULL_TREE;
6727 : 16806 : tree token = NULL_TREE;
6728 : 16806 : tree size;
6729 : 16806 : tree msg;
6730 : 16806 : tree error = NULL_TREE;
6731 : 16806 : tree overflow; /* Boolean storing whether size calculation overflows. */
6732 : 16806 : tree var_overflow = NULL_TREE;
6733 : 16806 : tree cond;
6734 : 16806 : tree set_descriptor;
6735 : 16806 : tree not_prev_allocated = NULL_TREE;
6736 : 16806 : tree element_size = NULL_TREE;
6737 : 16806 : stmtblock_t set_descriptor_block;
6738 : 16806 : stmtblock_t elseblock;
6739 : 16806 : gfc_expr **lower;
6740 : 16806 : gfc_expr **upper;
6741 : 16806 : gfc_ref *ref, *prev_ref = NULL, *coref;
6742 : 16806 : bool allocatable, coarray, dimension, alloc_w_e3_arr_spec = false,
6743 : : non_ulimate_coarray_ptr_comp;
6744 : 16806 : tree omp_cond = NULL_TREE, omp_alt_alloc = NULL_TREE;
6745 : :
6746 : 16806 : ref = expr->ref;
6747 : :
6748 : : /* Find the last reference in the chain. */
6749 : 16806 : if (!retrieve_last_ref (&ref, &prev_ref))
6750 : : return false;
6751 : :
6752 : : /* Take the allocatable and coarray properties solely from the expr-ref's
6753 : : attributes and not from source=-expression. */
6754 : 11728 : if (!prev_ref)
6755 : : {
6756 : 8162 : allocatable = expr->symtree->n.sym->attr.allocatable;
6757 : 8162 : dimension = expr->symtree->n.sym->attr.dimension;
6758 : 8162 : non_ulimate_coarray_ptr_comp = false;
6759 : : }
6760 : : else
6761 : : {
6762 : 3566 : allocatable = prev_ref->u.c.component->attr.allocatable;
6763 : : /* Pointer components in coarrayed derived types must be treated
6764 : : specially in that they are registered without a check if the are
6765 : : already associated. This does not hold for ultimate coarray
6766 : : pointers. */
6767 : 7132 : non_ulimate_coarray_ptr_comp = (prev_ref->u.c.component->attr.pointer
6768 : 3566 : && !prev_ref->u.c.component->attr.codimension);
6769 : 3566 : dimension = prev_ref->u.c.component->attr.dimension;
6770 : : }
6771 : :
6772 : : /* For allocatable/pointer arrays in derived types, one of the refs has to be
6773 : : a coarray. In this case it does not matter whether we are on this_image
6774 : : or not. */
6775 : 11728 : coarray = false;
6776 : 27922 : for (coref = expr->ref; coref; coref = coref->next)
6777 : 16734 : if (coref->type == REF_ARRAY && coref->u.ar.codimen > 0)
6778 : : {
6779 : : coarray = true;
6780 : : break;
6781 : : }
6782 : :
6783 : 11728 : if (!dimension)
6784 : 163 : gcc_assert (coarray);
6785 : :
6786 : 11728 : if (ref->u.ar.type == AR_FULL && expr3 != NULL)
6787 : : {
6788 : 1196 : gfc_ref *old_ref = ref;
6789 : : /* F08:C633: Array shape from expr3. */
6790 : 1196 : ref = expr3->ref;
6791 : :
6792 : : /* Find the last reference in the chain. */
6793 : 1196 : if (!retrieve_last_ref (&ref, &prev_ref))
6794 : : {
6795 : 0 : if (expr3->expr_type == EXPR_FUNCTION
6796 : 0 : && gfc_expr_attr (expr3).dimension)
6797 : 0 : ref = old_ref;
6798 : : else
6799 : 0 : return false;
6800 : : }
6801 : : alloc_w_e3_arr_spec = true;
6802 : : }
6803 : :
6804 : : /* Figure out the size of the array. */
6805 : 11728 : switch (ref->u.ar.type)
6806 : : {
6807 : 8900 : case AR_ELEMENT:
6808 : 8900 : if (!coarray)
6809 : : {
6810 : 8406 : lower = NULL;
6811 : 8406 : upper = ref->u.ar.start;
6812 : 8406 : break;
6813 : : }
6814 : : /* Fall through. */
6815 : :
6816 : 2156 : case AR_SECTION:
6817 : 2156 : lower = ref->u.ar.start;
6818 : 2156 : upper = ref->u.ar.end;
6819 : 2156 : break;
6820 : :
6821 : 1166 : case AR_FULL:
6822 : 1166 : gcc_assert (ref->u.ar.as->type == AS_EXPLICIT
6823 : : || alloc_w_e3_arr_spec);
6824 : :
6825 : 1166 : lower = ref->u.ar.as->lower;
6826 : 1166 : upper = ref->u.ar.as->upper;
6827 : 1166 : break;
6828 : :
6829 : 0 : default:
6830 : 0 : gcc_unreachable ();
6831 : 11728 : break;
6832 : : }
6833 : :
6834 : 11728 : overflow = integer_zero_node;
6835 : :
6836 : 11728 : if (expr->ts.type == BT_CHARACTER
6837 : 1067 : && TREE_CODE (se->string_length) == COMPONENT_REF
6838 : 161 : && expr->ts.u.cl->backend_decl != se->string_length
6839 : 161 : && VAR_P (expr->ts.u.cl->backend_decl))
6840 : 0 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
6841 : 0 : fold_convert (TREE_TYPE (expr->ts.u.cl->backend_decl),
6842 : : se->string_length));
6843 : :
6844 : 11728 : gfc_init_block (&set_descriptor_block);
6845 : : /* Take the corank only from the actual ref and not from the coref. The
6846 : : later will mislead the generation of the array dimensions for allocatable/
6847 : : pointer components in derived types. */
6848 : 22800 : size = gfc_array_init_size (se->expr, alloc_w_e3_arr_spec ? expr->rank
6849 : 10532 : : ref->u.ar.as->rank,
6850 : 540 : coarray ? ref->u.ar.as->corank : 0,
6851 : : &offset, lower, upper,
6852 : : &se->pre, &set_descriptor_block, &overflow,
6853 : : expr3_elem_size, expr3, e3_arr_desc,
6854 : : e3_has_nodescriptor, expr, &element_size,
6855 : : explicit_ts);
6856 : :
6857 : 11728 : if (dimension)
6858 : : {
6859 : 11565 : var_overflow = gfc_create_var (integer_type_node, "overflow");
6860 : 11565 : gfc_add_modify (&se->pre, var_overflow, overflow);
6861 : :
6862 : 11565 : if (status == NULL_TREE)
6863 : : {
6864 : : /* Generate the block of code handling overflow. */
6865 : 11354 : msg = gfc_build_addr_expr (pchar_type_node,
6866 : : gfc_build_localized_cstring_const
6867 : : ("Integer overflow when calculating the amount of "
6868 : : "memory to allocate"));
6869 : 11354 : error = build_call_expr_loc (input_location,
6870 : : gfor_fndecl_runtime_error, 1, msg);
6871 : : }
6872 : : else
6873 : : {
6874 : 211 : tree status_type = TREE_TYPE (status);
6875 : 211 : stmtblock_t set_status_block;
6876 : :
6877 : 211 : gfc_start_block (&set_status_block);
6878 : 211 : gfc_add_modify (&set_status_block, status,
6879 : : build_int_cst (status_type, LIBERROR_ALLOCATION));
6880 : 211 : error = gfc_finish_block (&set_status_block);
6881 : : }
6882 : : }
6883 : :
6884 : : /* Allocate memory to store the data. */
6885 : 11728 : if (POINTER_TYPE_P (TREE_TYPE (se->expr)))
6886 : 0 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
6887 : :
6888 : 11728 : if (coarray && flag_coarray == GFC_FCOARRAY_LIB)
6889 : : {
6890 : 305 : pointer = non_ulimate_coarray_ptr_comp ? se->expr
6891 : 236 : : gfc_conv_descriptor_data_get (se->expr);
6892 : 305 : token = gfc_conv_descriptor_token (se->expr);
6893 : 305 : token = gfc_build_addr_expr (NULL_TREE, token);
6894 : : }
6895 : : else
6896 : : {
6897 : 11423 : pointer = gfc_conv_descriptor_data_get (se->expr);
6898 : 11423 : if (omp_alloc)
6899 : 33 : omp_cond = boolean_true_node;
6900 : : }
6901 : 11728 : STRIP_NOPS (pointer);
6902 : :
6903 : 11728 : if (allocatable)
6904 : : {
6905 : 9599 : not_prev_allocated = gfc_create_var (logical_type_node,
6906 : : "not_prev_allocated");
6907 : 9599 : tmp = fold_build2_loc (input_location, EQ_EXPR,
6908 : : logical_type_node, pointer,
6909 : 9599 : build_int_cst (TREE_TYPE (pointer), 0));
6910 : :
6911 : 9599 : gfc_add_modify (&se->pre, not_prev_allocated, tmp);
6912 : : }
6913 : :
6914 : 11728 : gfc_start_block (&elseblock);
6915 : :
6916 : 11728 : tree succ_add_expr = NULL_TREE;
6917 : 11728 : if (omp_cond)
6918 : : {
6919 : 33 : tree align, alloc, sz;
6920 : 33 : gfc_se se2;
6921 : 33 : if (omp_alloc->u2.allocator)
6922 : : {
6923 : 10 : gfc_init_se (&se2, NULL);
6924 : 10 : gfc_conv_expr (&se2, omp_alloc->u2.allocator);
6925 : 10 : gfc_add_block_to_block (&elseblock, &se2.pre);
6926 : 10 : alloc = gfc_evaluate_now (se2.expr, &elseblock);
6927 : 10 : gfc_add_block_to_block (&elseblock, &se2.post);
6928 : : }
6929 : : else
6930 : 23 : alloc = build_zero_cst (ptr_type_node);
6931 : 33 : tmp = TREE_TYPE (TREE_TYPE (pointer));
6932 : 33 : if (tmp == void_type_node)
6933 : 33 : tmp = gfc_typenode_for_spec (&expr->ts, 0);
6934 : 33 : if (omp_alloc->u.align)
6935 : : {
6936 : 17 : gfc_init_se (&se2, NULL);
6937 : 17 : gfc_conv_expr (&se2, omp_alloc->u.align);
6938 : 17 : gcc_assert (CONSTANT_CLASS_P (se2.expr)
6939 : : && se2.pre.head == NULL
6940 : : && se2.post.head == NULL);
6941 : 17 : align = build_int_cst (size_type_node,
6942 : 17 : MAX (tree_to_uhwi (se2.expr),
6943 : : TYPE_ALIGN_UNIT (tmp)));
6944 : : }
6945 : : else
6946 : 16 : align = build_int_cst (size_type_node, TYPE_ALIGN_UNIT (tmp));
6947 : 33 : sz = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
6948 : : fold_convert (size_type_node, size),
6949 : : build_int_cst (size_type_node, 1));
6950 : 33 : omp_alt_alloc = builtin_decl_explicit (BUILT_IN_GOMP_ALLOC);
6951 : 33 : DECL_ATTRIBUTES (omp_alt_alloc)
6952 : 33 : = tree_cons (get_identifier ("omp allocator"),
6953 : : build_tree_list (NULL_TREE, alloc),
6954 : 33 : DECL_ATTRIBUTES (omp_alt_alloc));
6955 : 33 : omp_alt_alloc = build_call_expr (omp_alt_alloc, 3, align, sz, alloc);
6956 : 33 : succ_add_expr = fold_build2_loc (input_location, MODIFY_EXPR,
6957 : : void_type_node,
6958 : : gfc_conv_descriptor_version (se->expr),
6959 : : build_int_cst (integer_type_node, 1));
6960 : : }
6961 : :
6962 : : /* The allocatable variant takes the old pointer as first argument. */
6963 : 11728 : if (allocatable)
6964 : 10067 : gfc_allocate_allocatable (&elseblock, pointer, size, token,
6965 : : status, errmsg, errlen, label_finish, expr,
6966 : 468 : coref != NULL ? coref->u.ar.as->corank : 0,
6967 : : omp_cond, omp_alt_alloc, succ_add_expr);
6968 : 2129 : else if (non_ulimate_coarray_ptr_comp && token)
6969 : : /* The token is set only for GFC_FCOARRAY_LIB mode. */
6970 : 69 : gfc_allocate_using_caf_lib (&elseblock, pointer, size, token, status,
6971 : : errmsg, errlen,
6972 : : GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY);
6973 : : else
6974 : 2060 : gfc_allocate_using_malloc (&elseblock, pointer, size, status,
6975 : : omp_cond, omp_alt_alloc, succ_add_expr);
6976 : :
6977 : 11728 : if (dimension)
6978 : : {
6979 : 11565 : cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
6980 : : logical_type_node, var_overflow, integer_zero_node),
6981 : : PRED_FORTRAN_OVERFLOW);
6982 : 11565 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6983 : : error, gfc_finish_block (&elseblock));
6984 : : }
6985 : : else
6986 : 163 : tmp = gfc_finish_block (&elseblock);
6987 : :
6988 : 11728 : gfc_add_expr_to_block (&se->pre, tmp);
6989 : :
6990 : : /* Update the array descriptor with the offset and the span. */
6991 : 11728 : if (dimension)
6992 : : {
6993 : 11565 : gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
6994 : 11565 : tmp = fold_convert (gfc_array_index_type, element_size);
6995 : 11565 : gfc_conv_descriptor_span_set (&set_descriptor_block, se->expr, tmp);
6996 : : }
6997 : :
6998 : 11728 : set_descriptor = gfc_finish_block (&set_descriptor_block);
6999 : 11728 : if (status != NULL_TREE)
7000 : : {
7001 : 225 : cond = fold_build2_loc (input_location, EQ_EXPR,
7002 : : logical_type_node, status,
7003 : 225 : build_int_cst (TREE_TYPE (status), 0));
7004 : :
7005 : 225 : if (not_prev_allocated != NULL_TREE)
7006 : 209 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
7007 : : logical_type_node, cond, not_prev_allocated);
7008 : :
7009 : 225 : gfc_add_expr_to_block (&se->pre,
7010 : : fold_build3_loc (input_location, COND_EXPR, void_type_node,
7011 : : cond,
7012 : : set_descriptor,
7013 : : build_empty_stmt (input_location)));
7014 : : }
7015 : : else
7016 : 11503 : gfc_add_expr_to_block (&se->pre, set_descriptor);
7017 : :
7018 : : return true;
7019 : : }
7020 : :
7021 : :
7022 : : /* Create an array constructor from an initialization expression.
7023 : : We assume the frontend already did any expansions and conversions. */
7024 : :
7025 : : tree
7026 : 7545 : gfc_conv_array_initializer (tree type, gfc_expr * expr)
7027 : : {
7028 : 7545 : gfc_constructor *c;
7029 : 7545 : tree tmp;
7030 : 7545 : gfc_se se;
7031 : 7545 : tree index, range;
7032 : 7545 : vec<constructor_elt, va_gc> *v = NULL;
7033 : :
7034 : 7545 : if (expr->expr_type == EXPR_VARIABLE
7035 : 0 : && expr->symtree->n.sym->attr.flavor == FL_PARAMETER
7036 : 0 : && expr->symtree->n.sym->value)
7037 : 7545 : expr = expr->symtree->n.sym->value;
7038 : :
7039 : 7545 : switch (expr->expr_type)
7040 : : {
7041 : 1100 : case EXPR_CONSTANT:
7042 : 1100 : case EXPR_STRUCTURE:
7043 : : /* A single scalar or derived type value. Create an array with all
7044 : : elements equal to that value. */
7045 : 1100 : gfc_init_se (&se, NULL);
7046 : :
7047 : 1100 : if (expr->expr_type == EXPR_CONSTANT)
7048 : 380 : gfc_conv_constant (&se, expr);
7049 : : else
7050 : 720 : gfc_conv_structure (&se, expr, 1);
7051 : :
7052 : 2200 : if (tree_int_cst_lt (TYPE_MAX_VALUE (TYPE_DOMAIN (type)),
7053 : 1100 : TYPE_MIN_VALUE (TYPE_DOMAIN (type))))
7054 : : break;
7055 : 2176 : else if (tree_int_cst_equal (TYPE_MIN_VALUE (TYPE_DOMAIN (type)),
7056 : 1088 : TYPE_MAX_VALUE (TYPE_DOMAIN (type))))
7057 : 144 : range = TYPE_MIN_VALUE (TYPE_DOMAIN (type));
7058 : : else
7059 : 1888 : range = build2 (RANGE_EXPR, gfc_array_index_type,
7060 : 944 : TYPE_MIN_VALUE (TYPE_DOMAIN (type)),
7061 : 944 : TYPE_MAX_VALUE (TYPE_DOMAIN (type)));
7062 : 1088 : CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
7063 : 1088 : break;
7064 : :
7065 : 6445 : case EXPR_ARRAY:
7066 : : /* Create a vector of all the elements. */
7067 : 6445 : for (c = gfc_constructor_first (expr->value.constructor);
7068 : 163790 : c && c->expr; c = gfc_constructor_next (c))
7069 : : {
7070 : 157345 : if (c->iterator)
7071 : : {
7072 : : /* Problems occur when we get something like
7073 : : integer :: a(lots) = (/(i, i=1, lots)/) */
7074 : 0 : gfc_fatal_error ("The number of elements in the array "
7075 : : "constructor at %L requires an increase of "
7076 : : "the allowed %d upper limit. See "
7077 : : "%<-fmax-array-constructor%> option",
7078 : : &expr->where, flag_max_array_constructor);
7079 : : return NULL_TREE;
7080 : : }
7081 : 157345 : if (mpz_cmp_si (c->offset, 0) != 0)
7082 : 151157 : index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
7083 : : else
7084 : : index = NULL_TREE;
7085 : :
7086 : 157345 : if (mpz_cmp_si (c->repeat, 1) > 0)
7087 : : {
7088 : 127 : tree tmp1, tmp2;
7089 : 127 : mpz_t maxval;
7090 : :
7091 : 127 : mpz_init (maxval);
7092 : 127 : mpz_add (maxval, c->offset, c->repeat);
7093 : 127 : mpz_sub_ui (maxval, maxval, 1);
7094 : 127 : tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
7095 : 127 : if (mpz_cmp_si (c->offset, 0) != 0)
7096 : : {
7097 : 27 : mpz_add_ui (maxval, c->offset, 1);
7098 : 27 : tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
7099 : : }
7100 : : else
7101 : 100 : tmp1 = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
7102 : :
7103 : 127 : range = fold_build2 (RANGE_EXPR, gfc_array_index_type, tmp1, tmp2);
7104 : 127 : mpz_clear (maxval);
7105 : : }
7106 : : else
7107 : : range = NULL;
7108 : :
7109 : 157345 : gfc_init_se (&se, NULL);
7110 : 157345 : switch (c->expr->expr_type)
7111 : : {
7112 : 155933 : case EXPR_CONSTANT:
7113 : 155933 : gfc_conv_constant (&se, c->expr);
7114 : :
7115 : : /* See gfortran.dg/charlen_15.f90 for instance. */
7116 : 155933 : if (TREE_CODE (se.expr) == STRING_CST
7117 : 5206 : && TREE_CODE (type) == ARRAY_TYPE)
7118 : : {
7119 : : tree atype = type;
7120 : 10412 : while (TREE_CODE (TREE_TYPE (atype)) == ARRAY_TYPE)
7121 : 5206 : atype = TREE_TYPE (atype);
7122 : 5206 : gcc_checking_assert (TREE_CODE (TREE_TYPE (atype))
7123 : : == INTEGER_TYPE);
7124 : 5206 : gcc_checking_assert (TREE_TYPE (TREE_TYPE (se.expr))
7125 : : == TREE_TYPE (atype));
7126 : 5206 : if (tree_to_uhwi (TYPE_SIZE_UNIT (TREE_TYPE (se.expr)))
7127 : 5206 : > tree_to_uhwi (TYPE_SIZE_UNIT (atype)))
7128 : : {
7129 : 0 : unsigned HOST_WIDE_INT size
7130 : 0 : = tree_to_uhwi (TYPE_SIZE_UNIT (atype));
7131 : 0 : const char *p = TREE_STRING_POINTER (se.expr);
7132 : :
7133 : 0 : se.expr = build_string (size, p);
7134 : : }
7135 : 5206 : TREE_TYPE (se.expr) = atype;
7136 : : }
7137 : : break;
7138 : :
7139 : 1412 : case EXPR_STRUCTURE:
7140 : 1412 : gfc_conv_structure (&se, c->expr, 1);
7141 : 1412 : break;
7142 : :
7143 : 0 : default:
7144 : : /* Catch those occasional beasts that do not simplify
7145 : : for one reason or another, assuming that if they are
7146 : : standard defying the frontend will catch them. */
7147 : 0 : gfc_conv_expr (&se, c->expr);
7148 : 0 : break;
7149 : : }
7150 : :
7151 : 157345 : if (range == NULL_TREE)
7152 : 157218 : CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
7153 : : else
7154 : : {
7155 : 127 : if (index != NULL_TREE)
7156 : 27 : CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
7157 : 157472 : CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
7158 : : }
7159 : : }
7160 : : break;
7161 : :
7162 : 0 : case EXPR_NULL:
7163 : 0 : return gfc_build_null_descriptor (type);
7164 : :
7165 : 0 : default:
7166 : 0 : gcc_unreachable ();
7167 : : }
7168 : :
7169 : : /* Create a constructor from the list of elements. */
7170 : 7545 : tmp = build_constructor (type, v);
7171 : 7545 : TREE_CONSTANT (tmp) = 1;
7172 : 7545 : return tmp;
7173 : : }
7174 : :
7175 : :
7176 : : /* Generate code to evaluate non-constant coarray cobounds. */
7177 : :
7178 : : void
7179 : 19649 : gfc_trans_array_cobounds (tree type, stmtblock_t * pblock,
7180 : : const gfc_symbol *sym)
7181 : : {
7182 : 19649 : int dim;
7183 : 19649 : tree ubound;
7184 : 19649 : tree lbound;
7185 : 19649 : gfc_se se;
7186 : 19649 : gfc_array_spec *as;
7187 : :
7188 : 19649 : as = IS_CLASS_COARRAY_OR_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
7189 : :
7190 : 20412 : for (dim = as->rank; dim < as->rank + as->corank; dim++)
7191 : : {
7192 : : /* Evaluate non-constant array bound expressions.
7193 : : F2008 4.5.6.3 para 6: If a specification expression in a scoping unit
7194 : : references a function, the result is finalized before execution of the
7195 : : executable constructs in the scoping unit.
7196 : : Adding the finalblocks enables this. */
7197 : 763 : lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
7198 : 763 : if (as->lower[dim] && !INTEGER_CST_P (lbound))
7199 : : {
7200 : 96 : gfc_init_se (&se, NULL);
7201 : 96 : gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
7202 : 96 : gfc_add_block_to_block (pblock, &se.pre);
7203 : 96 : gfc_add_block_to_block (pblock, &se.finalblock);
7204 : 96 : gfc_add_modify (pblock, lbound, se.expr);
7205 : : }
7206 : 763 : ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
7207 : 763 : if (as->upper[dim] && !INTEGER_CST_P (ubound))
7208 : : {
7209 : 50 : gfc_init_se (&se, NULL);
7210 : 50 : gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
7211 : 50 : gfc_add_block_to_block (pblock, &se.pre);
7212 : 50 : gfc_add_block_to_block (pblock, &se.finalblock);
7213 : 50 : gfc_add_modify (pblock, ubound, se.expr);
7214 : : }
7215 : : }
7216 : 19649 : }
7217 : :
7218 : :
7219 : : /* Generate code to evaluate non-constant array bounds. Sets *poffset and
7220 : : returns the size (in elements) of the array. */
7221 : :
7222 : : tree
7223 : 12713 : gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
7224 : : stmtblock_t * pblock)
7225 : : {
7226 : 12713 : gfc_array_spec *as;
7227 : 12713 : tree size;
7228 : 12713 : tree stride;
7229 : 12713 : tree offset;
7230 : 12713 : tree ubound;
7231 : 12713 : tree lbound;
7232 : 12713 : tree tmp;
7233 : 12713 : gfc_se se;
7234 : :
7235 : 12713 : int dim;
7236 : :
7237 : 12713 : as = IS_CLASS_COARRAY_OR_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
7238 : :
7239 : 12713 : size = gfc_index_one_node;
7240 : 12713 : offset = gfc_index_zero_node;
7241 : 12713 : stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
7242 : 12713 : if (stride && VAR_P (stride))
7243 : 124 : gfc_add_modify (pblock, stride, gfc_index_one_node);
7244 : 28670 : for (dim = 0; dim < as->rank; dim++)
7245 : : {
7246 : : /* Evaluate non-constant array bound expressions.
7247 : : F2008 4.5.6.3 para 6: If a specification expression in a scoping unit
7248 : : references a function, the result is finalized before execution of the
7249 : : executable constructs in the scoping unit.
7250 : : Adding the finalblocks enables this. */
7251 : 15957 : lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
7252 : 15957 : if (as->lower[dim] && !INTEGER_CST_P (lbound))
7253 : : {
7254 : 475 : gfc_init_se (&se, NULL);
7255 : 475 : gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
7256 : 475 : gfc_add_block_to_block (pblock, &se.pre);
7257 : 475 : gfc_add_block_to_block (pblock, &se.finalblock);
7258 : 475 : gfc_add_modify (pblock, lbound, se.expr);
7259 : : }
7260 : 15957 : ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
7261 : 15957 : if (as->upper[dim] && !INTEGER_CST_P (ubound))
7262 : : {
7263 : 9600 : gfc_init_se (&se, NULL);
7264 : 9600 : gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
7265 : 9600 : gfc_add_block_to_block (pblock, &se.pre);
7266 : 9600 : gfc_add_block_to_block (pblock, &se.finalblock);
7267 : 9600 : gfc_add_modify (pblock, ubound, se.expr);
7268 : : }
7269 : : /* The offset of this dimension. offset = offset - lbound * stride. */
7270 : 15957 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7271 : : lbound, size);
7272 : 15957 : offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7273 : : offset, tmp);
7274 : :
7275 : : /* The size of this dimension, and the stride of the next. */
7276 : 15957 : if (dim + 1 < as->rank)
7277 : 3391 : stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
7278 : : else
7279 : 12566 : stride = GFC_TYPE_ARRAY_SIZE (type);
7280 : :
7281 : 15957 : if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
7282 : : {
7283 : : /* Calculate stride = size * (ubound + 1 - lbound). */
7284 : 9784 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
7285 : : gfc_array_index_type,
7286 : : gfc_index_one_node, lbound);
7287 : 9784 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
7288 : : gfc_array_index_type, ubound, tmp);
7289 : 9784 : tmp = fold_build2_loc (input_location, MULT_EXPR,
7290 : : gfc_array_index_type, size, tmp);
7291 : 9784 : if (stride)
7292 : 9784 : gfc_add_modify (pblock, stride, tmp);
7293 : : else
7294 : 0 : stride = gfc_evaluate_now (tmp, pblock);
7295 : :
7296 : : /* Make sure that negative size arrays are translated
7297 : : to being zero size. */
7298 : 9784 : tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
7299 : : stride, gfc_index_zero_node);
7300 : 9784 : tmp = fold_build3_loc (input_location, COND_EXPR,
7301 : : gfc_array_index_type, tmp,
7302 : : stride, gfc_index_zero_node);
7303 : 9784 : gfc_add_modify (pblock, stride, tmp);
7304 : : }
7305 : :
7306 : : size = stride;
7307 : : }
7308 : :
7309 : 12713 : gfc_trans_array_cobounds (type, pblock, sym);
7310 : 12713 : gfc_trans_vla_type_sizes (sym, pblock);
7311 : :
7312 : 12713 : *poffset = offset;
7313 : 12713 : return size;
7314 : : }
7315 : :
7316 : :
7317 : : /* Generate code to initialize/allocate an array variable. */
7318 : :
7319 : : void
7320 : 30571 : gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
7321 : : gfc_wrapped_block * block)
7322 : : {
7323 : 30571 : stmtblock_t init;
7324 : 30571 : tree type;
7325 : 30571 : tree tmp = NULL_TREE;
7326 : 30571 : tree size;
7327 : 30571 : tree offset;
7328 : 30571 : tree space;
7329 : 30571 : tree inittree;
7330 : 30571 : bool onstack;
7331 : 30571 : bool back;
7332 : :
7333 : 30571 : gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
7334 : :
7335 : : /* Do nothing for USEd variables. */
7336 : 30571 : if (sym->attr.use_assoc)
7337 : 25444 : return;
7338 : :
7339 : 30531 : type = TREE_TYPE (decl);
7340 : 30531 : gcc_assert (GFC_ARRAY_TYPE_P (type));
7341 : 30531 : onstack = TREE_CODE (type) != POINTER_TYPE;
7342 : :
7343 : : /* In the case of non-dummy symbols with dependencies on an old-fashioned
7344 : : function result (ie. proc_name = proc_name->result), gfc_add_init_cleanup
7345 : : must be called with the last, optional argument false so that the alloc-
7346 : : ation occurs after the processing of the result. */
7347 : 30531 : back = sym->fn_result_dep;
7348 : :
7349 : 30531 : gfc_init_block (&init);
7350 : :
7351 : : /* Evaluate character string length. */
7352 : 30531 : if (sym->ts.type == BT_CHARACTER
7353 : 2983 : && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
7354 : : {
7355 : 43 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7356 : :
7357 : 43 : gfc_trans_vla_type_sizes (sym, &init);
7358 : :
7359 : : /* Emit a DECL_EXPR for this variable, which will cause the
7360 : : gimplifier to allocate storage, and all that good stuff. */
7361 : 43 : tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
7362 : 43 : gfc_add_expr_to_block (&init, tmp);
7363 : 43 : if (sym->attr.omp_allocate)
7364 : : {
7365 : : /* Save location of size calculation to ensure GOMP_alloc is placed
7366 : : after it. */
7367 : 0 : tree omp_alloc = lookup_attribute ("omp allocate",
7368 : 0 : DECL_ATTRIBUTES (decl));
7369 : 0 : TREE_CHAIN (TREE_CHAIN (TREE_VALUE (omp_alloc)))
7370 : 0 : = build_tree_list (NULL_TREE, tsi_stmt (tsi_last (init.head)));
7371 : : }
7372 : : }
7373 : :
7374 : 30329 : if (onstack)
7375 : : {
7376 : 25264 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE,
7377 : : back);
7378 : 25264 : return;
7379 : : }
7380 : :
7381 : 5267 : type = TREE_TYPE (type);
7382 : :
7383 : 5267 : gcc_assert (!sym->attr.use_assoc);
7384 : 5267 : gcc_assert (!sym->module);
7385 : :
7386 : 5267 : if (sym->ts.type == BT_CHARACTER
7387 : 202 : && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
7388 : 94 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7389 : :
7390 : 5267 : size = gfc_trans_array_bounds (type, sym, &offset, &init);
7391 : :
7392 : : /* Don't actually allocate space for Cray Pointees. */
7393 : 5267 : if (sym->attr.cray_pointee)
7394 : : {
7395 : 140 : if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
7396 : 49 : gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
7397 : :
7398 : 140 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
7399 : 140 : return;
7400 : : }
7401 : 5127 : if (sym->attr.omp_allocate)
7402 : : {
7403 : : /* The size is the number of elements in the array, so multiply by the
7404 : : size of an element to get the total size. */
7405 : 7 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
7406 : 7 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7407 : : size, fold_convert (gfc_array_index_type, tmp));
7408 : 7 : size = gfc_evaluate_now (size, &init);
7409 : :
7410 : 7 : tree omp_alloc = lookup_attribute ("omp allocate",
7411 : 7 : DECL_ATTRIBUTES (decl));
7412 : 7 : TREE_CHAIN (TREE_CHAIN (TREE_VALUE (omp_alloc)))
7413 : 7 : = build_tree_list (size, NULL_TREE);
7414 : 7 : space = NULL_TREE;
7415 : : }
7416 : 5120 : else if (flag_stack_arrays)
7417 : : {
7418 : 13 : gcc_assert (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE);
7419 : 13 : space = build_decl (gfc_get_location (&sym->declared_at),
7420 : : VAR_DECL, create_tmp_var_name ("A"),
7421 : 13 : TREE_TYPE (TREE_TYPE (decl)));
7422 : 13 : gfc_trans_vla_type_sizes (sym, &init);
7423 : : }
7424 : : else
7425 : : {
7426 : : /* The size is the number of elements in the array, so multiply by the
7427 : : size of an element to get the total size. */
7428 : 5107 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
7429 : 5107 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7430 : : size, fold_convert (gfc_array_index_type, tmp));
7431 : :
7432 : : /* Allocate memory to hold the data. */
7433 : 5107 : tmp = gfc_call_malloc (&init, TREE_TYPE (decl), size);
7434 : 5107 : gfc_add_modify (&init, decl, tmp);
7435 : :
7436 : : /* Free the temporary. */
7437 : 5107 : tmp = gfc_call_free (decl);
7438 : 5107 : space = NULL_TREE;
7439 : : }
7440 : :
7441 : : /* Set offset of the array. */
7442 : 5127 : if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
7443 : 369 : gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
7444 : :
7445 : : /* Automatic arrays should not have initializers. */
7446 : 5127 : gcc_assert (!sym->value);
7447 : :
7448 : 5127 : inittree = gfc_finish_block (&init);
7449 : :
7450 : 5127 : if (space)
7451 : : {
7452 : 13 : tree addr;
7453 : 13 : pushdecl (space);
7454 : :
7455 : : /* Don't create new scope, emit the DECL_EXPR in exactly the scope
7456 : : where also space is located. */
7457 : 13 : gfc_init_block (&init);
7458 : 13 : tmp = fold_build1_loc (input_location, DECL_EXPR,
7459 : 13 : TREE_TYPE (space), space);
7460 : 13 : gfc_add_expr_to_block (&init, tmp);
7461 : 13 : addr = fold_build1_loc (gfc_get_location (&sym->declared_at),
7462 : 13 : ADDR_EXPR, TREE_TYPE (decl), space);
7463 : 13 : gfc_add_modify (&init, decl, addr);
7464 : 13 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE,
7465 : : back);
7466 : 13 : tmp = NULL_TREE;
7467 : : }
7468 : 5127 : gfc_add_init_cleanup (block, inittree, tmp, back);
7469 : : }
7470 : :
7471 : :
7472 : : /* Generate entry and exit code for g77 calling convention arrays. */
7473 : :
7474 : : void
7475 : 7192 : gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block)
7476 : : {
7477 : 7192 : tree parm;
7478 : 7192 : tree type;
7479 : 7192 : tree offset;
7480 : 7192 : tree tmp;
7481 : 7192 : tree stmt;
7482 : 7192 : stmtblock_t init;
7483 : :
7484 : 7192 : location_t loc = input_location;
7485 : 7192 : input_location = gfc_get_location (&sym->declared_at);
7486 : :
7487 : : /* Descriptor type. */
7488 : 7192 : parm = sym->backend_decl;
7489 : 7192 : type = TREE_TYPE (parm);
7490 : 7192 : gcc_assert (GFC_ARRAY_TYPE_P (type));
7491 : :
7492 : 7192 : gfc_start_block (&init);
7493 : :
7494 : 7192 : if (sym->ts.type == BT_CHARACTER
7495 : 661 : && VAR_P (sym->ts.u.cl->backend_decl))
7496 : 79 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7497 : :
7498 : : /* Evaluate the bounds of the array. */
7499 : 7192 : gfc_trans_array_bounds (type, sym, &offset, &init);
7500 : :
7501 : : /* Set the offset. */
7502 : 7192 : if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
7503 : 1210 : gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
7504 : :
7505 : : /* Set the pointer itself if we aren't using the parameter directly. */
7506 : 7192 : if (TREE_CODE (parm) != PARM_DECL)
7507 : : {
7508 : 559 : tmp = GFC_DECL_SAVED_DESCRIPTOR (parm);
7509 : 559 : if (sym->ts.type == BT_CLASS)
7510 : : {
7511 : 239 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
7512 : 239 : tmp = gfc_class_data_get (tmp);
7513 : 239 : tmp = gfc_conv_descriptor_data_get (tmp);
7514 : : }
7515 : 559 : tmp = convert (TREE_TYPE (parm), tmp);
7516 : 559 : gfc_add_modify (&init, parm, tmp);
7517 : : }
7518 : 7192 : stmt = gfc_finish_block (&init);
7519 : :
7520 : 7192 : input_location = loc;
7521 : :
7522 : : /* Add the initialization code to the start of the function. */
7523 : :
7524 : 7192 : if ((sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.optional)
7525 : 7192 : || sym->attr.optional
7526 : 6710 : || sym->attr.not_always_present)
7527 : : {
7528 : 539 : tree nullify;
7529 : 539 : if (TREE_CODE (parm) != PARM_DECL)
7530 : 105 : nullify = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
7531 : : parm, null_pointer_node);
7532 : : else
7533 : 434 : nullify = build_empty_stmt (input_location);
7534 : 539 : tmp = gfc_conv_expr_present (sym, true);
7535 : 539 : stmt = build3_v (COND_EXPR, tmp, stmt, nullify);
7536 : : }
7537 : :
7538 : 7192 : gfc_add_init_cleanup (block, stmt, NULL_TREE);
7539 : 7192 : }
7540 : :
7541 : :
7542 : : /* Modify the descriptor of an array parameter so that it has the
7543 : : correct lower bound. Also move the upper bound accordingly.
7544 : : If the array is not packed, it will be copied into a temporary.
7545 : : For each dimension we set the new lower and upper bounds. Then we copy the
7546 : : stride and calculate the offset for this dimension. We also work out
7547 : : what the stride of a packed array would be, and see it the two match.
7548 : : If the array need repacking, we set the stride to the values we just
7549 : : calculated, recalculate the offset and copy the array data.
7550 : : Code is also added to copy the data back at the end of the function.
7551 : : */
7552 : :
7553 : : void
7554 : 12490 : gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
7555 : : gfc_wrapped_block * block)
7556 : : {
7557 : 12490 : tree size;
7558 : 12490 : tree type;
7559 : 12490 : tree offset;
7560 : 12490 : stmtblock_t init;
7561 : 12490 : tree stmtInit, stmtCleanup;
7562 : 12490 : tree lbound;
7563 : 12490 : tree ubound;
7564 : 12490 : tree dubound;
7565 : 12490 : tree dlbound;
7566 : 12490 : tree dumdesc;
7567 : 12490 : tree tmp;
7568 : 12490 : tree stride, stride2;
7569 : 12490 : tree stmt_packed;
7570 : 12490 : tree stmt_unpacked;
7571 : 12490 : tree partial;
7572 : 12490 : gfc_se se;
7573 : 12490 : int n;
7574 : 12490 : int checkparm;
7575 : 12490 : int no_repack;
7576 : 12490 : bool optional_arg;
7577 : 12490 : gfc_array_spec *as;
7578 : 12490 : bool is_classarray = IS_CLASS_COARRAY_OR_ARRAY (sym);
7579 : :
7580 : : /* Do nothing for pointer and allocatable arrays. */
7581 : 12490 : if ((sym->ts.type != BT_CLASS && sym->attr.pointer)
7582 : 12393 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer)
7583 : 12393 : || sym->attr.allocatable
7584 : 12287 : || (is_classarray && CLASS_DATA (sym)->attr.allocatable))
7585 : 5876 : return;
7586 : :
7587 : 742 : if ((!is_classarray
7588 : 742 : || (is_classarray && CLASS_DATA (sym)->as->type == AS_EXPLICIT))
7589 : 11725 : && sym->attr.dummy && !sym->attr.elemental && gfc_is_nodesc_array (sym))
7590 : : {
7591 : 5673 : gfc_trans_g77_array (sym, block);
7592 : 5673 : return;
7593 : : }
7594 : :
7595 : 6614 : location_t loc = input_location;
7596 : 6614 : input_location = gfc_get_location (&sym->declared_at);
7597 : :
7598 : : /* Descriptor type. */
7599 : 6614 : type = TREE_TYPE (tmpdesc);
7600 : 6614 : gcc_assert (GFC_ARRAY_TYPE_P (type));
7601 : 6614 : dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
7602 : 6614 : if (is_classarray)
7603 : : /* For a class array the dummy array descriptor is in the _class
7604 : : component. */
7605 : 581 : dumdesc = gfc_class_data_get (dumdesc);
7606 : : else
7607 : 6033 : dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc);
7608 : 6614 : as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
7609 : 6614 : gfc_start_block (&init);
7610 : :
7611 : 6614 : if (sym->ts.type == BT_CHARACTER
7612 : 771 : && VAR_P (sym->ts.u.cl->backend_decl))
7613 : 87 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7614 : :
7615 : : /* TODO: Fix the exclusion of class arrays from extent checking. */
7616 : 1053 : checkparm = (as->type == AS_EXPLICIT && !is_classarray
7617 : 7648 : && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
7618 : :
7619 : 6614 : no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
7620 : 6613 : || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
7621 : :
7622 : 6614 : if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
7623 : : {
7624 : : /* For non-constant shape arrays we only check if the first dimension
7625 : : is contiguous. Repacking higher dimensions wouldn't gain us
7626 : : anything as we still don't know the array stride. */
7627 : 1 : partial = gfc_create_var (logical_type_node, "partial");
7628 : 1 : TREE_USED (partial) = 1;
7629 : 1 : tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
7630 : 1 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, tmp,
7631 : : gfc_index_one_node);
7632 : 1 : gfc_add_modify (&init, partial, tmp);
7633 : : }
7634 : : else
7635 : : partial = NULL_TREE;
7636 : :
7637 : : /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
7638 : : here, however I think it does the right thing. */
7639 : 6614 : if (no_repack)
7640 : : {
7641 : : /* Set the first stride. */
7642 : 6612 : stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
7643 : 6612 : stride = gfc_evaluate_now (stride, &init);
7644 : :
7645 : 6612 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7646 : : stride, gfc_index_zero_node);
7647 : 6612 : tmp = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
7648 : : tmp, gfc_index_one_node, stride);
7649 : 6612 : stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
7650 : 6612 : gfc_add_modify (&init, stride, tmp);
7651 : :
7652 : : /* Allow the user to disable array repacking. */
7653 : 6612 : stmt_unpacked = NULL_TREE;
7654 : : }
7655 : : else
7656 : : {
7657 : 2 : gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
7658 : : /* A library call to repack the array if necessary. */
7659 : 2 : tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
7660 : 2 : stmt_unpacked = build_call_expr_loc (input_location,
7661 : : gfor_fndecl_in_pack, 1, tmp);
7662 : :
7663 : 2 : stride = gfc_index_one_node;
7664 : :
7665 : 2 : if (warn_array_temporaries)
7666 : : {
7667 : 1 : locus where;
7668 : 1 : gfc_locus_from_location (&where, loc);
7669 : 1 : gfc_warning (OPT_Warray_temporaries,
7670 : : "Creating array temporary at %L", &where);
7671 : : }
7672 : : }
7673 : :
7674 : : /* This is for the case where the array data is used directly without
7675 : : calling the repack function. */
7676 : 6614 : if (no_repack || partial != NULL_TREE)
7677 : 6613 : stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
7678 : : else
7679 : : stmt_packed = NULL_TREE;
7680 : :
7681 : : /* Assign the data pointer. */
7682 : 6614 : if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
7683 : : {
7684 : : /* Don't repack unknown shape arrays when the first stride is 1. */
7685 : 1 : tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (stmt_packed),
7686 : : partial, stmt_packed, stmt_unpacked);
7687 : : }
7688 : : else
7689 : 6613 : tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
7690 : 6614 : gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp));
7691 : :
7692 : 6614 : offset = gfc_index_zero_node;
7693 : 6614 : size = gfc_index_one_node;
7694 : :
7695 : : /* Evaluate the bounds of the array. */
7696 : 15500 : for (n = 0; n < as->rank; n++)
7697 : : {
7698 : 8886 : if (checkparm || !as->upper[n])
7699 : : {
7700 : : /* Get the bounds of the actual parameter. */
7701 : 7598 : dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]);
7702 : 7598 : dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]);
7703 : : }
7704 : : else
7705 : : {
7706 : : dubound = NULL_TREE;
7707 : : dlbound = NULL_TREE;
7708 : : }
7709 : :
7710 : 8886 : lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
7711 : 8886 : if (!INTEGER_CST_P (lbound))
7712 : : {
7713 : 45 : gfc_init_se (&se, NULL);
7714 : 45 : gfc_conv_expr_type (&se, as->lower[n],
7715 : : gfc_array_index_type);
7716 : 45 : gfc_add_block_to_block (&init, &se.pre);
7717 : 45 : gfc_add_modify (&init, lbound, se.expr);
7718 : : }
7719 : :
7720 : 8886 : ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
7721 : : /* Set the desired upper bound. */
7722 : 8886 : if (as->upper[n])
7723 : : {
7724 : : /* We know what we want the upper bound to be. */
7725 : 1346 : if (!INTEGER_CST_P (ubound))
7726 : : {
7727 : 620 : gfc_init_se (&se, NULL);
7728 : 620 : gfc_conv_expr_type (&se, as->upper[n],
7729 : : gfc_array_index_type);
7730 : 620 : gfc_add_block_to_block (&init, &se.pre);
7731 : 620 : gfc_add_modify (&init, ubound, se.expr);
7732 : : }
7733 : :
7734 : : /* Check the sizes match. */
7735 : 1346 : if (checkparm)
7736 : : {
7737 : : /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
7738 : 58 : char * msg;
7739 : 58 : tree temp;
7740 : 58 : locus where;
7741 : :
7742 : 58 : gfc_locus_from_location (&where, loc);
7743 : 58 : temp = fold_build2_loc (input_location, MINUS_EXPR,
7744 : : gfc_array_index_type, ubound, lbound);
7745 : 58 : temp = fold_build2_loc (input_location, PLUS_EXPR,
7746 : : gfc_array_index_type,
7747 : : gfc_index_one_node, temp);
7748 : 58 : stride2 = fold_build2_loc (input_location, MINUS_EXPR,
7749 : : gfc_array_index_type, dubound,
7750 : : dlbound);
7751 : 58 : stride2 = fold_build2_loc (input_location, PLUS_EXPR,
7752 : : gfc_array_index_type,
7753 : : gfc_index_one_node, stride2);
7754 : 58 : tmp = fold_build2_loc (input_location, NE_EXPR,
7755 : : gfc_array_index_type, temp, stride2);
7756 : 58 : msg = xasprintf ("Dimension %d of array '%s' has extent "
7757 : : "%%ld instead of %%ld", n+1, sym->name);
7758 : :
7759 : 58 : gfc_trans_runtime_check (true, false, tmp, &init, &where, msg,
7760 : : fold_convert (long_integer_type_node, temp),
7761 : : fold_convert (long_integer_type_node, stride2));
7762 : :
7763 : 58 : free (msg);
7764 : : }
7765 : : }
7766 : : else
7767 : : {
7768 : : /* For assumed shape arrays move the upper bound by the same amount
7769 : : as the lower bound. */
7770 : 7540 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
7771 : : gfc_array_index_type, dubound, dlbound);
7772 : 7540 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
7773 : : gfc_array_index_type, tmp, lbound);
7774 : 7540 : gfc_add_modify (&init, ubound, tmp);
7775 : : }
7776 : : /* The offset of this dimension. offset = offset - lbound * stride. */
7777 : 8886 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7778 : : lbound, stride);
7779 : 8886 : offset = fold_build2_loc (input_location, MINUS_EXPR,
7780 : : gfc_array_index_type, offset, tmp);
7781 : :
7782 : : /* The size of this dimension, and the stride of the next. */
7783 : 8886 : if (n + 1 < as->rank)
7784 : : {
7785 : 2272 : stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
7786 : :
7787 : 2272 : if (no_repack || partial != NULL_TREE)
7788 : 2271 : stmt_unpacked =
7789 : 2271 : gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]);
7790 : :
7791 : : /* Figure out the stride if not a known constant. */
7792 : 2272 : if (!INTEGER_CST_P (stride))
7793 : : {
7794 : 2271 : if (no_repack)
7795 : : stmt_packed = NULL_TREE;
7796 : : else
7797 : : {
7798 : : /* Calculate stride = size * (ubound + 1 - lbound). */
7799 : 0 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
7800 : : gfc_array_index_type,
7801 : : gfc_index_one_node, lbound);
7802 : 0 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
7803 : : gfc_array_index_type, ubound, tmp);
7804 : 0 : size = fold_build2_loc (input_location, MULT_EXPR,
7805 : : gfc_array_index_type, size, tmp);
7806 : 0 : stmt_packed = size;
7807 : : }
7808 : :
7809 : : /* Assign the stride. */
7810 : 2271 : if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
7811 : 0 : tmp = fold_build3_loc (input_location, COND_EXPR,
7812 : : gfc_array_index_type, partial,
7813 : : stmt_unpacked, stmt_packed);
7814 : : else
7815 : 2271 : tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
7816 : 2271 : gfc_add_modify (&init, stride, tmp);
7817 : : }
7818 : : }
7819 : : else
7820 : : {
7821 : 6614 : stride = GFC_TYPE_ARRAY_SIZE (type);
7822 : :
7823 : 6614 : if (stride && !INTEGER_CST_P (stride))
7824 : : {
7825 : : /* Calculate size = stride * (ubound + 1 - lbound). */
7826 : 6613 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
7827 : : gfc_array_index_type,
7828 : : gfc_index_one_node, lbound);
7829 : 6613 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
7830 : : gfc_array_index_type,
7831 : : ubound, tmp);
7832 : 19839 : tmp = fold_build2_loc (input_location, MULT_EXPR,
7833 : : gfc_array_index_type,
7834 : 6613 : GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
7835 : 6613 : gfc_add_modify (&init, stride, tmp);
7836 : : }
7837 : : }
7838 : : }
7839 : :
7840 : 6614 : gfc_trans_array_cobounds (type, &init, sym);
7841 : :
7842 : : /* Set the offset. */
7843 : 6614 : if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
7844 : 6612 : gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
7845 : :
7846 : 6614 : gfc_trans_vla_type_sizes (sym, &init);
7847 : :
7848 : 6614 : stmtInit = gfc_finish_block (&init);
7849 : :
7850 : : /* Only do the entry/initialization code if the arg is present. */
7851 : 6614 : dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
7852 : 6614 : optional_arg = (sym->attr.optional
7853 : 6614 : || (sym->ns->proc_name->attr.entry_master
7854 : 79 : && sym->attr.dummy));
7855 : : if (optional_arg)
7856 : : {
7857 : 717 : tree zero_init = fold_convert (TREE_TYPE (tmpdesc), null_pointer_node);
7858 : 717 : zero_init = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
7859 : : tmpdesc, zero_init);
7860 : 717 : tmp = gfc_conv_expr_present (sym, true);
7861 : 717 : stmtInit = build3_v (COND_EXPR, tmp, stmtInit, zero_init);
7862 : : }
7863 : :
7864 : : /* Cleanup code. */
7865 : 6614 : if (no_repack)
7866 : : stmtCleanup = NULL_TREE;
7867 : : else
7868 : : {
7869 : 2 : stmtblock_t cleanup;
7870 : 2 : gfc_start_block (&cleanup);
7871 : :
7872 : 2 : if (sym->attr.intent != INTENT_IN)
7873 : : {
7874 : : /* Copy the data back. */
7875 : 2 : tmp = build_call_expr_loc (input_location,
7876 : : gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
7877 : 2 : gfc_add_expr_to_block (&cleanup, tmp);
7878 : : }
7879 : :
7880 : : /* Free the temporary. */
7881 : 2 : tmp = gfc_call_free (tmpdesc);
7882 : 2 : gfc_add_expr_to_block (&cleanup, tmp);
7883 : :
7884 : 2 : stmtCleanup = gfc_finish_block (&cleanup);
7885 : :
7886 : : /* Only do the cleanup if the array was repacked. */
7887 : 2 : if (is_classarray)
7888 : : /* For a class array the dummy array descriptor is in the _class
7889 : : component. */
7890 : 1 : tmp = gfc_class_data_get (dumdesc);
7891 : : else
7892 : 1 : tmp = build_fold_indirect_ref_loc (input_location, dumdesc);
7893 : 2 : tmp = gfc_conv_descriptor_data_get (tmp);
7894 : 2 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
7895 : : tmp, tmpdesc);
7896 : 2 : stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
7897 : : build_empty_stmt (input_location));
7898 : :
7899 : 2 : if (optional_arg)
7900 : : {
7901 : 0 : tmp = gfc_conv_expr_present (sym);
7902 : 0 : stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
7903 : : build_empty_stmt (input_location));
7904 : : }
7905 : : }
7906 : :
7907 : : /* We don't need to free any memory allocated by internal_pack as it will
7908 : : be freed at the end of the function by pop_context. */
7909 : 6614 : gfc_add_init_cleanup (block, stmtInit, stmtCleanup);
7910 : :
7911 : 6614 : input_location = loc;
7912 : : }
7913 : :
7914 : :
7915 : : /* Calculate the overall offset, including subreferences. */
7916 : : void
7917 : 58906 : gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
7918 : : bool subref, gfc_expr *expr)
7919 : : {
7920 : 58906 : tree tmp;
7921 : 58906 : tree field;
7922 : 58906 : tree stride;
7923 : 58906 : tree index;
7924 : 58906 : gfc_ref *ref;
7925 : 58906 : gfc_se start;
7926 : 58906 : int n;
7927 : :
7928 : : /* If offset is NULL and this is not a subreferenced array, there is
7929 : : nothing to do. */
7930 : 58906 : if (offset == NULL_TREE)
7931 : : {
7932 : 1054 : if (subref)
7933 : 139 : offset = gfc_index_zero_node;
7934 : : else
7935 : 915 : return;
7936 : : }
7937 : :
7938 : 57991 : tmp = build_array_ref (desc, offset, NULL, NULL);
7939 : :
7940 : : /* Offset the data pointer for pointer assignments from arrays with
7941 : : subreferences; e.g. my_integer => my_type(:)%integer_component. */
7942 : 57991 : if (subref)
7943 : : {
7944 : : /* Go past the array reference. */
7945 : 844 : for (ref = expr->ref; ref; ref = ref->next)
7946 : 844 : if (ref->type == REF_ARRAY &&
7947 : 757 : ref->u.ar.type != AR_ELEMENT)
7948 : : {
7949 : 733 : ref = ref->next;
7950 : 733 : break;
7951 : : }
7952 : :
7953 : : /* Calculate the offset for each subsequent subreference. */
7954 : 1438 : for (; ref; ref = ref->next)
7955 : : {
7956 : 705 : switch (ref->type)
7957 : : {
7958 : 301 : case REF_COMPONENT:
7959 : 301 : field = ref->u.c.component->backend_decl;
7960 : 301 : gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
7961 : 602 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
7962 : 301 : TREE_TYPE (field),
7963 : : tmp, field, NULL_TREE);
7964 : 301 : break;
7965 : :
7966 : 320 : case REF_SUBSTRING:
7967 : 320 : gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
7968 : 320 : gfc_init_se (&start, NULL);
7969 : 320 : gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
7970 : 320 : gfc_add_block_to_block (block, &start.pre);
7971 : 320 : tmp = gfc_build_array_ref (tmp, start.expr, NULL);
7972 : 320 : break;
7973 : :
7974 : 24 : case REF_ARRAY:
7975 : 24 : gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
7976 : : && ref->u.ar.type == AR_ELEMENT);
7977 : :
7978 : : /* TODO - Add bounds checking. */
7979 : 24 : stride = gfc_index_one_node;
7980 : 24 : index = gfc_index_zero_node;
7981 : 55 : for (n = 0; n < ref->u.ar.dimen; n++)
7982 : : {
7983 : 31 : tree itmp;
7984 : 31 : tree jtmp;
7985 : :
7986 : : /* Update the index. */
7987 : 31 : gfc_init_se (&start, NULL);
7988 : 31 : gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
7989 : 31 : itmp = gfc_evaluate_now (start.expr, block);
7990 : 31 : gfc_init_se (&start, NULL);
7991 : 31 : gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
7992 : 31 : jtmp = gfc_evaluate_now (start.expr, block);
7993 : 31 : itmp = fold_build2_loc (input_location, MINUS_EXPR,
7994 : : gfc_array_index_type, itmp, jtmp);
7995 : 31 : itmp = fold_build2_loc (input_location, MULT_EXPR,
7996 : : gfc_array_index_type, itmp, stride);
7997 : 31 : index = fold_build2_loc (input_location, PLUS_EXPR,
7998 : : gfc_array_index_type, itmp, index);
7999 : 31 : index = gfc_evaluate_now (index, block);
8000 : :
8001 : : /* Update the stride. */
8002 : 31 : gfc_init_se (&start, NULL);
8003 : 31 : gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
8004 : 31 : itmp = fold_build2_loc (input_location, MINUS_EXPR,
8005 : : gfc_array_index_type, start.expr,
8006 : : jtmp);
8007 : 31 : itmp = fold_build2_loc (input_location, PLUS_EXPR,
8008 : : gfc_array_index_type,
8009 : : gfc_index_one_node, itmp);
8010 : 31 : stride = fold_build2_loc (input_location, MULT_EXPR,
8011 : : gfc_array_index_type, stride, itmp);
8012 : 31 : stride = gfc_evaluate_now (stride, block);
8013 : : }
8014 : :
8015 : : /* Apply the index to obtain the array element. */
8016 : 24 : tmp = gfc_build_array_ref (tmp, index, NULL);
8017 : 24 : break;
8018 : :
8019 : 60 : case REF_INQUIRY:
8020 : 60 : switch (ref->u.i)
8021 : : {
8022 : 54 : case INQUIRY_RE:
8023 : 108 : tmp = fold_build1_loc (input_location, REALPART_EXPR,
8024 : 54 : TREE_TYPE (TREE_TYPE (tmp)), tmp);
8025 : 54 : break;
8026 : :
8027 : 6 : case INQUIRY_IM:
8028 : 12 : tmp = fold_build1_loc (input_location, IMAGPART_EXPR,
8029 : 6 : TREE_TYPE (TREE_TYPE (tmp)), tmp);
8030 : 6 : break;
8031 : :
8032 : : default:
8033 : : break;
8034 : : }
8035 : : break;
8036 : :
8037 : 0 : default:
8038 : 0 : gcc_unreachable ();
8039 : 705 : break;
8040 : : }
8041 : : }
8042 : : }
8043 : :
8044 : : /* Set the target data pointer. */
8045 : 57991 : offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
8046 : :
8047 : : /* Check for optional dummy argument being present. Arguments of BIND(C)
8048 : : procedures are excepted here since they are handled differently. */
8049 : 57991 : if (expr->expr_type == EXPR_VARIABLE
8050 : 51372 : && expr->symtree->n.sym->attr.dummy
8051 : 6095 : && expr->symtree->n.sym->attr.optional
8052 : 58983 : && !is_CFI_desc (NULL, expr))
8053 : 1624 : offset = build3_loc (input_location, COND_EXPR, TREE_TYPE (offset),
8054 : 812 : gfc_conv_expr_present (expr->symtree->n.sym), offset,
8055 : 812 : fold_convert (TREE_TYPE (offset), gfc_index_zero_node));
8056 : :
8057 : 57991 : gfc_conv_descriptor_data_set (block, parm, offset);
8058 : : }
8059 : :
8060 : :
8061 : : /* gfc_conv_expr_descriptor needs the string length an expression
8062 : : so that the size of the temporary can be obtained. This is done
8063 : : by adding up the string lengths of all the elements in the
8064 : : expression. Function with non-constant expressions have their
8065 : : string lengths mapped onto the actual arguments using the
8066 : : interface mapping machinery in trans-expr.cc. */
8067 : : static void
8068 : 1551 : get_array_charlen (gfc_expr *expr, gfc_se *se)
8069 : : {
8070 : 1551 : gfc_interface_mapping mapping;
8071 : 1551 : gfc_formal_arglist *formal;
8072 : 1551 : gfc_actual_arglist *arg;
8073 : 1551 : gfc_se tse;
8074 : 1551 : gfc_expr *e;
8075 : :
8076 : 1551 : if (expr->ts.u.cl->length
8077 : 1551 : && gfc_is_constant_expr (expr->ts.u.cl->length))
8078 : : {
8079 : 1207 : if (!expr->ts.u.cl->backend_decl)
8080 : 471 : gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
8081 : 1339 : return;
8082 : : }
8083 : :
8084 : 344 : switch (expr->expr_type)
8085 : : {
8086 : 130 : case EXPR_ARRAY:
8087 : :
8088 : : /* This is somewhat brutal. The expression for the first
8089 : : element of the array is evaluated and assigned to a
8090 : : new string length for the original expression. */
8091 : 130 : e = gfc_constructor_first (expr->value.constructor)->expr;
8092 : :
8093 : 130 : gfc_init_se (&tse, NULL);
8094 : :
8095 : : /* Avoid evaluating trailing array references since all we need is
8096 : : the string length. */
8097 : 130 : if (e->rank)
8098 : 38 : tse.descriptor_only = 1;
8099 : 130 : if (e->rank && e->expr_type != EXPR_VARIABLE)
8100 : 1 : gfc_conv_expr_descriptor (&tse, e);
8101 : : else
8102 : 129 : gfc_conv_expr (&tse, e);
8103 : :
8104 : 130 : gfc_add_block_to_block (&se->pre, &tse.pre);
8105 : 130 : gfc_add_block_to_block (&se->post, &tse.post);
8106 : :
8107 : 130 : if (!expr->ts.u.cl->backend_decl || !VAR_P (expr->ts.u.cl->backend_decl))
8108 : : {
8109 : 87 : expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
8110 : 87 : expr->ts.u.cl->backend_decl =
8111 : 87 : gfc_create_var (gfc_charlen_type_node, "sln");
8112 : : }
8113 : :
8114 : 130 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
8115 : : tse.string_length);
8116 : :
8117 : : /* Make sure that deferred length components point to the hidden
8118 : : string_length component. */
8119 : 130 : if (TREE_CODE (tse.expr) == COMPONENT_REF
8120 : 25 : && TREE_CODE (tse.string_length) == COMPONENT_REF
8121 : 149 : && TREE_OPERAND (tse.expr, 0) == TREE_OPERAND (tse.string_length, 0))
8122 : 19 : e->ts.u.cl->backend_decl = expr->ts.u.cl->backend_decl;
8123 : :
8124 : : return;
8125 : :
8126 : 90 : case EXPR_OP:
8127 : 90 : get_array_charlen (expr->value.op.op1, se);
8128 : :
8129 : : /* For parentheses the expression ts.u.cl should be identical. */
8130 : 90 : if (expr->value.op.op == INTRINSIC_PARENTHESES)
8131 : : {
8132 : 2 : if (expr->value.op.op1->ts.u.cl != expr->ts.u.cl)
8133 : 2 : expr->ts.u.cl->backend_decl
8134 : 2 : = expr->value.op.op1->ts.u.cl->backend_decl;
8135 : 2 : return;
8136 : : }
8137 : :
8138 : 176 : expr->ts.u.cl->backend_decl =
8139 : 88 : gfc_create_var (gfc_charlen_type_node, "sln");
8140 : :
8141 : 88 : if (expr->value.op.op2)
8142 : : {
8143 : 88 : get_array_charlen (expr->value.op.op2, se);
8144 : :
8145 : 88 : gcc_assert (expr->value.op.op == INTRINSIC_CONCAT);
8146 : :
8147 : : /* Add the string lengths and assign them to the expression
8148 : : string length backend declaration. */
8149 : 88 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
8150 : : fold_build2_loc (input_location, PLUS_EXPR,
8151 : : gfc_charlen_type_node,
8152 : 88 : expr->value.op.op1->ts.u.cl->backend_decl,
8153 : 88 : expr->value.op.op2->ts.u.cl->backend_decl));
8154 : : }
8155 : : else
8156 : 0 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
8157 : 0 : expr->value.op.op1->ts.u.cl->backend_decl);
8158 : : break;
8159 : :
8160 : 43 : case EXPR_FUNCTION:
8161 : 43 : if (expr->value.function.esym == NULL
8162 : 37 : || expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
8163 : : {
8164 : 6 : gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
8165 : 6 : break;
8166 : : }
8167 : :
8168 : : /* Map expressions involving the dummy arguments onto the actual
8169 : : argument expressions. */
8170 : 37 : gfc_init_interface_mapping (&mapping);
8171 : 37 : formal = gfc_sym_get_dummy_args (expr->symtree->n.sym);
8172 : 37 : arg = expr->value.function.actual;
8173 : :
8174 : : /* Set se = NULL in the calls to the interface mapping, to suppress any
8175 : : backend stuff. */
8176 : 113 : for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
8177 : : {
8178 : 38 : if (!arg->expr)
8179 : 0 : continue;
8180 : 38 : if (formal->sym)
8181 : 38 : gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
8182 : : }
8183 : :
8184 : 37 : gfc_init_se (&tse, NULL);
8185 : :
8186 : : /* Build the expression for the character length and convert it. */
8187 : 37 : gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length);
8188 : :
8189 : 37 : gfc_add_block_to_block (&se->pre, &tse.pre);
8190 : 37 : gfc_add_block_to_block (&se->post, &tse.post);
8191 : 37 : tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
8192 : 74 : tse.expr = fold_build2_loc (input_location, MAX_EXPR,
8193 : 37 : TREE_TYPE (tse.expr), tse.expr,
8194 : 37 : build_zero_cst (TREE_TYPE (tse.expr)));
8195 : 37 : expr->ts.u.cl->backend_decl = tse.expr;
8196 : 37 : gfc_free_interface_mapping (&mapping);
8197 : 37 : break;
8198 : :
8199 : 81 : default:
8200 : 81 : gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
8201 : 81 : break;
8202 : : }
8203 : : }
8204 : :
8205 : :
8206 : : /* Helper function to check dimensions. */
8207 : : static bool
8208 : 144 : transposed_dims (gfc_ss *ss)
8209 : : {
8210 : 144 : int n;
8211 : :
8212 : 170250 : for (n = 0; n < ss->dimen; n++)
8213 : 87557 : if (ss->dim[n] != n)
8214 : : return true;
8215 : : return false;
8216 : : }
8217 : :
8218 : :
8219 : : /* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
8220 : : AR_FULL, suitable for the scalarizer. */
8221 : :
8222 : : static gfc_ss *
8223 : 1170 : walk_coarray (gfc_expr *e)
8224 : : {
8225 : 1170 : gfc_ss *ss;
8226 : :
8227 : 1170 : ss = gfc_walk_expr (e);
8228 : :
8229 : : /* Fix scalar coarray. */
8230 : 1170 : if (ss == gfc_ss_terminator)
8231 : : {
8232 : 251 : gfc_ref *ref;
8233 : :
8234 : 251 : ref = e->ref;
8235 : 368 : while (ref)
8236 : : {
8237 : 368 : if (ref->type == REF_ARRAY
8238 : 251 : && ref->u.ar.codimen > 0)
8239 : : break;
8240 : :
8241 : 117 : ref = ref->next;
8242 : : }
8243 : :
8244 : 251 : gcc_assert (ref != NULL);
8245 : 251 : if (ref->u.ar.type == AR_ELEMENT)
8246 : 237 : ref->u.ar.type = AR_SECTION;
8247 : 251 : ss = gfc_reverse_ss (gfc_walk_array_ref (ss, e, ref, false));
8248 : : }
8249 : :
8250 : 1170 : return ss;
8251 : : }
8252 : :
8253 : : gfc_array_spec *
8254 : 1774 : get_coarray_as (const gfc_expr *e)
8255 : : {
8256 : 1774 : gfc_array_spec *as;
8257 : 1774 : gfc_symbol *sym = e->symtree->n.sym;
8258 : 1774 : gfc_component *comp;
8259 : :
8260 : 1774 : if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.codimension)
8261 : 544 : as = CLASS_DATA (sym)->as;
8262 : 1230 : else if (sym->attr.codimension)
8263 : 1184 : as = sym->as;
8264 : : else
8265 : : as = nullptr;
8266 : :
8267 : 4192 : for (gfc_ref *ref = e->ref; ref; ref = ref->next)
8268 : : {
8269 : 2418 : switch (ref->type)
8270 : : {
8271 : 644 : case REF_COMPONENT:
8272 : 644 : comp = ref->u.c.component;
8273 : 644 : if (comp->ts.type == BT_CLASS && CLASS_DATA (comp)->attr.codimension)
8274 : 18 : as = CLASS_DATA (comp)->as;
8275 : 626 : else if (comp->ts.type != BT_CLASS && comp->attr.codimension)
8276 : 590 : as = comp->as;
8277 : : break;
8278 : :
8279 : : case REF_ARRAY:
8280 : : case REF_SUBSTRING:
8281 : : case REF_INQUIRY:
8282 : : break;
8283 : : }
8284 : : }
8285 : :
8286 : 1774 : return as;
8287 : : }
8288 : :
8289 : : bool
8290 : 138399 : is_explicit_coarray (gfc_expr *expr)
8291 : : {
8292 : 138399 : if (!gfc_is_coarray (expr))
8293 : : return false;
8294 : :
8295 : 1774 : gfc_array_spec *cas = get_coarray_as (expr);
8296 : 1774 : return cas && cas->cotype == AS_EXPLICIT;
8297 : : }
8298 : :
8299 : : /* Convert an array for passing as an actual argument. Expressions and
8300 : : vector subscripts are evaluated and stored in a temporary, which is then
8301 : : passed. For whole arrays the descriptor is passed. For array sections
8302 : : a modified copy of the descriptor is passed, but using the original data.
8303 : :
8304 : : This function is also used for array pointer assignments, and there
8305 : : are three cases:
8306 : :
8307 : : - se->want_pointer && !se->direct_byref
8308 : : EXPR is an actual argument. On exit, se->expr contains a
8309 : : pointer to the array descriptor.
8310 : :
8311 : : - !se->want_pointer && !se->direct_byref
8312 : : EXPR is an actual argument to an intrinsic function or the
8313 : : left-hand side of a pointer assignment. On exit, se->expr
8314 : : contains the descriptor for EXPR.
8315 : :
8316 : : - !se->want_pointer && se->direct_byref
8317 : : EXPR is the right-hand side of a pointer assignment and
8318 : : se->expr is the descriptor for the previously-evaluated
8319 : : left-hand side. The function creates an assignment from
8320 : : EXPR to se->expr.
8321 : :
8322 : :
8323 : : The se->force_tmp flag disables the non-copying descriptor optimization
8324 : : that is used for transpose. It may be used in cases where there is an
8325 : : alias between the transpose argument and another argument in the same
8326 : : function call. */
8327 : :
8328 : : void
8329 : 154358 : gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
8330 : : {
8331 : 154358 : gfc_ss *ss;
8332 : 154358 : gfc_ss_type ss_type;
8333 : 154358 : gfc_ss_info *ss_info;
8334 : 154358 : gfc_loopinfo loop;
8335 : 154358 : gfc_array_info *info;
8336 : 154358 : int need_tmp;
8337 : 154358 : int n;
8338 : 154358 : tree tmp;
8339 : 154358 : tree desc;
8340 : 154358 : stmtblock_t block;
8341 : 154358 : tree start;
8342 : 154358 : int full;
8343 : 154358 : bool subref_array_target = false;
8344 : 154358 : bool deferred_array_component = false;
8345 : 154358 : bool substr = false;
8346 : 154358 : gfc_expr *arg, *ss_expr;
8347 : :
8348 : 154358 : if (se->want_coarray || expr->rank == 0)
8349 : 1170 : ss = walk_coarray (expr);
8350 : : else
8351 : 153188 : ss = gfc_walk_expr (expr);
8352 : :
8353 : 154358 : gcc_assert (ss != NULL);
8354 : 154358 : gcc_assert (ss != gfc_ss_terminator);
8355 : :
8356 : 154358 : ss_info = ss->info;
8357 : 154358 : ss_type = ss_info->type;
8358 : 154358 : ss_expr = ss_info->expr;
8359 : :
8360 : : /* Special case: TRANSPOSE which needs no temporary. */
8361 : 159587 : while (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym
8362 : 159318 : && (arg = gfc_get_noncopying_intrinsic_argument (expr)) != NULL)
8363 : : {
8364 : : /* This is a call to transpose which has already been handled by the
8365 : : scalarizer, so that we just need to get its argument's descriptor. */
8366 : 408 : gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
8367 : 408 : expr = expr->value.function.actual->expr;
8368 : : }
8369 : :
8370 : 154358 : if (!se->direct_byref)
8371 : 296608 : se->unlimited_polymorphic = UNLIMITED_POLY (expr);
8372 : :
8373 : : /* Special case things we know we can pass easily. */
8374 : 154358 : switch (expr->expr_type)
8375 : : {
8376 : 138624 : case EXPR_VARIABLE:
8377 : : /* If we have a linear array section, we can pass it directly.
8378 : : Otherwise we need to copy it into a temporary. */
8379 : :
8380 : 138624 : gcc_assert (ss_type == GFC_SS_SECTION);
8381 : 138624 : gcc_assert (ss_expr == expr);
8382 : 138624 : info = &ss_info->data.array;
8383 : :
8384 : : /* Get the descriptor for the array. */
8385 : 138624 : gfc_conv_ss_descriptor (&se->pre, ss, 0);
8386 : 138624 : desc = info->descriptor;
8387 : :
8388 : : /* The charlen backend decl for deferred character components cannot
8389 : : be used because it is fixed at zero. Instead, the hidden string
8390 : : length component is used. */
8391 : 138624 : if (expr->ts.type == BT_CHARACTER
8392 : 20059 : && expr->ts.deferred
8393 : 2812 : && TREE_CODE (desc) == COMPONENT_REF)
8394 : 138624 : deferred_array_component = true;
8395 : :
8396 : 138624 : substr = info->ref && info->ref->next
8397 : 139439 : && info->ref->next->type == REF_SUBSTRING;
8398 : :
8399 : 138624 : subref_array_target = (is_subref_array (expr)
8400 : 138624 : && (se->direct_byref
8401 : 2583 : || expr->ts.type == BT_CHARACTER));
8402 : 138624 : need_tmp = (gfc_ref_needs_temporary_p (expr->ref)
8403 : 138624 : && !subref_array_target);
8404 : :
8405 : 138624 : if (se->force_tmp)
8406 : : need_tmp = 1;
8407 : 138495 : else if (se->force_no_tmp)
8408 : : need_tmp = 0;
8409 : :
8410 : 132352 : if (need_tmp)
8411 : : full = 0;
8412 : 138399 : else if (is_explicit_coarray (expr))
8413 : : full = 0;
8414 : 137763 : else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
8415 : : {
8416 : : /* Create a new descriptor if the array doesn't have one. */
8417 : : full = 0;
8418 : : }
8419 : 88754 : else if (info->ref->u.ar.type == AR_FULL || se->descriptor_only)
8420 : : full = 1;
8421 : 7884 : else if (se->direct_byref)
8422 : : full = 0;
8423 : 7528 : else if (info->ref->u.ar.dimen == 0 && !info->ref->next)
8424 : : full = 1;
8425 : 7422 : else if (info->ref->u.ar.type == AR_SECTION && se->want_pointer)
8426 : : full = 0;
8427 : : else
8428 : 3551 : full = gfc_full_array_ref_p (info->ref, NULL);
8429 : :
8430 : 165743 : if (full && !transposed_dims (ss))
8431 : : {
8432 : 81159 : if (se->direct_byref && !se->byref_noassign)
8433 : : {
8434 : 1042 : struct lang_type *lhs_ls
8435 : 1042 : = TYPE_LANG_SPECIFIC (TREE_TYPE (se->expr)),
8436 : 1042 : *rhs_ls = TYPE_LANG_SPECIFIC (TREE_TYPE (desc));
8437 : : /* When only the array_kind differs, do a view_convert. */
8438 : 1430 : tmp = lhs_ls && rhs_ls && lhs_ls->rank == rhs_ls->rank
8439 : 1042 : && lhs_ls->akind != rhs_ls->akind
8440 : 1430 : ? build1 (VIEW_CONVERT_EXPR, TREE_TYPE (se->expr), desc)
8441 : : : desc;
8442 : : /* Copy the descriptor for pointer assignments. */
8443 : 1042 : gfc_add_modify (&se->pre, se->expr, tmp);
8444 : :
8445 : : /* Add any offsets from subreferences. */
8446 : 1042 : gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
8447 : : subref_array_target, expr);
8448 : :
8449 : : /* ....and set the span field. */
8450 : 1042 : if (ss_info->expr->ts.type == BT_CHARACTER)
8451 : 141 : tmp = gfc_conv_descriptor_span_get (desc);
8452 : : else
8453 : 901 : tmp = gfc_get_array_span (desc, expr);
8454 : 1042 : gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp);
8455 : 1042 : }
8456 : 80117 : else if (se->want_pointer)
8457 : : {
8458 : : /* We pass full arrays directly. This means that pointers and
8459 : : allocatable arrays should also work. */
8460 : 13580 : se->expr = gfc_build_addr_expr (NULL_TREE, desc);
8461 : : }
8462 : : else
8463 : : {
8464 : 66537 : se->expr = desc;
8465 : : }
8466 : :
8467 : 81159 : if (expr->ts.type == BT_CHARACTER && !deferred_array_component)
8468 : 8327 : se->string_length = gfc_get_expr_charlen (expr);
8469 : : /* The ss_info string length is returned set to the value of the
8470 : : hidden string length component. */
8471 : 72569 : else if (deferred_array_component)
8472 : 263 : se->string_length = ss_info->string_length;
8473 : :
8474 : 81159 : se->class_container = ss_info->class_container;
8475 : :
8476 : 81159 : gfc_free_ss_chain (ss);
8477 : 162444 : return;
8478 : : }
8479 : : break;
8480 : :
8481 : 4821 : case EXPR_FUNCTION:
8482 : : /* A transformational function return value will be a temporary
8483 : : array descriptor. We still need to go through the scalarizer
8484 : : to create the descriptor. Elemental functions are handled as
8485 : : arbitrary expressions, i.e. copy to a temporary. */
8486 : :
8487 : 4821 : if (se->direct_byref)
8488 : : {
8489 : 126 : gcc_assert (ss_type == GFC_SS_FUNCTION && ss_expr == expr);
8490 : :
8491 : : /* For pointer assignments pass the descriptor directly. */
8492 : 126 : if (se->ss == NULL)
8493 : 126 : se->ss = ss;
8494 : : else
8495 : 0 : gcc_assert (se->ss == ss);
8496 : :
8497 : 126 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
8498 : 126 : gfc_conv_expr (se, expr);
8499 : :
8500 : 126 : gfc_free_ss_chain (ss);
8501 : 126 : return;
8502 : : }
8503 : :
8504 : 4695 : if (ss_expr != expr || ss_type != GFC_SS_FUNCTION)
8505 : : {
8506 : 3286 : if (ss_expr != expr)
8507 : : /* Elemental function. */
8508 : 2561 : gcc_assert ((expr->value.function.esym != NULL
8509 : : && expr->value.function.esym->attr.elemental)
8510 : : || (expr->value.function.isym != NULL
8511 : : && expr->value.function.isym->elemental)
8512 : : || (gfc_expr_attr (expr).proc_pointer
8513 : : && gfc_expr_attr (expr).elemental)
8514 : : || gfc_inline_intrinsic_function_p (expr));
8515 : :
8516 : 3286 : need_tmp = 1;
8517 : 3286 : if (expr->ts.type == BT_CHARACTER
8518 : 35 : && expr->ts.u.cl->length
8519 : 29 : && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
8520 : 13 : get_array_charlen (expr, se);
8521 : :
8522 : : info = NULL;
8523 : : }
8524 : : else
8525 : : {
8526 : : /* Transformational function. */
8527 : 1409 : info = &ss_info->data.array;
8528 : 1409 : need_tmp = 0;
8529 : : }
8530 : : break;
8531 : :
8532 : 10206 : case EXPR_ARRAY:
8533 : : /* Constant array constructors don't need a temporary. */
8534 : 10206 : if (ss_type == GFC_SS_CONSTRUCTOR
8535 : 10206 : && expr->ts.type != BT_CHARACTER
8536 : 19183 : && gfc_constant_array_constructor_p (expr->value.constructor))
8537 : : {
8538 : 6606 : need_tmp = 0;
8539 : 6606 : info = &ss_info->data.array;
8540 : : }
8541 : : else
8542 : : {
8543 : : need_tmp = 1;
8544 : : info = NULL;
8545 : : }
8546 : : break;
8547 : :
8548 : : default:
8549 : : /* Something complicated. Copy it into a temporary. */
8550 : : need_tmp = 1;
8551 : : info = NULL;
8552 : : break;
8553 : : }
8554 : :
8555 : : /* If we are creating a temporary, we don't need to bother about aliases
8556 : : anymore. */
8557 : 65480 : if (need_tmp)
8558 : 7818 : se->force_tmp = 0;
8559 : :
8560 : 73073 : gfc_init_loopinfo (&loop);
8561 : :
8562 : : /* Associate the SS with the loop. */
8563 : 73073 : gfc_add_ss_to_loop (&loop, ss);
8564 : :
8565 : : /* Tell the scalarizer not to bother creating loop variables, etc. */
8566 : 73073 : if (!need_tmp)
8567 : 65255 : loop.array_parameter = 1;
8568 : : else
8569 : : /* The right-hand side of a pointer assignment mustn't use a temporary. */
8570 : 7818 : gcc_assert (!se->direct_byref);
8571 : :
8572 : : /* Do we need bounds checking or not? */
8573 : 73073 : ss->no_bounds_check = expr->no_bounds_check;
8574 : :
8575 : : /* Setup the scalarizing loops and bounds. */
8576 : 73073 : gfc_conv_ss_startstride (&loop);
8577 : :
8578 : : /* Add bounds-checking for elemental dimensions. */
8579 : 73073 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !expr->no_bounds_check)
8580 : 6667 : array_bound_check_elemental (se, ss, expr);
8581 : :
8582 : 73073 : if (need_tmp)
8583 : : {
8584 : 7818 : if (expr->ts.type == BT_CHARACTER
8585 : 1459 : && (!expr->ts.u.cl->backend_decl || expr->expr_type == EXPR_ARRAY))
8586 : 1360 : get_array_charlen (expr, se);
8587 : :
8588 : : /* Tell the scalarizer to make a temporary. */
8589 : 7818 : loop.temp_ss = gfc_get_temp_ss (gfc_typenode_for_spec (&expr->ts),
8590 : 7818 : ((expr->ts.type == BT_CHARACTER)
8591 : 1459 : ? expr->ts.u.cl->backend_decl
8592 : : : NULL),
8593 : : loop.dimen);
8594 : :
8595 : 7818 : se->string_length = loop.temp_ss->info->string_length;
8596 : 7818 : gcc_assert (loop.temp_ss->dimen == loop.dimen);
8597 : 7818 : gfc_add_ss_to_loop (&loop, loop.temp_ss);
8598 : : }
8599 : :
8600 : 73073 : gfc_conv_loop_setup (&loop, & expr->where);
8601 : :
8602 : 73073 : if (need_tmp)
8603 : : {
8604 : : /* Copy into a temporary and pass that. We don't need to copy the data
8605 : : back because expressions and vector subscripts must be INTENT_IN. */
8606 : : /* TODO: Optimize passing function return values. */
8607 : 7818 : gfc_se lse;
8608 : 7818 : gfc_se rse;
8609 : 7818 : bool deep_copy;
8610 : :
8611 : : /* Start the copying loops. */
8612 : 7818 : gfc_mark_ss_chain_used (loop.temp_ss, 1);
8613 : 7818 : gfc_mark_ss_chain_used (ss, 1);
8614 : 7818 : gfc_start_scalarized_body (&loop, &block);
8615 : :
8616 : : /* Copy each data element. */
8617 : 7818 : gfc_init_se (&lse, NULL);
8618 : 7818 : gfc_copy_loopinfo_to_se (&lse, &loop);
8619 : 7818 : gfc_init_se (&rse, NULL);
8620 : 7818 : gfc_copy_loopinfo_to_se (&rse, &loop);
8621 : :
8622 : 7818 : lse.ss = loop.temp_ss;
8623 : 7818 : rse.ss = ss;
8624 : :
8625 : 7818 : gfc_conv_tmp_array_ref (&lse);
8626 : 7818 : if (expr->ts.type == BT_CHARACTER)
8627 : : {
8628 : 1459 : gfc_conv_expr (&rse, expr);
8629 : 1459 : if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
8630 : 1141 : rse.expr = build_fold_indirect_ref_loc (input_location,
8631 : : rse.expr);
8632 : : }
8633 : : else
8634 : 6359 : gfc_conv_expr_val (&rse, expr);
8635 : :
8636 : 7818 : gfc_add_block_to_block (&block, &rse.pre);
8637 : 7818 : gfc_add_block_to_block (&block, &lse.pre);
8638 : :
8639 : 7818 : lse.string_length = rse.string_length;
8640 : :
8641 : 15636 : deep_copy = !se->data_not_needed
8642 : 7818 : && (expr->expr_type == EXPR_VARIABLE
8643 : 7340 : || expr->expr_type == EXPR_ARRAY);
8644 : 7818 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts,
8645 : : deep_copy, false);
8646 : 7818 : gfc_add_expr_to_block (&block, tmp);
8647 : :
8648 : : /* Finish the copying loops. */
8649 : 7818 : gfc_trans_scalarizing_loops (&loop, &block);
8650 : :
8651 : 7818 : desc = loop.temp_ss->info->data.array.descriptor;
8652 : : }
8653 : 66664 : else if (expr->expr_type == EXPR_FUNCTION && !transposed_dims (ss))
8654 : : {
8655 : 1396 : desc = info->descriptor;
8656 : 1396 : se->string_length = ss_info->string_length;
8657 : : }
8658 : : else
8659 : : {
8660 : : /* We pass sections without copying to a temporary. Make a new
8661 : : descriptor and point it at the section we want. The loop variable
8662 : : limits will be the limits of the section.
8663 : : A function may decide to repack the array to speed up access, but
8664 : : we're not bothered about that here. */
8665 : 63859 : int dim, ndim, codim;
8666 : 63859 : tree parm;
8667 : 63859 : tree parmtype;
8668 : 63859 : tree dtype;
8669 : 63859 : tree stride;
8670 : 63859 : tree from;
8671 : 63859 : tree to;
8672 : 63859 : tree base;
8673 : 63859 : tree offset;
8674 : :
8675 : 63859 : ndim = info->ref ? info->ref->u.ar.dimen : ss->dimen;
8676 : :
8677 : 63859 : if (se->want_coarray)
8678 : : {
8679 : 529 : gfc_array_ref *ar = &info->ref->u.ar;
8680 : :
8681 : 529 : codim = expr->corank;
8682 : 1083 : for (n = 0; n < codim - 1; n++)
8683 : : {
8684 : : /* Make sure we are not lost somehow. */
8685 : 554 : gcc_assert (ar->dimen_type[n + ndim] == DIMEN_THIS_IMAGE);
8686 : :
8687 : : /* Make sure the call to gfc_conv_section_startstride won't
8688 : : generate unnecessary code to calculate stride. */
8689 : 554 : gcc_assert (ar->stride[n + ndim] == NULL);
8690 : :
8691 : 554 : gfc_conv_section_startstride (&loop.pre, ss, n + ndim);
8692 : 554 : loop.from[n + loop.dimen] = info->start[n + ndim];
8693 : 554 : loop.to[n + loop.dimen] = info->end[n + ndim];
8694 : : }
8695 : :
8696 : 529 : gcc_assert (n == codim - 1);
8697 : 529 : evaluate_bound (&loop.pre, info->start, ar->start,
8698 : : info->descriptor, n + ndim, true,
8699 : 529 : ar->as->type == AS_DEFERRED, true);
8700 : 529 : loop.from[n + loop.dimen] = info->start[n + ndim];
8701 : : }
8702 : : else
8703 : : codim = 0;
8704 : :
8705 : : /* Set the string_length for a character array. */
8706 : 63859 : if (expr->ts.type == BT_CHARACTER)
8707 : : {
8708 : 11433 : if (deferred_array_component && !substr)
8709 : 37 : se->string_length = ss_info->string_length;
8710 : : else
8711 : 11396 : se->string_length = gfc_get_expr_charlen (expr);
8712 : :
8713 : 11433 : if (VAR_P (se->string_length)
8714 : 990 : && expr->ts.u.cl->backend_decl == se->string_length)
8715 : 984 : tmp = ss_info->string_length;
8716 : : else
8717 : : tmp = se->string_length;
8718 : :
8719 : 11433 : if (expr->ts.deferred && expr->ts.u.cl->backend_decl
8720 : 217 : && VAR_P (expr->ts.u.cl->backend_decl))
8721 : 156 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, tmp);
8722 : : else
8723 : 11277 : expr->ts.u.cl->backend_decl = tmp;
8724 : : }
8725 : :
8726 : : /* If we have an array section, are assigning or passing an array
8727 : : section argument make sure that the lower bound is 1. References
8728 : : to the full array should otherwise keep the original bounds. */
8729 : 63859 : if (!info->ref || info->ref->u.ar.type != AR_FULL)
8730 : 81995 : for (dim = 0; dim < loop.dimen; dim++)
8731 : 50016 : if (!integer_onep (loop.from[dim]))
8732 : : {
8733 : 26691 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
8734 : : gfc_array_index_type, gfc_index_one_node,
8735 : : loop.from[dim]);
8736 : 26691 : loop.to[dim] = fold_build2_loc (input_location, PLUS_EXPR,
8737 : : gfc_array_index_type,
8738 : : loop.to[dim], tmp);
8739 : 26691 : loop.from[dim] = gfc_index_one_node;
8740 : : }
8741 : :
8742 : 63859 : desc = info->descriptor;
8743 : 63859 : if (se->direct_byref && !se->byref_noassign)
8744 : : {
8745 : : /* For pointer assignments we fill in the destination. */
8746 : 2643 : parm = se->expr;
8747 : 2643 : parmtype = TREE_TYPE (parm);
8748 : : }
8749 : : else
8750 : : {
8751 : : /* Otherwise make a new one. */
8752 : 61216 : if (expr->ts.type == BT_CHARACTER)
8753 : 10781 : parmtype = gfc_typenode_for_spec (&expr->ts);
8754 : : else
8755 : 50435 : parmtype = gfc_get_element_type (TREE_TYPE (desc));
8756 : :
8757 : 61216 : parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, codim,
8758 : : loop.from, loop.to, 0,
8759 : : GFC_ARRAY_UNKNOWN, false);
8760 : 61216 : parm = gfc_create_var (parmtype, "parm");
8761 : :
8762 : : /* When expression is a class object, then add the class' handle to
8763 : : the parm_decl. */
8764 : 61216 : if (expr->ts.type == BT_CLASS && expr->expr_type == EXPR_VARIABLE)
8765 : : {
8766 : 1134 : gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr);
8767 : 1134 : gfc_se classse;
8768 : :
8769 : : /* class_expr can be NULL, when no _class ref is in expr.
8770 : : We must not fix this here with a gfc_fix_class_ref (). */
8771 : 1134 : if (class_expr)
8772 : : {
8773 : 1124 : gfc_init_se (&classse, NULL);
8774 : 1124 : gfc_conv_expr (&classse, class_expr);
8775 : 1124 : gfc_free_expr (class_expr);
8776 : :
8777 : 1124 : gcc_assert (classse.pre.head == NULL_TREE
8778 : : && classse.post.head == NULL_TREE);
8779 : 1124 : gfc_allocate_lang_decl (parm);
8780 : 1124 : GFC_DECL_SAVED_DESCRIPTOR (parm) = classse.expr;
8781 : : }
8782 : : }
8783 : : }
8784 : :
8785 : 63859 : if (expr->ts.type == BT_CHARACTER
8786 : 63859 : && VAR_P (TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (parm)))))
8787 : : {
8788 : 0 : tree elem_len = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (parm)));
8789 : 0 : gfc_add_modify (&loop.pre, elem_len,
8790 : 0 : fold_convert (TREE_TYPE (elem_len),
8791 : : gfc_get_array_span (desc, expr)));
8792 : : }
8793 : :
8794 : : /* Set the span field. */
8795 : 63859 : tmp = NULL_TREE;
8796 : 63859 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
8797 : 7624 : tmp = gfc_conv_descriptor_span_get (desc);
8798 : : else
8799 : 56235 : tmp = gfc_get_array_span (desc, expr);
8800 : 63859 : if (tmp)
8801 : 63779 : gfc_conv_descriptor_span_set (&loop.pre, parm, tmp);
8802 : :
8803 : : /* The following can be somewhat confusing. We have two
8804 : : descriptors, a new one and the original array.
8805 : : {parm, parmtype, dim} refer to the new one.
8806 : : {desc, type, n, loop} refer to the original, which maybe
8807 : : a descriptorless array.
8808 : : The bounds of the scalarization are the bounds of the section.
8809 : : We don't have to worry about numeric overflows when calculating
8810 : : the offsets because all elements are within the array data. */
8811 : :
8812 : : /* Set the dtype. */
8813 : 63859 : tmp = gfc_conv_descriptor_dtype (parm);
8814 : 63859 : if (se->unlimited_polymorphic)
8815 : 589 : dtype = gfc_get_dtype (TREE_TYPE (desc), &loop.dimen);
8816 : 63270 : else if (expr->ts.type == BT_ASSUMED)
8817 : : {
8818 : 127 : tree tmp2 = desc;
8819 : 127 : if (DECL_LANG_SPECIFIC (tmp2) && GFC_DECL_SAVED_DESCRIPTOR (tmp2))
8820 : 127 : tmp2 = GFC_DECL_SAVED_DESCRIPTOR (tmp2);
8821 : 127 : if (POINTER_TYPE_P (TREE_TYPE (tmp2)))
8822 : 127 : tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
8823 : 127 : dtype = gfc_conv_descriptor_dtype (tmp2);
8824 : : }
8825 : : else
8826 : 63143 : dtype = gfc_get_dtype (parmtype);
8827 : 63859 : gfc_add_modify (&loop.pre, tmp, dtype);
8828 : :
8829 : : /* The 1st element in the section. */
8830 : 63859 : base = gfc_index_zero_node;
8831 : 63859 : if (expr->ts.type == BT_CHARACTER && expr->rank == 0 && codim)
8832 : 6 : base = gfc_index_one_node;
8833 : :
8834 : : /* The offset from the 1st element in the section. */
8835 : : offset = gfc_index_zero_node;
8836 : :
8837 : 164975 : for (n = 0; n < ndim; n++)
8838 : : {
8839 : 101116 : stride = gfc_conv_array_stride (desc, n);
8840 : :
8841 : : /* Work out the 1st element in the section. */
8842 : 101116 : if (info->ref
8843 : 94184 : && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
8844 : : {
8845 : 1191 : gcc_assert (info->subscript[n]
8846 : : && info->subscript[n]->info->type == GFC_SS_SCALAR);
8847 : 1191 : start = info->subscript[n]->info->data.scalar.value;
8848 : : }
8849 : : else
8850 : : {
8851 : : /* Evaluate and remember the start of the section. */
8852 : 99925 : start = info->start[n];
8853 : 99925 : stride = gfc_evaluate_now (stride, &loop.pre);
8854 : : }
8855 : :
8856 : 101116 : tmp = gfc_conv_array_lbound (desc, n);
8857 : 101116 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
8858 : : start, tmp);
8859 : 101116 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
8860 : : tmp, stride);
8861 : 101116 : base = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
8862 : : base, tmp);
8863 : :
8864 : 101116 : if (info->ref
8865 : 94184 : && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
8866 : : {
8867 : : /* For elemental dimensions, we only need the 1st
8868 : : element in the section. */
8869 : 1191 : continue;
8870 : : }
8871 : :
8872 : : /* Vector subscripts need copying and are handled elsewhere. */
8873 : 99925 : if (info->ref)
8874 : 92993 : gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
8875 : :
8876 : : /* look for the corresponding scalarizer dimension: dim. */
8877 : 151063 : for (dim = 0; dim < ndim; dim++)
8878 : 151063 : if (ss->dim[dim] == n)
8879 : : break;
8880 : :
8881 : : /* loop exited early: the DIM being looked for has been found. */
8882 : 99925 : gcc_assert (dim < ndim);
8883 : :
8884 : : /* Set the new lower bound. */
8885 : 99925 : from = loop.from[dim];
8886 : 99925 : to = loop.to[dim];
8887 : :
8888 : 99925 : gfc_conv_descriptor_lbound_set (&loop.pre, parm,
8889 : : gfc_rank_cst[dim], from);
8890 : :
8891 : : /* Set the new upper bound. */
8892 : 99925 : gfc_conv_descriptor_ubound_set (&loop.pre, parm,
8893 : : gfc_rank_cst[dim], to);
8894 : :
8895 : : /* Multiply the stride by the section stride to get the
8896 : : total stride. */
8897 : 99925 : stride = fold_build2_loc (input_location, MULT_EXPR,
8898 : : gfc_array_index_type,
8899 : : stride, info->stride[n]);
8900 : :
8901 : 99925 : tmp = fold_build2_loc (input_location, MULT_EXPR,
8902 : 99925 : TREE_TYPE (offset), stride, from);
8903 : 99925 : offset = fold_build2_loc (input_location, MINUS_EXPR,
8904 : 99925 : TREE_TYPE (offset), offset, tmp);
8905 : :
8906 : : /* Store the new stride. */
8907 : 99925 : gfc_conv_descriptor_stride_set (&loop.pre, parm,
8908 : : gfc_rank_cst[dim], stride);
8909 : : }
8910 : :
8911 : : /* For deferred-length character we need to take the dynamic length
8912 : : into account for the dataptr offset. */
8913 : 63859 : if (expr->ts.type == BT_CHARACTER
8914 : 11433 : && expr->ts.deferred
8915 : 223 : && expr->ts.u.cl->backend_decl
8916 : 223 : && VAR_P (expr->ts.u.cl->backend_decl))
8917 : : {
8918 : 156 : tree base_type = TREE_TYPE (base);
8919 : 156 : base = fold_build2_loc (input_location, MULT_EXPR, base_type, base,
8920 : : fold_convert (base_type,
8921 : : expr->ts.u.cl->backend_decl));
8922 : : }
8923 : :
8924 : 64942 : for (n = loop.dimen; n < loop.dimen + codim; n++)
8925 : : {
8926 : 1083 : from = loop.from[n];
8927 : 1083 : to = loop.to[n];
8928 : 1083 : gfc_conv_descriptor_lbound_set (&loop.pre, parm,
8929 : : gfc_rank_cst[n], from);
8930 : 1083 : if (n < loop.dimen + codim - 1)
8931 : 554 : gfc_conv_descriptor_ubound_set (&loop.pre, parm,
8932 : : gfc_rank_cst[n], to);
8933 : : }
8934 : :
8935 : 63859 : if (se->data_not_needed)
8936 : 6007 : gfc_conv_descriptor_data_set (&loop.pre, parm,
8937 : : gfc_index_zero_node);
8938 : : else
8939 : : /* Point the data pointer at the 1st element in the section. */
8940 : 57852 : gfc_get_dataptr_offset (&loop.pre, parm, desc, base,
8941 : : subref_array_target, expr);
8942 : :
8943 : 63859 : gfc_conv_descriptor_offset_set (&loop.pre, parm, offset);
8944 : :
8945 : 63859 : if (flag_coarray == GFC_FCOARRAY_LIB && expr->corank)
8946 : : {
8947 : 215 : tmp = INDIRECT_REF_P (desc) ? TREE_OPERAND (desc, 0) : desc;
8948 : 215 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
8949 : : {
8950 : 12 : tmp = gfc_conv_descriptor_token (tmp);
8951 : : }
8952 : 203 : else if (DECL_P (tmp) && DECL_LANG_SPECIFIC (tmp)
8953 : 245 : && GFC_DECL_TOKEN (tmp) != NULL_TREE)
8954 : 34 : tmp = GFC_DECL_TOKEN (tmp);
8955 : : else
8956 : : {
8957 : 169 : tmp = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (tmp));
8958 : : }
8959 : :
8960 : 215 : gfc_add_modify (&loop.pre, gfc_conv_descriptor_token (parm), tmp);
8961 : : }
8962 : : desc = parm;
8963 : : }
8964 : :
8965 : : /* For class arrays add the class tree into the saved descriptor to
8966 : : enable getting of _vptr and the like. */
8967 : 73073 : if (expr->expr_type == EXPR_VARIABLE && VAR_P (desc)
8968 : 56561 : && IS_CLASS_ARRAY (expr->symtree->n.sym))
8969 : : {
8970 : 1109 : gfc_allocate_lang_decl (desc);
8971 : 1109 : GFC_DECL_SAVED_DESCRIPTOR (desc) =
8972 : 1109 : DECL_LANG_SPECIFIC (expr->symtree->n.sym->backend_decl) ?
8973 : 1023 : GFC_DECL_SAVED_DESCRIPTOR (expr->symtree->n.sym->backend_decl)
8974 : : : expr->symtree->n.sym->backend_decl;
8975 : : }
8976 : 71964 : else if (expr->expr_type == EXPR_ARRAY && VAR_P (desc)
8977 : 10206 : && IS_CLASS_ARRAY (expr))
8978 : : {
8979 : 12 : tree vtype;
8980 : 12 : gfc_allocate_lang_decl (desc);
8981 : 12 : tmp = gfc_create_var (expr->ts.u.derived->backend_decl, "class");
8982 : 12 : GFC_DECL_SAVED_DESCRIPTOR (desc) = tmp;
8983 : 12 : vtype = gfc_class_vptr_get (tmp);
8984 : 12 : gfc_add_modify (&se->pre, vtype,
8985 : 12 : gfc_build_addr_expr (TREE_TYPE (vtype),
8986 : 12 : gfc_find_vtab (&expr->ts)->backend_decl));
8987 : : }
8988 : 73073 : if (!se->direct_byref || se->byref_noassign)
8989 : : {
8990 : : /* Get a pointer to the new descriptor. */
8991 : 70430 : if (se->want_pointer)
8992 : 40437 : se->expr = gfc_build_addr_expr (NULL_TREE, desc);
8993 : : else
8994 : 29993 : se->expr = desc;
8995 : : }
8996 : :
8997 : 73073 : gfc_add_block_to_block (&se->pre, &loop.pre);
8998 : 73073 : gfc_add_block_to_block (&se->post, &loop.post);
8999 : :
9000 : : /* Cleanup the scalarizer. */
9001 : 73073 : gfc_cleanup_loop (&loop);
9002 : : }
9003 : :
9004 : :
9005 : : /* Calculate the array size (number of elements); if dim != NULL_TREE,
9006 : : return size for that dim (dim=0..rank-1; only for GFC_DESCRIPTOR_TYPE_P).
9007 : : If !expr && descriptor array, the rank is taken from the descriptor. */
9008 : : tree
9009 : 14878 : gfc_tree_array_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree dim)
9010 : : {
9011 : 14878 : if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
9012 : : {
9013 : 34 : gcc_assert (dim == NULL_TREE);
9014 : 34 : return GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
9015 : : }
9016 : 14844 : tree size, tmp, rank = NULL_TREE, cond = NULL_TREE;
9017 : 14844 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
9018 : 14844 : enum gfc_array_kind akind = GFC_TYPE_ARRAY_AKIND (TREE_TYPE (desc));
9019 : 14844 : if (expr == NULL || expr->rank < 0)
9020 : 3130 : rank = fold_convert (signed_char_type_node,
9021 : : gfc_conv_descriptor_rank (desc));
9022 : : else
9023 : 11714 : rank = build_int_cst (signed_char_type_node, expr->rank);
9024 : :
9025 : 14844 : if (dim || (expr && expr->rank == 1))
9026 : : {
9027 : 4455 : if (!dim)
9028 : 4455 : dim = gfc_index_zero_node;
9029 : 13191 : tree ubound = gfc_conv_descriptor_ubound_get (desc, dim);
9030 : 13191 : tree lbound = gfc_conv_descriptor_lbound_get (desc, dim);
9031 : :
9032 : 13191 : size = fold_build2_loc (input_location, MINUS_EXPR,
9033 : : gfc_array_index_type, ubound, lbound);
9034 : 13191 : size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
9035 : : size, gfc_index_one_node);
9036 : : /* if (!allocatable && !pointer && assumed rank)
9037 : : size = (idx == rank && ubound[rank-1] == -1 ? -1 : size;
9038 : : else
9039 : : size = max (0, size); */
9040 : 13191 : size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
9041 : : size, gfc_index_zero_node);
9042 : 13191 : if (akind == GFC_ARRAY_ASSUMED_RANK_CONT
9043 : 13191 : || akind == GFC_ARRAY_ASSUMED_RANK)
9044 : : {
9045 : 2443 : tmp = fold_build2_loc (input_location, MINUS_EXPR, signed_char_type_node,
9046 : : rank, build_int_cst (signed_char_type_node, 1));
9047 : 2443 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
9048 : : fold_convert (signed_char_type_node, dim),
9049 : : tmp);
9050 : 2443 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
9051 : : gfc_conv_descriptor_ubound_get (desc, dim),
9052 : : build_int_cst (gfc_array_index_type, -1));
9053 : 2443 : cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
9054 : : cond, tmp);
9055 : 2443 : tmp = build_int_cst (gfc_array_index_type, -1);
9056 : 2443 : size = build3_loc (input_location, COND_EXPR, gfc_array_index_type,
9057 : : cond, tmp, size);
9058 : : }
9059 : 13191 : return size;
9060 : : }
9061 : :
9062 : : /* size = 1. */
9063 : 1653 : size = gfc_create_var (gfc_array_index_type, "size");
9064 : 1653 : gfc_add_modify (block, size, build_int_cst (TREE_TYPE (size), 1));
9065 : 1653 : tree extent = gfc_create_var (gfc_array_index_type, "extent");
9066 : :
9067 : 1653 : stmtblock_t cond_block, loop_body;
9068 : 1653 : gfc_init_block (&cond_block);
9069 : 1653 : gfc_init_block (&loop_body);
9070 : :
9071 : : /* Loop: for (i = 0; i < rank; ++i). */
9072 : 1653 : tree idx = gfc_create_var (signed_char_type_node, "idx");
9073 : : /* Loop body. */
9074 : : /* #if (assumed-rank + !allocatable && !pointer)
9075 : : if (idx == rank - 1 && dim[idx].ubound == -1)
9076 : : extent = -1;
9077 : : else
9078 : : #endif
9079 : : extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1
9080 : : if (extent < 0)
9081 : : extent = 0
9082 : : size *= extent. */
9083 : 1653 : cond = NULL_TREE;
9084 : 1653 : if (akind == GFC_ARRAY_ASSUMED_RANK_CONT || akind == GFC_ARRAY_ASSUMED_RANK)
9085 : : {
9086 : 459 : tmp = fold_build2_loc (input_location, MINUS_EXPR, signed_char_type_node,
9087 : : rank, build_int_cst (signed_char_type_node, 1));
9088 : 459 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
9089 : : idx, tmp);
9090 : 459 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
9091 : : gfc_conv_descriptor_ubound_get (desc, idx),
9092 : : build_int_cst (gfc_array_index_type, -1));
9093 : 459 : cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
9094 : : cond, tmp);
9095 : : }
9096 : 1653 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
9097 : : gfc_conv_descriptor_ubound_get (desc, idx),
9098 : : gfc_conv_descriptor_lbound_get (desc, idx));
9099 : 1653 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
9100 : : tmp, gfc_index_one_node);
9101 : 1653 : gfc_add_modify (&cond_block, extent, tmp);
9102 : 1653 : tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
9103 : : extent, gfc_index_zero_node);
9104 : 1653 : tmp = build3_v (COND_EXPR, tmp,
9105 : : fold_build2_loc (input_location, MODIFY_EXPR,
9106 : : gfc_array_index_type,
9107 : : extent, gfc_index_zero_node),
9108 : : build_empty_stmt (input_location));
9109 : 1653 : gfc_add_expr_to_block (&cond_block, tmp);
9110 : 1653 : tmp = gfc_finish_block (&cond_block);
9111 : 1653 : if (cond)
9112 : 459 : tmp = build3_v (COND_EXPR, cond,
9113 : : fold_build2_loc (input_location, MODIFY_EXPR,
9114 : : gfc_array_index_type, extent,
9115 : : build_int_cst (gfc_array_index_type, -1)),
9116 : : tmp);
9117 : 1653 : gfc_add_expr_to_block (&loop_body, tmp);
9118 : : /* size *= extent. */
9119 : 1653 : gfc_add_modify (&loop_body, size,
9120 : : fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9121 : : size, extent));
9122 : : /* Generate loop. */
9123 : 3306 : gfc_simple_for_loop (block, idx, build_int_cst (TREE_TYPE (idx), 0), rank, LT_EXPR,
9124 : 1653 : build_int_cst (TREE_TYPE (idx), 1),
9125 : : gfc_finish_block (&loop_body));
9126 : 1653 : return size;
9127 : : }
9128 : :
9129 : : /* Helper function for gfc_conv_array_parameter if array size needs to be
9130 : : computed. */
9131 : :
9132 : : static void
9133 : 102 : array_parameter_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree *size)
9134 : : {
9135 : 102 : tree elem;
9136 : 102 : *size = gfc_tree_array_size (block, desc, expr, NULL);
9137 : 102 : elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
9138 : 102 : *size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9139 : : *size, fold_convert (gfc_array_index_type, elem));
9140 : 102 : }
9141 : :
9142 : : /* Helper function - return true if the argument is a pointer. */
9143 : :
9144 : : static bool
9145 : 733 : is_pointer (gfc_expr *e)
9146 : : {
9147 : 733 : gfc_symbol *sym;
9148 : :
9149 : 733 : if (e->expr_type != EXPR_VARIABLE || e->symtree == NULL)
9150 : : return false;
9151 : :
9152 : 733 : sym = e->symtree->n.sym;
9153 : 733 : if (sym == NULL)
9154 : : return false;
9155 : :
9156 : 733 : return sym->attr.pointer || sym->attr.proc_pointer;
9157 : : }
9158 : :
9159 : : /* Convert an array for passing as an actual parameter. */
9160 : :
9161 : : void
9162 : 65507 : gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr, bool g77,
9163 : : const gfc_symbol *fsym, const char *proc_name,
9164 : : tree *size, tree *lbshift, tree *packed)
9165 : : {
9166 : 65507 : tree ptr;
9167 : 65507 : tree desc;
9168 : 65507 : tree tmp = NULL_TREE;
9169 : 65507 : tree stmt;
9170 : 65507 : tree parent = DECL_CONTEXT (current_function_decl);
9171 : 65507 : tree ctree;
9172 : 65507 : tree pack_attr = NULL_TREE; /* Set when packing class arrays. */
9173 : 65507 : bool full_array_var;
9174 : 65507 : bool this_array_result;
9175 : 65507 : bool contiguous;
9176 : 65507 : bool no_pack;
9177 : 65507 : bool array_constructor;
9178 : 65507 : bool good_allocatable;
9179 : 65507 : bool ultimate_ptr_comp;
9180 : 65507 : bool ultimate_alloc_comp;
9181 : 65507 : bool readonly;
9182 : 65507 : gfc_symbol *sym;
9183 : 65507 : stmtblock_t block;
9184 : 65507 : gfc_ref *ref;
9185 : :
9186 : 65507 : ultimate_ptr_comp = false;
9187 : 65507 : ultimate_alloc_comp = false;
9188 : :
9189 : 66207 : for (ref = expr->ref; ref; ref = ref->next)
9190 : : {
9191 : 54434 : if (ref->next == NULL)
9192 : : break;
9193 : :
9194 : 700 : if (ref->type == REF_COMPONENT)
9195 : : {
9196 : 622 : ultimate_ptr_comp = ref->u.c.component->attr.pointer;
9197 : 622 : ultimate_alloc_comp = ref->u.c.component->attr.allocatable;
9198 : : }
9199 : : }
9200 : :
9201 : 65507 : full_array_var = false;
9202 : 65507 : contiguous = false;
9203 : :
9204 : 65507 : if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp)
9205 : 53642 : full_array_var = gfc_full_array_ref_p (ref, &contiguous);
9206 : :
9207 : 53642 : sym = full_array_var ? expr->symtree->n.sym : NULL;
9208 : :
9209 : : /* The symbol should have an array specification. */
9210 : 62633 : gcc_assert (!sym || sym->as || ref->u.ar.as);
9211 : :
9212 : 65507 : if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
9213 : : {
9214 : 678 : get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
9215 : 678 : expr->ts.u.cl->backend_decl = tmp;
9216 : 678 : se->string_length = tmp;
9217 : : }
9218 : :
9219 : : /* Is this the result of the enclosing procedure? */
9220 : 65507 : this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
9221 : 58 : if (this_array_result
9222 : 58 : && (sym->backend_decl != current_function_decl)
9223 : 0 : && (sym->backend_decl != parent))
9224 : 65507 : this_array_result = false;
9225 : :
9226 : : /* Passing an optional dummy argument as actual to an optional dummy? */
9227 : 65507 : bool pass_optional;
9228 : 65507 : pass_optional = fsym && fsym->attr.optional && sym && sym->attr.optional;
9229 : :
9230 : : /* Passing address of the array if it is not pointer or assumed-shape. */
9231 : 65507 : if (full_array_var && g77 && !this_array_result
9232 : 15433 : && sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
9233 : : {
9234 : 12320 : tmp = gfc_get_symbol_decl (sym);
9235 : :
9236 : 12320 : if (sym->ts.type == BT_CHARACTER)
9237 : 2741 : se->string_length = sym->ts.u.cl->backend_decl;
9238 : :
9239 : 12320 : if (!sym->attr.pointer
9240 : 11815 : && sym->as
9241 : 11815 : && sym->as->type != AS_ASSUMED_SHAPE
9242 : 11571 : && sym->as->type != AS_DEFERRED
9243 : 10169 : && sym->as->type != AS_ASSUMED_RANK
9244 : 10093 : && !sym->attr.allocatable)
9245 : : {
9246 : : /* Some variables are declared directly, others are declared as
9247 : : pointers and allocated on the heap. */
9248 : 9641 : if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
9249 : 2489 : se->expr = tmp;
9250 : : else
9251 : 7152 : se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
9252 : 9641 : if (size)
9253 : 34 : array_parameter_size (&se->pre, tmp, expr, size);
9254 : 16303 : return;
9255 : : }
9256 : :
9257 : 2679 : if (sym->attr.allocatable)
9258 : : {
9259 : 1734 : if (sym->attr.dummy || sym->attr.result)
9260 : : {
9261 : 1092 : gfc_conv_expr_descriptor (se, expr);
9262 : 1092 : tmp = se->expr;
9263 : : }
9264 : 1734 : if (size)
9265 : 6 : array_parameter_size (&se->pre, tmp, expr, size);
9266 : 1734 : se->expr = gfc_conv_array_data (tmp);
9267 : 1734 : if (pass_optional)
9268 : : {
9269 : 18 : tree cond = gfc_conv_expr_present (sym);
9270 : 36 : se->expr = build3_loc (input_location, COND_EXPR,
9271 : 18 : TREE_TYPE (se->expr), cond, se->expr,
9272 : 18 : fold_convert (TREE_TYPE (se->expr),
9273 : : null_pointer_node));
9274 : : }
9275 : 1734 : return;
9276 : : }
9277 : : }
9278 : :
9279 : : /* A convenient reduction in scope. */
9280 : 54132 : contiguous = g77 && !this_array_result && contiguous;
9281 : :
9282 : : /* There is no need to pack and unpack the array, if it is contiguous
9283 : : and not a deferred- or assumed-shape array, or if it is simply
9284 : : contiguous. */
9285 : 54132 : no_pack = false;
9286 : : // clang-format off
9287 : 54132 : if (sym)
9288 : : {
9289 : 39483 : symbol_attribute *attr = &(IS_CLASS_ARRAY (sym)
9290 : : ? CLASS_DATA (sym)->attr : sym->attr);
9291 : 39483 : gfc_array_spec *as = IS_CLASS_ARRAY (sym)
9292 : 39483 : ? CLASS_DATA (sym)->as : sym->as;
9293 : 39483 : no_pack = (as
9294 : 39217 : && !attr->pointer
9295 : 35944 : && as->type != AS_DEFERRED
9296 : 26407 : && as->type != AS_ASSUMED_RANK
9297 : 63213 : && as->type != AS_ASSUMED_SHAPE);
9298 : : }
9299 : 54132 : if (ref && ref->u.ar.as)
9300 : 42357 : no_pack = no_pack
9301 : 42357 : || (ref->u.ar.as->type != AS_DEFERRED
9302 : : && ref->u.ar.as->type != AS_ASSUMED_RANK
9303 : : && ref->u.ar.as->type != AS_ASSUMED_SHAPE);
9304 : 108264 : no_pack = contiguous
9305 : 54132 : && (no_pack || gfc_is_simply_contiguous (expr, false, true));
9306 : : // clang-format on
9307 : :
9308 : : /* If we have an EXPR_OP or a function returning an explicit-shaped
9309 : : or allocatable array, an array temporary will be generated which
9310 : : does not need to be packed / unpacked if passed to an
9311 : : explicit-shape dummy array. */
9312 : :
9313 : 54132 : if (g77)
9314 : : {
9315 : 5991 : if (expr->expr_type == EXPR_OP)
9316 : : no_pack = 1;
9317 : 5914 : else if (expr->expr_type == EXPR_FUNCTION && expr->value.function.esym)
9318 : : {
9319 : 41 : gfc_symbol *result = expr->value.function.esym->result;
9320 : 41 : if (result->attr.dimension
9321 : 41 : && (result->as->type == AS_EXPLICIT
9322 : 14 : || result->attr.allocatable
9323 : 7 : || result->attr.contiguous))
9324 : 112 : no_pack = 1;
9325 : : }
9326 : : }
9327 : :
9328 : : /* Array constructors are always contiguous and do not need packing. */
9329 : 54132 : array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY;
9330 : :
9331 : : /* Same is true of contiguous sections from allocatable variables. */
9332 : 108264 : good_allocatable = contiguous
9333 : 4175 : && expr->symtree
9334 : 58307 : && expr->symtree->n.sym->attr.allocatable;
9335 : :
9336 : : /* Or ultimate allocatable components. */
9337 : 54132 : ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
9338 : :
9339 : 54132 : if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp)
9340 : : {
9341 : 4542 : gfc_conv_expr_descriptor (se, expr);
9342 : : /* Deallocate the allocatable components of structures that are
9343 : : not variable. */
9344 : 4542 : if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
9345 : 3028 : && expr->ts.u.derived->attr.alloc_comp
9346 : 1747 : && expr->expr_type != EXPR_VARIABLE)
9347 : : {
9348 : 2 : tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, se->expr, expr->rank);
9349 : :
9350 : : /* The components shall be deallocated before their containing entity. */
9351 : 2 : gfc_prepend_expr_to_block (&se->post, tmp);
9352 : : }
9353 : 4542 : if (expr->ts.type == BT_CHARACTER && expr->expr_type != EXPR_FUNCTION)
9354 : 279 : se->string_length = expr->ts.u.cl->backend_decl;
9355 : 4542 : if (size)
9356 : 32 : array_parameter_size (&se->pre, se->expr, expr, size);
9357 : 4542 : se->expr = gfc_conv_array_data (se->expr);
9358 : 4542 : return;
9359 : : }
9360 : :
9361 : 49590 : if (fsym && fsym->ts.type == BT_CLASS)
9362 : : {
9363 : 1211 : gcc_assert (se->expr);
9364 : : ctree = se->expr;
9365 : : }
9366 : : else
9367 : : ctree = NULL_TREE;
9368 : :
9369 : 49590 : if (this_array_result)
9370 : : {
9371 : : /* Result of the enclosing function. */
9372 : 58 : gfc_conv_expr_descriptor (se, expr);
9373 : 58 : if (size)
9374 : 0 : array_parameter_size (&se->pre, se->expr, expr, size);
9375 : 58 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
9376 : :
9377 : 18 : if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
9378 : 76 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
9379 : 18 : se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location,
9380 : : se->expr));
9381 : :
9382 : 58 : return;
9383 : : }
9384 : : else
9385 : : {
9386 : : /* Every other type of array. */
9387 : 49532 : se->want_pointer = (ctree) ? 0 : 1;
9388 : 49532 : se->want_coarray = expr->corank;
9389 : 49532 : gfc_conv_expr_descriptor (se, expr);
9390 : :
9391 : 49532 : if (size)
9392 : 30 : array_parameter_size (&se->pre,
9393 : : build_fold_indirect_ref_loc (input_location,
9394 : : se->expr),
9395 : : expr, size);
9396 : 49532 : if (ctree)
9397 : : {
9398 : 1211 : stmtblock_t block;
9399 : :
9400 : 1211 : gfc_init_block (&block);
9401 : 1211 : if (lbshift && *lbshift)
9402 : : {
9403 : : /* Apply a shift of the lbound when supplied. */
9404 : 98 : for (int dim = 0; dim < expr->rank; ++dim)
9405 : 49 : gfc_conv_shift_descriptor_lbound (&block, se->expr, dim,
9406 : : *lbshift);
9407 : : }
9408 : 1211 : tmp = gfc_class_data_get (ctree);
9409 : 1211 : if (expr->rank > 1 && CLASS_DATA (fsym)->as->rank != expr->rank
9410 : 84 : && CLASS_DATA (fsym)->as->type == AS_EXPLICIT && !no_pack)
9411 : : {
9412 : 36 : tree arr = gfc_create_var (TREE_TYPE (tmp), "parm");
9413 : 36 : gfc_conv_descriptor_data_set (&block, arr,
9414 : : gfc_conv_descriptor_data_get (
9415 : : se->expr));
9416 : 36 : gfc_conv_descriptor_lbound_set (&block, arr, gfc_index_zero_node,
9417 : : gfc_index_zero_node);
9418 : 36 : gfc_conv_descriptor_ubound_set (
9419 : : &block, arr, gfc_index_zero_node,
9420 : : gfc_conv_descriptor_size (se->expr, expr->rank));
9421 : 36 : gfc_conv_descriptor_stride_set (
9422 : : &block, arr, gfc_index_zero_node,
9423 : : gfc_conv_descriptor_stride_get (se->expr, gfc_index_zero_node));
9424 : 36 : gfc_add_modify (&block, gfc_conv_descriptor_dtype (arr),
9425 : : gfc_conv_descriptor_dtype (se->expr));
9426 : 36 : gfc_add_modify (&block, gfc_conv_descriptor_rank (arr),
9427 : : build_int_cst (signed_char_type_node, 1));
9428 : 36 : gfc_conv_descriptor_span_set (&block, arr,
9429 : : gfc_conv_descriptor_span_get (arr));
9430 : 36 : gfc_conv_descriptor_offset_set (&block, arr, gfc_index_zero_node);
9431 : 36 : se->expr = arr;
9432 : : }
9433 : 1211 : gfc_class_array_data_assign (&block, tmp, se->expr, true);
9434 : :
9435 : : /* Handle optional. */
9436 : 1211 : if (fsym && fsym->attr.optional && sym && sym->attr.optional)
9437 : 348 : tmp = build3_v (COND_EXPR, gfc_conv_expr_present (sym),
9438 : : gfc_finish_block (&block),
9439 : : build_empty_stmt (input_location));
9440 : : else
9441 : 863 : tmp = gfc_finish_block (&block);
9442 : :
9443 : 1211 : gfc_add_expr_to_block (&se->pre, tmp);
9444 : : }
9445 : 48321 : else if (pass_optional && full_array_var && sym->as && sym->as->rank != 0)
9446 : : {
9447 : : /* Perform calculation of bounds and strides of optional array dummy
9448 : : only if the argument is present. */
9449 : 219 : tmp = build3_v (COND_EXPR, gfc_conv_expr_present (sym),
9450 : : gfc_finish_block (&se->pre),
9451 : : build_empty_stmt (input_location));
9452 : 219 : gfc_add_expr_to_block (&se->pre, tmp);
9453 : : }
9454 : : }
9455 : :
9456 : : /* Deallocate the allocatable components of structures that are
9457 : : not variable, for descriptorless arguments.
9458 : : Arguments with a descriptor are handled in gfc_conv_procedure_call. */
9459 : 49532 : if (g77 && (expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
9460 : 75 : && expr->ts.u.derived->attr.alloc_comp
9461 : 21 : && expr->expr_type != EXPR_VARIABLE)
9462 : : {
9463 : 0 : tmp = build_fold_indirect_ref_loc (input_location, se->expr);
9464 : 0 : tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank);
9465 : :
9466 : : /* The components shall be deallocated before their containing entity. */
9467 : 0 : gfc_prepend_expr_to_block (&se->post, tmp);
9468 : : }
9469 : :
9470 : 48101 : if (g77 || (fsym && fsym->attr.contiguous
9471 : 1527 : && !gfc_is_simply_contiguous (expr, false, true)))
9472 : : {
9473 : 1575 : tree origptr = NULL_TREE, packedptr = NULL_TREE;
9474 : :
9475 : 1575 : desc = se->expr;
9476 : :
9477 : : /* For contiguous arrays, save the original value of the descriptor. */
9478 : 1575 : if (!g77 && !ctree)
9479 : : {
9480 : 48 : origptr = gfc_create_var (pvoid_type_node, "origptr");
9481 : 48 : tmp = build_fold_indirect_ref_loc (input_location, desc);
9482 : 48 : tmp = gfc_conv_array_data (tmp);
9483 : 96 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
9484 : 48 : TREE_TYPE (origptr), origptr,
9485 : 48 : fold_convert (TREE_TYPE (origptr), tmp));
9486 : 48 : gfc_add_expr_to_block (&se->pre, tmp);
9487 : : }
9488 : :
9489 : : /* Repack the array. */
9490 : 1575 : if (warn_array_temporaries)
9491 : : {
9492 : 28 : if (fsym)
9493 : 18 : gfc_warning (OPT_Warray_temporaries,
9494 : : "Creating array temporary at %L for argument %qs",
9495 : 18 : &expr->where, fsym->name);
9496 : : else
9497 : 10 : gfc_warning (OPT_Warray_temporaries,
9498 : : "Creating array temporary at %L", &expr->where);
9499 : : }
9500 : :
9501 : : /* When optimizing, we can use gfc_conv_subref_array_arg for
9502 : : making the packing and unpacking operation visible to the
9503 : : optimizers. */
9504 : :
9505 : 1431 : if (g77 && flag_inline_arg_packing && expr->expr_type == EXPR_VARIABLE
9506 : 733 : && !is_pointer (expr) && ! gfc_has_dimen_vector_ref (expr)
9507 : 349 : && !(expr->symtree->n.sym->as
9508 : 320 : && expr->symtree->n.sym->as->type == AS_ASSUMED_RANK)
9509 : 1924 : && (fsym == NULL || fsym->ts.type != BT_ASSUMED))
9510 : : {
9511 : 328 : gfc_conv_subref_array_arg (se, expr, g77,
9512 : 137 : fsym ? fsym->attr.intent : INTENT_INOUT,
9513 : : false, fsym, proc_name, sym, true);
9514 : 328 : return;
9515 : : }
9516 : :
9517 : 1247 : if (ctree)
9518 : : {
9519 : 96 : packedptr
9520 : 96 : = gfc_build_addr_expr (NULL_TREE, gfc_create_var (TREE_TYPE (ctree),
9521 : : "packed"));
9522 : 96 : if (fsym)
9523 : : {
9524 : 96 : int pack_mask = 0;
9525 : :
9526 : : /* Set bit 0 to the mask, when this is an unlimited_poly
9527 : : class. */
9528 : 96 : if (CLASS_DATA (fsym)->ts.u.derived->attr.unlimited_polymorphic)
9529 : 36 : pack_mask = 1 << 0;
9530 : 96 : pack_attr = build_int_cst (integer_type_node, pack_mask);
9531 : : }
9532 : : else
9533 : 0 : pack_attr = integer_zero_node;
9534 : :
9535 : 96 : gfc_add_expr_to_block (
9536 : : &se->pre,
9537 : : build_call_expr_loc (input_location, gfor_fndecl_in_pack_class, 4,
9538 : : packedptr,
9539 : : gfc_build_addr_expr (NULL_TREE, ctree),
9540 : 96 : size_in_bytes (TREE_TYPE (ctree)), pack_attr));
9541 : 96 : ptr = gfc_conv_array_data (gfc_class_data_get (packedptr));
9542 : 96 : se->expr = packedptr;
9543 : 96 : if (packed)
9544 : 96 : *packed = packedptr;
9545 : : }
9546 : : else
9547 : : {
9548 : 1151 : ptr = build_call_expr_loc (input_location, gfor_fndecl_in_pack, 1,
9549 : : desc);
9550 : :
9551 : 1151 : if (fsym && fsym->attr.optional && sym && sym->attr.optional)
9552 : : {
9553 : 11 : tmp = gfc_conv_expr_present (sym);
9554 : 22 : ptr = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
9555 : 11 : tmp, fold_convert (TREE_TYPE (se->expr), ptr),
9556 : 11 : fold_convert (TREE_TYPE (se->expr),
9557 : : null_pointer_node));
9558 : : }
9559 : :
9560 : 1151 : ptr = gfc_evaluate_now (ptr, &se->pre);
9561 : : }
9562 : :
9563 : : /* Use the packed data for the actual argument, except for contiguous arrays,
9564 : : where the descriptor's data component is set. */
9565 : 1247 : if (g77)
9566 : 1103 : se->expr = ptr;
9567 : : else
9568 : : {
9569 : 144 : tmp = build_fold_indirect_ref_loc (input_location, desc);
9570 : :
9571 : 144 : gfc_ss * ss = gfc_walk_expr (expr);
9572 : 288 : if (!transposed_dims (ss))
9573 : : {
9574 : 138 : if (!ctree)
9575 : 48 : gfc_conv_descriptor_data_set (&se->pre, tmp, ptr);
9576 : : }
9577 : 6 : else if (!ctree)
9578 : : {
9579 : 0 : tree old_field, new_field;
9580 : :
9581 : : /* The original descriptor has transposed dims so we can't reuse
9582 : : it directly; we have to create a new one. */
9583 : 0 : tree old_desc = tmp;
9584 : 0 : tree new_desc = gfc_create_var (TREE_TYPE (old_desc), "arg_desc");
9585 : :
9586 : 0 : old_field = gfc_conv_descriptor_dtype (old_desc);
9587 : 0 : new_field = gfc_conv_descriptor_dtype (new_desc);
9588 : 0 : gfc_add_modify (&se->pre, new_field, old_field);
9589 : :
9590 : 0 : old_field = gfc_conv_descriptor_offset_get (old_desc);
9591 : 0 : gfc_conv_descriptor_offset_set (&se->pre, new_desc, old_field);
9592 : :
9593 : 0 : for (int i = 0; i < expr->rank; i++)
9594 : : {
9595 : 0 : old_field = gfc_conv_descriptor_dimension (old_desc,
9596 : 0 : gfc_rank_cst[get_array_ref_dim_for_loop_dim (ss, i)]);
9597 : 0 : new_field = gfc_conv_descriptor_dimension (new_desc,
9598 : : gfc_rank_cst[i]);
9599 : 0 : gfc_add_modify (&se->pre, new_field, old_field);
9600 : : }
9601 : :
9602 : 0 : if (flag_coarray == GFC_FCOARRAY_LIB
9603 : 0 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (old_desc))
9604 : 0 : && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (old_desc))
9605 : : == GFC_ARRAY_ALLOCATABLE)
9606 : : {
9607 : 0 : old_field = gfc_conv_descriptor_token (old_desc);
9608 : 0 : new_field = gfc_conv_descriptor_token (new_desc);
9609 : 0 : gfc_add_modify (&se->pre, new_field, old_field);
9610 : : }
9611 : :
9612 : 0 : gfc_conv_descriptor_data_set (&se->pre, new_desc, ptr);
9613 : 0 : se->expr = gfc_build_addr_expr (NULL_TREE, new_desc);
9614 : : }
9615 : 144 : gfc_free_ss (ss);
9616 : : }
9617 : :
9618 : 1247 : if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
9619 : : {
9620 : 8 : char * msg;
9621 : :
9622 : 8 : if (fsym && proc_name)
9623 : 8 : msg = xasprintf ("An array temporary was created for argument "
9624 : 8 : "'%s' of procedure '%s'", fsym->name, proc_name);
9625 : : else
9626 : 0 : msg = xasprintf ("An array temporary was created");
9627 : :
9628 : 8 : tmp = build_fold_indirect_ref_loc (input_location,
9629 : : desc);
9630 : 8 : tmp = gfc_conv_array_data (tmp);
9631 : 8 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9632 : 8 : fold_convert (TREE_TYPE (tmp), ptr), tmp);
9633 : :
9634 : 8 : if (pass_optional)
9635 : 6 : tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
9636 : : logical_type_node,
9637 : : gfc_conv_expr_present (sym), tmp);
9638 : :
9639 : 8 : gfc_trans_runtime_check (false, true, tmp, &se->pre,
9640 : : &expr->where, msg);
9641 : 8 : free (msg);
9642 : : }
9643 : :
9644 : 1247 : gfc_start_block (&block);
9645 : :
9646 : : /* Copy the data back. If input expr is read-only, e.g. a PARAMETER
9647 : : array, copying back modified values is undefined behavior. */
9648 : 2494 : readonly = (expr->expr_type == EXPR_VARIABLE
9649 : 854 : && expr->symtree
9650 : 2101 : && expr->symtree->n.sym->attr.flavor == FL_PARAMETER);
9651 : :
9652 : 1247 : if ((fsym == NULL || fsym->attr.intent != INTENT_IN) && !readonly)
9653 : : {
9654 : 1114 : if (ctree)
9655 : : {
9656 : 66 : tmp = gfc_build_addr_expr (NULL_TREE, ctree);
9657 : 66 : tmp = build_call_expr_loc (input_location,
9658 : : gfor_fndecl_in_unpack_class, 4, tmp,
9659 : : packedptr,
9660 : 66 : size_in_bytes (TREE_TYPE (ctree)),
9661 : : pack_attr);
9662 : : }
9663 : : else
9664 : 1048 : tmp = build_call_expr_loc (input_location, gfor_fndecl_in_unpack, 2,
9665 : : desc, ptr);
9666 : 1114 : gfc_add_expr_to_block (&block, tmp);
9667 : : }
9668 : 133 : else if (ctree && fsym->attr.intent == INTENT_IN)
9669 : : {
9670 : : /* Need to free the memory for class arrays, that got packed. */
9671 : 30 : gfc_add_expr_to_block (&block, gfc_call_free (ptr));
9672 : : }
9673 : :
9674 : : /* Free the temporary. */
9675 : 1144 : if (!ctree)
9676 : 1151 : gfc_add_expr_to_block (&block, gfc_call_free (ptr));
9677 : :
9678 : 1247 : stmt = gfc_finish_block (&block);
9679 : :
9680 : 1247 : gfc_init_block (&block);
9681 : : /* Only if it was repacked. This code needs to be executed before the
9682 : : loop cleanup code. */
9683 : 1247 : tmp = (ctree) ? desc : build_fold_indirect_ref_loc (input_location, desc);
9684 : 1247 : tmp = gfc_conv_array_data (tmp);
9685 : 1247 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9686 : 1247 : fold_convert (TREE_TYPE (tmp), ptr), tmp);
9687 : :
9688 : 1247 : if (pass_optional)
9689 : 11 : tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
9690 : : logical_type_node,
9691 : : gfc_conv_expr_present (sym), tmp);
9692 : :
9693 : 1247 : tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
9694 : :
9695 : 1247 : gfc_add_expr_to_block (&block, tmp);
9696 : 1247 : gfc_add_block_to_block (&block, &se->post);
9697 : :
9698 : 1247 : gfc_init_block (&se->post);
9699 : :
9700 : : /* Reset the descriptor pointer. */
9701 : 1247 : if (!g77 && !ctree)
9702 : : {
9703 : 48 : tmp = build_fold_indirect_ref_loc (input_location, desc);
9704 : 48 : gfc_conv_descriptor_data_set (&se->post, tmp, origptr);
9705 : : }
9706 : :
9707 : 1247 : gfc_add_block_to_block (&se->post, &block);
9708 : : }
9709 : : }
9710 : :
9711 : :
9712 : : /* This helper function calculates the size in words of a full array. */
9713 : :
9714 : : tree
9715 : 16265 : gfc_full_array_size (stmtblock_t *block, tree decl, int rank)
9716 : : {
9717 : 16265 : tree idx;
9718 : 16265 : tree nelems;
9719 : 16265 : tree tmp;
9720 : 16265 : if (rank < 0)
9721 : 0 : idx = gfc_conv_descriptor_rank (decl);
9722 : : else
9723 : 16265 : idx = gfc_rank_cst[rank - 1];
9724 : 16265 : nelems = gfc_conv_descriptor_ubound_get (decl, idx);
9725 : 16265 : tmp = gfc_conv_descriptor_lbound_get (decl, idx);
9726 : 16265 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
9727 : : nelems, tmp);
9728 : 16265 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
9729 : : tmp, gfc_index_one_node);
9730 : 16265 : tmp = gfc_evaluate_now (tmp, block);
9731 : :
9732 : 16265 : nelems = gfc_conv_descriptor_stride_get (decl, idx);
9733 : 16265 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9734 : : nelems, tmp);
9735 : 16265 : return gfc_evaluate_now (tmp, block);
9736 : : }
9737 : :
9738 : :
9739 : : /* Allocate dest to the same size as src, and copy src -> dest.
9740 : : If no_malloc is set, only the copy is done. */
9741 : :
9742 : : static tree
9743 : 7438 : duplicate_allocatable (tree dest, tree src, tree type, int rank,
9744 : : bool no_malloc, bool no_memcpy, tree str_sz,
9745 : : tree add_when_allocated)
9746 : : {
9747 : 7438 : tree tmp;
9748 : 7438 : tree eltype;
9749 : 7438 : tree size;
9750 : 7438 : tree nelems;
9751 : 7438 : tree null_cond;
9752 : 7438 : tree null_data;
9753 : 7438 : stmtblock_t block;
9754 : :
9755 : : /* If the source is null, set the destination to null. Then,
9756 : : allocate memory to the destination. */
9757 : 7438 : gfc_init_block (&block);
9758 : :
9759 : 7438 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
9760 : : {
9761 : 2087 : gfc_add_modify (&block, dest, fold_convert (type, null_pointer_node));
9762 : 2087 : null_data = gfc_finish_block (&block);
9763 : :
9764 : 2087 : gfc_init_block (&block);
9765 : 2087 : eltype = TREE_TYPE (type);
9766 : 2087 : if (str_sz != NULL_TREE)
9767 : : size = str_sz;
9768 : : else
9769 : 1786 : size = TYPE_SIZE_UNIT (eltype);
9770 : :
9771 : 2087 : if (!no_malloc)
9772 : : {
9773 : 2087 : tmp = gfc_call_malloc (&block, type, size);
9774 : 2087 : gfc_add_modify (&block, dest, fold_convert (type, tmp));
9775 : : }
9776 : :
9777 : 2087 : if (!no_memcpy)
9778 : : {
9779 : 1662 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
9780 : 1662 : tmp = build_call_expr_loc (input_location, tmp, 3, dest, src,
9781 : : fold_convert (size_type_node, size));
9782 : 1662 : gfc_add_expr_to_block (&block, tmp);
9783 : : }
9784 : : }
9785 : : else
9786 : : {
9787 : 5351 : gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
9788 : 5351 : null_data = gfc_finish_block (&block);
9789 : :
9790 : 5351 : gfc_init_block (&block);
9791 : 5351 : if (rank)
9792 : 5340 : nelems = gfc_full_array_size (&block, src, rank);
9793 : : else
9794 : 11 : nelems = gfc_index_one_node;
9795 : :
9796 : : /* If type is not the array type, then it is the element type. */
9797 : 5351 : if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type))
9798 : 5321 : eltype = gfc_get_element_type (type);
9799 : : else
9800 : : eltype = type;
9801 : :
9802 : 5351 : if (str_sz != NULL_TREE)
9803 : 43 : tmp = fold_convert (gfc_array_index_type, str_sz);
9804 : : else
9805 : 5308 : tmp = fold_convert (gfc_array_index_type,
9806 : : TYPE_SIZE_UNIT (eltype));
9807 : :
9808 : 5351 : tmp = gfc_evaluate_now (tmp, &block);
9809 : 5351 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9810 : : nelems, tmp);
9811 : 5351 : if (!no_malloc)
9812 : : {
9813 : 5300 : tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src));
9814 : 5300 : tmp = gfc_call_malloc (&block, tmp, size);
9815 : 5300 : gfc_conv_descriptor_data_set (&block, dest, tmp);
9816 : : }
9817 : :
9818 : : /* We know the temporary and the value will be the same length,
9819 : : so can use memcpy. */
9820 : 5351 : if (!no_memcpy)
9821 : : {
9822 : 4693 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
9823 : 4693 : tmp = build_call_expr_loc (input_location, tmp, 3,
9824 : : gfc_conv_descriptor_data_get (dest),
9825 : : gfc_conv_descriptor_data_get (src),
9826 : : fold_convert (size_type_node, size));
9827 : 4693 : gfc_add_expr_to_block (&block, tmp);
9828 : : }
9829 : : }
9830 : :
9831 : 7438 : gfc_add_expr_to_block (&block, add_when_allocated);
9832 : 7438 : tmp = gfc_finish_block (&block);
9833 : :
9834 : : /* Null the destination if the source is null; otherwise do
9835 : : the allocate and copy. */
9836 : 7438 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src)))
9837 : : null_cond = src;
9838 : : else
9839 : 5351 : null_cond = gfc_conv_descriptor_data_get (src);
9840 : :
9841 : 7438 : null_cond = convert (pvoid_type_node, null_cond);
9842 : 7438 : null_cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9843 : : null_cond, null_pointer_node);
9844 : 7438 : return build3_v (COND_EXPR, null_cond, tmp, null_data);
9845 : : }
9846 : :
9847 : :
9848 : : /* Allocate dest to the same size as src, and copy data src -> dest. */
9849 : :
9850 : : tree
9851 : 5855 : gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank,
9852 : : tree add_when_allocated)
9853 : : {
9854 : 5855 : return duplicate_allocatable (dest, src, type, rank, false, false,
9855 : 5855 : NULL_TREE, add_when_allocated);
9856 : : }
9857 : :
9858 : :
9859 : : /* Copy data src -> dest. */
9860 : :
9861 : : tree
9862 : 51 : gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
9863 : : {
9864 : 51 : return duplicate_allocatable (dest, src, type, rank, true, false,
9865 : 51 : NULL_TREE, NULL_TREE);
9866 : : }
9867 : :
9868 : : /* Allocate dest to the same size as src, but don't copy anything. */
9869 : :
9870 : : tree
9871 : 1083 : gfc_duplicate_allocatable_nocopy (tree dest, tree src, tree type, int rank)
9872 : : {
9873 : 1083 : return duplicate_allocatable (dest, src, type, rank, false, true,
9874 : 1083 : NULL_TREE, NULL_TREE);
9875 : : }
9876 : :
9877 : : static tree
9878 : 55 : duplicate_allocatable_coarray (tree dest, tree dest_tok, tree src, tree type,
9879 : : int rank, tree add_when_allocated)
9880 : : {
9881 : 55 : tree tmp;
9882 : 55 : tree size;
9883 : 55 : tree nelems;
9884 : 55 : tree null_cond;
9885 : 55 : tree null_data;
9886 : 55 : stmtblock_t block, globalblock;
9887 : :
9888 : : /* If the source is null, set the destination to null. Then,
9889 : : allocate memory to the destination. */
9890 : 55 : gfc_init_block (&block);
9891 : 55 : gfc_init_block (&globalblock);
9892 : :
9893 : 55 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
9894 : : {
9895 : 15 : gfc_se se;
9896 : 15 : symbol_attribute attr;
9897 : 15 : tree dummy_desc;
9898 : :
9899 : 15 : gfc_init_se (&se, NULL);
9900 : 15 : gfc_clear_attr (&attr);
9901 : 15 : attr.allocatable = 1;
9902 : 15 : dummy_desc = gfc_conv_scalar_to_descriptor (&se, dest, attr);
9903 : 15 : gfc_add_block_to_block (&globalblock, &se.pre);
9904 : 15 : size = TYPE_SIZE_UNIT (TREE_TYPE (type));
9905 : :
9906 : 15 : gfc_add_modify (&block, dest, fold_convert (type, null_pointer_node));
9907 : 15 : gfc_allocate_using_caf_lib (&block, dummy_desc, size,
9908 : : gfc_build_addr_expr (NULL_TREE, dest_tok),
9909 : : NULL_TREE, NULL_TREE, NULL_TREE,
9910 : : GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
9911 : 15 : gfc_add_modify (&block, dest, gfc_conv_descriptor_data_get (dummy_desc));
9912 : 15 : null_data = gfc_finish_block (&block);
9913 : :
9914 : 15 : gfc_init_block (&block);
9915 : :
9916 : 15 : gfc_allocate_using_caf_lib (&block, dummy_desc,
9917 : : fold_convert (size_type_node, size),
9918 : : gfc_build_addr_expr (NULL_TREE, dest_tok),
9919 : : NULL_TREE, NULL_TREE, NULL_TREE,
9920 : : GFC_CAF_COARRAY_ALLOC);
9921 : 15 : gfc_add_modify (&block, dest, gfc_conv_descriptor_data_get (dummy_desc));
9922 : :
9923 : 15 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
9924 : 15 : tmp = build_call_expr_loc (input_location, tmp, 3, dest, src,
9925 : : fold_convert (size_type_node, size));
9926 : 15 : gfc_add_expr_to_block (&block, tmp);
9927 : : }
9928 : : else
9929 : : {
9930 : : /* Set the rank or unitialized memory access may be reported. */
9931 : 40 : tmp = gfc_conv_descriptor_rank (dest);
9932 : 40 : gfc_add_modify (&globalblock, tmp, build_int_cst (TREE_TYPE (tmp), rank));
9933 : :
9934 : 40 : if (rank)
9935 : 40 : nelems = gfc_full_array_size (&globalblock, src, rank);
9936 : : else
9937 : 0 : nelems = integer_one_node;
9938 : :
9939 : 40 : tmp = fold_convert (size_type_node,
9940 : : TYPE_SIZE_UNIT (gfc_get_element_type (type)));
9941 : 40 : size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
9942 : : fold_convert (size_type_node, nelems), tmp);
9943 : :
9944 : 40 : gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
9945 : 40 : gfc_allocate_using_caf_lib (&block, dest, fold_convert (size_type_node,
9946 : : size),
9947 : : gfc_build_addr_expr (NULL_TREE, dest_tok),
9948 : : NULL_TREE, NULL_TREE, NULL_TREE,
9949 : : GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
9950 : 40 : null_data = gfc_finish_block (&block);
9951 : :
9952 : 40 : gfc_init_block (&block);
9953 : 40 : gfc_allocate_using_caf_lib (&block, dest,
9954 : : fold_convert (size_type_node, size),
9955 : : gfc_build_addr_expr (NULL_TREE, dest_tok),
9956 : : NULL_TREE, NULL_TREE, NULL_TREE,
9957 : : GFC_CAF_COARRAY_ALLOC);
9958 : :
9959 : 40 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
9960 : 40 : tmp = build_call_expr_loc (input_location, tmp, 3,
9961 : : gfc_conv_descriptor_data_get (dest),
9962 : : gfc_conv_descriptor_data_get (src),
9963 : : fold_convert (size_type_node, size));
9964 : 40 : gfc_add_expr_to_block (&block, tmp);
9965 : : }
9966 : 55 : gfc_add_expr_to_block (&block, add_when_allocated);
9967 : 55 : tmp = gfc_finish_block (&block);
9968 : :
9969 : : /* Null the destination if the source is null; otherwise do
9970 : : the register and copy. */
9971 : 55 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src)))
9972 : : null_cond = src;
9973 : : else
9974 : 40 : null_cond = gfc_conv_descriptor_data_get (src);
9975 : :
9976 : 55 : null_cond = convert (pvoid_type_node, null_cond);
9977 : 55 : null_cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9978 : : null_cond, null_pointer_node);
9979 : 55 : gfc_add_expr_to_block (&globalblock, build3_v (COND_EXPR, null_cond, tmp,
9980 : : null_data));
9981 : 55 : return gfc_finish_block (&globalblock);
9982 : : }
9983 : :
9984 : :
9985 : : /* Helper function to abstract whether coarray processing is enabled. */
9986 : :
9987 : : static bool
9988 : 73 : caf_enabled (int caf_mode)
9989 : : {
9990 : 73 : return (caf_mode & GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY)
9991 : 73 : == GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY;
9992 : : }
9993 : :
9994 : :
9995 : : /* Helper function to abstract whether coarray processing is enabled
9996 : : and we are in a derived type coarray. */
9997 : :
9998 : : static bool
9999 : 8173 : caf_in_coarray (int caf_mode)
10000 : : {
10001 : 8173 : static const int pat = GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
10002 : : | GFC_STRUCTURE_CAF_MODE_IN_COARRAY;
10003 : 8173 : return (caf_mode & pat) == pat;
10004 : : }
10005 : :
10006 : :
10007 : : /* Helper function to abstract whether coarray is to deallocate only. */
10008 : :
10009 : : bool
10010 : 311 : gfc_caf_is_dealloc_only (int caf_mode)
10011 : : {
10012 : 311 : return (caf_mode & GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY)
10013 : 311 : == GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY;
10014 : : }
10015 : :
10016 : :
10017 : : /* Recursively traverse an object of derived type, generating code to
10018 : : deallocate, nullify or copy allocatable components. This is the work horse
10019 : : function for the functions named in this enum. */
10020 : :
10021 : : enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP,
10022 : : COPY_ALLOC_COMP, COPY_ONLY_ALLOC_COMP, REASSIGN_CAF_COMP,
10023 : : ALLOCATE_PDT_COMP, DEALLOCATE_PDT_COMP, CHECK_PDT_DUMMY,
10024 : : BCAST_ALLOC_COMP};
10025 : :
10026 : : static gfc_actual_arglist *pdt_param_list;
10027 : : static bool generating_copy_helper;
10028 : : static hash_set<gfc_symbol *> seen_derived_types;
10029 : :
10030 : : /* Forward declaration of structure_alloc_comps for wrapper generator. */
10031 : : static tree structure_alloc_comps (gfc_symbol *, tree, tree, int, int, int,
10032 : : gfc_co_subroutines_args *, bool);
10033 : :
10034 : : /* Generate a wrapper function that performs element-wise deep copy for
10035 : : recursive allocatable array components. This wrapper is passed as a
10036 : : function pointer to the runtime helper _gfortran_cfi_deep_copy_array,
10037 : : allowing recursion to happen at runtime instead of compile time. */
10038 : :
10039 : : static tree
10040 : 139 : get_copy_helper_function_type (void)
10041 : : {
10042 : 139 : static tree fn_type = NULL_TREE;
10043 : 139 : if (fn_type == NULL_TREE)
10044 : 26 : fn_type = build_function_type_list (void_type_node,
10045 : : pvoid_type_node,
10046 : : pvoid_type_node,
10047 : : NULL_TREE);
10048 : 139 : return fn_type;
10049 : : }
10050 : :
10051 : : static tree
10052 : 341 : get_copy_helper_pointer_type (void)
10053 : : {
10054 : 341 : static tree ptr_type = NULL_TREE;
10055 : 341 : if (ptr_type == NULL_TREE)
10056 : 26 : ptr_type = build_pointer_type (get_copy_helper_function_type ());
10057 : 341 : return ptr_type;
10058 : : }
10059 : :
10060 : : static tree
10061 : 113 : generate_element_copy_wrapper (gfc_symbol *der_type, tree comp_type,
10062 : : int purpose, int caf_mode)
10063 : : {
10064 : 113 : tree fndecl, fntype, result_decl;
10065 : 113 : tree dest_parm, src_parm, dest_typed, src_typed;
10066 : 113 : tree der_type_ptr;
10067 : 113 : stmtblock_t block;
10068 : 113 : tree decls;
10069 : 113 : tree body;
10070 : :
10071 : 113 : fntype = get_copy_helper_function_type ();
10072 : :
10073 : 113 : fndecl = build_decl (input_location, FUNCTION_DECL,
10074 : : create_tmp_var_name ("copy_element"),
10075 : : fntype);
10076 : :
10077 : 113 : TREE_STATIC (fndecl) = 1;
10078 : 113 : TREE_USED (fndecl) = 1;
10079 : 113 : DECL_ARTIFICIAL (fndecl) = 1;
10080 : 113 : DECL_IGNORED_P (fndecl) = 0;
10081 : 113 : TREE_PUBLIC (fndecl) = 0;
10082 : 113 : DECL_UNINLINABLE (fndecl) = 1;
10083 : 113 : DECL_EXTERNAL (fndecl) = 0;
10084 : 113 : DECL_CONTEXT (fndecl) = NULL_TREE;
10085 : 113 : DECL_INITIAL (fndecl) = make_node (BLOCK);
10086 : 113 : BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
10087 : :
10088 : 113 : result_decl = build_decl (input_location, RESULT_DECL, NULL_TREE,
10089 : : void_type_node);
10090 : 113 : DECL_ARTIFICIAL (result_decl) = 1;
10091 : 113 : DECL_IGNORED_P (result_decl) = 1;
10092 : 113 : DECL_CONTEXT (result_decl) = fndecl;
10093 : 113 : DECL_RESULT (fndecl) = result_decl;
10094 : :
10095 : 113 : dest_parm = build_decl (input_location, PARM_DECL,
10096 : : get_identifier ("dest"), pvoid_type_node);
10097 : 113 : src_parm = build_decl (input_location, PARM_DECL,
10098 : : get_identifier ("src"), pvoid_type_node);
10099 : :
10100 : 113 : DECL_ARTIFICIAL (dest_parm) = 1;
10101 : 113 : DECL_ARTIFICIAL (src_parm) = 1;
10102 : 113 : DECL_ARG_TYPE (dest_parm) = pvoid_type_node;
10103 : 113 : DECL_ARG_TYPE (src_parm) = pvoid_type_node;
10104 : 113 : DECL_CONTEXT (dest_parm) = fndecl;
10105 : 113 : DECL_CONTEXT (src_parm) = fndecl;
10106 : :
10107 : 113 : DECL_ARGUMENTS (fndecl) = dest_parm;
10108 : 113 : TREE_CHAIN (dest_parm) = src_parm;
10109 : :
10110 : 113 : push_struct_function (fndecl);
10111 : 113 : cfun->function_end_locus = input_location;
10112 : :
10113 : 113 : pushlevel ();
10114 : 113 : gfc_init_block (&block);
10115 : :
10116 : 113 : bool saved_generating = generating_copy_helper;
10117 : 113 : generating_copy_helper = true;
10118 : :
10119 : : /* When generating a wrapper, we need a fresh type tracking state to
10120 : : avoid inheriting the parent context's seen_derived_types, which would
10121 : : cause infinite recursion when the wrapper tries to handle the same
10122 : : recursive type. Save elements, clear the set, generate wrapper, then
10123 : : restore elements. */
10124 : 113 : vec<gfc_symbol *> saved_symbols = vNULL;
10125 : 113 : for (hash_set<gfc_symbol *>::iterator it = seen_derived_types.begin ();
10126 : 375 : it != seen_derived_types.end (); ++it)
10127 : 131 : saved_symbols.safe_push (*it);
10128 : 113 : seen_derived_types.empty ();
10129 : :
10130 : 113 : der_type_ptr = build_pointer_type (comp_type);
10131 : 113 : dest_typed = fold_convert (der_type_ptr, dest_parm);
10132 : 113 : src_typed = fold_convert (der_type_ptr, src_parm);
10133 : :
10134 : 113 : dest_typed = build_fold_indirect_ref (dest_typed);
10135 : 113 : src_typed = build_fold_indirect_ref (src_typed);
10136 : :
10137 : 113 : body = structure_alloc_comps (der_type, src_typed, dest_typed,
10138 : : 0, purpose, caf_mode, NULL, false);
10139 : 113 : gfc_add_expr_to_block (&block, body);
10140 : :
10141 : : /* Restore saved symbols. */
10142 : 113 : seen_derived_types.empty ();
10143 : 244 : for (unsigned i = 0; i < saved_symbols.length (); i++)
10144 : 131 : seen_derived_types.add (saved_symbols[i]);
10145 : 113 : saved_symbols.release ();
10146 : 113 : generating_copy_helper = saved_generating;
10147 : :
10148 : 113 : body = gfc_finish_block (&block);
10149 : 113 : decls = getdecls ();
10150 : :
10151 : 113 : poplevel (1, 1);
10152 : :
10153 : 226 : DECL_SAVED_TREE (fndecl)
10154 : 113 : = fold_build3_loc (DECL_SOURCE_LOCATION (fndecl), BIND_EXPR,
10155 : 113 : void_type_node, decls, body, DECL_INITIAL (fndecl));
10156 : :
10157 : 113 : pop_cfun ();
10158 : :
10159 : 113 : cgraph_node::add_new_function (fndecl, false);
10160 : :
10161 : 113 : return build1 (ADDR_EXPR, get_copy_helper_pointer_type (), fndecl);
10162 : : }
10163 : :
10164 : : static tree
10165 : 17436 : structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
10166 : : int rank, int purpose, int caf_mode,
10167 : : gfc_co_subroutines_args *args,
10168 : : bool no_finalization = false)
10169 : : {
10170 : 17436 : gfc_component *c;
10171 : 17436 : gfc_loopinfo loop;
10172 : 17436 : stmtblock_t fnblock;
10173 : 17436 : stmtblock_t loopbody;
10174 : 17436 : stmtblock_t tmpblock;
10175 : 17436 : tree decl_type;
10176 : 17436 : tree tmp;
10177 : 17436 : tree comp;
10178 : 17436 : tree dcmp;
10179 : 17436 : tree nelems;
10180 : 17436 : tree index;
10181 : 17436 : tree var;
10182 : 17436 : tree cdecl;
10183 : 17436 : tree ctype;
10184 : 17436 : tree vref, dref;
10185 : 17436 : tree null_cond = NULL_TREE;
10186 : 17436 : tree add_when_allocated;
10187 : 17436 : tree dealloc_fndecl;
10188 : 17436 : tree caf_token;
10189 : 17436 : gfc_symbol *vtab;
10190 : 17436 : int caf_dereg_mode;
10191 : 17436 : symbol_attribute *attr;
10192 : 17436 : bool deallocate_called;
10193 : :
10194 : 17436 : gfc_init_block (&fnblock);
10195 : :
10196 : 17436 : decl_type = TREE_TYPE (decl);
10197 : :
10198 : 17436 : if ((POINTER_TYPE_P (decl_type))
10199 : : || (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == 0))
10200 : : {
10201 : 1373 : decl = build_fold_indirect_ref_loc (input_location, decl);
10202 : : /* Deref dest in sync with decl, but only when it is not NULL. */
10203 : 1373 : if (dest)
10204 : 109 : dest = build_fold_indirect_ref_loc (input_location, dest);
10205 : :
10206 : : /* Update the decl_type because it got dereferenced. */
10207 : 1373 : decl_type = TREE_TYPE (decl);
10208 : : }
10209 : :
10210 : : /* If this is an array of derived types with allocatable components
10211 : : build a loop and recursively call this function. */
10212 : 17436 : if (TREE_CODE (decl_type) == ARRAY_TYPE
10213 : 17436 : || (GFC_DESCRIPTOR_TYPE_P (decl_type) && rank != 0))
10214 : : {
10215 : 2763 : tmp = gfc_conv_array_data (decl);
10216 : 2763 : var = build_fold_indirect_ref_loc (input_location, tmp);
10217 : :
10218 : : /* Get the number of elements - 1 and set the counter. */
10219 : 2763 : if (GFC_DESCRIPTOR_TYPE_P (decl_type))
10220 : : {
10221 : : /* Use the descriptor for an allocatable array. Since this
10222 : : is a full array reference, we only need the descriptor
10223 : : information from dimension = rank. */
10224 : 1905 : tmp = gfc_full_array_size (&fnblock, decl, rank);
10225 : 1905 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
10226 : : gfc_array_index_type, tmp,
10227 : : gfc_index_one_node);
10228 : :
10229 : 1905 : null_cond = gfc_conv_descriptor_data_get (decl);
10230 : 1905 : null_cond = fold_build2_loc (input_location, NE_EXPR,
10231 : : logical_type_node, null_cond,
10232 : 1905 : build_int_cst (TREE_TYPE (null_cond), 0));
10233 : : }
10234 : : else
10235 : : {
10236 : : /* Otherwise use the TYPE_DOMAIN information. */
10237 : 858 : tmp = array_type_nelts_minus_one (decl_type);
10238 : 858 : tmp = fold_convert (gfc_array_index_type, tmp);
10239 : : }
10240 : :
10241 : : /* Remember that this is, in fact, the no. of elements - 1. */
10242 : 2763 : nelems = gfc_evaluate_now (tmp, &fnblock);
10243 : 2763 : index = gfc_create_var (gfc_array_index_type, "S");
10244 : :
10245 : : /* Build the body of the loop. */
10246 : 2763 : gfc_init_block (&loopbody);
10247 : :
10248 : 2763 : vref = gfc_build_array_ref (var, index, NULL);
10249 : :
10250 : 2763 : if (purpose == COPY_ALLOC_COMP || purpose == COPY_ONLY_ALLOC_COMP)
10251 : : {
10252 : 491 : tmp = build_fold_indirect_ref_loc (input_location,
10253 : : gfc_conv_array_data (dest));
10254 : 491 : dref = gfc_build_array_ref (tmp, index, NULL);
10255 : 491 : tmp = structure_alloc_comps (der_type, vref, dref, rank,
10256 : : COPY_ALLOC_COMP, caf_mode, args,
10257 : : no_finalization);
10258 : : }
10259 : : else
10260 : 2272 : tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose,
10261 : : caf_mode, args, no_finalization);
10262 : :
10263 : 2763 : gfc_add_expr_to_block (&loopbody, tmp);
10264 : :
10265 : : /* Build the loop and return. */
10266 : 2763 : gfc_init_loopinfo (&loop);
10267 : 2763 : loop.dimen = 1;
10268 : 2763 : loop.from[0] = gfc_index_zero_node;
10269 : 2763 : loop.loopvar[0] = index;
10270 : 2763 : loop.to[0] = nelems;
10271 : 2763 : gfc_trans_scalarizing_loops (&loop, &loopbody);
10272 : 2763 : gfc_add_block_to_block (&fnblock, &loop.pre);
10273 : :
10274 : 2763 : tmp = gfc_finish_block (&fnblock);
10275 : : /* When copying allocateable components, the above implements the
10276 : : deep copy. Nevertheless is a deep copy only allowed, when the current
10277 : : component is allocated, for which code will be generated in
10278 : : gfc_duplicate_allocatable (), where the deep copy code is just added
10279 : : into the if's body, by adding tmp (the deep copy code) as last
10280 : : argument to gfc_duplicate_allocatable (). */
10281 : 2763 : if (purpose == COPY_ALLOC_COMP && caf_mode == 0
10282 : 2763 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
10283 : 414 : tmp = gfc_duplicate_allocatable (dest, decl, decl_type, rank,
10284 : : tmp);
10285 : 2349 : else if (null_cond != NULL_TREE)
10286 : 1491 : tmp = build3_v (COND_EXPR, null_cond, tmp,
10287 : : build_empty_stmt (input_location));
10288 : :
10289 : 2763 : return tmp;
10290 : : }
10291 : :
10292 : 14673 : if (purpose == DEALLOCATE_ALLOC_COMP && der_type->attr.pdt_type)
10293 : : {
10294 : 141 : tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
10295 : : DEALLOCATE_PDT_COMP, 0, args,
10296 : : no_finalization);
10297 : 141 : gfc_add_expr_to_block (&fnblock, tmp);
10298 : : }
10299 : 14532 : else if (purpose == ALLOCATE_PDT_COMP && der_type->attr.alloc_comp)
10300 : : {
10301 : 66 : tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
10302 : : NULLIFY_ALLOC_COMP, 0, args,
10303 : : no_finalization);
10304 : 66 : gfc_add_expr_to_block (&fnblock, tmp);
10305 : : }
10306 : :
10307 : : /* Still having a descriptor array of rank == 0 here, indicates an
10308 : : allocatable coarrays. Dereference it correctly. */
10309 : 14673 : if (GFC_DESCRIPTOR_TYPE_P (decl_type))
10310 : : {
10311 : 5 : decl = build_fold_indirect_ref (gfc_conv_array_data (decl));
10312 : : }
10313 : : /* Otherwise, act on the components or recursively call self to
10314 : : act on a chain of components. */
10315 : 14673 : seen_derived_types.add (der_type);
10316 : 41435 : for (c = der_type->components; c; c = c->next)
10317 : : {
10318 : 26762 : bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED
10319 : 26762 : || c->ts.type == BT_CLASS)
10320 : 26762 : && c->ts.u.derived->attr.alloc_comp;
10321 : 26762 : bool same_type
10322 : : = (c->ts.type == BT_DERIVED
10323 : 5490 : && seen_derived_types.contains (c->ts.u.derived))
10324 : 30870 : || (c->ts.type == BT_CLASS
10325 : 2184 : && seen_derived_types.contains (CLASS_DATA (c)->ts.u.derived));
10326 : 26762 : bool inside_wrapper = generating_copy_helper;
10327 : :
10328 : 53524 : bool is_pdt_type = c->ts.type == BT_DERIVED
10329 : 26762 : && c->ts.u.derived->attr.pdt_type;
10330 : :
10331 : 26762 : cdecl = c->backend_decl;
10332 : 26762 : ctype = TREE_TYPE (cdecl);
10333 : :
10334 : 26762 : switch (purpose)
10335 : : {
10336 : :
10337 : 3 : case BCAST_ALLOC_COMP:
10338 : :
10339 : 3 : tree ubound;
10340 : 3 : tree cdesc;
10341 : 3 : stmtblock_t derived_type_block;
10342 : :
10343 : 3 : gfc_init_block (&tmpblock);
10344 : :
10345 : 3 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10346 : : decl, cdecl, NULL_TREE);
10347 : :
10348 : : /* Shortcut to get the attributes of the component. */
10349 : 3 : if (c->ts.type == BT_CLASS)
10350 : : {
10351 : 0 : attr = &CLASS_DATA (c)->attr;
10352 : 0 : if (attr->class_pointer)
10353 : 0 : continue;
10354 : : }
10355 : : else
10356 : : {
10357 : 3 : attr = &c->attr;
10358 : 3 : if (attr->pointer)
10359 : 0 : continue;
10360 : : }
10361 : :
10362 : : /* Do not broadcast a caf_token. These are local to the image. */
10363 : 3 : if (attr->caf_token)
10364 : 1 : continue;
10365 : :
10366 : 2 : add_when_allocated = NULL_TREE;
10367 : 2 : if (cmp_has_alloc_comps
10368 : 0 : && !c->attr.pointer && !c->attr.proc_pointer)
10369 : : {
10370 : 0 : if (c->ts.type == BT_CLASS)
10371 : : {
10372 : 0 : rank = CLASS_DATA (c)->as ? CLASS_DATA (c)->as->rank : 0;
10373 : 0 : add_when_allocated
10374 : 0 : = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
10375 : : comp, NULL_TREE, rank, purpose,
10376 : : caf_mode, args, no_finalization);
10377 : : }
10378 : : else
10379 : : {
10380 : 0 : rank = c->as ? c->as->rank : 0;
10381 : 0 : add_when_allocated = structure_alloc_comps (c->ts.u.derived,
10382 : : comp, NULL_TREE,
10383 : : rank, purpose,
10384 : : caf_mode, args,
10385 : : no_finalization);
10386 : : }
10387 : : }
10388 : :
10389 : 2 : gfc_init_block (&derived_type_block);
10390 : 2 : if (add_when_allocated)
10391 : 0 : gfc_add_expr_to_block (&derived_type_block, add_when_allocated);
10392 : 2 : tmp = gfc_finish_block (&derived_type_block);
10393 : 2 : gfc_add_expr_to_block (&tmpblock, tmp);
10394 : :
10395 : : /* Convert the component into a rank 1 descriptor type. */
10396 : 2 : if (attr->dimension)
10397 : : {
10398 : 0 : tmp = gfc_get_element_type (TREE_TYPE (comp));
10399 : 0 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
10400 : 0 : ubound = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (comp));
10401 : : else
10402 : 0 : ubound = gfc_full_array_size (&tmpblock, comp,
10403 : 0 : c->ts.type == BT_CLASS
10404 : 0 : ? CLASS_DATA (c)->as->rank
10405 : 0 : : c->as->rank);
10406 : : }
10407 : : else
10408 : : {
10409 : 2 : tmp = TREE_TYPE (comp);
10410 : 2 : ubound = build_int_cst (gfc_array_index_type, 1);
10411 : : }
10412 : :
10413 : : /* Treat strings like arrays. Or the other way around, do not
10414 : : * generate an additional array layer for scalar components. */
10415 : 2 : if (attr->dimension || c->ts.type == BT_CHARACTER)
10416 : : {
10417 : 0 : cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node,
10418 : : &ubound, 1,
10419 : : GFC_ARRAY_ALLOCATABLE, false);
10420 : :
10421 : 0 : cdesc = gfc_create_var (cdesc, "cdesc");
10422 : 0 : DECL_ARTIFICIAL (cdesc) = 1;
10423 : :
10424 : 0 : gfc_add_modify (&tmpblock, gfc_conv_descriptor_dtype (cdesc),
10425 : : gfc_get_dtype_rank_type (1, tmp));
10426 : 0 : gfc_conv_descriptor_lbound_set (&tmpblock, cdesc,
10427 : : gfc_index_zero_node,
10428 : : gfc_index_one_node);
10429 : 0 : gfc_conv_descriptor_stride_set (&tmpblock, cdesc,
10430 : : gfc_index_zero_node,
10431 : : gfc_index_one_node);
10432 : 0 : gfc_conv_descriptor_ubound_set (&tmpblock, cdesc,
10433 : : gfc_index_zero_node, ubound);
10434 : : }
10435 : : else
10436 : : /* Prevent warning. */
10437 : : cdesc = NULL_TREE;
10438 : :
10439 : 2 : if (attr->dimension)
10440 : : {
10441 : 0 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
10442 : 0 : comp = gfc_conv_descriptor_data_get (comp);
10443 : : else
10444 : 0 : comp = gfc_build_addr_expr (NULL_TREE, comp);
10445 : : }
10446 : : else
10447 : : {
10448 : 2 : gfc_se se;
10449 : :
10450 : 2 : gfc_init_se (&se, NULL);
10451 : :
10452 : 2 : comp = gfc_conv_scalar_to_descriptor (&se, comp,
10453 : 2 : c->ts.type == BT_CLASS
10454 : 2 : ? CLASS_DATA (c)->attr
10455 : : : c->attr);
10456 : 2 : if (c->ts.type == BT_CHARACTER)
10457 : 0 : comp = gfc_build_addr_expr (NULL_TREE, comp);
10458 : 2 : gfc_add_block_to_block (&tmpblock, &se.pre);
10459 : : }
10460 : :
10461 : 2 : if (attr->dimension || c->ts.type == BT_CHARACTER)
10462 : 0 : gfc_conv_descriptor_data_set (&tmpblock, cdesc, comp);
10463 : : else
10464 : 2 : cdesc = comp;
10465 : :
10466 : 2 : tree fndecl;
10467 : :
10468 : 2 : fndecl = build_call_expr_loc (input_location,
10469 : : gfor_fndecl_co_broadcast, 5,
10470 : : gfc_build_addr_expr (pvoid_type_node,cdesc),
10471 : : args->image_index,
10472 : : null_pointer_node, null_pointer_node,
10473 : : null_pointer_node);
10474 : :
10475 : 2 : gfc_add_expr_to_block (&tmpblock, fndecl);
10476 : 2 : gfc_add_block_to_block (&fnblock, &tmpblock);
10477 : :
10478 : 21911 : break;
10479 : :
10480 : 10418 : case DEALLOCATE_ALLOC_COMP:
10481 : :
10482 : 10418 : gfc_init_block (&tmpblock);
10483 : :
10484 : 10418 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10485 : : decl, cdecl, NULL_TREE);
10486 : :
10487 : : /* Shortcut to get the attributes of the component. */
10488 : 10418 : if (c->ts.type == BT_CLASS)
10489 : : {
10490 : 1008 : attr = &CLASS_DATA (c)->attr;
10491 : 1008 : if (attr->class_pointer || c->attr.proc_pointer)
10492 : 18 : continue;
10493 : : }
10494 : : else
10495 : : {
10496 : 9410 : attr = &c->attr;
10497 : 9410 : if (attr->pointer || attr->proc_pointer)
10498 : 130 : continue;
10499 : : }
10500 : :
10501 : 10270 : if (!no_finalization && ((c->ts.type == BT_DERIVED && !c->attr.pointer)
10502 : 7826 : || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer)))
10503 : : /* Call the finalizer, which will free the memory and nullify the
10504 : : pointer of an array. */
10505 : 2980 : deallocate_called = gfc_add_comp_finalizer_call (&tmpblock, comp, c,
10506 : 2980 : caf_enabled (caf_mode))
10507 : 2980 : && attr->dimension;
10508 : : else
10509 : : deallocate_called = false;
10510 : :
10511 : : /* Add the _class ref for classes. */
10512 : 10270 : if (c->ts.type == BT_CLASS && attr->allocatable)
10513 : 990 : comp = gfc_class_data_get (comp);
10514 : :
10515 : 10270 : add_when_allocated = NULL_TREE;
10516 : 10270 : if (cmp_has_alloc_comps
10517 : 2163 : && !c->attr.pointer && !c->attr.proc_pointer
10518 : : && !same_type
10519 : 2163 : && !deallocate_called)
10520 : : {
10521 : : /* Add checked deallocation of the components. This code is
10522 : : obviously added because the finalizer is not trusted to free
10523 : : all memory. */
10524 : 1265 : if (c->ts.type == BT_CLASS)
10525 : : {
10526 : 241 : rank = CLASS_DATA (c)->as ? CLASS_DATA (c)->as->rank : 0;
10527 : 241 : add_when_allocated
10528 : 241 : = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
10529 : : comp, NULL_TREE, rank, purpose,
10530 : : caf_mode, args, no_finalization);
10531 : : }
10532 : : else
10533 : : {
10534 : 1024 : rank = c->as ? c->as->rank : 0;
10535 : 1024 : add_when_allocated = structure_alloc_comps (c->ts.u.derived,
10536 : : comp, NULL_TREE,
10537 : : rank, purpose,
10538 : : caf_mode, args,
10539 : : no_finalization);
10540 : : }
10541 : : }
10542 : :
10543 : 6972 : if (attr->allocatable && !same_type
10544 : 16524 : && (!attr->codimension || caf_enabled (caf_mode)))
10545 : : {
10546 : : /* Handle all types of components besides components of the
10547 : : same_type as the current one, because those would create an
10548 : : endless loop. */
10549 : 45 : caf_dereg_mode = (caf_in_coarray (caf_mode)
10550 : 51 : && (attr->dimension || c->caf_token))
10551 : 6198 : || attr->codimension
10552 : 6319 : ? (gfc_caf_is_dealloc_only (caf_mode)
10553 : : ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
10554 : : : GFC_CAF_COARRAY_DEREGISTER)
10555 : : : GFC_CAF_COARRAY_NOCOARRAY;
10556 : :
10557 : 6248 : caf_token = NULL_TREE;
10558 : : /* Coarray components are handled directly by
10559 : : deallocate_with_status. */
10560 : 6248 : if (!attr->codimension
10561 : 6227 : && caf_dereg_mode != GFC_CAF_COARRAY_NOCOARRAY)
10562 : : {
10563 : 50 : if (c->caf_token)
10564 : 16 : caf_token
10565 : 16 : = fold_build3_loc (input_location, COMPONENT_REF,
10566 : 16 : TREE_TYPE (gfc_comp_caf_token (c)),
10567 : : decl, gfc_comp_caf_token (c),
10568 : : NULL_TREE);
10569 : 34 : else if (attr->dimension && !attr->proc_pointer)
10570 : 34 : caf_token = gfc_conv_descriptor_token (comp);
10571 : : }
10572 : :
10573 : 6248 : tmp = gfc_deallocate_with_status (comp, NULL_TREE, NULL_TREE,
10574 : : NULL_TREE, NULL_TREE, true,
10575 : : NULL, caf_dereg_mode, NULL_TREE,
10576 : : add_when_allocated, caf_token);
10577 : :
10578 : 6248 : gfc_add_expr_to_block (&tmpblock, tmp);
10579 : : }
10580 : 4022 : else if (attr->allocatable && !attr->codimension
10581 : 718 : && !deallocate_called)
10582 : : {
10583 : : /* Case of recursive allocatable derived types. */
10584 : 718 : tree is_allocated;
10585 : 718 : tree ubound;
10586 : 718 : tree cdesc;
10587 : 718 : stmtblock_t dealloc_block;
10588 : :
10589 : 718 : gfc_init_block (&dealloc_block);
10590 : 718 : if (add_when_allocated)
10591 : 0 : gfc_add_expr_to_block (&dealloc_block, add_when_allocated);
10592 : :
10593 : : /* Convert the component into a rank 1 descriptor type. */
10594 : 718 : if (attr->dimension)
10595 : : {
10596 : 112 : tmp = gfc_get_element_type (TREE_TYPE (comp));
10597 : 112 : ubound = gfc_full_array_size (&dealloc_block, comp,
10598 : 112 : c->ts.type == BT_CLASS
10599 : 0 : ? CLASS_DATA (c)->as->rank
10600 : 112 : : c->as->rank);
10601 : : }
10602 : : else
10603 : : {
10604 : 606 : tmp = TREE_TYPE (comp);
10605 : 606 : ubound = build_int_cst (gfc_array_index_type, 1);
10606 : : }
10607 : :
10608 : 718 : cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node,
10609 : : &ubound, 1,
10610 : : GFC_ARRAY_ALLOCATABLE, false);
10611 : :
10612 : 718 : cdesc = gfc_create_var (cdesc, "cdesc");
10613 : 718 : DECL_ARTIFICIAL (cdesc) = 1;
10614 : :
10615 : 718 : gfc_add_modify (&dealloc_block, gfc_conv_descriptor_dtype (cdesc),
10616 : : gfc_get_dtype_rank_type (1, tmp));
10617 : 718 : gfc_conv_descriptor_lbound_set (&dealloc_block, cdesc,
10618 : : gfc_index_zero_node,
10619 : : gfc_index_one_node);
10620 : 718 : gfc_conv_descriptor_stride_set (&dealloc_block, cdesc,
10621 : : gfc_index_zero_node,
10622 : : gfc_index_one_node);
10623 : 718 : gfc_conv_descriptor_ubound_set (&dealloc_block, cdesc,
10624 : : gfc_index_zero_node, ubound);
10625 : :
10626 : 718 : if (attr->dimension)
10627 : 112 : comp = gfc_conv_descriptor_data_get (comp);
10628 : :
10629 : 718 : gfc_conv_descriptor_data_set (&dealloc_block, cdesc, comp);
10630 : :
10631 : : /* Now call the deallocator. */
10632 : 718 : vtab = gfc_find_vtab (&c->ts);
10633 : 718 : if (vtab->backend_decl == NULL)
10634 : 41 : gfc_get_symbol_decl (vtab);
10635 : 718 : tmp = gfc_build_addr_expr (NULL_TREE, vtab->backend_decl);
10636 : 718 : dealloc_fndecl = gfc_vptr_deallocate_get (tmp);
10637 : 718 : dealloc_fndecl = build_fold_indirect_ref_loc (input_location,
10638 : : dealloc_fndecl);
10639 : 718 : tmp = build_int_cst (TREE_TYPE (comp), 0);
10640 : 718 : is_allocated = fold_build2_loc (input_location, NE_EXPR,
10641 : : logical_type_node, tmp,
10642 : : comp);
10643 : 718 : cdesc = gfc_build_addr_expr (NULL_TREE, cdesc);
10644 : :
10645 : 718 : tmp = build_call_expr_loc (input_location,
10646 : : dealloc_fndecl, 1,
10647 : : cdesc);
10648 : 718 : gfc_add_expr_to_block (&dealloc_block, tmp);
10649 : :
10650 : 718 : tmp = gfc_finish_block (&dealloc_block);
10651 : :
10652 : 718 : tmp = fold_build3_loc (input_location, COND_EXPR,
10653 : : void_type_node, is_allocated, tmp,
10654 : : build_empty_stmt (input_location));
10655 : :
10656 : 718 : gfc_add_expr_to_block (&tmpblock, tmp);
10657 : 718 : }
10658 : 3304 : else if (add_when_allocated)
10659 : 525 : gfc_add_expr_to_block (&tmpblock, add_when_allocated);
10660 : :
10661 : 990 : if (c->ts.type == BT_CLASS && attr->allocatable
10662 : 11260 : && (!attr->codimension || !caf_enabled (caf_mode)))
10663 : : {
10664 : : /* Finally, reset the vptr to the declared type vtable and, if
10665 : : necessary reset the _len field.
10666 : :
10667 : : First recover the reference to the component and obtain
10668 : : the vptr. */
10669 : 975 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10670 : : decl, cdecl, NULL_TREE);
10671 : 975 : tmp = gfc_class_vptr_get (comp);
10672 : :
10673 : 975 : if (UNLIMITED_POLY (c))
10674 : : {
10675 : : /* Both vptr and _len field should be nulled. */
10676 : 211 : gfc_add_modify (&tmpblock, tmp,
10677 : 211 : build_int_cst (TREE_TYPE (tmp), 0));
10678 : 211 : tmp = gfc_class_len_get (comp);
10679 : 211 : gfc_add_modify (&tmpblock, tmp,
10680 : 211 : build_int_cst (TREE_TYPE (tmp), 0));
10681 : : }
10682 : : else
10683 : : {
10684 : : /* Build the vtable address and set the vptr with it. */
10685 : 764 : gfc_reset_vptr (&tmpblock, nullptr, tmp, c->ts.u.derived);
10686 : : }
10687 : : }
10688 : :
10689 : : /* Now add the deallocation of this component. */
10690 : 10270 : gfc_add_block_to_block (&fnblock, &tmpblock);
10691 : 10270 : break;
10692 : :
10693 : 4136 : case NULLIFY_ALLOC_COMP:
10694 : : /* Nullify
10695 : : - allocatable components (regular or in class)
10696 : : - components that have allocatable components
10697 : : - pointer components when in a coarray.
10698 : : Skip everything else especially proc_pointers, which may come
10699 : : coupled with the regular pointer attribute. */
10700 : 5504 : if (c->attr.proc_pointer
10701 : 4136 : || !(c->attr.allocatable || (c->ts.type == BT_CLASS
10702 : 424 : && CLASS_DATA (c)->attr.allocatable)
10703 : 1686 : || (cmp_has_alloc_comps
10704 : 234 : && ((c->ts.type == BT_DERIVED && !c->attr.pointer)
10705 : 18 : || (c->ts.type == BT_CLASS
10706 : 12 : && !CLASS_DATA (c)->attr.class_pointer)))
10707 : 1470 : || (caf_in_coarray (caf_mode) && c->attr.pointer)))
10708 : 1368 : continue;
10709 : :
10710 : : /* Process class components first, because they always have the
10711 : : pointer-attribute set which would be caught wrong else. */
10712 : 2768 : if (c->ts.type == BT_CLASS
10713 : 411 : && (CLASS_DATA (c)->attr.allocatable
10714 : 0 : || CLASS_DATA (c)->attr.class_pointer))
10715 : : {
10716 : 411 : tree class_ref;
10717 : :
10718 : : /* Allocatable CLASS components. */
10719 : 411 : class_ref = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10720 : : decl, cdecl, NULL_TREE);
10721 : :
10722 : 411 : comp = gfc_class_data_get (class_ref);
10723 : 411 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
10724 : 215 : gfc_conv_descriptor_data_set (&fnblock, comp,
10725 : : null_pointer_node);
10726 : : else
10727 : : {
10728 : 196 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
10729 : : void_type_node, comp,
10730 : 196 : build_int_cst (TREE_TYPE (comp), 0));
10731 : 196 : gfc_add_expr_to_block (&fnblock, tmp);
10732 : : }
10733 : :
10734 : : /* The dynamic type of a disassociated pointer or unallocated
10735 : : allocatable variable is its declared type. An unlimited
10736 : : polymorphic entity has no declared type. */
10737 : 411 : gfc_reset_vptr (&fnblock, nullptr, class_ref, c->ts.u.derived);
10738 : :
10739 : 411 : cmp_has_alloc_comps = false;
10740 : 411 : }
10741 : : /* Coarrays need the component to be nulled before the api-call
10742 : : is made. */
10743 : 2357 : else if (c->attr.pointer || c->attr.allocatable)
10744 : : {
10745 : 2141 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10746 : : decl, cdecl, NULL_TREE);
10747 : 2141 : if (c->attr.dimension || c->attr.codimension)
10748 : 1466 : gfc_conv_descriptor_data_set (&fnblock, comp,
10749 : : null_pointer_node);
10750 : : else
10751 : 675 : gfc_add_modify (&fnblock, comp,
10752 : 675 : build_int_cst (TREE_TYPE (comp), 0));
10753 : 2141 : if (gfc_deferred_strlen (c, &comp))
10754 : : {
10755 : 262 : comp = fold_build3_loc (input_location, COMPONENT_REF,
10756 : 262 : TREE_TYPE (comp),
10757 : : decl, comp, NULL_TREE);
10758 : 524 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
10759 : 262 : TREE_TYPE (comp), comp,
10760 : 262 : build_int_cst (TREE_TYPE (comp), 0));
10761 : 262 : gfc_add_expr_to_block (&fnblock, tmp);
10762 : : }
10763 : : cmp_has_alloc_comps = false;
10764 : : }
10765 : :
10766 : 2768 : if (flag_coarray == GFC_FCOARRAY_LIB && caf_in_coarray (caf_mode))
10767 : : {
10768 : : /* Register a component of a derived type coarray with the
10769 : : coarray library. Do not register ultimate component
10770 : : coarrays here. They are treated like regular coarrays and
10771 : : are either allocated on all images or on none. */
10772 : 126 : tree token;
10773 : :
10774 : 126 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10775 : : decl, cdecl, NULL_TREE);
10776 : 126 : if (c->attr.dimension)
10777 : : {
10778 : : /* Set the dtype, because caf_register needs it. */
10779 : 100 : gfc_add_modify (&fnblock, gfc_conv_descriptor_dtype (comp),
10780 : 100 : gfc_get_dtype (TREE_TYPE (comp)));
10781 : 100 : tmp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10782 : : decl, cdecl, NULL_TREE);
10783 : 100 : token = gfc_conv_descriptor_token (tmp);
10784 : : }
10785 : : else
10786 : : {
10787 : 26 : gfc_se se;
10788 : :
10789 : 26 : gfc_init_se (&se, NULL);
10790 : 52 : token = fold_build3_loc (input_location, COMPONENT_REF,
10791 : : pvoid_type_node, decl,
10792 : 26 : gfc_comp_caf_token (c), NULL_TREE);
10793 : 26 : comp = gfc_conv_scalar_to_descriptor (&se, comp,
10794 : 26 : c->ts.type == BT_CLASS
10795 : 26 : ? CLASS_DATA (c)->attr
10796 : : : c->attr);
10797 : 26 : gfc_add_block_to_block (&fnblock, &se.pre);
10798 : : }
10799 : :
10800 : 126 : gfc_allocate_using_caf_lib (&fnblock, comp, size_zero_node,
10801 : : gfc_build_addr_expr (NULL_TREE,
10802 : : token),
10803 : : NULL_TREE, NULL_TREE, NULL_TREE,
10804 : : GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
10805 : : }
10806 : :
10807 : 2768 : if (cmp_has_alloc_comps)
10808 : : {
10809 : 216 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10810 : : decl, cdecl, NULL_TREE);
10811 : 216 : rank = c->as ? c->as->rank : 0;
10812 : 216 : tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
10813 : : rank, purpose, caf_mode, args,
10814 : : no_finalization);
10815 : 216 : gfc_add_expr_to_block (&fnblock, tmp);
10816 : : }
10817 : : break;
10818 : :
10819 : 29 : case REASSIGN_CAF_COMP:
10820 : 29 : if (caf_enabled (caf_mode)
10821 : 29 : && (c->attr.codimension
10822 : 23 : || (c->ts.type == BT_CLASS
10823 : 2 : && (CLASS_DATA (c)->attr.coarray_comp
10824 : 2 : || caf_in_coarray (caf_mode)))
10825 : 21 : || (c->ts.type == BT_DERIVED
10826 : 7 : && (c->ts.u.derived->attr.coarray_comp
10827 : 6 : || caf_in_coarray (caf_mode))))
10828 : 44 : && !same_type)
10829 : : {
10830 : 13 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10831 : : decl, cdecl, NULL_TREE);
10832 : 13 : dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10833 : : dest, cdecl, NULL_TREE);
10834 : :
10835 : 13 : if (c->attr.codimension)
10836 : : {
10837 : 6 : if (c->ts.type == BT_CLASS)
10838 : : {
10839 : 0 : comp = gfc_class_data_get (comp);
10840 : 0 : dcmp = gfc_class_data_get (dcmp);
10841 : : }
10842 : 6 : gfc_conv_descriptor_data_set (&fnblock, dcmp,
10843 : : gfc_conv_descriptor_data_get (comp));
10844 : : }
10845 : : else
10846 : : {
10847 : 7 : tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
10848 : : rank, purpose, caf_mode
10849 : : | GFC_STRUCTURE_CAF_MODE_IN_COARRAY,
10850 : : args, no_finalization);
10851 : 7 : gfc_add_expr_to_block (&fnblock, tmp);
10852 : : }
10853 : : }
10854 : : break;
10855 : :
10856 : 8706 : case COPY_ALLOC_COMP:
10857 : 8706 : if (c->attr.pointer || c->attr.proc_pointer)
10858 : 159 : continue;
10859 : :
10860 : : /* We need source and destination components. */
10861 : 8547 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl,
10862 : : cdecl, NULL_TREE);
10863 : 8547 : dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, dest,
10864 : : cdecl, NULL_TREE);
10865 : 8547 : dcmp = fold_convert (TREE_TYPE (comp), dcmp);
10866 : :
10867 : 8547 : if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pdt_type
10868 : 68 : && !c->attr.allocatable)
10869 : : {
10870 : 47 : tmp = gfc_copy_alloc_comp (c->ts.u.derived, comp, dcmp,
10871 : : 0, 0);
10872 : 47 : gfc_add_expr_to_block (&fnblock, tmp);
10873 : 47 : continue;
10874 : : }
10875 : :
10876 : 8500 : if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
10877 : : {
10878 : 722 : tree ftn_tree;
10879 : 722 : tree size;
10880 : 722 : tree dst_data;
10881 : 722 : tree src_data;
10882 : 722 : tree null_data;
10883 : :
10884 : 722 : dst_data = gfc_class_data_get (dcmp);
10885 : 722 : src_data = gfc_class_data_get (comp);
10886 : 722 : size = fold_convert (size_type_node,
10887 : : gfc_class_vtab_size_get (comp));
10888 : :
10889 : 722 : if (CLASS_DATA (c)->attr.dimension)
10890 : : {
10891 : 704 : nelems = gfc_conv_descriptor_size (src_data,
10892 : 352 : CLASS_DATA (c)->as->rank);
10893 : 352 : size = fold_build2_loc (input_location, MULT_EXPR,
10894 : : size_type_node, size,
10895 : : fold_convert (size_type_node,
10896 : : nelems));
10897 : : }
10898 : : else
10899 : 370 : nelems = build_int_cst (size_type_node, 1);
10900 : :
10901 : 722 : if (CLASS_DATA (c)->attr.dimension
10902 : 370 : || CLASS_DATA (c)->attr.codimension)
10903 : : {
10904 : 360 : src_data = gfc_conv_descriptor_data_get (src_data);
10905 : 360 : dst_data = gfc_conv_descriptor_data_get (dst_data);
10906 : : }
10907 : :
10908 : 722 : gfc_init_block (&tmpblock);
10909 : :
10910 : 722 : gfc_add_modify (&tmpblock, gfc_class_vptr_get (dcmp),
10911 : : gfc_class_vptr_get (comp));
10912 : :
10913 : : /* Copy the unlimited '_len' field. If it is greater than zero
10914 : : (ie. a character(_len)), multiply it by size and use this
10915 : : for the malloc call. */
10916 : 722 : if (UNLIMITED_POLY (c))
10917 : : {
10918 : 135 : gfc_add_modify (&tmpblock, gfc_class_len_get (dcmp),
10919 : : gfc_class_len_get (comp));
10920 : 135 : size = gfc_resize_class_size_with_len (&tmpblock, comp, size);
10921 : : }
10922 : :
10923 : : /* Coarray component have to have the same allocation status and
10924 : : shape/type-parameter/effective-type on the LHS and RHS of an
10925 : : intrinsic assignment. Hence, we did not deallocated them - and
10926 : : do not allocate them here. */
10927 : 722 : if (!CLASS_DATA (c)->attr.codimension)
10928 : : {
10929 : 707 : ftn_tree = builtin_decl_explicit (BUILT_IN_MALLOC);
10930 : 707 : tmp = build_call_expr_loc (input_location, ftn_tree, 1, size);
10931 : 707 : gfc_add_modify (&tmpblock, dst_data,
10932 : 707 : fold_convert (TREE_TYPE (dst_data), tmp));
10933 : : }
10934 : :
10935 : 1429 : tmp = gfc_copy_class_to_class (comp, dcmp, nelems,
10936 : 722 : UNLIMITED_POLY (c));
10937 : 722 : gfc_add_expr_to_block (&tmpblock, tmp);
10938 : 722 : tmp = gfc_finish_block (&tmpblock);
10939 : :
10940 : 722 : gfc_init_block (&tmpblock);
10941 : 722 : gfc_add_modify (&tmpblock, dst_data,
10942 : 722 : fold_convert (TREE_TYPE (dst_data),
10943 : : null_pointer_node));
10944 : 722 : null_data = gfc_finish_block (&tmpblock);
10945 : :
10946 : 722 : null_cond = fold_build2_loc (input_location, NE_EXPR,
10947 : : logical_type_node, src_data,
10948 : : null_pointer_node);
10949 : :
10950 : 722 : gfc_add_expr_to_block (&fnblock, build3_v (COND_EXPR, null_cond,
10951 : : tmp, null_data));
10952 : 722 : continue;
10953 : 722 : }
10954 : :
10955 : : /* To implement guarded deep copy, i.e., deep copy only allocatable
10956 : : components that are really allocated, the deep copy code has to
10957 : : be generated first and then added to the if-block in
10958 : : gfc_duplicate_allocatable (). */
10959 : 7778 : if (cmp_has_alloc_comps && !c->attr.proc_pointer && !same_type)
10960 : : {
10961 : 1144 : rank = c->as ? c->as->rank : 0;
10962 : 1144 : tmp = fold_convert (TREE_TYPE (dcmp), comp);
10963 : 1144 : gfc_add_modify (&fnblock, dcmp, tmp);
10964 : 1144 : add_when_allocated = structure_alloc_comps (c->ts.u.derived,
10965 : : comp, dcmp,
10966 : : rank, purpose,
10967 : : caf_mode, args,
10968 : : no_finalization);
10969 : : }
10970 : : else
10971 : : add_when_allocated = NULL_TREE;
10972 : :
10973 : 7778 : if (gfc_deferred_strlen (c, &tmp))
10974 : : {
10975 : 344 : tree len, size;
10976 : 344 : len = tmp;
10977 : 344 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
10978 : 344 : TREE_TYPE (len),
10979 : : decl, len, NULL_TREE);
10980 : 344 : len = fold_build3_loc (input_location, COMPONENT_REF,
10981 : 344 : TREE_TYPE (len),
10982 : : dest, len, NULL_TREE);
10983 : 344 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
10984 : 344 : TREE_TYPE (len), len, tmp);
10985 : 344 : gfc_add_expr_to_block (&fnblock, tmp);
10986 : 344 : size = size_of_string_in_bytes (c->ts.kind, len);
10987 : : /* This component cannot have allocatable components,
10988 : : therefore add_when_allocated of duplicate_allocatable ()
10989 : : is always NULL. */
10990 : 344 : rank = c->as ? c->as->rank : 0;
10991 : 344 : tmp = duplicate_allocatable (dcmp, comp, ctype, rank,
10992 : : false, false, size, NULL_TREE);
10993 : 344 : gfc_add_expr_to_block (&fnblock, tmp);
10994 : : }
10995 : 7434 : else if (c->attr.pdt_array
10996 : 105 : && !c->attr.allocatable && !c->attr.pointer)
10997 : : {
10998 : 105 : tmp = duplicate_allocatable (dcmp, comp, ctype,
10999 : 105 : c->as ? c->as->rank : 0,
11000 : : false, false, NULL_TREE, NULL_TREE);
11001 : 105 : gfc_add_expr_to_block (&fnblock, tmp);
11002 : : }
11003 : : /* Special case: recursive allocatable array components require
11004 : : runtime helpers to avoid compile-time infinite recursion. Generate
11005 : : a call to _gfortran_cfi_deep_copy_array with an element copy
11006 : : wrapper. When inside a wrapper, reuse current_function_decl. */
11007 : 4025 : else if (c->attr.allocatable && c->as && cmp_has_alloc_comps && same_type
11008 : 228 : && purpose == COPY_ALLOC_COMP && !c->attr.proc_pointer
11009 : 228 : && !c->attr.codimension && !caf_in_coarray (caf_mode)
11010 : 7557 : && c->ts.type == BT_DERIVED && c->ts.u.derived != NULL)
11011 : : {
11012 : 228 : tree copy_wrapper, call, dest_addr, src_addr, elem_type;
11013 : 228 : tree helper_ptr_type;
11014 : 228 : tree alloc_expr;
11015 : 228 : int comp_rank;
11016 : :
11017 : : /* Get the element type from ctype (already the component
11018 : : type). For arrays we need the element type, not the array
11019 : : type. */
11020 : 228 : elem_type = ctype;
11021 : 228 : if (GFC_DESCRIPTOR_TYPE_P (ctype))
11022 : 228 : elem_type = gfc_get_element_type (ctype);
11023 : 0 : else if (TREE_CODE (ctype) == ARRAY_TYPE)
11024 : 0 : elem_type = TREE_TYPE (ctype);
11025 : :
11026 : 228 : helper_ptr_type = get_copy_helper_pointer_type ();
11027 : :
11028 : 228 : comp_rank = c->as ? c->as->rank : 0;
11029 : 228 : alloc_expr = gfc_duplicate_allocatable_nocopy (dcmp, comp, ctype,
11030 : : comp_rank);
11031 : 228 : gfc_add_expr_to_block (&fnblock, alloc_expr);
11032 : :
11033 : : /* Generate or reuse the element copy helper. Inside an
11034 : : existing helper we can reuse the current function to
11035 : : prevent recursive generation. */
11036 : 228 : if (inside_wrapper)
11037 : 115 : copy_wrapper
11038 : 115 : = gfc_build_addr_expr (NULL_TREE, current_function_decl);
11039 : : else
11040 : 113 : copy_wrapper
11041 : 113 : = generate_element_copy_wrapper (c->ts.u.derived, elem_type,
11042 : : purpose, caf_mode);
11043 : 228 : copy_wrapper = fold_convert (helper_ptr_type, copy_wrapper);
11044 : :
11045 : : /* Build addresses of descriptors. */
11046 : 228 : dest_addr = gfc_build_addr_expr (pvoid_type_node, dcmp);
11047 : 228 : src_addr = gfc_build_addr_expr (pvoid_type_node, comp);
11048 : :
11049 : : /* Build call: _gfortran_cfi_deep_copy_array (&dcmp, &comp,
11050 : : wrapper). */
11051 : 228 : call = build_call_expr_loc (input_location,
11052 : : gfor_fndecl_cfi_deep_copy_array, 3,
11053 : : dest_addr, src_addr,
11054 : : copy_wrapper);
11055 : 228 : gfc_add_expr_to_block (&fnblock, call);
11056 : : }
11057 : 3797 : else if (c->attr.allocatable && !c->attr.proc_pointer
11058 : 7101 : && (add_when_allocated != NULL_TREE
11059 : 3797 : || !cmp_has_alloc_comps
11060 : 119 : || !c->as
11061 : 0 : || c->attr.codimension
11062 : 0 : || caf_in_coarray (caf_mode)))
11063 : : {
11064 : 3797 : rank = c->as ? c->as->rank : 0;
11065 : 3797 : if (c->attr.codimension)
11066 : 15 : tmp = gfc_copy_allocatable_data (dcmp, comp, ctype, rank);
11067 : 3782 : else if (flag_coarray == GFC_FCOARRAY_LIB
11068 : 3782 : && caf_in_coarray (caf_mode))
11069 : : {
11070 : 55 : tree dst_tok;
11071 : 55 : if (c->as)
11072 : 40 : dst_tok = gfc_conv_descriptor_token (dcmp);
11073 : : else
11074 : : {
11075 : 15 : dst_tok
11076 : 15 : = fold_build3_loc (input_location, COMPONENT_REF,
11077 : : pvoid_type_node, dest,
11078 : 15 : gfc_comp_caf_token (c), NULL_TREE);
11079 : : }
11080 : 55 : tmp
11081 : 55 : = duplicate_allocatable_coarray (dcmp, dst_tok, comp, ctype,
11082 : : rank, add_when_allocated);
11083 : : }
11084 : : else
11085 : 3727 : tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank,
11086 : : add_when_allocated);
11087 : 3797 : gfc_add_expr_to_block (&fnblock, tmp);
11088 : : }
11089 : : else
11090 : 3304 : if (cmp_has_alloc_comps || is_pdt_type)
11091 : 763 : gfc_add_expr_to_block (&fnblock, add_when_allocated);
11092 : :
11093 : : break;
11094 : :
11095 : 1513 : case ALLOCATE_PDT_COMP:
11096 : :
11097 : 1513 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
11098 : : decl, cdecl, NULL_TREE);
11099 : :
11100 : : /* Set the PDT KIND and LEN fields. */
11101 : 1513 : if (c->attr.pdt_kind || c->attr.pdt_len)
11102 : : {
11103 : 699 : gfc_se tse;
11104 : 699 : gfc_expr *c_expr = NULL;
11105 : 699 : gfc_actual_arglist *param = pdt_param_list;
11106 : 699 : gfc_init_se (&tse, NULL);
11107 : 2639 : for (; param; param = param->next)
11108 : 1241 : if (param->name && !strcmp (c->name, param->name))
11109 : 699 : c_expr = param->expr;
11110 : :
11111 : 699 : if (!c_expr)
11112 : 18 : c_expr = c->initializer;
11113 : :
11114 : 18 : if (c_expr)
11115 : : {
11116 : 681 : gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp));
11117 : 681 : gfc_add_block_to_block (&fnblock, &tse.pre);
11118 : 681 : gfc_add_modify (&fnblock, comp, tse.expr);
11119 : 681 : gfc_add_block_to_block (&fnblock, &tse.post);
11120 : : }
11121 : 699 : }
11122 : 814 : else if (c->initializer && !c->attr.pdt_string && !c->attr.pdt_array
11123 : 38 : && !c->as && !(c->ts.type == BT_DERIVED
11124 : 28 : && c->ts.u.derived->attr.pdt_type)) /* Take care of arrays. */
11125 : : {
11126 : 10 : gfc_se tse;
11127 : 10 : gfc_expr *c_expr;
11128 : 10 : c_expr = c->initializer;
11129 : 10 : gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp));
11130 : 10 : gfc_add_block_to_block (&fnblock, &tse.pre);
11131 : 10 : gfc_add_modify (&fnblock, comp, tse.expr);
11132 : 10 : gfc_add_block_to_block (&fnblock, &tse.post);
11133 : : }
11134 : :
11135 : 1513 : if (c->attr.pdt_string)
11136 : : {
11137 : 90 : gfc_se tse;
11138 : 90 : gfc_init_se (&tse, NULL);
11139 : 90 : tree strlen = NULL_TREE;
11140 : 90 : gfc_expr *e = gfc_copy_expr (c->ts.u.cl->length);
11141 : : /* Convert the parameterized string length to its value. The
11142 : : string length is stored in a hidden field in the same way as
11143 : : deferred string lengths. */
11144 : 90 : gfc_insert_parameter_exprs (e, pdt_param_list);
11145 : 90 : if (gfc_deferred_strlen (c, &strlen) && strlen != NULL_TREE)
11146 : : {
11147 : 90 : gfc_conv_expr_type (&tse, e,
11148 : 90 : TREE_TYPE (strlen));
11149 : 90 : strlen = fold_build3_loc (input_location, COMPONENT_REF,
11150 : 90 : TREE_TYPE (strlen),
11151 : : decl, strlen, NULL_TREE);
11152 : 90 : gfc_add_block_to_block (&fnblock, &tse.pre);
11153 : 90 : gfc_add_modify (&fnblock, strlen, tse.expr);
11154 : 90 : gfc_add_block_to_block (&fnblock, &tse.post);
11155 : 90 : c->ts.u.cl->backend_decl = strlen;
11156 : : }
11157 : 90 : gfc_free_expr (e);
11158 : :
11159 : : /* Scalar parameterized strings can be allocated now. */
11160 : 90 : if (!c->as)
11161 : : {
11162 : 90 : tmp = fold_convert (gfc_array_index_type, strlen);
11163 : 90 : tmp = size_of_string_in_bytes (c->ts.kind, tmp);
11164 : 90 : tmp = gfc_evaluate_now (tmp, &fnblock);
11165 : 90 : tmp = gfc_call_malloc (&fnblock, TREE_TYPE (comp), tmp);
11166 : 90 : gfc_add_modify (&fnblock, comp, tmp);
11167 : : }
11168 : : }
11169 : :
11170 : : /* Allocate parameterized arrays of parameterized derived types. */
11171 : 1513 : if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT)
11172 : 1261 : && !((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
11173 : 142 : && (c->ts.u.derived && c->ts.u.derived->attr.pdt_type)))
11174 : 1126 : continue;
11175 : :
11176 : 387 : if (c->ts.type == BT_CLASS)
11177 : 0 : comp = gfc_class_data_get (comp);
11178 : :
11179 : 387 : if (c->attr.pdt_array)
11180 : : {
11181 : 252 : gfc_se tse;
11182 : 252 : int i;
11183 : 252 : tree size = gfc_index_one_node;
11184 : 252 : tree offset = gfc_index_zero_node;
11185 : 252 : tree lower, upper;
11186 : 252 : gfc_expr *e;
11187 : :
11188 : : /* This chunk takes the expressions for 'lower' and 'upper'
11189 : : in the arrayspec and substitutes in the expressions for
11190 : : the parameters from 'pdt_param_list'. The descriptor
11191 : : fields can then be filled from the values so obtained. */
11192 : 252 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)));
11193 : 612 : for (i = 0; i < c->as->rank; i++)
11194 : : {
11195 : 360 : gfc_init_se (&tse, NULL);
11196 : 360 : e = gfc_copy_expr (c->as->lower[i]);
11197 : 360 : gfc_insert_parameter_exprs (e, pdt_param_list);
11198 : 360 : gfc_conv_expr_type (&tse, e, gfc_array_index_type);
11199 : 360 : gfc_free_expr (e);
11200 : 360 : lower = tse.expr;
11201 : 360 : gfc_add_block_to_block (&fnblock, &tse.pre);
11202 : 360 : gfc_conv_descriptor_lbound_set (&fnblock, comp,
11203 : : gfc_rank_cst[i],
11204 : : lower);
11205 : 360 : gfc_add_block_to_block (&fnblock, &tse.post);
11206 : 360 : e = gfc_copy_expr (c->as->upper[i]);
11207 : 360 : gfc_insert_parameter_exprs (e, pdt_param_list);
11208 : 360 : gfc_conv_expr_type (&tse, e, gfc_array_index_type);
11209 : 360 : gfc_free_expr (e);
11210 : 360 : upper = tse.expr;
11211 : 360 : gfc_add_block_to_block (&fnblock, &tse.pre);
11212 : 360 : gfc_conv_descriptor_ubound_set (&fnblock, comp,
11213 : : gfc_rank_cst[i],
11214 : : upper);
11215 : 360 : gfc_add_block_to_block (&fnblock, &tse.post);
11216 : 360 : gfc_conv_descriptor_stride_set (&fnblock, comp,
11217 : : gfc_rank_cst[i],
11218 : : size);
11219 : 360 : size = gfc_evaluate_now (size, &fnblock);
11220 : 360 : offset = fold_build2_loc (input_location,
11221 : : MINUS_EXPR,
11222 : : gfc_array_index_type,
11223 : : offset, size);
11224 : 360 : offset = gfc_evaluate_now (offset, &fnblock);
11225 : 360 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
11226 : : gfc_array_index_type,
11227 : : upper, lower);
11228 : 360 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
11229 : : gfc_array_index_type,
11230 : : tmp, gfc_index_one_node);
11231 : 360 : size = fold_build2_loc (input_location, MULT_EXPR,
11232 : : gfc_array_index_type, size, tmp);
11233 : : }
11234 : 252 : gfc_conv_descriptor_offset_set (&fnblock, comp, offset);
11235 : 252 : if (c->ts.type == BT_CLASS)
11236 : : {
11237 : 0 : tmp = gfc_get_vptr_from_expr (comp);
11238 : 0 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
11239 : 0 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
11240 : 0 : tmp = gfc_vptr_size_get (tmp);
11241 : : }
11242 : : else
11243 : 252 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (ctype));
11244 : 252 : tmp = fold_convert (gfc_array_index_type, tmp);
11245 : 252 : size = fold_build2_loc (input_location, MULT_EXPR,
11246 : : gfc_array_index_type, size, tmp);
11247 : 252 : size = gfc_evaluate_now (size, &fnblock);
11248 : 252 : tmp = gfc_call_malloc (&fnblock, NULL, size);
11249 : 252 : gfc_conv_descriptor_data_set (&fnblock, comp, tmp);
11250 : 252 : tmp = gfc_conv_descriptor_dtype (comp);
11251 : 252 : gfc_add_modify (&fnblock, tmp, gfc_get_dtype (ctype));
11252 : :
11253 : 252 : if (c->initializer && c->initializer->rank)
11254 : : {
11255 : 0 : gfc_init_se (&tse, NULL);
11256 : 0 : e = gfc_copy_expr (c->initializer);
11257 : 0 : gfc_insert_parameter_exprs (e, pdt_param_list);
11258 : 0 : gfc_conv_expr_descriptor (&tse, e);
11259 : 0 : gfc_add_block_to_block (&fnblock, &tse.pre);
11260 : 0 : gfc_free_expr (e);
11261 : 0 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
11262 : 0 : tmp = build_call_expr_loc (input_location, tmp, 3,
11263 : : gfc_conv_descriptor_data_get (comp),
11264 : : gfc_conv_descriptor_data_get (tse.expr),
11265 : : fold_convert (size_type_node, size));
11266 : 0 : gfc_add_expr_to_block (&fnblock, tmp);
11267 : 0 : gfc_add_block_to_block (&fnblock, &tse.post);
11268 : : }
11269 : : }
11270 : :
11271 : : /* Recurse in to PDT components. */
11272 : 387 : if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
11273 : 148 : && c->ts.u.derived && c->ts.u.derived->attr.pdt_type
11274 : 148 : && !(c->attr.pointer || c->attr.allocatable))
11275 : : {
11276 : 71 : gfc_actual_arglist *tail = c->param_list;
11277 : :
11278 : 196 : for (; tail; tail = tail->next)
11279 : 125 : if (tail->expr)
11280 : 101 : gfc_insert_parameter_exprs (tail->expr, pdt_param_list);
11281 : :
11282 : 71 : tmp = gfc_allocate_pdt_comp (c->ts.u.derived, comp,
11283 : 71 : c->as ? c->as->rank : 0,
11284 : 71 : c->param_list);
11285 : 71 : gfc_add_expr_to_block (&fnblock, tmp);
11286 : : }
11287 : :
11288 : : break;
11289 : :
11290 : 1687 : case DEALLOCATE_PDT_COMP:
11291 : : /* Deallocate array or parameterized string length components
11292 : : of parameterized derived types. */
11293 : 1687 : if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT)
11294 : 1328 : && !c->attr.pdt_string
11295 : 1220 : && !((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
11296 : 160 : && (c->ts.u.derived && c->ts.u.derived->attr.pdt_type)))
11297 : 1060 : continue;
11298 : :
11299 : 627 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
11300 : : decl, cdecl, NULL_TREE);
11301 : 627 : if (c->ts.type == BT_CLASS)
11302 : 0 : comp = gfc_class_data_get (comp);
11303 : :
11304 : : /* Recurse in to PDT components. */
11305 : 627 : if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
11306 : 173 : && c->ts.u.derived && c->ts.u.derived->attr.pdt_type
11307 : 173 : && (!c->attr.pointer && !c->attr.allocatable))
11308 : : {
11309 : 55 : tmp = gfc_deallocate_pdt_comp (c->ts.u.derived, comp,
11310 : 55 : c->as ? c->as->rank : 0);
11311 : 55 : gfc_add_expr_to_block (&fnblock, tmp);
11312 : : }
11313 : :
11314 : 627 : if (c->attr.pdt_array || c->attr.pdt_string)
11315 : : {
11316 : 467 : tmp = comp;
11317 : 467 : if (c->attr.pdt_array)
11318 : 359 : tmp = gfc_conv_descriptor_data_get (comp);
11319 : 467 : null_cond = fold_build2_loc (input_location, NE_EXPR,
11320 : : logical_type_node, tmp,
11321 : 467 : build_int_cst (TREE_TYPE (tmp), 0));
11322 : 467 : if (flag_openmp_allocators)
11323 : : {
11324 : 0 : tree cd, t;
11325 : 0 : if (c->attr.pdt_array)
11326 : 0 : cd = fold_build2_loc (input_location, EQ_EXPR,
11327 : : boolean_type_node,
11328 : : gfc_conv_descriptor_version (comp),
11329 : : build_int_cst (integer_type_node, 1));
11330 : : else
11331 : 0 : cd = gfc_omp_call_is_alloc (tmp);
11332 : 0 : t = builtin_decl_explicit (BUILT_IN_GOMP_FREE);
11333 : 0 : t = build_call_expr_loc (input_location, t, 1, tmp);
11334 : :
11335 : 0 : stmtblock_t tblock;
11336 : 0 : gfc_init_block (&tblock);
11337 : 0 : gfc_add_expr_to_block (&tblock, t);
11338 : 0 : if (c->attr.pdt_array)
11339 : 0 : gfc_add_modify (&tblock, gfc_conv_descriptor_version (comp),
11340 : : integer_zero_node);
11341 : 0 : tmp = build3_loc (input_location, COND_EXPR, void_type_node,
11342 : : cd, gfc_finish_block (&tblock),
11343 : : gfc_call_free (tmp));
11344 : : }
11345 : : else
11346 : 467 : tmp = gfc_call_free (tmp);
11347 : 467 : tmp = build3_v (COND_EXPR, null_cond, tmp,
11348 : : build_empty_stmt (input_location));
11349 : 467 : gfc_add_expr_to_block (&fnblock, tmp);
11350 : :
11351 : 467 : if (c->attr.pdt_array)
11352 : 359 : gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
11353 : : else
11354 : : {
11355 : 108 : tmp = fold_convert (TREE_TYPE (comp), null_pointer_node);
11356 : 108 : gfc_add_modify (&fnblock, comp, tmp);
11357 : : }
11358 : : }
11359 : :
11360 : : break;
11361 : :
11362 : 270 : case CHECK_PDT_DUMMY:
11363 : :
11364 : 270 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
11365 : : decl, cdecl, NULL_TREE);
11366 : 270 : if (c->ts.type == BT_CLASS)
11367 : 0 : comp = gfc_class_data_get (comp);
11368 : :
11369 : : /* Recurse in to PDT components. */
11370 : 270 : if (((c->ts.type == BT_DERIVED
11371 : 2 : && !c->attr.allocatable && !c->attr.pointer)
11372 : 270 : || (c->ts.type == BT_CLASS
11373 : 0 : && !CLASS_DATA (c)->attr.allocatable
11374 : 0 : && !CLASS_DATA (c)->attr.pointer))
11375 : 0 : && c->ts.u.derived && c->ts.u.derived->attr.pdt_type)
11376 : : {
11377 : 0 : tmp = gfc_check_pdt_dummy (c->ts.u.derived, comp,
11378 : 0 : c->as ? c->as->rank : 0,
11379 : : pdt_param_list);
11380 : 0 : gfc_add_expr_to_block (&fnblock, tmp);
11381 : : }
11382 : :
11383 : 270 : if (!c->attr.pdt_len)
11384 : 222 : continue;
11385 : : else
11386 : : {
11387 : 48 : gfc_se tse;
11388 : 48 : gfc_expr *c_expr = NULL;
11389 : 48 : gfc_actual_arglist *param = pdt_param_list;
11390 : :
11391 : 48 : gfc_init_se (&tse, NULL);
11392 : 186 : for (; param; param = param->next)
11393 : 90 : if (!strcmp (c->name, param->name)
11394 : 48 : && param->spec_type == SPEC_EXPLICIT)
11395 : 30 : c_expr = param->expr;
11396 : :
11397 : 48 : if (c_expr)
11398 : : {
11399 : 30 : tree error, cond, cname;
11400 : 30 : gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp));
11401 : 30 : cond = fold_build2_loc (input_location, NE_EXPR,
11402 : : logical_type_node,
11403 : : comp, tse.expr);
11404 : 30 : cname = gfc_build_cstring_const (c->name);
11405 : 30 : cname = gfc_build_addr_expr (pchar_type_node, cname);
11406 : 30 : error = gfc_trans_runtime_error (true, NULL,
11407 : : "The value of the PDT LEN "
11408 : : "parameter '%s' does not "
11409 : : "agree with that in the "
11410 : : "dummy declaration",
11411 : : cname);
11412 : 30 : tmp = fold_build3_loc (input_location, COND_EXPR,
11413 : : void_type_node, cond, error,
11414 : : build_empty_stmt (input_location));
11415 : 30 : gfc_add_expr_to_block (&fnblock, tmp);
11416 : : }
11417 : : }
11418 : 48 : break;
11419 : :
11420 : 0 : default:
11421 : 0 : gcc_unreachable ();
11422 : 4853 : break;
11423 : : }
11424 : : }
11425 : 14673 : seen_derived_types.remove (der_type);
11426 : :
11427 : 14673 : return gfc_finish_block (&fnblock);
11428 : : }
11429 : :
11430 : : /* Recursively traverse an object of derived type, generating code to
11431 : : nullify allocatable components. */
11432 : :
11433 : : tree
11434 : 2310 : gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
11435 : : int caf_mode)
11436 : : {
11437 : 2310 : return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11438 : : NULLIFY_ALLOC_COMP,
11439 : : GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode,
11440 : 2310 : NULL);
11441 : : }
11442 : :
11443 : :
11444 : : /* Recursively traverse an object of derived type, generating code to
11445 : : deallocate allocatable components. */
11446 : :
11447 : : tree
11448 : 2632 : gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
11449 : : int caf_mode)
11450 : : {
11451 : 2632 : return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11452 : : DEALLOCATE_ALLOC_COMP,
11453 : : GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode,
11454 : 2632 : NULL);
11455 : : }
11456 : :
11457 : : tree
11458 : 1 : gfc_bcast_alloc_comp (gfc_symbol *derived, gfc_expr *expr, int rank,
11459 : : tree image_index, tree stat, tree errmsg,
11460 : : tree errmsg_len)
11461 : : {
11462 : 1 : tree tmp, array;
11463 : 1 : gfc_se argse;
11464 : 1 : stmtblock_t block, post_block;
11465 : 1 : gfc_co_subroutines_args args;
11466 : :
11467 : 1 : args.image_index = image_index;
11468 : 1 : args.stat = stat;
11469 : 1 : args.errmsg = errmsg;
11470 : 1 : args.errmsg_len = errmsg_len;
11471 : :
11472 : 1 : if (rank == 0)
11473 : : {
11474 : 1 : gfc_start_block (&block);
11475 : 1 : gfc_init_block (&post_block);
11476 : 1 : gfc_init_se (&argse, NULL);
11477 : 1 : gfc_conv_expr (&argse, expr);
11478 : 1 : gfc_add_block_to_block (&block, &argse.pre);
11479 : 1 : gfc_add_block_to_block (&post_block, &argse.post);
11480 : 1 : array = argse.expr;
11481 : : }
11482 : : else
11483 : : {
11484 : 0 : gfc_init_se (&argse, NULL);
11485 : 0 : argse.want_pointer = 1;
11486 : 0 : gfc_conv_expr_descriptor (&argse, expr);
11487 : 0 : array = argse.expr;
11488 : : }
11489 : :
11490 : 1 : tmp = structure_alloc_comps (derived, array, NULL_TREE, rank,
11491 : : BCAST_ALLOC_COMP,
11492 : : GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY,
11493 : : &args);
11494 : 1 : return tmp;
11495 : : }
11496 : :
11497 : : /* Recursively traverse an object of derived type, generating code to
11498 : : deallocate allocatable components. But do not deallocate coarrays.
11499 : : To be used for intrinsic assignment, which may not change the allocation
11500 : : status of coarrays. */
11501 : :
11502 : : tree
11503 : 1968 : gfc_deallocate_alloc_comp_no_caf (gfc_symbol * der_type, tree decl, int rank,
11504 : : bool no_finalization)
11505 : : {
11506 : 1968 : return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11507 : : DEALLOCATE_ALLOC_COMP, 0, NULL,
11508 : 1968 : no_finalization);
11509 : : }
11510 : :
11511 : :
11512 : : tree
11513 : 4 : gfc_reassign_alloc_comp_caf (gfc_symbol *der_type, tree decl, tree dest)
11514 : : {
11515 : 4 : return structure_alloc_comps (der_type, decl, dest, 0, REASSIGN_CAF_COMP,
11516 : : GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY,
11517 : 4 : NULL);
11518 : : }
11519 : :
11520 : :
11521 : : /* Recursively traverse an object of derived type, generating code to
11522 : : copy it and its allocatable components. */
11523 : :
11524 : : tree
11525 : 3783 : gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank,
11526 : : int caf_mode)
11527 : : {
11528 : 3783 : return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP,
11529 : 3783 : caf_mode, NULL);
11530 : : }
11531 : :
11532 : :
11533 : : /* Recursively traverse an object of derived type, generating code to
11534 : : copy it and its allocatable components, while suppressing any
11535 : : finalization that might occur. This is used in the finalization of
11536 : : function results. */
11537 : :
11538 : : tree
11539 : 37 : gfc_copy_alloc_comp_no_fini (gfc_symbol * der_type, tree decl, tree dest,
11540 : : int rank, int caf_mode)
11541 : : {
11542 : 37 : return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP,
11543 : 37 : caf_mode, NULL, true);
11544 : : }
11545 : :
11546 : :
11547 : : /* Recursively traverse an object of derived type, generating code to
11548 : : copy only its allocatable components. */
11549 : :
11550 : : tree
11551 : 0 : gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
11552 : : {
11553 : 0 : return structure_alloc_comps (der_type, decl, dest, rank,
11554 : 0 : COPY_ONLY_ALLOC_COMP, 0, NULL);
11555 : : }
11556 : :
11557 : :
11558 : : /* Recursively traverse an object of parameterized derived type, generating
11559 : : code to allocate parameterized components. */
11560 : :
11561 : : tree
11562 : 516 : gfc_allocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank,
11563 : : gfc_actual_arglist *param_list)
11564 : : {
11565 : 516 : tree res;
11566 : 516 : gfc_actual_arglist *old_param_list = pdt_param_list;
11567 : 516 : pdt_param_list = param_list;
11568 : 516 : res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11569 : : ALLOCATE_PDT_COMP, 0, NULL);
11570 : 516 : pdt_param_list = old_param_list;
11571 : 516 : return res;
11572 : : }
11573 : :
11574 : : /* Recursively traverse an object of parameterized derived type, generating
11575 : : code to deallocate parameterized components. */
11576 : :
11577 : : static bool
11578 : 718 : has_parameterized_comps (gfc_symbol * der_type)
11579 : : {
11580 : : /* A type without parameterized components causes gimplifier problems. */
11581 : 718 : bool parameterized_comps = false;
11582 : 2773 : for (gfc_component *c = der_type->components; c; c = c->next)
11583 : 2055 : if (c->attr.pdt_array || c->attr.pdt_string)
11584 : : parameterized_comps = true;
11585 : 1563 : else if (c->ts.type == BT_DERIVED
11586 : 139 : && c->ts.u.derived->attr.pdt_type
11587 : 137 : && strcmp (der_type->name, c->ts.u.derived->name))
11588 : 66 : parameterized_comps = has_parameterized_comps (c->ts.u.derived);
11589 : 718 : return parameterized_comps;
11590 : : }
11591 : :
11592 : : tree
11593 : 652 : gfc_deallocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank)
11594 : : {
11595 : 652 : if (!has_parameterized_comps (der_type))
11596 : : return NULL_TREE;
11597 : :
11598 : 420 : return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11599 : 420 : DEALLOCATE_PDT_COMP, 0, NULL);
11600 : : }
11601 : :
11602 : :
11603 : : /* Recursively traverse a dummy of parameterized derived type to check the
11604 : : values of LEN parameters. */
11605 : :
11606 : : tree
11607 : 50 : gfc_check_pdt_dummy (gfc_symbol * der_type, tree decl, int rank,
11608 : : gfc_actual_arglist *param_list)
11609 : : {
11610 : 50 : tree res;
11611 : 50 : gfc_actual_arglist *old_param_list = pdt_param_list;
11612 : 50 : pdt_param_list = param_list;
11613 : 50 : res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11614 : : CHECK_PDT_DUMMY, 0, NULL);
11615 : 50 : pdt_param_list = old_param_list;
11616 : 50 : return res;
11617 : : }
11618 : :
11619 : :
11620 : : /* Returns the value of LBOUND for an expression. This could be broken out
11621 : : from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
11622 : : called by gfc_alloc_allocatable_for_assignment. */
11623 : : static tree
11624 : 980 : get_std_lbound (gfc_expr *expr, tree desc, int dim, bool assumed_size)
11625 : : {
11626 : 980 : tree lbound;
11627 : 980 : tree ubound;
11628 : 980 : tree stride;
11629 : 980 : tree cond, cond1, cond3, cond4;
11630 : 980 : tree tmp;
11631 : 980 : gfc_ref *ref;
11632 : :
11633 : 980 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
11634 : : {
11635 : 482 : tmp = gfc_rank_cst[dim];
11636 : 482 : lbound = gfc_conv_descriptor_lbound_get (desc, tmp);
11637 : 482 : ubound = gfc_conv_descriptor_ubound_get (desc, tmp);
11638 : 482 : stride = gfc_conv_descriptor_stride_get (desc, tmp);
11639 : 482 : cond1 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
11640 : : ubound, lbound);
11641 : 482 : cond3 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
11642 : : stride, gfc_index_zero_node);
11643 : 482 : cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
11644 : : logical_type_node, cond3, cond1);
11645 : 482 : cond4 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
11646 : : stride, gfc_index_zero_node);
11647 : 482 : if (assumed_size)
11648 : 0 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
11649 : : tmp, build_int_cst (gfc_array_index_type,
11650 : 0 : expr->rank - 1));
11651 : : else
11652 : 482 : cond = logical_false_node;
11653 : :
11654 : 482 : cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
11655 : : logical_type_node, cond3, cond4);
11656 : 482 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
11657 : : logical_type_node, cond, cond1);
11658 : :
11659 : 482 : return fold_build3_loc (input_location, COND_EXPR,
11660 : : gfc_array_index_type, cond,
11661 : 482 : lbound, gfc_index_one_node);
11662 : : }
11663 : :
11664 : 498 : if (expr->expr_type == EXPR_FUNCTION)
11665 : : {
11666 : : /* A conversion function, so use the argument. */
11667 : 7 : gcc_assert (expr->value.function.isym
11668 : : && expr->value.function.isym->conversion);
11669 : 7 : expr = expr->value.function.actual->expr;
11670 : : }
11671 : :
11672 : 498 : if (expr->expr_type == EXPR_VARIABLE)
11673 : : {
11674 : 498 : tmp = TREE_TYPE (expr->symtree->n.sym->backend_decl);
11675 : 1310 : for (ref = expr->ref; ref; ref = ref->next)
11676 : : {
11677 : 812 : if (ref->type == REF_COMPONENT
11678 : 265 : && ref->u.c.component->as
11679 : 216 : && ref->next
11680 : 216 : && ref->next->u.ar.type == AR_FULL)
11681 : 174 : tmp = TREE_TYPE (ref->u.c.component->backend_decl);
11682 : : }
11683 : 498 : return GFC_TYPE_ARRAY_LBOUND(tmp, dim);
11684 : : }
11685 : :
11686 : 0 : return gfc_index_one_node;
11687 : : }
11688 : :
11689 : :
11690 : : /* Returns true if an expression represents an lhs that can be reallocated
11691 : : on assignment. */
11692 : :
11693 : : bool
11694 : 334862 : gfc_is_reallocatable_lhs (gfc_expr *expr)
11695 : : {
11696 : 334862 : gfc_ref * ref;
11697 : 334862 : gfc_symbol *sym;
11698 : :
11699 : 334862 : if (!flag_realloc_lhs)
11700 : : return false;
11701 : :
11702 : 334862 : if (!expr->ref)
11703 : : return false;
11704 : :
11705 : 117328 : sym = expr->symtree->n.sym;
11706 : :
11707 : 117328 : if (sym->attr.associate_var && !expr->ref)
11708 : : return false;
11709 : :
11710 : : /* An allocatable class variable with no reference. */
11711 : 117328 : if (sym->ts.type == BT_CLASS
11712 : 3448 : && (!sym->attr.associate_var || sym->attr.select_rank_temporary)
11713 : 3361 : && CLASS_DATA (sym)->attr.allocatable
11714 : : && expr->ref
11715 : 2163 : && ((expr->ref->type == REF_ARRAY && expr->ref->u.ar.type == AR_FULL
11716 : 0 : && expr->ref->next == NULL)
11717 : 2163 : || (expr->ref->type == REF_COMPONENT
11718 : 2163 : && strcmp (expr->ref->u.c.component->name, "_data") == 0
11719 : 1787 : && (expr->ref->next == NULL
11720 : 1787 : || (expr->ref->next->type == REF_ARRAY
11721 : 1787 : && expr->ref->next->u.ar.type == AR_FULL
11722 : 1503 : && expr->ref->next->next == NULL)))))
11723 : : return true;
11724 : :
11725 : : /* An allocatable variable. */
11726 : 115965 : if (sym->attr.allocatable
11727 : 28804 : && (!sym->attr.associate_var || sym->attr.select_rank_temporary)
11728 : : && expr->ref
11729 : 28804 : && expr->ref->type == REF_ARRAY
11730 : 27781 : && expr->ref->u.ar.type == AR_FULL)
11731 : : return true;
11732 : :
11733 : : /* All that can be left are allocatable components. */
11734 : 97528 : if (sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
11735 : : return false;
11736 : :
11737 : : /* Find a component ref followed by an array reference. */
11738 : 46784 : for (ref = expr->ref; ref; ref = ref->next)
11739 : 33088 : if (ref->next
11740 : 19392 : && ref->type == REF_COMPONENT
11741 : 11571 : && ref->next->type == REF_ARRAY
11742 : 9072 : && !ref->next->next)
11743 : : break;
11744 : :
11745 : 20681 : if (!ref)
11746 : : return false;
11747 : :
11748 : : /* Return true if valid reallocatable lhs. */
11749 : 6985 : if (ref->u.c.component->attr.allocatable
11750 : 3097 : && ref->next->u.ar.type == AR_FULL)
11751 : 2270 : return true;
11752 : :
11753 : : return false;
11754 : : }
11755 : :
11756 : :
11757 : : static tree
11758 : 56 : concat_str_length (gfc_expr* expr)
11759 : : {
11760 : 56 : tree type;
11761 : 56 : tree len1;
11762 : 56 : tree len2;
11763 : 56 : gfc_se se;
11764 : :
11765 : 56 : type = gfc_typenode_for_spec (&expr->value.op.op1->ts);
11766 : 56 : len1 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
11767 : 56 : if (len1 == NULL_TREE)
11768 : : {
11769 : 56 : if (expr->value.op.op1->expr_type == EXPR_OP)
11770 : 31 : len1 = concat_str_length (expr->value.op.op1);
11771 : 25 : else if (expr->value.op.op1->expr_type == EXPR_CONSTANT)
11772 : 25 : len1 = build_int_cst (gfc_charlen_type_node,
11773 : 25 : expr->value.op.op1->value.character.length);
11774 : 0 : else if (expr->value.op.op1->ts.u.cl->length)
11775 : : {
11776 : 0 : gfc_init_se (&se, NULL);
11777 : 0 : gfc_conv_expr (&se, expr->value.op.op1->ts.u.cl->length);
11778 : 0 : len1 = se.expr;
11779 : : }
11780 : : else
11781 : : {
11782 : : /* Last resort! */
11783 : 0 : gfc_init_se (&se, NULL);
11784 : 0 : se.want_pointer = 1;
11785 : 0 : se.descriptor_only = 1;
11786 : 0 : gfc_conv_expr (&se, expr->value.op.op1);
11787 : 0 : len1 = se.string_length;
11788 : : }
11789 : : }
11790 : :
11791 : 56 : type = gfc_typenode_for_spec (&expr->value.op.op2->ts);
11792 : 56 : len2 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
11793 : 56 : if (len2 == NULL_TREE)
11794 : : {
11795 : 31 : if (expr->value.op.op2->expr_type == EXPR_OP)
11796 : 0 : len2 = concat_str_length (expr->value.op.op2);
11797 : 31 : else if (expr->value.op.op2->expr_type == EXPR_CONSTANT)
11798 : 25 : len2 = build_int_cst (gfc_charlen_type_node,
11799 : 25 : expr->value.op.op2->value.character.length);
11800 : 6 : else if (expr->value.op.op2->ts.u.cl->length)
11801 : : {
11802 : 6 : gfc_init_se (&se, NULL);
11803 : 6 : gfc_conv_expr (&se, expr->value.op.op2->ts.u.cl->length);
11804 : 6 : len2 = se.expr;
11805 : : }
11806 : : else
11807 : : {
11808 : : /* Last resort! */
11809 : 0 : gfc_init_se (&se, NULL);
11810 : 0 : se.want_pointer = 1;
11811 : 0 : se.descriptor_only = 1;
11812 : 0 : gfc_conv_expr (&se, expr->value.op.op2);
11813 : 0 : len2 = se.string_length;
11814 : : }
11815 : : }
11816 : :
11817 : 56 : gcc_assert(len1 && len2);
11818 : 56 : len1 = fold_convert (gfc_charlen_type_node, len1);
11819 : 56 : len2 = fold_convert (gfc_charlen_type_node, len2);
11820 : :
11821 : 56 : return fold_build2_loc (input_location, PLUS_EXPR,
11822 : 56 : gfc_charlen_type_node, len1, len2);
11823 : : }
11824 : :
11825 : :
11826 : : /* Among the scalarization chain of LOOP, find the element associated with an
11827 : : allocatable array on the lhs of an assignment and evaluate its fields
11828 : : (bounds, offset, etc) to new variables, putting the new code in BLOCK. This
11829 : : function is to be called after putting the reallocation code in BLOCK and
11830 : : before the beginning of the scalarization loop body.
11831 : :
11832 : : The fields to be saved are expected to hold on entry to the function
11833 : : expressions referencing the array descriptor. Especially the expressions
11834 : : shouldn't be already temporary variable references as the value saved before
11835 : : reallocation would be incorrect after reallocation.
11836 : : At the end of the function, the expressions have been replaced with variable
11837 : : references. */
11838 : :
11839 : : static void
11840 : 5896 : update_reallocated_descriptor (stmtblock_t *block, gfc_loopinfo *loop)
11841 : : {
11842 : 20841 : for (gfc_ss *s = loop->ss; s != gfc_ss_terminator; s = s->loop_chain)
11843 : : {
11844 : 14945 : if (!s->is_alloc_lhs)
11845 : 9049 : continue;
11846 : :
11847 : 5896 : gcc_assert (s->info->type == GFC_SS_SECTION);
11848 : 5896 : gfc_array_info *info = &s->info->data.array;
11849 : :
11850 : : #define SAVE_VALUE(value) \
11851 : : do \
11852 : : { \
11853 : : value = gfc_evaluate_now (value, block); \
11854 : : } \
11855 : : while (0)
11856 : :
11857 : 5896 : if (save_descriptor_data (info->descriptor, info->data))
11858 : 5189 : SAVE_VALUE (info->data);
11859 : 5896 : SAVE_VALUE (info->offset);
11860 : 5896 : info->saved_offset = info->offset;
11861 : 14837 : for (int i = 0; i < s->dimen; i++)
11862 : : {
11863 : 8941 : int dim = s->dim[i];
11864 : 8941 : SAVE_VALUE (info->start[dim]);
11865 : 8941 : SAVE_VALUE (info->end[dim]);
11866 : 8941 : SAVE_VALUE (info->stride[dim]);
11867 : 8941 : SAVE_VALUE (info->delta[dim]);
11868 : : }
11869 : :
11870 : : #undef SAVE_VALUE
11871 : : }
11872 : 5896 : }
11873 : :
11874 : :
11875 : : /* Allocate the lhs of an assignment to an allocatable array, otherwise
11876 : : reallocate it. */
11877 : :
11878 : : tree
11879 : 5896 : gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
11880 : : gfc_expr *expr1,
11881 : : gfc_expr *expr2)
11882 : : {
11883 : 5896 : stmtblock_t realloc_block;
11884 : 5896 : stmtblock_t alloc_block;
11885 : 5896 : stmtblock_t fblock;
11886 : 5896 : stmtblock_t loop_pre_block;
11887 : 5896 : gfc_ref *ref;
11888 : 5896 : gfc_ss *rss;
11889 : 5896 : gfc_ss *lss;
11890 : 5896 : gfc_array_info *linfo;
11891 : 5896 : tree realloc_expr;
11892 : 5896 : tree alloc_expr;
11893 : 5896 : tree size1;
11894 : 5896 : tree size2;
11895 : 5896 : tree elemsize1;
11896 : 5896 : tree elemsize2;
11897 : 5896 : tree array1;
11898 : 5896 : tree cond_null;
11899 : 5896 : tree cond;
11900 : 5896 : tree tmp;
11901 : 5896 : tree tmp2;
11902 : 5896 : tree lbound;
11903 : 5896 : tree ubound;
11904 : 5896 : tree desc;
11905 : 5896 : tree old_desc;
11906 : 5896 : tree desc2;
11907 : 5896 : tree offset;
11908 : 5896 : tree jump_label1;
11909 : 5896 : tree jump_label2;
11910 : 5896 : tree lbd;
11911 : 5896 : tree class_expr2 = NULL_TREE;
11912 : 5896 : int n;
11913 : 5896 : gfc_array_spec * as;
11914 : 5896 : bool coarray = (flag_coarray == GFC_FCOARRAY_LIB
11915 : 5896 : && gfc_caf_attr (expr1, true).codimension);
11916 : 5896 : tree token;
11917 : 5896 : gfc_se caf_se;
11918 : :
11919 : : /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
11920 : : Find the lhs expression in the loop chain and set expr1 and
11921 : : expr2 accordingly. */
11922 : 5896 : if (expr1->expr_type == EXPR_FUNCTION && expr2 == NULL)
11923 : : {
11924 : 166 : expr2 = expr1;
11925 : : /* Find the ss for the lhs. */
11926 : 166 : lss = loop->ss;
11927 : 332 : for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
11928 : 332 : if (lss->info->expr && lss->info->expr->expr_type == EXPR_VARIABLE)
11929 : : break;
11930 : 166 : if (lss == gfc_ss_terminator)
11931 : : return NULL_TREE;
11932 : 166 : expr1 = lss->info->expr;
11933 : : }
11934 : :
11935 : : /* Bail out if this is not a valid allocate on assignment. */
11936 : 5896 : if (!gfc_is_reallocatable_lhs (expr1)
11937 : 5896 : || (expr2 && !expr2->rank))
11938 : : return NULL_TREE;
11939 : :
11940 : : /* Find the ss for the lhs. */
11941 : 5896 : lss = loop->ss;
11942 : 14945 : for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
11943 : 14945 : if (lss->info->expr == expr1)
11944 : : break;
11945 : :
11946 : 5896 : if (lss == gfc_ss_terminator)
11947 : : return NULL_TREE;
11948 : :
11949 : 5896 : linfo = &lss->info->data.array;
11950 : :
11951 : : /* Find an ss for the rhs. For operator expressions, we see the
11952 : : ss's for the operands. Any one of these will do. */
11953 : 5896 : rss = loop->ss;
11954 : 6403 : for (; rss && rss != gfc_ss_terminator; rss = rss->loop_chain)
11955 : 6403 : if (rss->info->expr != expr1 && rss != loop->temp_ss)
11956 : : break;
11957 : :
11958 : 5896 : if (expr2 && rss == gfc_ss_terminator)
11959 : : return NULL_TREE;
11960 : :
11961 : : /* Ensure that the string length from the current scope is used. */
11962 : 5896 : if (expr2->ts.type == BT_CHARACTER
11963 : 879 : && expr2->expr_type == EXPR_FUNCTION
11964 : 130 : && !expr2->value.function.isym)
11965 : 21 : expr2->ts.u.cl->backend_decl = rss->info->string_length;
11966 : :
11967 : : /* Since the lhs is allocatable, this must be a descriptor type.
11968 : : Get the data and array size. */
11969 : 5896 : desc = linfo->descriptor;
11970 : 5896 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
11971 : 5896 : array1 = gfc_conv_descriptor_data_get (desc);
11972 : :
11973 : : /* If the data is null, set the descriptor bounds and offset. This suppresses
11974 : : the maybe used uninitialized warning. Note that the always false variable
11975 : : prevents this block from ever being executed, and makes sure that the
11976 : : optimizers are able to remove it. Component references are not subject to
11977 : : the warnings, so we don't uselessly complicate the generated code for them.
11978 : : */
11979 : 10730 : for (ref = expr1->ref; ref; ref = ref->next)
11980 : 6091 : if (ref->type == REF_COMPONENT)
11981 : : break;
11982 : :
11983 : 5896 : if (!ref)
11984 : : {
11985 : 4639 : stmtblock_t unalloc_init_block;
11986 : 4639 : gfc_init_block (&unalloc_init_block);
11987 : 4639 : tree guard = gfc_create_var (logical_type_node, "unallocated_init_guard");
11988 : 4639 : gfc_add_modify (&unalloc_init_block, guard, logical_false_node);
11989 : :
11990 : 4639 : gfc_start_block (&loop_pre_block);
11991 : 16738 : for (n = 0; n < expr1->rank; n++)
11992 : : {
11993 : 7460 : gfc_conv_descriptor_lbound_set (&loop_pre_block, desc,
11994 : : gfc_rank_cst[n],
11995 : : gfc_index_one_node);
11996 : 7460 : gfc_conv_descriptor_ubound_set (&loop_pre_block, desc,
11997 : : gfc_rank_cst[n],
11998 : : gfc_index_zero_node);
11999 : 7460 : gfc_conv_descriptor_stride_set (&loop_pre_block, desc,
12000 : : gfc_rank_cst[n],
12001 : : gfc_index_zero_node);
12002 : : }
12003 : :
12004 : 4639 : gfc_conv_descriptor_offset_set (&loop_pre_block, desc,
12005 : : gfc_index_zero_node);
12006 : :
12007 : 4639 : tmp = fold_build2_loc (input_location, EQ_EXPR,
12008 : : logical_type_node, array1,
12009 : 4639 : build_int_cst (TREE_TYPE (array1), 0));
12010 : 4639 : tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
12011 : : logical_type_node, tmp, guard);
12012 : 4639 : tmp = build3_v (COND_EXPR, tmp,
12013 : : gfc_finish_block (&loop_pre_block),
12014 : : build_empty_stmt (input_location));
12015 : 4639 : gfc_prepend_expr_to_block (&loop->pre, tmp);
12016 : 4639 : gfc_prepend_expr_to_block (&loop->pre,
12017 : : gfc_finish_block (&unalloc_init_block));
12018 : : }
12019 : :
12020 : 5896 : gfc_start_block (&fblock);
12021 : :
12022 : 5896 : if (expr2)
12023 : 5896 : desc2 = rss->info->data.array.descriptor;
12024 : : else
12025 : : desc2 = NULL_TREE;
12026 : :
12027 : : /* Get the old lhs element size for deferred character and class expr1. */
12028 : 5896 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12029 : : {
12030 : 579 : if (expr1->ts.u.cl->backend_decl
12031 : 579 : && VAR_P (expr1->ts.u.cl->backend_decl))
12032 : : elemsize1 = expr1->ts.u.cl->backend_decl;
12033 : : else
12034 : 64 : elemsize1 = lss->info->string_length;
12035 : 579 : tree unit_size = TYPE_SIZE_UNIT (gfc_get_char_type (expr1->ts.kind));
12036 : 1158 : elemsize1 = fold_build2_loc (input_location, MULT_EXPR,
12037 : 579 : TREE_TYPE (elemsize1), elemsize1,
12038 : 579 : fold_convert (TREE_TYPE (elemsize1), unit_size));
12039 : :
12040 : 579 : }
12041 : 5317 : else if (expr1->ts.type == BT_CLASS)
12042 : : {
12043 : : /* Unfortunately, the lhs vptr is set too early in many cases.
12044 : : Play it safe by using the descriptor element length. */
12045 : 561 : tmp = gfc_conv_descriptor_elem_len (desc);
12046 : 561 : elemsize1 = fold_convert (gfc_array_index_type, tmp);
12047 : : }
12048 : : else
12049 : : elemsize1 = NULL_TREE;
12050 : 1140 : if (elemsize1 != NULL_TREE)
12051 : 1140 : elemsize1 = gfc_evaluate_now (elemsize1, &fblock);
12052 : :
12053 : : /* Get the new lhs size in bytes. */
12054 : 5896 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12055 : : {
12056 : 579 : if (expr2->ts.deferred)
12057 : : {
12058 : 183 : if (expr2->ts.u.cl->backend_decl
12059 : 183 : && VAR_P (expr2->ts.u.cl->backend_decl))
12060 : : tmp = expr2->ts.u.cl->backend_decl;
12061 : : else
12062 : 0 : tmp = rss->info->string_length;
12063 : : }
12064 : : else
12065 : : {
12066 : 396 : tmp = expr2->ts.u.cl->backend_decl;
12067 : 396 : if (!tmp && expr2->expr_type == EXPR_OP
12068 : 25 : && expr2->value.op.op == INTRINSIC_CONCAT)
12069 : : {
12070 : 25 : tmp = concat_str_length (expr2);
12071 : 25 : expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
12072 : : }
12073 : 12 : else if (!tmp && expr2->ts.u.cl->length)
12074 : : {
12075 : 12 : gfc_se tmpse;
12076 : 12 : gfc_init_se (&tmpse, NULL);
12077 : 12 : gfc_conv_expr_type (&tmpse, expr2->ts.u.cl->length,
12078 : : gfc_charlen_type_node);
12079 : 12 : tmp = tmpse.expr;
12080 : 12 : expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
12081 : : }
12082 : 396 : tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
12083 : : }
12084 : :
12085 : 579 : if (expr1->ts.u.cl->backend_decl
12086 : 579 : && VAR_P (expr1->ts.u.cl->backend_decl))
12087 : 515 : gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
12088 : : else
12089 : 64 : gfc_add_modify (&fblock, lss->info->string_length, tmp);
12090 : :
12091 : 579 : if (expr1->ts.kind > 1)
12092 : 12 : tmp = fold_build2_loc (input_location, MULT_EXPR,
12093 : 6 : TREE_TYPE (tmp),
12094 : 6 : tmp, build_int_cst (TREE_TYPE (tmp),
12095 : 6 : expr1->ts.kind));
12096 : : }
12097 : 5317 : else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
12098 : : {
12099 : 251 : tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts)));
12100 : 251 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
12101 : : fold_convert (gfc_array_index_type, tmp),
12102 : 251 : expr1->ts.u.cl->backend_decl);
12103 : : }
12104 : 5066 : else if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS)
12105 : 116 : tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
12106 : 4950 : else if (expr1->ts.type == BT_CLASS && expr2->ts.type == BT_CLASS)
12107 : : {
12108 : 268 : tmp = expr2->rank ? gfc_get_class_from_expr (desc2) : NULL_TREE;
12109 : 268 : if (tmp == NULL_TREE && expr2->expr_type == EXPR_VARIABLE)
12110 : 24 : tmp = class_expr2 = gfc_get_class_from_gfc_expr (expr2);
12111 : :
12112 : 31 : if (tmp != NULL_TREE)
12113 : 261 : tmp = gfc_class_vtab_size_get (tmp);
12114 : : else
12115 : 7 : tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&CLASS_DATA (expr2)->ts));
12116 : : }
12117 : : else
12118 : 4682 : tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
12119 : 5896 : elemsize2 = fold_convert (gfc_array_index_type, tmp);
12120 : 5896 : elemsize2 = gfc_evaluate_now (elemsize2, &fblock);
12121 : :
12122 : : /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
12123 : : deallocated if expr is an array of different shape or any of the
12124 : : corresponding length type parameter values of variable and expr
12125 : : differ." This assures F95 compatibility. */
12126 : 5896 : jump_label1 = gfc_build_label_decl (NULL_TREE);
12127 : 5896 : jump_label2 = gfc_build_label_decl (NULL_TREE);
12128 : :
12129 : : /* Allocate if data is NULL. */
12130 : 5896 : cond_null = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
12131 : 5896 : array1, build_int_cst (TREE_TYPE (array1), 0));
12132 : 5896 : cond_null= gfc_evaluate_now (cond_null, &fblock);
12133 : :
12134 : 5896 : tmp = build3_v (COND_EXPR, cond_null,
12135 : : build1_v (GOTO_EXPR, jump_label1),
12136 : : build_empty_stmt (input_location));
12137 : 5896 : gfc_add_expr_to_block (&fblock, tmp);
12138 : :
12139 : : /* Get arrayspec if expr is a full array. */
12140 : 5896 : if (expr2 && expr2->expr_type == EXPR_FUNCTION
12141 : 2736 : && expr2->value.function.isym
12142 : 2290 : && expr2->value.function.isym->conversion)
12143 : : {
12144 : : /* For conversion functions, take the arg. */
12145 : 243 : gfc_expr *arg = expr2->value.function.actual->expr;
12146 : 243 : as = gfc_get_full_arrayspec_from_expr (arg);
12147 : 243 : }
12148 : : else if (expr2)
12149 : 5653 : as = gfc_get_full_arrayspec_from_expr (expr2);
12150 : : else
12151 : : as = NULL;
12152 : :
12153 : : /* If the lhs shape is not the same as the rhs jump to setting the
12154 : : bounds and doing the reallocation....... */
12155 : 14837 : for (n = 0; n < expr1->rank; n++)
12156 : : {
12157 : : /* Check the shape. */
12158 : 8941 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
12159 : 8941 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
12160 : 8941 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
12161 : : gfc_array_index_type,
12162 : : loop->to[n], loop->from[n]);
12163 : 8941 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
12164 : : gfc_array_index_type,
12165 : : tmp, lbound);
12166 : 8941 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
12167 : : gfc_array_index_type,
12168 : : tmp, ubound);
12169 : 8941 : cond = fold_build2_loc (input_location, NE_EXPR,
12170 : : logical_type_node,
12171 : : tmp, gfc_index_zero_node);
12172 : 8941 : tmp = build3_v (COND_EXPR, cond,
12173 : : build1_v (GOTO_EXPR, jump_label1),
12174 : : build_empty_stmt (input_location));
12175 : 8941 : gfc_add_expr_to_block (&fblock, tmp);
12176 : : }
12177 : :
12178 : : /* ...else if the element lengths are not the same also go to
12179 : : setting the bounds and doing the reallocation.... */
12180 : 5896 : if (elemsize1 != NULL_TREE)
12181 : : {
12182 : 1140 : cond = fold_build2_loc (input_location, NE_EXPR,
12183 : : logical_type_node,
12184 : : elemsize1, elemsize2);
12185 : 1140 : tmp = build3_v (COND_EXPR, cond,
12186 : : build1_v (GOTO_EXPR, jump_label1),
12187 : : build_empty_stmt (input_location));
12188 : 1140 : gfc_add_expr_to_block (&fblock, tmp);
12189 : : }
12190 : :
12191 : : /* ....else jump past the (re)alloc code. */
12192 : 5896 : tmp = build1_v (GOTO_EXPR, jump_label2);
12193 : 5896 : gfc_add_expr_to_block (&fblock, tmp);
12194 : :
12195 : : /* Add the label to start automatic (re)allocation. */
12196 : 5896 : tmp = build1_v (LABEL_EXPR, jump_label1);
12197 : 5896 : gfc_add_expr_to_block (&fblock, tmp);
12198 : :
12199 : : /* Get the rhs size and fix it. */
12200 : 5896 : size2 = gfc_index_one_node;
12201 : 14837 : for (n = 0; n < expr2->rank; n++)
12202 : : {
12203 : 8941 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
12204 : : gfc_array_index_type,
12205 : : loop->to[n], loop->from[n]);
12206 : 8941 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
12207 : : gfc_array_index_type,
12208 : : tmp, gfc_index_one_node);
12209 : 8941 : size2 = fold_build2_loc (input_location, MULT_EXPR,
12210 : : gfc_array_index_type,
12211 : : tmp, size2);
12212 : : }
12213 : 5896 : size2 = gfc_evaluate_now (size2, &fblock);
12214 : :
12215 : : /* Deallocation of allocatable components will have to occur on
12216 : : reallocation. Fix the old descriptor now. */
12217 : 5896 : if ((expr1->ts.type == BT_DERIVED)
12218 : 289 : && expr1->ts.u.derived->attr.alloc_comp)
12219 : 109 : old_desc = gfc_evaluate_now (desc, &fblock);
12220 : : else
12221 : : old_desc = NULL_TREE;
12222 : :
12223 : : /* Now modify the lhs descriptor and the associated scalarizer
12224 : : variables. F2003 7.4.1.3: "If variable is or becomes an
12225 : : unallocated allocatable variable, then it is allocated with each
12226 : : deferred type parameter equal to the corresponding type parameters
12227 : : of expr , with the shape of expr , and with each lower bound equal
12228 : : to the corresponding element of LBOUND(expr)."
12229 : : Reuse size1 to keep a dimension-by-dimension track of the
12230 : : stride of the new array. */
12231 : 5896 : size1 = gfc_index_one_node;
12232 : 5896 : offset = gfc_index_zero_node;
12233 : :
12234 : 14837 : for (n = 0; n < expr2->rank; n++)
12235 : : {
12236 : 8941 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
12237 : : gfc_array_index_type,
12238 : : loop->to[n], loop->from[n]);
12239 : 8941 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
12240 : : gfc_array_index_type,
12241 : : tmp, gfc_index_one_node);
12242 : :
12243 : 8941 : lbound = gfc_index_one_node;
12244 : 8941 : ubound = tmp;
12245 : :
12246 : 8941 : if (as)
12247 : : {
12248 : 1960 : lbd = get_std_lbound (expr2, desc2, n,
12249 : 980 : as->type == AS_ASSUMED_SIZE);
12250 : 980 : ubound = fold_build2_loc (input_location,
12251 : : MINUS_EXPR,
12252 : : gfc_array_index_type,
12253 : : ubound, lbound);
12254 : 980 : ubound = fold_build2_loc (input_location,
12255 : : PLUS_EXPR,
12256 : : gfc_array_index_type,
12257 : : ubound, lbd);
12258 : 980 : lbound = lbd;
12259 : : }
12260 : :
12261 : 8941 : gfc_conv_descriptor_lbound_set (&fblock, desc,
12262 : : gfc_rank_cst[n],
12263 : : lbound);
12264 : 8941 : gfc_conv_descriptor_ubound_set (&fblock, desc,
12265 : : gfc_rank_cst[n],
12266 : : ubound);
12267 : 8941 : gfc_conv_descriptor_stride_set (&fblock, desc,
12268 : : gfc_rank_cst[n],
12269 : : size1);
12270 : 8941 : lbound = gfc_conv_descriptor_lbound_get (desc,
12271 : : gfc_rank_cst[n]);
12272 : 8941 : tmp2 = fold_build2_loc (input_location, MULT_EXPR,
12273 : : gfc_array_index_type,
12274 : : lbound, size1);
12275 : 8941 : offset = fold_build2_loc (input_location, MINUS_EXPR,
12276 : : gfc_array_index_type,
12277 : : offset, tmp2);
12278 : 8941 : size1 = fold_build2_loc (input_location, MULT_EXPR,
12279 : : gfc_array_index_type,
12280 : : tmp, size1);
12281 : : }
12282 : :
12283 : : /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
12284 : : the array offset is saved and the info.offset is used for a
12285 : : running offset. Use the saved_offset instead. */
12286 : 5896 : tmp = gfc_conv_descriptor_offset (desc);
12287 : 5896 : gfc_add_modify (&fblock, tmp, offset);
12288 : :
12289 : : /* Take into account _len of unlimited polymorphic entities, so that span
12290 : : for array descriptors and allocation sizes are computed correctly. */
12291 : 5896 : if (UNLIMITED_POLY (expr2))
12292 : : {
12293 : 92 : tree len = gfc_class_len_get (TREE_OPERAND (desc2, 0));
12294 : 92 : len = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
12295 : : fold_convert (size_type_node, len),
12296 : : size_one_node);
12297 : 92 : elemsize2 = fold_build2_loc (input_location, MULT_EXPR,
12298 : : gfc_array_index_type, elemsize2,
12299 : : fold_convert (gfc_array_index_type, len));
12300 : : }
12301 : :
12302 : 5896 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
12303 : 5896 : gfc_conv_descriptor_span_set (&fblock, desc, elemsize2);
12304 : :
12305 : 5896 : size2 = fold_build2_loc (input_location, MULT_EXPR,
12306 : : gfc_array_index_type,
12307 : : elemsize2, size2);
12308 : 5896 : size2 = fold_convert (size_type_node, size2);
12309 : 5896 : size2 = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
12310 : : size2, size_one_node);
12311 : 5896 : size2 = gfc_evaluate_now (size2, &fblock);
12312 : :
12313 : : /* For deferred character length, the 'size' field of the dtype might
12314 : : have changed so set the dtype. */
12315 : 5896 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
12316 : 5896 : && expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12317 : : {
12318 : 579 : tree type;
12319 : 579 : tmp = gfc_conv_descriptor_dtype (desc);
12320 : 579 : if (expr2->ts.u.cl->backend_decl)
12321 : 579 : type = gfc_typenode_for_spec (&expr2->ts);
12322 : : else
12323 : 0 : type = gfc_typenode_for_spec (&expr1->ts);
12324 : :
12325 : 579 : gfc_add_modify (&fblock, tmp,
12326 : : gfc_get_dtype_rank_type (expr1->rank,type));
12327 : : }
12328 : 5317 : else if (expr1->ts.type == BT_CLASS)
12329 : : {
12330 : 561 : tree type;
12331 : 561 : tmp = gfc_conv_descriptor_dtype (desc);
12332 : :
12333 : 561 : if (expr2->ts.type != BT_CLASS)
12334 : 293 : type = gfc_typenode_for_spec (&expr2->ts);
12335 : : else
12336 : 268 : type = gfc_get_character_type_len (1, elemsize2);
12337 : :
12338 : 561 : gfc_add_modify (&fblock, tmp,
12339 : : gfc_get_dtype_rank_type (expr2->rank,type));
12340 : : /* Set the _len field as well... */
12341 : 561 : if (UNLIMITED_POLY (expr1))
12342 : : {
12343 : 208 : tmp = gfc_class_len_get (TREE_OPERAND (desc, 0));
12344 : 208 : if (expr2->ts.type == BT_CHARACTER)
12345 : 49 : gfc_add_modify (&fblock, tmp,
12346 : 49 : fold_convert (TREE_TYPE (tmp),
12347 : : TYPE_SIZE_UNIT (type)));
12348 : 159 : else if (UNLIMITED_POLY (expr2))
12349 : 92 : gfc_add_modify (&fblock, tmp,
12350 : 92 : gfc_class_len_get (TREE_OPERAND (desc2, 0)));
12351 : : else
12352 : 67 : gfc_add_modify (&fblock, tmp,
12353 : 67 : build_int_cst (TREE_TYPE (tmp), 0));
12354 : : }
12355 : : /* ...and the vptr. */
12356 : 561 : tmp = gfc_class_vptr_get (TREE_OPERAND (desc, 0));
12357 : 561 : if (expr2->ts.type == BT_CLASS && !VAR_P (desc2)
12358 : 261 : && TREE_CODE (desc2) == COMPONENT_REF)
12359 : : {
12360 : 237 : tmp2 = gfc_get_class_from_expr (desc2);
12361 : 237 : tmp2 = gfc_class_vptr_get (tmp2);
12362 : : }
12363 : 324 : else if (expr2->ts.type == BT_CLASS && class_expr2 != NULL_TREE)
12364 : 24 : tmp2 = gfc_class_vptr_get (class_expr2);
12365 : : else
12366 : : {
12367 : 300 : tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts));
12368 : 300 : tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2);
12369 : : }
12370 : :
12371 : 561 : gfc_add_modify (&fblock, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
12372 : : }
12373 : 4756 : else if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
12374 : : {
12375 : 38 : gfc_add_modify (&fblock, gfc_conv_descriptor_dtype (desc),
12376 : 38 : gfc_get_dtype (TREE_TYPE (desc)));
12377 : : }
12378 : :
12379 : : /* Realloc expression. Note that the scalarizer uses desc.data
12380 : : in the array reference - (*desc.data)[<element>]. */
12381 : 5896 : gfc_init_block (&realloc_block);
12382 : 5896 : gfc_init_se (&caf_se, NULL);
12383 : :
12384 : 5896 : if (coarray)
12385 : : {
12386 : 38 : token = gfc_get_ultimate_alloc_ptr_comps_caf_token (&caf_se, expr1);
12387 : 38 : if (token == NULL_TREE)
12388 : : {
12389 : 8 : tmp = gfc_get_tree_for_caf_expr (expr1);
12390 : 8 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
12391 : 6 : tmp = build_fold_indirect_ref (tmp);
12392 : 8 : gfc_get_caf_token_offset (&caf_se, &token, NULL, tmp, NULL_TREE,
12393 : : expr1);
12394 : 8 : token = gfc_build_addr_expr (NULL_TREE, token);
12395 : : }
12396 : :
12397 : 38 : gfc_add_block_to_block (&realloc_block, &caf_se.pre);
12398 : : }
12399 : 5896 : if ((expr1->ts.type == BT_DERIVED)
12400 : 289 : && expr1->ts.u.derived->attr.alloc_comp)
12401 : : {
12402 : 109 : tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, old_desc,
12403 : : expr1->rank, true);
12404 : 109 : gfc_add_expr_to_block (&realloc_block, tmp);
12405 : : }
12406 : :
12407 : 5896 : if (!coarray)
12408 : : {
12409 : 5858 : tmp = build_call_expr_loc (input_location,
12410 : : builtin_decl_explicit (BUILT_IN_REALLOC), 2,
12411 : : fold_convert (pvoid_type_node, array1),
12412 : : size2);
12413 : 5858 : if (flag_openmp_allocators)
12414 : : {
12415 : 2 : tree cond, omp_tmp;
12416 : 2 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
12417 : : gfc_conv_descriptor_version (desc),
12418 : : build_int_cst (integer_type_node, 1));
12419 : 2 : omp_tmp = builtin_decl_explicit (BUILT_IN_GOMP_REALLOC);
12420 : 2 : omp_tmp = build_call_expr_loc (input_location, omp_tmp, 4,
12421 : : fold_convert (pvoid_type_node, array1), size2,
12422 : : build_zero_cst (ptr_type_node),
12423 : : build_zero_cst (ptr_type_node));
12424 : 2 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond,
12425 : : omp_tmp, tmp);
12426 : : }
12427 : :
12428 : 5858 : gfc_conv_descriptor_data_set (&realloc_block, desc, tmp);
12429 : : }
12430 : : else
12431 : : {
12432 : 38 : tmp = build_call_expr_loc (input_location,
12433 : : gfor_fndecl_caf_deregister, 5, token,
12434 : : build_int_cst (integer_type_node,
12435 : : GFC_CAF_COARRAY_DEALLOCATE_ONLY),
12436 : : null_pointer_node, null_pointer_node,
12437 : : integer_zero_node);
12438 : 38 : gfc_add_expr_to_block (&realloc_block, tmp);
12439 : 38 : tmp = build_call_expr_loc (input_location,
12440 : : gfor_fndecl_caf_register,
12441 : : 7, size2,
12442 : : build_int_cst (integer_type_node,
12443 : : GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY),
12444 : : token, gfc_build_addr_expr (NULL_TREE, desc),
12445 : : null_pointer_node, null_pointer_node,
12446 : : integer_zero_node);
12447 : 38 : gfc_add_expr_to_block (&realloc_block, tmp);
12448 : : }
12449 : :
12450 : 5896 : if ((expr1->ts.type == BT_DERIVED)
12451 : 289 : && expr1->ts.u.derived->attr.alloc_comp)
12452 : : {
12453 : 109 : tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc,
12454 : : expr1->rank);
12455 : 109 : gfc_add_expr_to_block (&realloc_block, tmp);
12456 : : }
12457 : :
12458 : 5896 : gfc_add_block_to_block (&realloc_block, &caf_se.post);
12459 : 5896 : realloc_expr = gfc_finish_block (&realloc_block);
12460 : :
12461 : : /* Malloc expression. */
12462 : 5896 : gfc_init_block (&alloc_block);
12463 : 5896 : if (!coarray)
12464 : : {
12465 : 5858 : tmp = build_call_expr_loc (input_location,
12466 : : builtin_decl_explicit (BUILT_IN_MALLOC),
12467 : : 1, size2);
12468 : 5858 : gfc_conv_descriptor_data_set (&alloc_block,
12469 : : desc, tmp);
12470 : : }
12471 : : else
12472 : : {
12473 : 38 : tmp = build_call_expr_loc (input_location,
12474 : : gfor_fndecl_caf_register,
12475 : : 7, size2,
12476 : : build_int_cst (integer_type_node,
12477 : : GFC_CAF_COARRAY_ALLOC),
12478 : : token, gfc_build_addr_expr (NULL_TREE, desc),
12479 : : null_pointer_node, null_pointer_node,
12480 : : integer_zero_node);
12481 : 38 : gfc_add_expr_to_block (&alloc_block, tmp);
12482 : : }
12483 : :
12484 : :
12485 : : /* We already set the dtype in the case of deferred character
12486 : : length arrays and class lvalues. */
12487 : 5896 : if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
12488 : 5896 : && ((expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12489 : 5317 : || coarray))
12490 : 11175 : && expr1->ts.type != BT_CLASS)
12491 : : {
12492 : 4718 : tmp = gfc_conv_descriptor_dtype (desc);
12493 : 4718 : gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
12494 : : }
12495 : :
12496 : 5896 : if ((expr1->ts.type == BT_DERIVED)
12497 : 289 : && expr1->ts.u.derived->attr.alloc_comp)
12498 : : {
12499 : 109 : tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc,
12500 : : expr1->rank);
12501 : 109 : gfc_add_expr_to_block (&alloc_block, tmp);
12502 : : }
12503 : 5896 : alloc_expr = gfc_finish_block (&alloc_block);
12504 : :
12505 : : /* Malloc if not allocated; realloc otherwise. */
12506 : 5896 : tmp = build3_v (COND_EXPR, cond_null, alloc_expr, realloc_expr);
12507 : 5896 : gfc_add_expr_to_block (&fblock, tmp);
12508 : :
12509 : : /* Add the label for same shape lhs and rhs. */
12510 : 5896 : tmp = build1_v (LABEL_EXPR, jump_label2);
12511 : 5896 : gfc_add_expr_to_block (&fblock, tmp);
12512 : :
12513 : 5896 : tree realloc_code = gfc_finish_block (&fblock);
12514 : :
12515 : 5896 : stmtblock_t result_block;
12516 : 5896 : gfc_init_block (&result_block);
12517 : 5896 : gfc_add_expr_to_block (&result_block, realloc_code);
12518 : 5896 : update_reallocated_descriptor (&result_block, loop);
12519 : :
12520 : 5896 : return gfc_finish_block (&result_block);
12521 : : }
12522 : :
12523 : :
12524 : : /* Initialize class descriptor's TKR information. */
12525 : :
12526 : : void
12527 : 2837 : gfc_trans_class_array (gfc_symbol * sym, gfc_wrapped_block * block)
12528 : : {
12529 : 2837 : tree type, etype;
12530 : 2837 : tree tmp;
12531 : 2837 : tree descriptor;
12532 : 2837 : stmtblock_t init;
12533 : 2837 : int rank;
12534 : :
12535 : : /* Make sure the frontend gets these right. */
12536 : 2837 : gcc_assert (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
12537 : : && (CLASS_DATA (sym)->attr.class_pointer
12538 : : || CLASS_DATA (sym)->attr.allocatable));
12539 : :
12540 : 2837 : gcc_assert (VAR_P (sym->backend_decl)
12541 : : || TREE_CODE (sym->backend_decl) == PARM_DECL);
12542 : :
12543 : 2837 : if (sym->attr.dummy)
12544 : 1408 : return;
12545 : :
12546 : 2837 : descriptor = gfc_class_data_get (sym->backend_decl);
12547 : 2837 : type = TREE_TYPE (descriptor);
12548 : :
12549 : 2837 : if (type == NULL || !GFC_DESCRIPTOR_TYPE_P (type))
12550 : : return;
12551 : :
12552 : 1429 : location_t loc = input_location;
12553 : 1429 : input_location = gfc_get_location (&sym->declared_at);
12554 : 1429 : gfc_init_block (&init);
12555 : :
12556 : 1429 : rank = CLASS_DATA (sym)->as ? (CLASS_DATA (sym)->as->rank) : (0);
12557 : 1429 : gcc_assert (rank>=0);
12558 : 1429 : tmp = gfc_conv_descriptor_dtype (descriptor);
12559 : 1429 : etype = gfc_get_element_type (type);
12560 : 1429 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (tmp), tmp,
12561 : : gfc_get_dtype_rank_type (rank, etype));
12562 : 1429 : gfc_add_expr_to_block (&init, tmp);
12563 : :
12564 : 1429 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
12565 : 1429 : input_location = loc;
12566 : : }
12567 : :
12568 : :
12569 : : /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
12570 : : Do likewise, recursively if necessary, with the allocatable components of
12571 : : derived types. This function is also called for assumed-rank arrays, which
12572 : : are always dummy arguments. */
12573 : :
12574 : : void
12575 : 17019 : gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
12576 : : {
12577 : 17019 : tree type;
12578 : 17019 : tree tmp;
12579 : 17019 : tree descriptor;
12580 : 17019 : stmtblock_t init;
12581 : 17019 : stmtblock_t cleanup;
12582 : 17019 : int rank;
12583 : 17019 : bool sym_has_alloc_comp, has_finalizer;
12584 : :
12585 : 34038 : sym_has_alloc_comp = (sym->ts.type == BT_DERIVED
12586 : 10676 : || sym->ts.type == BT_CLASS)
12587 : 17019 : && sym->ts.u.derived->attr.alloc_comp;
12588 : 17019 : has_finalizer = gfc_may_be_finalized (sym->ts);
12589 : :
12590 : : /* Make sure the frontend gets these right. */
12591 : 17019 : gcc_assert (sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp
12592 : : || has_finalizer
12593 : : || (sym->as->type == AS_ASSUMED_RANK && sym->attr.dummy));
12594 : :
12595 : 17019 : location_t loc = input_location;
12596 : 17019 : input_location = gfc_get_location (&sym->declared_at);
12597 : 17019 : gfc_init_block (&init);
12598 : :
12599 : 17019 : gcc_assert (VAR_P (sym->backend_decl)
12600 : : || TREE_CODE (sym->backend_decl) == PARM_DECL);
12601 : :
12602 : 17019 : if (sym->ts.type == BT_CHARACTER
12603 : 1331 : && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
12604 : : {
12605 : 778 : if (sym->ts.deferred && !sym->ts.u.cl->length && !sym->attr.dummy)
12606 : : {
12607 : 586 : tree len_expr = sym->ts.u.cl->backend_decl;
12608 : 586 : tree init_val = build_zero_cst (TREE_TYPE (len_expr));
12609 : 586 : if (VAR_P (len_expr)
12610 : 586 : && sym->attr.save
12611 : 641 : && !DECL_INITIAL (len_expr))
12612 : 55 : DECL_INITIAL (len_expr) = init_val;
12613 : : else
12614 : 531 : gfc_add_modify (&init, len_expr, init_val);
12615 : : }
12616 : 778 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
12617 : 778 : gfc_trans_vla_type_sizes (sym, &init);
12618 : :
12619 : : /* Presence check of optional deferred-length character dummy. */
12620 : 778 : if (sym->ts.deferred && sym->attr.dummy && sym->attr.optional)
12621 : : {
12622 : 43 : tmp = gfc_finish_block (&init);
12623 : 43 : tmp = build3_v (COND_EXPR, gfc_conv_expr_present (sym),
12624 : : tmp, build_empty_stmt (input_location));
12625 : 43 : gfc_add_expr_to_block (&init, tmp);
12626 : : }
12627 : : }
12628 : :
12629 : : /* Dummy, use associated and result variables don't need anything special. */
12630 : 17019 : if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result)
12631 : : {
12632 : 732 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
12633 : 732 : input_location = loc;
12634 : 1006 : return;
12635 : : }
12636 : :
12637 : 16287 : descriptor = sym->backend_decl;
12638 : :
12639 : : /* Although static, derived types with default initializers and
12640 : : allocatable components must not be nulled wholesale; instead they
12641 : : are treated component by component. */
12642 : 16287 : if (TREE_STATIC (descriptor) && !sym_has_alloc_comp && !has_finalizer)
12643 : : {
12644 : : /* SAVEd variables are not freed on exit. */
12645 : 274 : gfc_trans_static_array_pointer (sym);
12646 : :
12647 : 274 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
12648 : 274 : input_location = loc;
12649 : 274 : return;
12650 : : }
12651 : :
12652 : : /* Get the descriptor type. */
12653 : 16013 : type = TREE_TYPE (sym->backend_decl);
12654 : :
12655 : 16013 : if ((sym_has_alloc_comp || (has_finalizer && sym->ts.type != BT_CLASS))
12656 : 4925 : && !(sym->attr.pointer || sym->attr.allocatable))
12657 : : {
12658 : 2683 : if (!sym->attr.save
12659 : 2304 : && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program))
12660 : : {
12661 : 2304 : if (sym->value == NULL
12662 : 2304 : || !gfc_has_default_initializer (sym->ts.u.derived))
12663 : : {
12664 : 1939 : rank = sym->as ? sym->as->rank : 0;
12665 : 1939 : tmp = gfc_nullify_alloc_comp (sym->ts.u.derived,
12666 : : descriptor, rank);
12667 : 1939 : gfc_add_expr_to_block (&init, tmp);
12668 : : }
12669 : : else
12670 : 365 : gfc_init_default_dt (sym, &init, false);
12671 : : }
12672 : : }
12673 : 13330 : else if (!GFC_DESCRIPTOR_TYPE_P (type))
12674 : : {
12675 : : /* If the backend_decl is not a descriptor, we must have a pointer
12676 : : to one. */
12677 : 1745 : descriptor = build_fold_indirect_ref_loc (input_location,
12678 : : sym->backend_decl);
12679 : 1745 : type = TREE_TYPE (descriptor);
12680 : : }
12681 : :
12682 : : /* NULLIFY the data pointer for non-saved allocatables, or for non-saved
12683 : : pointers when -fcheck=pointer is specified. */
12684 : 27598 : if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save
12685 : 27585 : && (sym->attr.allocatable
12686 : 3272 : || (sym->attr.pointer && (gfc_option.rtcheck & GFC_RTCHECK_POINTER))))
12687 : : {
12688 : 8343 : gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node);
12689 : 8343 : if (flag_coarray == GFC_FCOARRAY_LIB && sym->attr.codimension)
12690 : : {
12691 : : /* Declare the variable static so its array descriptor stays present
12692 : : after leaving the scope. It may still be accessed through another
12693 : : image. This may happen, for example, with the caf_mpi
12694 : : implementation. */
12695 : 104 : TREE_STATIC (descriptor) = 1;
12696 : 104 : tmp = gfc_conv_descriptor_token (descriptor);
12697 : 104 : gfc_add_modify (&init, tmp, fold_convert (TREE_TYPE (tmp),
12698 : : null_pointer_node));
12699 : : }
12700 : : }
12701 : :
12702 : : /* Set initial TKR for pointers and allocatables */
12703 : 16013 : if (GFC_DESCRIPTOR_TYPE_P (type)
12704 : 16013 : && (sym->attr.pointer || sym->attr.allocatable))
12705 : : {
12706 : 11585 : tree etype;
12707 : :
12708 : 11585 : gcc_assert (sym->as && sym->as->rank>=0);
12709 : 11585 : tmp = gfc_conv_descriptor_dtype (descriptor);
12710 : 11585 : etype = gfc_get_element_type (type);
12711 : 11585 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
12712 : 11585 : TREE_TYPE (tmp), tmp,
12713 : 11585 : gfc_get_dtype_rank_type (sym->as->rank, etype));
12714 : 11585 : gfc_add_expr_to_block (&init, tmp);
12715 : : }
12716 : 16013 : input_location = loc;
12717 : 16013 : gfc_init_block (&cleanup);
12718 : :
12719 : : /* Allocatable arrays need to be freed when they go out of scope.
12720 : : The allocatable components of pointers must not be touched. */
12721 : 16013 : if (!sym->attr.allocatable && has_finalizer && sym->ts.type != BT_CLASS
12722 : 523 : && !sym->attr.pointer && !sym->attr.artificial && !sym->attr.save
12723 : 260 : && !sym->ns->proc_name->attr.is_main_program)
12724 : : {
12725 : 222 : gfc_expr *e;
12726 : 222 : sym->attr.referenced = 1;
12727 : 222 : e = gfc_lval_expr_from_sym (sym);
12728 : 222 : gfc_add_finalizer_call (&cleanup, e);
12729 : 222 : gfc_free_expr (e);
12730 : 222 : }
12731 : 15791 : else if ((!sym->attr.allocatable || !has_finalizer)
12732 : 15668 : && sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
12733 : 4435 : && !sym->attr.pointer && !sym->attr.save
12734 : 2285 : && !(sym->attr.artificial && sym->name[0] == '_')
12735 : 2230 : && !sym->ns->proc_name->attr.is_main_program)
12736 : : {
12737 : 611 : int rank;
12738 : 611 : rank = sym->as ? sym->as->rank : 0;
12739 : 611 : tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank,
12740 : 611 : (sym->attr.codimension
12741 : 2 : && flag_coarray == GFC_FCOARRAY_LIB)
12742 : : ? GFC_STRUCTURE_CAF_MODE_IN_COARRAY
12743 : : : 0);
12744 : 611 : gfc_add_expr_to_block (&cleanup, tmp);
12745 : : }
12746 : :
12747 : 16013 : if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension)
12748 : 8307 : && !sym->attr.save && !sym->attr.result
12749 : 8300 : && !sym->ns->proc_name->attr.is_main_program)
12750 : : {
12751 : 4458 : gfc_expr *e;
12752 : 4458 : e = has_finalizer ? gfc_lval_expr_from_sym (sym) : NULL;
12753 : 8916 : tmp = gfc_deallocate_with_status (sym->backend_decl, NULL_TREE, NULL_TREE,
12754 : : NULL_TREE, NULL_TREE, true, e,
12755 : 4458 : sym->attr.codimension
12756 : : ? GFC_CAF_COARRAY_DEREGISTER
12757 : : : GFC_CAF_COARRAY_NOCOARRAY,
12758 : : NULL_TREE, gfc_finish_block (&cleanup));
12759 : 4458 : if (e)
12760 : 44 : gfc_free_expr (e);
12761 : 4458 : gfc_init_block (&cleanup);
12762 : 4458 : gfc_add_expr_to_block (&cleanup, tmp);
12763 : : }
12764 : :
12765 : 16013 : gfc_add_init_cleanup (block, gfc_finish_block (&init),
12766 : : gfc_finish_block (&cleanup));
12767 : : }
12768 : :
12769 : : /************ Expression Walking Functions ******************/
12770 : :
12771 : : /* Walk a variable reference.
12772 : :
12773 : : Possible extension - multiple component subscripts.
12774 : : x(:,:) = foo%a(:)%b(:)
12775 : : Transforms to
12776 : : forall (i=..., j=...)
12777 : : x(i,j) = foo%a(j)%b(i)
12778 : : end forall
12779 : : This adds a fair amount of complexity because you need to deal with more
12780 : : than one ref. Maybe handle in a similar manner to vector subscripts.
12781 : : Maybe not worth the effort. */
12782 : :
12783 : :
12784 : : static gfc_ss *
12785 : 665343 : gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
12786 : : {
12787 : 665343 : gfc_ref *ref;
12788 : :
12789 : 665343 : gfc_fix_class_refs (expr);
12790 : :
12791 : 774426 : for (ref = expr->ref; ref; ref = ref->next)
12792 : 428468 : if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
12793 : : break;
12794 : :
12795 : 665343 : return gfc_walk_array_ref (ss, expr, ref);
12796 : : }
12797 : :
12798 : : gfc_ss *
12799 : 665594 : gfc_walk_array_ref (gfc_ss *ss, gfc_expr *expr, gfc_ref *ref, bool array_only)
12800 : : {
12801 : 665594 : gfc_array_ref *ar;
12802 : 665594 : gfc_ss *newss;
12803 : 665594 : int n;
12804 : :
12805 : 993169 : for (; ref; ref = ref->next)
12806 : : {
12807 : 327575 : if (ref->type == REF_SUBSTRING)
12808 : : {
12809 : 1314 : ss = gfc_get_scalar_ss (ss, ref->u.ss.start);
12810 : 1314 : if (ref->u.ss.end)
12811 : 1288 : ss = gfc_get_scalar_ss (ss, ref->u.ss.end);
12812 : : }
12813 : :
12814 : : /* We're only interested in array sections from now on. */
12815 : 327575 : if (ref->type != REF_ARRAY
12816 : 319930 : || (array_only && ref->u.ar.as && ref->u.ar.as->rank == 0))
12817 : 7742 : continue;
12818 : :
12819 : 319833 : ar = &ref->u.ar;
12820 : :
12821 : 319833 : switch (ar->type)
12822 : : {
12823 : 224 : case AR_ELEMENT:
12824 : 495 : for (n = ar->dimen - 1; n >= 0; n--)
12825 : 271 : ss = gfc_get_scalar_ss (ss, ar->start[n]);
12826 : : break;
12827 : :
12828 : 264539 : case AR_FULL:
12829 : : /* Assumed shape arrays from interface mapping need this fix. */
12830 : 264539 : if (!ar->as && expr->symtree->n.sym->as)
12831 : : {
12832 : 6 : ar->as = gfc_get_array_spec();
12833 : 6 : *ar->as = *expr->symtree->n.sym->as;
12834 : : }
12835 : 264539 : newss = gfc_get_array_ss (ss, expr, ar->as->rank, GFC_SS_SECTION);
12836 : 264539 : newss->info->data.array.ref = ref;
12837 : :
12838 : : /* Make sure array is the same as array(:,:), this way
12839 : : we don't need to special case all the time. */
12840 : 264539 : ar->dimen = ar->as->rank;
12841 : 614604 : for (n = 0; n < ar->dimen; n++)
12842 : : {
12843 : 350065 : ar->dimen_type[n] = DIMEN_RANGE;
12844 : :
12845 : 350065 : gcc_assert (ar->start[n] == NULL);
12846 : 350065 : gcc_assert (ar->end[n] == NULL);
12847 : 350065 : gcc_assert (ar->stride[n] == NULL);
12848 : : }
12849 : : ss = newss;
12850 : : break;
12851 : :
12852 : 55070 : case AR_SECTION:
12853 : 55070 : newss = gfc_get_array_ss (ss, expr, 0, GFC_SS_SECTION);
12854 : 55070 : newss->info->data.array.ref = ref;
12855 : :
12856 : : /* We add SS chains for all the subscripts in the section. */
12857 : 142209 : for (n = 0; n < ar->dimen; n++)
12858 : : {
12859 : 87139 : gfc_ss *indexss;
12860 : :
12861 : 87139 : switch (ar->dimen_type[n])
12862 : : {
12863 : 6571 : case DIMEN_ELEMENT:
12864 : : /* Add SS for elemental (scalar) subscripts. */
12865 : 6571 : gcc_assert (ar->start[n]);
12866 : 6571 : indexss = gfc_get_scalar_ss (gfc_ss_terminator, ar->start[n]);
12867 : 6571 : indexss->loop_chain = gfc_ss_terminator;
12868 : 6571 : newss->info->data.array.subscript[n] = indexss;
12869 : 6571 : break;
12870 : :
12871 : 79762 : case DIMEN_RANGE:
12872 : : /* We don't add anything for sections, just remember this
12873 : : dimension for later. */
12874 : 79762 : newss->dim[newss->dimen] = n;
12875 : 79762 : newss->dimen++;
12876 : 79762 : break;
12877 : :
12878 : 806 : case DIMEN_VECTOR:
12879 : : /* Create a GFC_SS_VECTOR index in which we can store
12880 : : the vector's descriptor. */
12881 : 806 : indexss = gfc_get_array_ss (gfc_ss_terminator, ar->start[n],
12882 : : 1, GFC_SS_VECTOR);
12883 : 806 : indexss->loop_chain = gfc_ss_terminator;
12884 : 806 : newss->info->data.array.subscript[n] = indexss;
12885 : 806 : newss->dim[newss->dimen] = n;
12886 : 806 : newss->dimen++;
12887 : 806 : break;
12888 : :
12889 : 0 : default:
12890 : : /* We should know what sort of section it is by now. */
12891 : 0 : gcc_unreachable ();
12892 : : }
12893 : : }
12894 : : /* We should have at least one non-elemental dimension,
12895 : : unless we are creating a descriptor for a (scalar) coarray. */
12896 : 55070 : gcc_assert (newss->dimen > 0
12897 : : || newss->info->data.array.ref->u.ar.as->corank > 0);
12898 : : ss = newss;
12899 : : break;
12900 : :
12901 : 0 : default:
12902 : : /* We should know what sort of section it is by now. */
12903 : 0 : gcc_unreachable ();
12904 : : }
12905 : :
12906 : : }
12907 : 665594 : return ss;
12908 : : }
12909 : :
12910 : :
12911 : : /* Walk an expression operator. If only one operand of a binary expression is
12912 : : scalar, we must also add the scalar term to the SS chain. */
12913 : :
12914 : : static gfc_ss *
12915 : 54771 : gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
12916 : : {
12917 : 54771 : gfc_ss *head;
12918 : 54771 : gfc_ss *head2;
12919 : :
12920 : 54771 : head = gfc_walk_subexpr (ss, expr->value.op.op1);
12921 : 54771 : if (expr->value.op.op2 == NULL)
12922 : : head2 = head;
12923 : : else
12924 : 52792 : head2 = gfc_walk_subexpr (head, expr->value.op.op2);
12925 : :
12926 : : /* All operands are scalar. Pass back and let the caller deal with it. */
12927 : 54771 : if (head2 == ss)
12928 : : return head2;
12929 : :
12930 : : /* All operands require scalarization. */
12931 : 50258 : if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
12932 : : return head2;
12933 : :
12934 : : /* One of the operands needs scalarization, the other is scalar.
12935 : : Create a gfc_ss for the scalar expression. */
12936 : 18743 : if (head == ss)
12937 : : {
12938 : : /* First operand is scalar. We build the chain in reverse order, so
12939 : : add the scalar SS after the second operand. */
12940 : : head = head2;
12941 : 2266 : while (head && head->next != ss)
12942 : : head = head->next;
12943 : : /* Check we haven't somehow broken the chain. */
12944 : 2023 : gcc_assert (head);
12945 : 2023 : head->next = gfc_get_scalar_ss (ss, expr->value.op.op1);
12946 : : }
12947 : : else /* head2 == head */
12948 : : {
12949 : 16720 : gcc_assert (head2 == head);
12950 : : /* Second operand is scalar. */
12951 : 16720 : head2 = gfc_get_scalar_ss (head2, expr->value.op.op2);
12952 : : }
12953 : :
12954 : : return head2;
12955 : : }
12956 : :
12957 : : static gfc_ss *
12958 : 36 : gfc_walk_conditional_expr (gfc_ss *ss, gfc_expr *expr)
12959 : : {
12960 : 36 : gfc_ss *head;
12961 : :
12962 : 36 : head = gfc_walk_subexpr (ss, expr->value.conditional.true_expr);
12963 : 36 : head = gfc_walk_subexpr (head, expr->value.conditional.false_expr);
12964 : 36 : return head;
12965 : : }
12966 : :
12967 : : /* Reverse a SS chain. */
12968 : :
12969 : : gfc_ss *
12970 : 838379 : gfc_reverse_ss (gfc_ss * ss)
12971 : : {
12972 : 838379 : gfc_ss *next;
12973 : 838379 : gfc_ss *head;
12974 : :
12975 : 838379 : gcc_assert (ss != NULL);
12976 : :
12977 : : head = gfc_ss_terminator;
12978 : 1264868 : while (ss != gfc_ss_terminator)
12979 : : {
12980 : 426489 : next = ss->next;
12981 : : /* Check we didn't somehow break the chain. */
12982 : 426489 : gcc_assert (next != NULL);
12983 : 426489 : ss->next = head;
12984 : 426489 : head = ss;
12985 : 426489 : ss = next;
12986 : : }
12987 : :
12988 : 838379 : return (head);
12989 : : }
12990 : :
12991 : :
12992 : : /* Given an expression referring to a procedure, return the symbol of its
12993 : : interface. We can't get the procedure symbol directly as we have to handle
12994 : : the case of (deferred) type-bound procedures. */
12995 : :
12996 : : gfc_symbol *
12997 : 160 : gfc_get_proc_ifc_for_expr (gfc_expr *procedure_ref)
12998 : : {
12999 : 160 : gfc_symbol *sym;
13000 : 160 : gfc_ref *ref;
13001 : :
13002 : 160 : if (procedure_ref == NULL)
13003 : : return NULL;
13004 : :
13005 : : /* Normal procedure case. */
13006 : 160 : if (procedure_ref->expr_type == EXPR_FUNCTION
13007 : 160 : && procedure_ref->value.function.esym)
13008 : : sym = procedure_ref->value.function.esym;
13009 : : else
13010 : 24 : sym = procedure_ref->symtree->n.sym;
13011 : :
13012 : : /* Typebound procedure case. */
13013 : 208 : for (ref = procedure_ref->ref; ref; ref = ref->next)
13014 : : {
13015 : 48 : if (ref->type == REF_COMPONENT
13016 : 48 : && ref->u.c.component->attr.proc_pointer)
13017 : 24 : sym = ref->u.c.component->ts.interface;
13018 : : else
13019 : : sym = NULL;
13020 : : }
13021 : :
13022 : : return sym;
13023 : : }
13024 : :
13025 : :
13026 : : /* Given an expression referring to an intrinsic function call,
13027 : : return the intrinsic symbol. */
13028 : :
13029 : : gfc_intrinsic_sym *
13030 : 7771 : gfc_get_intrinsic_for_expr (gfc_expr *call)
13031 : : {
13032 : 7771 : if (call == NULL)
13033 : : return NULL;
13034 : :
13035 : : /* Normal procedure case. */
13036 : 2341 : if (call->expr_type == EXPR_FUNCTION)
13037 : 2235 : return call->value.function.isym;
13038 : : else
13039 : : return NULL;
13040 : : }
13041 : :
13042 : :
13043 : : /* Indicates whether an argument to an intrinsic function should be used in
13044 : : scalarization. It is usually the case, except for some intrinsics
13045 : : requiring the value to be constant, and using the value at compile time only.
13046 : : As the value is not used at runtime in those cases, we don’t produce code
13047 : : for it, and it should not be visible to the scalarizer.
13048 : : FUNCTION is the intrinsic function being called, ACTUAL_ARG is the actual
13049 : : argument being examined in that call, and ARG_NUM the index number
13050 : : of ACTUAL_ARG in the list of arguments.
13051 : : The intrinsic procedure’s dummy argument associated with ACTUAL_ARG is
13052 : : identified using the name in ACTUAL_ARG if it is present (that is: if it’s
13053 : : a keyword argument), otherwise using ARG_NUM. */
13054 : :
13055 : : static bool
13056 : 38027 : arg_evaluated_for_scalarization (gfc_intrinsic_sym *function,
13057 : : gfc_dummy_arg *dummy_arg)
13058 : : {
13059 : 38027 : if (function != NULL && dummy_arg != NULL)
13060 : : {
13061 : 12369 : switch (function->id)
13062 : : {
13063 : 241 : case GFC_ISYM_INDEX:
13064 : 241 : case GFC_ISYM_LEN_TRIM:
13065 : 241 : case GFC_ISYM_MASKL:
13066 : 241 : case GFC_ISYM_MASKR:
13067 : 241 : case GFC_ISYM_SCAN:
13068 : 241 : case GFC_ISYM_VERIFY:
13069 : 241 : if (strcmp ("kind", gfc_dummy_arg_get_name (*dummy_arg)) == 0)
13070 : : return false;
13071 : : /* Fallthrough. */
13072 : :
13073 : : default:
13074 : : break;
13075 : : }
13076 : : }
13077 : :
13078 : : return true;
13079 : : }
13080 : :
13081 : :
13082 : : /* Walk the arguments of an elemental function.
13083 : : PROC_EXPR is used to check whether an argument is permitted to be absent. If
13084 : : it is NULL, we don't do the check and the argument is assumed to be present.
13085 : : */
13086 : :
13087 : : gfc_ss *
13088 : 27243 : gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
13089 : : gfc_intrinsic_sym *intrinsic_sym,
13090 : : gfc_ss_type type)
13091 : : {
13092 : 27243 : int scalar;
13093 : 27243 : gfc_ss *head;
13094 : 27243 : gfc_ss *tail;
13095 : 27243 : gfc_ss *newss;
13096 : :
13097 : 27243 : head = gfc_ss_terminator;
13098 : 27243 : tail = NULL;
13099 : :
13100 : 27243 : scalar = 1;
13101 : 66732 : for (; arg; arg = arg->next)
13102 : : {
13103 : 39489 : gfc_dummy_arg * const dummy_arg = arg->associated_dummy;
13104 : 40984 : if (!arg->expr
13105 : 38177 : || arg->expr->expr_type == EXPR_NULL
13106 : 77516 : || !arg_evaluated_for_scalarization (intrinsic_sym, dummy_arg))
13107 : 1495 : continue;
13108 : :
13109 : 37994 : newss = gfc_walk_subexpr (head, arg->expr);
13110 : 37994 : if (newss == head)
13111 : : {
13112 : : /* Scalar argument. */
13113 : 18432 : gcc_assert (type == GFC_SS_SCALAR || type == GFC_SS_REFERENCE);
13114 : 18432 : newss = gfc_get_scalar_ss (head, arg->expr);
13115 : 18432 : newss->info->type = type;
13116 : 18432 : if (dummy_arg)
13117 : 15448 : newss->info->data.scalar.dummy_arg = dummy_arg;
13118 : : }
13119 : : else
13120 : : scalar = 0;
13121 : :
13122 : 35010 : if (dummy_arg != NULL
13123 : 25828 : && gfc_dummy_arg_is_optional (*dummy_arg)
13124 : 2538 : && arg->expr->expr_type == EXPR_VARIABLE
13125 : 36714 : && (gfc_expr_attr (arg->expr).optional
13126 : 1223 : || gfc_expr_attr (arg->expr).allocatable
13127 : 37941 : || gfc_expr_attr (arg->expr).pointer))
13128 : 1005 : newss->info->can_be_null_ref = true;
13129 : :
13130 : 37994 : head = newss;
13131 : 37994 : if (!tail)
13132 : : {
13133 : : tail = head;
13134 : 33839 : while (tail->next != gfc_ss_terminator)
13135 : : tail = tail->next;
13136 : : }
13137 : : }
13138 : :
13139 : 27243 : if (scalar)
13140 : : {
13141 : : /* If all the arguments are scalar we don't need the argument SS. */
13142 : 10219 : gfc_free_ss_chain (head);
13143 : : /* Pass it back. */
13144 : 10219 : return ss;
13145 : : }
13146 : :
13147 : : /* Add it onto the existing chain. */
13148 : 17024 : tail->next = ss;
13149 : 17024 : return head;
13150 : : }
13151 : :
13152 : :
13153 : : /* Walk a function call. Scalar functions are passed back, and taken out of
13154 : : scalarization loops. For elemental functions we walk their arguments.
13155 : : The result of functions returning arrays is stored in a temporary outside
13156 : : the loop, so that the function is only called once. Hence we do not need
13157 : : to walk their arguments. */
13158 : :
13159 : : static gfc_ss *
13160 : 63614 : gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
13161 : : {
13162 : 63614 : gfc_intrinsic_sym *isym;
13163 : 63614 : gfc_symbol *sym;
13164 : 63614 : gfc_component *comp = NULL;
13165 : :
13166 : 63614 : isym = expr->value.function.isym;
13167 : :
13168 : : /* Handle intrinsic functions separately. */
13169 : 63614 : if (isym)
13170 : 55995 : return gfc_walk_intrinsic_function (ss, expr, isym);
13171 : :
13172 : 7619 : sym = expr->value.function.esym;
13173 : 7619 : if (!sym)
13174 : 546 : sym = expr->symtree->n.sym;
13175 : :
13176 : 7619 : if (gfc_is_class_array_function (expr))
13177 : 234 : return gfc_get_array_ss (ss, expr,
13178 : 234 : CLASS_DATA (expr->value.function.esym->result)->as->rank,
13179 : 234 : GFC_SS_FUNCTION);
13180 : :
13181 : : /* A function that returns arrays. */
13182 : 7385 : comp = gfc_get_proc_ptr_comp (expr);
13183 : 6987 : if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
13184 : 7385 : || (comp && comp->attr.dimension))
13185 : 2617 : return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
13186 : :
13187 : : /* Walk the parameters of an elemental function. For now we always pass
13188 : : by reference. */
13189 : 4768 : if (sym->attr.elemental || (comp && comp->attr.elemental))
13190 : : {
13191 : 2199 : gfc_ss *old_ss = ss;
13192 : :
13193 : 2199 : ss = gfc_walk_elemental_function_args (old_ss,
13194 : : expr->value.function.actual,
13195 : : gfc_get_intrinsic_for_expr (expr),
13196 : : GFC_SS_REFERENCE);
13197 : 2199 : if (ss != old_ss
13198 : 1163 : && (comp
13199 : 1102 : || sym->attr.proc_pointer
13200 : 1102 : || sym->attr.if_source != IFSRC_DECL
13201 : 987 : || sym->attr.array_outer_dependency))
13202 : 224 : ss->info->array_outer_dependency = 1;
13203 : : }
13204 : :
13205 : : /* Scalar functions are OK as these are evaluated outside the scalarization
13206 : : loop. Pass back and let the caller deal with it. */
13207 : : return ss;
13208 : : }
13209 : :
13210 : :
13211 : : /* An array temporary is constructed for array constructors. */
13212 : :
13213 : : static gfc_ss *
13214 : 49324 : gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
13215 : : {
13216 : 0 : return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_CONSTRUCTOR);
13217 : : }
13218 : :
13219 : :
13220 : : /* Walk an expression. Add walked expressions to the head of the SS chain.
13221 : : A wholly scalar expression will not be added. */
13222 : :
13223 : : gfc_ss *
13224 : 988456 : gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
13225 : : {
13226 : 988456 : gfc_ss *head;
13227 : :
13228 : 988456 : switch (expr->expr_type)
13229 : : {
13230 : 665343 : case EXPR_VARIABLE:
13231 : 665343 : head = gfc_walk_variable_expr (ss, expr);
13232 : 665343 : return head;
13233 : :
13234 : 54771 : case EXPR_OP:
13235 : 54771 : head = gfc_walk_op_expr (ss, expr);
13236 : 54771 : return head;
13237 : :
13238 : 36 : case EXPR_CONDITIONAL:
13239 : 36 : head = gfc_walk_conditional_expr (ss, expr);
13240 : 36 : return head;
13241 : :
13242 : 63614 : case EXPR_FUNCTION:
13243 : 63614 : head = gfc_walk_function_expr (ss, expr);
13244 : 63614 : return head;
13245 : :
13246 : : case EXPR_CONSTANT:
13247 : : case EXPR_NULL:
13248 : : case EXPR_STRUCTURE:
13249 : : /* Pass back and let the caller deal with it. */
13250 : : break;
13251 : :
13252 : 49324 : case EXPR_ARRAY:
13253 : 49324 : head = gfc_walk_array_constructor (ss, expr);
13254 : 49324 : return head;
13255 : :
13256 : : case EXPR_SUBSTRING:
13257 : : /* Pass back and let the caller deal with it. */
13258 : : break;
13259 : :
13260 : 0 : default:
13261 : 0 : gfc_internal_error ("bad expression type during walk (%d)",
13262 : : expr->expr_type);
13263 : : }
13264 : : return ss;
13265 : : }
13266 : :
13267 : :
13268 : : /* Entry point for expression walking.
13269 : : A return value equal to the passed chain means this is
13270 : : a scalar expression. It is up to the caller to take whatever action is
13271 : : necessary to translate these. */
13272 : :
13273 : : gfc_ss *
13274 : 835912 : gfc_walk_expr (gfc_expr * expr)
13275 : : {
13276 : 835912 : gfc_ss *res;
13277 : :
13278 : 835912 : res = gfc_walk_subexpr (gfc_ss_terminator, expr);
13279 : 835912 : return gfc_reverse_ss (res);
13280 : : }
|
