Branch data Line data Source code
1 : : /* Array translation routines
2 : : Copyright (C) 2002-2024 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 : :
96 : : static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor_base);
97 : :
98 : : /* The contents of this structure aren't actually used, just the address. */
99 : : static gfc_ss gfc_ss_terminator_var;
100 : : gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var;
101 : :
102 : :
103 : : static tree
104 : 49017 : gfc_array_dataptr_type (tree desc)
105 : : {
106 : 49017 : return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
107 : : }
108 : :
109 : : /* Build expressions to access members of the CFI descriptor. */
110 : : #define CFI_FIELD_BASE_ADDR 0
111 : : #define CFI_FIELD_ELEM_LEN 1
112 : : #define CFI_FIELD_VERSION 2
113 : : #define CFI_FIELD_RANK 3
114 : : #define CFI_FIELD_ATTRIBUTE 4
115 : : #define CFI_FIELD_TYPE 5
116 : : #define CFI_FIELD_DIM 6
117 : :
118 : : #define CFI_DIM_FIELD_LOWER_BOUND 0
119 : : #define CFI_DIM_FIELD_EXTENT 1
120 : : #define CFI_DIM_FIELD_SM 2
121 : :
122 : : static tree
123 : 84903 : gfc_get_cfi_descriptor_field (tree desc, unsigned field_idx)
124 : : {
125 : 84903 : tree type = TREE_TYPE (desc);
126 : 84903 : gcc_assert (TREE_CODE (type) == RECORD_TYPE
127 : : && TYPE_FIELDS (type)
128 : : && (strcmp ("base_addr",
129 : : IDENTIFIER_POINTER (DECL_NAME (TYPE_FIELDS (type))))
130 : : == 0));
131 : 84903 : tree field = gfc_advance_chain (TYPE_FIELDS (type), field_idx);
132 : 84903 : gcc_assert (field != NULL_TREE);
133 : :
134 : 84903 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
135 : 84903 : desc, field, NULL_TREE);
136 : : }
137 : :
138 : : tree
139 : 14190 : gfc_get_cfi_desc_base_addr (tree desc)
140 : : {
141 : 14190 : return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_BASE_ADDR);
142 : : }
143 : :
144 : : tree
145 : 10668 : gfc_get_cfi_desc_elem_len (tree desc)
146 : : {
147 : 10668 : return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_ELEM_LEN);
148 : : }
149 : :
150 : : tree
151 : 7190 : gfc_get_cfi_desc_version (tree desc)
152 : : {
153 : 7190 : return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_VERSION);
154 : : }
155 : :
156 : : tree
157 : 7815 : gfc_get_cfi_desc_rank (tree desc)
158 : : {
159 : 7815 : return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_RANK);
160 : : }
161 : :
162 : : tree
163 : 7282 : gfc_get_cfi_desc_type (tree desc)
164 : : {
165 : 7282 : return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_TYPE);
166 : : }
167 : :
168 : : tree
169 : 7190 : gfc_get_cfi_desc_attribute (tree desc)
170 : : {
171 : 7190 : return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_ATTRIBUTE);
172 : : }
173 : :
174 : : static tree
175 : 30568 : gfc_get_cfi_dim_item (tree desc, tree idx, unsigned field_idx)
176 : : {
177 : 30568 : tree tmp = gfc_get_cfi_descriptor_field (desc, CFI_FIELD_DIM);
178 : 30568 : tmp = gfc_build_array_ref (tmp, idx, NULL_TREE, true);
179 : 30568 : tree field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), field_idx);
180 : 30568 : gcc_assert (field != NULL_TREE);
181 : 30568 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
182 : 30568 : tmp, field, NULL_TREE);
183 : : }
184 : :
185 : : tree
186 : 6786 : gfc_get_cfi_dim_lbound (tree desc, tree idx)
187 : : {
188 : 6786 : return gfc_get_cfi_dim_item (desc, idx, CFI_DIM_FIELD_LOWER_BOUND);
189 : : }
190 : :
191 : : tree
192 : 11922 : gfc_get_cfi_dim_extent (tree desc, tree idx)
193 : : {
194 : 11922 : return gfc_get_cfi_dim_item (desc, idx, CFI_DIM_FIELD_EXTENT);
195 : : }
196 : :
197 : : tree
198 : 11860 : gfc_get_cfi_dim_sm (tree desc, tree idx)
199 : : {
200 : 11860 : return gfc_get_cfi_dim_item (desc, idx, CFI_DIM_FIELD_SM);
201 : : }
202 : :
203 : : #undef CFI_FIELD_BASE_ADDR
204 : : #undef CFI_FIELD_ELEM_LEN
205 : : #undef CFI_FIELD_VERSION
206 : : #undef CFI_FIELD_RANK
207 : : #undef CFI_FIELD_ATTRIBUTE
208 : : #undef CFI_FIELD_TYPE
209 : : #undef CFI_FIELD_DIM
210 : :
211 : : #undef CFI_DIM_FIELD_LOWER_BOUND
212 : : #undef CFI_DIM_FIELD_EXTENT
213 : : #undef CFI_DIM_FIELD_SM
214 : :
215 : : /* Build expressions to access the members of an array descriptor.
216 : : It's surprisingly easy to mess up here, so never access
217 : : an array descriptor by "brute force", always use these
218 : : functions. This also avoids problems if we change the format
219 : : of an array descriptor.
220 : :
221 : : To understand these magic numbers, look at the comments
222 : : before gfc_build_array_type() in trans-types.cc.
223 : :
224 : : The code within these defines should be the only code which knows the format
225 : : of an array descriptor.
226 : :
227 : : Any code just needing to read obtain the bounds of an array should use
228 : : gfc_conv_array_* rather than the following functions as these will return
229 : : know constant values, and work with arrays which do not have descriptors.
230 : :
231 : : Don't forget to #undef these! */
232 : :
233 : : #define DATA_FIELD 0
234 : : #define OFFSET_FIELD 1
235 : : #define DTYPE_FIELD 2
236 : : #define SPAN_FIELD 3
237 : : #define DIMENSION_FIELD 4
238 : : #define CAF_TOKEN_FIELD 5
239 : :
240 : : #define STRIDE_SUBFIELD 0
241 : : #define LBOUND_SUBFIELD 1
242 : : #define UBOUND_SUBFIELD 2
243 : :
244 : : static tree
245 : 1533804 : gfc_get_descriptor_field (tree desc, unsigned field_idx)
246 : : {
247 : 1533804 : tree type = TREE_TYPE (desc);
248 : 1533804 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
249 : :
250 : 1533804 : tree field = gfc_advance_chain (TYPE_FIELDS (type), field_idx);
251 : 1533804 : gcc_assert (field != NULL_TREE);
252 : :
253 : 1533804 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
254 : 1533804 : desc, field, NULL_TREE);
255 : : }
256 : :
257 : : /* This provides READ-ONLY access to the data field. The field itself
258 : : doesn't have the proper type. */
259 : :
260 : : tree
261 : 222745 : gfc_conv_descriptor_data_get (tree desc)
262 : : {
263 : 222745 : tree type = TREE_TYPE (desc);
264 : 222745 : if (TREE_CODE (type) == REFERENCE_TYPE)
265 : 0 : gcc_unreachable ();
266 : :
267 : 222745 : tree field = gfc_get_descriptor_field (desc, DATA_FIELD);
268 : 222745 : return fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), field);
269 : : }
270 : :
271 : : /* This provides WRITE access to the data field.
272 : :
273 : : TUPLES_P is true if we are generating tuples.
274 : :
275 : : This function gets called through the following macros:
276 : : gfc_conv_descriptor_data_set
277 : : gfc_conv_descriptor_data_set. */
278 : :
279 : : void
280 : 118952 : gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
281 : : {
282 : 118952 : tree field = gfc_get_descriptor_field (desc, DATA_FIELD);
283 : 118952 : gfc_add_modify (block, field, fold_convert (TREE_TYPE (field), value));
284 : 118952 : }
285 : :
286 : :
287 : : /* This provides address access to the data field. This should only be
288 : : used by array allocation, passing this on to the runtime. */
289 : :
290 : : tree
291 : 954 : gfc_conv_descriptor_data_addr (tree desc)
292 : : {
293 : 954 : tree field = gfc_get_descriptor_field (desc, DATA_FIELD);
294 : 954 : return gfc_build_addr_expr (NULL_TREE, field);
295 : : }
296 : :
297 : : static tree
298 : 161919 : gfc_conv_descriptor_offset (tree desc)
299 : : {
300 : 161919 : tree field = gfc_get_descriptor_field (desc, OFFSET_FIELD);
301 : 161919 : gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
302 : 161919 : return field;
303 : : }
304 : :
305 : : tree
306 : 59474 : gfc_conv_descriptor_offset_get (tree desc)
307 : : {
308 : 59474 : return gfc_conv_descriptor_offset (desc);
309 : : }
310 : :
311 : : void
312 : 99481 : gfc_conv_descriptor_offset_set (stmtblock_t *block, tree desc,
313 : : tree value)
314 : : {
315 : 99481 : tree t = gfc_conv_descriptor_offset (desc);
316 : 99481 : gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
317 : 99481 : }
318 : :
319 : :
320 : : tree
321 : 140110 : gfc_conv_descriptor_dtype (tree desc)
322 : : {
323 : 140110 : tree field = gfc_get_descriptor_field (desc, DTYPE_FIELD);
324 : 140110 : gcc_assert (TREE_TYPE (field) == get_dtype_type_node ());
325 : 140110 : return field;
326 : : }
327 : :
328 : : static tree
329 : 130822 : gfc_conv_descriptor_span (tree desc)
330 : : {
331 : 130822 : tree field = gfc_get_descriptor_field (desc, SPAN_FIELD);
332 : 130822 : gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
333 : 130822 : return field;
334 : : }
335 : :
336 : : tree
337 : 27738 : gfc_conv_descriptor_span_get (tree desc)
338 : : {
339 : 27738 : return gfc_conv_descriptor_span (desc);
340 : : }
341 : :
342 : : void
343 : 103084 : gfc_conv_descriptor_span_set (stmtblock_t *block, tree desc,
344 : : tree value)
345 : : {
346 : 103084 : tree t = gfc_conv_descriptor_span (desc);
347 : 103084 : gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
348 : 103084 : }
349 : :
350 : :
351 : : tree
352 : 17368 : gfc_conv_descriptor_rank (tree desc)
353 : : {
354 : 17368 : tree tmp;
355 : 17368 : tree dtype;
356 : :
357 : 17368 : dtype = gfc_conv_descriptor_dtype (desc);
358 : 17368 : tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), GFC_DTYPE_RANK);
359 : 17368 : gcc_assert (tmp != NULL_TREE
360 : : && TREE_TYPE (tmp) == signed_char_type_node);
361 : 17368 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
362 : 17368 : dtype, tmp, NULL_TREE);
363 : : }
364 : :
365 : :
366 : : tree
367 : 118 : gfc_conv_descriptor_version (tree desc)
368 : : {
369 : 118 : tree tmp;
370 : 118 : tree dtype;
371 : :
372 : 118 : dtype = gfc_conv_descriptor_dtype (desc);
373 : 118 : tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), GFC_DTYPE_VERSION);
374 : 118 : gcc_assert (tmp != NULL_TREE
375 : : && TREE_TYPE (tmp) == integer_type_node);
376 : 118 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
377 : 118 : dtype, tmp, NULL_TREE);
378 : : }
379 : :
380 : :
381 : : /* Return the element length from the descriptor dtype field. */
382 : :
383 : : tree
384 : 7321 : gfc_conv_descriptor_elem_len (tree desc)
385 : : {
386 : 7321 : tree tmp;
387 : 7321 : tree dtype;
388 : :
389 : 7321 : dtype = gfc_conv_descriptor_dtype (desc);
390 : 7321 : tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)),
391 : : GFC_DTYPE_ELEM_LEN);
392 : 7321 : gcc_assert (tmp != NULL_TREE
393 : : && TREE_TYPE (tmp) == size_type_node);
394 : 7321 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
395 : 7321 : dtype, tmp, NULL_TREE);
396 : : }
397 : :
398 : :
399 : : tree
400 : 0 : gfc_conv_descriptor_attribute (tree desc)
401 : : {
402 : 0 : tree tmp;
403 : 0 : tree dtype;
404 : :
405 : 0 : dtype = gfc_conv_descriptor_dtype (desc);
406 : 0 : tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)),
407 : : GFC_DTYPE_ATTRIBUTE);
408 : 0 : gcc_assert (tmp!= NULL_TREE
409 : : && TREE_TYPE (tmp) == short_integer_type_node);
410 : 0 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
411 : 0 : dtype, tmp, NULL_TREE);
412 : : }
413 : :
414 : : tree
415 : 73 : gfc_conv_descriptor_type (tree desc)
416 : : {
417 : 73 : tree tmp;
418 : 73 : tree dtype;
419 : :
420 : 73 : dtype = gfc_conv_descriptor_dtype (desc);
421 : 73 : tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), GFC_DTYPE_TYPE);
422 : 73 : gcc_assert (tmp!= NULL_TREE
423 : : && TREE_TYPE (tmp) == signed_char_type_node);
424 : 73 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
425 : 73 : dtype, tmp, NULL_TREE);
426 : : }
427 : :
428 : : tree
429 : 756606 : gfc_get_descriptor_dimension (tree desc)
430 : : {
431 : 756606 : tree field = gfc_get_descriptor_field (desc, DIMENSION_FIELD);
432 : 756606 : gcc_assert (TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
433 : : && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
434 : 756606 : return field;
435 : : }
436 : :
437 : :
438 : : static tree
439 : 754356 : gfc_conv_descriptor_dimension (tree desc, tree dim)
440 : : {
441 : 754356 : tree tmp;
442 : :
443 : 754356 : tmp = gfc_get_descriptor_dimension (desc);
444 : :
445 : 754356 : return gfc_build_array_ref (tmp, dim, NULL_TREE, true);
446 : : }
447 : :
448 : :
449 : : tree
450 : 1696 : gfc_conv_descriptor_token (tree desc)
451 : : {
452 : 1696 : gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
453 : 1696 : tree field = gfc_get_descriptor_field (desc, CAF_TOKEN_FIELD);
454 : : /* Should be a restricted pointer - except in the finalization wrapper. */
455 : 1696 : gcc_assert (TREE_TYPE (field) == prvoid_type_node
456 : : || TREE_TYPE (field) == pvoid_type_node);
457 : 1696 : return field;
458 : : }
459 : :
460 : : static tree
461 : 754356 : gfc_conv_descriptor_subfield (tree desc, tree dim, unsigned field_idx)
462 : : {
463 : 754356 : tree tmp = gfc_conv_descriptor_dimension (desc, dim);
464 : 754356 : tree field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), field_idx);
465 : 754356 : gcc_assert (field != NULL_TREE);
466 : :
467 : 754356 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
468 : 754356 : tmp, field, NULL_TREE);
469 : : }
470 : :
471 : : static tree
472 : 206010 : gfc_conv_descriptor_stride (tree desc, tree dim)
473 : : {
474 : 206010 : tree field = gfc_conv_descriptor_subfield (desc, dim, STRIDE_SUBFIELD);
475 : 206010 : gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
476 : 206010 : return field;
477 : : }
478 : :
479 : : tree
480 : 123401 : gfc_conv_descriptor_stride_get (tree desc, tree dim)
481 : : {
482 : 123401 : tree type = TREE_TYPE (desc);
483 : 123401 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
484 : 123401 : if (integer_zerop (dim)
485 : 123401 : && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
486 : 37587 : ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT
487 : 36519 : ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT
488 : 36387 : ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
489 : 51188 : return gfc_index_one_node;
490 : :
491 : 72213 : return gfc_conv_descriptor_stride (desc, dim);
492 : : }
493 : :
494 : : void
495 : 133797 : gfc_conv_descriptor_stride_set (stmtblock_t *block, tree desc,
496 : : tree dim, tree value)
497 : : {
498 : 133797 : tree t = gfc_conv_descriptor_stride (desc, dim);
499 : 133797 : gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
500 : 133797 : }
501 : :
502 : : static tree
503 : 284140 : gfc_conv_descriptor_lbound (tree desc, tree dim)
504 : : {
505 : 284140 : tree field = gfc_conv_descriptor_subfield (desc, dim, LBOUND_SUBFIELD);
506 : 284140 : gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
507 : 284140 : return field;
508 : : }
509 : :
510 : : tree
511 : 146884 : gfc_conv_descriptor_lbound_get (tree desc, tree dim)
512 : : {
513 : 146884 : return gfc_conv_descriptor_lbound (desc, dim);
514 : : }
515 : :
516 : : void
517 : 137256 : gfc_conv_descriptor_lbound_set (stmtblock_t *block, tree desc,
518 : : tree dim, tree value)
519 : : {
520 : 137256 : tree t = gfc_conv_descriptor_lbound (desc, dim);
521 : 137256 : gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
522 : 137256 : }
523 : :
524 : : static tree
525 : 264206 : gfc_conv_descriptor_ubound (tree desc, tree dim)
526 : : {
527 : 264206 : tree field = gfc_conv_descriptor_subfield (desc, dim, UBOUND_SUBFIELD);
528 : 264206 : gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
529 : 264206 : return field;
530 : : }
531 : :
532 : : tree
533 : 126102 : gfc_conv_descriptor_ubound_get (tree desc, tree dim)
534 : : {
535 : 126102 : return gfc_conv_descriptor_ubound (desc, dim);
536 : : }
537 : :
538 : : void
539 : 138104 : gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree desc,
540 : : tree dim, tree value)
541 : : {
542 : 138104 : tree t = gfc_conv_descriptor_ubound (desc, dim);
543 : 138104 : gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
544 : 138104 : }
545 : :
546 : : /* Build a null array descriptor constructor. */
547 : :
548 : : tree
549 : 786 : gfc_build_null_descriptor (tree type)
550 : : {
551 : 786 : tree field;
552 : 786 : tree tmp;
553 : :
554 : 786 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
555 : 786 : gcc_assert (DATA_FIELD == 0);
556 : 786 : field = TYPE_FIELDS (type);
557 : :
558 : : /* Set a NULL data pointer. */
559 : 786 : tmp = build_constructor_single (type, field, null_pointer_node);
560 : 786 : TREE_CONSTANT (tmp) = 1;
561 : : /* All other fields are ignored. */
562 : :
563 : 786 : return tmp;
564 : : }
565 : :
566 : :
567 : : /* Modify a descriptor such that the lbound of a given dimension is the value
568 : : specified. This also updates ubound and offset accordingly. */
569 : :
570 : : void
571 : 833 : gfc_conv_shift_descriptor_lbound (stmtblock_t* block, tree desc,
572 : : int dim, tree new_lbound)
573 : : {
574 : 833 : tree offs, ubound, lbound, stride;
575 : 833 : tree diff, offs_diff;
576 : :
577 : 833 : new_lbound = fold_convert (gfc_array_index_type, new_lbound);
578 : :
579 : 833 : offs = gfc_conv_descriptor_offset_get (desc);
580 : 833 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
581 : 833 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
582 : 833 : stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]);
583 : :
584 : : /* Get difference (new - old) by which to shift stuff. */
585 : 833 : diff = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
586 : : new_lbound, lbound);
587 : :
588 : : /* Shift ubound and offset accordingly. This has to be done before
589 : : updating the lbound, as they depend on the lbound expression! */
590 : 833 : ubound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
591 : : ubound, diff);
592 : 833 : gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[dim], ubound);
593 : 833 : offs_diff = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
594 : : diff, stride);
595 : 833 : offs = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
596 : : offs, offs_diff);
597 : 833 : gfc_conv_descriptor_offset_set (block, desc, offs);
598 : :
599 : : /* Finally set lbound to value we want. */
600 : 833 : gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[dim], new_lbound);
601 : 833 : }
602 : :
603 : :
604 : : /* Obtain offsets for trans-types.cc(gfc_get_array_descr_info). */
605 : :
606 : : void
607 : 223671 : gfc_get_descriptor_offsets_for_info (const_tree desc_type, tree *data_off,
608 : : tree *dtype_off, tree *span_off,
609 : : tree *dim_off, tree *dim_size,
610 : : tree *stride_suboff, tree *lower_suboff,
611 : : tree *upper_suboff)
612 : : {
613 : 223671 : tree field;
614 : 223671 : tree type;
615 : :
616 : 223671 : type = TYPE_MAIN_VARIANT (desc_type);
617 : 223671 : field = gfc_advance_chain (TYPE_FIELDS (type), DATA_FIELD);
618 : 223671 : *data_off = byte_position (field);
619 : 223671 : field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
620 : 223671 : *dtype_off = byte_position (field);
621 : 223671 : field = gfc_advance_chain (TYPE_FIELDS (type), SPAN_FIELD);
622 : 223671 : *span_off = byte_position (field);
623 : 223671 : field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
624 : 223671 : *dim_off = byte_position (field);
625 : 223671 : type = TREE_TYPE (TREE_TYPE (field));
626 : 223671 : *dim_size = TYPE_SIZE_UNIT (type);
627 : 223671 : field = gfc_advance_chain (TYPE_FIELDS (type), STRIDE_SUBFIELD);
628 : 223671 : *stride_suboff = byte_position (field);
629 : 223671 : field = gfc_advance_chain (TYPE_FIELDS (type), LBOUND_SUBFIELD);
630 : 223671 : *lower_suboff = byte_position (field);
631 : 223671 : field = gfc_advance_chain (TYPE_FIELDS (type), UBOUND_SUBFIELD);
632 : 223671 : *upper_suboff = byte_position (field);
633 : 223671 : }
634 : :
635 : :
636 : : /* Cleanup those #defines. */
637 : :
638 : : #undef DATA_FIELD
639 : : #undef OFFSET_FIELD
640 : : #undef DTYPE_FIELD
641 : : #undef SPAN_FIELD
642 : : #undef DIMENSION_FIELD
643 : : #undef CAF_TOKEN_FIELD
644 : : #undef STRIDE_SUBFIELD
645 : : #undef LBOUND_SUBFIELD
646 : : #undef UBOUND_SUBFIELD
647 : :
648 : :
649 : : /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
650 : : flags & 1 = Main loop body.
651 : : flags & 2 = temp copy loop. */
652 : :
653 : : void
654 : 138588 : gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
655 : : {
656 : 322090 : for (; ss != gfc_ss_terminator; ss = ss->next)
657 : 183502 : ss->info->useflags = flags;
658 : 138588 : }
659 : :
660 : :
661 : : /* Free a gfc_ss chain. */
662 : :
663 : : void
664 : 144164 : gfc_free_ss_chain (gfc_ss * ss)
665 : : {
666 : 144164 : gfc_ss *next;
667 : :
668 : 296426 : while (ss != gfc_ss_terminator)
669 : : {
670 : 152262 : gcc_assert (ss != NULL);
671 : 152262 : next = ss->next;
672 : 152262 : gfc_free_ss (ss);
673 : 152262 : ss = next;
674 : : }
675 : 144164 : }
676 : :
677 : :
678 : : static void
679 : 391391 : free_ss_info (gfc_ss_info *ss_info)
680 : : {
681 : 391391 : int n;
682 : :
683 : 391391 : ss_info->refcount--;
684 : 391391 : if (ss_info->refcount > 0)
685 : : return;
686 : :
687 : 390647 : gcc_assert (ss_info->refcount == 0);
688 : :
689 : 390647 : switch (ss_info->type)
690 : : {
691 : : case GFC_SS_SECTION:
692 : 4397232 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
693 : 4122405 : if (ss_info->data.array.subscript[n])
694 : 4856 : gfc_free_ss_chain (ss_info->data.array.subscript[n]);
695 : : break;
696 : :
697 : : default:
698 : : break;
699 : : }
700 : :
701 : 390647 : free (ss_info);
702 : : }
703 : :
704 : :
705 : : /* Free a SS. */
706 : :
707 : : void
708 : 391391 : gfc_free_ss (gfc_ss * ss)
709 : : {
710 : 391391 : free_ss_info (ss->info);
711 : 391391 : free (ss);
712 : 391391 : }
713 : :
714 : :
715 : : /* Creates and initializes an array type gfc_ss struct. */
716 : :
717 : : gfc_ss *
718 : 331286 : gfc_get_array_ss (gfc_ss *next, gfc_expr *expr, int dimen, gfc_ss_type type)
719 : : {
720 : 331286 : gfc_ss *ss;
721 : 331286 : gfc_ss_info *ss_info;
722 : 331286 : int i;
723 : :
724 : 331286 : ss_info = gfc_get_ss_info ();
725 : 331286 : ss_info->refcount++;
726 : 331286 : ss_info->type = type;
727 : 331286 : ss_info->expr = expr;
728 : :
729 : 331286 : ss = gfc_get_ss ();
730 : 331286 : ss->info = ss_info;
731 : 331286 : ss->next = next;
732 : 331286 : ss->dimen = dimen;
733 : 681234 : for (i = 0; i < ss->dimen; i++)
734 : 349948 : ss->dim[i] = i;
735 : :
736 : 331286 : return ss;
737 : : }
738 : :
739 : :
740 : : /* Creates and initializes a temporary type gfc_ss struct. */
741 : :
742 : : gfc_ss *
743 : 8519 : gfc_get_temp_ss (tree type, tree string_length, int dimen)
744 : : {
745 : 8519 : gfc_ss *ss;
746 : 8519 : gfc_ss_info *ss_info;
747 : 8519 : int i;
748 : :
749 : 8519 : ss_info = gfc_get_ss_info ();
750 : 8519 : ss_info->refcount++;
751 : 8519 : ss_info->type = GFC_SS_TEMP;
752 : 8519 : ss_info->string_length = string_length;
753 : 8519 : ss_info->data.temp.type = type;
754 : :
755 : 8519 : ss = gfc_get_ss ();
756 : 8519 : ss->info = ss_info;
757 : 8519 : ss->next = gfc_ss_terminator;
758 : 8519 : ss->dimen = dimen;
759 : 19430 : for (i = 0; i < ss->dimen; i++)
760 : 10911 : ss->dim[i] = i;
761 : :
762 : 8519 : return ss;
763 : : }
764 : :
765 : :
766 : : /* Creates and initializes a scalar type gfc_ss struct. */
767 : :
768 : : gfc_ss *
769 : 54559 : gfc_get_scalar_ss (gfc_ss *next, gfc_expr *expr)
770 : : {
771 : 54559 : gfc_ss *ss;
772 : 54559 : gfc_ss_info *ss_info;
773 : :
774 : 54559 : ss_info = gfc_get_ss_info ();
775 : 54559 : ss_info->refcount++;
776 : 54559 : ss_info->type = GFC_SS_SCALAR;
777 : 54559 : ss_info->expr = expr;
778 : :
779 : 54559 : ss = gfc_get_ss ();
780 : 54559 : ss->info = ss_info;
781 : 54559 : ss->next = next;
782 : :
783 : 54559 : return ss;
784 : : }
785 : :
786 : :
787 : : /* Free all the SS associated with a loop. */
788 : :
789 : : void
790 : 146352 : gfc_cleanup_loop (gfc_loopinfo * loop)
791 : : {
792 : 146352 : gfc_loopinfo *loop_next, **ploop;
793 : 146352 : gfc_ss *ss;
794 : 146352 : gfc_ss *next;
795 : :
796 : 146352 : ss = loop->ss;
797 : 385270 : while (ss != gfc_ss_terminator)
798 : : {
799 : 238918 : gcc_assert (ss != NULL);
800 : 238918 : next = ss->loop_chain;
801 : 238918 : gfc_free_ss (ss);
802 : 238918 : ss = next;
803 : : }
804 : :
805 : : /* Remove reference to self in the parent loop. */
806 : 146352 : if (loop->parent)
807 : 553 : for (ploop = &loop->parent->nested; *ploop; ploop = &(*ploop)->next)
808 : 553 : if (*ploop == loop)
809 : : {
810 : 553 : *ploop = loop->next;
811 : 553 : break;
812 : : }
813 : :
814 : : /* Free non-freed nested loops. */
815 : 146905 : for (loop = loop->nested; loop; loop = loop_next)
816 : : {
817 : 553 : loop_next = loop->next;
818 : 553 : gfc_cleanup_loop (loop);
819 : 553 : free (loop);
820 : : }
821 : 146352 : }
822 : :
823 : :
824 : : static void
825 : 199072 : set_ss_loop (gfc_ss *ss, gfc_loopinfo *loop)
826 : : {
827 : 199072 : int n;
828 : :
829 : 444322 : for (; ss != gfc_ss_terminator; ss = ss->next)
830 : : {
831 : 245250 : ss->loop = loop;
832 : :
833 : 245250 : if (ss->info->type == GFC_SS_SCALAR
834 : : || ss->info->type == GFC_SS_REFERENCE
835 : 207829 : || ss->info->type == GFC_SS_TEMP)
836 : 45940 : continue;
837 : :
838 : 3188960 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
839 : 2989650 : if (ss->info->data.array.subscript[n] != NULL)
840 : 4712 : set_ss_loop (ss->info->data.array.subscript[n], loop);
841 : : }
842 : 199072 : }
843 : :
844 : :
845 : : /* Associate a SS chain with a loop. */
846 : :
847 : : void
848 : 194360 : gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
849 : : {
850 : 194360 : gfc_ss *ss;
851 : 194360 : gfc_loopinfo *nested_loop;
852 : :
853 : 194360 : if (head == gfc_ss_terminator)
854 : : return;
855 : :
856 : 194360 : set_ss_loop (head, loop);
857 : :
858 : 194360 : ss = head;
859 : 629258 : for (; ss && ss != gfc_ss_terminator; ss = ss->next)
860 : : {
861 : 240538 : if (ss->nested_ss)
862 : : {
863 : 737 : nested_loop = ss->nested_ss->loop;
864 : :
865 : : /* More than one ss can belong to the same loop. Hence, we add the
866 : : loop to the chain only if it is different from the previously
867 : : added one, to avoid duplicate nested loops. */
868 : 737 : if (nested_loop != loop->nested)
869 : : {
870 : 553 : gcc_assert (nested_loop->parent == NULL);
871 : 553 : nested_loop->parent = loop;
872 : :
873 : 553 : gcc_assert (nested_loop->next == NULL);
874 : 553 : nested_loop->next = loop->nested;
875 : 553 : loop->nested = nested_loop;
876 : : }
877 : : else
878 : 184 : gcc_assert (nested_loop->parent == loop);
879 : : }
880 : :
881 : 240538 : if (ss->next == gfc_ss_terminator)
882 : 194360 : ss->loop_chain = loop->ss;
883 : : else
884 : 46178 : ss->loop_chain = ss->next;
885 : : }
886 : 194360 : gcc_assert (ss == gfc_ss_terminator);
887 : 194360 : loop->ss = head;
888 : : }
889 : :
890 : :
891 : : /* Returns true if the expression is an array pointer. */
892 : :
893 : : static bool
894 : 303661 : is_pointer_array (tree expr)
895 : : {
896 : 303661 : if (expr == NULL_TREE
897 : 303661 : || !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr))
898 : 379429 : || GFC_CLASS_TYPE_P (TREE_TYPE (expr)))
899 : : return false;
900 : :
901 : 75768 : if (VAR_P (expr)
902 : 75768 : && GFC_DECL_PTR_ARRAY_P (expr))
903 : : return true;
904 : :
905 : 70304 : if (TREE_CODE (expr) == PARM_DECL
906 : 70304 : && GFC_DECL_PTR_ARRAY_P (expr))
907 : : return true;
908 : :
909 : 70304 : if (INDIRECT_REF_P (expr)
910 : 70304 : && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 0)))
911 : : return true;
912 : :
913 : : /* The field declaration is marked as an pointer array. */
914 : 68231 : if (TREE_CODE (expr) == COMPONENT_REF
915 : 10230 : && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 1))
916 : 70465 : && !GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (expr, 1))))
917 : 2234 : return true;
918 : :
919 : : return false;
920 : : }
921 : :
922 : :
923 : : /* If the symbol or expression reference a CFI descriptor, return the
924 : : pointer to the converted gfc descriptor. If an array reference is
925 : : present as the last argument, check that it is the one applied to
926 : : the CFI descriptor in the expression. Note that the CFI object is
927 : : always the symbol in the expression! */
928 : :
929 : : static bool
930 : 305548 : get_CFI_desc (gfc_symbol *sym, gfc_expr *expr,
931 : : tree *desc, gfc_array_ref *ar)
932 : : {
933 : 305548 : tree tmp;
934 : :
935 : 305548 : if (!is_CFI_desc (sym, expr))
936 : : return false;
937 : :
938 : 4727 : if (expr && ar)
939 : : {
940 : 4061 : if (!(expr->ref && expr->ref->type == REF_ARRAY)
941 : 4043 : || (&expr->ref->u.ar != ar))
942 : : return false;
943 : : }
944 : :
945 : 4697 : if (sym == NULL)
946 : 1108 : tmp = expr->symtree->n.sym->backend_decl;
947 : : else
948 : 3589 : tmp = sym->backend_decl;
949 : :
950 : 4697 : if (tmp && DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp))
951 : 0 : tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
952 : :
953 : 4697 : *desc = tmp;
954 : 4697 : return true;
955 : : }
956 : :
957 : :
958 : : /* Return the span of an array. */
959 : :
960 : : tree
961 : 49986 : gfc_get_array_span (tree desc, gfc_expr *expr)
962 : : {
963 : 49986 : tree tmp;
964 : :
965 : 49986 : if (is_pointer_array (desc)
966 : 49986 : || (get_CFI_desc (NULL, expr, &desc, NULL)
967 : 1332 : && (POINTER_TYPE_P (TREE_TYPE (desc))
968 : 666 : ? GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (desc)))
969 : 0 : : GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))))
970 : : {
971 : 491 : if (POINTER_TYPE_P (TREE_TYPE (desc)))
972 : 0 : desc = build_fold_indirect_ref_loc (input_location, desc);
973 : :
974 : : /* This will have the span field set. */
975 : 491 : tmp = gfc_conv_descriptor_span_get (desc);
976 : : }
977 : 49495 : else if (expr->ts.type == BT_ASSUMED)
978 : : {
979 : 127 : if (DECL_LANG_SPECIFIC (desc) && GFC_DECL_SAVED_DESCRIPTOR (desc))
980 : 127 : desc = GFC_DECL_SAVED_DESCRIPTOR (desc);
981 : 127 : if (POINTER_TYPE_P (TREE_TYPE (desc)))
982 : 127 : desc = build_fold_indirect_ref_loc (input_location, desc);
983 : 127 : tmp = gfc_conv_descriptor_span_get (desc);
984 : : }
985 : 49368 : else if (TREE_CODE (desc) == COMPONENT_REF
986 : 549 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
987 : 49464 : && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (desc, 0))))
988 : : {
989 : : /* The descriptor is a class _data field and so use the vtable
990 : : size for the receiving span field. */
991 : 36 : tmp = gfc_get_vptr_from_expr (desc);
992 : 36 : tmp = gfc_vptr_size_get (tmp);
993 : : }
994 : 49332 : else if (expr && expr->expr_type == EXPR_VARIABLE
995 : 44010 : && expr->symtree->n.sym->ts.type == BT_CLASS
996 : 954 : && expr->ref->type == REF_COMPONENT
997 : 954 : && expr->ref->next->type == REF_ARRAY
998 : 954 : && expr->ref->next->next == NULL
999 : 930 : && CLASS_DATA (expr->symtree->n.sym)->attr.dimension)
1000 : : {
1001 : : /* Dummys come in sometimes with the descriptor detached from
1002 : : the class field or declaration. */
1003 : 908 : tmp = gfc_class_vptr_get (expr->symtree->n.sym->backend_decl);
1004 : 908 : tmp = gfc_vptr_size_get (tmp);
1005 : : }
1006 : : else
1007 : : {
1008 : : /* If none of the fancy stuff works, the span is the element
1009 : : size of the array. Attempt to deal with unbounded character
1010 : : types if possible. Otherwise, return NULL_TREE. */
1011 : 48424 : tmp = gfc_get_element_type (TREE_TYPE (desc));
1012 : 48424 : if (tmp && TREE_CODE (tmp) == ARRAY_TYPE && TYPE_STRING_FLAG (tmp))
1013 : : {
1014 : 10313 : gcc_assert (expr->ts.type == BT_CHARACTER);
1015 : :
1016 : 10313 : tmp = gfc_get_character_len_in_bytes (tmp);
1017 : :
1018 : 10313 : if (tmp == NULL_TREE || integer_zerop (tmp))
1019 : : {
1020 : 96 : tree bs;
1021 : :
1022 : 96 : tmp = gfc_get_expr_charlen (expr);
1023 : 96 : tmp = fold_convert (gfc_array_index_type, tmp);
1024 : 96 : bs = build_int_cst (gfc_array_index_type, expr->ts.kind);
1025 : 96 : tmp = fold_build2_loc (input_location, MULT_EXPR,
1026 : : gfc_array_index_type, tmp, bs);
1027 : : }
1028 : :
1029 : 10313 : tmp = (tmp && !integer_zerop (tmp))
1030 : 20546 : ? (fold_convert (gfc_array_index_type, tmp)) : (NULL_TREE);
1031 : : }
1032 : : else
1033 : 38111 : tmp = fold_convert (gfc_array_index_type,
1034 : : size_in_bytes (tmp));
1035 : : }
1036 : 49986 : return tmp;
1037 : : }
1038 : :
1039 : :
1040 : : /* Generate an initializer for a static pointer or allocatable array. */
1041 : :
1042 : : void
1043 : 173 : gfc_trans_static_array_pointer (gfc_symbol * sym)
1044 : : {
1045 : 173 : tree type;
1046 : :
1047 : 173 : gcc_assert (TREE_STATIC (sym->backend_decl));
1048 : : /* Just zero the data member. */
1049 : 173 : type = TREE_TYPE (sym->backend_decl);
1050 : 173 : DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
1051 : 173 : }
1052 : :
1053 : :
1054 : : /* If the bounds of SE's loop have not yet been set, see if they can be
1055 : : determined from array spec AS, which is the array spec of a called
1056 : : function. MAPPING maps the callee's dummy arguments to the values
1057 : : that the caller is passing. Add any initialization and finalization
1058 : : code to SE. */
1059 : :
1060 : : void
1061 : 7588 : gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
1062 : : gfc_se * se, gfc_array_spec * as)
1063 : : {
1064 : 7588 : int n, dim, total_dim;
1065 : 7588 : gfc_se tmpse;
1066 : 7588 : gfc_ss *ss;
1067 : 7588 : tree lower;
1068 : 7588 : tree upper;
1069 : 7588 : tree tmp;
1070 : :
1071 : 7588 : total_dim = 0;
1072 : :
1073 : 7588 : if (!as || as->type != AS_EXPLICIT)
1074 : 6527 : return;
1075 : :
1076 : 2147 : for (ss = se->ss; ss; ss = ss->parent)
1077 : : {
1078 : 1086 : total_dim += ss->loop->dimen;
1079 : 2527 : for (n = 0; n < ss->loop->dimen; n++)
1080 : : {
1081 : : /* The bound is known, nothing to do. */
1082 : 1441 : if (ss->loop->to[n] != NULL_TREE)
1083 : 491 : continue;
1084 : :
1085 : 950 : dim = ss->dim[n];
1086 : 950 : gcc_assert (dim < as->rank);
1087 : 950 : gcc_assert (ss->loop->dimen <= as->rank);
1088 : :
1089 : : /* Evaluate the lower bound. */
1090 : 950 : gfc_init_se (&tmpse, NULL);
1091 : 950 : gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
1092 : 950 : gfc_add_block_to_block (&se->pre, &tmpse.pre);
1093 : 950 : gfc_add_block_to_block (&se->post, &tmpse.post);
1094 : 950 : lower = fold_convert (gfc_array_index_type, tmpse.expr);
1095 : :
1096 : : /* ...and the upper bound. */
1097 : 950 : gfc_init_se (&tmpse, NULL);
1098 : 950 : gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
1099 : 950 : gfc_add_block_to_block (&se->pre, &tmpse.pre);
1100 : 950 : gfc_add_block_to_block (&se->post, &tmpse.post);
1101 : 950 : upper = fold_convert (gfc_array_index_type, tmpse.expr);
1102 : :
1103 : : /* Set the upper bound of the loop to UPPER - LOWER. */
1104 : 950 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
1105 : : gfc_array_index_type, upper, lower);
1106 : 950 : tmp = gfc_evaluate_now (tmp, &se->pre);
1107 : 950 : ss->loop->to[n] = tmp;
1108 : : }
1109 : : }
1110 : :
1111 : 1061 : gcc_assert (total_dim == as->rank);
1112 : : }
1113 : :
1114 : :
1115 : : /* Generate code to allocate an array temporary, or create a variable to
1116 : : hold the data. If size is NULL, zero the descriptor so that the
1117 : : callee will allocate the array. If DEALLOC is true, also generate code to
1118 : : free the array afterwards.
1119 : :
1120 : : If INITIAL is not NULL, it is packed using internal_pack and the result used
1121 : : as data instead of allocating a fresh, unitialized area of memory.
1122 : :
1123 : : Initialization code is added to PRE and finalization code to POST.
1124 : : DYNAMIC is true if the caller may want to extend the array later
1125 : : using realloc. This prevents us from putting the array on the stack. */
1126 : :
1127 : : static void
1128 : 24000 : gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
1129 : : gfc_array_info * info, tree size, tree nelem,
1130 : : tree initial, bool dynamic, bool dealloc)
1131 : : {
1132 : 24000 : tree tmp;
1133 : 24000 : tree desc;
1134 : 24000 : bool onstack;
1135 : :
1136 : 24000 : desc = info->descriptor;
1137 : 24000 : info->offset = gfc_index_zero_node;
1138 : 24000 : if (size == NULL_TREE || (dynamic && integer_zerop (size)))
1139 : : {
1140 : : /* A callee allocated array. */
1141 : 2374 : gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
1142 : 2374 : onstack = false;
1143 : : }
1144 : : else
1145 : : {
1146 : : /* Allocate the temporary. */
1147 : 43252 : onstack = !dynamic && initial == NULL_TREE
1148 : 21626 : && (flag_stack_arrays
1149 : 21341 : || gfc_can_put_var_on_stack (size));
1150 : :
1151 : 21626 : if (onstack)
1152 : : {
1153 : : /* Make a temporary variable to hold the data. */
1154 : 17474 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (nelem),
1155 : : nelem, gfc_index_one_node);
1156 : 17474 : tmp = gfc_evaluate_now (tmp, pre);
1157 : 17474 : tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
1158 : : tmp);
1159 : 17474 : tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
1160 : : tmp);
1161 : 17474 : tmp = gfc_create_var (tmp, "A");
1162 : : /* If we're here only because of -fstack-arrays we have to
1163 : : emit a DECL_EXPR to make the gimplifier emit alloca calls. */
1164 : 17474 : if (!gfc_can_put_var_on_stack (size))
1165 : 17 : gfc_add_expr_to_block (pre,
1166 : : fold_build1_loc (input_location,
1167 : 17 : DECL_EXPR, TREE_TYPE (tmp),
1168 : : tmp));
1169 : 17474 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1170 : 17474 : gfc_conv_descriptor_data_set (pre, desc, tmp);
1171 : : }
1172 : : else
1173 : : {
1174 : : /* Allocate memory to hold the data or call internal_pack. */
1175 : 4152 : if (initial == NULL_TREE)
1176 : : {
1177 : 4051 : tmp = gfc_call_malloc (pre, NULL, size);
1178 : 4051 : tmp = gfc_evaluate_now (tmp, pre);
1179 : : }
1180 : : else
1181 : : {
1182 : 101 : tree packed;
1183 : 101 : tree source_data;
1184 : 101 : tree was_packed;
1185 : 101 : stmtblock_t do_copying;
1186 : :
1187 : 101 : tmp = TREE_TYPE (initial); /* Pointer to descriptor. */
1188 : 101 : gcc_assert (TREE_CODE (tmp) == POINTER_TYPE);
1189 : 101 : tmp = TREE_TYPE (tmp); /* The descriptor itself. */
1190 : 101 : tmp = gfc_get_element_type (tmp);
1191 : 101 : packed = gfc_create_var (build_pointer_type (tmp), "data");
1192 : :
1193 : 101 : tmp = build_call_expr_loc (input_location,
1194 : : gfor_fndecl_in_pack, 1, initial);
1195 : 101 : tmp = fold_convert (TREE_TYPE (packed), tmp);
1196 : 101 : gfc_add_modify (pre, packed, tmp);
1197 : :
1198 : 101 : tmp = build_fold_indirect_ref_loc (input_location,
1199 : : initial);
1200 : 101 : source_data = gfc_conv_descriptor_data_get (tmp);
1201 : :
1202 : : /* internal_pack may return source->data without any allocation
1203 : : or copying if it is already packed. If that's the case, we
1204 : : need to allocate and copy manually. */
1205 : :
1206 : 101 : gfc_start_block (&do_copying);
1207 : 101 : tmp = gfc_call_malloc (&do_copying, NULL, size);
1208 : 101 : tmp = fold_convert (TREE_TYPE (packed), tmp);
1209 : 101 : gfc_add_modify (&do_copying, packed, tmp);
1210 : 101 : tmp = gfc_build_memcpy_call (packed, source_data, size);
1211 : 101 : gfc_add_expr_to_block (&do_copying, tmp);
1212 : :
1213 : 101 : was_packed = fold_build2_loc (input_location, EQ_EXPR,
1214 : : logical_type_node, packed,
1215 : : source_data);
1216 : 101 : tmp = gfc_finish_block (&do_copying);
1217 : 101 : tmp = build3_v (COND_EXPR, was_packed, tmp,
1218 : : build_empty_stmt (input_location));
1219 : 101 : gfc_add_expr_to_block (pre, tmp);
1220 : :
1221 : 101 : tmp = fold_convert (pvoid_type_node, packed);
1222 : : }
1223 : :
1224 : 4152 : gfc_conv_descriptor_data_set (pre, desc, tmp);
1225 : : }
1226 : : }
1227 : 24000 : info->data = gfc_conv_descriptor_data_get (desc);
1228 : :
1229 : : /* The offset is zero because we create temporaries with a zero
1230 : : lower bound. */
1231 : 24000 : gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node);
1232 : :
1233 : 24000 : if (dealloc && !onstack)
1234 : : {
1235 : : /* Free the temporary. */
1236 : 6318 : tmp = gfc_conv_descriptor_data_get (desc);
1237 : 6318 : tmp = gfc_call_free (tmp);
1238 : 6318 : gfc_add_expr_to_block (post, tmp);
1239 : : }
1240 : 24000 : }
1241 : :
1242 : :
1243 : : /* Get the scalarizer array dimension corresponding to actual array dimension
1244 : : given by ARRAY_DIM.
1245 : :
1246 : : For example, if SS represents the array ref a(1,:,:,1), it is a
1247 : : bidimensional scalarizer array, and the result would be 0 for ARRAY_DIM=1,
1248 : : and 1 for ARRAY_DIM=2.
1249 : : If SS represents transpose(a(:,1,1,:)), it is again a bidimensional
1250 : : scalarizer array, and the result would be 1 for ARRAY_DIM=0 and 0 for
1251 : : ARRAY_DIM=3.
1252 : : If SS represents sum(a(:,:,:,1), dim=1), it is a 2+1-dimensional scalarizer
1253 : : array. If called on the inner ss, the result would be respectively 0,1,2 for
1254 : : ARRAY_DIM=0,1,2. If called on the outer ss, the result would be 0,1
1255 : : for ARRAY_DIM=1,2. */
1256 : :
1257 : : static int
1258 : 207837 : get_scalarizer_dim_for_array_dim (gfc_ss *ss, int array_dim)
1259 : : {
1260 : 207837 : int array_ref_dim;
1261 : 207837 : int n;
1262 : :
1263 : 207837 : array_ref_dim = 0;
1264 : :
1265 : 416670 : for (; ss; ss = ss->parent)
1266 : 529899 : for (n = 0; n < ss->dimen; n++)
1267 : 321066 : if (ss->dim[n] < array_dim)
1268 : 54981 : array_ref_dim++;
1269 : :
1270 : 207837 : return array_ref_dim;
1271 : : }
1272 : :
1273 : :
1274 : : static gfc_ss *
1275 : 174146 : innermost_ss (gfc_ss *ss)
1276 : : {
1277 : 318683 : while (ss->nested_ss != NULL)
1278 : : ss = ss->nested_ss;
1279 : :
1280 : 317676 : return ss;
1281 : : }
1282 : :
1283 : :
1284 : :
1285 : : /* Get the array reference dimension corresponding to the given loop dimension.
1286 : : It is different from the true array dimension given by the dim array in
1287 : : the case of a partial array reference (i.e. a(:,:,1,:) for example)
1288 : : It is different from the loop dimension in the case of a transposed array.
1289 : : */
1290 : :
1291 : : static int
1292 : 174146 : get_array_ref_dim_for_loop_dim (gfc_ss *ss, int loop_dim)
1293 : : {
1294 : 174146 : return get_scalarizer_dim_for_array_dim (innermost_ss (ss),
1295 : 174146 : ss->dim[loop_dim]);
1296 : : }
1297 : :
1298 : :
1299 : : /* Use the information in the ss to obtain the required information about
1300 : : the type and size of an array temporary, when the lhs in an assignment
1301 : : is a class expression. */
1302 : :
1303 : : static tree
1304 : 188 : get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype)
1305 : : {
1306 : 188 : gfc_ss *lhs_ss;
1307 : 188 : gfc_ss *rhs_ss;
1308 : 188 : tree tmp;
1309 : 188 : tree tmp2;
1310 : 188 : tree vptr;
1311 : 188 : tree rhs_class_expr = NULL_TREE;
1312 : 188 : tree lhs_class_expr = NULL_TREE;
1313 : 188 : bool unlimited_rhs = false;
1314 : 188 : bool unlimited_lhs = false;
1315 : 188 : bool rhs_function = false;
1316 : 188 : gfc_symbol *vtab;
1317 : :
1318 : : /* The second element in the loop chain contains the source for the
1319 : : temporary; ie. the rhs of the assignment. */
1320 : 188 : rhs_ss = ss->loop->ss->loop_chain;
1321 : :
1322 : 188 : if (rhs_ss != gfc_ss_terminator
1323 : 188 : && rhs_ss->info
1324 : 188 : && rhs_ss->info->expr
1325 : 188 : && rhs_ss->info->expr->ts.type == BT_CLASS
1326 : 104 : && rhs_ss->info->data.array.descriptor)
1327 : : {
1328 : 98 : if (rhs_ss->info->expr->expr_type != EXPR_VARIABLE)
1329 : 50 : rhs_class_expr
1330 : 50 : = gfc_get_class_from_expr (rhs_ss->info->data.array.descriptor);
1331 : : else
1332 : 48 : rhs_class_expr = gfc_get_class_from_gfc_expr (rhs_ss->info->expr);
1333 : 98 : unlimited_rhs = UNLIMITED_POLY (rhs_ss->info->expr);
1334 : 98 : if (rhs_ss->info->expr->expr_type == EXPR_FUNCTION)
1335 : 31 : rhs_function = true;
1336 : : }
1337 : :
1338 : : /* For an assignment the lhs is the next element in the loop chain.
1339 : : If we have a class rhs, this had better be a class variable
1340 : : expression! */
1341 : 188 : lhs_ss = rhs_ss->loop_chain;
1342 : 188 : if (lhs_ss != gfc_ss_terminator
1343 : 176 : && lhs_ss->info
1344 : 176 : && lhs_ss->info->expr
1345 : 176 : && lhs_ss->info->expr->expr_type ==EXPR_VARIABLE
1346 : 176 : && lhs_ss->info->expr->ts.type == BT_CLASS)
1347 : : {
1348 : 176 : tmp = lhs_ss->info->data.array.descriptor;
1349 : 176 : unlimited_lhs = UNLIMITED_POLY (rhs_ss->info->expr);
1350 : : }
1351 : : else
1352 : : tmp = NULL_TREE;
1353 : :
1354 : : /* Get the lhs class expression. */
1355 : 176 : if (tmp != NULL_TREE && lhs_ss->loop_chain == gfc_ss_terminator)
1356 : 164 : lhs_class_expr = gfc_get_class_from_expr (tmp);
1357 : : else
1358 : : return rhs_class_expr;
1359 : :
1360 : 164 : gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (lhs_class_expr)));
1361 : :
1362 : : /* Set the lhs vptr and, if necessary, the _len field. */
1363 : 164 : if (rhs_class_expr)
1364 : : {
1365 : : /* Both lhs and rhs are class expressions. */
1366 : 73 : tmp = gfc_class_vptr_get (lhs_class_expr);
1367 : 146 : gfc_add_modify (pre, tmp,
1368 : 73 : fold_convert (TREE_TYPE (tmp),
1369 : : gfc_class_vptr_get (rhs_class_expr)));
1370 : 73 : if (unlimited_lhs)
1371 : : {
1372 : 31 : tmp = gfc_class_len_get (lhs_class_expr);
1373 : 31 : if (unlimited_rhs)
1374 : 31 : tmp2 = gfc_class_len_get (rhs_class_expr);
1375 : : else
1376 : 0 : tmp2 = build_int_cst (TREE_TYPE (tmp), 0);
1377 : 31 : gfc_add_modify (pre, tmp, tmp2);
1378 : : }
1379 : :
1380 : 73 : if (rhs_function)
1381 : : {
1382 : 31 : tmp = gfc_class_data_get (rhs_class_expr);
1383 : 31 : gfc_conv_descriptor_offset_set (pre, tmp, gfc_index_zero_node);
1384 : : }
1385 : : }
1386 : : else
1387 : : {
1388 : : /* lhs is class and rhs is intrinsic or derived type. */
1389 : 91 : *eltype = TREE_TYPE (rhs_ss->info->data.array.descriptor);
1390 : 91 : *eltype = gfc_get_element_type (*eltype);
1391 : 91 : vtab = gfc_find_vtab (&rhs_ss->info->expr->ts);
1392 : 91 : vptr = vtab->backend_decl;
1393 : 91 : if (vptr == NULL_TREE)
1394 : 12 : vptr = gfc_get_symbol_decl (vtab);
1395 : 91 : vptr = gfc_build_addr_expr (NULL_TREE, vptr);
1396 : 91 : tmp = gfc_class_vptr_get (lhs_class_expr);
1397 : 91 : gfc_add_modify (pre, tmp,
1398 : 91 : fold_convert (TREE_TYPE (tmp), vptr));
1399 : :
1400 : 91 : if (unlimited_lhs)
1401 : : {
1402 : 0 : tmp = gfc_class_len_get (lhs_class_expr);
1403 : 0 : if (rhs_ss->info
1404 : 0 : && rhs_ss->info->expr
1405 : 0 : && rhs_ss->info->expr->ts.type == BT_CHARACTER)
1406 : 0 : tmp2 = build_int_cst (TREE_TYPE (tmp),
1407 : 0 : rhs_ss->info->expr->ts.kind);
1408 : : else
1409 : 0 : tmp2 = build_int_cst (TREE_TYPE (tmp), 0);
1410 : 0 : gfc_add_modify (pre, tmp, tmp2);
1411 : : }
1412 : : }
1413 : :
1414 : : return rhs_class_expr;
1415 : : }
1416 : :
1417 : :
1418 : :
1419 : : /* Generate code to create and initialize the descriptor for a temporary
1420 : : array. This is used for both temporaries needed by the scalarizer, and
1421 : : functions returning arrays. Adjusts the loop variables to be
1422 : : zero-based, and calculates the loop bounds for callee allocated arrays.
1423 : : Allocate the array unless it's callee allocated (we have a callee
1424 : : allocated array if 'callee_alloc' is true, or if loop->to[n] is
1425 : : NULL_TREE for any n). Also fills in the descriptor, data and offset
1426 : : fields of info if known. Returns the size of the array, or NULL for a
1427 : : callee allocated array.
1428 : :
1429 : : 'eltype' == NULL signals that the temporary should be a class object.
1430 : : The 'initial' expression is used to obtain the size of the dynamic
1431 : : type; otherwise the allocation and initialization proceeds as for any
1432 : : other expression
1433 : :
1434 : : PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
1435 : : gfc_trans_allocate_array_storage. */
1436 : :
1437 : : tree
1438 : 24000 : gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
1439 : : tree eltype, tree initial, bool dynamic,
1440 : : bool dealloc, bool callee_alloc, locus * where)
1441 : : {
1442 : 24000 : gfc_loopinfo *loop;
1443 : 24000 : gfc_ss *s;
1444 : 24000 : gfc_array_info *info;
1445 : 24000 : tree from[GFC_MAX_DIMENSIONS], to[GFC_MAX_DIMENSIONS];
1446 : 24000 : tree type;
1447 : 24000 : tree desc;
1448 : 24000 : tree tmp;
1449 : 24000 : tree size;
1450 : 24000 : tree nelem;
1451 : 24000 : tree cond;
1452 : 24000 : tree or_expr;
1453 : 24000 : tree elemsize;
1454 : 24000 : tree class_expr = NULL_TREE;
1455 : 24000 : int n, dim, tmp_dim;
1456 : 24000 : int total_dim = 0;
1457 : :
1458 : : /* This signals a class array for which we need the size of the
1459 : : dynamic type. Generate an eltype and then the class expression. */
1460 : 24000 : if (eltype == NULL_TREE && initial)
1461 : : {
1462 : 6 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial)));
1463 : 6 : class_expr = build_fold_indirect_ref_loc (input_location, initial);
1464 : : /* Obtain the structure (class) expression. */
1465 : 6 : class_expr = gfc_get_class_from_expr (class_expr);
1466 : 6 : gcc_assert (class_expr);
1467 : : }
1468 : :
1469 : : /* Otherwise, some expressions, such as class functions, arising from
1470 : : dependency checking in assignments come here with class element type.
1471 : : The descriptor can be obtained from the ss->info and then converted
1472 : : to the class object. */
1473 : 23994 : if (class_expr == NULL_TREE && GFC_CLASS_TYPE_P (eltype))
1474 : 188 : class_expr = get_class_info_from_ss (pre, ss, &eltype);
1475 : :
1476 : : /* If the dynamic type is not available, use the declared type. */
1477 : 24000 : if (eltype && GFC_CLASS_TYPE_P (eltype))
1478 : 97 : eltype = gfc_get_element_type (TREE_TYPE (TYPE_FIELDS (eltype)));
1479 : :
1480 : 24000 : if (class_expr == NULL_TREE)
1481 : 23915 : elemsize = fold_convert (gfc_array_index_type,
1482 : : TYPE_SIZE_UNIT (eltype));
1483 : : else
1484 : : {
1485 : : /* Unlimited polymorphic entities are initialised with NULL vptr. They
1486 : : can be tested for by checking if the len field is present. If so
1487 : : test the vptr before using the vtable size. */
1488 : 85 : tmp = gfc_class_vptr_get (class_expr);
1489 : 85 : tmp = fold_build2_loc (input_location, NE_EXPR,
1490 : : logical_type_node,
1491 : 85 : tmp, build_int_cst (TREE_TYPE (tmp), 0));
1492 : 85 : elemsize = fold_build3_loc (input_location, COND_EXPR,
1493 : : gfc_array_index_type,
1494 : : tmp,
1495 : : gfc_class_vtab_size_get (class_expr),
1496 : : gfc_index_zero_node);
1497 : 85 : elemsize = gfc_evaluate_now (elemsize, pre);
1498 : 85 : elemsize = gfc_resize_class_size_with_len (pre, class_expr, elemsize);
1499 : : /* Casting the data as a character of the dynamic length ensures that
1500 : : assignment of elements works when needed. */
1501 : 85 : eltype = gfc_get_character_type_len (1, elemsize);
1502 : : }
1503 : :
1504 : 24000 : memset (from, 0, sizeof (from));
1505 : 24000 : memset (to, 0, sizeof (to));
1506 : :
1507 : 24000 : info = &ss->info->data.array;
1508 : :
1509 : 24000 : gcc_assert (ss->dimen > 0);
1510 : 24000 : gcc_assert (ss->loop->dimen == ss->dimen);
1511 : :
1512 : 24000 : if (warn_array_temporaries && where)
1513 : 204 : gfc_warning (OPT_Warray_temporaries,
1514 : : "Creating array temporary at %L", where);
1515 : :
1516 : : /* Set the lower bound to zero. */
1517 : 48035 : for (s = ss; s; s = s->parent)
1518 : : {
1519 : 24035 : loop = s->loop;
1520 : :
1521 : 24035 : total_dim += loop->dimen;
1522 : 55035 : for (n = 0; n < loop->dimen; n++)
1523 : : {
1524 : 31000 : dim = s->dim[n];
1525 : :
1526 : : /* Callee allocated arrays may not have a known bound yet. */
1527 : 31000 : if (loop->to[n])
1528 : 28314 : loop->to[n] = gfc_evaluate_now (
1529 : : fold_build2_loc (input_location, MINUS_EXPR,
1530 : : gfc_array_index_type,
1531 : : loop->to[n], loop->from[n]),
1532 : : pre);
1533 : 31000 : loop->from[n] = gfc_index_zero_node;
1534 : :
1535 : : /* We have just changed the loop bounds, we must clear the
1536 : : corresponding specloop, so that delta calculation is not skipped
1537 : : later in gfc_set_delta. */
1538 : 31000 : loop->specloop[n] = NULL;
1539 : :
1540 : : /* We are constructing the temporary's descriptor based on the loop
1541 : : dimensions. As the dimensions may be accessed in arbitrary order
1542 : : (think of transpose) the size taken from the n'th loop may not map
1543 : : to the n'th dimension of the array. We need to reconstruct loop
1544 : : infos in the right order before using it to set the descriptor
1545 : : bounds. */
1546 : 31000 : tmp_dim = get_scalarizer_dim_for_array_dim (ss, dim);
1547 : 31000 : from[tmp_dim] = loop->from[n];
1548 : 31000 : to[tmp_dim] = loop->to[n];
1549 : :
1550 : 31000 : info->delta[dim] = gfc_index_zero_node;
1551 : 31000 : info->start[dim] = gfc_index_zero_node;
1552 : 31000 : info->end[dim] = gfc_index_zero_node;
1553 : 31000 : info->stride[dim] = gfc_index_one_node;
1554 : : }
1555 : : }
1556 : :
1557 : : /* Initialize the descriptor. */
1558 : 24000 : type =
1559 : 24000 : gfc_get_array_type_bounds (eltype, total_dim, 0, from, to, 1,
1560 : : GFC_ARRAY_UNKNOWN, true);
1561 : 24000 : desc = gfc_create_var (type, "atmp");
1562 : 24000 : GFC_DECL_PACKED_ARRAY (desc) = 1;
1563 : :
1564 : : /* Emit a DECL_EXPR for the variable sized array type in
1565 : : GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
1566 : : sizes works correctly. */
1567 : 24000 : tree arraytype = TREE_TYPE (GFC_TYPE_ARRAY_DATAPTR_TYPE (type));
1568 : 24000 : if (! TYPE_NAME (arraytype))
1569 : 24000 : TYPE_NAME (arraytype) = build_decl (UNKNOWN_LOCATION, TYPE_DECL,
1570 : : NULL_TREE, arraytype);
1571 : 24000 : gfc_add_expr_to_block (pre, build1 (DECL_EXPR,
1572 : 24000 : arraytype, TYPE_NAME (arraytype)));
1573 : :
1574 : 24000 : if (class_expr != NULL_TREE)
1575 : : {
1576 : 85 : tree class_data;
1577 : 85 : tree dtype;
1578 : :
1579 : : /* Create a class temporary. */
1580 : 85 : tmp = gfc_create_var (TREE_TYPE (class_expr), "ctmp");
1581 : 85 : gfc_add_modify (pre, tmp, class_expr);
1582 : :
1583 : : /* Assign the new descriptor to the _data field. This allows the
1584 : : vptr _copy to be used for scalarized assignment since the class
1585 : : temporary can be found from the descriptor. */
1586 : 85 : class_data = gfc_class_data_get (tmp);
1587 : 85 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1588 : 85 : TREE_TYPE (desc), desc);
1589 : 85 : gfc_add_modify (pre, class_data, tmp);
1590 : :
1591 : : /* Take the dtype from the class expression. */
1592 : 85 : dtype = gfc_conv_descriptor_dtype (gfc_class_data_get (class_expr));
1593 : 85 : tmp = gfc_conv_descriptor_dtype (class_data);
1594 : 85 : gfc_add_modify (pre, tmp, dtype);
1595 : :
1596 : : /* Point desc to the class _data field. */
1597 : 85 : desc = class_data;
1598 : : }
1599 : : else
1600 : : {
1601 : : /* Fill in the array dtype. */
1602 : 23915 : tmp = gfc_conv_descriptor_dtype (desc);
1603 : 23915 : gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
1604 : : }
1605 : :
1606 : 24000 : info->descriptor = desc;
1607 : 24000 : size = gfc_index_one_node;
1608 : :
1609 : : /*
1610 : : Fill in the bounds and stride. This is a packed array, so:
1611 : :
1612 : : size = 1;
1613 : : for (n = 0; n < rank; n++)
1614 : : {
1615 : : stride[n] = size
1616 : : delta = ubound[n] + 1 - lbound[n];
1617 : : size = size * delta;
1618 : : }
1619 : : size = size * sizeof(element);
1620 : : */
1621 : :
1622 : 24000 : or_expr = NULL_TREE;
1623 : :
1624 : : /* If there is at least one null loop->to[n], it is a callee allocated
1625 : : array. */
1626 : 52314 : for (n = 0; n < total_dim; n++)
1627 : 29954 : if (to[n] == NULL_TREE)
1628 : : {
1629 : : size = NULL_TREE;
1630 : : break;
1631 : : }
1632 : :
1633 : 24000 : if (size == NULL_TREE)
1634 : 3290 : for (s = ss; s; s = s->parent)
1635 : 4341 : for (n = 0; n < s->loop->dimen; n++)
1636 : : {
1637 : 2691 : dim = get_scalarizer_dim_for_array_dim (ss, s->dim[n]);
1638 : :
1639 : : /* For a callee allocated array express the loop bounds in terms
1640 : : of the descriptor fields. */
1641 : 2691 : tmp = fold_build2_loc (input_location,
1642 : : MINUS_EXPR, gfc_array_index_type,
1643 : : gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]),
1644 : : gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]));
1645 : 2691 : s->loop->to[n] = tmp;
1646 : : }
1647 : : else
1648 : : {
1649 : 50669 : for (n = 0; n < total_dim; n++)
1650 : : {
1651 : : /* Store the stride and bound components in the descriptor. */
1652 : 28309 : gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size);
1653 : :
1654 : 28309 : gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
1655 : : gfc_index_zero_node);
1656 : :
1657 : 28309 : gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], to[n]);
1658 : :
1659 : 28309 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
1660 : : gfc_array_index_type,
1661 : : to[n], gfc_index_one_node);
1662 : :
1663 : : /* Check whether the size for this dimension is negative. */
1664 : 28309 : cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
1665 : : tmp, gfc_index_zero_node);
1666 : 28309 : cond = gfc_evaluate_now (cond, pre);
1667 : :
1668 : 28309 : if (n == 0)
1669 : : or_expr = cond;
1670 : : else
1671 : 5949 : or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1672 : : logical_type_node, or_expr, cond);
1673 : :
1674 : 28309 : size = fold_build2_loc (input_location, MULT_EXPR,
1675 : : gfc_array_index_type, size, tmp);
1676 : 28309 : size = gfc_evaluate_now (size, pre);
1677 : : }
1678 : : }
1679 : :
1680 : : /* Get the size of the array. */
1681 : 24000 : if (size && !callee_alloc)
1682 : : {
1683 : : /* If or_expr is true, then the extent in at least one
1684 : : dimension is zero and the size is set to zero. */
1685 : 22167 : size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
1686 : : or_expr, gfc_index_zero_node, size);
1687 : :
1688 : 22167 : nelem = size;
1689 : 22167 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
1690 : : size, elemsize);
1691 : : }
1692 : : else
1693 : : {
1694 : : nelem = size;
1695 : : size = NULL_TREE;
1696 : : }
1697 : :
1698 : : /* Set the span. */
1699 : 24000 : tmp = fold_convert (gfc_array_index_type, elemsize);
1700 : 24000 : gfc_conv_descriptor_span_set (pre, desc, tmp);
1701 : :
1702 : 24000 : gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
1703 : : dynamic, dealloc);
1704 : :
1705 : 48035 : while (ss->parent)
1706 : : ss = ss->parent;
1707 : :
1708 : 24000 : if (ss->dimen > ss->loop->temp_dim)
1709 : 20932 : ss->loop->temp_dim = ss->dimen;
1710 : :
1711 : 24000 : return size;
1712 : : }
1713 : :
1714 : :
1715 : : /* Return the number of iterations in a loop that starts at START,
1716 : : ends at END, and has step STEP. */
1717 : :
1718 : : static tree
1719 : 916 : gfc_get_iteration_count (tree start, tree end, tree step)
1720 : : {
1721 : 916 : tree tmp;
1722 : 916 : tree type;
1723 : :
1724 : 916 : type = TREE_TYPE (step);
1725 : 916 : tmp = fold_build2_loc (input_location, MINUS_EXPR, type, end, start);
1726 : 916 : tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, type, tmp, step);
1727 : 916 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp,
1728 : 916 : build_int_cst (type, 1));
1729 : 916 : tmp = fold_build2_loc (input_location, MAX_EXPR, type, tmp,
1730 : 916 : build_int_cst (type, 0));
1731 : 916 : return fold_convert (gfc_array_index_type, tmp);
1732 : : }
1733 : :
1734 : :
1735 : : /* Extend the data in array DESC by EXTRA elements. */
1736 : :
1737 : : static void
1738 : 904 : gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
1739 : : {
1740 : 904 : tree arg0, arg1;
1741 : 904 : tree tmp;
1742 : 904 : tree size;
1743 : 904 : tree ubound;
1744 : :
1745 : 904 : if (integer_zerop (extra))
1746 : : return;
1747 : :
1748 : 874 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
1749 : :
1750 : : /* Add EXTRA to the upper bound. */
1751 : 874 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1752 : : ubound, extra);
1753 : 874 : gfc_conv_descriptor_ubound_set (pblock, desc, gfc_rank_cst[0], tmp);
1754 : :
1755 : : /* Get the value of the current data pointer. */
1756 : 874 : arg0 = gfc_conv_descriptor_data_get (desc);
1757 : :
1758 : : /* Calculate the new array size. */
1759 : 874 : size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
1760 : 874 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1761 : : ubound, gfc_index_one_node);
1762 : 874 : arg1 = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
1763 : : fold_convert (size_type_node, tmp),
1764 : : fold_convert (size_type_node, size));
1765 : :
1766 : : /* Call the realloc() function. */
1767 : 874 : tmp = gfc_call_realloc (pblock, arg0, arg1);
1768 : 874 : gfc_conv_descriptor_data_set (pblock, desc, tmp);
1769 : : }
1770 : :
1771 : :
1772 : : /* Return true if the bounds of iterator I can only be determined
1773 : : at run time. */
1774 : :
1775 : : static inline bool
1776 : 1885 : gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
1777 : : {
1778 : 1885 : return (i->start->expr_type != EXPR_CONSTANT
1779 : 1488 : || i->end->expr_type != EXPR_CONSTANT
1780 : 2043 : || i->step->expr_type != EXPR_CONSTANT);
1781 : : }
1782 : :
1783 : :
1784 : : /* Split the size of constructor element EXPR into the sum of two terms,
1785 : : one of which can be determined at compile time and one of which must
1786 : : be calculated at run time. Set *SIZE to the former and return true
1787 : : if the latter might be nonzero. */
1788 : :
1789 : : static bool
1790 : 2574 : gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
1791 : : {
1792 : 2574 : if (expr->expr_type == EXPR_ARRAY)
1793 : 579 : return gfc_get_array_constructor_size (size, expr->value.constructor);
1794 : 1995 : else if (expr->rank > 0)
1795 : : {
1796 : : /* Calculate everything at run time. */
1797 : 893 : mpz_set_ui (*size, 0);
1798 : 893 : return true;
1799 : : }
1800 : : else
1801 : : {
1802 : : /* A single element. */
1803 : 1102 : mpz_set_ui (*size, 1);
1804 : 1102 : return false;
1805 : : }
1806 : : }
1807 : :
1808 : :
1809 : : /* Like gfc_get_array_constructor_element_size, but applied to the whole
1810 : : of array constructor C. */
1811 : :
1812 : : static bool
1813 : 2397 : gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base)
1814 : : {
1815 : 2397 : gfc_constructor *c;
1816 : 2397 : gfc_iterator *i;
1817 : 2397 : mpz_t val;
1818 : 2397 : mpz_t len;
1819 : 2397 : bool dynamic;
1820 : :
1821 : 2397 : mpz_set_ui (*size, 0);
1822 : 2397 : mpz_init (len);
1823 : 2397 : mpz_init (val);
1824 : :
1825 : 2397 : dynamic = false;
1826 : 5784 : for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1827 : : {
1828 : 3387 : i = c->iterator;
1829 : 3387 : if (i && gfc_iterator_has_dynamic_bounds (i))
1830 : : dynamic = true;
1831 : : else
1832 : : {
1833 : 2117 : dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
1834 : 2117 : if (i)
1835 : : {
1836 : : /* Multiply the static part of the element size by the
1837 : : number of iterations. */
1838 : 116 : mpz_sub (val, i->end->value.integer, i->start->value.integer);
1839 : 116 : mpz_fdiv_q (val, val, i->step->value.integer);
1840 : 116 : mpz_add_ui (val, val, 1);
1841 : 116 : if (mpz_sgn (val) > 0)
1842 : 80 : mpz_mul (len, len, val);
1843 : : else
1844 : 36 : mpz_set_ui (len, 0);
1845 : : }
1846 : 2117 : mpz_add (*size, *size, len);
1847 : : }
1848 : : }
1849 : 2397 : mpz_clear (len);
1850 : 2397 : mpz_clear (val);
1851 : 2397 : return dynamic;
1852 : : }
1853 : :
1854 : :
1855 : : /* Make sure offset is a variable. */
1856 : :
1857 : : static void
1858 : 2786 : gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
1859 : : tree * offsetvar)
1860 : : {
1861 : : /* We should have already created the offset variable. We cannot
1862 : : create it here because we may be in an inner scope. */
1863 : 2786 : gcc_assert (*offsetvar != NULL_TREE);
1864 : 2786 : gfc_add_modify (pblock, *offsetvar, *poffset);
1865 : 2786 : *poffset = *offsetvar;
1866 : 2786 : TREE_USED (*offsetvar) = 1;
1867 : 2786 : }
1868 : :
1869 : :
1870 : : /* Variables needed for bounds-checking. */
1871 : : static bool first_len;
1872 : : static tree first_len_val;
1873 : : static bool typespec_chararray_ctor;
1874 : :
1875 : : static void
1876 : 12309 : gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
1877 : : tree offset, gfc_se * se, gfc_expr * expr)
1878 : : {
1879 : 12309 : tree tmp;
1880 : :
1881 : 12309 : gfc_conv_expr (se, expr);
1882 : :
1883 : : /* Store the value. */
1884 : 12309 : tmp = build_fold_indirect_ref_loc (input_location,
1885 : : gfc_conv_descriptor_data_get (desc));
1886 : 12309 : tmp = gfc_build_array_ref (tmp, offset, NULL);
1887 : :
1888 : 12309 : if (expr->ts.type == BT_CHARACTER)
1889 : : {
1890 : 1769 : int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
1891 : 1769 : tree esize;
1892 : :
1893 : 1769 : esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)));
1894 : 1769 : esize = fold_convert (gfc_charlen_type_node, esize);
1895 : 3538 : esize = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
1896 : 1769 : TREE_TYPE (esize), esize,
1897 : 1769 : build_int_cst (TREE_TYPE (esize),
1898 : 1769 : gfc_character_kinds[i].bit_size / 8));
1899 : :
1900 : 1769 : gfc_conv_string_parameter (se);
1901 : 1769 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
1902 : : {
1903 : : /* The temporary is an array of pointers. */
1904 : 6 : se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1905 : 6 : gfc_add_modify (&se->pre, tmp, se->expr);
1906 : : }
1907 : : else
1908 : : {
1909 : : /* The temporary is an array of string values. */
1910 : 1763 : tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp);
1911 : : /* We know the temporary and the value will be the same length,
1912 : : so can use memcpy. */
1913 : 1763 : gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind,
1914 : : se->string_length, se->expr, expr->ts.kind);
1915 : : }
1916 : 1769 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !typespec_chararray_ctor)
1917 : : {
1918 : 295 : if (first_len)
1919 : : {
1920 : 115 : gfc_add_modify (&se->pre, first_len_val,
1921 : 115 : fold_convert (TREE_TYPE (first_len_val),
1922 : : se->string_length));
1923 : 115 : first_len = false;
1924 : : }
1925 : : else
1926 : : {
1927 : : /* Verify that all constructor elements are of the same
1928 : : length. */
1929 : 180 : tree rhs = fold_convert (TREE_TYPE (first_len_val),
1930 : : se->string_length);
1931 : 180 : tree cond = fold_build2_loc (input_location, NE_EXPR,
1932 : : logical_type_node, first_len_val,
1933 : : rhs);
1934 : 180 : gfc_trans_runtime_check
1935 : 180 : (true, false, cond, &se->pre, &expr->where,
1936 : : "Different CHARACTER lengths (%ld/%ld) in array constructor",
1937 : : fold_convert (long_integer_type_node, first_len_val),
1938 : : fold_convert (long_integer_type_node, se->string_length));
1939 : : }
1940 : : }
1941 : : }
1942 : 10540 : else if (GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
1943 : 10540 : && !GFC_CLASS_TYPE_P (gfc_get_element_type (TREE_TYPE (desc))))
1944 : : {
1945 : : /* Assignment of a CLASS array constructor to a derived type array. */
1946 : 24 : if (expr->expr_type == EXPR_FUNCTION)
1947 : 18 : se->expr = gfc_evaluate_now (se->expr, pblock);
1948 : 24 : se->expr = gfc_class_data_get (se->expr);
1949 : 24 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
1950 : 24 : se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1951 : 24 : gfc_add_modify (&se->pre, tmp, se->expr);
1952 : : }
1953 : : else
1954 : : {
1955 : : /* TODO: Should the frontend already have done this conversion? */
1956 : 10516 : se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1957 : 10516 : gfc_add_modify (&se->pre, tmp, se->expr);
1958 : : }
1959 : :
1960 : 12309 : gfc_add_block_to_block (pblock, &se->pre);
1961 : 12309 : gfc_add_block_to_block (pblock, &se->post);
1962 : 12309 : }
1963 : :
1964 : :
1965 : : /* Add the contents of an array to the constructor. DYNAMIC is as for
1966 : : gfc_trans_array_constructor_value. */
1967 : :
1968 : : static void
1969 : 1046 : gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
1970 : : tree type ATTRIBUTE_UNUSED,
1971 : : tree desc, gfc_expr * expr,
1972 : : tree * poffset, tree * offsetvar,
1973 : : bool dynamic)
1974 : : {
1975 : 1046 : gfc_se se;
1976 : 1046 : gfc_ss *ss;
1977 : 1046 : gfc_loopinfo loop;
1978 : 1046 : stmtblock_t body;
1979 : 1046 : tree tmp;
1980 : 1046 : tree size;
1981 : 1046 : int n;
1982 : :
1983 : : /* We need this to be a variable so we can increment it. */
1984 : 1046 : gfc_put_offset_into_var (pblock, poffset, offsetvar);
1985 : :
1986 : 1046 : gfc_init_se (&se, NULL);
1987 : :
1988 : : /* Walk the array expression. */
1989 : 1046 : ss = gfc_walk_expr (expr);
1990 : 1046 : gcc_assert (ss != gfc_ss_terminator);
1991 : :
1992 : : /* Initialize the scalarizer. */
1993 : 1046 : gfc_init_loopinfo (&loop);
1994 : 1046 : gfc_add_ss_to_loop (&loop, ss);
1995 : :
1996 : : /* Initialize the loop. */
1997 : 1046 : gfc_conv_ss_startstride (&loop);
1998 : 1046 : gfc_conv_loop_setup (&loop, &expr->where);
1999 : :
2000 : : /* Make sure the constructed array has room for the new data. */
2001 : 1046 : if (dynamic)
2002 : : {
2003 : : /* Set SIZE to the total number of elements in the subarray. */
2004 : 447 : size = gfc_index_one_node;
2005 : 906 : for (n = 0; n < loop.dimen; n++)
2006 : : {
2007 : 459 : tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
2008 : : gfc_index_one_node);
2009 : 459 : size = fold_build2_loc (input_location, MULT_EXPR,
2010 : : gfc_array_index_type, size, tmp);
2011 : : }
2012 : :
2013 : : /* Grow the constructed array by SIZE elements. */
2014 : 447 : gfc_grow_array (&loop.pre, desc, size);
2015 : : }
2016 : :
2017 : : /* Make the loop body. */
2018 : 1046 : gfc_mark_ss_chain_used (ss, 1);
2019 : 1046 : gfc_start_scalarized_body (&loop, &body);
2020 : 1046 : gfc_copy_loopinfo_to_se (&se, &loop);
2021 : 1046 : se.ss = ss;
2022 : :
2023 : 1046 : gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
2024 : 1046 : gcc_assert (se.ss == gfc_ss_terminator);
2025 : :
2026 : : /* Increment the offset. */
2027 : 1046 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2028 : : *poffset, gfc_index_one_node);
2029 : 1046 : gfc_add_modify (&body, *poffset, tmp);
2030 : :
2031 : : /* Finish the loop. */
2032 : 1046 : gfc_trans_scalarizing_loops (&loop, &body);
2033 : 1046 : gfc_add_block_to_block (&loop.pre, &loop.post);
2034 : 1046 : tmp = gfc_finish_block (&loop.pre);
2035 : 1046 : gfc_add_expr_to_block (pblock, tmp);
2036 : :
2037 : 1046 : gfc_cleanup_loop (&loop);
2038 : 1046 : }
2039 : :
2040 : :
2041 : : /* Assign the values to the elements of an array constructor. DYNAMIC
2042 : : is true if descriptor DESC only contains enough data for the static
2043 : : size calculated by gfc_get_array_constructor_size. When true, memory
2044 : : for the dynamic parts must be allocated using realloc. */
2045 : :
2046 : : static void
2047 : 8307 : gfc_trans_array_constructor_value (stmtblock_t * pblock,
2048 : : stmtblock_t * finalblock,
2049 : : tree type, tree desc,
2050 : : gfc_constructor_base base, tree * poffset,
2051 : : tree * offsetvar, bool dynamic)
2052 : : {
2053 : 8307 : tree tmp;
2054 : 8307 : tree start = NULL_TREE;
2055 : 8307 : tree end = NULL_TREE;
2056 : 8307 : tree step = NULL_TREE;
2057 : 8307 : stmtblock_t body;
2058 : 8307 : gfc_se se;
2059 : 8307 : mpz_t size;
2060 : 8307 : gfc_constructor *c;
2061 : 8307 : gfc_typespec ts;
2062 : 8307 : int ctr = 0;
2063 : :
2064 : 8307 : tree shadow_loopvar = NULL_TREE;
2065 : 8307 : gfc_saved_var saved_loopvar;
2066 : :
2067 : 8307 : ts.type = BT_UNKNOWN;
2068 : 8307 : mpz_init (size);
2069 : 21829 : for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
2070 : : {
2071 : 13522 : ctr++;
2072 : : /* If this is an iterator or an array, the offset must be a variable. */
2073 : 13522 : if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
2074 : 1740 : gfc_put_offset_into_var (pblock, poffset, offsetvar);
2075 : :
2076 : : /* Shadowing the iterator avoids changing its value and saves us from
2077 : : keeping track of it. Further, it makes sure that there's always a
2078 : : backend-decl for the symbol, even if there wasn't one before,
2079 : : e.g. in the case of an iterator that appears in a specification
2080 : : expression in an interface mapping. */
2081 : 13522 : if (c->iterator)
2082 : : {
2083 : 1116 : gfc_symbol *sym;
2084 : 1116 : tree type;
2085 : :
2086 : : /* Evaluate loop bounds before substituting the loop variable
2087 : : in case they depend on it. Such a case is invalid, but it is
2088 : : not more expensive to do the right thing here.
2089 : : See PR 44354. */
2090 : 1116 : gfc_init_se (&se, NULL);
2091 : 1116 : gfc_conv_expr_val (&se, c->iterator->start);
2092 : 1116 : gfc_add_block_to_block (pblock, &se.pre);
2093 : 1116 : start = gfc_evaluate_now (se.expr, pblock);
2094 : :
2095 : 1116 : gfc_init_se (&se, NULL);
2096 : 1116 : gfc_conv_expr_val (&se, c->iterator->end);
2097 : 1116 : gfc_add_block_to_block (pblock, &se.pre);
2098 : 1116 : end = gfc_evaluate_now (se.expr, pblock);
2099 : :
2100 : 1116 : gfc_init_se (&se, NULL);
2101 : 1116 : gfc_conv_expr_val (&se, c->iterator->step);
2102 : 1116 : gfc_add_block_to_block (pblock, &se.pre);
2103 : 1116 : step = gfc_evaluate_now (se.expr, pblock);
2104 : :
2105 : 1116 : sym = c->iterator->var->symtree->n.sym;
2106 : 1116 : type = gfc_typenode_for_spec (&sym->ts);
2107 : :
2108 : 1116 : shadow_loopvar = gfc_create_var (type, "shadow_loopvar");
2109 : 1116 : gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar);
2110 : : }
2111 : :
2112 : 13522 : gfc_start_block (&body);
2113 : :
2114 : 13522 : if (c->expr->expr_type == EXPR_ARRAY)
2115 : : {
2116 : : /* Array constructors can be nested. */
2117 : 1126 : gfc_trans_array_constructor_value (&body, finalblock, type,
2118 : : desc, c->expr->value.constructor,
2119 : : poffset, offsetvar, dynamic);
2120 : : }
2121 : 12396 : else if (c->expr->rank > 0)
2122 : : {
2123 : 1046 : gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
2124 : : poffset, offsetvar, dynamic);
2125 : : }
2126 : : else
2127 : : {
2128 : : /* This code really upsets the gimplifier so don't bother for now. */
2129 : : gfc_constructor *p;
2130 : : HOST_WIDE_INT n;
2131 : : HOST_WIDE_INT size;
2132 : :
2133 : : p = c;
2134 : : n = 0;
2135 : 12765 : while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
2136 : : {
2137 : 1415 : p = gfc_constructor_next (p);
2138 : 1415 : n++;
2139 : : }
2140 : 11350 : if (n < 4)
2141 : : {
2142 : : /* Scalar values. */
2143 : 11263 : gfc_init_se (&se, NULL);
2144 : 11263 : gfc_trans_array_ctor_element (&body, desc, *poffset,
2145 : : &se, c->expr);
2146 : :
2147 : 11263 : *poffset = fold_build2_loc (input_location, PLUS_EXPR,
2148 : : gfc_array_index_type,
2149 : : *poffset, gfc_index_one_node);
2150 : : }
2151 : : else
2152 : : {
2153 : : /* Collect multiple scalar constants into a constructor. */
2154 : 87 : vec<constructor_elt, va_gc> *v = NULL;
2155 : 87 : tree init;
2156 : 87 : tree bound;
2157 : 87 : tree tmptype;
2158 : 87 : HOST_WIDE_INT idx = 0;
2159 : :
2160 : 87 : p = c;
2161 : : /* Count the number of consecutive scalar constants. */
2162 : 747 : while (p && !(p->iterator
2163 : 673 : || p->expr->expr_type != EXPR_CONSTANT))
2164 : : {
2165 : 660 : gfc_init_se (&se, NULL);
2166 : 660 : gfc_conv_constant (&se, p->expr);
2167 : :
2168 : 660 : if (c->expr->ts.type != BT_CHARACTER)
2169 : 660 : se.expr = fold_convert (type, se.expr);
2170 : : /* For constant character array constructors we build
2171 : : an array of pointers. */
2172 : 0 : else if (POINTER_TYPE_P (type))
2173 : 0 : se.expr = gfc_build_addr_expr
2174 : 0 : (gfc_get_pchar_type (p->expr->ts.kind),
2175 : : se.expr);
2176 : :
2177 : 660 : CONSTRUCTOR_APPEND_ELT (v,
2178 : : build_int_cst (gfc_array_index_type,
2179 : : idx++),
2180 : : se.expr);
2181 : 660 : c = p;
2182 : 660 : p = gfc_constructor_next (p);
2183 : : }
2184 : :
2185 : 87 : bound = size_int (n - 1);
2186 : : /* Create an array type to hold them. */
2187 : 87 : tmptype = build_range_type (gfc_array_index_type,
2188 : : gfc_index_zero_node, bound);
2189 : 87 : tmptype = build_array_type (type, tmptype);
2190 : :
2191 : 87 : init = build_constructor (tmptype, v);
2192 : 87 : TREE_CONSTANT (init) = 1;
2193 : 87 : TREE_STATIC (init) = 1;
2194 : : /* Create a static variable to hold the data. */
2195 : 87 : tmp = gfc_create_var (tmptype, "data");
2196 : 87 : TREE_STATIC (tmp) = 1;
2197 : 87 : TREE_CONSTANT (tmp) = 1;
2198 : 87 : TREE_READONLY (tmp) = 1;
2199 : 87 : DECL_INITIAL (tmp) = init;
2200 : 87 : init = tmp;
2201 : :
2202 : : /* Use BUILTIN_MEMCPY to assign the values. */
2203 : 87 : tmp = gfc_conv_descriptor_data_get (desc);
2204 : 87 : tmp = build_fold_indirect_ref_loc (input_location,
2205 : : tmp);
2206 : 87 : tmp = gfc_build_array_ref (tmp, *poffset, NULL);
2207 : 87 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
2208 : 87 : init = gfc_build_addr_expr (NULL_TREE, init);
2209 : :
2210 : 87 : size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
2211 : 87 : bound = build_int_cst (size_type_node, n * size);
2212 : 87 : tmp = build_call_expr_loc (input_location,
2213 : : builtin_decl_explicit (BUILT_IN_MEMCPY),
2214 : : 3, tmp, init, bound);
2215 : 87 : gfc_add_expr_to_block (&body, tmp);
2216 : :
2217 : 87 : *poffset = fold_build2_loc (input_location, PLUS_EXPR,
2218 : : gfc_array_index_type, *poffset,
2219 : : build_int_cst (gfc_array_index_type, n));
2220 : : }
2221 : 11350 : if (!INTEGER_CST_P (*poffset))
2222 : : {
2223 : 1307 : gfc_add_modify (&body, *offsetvar, *poffset);
2224 : 1307 : *poffset = *offsetvar;
2225 : : }
2226 : :
2227 : 11350 : if (!c->iterator)
2228 : 11350 : ts = c->expr->ts;
2229 : : }
2230 : :
2231 : : /* The frontend should already have done any expansions
2232 : : at compile-time. */
2233 : 13522 : if (!c->iterator)
2234 : : {
2235 : : /* Pass the code as is. */
2236 : 12406 : tmp = gfc_finish_block (&body);
2237 : 12406 : gfc_add_expr_to_block (pblock, tmp);
2238 : : }
2239 : : else
2240 : : {
2241 : : /* Build the implied do-loop. */
2242 : 1116 : stmtblock_t implied_do_block;
2243 : 1116 : tree cond;
2244 : 1116 : tree exit_label;
2245 : 1116 : tree loopbody;
2246 : 1116 : tree tmp2;
2247 : :
2248 : 1116 : loopbody = gfc_finish_block (&body);
2249 : :
2250 : : /* Create a new block that holds the implied-do loop. A temporary
2251 : : loop-variable is used. */
2252 : 1116 : gfc_start_block(&implied_do_block);
2253 : :
2254 : : /* Initialize the loop. */
2255 : 1116 : gfc_add_modify (&implied_do_block, shadow_loopvar, start);
2256 : :
2257 : : /* If this array expands dynamically, and the number of iterations
2258 : : is not constant, we won't have allocated space for the static
2259 : : part of C->EXPR's size. Do that now. */
2260 : 1116 : if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
2261 : : {
2262 : : /* Get the number of iterations. */
2263 : 457 : tmp = gfc_get_iteration_count (shadow_loopvar, end, step);
2264 : :
2265 : : /* Get the static part of C->EXPR's size. */
2266 : 457 : gfc_get_array_constructor_element_size (&size, c->expr);
2267 : 457 : tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
2268 : :
2269 : : /* Grow the array by TMP * TMP2 elements. */
2270 : 457 : tmp = fold_build2_loc (input_location, MULT_EXPR,
2271 : : gfc_array_index_type, tmp, tmp2);
2272 : 457 : gfc_grow_array (&implied_do_block, desc, tmp);
2273 : : }
2274 : :
2275 : : /* Generate the loop body. */
2276 : 1116 : exit_label = gfc_build_label_decl (NULL_TREE);
2277 : 1116 : gfc_start_block (&body);
2278 : :
2279 : : /* Generate the exit condition. Depending on the sign of
2280 : : the step variable we have to generate the correct
2281 : : comparison. */
2282 : 1116 : tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2283 : 1116 : step, build_int_cst (TREE_TYPE (step), 0));
2284 : 1116 : cond = fold_build3_loc (input_location, COND_EXPR,
2285 : : logical_type_node, tmp,
2286 : : fold_build2_loc (input_location, GT_EXPR,
2287 : : logical_type_node, shadow_loopvar, end),
2288 : : fold_build2_loc (input_location, LT_EXPR,
2289 : : logical_type_node, shadow_loopvar, end));
2290 : 1116 : tmp = build1_v (GOTO_EXPR, exit_label);
2291 : 1116 : TREE_USED (exit_label) = 1;
2292 : 1116 : tmp = build3_v (COND_EXPR, cond, tmp,
2293 : : build_empty_stmt (input_location));
2294 : 1116 : gfc_add_expr_to_block (&body, tmp);
2295 : :
2296 : : /* The main loop body. */
2297 : 1116 : gfc_add_expr_to_block (&body, loopbody);
2298 : :
2299 : : /* Increase loop variable by step. */
2300 : 1116 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
2301 : 1116 : TREE_TYPE (shadow_loopvar), shadow_loopvar,
2302 : : step);
2303 : 1116 : gfc_add_modify (&body, shadow_loopvar, tmp);
2304 : :
2305 : : /* Finish the loop. */
2306 : 1116 : tmp = gfc_finish_block (&body);
2307 : 1116 : tmp = build1_v (LOOP_EXPR, tmp);
2308 : 1116 : gfc_add_expr_to_block (&implied_do_block, tmp);
2309 : :
2310 : : /* Add the exit label. */
2311 : 1116 : tmp = build1_v (LABEL_EXPR, exit_label);
2312 : 1116 : gfc_add_expr_to_block (&implied_do_block, tmp);
2313 : :
2314 : : /* Finish the implied-do loop. */
2315 : 1116 : tmp = gfc_finish_block(&implied_do_block);
2316 : 1116 : gfc_add_expr_to_block(pblock, tmp);
2317 : :
2318 : 1116 : gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar);
2319 : : }
2320 : : }
2321 : :
2322 : : /* F2008 4.5.6.3 para 5: If an executable construct references a structure
2323 : : constructor or array constructor, the entity created by the constructor is
2324 : : finalized after execution of the innermost executable construct containing
2325 : : the reference. This, in fact, was later deleted by the Combined Techical
2326 : : Corrigenda 1 TO 4 for fortran 2008 (f08/0011).
2327 : :
2328 : : Transmit finalization of this constructor through 'finalblock'. */
2329 : 8307 : if ((gfc_option.allow_std & (GFC_STD_F2008 | GFC_STD_F2003))
2330 : 8307 : && !(gfc_option.allow_std & GFC_STD_GNU)
2331 : 52 : && finalblock != NULL
2332 : 24 : && gfc_may_be_finalized (ts)
2333 : 18 : && ctr > 0 && desc != NULL_TREE
2334 : 8325 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
2335 : : {
2336 : 18 : symbol_attribute attr;
2337 : 18 : gfc_se fse;
2338 : 18 : gfc_warning (0, "The structure constructor at %C has been"
2339 : : " finalized. This feature was removed by f08/0011."
2340 : : " Use -std=f2018 or -std=gnu to eliminate the"
2341 : : " finalization.");
2342 : 18 : attr.pointer = attr.allocatable = 0;
2343 : 18 : gfc_init_se (&fse, NULL);
2344 : 18 : fse.expr = desc;
2345 : 18 : gfc_finalize_tree_expr (&fse, ts.u.derived, attr, 1);
2346 : 18 : gfc_add_block_to_block (finalblock, &fse.pre);
2347 : 18 : gfc_add_block_to_block (finalblock, &fse.finalblock);
2348 : 18 : gfc_add_block_to_block (finalblock, &fse.post);
2349 : : }
2350 : :
2351 : 8307 : mpz_clear (size);
2352 : 8307 : }
2353 : :
2354 : :
2355 : : /* The array constructor code can create a string length with an operand
2356 : : in the form of a temporary variable. This variable will retain its
2357 : : context (current_function_decl). If we store this length tree in a
2358 : : gfc_charlen structure which is shared by a variable in another
2359 : : context, the resulting gfc_charlen structure with a variable in a
2360 : : different context, we could trip the assertion in expand_expr_real_1
2361 : : when it sees that a variable has been created in one context and
2362 : : referenced in another.
2363 : :
2364 : : If this might be the case, we create a new gfc_charlen structure and
2365 : : link it into the current namespace. */
2366 : :
2367 : : static void
2368 : 7670 : store_backend_decl (gfc_charlen **clp, tree len, bool force_new_cl)
2369 : : {
2370 : 7670 : if (force_new_cl)
2371 : : {
2372 : 7643 : gfc_charlen *new_cl = gfc_new_charlen (gfc_current_ns, *clp);
2373 : 7643 : *clp = new_cl;
2374 : : }
2375 : 7670 : (*clp)->backend_decl = len;
2376 : 7670 : }
2377 : :
2378 : : /* A catch-all to obtain the string length for anything that is not
2379 : : a substring of non-constant length, a constant, array or variable. */
2380 : :
2381 : : static void
2382 : 261 : get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
2383 : : {
2384 : 261 : gfc_se se;
2385 : :
2386 : : /* Don't bother if we already know the length is a constant. */
2387 : 261 : if (*len && INTEGER_CST_P (*len))
2388 : 32 : return;
2389 : :
2390 : 229 : if (!e->ref && e->ts.u.cl && e->ts.u.cl->length
2391 : 29 : && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
2392 : : {
2393 : : /* This is easy. */
2394 : 1 : gfc_conv_const_charlen (e->ts.u.cl);
2395 : 1 : *len = e->ts.u.cl->backend_decl;
2396 : : }
2397 : : else
2398 : : {
2399 : : /* Otherwise, be brutal even if inefficient. */
2400 : 228 : gfc_init_se (&se, NULL);
2401 : :
2402 : : /* No function call, in case of side effects. */
2403 : 228 : se.no_function_call = 1;
2404 : 228 : if (e->rank == 0)
2405 : 116 : gfc_conv_expr (&se, e);
2406 : : else
2407 : 112 : gfc_conv_expr_descriptor (&se, e);
2408 : :
2409 : : /* Fix the value. */
2410 : 228 : *len = gfc_evaluate_now (se.string_length, &se.pre);
2411 : :
2412 : 228 : gfc_add_block_to_block (block, &se.pre);
2413 : 228 : gfc_add_block_to_block (block, &se.post);
2414 : :
2415 : 228 : store_backend_decl (&e->ts.u.cl, *len, true);
2416 : : }
2417 : : }
2418 : :
2419 : :
2420 : : /* Figure out the string length of a variable reference expression.
2421 : : Used by get_array_ctor_strlen. */
2422 : :
2423 : : static void
2424 : 840 : get_array_ctor_var_strlen (stmtblock_t *block, gfc_expr * expr, tree * len)
2425 : : {
2426 : 840 : gfc_ref *ref;
2427 : 840 : gfc_typespec *ts;
2428 : 840 : mpz_t char_len;
2429 : 840 : gfc_se se;
2430 : :
2431 : : /* Don't bother if we already know the length is a constant. */
2432 : 840 : if (*len && INTEGER_CST_P (*len))
2433 : 503 : return;
2434 : :
2435 : 417 : ts = &expr->symtree->n.sym->ts;
2436 : 655 : for (ref = expr->ref; ref; ref = ref->next)
2437 : : {
2438 : 318 : switch (ref->type)
2439 : : {
2440 : 195 : case REF_ARRAY:
2441 : : /* Array references don't change the string length. */
2442 : 195 : if (ts->deferred)
2443 : 99 : get_array_ctor_all_strlen (block, expr, len);
2444 : : break;
2445 : :
2446 : 43 : case REF_COMPONENT:
2447 : : /* Use the length of the component. */
2448 : 43 : ts = &ref->u.c.component->ts;
2449 : 43 : break;
2450 : :
2451 : 80 : case REF_SUBSTRING:
2452 : 80 : if (ref->u.ss.end == NULL
2453 : 68 : || ref->u.ss.start->expr_type != EXPR_CONSTANT
2454 : 61 : || ref->u.ss.end->expr_type != EXPR_CONSTANT)
2455 : : {
2456 : : /* Note that this might evaluate expr. */
2457 : 52 : get_array_ctor_all_strlen (block, expr, len);
2458 : 52 : return;
2459 : : }
2460 : 28 : mpz_init_set_ui (char_len, 1);
2461 : 28 : mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
2462 : 28 : mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
2463 : 28 : *len = gfc_conv_mpz_to_tree_type (char_len, gfc_charlen_type_node);
2464 : 28 : mpz_clear (char_len);
2465 : 28 : return;
2466 : :
2467 : : case REF_INQUIRY:
2468 : : break;
2469 : :
2470 : 0 : default:
2471 : 0 : gcc_unreachable ();
2472 : : }
2473 : : }
2474 : :
2475 : : /* A last ditch attempt that is sometimes needed for deferred characters. */
2476 : 337 : if (!ts->u.cl->backend_decl)
2477 : : {
2478 : 19 : gfc_init_se (&se, NULL);
2479 : 19 : if (expr->rank)
2480 : 12 : gfc_conv_expr_descriptor (&se, expr);
2481 : : else
2482 : 7 : gfc_conv_expr (&se, expr);
2483 : 19 : gcc_assert (se.string_length != NULL_TREE);
2484 : 19 : gfc_add_block_to_block (block, &se.pre);
2485 : 19 : ts->u.cl->backend_decl = se.string_length;
2486 : : }
2487 : :
2488 : 337 : *len = ts->u.cl->backend_decl;
2489 : : }
2490 : :
2491 : :
2492 : : /* Figure out the string length of a character array constructor.
2493 : : If len is NULL, don't calculate the length; this happens for recursive calls
2494 : : when a sub-array-constructor is an element but not at the first position,
2495 : : so when we're not interested in the length.
2496 : : Returns TRUE if all elements are character constants. */
2497 : :
2498 : : bool
2499 : 8115 : get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len)
2500 : : {
2501 : 8115 : gfc_constructor *c;
2502 : 8115 : bool is_const;
2503 : :
2504 : 8115 : is_const = true;
2505 : :
2506 : 8115 : if (gfc_constructor_first (base) == NULL)
2507 : : {
2508 : 303 : if (len)
2509 : 303 : *len = build_int_cstu (gfc_charlen_type_node, 0);
2510 : 303 : return is_const;
2511 : : }
2512 : :
2513 : : /* Loop over all constructor elements to find out is_const, but in len we
2514 : : want to store the length of the first, not the last, element. We can
2515 : : of course exit the loop as soon as is_const is found to be false. */
2516 : 7812 : for (c = gfc_constructor_first (base);
2517 : 43806 : c && is_const; c = gfc_constructor_next (c))
2518 : : {
2519 : 35994 : switch (c->expr->expr_type)
2520 : : {
2521 : 34953 : case EXPR_CONSTANT:
2522 : 34953 : if (len && !(*len && INTEGER_CST_P (*len)))
2523 : 394 : *len = build_int_cstu (gfc_charlen_type_node,
2524 : 394 : c->expr->value.character.length);
2525 : : break;
2526 : :
2527 : 31 : case EXPR_ARRAY:
2528 : 31 : if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
2529 : 1029 : is_const = false;
2530 : : break;
2531 : :
2532 : 900 : case EXPR_VARIABLE:
2533 : 900 : is_const = false;
2534 : 900 : if (len)
2535 : 840 : get_array_ctor_var_strlen (block, c->expr, len);
2536 : : break;
2537 : :
2538 : 110 : default:
2539 : 110 : is_const = false;
2540 : 110 : if (len)
2541 : 110 : get_array_ctor_all_strlen (block, c->expr, len);
2542 : : break;
2543 : : }
2544 : :
2545 : : /* After the first iteration, we don't want the length modified. */
2546 : 35994 : len = NULL;
2547 : : }
2548 : :
2549 : : return is_const;
2550 : : }
2551 : :
2552 : : /* Check whether the array constructor C consists entirely of constant
2553 : : elements, and if so returns the number of those elements, otherwise
2554 : : return zero. Note, an empty or NULL array constructor returns zero. */
2555 : :
2556 : : unsigned HOST_WIDE_INT
2557 : 49058 : gfc_constant_array_constructor_p (gfc_constructor_base base)
2558 : : {
2559 : 49058 : unsigned HOST_WIDE_INT nelem = 0;
2560 : :
2561 : 49058 : gfc_constructor *c = gfc_constructor_first (base);
2562 : 305326 : while (c)
2563 : : {
2564 : 216753 : if (c->iterator
2565 : 215550 : || c->expr->rank > 0
2566 : 214795 : || c->expr->expr_type != EXPR_CONSTANT)
2567 : : return 0;
2568 : 207210 : c = gfc_constructor_next (c);
2569 : 207210 : nelem++;
2570 : : }
2571 : : return nelem;
2572 : : }
2573 : :
2574 : :
2575 : : /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
2576 : : and the tree type of it's elements, TYPE, return a static constant
2577 : : variable that is compile-time initialized. */
2578 : :
2579 : : tree
2580 : 32249 : gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
2581 : : {
2582 : 32249 : tree tmptype, init, tmp;
2583 : 32249 : HOST_WIDE_INT nelem;
2584 : 32249 : gfc_constructor *c;
2585 : 32249 : gfc_array_spec as;
2586 : 32249 : gfc_se se;
2587 : 32249 : int i;
2588 : 32249 : vec<constructor_elt, va_gc> *v = NULL;
2589 : :
2590 : : /* First traverse the constructor list, converting the constants
2591 : : to tree to build an initializer. */
2592 : 32249 : nelem = 0;
2593 : 32249 : c = gfc_constructor_first (expr->value.constructor);
2594 : 247832 : while (c)
2595 : : {
2596 : 183334 : gfc_init_se (&se, NULL);
2597 : 183334 : gfc_conv_constant (&se, c->expr);
2598 : 183334 : if (c->expr->ts.type != BT_CHARACTER)
2599 : 149251 : se.expr = fold_convert (type, se.expr);
2600 : 34083 : else if (POINTER_TYPE_P (type))
2601 : 34083 : se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
2602 : : se.expr);
2603 : 183334 : CONSTRUCTOR_APPEND_ELT (v, build_int_cst (gfc_array_index_type, nelem),
2604 : : se.expr);
2605 : 183334 : c = gfc_constructor_next (c);
2606 : 183334 : nelem++;
2607 : : }
2608 : :
2609 : : /* Next determine the tree type for the array. We use the gfortran
2610 : : front-end's gfc_get_nodesc_array_type in order to create a suitable
2611 : : GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
2612 : :
2613 : 32249 : memset (&as, 0, sizeof (gfc_array_spec));
2614 : :
2615 : 32249 : as.rank = expr->rank;
2616 : 32249 : as.type = AS_EXPLICIT;
2617 : 32249 : if (!expr->shape)
2618 : : {
2619 : 3 : as.lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
2620 : 3 : as.upper[0] = gfc_get_int_expr (gfc_default_integer_kind,
2621 : : NULL, nelem - 1);
2622 : : }
2623 : : else
2624 : 68008 : for (i = 0; i < expr->rank; i++)
2625 : : {
2626 : 35762 : int tmp = (int) mpz_get_si (expr->shape[i]);
2627 : 35762 : as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
2628 : 35762 : as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind,
2629 : 35762 : NULL, tmp - 1);
2630 : : }
2631 : :
2632 : 32249 : tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
2633 : :
2634 : : /* as is not needed anymore. */
2635 : 100263 : for (i = 0; i < as.rank + as.corank; i++)
2636 : : {
2637 : 35765 : gfc_free_expr (as.lower[i]);
2638 : 35765 : gfc_free_expr (as.upper[i]);
2639 : : }
2640 : :
2641 : 32249 : init = build_constructor (tmptype, v);
2642 : :
2643 : 32249 : TREE_CONSTANT (init) = 1;
2644 : 32249 : TREE_STATIC (init) = 1;
2645 : :
2646 : 32249 : tmp = build_decl (input_location, VAR_DECL, create_tmp_var_name ("A"),
2647 : : tmptype);
2648 : 32249 : DECL_ARTIFICIAL (tmp) = 1;
2649 : 32249 : DECL_IGNORED_P (tmp) = 1;
2650 : 32249 : TREE_STATIC (tmp) = 1;
2651 : 32249 : TREE_CONSTANT (tmp) = 1;
2652 : 32249 : TREE_READONLY (tmp) = 1;
2653 : 32249 : DECL_INITIAL (tmp) = init;
2654 : 32249 : pushdecl (tmp);
2655 : :
2656 : 32249 : return tmp;
2657 : : }
2658 : :
2659 : :
2660 : : /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
2661 : : This mostly initializes the scalarizer state info structure with the
2662 : : appropriate values to directly use the array created by the function
2663 : : gfc_build_constant_array_constructor. */
2664 : :
2665 : : static void
2666 : 27741 : trans_constant_array_constructor (gfc_ss * ss, tree type)
2667 : : {
2668 : 27741 : gfc_array_info *info;
2669 : 27741 : tree tmp;
2670 : 27741 : int i;
2671 : :
2672 : 27741 : tmp = gfc_build_constant_array_constructor (ss->info->expr, type);
2673 : :
2674 : 27741 : info = &ss->info->data.array;
2675 : :
2676 : 27741 : info->descriptor = tmp;
2677 : 27741 : info->data = gfc_build_addr_expr (NULL_TREE, tmp);
2678 : 27741 : info->offset = gfc_index_zero_node;
2679 : :
2680 : 57724 : for (i = 0; i < ss->dimen; i++)
2681 : : {
2682 : 29983 : info->delta[i] = gfc_index_zero_node;
2683 : 29983 : info->start[i] = gfc_index_zero_node;
2684 : 29983 : info->end[i] = gfc_index_zero_node;
2685 : 29983 : info->stride[i] = gfc_index_one_node;
2686 : : }
2687 : 27741 : }
2688 : :
2689 : :
2690 : : static int
2691 : 27747 : get_rank (gfc_loopinfo *loop)
2692 : : {
2693 : 27747 : int rank;
2694 : :
2695 : 27747 : rank = 0;
2696 : 123156 : for (; loop; loop = loop->parent)
2697 : 61584 : rank += loop->dimen;
2698 : :
2699 : 33825 : return rank;
2700 : : }
2701 : :
2702 : :
2703 : : /* Helper routine of gfc_trans_array_constructor to determine if the
2704 : : bounds of the loop specified by LOOP are constant and simple enough
2705 : : to use with trans_constant_array_constructor. Returns the
2706 : : iteration count of the loop if suitable, and NULL_TREE otherwise. */
2707 : :
2708 : : static tree
2709 : 27747 : constant_array_constructor_loop_size (gfc_loopinfo * l)
2710 : : {
2711 : 27747 : gfc_loopinfo *loop;
2712 : 27747 : tree size = gfc_index_one_node;
2713 : 27747 : tree tmp;
2714 : 27747 : int i, total_dim;
2715 : :
2716 : 27747 : total_dim = get_rank (l);
2717 : :
2718 : 55494 : for (loop = l; loop; loop = loop->parent)
2719 : : {
2720 : 57748 : for (i = 0; i < loop->dimen; i++)
2721 : : {
2722 : : /* If the bounds aren't constant, return NULL_TREE. */
2723 : 30001 : if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
2724 : : return NULL_TREE;
2725 : 29995 : if (!integer_zerop (loop->from[i]))
2726 : : {
2727 : : /* Only allow nonzero "from" in one-dimensional arrays. */
2728 : 0 : if (total_dim != 1)
2729 : : return NULL_TREE;
2730 : 0 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2731 : : gfc_array_index_type,
2732 : : loop->to[i], loop->from[i]);
2733 : : }
2734 : : else
2735 : 29995 : tmp = loop->to[i];
2736 : 29995 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
2737 : : gfc_array_index_type, tmp, gfc_index_one_node);
2738 : 29995 : size = fold_build2_loc (input_location, MULT_EXPR,
2739 : : gfc_array_index_type, size, tmp);
2740 : : }
2741 : : }
2742 : :
2743 : : return size;
2744 : : }
2745 : :
2746 : :
2747 : : static tree *
2748 : 34922 : get_loop_upper_bound_for_array (gfc_ss *array, int array_dim)
2749 : : {
2750 : 34922 : gfc_ss *ss;
2751 : 34922 : int n;
2752 : :
2753 : 34922 : gcc_assert (array->nested_ss == NULL);
2754 : :
2755 : 34922 : for (ss = array; ss; ss = ss->parent)
2756 : 34922 : for (n = 0; n < ss->loop->dimen; n++)
2757 : 34922 : if (array_dim == get_array_ref_dim_for_loop_dim (ss, n))
2758 : 34922 : return &(ss->loop->to[n]);
2759 : :
2760 : 0 : gcc_unreachable ();
2761 : : }
2762 : :
2763 : :
2764 : : static gfc_loopinfo *
2765 : 566614 : outermost_loop (gfc_loopinfo * loop)
2766 : : {
2767 : 720894 : while (loop->parent != NULL)
2768 : : loop = loop->parent;
2769 : :
2770 : 717653 : return loop;
2771 : : }
2772 : :
2773 : :
2774 : : /* Array constructors are handled by constructing a temporary, then using that
2775 : : within the scalarization loop. This is not optimal, but seems by far the
2776 : : simplest method. */
2777 : :
2778 : : static void
2779 : 34922 : trans_array_constructor (gfc_ss * ss, locus * where)
2780 : : {
2781 : 34922 : gfc_constructor_base c;
2782 : 34922 : tree offset;
2783 : 34922 : tree offsetvar;
2784 : 34922 : tree desc;
2785 : 34922 : tree type;
2786 : 34922 : tree tmp;
2787 : 34922 : tree *loop_ubound0;
2788 : 34922 : bool dynamic;
2789 : 34922 : bool old_first_len, old_typespec_chararray_ctor;
2790 : 34922 : tree old_first_len_val;
2791 : 34922 : gfc_loopinfo *loop, *outer_loop;
2792 : 34922 : gfc_ss_info *ss_info;
2793 : 34922 : gfc_expr *expr;
2794 : 34922 : gfc_ss *s;
2795 : 34922 : tree neg_len;
2796 : 34922 : char *msg;
2797 : 34922 : stmtblock_t finalblock;
2798 : :
2799 : : /* Save the old values for nested checking. */
2800 : 34922 : old_first_len = first_len;
2801 : 34922 : old_first_len_val = first_len_val;
2802 : 34922 : old_typespec_chararray_ctor = typespec_chararray_ctor;
2803 : :
2804 : 34922 : loop = ss->loop;
2805 : 34922 : outer_loop = outermost_loop (loop);
2806 : 34922 : ss_info = ss->info;
2807 : 34922 : expr = ss_info->expr;
2808 : :
2809 : : /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
2810 : : typespec was given for the array constructor. */
2811 : 69844 : typespec_chararray_ctor = (expr->ts.type == BT_CHARACTER
2812 : 7442 : && expr->ts.u.cl
2813 : 42364 : && expr->ts.u.cl->length_from_typespec);
2814 : :
2815 : 34922 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2816 : 2425 : && expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
2817 : : {
2818 : 1450 : first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
2819 : 1450 : first_len = true;
2820 : : }
2821 : :
2822 : 34922 : gcc_assert (ss->dimen == ss->loop->dimen);
2823 : :
2824 : 34922 : c = expr->value.constructor;
2825 : 34922 : if (expr->ts.type == BT_CHARACTER)
2826 : : {
2827 : 7442 : bool const_string;
2828 : 7442 : bool force_new_cl = false;
2829 : :
2830 : : /* get_array_ctor_strlen walks the elements of the constructor, if a
2831 : : typespec was given, we already know the string length and want the one
2832 : : specified there. */
2833 : 7442 : if (typespec_chararray_ctor && expr->ts.u.cl->length
2834 : 312 : && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
2835 : : {
2836 : 27 : gfc_se length_se;
2837 : :
2838 : 27 : const_string = false;
2839 : 27 : gfc_init_se (&length_se, NULL);
2840 : 27 : gfc_conv_expr_type (&length_se, expr->ts.u.cl->length,
2841 : : gfc_charlen_type_node);
2842 : 27 : ss_info->string_length = length_se.expr;
2843 : :
2844 : : /* Check if the character length is negative. If it is, then
2845 : : set LEN = 0. */
2846 : 27 : neg_len = fold_build2_loc (input_location, LT_EXPR,
2847 : : logical_type_node, ss_info->string_length,
2848 : 27 : build_zero_cst (TREE_TYPE
2849 : : (ss_info->string_length)));
2850 : : /* Print a warning if bounds checking is enabled. */
2851 : 27 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2852 : : {
2853 : 18 : msg = xasprintf ("Negative character length treated as LEN = 0");
2854 : 18 : gfc_trans_runtime_check (false, true, neg_len, &length_se.pre,
2855 : : where, msg);
2856 : 18 : free (msg);
2857 : : }
2858 : :
2859 : 27 : ss_info->string_length
2860 : 27 : = fold_build3_loc (input_location, COND_EXPR,
2861 : : gfc_charlen_type_node, neg_len,
2862 : : build_zero_cst
2863 : 27 : (TREE_TYPE (ss_info->string_length)),
2864 : : ss_info->string_length);
2865 : 27 : ss_info->string_length = gfc_evaluate_now (ss_info->string_length,
2866 : : &length_se.pre);
2867 : 27 : gfc_add_block_to_block (&outer_loop->pre, &length_se.pre);
2868 : 27 : gfc_add_block_to_block (&outer_loop->post, &length_se.post);
2869 : 27 : }
2870 : : else
2871 : : {
2872 : 7415 : const_string = get_array_ctor_strlen (&outer_loop->pre, c,
2873 : : &ss_info->string_length);
2874 : 7415 : force_new_cl = true;
2875 : :
2876 : : /* Initialize "len" with string length for bounds checking. */
2877 : 7415 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2878 : 1468 : && !typespec_chararray_ctor
2879 : 1450 : && ss_info->string_length)
2880 : : {
2881 : 1450 : gfc_se length_se;
2882 : :
2883 : 1450 : gfc_init_se (&length_se, NULL);
2884 : 1450 : gfc_add_modify (&length_se.pre, first_len_val,
2885 : 1450 : fold_convert (TREE_TYPE (first_len_val),
2886 : : ss_info->string_length));
2887 : 1450 : ss_info->string_length = gfc_evaluate_now (ss_info->string_length,
2888 : : &length_se.pre);
2889 : 1450 : gfc_add_block_to_block (&outer_loop->pre, &length_se.pre);
2890 : 1450 : gfc_add_block_to_block (&outer_loop->post, &length_se.post);
2891 : : }
2892 : : }
2893 : :
2894 : : /* Complex character array constructors should have been taken care of
2895 : : and not end up here. */
2896 : 7442 : gcc_assert (ss_info->string_length);
2897 : :
2898 : 7442 : store_backend_decl (&expr->ts.u.cl, ss_info->string_length, force_new_cl);
2899 : :
2900 : 7442 : type = gfc_get_character_type_len (expr->ts.kind, ss_info->string_length);
2901 : 7442 : if (const_string)
2902 : 6598 : type = build_pointer_type (type);
2903 : : }
2904 : : else
2905 : 27505 : type = gfc_typenode_for_spec (expr->ts.type == BT_CLASS
2906 : 25 : ? &CLASS_DATA (expr)->ts : &expr->ts);
2907 : :
2908 : : /* See if the constructor determines the loop bounds. */
2909 : 34922 : dynamic = false;
2910 : :
2911 : 34922 : loop_ubound0 = get_loop_upper_bound_for_array (ss, 0);
2912 : :
2913 : 68747 : if (expr->shape && get_rank (loop) > 1 && *loop_ubound0 == NULL_TREE)
2914 : : {
2915 : : /* We have a multidimensional parameter. */
2916 : 0 : for (s = ss; s; s = s->parent)
2917 : : {
2918 : : int n;
2919 : 0 : for (n = 0; n < s->loop->dimen; n++)
2920 : : {
2921 : 0 : s->loop->from[n] = gfc_index_zero_node;
2922 : 0 : s->loop->to[n] = gfc_conv_mpz_to_tree (expr->shape[s->dim[n]],
2923 : : gfc_index_integer_kind);
2924 : 0 : s->loop->to[n] = fold_build2_loc (input_location, MINUS_EXPR,
2925 : : gfc_array_index_type,
2926 : 0 : s->loop->to[n],
2927 : : gfc_index_one_node);
2928 : : }
2929 : : }
2930 : : }
2931 : :
2932 : 34922 : if (*loop_ubound0 == NULL_TREE)
2933 : : {
2934 : 721 : mpz_t size;
2935 : :
2936 : : /* We should have a 1-dimensional, zero-based loop. */
2937 : 721 : gcc_assert (loop->parent == NULL && loop->nested == NULL);
2938 : 721 : gcc_assert (loop->dimen == 1);
2939 : 721 : gcc_assert (integer_zerop (loop->from[0]));
2940 : :
2941 : : /* Split the constructor size into a static part and a dynamic part.
2942 : : Allocate the static size up-front and record whether the dynamic
2943 : : size might be nonzero. */
2944 : 721 : mpz_init (size);
2945 : 721 : dynamic = gfc_get_array_constructor_size (&size, c);
2946 : 721 : mpz_sub_ui (size, size, 1);
2947 : 721 : loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
2948 : 721 : mpz_clear (size);
2949 : : }
2950 : :
2951 : : /* Special case constant array constructors. */
2952 : 721 : if (!dynamic)
2953 : : {
2954 : 34216 : unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
2955 : 34216 : if (nelem > 0)
2956 : : {
2957 : 27747 : tree size = constant_array_constructor_loop_size (loop);
2958 : 27747 : if (size && compare_tree_int (size, nelem) == 0)
2959 : : {
2960 : 27741 : trans_constant_array_constructor (ss, type);
2961 : 27741 : goto finish;
2962 : : }
2963 : : }
2964 : : }
2965 : :
2966 : 7181 : gfc_trans_create_temp_array (&outer_loop->pre, &outer_loop->post, ss, type,
2967 : : NULL_TREE, dynamic, true, false, where);
2968 : :
2969 : 7181 : desc = ss_info->data.array.descriptor;
2970 : 7181 : offset = gfc_index_zero_node;
2971 : 7181 : offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
2972 : 7181 : suppress_warning (offsetvar);
2973 : 7181 : TREE_USED (offsetvar) = 0;
2974 : :
2975 : 7181 : gfc_init_block (&finalblock);
2976 : 7181 : gfc_trans_array_constructor_value (&outer_loop->pre,
2977 : 7181 : expr->must_finalize ? &finalblock : NULL,
2978 : : type, desc, c, &offset, &offsetvar,
2979 : : dynamic);
2980 : :
2981 : : /* If the array grows dynamically, the upper bound of the loop variable
2982 : : is determined by the array's final upper bound. */
2983 : 7181 : if (dynamic)
2984 : : {
2985 : 706 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2986 : : gfc_array_index_type,
2987 : : offsetvar, gfc_index_one_node);
2988 : 706 : tmp = gfc_evaluate_now (tmp, &outer_loop->pre);
2989 : 706 : gfc_conv_descriptor_ubound_set (&loop->pre, desc, gfc_rank_cst[0], tmp);
2990 : 706 : if (*loop_ubound0 && VAR_P (*loop_ubound0))
2991 : 0 : gfc_add_modify (&outer_loop->pre, *loop_ubound0, tmp);
2992 : : else
2993 : 706 : *loop_ubound0 = tmp;
2994 : : }
2995 : :
2996 : 7181 : if (TREE_USED (offsetvar))
2997 : 1740 : pushdecl (offsetvar);
2998 : : else
2999 : 5441 : gcc_assert (INTEGER_CST_P (offset));
3000 : :
3001 : : #if 0
3002 : : /* Disable bound checking for now because it's probably broken. */
3003 : : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3004 : : {
3005 : : gcc_unreachable ();
3006 : : }
3007 : : #endif
3008 : :
3009 : 5441 : finish:
3010 : : /* Restore old values of globals. */
3011 : 34922 : first_len = old_first_len;
3012 : 34922 : first_len_val = old_first_len_val;
3013 : 34922 : typespec_chararray_ctor = old_typespec_chararray_ctor;
3014 : :
3015 : : /* F2008 4.5.6.3 para 5: If an executable construct references a structure
3016 : : constructor or array constructor, the entity created by the constructor is
3017 : : finalized after execution of the innermost executable construct containing
3018 : : the reference. */
3019 : 34922 : if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
3020 : 1345 : && finalblock.head != NULL_TREE)
3021 : 18 : gfc_add_block_to_block (&loop->post, &finalblock);
3022 : :
3023 : 34922 : }
3024 : :
3025 : :
3026 : : /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
3027 : : called after evaluating all of INFO's vector dimensions. Go through
3028 : : each such vector dimension and see if we can now fill in any missing
3029 : : loop bounds. */
3030 : :
3031 : : static void
3032 : 148406 : set_vector_loop_bounds (gfc_ss * ss)
3033 : : {
3034 : 148406 : gfc_loopinfo *loop, *outer_loop;
3035 : 148406 : gfc_array_info *info;
3036 : 148406 : gfc_se se;
3037 : 148406 : tree tmp;
3038 : 148406 : tree desc;
3039 : 148406 : tree zero;
3040 : 148406 : int n;
3041 : 148406 : int dim;
3042 : :
3043 : 148406 : outer_loop = outermost_loop (ss->loop);
3044 : :
3045 : 148406 : info = &ss->info->data.array;
3046 : :
3047 : 297449 : for (; ss; ss = ss->parent)
3048 : : {
3049 : 149043 : loop = ss->loop;
3050 : :
3051 : 347263 : for (n = 0; n < loop->dimen; n++)
3052 : : {
3053 : 198220 : dim = ss->dim[n];
3054 : 198220 : if (info->ref->u.ar.dimen_type[dim] != DIMEN_VECTOR
3055 : 744 : || loop->to[n] != NULL)
3056 : 198061 : continue;
3057 : :
3058 : : /* Loop variable N indexes vector dimension DIM, and we don't
3059 : : yet know the upper bound of loop variable N. Set it to the
3060 : : difference between the vector's upper and lower bounds. */
3061 : 159 : gcc_assert (loop->from[n] == gfc_index_zero_node);
3062 : 159 : gcc_assert (info->subscript[dim]
3063 : : && info->subscript[dim]->info->type == GFC_SS_VECTOR);
3064 : :
3065 : 159 : gfc_init_se (&se, NULL);
3066 : 159 : desc = info->subscript[dim]->info->data.array.descriptor;
3067 : 159 : zero = gfc_rank_cst[0];
3068 : 159 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
3069 : : gfc_array_index_type,
3070 : : gfc_conv_descriptor_ubound_get (desc, zero),
3071 : : gfc_conv_descriptor_lbound_get (desc, zero));
3072 : 159 : tmp = gfc_evaluate_now (tmp, &outer_loop->pre);
3073 : 159 : loop->to[n] = tmp;
3074 : : }
3075 : : }
3076 : 148406 : }
3077 : :
3078 : :
3079 : : /* Tells whether a scalar argument to an elemental procedure is saved out
3080 : : of a scalarization loop as a value or as a reference. */
3081 : :
3082 : : bool
3083 : 33190 : gfc_scalar_elemental_arg_saved_as_reference (gfc_ss_info * ss_info)
3084 : : {
3085 : 33190 : if (ss_info->type != GFC_SS_REFERENCE)
3086 : : return false;
3087 : :
3088 : 3026 : if (ss_info->data.scalar.needs_temporary)
3089 : : return false;
3090 : :
3091 : : /* If the actual argument can be absent (in other words, it can
3092 : : be a NULL reference), don't try to evaluate it; pass instead
3093 : : the reference directly. */
3094 : 2662 : if (ss_info->can_be_null_ref)
3095 : : return true;
3096 : :
3097 : : /* If the expression is of polymorphic type, it's actual size is not known,
3098 : : so we avoid copying it anywhere. */
3099 : 2026 : if (ss_info->data.scalar.dummy_arg
3100 : 1232 : && gfc_dummy_arg_get_typespec (*ss_info->data.scalar.dummy_arg).type
3101 : : == BT_CLASS
3102 : 2076 : && ss_info->expr->ts.type == BT_CLASS)
3103 : : return true;
3104 : :
3105 : : /* If the expression is a data reference of aggregate type,
3106 : : and the data reference is not used on the left hand side,
3107 : : avoid a copy by saving a reference to the content. */
3108 : 2002 : if (!ss_info->data.scalar.needs_temporary
3109 : 2002 : && (ss_info->expr->ts.type == BT_DERIVED
3110 : 1126 : || ss_info->expr->ts.type == BT_CLASS)
3111 : 2926 : && gfc_expr_is_variable (ss_info->expr))
3112 : : return true;
3113 : :
3114 : : /* Otherwise the expression is evaluated to a temporary variable before the
3115 : : scalarization loop. */
3116 : : return false;
3117 : : }
3118 : :
3119 : :
3120 : : /* Add the pre and post chains for all the scalar expressions in a SS chain
3121 : : to loop. This is called after the loop parameters have been calculated,
3122 : : but before the actual scalarizing loops. */
3123 : :
3124 : : static void
3125 : 151191 : gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
3126 : : locus * where)
3127 : : {
3128 : 151191 : gfc_loopinfo *nested_loop, *outer_loop;
3129 : 151191 : gfc_se se;
3130 : 151191 : gfc_ss_info *ss_info;
3131 : 151191 : gfc_array_info *info;
3132 : 151191 : gfc_expr *expr;
3133 : 151191 : int n;
3134 : :
3135 : : /* Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise,
3136 : : arguments could get evaluated multiple times. */
3137 : 151191 : if (ss->is_alloc_lhs)
3138 : 152 : return;
3139 : :
3140 : 151039 : outer_loop = outermost_loop (loop);
3141 : :
3142 : : /* TODO: This can generate bad code if there are ordering dependencies,
3143 : : e.g., a callee allocated function and an unknown size constructor. */
3144 : 151039 : gcc_assert (ss != NULL);
3145 : :
3146 : 395927 : for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
3147 : : {
3148 : 244888 : gcc_assert (ss);
3149 : :
3150 : : /* Cross loop arrays are handled from within the most nested loop. */
3151 : 244888 : if (ss->nested_ss != NULL)
3152 : 737 : continue;
3153 : :
3154 : 244151 : ss_info = ss->info;
3155 : 244151 : expr = ss_info->expr;
3156 : 244151 : info = &ss_info->data.array;
3157 : :
3158 : 244151 : switch (ss_info->type)
3159 : : {
3160 : 35849 : case GFC_SS_SCALAR:
3161 : : /* Scalar expression. Evaluate this now. This includes elemental
3162 : : dimension indices, but not array section bounds. */
3163 : 35849 : gfc_init_se (&se, NULL);
3164 : 35849 : gfc_conv_expr (&se, expr);
3165 : 35849 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3166 : :
3167 : 35849 : if (expr->ts.type != BT_CHARACTER
3168 : 35849 : && !gfc_is_alloc_class_scalar_function (expr))
3169 : : {
3170 : : /* Move the evaluation of scalar expressions outside the
3171 : : scalarization loop, except for WHERE assignments. */
3172 : 32310 : if (subscript)
3173 : 3930 : se.expr = convert(gfc_array_index_type, se.expr);
3174 : 32310 : if (!ss_info->where)
3175 : 31896 : se.expr = gfc_evaluate_now (se.expr, &outer_loop->pre);
3176 : 32310 : gfc_add_block_to_block (&outer_loop->pre, &se.post);
3177 : : }
3178 : : else
3179 : 3539 : gfc_add_block_to_block (&outer_loop->post, &se.post);
3180 : :
3181 : 35849 : ss_info->data.scalar.value = se.expr;
3182 : 35849 : ss_info->string_length = se.string_length;
3183 : 35849 : break;
3184 : :
3185 : 1513 : case GFC_SS_REFERENCE:
3186 : : /* Scalar argument to elemental procedure. */
3187 : 1513 : gfc_init_se (&se, NULL);
3188 : 1513 : if (gfc_scalar_elemental_arg_saved_as_reference (ss_info))
3189 : 768 : gfc_conv_expr_reference (&se, expr);
3190 : : else
3191 : : {
3192 : : /* Evaluate the argument outside the loop and pass
3193 : : a reference to the value. */
3194 : 745 : gfc_conv_expr (&se, expr);
3195 : : }
3196 : :
3197 : : /* Ensure that a pointer to the string is stored. */
3198 : 1513 : if (expr->ts.type == BT_CHARACTER)
3199 : 174 : gfc_conv_string_parameter (&se);
3200 : :
3201 : 1513 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3202 : 1513 : gfc_add_block_to_block (&outer_loop->post, &se.post);
3203 : 1513 : if (gfc_is_class_scalar_expr (expr))
3204 : : /* This is necessary because the dynamic type will always be
3205 : : large than the declared type. In consequence, assigning
3206 : : the value to a temporary could segfault.
3207 : : OOP-TODO: see if this is generally correct or is the value
3208 : : has to be written to an allocated temporary, whose address
3209 : : is passed via ss_info. */
3210 : 48 : ss_info->data.scalar.value = se.expr;
3211 : : else
3212 : 1465 : ss_info->data.scalar.value = gfc_evaluate_now (se.expr,
3213 : : &outer_loop->pre);
3214 : :
3215 : 1513 : ss_info->string_length = se.string_length;
3216 : 1513 : break;
3217 : :
3218 : : case GFC_SS_SECTION:
3219 : : /* Add the expressions for scalar and vector subscripts. */
3220 : 2374496 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
3221 : 2226090 : if (info->subscript[n])
3222 : 4674 : gfc_add_loop_ss_code (loop, info->subscript[n], true, where);
3223 : :
3224 : 148406 : set_vector_loop_bounds (ss);
3225 : 148406 : break;
3226 : :
3227 : 744 : case GFC_SS_VECTOR:
3228 : : /* Get the vector's descriptor and store it in SS. */
3229 : 744 : gfc_init_se (&se, NULL);
3230 : 744 : gfc_conv_expr_descriptor (&se, expr);
3231 : 744 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3232 : 744 : gfc_add_block_to_block (&outer_loop->post, &se.post);
3233 : 744 : info->descriptor = se.expr;
3234 : 744 : break;
3235 : :
3236 : 4970 : case GFC_SS_INTRINSIC:
3237 : 4970 : gfc_add_intrinsic_ss_code (loop, ss);
3238 : 4970 : break;
3239 : :
3240 : 8294 : case GFC_SS_FUNCTION:
3241 : : /* Array function return value. We call the function and save its
3242 : : result in a temporary for use inside the loop. */
3243 : 8294 : gfc_init_se (&se, NULL);
3244 : 8294 : se.loop = loop;
3245 : 8294 : se.ss = ss;
3246 : 8294 : if (gfc_is_class_array_function (expr))
3247 : 153 : expr->must_finalize = 1;
3248 : 8294 : gfc_conv_expr (&se, expr);
3249 : 8294 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3250 : 8294 : gfc_add_block_to_block (&outer_loop->post, &se.post);
3251 : 8294 : gfc_add_block_to_block (&outer_loop->post, &se.finalblock);
3252 : 8294 : ss_info->string_length = se.string_length;
3253 : 8294 : break;
3254 : :
3255 : 34922 : case GFC_SS_CONSTRUCTOR:
3256 : 34922 : if (expr->ts.type == BT_CHARACTER
3257 : 7442 : && ss_info->string_length == NULL
3258 : 7442 : && expr->ts.u.cl
3259 : 7442 : && expr->ts.u.cl->length
3260 : 7136 : && expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
3261 : : {
3262 : 7085 : gfc_init_se (&se, NULL);
3263 : 7085 : gfc_conv_expr_type (&se, expr->ts.u.cl->length,
3264 : : gfc_charlen_type_node);
3265 : 7085 : ss_info->string_length = se.expr;
3266 : 7085 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3267 : 7085 : gfc_add_block_to_block (&outer_loop->post, &se.post);
3268 : : }
3269 : 34922 : trans_array_constructor (ss, where);
3270 : 34922 : break;
3271 : :
3272 : : case GFC_SS_TEMP:
3273 : : case GFC_SS_COMPONENT:
3274 : : /* Do nothing. These are handled elsewhere. */
3275 : : break;
3276 : :
3277 : 0 : default:
3278 : 0 : gcc_unreachable ();
3279 : : }
3280 : : }
3281 : :
3282 : 151039 : if (!subscript)
3283 : 146918 : for (nested_loop = loop->nested; nested_loop;
3284 : 553 : nested_loop = nested_loop->next)
3285 : 553 : gfc_add_loop_ss_code (nested_loop, nested_loop->ss, subscript, where);
3286 : : }
3287 : :
3288 : :
3289 : : /* Translate expressions for the descriptor and data pointer of a SS. */
3290 : : /*GCC ARRAYS*/
3291 : :
3292 : : static void
3293 : 266034 : gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
3294 : : {
3295 : 266034 : gfc_se se;
3296 : 266034 : gfc_ss_info *ss_info;
3297 : 266034 : gfc_array_info *info;
3298 : 266034 : tree tmp;
3299 : :
3300 : 266034 : ss_info = ss->info;
3301 : 266034 : info = &ss_info->data.array;
3302 : :
3303 : : /* Get the descriptor for the array to be scalarized. */
3304 : 266034 : gcc_assert (ss_info->expr->expr_type == EXPR_VARIABLE);
3305 : 266034 : gfc_init_se (&se, NULL);
3306 : 266034 : se.descriptor_only = 1;
3307 : 266034 : gfc_conv_expr_lhs (&se, ss_info->expr);
3308 : 266034 : gfc_add_block_to_block (block, &se.pre);
3309 : 266034 : info->descriptor = se.expr;
3310 : 266034 : ss_info->string_length = se.string_length;
3311 : 266034 : ss_info->class_container = se.class_container;
3312 : :
3313 : 266034 : if (base)
3314 : : {
3315 : 98333 : if (ss_info->expr->ts.type == BT_CHARACTER && !ss_info->expr->ts.deferred
3316 : 21504 : && ss_info->expr->ts.u.cl->length == NULL)
3317 : : {
3318 : : /* Emit a DECL_EXPR for the variable sized array type in
3319 : : GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
3320 : : sizes works correctly. */
3321 : 988 : tree arraytype = TREE_TYPE (
3322 : : GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (info->descriptor)));
3323 : 988 : if (! TYPE_NAME (arraytype))
3324 : 836 : TYPE_NAME (arraytype) = build_decl (UNKNOWN_LOCATION, TYPE_DECL,
3325 : : NULL_TREE, arraytype);
3326 : 988 : gfc_add_expr_to_block (block, build1 (DECL_EXPR, arraytype,
3327 : 988 : TYPE_NAME (arraytype)));
3328 : : }
3329 : : /* Also the data pointer. */
3330 : 98333 : tmp = gfc_conv_array_data (se.expr);
3331 : : /* If this is a variable or address or a class array, use it directly.
3332 : : Otherwise we must evaluate it now to avoid breaking dependency
3333 : : analysis by pulling the expressions for elemental array indices
3334 : : inside the loop. */
3335 : 98333 : if (!(DECL_P (tmp)
3336 : 89018 : || (TREE_CODE (tmp) == ADDR_EXPR
3337 : 59473 : && DECL_P (TREE_OPERAND (tmp, 0)))
3338 : 32055 : || (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))
3339 : 29268 : && TREE_CODE (se.expr) == COMPONENT_REF
3340 : 6813 : && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (se.expr, 0))))))
3341 : 29564 : tmp = gfc_evaluate_now (tmp, block);
3342 : 98333 : info->data = tmp;
3343 : :
3344 : 98333 : tmp = gfc_conv_array_offset (se.expr);
3345 : 98333 : info->offset = gfc_evaluate_now (tmp, block);
3346 : :
3347 : : /* Make absolutely sure that the saved_offset is indeed saved
3348 : : so that the variable is still accessible after the loops
3349 : : are translated. */
3350 : 98333 : info->saved_offset = info->offset;
3351 : : }
3352 : 266034 : }
3353 : :
3354 : :
3355 : : /* Initialize a gfc_loopinfo structure. */
3356 : :
3357 : : void
3358 : 150944 : gfc_init_loopinfo (gfc_loopinfo * loop)
3359 : : {
3360 : 150944 : int n;
3361 : :
3362 : 150944 : memset (loop, 0, sizeof (gfc_loopinfo));
3363 : 150944 : gfc_init_block (&loop->pre);
3364 : 150944 : gfc_init_block (&loop->post);
3365 : :
3366 : : /* Initially scalarize in order and default to no loop reversal. */
3367 : 2566048 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
3368 : : {
3369 : 2264160 : loop->order[n] = n;
3370 : 2264160 : loop->reverse[n] = GFC_INHIBIT_REVERSE;
3371 : : }
3372 : :
3373 : 150944 : loop->ss = gfc_ss_terminator;
3374 : 150944 : }
3375 : :
3376 : :
3377 : : /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
3378 : : chain. */
3379 : :
3380 : : void
3381 : 145651 : gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
3382 : : {
3383 : 145651 : se->loop = loop;
3384 : 145651 : }
3385 : :
3386 : :
3387 : : /* Return an expression for the data pointer of an array. */
3388 : :
3389 : : tree
3390 : 275434 : gfc_conv_array_data (tree descriptor)
3391 : : {
3392 : 275434 : tree type;
3393 : :
3394 : 275434 : type = TREE_TYPE (descriptor);
3395 : 275434 : if (GFC_ARRAY_TYPE_P (type))
3396 : : {
3397 : 199572 : if (TREE_CODE (type) == POINTER_TYPE)
3398 : : return descriptor;
3399 : : else
3400 : : {
3401 : : /* Descriptorless arrays. */
3402 : 150351 : return gfc_build_addr_expr (NULL_TREE, descriptor);
3403 : : }
3404 : : }
3405 : : else
3406 : 75862 : return gfc_conv_descriptor_data_get (descriptor);
3407 : : }
3408 : :
3409 : :
3410 : : /* Return an expression for the base offset of an array. */
3411 : :
3412 : : tree
3413 : 208417 : gfc_conv_array_offset (tree descriptor)
3414 : : {
3415 : 208417 : tree type;
3416 : :
3417 : 208417 : type = TREE_TYPE (descriptor);
3418 : 208417 : if (GFC_ARRAY_TYPE_P (type))
3419 : 154305 : return GFC_TYPE_ARRAY_OFFSET (type);
3420 : : else
3421 : 54112 : return gfc_conv_descriptor_offset_get (descriptor);
3422 : : }
3423 : :
3424 : :
3425 : : /* Get an expression for the array stride. */
3426 : :
3427 : : tree
3428 : 399928 : gfc_conv_array_stride (tree descriptor, int dim)
3429 : : {
3430 : 399928 : tree tmp;
3431 : 399928 : tree type;
3432 : :
3433 : 399928 : type = TREE_TYPE (descriptor);
3434 : :
3435 : : /* For descriptorless arrays use the array size. */
3436 : 399928 : tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
3437 : 399928 : if (tmp != NULL_TREE)
3438 : : return tmp;
3439 : :
3440 : 76756 : tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]);
3441 : 76756 : return tmp;
3442 : : }
3443 : :
3444 : :
3445 : : /* Like gfc_conv_array_stride, but for the lower bound. */
3446 : :
3447 : : tree
3448 : 267075 : gfc_conv_array_lbound (tree descriptor, int dim)
3449 : : {
3450 : 267075 : tree tmp;
3451 : 267075 : tree type;
3452 : :
3453 : 267075 : type = TREE_TYPE (descriptor);
3454 : :
3455 : 267075 : tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
3456 : 267075 : if (tmp != NULL_TREE)
3457 : : return tmp;
3458 : :
3459 : 11530 : tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]);
3460 : 11530 : return tmp;
3461 : : }
3462 : :
3463 : :
3464 : : /* Like gfc_conv_array_stride, but for the upper bound. */
3465 : :
3466 : : tree
3467 : 174156 : gfc_conv_array_ubound (tree descriptor, int dim)
3468 : : {
3469 : 174156 : tree tmp;
3470 : 174156 : tree type;
3471 : :
3472 : 174156 : type = TREE_TYPE (descriptor);
3473 : :
3474 : 174156 : tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
3475 : 174156 : if (tmp != NULL_TREE)
3476 : : return tmp;
3477 : :
3478 : : /* This should only ever happen when passing an assumed shape array
3479 : : as an actual parameter. The value will never be used. */
3480 : 7340 : if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
3481 : 535 : return gfc_index_zero_node;
3482 : :
3483 : 6805 : tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]);
3484 : 6805 : return tmp;
3485 : : }
3486 : :
3487 : :
3488 : : /* Generate abridged name of a part-ref for use in bounds-check message.
3489 : : Cases:
3490 : : (1) for an ordinary array variable x return "x"
3491 : : (2) for z a DT scalar and array component x (at level 1) return "z%%x"
3492 : : (3) for z a DT scalar and array component x (at level > 1) or
3493 : : for z a DT array and array x (at any number of levels): "z...%%x"
3494 : : */
3495 : :
3496 : : static char *
3497 : 15522 : abridged_ref_name (gfc_expr * expr, gfc_array_ref * ar)
3498 : : {
3499 : 15522 : gfc_ref *ref;
3500 : 15522 : gfc_symbol *sym;
3501 : 15522 : char *ref_name = NULL;
3502 : 15522 : const char *comp_name = NULL;
3503 : 15522 : int len_sym, last_len = 0, level = 0;
3504 : 15522 : bool sym_is_array;
3505 : :
3506 : 15522 : gcc_assert (expr->expr_type == EXPR_VARIABLE && expr->ref != NULL);
3507 : :
3508 : 15522 : sym = expr->symtree->n.sym;
3509 : 31044 : sym_is_array = (sym->ts.type != BT_CLASS
3510 : 15522 : ? sym->as != NULL
3511 : 73 : : IS_CLASS_ARRAY (sym));
3512 : 15522 : len_sym = strlen (sym->name);
3513 : :
3514 : : /* Scan ref chain to get name of the array component (when ar != NULL) or
3515 : : array section, determine depth and remember its component name. */
3516 : 15912 : for (ref = expr->ref; ref; ref = ref->next)
3517 : : {
3518 : 15912 : if (ref->type == REF_COMPONENT
3519 : 253 : && strcmp (ref->u.c.component->name, "_data") != 0)
3520 : : {
3521 : 219 : level++;
3522 : 219 : comp_name = ref->u.c.component->name;
3523 : 219 : continue;
3524 : : }
3525 : :
3526 : 15693 : if (ref->type != REF_ARRAY)
3527 : 34 : continue;
3528 : :
3529 : 15659 : if (ar)
3530 : : {
3531 : 15507 : if (&ref->u.ar == ar)
3532 : : break;
3533 : : }
3534 : 152 : else if (ref->u.ar.type == AR_SECTION)
3535 : : break;
3536 : : }
3537 : :
3538 : 15522 : if (level > 0)
3539 : 205 : last_len = strlen (comp_name);
3540 : :
3541 : : /* Provide a buffer sufficiently large to hold "x...%%z". */
3542 : 15522 : ref_name = XNEWVEC (char, len_sym + last_len + 6);
3543 : 15522 : strcpy (ref_name, sym->name);
3544 : :
3545 : 15522 : if (level == 1 && !sym_is_array)
3546 : : {
3547 : 75 : strcat (ref_name, "%%");
3548 : 75 : strcat (ref_name, comp_name);
3549 : : }
3550 : 15447 : else if (level > 0)
3551 : : {
3552 : 130 : strcat (ref_name, "...%%");
3553 : 130 : strcat (ref_name, comp_name);
3554 : : }
3555 : :
3556 : 15522 : return ref_name;
3557 : : }
3558 : :
3559 : :
3560 : : /* Generate code to perform an array index bound check. */
3561 : :
3562 : : static tree
3563 : 3616 : trans_array_bound_check (gfc_se * se, gfc_ss *ss, tree index, int n,
3564 : : locus * where, bool check_upper,
3565 : : const char *compname = NULL)
3566 : : {
3567 : 3616 : tree fault;
3568 : 3616 : tree tmp_lo, tmp_up;
3569 : 3616 : tree descriptor;
3570 : 3616 : char *msg;
3571 : 3616 : char *ref_name = NULL;
3572 : 3616 : const char * name = NULL;
3573 : 3616 : gfc_expr *expr;
3574 : :
3575 : 3616 : if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
3576 : : return index;
3577 : :
3578 : 216 : descriptor = ss->info->data.array.descriptor;
3579 : :
3580 : 216 : index = gfc_evaluate_now (index, &se->pre);
3581 : :
3582 : : /* We find a name for the error message. */
3583 : 216 : name = ss->info->expr->symtree->n.sym->name;
3584 : 216 : gcc_assert (name != NULL);
3585 : :
3586 : : /* When we have a component ref, get name of the array section.
3587 : : Note that there can only be one part ref. */
3588 : 216 : expr = ss->info->expr;
3589 : 216 : if (expr->ref && !compname)
3590 : 142 : name = ref_name = abridged_ref_name (expr, NULL);
3591 : :
3592 : 216 : if (VAR_P (descriptor))
3593 : 138 : name = IDENTIFIER_POINTER (DECL_NAME (descriptor));
3594 : :
3595 : : /* Use given (array component) name. */
3596 : 216 : if (compname)
3597 : 74 : name = compname;
3598 : :
3599 : : /* If upper bound is present, include both bounds in the error message. */
3600 : 216 : if (check_upper)
3601 : : {
3602 : 189 : tmp_lo = gfc_conv_array_lbound (descriptor, n);
3603 : 189 : tmp_up = gfc_conv_array_ubound (descriptor, n);
3604 : :
3605 : 189 : if (name)
3606 : 189 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3607 : : "outside of expected range (%%ld:%%ld)", n+1, name);
3608 : : else
3609 : 0 : msg = xasprintf ("Index '%%ld' of dimension %d "
3610 : : "outside of expected range (%%ld:%%ld)", n+1);
3611 : :
3612 : 189 : fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3613 : : index, tmp_lo);
3614 : 189 : gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
3615 : : fold_convert (long_integer_type_node, index),
3616 : : fold_convert (long_integer_type_node, tmp_lo),
3617 : : fold_convert (long_integer_type_node, tmp_up));
3618 : 189 : fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3619 : : index, tmp_up);
3620 : 189 : gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
3621 : : fold_convert (long_integer_type_node, index),
3622 : : fold_convert (long_integer_type_node, tmp_lo),
3623 : : fold_convert (long_integer_type_node, tmp_up));
3624 : 189 : free (msg);
3625 : : }
3626 : : else
3627 : : {
3628 : 27 : tmp_lo = gfc_conv_array_lbound (descriptor, n);
3629 : :
3630 : 27 : if (name)
3631 : 27 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3632 : : "below lower bound of %%ld", n+1, name);
3633 : : else
3634 : 0 : msg = xasprintf ("Index '%%ld' of dimension %d "
3635 : : "below lower bound of %%ld", n+1);
3636 : :
3637 : 27 : fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3638 : : index, tmp_lo);
3639 : 27 : gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
3640 : : fold_convert (long_integer_type_node, index),
3641 : : fold_convert (long_integer_type_node, tmp_lo));
3642 : 27 : free (msg);
3643 : : }
3644 : :
3645 : 216 : free (ref_name);
3646 : 216 : return index;
3647 : : }
3648 : :
3649 : :
3650 : : /* Generate code for bounds checking for elemental dimensions. */
3651 : :
3652 : : static void
3653 : 6635 : array_bound_check_elemental (gfc_se * se, gfc_ss * ss, gfc_expr * expr)
3654 : : {
3655 : 6635 : gfc_array_ref *ar;
3656 : 6635 : gfc_ref *ref;
3657 : 6635 : char *var_name = NULL;
3658 : 6635 : int dim;
3659 : :
3660 : 6635 : if (expr->expr_type == EXPR_VARIABLE)
3661 : : {
3662 : 12515 : for (ref = expr->ref; ref; ref = ref->next)
3663 : : {
3664 : 6281 : if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
3665 : : {
3666 : 3971 : ar = &ref->u.ar;
3667 : 3971 : var_name = abridged_ref_name (expr, ar);
3668 : 8231 : for (dim = 0; dim < ar->dimen; dim++)
3669 : : {
3670 : 4260 : if (ar->dimen_type[dim] == DIMEN_ELEMENT)
3671 : : {
3672 : 74 : gfc_se indexse;
3673 : 74 : gfc_init_se (&indexse, NULL);
3674 : 74 : gfc_conv_expr_type (&indexse, ar->start[dim],
3675 : : gfc_array_index_type);
3676 : 74 : trans_array_bound_check (se, ss, indexse.expr, dim,
3677 : : &ar->where,
3678 : 74 : ar->as->type != AS_ASSUMED_SIZE
3679 : 74 : || dim < ar->dimen - 1,
3680 : : var_name);
3681 : : }
3682 : : }
3683 : 3971 : free (var_name);
3684 : : }
3685 : : }
3686 : : }
3687 : 6635 : }
3688 : :
3689 : :
3690 : : /* Return the offset for an index. Performs bound checking for elemental
3691 : : dimensions. Single element references are processed separately.
3692 : : DIM is the array dimension, I is the loop dimension. */
3693 : :
3694 : : static tree
3695 : 183763 : conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i,
3696 : : gfc_array_ref * ar, tree stride)
3697 : : {
3698 : 183763 : gfc_array_info *info;
3699 : 183763 : tree index;
3700 : 183763 : tree desc;
3701 : 183763 : tree data;
3702 : :
3703 : 183763 : info = &ss->info->data.array;
3704 : :
3705 : : /* Get the index into the array for this dimension. */
3706 : 183763 : if (ar)
3707 : : {
3708 : 128207 : gcc_assert (ar->type != AR_ELEMENT);
3709 : 128207 : switch (ar->dimen_type[dim])
3710 : : {
3711 : 0 : case DIMEN_THIS_IMAGE:
3712 : 0 : gcc_unreachable ();
3713 : 2805 : break;
3714 : 2805 : case DIMEN_ELEMENT:
3715 : : /* Elemental dimension. */
3716 : 2805 : gcc_assert (info->subscript[dim]
3717 : : && info->subscript[dim]->info->type == GFC_SS_SCALAR);
3718 : : /* We've already translated this value outside the loop. */
3719 : 2805 : index = info->subscript[dim]->info->data.scalar.value;
3720 : :
3721 : 5610 : index = trans_array_bound_check (se, ss, index, dim, &ar->where,
3722 : 2805 : ar->as->type != AS_ASSUMED_SIZE
3723 : 2805 : || dim < ar->dimen - 1);
3724 : 2805 : break;
3725 : :
3726 : 737 : case DIMEN_VECTOR:
3727 : 737 : gcc_assert (info && se->loop);
3728 : 737 : gcc_assert (info->subscript[dim]
3729 : : && info->subscript[dim]->info->type == GFC_SS_VECTOR);
3730 : 737 : desc = info->subscript[dim]->info->data.array.descriptor;
3731 : :
3732 : : /* Get a zero-based index into the vector. */
3733 : 737 : index = fold_build2_loc (input_location, MINUS_EXPR,
3734 : : gfc_array_index_type,
3735 : : se->loop->loopvar[i], se->loop->from[i]);
3736 : :
3737 : : /* Multiply the index by the stride. */
3738 : 737 : index = fold_build2_loc (input_location, MULT_EXPR,
3739 : : gfc_array_index_type,
3740 : : index, gfc_conv_array_stride (desc, 0));
3741 : :
3742 : : /* Read the vector to get an index into info->descriptor. */
3743 : 737 : data = build_fold_indirect_ref_loc (input_location,
3744 : : gfc_conv_array_data (desc));
3745 : 737 : index = gfc_build_array_ref (data, index, NULL);
3746 : 737 : index = gfc_evaluate_now (index, &se->pre);
3747 : 737 : index = fold_convert (gfc_array_index_type, index);
3748 : :
3749 : : /* Do any bounds checking on the final info->descriptor index. */
3750 : 1474 : index = trans_array_bound_check (se, ss, index, dim, &ar->where,
3751 : 737 : ar->as->type != AS_ASSUMED_SIZE
3752 : 737 : || dim < ar->dimen - 1);
3753 : 737 : break;
3754 : :
3755 : 124665 : case DIMEN_RANGE:
3756 : : /* Scalarized dimension. */
3757 : 124665 : gcc_assert (info && se->loop);
3758 : :
3759 : : /* Multiply the loop variable by the stride and delta. */
3760 : 124665 : index = se->loop->loopvar[i];
3761 : 124665 : if (!integer_onep (info->stride[dim]))
3762 : 5330 : index = fold_build2_loc (input_location, MULT_EXPR,
3763 : : gfc_array_index_type, index,
3764 : : info->stride[dim]);
3765 : 124665 : if (!integer_zerop (info->delta[dim]))
3766 : 47267 : index = fold_build2_loc (input_location, PLUS_EXPR,
3767 : : gfc_array_index_type, index,
3768 : : info->delta[dim]);
3769 : : break;
3770 : :
3771 : 0 : default:
3772 : 0 : gcc_unreachable ();
3773 : : }
3774 : : }
3775 : : else
3776 : : {
3777 : : /* Temporary array or derived type component. */
3778 : 55556 : gcc_assert (se->loop);
3779 : 55556 : index = se->loop->loopvar[se->loop->order[i]];
3780 : :
3781 : : /* Pointer functions can have stride[0] different from unity.
3782 : : Use the stride returned by the function call and stored in
3783 : : the descriptor for the temporary. */
3784 : 55556 : if (se->ss && se->ss->info->type == GFC_SS_FUNCTION
3785 : 6917 : && se->ss->info->expr
3786 : 6917 : && se->ss->info->expr->symtree
3787 : 6917 : && se->ss->info->expr->symtree->n.sym->result
3788 : 6585 : && se->ss->info->expr->symtree->n.sym->result->attr.pointer)
3789 : 138 : stride = gfc_conv_descriptor_stride_get (info->descriptor,
3790 : : gfc_rank_cst[dim]);
3791 : :
3792 : 55556 : if (info->delta[dim] && !integer_zerop (info->delta[dim]))
3793 : 708 : index = fold_build2_loc (input_location, PLUS_EXPR,
3794 : : gfc_array_index_type, index, info->delta[dim]);
3795 : : }
3796 : :
3797 : : /* Multiply by the stride. */
3798 : 183763 : if (stride != NULL && !integer_onep (stride))
3799 : 47304 : index = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
3800 : : index, stride);
3801 : :
3802 : 183763 : return index;
3803 : : }
3804 : :
3805 : :
3806 : : /* Build a scalarized array reference using the vptr 'size'. */
3807 : :
3808 : : static bool
3809 : 149973 : build_class_array_ref (gfc_se *se, tree base, tree index)
3810 : : {
3811 : 149973 : tree size;
3812 : 149973 : tree decl = NULL_TREE;
3813 : 149973 : tree tmp;
3814 : 149973 : gfc_expr *expr = se->ss->info->expr;
3815 : 149973 : gfc_expr *class_expr;
3816 : 149973 : gfc_typespec *ts;
3817 : 149973 : gfc_symbol *sym;
3818 : :
3819 : 149973 : tmp = !VAR_P (base) ? gfc_get_class_from_expr (base) : NULL_TREE;
3820 : :
3821 : 67047 : if (tmp != NULL_TREE)
3822 : : decl = tmp;
3823 : : else
3824 : : {
3825 : : /* The base expression does not contain a class component, either
3826 : : because it is a temporary array or array descriptor. Class
3827 : : array functions are correctly resolved above. */
3828 : 147216 : if (!expr
3829 : 147216 : || (expr->ts.type != BT_CLASS
3830 : 136788 : && !gfc_is_class_array_ref (expr, NULL)))
3831 : 146902 : return false;
3832 : :
3833 : : /* Obtain the expression for the class entity or component that is
3834 : : followed by an array reference, which is not an element, so that
3835 : : the span of the array can be obtained. */
3836 : 314 : class_expr = gfc_find_and_cut_at_last_class_ref (expr, false, &ts);
3837 : :
3838 : 314 : if (!ts)
3839 : : return false;
3840 : :
3841 : 289 : sym = (!class_expr && expr) ? expr->symtree->n.sym : NULL;
3842 : 0 : if (sym && sym->attr.function
3843 : 0 : && sym == sym->result
3844 : 0 : && sym->backend_decl == current_function_decl)
3845 : : /* The temporary is the data field of the class data component
3846 : : of the current function. */
3847 : 0 : decl = gfc_get_fake_result_decl (sym, 0);
3848 : 289 : else if (sym)
3849 : : {
3850 : 0 : if (decl == NULL_TREE)
3851 : 0 : decl = expr->symtree->n.sym->backend_decl;
3852 : : /* For class arrays the tree containing the class is stored in
3853 : : GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl.
3854 : : For all others it's sym's backend_decl directly. */
3855 : 0 : if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl))
3856 : 0 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
3857 : : }
3858 : : else
3859 : 289 : decl = gfc_get_class_from_gfc_expr (class_expr);
3860 : :
3861 : 289 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
3862 : 0 : decl = build_fold_indirect_ref_loc (input_location, decl);
3863 : :
3864 : 289 : if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl)))
3865 : : return false;
3866 : : }
3867 : :
3868 : 3046 : se->class_vptr = gfc_evaluate_now (gfc_class_vptr_get (decl), &se->pre);
3869 : :
3870 : 3046 : size = gfc_class_vtab_size_get (decl);
3871 : : /* For unlimited polymorphic entities then _len component needs to be
3872 : : multiplied with the size. */
3873 : 3046 : size = gfc_resize_class_size_with_len (&se->pre, decl, size);
3874 : 3046 : size = fold_convert (TREE_TYPE (index), size);
3875 : :
3876 : : /* Return the element in the se expression. */
3877 : 3046 : se->expr = gfc_build_spanned_array_ref (base, index, size);
3878 : 3046 : return true;
3879 : : }
3880 : :
3881 : :
3882 : : /* Indicates that the tree EXPR is a reference to an array that can’t
3883 : : have any negative stride. */
3884 : :
3885 : : static bool
3886 : 258222 : non_negative_strides_array_p (tree expr)
3887 : : {
3888 : 269622 : if (expr == NULL_TREE)
3889 : : return false;
3890 : :
3891 : 269622 : tree type = TREE_TYPE (expr);
3892 : 269622 : if (POINTER_TYPE_P (type))
3893 : 60606 : type = TREE_TYPE (type);
3894 : :
3895 : 269622 : if (TYPE_LANG_SPECIFIC (type))
3896 : : {
3897 : 269622 : gfc_array_kind array_kind = GFC_TYPE_ARRAY_AKIND (type);
3898 : :
3899 : 269622 : if (array_kind == GFC_ARRAY_ALLOCATABLE
3900 : 269622 : || array_kind == GFC_ARRAY_ASSUMED_SHAPE_CONT)
3901 : : return true;
3902 : : }
3903 : :
3904 : : /* An array with descriptor can have negative strides.
3905 : : We try to be conservative and return false by default here
3906 : : if we don’t recognize a contiguous array instead of
3907 : : returning false if we can identify a non-contiguous one. */
3908 : 229434 : if (!GFC_ARRAY_TYPE_P (type))
3909 : : return false;
3910 : :
3911 : : /* If the array was originally a dummy with a descriptor, strides can be
3912 : : negative. */
3913 : 200744 : if (DECL_P (expr)
3914 : 192817 : && DECL_LANG_SPECIFIC (expr)
3915 : 43871 : && GFC_DECL_SAVED_DESCRIPTOR (expr)
3916 : 212163 : && GFC_DECL_SAVED_DESCRIPTOR (expr) != expr)
3917 : 11400 : return non_negative_strides_array_p (GFC_DECL_SAVED_DESCRIPTOR (expr));
3918 : :
3919 : : return true;
3920 : : }
3921 : :
3922 : :
3923 : : /* Build a scalarized reference to an array. */
3924 : :
3925 : : static void
3926 : 149973 : gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar,
3927 : : bool tmp_array = false)
3928 : : {
3929 : 149973 : gfc_array_info *info;
3930 : 149973 : tree decl = NULL_TREE;
3931 : 149973 : tree index;
3932 : 149973 : tree base;
3933 : 149973 : gfc_ss *ss;
3934 : 149973 : gfc_expr *expr;
3935 : 149973 : int n;
3936 : :
3937 : 149973 : ss = se->ss;
3938 : 149973 : expr = ss->info->expr;
3939 : 149973 : info = &ss->info->data.array;
3940 : 149973 : if (ar)
3941 : 102833 : n = se->loop->order[0];
3942 : : else
3943 : : n = 0;
3944 : :
3945 : 149973 : index = conv_array_index_offset (se, ss, ss->dim[n], n, ar, info->stride0);
3946 : : /* Add the offset for this dimension to the stored offset for all other
3947 : : dimensions. */
3948 : 149973 : if (info->offset && !integer_zerop (info->offset))
3949 : 109469 : index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3950 : : index, info->offset);
3951 : :
3952 : 149973 : base = build_fold_indirect_ref_loc (input_location, info->data);
3953 : :
3954 : : /* Use the vptr 'size' field to access the element of a class array. */
3955 : 149973 : if (build_class_array_ref (se, base, index))
3956 : 3046 : return;
3957 : :
3958 : 146927 : if (get_CFI_desc (NULL, expr, &decl, ar))
3959 : 442 : decl = build_fold_indirect_ref_loc (input_location, decl);
3960 : :
3961 : : /* A pointer array component can be detected from its field decl. Fix
3962 : : the descriptor, mark the resulting variable decl and pass it to
3963 : : gfc_build_array_ref. */
3964 : 146927 : if (is_pointer_array (info->descriptor)
3965 : 146927 : || (expr && expr->ts.deferred && info->descriptor
3966 : 1926 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info->descriptor))))
3967 : : {
3968 : 7456 : if (TREE_CODE (info->descriptor) == COMPONENT_REF)
3969 : 1238 : decl = info->descriptor;
3970 : 6218 : else if (INDIRECT_REF_P (info->descriptor))
3971 : 1362 : decl = TREE_OPERAND (info->descriptor, 0);
3972 : :
3973 : 7456 : if (decl == NULL_TREE)
3974 : 4856 : decl = info->descriptor;
3975 : : }
3976 : :
3977 : 146927 : bool non_negative_stride = tmp_array
3978 : 146927 : || non_negative_strides_array_p (info->descriptor);
3979 : 146927 : se->expr = gfc_build_array_ref (base, index, decl,
3980 : : non_negative_stride);
3981 : : }
3982 : :
3983 : :
3984 : : /* Translate access of temporary array. */
3985 : :
3986 : : void
3987 : 47140 : gfc_conv_tmp_array_ref (gfc_se * se)
3988 : : {
3989 : 47140 : se->string_length = se->ss->info->string_length;
3990 : 47140 : gfc_conv_scalarized_array_ref (se, NULL, true);
3991 : 47140 : gfc_advance_se_ss_chain (se);
3992 : 47140 : }
3993 : :
3994 : : /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
3995 : :
3996 : : static void
3997 : 244606 : add_to_offset (tree *cst_offset, tree *offset, tree t)
3998 : : {
3999 : 244606 : if (TREE_CODE (t) == INTEGER_CST)
4000 : 122788 : *cst_offset = int_const_binop (PLUS_EXPR, *cst_offset, t);
4001 : : else
4002 : : {
4003 : 121818 : if (!integer_zerop (*offset))
4004 : 44858 : *offset = fold_build2_loc (input_location, PLUS_EXPR,
4005 : : gfc_array_index_type, *offset, t);
4006 : : else
4007 : 76960 : *offset = t;
4008 : : }
4009 : 244606 : }
4010 : :
4011 : :
4012 : : static tree
4013 : 158143 : build_array_ref (tree desc, tree offset, tree decl, tree vptr)
4014 : : {
4015 : 158143 : tree tmp;
4016 : 158143 : tree type;
4017 : 158143 : tree cdesc;
4018 : :
4019 : : /* For class arrays the class declaration is stored in the saved
4020 : : descriptor. */
4021 : 158143 : if (INDIRECT_REF_P (desc)
4022 : 6748 : && DECL_LANG_SPECIFIC (TREE_OPERAND (desc, 0))
4023 : 160290 : && GFC_DECL_SAVED_DESCRIPTOR (TREE_OPERAND (desc, 0)))
4024 : 733 : cdesc = gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (
4025 : : TREE_OPERAND (desc, 0)));
4026 : : else
4027 : : cdesc = desc;
4028 : :
4029 : : /* Class container types do not always have the GFC_CLASS_TYPE_P
4030 : : but the canonical type does. */
4031 : 158143 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdesc))
4032 : 158143 : && TREE_CODE (cdesc) == COMPONENT_REF)
4033 : : {
4034 : 7964 : type = TREE_TYPE (TREE_OPERAND (cdesc, 0));
4035 : 7964 : if (TYPE_CANONICAL (type)
4036 : 7964 : && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type)))
4037 : 2940 : vptr = gfc_class_vptr_get (TREE_OPERAND (cdesc, 0));
4038 : : }
4039 : :
4040 : 158143 : tmp = gfc_conv_array_data (desc);
4041 : 158143 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
4042 : 158143 : tmp = gfc_build_array_ref (tmp, offset, decl,
4043 : 158143 : non_negative_strides_array_p (desc),
4044 : : vptr);
4045 : 158143 : return tmp;
4046 : : }
4047 : :
4048 : :
4049 : : /* Build an array reference. se->expr already holds the array descriptor.
4050 : : This should be either a variable, indirect variable reference or component
4051 : : reference. For arrays which do not have a descriptor, se->expr will be
4052 : : the data pointer.
4053 : : a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
4054 : :
4055 : : void
4056 : 216071 : gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
4057 : : locus * where)
4058 : : {
4059 : 216071 : int n;
4060 : 216071 : tree offset, cst_offset;
4061 : 216071 : tree tmp;
4062 : 216071 : tree stride;
4063 : 216071 : tree decl = NULL_TREE;
4064 : 216071 : gfc_se indexse;
4065 : 216071 : gfc_se tmpse;
4066 : 216071 : gfc_symbol * sym = expr->symtree->n.sym;
4067 : 216071 : char *var_name = NULL;
4068 : :
4069 : 216071 : if (ar->dimen == 0)
4070 : : {
4071 : 4112 : gcc_assert (ar->codimen || sym->attr.select_rank_temporary
4072 : : || (ar->as && ar->as->corank));
4073 : :
4074 : 4112 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
4075 : 908 : se->expr = build_fold_indirect_ref (gfc_conv_array_data (se->expr));
4076 : : else
4077 : : {
4078 : 3204 : if (GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr))
4079 : 3204 : && TREE_CODE (TREE_TYPE (se->expr)) == POINTER_TYPE)
4080 : 2394 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
4081 : :
4082 : : /* Use the actual tree type and not the wrapped coarray. */
4083 : 3204 : if (!se->want_pointer)
4084 : 2416 : se->expr = fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se->expr)),
4085 : : se->expr);
4086 : : }
4087 : :
4088 : 106945 : return;
4089 : : }
4090 : :
4091 : : /* Handle scalarized references separately. */
4092 : 211959 : if (ar->type != AR_ELEMENT)
4093 : : {
4094 : 102833 : gfc_conv_scalarized_array_ref (se, ar);
4095 : 102833 : gfc_advance_se_ss_chain (se);
4096 : 102833 : return;
4097 : : }
4098 : :
4099 : 109126 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
4100 : 11409 : var_name = abridged_ref_name (expr, ar);
4101 : :
4102 : 109126 : decl = se->expr;
4103 : 109126 : if (UNLIMITED_POLY(sym)
4104 : 68 : && IS_CLASS_ARRAY (sym)
4105 : 67 : && sym->attr.dummy
4106 : 54 : && ar->as->type != AS_DEFERRED)
4107 : 42 : decl = sym->backend_decl;
4108 : :
4109 : 109126 : cst_offset = offset = gfc_index_zero_node;
4110 : 109126 : add_to_offset (&cst_offset, &offset, gfc_conv_array_offset (decl));
4111 : :
4112 : : /* Calculate the offsets from all the dimensions. Make sure to associate
4113 : : the final offset so that we form a chain of loop invariant summands. */
4114 : 244606 : for (n = ar->dimen - 1; n >= 0; n--)
4115 : : {
4116 : : /* Calculate the index for this dimension. */
4117 : 135480 : gfc_init_se (&indexse, se);
4118 : 135480 : gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
4119 : 135480 : gfc_add_block_to_block (&se->pre, &indexse.pre);
4120 : :
4121 : 135480 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && ! expr->no_bounds_check)
4122 : : {
4123 : : /* Check array bounds. */
4124 : 14911 : tree cond;
4125 : 14911 : char *msg;
4126 : :
4127 : : /* Evaluate the indexse.expr only once. */
4128 : 14911 : indexse.expr = save_expr (indexse.expr);
4129 : :
4130 : : /* Lower bound. */
4131 : 14911 : tmp = gfc_conv_array_lbound (decl, n);
4132 : 14911 : if (sym->attr.temporary)
4133 : : {
4134 : 18 : gfc_init_se (&tmpse, se);
4135 : 18 : gfc_conv_expr_type (&tmpse, ar->as->lower[n],
4136 : : gfc_array_index_type);
4137 : 18 : gfc_add_block_to_block (&se->pre, &tmpse.pre);
4138 : 18 : tmp = tmpse.expr;
4139 : : }
4140 : :
4141 : 14911 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
4142 : : indexse.expr, tmp);
4143 : 14911 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4144 : : "below lower bound of %%ld", n+1, var_name);
4145 : 14911 : gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
4146 : : fold_convert (long_integer_type_node,
4147 : : indexse.expr),
4148 : : fold_convert (long_integer_type_node, tmp));
4149 : 14911 : free (msg);
4150 : :
4151 : : /* Upper bound, but not for the last dimension of assumed-size
4152 : : arrays. */
4153 : 14911 : if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE)
4154 : : {
4155 : 13178 : tmp = gfc_conv_array_ubound (decl, n);
4156 : 13178 : if (sym->attr.temporary)
4157 : : {
4158 : 18 : gfc_init_se (&tmpse, se);
4159 : 18 : gfc_conv_expr_type (&tmpse, ar->as->upper[n],
4160 : : gfc_array_index_type);
4161 : 18 : gfc_add_block_to_block (&se->pre, &tmpse.pre);
4162 : 18 : tmp = tmpse.expr;
4163 : : }
4164 : :
4165 : 13178 : cond = fold_build2_loc (input_location, GT_EXPR,
4166 : : logical_type_node, indexse.expr, tmp);
4167 : 13178 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4168 : : "above upper bound of %%ld", n+1, var_name);
4169 : 13178 : gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
4170 : : fold_convert (long_integer_type_node,
4171 : : indexse.expr),
4172 : : fold_convert (long_integer_type_node, tmp));
4173 : 13178 : free (msg);
4174 : : }
4175 : : }
4176 : :
4177 : : /* Multiply the index by the stride. */
4178 : 135480 : stride = gfc_conv_array_stride (decl, n);
4179 : 135480 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4180 : : indexse.expr, stride);
4181 : :
4182 : : /* And add it to the total. */
4183 : 135480 : add_to_offset (&cst_offset, &offset, tmp);
4184 : : }
4185 : :
4186 : 109126 : if (!integer_zerop (cst_offset))
4187 : 58585 : offset = fold_build2_loc (input_location, PLUS_EXPR,
4188 : : gfc_array_index_type, offset, cst_offset);
4189 : :
4190 : : /* A pointer array component can be detected from its field decl. Fix
4191 : : the descriptor, mark the resulting variable decl and pass it to
4192 : : build_array_ref. */
4193 : 109126 : decl = NULL_TREE;
4194 : 109126 : if (get_CFI_desc (sym, expr, &decl, ar))
4195 : 3589 : decl = build_fold_indirect_ref_loc (input_location, decl);
4196 : 108460 : if (!expr->ts.deferred && !sym->attr.codimension
4197 : 215749 : && is_pointer_array (se->expr))
4198 : : {
4199 : 3744 : if (TREE_CODE (se->expr) == COMPONENT_REF)
4200 : 1102 : decl = se->expr;
4201 : 2642 : else if (INDIRECT_REF_P (se->expr))
4202 : 701 : decl = TREE_OPERAND (se->expr, 0);
4203 : : else
4204 : 1941 : decl = se->expr;
4205 : : }
4206 : 105382 : else if (expr->ts.deferred
4207 : 104716 : || (sym->ts.type == BT_CHARACTER
4208 : 14231 : && sym->attr.select_type_temporary))
4209 : : {
4210 : 2322 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
4211 : : {
4212 : 2286 : decl = se->expr;
4213 : 2286 : if (INDIRECT_REF_P (decl))
4214 : 20 : decl = TREE_OPERAND (decl, 0);
4215 : : }
4216 : : else
4217 : 36 : decl = sym->backend_decl;
4218 : : }
4219 : 103060 : else if (sym->ts.type == BT_CLASS)
4220 : : {
4221 : 2009 : if (UNLIMITED_POLY (sym))
4222 : : {
4223 : 68 : gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr);
4224 : 68 : gfc_init_se (&tmpse, NULL);
4225 : 68 : gfc_conv_expr (&tmpse, class_expr);
4226 : 68 : if (!se->class_vptr)
4227 : 68 : se->class_vptr = gfc_class_vptr_get (tmpse.expr);
4228 : 68 : gfc_free_expr (class_expr);
4229 : 68 : decl = tmpse.expr;
4230 : 68 : }
4231 : : else
4232 : 1941 : decl = NULL_TREE;
4233 : : }
4234 : :
4235 : 109126 : free (var_name);
4236 : 109126 : se->expr = build_array_ref (se->expr, offset, decl, se->class_vptr);
4237 : : }
4238 : :
4239 : :
4240 : : /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
4241 : : LOOP_DIM dimension (if any) to array's offset. */
4242 : :
4243 : : static void
4244 : 33790 : add_array_offset (stmtblock_t *pblock, gfc_loopinfo *loop, gfc_ss *ss,
4245 : : gfc_array_ref *ar, int array_dim, int loop_dim)
4246 : : {
4247 : 33790 : gfc_se se;
4248 : 33790 : gfc_array_info *info;
4249 : 33790 : tree stride, index;
4250 : :
4251 : 33790 : info = &ss->info->data.array;
4252 : :
4253 : 33790 : gfc_init_se (&se, NULL);
4254 : 33790 : se.loop = loop;
4255 : 33790 : se.expr = info->descriptor;
4256 : 33790 : stride = gfc_conv_array_stride (info->descriptor, array_dim);
4257 : 33790 : index = conv_array_index_offset (&se, ss, array_dim, loop_dim, ar, stride);
4258 : 33790 : gfc_add_block_to_block (pblock, &se.pre);
4259 : :
4260 : 33790 : info->offset = fold_build2_loc (input_location, PLUS_EXPR,
4261 : : gfc_array_index_type,
4262 : : info->offset, index);
4263 : 33790 : info->offset = gfc_evaluate_now (info->offset, pblock);
4264 : 33790 : }
4265 : :
4266 : :
4267 : : /* Generate the code to be executed immediately before entering a
4268 : : scalarization loop. */
4269 : :
4270 : : static void
4271 : 108859 : gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
4272 : : stmtblock_t * pblock)
4273 : : {
4274 : 108859 : tree stride;
4275 : 108859 : gfc_ss_info *ss_info;
4276 : 108859 : gfc_array_info *info;
4277 : 108859 : gfc_ss_type ss_type;
4278 : 108859 : gfc_ss *ss, *pss;
4279 : 108859 : gfc_loopinfo *ploop;
4280 : 108859 : gfc_array_ref *ar;
4281 : 108859 : int i;
4282 : :
4283 : : /* This code will be executed before entering the scalarization loop
4284 : : for this dimension. */
4285 : 328891 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4286 : : {
4287 : 220032 : ss_info = ss->info;
4288 : :
4289 : 220032 : if ((ss_info->useflags & flag) == 0)
4290 : 1284 : continue;
4291 : :
4292 : 218748 : ss_type = ss_info->type;
4293 : 262981 : if (ss_type != GFC_SS_SECTION
4294 : : && ss_type != GFC_SS_FUNCTION
4295 : 218748 : && ss_type != GFC_SS_CONSTRUCTOR
4296 : 218748 : && ss_type != GFC_SS_COMPONENT)
4297 : 44233 : continue;
4298 : :
4299 : 174515 : info = &ss_info->data.array;
4300 : :
4301 : 174515 : gcc_assert (dim < ss->dimen);
4302 : 174515 : gcc_assert (ss->dimen == loop->dimen);
4303 : :
4304 : 174515 : if (info->ref)
4305 : 119989 : ar = &info->ref->u.ar;
4306 : : else
4307 : : ar = NULL;
4308 : :
4309 : 174515 : if (dim == loop->dimen - 1 && loop->parent != NULL)
4310 : : {
4311 : : /* If we are in the outermost dimension of this loop, the previous
4312 : : dimension shall be in the parent loop. */
4313 : 688 : gcc_assert (ss->parent != NULL);
4314 : :
4315 : 688 : pss = ss->parent;
4316 : 688 : ploop = loop->parent;
4317 : :
4318 : : /* ss and ss->parent are about the same array. */
4319 : 688 : gcc_assert (ss_info == pss->info);
4320 : : }
4321 : : else
4322 : : {
4323 : : ploop = loop;
4324 : : pss = ss;
4325 : : }
4326 : :
4327 : 174515 : if (dim == loop->dimen - 1)
4328 : : i = 0;
4329 : : else
4330 : 30297 : i = dim + 1;
4331 : :
4332 : : /* For the time being, there is no loop reordering. */
4333 : 174515 : gcc_assert (i == ploop->order[i]);
4334 : 174515 : i = ploop->order[i];
4335 : :
4336 : 174515 : if (dim == loop->dimen - 1 && loop->parent == NULL)
4337 : : {
4338 : 287060 : stride = gfc_conv_array_stride (info->descriptor,
4339 : 143530 : innermost_ss (ss)->dim[i]);
4340 : :
4341 : : /* Calculate the stride of the innermost loop. Hopefully this will
4342 : : allow the backend optimizers to do their stuff more effectively.
4343 : : */
4344 : 143530 : info->stride0 = gfc_evaluate_now (stride, pblock);
4345 : :
4346 : : /* For the outermost loop calculate the offset due to any
4347 : : elemental dimensions. It will have been initialized with the
4348 : : base offset of the array. */
4349 : 143530 : if (info->ref)
4350 : : {
4351 : 220086 : for (i = 0; i < ar->dimen; i++)
4352 : : {
4353 : 122666 : if (ar->dimen_type[i] != DIMEN_ELEMENT)
4354 : 119861 : continue;
4355 : :
4356 : 2805 : add_array_offset (pblock, loop, ss, ar, i, /* unused */ -1);
4357 : : }
4358 : : }
4359 : : }
4360 : : else
4361 : : /* Add the offset for the previous loop dimension. */
4362 : 30985 : add_array_offset (pblock, ploop, ss, ar, pss->dim[i], i);
4363 : :
4364 : : /* Remember this offset for the second loop. */
4365 : 174515 : if (dim == loop->temp_dim - 1 && loop->parent == NULL)
4366 : 46348 : info->saved_offset = info->offset;
4367 : : }
4368 : 108859 : }
4369 : :
4370 : :
4371 : : /* Start a scalarized expression. Creates a scope and declares loop
4372 : : variables. */
4373 : :
4374 : : void
4375 : 89922 : gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
4376 : : {
4377 : 89922 : int dim;
4378 : 89922 : int n;
4379 : 89922 : int flags;
4380 : :
4381 : 89922 : gcc_assert (!loop->array_parameter);
4382 : :
4383 : 198663 : for (dim = loop->dimen - 1; dim >= 0; dim--)
4384 : : {
4385 : 108741 : n = loop->order[dim];
4386 : :
4387 : 108741 : gfc_start_block (&loop->code[n]);
4388 : :
4389 : : /* Create the loop variable. */
4390 : 108741 : loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
4391 : :
4392 : 108741 : if (dim < loop->temp_dim)
4393 : : flags = 3;
4394 : : else
4395 : 76362 : flags = 1;
4396 : : /* Calculate values that will be constant within this loop. */
4397 : 108741 : gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
4398 : : }
4399 : 89922 : gfc_start_block (pbody);
4400 : 89922 : }
4401 : :
4402 : :
4403 : : /* Generates the actual loop code for a scalarization loop. */
4404 : :
4405 : : static void
4406 : 116995 : gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
4407 : : stmtblock_t * pbody)
4408 : : {
4409 : 116995 : stmtblock_t block;
4410 : 116995 : tree cond;
4411 : 116995 : tree tmp;
4412 : 116995 : tree loopbody;
4413 : 116995 : tree exit_label;
4414 : 116995 : tree stmt;
4415 : 116995 : tree init;
4416 : 116995 : tree incr;
4417 : :
4418 : 116995 : if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS
4419 : : | OMPWS_SCALARIZER_BODY))
4420 : : == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS)
4421 : 108 : && n == loop->dimen - 1)
4422 : : {
4423 : : /* We create an OMP_FOR construct for the outermost scalarized loop. */
4424 : 80 : init = make_tree_vec (1);
4425 : 80 : cond = make_tree_vec (1);
4426 : 80 : incr = make_tree_vec (1);
4427 : :
4428 : : /* Cycle statement is implemented with a goto. Exit statement must not
4429 : : be present for this loop. */
4430 : 80 : exit_label = gfc_build_label_decl (NULL_TREE);
4431 : 80 : TREE_USED (exit_label) = 1;
4432 : :
4433 : : /* Label for cycle statements (if needed). */
4434 : 80 : tmp = build1_v (LABEL_EXPR, exit_label);
4435 : 80 : gfc_add_expr_to_block (pbody, tmp);
4436 : :
4437 : 80 : stmt = make_node (OMP_FOR);
4438 : :
4439 : 80 : TREE_TYPE (stmt) = void_type_node;
4440 : 80 : OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody);
4441 : :
4442 : 80 : OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location,
4443 : : OMP_CLAUSE_SCHEDULE);
4444 : 80 : OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt))
4445 : 80 : = OMP_CLAUSE_SCHEDULE_STATIC;
4446 : 80 : if (ompws_flags & OMPWS_NOWAIT)
4447 : 33 : OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt))
4448 : 66 : = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT);
4449 : :
4450 : : /* Initialize the loopvar. */
4451 : 80 : TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n],
4452 : : loop->from[n]);
4453 : 80 : OMP_FOR_INIT (stmt) = init;
4454 : : /* The exit condition. */
4455 : 80 : TREE_VEC_ELT (cond, 0) = build2_loc (input_location, LE_EXPR,
4456 : : logical_type_node,
4457 : : loop->loopvar[n], loop->to[n]);
4458 : 80 : SET_EXPR_LOCATION (TREE_VEC_ELT (cond, 0), input_location);
4459 : 80 : OMP_FOR_COND (stmt) = cond;
4460 : : /* Increment the loopvar. */
4461 : 80 : tmp = build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4462 : : loop->loopvar[n], gfc_index_one_node);
4463 : 80 : TREE_VEC_ELT (incr, 0) = fold_build2_loc (input_location, MODIFY_EXPR,
4464 : : void_type_node, loop->loopvar[n], tmp);
4465 : 80 : OMP_FOR_INCR (stmt) = incr;
4466 : :
4467 : 80 : ompws_flags &= ~OMPWS_CURR_SINGLEUNIT;
4468 : 80 : gfc_add_expr_to_block (&loop->code[n], stmt);
4469 : : }
4470 : : else
4471 : : {
4472 : 233830 : bool reverse_loop = (loop->reverse[n] == GFC_REVERSE_SET)
4473 : 116915 : && (loop->temp_ss == NULL);
4474 : :
4475 : 116915 : loopbody = gfc_finish_block (pbody);
4476 : :
4477 : 116915 : if (reverse_loop)
4478 : 178 : std::swap (loop->from[n], loop->to[n]);
4479 : :
4480 : : /* Initialize the loopvar. */
4481 : 116915 : if (loop->loopvar[n] != loop->from[n])
4482 : 113476 : gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
4483 : :
4484 : 116915 : exit_label = gfc_build_label_decl (NULL_TREE);
4485 : :
4486 : : /* Generate the loop body. */
4487 : 116915 : gfc_init_block (&block);
4488 : :
4489 : : /* The exit condition. */
4490 : 233652 : cond = fold_build2_loc (input_location, reverse_loop ? LT_EXPR : GT_EXPR,
4491 : : logical_type_node, loop->loopvar[n], loop->to[n]);
4492 : 116915 : tmp = build1_v (GOTO_EXPR, exit_label);
4493 : 116915 : TREE_USED (exit_label) = 1;
4494 : 116915 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
4495 : 116915 : gfc_add_expr_to_block (&block, tmp);
4496 : :
4497 : : /* The main body. */
4498 : 116915 : gfc_add_expr_to_block (&block, loopbody);
4499 : :
4500 : : /* Increment the loopvar. */
4501 : 233652 : tmp = fold_build2_loc (input_location,
4502 : : reverse_loop ? MINUS_EXPR : PLUS_EXPR,
4503 : : gfc_array_index_type, loop->loopvar[n],
4504 : : gfc_index_one_node);
4505 : :
4506 : 116915 : gfc_add_modify (&block, loop->loopvar[n], tmp);
4507 : :
4508 : : /* Build the loop. */
4509 : 116915 : tmp = gfc_finish_block (&block);
4510 : 116915 : tmp = build1_v (LOOP_EXPR, tmp);
4511 : 116915 : gfc_add_expr_to_block (&loop->code[n], tmp);
4512 : :
4513 : : /* Add the exit label. */
4514 : 116915 : tmp = build1_v (LABEL_EXPR, exit_label);
4515 : 116915 : gfc_add_expr_to_block (&loop->code[n], tmp);
4516 : : }
4517 : :
4518 : 116995 : }
4519 : :
4520 : :
4521 : : /* Finishes and generates the loops for a scalarized expression. */
4522 : :
4523 : : void
4524 : 93759 : gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
4525 : : {
4526 : 93759 : int dim;
4527 : 93759 : int n;
4528 : 93759 : gfc_ss *ss;
4529 : 93759 : stmtblock_t *pblock;
4530 : 93759 : tree tmp;
4531 : :
4532 : 93759 : pblock = body;
4533 : : /* Generate the loops. */
4534 : 206323 : for (dim = 0; dim < loop->dimen; dim++)
4535 : : {
4536 : 112564 : n = loop->order[dim];
4537 : 112564 : gfc_trans_scalarized_loop_end (loop, n, pblock);
4538 : 112564 : loop->loopvar[n] = NULL_TREE;
4539 : 112564 : pblock = &loop->code[n];
4540 : : }
4541 : :
4542 : 93759 : tmp = gfc_finish_block (pblock);
4543 : 93759 : gfc_add_expr_to_block (&loop->pre, tmp);
4544 : :
4545 : : /* Clear all the used flags. */
4546 : 275669 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4547 : 181910 : if (ss->parent == NULL)
4548 : 181163 : ss->info->useflags = 0;
4549 : 93759 : }
4550 : :
4551 : :
4552 : : /* Finish the main body of a scalarized expression, and start the secondary
4553 : : copying body. */
4554 : :
4555 : : void
4556 : 4313 : gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
4557 : : {
4558 : 4313 : int dim;
4559 : 4313 : int n;
4560 : 4313 : stmtblock_t *pblock;
4561 : 4313 : gfc_ss *ss;
4562 : :
4563 : 4313 : pblock = body;
4564 : : /* We finish as many loops as are used by the temporary. */
4565 : 4431 : for (dim = 0; dim < loop->temp_dim - 1; dim++)
4566 : : {
4567 : 118 : n = loop->order[dim];
4568 : 118 : gfc_trans_scalarized_loop_end (loop, n, pblock);
4569 : 118 : loop->loopvar[n] = NULL_TREE;
4570 : 118 : pblock = &loop->code[n];
4571 : : }
4572 : :
4573 : : /* We don't want to finish the outermost loop entirely. */
4574 : 4313 : n = loop->order[loop->temp_dim - 1];
4575 : 4313 : gfc_trans_scalarized_loop_end (loop, n, pblock);
4576 : :
4577 : : /* Restore the initial offsets. */
4578 : 12743 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4579 : : {
4580 : 8430 : gfc_ss_type ss_type;
4581 : 8430 : gfc_ss_info *ss_info;
4582 : :
4583 : 8430 : ss_info = ss->info;
4584 : :
4585 : 8430 : if ((ss_info->useflags & 2) == 0)
4586 : 1077 : continue;
4587 : :
4588 : 7353 : ss_type = ss_info->type;
4589 : 7393 : if (ss_type != GFC_SS_SECTION
4590 : : && ss_type != GFC_SS_FUNCTION
4591 : 7353 : && ss_type != GFC_SS_CONSTRUCTOR
4592 : 7353 : && ss_type != GFC_SS_COMPONENT)
4593 : 40 : continue;
4594 : :
4595 : 7313 : ss_info->data.array.offset = ss_info->data.array.saved_offset;
4596 : : }
4597 : :
4598 : : /* Restart all the inner loops we just finished. */
4599 : 4431 : for (dim = loop->temp_dim - 2; dim >= 0; dim--)
4600 : : {
4601 : 118 : n = loop->order[dim];
4602 : :
4603 : 118 : gfc_start_block (&loop->code[n]);
4604 : :
4605 : 118 : loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
4606 : :
4607 : 118 : gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
4608 : : }
4609 : :
4610 : : /* Start a block for the secondary copying code. */
4611 : 4313 : gfc_start_block (body);
4612 : 4313 : }
4613 : :
4614 : :
4615 : : /* Precalculate (either lower or upper) bound of an array section.
4616 : : BLOCK: Block in which the (pre)calculation code will go.
4617 : : BOUNDS[DIM]: Where the bound value will be stored once evaluated.
4618 : : VALUES[DIM]: Specified bound (NULL <=> unspecified).
4619 : : DESC: Array descriptor from which the bound will be picked if unspecified
4620 : : (either lower or upper bound according to LBOUND). */
4621 : :
4622 : : static void
4623 : 396892 : evaluate_bound (stmtblock_t *block, tree *bounds, gfc_expr ** values,
4624 : : tree desc, int dim, bool lbound, bool deferred)
4625 : : {
4626 : 396892 : gfc_se se;
4627 : 396892 : gfc_expr * input_val = values[dim];
4628 : 396892 : tree *output = &bounds[dim];
4629 : :
4630 : :
4631 : 396892 : if (input_val)
4632 : : {
4633 : : /* Specified section bound. */
4634 : 44824 : gfc_init_se (&se, NULL);
4635 : 44824 : gfc_conv_expr_type (&se, input_val, gfc_array_index_type);
4636 : 44824 : gfc_add_block_to_block (block, &se.pre);
4637 : 44824 : *output = se.expr;
4638 : : }
4639 : 352068 : else if (deferred && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
4640 : : {
4641 : : /* The gfc_conv_array_lbound () routine returns a constant zero for
4642 : : deferred length arrays, which in the scalarizer wreaks havoc, when
4643 : : copying to a (newly allocated) one-based array.
4644 : : Keep returning the actual result in sync for both bounds. */
4645 : 111607 : *output = lbound ? gfc_conv_descriptor_lbound_get (desc,
4646 : : gfc_rank_cst[dim]):
4647 : 37267 : gfc_conv_descriptor_ubound_get (desc,
4648 : : gfc_rank_cst[dim]);
4649 : : }
4650 : : else
4651 : : {
4652 : : /* No specific bound specified so use the bound of the array. */
4653 : 413125 : *output = lbound ? gfc_conv_array_lbound (desc, dim) :
4654 : 135397 : gfc_conv_array_ubound (desc, dim);
4655 : : }
4656 : 396892 : *output = gfc_evaluate_now (*output, block);
4657 : 396892 : }
4658 : :
4659 : :
4660 : : /* Calculate the lower bound of an array section. */
4661 : :
4662 : : static void
4663 : 198992 : gfc_conv_section_startstride (stmtblock_t * block, gfc_ss * ss, int dim)
4664 : : {
4665 : 198992 : gfc_expr *stride = NULL;
4666 : 198992 : tree desc;
4667 : 198992 : gfc_se se;
4668 : 198992 : gfc_array_info *info;
4669 : 198992 : gfc_array_ref *ar;
4670 : :
4671 : 198992 : gcc_assert (ss->info->type == GFC_SS_SECTION);
4672 : :
4673 : 198992 : info = &ss->info->data.array;
4674 : 198992 : ar = &info->ref->u.ar;
4675 : :
4676 : 198992 : if (ar->dimen_type[dim] == DIMEN_VECTOR)
4677 : : {
4678 : : /* We use a zero-based index to access the vector. */
4679 : 744 : info->start[dim] = gfc_index_zero_node;
4680 : 744 : info->end[dim] = NULL;
4681 : 744 : info->stride[dim] = gfc_index_one_node;
4682 : 744 : return;
4683 : : }
4684 : :
4685 : 198248 : gcc_assert (ar->dimen_type[dim] == DIMEN_RANGE
4686 : : || ar->dimen_type[dim] == DIMEN_THIS_IMAGE);
4687 : 198248 : desc = info->descriptor;
4688 : 198248 : stride = ar->stride[dim];
4689 : :
4690 : :
4691 : : /* Calculate the start of the range. For vector subscripts this will
4692 : : be the range of the vector. */
4693 : 198248 : evaluate_bound (block, info->start, ar->start, desc, dim, true,
4694 : 198248 : ar->as->type == AS_DEFERRED);
4695 : :
4696 : : /* Similarly calculate the end. Although this is not used in the
4697 : : scalarizer, it is needed when checking bounds and where the end
4698 : : is an expression with side-effects. */
4699 : 198248 : evaluate_bound (block, info->end, ar->end, desc, dim, false,
4700 : 198248 : ar->as->type == AS_DEFERRED);
4701 : :
4702 : :
4703 : : /* Calculate the stride. */
4704 : 198248 : if (stride == NULL)
4705 : 186785 : info->stride[dim] = gfc_index_one_node;
4706 : : else
4707 : : {
4708 : 11463 : gfc_init_se (&se, NULL);
4709 : 11463 : gfc_conv_expr_type (&se, stride, gfc_array_index_type);
4710 : 11463 : gfc_add_block_to_block (block, &se.pre);
4711 : 11463 : info->stride[dim] = gfc_evaluate_now (se.expr, block);
4712 : : }
4713 : : }
4714 : :
4715 : :
4716 : : /* Calculates the range start and stride for a SS chain. Also gets the
4717 : : descriptor and data pointer. The range of vector subscripts is the size
4718 : : of the vector. Array bounds are also checked. */
4719 : :
4720 : : void
4721 : 146517 : gfc_conv_ss_startstride (gfc_loopinfo * loop)
4722 : : {
4723 : 146517 : int n;
4724 : 146517 : tree tmp;
4725 : 146517 : gfc_ss *ss;
4726 : 146517 : tree desc;
4727 : :
4728 : 146517 : gfc_loopinfo * const outer_loop = outermost_loop (loop);
4729 : :
4730 : 146517 : loop->dimen = 0;
4731 : : /* Determine the rank of the loop. */
4732 : 163263 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4733 : : {
4734 : 163263 : switch (ss->info->type)
4735 : : {
4736 : 141675 : case GFC_SS_SECTION:
4737 : 141675 : case GFC_SS_CONSTRUCTOR:
4738 : 141675 : case GFC_SS_FUNCTION:
4739 : 141675 : case GFC_SS_COMPONENT:
4740 : 141675 : loop->dimen = ss->dimen;
4741 : 141675 : goto done;
4742 : :
4743 : : /* As usual, lbound and ubound are exceptions!. */
4744 : 4842 : case GFC_SS_INTRINSIC:
4745 : 4842 : switch (ss->info->expr->value.function.isym->id)
4746 : : {
4747 : 4842 : case GFC_ISYM_LBOUND:
4748 : 4842 : case GFC_ISYM_UBOUND:
4749 : 4842 : case GFC_ISYM_LCOBOUND:
4750 : 4842 : case GFC_ISYM_UCOBOUND:
4751 : 4842 : case GFC_ISYM_SHAPE:
4752 : 4842 : case GFC_ISYM_THIS_IMAGE:
4753 : 4842 : loop->dimen = ss->dimen;
4754 : 4842 : goto done;
4755 : :
4756 : : default:
4757 : : break;
4758 : : }
4759 : :
4760 : 16746 : default:
4761 : 16746 : break;
4762 : : }
4763 : : }
4764 : :
4765 : : /* We should have determined the rank of the expression by now. If
4766 : : not, that's bad news. */
4767 : 0 : gcc_unreachable ();
4768 : :
4769 : : done:
4770 : : /* Loop over all the SS in the chain. */
4771 : 378516 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4772 : : {
4773 : 231999 : gfc_ss_info *ss_info;
4774 : 231999 : gfc_array_info *info;
4775 : 231999 : gfc_expr *expr;
4776 : :
4777 : 231999 : ss_info = ss->info;
4778 : 231999 : expr = ss_info->expr;
4779 : 231999 : info = &ss_info->data.array;
4780 : :
4781 : 231999 : if (expr && expr->shape && !info->shape)
4782 : 139067 : info->shape = expr->shape;
4783 : :
4784 : 231999 : switch (ss_info->type)
4785 : : {
4786 : 149195 : case GFC_SS_SECTION:
4787 : : /* Get the descriptor for the array. If it is a cross loops array,
4788 : : we got the descriptor already in the outermost loop. */
4789 : 149195 : if (ss->parent == NULL)
4790 : 148558 : gfc_conv_ss_descriptor (&outer_loop->pre, ss,
4791 : 148558 : !loop->array_parameter);
4792 : :
4793 : 347666 : for (n = 0; n < ss->dimen; n++)
4794 : 198471 : gfc_conv_section_startstride (&outer_loop->pre, ss, ss->dim[n]);
4795 : : break;
4796 : :
4797 : 4970 : case GFC_SS_INTRINSIC:
4798 : 4970 : switch (expr->value.function.isym->id)
4799 : : {
4800 : : /* Fall through to supply start and stride. */
4801 : 2774 : case GFC_ISYM_LBOUND:
4802 : 2774 : case GFC_ISYM_UBOUND:
4803 : : /* This is the variant without DIM=... */
4804 : 2774 : gcc_assert (expr->value.function.actual->next->expr == NULL);
4805 : : /* Fall through. */
4806 : :
4807 : 4763 : case GFC_ISYM_SHAPE:
4808 : 4763 : {
4809 : 4763 : gfc_expr *arg;
4810 : :
4811 : 4763 : arg = expr->value.function.actual->expr;
4812 : 4763 : if (arg->rank == -1)
4813 : : {
4814 : 1115 : gfc_se se;
4815 : 1115 : tree rank, tmp;
4816 : :
4817 : : /* The rank (hence the return value's shape) is unknown,
4818 : : we have to retrieve it. */
4819 : 1115 : gfc_init_se (&se, NULL);
4820 : 1115 : se.descriptor_only = 1;
4821 : 1115 : gfc_conv_expr (&se, arg);
4822 : : /* This is a bare variable, so there is no preliminary
4823 : : or cleanup code. */
4824 : 1115 : gcc_assert (se.pre.head == NULL_TREE
4825 : : && se.post.head == NULL_TREE);
4826 : 1115 : rank = gfc_conv_descriptor_rank (se.expr);
4827 : 1115 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
4828 : : gfc_array_index_type,
4829 : : fold_convert (gfc_array_index_type,
4830 : : rank),
4831 : : gfc_index_one_node);
4832 : 1115 : info->end[0] = gfc_evaluate_now (tmp, &outer_loop->pre);
4833 : 1115 : info->start[0] = gfc_index_zero_node;
4834 : 1115 : info->stride[0] = gfc_index_one_node;
4835 : 1115 : continue;
4836 : 1115 : }
4837 : : /* Otherwise fall through GFC_SS_FUNCTION. */
4838 : : gcc_fallthrough ();
4839 : : }
4840 : : case GFC_ISYM_LCOBOUND:
4841 : : case GFC_ISYM_UCOBOUND:
4842 : : case GFC_ISYM_THIS_IMAGE:
4843 : : break;
4844 : :
4845 : 0 : default:
4846 : 0 : continue;
4847 : 0 : }
4848 : :
4849 : : /* FALLTHRU */
4850 : : case GFC_SS_CONSTRUCTOR:
4851 : : case GFC_SS_FUNCTION:
4852 : 101435 : for (n = 0; n < ss->dimen; n++)
4853 : : {
4854 : 54171 : int dim = ss->dim[n];
4855 : :
4856 : 54171 : info->start[dim] = gfc_index_zero_node;
4857 : 54171 : info->end[dim] = gfc_index_zero_node;
4858 : 54171 : info->stride[dim] = gfc_index_one_node;
4859 : : }
4860 : : break;
4861 : :
4862 : : default:
4863 : : break;
4864 : : }
4865 : : }
4866 : :
4867 : : /* The rest is just runtime bounds checking. */
4868 : 146517 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
4869 : : {
4870 : 16588 : stmtblock_t block;
4871 : 16588 : tree lbound, ubound;
4872 : 16588 : tree end;
4873 : 16588 : tree size[GFC_MAX_DIMENSIONS];
4874 : 16588 : tree stride_pos, stride_neg, non_zerosized, tmp2, tmp3;
4875 : 16588 : gfc_array_info *info;
4876 : 16588 : char *msg;
4877 : 16588 : int dim;
4878 : :
4879 : 16588 : gfc_start_block (&block);
4880 : :
4881 : 53172 : for (n = 0; n < loop->dimen; n++)
4882 : 19996 : size[n] = NULL_TREE;
4883 : :
4884 : : /* If there is a constructor involved, derive size[] from its shape. */
4885 : 38343 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4886 : : {
4887 : 24135 : gfc_ss_info *ss_info;
4888 : :
4889 : 24135 : ss_info = ss->info;
4890 : 24135 : info = &ss_info->data.array;
4891 : :
4892 : 24135 : if (ss_info->type == GFC_SS_CONSTRUCTOR && info->shape)
4893 : : {
4894 : 5018 : for (n = 0; n < loop->dimen; n++)
4895 : : {
4896 : 2638 : if (size[n] == NULL)
4897 : : {
4898 : 2638 : gcc_assert (info->shape[n]);
4899 : 2638 : size[n] = gfc_conv_mpz_to_tree (info->shape[n],
4900 : : gfc_index_integer_kind);
4901 : : }
4902 : : }
4903 : : break;
4904 : : }
4905 : : }
4906 : :
4907 : 41047 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4908 : : {
4909 : 24459 : stmtblock_t inner;
4910 : 24459 : gfc_ss_info *ss_info;
4911 : 24459 : gfc_expr *expr;
4912 : 24459 : locus *expr_loc;
4913 : 24459 : const char *expr_name;
4914 : :
4915 : 24459 : ss_info = ss->info;
4916 : 24459 : if (ss_info->type != GFC_SS_SECTION)
4917 : 4370 : continue;
4918 : :
4919 : : /* Catch allocatable lhs in f2003. */
4920 : 20464 : if (flag_realloc_lhs && ss->no_bounds_check)
4921 : 375 : continue;
4922 : :
4923 : 20089 : expr = ss_info->expr;
4924 : 20089 : expr_loc = &expr->where;
4925 : 20089 : expr_name = expr->symtree->name;
4926 : :
4927 : 20089 : gfc_start_block (&inner);
4928 : :
4929 : : /* TODO: range checking for mapped dimensions. */
4930 : 20089 : info = &ss_info->data.array;
4931 : :
4932 : : /* This code only checks ranges. Elemental and vector
4933 : : dimensions are checked later. */
4934 : 43464 : for (n = 0; n < loop->dimen; n++)
4935 : : {
4936 : 23375 : bool check_upper;
4937 : :
4938 : 23375 : dim = ss->dim[n];
4939 : 23375 : if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
4940 : 14 : continue;
4941 : :
4942 : 23361 : if (dim == info->ref->u.ar.dimen - 1
4943 : 19976 : && info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
4944 : : check_upper = false;
4945 : : else
4946 : 23071 : check_upper = true;
4947 : :
4948 : : /* Zero stride is not allowed. */
4949 : 23361 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
4950 : : info->stride[dim], gfc_index_zero_node);
4951 : 23361 : msg = xasprintf ("Zero stride is not allowed, for dimension %d "
4952 : : "of array '%s'", dim + 1, expr_name);
4953 : 23361 : gfc_trans_runtime_check (true, false, tmp, &inner,
4954 : : expr_loc, msg);
4955 : 23361 : free (msg);
4956 : :
4957 : 23361 : desc = info->descriptor;
4958 : :
4959 : : /* This is the run-time equivalent of resolve.cc's
4960 : : check_dimension(). The logical is more readable there
4961 : : than it is here, with all the trees. */
4962 : 23361 : lbound = gfc_conv_array_lbound (desc, dim);
4963 : 23361 : end = info->end[dim];
4964 : 23361 : if (check_upper)
4965 : 23071 : ubound = gfc_conv_array_ubound (desc, dim);
4966 : : else
4967 : : ubound = NULL;
4968 : :
4969 : : /* non_zerosized is true when the selected range is not
4970 : : empty. */
4971 : 23361 : stride_pos = fold_build2_loc (input_location, GT_EXPR,
4972 : : logical_type_node, info->stride[dim],
4973 : : gfc_index_zero_node);
4974 : 23361 : tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
4975 : : info->start[dim], end);
4976 : 23361 : stride_pos = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4977 : : logical_type_node, stride_pos, tmp);
4978 : :
4979 : 23361 : stride_neg = fold_build2_loc (input_location, LT_EXPR,
4980 : : logical_type_node,
4981 : : info->stride[dim], gfc_index_zero_node);
4982 : 23361 : tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
4983 : : info->start[dim], end);
4984 : 23361 : stride_neg = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4985 : : logical_type_node,
4986 : : stride_neg, tmp);
4987 : 23361 : non_zerosized = fold_build2_loc (input_location, TRUTH_OR_EXPR,
4988 : : logical_type_node,
4989 : : stride_pos, stride_neg);
4990 : :
4991 : : /* Check the start of the range against the lower and upper
4992 : : bounds of the array, if the range is not empty.
4993 : : If upper bound is present, include both bounds in the
4994 : : error message. */
4995 : 23361 : if (check_upper)
4996 : : {
4997 : 23071 : tmp = fold_build2_loc (input_location, LT_EXPR,
4998 : : logical_type_node,
4999 : : info->start[dim], lbound);
5000 : 23071 : tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
5001 : : logical_type_node,
5002 : : non_zerosized, tmp);
5003 : 23071 : tmp2 = fold_build2_loc (input_location, GT_EXPR,
5004 : : logical_type_node,
5005 : : info->start[dim], ubound);
5006 : 23071 : tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
5007 : : logical_type_node,
5008 : : non_zerosized, tmp2);
5009 : 23071 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
5010 : : "outside of expected range (%%ld:%%ld)",
5011 : : dim + 1, expr_name);
5012 : 23071 : gfc_trans_runtime_check (true, false, tmp, &inner,
5013 : : expr_loc, msg,
5014 : : fold_convert (long_integer_type_node, info->start[dim]),
5015 : : fold_convert (long_integer_type_node, lbound),
5016 : : fold_convert (long_integer_type_node, ubound));
5017 : 23071 : gfc_trans_runtime_check (true, false, tmp2, &inner,
5018 : : expr_loc, msg,
5019 : : fold_convert (long_integer_type_node, info->start[dim]),
5020 : : fold_convert (long_integer_type_node, lbound),
5021 : : fold_convert (long_integer_type_node, ubound));
5022 : 23071 : free (msg);
5023 : : }
5024 : : else
5025 : : {
5026 : 290 : tmp = fold_build2_loc (input_location, LT_EXPR,
5027 : : logical_type_node,
5028 : : info->start[dim], lbound);
5029 : 290 : tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
5030 : : logical_type_node, non_zerosized, tmp);
5031 : 290 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
5032 : : "below lower bound of %%ld",
5033 : : dim + 1, expr_name);
5034 : 290 : gfc_trans_runtime_check (true, false, tmp, &inner,
5035 : : expr_loc, msg,
5036 : : fold_convert (long_integer_type_node, info->start[dim]),
5037 : : fold_convert (long_integer_type_node, lbound));
5038 : 290 : free (msg);
5039 : : }
5040 : :
5041 : : /* Compute the last element of the range, which is not
5042 : : necessarily "end" (think 0:5:3, which doesn't contain 5)
5043 : : and check it against both lower and upper bounds. */
5044 : :
5045 : 23361 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
5046 : : gfc_array_index_type, end,
5047 : : info->start[dim]);
5048 : 23361 : tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
5049 : : gfc_array_index_type, tmp,
5050 : : info->stride[dim]);
5051 : 23361 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
5052 : : gfc_array_index_type, end, tmp);
5053 : 23361 : tmp2 = fold_build2_loc (input_location, LT_EXPR,
5054 : : logical_type_node, tmp, lbound);
5055 : 23361 : tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
5056 : : logical_type_node, non_zerosized, tmp2);
5057 : 23361 : if (check_upper)
5058 : : {
5059 : 23071 : tmp3 = fold_build2_loc (input_location, GT_EXPR,
5060 : : logical_type_node, tmp, ubound);
5061 : 23071 : tmp3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
5062 : : logical_type_node, non_zerosized, tmp3);
5063 : 23071 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
5064 : : "outside of expected range (%%ld:%%ld)",
5065 : : dim + 1, expr_name);
5066 : 23071 : gfc_trans_runtime_check (true, false, tmp2, &inner,
5067 : : expr_loc, msg,
5068 : : fold_convert (long_integer_type_node, tmp),
5069 : : fold_convert (long_integer_type_node, ubound),
5070 : : fold_convert (long_integer_type_node, lbound));
5071 : 23071 : gfc_trans_runtime_check (true, false, tmp3, &inner,
5072 : : expr_loc, msg,
5073 : : fold_convert (long_integer_type_node, tmp),
5074 : : fold_convert (long_integer_type_node, ubound),
5075 : : fold_convert (long_integer_type_node, lbound));
5076 : 23071 : free (msg);
5077 : : }
5078 : : else
5079 : : {
5080 : 290 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
5081 : : "below lower bound of %%ld",
5082 : : dim + 1, expr_name);
5083 : 290 : gfc_trans_runtime_check (true, false, tmp2, &inner,
5084 : : expr_loc, msg,
5085 : : fold_convert (long_integer_type_node, tmp),
5086 : : fold_convert (long_integer_type_node, lbound));
5087 : 290 : free (msg);
5088 : : }
5089 : :
5090 : : /* Check the section sizes match. */
5091 : 23361 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
5092 : : gfc_array_index_type, end,
5093 : : info->start[dim]);
5094 : 23361 : tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
5095 : : gfc_array_index_type, tmp,
5096 : : info->stride[dim]);
5097 : 23361 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
5098 : : gfc_array_index_type,
5099 : : gfc_index_one_node, tmp);
5100 : 23361 : tmp = fold_build2_loc (input_location, MAX_EXPR,
5101 : : gfc_array_index_type, tmp,
5102 : 23361 : build_int_cst (gfc_array_index_type, 0));
5103 : : /* We remember the size of the first section, and check all the
5104 : : others against this. */
5105 : 23361 : if (size[n])
5106 : : {
5107 : 6945 : tmp3 = fold_build2_loc (input_location, NE_EXPR,
5108 : : logical_type_node, tmp, size[n]);
5109 : 6945 : msg = xasprintf ("Array bound mismatch for dimension %d "
5110 : : "of array '%s' (%%ld/%%ld)",
5111 : : dim + 1, expr_name);
5112 : :
5113 : 6945 : gfc_trans_runtime_check (true, false, tmp3, &inner,
5114 : : expr_loc, msg,
5115 : : fold_convert (long_integer_type_node, tmp),
5116 : : fold_convert (long_integer_type_node, size[n]));
5117 : :
5118 : 6945 : free (msg);
5119 : : }
5120 : : else
5121 : 16416 : size[n] = gfc_evaluate_now (tmp, &inner);
5122 : : }
5123 : :
5124 : 20089 : tmp = gfc_finish_block (&inner);
5125 : :
5126 : : /* For optional arguments, only check bounds if the argument is
5127 : : present. */
5128 : 20089 : if ((expr->symtree->n.sym->attr.optional
5129 : 20089 : || expr->symtree->n.sym->attr.not_always_present)
5130 : 296 : && expr->symtree->n.sym->attr.dummy)
5131 : 295 : tmp = build3_v (COND_EXPR,
5132 : : gfc_conv_expr_present (expr->symtree->n.sym),
5133 : : tmp, build_empty_stmt (input_location));
5134 : :
5135 : 20089 : gfc_add_expr_to_block (&block, tmp);
5136 : :
5137 : : }
5138 : :
5139 : 16588 : tmp = gfc_finish_block (&block);
5140 : 16588 : gfc_add_expr_to_block (&outer_loop->pre, tmp);
5141 : : }
5142 : :
5143 : 147070 : for (loop = loop->nested; loop; loop = loop->next)
5144 : 553 : gfc_conv_ss_startstride (loop);
5145 : 146517 : }
5146 : :
5147 : : /* Return true if both symbols could refer to the same data object. Does
5148 : : not take account of aliasing due to equivalence statements. */
5149 : :
5150 : : static bool
5151 : 9158 : symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym, bool lsym_pointer,
5152 : : bool lsym_target, bool rsym_pointer, bool rsym_target)
5153 : : {
5154 : : /* Aliasing isn't possible if the symbols have different base types. */
5155 : 9158 : if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
5156 : : return 0;
5157 : :
5158 : : /* Pointers can point to other pointers and target objects. */
5159 : :
5160 : 7269 : if ((lsym_pointer && (rsym_pointer || rsym_target))
5161 : 7085 : || (rsym_pointer && (lsym_pointer || lsym_target)))
5162 : : return 1;
5163 : :
5164 : : /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
5165 : : and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
5166 : : checked above. */
5167 : 7177 : if (lsym_target && rsym_target
5168 : 14 : && ((lsym->attr.dummy && !lsym->attr.contiguous
5169 : 0 : && (!lsym->attr.dimension || lsym->as->type == AS_ASSUMED_SHAPE))
5170 : 14 : || (rsym->attr.dummy && !rsym->attr.contiguous
5171 : 6 : && (!rsym->attr.dimension
5172 : 6 : || rsym->as->type == AS_ASSUMED_SHAPE))))
5173 : 6 : return 1;
5174 : :
5175 : : return 0;
5176 : : }
5177 : :
5178 : :
5179 : : /* Return true if the two SS could be aliased, i.e. both point to the same data
5180 : : object. */
5181 : : /* TODO: resolve aliases based on frontend expressions. */
5182 : :
5183 : : static int
5184 : 7959 : gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
5185 : : {
5186 : 7959 : gfc_ref *lref;
5187 : 7959 : gfc_ref *rref;
5188 : 7959 : gfc_expr *lexpr, *rexpr;
5189 : 7959 : gfc_symbol *lsym;
5190 : 7959 : gfc_symbol *rsym;
5191 : 7959 : bool lsym_pointer, lsym_target, rsym_pointer, rsym_target;
5192 : :
5193 : 7959 : lexpr = lss->info->expr;
5194 : 7959 : rexpr = rss->info->expr;
5195 : :
5196 : 7959 : lsym = lexpr->symtree->n.sym;
5197 : 7959 : rsym = rexpr->symtree->n.sym;
5198 : :
5199 : 7959 : lsym_pointer = lsym->attr.pointer;
5200 : 7959 : lsym_target = lsym->attr.target;
5201 : 7959 : rsym_pointer = rsym->attr.pointer;
5202 : 7959 : rsym_target = rsym->attr.target;
5203 : :
5204 : 7959 : if (symbols_could_alias (lsym, rsym, lsym_pointer, lsym_target,
5205 : : rsym_pointer, rsym_target))
5206 : : return 1;
5207 : :
5208 : 7893 : if (rsym->ts.type != BT_DERIVED && rsym->ts.type != BT_CLASS
5209 : 7188 : && lsym->ts.type != BT_DERIVED && lsym->ts.type != BT_CLASS)
5210 : : return 0;
5211 : :
5212 : : /* For derived types we must check all the component types. We can ignore
5213 : : array references as these will have the same base type as the previous
5214 : : component ref. */
5215 : 1468 : for (lref = lexpr->ref; lref != lss->info->data.array.ref; lref = lref->next)
5216 : : {
5217 : 552 : if (lref->type != REF_COMPONENT)
5218 : 65 : continue;
5219 : :
5220 : 487 : lsym_pointer = lsym_pointer || lref->u.c.sym->attr.pointer;
5221 : 487 : lsym_target = lsym_target || lref->u.c.sym->attr.target;
5222 : :
5223 : 487 : if (symbols_could_alias (lref->u.c.sym, rsym, lsym_pointer, lsym_target,
5224 : : rsym_pointer, rsym_target))
5225 : : return 1;
5226 : :
5227 : 487 : if ((lsym_pointer && (rsym_pointer || rsym_target))
5228 : 472 : || (rsym_pointer && (lsym_pointer || lsym_target)))
5229 : : {
5230 : 6 : if (gfc_compare_types (&lref->u.c.component->ts,
5231 : : &rsym->ts))
5232 : : return 1;
5233 : : }
5234 : :
5235 : 844 : for (rref = rexpr->ref; rref != rss->info->data.array.ref;
5236 : 363 : rref = rref->next)
5237 : : {
5238 : 364 : if (rref->type != REF_COMPONENT)
5239 : 36 : continue;
5240 : :
5241 : 328 : rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
5242 : 328 : rsym_target = lsym_target || rref->u.c.sym->attr.target;
5243 : :
5244 : 328 : if (symbols_could_alias (lref->u.c.sym, rref->u.c.sym,
5245 : : lsym_pointer, lsym_target,
5246 : : rsym_pointer, rsym_target))
5247 : : return 1;
5248 : :
5249 : 327 : if ((lsym_pointer && (rsym_pointer || rsym_target))
5250 : 323 : || (rsym_pointer && (lsym_pointer || lsym_target)))
5251 : : {
5252 : 0 : if (gfc_compare_types (&lref->u.c.component->ts,
5253 : 0 : &rref->u.c.sym->ts))
5254 : : return 1;
5255 : 0 : if (gfc_compare_types (&lref->u.c.sym->ts,
5256 : 0 : &rref->u.c.component->ts))
5257 : : return 1;
5258 : 0 : if (gfc_compare_types (&lref->u.c.component->ts,
5259 : 0 : &rref->u.c.component->ts))
5260 : : return 1;
5261 : : }
5262 : : }
5263 : : }
5264 : :
5265 : 916 : lsym_pointer = lsym->attr.pointer;
5266 : 916 : lsym_target = lsym->attr.target;
5267 : :
5268 : 1294 : for (rref = rexpr->ref; rref != rss->info->data.array.ref; rref = rref->next)
5269 : : {
5270 : 459 : if (rref->type != REF_COMPONENT)
5271 : : break;
5272 : :
5273 : 384 : rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
5274 : 384 : rsym_target = lsym_target || rref->u.c.sym->attr.target;
5275 : :
5276 : 384 : if (symbols_could_alias (rref->u.c.sym, lsym,
5277 : : lsym_pointer, lsym_target,
5278 : : rsym_pointer, rsym_target))
5279 : : return 1;
5280 : :
5281 : 384 : if ((lsym_pointer && (rsym_pointer || rsym_target))
5282 : 366 : || (rsym_pointer && (lsym_pointer || lsym_target)))
5283 : : {
5284 : 6 : if (gfc_compare_types (&lsym->ts, &rref->u.c.component->ts))
5285 : : return 1;
5286 : : }
5287 : : }
5288 : :
5289 : : return 0;
5290 : : }
5291 : :
5292 : :
5293 : : /* Resolve array data dependencies. Creates a temporary if required. */
5294 : : /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
5295 : : dependency.cc. */
5296 : :
5297 : : void
5298 : 31787 : gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
5299 : : gfc_ss * rss)
5300 : : {
5301 : 31787 : gfc_ss *ss;
5302 : 31787 : gfc_ref *lref;
5303 : 31787 : gfc_ref *rref;
5304 : 31787 : gfc_ss_info *ss_info;
5305 : 31787 : gfc_expr *dest_expr;
5306 : 31787 : gfc_expr *ss_expr;
5307 : 31787 : int nDepend = 0;
5308 : 31787 : int i, j;
5309 : :
5310 : 31787 : loop->temp_ss = NULL;
5311 : 31787 : dest_expr = dest->info->expr;
5312 : :
5313 : 66648 : for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
5314 : : {
5315 : 35735 : ss_info = ss->info;
5316 : 35735 : ss_expr = ss_info->expr;
5317 : :
5318 : 35735 : if (ss_info->array_outer_dependency)
5319 : : {
5320 : : nDepend = 1;
5321 : : break;
5322 : : }
5323 : :
5324 : 35625 : if (ss_info->type != GFC_SS_SECTION)
5325 : : {
5326 : 25395 : if (flag_realloc_lhs
5327 : 24526 : && dest_expr != ss_expr
5328 : 24526 : && gfc_is_reallocatable_lhs (dest_expr)
5329 : 29493 : && ss_expr->rank)
5330 : 1875 : nDepend = gfc_check_dependency (dest_expr, ss_expr, true);
5331 : :
5332 : : /* Check for cases like c(:)(1:2) = c(2)(2:3) */
5333 : 25395 : if (!nDepend && dest_expr->rank > 0
5334 : 25077 : && dest_expr->ts.type == BT_CHARACTER
5335 : 3949 : && ss_expr->expr_type == EXPR_VARIABLE)
5336 : :
5337 : 163 : nDepend = gfc_check_dependency (dest_expr, ss_expr, false);
5338 : :
5339 : 25395 : if (ss_info->type == GFC_SS_REFERENCE
5340 : 25395 : && gfc_check_dependency (dest_expr, ss_expr, false))
5341 : 182 : ss_info->data.scalar.needs_temporary = 1;
5342 : :
5343 : 25395 : if (nDepend)
5344 : : break;
5345 : : else
5346 : 25065 : continue;
5347 : : }
5348 : :
5349 : 10230 : if (dest_expr->symtree->n.sym != ss_expr->symtree->n.sym)
5350 : : {
5351 : 7959 : if (gfc_could_be_alias (dest, ss)
5352 : 7959 : || gfc_are_equivalenced_arrays (dest_expr, ss_expr))
5353 : : {
5354 : : nDepend = 1;
5355 : : break;
5356 : : }
5357 : : }
5358 : : else
5359 : : {
5360 : 2271 : lref = dest_expr->ref;
5361 : 2271 : rref = ss_expr->ref;
5362 : :
5363 : 2271 : nDepend = gfc_dep_resolver (lref, rref, &loop->reverse[0]);
5364 : :
5365 : 2271 : if (nDepend == 1)
5366 : : break;
5367 : :
5368 : 4565 : for (i = 0; i < dest->dimen; i++)
5369 : 6212 : for (j = 0; j < ss->dimen; j++)
5370 : 3704 : if (i != j
5371 : 1133 : && dest->dim[i] == ss->dim[j])
5372 : : {
5373 : : /* If we don't access array elements in the same order,
5374 : : there is a dependency. */
5375 : 63 : nDepend = 1;
5376 : 63 : goto temporary;
5377 : : }
5378 : : #if 0
5379 : : /* TODO : loop shifting. */
5380 : : if (nDepend == 1)
5381 : : {
5382 : : /* Mark the dimensions for LOOP SHIFTING */
5383 : : for (n = 0; n < loop->dimen; n++)
5384 : : {
5385 : : int dim = dest->data.info.dim[n];
5386 : :
5387 : : if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
5388 : : depends[n] = 2;
5389 : : else if (! gfc_is_same_range (&lref->u.ar,
5390 : : &rref->u.ar, dim, 0))
5391 : : depends[n] = 1;
5392 : : }
5393 : :
5394 : : /* Put all the dimensions with dependencies in the
5395 : : innermost loops. */
5396 : : dim = 0;
5397 : : for (n = 0; n < loop->dimen; n++)
5398 : : {
5399 : : gcc_assert (loop->order[n] == n);
5400 : : if (depends[n])
5401 : : loop->order[dim++] = n;
5402 : : }
5403 : : for (n = 0; n < loop->dimen; n++)
5404 : : {
5405 : : if (! depends[n])
5406 : : loop->order[dim++] = n;
5407 : : }
5408 : :
5409 : : gcc_assert (dim == loop->dimen);
5410 : : break;
5411 : : }
5412 : : #endif
5413 : : }
5414 : : }
5415 : :
5416 : 544 : temporary:
5417 : :
5418 : 31787 : if (nDepend == 1)
5419 : : {
5420 : 874 : tree base_type = gfc_typenode_for_spec (&dest_expr->ts);
5421 : 874 : if (GFC_ARRAY_TYPE_P (base_type)
5422 : 874 : || GFC_DESCRIPTOR_TYPE_P (base_type))
5423 : 0 : base_type = gfc_get_element_type (base_type);
5424 : 874 : loop->temp_ss = gfc_get_temp_ss (base_type, dest->info->string_length,
5425 : : loop->dimen);
5426 : 874 : gfc_add_ss_to_loop (loop, loop->temp_ss);
5427 : : }
5428 : : else
5429 : 30913 : loop->temp_ss = NULL;
5430 : 31787 : }
5431 : :
5432 : :
5433 : : /* Browse through each array's information from the scalarizer and set the loop
5434 : : bounds according to the "best" one (per dimension), i.e. the one which
5435 : : provides the most information (constant bounds, shape, etc.). */
5436 : :
5437 : : static void
5438 : 146517 : set_loop_bounds (gfc_loopinfo *loop)
5439 : : {
5440 : 146517 : int n, dim, spec_dim;
5441 : 146517 : gfc_array_info *info;
5442 : 146517 : gfc_array_info *specinfo;
5443 : 146517 : gfc_ss *ss;
5444 : 146517 : tree tmp;
5445 : 146517 : gfc_ss **loopspec;
5446 : 146517 : bool dynamic[GFC_MAX_DIMENSIONS];
5447 : 146517 : mpz_t *cshape;
5448 : 146517 : mpz_t i;
5449 : 146517 : bool nonoptional_arr;
5450 : :
5451 : 146517 : gfc_loopinfo * const outer_loop = outermost_loop (loop);
5452 : :
5453 : 146517 : loopspec = loop->specloop;
5454 : :
5455 : 146517 : mpz_init (i);
5456 : 340282 : for (n = 0; n < loop->dimen; n++)
5457 : : {
5458 : 193765 : loopspec[n] = NULL;
5459 : 193765 : dynamic[n] = false;
5460 : :
5461 : : /* If there are both optional and nonoptional array arguments, scalarize
5462 : : over the nonoptional; otherwise, it does not matter as then all
5463 : : (optional) arrays have to be present per F2008, 125.2.12p3(6). */
5464 : :
5465 : 193765 : nonoptional_arr = false;
5466 : :
5467 : 225643 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5468 : 225623 : if (ss->info->type != GFC_SS_SCALAR && ss->info->type != GFC_SS_TEMP
5469 : 194748 : && ss->info->type != GFC_SS_REFERENCE && !ss->info->can_be_null_ref)
5470 : : {
5471 : : nonoptional_arr = true;
5472 : : break;
5473 : : }
5474 : :
5475 : : /* We use one SS term, and use that to determine the bounds of the
5476 : : loop for this dimension. We try to pick the simplest term. */
5477 : 500441 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5478 : : {
5479 : 306676 : gfc_ss_type ss_type;
5480 : :
5481 : 306676 : ss_type = ss->info->type;
5482 : 358818 : if (ss_type == GFC_SS_SCALAR
5483 : 306676 : || ss_type == GFC_SS_TEMP
5484 : 256692 : || ss_type == GFC_SS_REFERENCE
5485 : 254753 : || (ss->info->can_be_null_ref && nonoptional_arr))
5486 : 52142 : continue;
5487 : :
5488 : 254534 : info = &ss->info->data.array;
5489 : 254534 : dim = ss->dim[n];
5490 : :
5491 : 254534 : if (loopspec[n] != NULL)
5492 : : {
5493 : 60769 : specinfo = &loopspec[n]->info->data.array;
5494 : 60769 : spec_dim = loopspec[n]->dim[n];
5495 : : }
5496 : : else
5497 : : {
5498 : : /* Silence uninitialized warnings. */
5499 : : specinfo = NULL;
5500 : : spec_dim = 0;
5501 : : }
5502 : :
5503 : 254534 : if (info->shape)
5504 : : {
5505 : : /* The frontend has worked out the size for us. */
5506 : 178253 : if (!loopspec[n]
5507 : 46849 : || !specinfo->shape
5508 : 216987 : || !integer_zerop (specinfo->start[spec_dim]))
5509 : : /* Prefer zero-based descriptors if possible. */
5510 : 164303 : loopspec[n] = ss;
5511 : 178253 : continue;
5512 : : }
5513 : :
5514 : 76281 : if (ss_type == GFC_SS_CONSTRUCTOR)
5515 : : {
5516 : 1097 : gfc_constructor_base base;
5517 : : /* An unknown size constructor will always be rank one.
5518 : : Higher rank constructors will either have known shape,
5519 : : or still be wrapped in a call to reshape. */
5520 : 1097 : gcc_assert (loop->dimen == 1);
5521 : :
5522 : : /* Always prefer to use the constructor bounds if the size
5523 : : can be determined at compile time. Prefer not to otherwise,
5524 : : since the general case involves realloc, and it's better to
5525 : : avoid that overhead if possible. */
5526 : 1097 : base = ss->info->expr->value.constructor;
5527 : 1097 : dynamic[n] = gfc_get_array_constructor_size (&i, base);
5528 : 1097 : if (!dynamic[n] || !loopspec[n])
5529 : 978 : loopspec[n] = ss;
5530 : 1097 : continue;
5531 : 1097 : }
5532 : :
5533 : : /* Avoid using an allocatable lhs in an assignment, since
5534 : : there might be a reallocation coming. */
5535 : 75184 : if (loopspec[n] && ss->is_alloc_lhs)
5536 : 4972 : continue;
5537 : :
5538 : 70212 : if (!loopspec[n])
5539 : 61383 : loopspec[n] = ss;
5540 : : /* Criteria for choosing a loop specifier (most important first):
5541 : : doesn't need realloc
5542 : : stride of one
5543 : : known stride
5544 : : known lower bound
5545 : : known upper bound
5546 : : */
5547 : 8829 : else if (loopspec[n]->info->type == GFC_SS_CONSTRUCTOR && dynamic[n])
5548 : 158 : loopspec[n] = ss;
5549 : 8671 : else if (integer_onep (info->stride[dim])
5550 : 8671 : && !integer_onep (specinfo->stride[spec_dim]))
5551 : 78 : loopspec[n] = ss;
5552 : 8593 : else if (INTEGER_CST_P (info->stride[dim])
5553 : 8423 : && !INTEGER_CST_P (specinfo->stride[spec_dim]))
5554 : 0 : loopspec[n] = ss;
5555 : 8593 : else if (INTEGER_CST_P (info->start[dim])
5556 : 3864 : && !INTEGER_CST_P (specinfo->start[spec_dim])
5557 : 490 : && integer_onep (info->stride[dim])
5558 : 245 : == integer_onep (specinfo->stride[spec_dim])
5559 : 8593 : && INTEGER_CST_P (info->stride[dim])
5560 : 218 : == INTEGER_CST_P (specinfo->stride[spec_dim]))
5561 : 218 : loopspec[n] = ss;
5562 : : /* We don't work out the upper bound.
5563 : : else if (INTEGER_CST_P (info->finish[n])
5564 : : && ! INTEGER_CST_P (specinfo->finish[n]))
5565 : : loopspec[n] = ss; */
5566 : : }
5567 : :
5568 : : /* We should have found the scalarization loop specifier. If not,
5569 : : that's bad news. */
5570 : 193765 : gcc_assert (loopspec[n]);
5571 : :
5572 : 193765 : info = &loopspec[n]->info->data.array;
5573 : 193765 : dim = loopspec[n]->dim[n];
5574 : :
5575 : : /* Set the extents of this range. */
5576 : 193765 : cshape = info->shape;
5577 : 193765 : if (cshape && INTEGER_CST_P (info->start[dim])
5578 : 139224 : && INTEGER_CST_P (info->stride[dim]))
5579 : : {
5580 : 139224 : loop->from[n] = info->start[dim];
5581 : 139224 : mpz_set (i, cshape[get_array_ref_dim_for_loop_dim (loopspec[n], n)]);
5582 : 139224 : mpz_sub_ui (i, i, 1);
5583 : : /* To = from + (size - 1) * stride. */
5584 : 139224 : tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
5585 : 139224 : if (!integer_onep (info->stride[dim]))
5586 : 8331 : tmp = fold_build2_loc (input_location, MULT_EXPR,
5587 : : gfc_array_index_type, tmp,
5588 : : info->stride[dim]);
5589 : 139224 : loop->to[n] = fold_build2_loc (input_location, PLUS_EXPR,
5590 : : gfc_array_index_type,
5591 : : loop->from[n], tmp);
5592 : : }
5593 : : else
5594 : : {
5595 : 54541 : loop->from[n] = info->start[dim];
5596 : 54541 : switch (loopspec[n]->info->type)
5597 : : {
5598 : 721 : case GFC_SS_CONSTRUCTOR:
5599 : : /* The upper bound is calculated when we expand the
5600 : : constructor. */
5601 : 721 : gcc_assert (loop->to[n] == NULL_TREE);
5602 : : break;
5603 : :
5604 : 49099 : case GFC_SS_SECTION:
5605 : : /* Use the end expression if it exists and is not constant,
5606 : : so that it is only evaluated once. */
5607 : 49099 : loop->to[n] = info->end[dim];
5608 : 49099 : break;
5609 : :
5610 : 3966 : case GFC_SS_FUNCTION:
5611 : : /* The loop bound will be set when we generate the call. */
5612 : 3966 : gcc_assert (loop->to[n] == NULL_TREE);
5613 : : break;
5614 : :
5615 : 749 : case GFC_SS_INTRINSIC:
5616 : 749 : {
5617 : 749 : gfc_expr *expr = loopspec[n]->info->expr;
5618 : :
5619 : : /* The {l,u}bound of an assumed rank. */
5620 : 749 : if (expr->value.function.isym->id == GFC_ISYM_SHAPE)
5621 : 237 : gcc_assert (expr->value.function.actual->expr->rank == -1);
5622 : : else
5623 : 512 : gcc_assert ((expr->value.function.isym->id == GFC_ISYM_LBOUND
5624 : : || expr->value.function.isym->id == GFC_ISYM_UBOUND)
5625 : : && expr->value.function.actual->next->expr == NULL
5626 : : && expr->value.function.actual->expr->rank == -1);
5627 : :
5628 : 749 : loop->to[n] = info->end[dim];
5629 : 749 : break;
5630 : : }
5631 : :
5632 : 6 : case GFC_SS_COMPONENT:
5633 : 6 : {
5634 : 6 : if (info->end[dim] != NULL_TREE)
5635 : : {
5636 : 6 : loop->to[n] = info->end[dim];
5637 : 6 : break;
5638 : : }
5639 : : else
5640 : 0 : gcc_unreachable ();
5641 : : }
5642 : :
5643 : 0 : default:
5644 : 0 : gcc_unreachable ();
5645 : : }
5646 : : }
5647 : :
5648 : : /* Transform everything so we have a simple incrementing variable. */
5649 : 193765 : if (integer_onep (info->stride[dim]))
5650 : 183804 : info->delta[dim] = gfc_index_zero_node;
5651 : : else
5652 : : {
5653 : : /* Set the delta for this section. */
5654 : 9961 : info->delta[dim] = gfc_evaluate_now (loop->from[n], &outer_loop->pre);
5655 : : /* Number of iterations is (end - start + step) / step.
5656 : : with start = 0, this simplifies to
5657 : : last = end / step;
5658 : : for (i = 0; i<=last; i++){...}; */
5659 : 9961 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
5660 : : gfc_array_index_type, loop->to[n],
5661 : : loop->from[n]);
5662 : 9961 : tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
5663 : : gfc_array_index_type, tmp, info->stride[dim]);
5664 : 9961 : tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
5665 : 9961 : tmp, build_int_cst (gfc_array_index_type, -1));
5666 : 9961 : loop->to[n] = gfc_evaluate_now (tmp, &outer_loop->pre);
5667 : : /* Make the loop variable start at 0. */
5668 : 9961 : loop->from[n] = gfc_index_zero_node;
5669 : : }
5670 : : }
5671 : 146517 : mpz_clear (i);
5672 : :
5673 : 147070 : for (loop = loop->nested; loop; loop = loop->next)
5674 : 553 : set_loop_bounds (loop);
5675 : 146517 : }
5676 : :
5677 : :
5678 : : /* Initialize the scalarization loop. Creates the loop variables. Determines
5679 : : the range of the loop variables. Creates a temporary if required.
5680 : : Also generates code for scalar expressions which have been
5681 : : moved outside the loop. */
5682 : :
5683 : : void
5684 : 145964 : gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
5685 : : {
5686 : 145964 : gfc_ss *tmp_ss;
5687 : 145964 : tree tmp;
5688 : :
5689 : 145964 : set_loop_bounds (loop);
5690 : :
5691 : : /* Add all the scalar code that can be taken out of the loops.
5692 : : This may include calculating the loop bounds, so do it before
5693 : : allocating the temporary. */
5694 : 145964 : gfc_add_loop_ss_code (loop, loop->ss, false, where);
5695 : :
5696 : 145964 : tmp_ss = loop->temp_ss;
5697 : : /* If we want a temporary then create it. */
5698 : 145964 : if (tmp_ss != NULL)
5699 : : {
5700 : 8519 : gfc_ss_info *tmp_ss_info;
5701 : :
5702 : 8519 : tmp_ss_info = tmp_ss->info;
5703 : 8519 : gcc_assert (tmp_ss_info->type == GFC_SS_TEMP);
5704 : 8519 : gcc_assert (loop->parent == NULL);
5705 : :
5706 : : /* Make absolutely sure that this is a complete type. */
5707 : 8519 : if (tmp_ss_info->string_length)
5708 : 2509 : tmp_ss_info->data.temp.type
5709 : 2509 : = gfc_get_character_type_len_for_eltype
5710 : 2509 : (TREE_TYPE (tmp_ss_info->data.temp.type),
5711 : : tmp_ss_info->string_length);
5712 : :
5713 : 8519 : tmp = tmp_ss_info->data.temp.type;
5714 : 8519 : memset (&tmp_ss_info->data.array, 0, sizeof (gfc_array_info));
5715 : 8519 : tmp_ss_info->type = GFC_SS_SECTION;
5716 : :
5717 : 8519 : gcc_assert (tmp_ss->dimen != 0);
5718 : :
5719 : 8519 : gfc_trans_create_temp_array (&loop->pre, &loop->post, tmp_ss, tmp,
5720 : : NULL_TREE, false, true, false, where);
5721 : : }
5722 : :
5723 : : /* For array parameters we don't have loop variables, so don't calculate the
5724 : : translations. */
5725 : 145964 : if (!loop->array_parameter)
5726 : 89520 : gfc_set_delta (loop);
5727 : 145964 : }
5728 : :
5729 : :
5730 : : /* Calculates how to transform from loop variables to array indices for each
5731 : : array: once loop bounds are chosen, sets the difference (DELTA field) between
5732 : : loop bounds and array reference bounds, for each array info. */
5733 : :
5734 : : void
5735 : 90252 : gfc_set_delta (gfc_loopinfo *loop)
5736 : : {
5737 : 90252 : gfc_ss *ss, **loopspec;
5738 : 90252 : gfc_array_info *info;
5739 : 90252 : tree tmp;
5740 : 90252 : int n, dim;
5741 : :
5742 : 90252 : gfc_loopinfo * const outer_loop = outermost_loop (loop);
5743 : :
5744 : 90252 : loopspec = loop->specloop;
5745 : :
5746 : : /* Calculate the translation from loop variables to array indices. */
5747 : 273038 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5748 : : {
5749 : 182786 : gfc_ss_type ss_type;
5750 : :
5751 : 182786 : ss_type = ss->info->type;
5752 : 182786 : if (ss_type != GFC_SS_SECTION
5753 : 182786 : && ss_type != GFC_SS_COMPONENT
5754 : 74029 : && ss_type != GFC_SS_CONSTRUCTOR)
5755 : 44423 : continue;
5756 : :
5757 : 304253 : info = &ss->info->data.array;
5758 : :
5759 : 304253 : for (n = 0; n < ss->dimen; n++)
5760 : : {
5761 : : /* If we are specifying the range the delta is already set. */
5762 : 165890 : if (loopspec[n] != ss)
5763 : : {
5764 : 86327 : dim = ss->dim[n];
5765 : :
5766 : : /* Calculate the offset relative to the loop variable.
5767 : : First multiply by the stride. */
5768 : 86327 : tmp = loop->from[n];
5769 : 86327 : if (!integer_onep (info->stride[dim]))
5770 : 2433 : tmp = fold_build2_loc (input_location, MULT_EXPR,
5771 : : gfc_array_index_type,
5772 : : tmp, info->stride[dim]);
5773 : :
5774 : : /* Then subtract this from our starting value. */
5775 : 86327 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
5776 : : gfc_array_index_type,
5777 : : info->start[dim], tmp);
5778 : :
5779 : 86327 : info->delta[dim] = gfc_evaluate_now (tmp, &outer_loop->pre);
5780 : : }
5781 : : }
5782 : : }
5783 : :
5784 : 90829 : for (loop = loop->nested; loop; loop = loop->next)
5785 : 577 : gfc_set_delta (loop);
5786 : 90252 : }
5787 : :
5788 : :
5789 : : /* Calculate the size of a given array dimension from the bounds. This
5790 : : is simply (ubound - lbound + 1) if this expression is positive
5791 : : or 0 if it is negative (pick either one if it is zero). Optionally
5792 : : (if or_expr is present) OR the (expression != 0) condition to it. */
5793 : :
5794 : : tree
5795 : 16352 : gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr)
5796 : : {
5797 : 16352 : tree res;
5798 : 16352 : tree cond;
5799 : :
5800 : : /* Calculate (ubound - lbound + 1). */
5801 : 16352 : res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5802 : : ubound, lbound);
5803 : 16352 : res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res,
5804 : : gfc_index_one_node);
5805 : :
5806 : : /* Check whether the size for this dimension is negative. */
5807 : 16352 : cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, res,
5808 : : gfc_index_zero_node);
5809 : 16352 : res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
5810 : : gfc_index_zero_node, res);
5811 : :
5812 : : /* Build OR expression. */
5813 : 16352 : if (or_expr)
5814 : 13588 : *or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
5815 : : logical_type_node, *or_expr, cond);
5816 : :
5817 : 16352 : return res;
5818 : : }
5819 : :
5820 : :
5821 : : /* For an array descriptor, get the total number of elements. This is just
5822 : : the product of the extents along from_dim to to_dim. */
5823 : :
5824 : : static tree
5825 : 443 : gfc_conv_descriptor_size_1 (tree desc, int from_dim, int to_dim)
5826 : : {
5827 : 443 : tree res;
5828 : 443 : int dim;
5829 : :
5830 : 443 : res = gfc_index_one_node;
5831 : :
5832 : 1078 : for (dim = from_dim; dim < to_dim; ++dim)
5833 : : {
5834 : 635 : tree lbound;
5835 : 635 : tree ubound;
5836 : 635 : tree extent;
5837 : :
5838 : 635 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
5839 : 635 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
5840 : :
5841 : 635 : extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
5842 : 635 : res = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5843 : : res, extent);
5844 : : }
5845 : :
5846 : 443 : return res;
5847 : : }
5848 : :
5849 : :
5850 : : /* Full size of an array. */
5851 : :
5852 : : tree
5853 : 417 : gfc_conv_descriptor_size (tree desc, int rank)
5854 : : {
5855 : 417 : return gfc_conv_descriptor_size_1 (desc, 0, rank);
5856 : : }
5857 : :
5858 : :
5859 : : /* Size of a coarray for all dimensions but the last. */
5860 : :
5861 : : tree
5862 : 26 : gfc_conv_descriptor_cosize (tree desc, int rank, int corank)
5863 : : {
5864 : 26 : return gfc_conv_descriptor_size_1 (desc, rank, rank + corank - 1);
5865 : : }
5866 : :
5867 : :
5868 : : /* Fills in an array descriptor, and returns the size of the array.
5869 : : The size will be a simple_val, ie a variable or a constant. Also
5870 : : calculates the offset of the base. The pointer argument overflow,
5871 : : which should be of integer type, will increase in value if overflow
5872 : : occurs during the size calculation. Returns the size of the array.
5873 : : {
5874 : : stride = 1;
5875 : : offset = 0;
5876 : : for (n = 0; n < rank; n++)
5877 : : {
5878 : : a.lbound[n] = specified_lower_bound;
5879 : : offset = offset + a.lbond[n] * stride;
5880 : : size = 1 - lbound;
5881 : : a.ubound[n] = specified_upper_bound;
5882 : : a.stride[n] = stride;
5883 : : size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
5884 : : overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
5885 : : stride = stride * size;
5886 : : }
5887 : : for (n = rank; n < rank+corank; n++)
5888 : : (Set lcobound/ucobound as above.)
5889 : : element_size = sizeof (array element);
5890 : : if (!rank)
5891 : : return element_size
5892 : : stride = (size_t) stride;
5893 : : overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
5894 : : stride = stride * element_size;
5895 : : return (stride);
5896 : : } */
5897 : : /*GCC ARRAYS*/
5898 : :
5899 : : static tree
5900 : 10036 : gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
5901 : : gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
5902 : : stmtblock_t * descriptor_block, tree * overflow,
5903 : : tree expr3_elem_size, tree *nelems, gfc_expr *expr3,
5904 : : tree expr3_desc, bool e3_has_nodescriptor, gfc_expr *expr,
5905 : : tree *element_size)
5906 : : {
5907 : 10036 : tree type;
5908 : 10036 : tree tmp;
5909 : 10036 : tree size;
5910 : 10036 : tree offset;
5911 : 10036 : tree stride;
5912 : 10036 : tree or_expr;
5913 : 10036 : tree thencase;
5914 : 10036 : tree elsecase;
5915 : 10036 : tree cond;
5916 : 10036 : tree var;
5917 : 10036 : stmtblock_t thenblock;
5918 : 10036 : stmtblock_t elseblock;
5919 : 10036 : gfc_expr *ubound;
5920 : 10036 : gfc_se se;
5921 : 10036 : int n;
5922 : :
5923 : 10036 : type = TREE_TYPE (descriptor);
5924 : :
5925 : 10036 : stride = gfc_index_one_node;
5926 : 10036 : offset = gfc_index_zero_node;
5927 : :
5928 : : /* Set the dtype before the alloc, because registration of coarrays needs
5929 : : it initialized. */
5930 : 10036 : if (expr->ts.type == BT_CHARACTER
5931 : 877 : && expr->ts.deferred
5932 : 420 : && VAR_P (expr->ts.u.cl->backend_decl))
5933 : : {
5934 : 243 : type = gfc_typenode_for_spec (&expr->ts);
5935 : 243 : tmp = gfc_conv_descriptor_dtype (descriptor);
5936 : 243 : gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type));
5937 : : }
5938 : 9793 : else if (expr->ts.type == BT_CHARACTER
5939 : 634 : && expr->ts.deferred
5940 : 177 : && TREE_CODE (descriptor) == COMPONENT_REF)
5941 : : {
5942 : : /* Deferred character components have their string length tucked away
5943 : : in a hidden field of the derived type. Obtain that and use it to
5944 : : set the dtype. The charlen backend decl is zero because the field
5945 : : type is zero length. */
5946 : 159 : gfc_ref *ref;
5947 : 159 : tmp = NULL_TREE;
5948 : 159 : for (ref = expr->ref; ref; ref = ref->next)
5949 : 159 : if (ref->type == REF_COMPONENT
5950 : 159 : && gfc_deferred_strlen (ref->u.c.component, &tmp))
5951 : : break;
5952 : 159 : gcc_assert (tmp != NULL_TREE);
5953 : 159 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
5954 : 159 : TREE_OPERAND (descriptor, 0), tmp, NULL_TREE);
5955 : 159 : tmp = fold_convert (gfc_charlen_type_node, tmp);
5956 : 159 : type = gfc_get_character_type_len (expr->ts.kind, tmp);
5957 : 159 : tmp = gfc_conv_descriptor_dtype (descriptor);
5958 : 159 : gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type));
5959 : 159 : }
5960 : : else
5961 : : {
5962 : 9634 : tmp = gfc_conv_descriptor_dtype (descriptor);
5963 : 9634 : gfc_add_modify (pblock, tmp, gfc_get_dtype (type));
5964 : : }
5965 : :
5966 : 10036 : or_expr = logical_false_node;
5967 : :
5968 : 23624 : for (n = 0; n < rank; n++)
5969 : : {
5970 : 13588 : tree conv_lbound;
5971 : 13588 : tree conv_ubound;
5972 : :
5973 : : /* We have 3 possibilities for determining the size of the array:
5974 : : lower == NULL => lbound = 1, ubound = upper[n]
5975 : : upper[n] = NULL => lbound = 1, ubound = lower[n]
5976 : : upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
5977 : 13588 : ubound = upper[n];
5978 : :
5979 : : /* Set lower bound. */
5980 : 13588 : gfc_init_se (&se, NULL);
5981 : 13588 : if (expr3_desc != NULL_TREE)
5982 : : {
5983 : 1254 : if (e3_has_nodescriptor)
5984 : : /* The lbound of nondescriptor arrays like array constructors,
5985 : : nonallocatable/nonpointer function results/variables,
5986 : : start at zero, but when allocating it, the standard expects
5987 : : the array to start at one. */
5988 : 801 : se.expr = gfc_index_one_node;
5989 : : else
5990 : 453 : se.expr = gfc_conv_descriptor_lbound_get (expr3_desc,
5991 : : gfc_rank_cst[n]);
5992 : : }
5993 : 12334 : else if (lower == NULL)
5994 : 9627 : se.expr = gfc_index_one_node;
5995 : : else
5996 : : {
5997 : 2707 : gcc_assert (lower[n]);
5998 : 2707 : if (ubound)
5999 : : {
6000 : 2158 : gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
6001 : 2158 : gfc_add_block_to_block (pblock, &se.pre);
6002 : : }
6003 : : else
6004 : : {
6005 : 549 : se.expr = gfc_index_one_node;
6006 : 549 : ubound = lower[n];
6007 : : }
6008 : : }
6009 : 13588 : gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
6010 : : gfc_rank_cst[n], se.expr);
6011 : 13588 : conv_lbound = se.expr;
6012 : :
6013 : : /* Work out the offset for this component. */
6014 : 13588 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6015 : : se.expr, stride);
6016 : 13588 : offset = fold_build2_loc (input_location, MINUS_EXPR,
6017 : : gfc_array_index_type, offset, tmp);
6018 : :
6019 : : /* Set upper bound. */
6020 : 13588 : gfc_init_se (&se, NULL);
6021 : 13588 : if (expr3_desc != NULL_TREE)
6022 : : {
6023 : 1254 : if (e3_has_nodescriptor)
6024 : : {
6025 : : /* The lbound of nondescriptor arrays like array constructors,
6026 : : nonallocatable/nonpointer function results/variables,
6027 : : start at zero, but when allocating it, the standard expects
6028 : : the array to start at one. Therefore fix the upper bound to be
6029 : : (desc.ubound - desc.lbound) + 1. */
6030 : 801 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
6031 : : gfc_array_index_type,
6032 : : gfc_conv_descriptor_ubound_get (
6033 : : expr3_desc, gfc_rank_cst[n]),
6034 : : gfc_conv_descriptor_lbound_get (
6035 : : expr3_desc, gfc_rank_cst[n]));
6036 : 801 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
6037 : : gfc_array_index_type, tmp,
6038 : : gfc_index_one_node);
6039 : 801 : se.expr = gfc_evaluate_now (tmp, pblock);
6040 : : }
6041 : : else
6042 : 453 : se.expr = gfc_conv_descriptor_ubound_get (expr3_desc,
6043 : : gfc_rank_cst[n]);
6044 : : }
6045 : : else
6046 : : {
6047 : 12334 : gcc_assert (ubound);
6048 : 12334 : gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
6049 : 12334 : gfc_add_block_to_block (pblock, &se.pre);
6050 : 12334 : if (ubound->expr_type == EXPR_FUNCTION)
6051 : 735 : se.expr = gfc_evaluate_now (se.expr, pblock);
6052 : : }
6053 : 13588 : gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
6054 : : gfc_rank_cst[n], se.expr);
6055 : 13588 : conv_ubound = se.expr;
6056 : :
6057 : : /* Store the stride. */
6058 : 13588 : gfc_conv_descriptor_stride_set (descriptor_block, descriptor,
6059 : : gfc_rank_cst[n], stride);
6060 : :
6061 : : /* Calculate size and check whether extent is negative. */
6062 : 13588 : size = gfc_conv_array_extent_dim (conv_lbound, conv_ubound, &or_expr);
6063 : 13588 : size = gfc_evaluate_now (size, pblock);
6064 : :
6065 : : /* Check whether multiplying the stride by the number of
6066 : : elements in this dimension would overflow. We must also check
6067 : : whether the current dimension has zero size in order to avoid
6068 : : division by zero.
6069 : : */
6070 : 13588 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
6071 : : gfc_array_index_type,
6072 : 13588 : fold_convert (gfc_array_index_type,
6073 : : TYPE_MAX_VALUE (gfc_array_index_type)),
6074 : : size);
6075 : 13588 : cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
6076 : : logical_type_node, tmp, stride),
6077 : : PRED_FORTRAN_OVERFLOW);
6078 : 13588 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
6079 : : integer_one_node, integer_zero_node);
6080 : 13588 : cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
6081 : : logical_type_node, size,
6082 : : gfc_index_zero_node),
6083 : : PRED_FORTRAN_SIZE_ZERO);
6084 : 13588 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
6085 : : integer_zero_node, tmp);
6086 : 13588 : tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
6087 : : *overflow, tmp);
6088 : 13588 : *overflow = gfc_evaluate_now (tmp, pblock);
6089 : :
6090 : : /* Multiply the stride by the number of elements in this dimension. */
6091 : 13588 : stride = fold_build2_loc (input_location, MULT_EXPR,
6092 : : gfc_array_index_type, stride, size);
6093 : 13588 : stride = gfc_evaluate_now (stride, pblock);
6094 : : }
6095 : :
6096 : 10521 : for (n = rank; n < rank + corank; n++)
6097 : : {
6098 : 485 : ubound = upper[n];
6099 : :
6100 : : /* Set lower bound. */
6101 : 485 : gfc_init_se (&se, NULL);
6102 : 485 : if (lower == NULL || lower[n] == NULL)
6103 : : {
6104 : 269 : gcc_assert (n == rank + corank - 1);
6105 : 269 : se.expr = gfc_index_one_node;
6106 : : }
6107 : : else
6108 : : {
6109 : 216 : if (ubound || n == rank + corank - 1)
6110 : : {
6111 : 142 : gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
6112 : 142 : gfc_add_block_to_block (pblock, &se.pre);
6113 : : }
6114 : : else
6115 : : {
6116 : 74 : se.expr = gfc_index_one_node;
6117 : 74 : ubound = lower[n];
6118 : : }
6119 : : }
6120 : 485 : gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
6121 : : gfc_rank_cst[n], se.expr);
6122 : :
6123 : 485 : if (n < rank + corank - 1)
6124 : : {
6125 : 143 : gfc_init_se (&se, NULL);
6126 : 143 : gcc_assert (ubound);
6127 : 143 : gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
6128 : 143 : gfc_add_block_to_block (pblock, &se.pre);
6129 : 143 : gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
6130 : : gfc_rank_cst[n], se.expr);
6131 : : }
6132 : : }
6133 : :
6134 : : /* The stride is the number of elements in the array, so multiply by the
6135 : : size of an element to get the total size. Obviously, if there is a
6136 : : SOURCE expression (expr3) we must use its element size. */
6137 : 10036 : if (expr3_elem_size != NULL_TREE)
6138 : 2613 : tmp = expr3_elem_size;
6139 : 7423 : else if (expr3 != NULL)
6140 : : {
6141 : 0 : if (expr3->ts.type == BT_CLASS)
6142 : : {
6143 : 0 : gfc_se se_sz;
6144 : 0 : gfc_expr *sz = gfc_copy_expr (expr3);
6145 : 0 : gfc_add_vptr_component (sz);
6146 : 0 : gfc_add_size_component (sz);
6147 : 0 : gfc_init_se (&se_sz, NULL);
6148 : 0 : gfc_conv_expr (&se_sz, sz);
6149 : 0 : gfc_free_expr (sz);
6150 : 0 : tmp = se_sz.expr;
6151 : : }
6152 : : else
6153 : : {
6154 : 0 : tmp = gfc_typenode_for_spec (&expr3->ts);
6155 : 0 : tmp = TYPE_SIZE_UNIT (tmp);
6156 : : }
6157 : : }
6158 : : else
6159 : 7423 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
6160 : :
6161 : : /* Convert to size_t. */
6162 : 10036 : *element_size = fold_convert (size_type_node, tmp);
6163 : :
6164 : 10036 : if (rank == 0)
6165 : : return *element_size;
6166 : :
6167 : 9887 : *nelems = gfc_evaluate_now (stride, pblock);
6168 : 9887 : stride = fold_convert (size_type_node, stride);
6169 : :
6170 : : /* First check for overflow. Since an array of type character can
6171 : : have zero element_size, we must check for that before
6172 : : dividing. */
6173 : 9887 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
6174 : : size_type_node,
6175 : 9887 : TYPE_MAX_VALUE (size_type_node), *element_size);
6176 : 9887 : cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
6177 : : logical_type_node, tmp, stride),
6178 : : PRED_FORTRAN_OVERFLOW);
6179 : 9887 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
6180 : : integer_one_node, integer_zero_node);
6181 : 9887 : cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
6182 : : logical_type_node, *element_size,
6183 : 9887 : build_int_cst (size_type_node, 0)),
6184 : : PRED_FORTRAN_SIZE_ZERO);
6185 : 9887 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
6186 : : integer_zero_node, tmp);
6187 : 9887 : tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
6188 : : *overflow, tmp);
6189 : 9887 : *overflow = gfc_evaluate_now (tmp, pblock);
6190 : :
6191 : 9887 : size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
6192 : : stride, *element_size);
6193 : :
6194 : 9887 : if (poffset != NULL)
6195 : : {
6196 : 9887 : offset = gfc_evaluate_now (offset, pblock);
6197 : 9887 : *poffset = offset;
6198 : : }
6199 : :
6200 : 9887 : if (integer_zerop (or_expr))
6201 : : return size;
6202 : 3108 : if (integer_onep (or_expr))
6203 : 328 : return build_int_cst (size_type_node, 0);
6204 : :
6205 : 2780 : var = gfc_create_var (TREE_TYPE (size), "size");
6206 : 2780 : gfc_start_block (&thenblock);
6207 : 2780 : gfc_add_modify (&thenblock, var, build_int_cst (size_type_node, 0));
6208 : 2780 : thencase = gfc_finish_block (&thenblock);
6209 : :
6210 : 2780 : gfc_start_block (&elseblock);
6211 : 2780 : gfc_add_modify (&elseblock, var, size);
6212 : 2780 : elsecase = gfc_finish_block (&elseblock);
6213 : :
6214 : 2780 : tmp = gfc_evaluate_now (or_expr, pblock);
6215 : 2780 : tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
6216 : 2780 : gfc_add_expr_to_block (pblock, tmp);
6217 : :
6218 : 2780 : return var;
6219 : : }
6220 : :
6221 : :
6222 : : /* Retrieve the last ref from the chain. This routine is specific to
6223 : : gfc_array_allocate ()'s needs. */
6224 : :
6225 : : bool
6226 : 15839 : retrieve_last_ref (gfc_ref **ref_in, gfc_ref **prev_ref_in)
6227 : : {
6228 : 15839 : gfc_ref *ref, *prev_ref;
6229 : :
6230 : 15839 : ref = *ref_in;
6231 : : /* Prevent warnings for uninitialized variables. */
6232 : 15839 : prev_ref = *prev_ref_in;
6233 : 21871 : while (ref && ref->next != NULL)
6234 : : {
6235 : 6032 : gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
6236 : : || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
6237 : : prev_ref = ref;
6238 : : ref = ref->next;
6239 : : }
6240 : :
6241 : 15839 : if (ref == NULL || ref->type != REF_ARRAY)
6242 : : return false;
6243 : :
6244 : 11110 : *ref_in = ref;
6245 : 11110 : *prev_ref_in = prev_ref;
6246 : 11110 : return true;
6247 : : }
6248 : :
6249 : : /* Initializes the descriptor and generates a call to _gfor_allocate. Does
6250 : : the work for an ALLOCATE statement. */
6251 : : /*GCC ARRAYS*/
6252 : :
6253 : : bool
6254 : 14765 : gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
6255 : : tree errlen, tree label_finish, tree expr3_elem_size,
6256 : : tree *nelems, gfc_expr *expr3, tree e3_arr_desc,
6257 : : bool e3_has_nodescriptor, gfc_omp_namelist *omp_alloc)
6258 : : {
6259 : 14765 : tree tmp;
6260 : 14765 : tree pointer;
6261 : 14765 : tree offset = NULL_TREE;
6262 : 14765 : tree token = NULL_TREE;
6263 : 14765 : tree size;
6264 : 14765 : tree msg;
6265 : 14765 : tree error = NULL_TREE;
6266 : 14765 : tree overflow; /* Boolean storing whether size calculation overflows. */
6267 : 14765 : tree var_overflow = NULL_TREE;
6268 : 14765 : tree cond;
6269 : 14765 : tree set_descriptor;
6270 : 14765 : tree not_prev_allocated = NULL_TREE;
6271 : 14765 : tree element_size = NULL_TREE;
6272 : 14765 : stmtblock_t set_descriptor_block;
6273 : 14765 : stmtblock_t elseblock;
6274 : 14765 : gfc_expr **lower;
6275 : 14765 : gfc_expr **upper;
6276 : 14765 : gfc_ref *ref, *prev_ref = NULL, *coref;
6277 : 14765 : bool allocatable, coarray, dimension, alloc_w_e3_arr_spec = false,
6278 : : non_ulimate_coarray_ptr_comp;
6279 : 14765 : tree omp_cond = NULL_TREE, omp_alt_alloc = NULL_TREE;
6280 : :
6281 : 14765 : ref = expr->ref;
6282 : :
6283 : : /* Find the last reference in the chain. */
6284 : 14765 : if (!retrieve_last_ref (&ref, &prev_ref))
6285 : : return false;
6286 : :
6287 : : /* Take the allocatable and coarray properties solely from the expr-ref's
6288 : : attributes and not from source=-expression. */
6289 : 10036 : if (!prev_ref)
6290 : : {
6291 : 6783 : allocatable = expr->symtree->n.sym->attr.allocatable;
6292 : 6783 : dimension = expr->symtree->n.sym->attr.dimension;
6293 : 6783 : non_ulimate_coarray_ptr_comp = false;
6294 : : }
6295 : : else
6296 : : {
6297 : 3253 : allocatable = prev_ref->u.c.component->attr.allocatable;
6298 : : /* Pointer components in coarrayed derived types must be treated
6299 : : specially in that they are registered without a check if the are
6300 : : already associated. This does not hold for ultimate coarray
6301 : : pointers. */
6302 : 3253 : non_ulimate_coarray_ptr_comp = (prev_ref->u.c.component->attr.pointer
6303 : 3253 : && !prev_ref->u.c.component->attr.codimension);
6304 : 3253 : dimension = prev_ref->u.c.component->attr.dimension;
6305 : : }
6306 : :
6307 : : /* For allocatable/pointer arrays in derived types, one of the refs has to be
6308 : : a coarray. In this case it does not matter whether we are on this_image
6309 : : or not. */
6310 : 10036 : coarray = false;
6311 : 24046 : for (coref = expr->ref; coref; coref = coref->next)
6312 : 14514 : if (coref->type == REF_ARRAY && coref->u.ar.codimen > 0)
6313 : : {
6314 : : coarray = true;
6315 : : break;
6316 : : }
6317 : :
6318 : 10036 : if (!dimension)
6319 : 149 : gcc_assert (coarray);
6320 : :
6321 : 10036 : if (ref->u.ar.type == AR_FULL && expr3 != NULL)
6322 : : {
6323 : 1074 : gfc_ref *old_ref = ref;
6324 : : /* F08:C633: Array shape from expr3. */
6325 : 1074 : ref = expr3->ref;
6326 : :
6327 : : /* Find the last reference in the chain. */
6328 : 1074 : if (!retrieve_last_ref (&ref, &prev_ref))
6329 : : {
6330 : 0 : if (expr3->expr_type == EXPR_FUNCTION
6331 : 0 : && gfc_expr_attr (expr3).dimension)
6332 : 0 : ref = old_ref;
6333 : : else
6334 : 0 : return false;
6335 : : }
6336 : : alloc_w_e3_arr_spec = true;
6337 : : }
6338 : :
6339 : : /* Figure out the size of the array. */
6340 : 10036 : switch (ref->u.ar.type)
6341 : : {
6342 : 7476 : case AR_ELEMENT:
6343 : 7476 : if (!coarray)
6344 : : {
6345 : 7018 : lower = NULL;
6346 : 7018 : upper = ref->u.ar.start;
6347 : 7018 : break;
6348 : : }
6349 : : /* Fall through. */
6350 : :
6351 : 1974 : case AR_SECTION:
6352 : 1974 : lower = ref->u.ar.start;
6353 : 1974 : upper = ref->u.ar.end;
6354 : 1974 : break;
6355 : :
6356 : 1044 : case AR_FULL:
6357 : 1044 : gcc_assert (ref->u.ar.as->type == AS_EXPLICIT
6358 : : || alloc_w_e3_arr_spec);
6359 : :
6360 : 1044 : lower = ref->u.ar.as->lower;
6361 : 1044 : upper = ref->u.ar.as->upper;
6362 : 1044 : break;
6363 : :
6364 : 0 : default:
6365 : 0 : gcc_unreachable ();
6366 : 10036 : break;
6367 : : }
6368 : :
6369 : 10036 : overflow = integer_zero_node;
6370 : :
6371 : 10036 : if (expr->ts.type == BT_CHARACTER
6372 : 877 : && TREE_CODE (se->string_length) == COMPONENT_REF
6373 : 159 : && expr->ts.u.cl->backend_decl != se->string_length
6374 : 159 : && VAR_P (expr->ts.u.cl->backend_decl))
6375 : 0 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
6376 : 0 : fold_convert (TREE_TYPE (expr->ts.u.cl->backend_decl),
6377 : : se->string_length));
6378 : :
6379 : 10036 : gfc_init_block (&set_descriptor_block);
6380 : : /* Take the corank only from the actual ref and not from the coref. The
6381 : : later will mislead the generation of the array dimensions for allocatable/
6382 : : pointer components in derived types. */
6383 : 19502 : size = gfc_array_init_size (se->expr, alloc_w_e3_arr_spec ? expr->rank
6384 : 8962 : : ref->u.ar.as->rank,
6385 : 504 : coarray ? ref->u.ar.as->corank : 0,
6386 : : &offset, lower, upper,
6387 : : &se->pre, &set_descriptor_block, &overflow,
6388 : : expr3_elem_size, nelems, expr3, e3_arr_desc,
6389 : : e3_has_nodescriptor, expr, &element_size);
6390 : :
6391 : 10036 : if (dimension)
6392 : : {
6393 : 9887 : var_overflow = gfc_create_var (integer_type_node, "overflow");
6394 : 9887 : gfc_add_modify (&se->pre, var_overflow, overflow);
6395 : :
6396 : 9887 : if (status == NULL_TREE)
6397 : : {
6398 : : /* Generate the block of code handling overflow. */
6399 : 9673 : msg = gfc_build_addr_expr (pchar_type_node,
6400 : : gfc_build_localized_cstring_const
6401 : : ("Integer overflow when calculating the amount of "
6402 : : "memory to allocate"));
6403 : 9673 : error = build_call_expr_loc (input_location,
6404 : : gfor_fndecl_runtime_error, 1, msg);
6405 : : }
6406 : : else
6407 : : {
6408 : 214 : tree status_type = TREE_TYPE (status);
6409 : 214 : stmtblock_t set_status_block;
6410 : :
6411 : 214 : gfc_start_block (&set_status_block);
6412 : 214 : gfc_add_modify (&set_status_block, status,
6413 : 214 : build_int_cst (status_type, LIBERROR_ALLOCATION));
6414 : 214 : error = gfc_finish_block (&set_status_block);
6415 : : }
6416 : : }
6417 : :
6418 : : /* Allocate memory to store the data. */
6419 : 10036 : if (POINTER_TYPE_P (TREE_TYPE (se->expr)))
6420 : 0 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
6421 : :
6422 : 10036 : if (coarray && flag_coarray == GFC_FCOARRAY_LIB)
6423 : : {
6424 : 284 : pointer = non_ulimate_coarray_ptr_comp ? se->expr
6425 : 215 : : gfc_conv_descriptor_data_get (se->expr);
6426 : 284 : token = gfc_conv_descriptor_token (se->expr);
6427 : 284 : token = gfc_build_addr_expr (NULL_TREE, token);
6428 : : }
6429 : : else
6430 : : {
6431 : 9752 : pointer = gfc_conv_descriptor_data_get (se->expr);
6432 : 9752 : if (omp_alloc)
6433 : 30 : omp_cond = boolean_true_node;
6434 : : }
6435 : 10036 : STRIP_NOPS (pointer);
6436 : :
6437 : 10036 : if (allocatable)
6438 : : {
6439 : 8034 : not_prev_allocated = gfc_create_var (logical_type_node,
6440 : : "not_prev_allocated");
6441 : 8034 : tmp = fold_build2_loc (input_location, EQ_EXPR,
6442 : : logical_type_node, pointer,
6443 : 8034 : build_int_cst (TREE_TYPE (pointer), 0));
6444 : :
6445 : 8034 : gfc_add_modify (&se->pre, not_prev_allocated, tmp);
6446 : : }
6447 : :
6448 : 10036 : gfc_start_block (&elseblock);
6449 : :
6450 : 10036 : tree succ_add_expr = NULL_TREE;
6451 : 10036 : if (omp_cond)
6452 : : {
6453 : 30 : tree align, alloc, sz;
6454 : 30 : gfc_se se2;
6455 : 30 : if (omp_alloc->u2.allocator)
6456 : : {
6457 : 7 : gfc_init_se (&se2, NULL);
6458 : 7 : gfc_conv_expr (&se2, omp_alloc->u2.allocator);
6459 : 7 : gfc_add_block_to_block (&elseblock, &se2.pre);
6460 : 7 : alloc = gfc_evaluate_now (se2.expr, &elseblock);
6461 : 7 : gfc_add_block_to_block (&elseblock, &se2.post);
6462 : : }
6463 : : else
6464 : 23 : alloc = build_zero_cst (ptr_type_node);
6465 : 30 : tmp = TREE_TYPE (TREE_TYPE (pointer));
6466 : 30 : if (tmp == void_type_node)
6467 : 30 : tmp = gfc_typenode_for_spec (&expr->ts, 0);
6468 : 30 : if (omp_alloc->u.align)
6469 : : {
6470 : 15 : gfc_init_se (&se2, NULL);
6471 : 15 : gfc_conv_expr (&se2, omp_alloc->u.align);
6472 : 15 : gcc_assert (CONSTANT_CLASS_P (se2.expr)
6473 : : && se2.pre.head == NULL
6474 : : && se2.post.head == NULL);
6475 : 15 : align = build_int_cst (size_type_node,
6476 : 15 : MAX (tree_to_uhwi (se2.expr),
6477 : : TYPE_ALIGN_UNIT (tmp)));
6478 : : }
6479 : : else
6480 : 15 : align = build_int_cst (size_type_node, TYPE_ALIGN_UNIT (tmp));
6481 : 30 : sz = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
6482 : : fold_convert (size_type_node, size),
6483 : 30 : build_int_cst (size_type_node, 1));
6484 : 30 : omp_alt_alloc = builtin_decl_explicit (BUILT_IN_GOMP_ALLOC);
6485 : 30 : DECL_ATTRIBUTES (omp_alt_alloc)
6486 : 30 : = tree_cons (get_identifier ("omp allocator"),
6487 : : build_tree_list (NULL_TREE, alloc),
6488 : 30 : DECL_ATTRIBUTES (omp_alt_alloc));
6489 : 30 : omp_alt_alloc = build_call_expr (omp_alt_alloc, 3, align, sz, alloc);
6490 : 30 : succ_add_expr = fold_build2_loc (input_location, MODIFY_EXPR,
6491 : : void_type_node,
6492 : : gfc_conv_descriptor_version (se->expr),
6493 : 30 : build_int_cst (integer_type_node, 1));
6494 : : }
6495 : :
6496 : : /* The allocatable variant takes the old pointer as first argument. */
6497 : 10036 : if (allocatable)
6498 : 8466 : gfc_allocate_allocatable (&elseblock, pointer, size, token,
6499 : : status, errmsg, errlen, label_finish, expr,
6500 : 432 : coref != NULL ? coref->u.ar.as->corank : 0,
6501 : : omp_cond, omp_alt_alloc, succ_add_expr);
6502 : 2002 : else if (non_ulimate_coarray_ptr_comp && token)
6503 : : /* The token is set only for GFC_FCOARRAY_LIB mode. */
6504 : 69 : gfc_allocate_using_caf_lib (&elseblock, pointer, size, token, status,
6505 : : errmsg, errlen,
6506 : : GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY);
6507 : : else
6508 : 1933 : gfc_allocate_using_malloc (&elseblock, pointer, size, status,
6509 : : omp_cond, omp_alt_alloc, succ_add_expr);
6510 : :
6511 : 10036 : if (dimension)
6512 : : {
6513 : 9887 : cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
6514 : : logical_type_node, var_overflow, integer_zero_node),
6515 : : PRED_FORTRAN_OVERFLOW);
6516 : 9887 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6517 : : error, gfc_finish_block (&elseblock));
6518 : : }
6519 : : else
6520 : 149 : tmp = gfc_finish_block (&elseblock);
6521 : :
6522 : 10036 : gfc_add_expr_to_block (&se->pre, tmp);
6523 : :
6524 : : /* Update the array descriptor with the offset and the span. */
6525 : 10036 : if (dimension)
6526 : : {
6527 : 9887 : gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
6528 : 9887 : tmp = fold_convert (gfc_array_index_type, element_size);
6529 : 9887 : gfc_conv_descriptor_span_set (&set_descriptor_block, se->expr, tmp);
6530 : : }
6531 : :
6532 : 10036 : set_descriptor = gfc_finish_block (&set_descriptor_block);
6533 : 10036 : if (status != NULL_TREE)
6534 : : {
6535 : 228 : cond = fold_build2_loc (input_location, EQ_EXPR,
6536 : : logical_type_node, status,
6537 : 228 : build_int_cst (TREE_TYPE (status), 0));
6538 : :
6539 : 228 : if (not_prev_allocated != NULL_TREE)
6540 : 207 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
6541 : : logical_type_node, cond, not_prev_allocated);
6542 : :
6543 : 228 : gfc_add_expr_to_block (&se->pre,
6544 : : fold_build3_loc (input_location, COND_EXPR, void_type_node,
6545 : : cond,
6546 : : set_descriptor,
6547 : : build_empty_stmt (input_location)));
6548 : : }
6549 : : else
6550 : 9808 : gfc_add_expr_to_block (&se->pre, set_descriptor);
6551 : :
6552 : : return true;
6553 : : }
6554 : :
6555 : :
6556 : : /* Create an array constructor from an initialization expression.
6557 : : We assume the frontend already did any expansions and conversions. */
6558 : :
6559 : : tree
6560 : 6582 : gfc_conv_array_initializer (tree type, gfc_expr * expr)
6561 : : {
6562 : 6582 : gfc_constructor *c;
6563 : 6582 : tree tmp;
6564 : 6582 : gfc_se se;
6565 : 6582 : tree index, range;
6566 : 6582 : vec<constructor_elt, va_gc> *v = NULL;
6567 : :
6568 : 6582 : if (expr->expr_type == EXPR_VARIABLE
6569 : 0 : && expr->symtree->n.sym->attr.flavor == FL_PARAMETER
6570 : 0 : && expr->symtree->n.sym->value)
6571 : 6582 : expr = expr->symtree->n.sym->value;
6572 : :
6573 : 6582 : switch (expr->expr_type)
6574 : : {
6575 : 1041 : case EXPR_CONSTANT:
6576 : 1041 : case EXPR_STRUCTURE:
6577 : : /* A single scalar or derived type value. Create an array with all
6578 : : elements equal to that value. */
6579 : 1041 : gfc_init_se (&se, NULL);
6580 : :
6581 : 1041 : if (expr->expr_type == EXPR_CONSTANT)
6582 : 359 : gfc_conv_constant (&se, expr);
6583 : : else
6584 : 682 : gfc_conv_structure (&se, expr, 1);
6585 : :
6586 : 2082 : if (tree_int_cst_lt (TYPE_MAX_VALUE (TYPE_DOMAIN (type)),
6587 : 1041 : TYPE_MIN_VALUE (TYPE_DOMAIN (type))))
6588 : : break;
6589 : 2058 : else if (tree_int_cst_equal (TYPE_MIN_VALUE (TYPE_DOMAIN (type)),
6590 : 1029 : TYPE_MAX_VALUE (TYPE_DOMAIN (type))))
6591 : 144 : range = TYPE_MIN_VALUE (TYPE_DOMAIN (type));
6592 : : else
6593 : 1770 : range = build2 (RANGE_EXPR, gfc_array_index_type,
6594 : 885 : TYPE_MIN_VALUE (TYPE_DOMAIN (type)),
6595 : 885 : TYPE_MAX_VALUE (TYPE_DOMAIN (type)));
6596 : 1029 : CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
6597 : 1029 : break;
6598 : :
6599 : 5541 : case EXPR_ARRAY:
6600 : : /* Create a vector of all the elements. */
6601 : 5541 : for (c = gfc_constructor_first (expr->value.constructor);
6602 : 148949 : c && c->expr; c = gfc_constructor_next (c))
6603 : : {
6604 : 143408 : if (c->iterator)
6605 : : {
6606 : : /* Problems occur when we get something like
6607 : : integer :: a(lots) = (/(i, i=1, lots)/) */
6608 : 0 : gfc_fatal_error ("The number of elements in the array "
6609 : : "constructor at %L requires an increase of "
6610 : : "the allowed %d upper limit. See "
6611 : : "%<-fmax-array-constructor%> option",
6612 : : &expr->where, flag_max_array_constructor);
6613 : : return NULL_TREE;
6614 : : }
6615 : 143408 : if (mpz_cmp_si (c->offset, 0) != 0)
6616 : 138100 : index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
6617 : : else
6618 : : index = NULL_TREE;
6619 : :
6620 : 143408 : if (mpz_cmp_si (c->repeat, 1) > 0)
6621 : : {
6622 : 152 : tree tmp1, tmp2;
6623 : 152 : mpz_t maxval;
6624 : :
6625 : 152 : mpz_init (maxval);
6626 : 152 : mpz_add (maxval, c->offset, c->repeat);
6627 : 152 : mpz_sub_ui (maxval, maxval, 1);
6628 : 152 : tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
6629 : 152 : if (mpz_cmp_si (c->offset, 0) != 0)
6630 : : {
6631 : 27 : mpz_add_ui (maxval, c->offset, 1);
6632 : 27 : tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
6633 : : }
6634 : : else
6635 : 125 : tmp1 = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
6636 : :
6637 : 152 : range = fold_build2 (RANGE_EXPR, gfc_array_index_type, tmp1, tmp2);
6638 : 152 : mpz_clear (maxval);
6639 : : }
6640 : : else
6641 : : range = NULL;
6642 : :
6643 : 143408 : gfc_init_se (&se, NULL);
6644 : 143408 : switch (c->expr->expr_type)
6645 : : {
6646 : 142226 : case EXPR_CONSTANT:
6647 : 142226 : gfc_conv_constant (&se, c->expr);
6648 : :
6649 : : /* See gfortran.dg/charlen_15.f90 for instance. */
6650 : 142226 : if (TREE_CODE (se.expr) == STRING_CST
6651 : 4893 : && TREE_CODE (type) == ARRAY_TYPE)
6652 : : {
6653 : : tree atype = type;
6654 : 9786 : while (TREE_CODE (TREE_TYPE (atype)) == ARRAY_TYPE)
6655 : 4893 : atype = TREE_TYPE (atype);
6656 : 4893 : gcc_checking_assert (TREE_CODE (TREE_TYPE (atype))
6657 : : == INTEGER_TYPE);
6658 : 4893 : gcc_checking_assert (TREE_TYPE (TREE_TYPE (se.expr))
6659 : : == TREE_TYPE (atype));
6660 : 4893 : if (tree_to_uhwi (TYPE_SIZE_UNIT (TREE_TYPE (se.expr)))
6661 : 4893 : > tree_to_uhwi (TYPE_SIZE_UNIT (atype)))
6662 : : {
6663 : 0 : unsigned HOST_WIDE_INT size
6664 : 0 : = tree_to_uhwi (TYPE_SIZE_UNIT (atype));
6665 : 0 : const char *p = TREE_STRING_POINTER (se.expr);
6666 : :
6667 : 0 : se.expr = build_string (size, p);
6668 : : }
6669 : 4893 : TREE_TYPE (se.expr) = atype;
6670 : : }
6671 : : break;
6672 : :
6673 : 1182 : case EXPR_STRUCTURE:
6674 : 1182 : gfc_conv_structure (&se, c->expr, 1);
6675 : 1182 : break;
6676 : :
6677 : 0 : default:
6678 : : /* Catch those occasional beasts that do not simplify
6679 : : for one reason or another, assuming that if they are
6680 : : standard defying the frontend will catch them. */
6681 : 0 : gfc_conv_expr (&se, c->expr);
6682 : 0 : break;
6683 : : }
6684 : :
6685 : 143408 : if (range == NULL_TREE)
6686 : 143256 : CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
6687 : : else
6688 : : {
6689 : 152 : if (index != NULL_TREE)
6690 : 27 : CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
6691 : 143560 : CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
6692 : : }
6693 : : }
6694 : : break;
6695 : :
6696 : 0 : case EXPR_NULL:
6697 : 0 : return gfc_build_null_descriptor (type);
6698 : :
6699 : 0 : default:
6700 : 0 : gcc_unreachable ();
6701 : : }
6702 : :
6703 : : /* Create a constructor from the list of elements. */
6704 : 6582 : tmp = build_constructor (type, v);
6705 : 6582 : TREE_CONSTANT (tmp) = 1;
6706 : 6582 : return tmp;
6707 : : }
6708 : :
6709 : :
6710 : : /* Generate code to evaluate non-constant coarray cobounds. */
6711 : :
6712 : : void
6713 : 17543 : gfc_trans_array_cobounds (tree type, stmtblock_t * pblock,
6714 : : const gfc_symbol *sym)
6715 : : {
6716 : 17543 : int dim;
6717 : 17543 : tree ubound;
6718 : 17543 : tree lbound;
6719 : 17543 : gfc_se se;
6720 : 17543 : gfc_array_spec *as;
6721 : :
6722 : 17543 : as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
6723 : :
6724 : 18144 : for (dim = as->rank; dim < as->rank + as->corank; dim++)
6725 : : {
6726 : : /* Evaluate non-constant array bound expressions.
6727 : : F2008 4.5.6.3 para 6: If a specification expression in a scoping unit
6728 : : references a function, the result is finalized before execution of the
6729 : : executable constructs in the scoping unit.
6730 : : Adding the finalblocks enables this. */
6731 : 601 : lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
6732 : 601 : if (as->lower[dim] && !INTEGER_CST_P (lbound))
6733 : : {
6734 : 96 : gfc_init_se (&se, NULL);
6735 : 96 : gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
6736 : 96 : gfc_add_block_to_block (pblock, &se.pre);
6737 : 96 : gfc_add_block_to_block (pblock, &se.finalblock);
6738 : 96 : gfc_add_modify (pblock, lbound, se.expr);
6739 : : }
6740 : 601 : ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
6741 : 601 : if (as->upper[dim] && !INTEGER_CST_P (ubound))
6742 : : {
6743 : 50 : gfc_init_se (&se, NULL);
6744 : 50 : gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
6745 : 50 : gfc_add_block_to_block (pblock, &se.pre);
6746 : 50 : gfc_add_block_to_block (pblock, &se.finalblock);
6747 : 50 : gfc_add_modify (pblock, ubound, se.expr);
6748 : : }
6749 : : }
6750 : 17543 : }
6751 : :
6752 : :
6753 : : /* Generate code to evaluate non-constant array bounds. Sets *poffset and
6754 : : returns the size (in elements) of the array. */
6755 : :
6756 : : tree
6757 : 11522 : gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
6758 : : stmtblock_t * pblock)
6759 : : {
6760 : 11522 : gfc_array_spec *as;
6761 : 11522 : tree size;
6762 : 11522 : tree stride;
6763 : 11522 : tree offset;
6764 : 11522 : tree ubound;
6765 : 11522 : tree lbound;
6766 : 11522 : tree tmp;
6767 : 11522 : gfc_se se;
6768 : :
6769 : 11522 : int dim;
6770 : :
6771 : 11522 : as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
6772 : :
6773 : 11522 : size = gfc_index_one_node;
6774 : 11522 : offset = gfc_index_zero_node;
6775 : 26319 : for (dim = 0; dim < as->rank; dim++)
6776 : : {
6777 : : /* Evaluate non-constant array bound expressions.
6778 : : F2008 4.5.6.3 para 6: If a specification expression in a scoping unit
6779 : : references a function, the result is finalized before execution of the
6780 : : executable constructs in the scoping unit.
6781 : : Adding the finalblocks enables this. */
6782 : 14797 : lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
6783 : 14797 : if (as->lower[dim] && !INTEGER_CST_P (lbound))
6784 : : {
6785 : 484 : gfc_init_se (&se, NULL);
6786 : 484 : gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
6787 : 484 : gfc_add_block_to_block (pblock, &se.pre);
6788 : 484 : gfc_add_block_to_block (pblock, &se.finalblock);
6789 : 484 : gfc_add_modify (pblock, lbound, se.expr);
6790 : : }
6791 : 14797 : ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
6792 : 14797 : if (as->upper[dim] && !INTEGER_CST_P (ubound))
6793 : : {
6794 : 8898 : gfc_init_se (&se, NULL);
6795 : 8898 : gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
6796 : 8898 : gfc_add_block_to_block (pblock, &se.pre);
6797 : 8898 : gfc_add_block_to_block (pblock, &se.finalblock);
6798 : 8898 : gfc_add_modify (pblock, ubound, se.expr);
6799 : : }
6800 : : /* The offset of this dimension. offset = offset - lbound * stride. */
6801 : 14797 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6802 : : lbound, size);
6803 : 14797 : offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6804 : : offset, tmp);
6805 : :
6806 : : /* The size of this dimension, and the stride of the next. */
6807 : 14797 : if (dim + 1 < as->rank)
6808 : 3316 : stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
6809 : : else
6810 : 11481 : stride = GFC_TYPE_ARRAY_SIZE (type);
6811 : :
6812 : 14797 : if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
6813 : : {
6814 : : /* Calculate stride = size * (ubound + 1 - lbound). */
6815 : 9032 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
6816 : : gfc_array_index_type,
6817 : : gfc_index_one_node, lbound);
6818 : 9032 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
6819 : : gfc_array_index_type, ubound, tmp);
6820 : 9032 : tmp = fold_build2_loc (input_location, MULT_EXPR,
6821 : : gfc_array_index_type, size, tmp);
6822 : 9032 : if (stride)
6823 : 9032 : gfc_add_modify (pblock, stride, tmp);
6824 : : else
6825 : 0 : stride = gfc_evaluate_now (tmp, pblock);
6826 : :
6827 : : /* Make sure that negative size arrays are translated
6828 : : to being zero size. */
6829 : 9032 : tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
6830 : : stride, gfc_index_zero_node);
6831 : 9032 : tmp = fold_build3_loc (input_location, COND_EXPR,
6832 : : gfc_array_index_type, tmp,
6833 : : stride, gfc_index_zero_node);
6834 : 9032 : gfc_add_modify (pblock, stride, tmp);
6835 : : }
6836 : :
6837 : : size = stride;
6838 : : }
6839 : :
6840 : 11522 : gfc_trans_array_cobounds (type, pblock, sym);
6841 : 11522 : gfc_trans_vla_type_sizes (sym, pblock);
6842 : :
6843 : 11522 : *poffset = offset;
6844 : 11522 : return size;
6845 : : }
6846 : :
6847 : :
6848 : : /* Generate code to initialize/allocate an array variable. */
6849 : :
6850 : : void
6851 : 26650 : gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
6852 : : gfc_wrapped_block * block)
6853 : : {
6854 : 26650 : stmtblock_t init;
6855 : 26650 : tree type;
6856 : 26650 : tree tmp = NULL_TREE;
6857 : 26650 : tree size;
6858 : 26650 : tree offset;
6859 : 26650 : tree space;
6860 : 26650 : tree inittree;
6861 : 26650 : bool onstack;
6862 : :
6863 : 26650 : gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
6864 : :
6865 : : /* Do nothing for USEd variables. */
6866 : 26650 : if (sym->attr.use_assoc)
6867 : 22059 : return;
6868 : :
6869 : 26610 : type = TREE_TYPE (decl);
6870 : 26610 : gcc_assert (GFC_ARRAY_TYPE_P (type));
6871 : 26610 : onstack = TREE_CODE (type) != POINTER_TYPE;
6872 : :
6873 : 26610 : gfc_init_block (&init);
6874 : :
6875 : : /* Evaluate character string length. */
6876 : 26610 : if (sym->ts.type == BT_CHARACTER
6877 : 2839 : && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
6878 : : {
6879 : 43 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
6880 : :
6881 : 43 : gfc_trans_vla_type_sizes (sym, &init);
6882 : :
6883 : : /* Emit a DECL_EXPR for this variable, which will cause the
6884 : : gimplifier to allocate storage, and all that good stuff. */
6885 : 43 : tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
6886 : 43 : gfc_add_expr_to_block (&init, tmp);
6887 : 43 : if (sym->attr.omp_allocate)
6888 : : {
6889 : : /* Save location of size calculation to ensure GOMP_alloc is placed
6890 : : after it. */
6891 : 0 : tree omp_alloc = lookup_attribute ("omp allocate",
6892 : 0 : DECL_ATTRIBUTES (decl));
6893 : 0 : TREE_CHAIN (TREE_CHAIN (TREE_VALUE (omp_alloc)))
6894 : 0 : = build_tree_list (NULL_TREE, tsi_stmt (tsi_last (init.head)));
6895 : : }
6896 : : }
6897 : :
6898 : 26414 : if (onstack)
6899 : : {
6900 : 21879 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
6901 : 21879 : return;
6902 : : }
6903 : :
6904 : 4731 : type = TREE_TYPE (type);
6905 : :
6906 : 4731 : gcc_assert (!sym->attr.use_assoc);
6907 : 4731 : gcc_assert (!sym->module);
6908 : :
6909 : 4731 : if (sym->ts.type == BT_CHARACTER
6910 : 196 : && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
6911 : 88 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
6912 : :
6913 : 4731 : size = gfc_trans_array_bounds (type, sym, &offset, &init);
6914 : :
6915 : : /* Don't actually allocate space for Cray Pointees. */
6916 : 4731 : if (sym->attr.cray_pointee)
6917 : : {
6918 : 140 : if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
6919 : 49 : gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
6920 : :
6921 : 140 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
6922 : 140 : return;
6923 : : }
6924 : 4591 : if (sym->attr.omp_allocate)
6925 : : {
6926 : : /* The size is the number of elements in the array, so multiply by the
6927 : : size of an element to get the total size. */
6928 : 7 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
6929 : 7 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6930 : : size, fold_convert (gfc_array_index_type, tmp));
6931 : 7 : size = gfc_evaluate_now (size, &init);
6932 : :
6933 : 7 : tree omp_alloc = lookup_attribute ("omp allocate",
6934 : 7 : DECL_ATTRIBUTES (decl));
6935 : 7 : TREE_CHAIN (TREE_CHAIN (TREE_VALUE (omp_alloc)))
6936 : 7 : = build_tree_list (size, NULL_TREE);
6937 : 7 : space = NULL_TREE;
6938 : : }
6939 : 4584 : else if (flag_stack_arrays)
6940 : : {
6941 : 11 : gcc_assert (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE);
6942 : 11 : space = build_decl (gfc_get_location (&sym->declared_at),
6943 : : VAR_DECL, create_tmp_var_name ("A"),
6944 : 11 : TREE_TYPE (TREE_TYPE (decl)));
6945 : 11 : gfc_trans_vla_type_sizes (sym, &init);
6946 : : }
6947 : : else
6948 : : {
6949 : : /* The size is the number of elements in the array, so multiply by the
6950 : : size of an element to get the total size. */
6951 : 4573 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
6952 : 4573 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6953 : : size, fold_convert (gfc_array_index_type, tmp));
6954 : :
6955 : : /* Allocate memory to hold the data. */
6956 : 4573 : tmp = gfc_call_malloc (&init, TREE_TYPE (decl), size);
6957 : 4573 : gfc_add_modify (&init, decl, tmp);
6958 : :
6959 : : /* Free the temporary. */
6960 : 4573 : tmp = gfc_call_free (decl);
6961 : 4573 : space = NULL_TREE;
6962 : : }
6963 : :
6964 : : /* Set offset of the array. */
6965 : 4591 : if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
6966 : 398 : gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
6967 : :
6968 : : /* Automatic arrays should not have initializers. */
6969 : 4591 : gcc_assert (!sym->value);
6970 : :
6971 : 4591 : inittree = gfc_finish_block (&init);
6972 : :
6973 : 4591 : if (space)
6974 : : {
6975 : 11 : tree addr;
6976 : 11 : pushdecl (space);
6977 : :
6978 : : /* Don't create new scope, emit the DECL_EXPR in exactly the scope
6979 : : where also space is located. */
6980 : 11 : gfc_init_block (&init);
6981 : 11 : tmp = fold_build1_loc (input_location, DECL_EXPR,
6982 : 11 : TREE_TYPE (space), space);
6983 : 11 : gfc_add_expr_to_block (&init, tmp);
6984 : 11 : addr = fold_build1_loc (gfc_get_location (&sym->declared_at),
6985 : 11 : ADDR_EXPR, TREE_TYPE (decl), space);
6986 : 11 : gfc_add_modify (&init, decl, addr);
6987 : 11 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
6988 : 11 : tmp = NULL_TREE;
6989 : : }
6990 : 4591 : gfc_add_init_cleanup (block, inittree, tmp);
6991 : : }
6992 : :
6993 : :
6994 : : /* Generate entry and exit code for g77 calling convention arrays. */
6995 : :
6996 : : void
6997 : 6537 : gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block)
6998 : : {
6999 : 6537 : tree parm;
7000 : 6537 : tree type;
7001 : 6537 : locus loc;
7002 : 6537 : tree offset;
7003 : 6537 : tree tmp;
7004 : 6537 : tree stmt;
7005 : 6537 : stmtblock_t init;
7006 : :
7007 : 6537 : gfc_save_backend_locus (&loc);
7008 : 6537 : gfc_set_backend_locus (&sym->declared_at);
7009 : :
7010 : : /* Descriptor type. */
7011 : 6537 : parm = sym->backend_decl;
7012 : 6537 : type = TREE_TYPE (parm);
7013 : 6537 : gcc_assert (GFC_ARRAY_TYPE_P (type));
7014 : :
7015 : 6537 : gfc_start_block (&init);
7016 : :
7017 : 6537 : if (sym->ts.type == BT_CHARACTER
7018 : 618 : && VAR_P (sym->ts.u.cl->backend_decl))
7019 : 79 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7020 : :
7021 : : /* Evaluate the bounds of the array. */
7022 : 6537 : gfc_trans_array_bounds (type, sym, &offset, &init);
7023 : :
7024 : : /* Set the offset. */
7025 : 6537 : if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
7026 : 1061 : gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
7027 : :
7028 : : /* Set the pointer itself if we aren't using the parameter directly. */
7029 : 6537 : if (TREE_CODE (parm) != PARM_DECL)
7030 : : {
7031 : 344 : tmp = GFC_DECL_SAVED_DESCRIPTOR (parm);
7032 : 344 : if (sym->ts.type == BT_CLASS)
7033 : : {
7034 : 72 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
7035 : 72 : tmp = gfc_class_data_get (tmp);
7036 : 72 : tmp = gfc_conv_descriptor_data_get (tmp);
7037 : : }
7038 : 344 : tmp = convert (TREE_TYPE (parm), tmp);
7039 : 344 : gfc_add_modify (&init, parm, tmp);
7040 : : }
7041 : 6537 : stmt = gfc_finish_block (&init);
7042 : :
7043 : 6537 : gfc_restore_backend_locus (&loc);
7044 : :
7045 : : /* Add the initialization code to the start of the function. */
7046 : :
7047 : 6537 : if ((sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.optional)
7048 : : || sym->attr.optional
7049 : 6537 : || sym->attr.not_always_present)
7050 : : {
7051 : 490 : tree nullify;
7052 : 490 : if (TREE_CODE (parm) != PARM_DECL)
7053 : 49 : nullify = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
7054 : : parm, null_pointer_node);
7055 : : else
7056 : 441 : nullify = build_empty_stmt (input_location);
7057 : 490 : tmp = gfc_conv_expr_present (sym, true);
7058 : 490 : stmt = build3_v (COND_EXPR, tmp, stmt, nullify);
7059 : : }
7060 : :
7061 : 6537 : gfc_add_init_cleanup (block, stmt, NULL_TREE);
7062 : 6537 : }
7063 : :
7064 : :
7065 : : /* Modify the descriptor of an array parameter so that it has the
7066 : : correct lower bound. Also move the upper bound accordingly.
7067 : : If the array is not packed, it will be copied into a temporary.
7068 : : For each dimension we set the new lower and upper bounds. Then we copy the
7069 : : stride and calculate the offset for this dimension. We also work out
7070 : : what the stride of a packed array would be, and see it the two match.
7071 : : If the array need repacking, we set the stride to the values we just
7072 : : calculated, recalculate the offset and copy the array data.
7073 : : Code is also added to copy the data back at the end of the function.
7074 : : */
7075 : :
7076 : : void
7077 : 11012 : gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
7078 : : gfc_wrapped_block * block)
7079 : : {
7080 : 11012 : tree size;
7081 : 11012 : tree type;
7082 : 11012 : tree offset;
7083 : 11012 : locus loc;
7084 : 11012 : stmtblock_t init;
7085 : 11012 : tree stmtInit, stmtCleanup;
7086 : 11012 : tree lbound;
7087 : 11012 : tree ubound;
7088 : 11012 : tree dubound;
7089 : 11012 : tree dlbound;
7090 : 11012 : tree dumdesc;
7091 : 11012 : tree tmp;
7092 : 11012 : tree stride, stride2;
7093 : 11012 : tree stmt_packed;
7094 : 11012 : tree stmt_unpacked;
7095 : 11012 : tree partial;
7096 : 11012 : gfc_se se;
7097 : 11012 : int n;
7098 : 11012 : int checkparm;
7099 : 11012 : int no_repack;
7100 : 11012 : bool optional_arg;
7101 : 11012 : gfc_array_spec *as;
7102 : 11012 : bool is_classarray = IS_CLASS_ARRAY (sym);
7103 : :
7104 : : /* Do nothing for pointer and allocatable arrays. */
7105 : 11012 : if ((sym->ts.type != BT_CLASS && sym->attr.pointer)
7106 : 10915 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer)
7107 : 10915 : || sym->attr.allocatable
7108 : 10794 : || (is_classarray && CLASS_DATA (sym)->attr.allocatable))
7109 : 5277 : return;
7110 : :
7111 : 10220 : if (!is_classarray && sym->attr.dummy && gfc_is_nodesc_array (sym))
7112 : : {
7113 : 5059 : gfc_trans_g77_array (sym, block);
7114 : 5059 : return;
7115 : : }
7116 : :
7117 : 5735 : loc.nextc = NULL;
7118 : 5735 : gfc_save_backend_locus (&loc);
7119 : : /* loc.nextc is not set by save_backend_locus but the location routines
7120 : : depend on it. */
7121 : 5735 : if (loc.nextc == NULL)
7122 : 5735 : loc.nextc = loc.lb->line;
7123 : 5735 : gfc_set_backend_locus (&sym->declared_at);
7124 : :
7125 : : /* Descriptor type. */
7126 : 5735 : type = TREE_TYPE (tmpdesc);
7127 : 5735 : gcc_assert (GFC_ARRAY_TYPE_P (type));
7128 : 5735 : dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
7129 : 5735 : if (is_classarray)
7130 : : /* For a class array the dummy array descriptor is in the _class
7131 : : component. */
7132 : 574 : dumdesc = gfc_class_data_get (dumdesc);
7133 : : else
7134 : 5161 : dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc);
7135 : 5735 : as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
7136 : 5735 : gfc_start_block (&init);
7137 : :
7138 : 5735 : if (sym->ts.type == BT_CHARACTER
7139 : 725 : && VAR_P (sym->ts.u.cl->backend_decl))
7140 : 87 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7141 : :
7142 : : /* TODO: Fix the exclusion of class arrays from extent checking. */
7143 : 1024 : checkparm = (as->type == AS_EXPLICIT && !is_classarray
7144 : 6683 : && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
7145 : :
7146 : 5735 : no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
7147 : 5734 : || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
7148 : :
7149 : 5735 : if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
7150 : : {
7151 : : /* For non-constant shape arrays we only check if the first dimension
7152 : : is contiguous. Repacking higher dimensions wouldn't gain us
7153 : : anything as we still don't know the array stride. */
7154 : 1 : partial = gfc_create_var (logical_type_node, "partial");
7155 : 1 : TREE_USED (partial) = 1;
7156 : 1 : tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
7157 : 1 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, tmp,
7158 : : gfc_index_one_node);
7159 : 1 : gfc_add_modify (&init, partial, tmp);
7160 : : }
7161 : : else
7162 : : partial = NULL_TREE;
7163 : :
7164 : : /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
7165 : : here, however I think it does the right thing. */
7166 : 5735 : if (no_repack)
7167 : : {
7168 : : /* Set the first stride. */
7169 : 5733 : stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
7170 : 5733 : stride = gfc_evaluate_now (stride, &init);
7171 : :
7172 : 5733 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7173 : : stride, gfc_index_zero_node);
7174 : 5733 : tmp = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
7175 : : tmp, gfc_index_one_node, stride);
7176 : 5733 : stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
7177 : 5733 : gfc_add_modify (&init, stride, tmp);
7178 : :
7179 : : /* Allow the user to disable array repacking. */
7180 : 5733 : stmt_unpacked = NULL_TREE;
7181 : : }
7182 : : else
7183 : : {
7184 : 2 : gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
7185 : : /* A library call to repack the array if necessary. */
7186 : 2 : tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
7187 : 2 : stmt_unpacked = build_call_expr_loc (input_location,
7188 : : gfor_fndecl_in_pack, 1, tmp);
7189 : :
7190 : 2 : stride = gfc_index_one_node;
7191 : :
7192 : 2 : if (warn_array_temporaries)
7193 : 1 : gfc_warning (OPT_Warray_temporaries,
7194 : : "Creating array temporary at %L", &loc);
7195 : : }
7196 : :
7197 : : /* This is for the case where the array data is used directly without
7198 : : calling the repack function. */
7199 : 5735 : if (no_repack || partial != NULL_TREE)
7200 : 5734 : stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
7201 : : else
7202 : : stmt_packed = NULL_TREE;
7203 : :
7204 : : /* Assign the data pointer. */
7205 : 5735 : if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
7206 : : {
7207 : : /* Don't repack unknown shape arrays when the first stride is 1. */
7208 : 1 : tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (stmt_packed),
7209 : : partial, stmt_packed, stmt_unpacked);
7210 : : }
7211 : : else
7212 : 5734 : tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
7213 : 5735 : gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp));
7214 : :
7215 : 5735 : offset = gfc_index_zero_node;
7216 : 5735 : size = gfc_index_one_node;
7217 : :
7218 : : /* Evaluate the bounds of the array. */
7219 : 13330 : for (n = 0; n < as->rank; n++)
7220 : : {
7221 : 7595 : if (checkparm || !as->upper[n])
7222 : : {
7223 : : /* Get the bounds of the actual parameter. */
7224 : 6336 : dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]);
7225 : 6336 : dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]);
7226 : : }
7227 : : else
7228 : : {
7229 : : dubound = NULL_TREE;
7230 : : dlbound = NULL_TREE;
7231 : : }
7232 : :
7233 : 7595 : lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
7234 : 7595 : if (!INTEGER_CST_P (lbound))
7235 : : {
7236 : 45 : gfc_init_se (&se, NULL);
7237 : 45 : gfc_conv_expr_type (&se, as->lower[n],
7238 : : gfc_array_index_type);
7239 : 45 : gfc_add_block_to_block (&init, &se.pre);
7240 : 45 : gfc_add_modify (&init, lbound, se.expr);
7241 : : }
7242 : :
7243 : 7595 : ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
7244 : : /* Set the desired upper bound. */
7245 : 7595 : if (as->upper[n])
7246 : : {
7247 : : /* We know what we want the upper bound to be. */
7248 : 1317 : if (!INTEGER_CST_P (ubound))
7249 : : {
7250 : 635 : gfc_init_se (&se, NULL);
7251 : 635 : gfc_conv_expr_type (&se, as->upper[n],
7252 : : gfc_array_index_type);
7253 : 635 : gfc_add_block_to_block (&init, &se.pre);
7254 : 635 : gfc_add_modify (&init, ubound, se.expr);
7255 : : }
7256 : :
7257 : : /* Check the sizes match. */
7258 : 1317 : if (checkparm)
7259 : : {
7260 : : /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
7261 : 58 : char * msg;
7262 : 58 : tree temp;
7263 : :
7264 : 58 : temp = fold_build2_loc (input_location, MINUS_EXPR,
7265 : : gfc_array_index_type, ubound, lbound);
7266 : 58 : temp = fold_build2_loc (input_location, PLUS_EXPR,
7267 : : gfc_array_index_type,
7268 : : gfc_index_one_node, temp);
7269 : 58 : stride2 = fold_build2_loc (input_location, MINUS_EXPR,
7270 : : gfc_array_index_type, dubound,
7271 : : dlbound);
7272 : 58 : stride2 = fold_build2_loc (input_location, PLUS_EXPR,
7273 : : gfc_array_index_type,
7274 : : gfc_index_one_node, stride2);
7275 : 58 : tmp = fold_build2_loc (input_location, NE_EXPR,
7276 : : gfc_array_index_type, temp, stride2);
7277 : 58 : msg = xasprintf ("Dimension %d of array '%s' has extent "
7278 : : "%%ld instead of %%ld", n+1, sym->name);
7279 : :
7280 : 58 : gfc_trans_runtime_check (true, false, tmp, &init, &loc, msg,
7281 : : fold_convert (long_integer_type_node, temp),
7282 : : fold_convert (long_integer_type_node, stride2));
7283 : :
7284 : 58 : free (msg);
7285 : : }
7286 : : }
7287 : : else
7288 : : {
7289 : : /* For assumed shape arrays move the upper bound by the same amount
7290 : : as the lower bound. */
7291 : 6278 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
7292 : : gfc_array_index_type, dubound, dlbound);
7293 : 6278 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
7294 : : gfc_array_index_type, tmp, lbound);
7295 : 6278 : gfc_add_modify (&init, ubound, tmp);
7296 : : }
7297 : : /* The offset of this dimension. offset = offset - lbound * stride. */
7298 : 7595 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7299 : : lbound, stride);
7300 : 7595 : offset = fold_build2_loc (input_location, MINUS_EXPR,
7301 : : gfc_array_index_type, offset, tmp);
7302 : :
7303 : : /* The size of this dimension, and the stride of the next. */
7304 : 7595 : if (n + 1 < as->rank)
7305 : : {
7306 : 1860 : stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
7307 : :
7308 : 1860 : if (no_repack || partial != NULL_TREE)
7309 : 1859 : stmt_unpacked =
7310 : 1859 : gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]);
7311 : :
7312 : : /* Figure out the stride if not a known constant. */
7313 : 1860 : if (!INTEGER_CST_P (stride))
7314 : : {
7315 : 1859 : if (no_repack)
7316 : : stmt_packed = NULL_TREE;
7317 : : else
7318 : : {
7319 : : /* Calculate stride = size * (ubound + 1 - lbound). */
7320 : 0 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
7321 : : gfc_array_index_type,
7322 : : gfc_index_one_node, lbound);
7323 : 0 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
7324 : : gfc_array_index_type, ubound, tmp);
7325 : 0 : size = fold_build2_loc (input_location, MULT_EXPR,
7326 : : gfc_array_index_type, size, tmp);
7327 : 0 : stmt_packed = size;
7328 : : }
7329 : :
7330 : : /* Assign the stride. */
7331 : 1859 : if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
7332 : 0 : tmp = fold_build3_loc (input_location, COND_EXPR,
7333 : : gfc_array_index_type, partial,
7334 : : stmt_unpacked, stmt_packed);
7335 : : else
7336 : 1859 : tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
7337 : 1859 : gfc_add_modify (&init, stride, tmp);
7338 : : }
7339 : : }
7340 : : else
7341 : : {
7342 : 5735 : stride = GFC_TYPE_ARRAY_SIZE (type);
7343 : :
7344 : 5735 : if (stride && !INTEGER_CST_P (stride))
7345 : : {
7346 : : /* Calculate size = stride * (ubound + 1 - lbound). */
7347 : 5734 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
7348 : : gfc_array_index_type,
7349 : : gfc_index_one_node, lbound);
7350 : 5734 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
7351 : : gfc_array_index_type,
7352 : : ubound, tmp);
7353 : 17202 : tmp = fold_build2_loc (input_location, MULT_EXPR,
7354 : : gfc_array_index_type,
7355 : 5734 : GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
7356 : 5734 : gfc_add_modify (&init, stride, tmp);
7357 : : }
7358 : : }
7359 : : }
7360 : :
7361 : 5735 : gfc_trans_array_cobounds (type, &init, sym);
7362 : :
7363 : : /* Set the offset. */
7364 : 5735 : if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
7365 : 5733 : gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
7366 : :
7367 : 5735 : gfc_trans_vla_type_sizes (sym, &init);
7368 : :
7369 : 5735 : stmtInit = gfc_finish_block (&init);
7370 : :
7371 : : /* Only do the entry/initialization code if the arg is present. */
7372 : 5735 : dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
7373 : 5735 : optional_arg = (sym->attr.optional
7374 : 5735 : || (sym->ns->proc_name->attr.entry_master
7375 : 79 : && sym->attr.dummy));
7376 : : if (optional_arg)
7377 : : {
7378 : 633 : tree zero_init = fold_convert (TREE_TYPE (tmpdesc), null_pointer_node);
7379 : 633 : zero_init = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
7380 : : tmpdesc, zero_init);
7381 : 633 : tmp = gfc_conv_expr_present (sym, true);
7382 : 633 : stmtInit = build3_v (COND_EXPR, tmp, stmtInit, zero_init);
7383 : : }
7384 : :
7385 : : /* Cleanup code. */
7386 : 5735 : if (no_repack)
7387 : : stmtCleanup = NULL_TREE;
7388 : : else
7389 : : {
7390 : 2 : stmtblock_t cleanup;
7391 : 2 : gfc_start_block (&cleanup);
7392 : :
7393 : 2 : if (sym->attr.intent != INTENT_IN)
7394 : : {
7395 : : /* Copy the data back. */
7396 : 2 : tmp = build_call_expr_loc (input_location,
7397 : : gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
7398 : 2 : gfc_add_expr_to_block (&cleanup, tmp);
7399 : : }
7400 : :
7401 : : /* Free the temporary. */
7402 : 2 : tmp = gfc_call_free (tmpdesc);
7403 : 2 : gfc_add_expr_to_block (&cleanup, tmp);
7404 : :
7405 : 2 : stmtCleanup = gfc_finish_block (&cleanup);
7406 : :
7407 : : /* Only do the cleanup if the array was repacked. */
7408 : 2 : if (is_classarray)
7409 : : /* For a class array the dummy array descriptor is in the _class
7410 : : component. */
7411 : 1 : tmp = gfc_class_data_get (dumdesc);
7412 : : else
7413 : 1 : tmp = build_fold_indirect_ref_loc (input_location, dumdesc);
7414 : 2 : tmp = gfc_conv_descriptor_data_get (tmp);
7415 : 2 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
7416 : : tmp, tmpdesc);
7417 : 2 : stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
7418 : : build_empty_stmt (input_location));
7419 : :
7420 : 2 : if (optional_arg)
7421 : : {
7422 : 0 : tmp = gfc_conv_expr_present (sym);
7423 : 0 : stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
7424 : : build_empty_stmt (input_location));
7425 : : }
7426 : : }
7427 : :
7428 : : /* We don't need to free any memory allocated by internal_pack as it will
7429 : : be freed at the end of the function by pop_context. */
7430 : 5735 : gfc_add_init_cleanup (block, stmtInit, stmtCleanup);
7431 : :
7432 : 5735 : gfc_restore_backend_locus (&loc);
7433 : : }
7434 : :
7435 : :
7436 : : /* Calculate the overall offset, including subreferences. */
7437 : : void
7438 : 49830 : gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
7439 : : bool subref, gfc_expr *expr)
7440 : : {
7441 : 49830 : tree tmp;
7442 : 49830 : tree field;
7443 : 49830 : tree stride;
7444 : 49830 : tree index;
7445 : 49830 : gfc_ref *ref;
7446 : 49830 : gfc_se start;
7447 : 49830 : int n;
7448 : :
7449 : : /* If offset is NULL and this is not a subreferenced array, there is
7450 : : nothing to do. */
7451 : 49830 : if (offset == NULL_TREE)
7452 : : {
7453 : 928 : if (subref)
7454 : 115 : offset = gfc_index_zero_node;
7455 : : else
7456 : 813 : return;
7457 : : }
7458 : :
7459 : 49017 : tmp = build_array_ref (desc, offset, NULL, NULL);
7460 : :
7461 : : /* Offset the data pointer for pointer assignments from arrays with
7462 : : subreferences; e.g. my_integer => my_type(:)%integer_component. */
7463 : 49017 : if (subref)
7464 : : {
7465 : : /* Go past the array reference. */
7466 : 737 : for (ref = expr->ref; ref; ref = ref->next)
7467 : 737 : if (ref->type == REF_ARRAY &&
7468 : 651 : ref->u.ar.type != AR_ELEMENT)
7469 : : {
7470 : 627 : ref = ref->next;
7471 : 627 : break;
7472 : : }
7473 : :
7474 : : /* Calculate the offset for each subsequent subreference. */
7475 : 1226 : for (; ref; ref = ref->next)
7476 : : {
7477 : 599 : switch (ref->type)
7478 : : {
7479 : 264 : case REF_COMPONENT:
7480 : 264 : field = ref->u.c.component->backend_decl;
7481 : 264 : gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
7482 : 528 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
7483 : 264 : TREE_TYPE (field),
7484 : : tmp, field, NULL_TREE);
7485 : 264 : break;
7486 : :
7487 : 299 : case REF_SUBSTRING:
7488 : 299 : gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
7489 : 299 : gfc_init_se (&start, NULL);
7490 : 299 : gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
7491 : 299 : gfc_add_block_to_block (block, &start.pre);
7492 : 299 : tmp = gfc_build_array_ref (tmp, start.expr, NULL);
7493 : 299 : break;
7494 : :
7495 : 24 : case REF_ARRAY:
7496 : 24 : gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
7497 : : && ref->u.ar.type == AR_ELEMENT);
7498 : :
7499 : : /* TODO - Add bounds checking. */
7500 : 24 : stride = gfc_index_one_node;
7501 : 24 : index = gfc_index_zero_node;
7502 : 55 : for (n = 0; n < ref->u.ar.dimen; n++)
7503 : : {
7504 : 31 : tree itmp;
7505 : 31 : tree jtmp;
7506 : :
7507 : : /* Update the index. */
7508 : 31 : gfc_init_se (&start, NULL);
7509 : 31 : gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
7510 : 31 : itmp = gfc_evaluate_now (start.expr, block);
7511 : 31 : gfc_init_se (&start, NULL);
7512 : 31 : gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
7513 : 31 : jtmp = gfc_evaluate_now (start.expr, block);
7514 : 31 : itmp = fold_build2_loc (input_location, MINUS_EXPR,
7515 : : gfc_array_index_type, itmp, jtmp);
7516 : 31 : itmp = fold_build2_loc (input_location, MULT_EXPR,
7517 : : gfc_array_index_type, itmp, stride);
7518 : 31 : index = fold_build2_loc (input_location, PLUS_EXPR,
7519 : : gfc_array_index_type, itmp, index);
7520 : 31 : index = gfc_evaluate_now (index, block);
7521 : :
7522 : : /* Update the stride. */
7523 : 31 : gfc_init_se (&start, NULL);
7524 : 31 : gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
7525 : 31 : itmp = fold_build2_loc (input_location, MINUS_EXPR,
7526 : : gfc_array_index_type, start.expr,
7527 : : jtmp);
7528 : 31 : itmp = fold_build2_loc (input_location, PLUS_EXPR,
7529 : : gfc_array_index_type,
7530 : : gfc_index_one_node, itmp);
7531 : 31 : stride = fold_build2_loc (input_location, MULT_EXPR,
7532 : : gfc_array_index_type, stride, itmp);
7533 : 31 : stride = gfc_evaluate_now (stride, block);
7534 : : }
7535 : :
7536 : : /* Apply the index to obtain the array element. */
7537 : 24 : tmp = gfc_build_array_ref (tmp, index, NULL);
7538 : 24 : break;
7539 : :
7540 : 12 : case REF_INQUIRY:
7541 : 12 : switch (ref->u.i)
7542 : : {
7543 : 6 : case INQUIRY_RE:
7544 : 12 : tmp = fold_build1_loc (input_location, REALPART_EXPR,
7545 : 6 : TREE_TYPE (TREE_TYPE (tmp)), tmp);
7546 : 6 : break;
7547 : :
7548 : 6 : case INQUIRY_IM:
7549 : 12 : tmp = fold_build1_loc (input_location, IMAGPART_EXPR,
7550 : 6 : TREE_TYPE (TREE_TYPE (tmp)), tmp);
7551 : 6 : break;
7552 : :
7553 : : default:
7554 : : break;
7555 : : }
7556 : : break;
7557 : :
7558 : 0 : default:
7559 : 0 : gcc_unreachable ();
7560 : 599 : break;
7561 : : }
7562 : : }
7563 : : }
7564 : :
7565 : : /* Set the target data pointer. */
7566 : 49017 : offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
7567 : :
7568 : : /* Check for optional dummy argument being present. Arguments of BIND(C)
7569 : : procedures are excepted here since they are handled differently. */
7570 : 49017 : if (expr->expr_type == EXPR_VARIABLE
7571 : 43682 : && expr->symtree->n.sym->attr.dummy
7572 : 43682 : && expr->symtree->n.sym->attr.optional
7573 : 49972 : && !is_CFI_desc (NULL, expr))
7574 : 1550 : offset = build3_loc (input_location, COND_EXPR, TREE_TYPE (offset),
7575 : 775 : gfc_conv_expr_present (expr->symtree->n.sym), offset,
7576 : 775 : fold_convert (TREE_TYPE (offset), gfc_index_zero_node));
7577 : :
7578 : 49017 : gfc_conv_descriptor_data_set (block, parm, offset);
7579 : : }
7580 : :
7581 : :
7582 : : /* gfc_conv_expr_descriptor needs the string length an expression
7583 : : so that the size of the temporary can be obtained. This is done
7584 : : by adding up the string lengths of all the elements in the
7585 : : expression. Function with non-constant expressions have their
7586 : : string lengths mapped onto the actual arguments using the
7587 : : interface mapping machinery in trans-expr.cc. */
7588 : : static void
7589 : 1444 : get_array_charlen (gfc_expr *expr, gfc_se *se)
7590 : : {
7591 : 1444 : gfc_interface_mapping mapping;
7592 : 1444 : gfc_formal_arglist *formal;
7593 : 1444 : gfc_actual_arglist *arg;
7594 : 1444 : gfc_se tse;
7595 : 1444 : gfc_expr *e;
7596 : :
7597 : 1444 : if (expr->ts.u.cl->length
7598 : 1444 : && gfc_is_constant_expr (expr->ts.u.cl->length))
7599 : : {
7600 : 1100 : if (!expr->ts.u.cl->backend_decl)
7601 : 393 : gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
7602 : 1232 : return;
7603 : : }
7604 : :
7605 : 344 : switch (expr->expr_type)
7606 : : {
7607 : 130 : case EXPR_ARRAY:
7608 : :
7609 : : /* This is somewhat brutal. The expression for the first
7610 : : element of the array is evaluated and assigned to a
7611 : : new string length for the original expression. */
7612 : 130 : e = gfc_constructor_first (expr->value.constructor)->expr;
7613 : :
7614 : 130 : gfc_init_se (&tse, NULL);
7615 : :
7616 : : /* Avoid evaluating trailing array references since all we need is
7617 : : the string length. */
7618 : 130 : if (e->rank)
7619 : 38 : tse.descriptor_only = 1;
7620 : 130 : if (e->rank && e->expr_type != EXPR_VARIABLE)
7621 : 1 : gfc_conv_expr_descriptor (&tse, e);
7622 : : else
7623 : 129 : gfc_conv_expr (&tse, e);
7624 : :
7625 : 130 : gfc_add_block_to_block (&se->pre, &tse.pre);
7626 : 130 : gfc_add_block_to_block (&se->post, &tse.post);
7627 : :
7628 : 130 : if (!expr->ts.u.cl->backend_decl || !VAR_P (expr->ts.u.cl->backend_decl))
7629 : : {
7630 : 87 : expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
7631 : 87 : expr->ts.u.cl->backend_decl =
7632 : 87 : gfc_create_var (gfc_charlen_type_node, "sln");
7633 : : }
7634 : :
7635 : 130 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
7636 : : tse.string_length);
7637 : :
7638 : : /* Make sure that deferred length components point to the hidden
7639 : : string_length component. */
7640 : 130 : if (TREE_CODE (tse.expr) == COMPONENT_REF
7641 : 25 : && TREE_CODE (tse.string_length) == COMPONENT_REF
7642 : 149 : && TREE_OPERAND (tse.expr, 0) == TREE_OPERAND (tse.string_length, 0))
7643 : 19 : e->ts.u.cl->backend_decl = expr->ts.u.cl->backend_decl;
7644 : :
7645 : : return;
7646 : :
7647 : 90 : case EXPR_OP:
7648 : 90 : get_array_charlen (expr->value.op.op1, se);
7649 : :
7650 : : /* For parentheses the expression ts.u.cl should be identical. */
7651 : 90 : if (expr->value.op.op == INTRINSIC_PARENTHESES)
7652 : : {
7653 : 2 : if (expr->value.op.op1->ts.u.cl != expr->ts.u.cl)
7654 : 2 : expr->ts.u.cl->backend_decl
7655 : 2 : = expr->value.op.op1->ts.u.cl->backend_decl;
7656 : 2 : return;
7657 : : }
7658 : :
7659 : 176 : expr->ts.u.cl->backend_decl =
7660 : 88 : gfc_create_var (gfc_charlen_type_node, "sln");
7661 : :
7662 : 88 : if (expr->value.op.op2)
7663 : : {
7664 : 88 : get_array_charlen (expr->value.op.op2, se);
7665 : :
7666 : 88 : gcc_assert (expr->value.op.op == INTRINSIC_CONCAT);
7667 : :
7668 : : /* Add the string lengths and assign them to the expression
7669 : : string length backend declaration. */
7670 : 88 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
7671 : : fold_build2_loc (input_location, PLUS_EXPR,
7672 : : gfc_charlen_type_node,
7673 : 88 : expr->value.op.op1->ts.u.cl->backend_decl,
7674 : 88 : expr->value.op.op2->ts.u.cl->backend_decl));
7675 : : }
7676 : : else
7677 : 0 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
7678 : 0 : expr->value.op.op1->ts.u.cl->backend_decl);
7679 : : break;
7680 : :
7681 : 43 : case EXPR_FUNCTION:
7682 : 43 : if (expr->value.function.esym == NULL
7683 : 37 : || expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
7684 : : {
7685 : 6 : gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
7686 : 6 : break;
7687 : : }
7688 : :
7689 : : /* Map expressions involving the dummy arguments onto the actual
7690 : : argument expressions. */
7691 : 37 : gfc_init_interface_mapping (&mapping);
7692 : 37 : formal = gfc_sym_get_dummy_args (expr->symtree->n.sym);
7693 : 37 : arg = expr->value.function.actual;
7694 : :
7695 : : /* Set se = NULL in the calls to the interface mapping, to suppress any
7696 : : backend stuff. */
7697 : 113 : for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
7698 : : {
7699 : 38 : if (!arg->expr)
7700 : 0 : continue;
7701 : 38 : if (formal->sym)
7702 : 38 : gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
7703 : : }
7704 : :
7705 : 37 : gfc_init_se (&tse, NULL);
7706 : :
7707 : : /* Build the expression for the character length and convert it. */
7708 : 37 : gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length);
7709 : :
7710 : 37 : gfc_add_block_to_block (&se->pre, &tse.pre);
7711 : 37 : gfc_add_block_to_block (&se->post, &tse.post);
7712 : 37 : tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
7713 : 74 : tse.expr = fold_build2_loc (input_location, MAX_EXPR,
7714 : 37 : TREE_TYPE (tse.expr), tse.expr,
7715 : 37 : build_zero_cst (TREE_TYPE (tse.expr)));
7716 : 37 : expr->ts.u.cl->backend_decl = tse.expr;
7717 : 37 : gfc_free_interface_mapping (&mapping);
7718 : 37 : break;
7719 : :
7720 : 81 : default:
7721 : 81 : gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
7722 : 81 : break;
7723 : : }
7724 : : }
7725 : :
7726 : :
7727 : : /* Helper function to check dimensions. */
7728 : : static bool
7729 : 48 : transposed_dims (gfc_ss *ss)
7730 : : {
7731 : 48 : int n;
7732 : :
7733 : 138496 : for (n = 0; n < ss->dimen; n++)
7734 : 69056 : if (ss->dim[n] != n)
7735 : : return true;
7736 : : return false;
7737 : : }
7738 : :
7739 : :
7740 : : /* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
7741 : : AR_FULL, suitable for the scalarizer. */
7742 : :
7743 : : static gfc_ss *
7744 : 918 : walk_coarray (gfc_expr *e)
7745 : : {
7746 : 918 : gfc_ss *ss;
7747 : :
7748 : 918 : gcc_assert (gfc_get_corank (e) > 0);
7749 : :
7750 : 918 : ss = gfc_walk_expr (e);
7751 : :
7752 : : /* Fix scalar coarray. */
7753 : 918 : if (ss == gfc_ss_terminator)
7754 : : {
7755 : 194 : gfc_ref *ref;
7756 : :
7757 : 194 : ref = e->ref;
7758 : 287 : while (ref)
7759 : : {
7760 : 287 : if (ref->type == REF_ARRAY
7761 : 194 : && ref->u.ar.codimen > 0)
7762 : : break;
7763 : :
7764 : 93 : ref = ref->next;
7765 : : }
7766 : :
7767 : 194 : gcc_assert (ref != NULL);
7768 : 194 : if (ref->u.ar.type == AR_ELEMENT)
7769 : 194 : ref->u.ar.type = AR_SECTION;
7770 : 194 : ss = gfc_reverse_ss (gfc_walk_array_ref (ss, e, ref));
7771 : : }
7772 : :
7773 : 918 : return ss;
7774 : : }
7775 : :
7776 : :
7777 : : /* Convert an array for passing as an actual argument. Expressions and
7778 : : vector subscripts are evaluated and stored in a temporary, which is then
7779 : : passed. For whole arrays the descriptor is passed. For array sections
7780 : : a modified copy of the descriptor is passed, but using the original data.
7781 : :
7782 : : This function is also used for array pointer assignments, and there
7783 : : are three cases:
7784 : :
7785 : : - se->want_pointer && !se->direct_byref
7786 : : EXPR is an actual argument. On exit, se->expr contains a
7787 : : pointer to the array descriptor.
7788 : :
7789 : : - !se->want_pointer && !se->direct_byref
7790 : : EXPR is an actual argument to an intrinsic function or the
7791 : : left-hand side of a pointer assignment. On exit, se->expr
7792 : : contains the descriptor for EXPR.
7793 : :
7794 : : - !se->want_pointer && se->direct_byref
7795 : : EXPR is the right-hand side of a pointer assignment and
7796 : : se->expr is the descriptor for the previously-evaluated
7797 : : left-hand side. The function creates an assignment from
7798 : : EXPR to se->expr.
7799 : :
7800 : :
7801 : : The se->force_tmp flag disables the non-copying descriptor optimization
7802 : : that is used for transpose. It may be used in cases where there is an
7803 : : alias between the transpose argument and another argument in the same
7804 : : function call. */
7805 : :
7806 : : void
7807 : 129611 : gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
7808 : : {
7809 : 129611 : gfc_ss *ss;
7810 : 129611 : gfc_ss_type ss_type;
7811 : 129611 : gfc_ss_info *ss_info;
7812 : 129611 : gfc_loopinfo loop;
7813 : 129611 : gfc_array_info *info;
7814 : 129611 : int need_tmp;
7815 : 129611 : int n;
7816 : 129611 : tree tmp;
7817 : 129611 : tree desc;
7818 : 129611 : stmtblock_t block;
7819 : 129611 : tree start;
7820 : 129611 : int full;
7821 : 129611 : bool subref_array_target = false;
7822 : 129611 : bool deferred_array_component = false;
7823 : 129611 : bool substr = false;
7824 : 129611 : gfc_expr *arg, *ss_expr;
7825 : :
7826 : 129611 : if (se->want_coarray)
7827 : 918 : ss = walk_coarray (expr);
7828 : : else
7829 : 128693 : ss = gfc_walk_expr (expr);
7830 : :
7831 : 129611 : gcc_assert (ss != NULL);
7832 : 129611 : gcc_assert (ss != gfc_ss_terminator);
7833 : :
7834 : 129611 : ss_info = ss->info;
7835 : 129611 : ss_type = ss_info->type;
7836 : 129611 : ss_expr = ss_info->expr;
7837 : :
7838 : : /* Special case: TRANSPOSE which needs no temporary. */
7839 : 133429 : while (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym
7840 : 133177 : && (arg = gfc_get_noncopying_intrinsic_argument (expr)) != NULL)
7841 : : {
7842 : : /* This is a call to transpose which has already been handled by the
7843 : : scalarizer, so that we just need to get its argument's descriptor. */
7844 : 427 : gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
7845 : 427 : expr = expr->value.function.actual->expr;
7846 : : }
7847 : :
7848 : 129611 : if (!se->direct_byref)
7849 : 249372 : se->unlimited_polymorphic = UNLIMITED_POLY (expr);
7850 : :
7851 : : /* Special case things we know we can pass easily. */
7852 : 129611 : switch (expr->expr_type)
7853 : : {
7854 : 117476 : case EXPR_VARIABLE:
7855 : : /* If we have a linear array section, we can pass it directly.
7856 : : Otherwise we need to copy it into a temporary. */
7857 : :
7858 : 117476 : gcc_assert (ss_type == GFC_SS_SECTION);
7859 : 117476 : gcc_assert (ss_expr == expr);
7860 : 117476 : info = &ss_info->data.array;
7861 : :
7862 : : /* Get the descriptor for the array. */
7863 : 117476 : gfc_conv_ss_descriptor (&se->pre, ss, 0);
7864 : 117476 : desc = info->descriptor;
7865 : :
7866 : : /* The charlen backend decl for deferred character components cannot
7867 : : be used because it is fixed at zero. Instead, the hidden string
7868 : : length component is used. */
7869 : 117476 : if (expr->ts.type == BT_CHARACTER
7870 : 18702 : && expr->ts.deferred
7871 : 2431 : && TREE_CODE (desc) == COMPONENT_REF)
7872 : 117476 : deferred_array_component = true;
7873 : :
7874 : 117476 : substr = info->ref && info->ref->next
7875 : 118097 : && info->ref->next->type == REF_SUBSTRING;
7876 : :
7877 : 117476 : subref_array_target = (is_subref_array (expr)
7878 : 117476 : && (se->direct_byref
7879 : 2223 : || expr->ts.type == BT_CHARACTER));
7880 : 117476 : need_tmp = (gfc_ref_needs_temporary_p (expr->ref)
7881 : 117476 : && !subref_array_target);
7882 : :
7883 : 117476 : if (se->force_tmp)
7884 : : need_tmp = 1;
7885 : 117426 : else if (se->force_no_tmp)
7886 : : need_tmp = 0;
7887 : :
7888 : 111790 : if (need_tmp)
7889 : : full = 0;
7890 : 117336 : else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
7891 : : {
7892 : : /* Create a new descriptor if the array doesn't have one. */
7893 : : full = 0;
7894 : : }
7895 : 73459 : else if (info->ref->u.ar.type == AR_FULL || se->descriptor_only)
7896 : : full = 1;
7897 : 5704 : else if (se->direct_byref)
7898 : : full = 0;
7899 : 5378 : else if (info->ref->u.ar.dimen == 0 && !info->ref->next)
7900 : : full = 1;
7901 : 5266 : else if (info->ref->u.ar.type == AR_SECTION && se->want_pointer)
7902 : : full = 0;
7903 : : else
7904 : 3499 : full = gfc_full_array_ref_p (info->ref, NULL);
7905 : :
7906 : 139473 : if (full && !transposed_dims (ss))
7907 : : {
7908 : 68050 : if (se->direct_byref && !se->byref_noassign)
7909 : : {
7910 : : /* Copy the descriptor for pointer assignments. */
7911 : 916 : gfc_add_modify (&se->pre, se->expr, desc);
7912 : :
7913 : : /* Add any offsets from subreferences. */
7914 : 916 : gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
7915 : : subref_array_target, expr);
7916 : :
7917 : : /* ....and set the span field. */
7918 : 916 : if (ss_info->expr->ts.type == BT_CHARACTER)
7919 : 135 : tmp = gfc_conv_descriptor_span_get (desc);
7920 : : else
7921 : 781 : tmp = gfc_get_array_span (desc, expr);
7922 : 916 : gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp);
7923 : : }
7924 : 67134 : else if (se->want_pointer)
7925 : : {
7926 : : /* We pass full arrays directly. This means that pointers and
7927 : : allocatable arrays should also work. */
7928 : 10618 : se->expr = gfc_build_addr_expr (NULL_TREE, desc);
7929 : : }
7930 : : else
7931 : : {
7932 : 56516 : se->expr = desc;
7933 : : }
7934 : :
7935 : 68050 : if (expr->ts.type == BT_CHARACTER && !deferred_array_component)
7936 : 7761 : se->string_length = gfc_get_expr_charlen (expr);
7937 : : /* The ss_info string length is returned set to the value of the
7938 : : hidden string length component. */
7939 : 60047 : else if (deferred_array_component)
7940 : 242 : se->string_length = ss_info->string_length;
7941 : :
7942 : 68050 : se->class_container = ss_info->class_container;
7943 : :
7944 : 68050 : gfc_free_ss_chain (ss);
7945 : 136225 : return;
7946 : : }
7947 : : break;
7948 : :
7949 : 3391 : case EXPR_FUNCTION:
7950 : : /* A transformational function return value will be a temporary
7951 : : array descriptor. We still need to go through the scalarizer
7952 : : to create the descriptor. Elemental functions are handled as
7953 : : arbitrary expressions, i.e. copy to a temporary. */
7954 : :
7955 : 3391 : if (se->direct_byref)
7956 : : {
7957 : 125 : gcc_assert (ss_type == GFC_SS_FUNCTION && ss_expr == expr);
7958 : :
7959 : : /* For pointer assignments pass the descriptor directly. */
7960 : 125 : if (se->ss == NULL)
7961 : 125 : se->ss = ss;
7962 : : else
7963 : 0 : gcc_assert (se->ss == ss);
7964 : :
7965 : 125 : if (!is_pointer_array (se->expr))
7966 : : {
7967 : 119 : tmp = gfc_get_element_type (TREE_TYPE (se->expr));
7968 : 119 : tmp = fold_convert (gfc_array_index_type,
7969 : : size_in_bytes (tmp));
7970 : 119 : gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp);
7971 : : }
7972 : :
7973 : 125 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
7974 : 125 : gfc_conv_expr (se, expr);
7975 : :
7976 : 125 : gfc_free_ss_chain (ss);
7977 : 125 : return;
7978 : : }
7979 : :
7980 : 3266 : if (ss_expr != expr || ss_type != GFC_SS_FUNCTION)
7981 : : {
7982 : 1911 : if (ss_expr != expr)
7983 : : /* Elemental function. */
7984 : 1194 : gcc_assert ((expr->value.function.esym != NULL
7985 : : && expr->value.function.esym->attr.elemental)
7986 : : || (expr->value.function.isym != NULL
7987 : : && expr->value.function.isym->elemental)
7988 : : || (gfc_expr_attr (expr).proc_pointer
7989 : : && gfc_expr_attr (expr).elemental)
7990 : : || gfc_inline_intrinsic_function_p (expr));
7991 : :
7992 : 1911 : need_tmp = 1;
7993 : 1911 : if (expr->ts.type == BT_CHARACTER
7994 : 35 : && expr->ts.u.cl->length
7995 : 29 : && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
7996 : 13 : get_array_charlen (expr, se);
7997 : :
7998 : : info = NULL;
7999 : : }
8000 : : else
8001 : : {
8002 : : /* Transformational function. */
8003 : 1355 : info = &ss_info->data.array;
8004 : 1355 : need_tmp = 0;
8005 : : }
8006 : : break;
8007 : :
8008 : 8064 : case EXPR_ARRAY:
8009 : : /* Constant array constructors don't need a temporary. */
8010 : 8064 : if (ss_type == GFC_SS_CONSTRUCTOR
8011 : 8064 : && expr->ts.type != BT_CHARACTER
8012 : 14995 : && gfc_constant_array_constructor_p (expr->value.constructor))
8013 : : {
8014 : 5322 : need_tmp = 0;
8015 : 5322 : info = &ss_info->data.array;
8016 : : }
8017 : : else
8018 : : {
8019 : : need_tmp = 1;
8020 : : info = NULL;
8021 : : }
8022 : : break;
8023 : :
8024 : : default:
8025 : : /* Something complicated. Copy it into a temporary. */
8026 : : need_tmp = 1;
8027 : : info = NULL;
8028 : : break;
8029 : : }
8030 : :
8031 : : /* If we are creating a temporary, we don't need to bother about aliases
8032 : : anymore. */
8033 : 61436 : if (need_tmp)
8034 : 5473 : se->force_tmp = 0;
8035 : :
8036 : 61436 : gfc_init_loopinfo (&loop);
8037 : :
8038 : : /* Associate the SS with the loop. */
8039 : 61436 : gfc_add_ss_to_loop (&loop, ss);
8040 : :
8041 : : /* Tell the scalarizer not to bother creating loop variables, etc. */
8042 : 61436 : if (!need_tmp)
8043 : 55963 : loop.array_parameter = 1;
8044 : : else
8045 : : /* The right-hand side of a pointer assignment mustn't use a temporary. */
8046 : 5473 : gcc_assert (!se->direct_byref);
8047 : :
8048 : : /* Do we need bounds checking or not? */
8049 : 61436 : ss->no_bounds_check = expr->no_bounds_check;
8050 : :
8051 : : /* Setup the scalarizing loops and bounds. */
8052 : 61436 : gfc_conv_ss_startstride (&loop);
8053 : :
8054 : : /* Add bounds-checking for elemental dimensions. */
8055 : 61436 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !expr->no_bounds_check)
8056 : 6635 : array_bound_check_elemental (se, ss, expr);
8057 : :
8058 : 61436 : if (need_tmp)
8059 : : {
8060 : 5473 : if (expr->ts.type == BT_CHARACTER
8061 : 1323 : && (!expr->ts.u.cl->backend_decl || expr->expr_type == EXPR_ARRAY))
8062 : 1253 : get_array_charlen (expr, se);
8063 : :
8064 : : /* Tell the scalarizer to make a temporary. */
8065 : 5473 : loop.temp_ss = gfc_get_temp_ss (gfc_typenode_for_spec (&expr->ts),
8066 : 5473 : ((expr->ts.type == BT_CHARACTER)
8067 : 1323 : ? expr->ts.u.cl->backend_decl
8068 : : : NULL),
8069 : : loop.dimen);
8070 : :
8071 : 5473 : se->string_length = loop.temp_ss->info->string_length;
8072 : 5473 : gcc_assert (loop.temp_ss->dimen == loop.dimen);
8073 : 5473 : gfc_add_ss_to_loop (&loop, loop.temp_ss);
8074 : : }
8075 : :
8076 : 61436 : gfc_conv_loop_setup (&loop, & expr->where);
8077 : :
8078 : 61436 : if (need_tmp)
8079 : : {
8080 : : /* Copy into a temporary and pass that. We don't need to copy the data
8081 : : back because expressions and vector subscripts must be INTENT_IN. */
8082 : : /* TODO: Optimize passing function return values. */
8083 : 5473 : gfc_se lse;
8084 : 5473 : gfc_se rse;
8085 : 5473 : bool deep_copy;
8086 : :
8087 : : /* Start the copying loops. */
8088 : 5473 : gfc_mark_ss_chain_used (loop.temp_ss, 1);
8089 : 5473 : gfc_mark_ss_chain_used (ss, 1);
8090 : 5473 : gfc_start_scalarized_body (&loop, &block);
8091 : :
8092 : : /* Copy each data element. */
8093 : 5473 : gfc_init_se (&lse, NULL);
8094 : 5473 : gfc_copy_loopinfo_to_se (&lse, &loop);
8095 : 5473 : gfc_init_se (&rse, NULL);
8096 : 5473 : gfc_copy_loopinfo_to_se (&rse, &loop);
8097 : :
8098 : 5473 : lse.ss = loop.temp_ss;
8099 : 5473 : rse.ss = ss;
8100 : :
8101 : 5473 : gfc_conv_tmp_array_ref (&lse);
8102 : 5473 : if (expr->ts.type == BT_CHARACTER)
8103 : : {
8104 : 1323 : gfc_conv_expr (&rse, expr);
8105 : 1323 : if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
8106 : 1038 : rse.expr = build_fold_indirect_ref_loc (input_location,
8107 : : rse.expr);
8108 : : }
8109 : : else
8110 : 4150 : gfc_conv_expr_val (&rse, expr);
8111 : :
8112 : 5473 : gfc_add_block_to_block (&block, &rse.pre);
8113 : 5473 : gfc_add_block_to_block (&block, &lse.pre);
8114 : :
8115 : 5473 : lse.string_length = rse.string_length;
8116 : :
8117 : 10946 : deep_copy = !se->data_not_needed
8118 : 5473 : && (expr->expr_type == EXPR_VARIABLE
8119 : 5080 : || expr->expr_type == EXPR_ARRAY);
8120 : 5473 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts,
8121 : : deep_copy, false);
8122 : 5473 : gfc_add_expr_to_block (&block, tmp);
8123 : :
8124 : : /* Finish the copying loops. */
8125 : 5473 : gfc_trans_scalarizing_loops (&loop, &block);
8126 : :
8127 : 5473 : desc = loop.temp_ss->info->data.array.descriptor;
8128 : : }
8129 : 57318 : else if (expr->expr_type == EXPR_FUNCTION && !transposed_dims (ss))
8130 : : {
8131 : 1342 : desc = info->descriptor;
8132 : 1342 : se->string_length = ss_info->string_length;
8133 : : }
8134 : : else
8135 : : {
8136 : : /* We pass sections without copying to a temporary. Make a new
8137 : : descriptor and point it at the section we want. The loop variable
8138 : : limits will be the limits of the section.
8139 : : A function may decide to repack the array to speed up access, but
8140 : : we're not bothered about that here. */
8141 : 54621 : int dim, ndim, codim;
8142 : 54621 : tree parm;
8143 : 54621 : tree parmtype;
8144 : 54621 : tree dtype;
8145 : 54621 : tree stride;
8146 : 54621 : tree from;
8147 : 54621 : tree to;
8148 : 54621 : tree base;
8149 : 54621 : tree offset;
8150 : :
8151 : 54621 : ndim = info->ref ? info->ref->u.ar.dimen : ss->dimen;
8152 : :
8153 : 54621 : if (se->want_coarray)
8154 : : {
8155 : 396 : gfc_array_ref *ar = &info->ref->u.ar;
8156 : :
8157 : 396 : codim = gfc_get_corank (expr);
8158 : 1313 : for (n = 0; n < codim - 1; n++)
8159 : : {
8160 : : /* Make sure we are not lost somehow. */
8161 : 521 : gcc_assert (ar->dimen_type[n + ndim] == DIMEN_THIS_IMAGE);
8162 : :
8163 : : /* Make sure the call to gfc_conv_section_startstride won't
8164 : : generate unnecessary code to calculate stride. */
8165 : 521 : gcc_assert (ar->stride[n + ndim] == NULL);
8166 : :
8167 : 521 : gfc_conv_section_startstride (&loop.pre, ss, n + ndim);
8168 : 521 : loop.from[n + loop.dimen] = info->start[n + ndim];
8169 : 521 : loop.to[n + loop.dimen] = info->end[n + ndim];
8170 : : }
8171 : :
8172 : 396 : gcc_assert (n == codim - 1);
8173 : 396 : evaluate_bound (&loop.pre, info->start, ar->start,
8174 : : info->descriptor, n + ndim, true,
8175 : 396 : ar->as->type == AS_DEFERRED);
8176 : 396 : loop.from[n + loop.dimen] = info->start[n + ndim];
8177 : : }
8178 : : else
8179 : : codim = 0;
8180 : :
8181 : : /* Set the string_length for a character array. */
8182 : 54621 : if (expr->ts.type == BT_CHARACTER)
8183 : : {
8184 : 10692 : if (deferred_array_component && !substr)
8185 : 37 : se->string_length = ss_info->string_length;
8186 : : else
8187 : 10655 : se->string_length = gfc_get_expr_charlen (expr);
8188 : :
8189 : 10692 : if (VAR_P (se->string_length)
8190 : 940 : && expr->ts.u.cl->backend_decl == se->string_length)
8191 : 934 : tmp = ss_info->string_length;
8192 : : else
8193 : : tmp = se->string_length;
8194 : :
8195 : 10692 : if (expr->ts.deferred && expr->ts.u.cl->backend_decl
8196 : 172 : && VAR_P (expr->ts.u.cl->backend_decl))
8197 : 112 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, tmp);
8198 : : else
8199 : 10580 : expr->ts.u.cl->backend_decl = tmp;
8200 : : }
8201 : :
8202 : : /* If we have an array section, are assigning or passing an array
8203 : : section argument make sure that the lower bound is 1. References
8204 : : to the full array should otherwise keep the original bounds. */
8205 : 54621 : if (!info->ref || info->ref->u.ar.type != AR_FULL)
8206 : 64762 : for (dim = 0; dim < loop.dimen; dim++)
8207 : 37984 : if (!integer_onep (loop.from[dim]))
8208 : : {
8209 : 18997 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
8210 : : gfc_array_index_type, gfc_index_one_node,
8211 : : loop.from[dim]);
8212 : 18997 : loop.to[dim] = fold_build2_loc (input_location, PLUS_EXPR,
8213 : : gfc_array_index_type,
8214 : : loop.to[dim], tmp);
8215 : 18997 : loop.from[dim] = gfc_index_one_node;
8216 : : }
8217 : :
8218 : 54621 : desc = info->descriptor;
8219 : 54621 : if (se->direct_byref && !se->byref_noassign)
8220 : : {
8221 : : /* For pointer assignments we fill in the destination. */
8222 : 2270 : parm = se->expr;
8223 : 2270 : parmtype = TREE_TYPE (parm);
8224 : : }
8225 : : else
8226 : : {
8227 : : /* Otherwise make a new one. */
8228 : 52351 : if (expr->ts.type == BT_CHARACTER)
8229 : 10111 : parmtype = gfc_typenode_for_spec (&expr->ts);
8230 : : else
8231 : 42240 : parmtype = gfc_get_element_type (TREE_TYPE (desc));
8232 : :
8233 : 52351 : parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, codim,
8234 : : loop.from, loop.to, 0,
8235 : : GFC_ARRAY_UNKNOWN, false);
8236 : 52351 : parm = gfc_create_var (parmtype, "parm");
8237 : :
8238 : : /* When expression is a class object, then add the class' handle to
8239 : : the parm_decl. */
8240 : 52351 : if (expr->ts.type == BT_CLASS && expr->expr_type == EXPR_VARIABLE)
8241 : : {
8242 : 1004 : gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr);
8243 : 1004 : gfc_se classse;
8244 : :
8245 : : /* class_expr can be NULL, when no _class ref is in expr.
8246 : : We must not fix this here with a gfc_fix_class_ref (). */
8247 : 1004 : if (class_expr)
8248 : : {
8249 : 994 : gfc_init_se (&classse, NULL);
8250 : 994 : gfc_conv_expr (&classse, class_expr);
8251 : 994 : gfc_free_expr (class_expr);
8252 : :
8253 : 994 : gcc_assert (classse.pre.head == NULL_TREE
8254 : : && classse.post.head == NULL_TREE);
8255 : 994 : gfc_allocate_lang_decl (parm);
8256 : 994 : GFC_DECL_SAVED_DESCRIPTOR (parm) = classse.expr;
8257 : : }
8258 : : }
8259 : : }
8260 : :
8261 : 54621 : if (expr->ts.type == BT_CHARACTER
8262 : 54621 : && VAR_P (TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (parm)))))
8263 : : {
8264 : 0 : tree elem_len = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (parm)));
8265 : 0 : gfc_add_modify (&loop.pre, elem_len,
8266 : 0 : fold_convert (TREE_TYPE (elem_len),
8267 : : gfc_get_array_span (desc, expr)));
8268 : : }
8269 : :
8270 : : /* Set the span field. */
8271 : 54621 : tmp = NULL_TREE;
8272 : 54621 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
8273 : 5422 : tmp = gfc_conv_descriptor_span_get (desc);
8274 : : else
8275 : 49199 : tmp = gfc_get_array_span (desc, expr);
8276 : 54621 : if (tmp)
8277 : 54541 : gfc_conv_descriptor_span_set (&loop.pre, parm, tmp);
8278 : :
8279 : : /* The following can be somewhat confusing. We have two
8280 : : descriptors, a new one and the original array.
8281 : : {parm, parmtype, dim} refer to the new one.
8282 : : {desc, type, n, loop} refer to the original, which maybe
8283 : : a descriptorless array.
8284 : : The bounds of the scalarization are the bounds of the section.
8285 : : We don't have to worry about numeric overflows when calculating
8286 : : the offsets because all elements are within the array data. */
8287 : :
8288 : : /* Set the dtype. */
8289 : 54621 : tmp = gfc_conv_descriptor_dtype (parm);
8290 : 54621 : if (se->unlimited_polymorphic)
8291 : 487 : dtype = gfc_get_dtype (TREE_TYPE (desc), &loop.dimen);
8292 : 54134 : else if (expr->ts.type == BT_ASSUMED)
8293 : : {
8294 : 127 : tree tmp2 = desc;
8295 : 127 : if (DECL_LANG_SPECIFIC (tmp2) && GFC_DECL_SAVED_DESCRIPTOR (tmp2))
8296 : 127 : tmp2 = GFC_DECL_SAVED_DESCRIPTOR (tmp2);
8297 : 127 : if (POINTER_TYPE_P (TREE_TYPE (tmp2)))
8298 : 127 : tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
8299 : 127 : dtype = gfc_conv_descriptor_dtype (tmp2);
8300 : : }
8301 : : else
8302 : 54007 : dtype = gfc_get_dtype (parmtype);
8303 : 54621 : gfc_add_modify (&loop.pre, tmp, dtype);
8304 : :
8305 : : /* The 1st element in the section. */
8306 : 54621 : base = gfc_index_zero_node;
8307 : :
8308 : : /* The offset from the 1st element in the section. */
8309 : 54621 : offset = gfc_index_zero_node;
8310 : :
8311 : 137566 : for (n = 0; n < ndim; n++)
8312 : : {
8313 : 82945 : stride = gfc_conv_array_stride (desc, n);
8314 : :
8315 : : /* Work out the 1st element in the section. */
8316 : 82945 : if (info->ref
8317 : 77447 : && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
8318 : : {
8319 : 848 : gcc_assert (info->subscript[n]
8320 : : && info->subscript[n]->info->type == GFC_SS_SCALAR);
8321 : 848 : start = info->subscript[n]->info->data.scalar.value;
8322 : : }
8323 : : else
8324 : : {
8325 : : /* Evaluate and remember the start of the section. */
8326 : 82097 : start = info->start[n];
8327 : 82097 : stride = gfc_evaluate_now (stride, &loop.pre);
8328 : : }
8329 : :
8330 : 82945 : tmp = gfc_conv_array_lbound (desc, n);
8331 : 82945 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
8332 : : start, tmp);
8333 : 82945 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
8334 : : tmp, stride);
8335 : 82945 : base = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
8336 : : base, tmp);
8337 : :
8338 : 82945 : if (info->ref
8339 : 77447 : && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
8340 : : {
8341 : : /* For elemental dimensions, we only need the 1st
8342 : : element in the section. */
8343 : 848 : continue;
8344 : : }
8345 : :
8346 : : /* Vector subscripts need copying and are handled elsewhere. */
8347 : 82097 : if (info->ref)
8348 : 76599 : gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
8349 : :
8350 : : /* look for the corresponding scalarizer dimension: dim. */
8351 : 118921 : for (dim = 0; dim < ndim; dim++)
8352 : 118921 : if (ss->dim[dim] == n)
8353 : : break;
8354 : :
8355 : : /* loop exited early: the DIM being looked for has been found. */
8356 : 82097 : gcc_assert (dim < ndim);
8357 : :
8358 : : /* Set the new lower bound. */
8359 : 82097 : from = loop.from[dim];
8360 : 82097 : to = loop.to[dim];
8361 : :
8362 : 82097 : gfc_conv_descriptor_lbound_set (&loop.pre, parm,
8363 : : gfc_rank_cst[dim], from);
8364 : :
8365 : : /* Set the new upper bound. */
8366 : 82097 : gfc_conv_descriptor_ubound_set (&loop.pre, parm,
8367 : : gfc_rank_cst[dim], to);
8368 : :
8369 : : /* Multiply the stride by the section stride to get the
8370 : : total stride. */
8371 : 82097 : stride = fold_build2_loc (input_location, MULT_EXPR,
8372 : : gfc_array_index_type,
8373 : : stride, info->stride[n]);
8374 : :
8375 : 82097 : tmp = fold_build2_loc (input_location, MULT_EXPR,
8376 : 82097 : TREE_TYPE (offset), stride, from);
8377 : 82097 : offset = fold_build2_loc (input_location, MINUS_EXPR,
8378 : 82097 : TREE_TYPE (offset), offset, tmp);
8379 : :
8380 : : /* Store the new stride. */
8381 : 82097 : gfc_conv_descriptor_stride_set (&loop.pre, parm,
8382 : : gfc_rank_cst[dim], stride);
8383 : : }
8384 : :
8385 : 55538 : for (n = loop.dimen; n < loop.dimen + codim; n++)
8386 : : {
8387 : 917 : from = loop.from[n];
8388 : 917 : to = loop.to[n];
8389 : 917 : gfc_conv_descriptor_lbound_set (&loop.pre, parm,
8390 : : gfc_rank_cst[n], from);
8391 : 917 : if (n < loop.dimen + codim - 1)
8392 : 521 : gfc_conv_descriptor_ubound_set (&loop.pre, parm,
8393 : : gfc_rank_cst[n], to);
8394 : : }
8395 : :
8396 : 54621 : if (se->data_not_needed)
8397 : 5719 : gfc_conv_descriptor_data_set (&loop.pre, parm,
8398 : : gfc_index_zero_node);
8399 : : else
8400 : : /* Point the data pointer at the 1st element in the section. */
8401 : 48902 : gfc_get_dataptr_offset (&loop.pre, parm, desc, base,
8402 : : subref_array_target, expr);
8403 : :
8404 : 54621 : gfc_conv_descriptor_offset_set (&loop.pre, parm, offset);
8405 : :
8406 : 54621 : desc = parm;
8407 : : }
8408 : :
8409 : : /* For class arrays add the class tree into the saved descriptor to
8410 : : enable getting of _vptr and the like. */
8411 : 61436 : if (expr->expr_type == EXPR_VARIABLE && VAR_P (desc)
8412 : 48802 : && IS_CLASS_ARRAY (expr->symtree->n.sym))
8413 : : {
8414 : 995 : gfc_allocate_lang_decl (desc);
8415 : 995 : GFC_DECL_SAVED_DESCRIPTOR (desc) =
8416 : 995 : DECL_LANG_SPECIFIC (expr->symtree->n.sym->backend_decl) ?
8417 : 909 : GFC_DECL_SAVED_DESCRIPTOR (expr->symtree->n.sym->backend_decl)
8418 : : : expr->symtree->n.sym->backend_decl;
8419 : : }
8420 : 60441 : else if (expr->expr_type == EXPR_ARRAY && VAR_P (desc)
8421 : 8064 : && IS_CLASS_ARRAY (expr))
8422 : : {
8423 : 12 : tree vtype;
8424 : 12 : gfc_allocate_lang_decl (desc);
8425 : 12 : tmp = gfc_create_var (expr->ts.u.derived->backend_decl, "class");
8426 : 12 : GFC_DECL_SAVED_DESCRIPTOR (desc) = tmp;
8427 : 12 : vtype = gfc_class_vptr_get (tmp);
8428 : 12 : gfc_add_modify (&se->pre, vtype,
8429 : 12 : gfc_build_addr_expr (TREE_TYPE (vtype),
8430 : 12 : gfc_find_vtab (&expr->ts)->backend_decl));
8431 : : }
8432 : 61436 : if (!se->direct_byref || se->byref_noassign)
8433 : : {
8434 : : /* Get a pointer to the new descriptor. */
8435 : 59166 : if (se->want_pointer)
8436 : 30136 : se->expr = gfc_build_addr_expr (NULL_TREE, desc);
8437 : : else
8438 : 29030 : se->expr = desc;
8439 : : }
8440 : :
8441 : 61436 : gfc_add_block_to_block (&se->pre, &loop.pre);
8442 : 61436 : gfc_add_block_to_block (&se->post, &loop.post);
8443 : :
8444 : : /* Cleanup the scalarizer. */
8445 : 61436 : gfc_cleanup_loop (&loop);
8446 : : }
8447 : :
8448 : :
8449 : : /* Calculate the array size (number of elements); if dim != NULL_TREE,
8450 : : return size for that dim (dim=0..rank-1; only for GFC_DESCRIPTOR_TYPE_P). */
8451 : : tree
8452 : 13445 : gfc_tree_array_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree dim)
8453 : : {
8454 : 13445 : if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
8455 : : {
8456 : 34 : gcc_assert (dim == NULL_TREE);
8457 : 34 : return GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
8458 : : }
8459 : 13411 : tree size, tmp, rank = NULL_TREE, cond = NULL_TREE;
8460 : 13411 : symbol_attribute attr = gfc_expr_attr (expr);
8461 : 13411 : gfc_array_spec *as = gfc_get_full_arrayspec_from_expr (expr);
8462 : 13411 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
8463 : 13411 : if ((!attr.pointer && !attr.allocatable && as && as->type == AS_ASSUMED_RANK)
8464 : 10802 : || !dim)
8465 : : {
8466 : 7767 : if (expr->rank < 0)
8467 : 2743 : rank = fold_convert (signed_char_type_node,
8468 : : gfc_conv_descriptor_rank (desc));
8469 : : else
8470 : 5024 : rank = build_int_cst (signed_char_type_node, expr->rank);
8471 : : }
8472 : :
8473 : 7767 : if (dim || expr->rank == 1)
8474 : : {
8475 : 9616 : if (!dim)
8476 : 3972 : dim = gfc_index_zero_node;
8477 : 11826 : tree ubound = gfc_conv_descriptor_ubound_get (desc, dim);
8478 : 11826 : tree lbound = gfc_conv_descriptor_lbound_get (desc, dim);
8479 : :
8480 : 11826 : size = fold_build2_loc (input_location, MINUS_EXPR,
8481 : : gfc_array_index_type, ubound, lbound);
8482 : 11826 : size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
8483 : : size, gfc_index_one_node);
8484 : : /* if (!allocatable && !pointer && assumed rank)
8485 : : size = (idx == rank && ubound[rank-1] == -1 ? -1 : size;
8486 : : else
8487 : : size = max (0, size); */
8488 : 11826 : size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
8489 : : size, gfc_index_zero_node);
8490 : 11826 : if (!attr.pointer && !attr.allocatable
8491 : 7277 : && as && as->type == AS_ASSUMED_RANK)
8492 : : {
8493 : 2210 : tmp = fold_build2_loc (input_location, MINUS_EXPR, signed_char_type_node,
8494 : 2210 : rank, build_int_cst (signed_char_type_node, 1));
8495 : 2210 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
8496 : : fold_convert (signed_char_type_node, dim),
8497 : : tmp);
8498 : 2210 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
8499 : : gfc_conv_descriptor_ubound_get (desc, dim),
8500 : 2210 : build_int_cst (gfc_array_index_type, -1));
8501 : 2210 : cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
8502 : : cond, tmp);
8503 : 2210 : tmp = build_int_cst (gfc_array_index_type, -1);
8504 : 2210 : size = build3_loc (input_location, COND_EXPR, gfc_array_index_type,
8505 : : cond, tmp, size);
8506 : : }
8507 : 11826 : return size;
8508 : : }
8509 : :
8510 : : /* size = 1. */
8511 : 1585 : size = gfc_create_var (gfc_array_index_type, "size");
8512 : 1585 : gfc_add_modify (block, size, build_int_cst (TREE_TYPE (size), 1));
8513 : 1585 : tree extent = gfc_create_var (gfc_array_index_type, "extent");
8514 : :
8515 : 1585 : stmtblock_t cond_block, loop_body;
8516 : 1585 : gfc_init_block (&cond_block);
8517 : 1585 : gfc_init_block (&loop_body);
8518 : :
8519 : : /* Loop: for (i = 0; i < rank; ++i). */
8520 : 1585 : tree idx = gfc_create_var (signed_char_type_node, "idx");
8521 : : /* Loop body. */
8522 : : /* #if (assumed-rank + !allocatable && !pointer)
8523 : : if (idx == rank - 1 && dim[idx].ubound == -1)
8524 : : extent = -1;
8525 : : else
8526 : : #endif
8527 : : extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1
8528 : : if (extent < 0)
8529 : : extent = 0
8530 : : size *= extent. */
8531 : 1585 : cond = NULL_TREE;
8532 : 1585 : if (!attr.pointer && !attr.allocatable && as && as->type == AS_ASSUMED_RANK)
8533 : : {
8534 : 399 : tmp = fold_build2_loc (input_location, MINUS_EXPR, signed_char_type_node,
8535 : 399 : rank, build_int_cst (signed_char_type_node, 1));
8536 : 399 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
8537 : : idx, tmp);
8538 : 399 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
8539 : : gfc_conv_descriptor_ubound_get (desc, idx),
8540 : 399 : build_int_cst (gfc_array_index_type, -1));
8541 : 399 : cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
8542 : : cond, tmp);
8543 : : }
8544 : 1585 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8545 : : gfc_conv_descriptor_ubound_get (desc, idx),
8546 : : gfc_conv_descriptor_lbound_get (desc, idx));
8547 : 1585 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
8548 : : tmp, gfc_index_one_node);
8549 : 1585 : gfc_add_modify (&cond_block, extent, tmp);
8550 : 1585 : tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
8551 : : extent, gfc_index_zero_node);
8552 : 1585 : tmp = build3_v (COND_EXPR, tmp,
8553 : : fold_build2_loc (input_location, MODIFY_EXPR,
8554 : : gfc_array_index_type,
8555 : : extent, gfc_index_zero_node),
8556 : : build_empty_stmt (input_location));
8557 : 1585 : gfc_add_expr_to_block (&cond_block, tmp);
8558 : 1585 : tmp = gfc_finish_block (&cond_block);
8559 : 1585 : if (cond)
8560 : 399 : tmp = build3_v (COND_EXPR, cond,
8561 : : fold_build2_loc (input_location, MODIFY_EXPR,
8562 : : gfc_array_index_type, extent,
8563 : : build_int_cst (gfc_array_index_type, -1)),
8564 : : tmp);
8565 : 1585 : gfc_add_expr_to_block (&loop_body, tmp);
8566 : : /* size *= extent. */
8567 : 1585 : gfc_add_modify (&loop_body, size,
8568 : : fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
8569 : : size, extent));
8570 : : /* Generate loop. */
8571 : 1585 : gfc_simple_for_loop (block, idx, build_int_cst (TREE_TYPE (idx), 0), rank, LT_EXPR,
8572 : 1585 : build_int_cst (TREE_TYPE (idx), 1),
8573 : : gfc_finish_block (&loop_body));
8574 : 1585 : return size;
8575 : : }
8576 : :
8577 : : /* Helper function for gfc_conv_array_parameter if array size needs to be
8578 : : computed. */
8579 : :
8580 : : static void
8581 : 102 : array_parameter_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree *size)
8582 : : {
8583 : 102 : tree elem;
8584 : 102 : *size = gfc_tree_array_size (block, desc, expr, NULL);
8585 : 102 : elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
8586 : 102 : *size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
8587 : : *size, fold_convert (gfc_array_index_type, elem));
8588 : 102 : }
8589 : :
8590 : : /* Helper function - return true if the argument is a pointer. */
8591 : :
8592 : : static bool
8593 : 733 : is_pointer (gfc_expr *e)
8594 : : {
8595 : 733 : gfc_symbol *sym;
8596 : :
8597 : 733 : if (e->expr_type != EXPR_VARIABLE || e->symtree == NULL)
8598 : : return false;
8599 : :
8600 : 733 : sym = e->symtree->n.sym;
8601 : 733 : if (sym == NULL)
8602 : : return false;
8603 : :
8604 : 733 : return sym->attr.pointer || sym->attr.proc_pointer;
8605 : : }
8606 : :
8607 : : /* Convert an array for passing as an actual parameter. */
8608 : :
8609 : : void
8610 : 50620 : gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
8611 : : const gfc_symbol *fsym, const char *proc_name,
8612 : : tree *size)
8613 : : {
8614 : 50620 : tree ptr;
8615 : 50620 : tree desc;
8616 : 50620 : tree tmp = NULL_TREE;
8617 : 50620 : tree stmt;
8618 : 50620 : tree parent = DECL_CONTEXT (current_function_decl);
8619 : 50620 : bool full_array_var;
8620 : 50620 : bool this_array_result;
8621 : 50620 : bool contiguous;
8622 : 50620 : bool no_pack;
8623 : 50620 : bool array_constructor;
8624 : 50620 : bool good_allocatable;
8625 : 50620 : bool ultimate_ptr_comp;
8626 : 50620 : bool ultimate_alloc_comp;
8627 : 50620 : gfc_symbol *sym;
8628 : 50620 : stmtblock_t block;
8629 : 50620 : gfc_ref *ref;
8630 : :
8631 : 50620 : ultimate_ptr_comp = false;
8632 : 50620 : ultimate_alloc_comp = false;
8633 : :
8634 : 51152 : for (ref = expr->ref; ref; ref = ref->next)
8635 : : {
8636 : 42833 : if (ref->next == NULL)
8637 : : break;
8638 : :
8639 : 532 : if (ref->type == REF_COMPONENT)
8640 : : {
8641 : 460 : ultimate_ptr_comp = ref->u.c.component->attr.pointer;
8642 : 460 : ultimate_alloc_comp = ref->u.c.component->attr.allocatable;
8643 : : }
8644 : : }
8645 : :
8646 : 50620 : full_array_var = false;
8647 : 50620 : contiguous = false;
8648 : :
8649 : 50620 : if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp)
8650 : 42224 : full_array_var = gfc_full_array_ref_p (ref, &contiguous);
8651 : :
8652 : 42224 : sym = full_array_var ? expr->symtree->n.sym : NULL;
8653 : :
8654 : : /* The symbol should have an array specification. */
8655 : 47870 : gcc_assert (!sym || sym->as || ref->u.ar.as);
8656 : :
8657 : 50620 : if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
8658 : : {
8659 : 667 : get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
8660 : 667 : expr->ts.u.cl->backend_decl = tmp;
8661 : 667 : se->string_length = tmp;
8662 : : }
8663 : :
8664 : : /* Is this the result of the enclosing procedure? */
8665 : 50620 : this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
8666 : 58 : if (this_array_result
8667 : 58 : && (sym->backend_decl != current_function_decl)
8668 : 0 : && (sym->backend_decl != parent))
8669 : 50620 : this_array_result = false;
8670 : :
8671 : : /* Passing address of the array if it is not pointer or assumed-shape. */
8672 : 50620 : if (full_array_var && g77 && !this_array_result
8673 : 13739 : && sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
8674 : : {
8675 : 10901 : tmp = gfc_get_symbol_decl (sym);
8676 : :
8677 : 10901 : if (sym->ts.type == BT_CHARACTER)
8678 : 2709 : se->string_length = sym->ts.u.cl->backend_decl;
8679 : :
8680 : 10901 : if (!sym->attr.pointer
8681 : 10402 : && sym->as
8682 : 10402 : && sym->as->type != AS_ASSUMED_SHAPE
8683 : 10145 : && sym->as->type != AS_DEFERRED
8684 : 9110 : && sym->as->type != AS_ASSUMED_RANK
8685 : 9042 : && !sym->attr.allocatable)
8686 : : {
8687 : : /* Some variables are declared directly, others are declared as
8688 : : pointers and allocated on the heap. */
8689 : 9042 : if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
8690 : 2464 : se->expr = tmp;
8691 : : else
8692 : 6578 : se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
8693 : 9042 : if (size)
8694 : 34 : array_parameter_size (&se->pre, tmp, expr, size);
8695 : 14588 : return;
8696 : : }
8697 : :
8698 : 1859 : if (sym->attr.allocatable)
8699 : : {
8700 : 915 : if (sym->attr.dummy || sym->attr.result)
8701 : : {
8702 : 292 : gfc_conv_expr_descriptor (se, expr);
8703 : 292 : tmp = se->expr;
8704 : : }
8705 : 915 : if (size)
8706 : 6 : array_parameter_size (&se->pre, tmp, expr, size);
8707 : 915 : se->expr = gfc_conv_array_data (tmp);
8708 : 915 : return;
8709 : : }
8710 : : }
8711 : :
8712 : : /* A convenient reduction in scope. */
8713 : 40663 : contiguous = g77 && !this_array_result && contiguous;
8714 : :
8715 : : /* There is no need to pack and unpack the array, if it is contiguous
8716 : : and not a deferred- or assumed-shape array, or if it is simply
8717 : : contiguous. */
8718 : 29592 : no_pack = ((sym && sym->as
8719 : 29281 : && !sym->attr.pointer
8720 : 26501 : && sym->as->type != AS_DEFERRED
8721 : 21039 : && sym->as->type != AS_ASSUMED_RANK
8722 : 18676 : && sym->as->type != AS_ASSUMED_SHAPE)
8723 : 23146 : ||
8724 : 14827 : (ref && ref->u.ar.as
8725 : 14825 : && ref->u.ar.as->type != AS_DEFERRED
8726 : 5773 : && ref->u.ar.as->type != AS_ASSUMED_RANK
8727 : 3360 : && ref->u.ar.as->type != AS_ASSUMED_SHAPE)
8728 : 61663 : ||
8729 : 21000 : gfc_is_simply_contiguous (expr, false, true));
8730 : :
8731 : 40663 : no_pack = contiguous && no_pack;
8732 : :
8733 : : /* If we have an EXPR_OP or a function returning an explicit-shaped
8734 : : or allocatable array, an array temporary will be generated which
8735 : : does not need to be packed / unpacked if passed to an
8736 : : explicit-shape dummy array. */
8737 : :
8738 : 40663 : if (g77)
8739 : : {
8740 : 5686 : if (expr->expr_type == EXPR_OP)
8741 : : no_pack = 1;
8742 : 5609 : else if (expr->expr_type == EXPR_FUNCTION && expr->value.function.esym)
8743 : : {
8744 : 41 : gfc_symbol *result = expr->value.function.esym->result;
8745 : 41 : if (result->attr.dimension
8746 : 41 : && (result->as->type == AS_EXPLICIT
8747 : : || result->attr.allocatable
8748 : 14 : || result->attr.contiguous))
8749 : 40663 : no_pack = 1;
8750 : : }
8751 : : }
8752 : :
8753 : : /* Array constructors are always contiguous and do not need packing. */
8754 : 40663 : array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY;
8755 : :
8756 : : /* Same is true of contiguous sections from allocatable variables. */
8757 : 81326 : good_allocatable = contiguous
8758 : 3911 : && expr->symtree
8759 : 44574 : && expr->symtree->n.sym->attr.allocatable;
8760 : :
8761 : : /* Or ultimate allocatable components. */
8762 : 40663 : ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
8763 : :
8764 : 40663 : if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp)
8765 : : {
8766 : 4241 : gfc_conv_expr_descriptor (se, expr);
8767 : : /* Deallocate the allocatable components of structures that are
8768 : : not variable. */
8769 : 4241 : if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
8770 : 2759 : && expr->ts.u.derived->attr.alloc_comp
8771 : 1505 : && expr->expr_type != EXPR_VARIABLE)
8772 : : {
8773 : 2 : tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, se->expr, expr->rank);
8774 : :
8775 : : /* The components shall be deallocated before their containing entity. */
8776 : 2 : gfc_prepend_expr_to_block (&se->post, tmp);
8777 : : }
8778 : 4241 : if (expr->ts.type == BT_CHARACTER && expr->expr_type != EXPR_FUNCTION)
8779 : 279 : se->string_length = expr->ts.u.cl->backend_decl;
8780 : 4241 : if (size)
8781 : 32 : array_parameter_size (&se->pre, se->expr, expr, size);
8782 : 4241 : se->expr = gfc_conv_array_data (se->expr);
8783 : 4241 : return;
8784 : : }
8785 : :
8786 : 36422 : if (this_array_result)
8787 : : {
8788 : : /* Result of the enclosing function. */
8789 : 58 : gfc_conv_expr_descriptor (se, expr);
8790 : 58 : if (size)
8791 : 0 : array_parameter_size (&se->pre, se->expr, expr, size);
8792 : 58 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
8793 : :
8794 : 18 : if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
8795 : 76 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
8796 : 18 : se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location,
8797 : : se->expr));
8798 : :
8799 : 58 : return;
8800 : : }
8801 : : else
8802 : : {
8803 : : /* Every other type of array. */
8804 : 36364 : se->want_pointer = 1;
8805 : 36364 : gfc_conv_expr_descriptor (se, expr);
8806 : :
8807 : 36364 : if (size)
8808 : 30 : array_parameter_size (&se->pre,
8809 : : build_fold_indirect_ref_loc (input_location,
8810 : : se->expr),
8811 : : expr, size);
8812 : : }
8813 : :
8814 : : /* Deallocate the allocatable components of structures that are
8815 : : not variable, for descriptorless arguments.
8816 : : Arguments with a descriptor are handled in gfc_conv_procedure_call. */
8817 : 36364 : if (g77 && (expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
8818 : 66 : && expr->ts.u.derived->attr.alloc_comp
8819 : 12 : && expr->expr_type != EXPR_VARIABLE)
8820 : : {
8821 : 0 : tmp = build_fold_indirect_ref_loc (input_location, se->expr);
8822 : 0 : tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank);
8823 : :
8824 : : /* The components shall be deallocated before their containing entity. */
8825 : 0 : gfc_prepend_expr_to_block (&se->post, tmp);
8826 : : }
8827 : :
8828 : 34937 : if (g77 || (fsym && fsym->attr.contiguous
8829 : 1359 : && !gfc_is_simply_contiguous (expr, false, true)))
8830 : : {
8831 : 1475 : tree origptr = NULL_TREE;
8832 : :
8833 : 1475 : desc = se->expr;
8834 : :
8835 : : /* For contiguous arrays, save the original value of the descriptor. */
8836 : 1475 : if (!g77)
8837 : : {
8838 : 48 : origptr = gfc_create_var (pvoid_type_node, "origptr");
8839 : 48 : tmp = build_fold_indirect_ref_loc (input_location, desc);
8840 : 48 : tmp = gfc_conv_array_data (tmp);
8841 : 96 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
8842 : 48 : TREE_TYPE (origptr), origptr,
8843 : 48 : fold_convert (TREE_TYPE (origptr), tmp));
8844 : 48 : gfc_add_expr_to_block (&se->pre, tmp);
8845 : : }
8846 : :
8847 : : /* Repack the array. */
8848 : 1475 : if (warn_array_temporaries)
8849 : : {
8850 : 28 : if (fsym)
8851 : 18 : gfc_warning (OPT_Warray_temporaries,
8852 : : "Creating array temporary at %L for argument %qs",
8853 : 18 : &expr->where, fsym->name);
8854 : : else
8855 : 10 : gfc_warning (OPT_Warray_temporaries,
8856 : : "Creating array temporary at %L", &expr->where);
8857 : : }
8858 : :
8859 : : /* When optimizing, we can use gfc_conv_subref_array_arg for
8860 : : making the packing and unpacking operation visible to the
8861 : : optimizers. */
8862 : :
8863 : 1427 : if (g77 && flag_inline_arg_packing && expr->expr_type == EXPR_VARIABLE
8864 : 733 : && !is_pointer (expr) && ! gfc_has_dimen_vector_ref (expr)
8865 : 353 : && !(expr->symtree->n.sym->as
8866 : 339 : && expr->symtree->n.sym->as->type == AS_ASSUMED_RANK)
8867 : 1828 : && (fsym == NULL || fsym->ts.type != BT_ASSUMED))
8868 : : {
8869 : 332 : gfc_conv_subref_array_arg (se, expr, g77,
8870 : 170 : fsym ? fsym->attr.intent : INTENT_INOUT,
8871 : : false, fsym, proc_name, sym, true);
8872 : 332 : return;
8873 : : }
8874 : :
8875 : 1143 : ptr = build_call_expr_loc (input_location,
8876 : : gfor_fndecl_in_pack, 1, desc);
8877 : :
8878 : 1143 : if (fsym && fsym->attr.optional && sym && sym->attr.optional)
8879 : : {
8880 : 5 : tmp = gfc_conv_expr_present (sym);
8881 : 10 : ptr = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
8882 : 5 : tmp, fold_convert (TREE_TYPE (se->expr), ptr),
8883 : 5 : fold_convert (TREE_TYPE (se->expr), null_pointer_node));
8884 : : }
8885 : :
8886 : 1143 : ptr = gfc_evaluate_now (ptr, &se->pre);
8887 : :
8888 : : /* Use the packed data for the actual argument, except for contiguous arrays,
8889 : : where the descriptor's data component is set. */
8890 : 1143 : if (g77)
8891 : 1095 : se->expr = ptr;
8892 : : else
8893 : : {
8894 : 48 : tmp = build_fold_indirect_ref_loc (input_location, desc);
8895 : :
8896 : 48 : gfc_ss * ss = gfc_walk_expr (expr);
8897 : 96 : if (!transposed_dims (ss))
8898 : 48 : gfc_conv_descriptor_data_set (&se->pre, tmp, ptr);
8899 : : else
8900 : : {
8901 : 0 : tree old_field, new_field;
8902 : :
8903 : : /* The original descriptor has transposed dims so we can't reuse
8904 : : it directly; we have to create a new one. */
8905 : 0 : tree old_desc = tmp;
8906 : 0 : tree new_desc = gfc_create_var (TREE_TYPE (old_desc), "arg_desc");
8907 : :
8908 : 0 : old_field = gfc_conv_descriptor_dtype (old_desc);
8909 : 0 : new_field = gfc_conv_descriptor_dtype (new_desc);
8910 : 0 : gfc_add_modify (&se->pre, new_field, old_field);
8911 : :
8912 : 0 : old_field = gfc_conv_descriptor_offset (old_desc);
8913 : 0 : new_field = gfc_conv_descriptor_offset (new_desc);
8914 : 0 : gfc_add_modify (&se->pre, new_field, old_field);
8915 : :
8916 : 0 : for (int i = 0; i < expr->rank; i++)
8917 : : {
8918 : 0 : old_field = gfc_conv_descriptor_dimension (old_desc,
8919 : 0 : gfc_rank_cst[get_array_ref_dim_for_loop_dim (ss, i)]);
8920 : 0 : new_field = gfc_conv_descriptor_dimension (new_desc,
8921 : : gfc_rank_cst[i]);
8922 : 0 : gfc_add_modify (&se->pre, new_field, old_field);
8923 : : }
8924 : :
8925 : 0 : if (flag_coarray == GFC_FCOARRAY_LIB
8926 : 0 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (old_desc))
8927 : 0 : && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (old_desc))
8928 : : == GFC_ARRAY_ALLOCATABLE)
8929 : : {
8930 : 0 : old_field = gfc_conv_descriptor_token (old_desc);
8931 : 0 : new_field = gfc_conv_descriptor_token (new_desc);
8932 : 0 : gfc_add_modify (&se->pre, new_field, old_field);
8933 : : }
8934 : :
8935 : 0 : gfc_conv_descriptor_data_set (&se->pre, new_desc, ptr);
8936 : 0 : se->expr = gfc_build_addr_expr (NULL_TREE, new_desc);
8937 : : }
8938 : 48 : gfc_free_ss (ss);
8939 : : }
8940 : :
8941 : 1143 : if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
8942 : : {
8943 : 2 : char * msg;
8944 : :
8945 : 2 : if (fsym && proc_name)
8946 : 2 : msg = xasprintf ("An array temporary was created for argument "
8947 : 2 : "'%s' of procedure '%s'", fsym->name, proc_name);
8948 : : else
8949 : 0 : msg = xasprintf ("An array temporary was created");
8950 : :
8951 : 2 : tmp = build_fold_indirect_ref_loc (input_location,
8952 : : desc);
8953 : 2 : tmp = gfc_conv_array_data (tmp);
8954 : 2 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
8955 : 2 : fold_convert (TREE_TYPE (tmp), ptr), tmp);
8956 : :
8957 : 2 : if (fsym && fsym->attr.optional && sym && sym->attr.optional)
8958 : 0 : tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
8959 : : logical_type_node,
8960 : : gfc_conv_expr_present (sym), tmp);
8961 : :
8962 : 2 : gfc_trans_runtime_check (false, true, tmp, &se->pre,
8963 : : &expr->where, msg);
8964 : 2 : free (msg);
8965 : : }
8966 : :
8967 : 1143 : gfc_start_block (&block);
8968 : :
8969 : : /* Copy the data back. */
8970 : 1143 : if (fsym == NULL || fsym->attr.intent != INTENT_IN)
8971 : : {
8972 : 1058 : tmp = build_call_expr_loc (input_location,
8973 : : gfor_fndecl_in_unpack, 2, desc, ptr);
8974 : 1058 : gfc_add_expr_to_block (&block, tmp);
8975 : : }
8976 : :
8977 : : /* Free the temporary. */
8978 : 1143 : tmp = gfc_call_free (ptr);
8979 : 1143 : gfc_add_expr_to_block (&block, tmp);
8980 : :
8981 : 1143 : stmt = gfc_finish_block (&block);
8982 : :
8983 : 1143 : gfc_init_block (&block);
8984 : : /* Only if it was repacked. This code needs to be executed before the
8985 : : loop cleanup code. */
8986 : 1143 : tmp = build_fold_indirect_ref_loc (input_location,
8987 : : desc);
8988 : 1143 : tmp = gfc_conv_array_data (tmp);
8989 : 1143 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
8990 : 1143 : fold_convert (TREE_TYPE (tmp), ptr), tmp);
8991 : :
8992 : 1143 : if (fsym && fsym->attr.optional && sym && sym->attr.optional)
8993 : 5 : tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
8994 : : logical_type_node,
8995 : : gfc_conv_expr_present (sym), tmp);
8996 : :
8997 : 1143 : tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
8998 : :
8999 : 1143 : gfc_add_expr_to_block (&block, tmp);
9000 : 1143 : gfc_add_block_to_block (&block, &se->post);
9001 : :
9002 : 1143 : gfc_init_block (&se->post);
9003 : :
9004 : : /* Reset the descriptor pointer. */
9005 : 1143 : if (!g77)
9006 : : {
9007 : 48 : tmp = build_fold_indirect_ref_loc (input_location, desc);
9008 : 48 : gfc_conv_descriptor_data_set (&se->post, tmp, origptr);
9009 : : }
9010 : :
9011 : 1143 : gfc_add_block_to_block (&se->post, &block);
9012 : : }
9013 : : }
9014 : :
9015 : :
9016 : : /* This helper function calculates the size in words of a full array. */
9017 : :
9018 : : tree
9019 : 14864 : gfc_full_array_size (stmtblock_t *block, tree decl, int rank)
9020 : : {
9021 : 14864 : tree idx;
9022 : 14864 : tree nelems;
9023 : 14864 : tree tmp;
9024 : 14864 : idx = gfc_rank_cst[rank - 1];
9025 : 14864 : nelems = gfc_conv_descriptor_ubound_get (decl, idx);
9026 : 14864 : tmp = gfc_conv_descriptor_lbound_get (decl, idx);
9027 : 14864 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
9028 : : nelems, tmp);
9029 : 14864 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
9030 : : tmp, gfc_index_one_node);
9031 : 14864 : tmp = gfc_evaluate_now (tmp, block);
9032 : :
9033 : 14864 : nelems = gfc_conv_descriptor_stride_get (decl, idx);
9034 : 14864 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9035 : : nelems, tmp);
9036 : 14864 : return gfc_evaluate_now (tmp, block);
9037 : : }
9038 : :
9039 : :
9040 : : /* Allocate dest to the same size as src, and copy src -> dest.
9041 : : If no_malloc is set, only the copy is done. */
9042 : :
9043 : : static tree
9044 : 6231 : duplicate_allocatable (tree dest, tree src, tree type, int rank,
9045 : : bool no_malloc, bool no_memcpy, tree str_sz,
9046 : : tree add_when_allocated)
9047 : : {
9048 : 6231 : tree tmp;
9049 : 6231 : tree eltype;
9050 : 6231 : tree size;
9051 : 6231 : tree nelems;
9052 : 6231 : tree null_cond;
9053 : 6231 : tree null_data;
9054 : 6231 : stmtblock_t block;
9055 : :
9056 : : /* If the source is null, set the destination to null. Then,
9057 : : allocate memory to the destination. */
9058 : 6231 : gfc_init_block (&block);
9059 : :
9060 : 6231 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
9061 : : {
9062 : 1757 : gfc_add_modify (&block, dest, fold_convert (type, null_pointer_node));
9063 : 1757 : null_data = gfc_finish_block (&block);
9064 : :
9065 : 1757 : gfc_init_block (&block);
9066 : 1757 : eltype = TREE_TYPE (type);
9067 : 1757 : if (str_sz != NULL_TREE)
9068 : : size = str_sz;
9069 : : else
9070 : 1484 : size = TYPE_SIZE_UNIT (eltype);
9071 : :
9072 : 1757 : if (!no_malloc)
9073 : : {
9074 : 1757 : tmp = gfc_call_malloc (&block, type, size);
9075 : 1757 : gfc_add_modify (&block, dest, fold_convert (type, tmp));
9076 : : }
9077 : :
9078 : 1757 : if (!no_memcpy)
9079 : : {
9080 : 1332 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
9081 : 1332 : tmp = build_call_expr_loc (input_location, tmp, 3, dest, src,
9082 : : fold_convert (size_type_node, size));
9083 : 1332 : gfc_add_expr_to_block (&block, tmp);
9084 : : }
9085 : : }
9086 : : else
9087 : : {
9088 : 4474 : gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
9089 : 4474 : null_data = gfc_finish_block (&block);
9090 : :
9091 : 4474 : gfc_init_block (&block);
9092 : 4474 : if (rank)
9093 : 4463 : nelems = gfc_full_array_size (&block, src, rank);
9094 : : else
9095 : 11 : nelems = gfc_index_one_node;
9096 : :
9097 : : /* If type is not the array type, then it is the element type. */
9098 : 4474 : if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type))
9099 : 4444 : eltype = gfc_get_element_type (type);
9100 : : else
9101 : : eltype = type;
9102 : :
9103 : 4474 : if (str_sz != NULL_TREE)
9104 : 43 : tmp = fold_convert (gfc_array_index_type, str_sz);
9105 : : else
9106 : 4431 : tmp = fold_convert (gfc_array_index_type,
9107 : : TYPE_SIZE_UNIT (eltype));
9108 : :
9109 : 4474 : tmp = gfc_evaluate_now (tmp, &block);
9110 : 4474 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9111 : : nelems, tmp);
9112 : 4474 : if (!no_malloc)
9113 : : {
9114 : 4443 : tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src));
9115 : 4443 : tmp = gfc_call_malloc (&block, tmp, size);
9116 : 4443 : gfc_conv_descriptor_data_set (&block, dest, tmp);
9117 : : }
9118 : :
9119 : : /* We know the temporary and the value will be the same length,
9120 : : so can use memcpy. */
9121 : 4474 : if (!no_memcpy)
9122 : : {
9123 : 4044 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
9124 : 4044 : tmp = build_call_expr_loc (input_location, tmp, 3,
9125 : : gfc_conv_descriptor_data_get (dest),
9126 : : gfc_conv_descriptor_data_get (src),
9127 : : fold_convert (size_type_node, size));
9128 : 4044 : gfc_add_expr_to_block (&block, tmp);
9129 : : }
9130 : : }
9131 : :
9132 : 6231 : gfc_add_expr_to_block (&block, add_when_allocated);
9133 : 6231 : tmp = gfc_finish_block (&block);
9134 : :
9135 : : /* Null the destination if the source is null; otherwise do
9136 : : the allocate and copy. */
9137 : 6231 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src)))
9138 : : null_cond = src;
9139 : : else
9140 : 4474 : null_cond = gfc_conv_descriptor_data_get (src);
9141 : :
9142 : 6231 : null_cond = convert (pvoid_type_node, null_cond);
9143 : 6231 : null_cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9144 : : null_cond, null_pointer_node);
9145 : 6231 : return build3_v (COND_EXPR, null_cond, tmp, null_data);
9146 : : }
9147 : :
9148 : :
9149 : : /* Allocate dest to the same size as src, and copy data src -> dest. */
9150 : :
9151 : : tree
9152 : 4998 : gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank,
9153 : : tree add_when_allocated)
9154 : : {
9155 : 4998 : return duplicate_allocatable (dest, src, type, rank, false, false,
9156 : 4998 : NULL_TREE, add_when_allocated);
9157 : : }
9158 : :
9159 : :
9160 : : /* Copy data src -> dest. */
9161 : :
9162 : : tree
9163 : 31 : gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
9164 : : {
9165 : 31 : return duplicate_allocatable (dest, src, type, rank, true, false,
9166 : 31 : NULL_TREE, NULL_TREE);
9167 : : }
9168 : :
9169 : : /* Allocate dest to the same size as src, but don't copy anything. */
9170 : :
9171 : : tree
9172 : 855 : gfc_duplicate_allocatable_nocopy (tree dest, tree src, tree type, int rank)
9173 : : {
9174 : 855 : return duplicate_allocatable (dest, src, type, rank, false, true,
9175 : 855 : NULL_TREE, NULL_TREE);
9176 : : }
9177 : :
9178 : :
9179 : : static tree
9180 : 49 : duplicate_allocatable_coarray (tree dest, tree dest_tok, tree src,
9181 : : tree type, int rank)
9182 : : {
9183 : 49 : tree tmp;
9184 : 49 : tree size;
9185 : 49 : tree nelems;
9186 : 49 : tree null_cond;
9187 : 49 : tree null_data;
9188 : 49 : stmtblock_t block, globalblock;
9189 : :
9190 : : /* If the source is null, set the destination to null. Then,
9191 : : allocate memory to the destination. */
9192 : 49 : gfc_init_block (&block);
9193 : 49 : gfc_init_block (&globalblock);
9194 : :
9195 : 49 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
9196 : : {
9197 : 13 : gfc_se se;
9198 : 13 : symbol_attribute attr;
9199 : 13 : tree dummy_desc;
9200 : :
9201 : 13 : gfc_init_se (&se, NULL);
9202 : 13 : gfc_clear_attr (&attr);
9203 : 13 : attr.allocatable = 1;
9204 : 13 : dummy_desc = gfc_conv_scalar_to_descriptor (&se, dest, attr);
9205 : 13 : gfc_add_block_to_block (&globalblock, &se.pre);
9206 : 13 : size = TYPE_SIZE_UNIT (TREE_TYPE (type));
9207 : :
9208 : 13 : gfc_add_modify (&block, dest, fold_convert (type, null_pointer_node));
9209 : 13 : gfc_allocate_using_caf_lib (&block, dummy_desc, size,
9210 : : gfc_build_addr_expr (NULL_TREE, dest_tok),
9211 : : NULL_TREE, NULL_TREE, NULL_TREE,
9212 : : GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
9213 : 13 : null_data = gfc_finish_block (&block);
9214 : :
9215 : 13 : gfc_init_block (&block);
9216 : :
9217 : 13 : gfc_allocate_using_caf_lib (&block, dummy_desc,
9218 : : fold_convert (size_type_node, size),
9219 : : gfc_build_addr_expr (NULL_TREE, dest_tok),
9220 : : NULL_TREE, NULL_TREE, NULL_TREE,
9221 : : GFC_CAF_COARRAY_ALLOC);
9222 : :
9223 : 13 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
9224 : 13 : tmp = build_call_expr_loc (input_location, tmp, 3, dest, src,
9225 : : fold_convert (size_type_node, size));
9226 : 13 : gfc_add_expr_to_block (&block, tmp);
9227 : : }
9228 : : else
9229 : : {
9230 : : /* Set the rank or unitialized memory access may be reported. */
9231 : 36 : tmp = gfc_conv_descriptor_rank (dest);
9232 : 36 : gfc_add_modify (&globalblock, tmp, build_int_cst (TREE_TYPE (tmp), rank));
9233 : :
9234 : 36 : if (rank)
9235 : 36 : nelems = gfc_full_array_size (&block, src, rank);
9236 : : else
9237 : 0 : nelems = integer_one_node;
9238 : :
9239 : 36 : tmp = fold_convert (size_type_node,
9240 : : TYPE_SIZE_UNIT (gfc_get_element_type (type)));
9241 : 36 : size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
9242 : : fold_convert (size_type_node, nelems), tmp);
9243 : :
9244 : 36 : gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
9245 : 36 : gfc_allocate_using_caf_lib (&block, dest, fold_convert (size_type_node,
9246 : : size),
9247 : : gfc_build_addr_expr (NULL_TREE, dest_tok),
9248 : : NULL_TREE, NULL_TREE, NULL_TREE,
9249 : : GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
9250 : 36 : null_data = gfc_finish_block (&block);
9251 : :
9252 : 36 : gfc_init_block (&block);
9253 : 36 : gfc_allocate_using_caf_lib (&block, dest,
9254 : : fold_convert (size_type_node, size),
9255 : : gfc_build_addr_expr (NULL_TREE, dest_tok),
9256 : : NULL_TREE, NULL_TREE, NULL_TREE,
9257 : : GFC_CAF_COARRAY_ALLOC);
9258 : :
9259 : 36 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
9260 : 36 : tmp = build_call_expr_loc (input_location, tmp, 3,
9261 : : gfc_conv_descriptor_data_get (dest),
9262 : : gfc_conv_descriptor_data_get (src),
9263 : : fold_convert (size_type_node, size));
9264 : 36 : gfc_add_expr_to_block (&block, tmp);
9265 : : }
9266 : :
9267 : 49 : tmp = gfc_finish_block (&block);
9268 : :
9269 : : /* Null the destination if the source is null; otherwise do
9270 : : the register and copy. */
9271 : 49 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src)))
9272 : : null_cond = src;
9273 : : else
9274 : 36 : null_cond = gfc_conv_descriptor_data_get (src);
9275 : :
9276 : 49 : null_cond = convert (pvoid_type_node, null_cond);
9277 : 49 : null_cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9278 : : null_cond, null_pointer_node);
9279 : 49 : gfc_add_expr_to_block (&globalblock, build3_v (COND_EXPR, null_cond, tmp,
9280 : : null_data));
9281 : 49 : return gfc_finish_block (&globalblock);
9282 : : }
9283 : :
9284 : :
9285 : : /* Helper function to abstract whether coarray processing is enabled. */
9286 : :
9287 : : static bool
9288 : 73 : caf_enabled (int caf_mode)
9289 : : {
9290 : 73 : return (caf_mode & GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY)
9291 : 73 : == GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY;
9292 : : }
9293 : :
9294 : :
9295 : : /* Helper function to abstract whether coarray processing is enabled
9296 : : and we are in a derived type coarray. */
9297 : :
9298 : : static bool
9299 : 7278 : caf_in_coarray (int caf_mode)
9300 : : {
9301 : 7278 : static const int pat = GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
9302 : : | GFC_STRUCTURE_CAF_MODE_IN_COARRAY;
9303 : 7278 : return (caf_mode & pat) == pat;
9304 : : }
9305 : :
9306 : :
9307 : : /* Helper function to abstract whether coarray is to deallocate only. */
9308 : :
9309 : : bool
9310 : 317 : gfc_caf_is_dealloc_only (int caf_mode)
9311 : : {
9312 : 317 : return (caf_mode & GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY)
9313 : 317 : == GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY;
9314 : : }
9315 : :
9316 : :
9317 : : /* Recursively traverse an object of derived type, generating code to
9318 : : deallocate, nullify or copy allocatable components. This is the work horse
9319 : : function for the functions named in this enum. */
9320 : :
9321 : : enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP,
9322 : : COPY_ALLOC_COMP, COPY_ONLY_ALLOC_COMP, REASSIGN_CAF_COMP,
9323 : : ALLOCATE_PDT_COMP, DEALLOCATE_PDT_COMP, CHECK_PDT_DUMMY,
9324 : : BCAST_ALLOC_COMP};
9325 : :
9326 : : static gfc_actual_arglist *pdt_param_list;
9327 : :
9328 : : static tree
9329 : 14272 : structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
9330 : : int rank, int purpose, int caf_mode,
9331 : : gfc_co_subroutines_args *args,
9332 : : bool no_finalization = false)
9333 : : {
9334 : 14272 : gfc_component *c;
9335 : 14272 : gfc_loopinfo loop;
9336 : 14272 : stmtblock_t fnblock;
9337 : 14272 : stmtblock_t loopbody;
9338 : 14272 : stmtblock_t tmpblock;
9339 : 14272 : tree decl_type;
9340 : 14272 : tree tmp;
9341 : 14272 : tree comp;
9342 : 14272 : tree dcmp;
9343 : 14272 : tree nelems;
9344 : 14272 : tree index;
9345 : 14272 : tree var;
9346 : 14272 : tree cdecl;
9347 : 14272 : tree ctype;
9348 : 14272 : tree vref, dref;
9349 : 14272 : tree null_cond = NULL_TREE;
9350 : 14272 : tree add_when_allocated;
9351 : 14272 : tree dealloc_fndecl;
9352 : 14272 : tree caf_token;
9353 : 14272 : gfc_symbol *vtab;
9354 : 14272 : int caf_dereg_mode;
9355 : 14272 : symbol_attribute *attr;
9356 : 14272 : bool deallocate_called;
9357 : :
9358 : 14272 : gfc_init_block (&fnblock);
9359 : :
9360 : 14272 : decl_type = TREE_TYPE (decl);
9361 : :
9362 : 14272 : if ((POINTER_TYPE_P (decl_type))
9363 : : || (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == 0))
9364 : : {
9365 : 1105 : decl = build_fold_indirect_ref_loc (input_location, decl);
9366 : : /* Deref dest in sync with decl, but only when it is not NULL. */
9367 : 1105 : if (dest)
9368 : 68 : dest = build_fold_indirect_ref_loc (input_location, dest);
9369 : :
9370 : : /* Update the decl_type because it got dereferenced. */
9371 : 1105 : decl_type = TREE_TYPE (decl);
9372 : : }
9373 : :
9374 : : /* If this is an array of derived types with allocatable components
9375 : : build a loop and recursively call this function. */
9376 : 14272 : if (TREE_CODE (decl_type) == ARRAY_TYPE
9377 : 14272 : || (GFC_DESCRIPTOR_TYPE_P (decl_type) && rank != 0))
9378 : : {
9379 : 2318 : tmp = gfc_conv_array_data (decl);
9380 : 2318 : var = build_fold_indirect_ref_loc (input_location, tmp);
9381 : :
9382 : : /* Get the number of elements - 1 and set the counter. */
9383 : 2318 : if (GFC_DESCRIPTOR_TYPE_P (decl_type))
9384 : : {
9385 : : /* Use the descriptor for an allocatable array. Since this
9386 : : is a full array reference, we only need the descriptor
9387 : : information from dimension = rank. */
9388 : 1565 : tmp = gfc_full_array_size (&fnblock, decl, rank);
9389 : 1565 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
9390 : : gfc_array_index_type, tmp,
9391 : : gfc_index_one_node);
9392 : :
9393 : 1565 : null_cond = gfc_conv_descriptor_data_get (decl);
9394 : 1565 : null_cond = fold_build2_loc (input_location, NE_EXPR,
9395 : : logical_type_node, null_cond,
9396 : 1565 : build_int_cst (TREE_TYPE (null_cond), 0));
9397 : : }
9398 : : else
9399 : : {
9400 : : /* Otherwise use the TYPE_DOMAIN information. */
9401 : 753 : tmp = array_type_nelts (decl_type);
9402 : 753 : tmp = fold_convert (gfc_array_index_type, tmp);
9403 : : }
9404 : :
9405 : : /* Remember that this is, in fact, the no. of elements - 1. */
9406 : 2318 : nelems = gfc_evaluate_now (tmp, &fnblock);
9407 : 2318 : index = gfc_create_var (gfc_array_index_type, "S");
9408 : :
9409 : : /* Build the body of the loop. */
9410 : 2318 : gfc_init_block (&loopbody);
9411 : :
9412 : 2318 : vref = gfc_build_array_ref (var, index, NULL);
9413 : :
9414 : 2318 : if (purpose == COPY_ALLOC_COMP || purpose == COPY_ONLY_ALLOC_COMP)
9415 : : {
9416 : 451 : tmp = build_fold_indirect_ref_loc (input_location,
9417 : : gfc_conv_array_data (dest));
9418 : 451 : dref = gfc_build_array_ref (tmp, index, NULL);
9419 : 451 : tmp = structure_alloc_comps (der_type, vref, dref, rank,
9420 : : COPY_ALLOC_COMP, caf_mode, args,
9421 : : no_finalization);
9422 : : }
9423 : : else
9424 : 1867 : tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose,
9425 : : caf_mode, args, no_finalization);
9426 : :
9427 : 2318 : gfc_add_expr_to_block (&loopbody, tmp);
9428 : :
9429 : : /* Build the loop and return. */
9430 : 2318 : gfc_init_loopinfo (&loop);
9431 : 2318 : loop.dimen = 1;
9432 : 2318 : loop.from[0] = gfc_index_zero_node;
9433 : 2318 : loop.loopvar[0] = index;
9434 : 2318 : loop.to[0] = nelems;
9435 : 2318 : gfc_trans_scalarizing_loops (&loop, &loopbody);
9436 : 2318 : gfc_add_block_to_block (&fnblock, &loop.pre);
9437 : :
9438 : 2318 : tmp = gfc_finish_block (&fnblock);
9439 : : /* When copying allocateable components, the above implements the
9440 : : deep copy. Nevertheless is a deep copy only allowed, when the current
9441 : : component is allocated, for which code will be generated in
9442 : : gfc_duplicate_allocatable (), where the deep copy code is just added
9443 : : into the if's body, by adding tmp (the deep copy code) as last
9444 : : argument to gfc_duplicate_allocatable (). */
9445 : 2318 : if (purpose == COPY_ALLOC_COMP
9446 : 2318 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
9447 : 380 : tmp = gfc_duplicate_allocatable (dest, decl, decl_type, rank,
9448 : : tmp);
9449 : 1938 : else if (null_cond != NULL_TREE)
9450 : 1185 : tmp = build3_v (COND_EXPR, null_cond, tmp,
9451 : : build_empty_stmt (input_location));
9452 : :
9453 : 2318 : return tmp;
9454 : : }
9455 : :
9456 : 11954 : if (purpose == DEALLOCATE_ALLOC_COMP && der_type->attr.pdt_type)
9457 : : {
9458 : 35 : tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
9459 : : DEALLOCATE_PDT_COMP, 0, args,
9460 : : no_finalization);
9461 : 35 : gfc_add_expr_to_block (&fnblock, tmp);
9462 : : }
9463 : 11919 : else if (purpose == ALLOCATE_PDT_COMP && der_type->attr.alloc_comp)
9464 : : {
9465 : 14 : tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
9466 : : NULLIFY_ALLOC_COMP, 0, args,
9467 : : no_finalization);
9468 : 14 : gfc_add_expr_to_block (&fnblock, tmp);
9469 : : }
9470 : :
9471 : : /* Still having a descriptor array of rank == 0 here, indicates an
9472 : : allocatable coarrays. Dereference it correctly. */
9473 : 11954 : if (GFC_DESCRIPTOR_TYPE_P (decl_type))
9474 : : {
9475 : 4 : decl = build_fold_indirect_ref (gfc_conv_array_data (decl));
9476 : : }
9477 : : /* Otherwise, act on the components or recursively call self to
9478 : : act on a chain of components. */
9479 : 33465 : for (c = der_type->components; c; c = c->next)
9480 : : {
9481 : 21511 : bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED
9482 : 21511 : || c->ts.type == BT_CLASS)
9483 : 21511 : && c->ts.u.derived->attr.alloc_comp;
9484 : 4209 : bool same_type = (c->ts.type == BT_DERIVED && der_type == c->ts.u.derived)
9485 : 25104 : || (c->ts.type == BT_CLASS && der_type == CLASS_DATA (c)->ts.u.derived);
9486 : :
9487 : 43022 : bool is_pdt_type = c->ts.type == BT_DERIVED
9488 : 21511 : && c->ts.u.derived->attr.pdt_type;
9489 : :
9490 : 21511 : cdecl = c->backend_decl;
9491 : 21511 : ctype = TREE_TYPE (cdecl);
9492 : :
9493 : 21511 : switch (purpose)
9494 : : {
9495 : :
9496 : 3 : case BCAST_ALLOC_COMP:
9497 : :
9498 : 3 : tree ubound;
9499 : 3 : tree cdesc;
9500 : 3 : stmtblock_t derived_type_block;
9501 : :
9502 : 3 : gfc_init_block (&tmpblock);
9503 : :
9504 : 3 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
9505 : : decl, cdecl, NULL_TREE);
9506 : :
9507 : : /* Shortcut to get the attributes of the component. */
9508 : 3 : if (c->ts.type == BT_CLASS)
9509 : : {
9510 : 0 : attr = &CLASS_DATA (c)->attr;
9511 : 0 : if (attr->class_pointer)
9512 : 0 : continue;
9513 : : }
9514 : : else
9515 : : {
9516 : 3 : attr = &c->attr;
9517 : 3 : if (attr->pointer)
9518 : 0 : continue;
9519 : : }
9520 : :
9521 : : /* Do not broadcast a caf_token. These are local to the image. */
9522 : 3 : if (attr->caf_token)
9523 : 1 : continue;
9524 : :
9525 : 2 : add_when_allocated = NULL_TREE;
9526 : 2 : if (cmp_has_alloc_comps
9527 : 0 : && !c->attr.pointer && !c->attr.proc_pointer)
9528 : : {
9529 : 0 : if (c->ts.type == BT_CLASS)
9530 : : {
9531 : 0 : rank = CLASS_DATA (c)->as ? CLASS_DATA (c)->as->rank : 0;
9532 : 0 : add_when_allocated
9533 : 0 : = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
9534 : : comp, NULL_TREE, rank, purpose,
9535 : : caf_mode, args, no_finalization);
9536 : : }
9537 : : else
9538 : : {
9539 : 0 : rank = c->as ? c->as->rank : 0;
9540 : 0 : add_when_allocated = structure_alloc_comps (c->ts.u.derived,
9541 : : comp, NULL_TREE,
9542 : : rank, purpose,
9543 : : caf_mode, args,
9544 : : no_finalization);
9545 : : }
9546 : : }
9547 : :
9548 : 2 : gfc_init_block (&derived_type_block);
9549 : 2 : if (add_when_allocated)
9550 : 0 : gfc_add_expr_to_block (&derived_type_block, add_when_allocated);
9551 : 2 : tmp = gfc_finish_block (&derived_type_block);
9552 : 2 : gfc_add_expr_to_block (&tmpblock, tmp);
9553 : :
9554 : : /* Convert the component into a rank 1 descriptor type. */
9555 : 2 : if (attr->dimension)
9556 : : {
9557 : 0 : tmp = gfc_get_element_type (TREE_TYPE (comp));
9558 : 0 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
9559 : 0 : ubound = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (comp));
9560 : : else
9561 : 0 : ubound = gfc_full_array_size (&tmpblock, comp,
9562 : 0 : c->ts.type == BT_CLASS
9563 : 0 : ? CLASS_DATA (c)->as->rank
9564 : 0 : : c->as->rank);
9565 : : }
9566 : : else
9567 : : {
9568 : 2 : tmp = TREE_TYPE (comp);
9569 : 2 : ubound = build_int_cst (gfc_array_index_type, 1);
9570 : : }
9571 : :
9572 : : /* Treat strings like arrays. Or the other way around, do not
9573 : : * generate an additional array layer for scalar components. */
9574 : 2 : if (attr->dimension || c->ts.type == BT_CHARACTER)
9575 : : {
9576 : 0 : cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node,
9577 : : &ubound, 1,
9578 : : GFC_ARRAY_ALLOCATABLE, false);
9579 : :
9580 : 0 : cdesc = gfc_create_var (cdesc, "cdesc");
9581 : 0 : DECL_ARTIFICIAL (cdesc) = 1;
9582 : :
9583 : 0 : gfc_add_modify (&tmpblock, gfc_conv_descriptor_dtype (cdesc),
9584 : : gfc_get_dtype_rank_type (1, tmp));
9585 : 0 : gfc_conv_descriptor_lbound_set (&tmpblock, cdesc,
9586 : : gfc_index_zero_node,
9587 : : gfc_index_one_node);
9588 : 0 : gfc_conv_descriptor_stride_set (&tmpblock, cdesc,
9589 : : gfc_index_zero_node,
9590 : : gfc_index_one_node);
9591 : 0 : gfc_conv_descriptor_ubound_set (&tmpblock, cdesc,
9592 : : gfc_index_zero_node, ubound);
9593 : : }
9594 : : else
9595 : : /* Prevent warning. */
9596 : : cdesc = NULL_TREE;
9597 : :
9598 : 2 : if (attr->dimension)
9599 : : {
9600 : 0 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
9601 : 0 : comp = gfc_conv_descriptor_data_get (comp);
9602 : : else
9603 : 0 : comp = gfc_build_addr_expr (NULL_TREE, comp);
9604 : : }
9605 : : else
9606 : : {
9607 : 2 : gfc_se se;
9608 : :
9609 : 2 : gfc_init_se (&se, NULL);
9610 : :
9611 : 2 : comp = gfc_conv_scalar_to_descriptor (&se, comp,
9612 : 2 : c->ts.type == BT_CLASS
9613 : 2 : ? CLASS_DATA (c)->attr
9614 : : : c->attr);
9615 : 2 : if (c->ts.type == BT_CHARACTER)
9616 : 0 : comp = gfc_build_addr_expr (NULL_TREE, comp);
9617 : 2 : gfc_add_block_to_block (&tmpblock, &se.pre);
9618 : : }
9619 : :
9620 : 2 : if (attr->dimension || c->ts.type == BT_CHARACTER)
9621 : 0 : gfc_conv_descriptor_data_set (&tmpblock, cdesc, comp);
9622 : : else
9623 : 2 : cdesc = comp;
9624 : :
9625 : 2 : tree fndecl;
9626 : :
9627 : 2 : fndecl = build_call_expr_loc (input_location,
9628 : : gfor_fndecl_co_broadcast, 5,
9629 : : gfc_build_addr_expr (pvoid_type_node,cdesc),
9630 : : args->image_index,
9631 : : null_pointer_node, null_pointer_node,
9632 : : null_pointer_node);
9633 : :
9634 : 2 : gfc_add_expr_to_block (&tmpblock, fndecl);
9635 : 2 : gfc_add_block_to_block (&fnblock, &tmpblock);
9636 : :
9637 : 17988 : break;
9638 : :
9639 : 8845 : case DEALLOCATE_ALLOC_COMP:
9640 : :
9641 : 8845 : gfc_init_block (&tmpblock);
9642 : :
9643 : 8845 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
9644 : : decl, cdecl, NULL_TREE);
9645 : :
9646 : : /* Shortcut to get the attributes of the component. */
9647 : 8845 : if (c->ts.type == BT_CLASS)
9648 : : {
9649 : 840 : attr = &CLASS_DATA (c)->attr;
9650 : 840 : if (attr->class_pointer)
9651 : 6 : continue;
9652 : : }
9653 : : else
9654 : : {
9655 : 8005 : attr = &c->attr;
9656 : 8005 : if (attr->pointer)
9657 : 71 : continue;
9658 : : }
9659 : :
9660 : 8768 : if (!no_finalization && ((c->ts.type == BT_DERIVED && !c->attr.pointer)
9661 : 6840 : || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer)))
9662 : : /* Call the finalizer, which will free the memory and nullify the
9663 : : pointer of an array. */
9664 : 2475 : deallocate_called = gfc_add_comp_finalizer_call (&tmpblock, comp, c,
9665 : 2475 : caf_enabled (caf_mode))
9666 : 2475 : && attr->dimension;
9667 : : else
9668 : : deallocate_called = false;
9669 : :
9670 : : /* Add the _class ref for classes. */
9671 : 8768 : if (c->ts.type == BT_CLASS && attr->allocatable)
9672 : 834 : comp = gfc_class_data_get (comp);
9673 : :
9674 : 8768 : add_when_allocated = NULL_TREE;
9675 : 8768 : if (cmp_has_alloc_comps
9676 : 1773 : && !c->attr.pointer && !c->attr.proc_pointer
9677 : : && !same_type
9678 : 1749 : && !deallocate_called)
9679 : : {
9680 : : /* Add checked deallocation of the components. This code is
9681 : : obviously added because the finalizer is not trusted to free
9682 : : all memory. */
9683 : 1167 : if (c->ts.type == BT_CLASS)
9684 : : {
9685 : 240 : rank = CLASS_DATA (c)->as ? CLASS_DATA (c)->as->rank : 0;
9686 : 240 : add_when_allocated
9687 : 240 : = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
9688 : : comp, NULL_TREE, rank, purpose,
9689 : : caf_mode, args, no_finalization);
9690 : : }
9691 : : else
9692 : : {
9693 : 927 : rank = c->as ? c->as->rank : 0;
9694 : 927 : add_when_allocated = structure_alloc_comps (c->ts.u.derived,
9695 : : comp, NULL_TREE,
9696 : : rank, purpose,
9697 : : caf_mode, args,
9698 : : no_finalization);
9699 : : }
9700 : : }
9701 : :
9702 : 5965 : if (attr->allocatable && !same_type
9703 : 14343 : && (!attr->codimension || caf_enabled (caf_mode)))
9704 : : {
9705 : : /* Handle all types of components besides components of the
9706 : : same_type as the current one, because those would create an
9707 : : endless loop. */
9708 : 5569 : caf_dereg_mode
9709 : 5505 : = (caf_in_coarray (caf_mode) || attr->codimension)
9710 : 5590 : ? (gfc_caf_is_dealloc_only (caf_mode)
9711 : : ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
9712 : : : GFC_CAF_COARRAY_DEREGISTER)
9713 : : : GFC_CAF_COARRAY_NOCOARRAY;
9714 : :
9715 : 5569 : caf_token = NULL_TREE;
9716 : : /* Coarray components are handled directly by
9717 : : deallocate_with_status. */
9718 : 5569 : if (!attr->codimension
9719 : 5548 : && caf_dereg_mode != GFC_CAF_COARRAY_NOCOARRAY)
9720 : : {
9721 : 64 : if (c->caf_token)
9722 : 31 : caf_token = fold_build3_loc (input_location, COMPONENT_REF,
9723 : 31 : TREE_TYPE (c->caf_token),
9724 : : decl, c->caf_token, NULL_TREE);
9725 : 33 : else if (attr->dimension && !attr->proc_pointer)
9726 : 33 : caf_token = gfc_conv_descriptor_token (comp);
9727 : : }
9728 : :
9729 : 5569 : tmp = gfc_deallocate_with_status (comp, NULL_TREE, NULL_TREE,
9730 : : NULL_TREE, NULL_TREE, true,
9731 : : NULL, caf_dereg_mode, NULL_TREE,
9732 : : add_when_allocated, caf_token);
9733 : :
9734 : 5569 : gfc_add_expr_to_block (&tmpblock, tmp);
9735 : : }
9736 : 3199 : else if (attr->allocatable && !attr->codimension
9737 : 390 : && !deallocate_called)
9738 : : {
9739 : : /* Case of recursive allocatable derived types. */
9740 : 390 : tree is_allocated;
9741 : 390 : tree ubound;
9742 : 390 : tree cdesc;
9743 : 390 : stmtblock_t dealloc_block;
9744 : :
9745 : 390 : gfc_init_block (&dealloc_block);
9746 : 390 : if (add_when_allocated)
9747 : 0 : gfc_add_expr_to_block (&dealloc_block, add_when_allocated);
9748 : :
9749 : : /* Convert the component into a rank 1 descriptor type. */
9750 : 390 : if (attr->dimension)
9751 : : {
9752 : 34 : tmp = gfc_get_element_type (TREE_TYPE (comp));
9753 : 34 : ubound = gfc_full_array_size (&dealloc_block, comp,
9754 : 34 : c->ts.type == BT_CLASS
9755 : 0 : ? CLASS_DATA (c)->as->rank
9756 : 34 : : c->as->rank);
9757 : : }
9758 : : else
9759 : : {
9760 : 356 : tmp = TREE_TYPE (comp);
9761 : 356 : ubound = build_int_cst (gfc_array_index_type, 1);
9762 : : }
9763 : :
9764 : 390 : cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node,
9765 : : &ubound, 1,
9766 : : GFC_ARRAY_ALLOCATABLE, false);
9767 : :
9768 : 390 : cdesc = gfc_create_var (cdesc, "cdesc");
9769 : 390 : DECL_ARTIFICIAL (cdesc) = 1;
9770 : :
9771 : 390 : gfc_add_modify (&dealloc_block, gfc_conv_descriptor_dtype (cdesc),
9772 : : gfc_get_dtype_rank_type (1, tmp));
9773 : 390 : gfc_conv_descriptor_lbound_set (&dealloc_block, cdesc,
9774 : : gfc_index_zero_node,
9775 : : gfc_index_one_node);
9776 : 390 : gfc_conv_descriptor_stride_set (&dealloc_block, cdesc,
9777 : : gfc_index_zero_node,
9778 : : gfc_index_one_node);
9779 : 390 : gfc_conv_descriptor_ubound_set (&dealloc_block, cdesc,
9780 : : gfc_index_zero_node, ubound);
9781 : :
9782 : 390 : if (attr->dimension)
9783 : 34 : comp = gfc_conv_descriptor_data_get (comp);
9784 : :
9785 : 390 : gfc_conv_descriptor_data_set (&dealloc_block, cdesc, comp);
9786 : :
9787 : : /* Now call the deallocator. */
9788 : 390 : vtab = gfc_find_vtab (&c->ts);
9789 : 390 : if (vtab->backend_decl == NULL)
9790 : 8 : gfc_get_symbol_decl (vtab);
9791 : 390 : tmp = gfc_build_addr_expr (NULL_TREE, vtab->backend_decl);
9792 : 390 : dealloc_fndecl = gfc_vptr_deallocate_get (tmp);
9793 : 390 : dealloc_fndecl = build_fold_indirect_ref_loc (input_location,
9794 : : dealloc_fndecl);
9795 : 390 : tmp = build_int_cst (TREE_TYPE (comp), 0);
9796 : 390 : is_allocated = fold_build2_loc (input_location, NE_EXPR,
9797 : : logical_type_node, tmp,
9798 : : comp);
9799 : 390 : cdesc = gfc_build_addr_expr (NULL_TREE, cdesc);
9800 : :
9801 : 390 : tmp = build_call_expr_loc (input_location,
9802 : : dealloc_fndecl, 1,
9803 : : cdesc);
9804 : 390 : gfc_add_expr_to_block (&dealloc_block, tmp);
9805 : :
9806 : 390 : tmp = gfc_finish_block (&dealloc_block);
9807 : :
9808 : 390 : tmp = fold_build3_loc (input_location, COND_EXPR,
9809 : : void_type_node, is_allocated, tmp,
9810 : : build_empty_stmt (input_location));
9811 : :
9812 : 390 : gfc_add_expr_to_block (&tmpblock, tmp);
9813 : 390 : }
9814 : 2809 : else if (add_when_allocated)
9815 : 490 : gfc_add_expr_to_block (&tmpblock, add_when_allocated);
9816 : :
9817 : 834 : if (c->ts.type == BT_CLASS && attr->allocatable
9818 : 9602 : && (!attr->codimension || !caf_enabled (caf_mode)))
9819 : : {
9820 : : /* Finally, reset the vptr to the declared type vtable and, if
9821 : : necessary reset the _len field.
9822 : :
9823 : : First recover the reference to the component and obtain
9824 : : the vptr. */
9825 : 819 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
9826 : : decl, cdecl, NULL_TREE);
9827 : 819 : tmp = gfc_class_vptr_get (comp);
9828 : :
9829 : 819 : if (UNLIMITED_POLY (c))
9830 : : {
9831 : : /* Both vptr and _len field should be nulled. */
9832 : 139 : gfc_add_modify (&tmpblock, tmp,
9833 : 139 : build_int_cst (TREE_TYPE (tmp), 0));
9834 : 139 : tmp = gfc_class_len_get (comp);
9835 : 139 : gfc_add_modify (&tmpblock, tmp,
9836 : 139 : build_int_cst (TREE_TYPE (tmp), 0));
9837 : : }
9838 : : else
9839 : : {
9840 : : /* Build the vtable address and set the vptr with it. */
9841 : 680 : tree vtab;
9842 : 680 : gfc_symbol *vtable;
9843 : 680 : vtable = gfc_find_derived_vtab (c->ts.u.derived);
9844 : 680 : vtab = vtable->backend_decl;
9845 : 680 : if (vtab == NULL_TREE)
9846 : 6 : vtab = gfc_get_symbol_decl (vtable);
9847 : 680 : vtab = gfc_build_addr_expr (NULL, vtab);
9848 : 680 : vtab = fold_convert (TREE_TYPE (tmp), vtab);
9849 : 680 : gfc_add_modify (&tmpblock, tmp, vtab);
9850 : : }
9851 : : }
9852 : :
9853 : : /* Now add the deallocation of this component. */
9854 : 8768 : gfc_add_block_to_block (&fnblock, &tmpblock);
9855 : 8768 : break;
9856 : :
9857 : 3548 : case NULLIFY_ALLOC_COMP:
9858 : : /* Nullify
9859 : : - allocatable components (regular or in class)
9860 : : - components that have allocatable components
9861 : : - pointer components when in a coarray.
9862 : : Skip everything else especially proc_pointers, which may come
9863 : : coupled with the regular pointer attribute. */
9864 : 4689 : if (c->attr.proc_pointer
9865 : 3548 : || !(c->attr.allocatable || (c->ts.type == BT_CLASS
9866 : 383 : && CLASS_DATA (c)->attr.allocatable)
9867 : 1455 : || (cmp_has_alloc_comps
9868 : 220 : && ((c->ts.type == BT_DERIVED && !c->attr.pointer)
9869 : 18 : || (c->ts.type == BT_CLASS
9870 : 12 : && !CLASS_DATA (c)->attr.class_pointer)))
9871 : 1253 : || (caf_in_coarray (caf_mode) && c->attr.pointer)))
9872 : 1141 : continue;
9873 : :
9874 : : /* Process class components first, because they always have the
9875 : : pointer-attribute set which would be caught wrong else. */
9876 : 2407 : if (c->ts.type == BT_CLASS
9877 : 370 : && (CLASS_DATA (c)->attr.allocatable
9878 : 370 : || CLASS_DATA (c)->attr.class_pointer))
9879 : : {
9880 : 370 : tree vptr_decl;
9881 : :
9882 : : /* Allocatable CLASS components. */
9883 : 370 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
9884 : : decl, cdecl, NULL_TREE);
9885 : :
9886 : 370 : vptr_decl = gfc_class_vptr_get (comp);
9887 : :
9888 : 370 : comp = gfc_class_data_get (comp);
9889 : 370 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
9890 : 191 : gfc_conv_descriptor_data_set (&fnblock, comp,
9891 : : null_pointer_node);
9892 : : else
9893 : : {
9894 : 179 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
9895 : : void_type_node, comp,
9896 : 179 : build_int_cst (TREE_TYPE (comp), 0));
9897 : 179 : gfc_add_expr_to_block (&fnblock, tmp);
9898 : : }
9899 : :
9900 : : /* The dynamic type of a disassociated pointer or unallocated
9901 : : allocatable variable is its declared type. An unlimited
9902 : : polymorphic entity has no declared type. */
9903 : 370 : if (!UNLIMITED_POLY (c))
9904 : : {
9905 : 280 : vtab = gfc_find_derived_vtab (c->ts.u.derived);
9906 : 280 : if (!vtab->backend_decl)
9907 : 7 : gfc_get_symbol_decl (vtab);
9908 : 280 : tmp = gfc_build_addr_expr (NULL_TREE, vtab->backend_decl);
9909 : : }
9910 : : else
9911 : 90 : tmp = build_int_cst (TREE_TYPE (vptr_decl), 0);
9912 : :
9913 : 370 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
9914 : : void_type_node, vptr_decl, tmp);
9915 : 370 : gfc_add_expr_to_block (&fnblock, tmp);
9916 : :
9917 : 370 : cmp_has_alloc_comps = false;
9918 : 370 : }
9919 : : /* Coarrays need the component to be nulled before the api-call
9920 : : is made. */
9921 : 2037 : else if (c->attr.pointer || c->attr.allocatable)
9922 : : {
9923 : 1835 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
9924 : : decl, cdecl, NULL_TREE);
9925 : 1835 : if (c->attr.dimension || c->attr.codimension)
9926 : 1330 : gfc_conv_descriptor_data_set (&fnblock, comp,
9927 : : null_pointer_node);
9928 : : else
9929 : 505 : gfc_add_modify (&fnblock, comp,
9930 : 505 : build_int_cst (TREE_TYPE (comp), 0));
9931 : 1835 : if (gfc_deferred_strlen (c, &comp))
9932 : : {
9933 : 244 : comp = fold_build3_loc (input_location, COMPONENT_REF,
9934 : 244 : TREE_TYPE (comp),
9935 : : decl, comp, NULL_TREE);
9936 : 488 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
9937 : 244 : TREE_TYPE (comp), comp,
9938 : 244 : build_int_cst (TREE_TYPE (comp), 0));
9939 : 244 : gfc_add_expr_to_block (&fnblock, tmp);
9940 : : }
9941 : : cmp_has_alloc_comps = false;
9942 : : }
9943 : :
9944 : 2407 : if (flag_coarray == GFC_FCOARRAY_LIB && caf_in_coarray (caf_mode))
9945 : : {
9946 : : /* Register a component of a derived type coarray with the
9947 : : coarray library. Do not register ultimate component
9948 : : coarrays here. They are treated like regular coarrays and
9949 : : are either allocated on all images or on none. */
9950 : 124 : tree token;
9951 : :
9952 : 124 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
9953 : : decl, cdecl, NULL_TREE);
9954 : 124 : if (c->attr.dimension)
9955 : : {
9956 : : /* Set the dtype, because caf_register needs it. */
9957 : 99 : gfc_add_modify (&fnblock, gfc_conv_descriptor_dtype (comp),
9958 : 99 : gfc_get_dtype (TREE_TYPE (comp)));
9959 : 99 : tmp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
9960 : : decl, cdecl, NULL_TREE);
9961 : 99 : token = gfc_conv_descriptor_token (tmp);
9962 : : }
9963 : : else
9964 : : {
9965 : 25 : gfc_se se;
9966 : :
9967 : 25 : gfc_init_se (&se, NULL);
9968 : 25 : token = fold_build3_loc (input_location, COMPONENT_REF,
9969 : : pvoid_type_node, decl, c->caf_token,
9970 : : NULL_TREE);
9971 : 25 : comp = gfc_conv_scalar_to_descriptor (&se, comp,
9972 : 25 : c->ts.type == BT_CLASS
9973 : 25 : ? CLASS_DATA (c)->attr
9974 : : : c->attr);
9975 : 25 : gfc_add_block_to_block (&fnblock, &se.pre);
9976 : : }
9977 : :
9978 : 124 : gfc_allocate_using_caf_lib (&fnblock, comp, size_zero_node,
9979 : : gfc_build_addr_expr (NULL_TREE,
9980 : : token),
9981 : : NULL_TREE, NULL_TREE, NULL_TREE,
9982 : : GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
9983 : : }
9984 : :
9985 : 2407 : if (cmp_has_alloc_comps)
9986 : : {
9987 : 202 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
9988 : : decl, cdecl, NULL_TREE);
9989 : 202 : rank = c->as ? c->as->rank : 0;
9990 : 202 : tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
9991 : : rank, purpose, caf_mode, args,
9992 : : no_finalization);
9993 : 202 : gfc_add_expr_to_block (&fnblock, tmp);
9994 : : }
9995 : : break;
9996 : :
9997 : 29 : case REASSIGN_CAF_COMP:
9998 : 29 : if (caf_enabled (caf_mode)
9999 : 29 : && (c->attr.codimension
10000 : 23 : || (c->ts.type == BT_CLASS
10001 : 2 : && (CLASS_DATA (c)->attr.coarray_comp
10002 : 2 : || caf_in_coarray (caf_mode)))
10003 : 21 : || (c->ts.type == BT_DERIVED
10004 : 7 : && (c->ts.u.derived->attr.coarray_comp
10005 : 6 : || caf_in_coarray (caf_mode))))
10006 : 44 : && !same_type)
10007 : : {
10008 : 13 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10009 : : decl, cdecl, NULL_TREE);
10010 : 13 : dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10011 : : dest, cdecl, NULL_TREE);
10012 : :
10013 : 13 : if (c->attr.codimension)
10014 : : {
10015 : 6 : if (c->ts.type == BT_CLASS)
10016 : : {
10017 : 0 : comp = gfc_class_data_get (comp);
10018 : 0 : dcmp = gfc_class_data_get (dcmp);
10019 : : }
10020 : 6 : gfc_conv_descriptor_data_set (&fnblock, dcmp,
10021 : : gfc_conv_descriptor_data_get (comp));
10022 : : }
10023 : : else
10024 : : {
10025 : 7 : tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
10026 : : rank, purpose, caf_mode
10027 : : | GFC_STRUCTURE_CAF_MODE_IN_COARRAY,
10028 : : args, no_finalization);
10029 : 7 : gfc_add_expr_to_block (&fnblock, tmp);
10030 : : }
10031 : : }
10032 : : break;
10033 : :
10034 : 6943 : case COPY_ALLOC_COMP:
10035 : 6943 : if (c->attr.pointer || c->attr.proc_pointer)
10036 : 144 : continue;
10037 : :
10038 : : /* We need source and destination components. */
10039 : 6799 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl,
10040 : : cdecl, NULL_TREE);
10041 : 6799 : dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, dest,
10042 : : cdecl, NULL_TREE);
10043 : 6799 : dcmp = fold_convert (TREE_TYPE (comp), dcmp);
10044 : :
10045 : 6799 : if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
10046 : : {
10047 : 633 : tree ftn_tree;
10048 : 633 : tree size;
10049 : 633 : tree dst_data;
10050 : 633 : tree src_data;
10051 : 633 : tree null_data;
10052 : :
10053 : 633 : dst_data = gfc_class_data_get (dcmp);
10054 : 633 : src_data = gfc_class_data_get (comp);
10055 : 633 : size = fold_convert (size_type_node,
10056 : : gfc_class_vtab_size_get (comp));
10057 : :
10058 : 633 : if (CLASS_DATA (c)->attr.dimension)
10059 : : {
10060 : 616 : nelems = gfc_conv_descriptor_size (src_data,
10061 : 308 : CLASS_DATA (c)->as->rank);
10062 : 308 : size = fold_build2_loc (input_location, MULT_EXPR,
10063 : : size_type_node, size,
10064 : : fold_convert (size_type_node,
10065 : : nelems));
10066 : : }
10067 : : else
10068 : 325 : nelems = build_int_cst (size_type_node, 1);
10069 : :
10070 : 633 : if (CLASS_DATA (c)->attr.dimension
10071 : 633 : || CLASS_DATA (c)->attr.codimension)
10072 : : {
10073 : 316 : src_data = gfc_conv_descriptor_data_get (src_data);
10074 : 316 : dst_data = gfc_conv_descriptor_data_get (dst_data);
10075 : : }
10076 : :
10077 : 633 : gfc_init_block (&tmpblock);
10078 : :
10079 : 633 : gfc_add_modify (&tmpblock, gfc_class_vptr_get (dcmp),
10080 : : gfc_class_vptr_get (comp));
10081 : :
10082 : : /* Copy the unlimited '_len' field. If it is greater than zero
10083 : : (ie. a character(_len)), multiply it by size and use this
10084 : : for the malloc call. */
10085 : 633 : if (UNLIMITED_POLY (c))
10086 : : {
10087 : 105 : gfc_add_modify (&tmpblock, gfc_class_len_get (dcmp),
10088 : : gfc_class_len_get (comp));
10089 : 105 : size = gfc_resize_class_size_with_len (&tmpblock, comp, size);
10090 : : }
10091 : :
10092 : : /* Coarray component have to have the same allocation status and
10093 : : shape/type-parameter/effective-type on the LHS and RHS of an
10094 : : intrinsic assignment. Hence, we did not deallocated them - and
10095 : : do not allocate them here. */
10096 : 633 : if (!CLASS_DATA (c)->attr.codimension)
10097 : : {
10098 : 618 : ftn_tree = builtin_decl_explicit (BUILT_IN_MALLOC);
10099 : 618 : tmp = build_call_expr_loc (input_location, ftn_tree, 1, size);
10100 : 618 : gfc_add_modify (&tmpblock, dst_data,
10101 : 618 : fold_convert (TREE_TYPE (dst_data), tmp));
10102 : : }
10103 : :
10104 : 1251 : tmp = gfc_copy_class_to_class (comp, dcmp, nelems,
10105 : 633 : UNLIMITED_POLY (c));
10106 : 633 : gfc_add_expr_to_block (&tmpblock, tmp);
10107 : 633 : tmp = gfc_finish_block (&tmpblock);
10108 : :
10109 : 633 : gfc_init_block (&tmpblock);
10110 : 633 : gfc_add_modify (&tmpblock, dst_data,
10111 : 633 : fold_convert (TREE_TYPE (dst_data),
10112 : : null_pointer_node));
10113 : 633 : null_data = gfc_finish_block (&tmpblock);
10114 : :
10115 : 633 : null_cond = fold_build2_loc (input_location, NE_EXPR,
10116 : : logical_type_node, src_data,
10117 : : null_pointer_node);
10118 : :
10119 : 633 : gfc_add_expr_to_block (&fnblock, build3_v (COND_EXPR, null_cond,
10120 : : tmp, null_data));
10121 : 633 : continue;
10122 : 633 : }
10123 : :
10124 : : /* To implement guarded deep copy, i.e., deep copy only allocatable
10125 : : components that are really allocated, the deep copy code has to
10126 : : be generated first and then added to the if-block in
10127 : : gfc_duplicate_allocatable (). */
10128 : 6166 : if (cmp_has_alloc_comps && !c->attr.proc_pointer && !same_type)
10129 : : {
10130 : 976 : rank = c->as ? c->as->rank : 0;
10131 : 976 : tmp = fold_convert (TREE_TYPE (dcmp), comp);
10132 : 976 : gfc_add_modify (&fnblock, dcmp, tmp);
10133 : 976 : add_when_allocated = structure_alloc_comps (c->ts.u.derived,
10134 : : comp, dcmp,
10135 : : rank, purpose,
10136 : : caf_mode, args,
10137 : : no_finalization);
10138 : : }
10139 : : else
10140 : : add_when_allocated = NULL_TREE;
10141 : :
10142 : 6166 : if (gfc_deferred_strlen (c, &tmp))
10143 : : {
10144 : 316 : tree len, size;
10145 : 316 : len = tmp;
10146 : 316 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
10147 : 316 : TREE_TYPE (len),
10148 : : decl, len, NULL_TREE);
10149 : 316 : len = fold_build3_loc (input_location, COMPONENT_REF,
10150 : 316 : TREE_TYPE (len),
10151 : : dest, len, NULL_TREE);
10152 : 316 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
10153 : 316 : TREE_TYPE (len), len, tmp);
10154 : 316 : gfc_add_expr_to_block (&fnblock, tmp);
10155 : 316 : size = size_of_string_in_bytes (c->ts.kind, len);
10156 : : /* This component cannot have allocatable components,
10157 : : therefore add_when_allocated of duplicate_allocatable ()
10158 : : is always NULL. */
10159 : 316 : rank = c->as ? c->as->rank : 0;
10160 : 316 : tmp = duplicate_allocatable (dcmp, comp, ctype, rank,
10161 : : false, false, size, NULL_TREE);
10162 : 316 : gfc_add_expr_to_block (&fnblock, tmp);
10163 : : }
10164 : 5850 : else if (c->attr.pdt_array)
10165 : : {
10166 : 31 : tmp = duplicate_allocatable (dcmp, comp, ctype,
10167 : 31 : c->as ? c->as->rank : 0,
10168 : : false, false, NULL_TREE, NULL_TREE);
10169 : 31 : gfc_add_expr_to_block (&fnblock, tmp);
10170 : : }
10171 : 5819 : else if ((c->attr.allocatable)
10172 : 3262 : && !c->attr.proc_pointer && !same_type
10173 : 9016 : && (!(cmp_has_alloc_comps && c->as) || c->attr.codimension
10174 : 248 : || caf_in_coarray (caf_mode)))
10175 : : {
10176 : 2950 : rank = c->as ? c->as->rank : 0;
10177 : 2950 : if (c->attr.codimension)
10178 : 13 : tmp = gfc_copy_allocatable_data (dcmp, comp, ctype, rank);
10179 : 2937 : else if (flag_coarray == GFC_FCOARRAY_LIB
10180 : 2937 : && caf_in_coarray (caf_mode))
10181 : : {
10182 : 49 : tree dst_tok;
10183 : 49 : if (c->as)
10184 : 36 : dst_tok = gfc_conv_descriptor_token (dcmp);
10185 : : else
10186 : : {
10187 : : /* For a scalar allocatable component the caf_token is
10188 : : the next component. */
10189 : 13 : if (!c->caf_token)
10190 : 1 : c->caf_token = c->next->backend_decl;
10191 : 13 : dst_tok = fold_build3_loc (input_location,
10192 : : COMPONENT_REF,
10193 : : pvoid_type_node, dest,
10194 : : c->caf_token,
10195 : : NULL_TREE);
10196 : : }
10197 : 49 : tmp = duplicate_allocatable_coarray (dcmp, dst_tok, comp,
10198 : : ctype, rank);
10199 : : }
10200 : : else
10201 : 2888 : tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank,
10202 : : add_when_allocated);
10203 : 2950 : gfc_add_expr_to_block (&fnblock, tmp);
10204 : : }
10205 : : else
10206 : 2869 : if (cmp_has_alloc_comps || is_pdt_type)
10207 : 997 : gfc_add_expr_to_block (&fnblock, add_when_allocated);
10208 : :
10209 : : break;
10210 : :
10211 : 900 : case ALLOCATE_PDT_COMP:
10212 : :
10213 : 900 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10214 : : decl, cdecl, NULL_TREE);
10215 : :
10216 : : /* Set the PDT KIND and LEN fields. */
10217 : 900 : if (c->attr.pdt_kind || c->attr.pdt_len)
10218 : : {
10219 : 439 : gfc_se tse;
10220 : 439 : gfc_expr *c_expr = NULL;
10221 : 439 : gfc_actual_arglist *param = pdt_param_list;
10222 : 439 : gfc_init_se (&tse, NULL);
10223 : 1767 : for (; param; param = param->next)
10224 : 889 : if (param->name && !strcmp (c->name, param->name))
10225 : 415 : c_expr = param->expr;
10226 : :
10227 : 439 : if (!c_expr)
10228 : 24 : c_expr = c->initializer;
10229 : :
10230 : 24 : if (c_expr)
10231 : : {
10232 : 439 : gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp));
10233 : 439 : gfc_add_modify (&fnblock, comp, tse.expr);
10234 : : }
10235 : : }
10236 : :
10237 : 900 : if (c->attr.pdt_string)
10238 : : {
10239 : 72 : gfc_se tse;
10240 : 72 : gfc_init_se (&tse, NULL);
10241 : 72 : tree strlen = NULL_TREE;
10242 : 72 : gfc_expr *e = gfc_copy_expr (c->ts.u.cl->length);
10243 : : /* Convert the parameterized string length to its value. The
10244 : : string length is stored in a hidden field in the same way as
10245 : : deferred string lengths. */
10246 : 72 : gfc_insert_parameter_exprs (e, pdt_param_list);
10247 : 72 : if (gfc_deferred_strlen (c, &strlen) && strlen != NULL_TREE)
10248 : : {
10249 : 72 : gfc_conv_expr_type (&tse, e,
10250 : 72 : TREE_TYPE (strlen));
10251 : 72 : strlen = fold_build3_loc (input_location, COMPONENT_REF,
10252 : 72 : TREE_TYPE (strlen),
10253 : : decl, strlen, NULL_TREE);
10254 : 72 : gfc_add_modify (&fnblock, strlen, tse.expr);
10255 : 72 : c->ts.u.cl->backend_decl = strlen;
10256 : : }
10257 : 72 : gfc_free_expr (e);
10258 : :
10259 : : /* Scalar parameterized strings can be allocated now. */
10260 : 72 : if (!c->as)
10261 : : {
10262 : 72 : tmp = fold_convert (gfc_array_index_type, strlen);
10263 : 72 : tmp = size_of_string_in_bytes (c->ts.kind, tmp);
10264 : 72 : tmp = gfc_evaluate_now (tmp, &fnblock);
10265 : 72 : tmp = gfc_call_malloc (&fnblock, TREE_TYPE (comp), tmp);
10266 : 72 : gfc_add_modify (&fnblock, comp, tmp);
10267 : : }
10268 : : }
10269 : :
10270 : : /* Allocate parameterized arrays of parameterized derived types. */
10271 : 900 : if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT)
10272 : 735 : && !((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
10273 : 62 : && (c->ts.u.derived && c->ts.u.derived->attr.pdt_type)))
10274 : 673 : continue;
10275 : :
10276 : 227 : if (c->ts.type == BT_CLASS)
10277 : 0 : comp = gfc_class_data_get (comp);
10278 : :
10279 : 227 : if (c->attr.pdt_array)
10280 : : {
10281 : 165 : gfc_se tse;
10282 : 165 : int i;
10283 : 165 : tree size = gfc_index_one_node;
10284 : 165 : tree offset = gfc_index_zero_node;
10285 : 165 : tree lower, upper;
10286 : 165 : gfc_expr *e;
10287 : :
10288 : : /* This chunk takes the expressions for 'lower' and 'upper'
10289 : : in the arrayspec and substitutes in the expressions for
10290 : : the parameters from 'pdt_param_list'. The descriptor
10291 : : fields can then be filled from the values so obtained. */
10292 : 165 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)));
10293 : 408 : for (i = 0; i < c->as->rank; i++)
10294 : : {
10295 : 243 : gfc_init_se (&tse, NULL);
10296 : 243 : e = gfc_copy_expr (c->as->lower[i]);
10297 : 243 : gfc_insert_parameter_exprs (e, pdt_param_list);
10298 : 243 : gfc_conv_expr_type (&tse, e, gfc_array_index_type);
10299 : 243 : gfc_free_expr (e);
10300 : 243 : lower = tse.expr;
10301 : 243 : gfc_conv_descriptor_lbound_set (&fnblock, comp,
10302 : : gfc_rank_cst[i],
10303 : : lower);
10304 : 243 : e = gfc_copy_expr (c->as->upper[i]);
10305 : 243 : gfc_insert_parameter_exprs (e, pdt_param_list);
10306 : 243 : gfc_conv_expr_type (&tse, e, gfc_array_index_type);
10307 : 243 : gfc_free_expr (e);
10308 : 243 : upper = tse.expr;
10309 : 243 : gfc_conv_descriptor_ubound_set (&fnblock, comp,
10310 : : gfc_rank_cst[i],
10311 : : upper);
10312 : 243 : gfc_conv_descriptor_stride_set (&fnblock, comp,
10313 : : gfc_rank_cst[i],
10314 : : size);
10315 : 243 : size = gfc_evaluate_now (size, &fnblock);
10316 : 243 : offset = fold_build2_loc (input_location,
10317 : : MINUS_EXPR,
10318 : : gfc_array_index_type,
10319 : : offset, size);
10320 : 243 : offset = gfc_evaluate_now (offset, &fnblock);
10321 : 243 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
10322 : : gfc_array_index_type,
10323 : : upper, lower);
10324 : 243 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
10325 : : gfc_array_index_type,
10326 : : tmp, gfc_index_one_node);
10327 : 243 : size = fold_build2_loc (input_location, MULT_EXPR,
10328 : : gfc_array_index_type, size, tmp);
10329 : : }
10330 : 165 : gfc_conv_descriptor_offset_set (&fnblock, comp, offset);
10331 : 165 : if (c->ts.type == BT_CLASS)
10332 : : {
10333 : 0 : tmp = gfc_get_vptr_from_expr (comp);
10334 : 0 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
10335 : 0 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
10336 : 0 : tmp = gfc_vptr_size_get (tmp);
10337 : : }
10338 : : else
10339 : 165 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (ctype));
10340 : 165 : tmp = fold_convert (gfc_array_index_type, tmp);
10341 : 165 : size = fold_build2_loc (input_location, MULT_EXPR,
10342 : : gfc_array_index_type, size, tmp);
10343 : 165 : size = gfc_evaluate_now (size, &fnblock);
10344 : 165 : tmp = gfc_call_malloc (&fnblock, NULL, size);
10345 : 165 : gfc_conv_descriptor_data_set (&fnblock, comp, tmp);
10346 : 165 : tmp = gfc_conv_descriptor_dtype (comp);
10347 : 165 : gfc_add_modify (&fnblock, tmp, gfc_get_dtype (ctype));
10348 : :
10349 : 165 : if (c->initializer && c->initializer->rank)
10350 : : {
10351 : 48 : gfc_init_se (&tse, NULL);
10352 : 48 : e = gfc_copy_expr (c->initializer);
10353 : 48 : gfc_insert_parameter_exprs (e, pdt_param_list);
10354 : 48 : gfc_conv_expr_descriptor (&tse, e);
10355 : 48 : gfc_add_block_to_block (&fnblock, &tse.pre);
10356 : 48 : gfc_free_expr (e);
10357 : 48 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
10358 : 48 : tmp = build_call_expr_loc (input_location, tmp, 3,
10359 : : gfc_conv_descriptor_data_get (comp),
10360 : : gfc_conv_descriptor_data_get (tse.expr),
10361 : : fold_convert (size_type_node, size));
10362 : 48 : gfc_add_expr_to_block (&fnblock, tmp);
10363 : 48 : gfc_add_block_to_block (&fnblock, &tse.post);
10364 : : }
10365 : : }
10366 : :
10367 : : /* Recurse in to PDT components. */
10368 : 227 : if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
10369 : 74 : && c->ts.u.derived && c->ts.u.derived->attr.pdt_type
10370 : 74 : && !(c->attr.pointer || c->attr.allocatable))
10371 : : {
10372 : 48 : bool is_deferred = false;
10373 : 48 : gfc_actual_arglist *tail = c->param_list;
10374 : :
10375 : 126 : for (; tail; tail = tail->next)
10376 : 78 : if (!tail->expr)
10377 : 24 : is_deferred = true;
10378 : :
10379 : 48 : tail = is_deferred ? pdt_param_list : c->param_list;
10380 : 48 : tmp = gfc_allocate_pdt_comp (c->ts.u.derived, comp,
10381 : 48 : c->as ? c->as->rank : 0,
10382 : : tail);
10383 : 48 : gfc_add_expr_to_block (&fnblock, tmp);
10384 : : }
10385 : :
10386 : : break;
10387 : :
10388 : 979 : case DEALLOCATE_PDT_COMP:
10389 : : /* Deallocate array or parameterized string length components
10390 : : of parameterized derived types. */
10391 : 979 : if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT)
10392 : 797 : && !c->attr.pdt_string
10393 : 731 : && !((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
10394 : 91 : && (c->ts.u.derived && c->ts.u.derived->attr.pdt_type)))
10395 : 640 : continue;
10396 : :
10397 : 339 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10398 : : decl, cdecl, NULL_TREE);
10399 : 339 : if (c->ts.type == BT_CLASS)
10400 : 0 : comp = gfc_class_data_get (comp);
10401 : :
10402 : : /* Recurse in to PDT components. */
10403 : 339 : if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
10404 : 97 : && c->ts.u.derived && c->ts.u.derived->attr.pdt_type
10405 : 97 : && (!c->attr.pointer && !c->attr.allocatable))
10406 : : {
10407 : 42 : tmp = gfc_deallocate_pdt_comp (c->ts.u.derived, comp,
10408 : 42 : c->as ? c->as->rank : 0);
10409 : 42 : gfc_add_expr_to_block (&fnblock, tmp);
10410 : : }
10411 : :
10412 : 339 : if (c->attr.pdt_array || c->attr.pdt_string)
10413 : : {
10414 : 248 : tmp = comp;
10415 : 248 : if (c->attr.pdt_array)
10416 : 182 : tmp = gfc_conv_descriptor_data_get (comp);
10417 : 248 : null_cond = fold_build2_loc (input_location, NE_EXPR,
10418 : : logical_type_node, tmp,
10419 : 248 : build_int_cst (TREE_TYPE (tmp), 0));
10420 : 248 : if (flag_openmp_allocators)
10421 : : {
10422 : 0 : tree cd, t;
10423 : 0 : if (c->attr.pdt_array)
10424 : 0 : cd = fold_build2_loc (input_location, EQ_EXPR,
10425 : : boolean_type_node,
10426 : : gfc_conv_descriptor_version (comp),
10427 : 0 : build_int_cst (integer_type_node, 1));
10428 : : else
10429 : 0 : cd = gfc_omp_call_is_alloc (tmp);
10430 : 0 : t = builtin_decl_explicit (BUILT_IN_GOMP_FREE);
10431 : 0 : t = build_call_expr_loc (input_location, t, 1, tmp);
10432 : :
10433 : 0 : stmtblock_t tblock;
10434 : 0 : gfc_init_block (&tblock);
10435 : 0 : gfc_add_expr_to_block (&tblock, t);
10436 : 0 : if (c->attr.pdt_array)
10437 : 0 : gfc_add_modify (&tblock, gfc_conv_descriptor_version (comp),
10438 : : integer_zero_node);
10439 : 0 : tmp = build3_loc (input_location, COND_EXPR, void_type_node,
10440 : : cd, gfc_finish_block (&tblock),
10441 : : gfc_call_free (tmp));
10442 : : }
10443 : : else
10444 : 248 : tmp = gfc_call_free (tmp);
10445 : 248 : tmp = build3_v (COND_EXPR, null_cond, tmp,
10446 : : build_empty_stmt (input_location));
10447 : 248 : gfc_add_expr_to_block (&fnblock, tmp);
10448 : :
10449 : 248 : if (c->attr.pdt_array)
10450 : 182 : gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
10451 : : else
10452 : : {
10453 : 66 : tmp = fold_convert (TREE_TYPE (comp), null_pointer_node);
10454 : 66 : gfc_add_modify (&fnblock, comp, tmp);
10455 : : }
10456 : : }
10457 : :
10458 : : break;
10459 : :
10460 : 264 : case CHECK_PDT_DUMMY:
10461 : :
10462 : 264 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10463 : : decl, cdecl, NULL_TREE);
10464 : 264 : if (c->ts.type == BT_CLASS)
10465 : 0 : comp = gfc_class_data_get (comp);
10466 : :
10467 : : /* Recurse in to PDT components. */
10468 : 264 : if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
10469 : 0 : && c->ts.u.derived && c->ts.u.derived->attr.pdt_type)
10470 : : {
10471 : 0 : tmp = gfc_check_pdt_dummy (c->ts.u.derived, comp,
10472 : 0 : c->as ? c->as->rank : 0,
10473 : : pdt_param_list);
10474 : 0 : gfc_add_expr_to_block (&fnblock, tmp);
10475 : : }
10476 : :
10477 : 264 : if (!c->attr.pdt_len)
10478 : 216 : continue;
10479 : : else
10480 : : {
10481 : 48 : gfc_se tse;
10482 : 48 : gfc_expr *c_expr = NULL;
10483 : 48 : gfc_actual_arglist *param = pdt_param_list;
10484 : :
10485 : 48 : gfc_init_se (&tse, NULL);
10486 : 186 : for (; param; param = param->next)
10487 : 90 : if (!strcmp (c->name, param->name)
10488 : 48 : && param->spec_type == SPEC_EXPLICIT)
10489 : 30 : c_expr = param->expr;
10490 : :
10491 : 48 : if (c_expr)
10492 : : {
10493 : 30 : tree error, cond, cname;
10494 : 30 : gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp));
10495 : 30 : cond = fold_build2_loc (input_location, NE_EXPR,
10496 : : logical_type_node,
10497 : : comp, tse.expr);
10498 : 30 : cname = gfc_build_cstring_const (c->name);
10499 : 30 : cname = gfc_build_addr_expr (pchar_type_node, cname);
10500 : 30 : error = gfc_trans_runtime_error (true, NULL,
10501 : : "The value of the PDT LEN "
10502 : : "parameter '%s' does not "
10503 : : "agree with that in the "
10504 : : "dummy declaration",
10505 : : cname);
10506 : 30 : tmp = fold_build3_loc (input_location, COND_EXPR,
10507 : : void_type_node, cond, error,
10508 : : build_empty_stmt (input_location));
10509 : 30 : gfc_add_expr_to_block (&fnblock, tmp);
10510 : : }
10511 : : }
10512 : 48 : break;
10513 : :
10514 : 0 : default:
10515 : 0 : gcc_unreachable ();
10516 : 3525 : break;
10517 : : }
10518 : : }
10519 : :
10520 : 11954 : return gfc_finish_block (&fnblock);
10521 : : }
10522 : :
10523 : : /* Recursively traverse an object of derived type, generating code to
10524 : : nullify allocatable components. */
10525 : :
10526 : : tree
10527 : 2048 : gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
10528 : : int caf_mode)
10529 : : {
10530 : 2048 : return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
10531 : : NULLIFY_ALLOC_COMP,
10532 : : GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode,
10533 : 2048 : NULL);
10534 : : }
10535 : :
10536 : :
10537 : : /* Recursively traverse an object of derived type, generating code to
10538 : : deallocate allocatable components. */
10539 : :
10540 : : tree
10541 : 2229 : gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
10542 : : int caf_mode)
10543 : : {
10544 : 2229 : return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
10545 : : DEALLOCATE_ALLOC_COMP,
10546 : : GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode,
10547 : 2229 : NULL);
10548 : : }
10549 : :
10550 : : tree
10551 : 1 : gfc_bcast_alloc_comp (gfc_symbol *derived, gfc_expr *expr, int rank,
10552 : : tree image_index, tree stat, tree errmsg,
10553 : : tree errmsg_len)
10554 : : {
10555 : 1 : tree tmp, array;
10556 : 1 : gfc_se argse;
10557 : 1 : stmtblock_t block, post_block;
10558 : 1 : gfc_co_subroutines_args args;
10559 : :
10560 : 1 : args.image_index = image_index;
10561 : 1 : args.stat = stat;
10562 : 1 : args.errmsg = errmsg;
10563 : 1 : args.errmsg_len = errmsg_len;
10564 : :
10565 : 1 : if (rank == 0)
10566 : : {
10567 : 1 : gfc_start_block (&block);
10568 : 1 : gfc_init_block (&post_block);
10569 : 1 : gfc_init_se (&argse, NULL);
10570 : 1 : gfc_conv_expr (&argse, expr);
10571 : 1 : gfc_add_block_to_block (&block, &argse.pre);
10572 : 1 : gfc_add_block_to_block (&post_block, &argse.post);
10573 : 1 : array = argse.expr;
10574 : : }
10575 : : else
10576 : : {
10577 : 0 : gfc_init_se (&argse, NULL);
10578 : 0 : argse.want_pointer = 1;
10579 : 0 : gfc_conv_expr_descriptor (&argse, expr);
10580 : 0 : array = argse.expr;
10581 : : }
10582 : :
10583 : 1 : tmp = structure_alloc_comps (derived, array, NULL_TREE, rank,
10584 : : BCAST_ALLOC_COMP,
10585 : : GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY,
10586 : : &args);
10587 : 1 : return tmp;
10588 : : }
10589 : :
10590 : : /* Recursively traverse an object of derived type, generating code to
10591 : : deallocate allocatable components. But do not deallocate coarrays.
10592 : : To be used for intrinsic assignment, which may not change the allocation
10593 : : status of coarrays. */
10594 : :
10595 : : tree
10596 : 1528 : gfc_deallocate_alloc_comp_no_caf (gfc_symbol * der_type, tree decl, int rank,
10597 : : bool no_finalization)
10598 : : {
10599 : 1528 : return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
10600 : : DEALLOCATE_ALLOC_COMP, 0, NULL,
10601 : 1528 : no_finalization);
10602 : : }
10603 : :
10604 : :
10605 : : tree
10606 : 4 : gfc_reassign_alloc_comp_caf (gfc_symbol *der_type, tree decl, tree dest)
10607 : : {
10608 : 4 : return structure_alloc_comps (der_type, decl, dest, 0, REASSIGN_CAF_COMP,
10609 : : GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY,
10610 : 4 : NULL);
10611 : : }
10612 : :
10613 : :
10614 : : /* Recursively traverse an object of derived type, generating code to
10615 : : copy it and its allocatable components. */
10616 : :
10617 : : tree
10618 : 3111 : gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank,
10619 : : int caf_mode)
10620 : : {
10621 : 3111 : return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP,
10622 : 3111 : caf_mode, NULL);
10623 : : }
10624 : :
10625 : :
10626 : : /* Recursively traverse an object of derived type, generating code to
10627 : : copy it and its allocatable components, while suppressing any
10628 : : finalization that might occur. This is used in the finalization of
10629 : : function results. */
10630 : :
10631 : : tree
10632 : 37 : gfc_copy_alloc_comp_no_fini (gfc_symbol * der_type, tree decl, tree dest,
10633 : : int rank, int caf_mode)
10634 : : {
10635 : 37 : return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP,
10636 : 37 : caf_mode, NULL, true);
10637 : : }
10638 : :
10639 : :
10640 : : /* Recursively traverse an object of derived type, generating code to
10641 : : copy only its allocatable components. */
10642 : :
10643 : : tree
10644 : 0 : gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
10645 : : {
10646 : 0 : return structure_alloc_comps (der_type, decl, dest, rank,
10647 : 0 : COPY_ONLY_ALLOC_COMP, 0, NULL);
10648 : : }
10649 : :
10650 : :
10651 : : /* Recursively traverse an object of parameterized derived type, generating
10652 : : code to allocate parameterized components. */
10653 : :
10654 : : tree
10655 : 280 : gfc_allocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank,
10656 : : gfc_actual_arglist *param_list)
10657 : : {
10658 : 280 : tree res;
10659 : 280 : gfc_actual_arglist *old_param_list = pdt_param_list;
10660 : 280 : pdt_param_list = param_list;
10661 : 280 : res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
10662 : : ALLOCATE_PDT_COMP, 0, NULL);
10663 : 280 : pdt_param_list = old_param_list;
10664 : 280 : return res;
10665 : : }
10666 : :
10667 : : /* Recursively traverse an object of parameterized derived type, generating
10668 : : code to deallocate parameterized components. */
10669 : :
10670 : : tree
10671 : 267 : gfc_deallocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank)
10672 : : {
10673 : 267 : return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
10674 : 267 : DEALLOCATE_PDT_COMP, 0, NULL);
10675 : : }
10676 : :
10677 : :
10678 : : /* Recursively traverse a dummy of parameterized derived type to check the
10679 : : values of LEN parameters. */
10680 : :
10681 : : tree
10682 : 48 : gfc_check_pdt_dummy (gfc_symbol * der_type, tree decl, int rank,
10683 : : gfc_actual_arglist *param_list)
10684 : : {
10685 : 48 : tree res;
10686 : 48 : gfc_actual_arglist *old_param_list = pdt_param_list;
10687 : 48 : pdt_param_list = param_list;
10688 : 48 : res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
10689 : : CHECK_PDT_DUMMY, 0, NULL);
10690 : 48 : pdt_param_list = old_param_list;
10691 : 48 : return res;
10692 : : }
10693 : :
10694 : :
10695 : : /* Returns the value of LBOUND for an expression. This could be broken out
10696 : : from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
10697 : : called by gfc_alloc_allocatable_for_assignment. */
10698 : : static tree
10699 : 521 : get_std_lbound (gfc_expr *expr, tree desc, int dim, bool assumed_size)
10700 : : {
10701 : 521 : tree lbound;
10702 : 521 : tree ubound;
10703 : 521 : tree stride;
10704 : 521 : tree cond, cond1, cond3, cond4;
10705 : 521 : tree tmp;
10706 : 521 : gfc_ref *ref;
10707 : :
10708 : 521 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
10709 : : {
10710 : 231 : tmp = gfc_rank_cst[dim];
10711 : 231 : lbound = gfc_conv_descriptor_lbound_get (desc, tmp);
10712 : 231 : ubound = gfc_conv_descriptor_ubound_get (desc, tmp);
10713 : 231 : stride = gfc_conv_descriptor_stride_get (desc, tmp);
10714 : 231 : cond1 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
10715 : : ubound, lbound);
10716 : 231 : cond3 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
10717 : : stride, gfc_index_zero_node);
10718 : 231 : cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
10719 : : logical_type_node, cond3, cond1);
10720 : 231 : cond4 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
10721 : : stride, gfc_index_zero_node);
10722 : 231 : if (assumed_size)
10723 : 0 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10724 : : tmp, build_int_cst (gfc_array_index_type,
10725 : 0 : expr->rank - 1));
10726 : : else
10727 : 231 : cond = logical_false_node;
10728 : :
10729 : 231 : cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
10730 : : logical_type_node, cond3, cond4);
10731 : 231 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
10732 : : logical_type_node, cond, cond1);
10733 : :
10734 : 231 : return fold_build3_loc (input_location, COND_EXPR,
10735 : : gfc_array_index_type, cond,
10736 : 231 : lbound, gfc_index_one_node);
10737 : : }
10738 : :
10739 : 290 : if (expr->expr_type == EXPR_FUNCTION)
10740 : : {
10741 : : /* A conversion function, so use the argument. */
10742 : 7 : gcc_assert (expr->value.function.isym
10743 : : && expr->value.function.isym->conversion);
10744 : 7 : expr = expr->value.function.actual->expr;
10745 : : }
10746 : :
10747 : 290 : if (expr->expr_type == EXPR_VARIABLE)
10748 : : {
10749 : 290 : tmp = TREE_TYPE (expr->symtree->n.sym->backend_decl);
10750 : 592 : for (ref = expr->ref; ref; ref = ref->next)
10751 : : {
10752 : 302 : if (ref->type == REF_COMPONENT
10753 : 11 : && ref->u.c.component->as
10754 : 10 : && ref->next
10755 : 10 : && ref->next->u.ar.type == AR_FULL)
10756 : 10 : tmp = TREE_TYPE (ref->u.c.component->backend_decl);
10757 : : }
10758 : 290 : return GFC_TYPE_ARRAY_LBOUND(tmp, dim);
10759 : : }
10760 : :
10761 : 0 : return gfc_index_one_node;
10762 : : }
10763 : :
10764 : :
10765 : : /* Returns true if an expression represents an lhs that can be reallocated
10766 : : on assignment. */
10767 : :
10768 : : bool
10769 : 409380 : gfc_is_reallocatable_lhs (gfc_expr *expr)
10770 : : {
10771 : 409380 : gfc_ref * ref;
10772 : 409380 : gfc_symbol *sym;
10773 : :
10774 : 409380 : if (!expr->ref)
10775 : : return false;
10776 : :
10777 : 173993 : sym = expr->symtree->n.sym;
10778 : :
10779 : 173993 : if (sym->attr.associate_var && !expr->ref)
10780 : : return false;
10781 : :
10782 : : /* An allocatable class variable with no reference. */
10783 : 173993 : if (sym->ts.type == BT_CLASS
10784 : 6534 : && (!sym->attr.associate_var || sym->attr.select_rank_temporary)
10785 : 6402 : && CLASS_DATA (sym)->attr.allocatable
10786 : : && expr->ref
10787 : 3956 : && ((expr->ref->type == REF_ARRAY && expr->ref->u.ar.type == AR_FULL
10788 : 0 : && expr->ref->next == NULL)
10789 : 3956 : || (expr->ref->type == REF_COMPONENT
10790 : 3956 : && strcmp (expr->ref->u.c.component->name, "_data") == 0
10791 : 3238 : && (expr->ref->next == NULL
10792 : 2503 : || (expr->ref->next->type == REF_ARRAY
10793 : 2503 : && expr->ref->next->u.ar.type == AR_FULL
10794 : 1935 : && expr->ref->next->next == NULL)))))
10795 : : return true;
10796 : :
10797 : : /* An allocatable variable. */
10798 : 171500 : if (sym->attr.allocatable
10799 : 30896 : && (!sym->attr.associate_var || sym->attr.select_rank_temporary)
10800 : : && expr->ref
10801 : 30896 : && expr->ref->type == REF_ARRAY
10802 : 29719 : && expr->ref->u.ar.type == AR_FULL)
10803 : : return true;
10804 : :
10805 : : /* All that can be left are allocatable components. */
10806 : 156097 : if ((sym->ts.type != BT_DERIVED
10807 : 127103 : && sym->ts.type != BT_CLASS)
10808 : 33035 : || !sym->ts.u.derived->attr.alloc_comp)
10809 : : return false;
10810 : :
10811 : : /* Find a component ref followed by an array reference. */
10812 : 18821 : for (ref = expr->ref; ref; ref = ref->next)
10813 : 14645 : if (ref->next
10814 : 10469 : && ref->type == REF_COMPONENT
10815 : 7596 : && ref->next->type == REF_ARRAY
10816 : 5772 : && !ref->next->next)
10817 : : break;
10818 : :
10819 : 8778 : if (!ref)
10820 : : return false;
10821 : :
10822 : : /* Return true if valid reallocatable lhs. */
10823 : 4602 : if (ref->u.c.component->attr.allocatable
10824 : 4489 : && ref->next->u.ar.type == AR_FULL)
10825 : 3181 : return true;
10826 : :
10827 : : return false;
10828 : : }
10829 : :
10830 : :
10831 : : static tree
10832 : 56 : concat_str_length (gfc_expr* expr)
10833 : : {
10834 : 56 : tree type;
10835 : 56 : tree len1;
10836 : 56 : tree len2;
10837 : 56 : gfc_se se;
10838 : :
10839 : 56 : type = gfc_typenode_for_spec (&expr->value.op.op1->ts);
10840 : 56 : len1 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
10841 : 56 : if (len1 == NULL_TREE)
10842 : : {
10843 : 56 : if (expr->value.op.op1->expr_type == EXPR_OP)
10844 : 31 : len1 = concat_str_length (expr->value.op.op1);
10845 : 25 : else if (expr->value.op.op1->expr_type == EXPR_CONSTANT)
10846 : 25 : len1 = build_int_cst (gfc_charlen_type_node,
10847 : 25 : expr->value.op.op1->value.character.length);
10848 : 0 : else if (expr->value.op.op1->ts.u.cl->length)
10849 : : {
10850 : 0 : gfc_init_se (&se, NULL);
10851 : 0 : gfc_conv_expr (&se, expr->value.op.op1->ts.u.cl->length);
10852 : 0 : len1 = se.expr;
10853 : : }
10854 : : else
10855 : : {
10856 : : /* Last resort! */
10857 : 0 : gfc_init_se (&se, NULL);
10858 : 0 : se.want_pointer = 1;
10859 : 0 : se.descriptor_only = 1;
10860 : 0 : gfc_conv_expr (&se, expr->value.op.op1);
10861 : 0 : len1 = se.string_length;
10862 : : }
10863 : : }
10864 : :
10865 : 56 : type = gfc_typenode_for_spec (&expr->value.op.op2->ts);
10866 : 56 : len2 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
10867 : 56 : if (len2 == NULL_TREE)
10868 : : {
10869 : 31 : if (expr->value.op.op2->expr_type == EXPR_OP)
10870 : 0 : len2 = concat_str_length (expr->value.op.op2);
10871 : 31 : else if (expr->value.op.op2->expr_type == EXPR_CONSTANT)
10872 : 25 : len2 = build_int_cst (gfc_charlen_type_node,
10873 : 25 : expr->value.op.op2->value.character.length);
10874 : 6 : else if (expr->value.op.op2->ts.u.cl->length)
10875 : : {
10876 : 6 : gfc_init_se (&se, NULL);
10877 : 6 : gfc_conv_expr (&se, expr->value.op.op2->ts.u.cl->length);
10878 : 6 : len2 = se.expr;
10879 : : }
10880 : : else
10881 : : {
10882 : : /* Last resort! */
10883 : 0 : gfc_init_se (&se, NULL);
10884 : 0 : se.want_pointer = 1;
10885 : 0 : se.descriptor_only = 1;
10886 : 0 : gfc_conv_expr (&se, expr->value.op.op2);
10887 : 0 : len2 = se.string_length;
10888 : : }
10889 : : }
10890 : :
10891 : 56 : gcc_assert(len1 && len2);
10892 : 56 : len1 = fold_convert (gfc_charlen_type_node, len1);
10893 : 56 : len2 = fold_convert (gfc_charlen_type_node, len2);
10894 : :
10895 : 56 : return fold_build2_loc (input_location, PLUS_EXPR,
10896 : 56 : gfc_charlen_type_node, len1, len2);
10897 : : }
10898 : :
10899 : :
10900 : : /* Allocate the lhs of an assignment to an allocatable array, otherwise
10901 : : reallocate it. */
10902 : :
10903 : : tree
10904 : 2964 : gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
10905 : : gfc_expr *expr1,
10906 : : gfc_expr *expr2)
10907 : : {
10908 : 2964 : stmtblock_t realloc_block;
10909 : 2964 : stmtblock_t alloc_block;
10910 : 2964 : stmtblock_t fblock;
10911 : 2964 : gfc_ss *rss;
10912 : 2964 : gfc_ss *lss;
10913 : 2964 : gfc_array_info *linfo;
10914 : 2964 : tree realloc_expr;
10915 : 2964 : tree alloc_expr;
10916 : 2964 : tree size1;
10917 : 2964 : tree size2;
10918 : 2964 : tree elemsize1;
10919 : 2964 : tree elemsize2;
10920 : 2964 : tree array1;
10921 : 2964 : tree cond_null;
10922 : 2964 : tree cond;
10923 : 2964 : tree tmp;
10924 : 2964 : tree tmp2;
10925 : 2964 : tree lbound;
10926 : 2964 : tree ubound;
10927 : 2964 : tree desc;
10928 : 2964 : tree old_desc;
10929 : 2964 : tree desc2;
10930 : 2964 : tree offset;
10931 : 2964 : tree jump_label1;
10932 : 2964 : tree jump_label2;
10933 : 2964 : tree lbd;
10934 : 2964 : tree class_expr2 = NULL_TREE;
10935 : 2964 : int n;
10936 : 2964 : int dim;
10937 : 2964 : gfc_array_spec * as;
10938 : 2964 : bool coarray = (flag_coarray == GFC_FCOARRAY_LIB
10939 : 2964 : && gfc_caf_attr (expr1, true).codimension);
10940 : 2964 : tree token;
10941 : 2964 : gfc_se caf_se;
10942 : :
10943 : : /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
10944 : : Find the lhs expression in the loop chain and set expr1 and
10945 : : expr2 accordingly. */
10946 : 2964 : if (expr1->expr_type == EXPR_FUNCTION && expr2 == NULL)
10947 : : {
10948 : 152 : expr2 = expr1;
10949 : : /* Find the ss for the lhs. */
10950 : 152 : lss = loop->ss;
10951 : 304 : for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
10952 : 304 : if (lss->info->expr && lss->info->expr->expr_type == EXPR_VARIABLE)
10953 : : break;
10954 : 152 : if (lss == gfc_ss_terminator)
10955 : : return NULL_TREE;
10956 : 152 : expr1 = lss->info->expr;
10957 : : }
10958 : :
10959 : : /* Bail out if this is not a valid allocate on assignment. */
10960 : 2964 : if (!gfc_is_reallocatable_lhs (expr1)
10961 : 2964 : || (expr2 && !expr2->rank))
10962 : : return NULL_TREE;
10963 : :
10964 : : /* Find the ss for the lhs. */
10965 : 2964 : lss = loop->ss;
10966 : 6768 : for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
10967 : 6768 : if (lss->info->expr == expr1)
10968 : : break;
10969 : :
10970 : 2964 : if (lss == gfc_ss_terminator)
10971 : : return NULL_TREE;
10972 : :
10973 : 2964 : linfo = &lss->info->data.array;
10974 : :
10975 : : /* Find an ss for the rhs. For operator expressions, we see the
10976 : : ss's for the operands. Any one of these will do. */
10977 : 2964 : rss = loop->ss;
10978 : 3349 : for (; rss && rss != gfc_ss_terminator; rss = rss->loop_chain)
10979 : 3349 : if (rss->info->expr != expr1 && rss != loop->temp_ss)
10980 : : break;
10981 : :
10982 : 2964 : if (expr2 && rss == gfc_ss_terminator)
10983 : : return NULL_TREE;
10984 : :
10985 : : /* Ensure that the string length from the current scope is used. */
10986 : 2964 : if (expr2->ts.type == BT_CHARACTER
10987 : 596 : && expr2->expr_type == EXPR_FUNCTION
10988 : 82 : && !expr2->value.function.isym)
10989 : 21 : expr2->ts.u.cl->backend_decl = rss->info->string_length;
10990 : :
10991 : 2964 : gfc_start_block (&fblock);
10992 : :
10993 : : /* Since the lhs is allocatable, this must be a descriptor type.
10994 : : Get the data and array size. */
10995 : 2964 : desc = linfo->descriptor;
10996 : 2964 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
10997 : 2964 : array1 = gfc_conv_descriptor_data_get (desc);
10998 : :
10999 : 2964 : if (expr2)
11000 : 2964 : desc2 = rss->info->data.array.descriptor;
11001 : : else
11002 : : desc2 = NULL_TREE;
11003 : :
11004 : : /* Get the old lhs element size for deferred character and class expr1. */
11005 : 2964 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
11006 : : {
11007 : 391 : if (expr1->ts.u.cl->backend_decl
11008 : 391 : && VAR_P (expr1->ts.u.cl->backend_decl))
11009 : : elemsize1 = expr1->ts.u.cl->backend_decl;
11010 : : else
11011 : 63 : elemsize1 = lss->info->string_length;
11012 : 391 : tree unit_size = TYPE_SIZE_UNIT (gfc_get_char_type (expr1->ts.kind));
11013 : 782 : elemsize1 = fold_build2_loc (input_location, MULT_EXPR,
11014 : 391 : TREE_TYPE (elemsize1), elemsize1,
11015 : 391 : fold_convert (TREE_TYPE (elemsize1), unit_size));
11016 : :
11017 : 391 : }
11018 : 2573 : else if (expr1->ts.type == BT_CLASS)
11019 : : {
11020 : : /* Unfortunately, the lhs vptr is set too early in many cases.
11021 : : Play it safe by using the descriptor element length. */
11022 : 343 : tmp = gfc_conv_descriptor_elem_len (desc);
11023 : 343 : elemsize1 = fold_convert (gfc_array_index_type, tmp);
11024 : : }
11025 : : else
11026 : : elemsize1 = NULL_TREE;
11027 : 734 : if (elemsize1 != NULL_TREE)
11028 : 734 : elemsize1 = gfc_evaluate_now (elemsize1, &fblock);
11029 : :
11030 : : /* Get the new lhs size in bytes. */
11031 : 2964 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
11032 : : {
11033 : 391 : if (expr2->ts.deferred)
11034 : : {
11035 : 87 : if (expr2->ts.u.cl->backend_decl
11036 : 87 : && VAR_P (expr2->ts.u.cl->backend_decl))
11037 : : tmp = expr2->ts.u.cl->backend_decl;
11038 : : else
11039 : 0 : tmp = rss->info->string_length;
11040 : : }
11041 : : else
11042 : : {
11043 : 304 : tmp = expr2->ts.u.cl->backend_decl;
11044 : 304 : if (!tmp && expr2->expr_type == EXPR_OP
11045 : 25 : && expr2->value.op.op == INTRINSIC_CONCAT)
11046 : : {
11047 : 25 : tmp = concat_str_length (expr2);
11048 : 25 : expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
11049 : : }
11050 : 12 : else if (!tmp && expr2->ts.u.cl->length)
11051 : : {
11052 : 12 : gfc_se tmpse;
11053 : 12 : gfc_init_se (&tmpse, NULL);
11054 : 12 : gfc_conv_expr_type (&tmpse, expr2->ts.u.cl->length,
11055 : : gfc_charlen_type_node);
11056 : 12 : tmp = tmpse.expr;
11057 : 12 : expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
11058 : : }
11059 : 304 : tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
11060 : : }
11061 : :
11062 : 391 : if (expr1->ts.u.cl->backend_decl
11063 : 391 : && VAR_P (expr1->ts.u.cl->backend_decl))
11064 : 328 : gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
11065 : : else
11066 : 63 : gfc_add_modify (&fblock, lss->info->string_length, tmp);
11067 : :
11068 : 391 : if (expr1->ts.kind > 1)
11069 : 12 : tmp = fold_build2_loc (input_location, MULT_EXPR,
11070 : 6 : TREE_TYPE (tmp),
11071 : 6 : tmp, build_int_cst (TREE_TYPE (tmp),
11072 : 6 : expr1->ts.kind));
11073 : : }
11074 : 2573 : else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
11075 : : {
11076 : 199 : tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts)));
11077 : 199 : tmp = fold_build2_loc (input_location, MULT_EXPR,
11078 : : gfc_array_index_type, tmp,
11079 : 199 : expr1->ts.u.cl->backend_decl);
11080 : : }
11081 : 2374 : else if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS)
11082 : 43 : tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
11083 : 2331 : else if (expr1->ts.type == BT_CLASS && expr2->ts.type == BT_CLASS)
11084 : : {
11085 : 160 : tmp = expr2->rank ? gfc_get_class_from_expr (desc2) : NULL_TREE;
11086 : 160 : if (tmp == NULL_TREE && expr2->expr_type == EXPR_VARIABLE)
11087 : 6 : tmp = class_expr2 = gfc_get_class_from_gfc_expr (expr2);
11088 : :
11089 : 13 : if (tmp != NULL_TREE)
11090 : 153 : tmp = gfc_class_vtab_size_get (tmp);
11091 : : else
11092 : 7 : tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&CLASS_DATA (expr2)->ts));
11093 : : }
11094 : : else
11095 : 2171 : tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
11096 : 2964 : elemsize2 = fold_convert (gfc_array_index_type, tmp);
11097 : 2964 : elemsize2 = gfc_evaluate_now (elemsize2, &fblock);
11098 : :
11099 : : /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
11100 : : deallocated if expr is an array of different shape or any of the
11101 : : corresponding length type parameter values of variable and expr
11102 : : differ." This assures F95 compatibility. */
11103 : 2964 : jump_label1 = gfc_build_label_decl (NULL_TREE);
11104 : 2964 : jump_label2 = gfc_build_label_decl (NULL_TREE);
11105 : :
11106 : : /* Allocate if data is NULL. */
11107 : 2964 : cond_null = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
11108 : 2964 : array1, build_int_cst (TREE_TYPE (array1), 0));
11109 : 2964 : cond_null= gfc_evaluate_now (cond_null, &fblock);
11110 : :
11111 : 2964 : tmp = build3_v (COND_EXPR, cond_null,
11112 : : build1_v (GOTO_EXPR, jump_label1),
11113 : : build_empty_stmt (input_location));
11114 : 2964 : gfc_add_expr_to_block (&fblock, tmp);
11115 : :
11116 : : /* Get arrayspec if expr is a full array. */
11117 : 2964 : if (expr2 && expr2->expr_type == EXPR_FUNCTION
11118 : 776 : && expr2->value.function.isym
11119 : 373 : && expr2->value.function.isym->conversion)
11120 : : {
11121 : : /* For conversion functions, take the arg. */
11122 : 243 : gfc_expr *arg = expr2->value.function.actual->expr;
11123 : 243 : as = gfc_get_full_arrayspec_from_expr (arg);
11124 : 243 : }
11125 : : else if (expr2)
11126 : 2721 : as = gfc_get_full_arrayspec_from_expr (expr2);
11127 : : else
11128 : : as = NULL;
11129 : :
11130 : : /* If the lhs shape is not the same as the rhs jump to setting the
11131 : : bounds and doing the reallocation....... */
11132 : 6815 : for (n = 0; n < expr1->rank; n++)
11133 : : {
11134 : : /* Check the shape. */
11135 : 3851 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
11136 : 3851 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
11137 : 3851 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
11138 : : gfc_array_index_type,
11139 : : loop->to[n], loop->from[n]);
11140 : 3851 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
11141 : : gfc_array_index_type,
11142 : : tmp, lbound);
11143 : 3851 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
11144 : : gfc_array_index_type,
11145 : : tmp, ubound);
11146 : 3851 : cond = fold_build2_loc (input_location, NE_EXPR,
11147 : : logical_type_node,
11148 : : tmp, gfc_index_zero_node);
11149 : 3851 : tmp = build3_v (COND_EXPR, cond,
11150 : : build1_v (GOTO_EXPR, jump_label1),
11151 : : build_empty_stmt (input_location));
11152 : 3851 : gfc_add_expr_to_block (&fblock, tmp);
11153 : : }
11154 : :
11155 : : /* ...else if the element lengths are not the same also go to
11156 : : setting the bounds and doing the reallocation.... */
11157 : 2964 : if (elemsize1 != NULL_TREE)
11158 : : {
11159 : 734 : cond = fold_build2_loc (input_location, NE_EXPR,
11160 : : logical_type_node,
11161 : : elemsize1, elemsize2);
11162 : 734 : tmp = build3_v (COND_EXPR, cond,
11163 : : build1_v (GOTO_EXPR, jump_label1),
11164 : : build_empty_stmt (input_location));
11165 : 734 : gfc_add_expr_to_block (&fblock, tmp);
11166 : : }
11167 : :
11168 : : /* ....else jump past the (re)alloc code. */
11169 : 2964 : tmp = build1_v (GOTO_EXPR, jump_label2);
11170 : 2964 : gfc_add_expr_to_block (&fblock, tmp);
11171 : :
11172 : : /* Add the label to start automatic (re)allocation. */
11173 : 2964 : tmp = build1_v (LABEL_EXPR, jump_label1);
11174 : 2964 : gfc_add_expr_to_block (&fblock, tmp);
11175 : :
11176 : : /* Get the rhs size and fix it. */
11177 : 2964 : size2 = gfc_index_one_node;
11178 : 6815 : for (n = 0; n < expr2->rank; n++)
11179 : : {
11180 : 3851 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
11181 : : gfc_array_index_type,
11182 : : loop->to[n], loop->from[n]);
11183 : 3851 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
11184 : : gfc_array_index_type,
11185 : : tmp, gfc_index_one_node);
11186 : 3851 : size2 = fold_build2_loc (input_location, MULT_EXPR,
11187 : : gfc_array_index_type,
11188 : : tmp, size2);
11189 : : }
11190 : 2964 : size2 = gfc_evaluate_now (size2, &fblock);
11191 : :
11192 : : /* Deallocation of allocatable components will have to occur on
11193 : : reallocation. Fix the old descriptor now. */
11194 : 2964 : if ((expr1->ts.type == BT_DERIVED)
11195 : 221 : && expr1->ts.u.derived->attr.alloc_comp)
11196 : 84 : old_desc = gfc_evaluate_now (desc, &fblock);
11197 : : else
11198 : : old_desc = NULL_TREE;
11199 : :
11200 : : /* Now modify the lhs descriptor and the associated scalarizer
11201 : : variables. F2003 7.4.1.3: "If variable is or becomes an
11202 : : unallocated allocatable variable, then it is allocated with each
11203 : : deferred type parameter equal to the corresponding type parameters
11204 : : of expr , with the shape of expr , and with each lower bound equal
11205 : : to the corresponding element of LBOUND(expr)."
11206 : : Reuse size1 to keep a dimension-by-dimension track of the
11207 : : stride of the new array. */
11208 : 2964 : size1 = gfc_index_one_node;
11209 : 2964 : offset = gfc_index_zero_node;
11210 : :
11211 : 6815 : for (n = 0; n < expr2->rank; n++)
11212 : : {
11213 : 3851 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
11214 : : gfc_array_index_type,
11215 : : loop->to[n], loop->from[n]);
11216 : 3851 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
11217 : : gfc_array_index_type,
11218 : : tmp, gfc_index_one_node);
11219 : :
11220 : 3851 : lbound = gfc_index_one_node;
11221 : 3851 : ubound = tmp;
11222 : :
11223 : 3851 : if (as)
11224 : : {
11225 : 1042 : lbd = get_std_lbound (expr2, desc2, n,
11226 : 521 : as->type == AS_ASSUMED_SIZE);
11227 : 521 : ubound = fold_build2_loc (input_location,
11228 : : MINUS_EXPR,
11229 : : gfc_array_index_type,
11230 : : ubound, lbound);
11231 : 521 : ubound = fold_build2_loc (input_location,
11232 : : PLUS_EXPR,
11233 : : gfc_array_index_type,
11234 : : ubound, lbd);
11235 : 521 : lbound = lbd;
11236 : : }
11237 : :
11238 : 3851 : gfc_conv_descriptor_lbound_set (&fblock, desc,
11239 : : gfc_rank_cst[n],
11240 : : lbound);
11241 : 3851 : gfc_conv_descriptor_ubound_set (&fblock, desc,
11242 : : gfc_rank_cst[n],
11243 : : ubound);
11244 : 3851 : gfc_conv_descriptor_stride_set (&fblock, desc,
11245 : : gfc_rank_cst[n],
11246 : : size1);
11247 : 3851 : lbound = gfc_conv_descriptor_lbound_get (desc,
11248 : : gfc_rank_cst[n]);
11249 : 3851 : tmp2 = fold_build2_loc (input_location, MULT_EXPR,
11250 : : gfc_array_index_type,
11251 : : lbound, size1);
11252 : 3851 : offset = fold_build2_loc (input_location, MINUS_EXPR,
11253 : : gfc_array_index_type,
11254 : : offset, tmp2);
11255 : 3851 : size1 = fold_build2_loc (input_location, MULT_EXPR,
11256 : : gfc_array_index_type,
11257 : : tmp, size1);
11258 : : }
11259 : :
11260 : : /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
11261 : : the array offset is saved and the info.offset is used for a
11262 : : running offset. Use the saved_offset instead. */
11263 : 2964 : tmp = gfc_conv_descriptor_offset (desc);
11264 : 2964 : gfc_add_modify (&fblock, tmp, offset);
11265 : 2964 : if (linfo->saved_offset
11266 : 2964 : && VAR_P (linfo->saved_offset))
11267 : 2964 : gfc_add_modify (&fblock, linfo->saved_offset, tmp);
11268 : :
11269 : : /* Now set the deltas for the lhs. */
11270 : 6815 : for (n = 0; n < expr1->rank; n++)
11271 : : {
11272 : 3851 : tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
11273 : 3851 : dim = lss->dim[n];
11274 : 3851 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
11275 : : gfc_array_index_type, tmp,
11276 : : loop->from[dim]);
11277 : 3851 : if (linfo->delta[dim] && VAR_P (linfo->delta[dim]))
11278 : 3851 : gfc_add_modify (&fblock, linfo->delta[dim], tmp);
11279 : : }
11280 : :
11281 : 2964 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
11282 : 2964 : gfc_conv_descriptor_span_set (&fblock, desc, elemsize2);
11283 : :
11284 : 2964 : size2 = fold_build2_loc (input_location, MULT_EXPR,
11285 : : gfc_array_index_type,
11286 : : elemsize2, size2);
11287 : 2964 : size2 = fold_convert (size_type_node, size2);
11288 : 2964 : size2 = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
11289 : : size2, size_one_node);
11290 : 2964 : size2 = gfc_evaluate_now (size2, &fblock);
11291 : :
11292 : : /* For deferred character length, the 'size' field of the dtype might
11293 : : have changed so set the dtype. */
11294 : 2964 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
11295 : 2964 : && expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
11296 : : {
11297 : 391 : tree type;
11298 : 391 : tmp = gfc_conv_descriptor_dtype (desc);
11299 : 391 : if (expr2->ts.u.cl->backend_decl)
11300 : 391 : type = gfc_typenode_for_spec (&expr2->ts);
11301 : : else
11302 : 0 : type = gfc_typenode_for_spec (&expr1->ts);
11303 : :
11304 : 391 : gfc_add_modify (&fblock, tmp,
11305 : : gfc_get_dtype_rank_type (expr1->rank,type));
11306 : : }
11307 : 2573 : else if (expr1->ts.type == BT_CLASS)
11308 : : {
11309 : 343 : tree type;
11310 : 343 : tmp = gfc_conv_descriptor_dtype (desc);
11311 : :
11312 : 343 : if (expr2->ts.type != BT_CLASS)
11313 : 183 : type = gfc_typenode_for_spec (&expr2->ts);
11314 : : else
11315 : 160 : type = gfc_get_character_type_len (1, elemsize2);
11316 : :
11317 : 343 : gfc_add_modify (&fblock, tmp,
11318 : : gfc_get_dtype_rank_type (expr2->rank,type));
11319 : : /* Set the _len field as well... */
11320 : 343 : if (UNLIMITED_POLY (expr1))
11321 : : {
11322 : 93 : tmp = gfc_class_len_get (TREE_OPERAND (desc, 0));
11323 : 93 : if (expr2->ts.type == BT_CHARACTER)
11324 : 6 : gfc_add_modify (&fblock, tmp,
11325 : 6 : fold_convert (TREE_TYPE (tmp),
11326 : : TYPE_SIZE_UNIT (type)));
11327 : : else
11328 : 87 : gfc_add_modify (&fblock, tmp,
11329 : 87 : build_int_cst (TREE_TYPE (tmp), 0));
11330 : : }
11331 : : /* ...and the vptr. */
11332 : 343 : tmp = gfc_class_vptr_get (TREE_OPERAND (desc, 0));
11333 : 343 : if (expr2->ts.type == BT_CLASS && !VAR_P (desc2)
11334 : 153 : && TREE_CODE (desc2) == COMPONENT_REF)
11335 : : {
11336 : 147 : tmp2 = gfc_get_class_from_expr (desc2);
11337 : 147 : tmp2 = gfc_class_vptr_get (tmp2);
11338 : : }
11339 : 196 : else if (expr2->ts.type == BT_CLASS && class_expr2 != NULL_TREE)
11340 : 6 : tmp2 = gfc_class_vptr_get (class_expr2);
11341 : : else
11342 : : {
11343 : 190 : tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts));
11344 : 190 : tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2);
11345 : : }
11346 : :
11347 : 343 : gfc_add_modify (&fblock, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
11348 : : }
11349 : 2230 : else if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
11350 : : {
11351 : 38 : gfc_add_modify (&fblock, gfc_conv_descriptor_dtype (desc),
11352 : 38 : gfc_get_dtype (TREE_TYPE (desc)));
11353 : : }
11354 : :
11355 : : /* Realloc expression. Note that the scalarizer uses desc.data
11356 : : in the array reference - (*desc.data)[<element>]. */
11357 : 2964 : gfc_init_block (&realloc_block);
11358 : 2964 : gfc_init_se (&caf_se, NULL);
11359 : :
11360 : 2964 : if (coarray)
11361 : : {
11362 : 38 : token = gfc_get_ultimate_alloc_ptr_comps_caf_token (&caf_se, expr1);
11363 : 38 : if (token == NULL_TREE)
11364 : : {
11365 : 8 : tmp = gfc_get_tree_for_caf_expr (expr1);
11366 : 8 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
11367 : 6 : tmp = build_fold_indirect_ref (tmp);
11368 : 8 : gfc_get_caf_token_offset (&caf_se, &token, NULL, tmp, NULL_TREE,
11369 : : expr1);
11370 : 8 : token = gfc_build_addr_expr (NULL_TREE, token);
11371 : : }
11372 : :
11373 : 38 : gfc_add_block_to_block (&realloc_block, &caf_se.pre);
11374 : : }
11375 : 2964 : if ((expr1->ts.type == BT_DERIVED)
11376 : 221 : && expr1->ts.u.derived->attr.alloc_comp)
11377 : : {
11378 : 84 : tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, old_desc,
11379 : : expr1->rank, true);
11380 : 84 : gfc_add_expr_to_block (&realloc_block, tmp);
11381 : : }
11382 : :
11383 : 2964 : if (!coarray)
11384 : : {
11385 : 2926 : tmp = build_call_expr_loc (input_location,
11386 : : builtin_decl_explicit (BUILT_IN_REALLOC), 2,
11387 : : fold_convert (pvoid_type_node, array1),
11388 : : size2);
11389 : 2926 : if (flag_openmp_allocators)
11390 : : {
11391 : 2 : tree cond, omp_tmp;
11392 : 2 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
11393 : : gfc_conv_descriptor_version (desc),
11394 : 2 : build_int_cst (integer_type_node, 1));
11395 : 2 : omp_tmp = builtin_decl_explicit (BUILT_IN_GOMP_REALLOC);
11396 : 2 : omp_tmp = build_call_expr_loc (input_location, omp_tmp, 4,
11397 : : fold_convert (pvoid_type_node, array1), size2,
11398 : : build_zero_cst (ptr_type_node),
11399 : : build_zero_cst (ptr_type_node));
11400 : 2 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond,
11401 : : omp_tmp, tmp);
11402 : : }
11403 : :
11404 : 2926 : gfc_conv_descriptor_data_set (&realloc_block, desc, tmp);
11405 : : }
11406 : : else
11407 : : {
11408 : 38 : tmp = build_call_expr_loc (input_location,
11409 : : gfor_fndecl_caf_deregister, 5, token,
11410 : : build_int_cst (integer_type_node,
11411 : 38 : GFC_CAF_COARRAY_DEALLOCATE_ONLY),
11412 : : null_pointer_node, null_pointer_node,
11413 : : integer_zero_node);
11414 : 38 : gfc_add_expr_to_block (&realloc_block, tmp);
11415 : 76 : tmp = build_call_expr_loc (input_location,
11416 : : gfor_fndecl_caf_register,
11417 : : 7, size2,
11418 : : build_int_cst (integer_type_node,
11419 : 38 : GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY),
11420 : : token, gfc_build_addr_expr (NULL_TREE, desc),
11421 : : null_pointer_node, null_pointer_node,
11422 : : integer_zero_node);
11423 : 38 : gfc_add_expr_to_block (&realloc_block, tmp);
11424 : : }
11425 : :
11426 : 2964 : if ((expr1->ts.type == BT_DERIVED)
11427 : 221 : && expr1->ts.u.derived->attr.alloc_comp)
11428 : : {
11429 : 84 : tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc,
11430 : : expr1->rank);
11431 : 84 : gfc_add_expr_to_block (&realloc_block, tmp);
11432 : : }
11433 : :
11434 : 2964 : gfc_add_block_to_block (&realloc_block, &caf_se.post);
11435 : 2964 : realloc_expr = gfc_finish_block (&realloc_block);
11436 : :
11437 : : /* Malloc expression. */
11438 : 2964 : gfc_init_block (&alloc_block);
11439 : 2964 : if (!coarray)
11440 : : {
11441 : 2926 : tmp = build_call_expr_loc (input_location,
11442 : : builtin_decl_explicit (BUILT_IN_MALLOC),
11443 : : 1, size2);
11444 : 2926 : gfc_conv_descriptor_data_set (&alloc_block,
11445 : : desc, tmp);
11446 : : }
11447 : : else
11448 : : {
11449 : 76 : tmp = build_call_expr_loc (input_location,
11450 : : gfor_fndecl_caf_register,
11451 : : 7, size2,
11452 : : build_int_cst (integer_type_node,
11453 : 38 : GFC_CAF_COARRAY_ALLOC),
11454 : : token, gfc_build_addr_expr (NULL_TREE, desc),
11455 : : null_pointer_node, null_pointer_node,
11456 : : integer_zero_node);
11457 : 38 : gfc_add_expr_to_block (&alloc_block, tmp);
11458 : : }
11459 : :
11460 : :
11461 : : /* We already set the dtype in the case of deferred character
11462 : : length arrays and class lvalues. */
11463 : 2964 : if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
11464 : 2964 : && ((expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
11465 : 2573 : || coarray))
11466 : 5499 : && expr1->ts.type != BT_CLASS)
11467 : : {
11468 : 2192 : tmp = gfc_conv_descriptor_dtype (desc);
11469 : 2192 : gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
11470 : : }
11471 : :
11472 : 2964 : if ((expr1->ts.type == BT_DERIVED)
11473 : 221 : && expr1->ts.u.derived->attr.alloc_comp)
11474 : : {
11475 : 84 : tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc,
11476 : : expr1->rank);
11477 : 84 : gfc_add_expr_to_block (&alloc_block, tmp);
11478 : : }
11479 : 2964 : alloc_expr = gfc_finish_block (&alloc_block);
11480 : :
11481 : : /* Malloc if not allocated; realloc otherwise. */
11482 : 2964 : tmp = build3_v (COND_EXPR, cond_null, alloc_expr, realloc_expr);
11483 : 2964 : gfc_add_expr_to_block (&fblock, tmp);
11484 : :
11485 : : /* Make sure that the scalarizer data pointer is updated. */
11486 : 2964 : if (linfo->data && VAR_P (linfo->data))
11487 : : {
11488 : 2621 : tmp = gfc_conv_descriptor_data_get (desc);
11489 : 2621 : gfc_add_modify (&fblock, linfo->data, tmp);
11490 : : }
11491 : :
11492 : : /* Add the label for same shape lhs and rhs. */
11493 : 2964 : tmp = build1_v (LABEL_EXPR, jump_label2);
11494 : 2964 : gfc_add_expr_to_block (&fblock, tmp);
11495 : :
11496 : 2964 : return gfc_finish_block (&fblock);
11497 : : }
11498 : :
11499 : :
11500 : : /* Initialize class descriptor's TKR information. */
11501 : :
11502 : : void
11503 : 2527 : gfc_trans_class_array (gfc_symbol * sym, gfc_wrapped_block * block)
11504 : : {
11505 : 2527 : tree type, etype;
11506 : 2527 : tree tmp;
11507 : 2527 : tree descriptor;
11508 : 2527 : stmtblock_t init;
11509 : 2527 : locus loc;
11510 : 2527 : int rank;
11511 : :
11512 : : /* Make sure the frontend gets these right. */
11513 : 2527 : gcc_assert (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
11514 : : && (CLASS_DATA (sym)->attr.class_pointer
11515 : : || CLASS_DATA (sym)->attr.allocatable));
11516 : :
11517 : 2527 : gcc_assert (VAR_P (sym->backend_decl)
11518 : : || TREE_CODE (sym->backend_decl) == PARM_DECL);
11519 : :
11520 : 2527 : if (sym->attr.dummy)
11521 : 1294 : return;
11522 : :
11523 : 2527 : descriptor = gfc_class_data_get (sym->backend_decl);
11524 : 2527 : type = TREE_TYPE (descriptor);
11525 : :
11526 : 2527 : if (type == NULL || !GFC_DESCRIPTOR_TYPE_P (type))
11527 : : return;
11528 : :
11529 : 1233 : gfc_save_backend_locus (&loc);
11530 : 1233 : gfc_set_backend_locus (&sym->declared_at);
11531 : 1233 : gfc_init_block (&init);
11532 : :
11533 : 1233 : rank = CLASS_DATA (sym)->as ? (CLASS_DATA (sym)->as->rank) : (0);
11534 : 1233 : gcc_assert (rank>=0);
11535 : 1233 : tmp = gfc_conv_descriptor_dtype (descriptor);
11536 : 1233 : etype = gfc_get_element_type (type);
11537 : 1233 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (tmp), tmp,
11538 : : gfc_get_dtype_rank_type (rank, etype));
11539 : 1233 : gfc_add_expr_to_block (&init, tmp);
11540 : :
11541 : 1233 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
11542 : 1233 : gfc_restore_backend_locus (&loc);
11543 : : }
11544 : :
11545 : :
11546 : : /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
11547 : : Do likewise, recursively if necessary, with the allocatable components of
11548 : : derived types. This function is also called for assumed-rank arrays, which
11549 : : are always dummy arguments. */
11550 : :
11551 : : void
11552 : 13084 : gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
11553 : : {
11554 : 13084 : tree type;
11555 : 13084 : tree tmp;
11556 : 13084 : tree descriptor;
11557 : 13084 : stmtblock_t init;
11558 : 13084 : stmtblock_t cleanup;
11559 : 13084 : locus loc;
11560 : 13084 : int rank;
11561 : 13084 : bool sym_has_alloc_comp, has_finalizer;
11562 : :
11563 : 26168 : sym_has_alloc_comp = (sym->ts.type == BT_DERIVED
11564 : 7540 : || sym->ts.type == BT_CLASS)
11565 : 13084 : && sym->ts.u.derived->attr.alloc_comp;
11566 : 13084 : has_finalizer = gfc_may_be_finalized (sym->ts);
11567 : :
11568 : : /* Make sure the frontend gets these right. */
11569 : 13084 : gcc_assert (sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp
11570 : : || has_finalizer
11571 : : || (sym->as->type == AS_ASSUMED_RANK && sym->attr.dummy));
11572 : :
11573 : 13084 : gfc_save_backend_locus (&loc);
11574 : 13084 : gfc_set_backend_locus (&sym->declared_at);
11575 : 13084 : gfc_init_block (&init);
11576 : :
11577 : 13084 : gcc_assert (VAR_P (sym->backend_decl)
11578 : : || TREE_CODE (sym->backend_decl) == PARM_DECL);
11579 : :
11580 : 13084 : if (sym->ts.type == BT_CHARACTER
11581 : 1053 : && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
11582 : : {
11583 : 586 : if (sym->ts.deferred && !sym->ts.u.cl->length && !sym->attr.dummy)
11584 : 440 : gfc_add_modify (&init, sym->ts.u.cl->backend_decl,
11585 : 440 : build_zero_cst (TREE_TYPE (sym->ts.u.cl->backend_decl)));
11586 : 586 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
11587 : 586 : gfc_trans_vla_type_sizes (sym, &init);
11588 : :
11589 : : /* Presence check of optional deferred-length character dummy. */
11590 : 586 : if (sym->ts.deferred && sym->attr.dummy && sym->attr.optional)
11591 : : {
11592 : 43 : tmp = gfc_finish_block (&init);
11593 : 43 : tmp = build3_v (COND_EXPR, gfc_conv_expr_present (sym),
11594 : : tmp, build_empty_stmt (input_location));
11595 : 43 : gfc_add_expr_to_block (&init, tmp);
11596 : : }
11597 : : }
11598 : :
11599 : : /* Dummy, use associated and result variables don't need anything special. */
11600 : 13084 : if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result)
11601 : : {
11602 : 581 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
11603 : 581 : gfc_restore_backend_locus (&loc);
11604 : 1335 : return;
11605 : : }
11606 : :
11607 : 12503 : descriptor = sym->backend_decl;
11608 : :
11609 : : /* Although static, derived types with default initializers and
11610 : : allocatable components must not be nulled wholesale; instead they
11611 : : are treated component by component. */
11612 : 12503 : if (TREE_STATIC (descriptor) && !sym_has_alloc_comp && !has_finalizer)
11613 : : {
11614 : : /* SAVEd variables are not freed on exit. */
11615 : 173 : gfc_trans_static_array_pointer (sym);
11616 : :
11617 : 173 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
11618 : 173 : gfc_restore_backend_locus (&loc);
11619 : 173 : return;
11620 : : }
11621 : :
11622 : : /* Get the descriptor type. */
11623 : 12330 : type = TREE_TYPE (sym->backend_decl);
11624 : :
11625 : 12330 : if ((sym_has_alloc_comp || (has_finalizer && sym->ts.type != BT_CLASS))
11626 : 4323 : && !(sym->attr.pointer || sym->attr.allocatable))
11627 : : {
11628 : 2348 : if (!sym->attr.save
11629 : 2033 : && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program))
11630 : : {
11631 : 2033 : if (sym->value == NULL
11632 : 2033 : || !gfc_has_default_initializer (sym->ts.u.derived))
11633 : : {
11634 : 1749 : rank = sym->as ? sym->as->rank : 0;
11635 : 1749 : tmp = gfc_nullify_alloc_comp (sym->ts.u.derived,
11636 : : descriptor, rank);
11637 : 1749 : gfc_add_expr_to_block (&init, tmp);
11638 : : }
11639 : : else
11640 : 284 : gfc_init_default_dt (sym, &init, false);
11641 : : }
11642 : : }
11643 : 9982 : else if (!GFC_DESCRIPTOR_TYPE_P (type))
11644 : : {
11645 : : /* If the backend_decl is not a descriptor, we must have a pointer
11646 : : to one. */
11647 : 1529 : descriptor = build_fold_indirect_ref_loc (input_location,
11648 : : sym->backend_decl);
11649 : 1529 : type = TREE_TYPE (descriptor);
11650 : : }
11651 : :
11652 : : /* NULLIFY the data pointer, for non-saved allocatables. */
11653 : 12330 : if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save && sym->attr.allocatable)
11654 : : {
11655 : 5297 : gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node);
11656 : 5297 : if (flag_coarray == GFC_FCOARRAY_LIB && sym->attr.codimension)
11657 : : {
11658 : : /* Declare the variable static so its array descriptor stays present
11659 : : after leaving the scope. It may still be accessed through another
11660 : : image. This may happen, for example, with the caf_mpi
11661 : : implementation. */
11662 : 88 : TREE_STATIC (descriptor) = 1;
11663 : 88 : tmp = gfc_conv_descriptor_token (descriptor);
11664 : 88 : gfc_add_modify (&init, tmp, fold_convert (TREE_TYPE (tmp),
11665 : : null_pointer_node));
11666 : : }
11667 : : }
11668 : :
11669 : : /* Set initial TKR for pointers and allocatables */
11670 : 12330 : if (GFC_DESCRIPTOR_TYPE_P (type)
11671 : 12330 : && (sym->attr.pointer || sym->attr.allocatable))
11672 : : {
11673 : 8453 : tree etype;
11674 : :
11675 : 8453 : gcc_assert (sym->as && sym->as->rank>=0);
11676 : 8453 : tmp = gfc_conv_descriptor_dtype (descriptor);
11677 : 8453 : etype = gfc_get_element_type (type);
11678 : 8453 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
11679 : 8453 : TREE_TYPE (tmp), tmp,
11680 : 8453 : gfc_get_dtype_rank_type (sym->as->rank, etype));
11681 : 8453 : gfc_add_expr_to_block (&init, tmp);
11682 : : }
11683 : 12330 : gfc_restore_backend_locus (&loc);
11684 : 12330 : gfc_init_block (&cleanup);
11685 : :
11686 : : /* Allocatable arrays need to be freed when they go out of scope.
11687 : : The allocatable components of pointers must not be touched. */
11688 : 12330 : if (!sym->attr.allocatable && has_finalizer && sym->ts.type != BT_CLASS
11689 : 430 : && !sym->attr.pointer && !sym->attr.artificial && !sym->attr.save
11690 : 210 : && !sym->ns->proc_name->attr.is_main_program)
11691 : : {
11692 : 186 : gfc_expr *e;
11693 : 186 : sym->attr.referenced = 1;
11694 : 186 : e = gfc_lval_expr_from_sym (sym);
11695 : 186 : gfc_add_finalizer_call (&cleanup, e);
11696 : 186 : gfc_free_expr (e);
11697 : 186 : }
11698 : 12144 : else if ((!sym->attr.allocatable || !has_finalizer)
11699 : 12033 : && sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
11700 : 3881 : && !sym->attr.pointer && !sym->attr.save
11701 : 2013 : && !(sym->attr.artificial && sym->name[0] == '_')
11702 : 1983 : && !sym->ns->proc_name->attr.is_main_program)
11703 : : {
11704 : 552 : int rank;
11705 : 552 : rank = sym->as ? sym->as->rank : 0;
11706 : 552 : tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank,
11707 : 552 : (sym->attr.codimension
11708 : 2 : && flag_coarray == GFC_FCOARRAY_LIB)
11709 : : ? GFC_STRUCTURE_CAF_MODE_IN_COARRAY
11710 : : : 0);
11711 : 552 : gfc_add_expr_to_block (&cleanup, tmp);
11712 : : }
11713 : :
11714 : 12330 : if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension)
11715 : 5303 : && !sym->attr.save && !sym->attr.result
11716 : 5297 : && !sym->ns->proc_name->attr.is_main_program)
11717 : : {
11718 : 1686 : gfc_expr *e;
11719 : 1686 : e = has_finalizer ? gfc_lval_expr_from_sym (sym) : NULL;
11720 : 3372 : tmp = gfc_deallocate_with_status (sym->backend_decl, NULL_TREE, NULL_TREE,
11721 : : NULL_TREE, NULL_TREE, true, e,
11722 : 1686 : sym->attr.codimension
11723 : : ? GFC_CAF_COARRAY_DEREGISTER
11724 : : : GFC_CAF_COARRAY_NOCOARRAY,
11725 : : NULL_TREE, gfc_finish_block (&cleanup));
11726 : 1686 : if (e)
11727 : 32 : gfc_free_expr (e);
11728 : 1686 : gfc_init_block (&cleanup);
11729 : 1686 : gfc_add_expr_to_block (&cleanup, tmp);
11730 : : }
11731 : :
11732 : 12330 : gfc_add_init_cleanup (block, gfc_finish_block (&init),
11733 : : gfc_finish_block (&cleanup));
11734 : : }
11735 : :
11736 : : /************ Expression Walking Functions ******************/
11737 : :
11738 : : /* Walk a variable reference.
11739 : :
11740 : : Possible extension - multiple component subscripts.
11741 : : x(:,:) = foo%a(:)%b(:)
11742 : : Transforms to
11743 : : forall (i=..., j=...)
11744 : : x(i,j) = foo%a(j)%b(i)
11745 : : end forall
11746 : : This adds a fair amount of complexity because you need to deal with more
11747 : : than one ref. Maybe handle in a similar manner to vector subscripts.
11748 : : Maybe not worth the effort. */
11749 : :
11750 : :
11751 : : static gfc_ss *
11752 : 506030 : gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
11753 : : {
11754 : 506030 : gfc_ref *ref;
11755 : :
11756 : 506030 : gfc_fix_class_refs (expr);
11757 : :
11758 : 599432 : for (ref = expr->ref; ref; ref = ref->next)
11759 : 362667 : if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
11760 : : break;
11761 : :
11762 : 506030 : return gfc_walk_array_ref (ss, expr, ref);
11763 : : }
11764 : :
11765 : :
11766 : : gfc_ss *
11767 : 506224 : gfc_walk_array_ref (gfc_ss * ss, gfc_expr * expr, gfc_ref * ref)
11768 : : {
11769 : 506224 : gfc_array_ref *ar;
11770 : 506224 : gfc_ss *newss;
11771 : 506224 : int n;
11772 : :
11773 : 782066 : for (; ref; ref = ref->next)
11774 : : {
11775 : 275842 : if (ref->type == REF_SUBSTRING)
11776 : : {
11777 : 1205 : ss = gfc_get_scalar_ss (ss, ref->u.ss.start);
11778 : 1205 : if (ref->u.ss.end)
11779 : 1193 : ss = gfc_get_scalar_ss (ss, ref->u.ss.end);
11780 : : }
11781 : :
11782 : : /* We're only interested in array sections from now on. */
11783 : 275842 : if (ref->type != REF_ARRAY)
11784 : 6167 : continue;
11785 : :
11786 : 269675 : ar = &ref->u.ar;
11787 : :
11788 : 269675 : switch (ar->type)
11789 : : {
11790 : 158 : case AR_ELEMENT:
11791 : 363 : for (n = ar->dimen - 1; n >= 0; n--)
11792 : 205 : ss = gfc_get_scalar_ss (ss, ar->start[n]);
11793 : : break;
11794 : :
11795 : 221177 : case AR_FULL:
11796 : : /* Assumed shape arrays from interface mapping need this fix. */
11797 : 221177 : if (!ar->as && expr->symtree->n.sym->as)
11798 : : {
11799 : 6 : ar->as = gfc_get_array_spec();
11800 : 6 : *ar->as = *expr->symtree->n.sym->as;
11801 : : }
11802 : 221177 : newss = gfc_get_array_ss (ss, expr, ar->as->rank, GFC_SS_SECTION);
11803 : 221177 : newss->info->data.array.ref = ref;
11804 : :
11805 : : /* Make sure array is the same as array(:,:), this way
11806 : : we don't need to special case all the time. */
11807 : 221177 : ar->dimen = ar->as->rank;
11808 : 498662 : for (n = 0; n < ar->dimen; n++)
11809 : : {
11810 : 277485 : ar->dimen_type[n] = DIMEN_RANGE;
11811 : :
11812 : 277485 : gcc_assert (ar->start[n] == NULL);
11813 : 277485 : gcc_assert (ar->end[n] == NULL);
11814 : 277485 : gcc_assert (ar->stride[n] == NULL);
11815 : : }
11816 : : ss = newss;
11817 : : break;
11818 : :
11819 : 48340 : case AR_SECTION:
11820 : 48340 : newss = gfc_get_array_ss (ss, expr, 0, GFC_SS_SECTION);
11821 : 48340 : newss->info->data.array.ref = ref;
11822 : :
11823 : : /* We add SS chains for all the subscripts in the section. */
11824 : 118783 : for (n = 0; n < ar->dimen; n++)
11825 : : {
11826 : 70443 : gfc_ss *indexss;
11827 : :
11828 : 70443 : switch (ar->dimen_type[n])
11829 : : {
11830 : 4152 : case DIMEN_ELEMENT:
11831 : : /* Add SS for elemental (scalar) subscripts. */
11832 : 4152 : gcc_assert (ar->start[n]);
11833 : 4152 : indexss = gfc_get_scalar_ss (gfc_ss_terminator, ar->start[n]);
11834 : 4152 : indexss->loop_chain = gfc_ss_terminator;
11835 : 4152 : newss->info->data.array.subscript[n] = indexss;
11836 : 4152 : break;
11837 : :
11838 : 65493 : case DIMEN_RANGE:
11839 : : /* We don't add anything for sections, just remember this
11840 : : dimension for later. */
11841 : 65493 : newss->dim[newss->dimen] = n;
11842 : 65493 : newss->dimen++;
11843 : 65493 : break;
11844 : :
11845 : 798 : case DIMEN_VECTOR:
11846 : : /* Create a GFC_SS_VECTOR index in which we can store
11847 : : the vector's descriptor. */
11848 : 798 : indexss = gfc_get_array_ss (gfc_ss_terminator, ar->start[n],
11849 : : 1, GFC_SS_VECTOR);
11850 : 798 : indexss->loop_chain = gfc_ss_terminator;
11851 : 798 : newss->info->data.array.subscript[n] = indexss;
11852 : 798 : newss->dim[newss->dimen] = n;
11853 : 798 : newss->dimen++;
11854 : 798 : break;
11855 : :
11856 : 0 : default:
11857 : : /* We should know what sort of section it is by now. */
11858 : 0 : gcc_unreachable ();
11859 : : }
11860 : : }
11861 : : /* We should have at least one non-elemental dimension,
11862 : : unless we are creating a descriptor for a (scalar) coarray. */
11863 : 48340 : gcc_assert (newss->dimen > 0
11864 : : || newss->info->data.array.ref->u.ar.as->corank > 0);
11865 : : ss = newss;
11866 : : break;
11867 : :
11868 : 0 : default:
11869 : : /* We should know what sort of section it is by now. */
11870 : 0 : gcc_unreachable ();
11871 : : }
11872 : :
11873 : : }
11874 : 506224 : return ss;
11875 : : }
11876 : :
11877 : :
11878 : : /* Walk an expression operator. If only one operand of a binary expression is
11879 : : scalar, we must also add the scalar term to the SS chain. */
11880 : :
11881 : : static gfc_ss *
11882 : 46259 : gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
11883 : : {
11884 : 46259 : gfc_ss *head;
11885 : 46259 : gfc_ss *head2;
11886 : :
11887 : 46259 : head = gfc_walk_subexpr (ss, expr->value.op.op1);
11888 : 46259 : if (expr->value.op.op2 == NULL)
11889 : : head2 = head;
11890 : : else
11891 : 44303 : head2 = gfc_walk_subexpr (head, expr->value.op.op2);
11892 : :
11893 : : /* All operands are scalar. Pass back and let the caller deal with it. */
11894 : 46259 : if (head2 == ss)
11895 : : return head2;
11896 : :
11897 : : /* All operands require scalarization. */
11898 : 41855 : if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
11899 : : return head2;
11900 : :
11901 : : /* One of the operands needs scalarization, the other is scalar.
11902 : : Create a gfc_ss for the scalar expression. */
11903 : 15385 : if (head == ss)
11904 : : {
11905 : : /* First operand is scalar. We build the chain in reverse order, so
11906 : : add the scalar SS after the second operand. */
11907 : : head = head2;
11908 : 2068 : while (head && head->next != ss)
11909 : : head = head->next;
11910 : : /* Check we haven't somehow broken the chain. */
11911 : 1825 : gcc_assert (head);
11912 : 1825 : head->next = gfc_get_scalar_ss (ss, expr->value.op.op1);
11913 : : }
11914 : : else /* head2 == head */
11915 : : {
11916 : 13560 : gcc_assert (head2 == head);
11917 : : /* Second operand is scalar. */
11918 : 13560 : head2 = gfc_get_scalar_ss (head2, expr->value.op.op2);
11919 : : }
11920 : :
11921 : : return head2;
11922 : : }
11923 : :
11924 : :
11925 : : /* Reverse a SS chain. */
11926 : :
11927 : : gfc_ss *
11928 : 660355 : gfc_reverse_ss (gfc_ss * ss)
11929 : : {
11930 : 660355 : gfc_ss *next;
11931 : 660355 : gfc_ss *head;
11932 : :
11933 : 660355 : gcc_assert (ss != NULL);
11934 : :
11935 : : head = gfc_ss_terminator;
11936 : 1009188 : while (ss != gfc_ss_terminator)
11937 : : {
11938 : 348833 : next = ss->next;
11939 : : /* Check we didn't somehow break the chain. */
11940 : 348833 : gcc_assert (next != NULL);
11941 : 348833 : ss->next = head;
11942 : 348833 : head = ss;
11943 : 348833 : ss = next;
11944 : : }
11945 : :
11946 : 660355 : return (head);
11947 : : }
11948 : :
11949 : :
11950 : : /* Given an expression referring to a procedure, return the symbol of its
11951 : : interface. We can't get the procedure symbol directly as we have to handle
11952 : : the case of (deferred) type-bound procedures. */
11953 : :
11954 : : gfc_symbol *
11955 : 138 : gfc_get_proc_ifc_for_expr (gfc_expr *procedure_ref)
11956 : : {
11957 : 138 : gfc_symbol *sym;
11958 : 138 : gfc_ref *ref;
11959 : :
11960 : 138 : if (procedure_ref == NULL)
11961 : : return NULL;
11962 : :
11963 : : /* Normal procedure case. */
11964 : 138 : if (procedure_ref->expr_type == EXPR_FUNCTION
11965 : 138 : && procedure_ref->value.function.esym)
11966 : : sym = procedure_ref->value.function.esym;
11967 : : else
11968 : 24 : sym = procedure_ref->symtree->n.sym;
11969 : :
11970 : : /* Typebound procedure case. */
11971 : 186 : for (ref = procedure_ref->ref; ref; ref = ref->next)
11972 : : {
11973 : 48 : if (ref->type == REF_COMPONENT
11974 : 48 : && ref->u.c.component->attr.proc_pointer)
11975 : 24 : sym = ref->u.c.component->ts.interface;
11976 : : else
11977 : : sym = NULL;
11978 : : }
11979 : :
11980 : : return sym;
11981 : : }
11982 : :
11983 : :
11984 : : /* Given an expression referring to an intrinsic function call,
11985 : : return the intrinsic symbol. */
11986 : :
11987 : : gfc_intrinsic_sym *
11988 : 6740 : gfc_get_intrinsic_for_expr (gfc_expr *call)
11989 : : {
11990 : 6740 : if (call == NULL)
11991 : : return NULL;
11992 : :
11993 : : /* Normal procedure case. */
11994 : 2174 : if (call->expr_type == EXPR_FUNCTION)
11995 : 2080 : return call->value.function.isym;
11996 : : else
11997 : : return NULL;
11998 : : }
11999 : :
12000 : :
12001 : : /* Indicates whether an argument to an intrinsic function should be used in
12002 : : scalarization. It is usually the case, except for some intrinsics
12003 : : requiring the value to be constant, and using the value at compile time only.
12004 : : As the value is not used at runtime in those cases, we don’t produce code
12005 : : for it, and it should not be visible to the scalarizer.
12006 : : FUNCTION is the intrinsic function being called, ACTUAL_ARG is the actual
12007 : : argument being examined in that call, and ARG_NUM the index number
12008 : : of ACTUAL_ARG in the list of arguments.
12009 : : The intrinsic procedure’s dummy argument associated with ACTUAL_ARG is
12010 : : identified using the name in ACTUAL_ARG if it is present (that is: if it’s
12011 : : a keyword argument), otherwise using ARG_NUM. */
12012 : :
12013 : : static bool
12014 : 30407 : arg_evaluated_for_scalarization (gfc_intrinsic_sym *function,
12015 : : gfc_dummy_arg *dummy_arg)
12016 : : {
12017 : 30407 : if (function != NULL && dummy_arg != NULL)
12018 : : {
12019 : 11548 : switch (function->id)
12020 : : {
12021 : 241 : case GFC_ISYM_INDEX:
12022 : 241 : case GFC_ISYM_LEN_TRIM:
12023 : 241 : case GFC_ISYM_MASKL:
12024 : 241 : case GFC_ISYM_MASKR:
12025 : 241 : case GFC_ISYM_SCAN:
12026 : 241 : case GFC_ISYM_VERIFY:
12027 : 241 : if (strcmp ("kind", gfc_dummy_arg_get_name (*dummy_arg)) == 0)
12028 : : return false;
12029 : : /* Fallthrough. */
12030 : :
12031 : : default:
12032 : : break;
12033 : : }
12034 : : }
12035 : :
12036 : : return true;
12037 : : }
12038 : :
12039 : :
12040 : : /* Walk the arguments of an elemental function.
12041 : : PROC_EXPR is used to check whether an argument is permitted to be absent. If
12042 : : it is NULL, we don't do the check and the argument is assumed to be present.
12043 : : */
12044 : :
12045 : : gfc_ss *
12046 : 20411 : gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
12047 : : gfc_intrinsic_sym *intrinsic_sym,
12048 : : gfc_ss_type type)
12049 : : {
12050 : 20411 : int scalar;
12051 : 20411 : gfc_ss *head;
12052 : 20411 : gfc_ss *tail;
12053 : 20411 : gfc_ss *newss;
12054 : :
12055 : 20411 : head = gfc_ss_terminator;
12056 : 20411 : tail = NULL;
12057 : :
12058 : 20411 : scalar = 1;
12059 : 51994 : for (; arg; arg = arg->next)
12060 : : {
12061 : 31583 : gfc_dummy_arg * const dummy_arg = arg->associated_dummy;
12062 : 32792 : if (!arg->expr
12063 : 30557 : || arg->expr->expr_type == EXPR_NULL
12064 : 61990 : || !arg_evaluated_for_scalarization (intrinsic_sym, dummy_arg))
12065 : 1209 : continue;
12066 : :
12067 : 30374 : newss = gfc_walk_subexpr (head, arg->expr);
12068 : 30374 : if (newss == head)
12069 : : {
12070 : : /* Scalar argument. */
12071 : 17380 : gcc_assert (type == GFC_SS_SCALAR || type == GFC_SS_REFERENCE);
12072 : 17380 : newss = gfc_get_scalar_ss (head, arg->expr);
12073 : 17380 : newss->info->type = type;
12074 : 17380 : if (dummy_arg)
12075 : 14513 : newss->info->data.scalar.dummy_arg = dummy_arg;
12076 : : }
12077 : : else
12078 : : scalar = 0;
12079 : :
12080 : 30374 : if (dummy_arg != NULL
12081 : 23660 : && gfc_dummy_arg_is_optional (*dummy_arg)
12082 : 1968 : && arg->expr->expr_type == EXPR_VARIABLE
12083 : 31728 : && (gfc_expr_attr (arg->expr).optional
12084 : 971 : || gfc_expr_attr (arg->expr).allocatable
12085 : 29720 : || gfc_expr_attr (arg->expr).pointer))
12086 : 907 : newss->info->can_be_null_ref = true;
12087 : :
12088 : 30374 : head = newss;
12089 : 30374 : if (!tail)
12090 : : {
12091 : : tail = head;
12092 : 25895 : while (tail->next != gfc_ss_terminator)
12093 : : tail = tail->next;
12094 : : }
12095 : : }
12096 : :
12097 : 20411 : if (scalar)
12098 : : {
12099 : : /* If all the arguments are scalar we don't need the argument SS. */
12100 : 9633 : gfc_free_ss_chain (head);
12101 : : /* Pass it back. */
12102 : 9633 : return ss;
12103 : : }
12104 : :
12105 : : /* Add it onto the existing chain. */
12106 : 10778 : tail->next = ss;
12107 : 10778 : return head;
12108 : : }
12109 : :
12110 : :
12111 : : /* Walk a function call. Scalar functions are passed back, and taken out of
12112 : : scalarization loops. For elemental functions we walk their arguments.
12113 : : The result of functions returning arrays is stored in a temporary outside
12114 : : the loop, so that the function is only called once. Hence we do not need
12115 : : to walk their arguments. */
12116 : :
12117 : : static gfc_ss *
12118 : 43068 : gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
12119 : : {
12120 : 43068 : gfc_intrinsic_sym *isym;
12121 : 43068 : gfc_symbol *sym;
12122 : 43068 : gfc_component *comp = NULL;
12123 : :
12124 : 43068 : isym = expr->value.function.isym;
12125 : :
12126 : : /* Handle intrinsic functions separately. */
12127 : 43068 : if (isym)
12128 : 36070 : return gfc_walk_intrinsic_function (ss, expr, isym);
12129 : :
12130 : 6998 : sym = expr->value.function.esym;
12131 : 6998 : if (!sym)
12132 : 538 : sym = expr->symtree->n.sym;
12133 : :
12134 : 6998 : if (gfc_is_class_array_function (expr))
12135 : 204 : return gfc_get_array_ss (ss, expr,
12136 : 204 : CLASS_DATA (expr->value.function.esym->result)->as->rank,
12137 : 204 : GFC_SS_FUNCTION);
12138 : :
12139 : : /* A function that returns arrays. */
12140 : 6794 : comp = gfc_get_proc_ptr_comp (expr);
12141 : 6404 : if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
12142 : 6794 : || (comp && comp->attr.dimension))
12143 : 2530 : return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
12144 : :
12145 : : /* Walk the parameters of an elemental function. For now we always pass
12146 : : by reference. */
12147 : 4264 : if (sym->attr.elemental || (comp && comp->attr.elemental))
12148 : : {
12149 : 2044 : gfc_ss *old_ss = ss;
12150 : :
12151 : 2044 : ss = gfc_walk_elemental_function_args (old_ss,
12152 : : expr->value.function.actual,
12153 : : gfc_get_intrinsic_for_expr (expr),
12154 : : GFC_SS_REFERENCE);
12155 : 2044 : if (ss != old_ss
12156 : 1010 : && (comp
12157 : 949 : || sym->attr.proc_pointer
12158 : : || sym->attr.if_source != IFSRC_DECL
12159 : 949 : || sym->attr.array_outer_dependency))
12160 : 224 : ss->info->array_outer_dependency = 1;
12161 : : }
12162 : :
12163 : : /* Scalar functions are OK as these are evaluated outside the scalarization
12164 : : loop. Pass back and let the caller deal with it. */
12165 : : return ss;
12166 : : }
12167 : :
12168 : :
12169 : : /* An array temporary is constructed for array constructors. */
12170 : :
12171 : : static gfc_ss *
12172 : 40743 : gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
12173 : : {
12174 : 0 : return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_CONSTRUCTOR);
12175 : : }
12176 : :
12177 : :
12178 : : /* Walk an expression. Add walked expressions to the head of the SS chain.
12179 : : A wholly scalar expression will not be added. */
12180 : :
12181 : : gfc_ss *
12182 : 781613 : gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
12183 : : {
12184 : 781613 : gfc_ss *head;
12185 : :
12186 : 781613 : switch (expr->expr_type)
12187 : : {
12188 : 506030 : case EXPR_VARIABLE:
12189 : 506030 : head = gfc_walk_variable_expr (ss, expr);
12190 : 506030 : return head;
12191 : :
12192 : 46259 : case EXPR_OP:
12193 : 46259 : head = gfc_walk_op_expr (ss, expr);
12194 : 46259 : return head;
12195 : :
12196 : 43068 : case EXPR_FUNCTION:
12197 : 43068 : head = gfc_walk_function_expr (ss, expr);
12198 : 43068 : return head;
12199 : :
12200 : : case EXPR_CONSTANT:
12201 : : case EXPR_NULL:
12202 : : case EXPR_STRUCTURE:
12203 : : /* Pass back and let the caller deal with it. */
12204 : : break;
12205 : :
12206 : 40743 : case EXPR_ARRAY:
12207 : 40743 : head = gfc_walk_array_constructor (ss, expr);
12208 : 40743 : return head;
12209 : :
12210 : : case EXPR_SUBSTRING:
12211 : : /* Pass back and let the caller deal with it. */
12212 : : break;
12213 : :
12214 : 0 : default:
12215 : 0 : gfc_internal_error ("bad expression type during walk (%d)",
12216 : : expr->expr_type);
12217 : : }
12218 : : return ss;
12219 : : }
12220 : :
12221 : :
12222 : : /* Entry point for expression walking.
12223 : : A return value equal to the passed chain means this is
12224 : : a scalar expression. It is up to the caller to take whatever action is
12225 : : necessary to translate these. */
12226 : :
12227 : : gfc_ss *
12228 : 658401 : gfc_walk_expr (gfc_expr * expr)
12229 : : {
12230 : 658401 : gfc_ss *res;
12231 : :
12232 : 658401 : res = gfc_walk_subexpr (gfc_ss_terminator, expr);
12233 : 658401 : return gfc_reverse_ss (res);
12234 : : }
|
