Branch data Line data Source code
1 : : /* Array translation routines
2 : : Copyright (C) 2002-2025 Free Software Foundation, Inc.
3 : : Contributed by Paul Brook <paul@nowt.org>
4 : : and Steven Bosscher <s.bosscher@student.tudelft.nl>
5 : :
6 : : This file is part of GCC.
7 : :
8 : : GCC is free software; you can redistribute it and/or modify it under
9 : : the terms of the GNU General Public License as published by the Free
10 : : Software Foundation; either version 3, or (at your option) any later
11 : : version.
12 : :
13 : : GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 : : WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 : : FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
16 : : for more details.
17 : :
18 : : You should have received a copy of the GNU General Public License
19 : : along with GCC; see the file COPYING3. If not see
20 : : <http://www.gnu.org/licenses/>. */
21 : :
22 : : /* trans-array.cc-- Various array related code, including scalarization,
23 : : allocation, initialization and other support routines. */
24 : :
25 : : /* How the scalarizer works.
26 : : In gfortran, array expressions use the same core routines as scalar
27 : : expressions.
28 : : First, a Scalarization State (SS) chain is built. This is done by walking
29 : : the expression tree, and building a linear list of the terms in the
30 : : expression. As the tree is walked, scalar subexpressions are translated.
31 : :
32 : : The scalarization parameters are stored in a gfc_loopinfo structure.
33 : : First the start and stride of each term is calculated by
34 : : gfc_conv_ss_startstride. During this process the expressions for the array
35 : : descriptors and data pointers are also translated.
36 : :
37 : : If the expression is an assignment, we must then resolve any dependencies.
38 : : In Fortran all the rhs values of an assignment must be evaluated before
39 : : any assignments take place. This can require a temporary array to store the
40 : : values. We also require a temporary when we are passing array expressions
41 : : or vector subscripts as procedure parameters.
42 : :
43 : : Array sections are passed without copying to a temporary. These use the
44 : : scalarizer to determine the shape of the section. The flag
45 : : loop->array_parameter tells the scalarizer that the actual values and loop
46 : : variables will not be required.
47 : :
48 : : The function gfc_conv_loop_setup generates the scalarization setup code.
49 : : It determines the range of the scalarizing loop variables. If a temporary
50 : : is required, this is created and initialized. Code for scalar expressions
51 : : taken outside the loop is also generated at this time. Next the offset and
52 : : scaling required to translate from loop variables to array indices for each
53 : : term is calculated.
54 : :
55 : : A call to gfc_start_scalarized_body marks the start of the scalarized
56 : : expression. This creates a scope and declares the loop variables. Before
57 : : calling this gfc_make_ss_chain_used must be used to indicate which terms
58 : : will be used inside this loop.
59 : :
60 : : The scalar gfc_conv_* functions are then used to build the main body of the
61 : : scalarization loop. Scalarization loop variables and precalculated scalar
62 : : values are automatically substituted. Note that gfc_advance_se_ss_chain
63 : : must be used, rather than changing the se->ss directly.
64 : :
65 : : For assignment expressions requiring a temporary two sub loops are
66 : : generated. The first stores the result of the expression in the temporary,
67 : : the second copies it to the result. A call to
68 : : gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
69 : : the start of the copying loop. The temporary may be less than full rank.
70 : :
71 : : Finally gfc_trans_scalarizing_loops is called to generate the implicit do
72 : : loops. The loops are added to the pre chain of the loopinfo. The post
73 : : chain may still contain cleanup code.
74 : :
75 : : After the loop code has been added into its parent scope gfc_cleanup_loop
76 : : is called to free all the SS allocated by the scalarizer. */
77 : :
78 : : #include "config.h"
79 : : #include "system.h"
80 : : #include "coretypes.h"
81 : : #include "options.h"
82 : : #include "tree.h"
83 : : #include "gfortran.h"
84 : : #include "gimple-expr.h"
85 : : #include "tree-iterator.h"
86 : : #include "stringpool.h" /* Required by "attribs.h". */
87 : : #include "attribs.h" /* For lookup_attribute. */
88 : : #include "trans.h"
89 : : #include "fold-const.h"
90 : : #include "constructor.h"
91 : : #include "trans-types.h"
92 : : #include "trans-array.h"
93 : : #include "trans-const.h"
94 : : #include "dependency.h"
95 : :
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 : 56057 : gfc_array_dataptr_type (tree desc)
105 : : {
106 : 56057 : 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 : 84935 : gfc_get_cfi_descriptor_field (tree desc, unsigned field_idx)
124 : : {
125 : 84935 : tree type = TREE_TYPE (desc);
126 : 84935 : 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 : 84935 : tree field = gfc_advance_chain (TYPE_FIELDS (type), field_idx);
132 : 84935 : gcc_assert (field != NULL_TREE);
133 : :
134 : 84935 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
135 : 84935 : desc, field, NULL_TREE);
136 : : }
137 : :
138 : : tree
139 : 14198 : gfc_get_cfi_desc_base_addr (tree desc)
140 : : {
141 : 14198 : return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_BASE_ADDR);
142 : : }
143 : :
144 : : tree
145 : 10680 : gfc_get_cfi_desc_elem_len (tree desc)
146 : : {
147 : 10680 : 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 : 30580 : gfc_get_cfi_dim_item (tree desc, tree idx, unsigned field_idx)
176 : : {
177 : 30580 : tree tmp = gfc_get_cfi_descriptor_field (desc, CFI_FIELD_DIM);
178 : 30580 : tmp = gfc_build_array_ref (tmp, idx, NULL_TREE, true);
179 : 30580 : tree field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), field_idx);
180 : 30580 : gcc_assert (field != NULL_TREE);
181 : 30580 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
182 : 30580 : 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 : 11926 : gfc_get_cfi_dim_extent (tree desc, tree idx)
193 : : {
194 : 11926 : return gfc_get_cfi_dim_item (desc, idx, CFI_DIM_FIELD_EXTENT);
195 : : }
196 : :
197 : : tree
198 : 11868 : gfc_get_cfi_dim_sm (tree desc, tree idx)
199 : : {
200 : 11868 : 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 : 1884111 : gfc_get_descriptor_field (tree desc, unsigned field_idx)
246 : : {
247 : 1884111 : tree type = TREE_TYPE (desc);
248 : 1884111 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
249 : :
250 : 1884111 : tree field = gfc_advance_chain (TYPE_FIELDS (type), field_idx);
251 : 1884111 : gcc_assert (field != NULL_TREE);
252 : :
253 : 1884111 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
254 : 1884111 : 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 : 259427 : gfc_conv_descriptor_data_get (tree desc)
262 : : {
263 : 259427 : tree type = TREE_TYPE (desc);
264 : 259427 : if (TREE_CODE (type) == REFERENCE_TYPE)
265 : 0 : gcc_unreachable ();
266 : :
267 : 259427 : tree field = gfc_get_descriptor_field (desc, DATA_FIELD);
268 : 259427 : 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 : 141666 : gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
281 : : {
282 : 141666 : tree field = gfc_get_descriptor_field (desc, DATA_FIELD);
283 : 141666 : gfc_add_modify (block, field, fold_convert (TREE_TYPE (field), value));
284 : 141666 : }
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 : 1066 : gfc_conv_descriptor_data_addr (tree desc)
292 : : {
293 : 1066 : tree field = gfc_get_descriptor_field (desc, DATA_FIELD);
294 : 1066 : return gfc_build_addr_expr (NULL_TREE, field);
295 : : }
296 : :
297 : : static tree
298 : 192356 : gfc_conv_descriptor_offset (tree desc)
299 : : {
300 : 192356 : tree field = gfc_get_descriptor_field (desc, OFFSET_FIELD);
301 : 192356 : gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
302 : 192356 : return field;
303 : : }
304 : :
305 : : tree
306 : 71053 : gfc_conv_descriptor_offset_get (tree desc)
307 : : {
308 : 71053 : return gfc_conv_descriptor_offset (desc);
309 : : }
310 : :
311 : : void
312 : 113194 : gfc_conv_descriptor_offset_set (stmtblock_t *block, tree desc,
313 : : tree value)
314 : : {
315 : 113194 : tree t = gfc_conv_descriptor_offset (desc);
316 : 113194 : gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
317 : 113194 : }
318 : :
319 : :
320 : : tree
321 : 162976 : gfc_conv_descriptor_dtype (tree desc)
322 : : {
323 : 162976 : tree field = gfc_get_descriptor_field (desc, DTYPE_FIELD);
324 : 162976 : gcc_assert (TREE_TYPE (field) == get_dtype_type_node ());
325 : 162976 : return field;
326 : : }
327 : :
328 : : static tree
329 : 150174 : gfc_conv_descriptor_span (tree desc)
330 : : {
331 : 150174 : tree field = gfc_get_descriptor_field (desc, SPAN_FIELD);
332 : 150174 : gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
333 : 150174 : return field;
334 : : }
335 : :
336 : : tree
337 : 32535 : gfc_conv_descriptor_span_get (tree desc)
338 : : {
339 : 32535 : return gfc_conv_descriptor_span (desc);
340 : : }
341 : :
342 : : void
343 : 117639 : gfc_conv_descriptor_span_set (stmtblock_t *block, tree desc,
344 : : tree value)
345 : : {
346 : 117639 : tree t = gfc_conv_descriptor_span (desc);
347 : 117639 : gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
348 : 117639 : }
349 : :
350 : :
351 : : tree
352 : 18879 : gfc_conv_descriptor_rank (tree desc)
353 : : {
354 : 18879 : tree tmp;
355 : 18879 : tree dtype;
356 : :
357 : 18879 : dtype = gfc_conv_descriptor_dtype (desc);
358 : 18879 : tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), GFC_DTYPE_RANK);
359 : 18879 : gcc_assert (tmp != NULL_TREE
360 : : && TREE_TYPE (tmp) == signed_char_type_node);
361 : 18879 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
362 : 18879 : 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 : 8122 : gfc_conv_descriptor_elem_len (tree desc)
385 : : {
386 : 8122 : tree tmp;
387 : 8122 : tree dtype;
388 : :
389 : 8122 : dtype = gfc_conv_descriptor_dtype (desc);
390 : 8122 : tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)),
391 : : GFC_DTYPE_ELEM_LEN);
392 : 8122 : gcc_assert (tmp != NULL_TREE
393 : : && TREE_TYPE (tmp) == size_type_node);
394 : 8122 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
395 : 8122 : 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 : 974983 : gfc_get_descriptor_dimension (tree desc)
430 : : {
431 : 974983 : tree field = gfc_get_descriptor_field (desc, DIMENSION_FIELD);
432 : 974983 : gcc_assert (TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
433 : : && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
434 : 974983 : return field;
435 : : }
436 : :
437 : :
438 : : static tree
439 : 971007 : gfc_conv_descriptor_dimension (tree desc, tree dim)
440 : : {
441 : 971007 : tree tmp;
442 : :
443 : 971007 : tmp = gfc_get_descriptor_dimension (desc);
444 : :
445 : 971007 : return gfc_build_array_ref (tmp, dim, NULL_TREE, true);
446 : : }
447 : :
448 : :
449 : : tree
450 : 1463 : gfc_conv_descriptor_token (tree desc)
451 : : {
452 : 1463 : gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
453 : 1463 : tree field = gfc_get_descriptor_field (desc, CAF_TOKEN_FIELD);
454 : : /* Should be a restricted pointer - except in the finalization wrapper. */
455 : 1463 : gcc_assert (TREE_TYPE (field) == prvoid_type_node
456 : : || TREE_TYPE (field) == pvoid_type_node);
457 : 1463 : return field;
458 : : }
459 : :
460 : : static tree
461 : 971007 : gfc_conv_descriptor_subfield (tree desc, tree dim, unsigned field_idx)
462 : : {
463 : 971007 : tree tmp = gfc_conv_descriptor_dimension (desc, dim);
464 : 971007 : tree field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), field_idx);
465 : 971007 : gcc_assert (field != NULL_TREE);
466 : :
467 : 971007 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
468 : 971007 : tmp, field, NULL_TREE);
469 : : }
470 : :
471 : : static tree
472 : 258564 : gfc_conv_descriptor_stride (tree desc, tree dim)
473 : : {
474 : 258564 : tree field = gfc_conv_descriptor_subfield (desc, dim, STRIDE_SUBFIELD);
475 : 258564 : gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
476 : 258564 : return field;
477 : : }
478 : :
479 : : tree
480 : 156708 : gfc_conv_descriptor_stride_get (tree desc, tree dim)
481 : : {
482 : 156708 : tree type = TREE_TYPE (desc);
483 : 156708 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
484 : 156708 : if (integer_zerop (dim)
485 : 156708 : && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
486 : 41458 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT
487 : 40390 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT
488 : 40240 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_ALLOCATABLE
489 : 40090 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_POINTER_CONT
490 : 40090 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
491 : 63139 : return gfc_index_one_node;
492 : :
493 : 93569 : return gfc_conv_descriptor_stride (desc, dim);
494 : : }
495 : :
496 : : void
497 : 164995 : gfc_conv_descriptor_stride_set (stmtblock_t *block, tree desc,
498 : : tree dim, tree value)
499 : : {
500 : 164995 : tree t = gfc_conv_descriptor_stride (desc, dim);
501 : 164995 : gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
502 : 164995 : }
503 : :
504 : : static tree
505 : 374264 : gfc_conv_descriptor_lbound (tree desc, tree dim)
506 : : {
507 : 374264 : tree field = gfc_conv_descriptor_subfield (desc, dim, LBOUND_SUBFIELD);
508 : 374264 : gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
509 : 374264 : return field;
510 : : }
511 : :
512 : : tree
513 : 205677 : gfc_conv_descriptor_lbound_get (tree desc, tree dim)
514 : : {
515 : 205677 : return gfc_conv_descriptor_lbound (desc, dim);
516 : : }
517 : :
518 : : void
519 : 168587 : gfc_conv_descriptor_lbound_set (stmtblock_t *block, tree desc,
520 : : tree dim, tree value)
521 : : {
522 : 168587 : tree t = gfc_conv_descriptor_lbound (desc, dim);
523 : 168587 : gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
524 : 168587 : }
525 : :
526 : : static tree
527 : 338179 : gfc_conv_descriptor_ubound (tree desc, tree dim)
528 : : {
529 : 338179 : tree field = gfc_conv_descriptor_subfield (desc, dim, UBOUND_SUBFIELD);
530 : 338179 : gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
531 : 338179 : return field;
532 : : }
533 : :
534 : : tree
535 : 168682 : gfc_conv_descriptor_ubound_get (tree desc, tree dim)
536 : : {
537 : 168682 : return gfc_conv_descriptor_ubound (desc, dim);
538 : : }
539 : :
540 : : void
541 : 169497 : gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree desc,
542 : : tree dim, tree value)
543 : : {
544 : 169497 : tree t = gfc_conv_descriptor_ubound (desc, dim);
545 : 169497 : gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
546 : 169497 : }
547 : :
548 : : /* Build a null array descriptor constructor. */
549 : :
550 : : tree
551 : 944 : gfc_build_null_descriptor (tree type)
552 : : {
553 : 944 : tree field;
554 : 944 : tree tmp;
555 : :
556 : 944 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
557 : 944 : gcc_assert (DATA_FIELD == 0);
558 : 944 : field = TYPE_FIELDS (type);
559 : :
560 : : /* Set a NULL data pointer. */
561 : 944 : tmp = build_constructor_single (type, field, null_pointer_node);
562 : 944 : TREE_CONSTANT (tmp) = 1;
563 : : /* All other fields are ignored. */
564 : :
565 : 944 : return tmp;
566 : : }
567 : :
568 : :
569 : : /* Modify a descriptor such that the lbound of a given dimension is the value
570 : : specified. This also updates ubound and offset accordingly. */
571 : :
572 : : void
573 : 870 : gfc_conv_shift_descriptor_lbound (stmtblock_t* block, tree desc,
574 : : int dim, tree new_lbound)
575 : : {
576 : 870 : tree offs, ubound, lbound, stride;
577 : 870 : tree diff, offs_diff;
578 : :
579 : 870 : new_lbound = fold_convert (gfc_array_index_type, new_lbound);
580 : :
581 : 870 : offs = gfc_conv_descriptor_offset_get (desc);
582 : 870 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
583 : 870 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
584 : 870 : stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]);
585 : :
586 : : /* Get difference (new - old) by which to shift stuff. */
587 : 870 : diff = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
588 : : new_lbound, lbound);
589 : :
590 : : /* Shift ubound and offset accordingly. This has to be done before
591 : : updating the lbound, as they depend on the lbound expression! */
592 : 870 : ubound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
593 : : ubound, diff);
594 : 870 : gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[dim], ubound);
595 : 870 : offs_diff = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
596 : : diff, stride);
597 : 870 : offs = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
598 : : offs, offs_diff);
599 : 870 : gfc_conv_descriptor_offset_set (block, desc, offs);
600 : :
601 : : /* Finally set lbound to value we want. */
602 : 870 : gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[dim], new_lbound);
603 : 870 : }
604 : :
605 : :
606 : : /* Obtain offsets for trans-types.cc(gfc_get_array_descr_info). */
607 : :
608 : : void
609 : 259892 : gfc_get_descriptor_offsets_for_info (const_tree desc_type, tree *data_off,
610 : : tree *dtype_off, tree *span_off,
611 : : tree *dim_off, tree *dim_size,
612 : : tree *stride_suboff, tree *lower_suboff,
613 : : tree *upper_suboff)
614 : : {
615 : 259892 : tree field;
616 : 259892 : tree type;
617 : :
618 : 259892 : type = TYPE_MAIN_VARIANT (desc_type);
619 : 259892 : field = gfc_advance_chain (TYPE_FIELDS (type), DATA_FIELD);
620 : 259892 : *data_off = byte_position (field);
621 : 259892 : field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
622 : 259892 : *dtype_off = byte_position (field);
623 : 259892 : field = gfc_advance_chain (TYPE_FIELDS (type), SPAN_FIELD);
624 : 259892 : *span_off = byte_position (field);
625 : 259892 : field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
626 : 259892 : *dim_off = byte_position (field);
627 : 259892 : type = TREE_TYPE (TREE_TYPE (field));
628 : 259892 : *dim_size = TYPE_SIZE_UNIT (type);
629 : 259892 : field = gfc_advance_chain (TYPE_FIELDS (type), STRIDE_SUBFIELD);
630 : 259892 : *stride_suboff = byte_position (field);
631 : 259892 : field = gfc_advance_chain (TYPE_FIELDS (type), LBOUND_SUBFIELD);
632 : 259892 : *lower_suboff = byte_position (field);
633 : 259892 : field = gfc_advance_chain (TYPE_FIELDS (type), UBOUND_SUBFIELD);
634 : 259892 : *upper_suboff = byte_position (field);
635 : 259892 : }
636 : :
637 : :
638 : : /* Cleanup those #defines. */
639 : :
640 : : #undef DATA_FIELD
641 : : #undef OFFSET_FIELD
642 : : #undef DTYPE_FIELD
643 : : #undef SPAN_FIELD
644 : : #undef DIMENSION_FIELD
645 : : #undef CAF_TOKEN_FIELD
646 : : #undef STRIDE_SUBFIELD
647 : : #undef LBOUND_SUBFIELD
648 : : #undef UBOUND_SUBFIELD
649 : :
650 : :
651 : : /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
652 : : flags & 1 = Main loop body.
653 : : flags & 2 = temp copy loop. */
654 : :
655 : : void
656 : 160230 : gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
657 : : {
658 : 374576 : for (; ss != gfc_ss_terminator; ss = ss->next)
659 : 214346 : ss->info->useflags = flags;
660 : 160230 : }
661 : :
662 : :
663 : : /* Free a gfc_ss chain. */
664 : :
665 : : void
666 : 169826 : gfc_free_ss_chain (gfc_ss * ss)
667 : : {
668 : 169826 : gfc_ss *next;
669 : :
670 : 347804 : while (ss != gfc_ss_terminator)
671 : : {
672 : 177978 : gcc_assert (ss != NULL);
673 : 177978 : next = ss->next;
674 : 177978 : gfc_free_ss (ss);
675 : 177978 : ss = next;
676 : : }
677 : 169826 : }
678 : :
679 : :
680 : : static void
681 : 457951 : free_ss_info (gfc_ss_info *ss_info)
682 : : {
683 : 457951 : int n;
684 : :
685 : 457951 : ss_info->refcount--;
686 : 457951 : if (ss_info->refcount > 0)
687 : : return;
688 : :
689 : 454436 : gcc_assert (ss_info->refcount == 0);
690 : :
691 : 454436 : switch (ss_info->type)
692 : : {
693 : : case GFC_SS_SECTION:
694 : 5047760 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
695 : 4732275 : if (ss_info->data.array.subscript[n])
696 : 6821 : gfc_free_ss_chain (ss_info->data.array.subscript[n]);
697 : : break;
698 : :
699 : : default:
700 : : break;
701 : : }
702 : :
703 : 454436 : free (ss_info);
704 : : }
705 : :
706 : :
707 : : /* Free a SS. */
708 : :
709 : : void
710 : 457951 : gfc_free_ss (gfc_ss * ss)
711 : : {
712 : 457951 : free_ss_info (ss->info);
713 : 457951 : free (ss);
714 : 457951 : }
715 : :
716 : :
717 : : /* Creates and initializes an array type gfc_ss struct. */
718 : :
719 : : gfc_ss *
720 : 387199 : gfc_get_array_ss (gfc_ss *next, gfc_expr *expr, int dimen, gfc_ss_type type)
721 : : {
722 : 387199 : gfc_ss *ss;
723 : 387199 : gfc_ss_info *ss_info;
724 : 387199 : int i;
725 : :
726 : 387199 : ss_info = gfc_get_ss_info ();
727 : 387199 : ss_info->refcount++;
728 : 387199 : ss_info->type = type;
729 : 387199 : ss_info->expr = expr;
730 : :
731 : 387199 : ss = gfc_get_ss ();
732 : 387199 : ss->info = ss_info;
733 : 387199 : ss->next = next;
734 : 387199 : ss->dimen = dimen;
735 : 819121 : for (i = 0; i < ss->dimen; i++)
736 : 431922 : ss->dim[i] = i;
737 : :
738 : 387199 : return ss;
739 : : }
740 : :
741 : :
742 : : /* Creates and initializes a temporary type gfc_ss struct. */
743 : :
744 : : gfc_ss *
745 : 11080 : gfc_get_temp_ss (tree type, tree string_length, int dimen)
746 : : {
747 : 11080 : gfc_ss *ss;
748 : 11080 : gfc_ss_info *ss_info;
749 : 11080 : int i;
750 : :
751 : 11080 : ss_info = gfc_get_ss_info ();
752 : 11080 : ss_info->refcount++;
753 : 11080 : ss_info->type = GFC_SS_TEMP;
754 : 11080 : ss_info->string_length = string_length;
755 : 11080 : ss_info->data.temp.type = type;
756 : :
757 : 11080 : ss = gfc_get_ss ();
758 : 11080 : ss->info = ss_info;
759 : 11080 : ss->next = gfc_ss_terminator;
760 : 11080 : ss->dimen = dimen;
761 : 24801 : for (i = 0; i < ss->dimen; i++)
762 : 13721 : ss->dim[i] = i;
763 : :
764 : 11080 : return ss;
765 : : }
766 : :
767 : :
768 : : /* Creates and initializes a scalar type gfc_ss struct. */
769 : :
770 : : gfc_ss *
771 : 60154 : gfc_get_scalar_ss (gfc_ss *next, gfc_expr *expr)
772 : : {
773 : 60154 : gfc_ss *ss;
774 : 60154 : gfc_ss_info *ss_info;
775 : :
776 : 60154 : ss_info = gfc_get_ss_info ();
777 : 60154 : ss_info->refcount++;
778 : 60154 : ss_info->type = GFC_SS_SCALAR;
779 : 60154 : ss_info->expr = expr;
780 : :
781 : 60154 : ss = gfc_get_ss ();
782 : 60154 : ss->info = ss_info;
783 : 60154 : ss->next = next;
784 : :
785 : 60154 : return ss;
786 : : }
787 : :
788 : :
789 : : /* Free all the SS associated with a loop. */
790 : :
791 : : void
792 : 169789 : gfc_cleanup_loop (gfc_loopinfo * loop)
793 : : {
794 : 169789 : gfc_loopinfo *loop_next, **ploop;
795 : 169789 : gfc_ss *ss;
796 : 169789 : gfc_ss *next;
797 : :
798 : 169789 : ss = loop->ss;
799 : 449275 : while (ss != gfc_ss_terminator)
800 : : {
801 : 279486 : gcc_assert (ss != NULL);
802 : 279486 : next = ss->loop_chain;
803 : 279486 : gfc_free_ss (ss);
804 : 279486 : ss = next;
805 : : }
806 : :
807 : : /* Remove reference to self in the parent loop. */
808 : 169789 : if (loop->parent)
809 : 2440 : for (ploop = &loop->parent->nested; *ploop; ploop = &(*ploop)->next)
810 : 2440 : if (*ploop == loop)
811 : : {
812 : 2440 : *ploop = loop->next;
813 : 2440 : break;
814 : : }
815 : :
816 : : /* Free non-freed nested loops. */
817 : 172229 : for (loop = loop->nested; loop; loop = loop_next)
818 : : {
819 : 2440 : loop_next = loop->next;
820 : 2440 : gfc_cleanup_loop (loop);
821 : 2440 : free (loop);
822 : : }
823 : 169789 : }
824 : :
825 : :
826 : : static void
827 : 231479 : set_ss_loop (gfc_ss *ss, gfc_loopinfo *loop)
828 : : {
829 : 231479 : int n;
830 : :
831 : 519248 : for (; ss != gfc_ss_terminator; ss = ss->next)
832 : : {
833 : 287769 : ss->loop = loop;
834 : :
835 : 287769 : if (ss->info->type == GFC_SS_SCALAR
836 : : || ss->info->type == GFC_SS_REFERENCE
837 : 245377 : || ss->info->type == GFC_SS_TEMP)
838 : 53472 : continue;
839 : :
840 : 3748752 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
841 : 3514455 : if (ss->info->data.array.subscript[n] != NULL)
842 : 6671 : set_ss_loop (ss->info->data.array.subscript[n], loop);
843 : : }
844 : 231479 : }
845 : :
846 : :
847 : : /* Associate a SS chain with a loop. */
848 : :
849 : : void
850 : 224808 : gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
851 : : {
852 : 224808 : gfc_ss *ss;
853 : 224808 : gfc_loopinfo *nested_loop;
854 : :
855 : 224808 : if (head == gfc_ss_terminator)
856 : : return;
857 : :
858 : 224808 : set_ss_loop (head, loop);
859 : :
860 : 224808 : ss = head;
861 : 730714 : for (; ss && ss != gfc_ss_terminator; ss = ss->next)
862 : : {
863 : 281098 : if (ss->nested_ss)
864 : : {
865 : 3508 : nested_loop = ss->nested_ss->loop;
866 : :
867 : : /* More than one ss can belong to the same loop. Hence, we add the
868 : : loop to the chain only if it is different from the previously
869 : : added one, to avoid duplicate nested loops. */
870 : 3508 : if (nested_loop != loop->nested)
871 : : {
872 : 2440 : gcc_assert (nested_loop->parent == NULL);
873 : 2440 : nested_loop->parent = loop;
874 : :
875 : 2440 : gcc_assert (nested_loop->next == NULL);
876 : 2440 : nested_loop->next = loop->nested;
877 : 2440 : loop->nested = nested_loop;
878 : : }
879 : : else
880 : 1068 : gcc_assert (nested_loop->parent == loop);
881 : : }
882 : :
883 : 281098 : if (ss->next == gfc_ss_terminator)
884 : 224808 : ss->loop_chain = loop->ss;
885 : : else
886 : 56290 : ss->loop_chain = ss->next;
887 : : }
888 : 224808 : gcc_assert (ss == gfc_ss_terminator);
889 : 224808 : loop->ss = head;
890 : : }
891 : :
892 : :
893 : : /* Returns true if the expression is an array pointer. */
894 : :
895 : : static bool
896 : 342274 : is_pointer_array (tree expr)
897 : : {
898 : 342274 : if (expr == NULL_TREE
899 : 342274 : || !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr))
900 : 432575 : || GFC_CLASS_TYPE_P (TREE_TYPE (expr)))
901 : : return false;
902 : :
903 : 90301 : if (VAR_P (expr)
904 : 90301 : && GFC_DECL_PTR_ARRAY_P (expr))
905 : : return true;
906 : :
907 : 84227 : if (TREE_CODE (expr) == PARM_DECL
908 : 84227 : && GFC_DECL_PTR_ARRAY_P (expr))
909 : : return true;
910 : :
911 : 84227 : if (INDIRECT_REF_P (expr)
912 : 84227 : && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 0)))
913 : : return true;
914 : :
915 : : /* The field declaration is marked as an pointer array. */
916 : 81829 : if (TREE_CODE (expr) == COMPONENT_REF
917 : 11718 : && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 1))
918 : 84653 : && !GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (expr, 1))))
919 : 2824 : return true;
920 : :
921 : : return false;
922 : : }
923 : :
924 : :
925 : : /* If the symbol or expression reference a CFI descriptor, return the
926 : : pointer to the converted gfc descriptor. If an array reference is
927 : : present as the last argument, check that it is the one applied to
928 : : the CFI descriptor in the expression. Note that the CFI object is
929 : : always the symbol in the expression! */
930 : :
931 : : static bool
932 : 344040 : get_CFI_desc (gfc_symbol *sym, gfc_expr *expr,
933 : : tree *desc, gfc_array_ref *ar)
934 : : {
935 : 344040 : tree tmp;
936 : :
937 : 344040 : if (!is_CFI_desc (sym, expr))
938 : : return false;
939 : :
940 : 4727 : if (expr && ar)
941 : : {
942 : 4061 : if (!(expr->ref && expr->ref->type == REF_ARRAY)
943 : 4043 : || (&expr->ref->u.ar != ar))
944 : : return false;
945 : : }
946 : :
947 : 4697 : if (sym == NULL)
948 : 1108 : tmp = expr->symtree->n.sym->backend_decl;
949 : : else
950 : 3589 : tmp = sym->backend_decl;
951 : :
952 : 4697 : if (tmp && DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp))
953 : 0 : tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
954 : :
955 : 4697 : *desc = tmp;
956 : 4697 : return true;
957 : : }
958 : :
959 : :
960 : : /* A helper function for gfc_get_array_span that returns the array element size
961 : : of a class entity. */
962 : : static tree
963 : 1060 : class_array_element_size (tree decl, bool unlimited)
964 : : {
965 : : /* Class dummys usually require extraction from the saved descriptor,
966 : : which gfc_class_vptr_get does for us if necessary. This, of course,
967 : : will be a component of the class object. */
968 : 1060 : tree vptr = gfc_class_vptr_get (decl);
969 : : /* If this is an unlimited polymorphic entity with a character payload,
970 : : the element size will be corrected for the string length. */
971 : 1060 : if (unlimited)
972 : 950 : return gfc_resize_class_size_with_len (NULL,
973 : 475 : TREE_OPERAND (vptr, 0),
974 : 475 : gfc_vptr_size_get (vptr));
975 : : else
976 : 585 : return gfc_vptr_size_get (vptr);
977 : : }
978 : :
979 : :
980 : : /* Return the span of an array. */
981 : :
982 : : tree
983 : 55223 : gfc_get_array_span (tree desc, gfc_expr *expr)
984 : : {
985 : 55223 : tree tmp;
986 : 55223 : gfc_symbol *sym = (expr && expr->expr_type == EXPR_VARIABLE) ?
987 : 48594 : expr->symtree->n.sym : NULL;
988 : :
989 : 55223 : if (is_pointer_array (desc)
990 : 55223 : || (get_CFI_desc (NULL, expr, &desc, NULL)
991 : 1332 : && (POINTER_TYPE_P (TREE_TYPE (desc))
992 : 666 : ? GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (desc)))
993 : 0 : : GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))))
994 : : {
995 : 557 : if (POINTER_TYPE_P (TREE_TYPE (desc)))
996 : 0 : desc = build_fold_indirect_ref_loc (input_location, desc);
997 : :
998 : : /* This will have the span field set. */
999 : 557 : tmp = gfc_conv_descriptor_span_get (desc);
1000 : : }
1001 : 54666 : else if (expr->ts.type == BT_ASSUMED)
1002 : : {
1003 : 127 : if (DECL_LANG_SPECIFIC (desc) && GFC_DECL_SAVED_DESCRIPTOR (desc))
1004 : 127 : desc = GFC_DECL_SAVED_DESCRIPTOR (desc);
1005 : 127 : if (POINTER_TYPE_P (TREE_TYPE (desc)))
1006 : 127 : desc = build_fold_indirect_ref_loc (input_location, desc);
1007 : 127 : tmp = gfc_conv_descriptor_span_get (desc);
1008 : : }
1009 : 54539 : else if (TREE_CODE (desc) == COMPONENT_REF
1010 : 469 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
1011 : 54652 : && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (desc, 0))))
1012 : : /* The descriptor is the _data field of a class object. */
1013 : 50 : tmp = class_array_element_size (TREE_OPERAND (desc, 0),
1014 : 50 : UNLIMITED_POLY (expr));
1015 : 54489 : else if (sym && sym->ts.type == BT_CLASS
1016 : 1057 : && expr->ref->type == REF_COMPONENT
1017 : 1057 : && expr->ref->next->type == REF_ARRAY
1018 : 1057 : && expr->ref->next->next == NULL
1019 : 1033 : && CLASS_DATA (sym)->attr.dimension)
1020 : : /* Having escaped the above, this can only be a class array dummy. */
1021 : 1010 : tmp = class_array_element_size (sym->backend_decl,
1022 : 1010 : UNLIMITED_POLY (sym));
1023 : : else
1024 : : {
1025 : : /* If none of the fancy stuff works, the span is the element
1026 : : size of the array. Attempt to deal with unbounded character
1027 : : types if possible. Otherwise, return NULL_TREE. */
1028 : 53479 : tmp = gfc_get_element_type (TREE_TYPE (desc));
1029 : 53479 : if (tmp && TREE_CODE (tmp) == ARRAY_TYPE && TYPE_STRING_FLAG (tmp))
1030 : : {
1031 : 10464 : gcc_assert (expr->ts.type == BT_CHARACTER);
1032 : :
1033 : 10464 : tmp = gfc_get_character_len_in_bytes (tmp);
1034 : :
1035 : 10464 : if (tmp == NULL_TREE || integer_zerop (tmp))
1036 : : {
1037 : 80 : tree bs;
1038 : :
1039 : 80 : tmp = gfc_get_expr_charlen (expr);
1040 : 80 : tmp = fold_convert (gfc_array_index_type, tmp);
1041 : 80 : bs = build_int_cst (gfc_array_index_type, expr->ts.kind);
1042 : 80 : tmp = fold_build2_loc (input_location, MULT_EXPR,
1043 : : gfc_array_index_type, tmp, bs);
1044 : : }
1045 : :
1046 : 10464 : tmp = (tmp && !integer_zerop (tmp))
1047 : 20848 : ? (fold_convert (gfc_array_index_type, tmp)) : (NULL_TREE);
1048 : : }
1049 : : else
1050 : 43015 : tmp = fold_convert (gfc_array_index_type,
1051 : : size_in_bytes (tmp));
1052 : : }
1053 : 55223 : return tmp;
1054 : : }
1055 : :
1056 : :
1057 : : /* Generate an initializer for a static pointer or allocatable array. */
1058 : :
1059 : : void
1060 : 214 : gfc_trans_static_array_pointer (gfc_symbol * sym)
1061 : : {
1062 : 214 : tree type;
1063 : :
1064 : 214 : gcc_assert (TREE_STATIC (sym->backend_decl));
1065 : : /* Just zero the data member. */
1066 : 214 : type = TREE_TYPE (sym->backend_decl);
1067 : 214 : DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
1068 : 214 : }
1069 : :
1070 : :
1071 : : /* If the bounds of SE's loop have not yet been set, see if they can be
1072 : : determined from array spec AS, which is the array spec of a called
1073 : : function. MAPPING maps the callee's dummy arguments to the values
1074 : : that the caller is passing. Add any initialization and finalization
1075 : : code to SE. */
1076 : :
1077 : : void
1078 : 7528 : gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
1079 : : gfc_se * se, gfc_array_spec * as)
1080 : : {
1081 : 7528 : int n, dim, total_dim;
1082 : 7528 : gfc_se tmpse;
1083 : 7528 : gfc_ss *ss;
1084 : 7528 : tree lower;
1085 : 7528 : tree upper;
1086 : 7528 : tree tmp;
1087 : :
1088 : 7528 : total_dim = 0;
1089 : :
1090 : 7528 : if (!as || as->type != AS_EXPLICIT)
1091 : 6424 : return;
1092 : :
1093 : 2233 : for (ss = se->ss; ss; ss = ss->parent)
1094 : : {
1095 : 1129 : total_dim += ss->loop->dimen;
1096 : 2613 : for (n = 0; n < ss->loop->dimen; n++)
1097 : : {
1098 : : /* The bound is known, nothing to do. */
1099 : 1484 : if (ss->loop->to[n] != NULL_TREE)
1100 : 483 : continue;
1101 : :
1102 : 1001 : dim = ss->dim[n];
1103 : 1001 : gcc_assert (dim < as->rank);
1104 : 1001 : gcc_assert (ss->loop->dimen <= as->rank);
1105 : :
1106 : : /* Evaluate the lower bound. */
1107 : 1001 : gfc_init_se (&tmpse, NULL);
1108 : 1001 : gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
1109 : 1001 : gfc_add_block_to_block (&se->pre, &tmpse.pre);
1110 : 1001 : gfc_add_block_to_block (&se->post, &tmpse.post);
1111 : 1001 : lower = fold_convert (gfc_array_index_type, tmpse.expr);
1112 : :
1113 : : /* ...and the upper bound. */
1114 : 1001 : gfc_init_se (&tmpse, NULL);
1115 : 1001 : gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
1116 : 1001 : gfc_add_block_to_block (&se->pre, &tmpse.pre);
1117 : 1001 : gfc_add_block_to_block (&se->post, &tmpse.post);
1118 : 1001 : upper = fold_convert (gfc_array_index_type, tmpse.expr);
1119 : :
1120 : : /* Set the upper bound of the loop to UPPER - LOWER. */
1121 : 1001 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
1122 : : gfc_array_index_type, upper, lower);
1123 : 1001 : tmp = gfc_evaluate_now (tmp, &se->pre);
1124 : 1001 : ss->loop->to[n] = tmp;
1125 : : }
1126 : : }
1127 : :
1128 : 1104 : gcc_assert (total_dim == as->rank);
1129 : : }
1130 : :
1131 : :
1132 : : /* Generate code to allocate an array temporary, or create a variable to
1133 : : hold the data. If size is NULL, zero the descriptor so that the
1134 : : callee will allocate the array. If DEALLOC is true, also generate code to
1135 : : free the array afterwards.
1136 : :
1137 : : If INITIAL is not NULL, it is packed using internal_pack and the result used
1138 : : as data instead of allocating a fresh, unitialized area of memory.
1139 : :
1140 : : Initialization code is added to PRE and finalization code to POST.
1141 : : DYNAMIC is true if the caller may want to extend the array later
1142 : : using realloc. This prevents us from putting the array on the stack. */
1143 : :
1144 : : static void
1145 : 26729 : gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
1146 : : gfc_array_info * info, tree size, tree nelem,
1147 : : tree initial, bool dynamic, bool dealloc)
1148 : : {
1149 : 26729 : tree tmp;
1150 : 26729 : tree desc;
1151 : 26729 : bool onstack;
1152 : :
1153 : 26729 : desc = info->descriptor;
1154 : 26729 : info->offset = gfc_index_zero_node;
1155 : 26729 : if (size == NULL_TREE || (dynamic && integer_zerop (size)))
1156 : : {
1157 : : /* A callee allocated array. */
1158 : 2661 : gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
1159 : 2661 : onstack = false;
1160 : : }
1161 : : else
1162 : : {
1163 : : /* Allocate the temporary. */
1164 : 48136 : onstack = !dynamic && initial == NULL_TREE
1165 : 24068 : && (flag_stack_arrays
1166 : 23741 : || gfc_can_put_var_on_stack (size));
1167 : :
1168 : 24068 : if (onstack)
1169 : : {
1170 : : /* Make a temporary variable to hold the data. */
1171 : 19388 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (nelem),
1172 : : nelem, gfc_index_one_node);
1173 : 19388 : tmp = gfc_evaluate_now (tmp, pre);
1174 : 19388 : tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
1175 : : tmp);
1176 : 19388 : tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
1177 : : tmp);
1178 : 19388 : tmp = gfc_create_var (tmp, "A");
1179 : : /* If we're here only because of -fstack-arrays we have to
1180 : : emit a DECL_EXPR to make the gimplifier emit alloca calls. */
1181 : 19388 : if (!gfc_can_put_var_on_stack (size))
1182 : 17 : gfc_add_expr_to_block (pre,
1183 : : fold_build1_loc (input_location,
1184 : 17 : DECL_EXPR, TREE_TYPE (tmp),
1185 : : tmp));
1186 : 19388 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1187 : 19388 : gfc_conv_descriptor_data_set (pre, desc, tmp);
1188 : : }
1189 : : else
1190 : : {
1191 : : /* Allocate memory to hold the data or call internal_pack. */
1192 : 4680 : if (initial == NULL_TREE)
1193 : : {
1194 : 4579 : tmp = gfc_call_malloc (pre, NULL, size);
1195 : 4579 : tmp = gfc_evaluate_now (tmp, pre);
1196 : : }
1197 : : else
1198 : : {
1199 : 101 : tree packed;
1200 : 101 : tree source_data;
1201 : 101 : tree was_packed;
1202 : 101 : stmtblock_t do_copying;
1203 : :
1204 : 101 : tmp = TREE_TYPE (initial); /* Pointer to descriptor. */
1205 : 101 : gcc_assert (TREE_CODE (tmp) == POINTER_TYPE);
1206 : 101 : tmp = TREE_TYPE (tmp); /* The descriptor itself. */
1207 : 101 : tmp = gfc_get_element_type (tmp);
1208 : 101 : packed = gfc_create_var (build_pointer_type (tmp), "data");
1209 : :
1210 : 101 : tmp = build_call_expr_loc (input_location,
1211 : : gfor_fndecl_in_pack, 1, initial);
1212 : 101 : tmp = fold_convert (TREE_TYPE (packed), tmp);
1213 : 101 : gfc_add_modify (pre, packed, tmp);
1214 : :
1215 : 101 : tmp = build_fold_indirect_ref_loc (input_location,
1216 : : initial);
1217 : 101 : source_data = gfc_conv_descriptor_data_get (tmp);
1218 : :
1219 : : /* internal_pack may return source->data without any allocation
1220 : : or copying if it is already packed. If that's the case, we
1221 : : need to allocate and copy manually. */
1222 : :
1223 : 101 : gfc_start_block (&do_copying);
1224 : 101 : tmp = gfc_call_malloc (&do_copying, NULL, size);
1225 : 101 : tmp = fold_convert (TREE_TYPE (packed), tmp);
1226 : 101 : gfc_add_modify (&do_copying, packed, tmp);
1227 : 101 : tmp = gfc_build_memcpy_call (packed, source_data, size);
1228 : 101 : gfc_add_expr_to_block (&do_copying, tmp);
1229 : :
1230 : 101 : was_packed = fold_build2_loc (input_location, EQ_EXPR,
1231 : : logical_type_node, packed,
1232 : : source_data);
1233 : 101 : tmp = gfc_finish_block (&do_copying);
1234 : 101 : tmp = build3_v (COND_EXPR, was_packed, tmp,
1235 : : build_empty_stmt (input_location));
1236 : 101 : gfc_add_expr_to_block (pre, tmp);
1237 : :
1238 : 101 : tmp = fold_convert (pvoid_type_node, packed);
1239 : : }
1240 : :
1241 : 4680 : gfc_conv_descriptor_data_set (pre, desc, tmp);
1242 : : }
1243 : : }
1244 : 26729 : info->data = gfc_conv_descriptor_data_get (desc);
1245 : :
1246 : : /* The offset is zero because we create temporaries with a zero
1247 : : lower bound. */
1248 : 26729 : gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node);
1249 : :
1250 : 26729 : if (dealloc && !onstack)
1251 : : {
1252 : : /* Free the temporary. */
1253 : 7101 : tmp = gfc_conv_descriptor_data_get (desc);
1254 : 7101 : tmp = gfc_call_free (tmp);
1255 : 7101 : gfc_add_expr_to_block (post, tmp);
1256 : : }
1257 : 26729 : }
1258 : :
1259 : :
1260 : : /* Get the scalarizer array dimension corresponding to actual array dimension
1261 : : given by ARRAY_DIM.
1262 : :
1263 : : For example, if SS represents the array ref a(1,:,:,1), it is a
1264 : : bidimensional scalarizer array, and the result would be 0 for ARRAY_DIM=1,
1265 : : and 1 for ARRAY_DIM=2.
1266 : : If SS represents transpose(a(:,1,1,:)), it is again a bidimensional
1267 : : scalarizer array, and the result would be 1 for ARRAY_DIM=0 and 0 for
1268 : : ARRAY_DIM=3.
1269 : : If SS represents sum(a(:,:,:,1), dim=1), it is a 2+1-dimensional scalarizer
1270 : : array. If called on the inner ss, the result would be respectively 0,1,2 for
1271 : : ARRAY_DIM=0,1,2. If called on the outer ss, the result would be 0,1
1272 : : for ARRAY_DIM=1,2. */
1273 : :
1274 : : static int
1275 : 241481 : get_scalarizer_dim_for_array_dim (gfc_ss *ss, int array_dim)
1276 : : {
1277 : 241481 : int array_ref_dim;
1278 : 241481 : int n;
1279 : :
1280 : 241481 : array_ref_dim = 0;
1281 : :
1282 : 486443 : for (; ss; ss = ss->parent)
1283 : 628192 : for (n = 0; n < ss->dimen; n++)
1284 : 383230 : if (ss->dim[n] < array_dim)
1285 : 68239 : array_ref_dim++;
1286 : :
1287 : 241481 : return array_ref_dim;
1288 : : }
1289 : :
1290 : :
1291 : : static gfc_ss *
1292 : 203057 : innermost_ss (gfc_ss *ss)
1293 : : {
1294 : 373598 : while (ss->nested_ss != NULL)
1295 : : ss = ss->nested_ss;
1296 : :
1297 : 368350 : return ss;
1298 : : }
1299 : :
1300 : :
1301 : :
1302 : : /* Get the array reference dimension corresponding to the given loop dimension.
1303 : : It is different from the true array dimension given by the dim array in
1304 : : the case of a partial array reference (i.e. a(:,:,1,:) for example)
1305 : : It is different from the loop dimension in the case of a transposed array.
1306 : : */
1307 : :
1308 : : static int
1309 : 203057 : get_array_ref_dim_for_loop_dim (gfc_ss *ss, int loop_dim)
1310 : : {
1311 : 203057 : return get_scalarizer_dim_for_array_dim (innermost_ss (ss),
1312 : 203057 : ss->dim[loop_dim]);
1313 : : }
1314 : :
1315 : :
1316 : : /* Use the information in the ss to obtain the required information about
1317 : : the type and size of an array temporary, when the lhs in an assignment
1318 : : is a class expression. */
1319 : :
1320 : : static tree
1321 : 303 : get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype,
1322 : : gfc_ss **fcnss)
1323 : : {
1324 : 303 : gfc_ss *loop_ss = ss->loop->ss;
1325 : 303 : gfc_ss *lhs_ss;
1326 : 303 : gfc_ss *rhs_ss;
1327 : 303 : gfc_ss *fcn_ss = NULL;
1328 : 303 : tree tmp;
1329 : 303 : tree tmp2;
1330 : 303 : tree vptr;
1331 : 303 : tree class_expr = NULL_TREE;
1332 : 303 : tree lhs_class_expr = NULL_TREE;
1333 : 303 : bool unlimited_rhs = false;
1334 : 303 : bool unlimited_lhs = false;
1335 : 303 : bool rhs_function = false;
1336 : 303 : bool unlimited_arg1 = false;
1337 : 303 : gfc_symbol *vtab;
1338 : 303 : tree cntnr = NULL_TREE;
1339 : :
1340 : : /* The second element in the loop chain contains the source for the
1341 : : class temporary created in gfc_trans_create_temp_array. */
1342 : 303 : rhs_ss = loop_ss->loop_chain;
1343 : :
1344 : 303 : if (rhs_ss != gfc_ss_terminator
1345 : 279 : && rhs_ss->info
1346 : 279 : && rhs_ss->info->expr
1347 : 279 : && rhs_ss->info->expr->ts.type == BT_CLASS
1348 : 170 : && rhs_ss->info->data.array.descriptor)
1349 : : {
1350 : 158 : if (rhs_ss->info->expr->expr_type != EXPR_VARIABLE)
1351 : 56 : class_expr
1352 : 56 : = gfc_get_class_from_expr (rhs_ss->info->data.array.descriptor);
1353 : : else
1354 : 102 : class_expr = gfc_get_class_from_gfc_expr (rhs_ss->info->expr);
1355 : 158 : unlimited_rhs = UNLIMITED_POLY (rhs_ss->info->expr);
1356 : 158 : if (rhs_ss->info->expr->expr_type == EXPR_FUNCTION)
1357 : : rhs_function = true;
1358 : : }
1359 : :
1360 : : /* Usually, ss points to the function. When the function call is an actual
1361 : : argument, it is instead rhs_ss because the ss chain is shifted by one. */
1362 : 303 : *fcnss = fcn_ss = rhs_function ? rhs_ss : ss;
1363 : :
1364 : : /* If this is a transformational function with a class result, the info
1365 : : class_container field points to the class container of arg1. */
1366 : 303 : if (class_expr != NULL_TREE
1367 : 139 : && fcn_ss->info && fcn_ss->info->expr
1368 : 91 : && fcn_ss->info->expr->expr_type == EXPR_FUNCTION
1369 : 91 : && fcn_ss->info->expr->value.function.isym
1370 : 60 : && fcn_ss->info->expr->value.function.isym->transformational)
1371 : : {
1372 : 60 : cntnr = ss->info->class_container;
1373 : 60 : unlimited_arg1
1374 : 60 : = UNLIMITED_POLY (fcn_ss->info->expr->value.function.actual->expr);
1375 : : }
1376 : :
1377 : : /* For an assignment the lhs is the next element in the loop chain.
1378 : : If we have a class rhs, this had better be a class variable
1379 : : expression! Otherwise, the class container from arg1 can be used
1380 : : to set the vptr and len fields of the result class container. */
1381 : 303 : lhs_ss = rhs_ss->loop_chain;
1382 : 303 : if (lhs_ss && lhs_ss != gfc_ss_terminator
1383 : 213 : && lhs_ss->info && lhs_ss->info->expr
1384 : 213 : && lhs_ss->info->expr->expr_type ==EXPR_VARIABLE
1385 : 213 : && lhs_ss->info->expr->ts.type == BT_CLASS)
1386 : : {
1387 : 213 : tmp = lhs_ss->info->data.array.descriptor;
1388 : 213 : unlimited_lhs = UNLIMITED_POLY (rhs_ss->info->expr);
1389 : : }
1390 : 90 : else if (cntnr != NULL_TREE)
1391 : : {
1392 : 54 : tmp = gfc_class_vptr_get (class_expr);
1393 : 54 : gfc_add_modify (pre, tmp, fold_convert (TREE_TYPE (tmp),
1394 : : gfc_class_vptr_get (cntnr)));
1395 : 54 : if (unlimited_rhs)
1396 : : {
1397 : 6 : tmp = gfc_class_len_get (class_expr);
1398 : 6 : if (unlimited_arg1)
1399 : 6 : gfc_add_modify (pre, tmp, gfc_class_len_get (cntnr));
1400 : : }
1401 : : tmp = NULL_TREE;
1402 : : }
1403 : : else
1404 : : tmp = NULL_TREE;
1405 : :
1406 : : /* Get the lhs class expression. */
1407 : 213 : if (tmp != NULL_TREE && lhs_ss->loop_chain == gfc_ss_terminator)
1408 : 201 : lhs_class_expr = gfc_get_class_from_expr (tmp);
1409 : : else
1410 : 102 : return class_expr;
1411 : :
1412 : 201 : gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (lhs_class_expr)));
1413 : :
1414 : : /* Set the lhs vptr and, if necessary, the _len field. */
1415 : 201 : if (class_expr)
1416 : : {
1417 : : /* Both lhs and rhs are class expressions. */
1418 : 79 : tmp = gfc_class_vptr_get (lhs_class_expr);
1419 : 158 : gfc_add_modify (pre, tmp,
1420 : 79 : fold_convert (TREE_TYPE (tmp),
1421 : : gfc_class_vptr_get (class_expr)));
1422 : 79 : if (unlimited_lhs)
1423 : : {
1424 : 31 : gcc_assert (unlimited_rhs);
1425 : 31 : tmp = gfc_class_len_get (lhs_class_expr);
1426 : 31 : tmp2 = gfc_class_len_get (class_expr);
1427 : 31 : gfc_add_modify (pre, tmp, tmp2);
1428 : : }
1429 : :
1430 : 79 : if (rhs_function)
1431 : : {
1432 : 37 : tmp = gfc_class_data_get (class_expr);
1433 : 37 : gfc_conv_descriptor_offset_set (pre, tmp, gfc_index_zero_node);
1434 : : }
1435 : : }
1436 : 122 : else if (rhs_ss->info->data.array.descriptor)
1437 : : {
1438 : : /* lhs is class and rhs is intrinsic or derived type. */
1439 : 116 : *eltype = TREE_TYPE (rhs_ss->info->data.array.descriptor);
1440 : 116 : *eltype = gfc_get_element_type (*eltype);
1441 : 116 : vtab = gfc_find_vtab (&rhs_ss->info->expr->ts);
1442 : 116 : vptr = vtab->backend_decl;
1443 : 116 : if (vptr == NULL_TREE)
1444 : 18 : vptr = gfc_get_symbol_decl (vtab);
1445 : 116 : vptr = gfc_build_addr_expr (NULL_TREE, vptr);
1446 : 116 : tmp = gfc_class_vptr_get (lhs_class_expr);
1447 : 116 : gfc_add_modify (pre, tmp,
1448 : 116 : fold_convert (TREE_TYPE (tmp), vptr));
1449 : :
1450 : 116 : if (unlimited_lhs)
1451 : : {
1452 : 0 : tmp = gfc_class_len_get (lhs_class_expr);
1453 : 0 : if (rhs_ss->info
1454 : 0 : && rhs_ss->info->expr
1455 : 0 : && rhs_ss->info->expr->ts.type == BT_CHARACTER)
1456 : 0 : tmp2 = build_int_cst (TREE_TYPE (tmp),
1457 : 0 : rhs_ss->info->expr->ts.kind);
1458 : : else
1459 : 0 : tmp2 = build_int_cst (TREE_TYPE (tmp), 0);
1460 : 0 : gfc_add_modify (pre, tmp, tmp2);
1461 : : }
1462 : : }
1463 : :
1464 : : return class_expr;
1465 : : }
1466 : :
1467 : :
1468 : :
1469 : : /* Generate code to create and initialize the descriptor for a temporary
1470 : : array. This is used for both temporaries needed by the scalarizer, and
1471 : : functions returning arrays. Adjusts the loop variables to be
1472 : : zero-based, and calculates the loop bounds for callee allocated arrays.
1473 : : Allocate the array unless it's callee allocated (we have a callee
1474 : : allocated array if 'callee_alloc' is true, or if loop->to[n] is
1475 : : NULL_TREE for any n). Also fills in the descriptor, data and offset
1476 : : fields of info if known. Returns the size of the array, or NULL for a
1477 : : callee allocated array.
1478 : :
1479 : : 'eltype' == NULL signals that the temporary should be a class object.
1480 : : The 'initial' expression is used to obtain the size of the dynamic
1481 : : type; otherwise the allocation and initialization proceeds as for any
1482 : : other expression
1483 : :
1484 : : PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
1485 : : gfc_trans_allocate_array_storage. */
1486 : :
1487 : : tree
1488 : 26729 : gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
1489 : : tree eltype, tree initial, bool dynamic,
1490 : : bool dealloc, bool callee_alloc, locus * where)
1491 : : {
1492 : 26729 : gfc_loopinfo *loop;
1493 : 26729 : gfc_ss *s;
1494 : 26729 : gfc_array_info *info;
1495 : 26729 : tree from[GFC_MAX_DIMENSIONS], to[GFC_MAX_DIMENSIONS];
1496 : 26729 : tree type;
1497 : 26729 : tree desc;
1498 : 26729 : tree tmp;
1499 : 26729 : tree size;
1500 : 26729 : tree nelem;
1501 : 26729 : tree cond;
1502 : 26729 : tree or_expr;
1503 : 26729 : tree elemsize;
1504 : 26729 : tree class_expr = NULL_TREE;
1505 : 26729 : gfc_ss *fcn_ss = NULL;
1506 : 26729 : int n, dim, tmp_dim;
1507 : 26729 : int total_dim = 0;
1508 : :
1509 : : /* This signals a class array for which we need the size of the
1510 : : dynamic type. Generate an eltype and then the class expression. */
1511 : 26729 : if (eltype == NULL_TREE && initial)
1512 : : {
1513 : 6 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial)));
1514 : 6 : class_expr = build_fold_indirect_ref_loc (input_location, initial);
1515 : : /* Obtain the structure (class) expression. */
1516 : 6 : class_expr = gfc_get_class_from_expr (class_expr);
1517 : 6 : gcc_assert (class_expr);
1518 : : }
1519 : :
1520 : : /* Otherwise, some expressions, such as class functions, arising from
1521 : : dependency checking in assignments come here with class element type.
1522 : : The descriptor can be obtained from the ss->info and then converted
1523 : : to the class object. */
1524 : 26723 : if (class_expr == NULL_TREE && GFC_CLASS_TYPE_P (eltype))
1525 : 303 : class_expr = get_class_info_from_ss (pre, ss, &eltype, &fcn_ss);
1526 : :
1527 : : /* If the dynamic type is not available, use the declared type. */
1528 : 26729 : if (eltype && GFC_CLASS_TYPE_P (eltype))
1529 : 187 : eltype = gfc_get_element_type (TREE_TYPE (TYPE_FIELDS (eltype)));
1530 : :
1531 : 26729 : if (class_expr == NULL_TREE)
1532 : 26584 : elemsize = fold_convert (gfc_array_index_type,
1533 : : TYPE_SIZE_UNIT (eltype));
1534 : : else
1535 : : {
1536 : : /* Unlimited polymorphic entities are initialised with NULL vptr. They
1537 : : can be tested for by checking if the len field is present. If so
1538 : : test the vptr before using the vtable size. */
1539 : 145 : tmp = gfc_class_vptr_get (class_expr);
1540 : 145 : tmp = fold_build2_loc (input_location, NE_EXPR,
1541 : : logical_type_node,
1542 : 145 : tmp, build_int_cst (TREE_TYPE (tmp), 0));
1543 : 145 : elemsize = fold_build3_loc (input_location, COND_EXPR,
1544 : : gfc_array_index_type,
1545 : : tmp,
1546 : : gfc_class_vtab_size_get (class_expr),
1547 : : gfc_index_zero_node);
1548 : 145 : elemsize = gfc_evaluate_now (elemsize, pre);
1549 : 145 : elemsize = gfc_resize_class_size_with_len (pre, class_expr, elemsize);
1550 : : /* Casting the data as a character of the dynamic length ensures that
1551 : : assignment of elements works when needed. */
1552 : 145 : eltype = gfc_get_character_type_len (1, elemsize);
1553 : : }
1554 : :
1555 : 26729 : memset (from, 0, sizeof (from));
1556 : 26729 : memset (to, 0, sizeof (to));
1557 : :
1558 : 26729 : info = &ss->info->data.array;
1559 : :
1560 : 26729 : gcc_assert (ss->dimen > 0);
1561 : 26729 : gcc_assert (ss->loop->dimen == ss->dimen);
1562 : :
1563 : 26729 : if (warn_array_temporaries && where)
1564 : 204 : gfc_warning (OPT_Warray_temporaries,
1565 : : "Creating array temporary at %L", where);
1566 : :
1567 : : /* Set the lower bound to zero. */
1568 : 53493 : for (s = ss; s; s = s->parent)
1569 : : {
1570 : 26764 : loop = s->loop;
1571 : :
1572 : 26764 : total_dim += loop->dimen;
1573 : 61966 : for (n = 0; n < loop->dimen; n++)
1574 : : {
1575 : 35202 : dim = s->dim[n];
1576 : :
1577 : : /* Callee allocated arrays may not have a known bound yet. */
1578 : 35202 : if (loop->to[n])
1579 : 31985 : loop->to[n] = gfc_evaluate_now (
1580 : : fold_build2_loc (input_location, MINUS_EXPR,
1581 : : gfc_array_index_type,
1582 : : loop->to[n], loop->from[n]),
1583 : : pre);
1584 : 35202 : loop->from[n] = gfc_index_zero_node;
1585 : :
1586 : : /* We have just changed the loop bounds, we must clear the
1587 : : corresponding specloop, so that delta calculation is not skipped
1588 : : later in gfc_set_delta. */
1589 : 35202 : loop->specloop[n] = NULL;
1590 : :
1591 : : /* We are constructing the temporary's descriptor based on the loop
1592 : : dimensions. As the dimensions may be accessed in arbitrary order
1593 : : (think of transpose) the size taken from the n'th loop may not map
1594 : : to the n'th dimension of the array. We need to reconstruct loop
1595 : : infos in the right order before using it to set the descriptor
1596 : : bounds. */
1597 : 35202 : tmp_dim = get_scalarizer_dim_for_array_dim (ss, dim);
1598 : 35202 : from[tmp_dim] = loop->from[n];
1599 : 35202 : to[tmp_dim] = loop->to[n];
1600 : :
1601 : 35202 : info->delta[dim] = gfc_index_zero_node;
1602 : 35202 : info->start[dim] = gfc_index_zero_node;
1603 : 35202 : info->end[dim] = gfc_index_zero_node;
1604 : 35202 : info->stride[dim] = gfc_index_one_node;
1605 : : }
1606 : : }
1607 : :
1608 : : /* Initialize the descriptor. */
1609 : 26729 : type =
1610 : 26729 : gfc_get_array_type_bounds (eltype, total_dim, 0, from, to, 1,
1611 : : GFC_ARRAY_UNKNOWN, true);
1612 : 26729 : desc = gfc_create_var (type, "atmp");
1613 : 26729 : GFC_DECL_PACKED_ARRAY (desc) = 1;
1614 : :
1615 : : /* Emit a DECL_EXPR for the variable sized array type in
1616 : : GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
1617 : : sizes works correctly. */
1618 : 26729 : tree arraytype = TREE_TYPE (GFC_TYPE_ARRAY_DATAPTR_TYPE (type));
1619 : 26729 : if (! TYPE_NAME (arraytype))
1620 : 26729 : TYPE_NAME (arraytype) = build_decl (UNKNOWN_LOCATION, TYPE_DECL,
1621 : : NULL_TREE, arraytype);
1622 : 26729 : gfc_add_expr_to_block (pre, build1 (DECL_EXPR,
1623 : 26729 : arraytype, TYPE_NAME (arraytype)));
1624 : :
1625 : 26729 : if (fcn_ss && fcn_ss->info && fcn_ss->info->class_container)
1626 : : {
1627 : 90 : suppress_warning (desc);
1628 : 90 : TREE_USED (desc) = 0;
1629 : : }
1630 : :
1631 : 26729 : if (class_expr != NULL_TREE
1632 : 26584 : || (fcn_ss && fcn_ss->info && fcn_ss->info->class_container))
1633 : : {
1634 : 175 : tree class_data;
1635 : 175 : tree dtype;
1636 : 175 : gfc_expr *expr1 = fcn_ss ? fcn_ss->info->expr : NULL;
1637 : 169 : bool rank_changer;
1638 : :
1639 : : /* Pick out these transformational functions because they change the rank
1640 : : or shape of the first argument. This requires that the class type be
1641 : : changed, the dtype updated and the correct rank used. */
1642 : 121 : rank_changer = expr1 && expr1->expr_type == EXPR_FUNCTION
1643 : 121 : && expr1->value.function.isym
1644 : 259 : && (expr1->value.function.isym->id == GFC_ISYM_RESHAPE
1645 : : || expr1->value.function.isym->id == GFC_ISYM_SPREAD
1646 : : || expr1->value.function.isym->id == GFC_ISYM_PACK
1647 : : || expr1->value.function.isym->id == GFC_ISYM_UNPACK);
1648 : :
1649 : : /* Create a class temporary for the result using the lhs class object. */
1650 : 175 : if (class_expr != NULL_TREE && !rank_changer)
1651 : : {
1652 : 97 : tmp = gfc_create_var (TREE_TYPE (class_expr), "ctmp");
1653 : 97 : gfc_add_modify (pre, tmp, class_expr);
1654 : : }
1655 : : else
1656 : : {
1657 : 78 : tree vptr;
1658 : 78 : class_expr = fcn_ss->info->class_container;
1659 : 78 : gcc_assert (expr1);
1660 : :
1661 : : /* Build a new class container using the arg1 class object. The class
1662 : : typespec must be rebuilt because the rank might have changed. */
1663 : 78 : gfc_typespec ts = CLASS_DATA (expr1)->ts;
1664 : 78 : symbol_attribute attr = CLASS_DATA (expr1)->attr;
1665 : 78 : gfc_change_class (&ts, &attr, NULL, expr1->rank, 0);
1666 : 78 : tmp = gfc_create_var (gfc_typenode_for_spec (&ts), "ctmp");
1667 : 78 : fcn_ss->info->class_container = tmp;
1668 : :
1669 : : /* Set the vptr and obtain the element size. */
1670 : 78 : vptr = gfc_class_vptr_get (tmp);
1671 : 156 : gfc_add_modify (pre, vptr,
1672 : 78 : fold_convert (TREE_TYPE (vptr),
1673 : : gfc_class_vptr_get (class_expr)));
1674 : 78 : elemsize = gfc_class_vtab_size_get (class_expr);
1675 : :
1676 : : /* Set the _len field, if necessary. */
1677 : 78 : if (UNLIMITED_POLY (expr1))
1678 : : {
1679 : 18 : gfc_add_modify (pre, gfc_class_len_get (tmp),
1680 : : gfc_class_len_get (class_expr));
1681 : 18 : elemsize = gfc_resize_class_size_with_len (pre, class_expr,
1682 : : elemsize);
1683 : : }
1684 : :
1685 : 78 : elemsize = gfc_evaluate_now (elemsize, pre);
1686 : : }
1687 : :
1688 : 175 : class_data = gfc_class_data_get (tmp);
1689 : :
1690 : 175 : if (rank_changer)
1691 : : {
1692 : : /* Take the dtype from the class expression. */
1693 : 72 : dtype = gfc_conv_descriptor_dtype (gfc_class_data_get (class_expr));
1694 : 72 : tmp = gfc_conv_descriptor_dtype (desc);
1695 : 72 : gfc_add_modify (pre, tmp, dtype);
1696 : :
1697 : : /* These transformational functions change the rank. */
1698 : 72 : tmp = gfc_conv_descriptor_rank (desc);
1699 : 72 : gfc_add_modify (pre, tmp,
1700 : 72 : build_int_cst (TREE_TYPE (tmp), ss->loop->dimen));
1701 : 72 : fcn_ss->info->class_container = NULL_TREE;
1702 : : }
1703 : :
1704 : : /* Assign the new descriptor to the _data field. This allows the
1705 : : vptr _copy to be used for scalarized assignment since the class
1706 : : temporary can be found from the descriptor. */
1707 : 175 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1708 : 175 : TREE_TYPE (desc), desc);
1709 : 175 : gfc_add_modify (pre, class_data, tmp);
1710 : :
1711 : : /* Point desc to the class _data field. */
1712 : 175 : desc = class_data;
1713 : 175 : }
1714 : : else
1715 : : {
1716 : : /* Fill in the array dtype. */
1717 : 26554 : tmp = gfc_conv_descriptor_dtype (desc);
1718 : 26554 : gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
1719 : : }
1720 : :
1721 : 26729 : info->descriptor = desc;
1722 : 26729 : size = gfc_index_one_node;
1723 : :
1724 : : /*
1725 : : Fill in the bounds and stride. This is a packed array, so:
1726 : :
1727 : : size = 1;
1728 : : for (n = 0; n < rank; n++)
1729 : : {
1730 : : stride[n] = size
1731 : : delta = ubound[n] + 1 - lbound[n];
1732 : : size = size * delta;
1733 : : }
1734 : : size = size * sizeof(element);
1735 : : */
1736 : :
1737 : 26729 : or_expr = NULL_TREE;
1738 : :
1739 : : /* If there is at least one null loop->to[n], it is a callee allocated
1740 : : array. */
1741 : 58714 : for (n = 0; n < total_dim; n++)
1742 : 33870 : if (to[n] == NULL_TREE)
1743 : : {
1744 : : size = NULL_TREE;
1745 : : break;
1746 : : }
1747 : :
1748 : 26729 : if (size == NULL_TREE)
1749 : 3780 : for (s = ss; s; s = s->parent)
1750 : 5117 : for (n = 0; n < s->loop->dimen; n++)
1751 : : {
1752 : 3222 : dim = get_scalarizer_dim_for_array_dim (ss, s->dim[n]);
1753 : :
1754 : : /* For a callee allocated array express the loop bounds in terms
1755 : : of the descriptor fields. */
1756 : 3222 : tmp = fold_build2_loc (input_location,
1757 : : MINUS_EXPR, gfc_array_index_type,
1758 : : gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]),
1759 : : gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]));
1760 : 3222 : s->loop->to[n] = tmp;
1761 : : }
1762 : : else
1763 : : {
1764 : 56824 : for (n = 0; n < total_dim; n++)
1765 : : {
1766 : : /* Store the stride and bound components in the descriptor. */
1767 : 31980 : gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size);
1768 : :
1769 : 31980 : gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
1770 : : gfc_index_zero_node);
1771 : :
1772 : 31980 : gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], to[n]);
1773 : :
1774 : 31980 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
1775 : : gfc_array_index_type,
1776 : : to[n], gfc_index_one_node);
1777 : :
1778 : : /* Check whether the size for this dimension is negative. */
1779 : 31980 : cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
1780 : : tmp, gfc_index_zero_node);
1781 : 31980 : cond = gfc_evaluate_now (cond, pre);
1782 : :
1783 : 31980 : if (n == 0)
1784 : : or_expr = cond;
1785 : : else
1786 : 7136 : or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1787 : : logical_type_node, or_expr, cond);
1788 : :
1789 : 31980 : size = fold_build2_loc (input_location, MULT_EXPR,
1790 : : gfc_array_index_type, size, tmp);
1791 : 31980 : size = gfc_evaluate_now (size, pre);
1792 : : }
1793 : : }
1794 : :
1795 : : /* Get the size of the array. */
1796 : 26729 : if (size && !callee_alloc)
1797 : : {
1798 : : /* If or_expr is true, then the extent in at least one
1799 : : dimension is zero and the size is set to zero. */
1800 : 24654 : size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
1801 : : or_expr, gfc_index_zero_node, size);
1802 : :
1803 : 24654 : nelem = size;
1804 : 24654 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
1805 : : size, elemsize);
1806 : : }
1807 : : else
1808 : : {
1809 : : nelem = size;
1810 : : size = NULL_TREE;
1811 : : }
1812 : :
1813 : : /* Set the span. */
1814 : 26729 : tmp = fold_convert (gfc_array_index_type, elemsize);
1815 : 26729 : gfc_conv_descriptor_span_set (pre, desc, tmp);
1816 : :
1817 : 26729 : gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
1818 : : dynamic, dealloc);
1819 : :
1820 : 53493 : while (ss->parent)
1821 : : ss = ss->parent;
1822 : :
1823 : 26729 : if (ss->dimen > ss->loop->temp_dim)
1824 : 22705 : ss->loop->temp_dim = ss->dimen;
1825 : :
1826 : 26729 : return size;
1827 : : }
1828 : :
1829 : :
1830 : : /* Return the number of iterations in a loop that starts at START,
1831 : : ends at END, and has step STEP. */
1832 : :
1833 : : static tree
1834 : 1003 : gfc_get_iteration_count (tree start, tree end, tree step)
1835 : : {
1836 : 1003 : tree tmp;
1837 : 1003 : tree type;
1838 : :
1839 : 1003 : type = TREE_TYPE (step);
1840 : 1003 : tmp = fold_build2_loc (input_location, MINUS_EXPR, type, end, start);
1841 : 1003 : tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, type, tmp, step);
1842 : 1003 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp,
1843 : 1003 : build_int_cst (type, 1));
1844 : 1003 : tmp = fold_build2_loc (input_location, MAX_EXPR, type, tmp,
1845 : 1003 : build_int_cst (type, 0));
1846 : 1003 : return fold_convert (gfc_array_index_type, tmp);
1847 : : }
1848 : :
1849 : :
1850 : : /* Extend the data in array DESC by EXTRA elements. */
1851 : :
1852 : : static void
1853 : 991 : gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
1854 : : {
1855 : 991 : tree arg0, arg1;
1856 : 991 : tree tmp;
1857 : 991 : tree size;
1858 : 991 : tree ubound;
1859 : :
1860 : 991 : if (integer_zerop (extra))
1861 : : return;
1862 : :
1863 : 961 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
1864 : :
1865 : : /* Add EXTRA to the upper bound. */
1866 : 961 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1867 : : ubound, extra);
1868 : 961 : gfc_conv_descriptor_ubound_set (pblock, desc, gfc_rank_cst[0], tmp);
1869 : :
1870 : : /* Get the value of the current data pointer. */
1871 : 961 : arg0 = gfc_conv_descriptor_data_get (desc);
1872 : :
1873 : : /* Calculate the new array size. */
1874 : 961 : size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
1875 : 961 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1876 : : ubound, gfc_index_one_node);
1877 : 961 : arg1 = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
1878 : : fold_convert (size_type_node, tmp),
1879 : : fold_convert (size_type_node, size));
1880 : :
1881 : : /* Call the realloc() function. */
1882 : 961 : tmp = gfc_call_realloc (pblock, arg0, arg1);
1883 : 961 : gfc_conv_descriptor_data_set (pblock, desc, tmp);
1884 : : }
1885 : :
1886 : :
1887 : : /* Return true if the bounds of iterator I can only be determined
1888 : : at run time. */
1889 : :
1890 : : static inline bool
1891 : 2104 : gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
1892 : : {
1893 : 2104 : return (i->start->expr_type != EXPR_CONSTANT
1894 : 1686 : || i->end->expr_type != EXPR_CONSTANT
1895 : 2272 : || i->step->expr_type != EXPR_CONSTANT);
1896 : : }
1897 : :
1898 : :
1899 : : /* Split the size of constructor element EXPR into the sum of two terms,
1900 : : one of which can be determined at compile time and one of which must
1901 : : be calculated at run time. Set *SIZE to the former and return true
1902 : : if the latter might be nonzero. */
1903 : :
1904 : : static bool
1905 : 3096 : gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
1906 : : {
1907 : 3096 : if (expr->expr_type == EXPR_ARRAY)
1908 : 630 : return gfc_get_array_constructor_size (size, expr->value.constructor);
1909 : 2466 : else if (expr->rank > 0)
1910 : : {
1911 : : /* Calculate everything at run time. */
1912 : 981 : mpz_set_ui (*size, 0);
1913 : 981 : return true;
1914 : : }
1915 : : else
1916 : : {
1917 : : /* A single element. */
1918 : 1485 : mpz_set_ui (*size, 1);
1919 : 1485 : return false;
1920 : : }
1921 : : }
1922 : :
1923 : :
1924 : : /* Like gfc_get_array_constructor_element_size, but applied to the whole
1925 : : of array constructor C. */
1926 : :
1927 : : static bool
1928 : 2706 : gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base)
1929 : : {
1930 : 2706 : gfc_constructor *c;
1931 : 2706 : gfc_iterator *i;
1932 : 2706 : mpz_t val;
1933 : 2706 : mpz_t len;
1934 : 2706 : bool dynamic;
1935 : :
1936 : 2706 : mpz_set_ui (*size, 0);
1937 : 2706 : mpz_init (len);
1938 : 2706 : mpz_init (val);
1939 : :
1940 : 2706 : dynamic = false;
1941 : 6738 : for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1942 : : {
1943 : 4032 : i = c->iterator;
1944 : 4032 : if (i && gfc_iterator_has_dynamic_bounds (i))
1945 : : dynamic = true;
1946 : : else
1947 : : {
1948 : 2596 : dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
1949 : 2596 : if (i)
1950 : : {
1951 : : /* Multiply the static part of the element size by the
1952 : : number of iterations. */
1953 : 124 : mpz_sub (val, i->end->value.integer, i->start->value.integer);
1954 : 124 : mpz_fdiv_q (val, val, i->step->value.integer);
1955 : 124 : mpz_add_ui (val, val, 1);
1956 : 124 : if (mpz_sgn (val) > 0)
1957 : 88 : mpz_mul (len, len, val);
1958 : : else
1959 : 36 : mpz_set_ui (len, 0);
1960 : : }
1961 : 2596 : mpz_add (*size, *size, len);
1962 : : }
1963 : : }
1964 : 2706 : mpz_clear (len);
1965 : 2706 : mpz_clear (val);
1966 : 2706 : return dynamic;
1967 : : }
1968 : :
1969 : :
1970 : : /* Make sure offset is a variable. */
1971 : :
1972 : : static void
1973 : 4688 : gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
1974 : : tree * offsetvar)
1975 : : {
1976 : : /* We should have already created the offset variable. We cannot
1977 : : create it here because we may be in an inner scope. */
1978 : 4688 : gcc_assert (*offsetvar != NULL_TREE);
1979 : 4688 : gfc_add_modify (pblock, *offsetvar, *poffset);
1980 : 4688 : *poffset = *offsetvar;
1981 : 4688 : TREE_USED (*offsetvar) = 1;
1982 : 4688 : }
1983 : :
1984 : :
1985 : : /* Variables needed for bounds-checking. */
1986 : : static bool first_len;
1987 : : static tree first_len_val;
1988 : : static bool typespec_chararray_ctor;
1989 : :
1990 : : static void
1991 : 12447 : gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
1992 : : tree offset, gfc_se * se, gfc_expr * expr)
1993 : : {
1994 : 12447 : tree tmp;
1995 : :
1996 : 12447 : gfc_conv_expr (se, expr);
1997 : :
1998 : : /* Store the value. */
1999 : 12447 : tmp = build_fold_indirect_ref_loc (input_location,
2000 : : gfc_conv_descriptor_data_get (desc));
2001 : 12447 : tmp = gfc_build_array_ref (tmp, offset, NULL);
2002 : :
2003 : 12447 : if (expr->expr_type == EXPR_FUNCTION && expr->ts.type == BT_DERIVED
2004 : 43 : && expr->ts.u.derived->attr.alloc_comp)
2005 : 13 : gfc_add_expr_to_block (&se->finalblock,
2006 : : gfc_deallocate_alloc_comp_no_caf (expr->ts.u.derived,
2007 : : tmp, expr->rank,
2008 : : true));
2009 : :
2010 : 12447 : if (expr->ts.type == BT_CHARACTER)
2011 : : {
2012 : 1993 : int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
2013 : 1993 : tree esize;
2014 : :
2015 : 1993 : esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)));
2016 : 1993 : esize = fold_convert (gfc_charlen_type_node, esize);
2017 : 3986 : esize = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
2018 : 1993 : TREE_TYPE (esize), esize,
2019 : 1993 : build_int_cst (TREE_TYPE (esize),
2020 : 1993 : gfc_character_kinds[i].bit_size / 8));
2021 : :
2022 : 1993 : gfc_conv_string_parameter (se);
2023 : 1993 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
2024 : : {
2025 : : /* The temporary is an array of pointers. */
2026 : 6 : se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
2027 : 6 : gfc_add_modify (&se->pre, tmp, se->expr);
2028 : : }
2029 : : else
2030 : : {
2031 : : /* The temporary is an array of string values. */
2032 : 1987 : tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp);
2033 : : /* We know the temporary and the value will be the same length,
2034 : : so can use memcpy. */
2035 : 1987 : gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind,
2036 : : se->string_length, se->expr, expr->ts.kind);
2037 : : }
2038 : 1993 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !typespec_chararray_ctor)
2039 : : {
2040 : 307 : if (first_len)
2041 : : {
2042 : 127 : gfc_add_modify (&se->pre, first_len_val,
2043 : 127 : fold_convert (TREE_TYPE (first_len_val),
2044 : : se->string_length));
2045 : 127 : first_len = false;
2046 : : }
2047 : : else
2048 : : {
2049 : : /* Verify that all constructor elements are of the same
2050 : : length. */
2051 : 180 : tree rhs = fold_convert (TREE_TYPE (first_len_val),
2052 : : se->string_length);
2053 : 180 : tree cond = fold_build2_loc (input_location, NE_EXPR,
2054 : : logical_type_node, first_len_val,
2055 : : rhs);
2056 : 180 : gfc_trans_runtime_check
2057 : 180 : (true, false, cond, &se->pre, &expr->where,
2058 : : "Different CHARACTER lengths (%ld/%ld) in array constructor",
2059 : : fold_convert (long_integer_type_node, first_len_val),
2060 : : fold_convert (long_integer_type_node, se->string_length));
2061 : : }
2062 : : }
2063 : : }
2064 : 10454 : else if (GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
2065 : 10454 : && !GFC_CLASS_TYPE_P (gfc_get_element_type (TREE_TYPE (desc))))
2066 : : {
2067 : : /* Assignment of a CLASS array constructor to a derived type array. */
2068 : 24 : if (expr->expr_type == EXPR_FUNCTION)
2069 : 18 : se->expr = gfc_evaluate_now (se->expr, pblock);
2070 : 24 : se->expr = gfc_class_data_get (se->expr);
2071 : 24 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
2072 : 24 : se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
2073 : 24 : gfc_add_modify (&se->pre, tmp, se->expr);
2074 : : }
2075 : : else
2076 : : {
2077 : : /* TODO: Should the frontend already have done this conversion? */
2078 : 10430 : se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
2079 : 10430 : gfc_add_modify (&se->pre, tmp, se->expr);
2080 : : }
2081 : :
2082 : 12447 : gfc_add_block_to_block (pblock, &se->pre);
2083 : 12447 : gfc_add_block_to_block (pblock, &se->post);
2084 : 12447 : }
2085 : :
2086 : :
2087 : : /* Add the contents of an array to the constructor. DYNAMIC is as for
2088 : : gfc_trans_array_constructor_value. */
2089 : :
2090 : : static void
2091 : 1904 : gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
2092 : : tree type ATTRIBUTE_UNUSED,
2093 : : tree desc, gfc_expr * expr,
2094 : : tree * poffset, tree * offsetvar,
2095 : : bool dynamic)
2096 : : {
2097 : 1904 : gfc_se se;
2098 : 1904 : gfc_ss *ss;
2099 : 1904 : gfc_loopinfo loop;
2100 : 1904 : stmtblock_t body;
2101 : 1904 : tree tmp;
2102 : 1904 : tree size;
2103 : 1904 : int n;
2104 : :
2105 : : /* We need this to be a variable so we can increment it. */
2106 : 1904 : gfc_put_offset_into_var (pblock, poffset, offsetvar);
2107 : :
2108 : 1904 : gfc_init_se (&se, NULL);
2109 : :
2110 : : /* Walk the array expression. */
2111 : 1904 : ss = gfc_walk_expr (expr);
2112 : 1904 : gcc_assert (ss != gfc_ss_terminator);
2113 : :
2114 : : /* Initialize the scalarizer. */
2115 : 1904 : gfc_init_loopinfo (&loop);
2116 : 1904 : gfc_add_ss_to_loop (&loop, ss);
2117 : :
2118 : : /* Initialize the loop. */
2119 : 1904 : gfc_conv_ss_startstride (&loop);
2120 : 1904 : gfc_conv_loop_setup (&loop, &expr->where);
2121 : :
2122 : : /* Make sure the constructed array has room for the new data. */
2123 : 1904 : if (dynamic)
2124 : : {
2125 : : /* Set SIZE to the total number of elements in the subarray. */
2126 : 491 : size = gfc_index_one_node;
2127 : 994 : for (n = 0; n < loop.dimen; n++)
2128 : : {
2129 : 503 : tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
2130 : : gfc_index_one_node);
2131 : 503 : size = fold_build2_loc (input_location, MULT_EXPR,
2132 : : gfc_array_index_type, size, tmp);
2133 : : }
2134 : :
2135 : : /* Grow the constructed array by SIZE elements. */
2136 : 491 : gfc_grow_array (&loop.pre, desc, size);
2137 : : }
2138 : :
2139 : : /* Make the loop body. */
2140 : 1904 : gfc_mark_ss_chain_used (ss, 1);
2141 : 1904 : gfc_start_scalarized_body (&loop, &body);
2142 : 1904 : gfc_copy_loopinfo_to_se (&se, &loop);
2143 : 1904 : se.ss = ss;
2144 : :
2145 : 1904 : gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
2146 : 1904 : gcc_assert (se.ss == gfc_ss_terminator);
2147 : :
2148 : : /* Increment the offset. */
2149 : 1904 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2150 : : *poffset, gfc_index_one_node);
2151 : 1904 : gfc_add_modify (&body, *poffset, tmp);
2152 : :
2153 : : /* Finish the loop. */
2154 : 1904 : gfc_trans_scalarizing_loops (&loop, &body);
2155 : 1904 : gfc_add_block_to_block (&loop.pre, &loop.post);
2156 : 1904 : tmp = gfc_finish_block (&loop.pre);
2157 : 1904 : gfc_add_expr_to_block (pblock, tmp);
2158 : :
2159 : 1904 : gfc_cleanup_loop (&loop);
2160 : 1904 : }
2161 : :
2162 : :
2163 : : /* Assign the values to the elements of an array constructor. DYNAMIC
2164 : : is true if descriptor DESC only contains enough data for the static
2165 : : size calculated by gfc_get_array_constructor_size. When true, memory
2166 : : for the dynamic parts must be allocated using realloc. */
2167 : :
2168 : : static void
2169 : 8464 : gfc_trans_array_constructor_value (stmtblock_t * pblock,
2170 : : stmtblock_t * finalblock,
2171 : : tree type, tree desc,
2172 : : gfc_constructor_base base, tree * poffset,
2173 : : tree * offsetvar, bool dynamic)
2174 : : {
2175 : 8464 : tree tmp;
2176 : 8464 : tree start = NULL_TREE;
2177 : 8464 : tree end = NULL_TREE;
2178 : 8464 : tree step = NULL_TREE;
2179 : 8464 : stmtblock_t body;
2180 : 8464 : gfc_se se;
2181 : 8464 : mpz_t size;
2182 : 8464 : gfc_constructor *c;
2183 : 8464 : gfc_typespec ts;
2184 : 8464 : int ctr = 0;
2185 : :
2186 : 8464 : tree shadow_loopvar = NULL_TREE;
2187 : 8464 : gfc_saved_var saved_loopvar;
2188 : :
2189 : 8464 : ts.type = BT_UNKNOWN;
2190 : 8464 : mpz_init (size);
2191 : 22317 : for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
2192 : : {
2193 : 13853 : ctr++;
2194 : : /* If this is an iterator or an array, the offset must be a variable. */
2195 : 13853 : if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
2196 : 2784 : gfc_put_offset_into_var (pblock, poffset, offsetvar);
2197 : :
2198 : : /* Shadowing the iterator avoids changing its value and saves us from
2199 : : keeping track of it. Further, it makes sure that there's always a
2200 : : backend-decl for the symbol, even if there wasn't one before,
2201 : : e.g. in the case of an iterator that appears in a specification
2202 : : expression in an interface mapping. */
2203 : 13853 : if (c->iterator)
2204 : : {
2205 : 1291 : gfc_symbol *sym;
2206 : 1291 : tree type;
2207 : :
2208 : : /* Evaluate loop bounds before substituting the loop variable
2209 : : in case they depend on it. Such a case is invalid, but it is
2210 : : not more expensive to do the right thing here.
2211 : : See PR 44354. */
2212 : 1291 : gfc_init_se (&se, NULL);
2213 : 1291 : gfc_conv_expr_val (&se, c->iterator->start);
2214 : 1291 : gfc_add_block_to_block (pblock, &se.pre);
2215 : 1291 : start = gfc_evaluate_now (se.expr, pblock);
2216 : :
2217 : 1291 : gfc_init_se (&se, NULL);
2218 : 1291 : gfc_conv_expr_val (&se, c->iterator->end);
2219 : 1291 : gfc_add_block_to_block (pblock, &se.pre);
2220 : 1291 : end = gfc_evaluate_now (se.expr, pblock);
2221 : :
2222 : 1291 : gfc_init_se (&se, NULL);
2223 : 1291 : gfc_conv_expr_val (&se, c->iterator->step);
2224 : 1291 : gfc_add_block_to_block (pblock, &se.pre);
2225 : 1291 : step = gfc_evaluate_now (se.expr, pblock);
2226 : :
2227 : 1291 : sym = c->iterator->var->symtree->n.sym;
2228 : 1291 : type = gfc_typenode_for_spec (&sym->ts);
2229 : :
2230 : 1291 : shadow_loopvar = gfc_create_var (type, "shadow_loopvar");
2231 : 1291 : gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar);
2232 : : }
2233 : :
2234 : 13853 : gfc_start_block (&body);
2235 : :
2236 : 13853 : if (c->expr->expr_type == EXPR_ARRAY)
2237 : : {
2238 : : /* Array constructors can be nested. */
2239 : 1301 : gfc_trans_array_constructor_value (&body, finalblock, type,
2240 : : desc, c->expr->value.constructor,
2241 : : poffset, offsetvar, dynamic);
2242 : : }
2243 : 12552 : else if (c->expr->rank > 0)
2244 : : {
2245 : 1904 : gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
2246 : : poffset, offsetvar, dynamic);
2247 : : }
2248 : : else
2249 : : {
2250 : : /* This code really upsets the gimplifier so don't bother for now. */
2251 : : gfc_constructor *p;
2252 : : HOST_WIDE_INT n;
2253 : : HOST_WIDE_INT size;
2254 : :
2255 : : p = c;
2256 : : n = 0;
2257 : 12435 : while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
2258 : : {
2259 : 1787 : p = gfc_constructor_next (p);
2260 : 1787 : n++;
2261 : : }
2262 : : /* Constructor with few constant elements, or element size not
2263 : : known at compile time (e.g. deferred-length character). */
2264 : 10648 : if (n < 4 || !INTEGER_CST_P (TYPE_SIZE_UNIT (type)))
2265 : : {
2266 : : /* Scalar values. */
2267 : 10543 : gfc_init_se (&se, NULL);
2268 : 10543 : gfc_trans_array_ctor_element (&body, desc, *poffset,
2269 : : &se, c->expr);
2270 : :
2271 : 10543 : *poffset = fold_build2_loc (input_location, PLUS_EXPR,
2272 : : gfc_array_index_type,
2273 : : *poffset, gfc_index_one_node);
2274 : 10543 : if (finalblock)
2275 : 947 : gfc_add_block_to_block (finalblock, &se.finalblock);
2276 : : }
2277 : : else
2278 : : {
2279 : : /* Collect multiple scalar constants into a constructor. */
2280 : 105 : vec<constructor_elt, va_gc> *v = NULL;
2281 : 105 : tree init;
2282 : 105 : tree bound;
2283 : 105 : tree tmptype;
2284 : 105 : HOST_WIDE_INT idx = 0;
2285 : :
2286 : 105 : p = c;
2287 : : /* Count the number of consecutive scalar constants. */
2288 : 837 : while (p && !(p->iterator
2289 : 745 : || p->expr->expr_type != EXPR_CONSTANT))
2290 : : {
2291 : 732 : gfc_init_se (&se, NULL);
2292 : 732 : gfc_conv_constant (&se, p->expr);
2293 : :
2294 : 732 : if (c->expr->ts.type != BT_CHARACTER)
2295 : 660 : se.expr = fold_convert (type, se.expr);
2296 : : /* For constant character array constructors we build
2297 : : an array of pointers. */
2298 : 72 : else if (POINTER_TYPE_P (type))
2299 : 0 : se.expr = gfc_build_addr_expr
2300 : 0 : (gfc_get_pchar_type (p->expr->ts.kind),
2301 : : se.expr);
2302 : :
2303 : 732 : CONSTRUCTOR_APPEND_ELT (v,
2304 : : build_int_cst (gfc_array_index_type,
2305 : : idx++),
2306 : : se.expr);
2307 : 732 : c = p;
2308 : 732 : p = gfc_constructor_next (p);
2309 : : }
2310 : :
2311 : 105 : bound = size_int (n - 1);
2312 : : /* Create an array type to hold them. */
2313 : 105 : tmptype = build_range_type (gfc_array_index_type,
2314 : : gfc_index_zero_node, bound);
2315 : 105 : tmptype = build_array_type (type, tmptype);
2316 : :
2317 : 105 : init = build_constructor (tmptype, v);
2318 : 105 : TREE_CONSTANT (init) = 1;
2319 : 105 : TREE_STATIC (init) = 1;
2320 : : /* Create a static variable to hold the data. */
2321 : 105 : tmp = gfc_create_var (tmptype, "data");
2322 : 105 : TREE_STATIC (tmp) = 1;
2323 : 105 : TREE_CONSTANT (tmp) = 1;
2324 : 105 : TREE_READONLY (tmp) = 1;
2325 : 105 : DECL_INITIAL (tmp) = init;
2326 : 105 : init = tmp;
2327 : :
2328 : : /* Use BUILTIN_MEMCPY to assign the values. */
2329 : 105 : tmp = gfc_conv_descriptor_data_get (desc);
2330 : 105 : tmp = build_fold_indirect_ref_loc (input_location,
2331 : : tmp);
2332 : 105 : tmp = gfc_build_array_ref (tmp, *poffset, NULL);
2333 : 105 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
2334 : 105 : init = gfc_build_addr_expr (NULL_TREE, init);
2335 : :
2336 : 105 : size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
2337 : 105 : bound = build_int_cst (size_type_node, n * size);
2338 : 105 : tmp = build_call_expr_loc (input_location,
2339 : : builtin_decl_explicit (BUILT_IN_MEMCPY),
2340 : : 3, tmp, init, bound);
2341 : 105 : gfc_add_expr_to_block (&body, tmp);
2342 : :
2343 : 105 : *poffset = fold_build2_loc (input_location, PLUS_EXPR,
2344 : : gfc_array_index_type, *poffset,
2345 : 105 : build_int_cst (gfc_array_index_type, n));
2346 : : }
2347 : 10648 : if (!INTEGER_CST_P (*poffset))
2348 : : {
2349 : 1600 : gfc_add_modify (&body, *offsetvar, *poffset);
2350 : 1600 : *poffset = *offsetvar;
2351 : : }
2352 : :
2353 : 10648 : if (!c->iterator)
2354 : 10648 : ts = c->expr->ts;
2355 : : }
2356 : :
2357 : : /* The frontend should already have done any expansions
2358 : : at compile-time. */
2359 : 13853 : if (!c->iterator)
2360 : : {
2361 : : /* Pass the code as is. */
2362 : 12562 : tmp = gfc_finish_block (&body);
2363 : 12562 : gfc_add_expr_to_block (pblock, tmp);
2364 : : }
2365 : : else
2366 : : {
2367 : : /* Build the implied do-loop. */
2368 : 1291 : stmtblock_t implied_do_block;
2369 : 1291 : tree cond;
2370 : 1291 : tree exit_label;
2371 : 1291 : tree loopbody;
2372 : 1291 : tree tmp2;
2373 : :
2374 : 1291 : loopbody = gfc_finish_block (&body);
2375 : :
2376 : : /* Create a new block that holds the implied-do loop. A temporary
2377 : : loop-variable is used. */
2378 : 1291 : gfc_start_block(&implied_do_block);
2379 : :
2380 : : /* Initialize the loop. */
2381 : 1291 : gfc_add_modify (&implied_do_block, shadow_loopvar, start);
2382 : :
2383 : : /* If this array expands dynamically, and the number of iterations
2384 : : is not constant, we won't have allocated space for the static
2385 : : part of C->EXPR's size. Do that now. */
2386 : 1291 : if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
2387 : : {
2388 : : /* Get the number of iterations. */
2389 : 500 : tmp = gfc_get_iteration_count (shadow_loopvar, end, step);
2390 : :
2391 : : /* Get the static part of C->EXPR's size. */
2392 : 500 : gfc_get_array_constructor_element_size (&size, c->expr);
2393 : 500 : tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
2394 : :
2395 : : /* Grow the array by TMP * TMP2 elements. */
2396 : 500 : tmp = fold_build2_loc (input_location, MULT_EXPR,
2397 : : gfc_array_index_type, tmp, tmp2);
2398 : 500 : gfc_grow_array (&implied_do_block, desc, tmp);
2399 : : }
2400 : :
2401 : : /* Generate the loop body. */
2402 : 1291 : exit_label = gfc_build_label_decl (NULL_TREE);
2403 : 1291 : gfc_start_block (&body);
2404 : :
2405 : : /* Generate the exit condition. Depending on the sign of
2406 : : the step variable we have to generate the correct
2407 : : comparison. */
2408 : 1291 : tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2409 : 1291 : step, build_int_cst (TREE_TYPE (step), 0));
2410 : 1291 : cond = fold_build3_loc (input_location, COND_EXPR,
2411 : : logical_type_node, tmp,
2412 : : fold_build2_loc (input_location, GT_EXPR,
2413 : : logical_type_node, shadow_loopvar, end),
2414 : : fold_build2_loc (input_location, LT_EXPR,
2415 : : logical_type_node, shadow_loopvar, end));
2416 : 1291 : tmp = build1_v (GOTO_EXPR, exit_label);
2417 : 1291 : TREE_USED (exit_label) = 1;
2418 : 1291 : tmp = build3_v (COND_EXPR, cond, tmp,
2419 : : build_empty_stmt (input_location));
2420 : 1291 : gfc_add_expr_to_block (&body, tmp);
2421 : :
2422 : : /* The main loop body. */
2423 : 1291 : gfc_add_expr_to_block (&body, loopbody);
2424 : :
2425 : : /* Increase loop variable by step. */
2426 : 1291 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
2427 : 1291 : TREE_TYPE (shadow_loopvar), shadow_loopvar,
2428 : : step);
2429 : 1291 : gfc_add_modify (&body, shadow_loopvar, tmp);
2430 : :
2431 : : /* Finish the loop. */
2432 : 1291 : tmp = gfc_finish_block (&body);
2433 : 1291 : tmp = build1_v (LOOP_EXPR, tmp);
2434 : 1291 : gfc_add_expr_to_block (&implied_do_block, tmp);
2435 : :
2436 : : /* Add the exit label. */
2437 : 1291 : tmp = build1_v (LABEL_EXPR, exit_label);
2438 : 1291 : gfc_add_expr_to_block (&implied_do_block, tmp);
2439 : :
2440 : : /* Finish the implied-do loop. */
2441 : 1291 : tmp = gfc_finish_block(&implied_do_block);
2442 : 1291 : gfc_add_expr_to_block(pblock, tmp);
2443 : :
2444 : 1291 : gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar);
2445 : : }
2446 : : }
2447 : :
2448 : : /* F2008 4.5.6.3 para 5: If an executable construct references a structure
2449 : : constructor or array constructor, the entity created by the constructor is
2450 : : finalized after execution of the innermost executable construct containing
2451 : : the reference. This, in fact, was later deleted by the Combined Techical
2452 : : Corrigenda 1 TO 4 for fortran 2008 (f08/0011).
2453 : :
2454 : : Transmit finalization of this constructor through 'finalblock'. */
2455 : 8464 : if ((gfc_option.allow_std & (GFC_STD_F2008 | GFC_STD_F2003))
2456 : 8464 : && !(gfc_option.allow_std & GFC_STD_GNU)
2457 : 70 : && finalblock != NULL
2458 : 24 : && gfc_may_be_finalized (ts)
2459 : 18 : && ctr > 0 && desc != NULL_TREE
2460 : 8482 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
2461 : : {
2462 : 18 : symbol_attribute attr;
2463 : 18 : gfc_se fse;
2464 : 18 : locus loc;
2465 : 18 : gfc_locus_from_location (&loc, input_location);
2466 : 18 : gfc_warning (0, "The structure constructor at %L has been"
2467 : : " finalized. This feature was removed by f08/0011."
2468 : : " Use -std=f2018 or -std=gnu to eliminate the"
2469 : : " finalization.", &loc);
2470 : 18 : attr.pointer = attr.allocatable = 0;
2471 : 18 : gfc_init_se (&fse, NULL);
2472 : 18 : fse.expr = desc;
2473 : 18 : gfc_finalize_tree_expr (&fse, ts.u.derived, attr, 1);
2474 : 18 : gfc_add_block_to_block (finalblock, &fse.pre);
2475 : 18 : gfc_add_block_to_block (finalblock, &fse.finalblock);
2476 : 18 : gfc_add_block_to_block (finalblock, &fse.post);
2477 : : }
2478 : :
2479 : 8464 : mpz_clear (size);
2480 : 8464 : }
2481 : :
2482 : :
2483 : : /* The array constructor code can create a string length with an operand
2484 : : in the form of a temporary variable. This variable will retain its
2485 : : context (current_function_decl). If we store this length tree in a
2486 : : gfc_charlen structure which is shared by a variable in another
2487 : : context, the resulting gfc_charlen structure with a variable in a
2488 : : different context, we could trip the assertion in expand_expr_real_1
2489 : : when it sees that a variable has been created in one context and
2490 : : referenced in another.
2491 : :
2492 : : If this might be the case, we create a new gfc_charlen structure and
2493 : : link it into the current namespace. */
2494 : :
2495 : : static void
2496 : 8052 : store_backend_decl (gfc_charlen **clp, tree len, bool force_new_cl)
2497 : : {
2498 : 8052 : if (force_new_cl)
2499 : : {
2500 : 8025 : gfc_charlen *new_cl = gfc_new_charlen (gfc_current_ns, *clp);
2501 : 8025 : *clp = new_cl;
2502 : : }
2503 : 8052 : (*clp)->backend_decl = len;
2504 : 8052 : }
2505 : :
2506 : : /* A catch-all to obtain the string length for anything that is not
2507 : : a substring of non-constant length, a constant, array or variable. */
2508 : :
2509 : : static void
2510 : 317 : get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
2511 : : {
2512 : 317 : gfc_se se;
2513 : :
2514 : : /* Don't bother if we already know the length is a constant. */
2515 : 317 : if (*len && INTEGER_CST_P (*len))
2516 : 40 : return;
2517 : :
2518 : 277 : if (!e->ref && e->ts.u.cl && e->ts.u.cl->length
2519 : 29 : && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
2520 : : {
2521 : : /* This is easy. */
2522 : 1 : gfc_conv_const_charlen (e->ts.u.cl);
2523 : 1 : *len = e->ts.u.cl->backend_decl;
2524 : : }
2525 : : else
2526 : : {
2527 : : /* Otherwise, be brutal even if inefficient. */
2528 : 276 : gfc_init_se (&se, NULL);
2529 : :
2530 : : /* No function call, in case of side effects. */
2531 : 276 : se.no_function_call = 1;
2532 : 276 : if (e->rank == 0)
2533 : 134 : gfc_conv_expr (&se, e);
2534 : : else
2535 : 142 : gfc_conv_expr_descriptor (&se, e);
2536 : :
2537 : : /* Fix the value. */
2538 : 276 : *len = gfc_evaluate_now (se.string_length, &se.pre);
2539 : :
2540 : 276 : gfc_add_block_to_block (block, &se.pre);
2541 : 276 : gfc_add_block_to_block (block, &se.post);
2542 : :
2543 : 276 : store_backend_decl (&e->ts.u.cl, *len, true);
2544 : : }
2545 : : }
2546 : :
2547 : :
2548 : : /* Figure out the string length of a variable reference expression.
2549 : : Used by get_array_ctor_strlen. */
2550 : :
2551 : : static void
2552 : 912 : get_array_ctor_var_strlen (stmtblock_t *block, gfc_expr * expr, tree * len)
2553 : : {
2554 : 912 : gfc_ref *ref;
2555 : 912 : gfc_typespec *ts;
2556 : 912 : mpz_t char_len;
2557 : 912 : gfc_se se;
2558 : :
2559 : : /* Don't bother if we already know the length is a constant. */
2560 : 912 : if (*len && INTEGER_CST_P (*len))
2561 : 539 : return;
2562 : :
2563 : 465 : ts = &expr->symtree->n.sym->ts;
2564 : 739 : for (ref = expr->ref; ref; ref = ref->next)
2565 : : {
2566 : 366 : switch (ref->type)
2567 : : {
2568 : 231 : case REF_ARRAY:
2569 : : /* Array references don't change the string length. */
2570 : 231 : if (ts->deferred)
2571 : 135 : get_array_ctor_all_strlen (block, expr, len);
2572 : : break;
2573 : :
2574 : 43 : case REF_COMPONENT:
2575 : : /* Use the length of the component. */
2576 : 43 : ts = &ref->u.c.component->ts;
2577 : 43 : break;
2578 : :
2579 : 92 : case REF_SUBSTRING:
2580 : 92 : if (ref->u.ss.end == NULL
2581 : 80 : || ref->u.ss.start->expr_type != EXPR_CONSTANT
2582 : 61 : || ref->u.ss.end->expr_type != EXPR_CONSTANT)
2583 : : {
2584 : : /* Note that this might evaluate expr. */
2585 : 64 : get_array_ctor_all_strlen (block, expr, len);
2586 : 64 : return;
2587 : : }
2588 : 28 : mpz_init_set_ui (char_len, 1);
2589 : 28 : mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
2590 : 28 : mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
2591 : 28 : *len = gfc_conv_mpz_to_tree_type (char_len, gfc_charlen_type_node);
2592 : 28 : mpz_clear (char_len);
2593 : 28 : return;
2594 : :
2595 : : case REF_INQUIRY:
2596 : : break;
2597 : :
2598 : 0 : default:
2599 : 0 : gcc_unreachable ();
2600 : : }
2601 : : }
2602 : :
2603 : : /* A last ditch attempt that is sometimes needed for deferred characters. */
2604 : 373 : if (!ts->u.cl->backend_decl)
2605 : : {
2606 : 19 : gfc_init_se (&se, NULL);
2607 : 19 : if (expr->rank)
2608 : 12 : gfc_conv_expr_descriptor (&se, expr);
2609 : : else
2610 : 7 : gfc_conv_expr (&se, expr);
2611 : 19 : gcc_assert (se.string_length != NULL_TREE);
2612 : 19 : gfc_add_block_to_block (block, &se.pre);
2613 : 19 : ts->u.cl->backend_decl = se.string_length;
2614 : : }
2615 : :
2616 : 373 : *len = ts->u.cl->backend_decl;
2617 : : }
2618 : :
2619 : :
2620 : : /* Figure out the string length of a character array constructor.
2621 : : If len is NULL, don't calculate the length; this happens for recursive calls
2622 : : when a sub-array-constructor is an element but not at the first position,
2623 : : so when we're not interested in the length.
2624 : : Returns TRUE if all elements are character constants. */
2625 : :
2626 : : bool
2627 : 8467 : get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len)
2628 : : {
2629 : 8467 : gfc_constructor *c;
2630 : 8467 : bool is_const;
2631 : :
2632 : 8467 : is_const = true;
2633 : :
2634 : 8467 : if (gfc_constructor_first (base) == NULL)
2635 : : {
2636 : 303 : if (len)
2637 : 303 : *len = build_int_cstu (gfc_charlen_type_node, 0);
2638 : 303 : return is_const;
2639 : : }
2640 : :
2641 : : /* Loop over all constructor elements to find out is_const, but in len we
2642 : : want to store the length of the first, not the last, element. We can
2643 : : of course exit the loop as soon as is_const is found to be false. */
2644 : 8164 : for (c = gfc_constructor_first (base);
2645 : 45012 : c && is_const; c = gfc_constructor_next (c))
2646 : : {
2647 : 36848 : switch (c->expr->expr_type)
2648 : : {
2649 : 35715 : case EXPR_CONSTANT:
2650 : 35715 : if (len && !(*len && INTEGER_CST_P (*len)))
2651 : 390 : *len = build_int_cstu (gfc_charlen_type_node,
2652 : 390 : c->expr->value.character.length);
2653 : : break;
2654 : :
2655 : 43 : case EXPR_ARRAY:
2656 : 43 : if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
2657 : 1121 : is_const = false;
2658 : : break;
2659 : :
2660 : 972 : case EXPR_VARIABLE:
2661 : 972 : is_const = false;
2662 : 972 : if (len)
2663 : 912 : get_array_ctor_var_strlen (block, c->expr, len);
2664 : : break;
2665 : :
2666 : 118 : default:
2667 : 118 : is_const = false;
2668 : 118 : if (len)
2669 : 118 : get_array_ctor_all_strlen (block, c->expr, len);
2670 : : break;
2671 : : }
2672 : :
2673 : : /* After the first iteration, we don't want the length modified. */
2674 : 36848 : len = NULL;
2675 : : }
2676 : :
2677 : : return is_const;
2678 : : }
2679 : :
2680 : : /* Check whether the array constructor C consists entirely of constant
2681 : : elements, and if so returns the number of those elements, otherwise
2682 : : return zero. Note, an empty or NULL array constructor returns zero. */
2683 : :
2684 : : unsigned HOST_WIDE_INT
2685 : 56357 : gfc_constant_array_constructor_p (gfc_constructor_base base)
2686 : : {
2687 : 56357 : unsigned HOST_WIDE_INT nelem = 0;
2688 : :
2689 : 56357 : gfc_constructor *c = gfc_constructor_first (base);
2690 : 454895 : while (c)
2691 : : {
2692 : 350300 : if (c->iterator
2693 : 348940 : || c->expr->rank > 0
2694 : 346532 : || c->expr->expr_type != EXPR_CONSTANT)
2695 : : return 0;
2696 : 342181 : c = gfc_constructor_next (c);
2697 : 342181 : nelem++;
2698 : : }
2699 : : return nelem;
2700 : : }
2701 : :
2702 : :
2703 : : /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
2704 : : and the tree type of it's elements, TYPE, return a static constant
2705 : : variable that is compile-time initialized. */
2706 : :
2707 : : tree
2708 : 38535 : gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
2709 : : {
2710 : 38535 : tree tmptype, init, tmp;
2711 : 38535 : HOST_WIDE_INT nelem;
2712 : 38535 : gfc_constructor *c;
2713 : 38535 : gfc_array_spec as;
2714 : 38535 : gfc_se se;
2715 : 38535 : int i;
2716 : 38535 : vec<constructor_elt, va_gc> *v = NULL;
2717 : :
2718 : : /* First traverse the constructor list, converting the constants
2719 : : to tree to build an initializer. */
2720 : 38535 : nelem = 0;
2721 : 38535 : c = gfc_constructor_first (expr->value.constructor);
2722 : 354209 : while (c)
2723 : : {
2724 : 277139 : gfc_init_se (&se, NULL);
2725 : 277139 : gfc_conv_constant (&se, c->expr);
2726 : 277139 : if (c->expr->ts.type != BT_CHARACTER)
2727 : 242318 : se.expr = fold_convert (type, se.expr);
2728 : 34821 : else if (POINTER_TYPE_P (type))
2729 : 34821 : se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
2730 : : se.expr);
2731 : 277139 : CONSTRUCTOR_APPEND_ELT (v, build_int_cst (gfc_array_index_type, nelem),
2732 : : se.expr);
2733 : 277139 : c = gfc_constructor_next (c);
2734 : 277139 : nelem++;
2735 : : }
2736 : :
2737 : : /* Next determine the tree type for the array. We use the gfortran
2738 : : front-end's gfc_get_nodesc_array_type in order to create a suitable
2739 : : GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
2740 : :
2741 : 38535 : memset (&as, 0, sizeof (gfc_array_spec));
2742 : :
2743 : 38535 : as.rank = expr->rank;
2744 : 38535 : as.type = AS_EXPLICIT;
2745 : 38535 : if (!expr->shape)
2746 : : {
2747 : 3 : as.lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
2748 : 3 : as.upper[0] = gfc_get_int_expr (gfc_default_integer_kind,
2749 : : NULL, nelem - 1);
2750 : : }
2751 : : else
2752 : 82649 : for (i = 0; i < expr->rank; i++)
2753 : : {
2754 : 44117 : int tmp = (int) mpz_get_si (expr->shape[i]);
2755 : 44117 : as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
2756 : 44117 : as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind,
2757 : 44117 : NULL, tmp - 1);
2758 : : }
2759 : :
2760 : 38535 : tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
2761 : :
2762 : : /* as is not needed anymore. */
2763 : 121190 : for (i = 0; i < as.rank + as.corank; i++)
2764 : : {
2765 : 44120 : gfc_free_expr (as.lower[i]);
2766 : 44120 : gfc_free_expr (as.upper[i]);
2767 : : }
2768 : :
2769 : 38535 : init = build_constructor (tmptype, v);
2770 : :
2771 : 38535 : TREE_CONSTANT (init) = 1;
2772 : 38535 : TREE_STATIC (init) = 1;
2773 : :
2774 : 38535 : tmp = build_decl (input_location, VAR_DECL, create_tmp_var_name ("A"),
2775 : : tmptype);
2776 : 38535 : DECL_ARTIFICIAL (tmp) = 1;
2777 : 38535 : DECL_IGNORED_P (tmp) = 1;
2778 : 38535 : TREE_STATIC (tmp) = 1;
2779 : 38535 : TREE_CONSTANT (tmp) = 1;
2780 : 38535 : TREE_READONLY (tmp) = 1;
2781 : 38535 : DECL_INITIAL (tmp) = init;
2782 : 38535 : pushdecl (tmp);
2783 : :
2784 : 38535 : return tmp;
2785 : : }
2786 : :
2787 : :
2788 : : /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
2789 : : This mostly initializes the scalarizer state info structure with the
2790 : : appropriate values to directly use the array created by the function
2791 : : gfc_build_constant_array_constructor. */
2792 : :
2793 : : static void
2794 : 33488 : trans_constant_array_constructor (gfc_ss * ss, tree type)
2795 : : {
2796 : 33488 : gfc_array_info *info;
2797 : 33488 : tree tmp;
2798 : 33488 : int i;
2799 : :
2800 : 33488 : tmp = gfc_build_constant_array_constructor (ss->info->expr, type);
2801 : :
2802 : 33488 : info = &ss->info->data.array;
2803 : :
2804 : 33488 : info->descriptor = tmp;
2805 : 33488 : info->data = gfc_build_addr_expr (NULL_TREE, tmp);
2806 : 33488 : info->offset = gfc_index_zero_node;
2807 : :
2808 : 70306 : for (i = 0; i < ss->dimen; i++)
2809 : : {
2810 : 36818 : info->delta[i] = gfc_index_zero_node;
2811 : 36818 : info->start[i] = gfc_index_zero_node;
2812 : 36818 : info->end[i] = gfc_index_zero_node;
2813 : 36818 : info->stride[i] = gfc_index_one_node;
2814 : : }
2815 : 33488 : }
2816 : :
2817 : :
2818 : : static int
2819 : 33494 : get_rank (gfc_loopinfo *loop)
2820 : : {
2821 : 33494 : int rank;
2822 : :
2823 : 33494 : rank = 0;
2824 : 145770 : for (; loop; loop = loop->parent)
2825 : 72891 : rank += loop->dimen;
2826 : :
2827 : 39385 : return rank;
2828 : : }
2829 : :
2830 : :
2831 : : /* Helper routine of gfc_trans_array_constructor to determine if the
2832 : : bounds of the loop specified by LOOP are constant and simple enough
2833 : : to use with trans_constant_array_constructor. Returns the
2834 : : iteration count of the loop if suitable, and NULL_TREE otherwise. */
2835 : :
2836 : : static tree
2837 : 33494 : constant_array_constructor_loop_size (gfc_loopinfo * l)
2838 : : {
2839 : 33494 : gfc_loopinfo *loop;
2840 : 33494 : tree size = gfc_index_one_node;
2841 : 33494 : tree tmp;
2842 : 33494 : int i, total_dim;
2843 : :
2844 : 33494 : total_dim = get_rank (l);
2845 : :
2846 : 66988 : for (loop = l; loop; loop = loop->parent)
2847 : : {
2848 : 70330 : for (i = 0; i < loop->dimen; i++)
2849 : : {
2850 : : /* If the bounds aren't constant, return NULL_TREE. */
2851 : 36836 : if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
2852 : : return NULL_TREE;
2853 : 36830 : if (!integer_zerop (loop->from[i]))
2854 : : {
2855 : : /* Only allow nonzero "from" in one-dimensional arrays. */
2856 : 0 : if (total_dim != 1)
2857 : : return NULL_TREE;
2858 : 0 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2859 : : gfc_array_index_type,
2860 : : loop->to[i], loop->from[i]);
2861 : : }
2862 : : else
2863 : 36830 : tmp = loop->to[i];
2864 : 36830 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
2865 : : gfc_array_index_type, tmp, gfc_index_one_node);
2866 : 36830 : size = fold_build2_loc (input_location, MULT_EXPR,
2867 : : gfc_array_index_type, size, tmp);
2868 : : }
2869 : : }
2870 : :
2871 : : return size;
2872 : : }
2873 : :
2874 : :
2875 : : static tree *
2876 : 40651 : get_loop_upper_bound_for_array (gfc_ss *array, int array_dim)
2877 : : {
2878 : 40651 : gfc_ss *ss;
2879 : 40651 : int n;
2880 : :
2881 : 40651 : gcc_assert (array->nested_ss == NULL);
2882 : :
2883 : 40651 : for (ss = array; ss; ss = ss->parent)
2884 : 40651 : for (n = 0; n < ss->loop->dimen; n++)
2885 : 40651 : if (array_dim == get_array_ref_dim_for_loop_dim (ss, n))
2886 : 40651 : return &(ss->loop->to[n]);
2887 : :
2888 : 0 : gcc_unreachable ();
2889 : : }
2890 : :
2891 : :
2892 : : static gfc_loopinfo *
2893 : 656154 : outermost_loop (gfc_loopinfo * loop)
2894 : : {
2895 : 846157 : while (loop->parent != NULL)
2896 : : loop = loop->parent;
2897 : :
2898 : 656154 : return loop;
2899 : : }
2900 : :
2901 : :
2902 : : /* Array constructors are handled by constructing a temporary, then using that
2903 : : within the scalarization loop. This is not optimal, but seems by far the
2904 : : simplest method. */
2905 : :
2906 : : static void
2907 : 40651 : trans_array_constructor (gfc_ss * ss, locus * where)
2908 : : {
2909 : 40651 : gfc_constructor_base c;
2910 : 40651 : tree offset;
2911 : 40651 : tree offsetvar;
2912 : 40651 : tree desc;
2913 : 40651 : tree type;
2914 : 40651 : tree tmp;
2915 : 40651 : tree *loop_ubound0;
2916 : 40651 : bool dynamic;
2917 : 40651 : bool old_first_len, old_typespec_chararray_ctor;
2918 : 40651 : tree old_first_len_val;
2919 : 40651 : gfc_loopinfo *loop, *outer_loop;
2920 : 40651 : gfc_ss_info *ss_info;
2921 : 40651 : gfc_expr *expr;
2922 : 40651 : gfc_ss *s;
2923 : 40651 : tree neg_len;
2924 : 40651 : char *msg;
2925 : 40651 : stmtblock_t finalblock;
2926 : 40651 : bool finalize_required;
2927 : :
2928 : : /* Save the old values for nested checking. */
2929 : 40651 : old_first_len = first_len;
2930 : 40651 : old_first_len_val = first_len_val;
2931 : 40651 : old_typespec_chararray_ctor = typespec_chararray_ctor;
2932 : :
2933 : 40651 : loop = ss->loop;
2934 : 40651 : outer_loop = outermost_loop (loop);
2935 : 40651 : ss_info = ss->info;
2936 : 40651 : expr = ss_info->expr;
2937 : :
2938 : : /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
2939 : : typespec was given for the array constructor. */
2940 : 81302 : typespec_chararray_ctor = (expr->ts.type == BT_CHARACTER
2941 : 7776 : && expr->ts.u.cl
2942 : 48427 : && expr->ts.u.cl->length_from_typespec);
2943 : :
2944 : 40651 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2945 : 2524 : && expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
2946 : : {
2947 : 1462 : first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
2948 : 1462 : first_len = true;
2949 : : }
2950 : :
2951 : 40651 : gcc_assert (ss->dimen == ss->loop->dimen);
2952 : :
2953 : 40651 : c = expr->value.constructor;
2954 : 40651 : if (expr->ts.type == BT_CHARACTER)
2955 : : {
2956 : 7776 : bool const_string;
2957 : 7776 : bool force_new_cl = false;
2958 : :
2959 : : /* get_array_ctor_strlen walks the elements of the constructor, if a
2960 : : typespec was given, we already know the string length and want the one
2961 : : specified there. */
2962 : 7776 : if (typespec_chararray_ctor && expr->ts.u.cl->length
2963 : 344 : && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
2964 : : {
2965 : 27 : gfc_se length_se;
2966 : :
2967 : 27 : const_string = false;
2968 : 27 : gfc_init_se (&length_se, NULL);
2969 : 27 : gfc_conv_expr_type (&length_se, expr->ts.u.cl->length,
2970 : : gfc_charlen_type_node);
2971 : 27 : ss_info->string_length = length_se.expr;
2972 : :
2973 : : /* Check if the character length is negative. If it is, then
2974 : : set LEN = 0. */
2975 : 27 : neg_len = fold_build2_loc (input_location, LT_EXPR,
2976 : : logical_type_node, ss_info->string_length,
2977 : 27 : build_zero_cst (TREE_TYPE
2978 : : (ss_info->string_length)));
2979 : : /* Print a warning if bounds checking is enabled. */
2980 : 27 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2981 : : {
2982 : 18 : msg = xasprintf ("Negative character length treated as LEN = 0");
2983 : 18 : gfc_trans_runtime_check (false, true, neg_len, &length_se.pre,
2984 : : where, msg);
2985 : 18 : free (msg);
2986 : : }
2987 : :
2988 : 27 : ss_info->string_length
2989 : 27 : = fold_build3_loc (input_location, COND_EXPR,
2990 : : gfc_charlen_type_node, neg_len,
2991 : : build_zero_cst
2992 : 27 : (TREE_TYPE (ss_info->string_length)),
2993 : : ss_info->string_length);
2994 : 27 : ss_info->string_length = gfc_evaluate_now (ss_info->string_length,
2995 : : &length_se.pre);
2996 : 27 : gfc_add_block_to_block (&outer_loop->pre, &length_se.pre);
2997 : 27 : gfc_add_block_to_block (&outer_loop->post, &length_se.post);
2998 : 27 : }
2999 : : else
3000 : : {
3001 : 7749 : const_string = get_array_ctor_strlen (&outer_loop->pre, c,
3002 : : &ss_info->string_length);
3003 : 7749 : force_new_cl = true;
3004 : :
3005 : : /* Initialize "len" with string length for bounds checking. */
3006 : 7749 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3007 : 1480 : && !typespec_chararray_ctor
3008 : 1462 : && ss_info->string_length)
3009 : : {
3010 : 1462 : gfc_se length_se;
3011 : :
3012 : 1462 : gfc_init_se (&length_se, NULL);
3013 : 1462 : gfc_add_modify (&length_se.pre, first_len_val,
3014 : 1462 : fold_convert (TREE_TYPE (first_len_val),
3015 : : ss_info->string_length));
3016 : 1462 : ss_info->string_length = gfc_evaluate_now (ss_info->string_length,
3017 : : &length_se.pre);
3018 : 1462 : gfc_add_block_to_block (&outer_loop->pre, &length_se.pre);
3019 : 1462 : gfc_add_block_to_block (&outer_loop->post, &length_se.post);
3020 : : }
3021 : : }
3022 : :
3023 : : /* Complex character array constructors should have been taken care of
3024 : : and not end up here. */
3025 : 7776 : gcc_assert (ss_info->string_length);
3026 : :
3027 : 7776 : store_backend_decl (&expr->ts.u.cl, ss_info->string_length, force_new_cl);
3028 : :
3029 : 7776 : type = gfc_get_character_type_len (expr->ts.kind, ss_info->string_length);
3030 : 7776 : if (const_string)
3031 : 6852 : type = build_pointer_type (type);
3032 : : }
3033 : : else
3034 : 32900 : type = gfc_typenode_for_spec (expr->ts.type == BT_CLASS
3035 : 25 : ? &CLASS_DATA (expr)->ts : &expr->ts);
3036 : :
3037 : : /* See if the constructor determines the loop bounds. */
3038 : 40651 : dynamic = false;
3039 : :
3040 : 40651 : loop_ubound0 = get_loop_upper_bound_for_array (ss, 0);
3041 : :
3042 : 80036 : if (expr->shape && get_rank (loop) > 1 && *loop_ubound0 == NULL_TREE)
3043 : : {
3044 : : /* We have a multidimensional parameter. */
3045 : 0 : for (s = ss; s; s = s->parent)
3046 : : {
3047 : : int n;
3048 : 0 : for (n = 0; n < s->loop->dimen; n++)
3049 : : {
3050 : 0 : s->loop->from[n] = gfc_index_zero_node;
3051 : 0 : s->loop->to[n] = gfc_conv_mpz_to_tree (expr->shape[s->dim[n]],
3052 : : gfc_index_integer_kind);
3053 : 0 : s->loop->to[n] = fold_build2_loc (input_location, MINUS_EXPR,
3054 : : gfc_array_index_type,
3055 : 0 : s->loop->to[n],
3056 : : gfc_index_one_node);
3057 : : }
3058 : : }
3059 : : }
3060 : :
3061 : 40651 : if (*loop_ubound0 == NULL_TREE)
3062 : : {
3063 : 810 : mpz_t size;
3064 : :
3065 : : /* We should have a 1-dimensional, zero-based loop. */
3066 : 810 : gcc_assert (loop->parent == NULL && loop->nested == NULL);
3067 : 810 : gcc_assert (loop->dimen == 1);
3068 : 810 : gcc_assert (integer_zerop (loop->from[0]));
3069 : :
3070 : : /* Split the constructor size into a static part and a dynamic part.
3071 : : Allocate the static size up-front and record whether the dynamic
3072 : : size might be nonzero. */
3073 : 810 : mpz_init (size);
3074 : 810 : dynamic = gfc_get_array_constructor_size (&size, c);
3075 : 810 : mpz_sub_ui (size, size, 1);
3076 : 810 : loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
3077 : 810 : mpz_clear (size);
3078 : : }
3079 : :
3080 : : /* Special case constant array constructors. */
3081 : 810 : if (!dynamic)
3082 : : {
3083 : 39858 : unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
3084 : 39858 : if (nelem > 0)
3085 : : {
3086 : 33494 : tree size = constant_array_constructor_loop_size (loop);
3087 : 33494 : if (size && compare_tree_int (size, nelem) == 0)
3088 : : {
3089 : 33488 : trans_constant_array_constructor (ss, type);
3090 : 33488 : goto finish;
3091 : : }
3092 : : }
3093 : : }
3094 : :
3095 : 7163 : gfc_trans_create_temp_array (&outer_loop->pre, &outer_loop->post, ss, type,
3096 : : NULL_TREE, dynamic, true, false, where);
3097 : :
3098 : 7163 : desc = ss_info->data.array.descriptor;
3099 : 7163 : offset = gfc_index_zero_node;
3100 : 7163 : offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
3101 : 7163 : suppress_warning (offsetvar);
3102 : 7163 : TREE_USED (offsetvar) = 0;
3103 : :
3104 : 7163 : gfc_init_block (&finalblock);
3105 : 7163 : finalize_required = expr->must_finalize;
3106 : 7163 : if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
3107 : : finalize_required = true;
3108 : 7193 : gfc_trans_array_constructor_value (&outer_loop->pre,
3109 : : finalize_required ? &finalblock : NULL,
3110 : : type, desc, c, &offset, &offsetvar,
3111 : : dynamic);
3112 : :
3113 : : /* If the array grows dynamically, the upper bound of the loop variable
3114 : : is determined by the array's final upper bound. */
3115 : 7163 : if (dynamic)
3116 : : {
3117 : 793 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
3118 : : gfc_array_index_type,
3119 : : offsetvar, gfc_index_one_node);
3120 : 793 : tmp = gfc_evaluate_now (tmp, &outer_loop->pre);
3121 : 793 : gfc_conv_descriptor_ubound_set (&loop->pre, desc, gfc_rank_cst[0], tmp);
3122 : 793 : if (*loop_ubound0 && VAR_P (*loop_ubound0))
3123 : 0 : gfc_add_modify (&outer_loop->pre, *loop_ubound0, tmp);
3124 : : else
3125 : 793 : *loop_ubound0 = tmp;
3126 : : }
3127 : :
3128 : 7163 : if (TREE_USED (offsetvar))
3129 : 2784 : pushdecl (offsetvar);
3130 : : else
3131 : 4379 : gcc_assert (INTEGER_CST_P (offset));
3132 : :
3133 : : #if 0
3134 : : /* Disable bound checking for now because it's probably broken. */
3135 : : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3136 : : {
3137 : : gcc_unreachable ();
3138 : : }
3139 : : #endif
3140 : :
3141 : 4379 : finish:
3142 : : /* Restore old values of globals. */
3143 : 40651 : first_len = old_first_len;
3144 : 40651 : first_len_val = old_first_len_val;
3145 : 40651 : typespec_chararray_ctor = old_typespec_chararray_ctor;
3146 : :
3147 : : /* F2008 4.5.6.3 para 5: If an executable construct references a structure
3148 : : constructor or array constructor, the entity created by the constructor is
3149 : : finalized after execution of the innermost executable construct containing
3150 : : the reference. */
3151 : 40651 : if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
3152 : 1536 : && finalblock.head != NULL_TREE)
3153 : 30 : gfc_add_block_to_block (&loop->post, &finalblock);
3154 : :
3155 : 40651 : }
3156 : :
3157 : :
3158 : : /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
3159 : : called after evaluating all of INFO's vector dimensions. Go through
3160 : : each such vector dimension and see if we can now fill in any missing
3161 : : loop bounds. */
3162 : :
3163 : : static void
3164 : 169085 : set_vector_loop_bounds (gfc_ss * ss)
3165 : : {
3166 : 169085 : gfc_loopinfo *loop, *outer_loop;
3167 : 169085 : gfc_array_info *info;
3168 : 169085 : gfc_se se;
3169 : 169085 : tree tmp;
3170 : 169085 : tree desc;
3171 : 169085 : tree zero;
3172 : 169085 : int n;
3173 : 169085 : int dim;
3174 : :
3175 : 169085 : outer_loop = outermost_loop (ss->loop);
3176 : :
3177 : 169085 : info = &ss->info->data.array;
3178 : :
3179 : 341574 : for (; ss; ss = ss->parent)
3180 : : {
3181 : 172489 : loop = ss->loop;
3182 : :
3183 : 410927 : for (n = 0; n < loop->dimen; n++)
3184 : : {
3185 : 238438 : dim = ss->dim[n];
3186 : 238438 : if (info->ref->u.ar.dimen_type[dim] != DIMEN_VECTOR
3187 : 752 : || loop->to[n] != NULL)
3188 : 238271 : continue;
3189 : :
3190 : : /* Loop variable N indexes vector dimension DIM, and we don't
3191 : : yet know the upper bound of loop variable N. Set it to the
3192 : : difference between the vector's upper and lower bounds. */
3193 : 167 : gcc_assert (loop->from[n] == gfc_index_zero_node);
3194 : 167 : gcc_assert (info->subscript[dim]
3195 : : && info->subscript[dim]->info->type == GFC_SS_VECTOR);
3196 : :
3197 : 167 : gfc_init_se (&se, NULL);
3198 : 167 : desc = info->subscript[dim]->info->data.array.descriptor;
3199 : 167 : zero = gfc_rank_cst[0];
3200 : 167 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
3201 : : gfc_array_index_type,
3202 : : gfc_conv_descriptor_ubound_get (desc, zero),
3203 : : gfc_conv_descriptor_lbound_get (desc, zero));
3204 : 167 : tmp = gfc_evaluate_now (tmp, &outer_loop->pre);
3205 : 167 : loop->to[n] = tmp;
3206 : : }
3207 : : }
3208 : 169085 : }
3209 : :
3210 : :
3211 : : /* Tells whether a scalar argument to an elemental procedure is saved out
3212 : : of a scalarization loop as a value or as a reference. */
3213 : :
3214 : : bool
3215 : 38674 : gfc_scalar_elemental_arg_saved_as_reference (gfc_ss_info * ss_info)
3216 : : {
3217 : 38674 : if (ss_info->type != GFC_SS_REFERENCE)
3218 : : return false;
3219 : :
3220 : 7778 : if (ss_info->data.scalar.needs_temporary)
3221 : : return false;
3222 : :
3223 : : /* If the actual argument can be absent (in other words, it can
3224 : : be a NULL reference), don't try to evaluate it; pass instead
3225 : : the reference directly. */
3226 : 7414 : if (ss_info->can_be_null_ref)
3227 : : return true;
3228 : :
3229 : : /* If the expression is of polymorphic type, it's actual size is not known,
3230 : : so we avoid copying it anywhere. */
3231 : 6738 : if (ss_info->data.scalar.dummy_arg
3232 : 1400 : && gfc_dummy_arg_get_typespec (*ss_info->data.scalar.dummy_arg).type
3233 : : == BT_CLASS
3234 : 6860 : && ss_info->expr->ts.type == BT_CLASS)
3235 : : return true;
3236 : :
3237 : : /* If the expression is a data reference of aggregate type,
3238 : : and the data reference is not used on the left hand side,
3239 : : avoid a copy by saving a reference to the content. */
3240 : 6714 : if (!ss_info->data.scalar.needs_temporary
3241 : 6714 : && (ss_info->expr->ts.type == BT_DERIVED
3242 : 5766 : || ss_info->expr->ts.type == BT_CLASS)
3243 : 7710 : && gfc_expr_is_variable (ss_info->expr))
3244 : : return true;
3245 : :
3246 : : /* Otherwise the expression is evaluated to a temporary variable before the
3247 : : scalarization loop. */
3248 : : return false;
3249 : : }
3250 : :
3251 : :
3252 : : /* Add the pre and post chains for all the scalar expressions in a SS chain
3253 : : to loop. This is called after the loop parameters have been calculated,
3254 : : but before the actual scalarizing loops. */
3255 : :
3256 : : static void
3257 : 176543 : gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
3258 : : locus * where)
3259 : : {
3260 : 176543 : gfc_loopinfo *nested_loop, *outer_loop;
3261 : 176543 : gfc_se se;
3262 : 176543 : gfc_ss_info *ss_info;
3263 : 176543 : gfc_array_info *info;
3264 : 176543 : gfc_expr *expr;
3265 : 176543 : int n;
3266 : :
3267 : : /* Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise,
3268 : : arguments could get evaluated multiple times. */
3269 : 176543 : if (ss->is_alloc_lhs)
3270 : 160 : return;
3271 : :
3272 : 463774 : outer_loop = outermost_loop (loop);
3273 : :
3274 : : /* TODO: This can generate bad code if there are ordering dependencies,
3275 : : e.g., a callee allocated function and an unknown size constructor. */
3276 : : gcc_assert (ss != NULL);
3277 : :
3278 : 463774 : for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
3279 : : {
3280 : 287391 : gcc_assert (ss);
3281 : :
3282 : : /* Cross loop arrays are handled from within the most nested loop. */
3283 : 287391 : if (ss->nested_ss != NULL)
3284 : 3508 : continue;
3285 : :
3286 : 283883 : ss_info = ss->info;
3287 : 283883 : expr = ss_info->expr;
3288 : 283883 : info = &ss_info->data.array;
3289 : :
3290 : 283883 : switch (ss_info->type)
3291 : : {
3292 : 38440 : case GFC_SS_SCALAR:
3293 : : /* Scalar expression. Evaluate this now. This includes elemental
3294 : : dimension indices, but not array section bounds. */
3295 : 38440 : gfc_init_se (&se, NULL);
3296 : 38440 : gfc_conv_expr (&se, expr);
3297 : 38440 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3298 : :
3299 : 38440 : if (expr->ts.type != BT_CHARACTER
3300 : 38440 : && !gfc_is_alloc_class_scalar_function (expr))
3301 : : {
3302 : : /* Move the evaluation of scalar expressions outside the
3303 : : scalarization loop, except for WHERE assignments. */
3304 : 34830 : if (subscript)
3305 : 5881 : se.expr = convert(gfc_array_index_type, se.expr);
3306 : 34830 : if (!ss_info->where)
3307 : 34416 : se.expr = gfc_evaluate_now (se.expr, &outer_loop->pre);
3308 : 34830 : gfc_add_block_to_block (&outer_loop->pre, &se.post);
3309 : : }
3310 : : else
3311 : 3610 : gfc_add_block_to_block (&outer_loop->post, &se.post);
3312 : :
3313 : 38440 : ss_info->data.scalar.value = se.expr;
3314 : 38440 : ss_info->string_length = se.string_length;
3315 : 38440 : break;
3316 : :
3317 : 3889 : case GFC_SS_REFERENCE:
3318 : : /* Scalar argument to elemental procedure. */
3319 : 3889 : gfc_init_se (&se, NULL);
3320 : 3889 : if (gfc_scalar_elemental_arg_saved_as_reference (ss_info))
3321 : 824 : gfc_conv_expr_reference (&se, expr);
3322 : : else
3323 : : {
3324 : : /* Evaluate the argument outside the loop and pass
3325 : : a reference to the value. */
3326 : 3065 : gfc_conv_expr (&se, expr);
3327 : : }
3328 : :
3329 : : /* Ensure that a pointer to the string is stored. */
3330 : 3889 : if (expr->ts.type == BT_CHARACTER)
3331 : 174 : gfc_conv_string_parameter (&se);
3332 : :
3333 : 3889 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3334 : 3889 : gfc_add_block_to_block (&outer_loop->post, &se.post);
3335 : 3889 : if (gfc_is_class_scalar_expr (expr))
3336 : : /* This is necessary because the dynamic type will always be
3337 : : large than the declared type. In consequence, assigning
3338 : : the value to a temporary could segfault.
3339 : : OOP-TODO: see if this is generally correct or is the value
3340 : : has to be written to an allocated temporary, whose address
3341 : : is passed via ss_info. */
3342 : 48 : ss_info->data.scalar.value = se.expr;
3343 : : else
3344 : 3841 : ss_info->data.scalar.value = gfc_evaluate_now (se.expr,
3345 : : &outer_loop->pre);
3346 : :
3347 : 3889 : ss_info->string_length = se.string_length;
3348 : 3889 : break;
3349 : :
3350 : : case GFC_SS_SECTION:
3351 : : /* Add the expressions for scalar and vector subscripts. */
3352 : 2705360 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
3353 : 2536275 : if (info->subscript[n])
3354 : 6633 : gfc_add_loop_ss_code (loop, info->subscript[n], true, where);
3355 : :
3356 : 169085 : set_vector_loop_bounds (ss);
3357 : 169085 : break;
3358 : :
3359 : 752 : case GFC_SS_VECTOR:
3360 : : /* Get the vector's descriptor and store it in SS. */
3361 : 752 : gfc_init_se (&se, NULL);
3362 : 752 : gfc_conv_expr_descriptor (&se, expr);
3363 : 752 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3364 : 752 : gfc_add_block_to_block (&outer_loop->post, &se.post);
3365 : 752 : info->descriptor = se.expr;
3366 : 752 : break;
3367 : :
3368 : 10673 : case GFC_SS_INTRINSIC:
3369 : 10673 : gfc_add_intrinsic_ss_code (loop, ss);
3370 : 10673 : break;
3371 : :
3372 : 8320 : case GFC_SS_FUNCTION:
3373 : : /* Array function return value. We call the function and save its
3374 : : result in a temporary for use inside the loop. */
3375 : 8320 : gfc_init_se (&se, NULL);
3376 : 8320 : se.loop = loop;
3377 : 8320 : se.ss = ss;
3378 : 8320 : if (gfc_is_class_array_function (expr))
3379 : 177 : expr->must_finalize = 1;
3380 : 8320 : gfc_conv_expr (&se, expr);
3381 : 8320 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3382 : 8320 : gfc_add_block_to_block (&outer_loop->post, &se.post);
3383 : 8320 : gfc_add_block_to_block (&outer_loop->post, &se.finalblock);
3384 : 8320 : ss_info->string_length = se.string_length;
3385 : 8320 : break;
3386 : :
3387 : 40651 : case GFC_SS_CONSTRUCTOR:
3388 : 40651 : if (expr->ts.type == BT_CHARACTER
3389 : 7776 : && ss_info->string_length == NULL
3390 : 7776 : && expr->ts.u.cl
3391 : 7776 : && expr->ts.u.cl->length
3392 : 7432 : && expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
3393 : : {
3394 : 7381 : gfc_init_se (&se, NULL);
3395 : 7381 : gfc_conv_expr_type (&se, expr->ts.u.cl->length,
3396 : : gfc_charlen_type_node);
3397 : 7381 : ss_info->string_length = se.expr;
3398 : 7381 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3399 : 7381 : gfc_add_block_to_block (&outer_loop->post, &se.post);
3400 : : }
3401 : 40651 : trans_array_constructor (ss, where);
3402 : 40651 : break;
3403 : :
3404 : : case GFC_SS_TEMP:
3405 : : case GFC_SS_COMPONENT:
3406 : : /* Do nothing. These are handled elsewhere. */
3407 : : break;
3408 : :
3409 : 0 : default:
3410 : 0 : gcc_unreachable ();
3411 : : }
3412 : : }
3413 : :
3414 : 176383 : if (!subscript)
3415 : 172190 : for (nested_loop = loop->nested; nested_loop;
3416 : 2440 : nested_loop = nested_loop->next)
3417 : 2440 : gfc_add_loop_ss_code (nested_loop, nested_loop->ss, subscript, where);
3418 : : }
3419 : :
3420 : :
3421 : : /* Translate expressions for the descriptor and data pointer of a SS. */
3422 : : /*GCC ARRAYS*/
3423 : :
3424 : : static void
3425 : 303875 : gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
3426 : : {
3427 : 303875 : gfc_se se;
3428 : 303875 : gfc_ss_info *ss_info;
3429 : 303875 : gfc_array_info *info;
3430 : 303875 : tree tmp;
3431 : :
3432 : 303875 : ss_info = ss->info;
3433 : 303875 : info = &ss_info->data.array;
3434 : :
3435 : : /* Get the descriptor for the array to be scalarized. */
3436 : 303875 : gcc_assert (ss_info->expr->expr_type == EXPR_VARIABLE);
3437 : 303875 : gfc_init_se (&se, NULL);
3438 : 303875 : se.descriptor_only = 1;
3439 : 303875 : gfc_conv_expr_lhs (&se, ss_info->expr);
3440 : 303875 : gfc_add_block_to_block (block, &se.pre);
3441 : 303875 : info->descriptor = se.expr;
3442 : 303875 : ss_info->string_length = se.string_length;
3443 : 303875 : ss_info->class_container = se.class_container;
3444 : :
3445 : 303875 : if (base)
3446 : : {
3447 : 113043 : if (ss_info->expr->ts.type == BT_CHARACTER && !ss_info->expr->ts.deferred
3448 : 21970 : && ss_info->expr->ts.u.cl->length == NULL)
3449 : : {
3450 : : /* Emit a DECL_EXPR for the variable sized array type in
3451 : : GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
3452 : : sizes works correctly. */
3453 : 1084 : tree arraytype = TREE_TYPE (
3454 : : GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (info->descriptor)));
3455 : 1084 : if (! TYPE_NAME (arraytype))
3456 : 892 : TYPE_NAME (arraytype) = build_decl (UNKNOWN_LOCATION, TYPE_DECL,
3457 : : NULL_TREE, arraytype);
3458 : 1084 : gfc_add_expr_to_block (block, build1 (DECL_EXPR, arraytype,
3459 : 1084 : TYPE_NAME (arraytype)));
3460 : : }
3461 : : /* Also the data pointer. */
3462 : 113043 : tmp = gfc_conv_array_data (se.expr);
3463 : : /* If this is a variable or address or a class array, use it directly.
3464 : : Otherwise we must evaluate it now to avoid breaking dependency
3465 : : analysis by pulling the expressions for elemental array indices
3466 : : inside the loop. */
3467 : 113043 : if (!(DECL_P (tmp)
3468 : 103170 : || (TREE_CODE (tmp) == ADDR_EXPR
3469 : 64897 : && DECL_P (TREE_OPERAND (tmp, 0)))
3470 : 41265 : || (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))
3471 : 37929 : && TREE_CODE (se.expr) == COMPONENT_REF
3472 : 7678 : && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (se.expr, 0))))))
3473 : 38441 : tmp = gfc_evaluate_now (tmp, block);
3474 : 113043 : info->data = tmp;
3475 : :
3476 : 113043 : tmp = gfc_conv_array_offset (se.expr);
3477 : 113043 : info->offset = gfc_evaluate_now (tmp, block);
3478 : :
3479 : : /* Make absolutely sure that the saved_offset is indeed saved
3480 : : so that the variable is still accessible after the loops
3481 : : are translated. */
3482 : 113043 : info->saved_offset = info->offset;
3483 : : }
3484 : 303875 : }
3485 : :
3486 : :
3487 : : /* Initialize a gfc_loopinfo structure. */
3488 : :
3489 : : void
3490 : 174646 : gfc_init_loopinfo (gfc_loopinfo * loop)
3491 : : {
3492 : 174646 : int n;
3493 : :
3494 : 174646 : memset (loop, 0, sizeof (gfc_loopinfo));
3495 : 174646 : gfc_init_block (&loop->pre);
3496 : 174646 : gfc_init_block (&loop->post);
3497 : :
3498 : : /* Initially scalarize in order and default to no loop reversal. */
3499 : 2968982 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
3500 : : {
3501 : 2619690 : loop->order[n] = n;
3502 : 2619690 : loop->reverse[n] = GFC_INHIBIT_REVERSE;
3503 : : }
3504 : :
3505 : 174646 : loop->ss = gfc_ss_terminator;
3506 : 174646 : }
3507 : :
3508 : :
3509 : : /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
3510 : : chain. */
3511 : :
3512 : : void
3513 : 173601 : gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
3514 : : {
3515 : 173601 : se->loop = loop;
3516 : 173601 : }
3517 : :
3518 : :
3519 : : /* Return an expression for the data pointer of an array. */
3520 : :
3521 : : tree
3522 : 307048 : gfc_conv_array_data (tree descriptor)
3523 : : {
3524 : 307048 : tree type;
3525 : :
3526 : 307048 : type = TREE_TYPE (descriptor);
3527 : 307048 : if (GFC_ARRAY_TYPE_P (type))
3528 : : {
3529 : 217040 : if (TREE_CODE (type) == POINTER_TYPE)
3530 : : return descriptor;
3531 : : else
3532 : : {
3533 : : /* Descriptorless arrays. */
3534 : 165038 : return gfc_build_addr_expr (NULL_TREE, descriptor);
3535 : : }
3536 : : }
3537 : : else
3538 : 90008 : return gfc_conv_descriptor_data_get (descriptor);
3539 : : }
3540 : :
3541 : :
3542 : : /* Return an expression for the base offset of an array. */
3543 : :
3544 : : tree
3545 : 228772 : gfc_conv_array_offset (tree descriptor)
3546 : : {
3547 : 228772 : tree type;
3548 : :
3549 : 228772 : type = TREE_TYPE (descriptor);
3550 : 228772 : if (GFC_ARRAY_TYPE_P (type))
3551 : 164112 : return GFC_TYPE_ARRAY_OFFSET (type);
3552 : : else
3553 : 64660 : return gfc_conv_descriptor_offset_get (descriptor);
3554 : : }
3555 : :
3556 : :
3557 : : /* Get an expression for the array stride. */
3558 : :
3559 : : tree
3560 : 460209 : gfc_conv_array_stride (tree descriptor, int dim)
3561 : : {
3562 : 460209 : tree tmp;
3563 : 460209 : tree type;
3564 : :
3565 : 460209 : type = TREE_TYPE (descriptor);
3566 : :
3567 : : /* For descriptorless arrays use the array size. */
3568 : 460209 : tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
3569 : 460209 : if (tmp != NULL_TREE)
3570 : : return tmp;
3571 : :
3572 : 105312 : tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]);
3573 : 105312 : return tmp;
3574 : : }
3575 : :
3576 : :
3577 : : /* Like gfc_conv_array_stride, but for the lower bound. */
3578 : :
3579 : : tree
3580 : 298258 : gfc_conv_array_lbound (tree descriptor, int dim)
3581 : : {
3582 : 298258 : tree tmp;
3583 : 298258 : tree type;
3584 : :
3585 : 298258 : type = TREE_TYPE (descriptor);
3586 : :
3587 : 298258 : tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
3588 : 298258 : if (tmp != NULL_TREE)
3589 : : return tmp;
3590 : :
3591 : 18112 : tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]);
3592 : 18112 : return tmp;
3593 : : }
3594 : :
3595 : :
3596 : : /* Like gfc_conv_array_stride, but for the upper bound. */
3597 : :
3598 : : tree
3599 : 191784 : gfc_conv_array_ubound (tree descriptor, int dim)
3600 : : {
3601 : 191784 : tree tmp;
3602 : 191784 : tree type;
3603 : :
3604 : 191784 : type = TREE_TYPE (descriptor);
3605 : :
3606 : 191784 : tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
3607 : 191784 : if (tmp != NULL_TREE)
3608 : : return tmp;
3609 : :
3610 : : /* This should only ever happen when passing an assumed shape array
3611 : : as an actual parameter. The value will never be used. */
3612 : 7432 : if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
3613 : 553 : return gfc_index_zero_node;
3614 : :
3615 : 6879 : tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]);
3616 : 6879 : return tmp;
3617 : : }
3618 : :
3619 : :
3620 : : /* Generate abridged name of a part-ref for use in bounds-check message.
3621 : : Cases:
3622 : : (1) for an ordinary array variable x return "x"
3623 : : (2) for z a DT scalar and array component x (at level 1) return "z%%x"
3624 : : (3) for z a DT scalar and array component x (at level > 1) or
3625 : : for z a DT array and array x (at any number of levels): "z...%%x"
3626 : : */
3627 : :
3628 : : static char *
3629 : 36004 : abridged_ref_name (gfc_expr * expr, gfc_array_ref * ar)
3630 : : {
3631 : 36004 : gfc_ref *ref;
3632 : 36004 : gfc_symbol *sym;
3633 : 36004 : char *ref_name = NULL;
3634 : 36004 : const char *comp_name = NULL;
3635 : 36004 : int len_sym, last_len = 0, level = 0;
3636 : 36004 : bool sym_is_array;
3637 : :
3638 : 36004 : gcc_assert (expr->expr_type == EXPR_VARIABLE && expr->ref != NULL);
3639 : :
3640 : 36004 : sym = expr->symtree->n.sym;
3641 : 72008 : sym_is_array = (sym->ts.type != BT_CLASS
3642 : 36004 : ? sym->as != NULL
3643 : 267 : : IS_CLASS_ARRAY (sym));
3644 : 36004 : len_sym = strlen (sym->name);
3645 : :
3646 : : /* Scan ref chain to get name of the array component (when ar != NULL) or
3647 : : array section, determine depth and remember its component name. */
3648 : 50977 : for (ref = expr->ref; ref; ref = ref->next)
3649 : : {
3650 : 37087 : if (ref->type == REF_COMPONENT
3651 : 774 : && strcmp (ref->u.c.component->name, "_data") != 0)
3652 : : {
3653 : 644 : level++;
3654 : 644 : comp_name = ref->u.c.component->name;
3655 : 644 : continue;
3656 : : }
3657 : :
3658 : 36443 : if (ref->type != REF_ARRAY)
3659 : 142 : continue;
3660 : :
3661 : 36301 : if (ar)
3662 : : {
3663 : 15554 : if (&ref->u.ar == ar)
3664 : : break;
3665 : : }
3666 : 20747 : else if (ref->u.ar.type == AR_SECTION)
3667 : : break;
3668 : : }
3669 : :
3670 : 36004 : if (level > 0)
3671 : 618 : last_len = strlen (comp_name);
3672 : :
3673 : : /* Provide a buffer sufficiently large to hold "x...%%z". */
3674 : 36004 : ref_name = XNEWVEC (char, len_sym + last_len + 6);
3675 : 36004 : strcpy (ref_name, sym->name);
3676 : :
3677 : 36004 : if (level == 1 && !sym_is_array)
3678 : : {
3679 : 334 : strcat (ref_name, "%%");
3680 : 334 : strcat (ref_name, comp_name);
3681 : : }
3682 : 35670 : else if (level > 0)
3683 : : {
3684 : 284 : strcat (ref_name, "...%%");
3685 : 284 : strcat (ref_name, comp_name);
3686 : : }
3687 : :
3688 : 36004 : return ref_name;
3689 : : }
3690 : :
3691 : :
3692 : : /* Generate code to perform an array index bound check. */
3693 : :
3694 : : static tree
3695 : 4998 : trans_array_bound_check (gfc_se * se, gfc_ss *ss, tree index, int n,
3696 : : locus * where, bool check_upper,
3697 : : const char *compname = NULL)
3698 : : {
3699 : 4998 : tree fault;
3700 : 4998 : tree tmp_lo, tmp_up;
3701 : 4998 : tree descriptor;
3702 : 4998 : char *msg;
3703 : 4998 : char *ref_name = NULL;
3704 : 4998 : const char * name = NULL;
3705 : 4998 : gfc_expr *expr;
3706 : :
3707 : 4998 : if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
3708 : : return index;
3709 : :
3710 : 234 : descriptor = ss->info->data.array.descriptor;
3711 : :
3712 : 234 : index = gfc_evaluate_now (index, &se->pre);
3713 : :
3714 : : /* We find a name for the error message. */
3715 : 234 : name = ss->info->expr->symtree->n.sym->name;
3716 : 234 : gcc_assert (name != NULL);
3717 : :
3718 : : /* When we have a component ref, get name of the array section.
3719 : : Note that there can only be one part ref. */
3720 : 234 : expr = ss->info->expr;
3721 : 234 : if (expr->ref && !compname)
3722 : 160 : name = ref_name = abridged_ref_name (expr, NULL);
3723 : :
3724 : 234 : if (VAR_P (descriptor))
3725 : 156 : name = IDENTIFIER_POINTER (DECL_NAME (descriptor));
3726 : :
3727 : : /* Use given (array component) name. */
3728 : 234 : if (compname)
3729 : 74 : name = compname;
3730 : :
3731 : : /* If upper bound is present, include both bounds in the error message. */
3732 : 234 : if (check_upper)
3733 : : {
3734 : 207 : tmp_lo = gfc_conv_array_lbound (descriptor, n);
3735 : 207 : tmp_up = gfc_conv_array_ubound (descriptor, n);
3736 : :
3737 : 207 : if (name)
3738 : 207 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3739 : : "outside of expected range (%%ld:%%ld)", n+1, name);
3740 : : else
3741 : 0 : msg = xasprintf ("Index '%%ld' of dimension %d "
3742 : : "outside of expected range (%%ld:%%ld)", n+1);
3743 : :
3744 : 207 : fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3745 : : index, tmp_lo);
3746 : 207 : gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
3747 : : fold_convert (long_integer_type_node, index),
3748 : : fold_convert (long_integer_type_node, tmp_lo),
3749 : : fold_convert (long_integer_type_node, tmp_up));
3750 : 207 : fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3751 : : index, tmp_up);
3752 : 207 : gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
3753 : : fold_convert (long_integer_type_node, index),
3754 : : fold_convert (long_integer_type_node, tmp_lo),
3755 : : fold_convert (long_integer_type_node, tmp_up));
3756 : 207 : free (msg);
3757 : : }
3758 : : else
3759 : : {
3760 : 27 : tmp_lo = gfc_conv_array_lbound (descriptor, n);
3761 : :
3762 : 27 : if (name)
3763 : 27 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3764 : : "below lower bound of %%ld", n+1, name);
3765 : : else
3766 : 0 : msg = xasprintf ("Index '%%ld' of dimension %d "
3767 : : "below lower bound of %%ld", n+1);
3768 : :
3769 : 27 : fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3770 : : index, tmp_lo);
3771 : 27 : gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
3772 : : fold_convert (long_integer_type_node, index),
3773 : : fold_convert (long_integer_type_node, tmp_lo));
3774 : 27 : free (msg);
3775 : : }
3776 : :
3777 : 234 : free (ref_name);
3778 : 234 : return index;
3779 : : }
3780 : :
3781 : :
3782 : : /* Generate code for bounds checking for elemental dimensions. */
3783 : :
3784 : : static void
3785 : 6649 : array_bound_check_elemental (gfc_se * se, gfc_ss * ss, gfc_expr * expr)
3786 : : {
3787 : 6649 : gfc_array_ref *ar;
3788 : 6649 : gfc_ref *ref;
3789 : 6649 : char *var_name = NULL;
3790 : 6649 : int dim;
3791 : :
3792 : 6649 : if (expr->expr_type == EXPR_VARIABLE)
3793 : : {
3794 : 12463 : for (ref = expr->ref; ref; ref = ref->next)
3795 : : {
3796 : 6255 : if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
3797 : : {
3798 : 3934 : ar = &ref->u.ar;
3799 : 3934 : var_name = abridged_ref_name (expr, ar);
3800 : 8102 : for (dim = 0; dim < ar->dimen; dim++)
3801 : : {
3802 : 4168 : if (ar->dimen_type[dim] == DIMEN_ELEMENT)
3803 : : {
3804 : 74 : gfc_se indexse;
3805 : 74 : gfc_init_se (&indexse, NULL);
3806 : 74 : gfc_conv_expr_type (&indexse, ar->start[dim],
3807 : : gfc_array_index_type);
3808 : 74 : trans_array_bound_check (se, ss, indexse.expr, dim,
3809 : : &ar->where,
3810 : 74 : ar->as->type != AS_ASSUMED_SIZE
3811 : 74 : || dim < ar->dimen - 1,
3812 : : var_name);
3813 : : }
3814 : : }
3815 : 3934 : free (var_name);
3816 : : }
3817 : : }
3818 : : }
3819 : 6649 : }
3820 : :
3821 : :
3822 : : /* Return the offset for an index. Performs bound checking for elemental
3823 : : dimensions. Single element references are processed separately.
3824 : : DIM is the array dimension, I is the loop dimension. */
3825 : :
3826 : : static tree
3827 : 231360 : conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i,
3828 : : gfc_array_ref * ar, tree stride)
3829 : : {
3830 : 231360 : gfc_array_info *info;
3831 : 231360 : tree index;
3832 : 231360 : tree desc;
3833 : 231360 : tree data;
3834 : :
3835 : 231360 : info = &ss->info->data.array;
3836 : :
3837 : : /* Get the index into the array for this dimension. */
3838 : 231360 : if (ar)
3839 : : {
3840 : 163134 : gcc_assert (ar->type != AR_ELEMENT);
3841 : 163134 : switch (ar->dimen_type[dim])
3842 : : {
3843 : 0 : case DIMEN_THIS_IMAGE:
3844 : 0 : gcc_unreachable ();
3845 : 4175 : break;
3846 : 4175 : case DIMEN_ELEMENT:
3847 : : /* Elemental dimension. */
3848 : 4175 : gcc_assert (info->subscript[dim]
3849 : : && info->subscript[dim]->info->type == GFC_SS_SCALAR);
3850 : : /* We've already translated this value outside the loop. */
3851 : 4175 : index = info->subscript[dim]->info->data.scalar.value;
3852 : :
3853 : 8350 : index = trans_array_bound_check (se, ss, index, dim, &ar->where,
3854 : 4175 : ar->as->type != AS_ASSUMED_SIZE
3855 : 4175 : || dim < ar->dimen - 1);
3856 : 4175 : break;
3857 : :
3858 : 749 : case DIMEN_VECTOR:
3859 : 749 : gcc_assert (info && se->loop);
3860 : 749 : gcc_assert (info->subscript[dim]
3861 : : && info->subscript[dim]->info->type == GFC_SS_VECTOR);
3862 : 749 : desc = info->subscript[dim]->info->data.array.descriptor;
3863 : :
3864 : : /* Get a zero-based index into the vector. */
3865 : 749 : index = fold_build2_loc (input_location, MINUS_EXPR,
3866 : : gfc_array_index_type,
3867 : : se->loop->loopvar[i], se->loop->from[i]);
3868 : :
3869 : : /* Multiply the index by the stride. */
3870 : 749 : index = fold_build2_loc (input_location, MULT_EXPR,
3871 : : gfc_array_index_type,
3872 : : index, gfc_conv_array_stride (desc, 0));
3873 : :
3874 : : /* Read the vector to get an index into info->descriptor. */
3875 : 749 : data = build_fold_indirect_ref_loc (input_location,
3876 : : gfc_conv_array_data (desc));
3877 : 749 : index = gfc_build_array_ref (data, index, NULL);
3878 : 749 : index = gfc_evaluate_now (index, &se->pre);
3879 : 749 : index = fold_convert (gfc_array_index_type, index);
3880 : :
3881 : : /* Do any bounds checking on the final info->descriptor index. */
3882 : 1498 : index = trans_array_bound_check (se, ss, index, dim, &ar->where,
3883 : 749 : ar->as->type != AS_ASSUMED_SIZE
3884 : 749 : || dim < ar->dimen - 1);
3885 : 749 : break;
3886 : :
3887 : 158210 : case DIMEN_RANGE:
3888 : : /* Scalarized dimension. */
3889 : 158210 : gcc_assert (info && se->loop);
3890 : :
3891 : : /* Multiply the loop variable by the stride and delta. */
3892 : 158210 : index = se->loop->loopvar[i];
3893 : 158210 : if (!integer_onep (info->stride[dim]))
3894 : 6457 : index = fold_build2_loc (input_location, MULT_EXPR,
3895 : : gfc_array_index_type, index,
3896 : : info->stride[dim]);
3897 : 158210 : if (!integer_zerop (info->delta[dim]))
3898 : 63032 : index = fold_build2_loc (input_location, PLUS_EXPR,
3899 : : gfc_array_index_type, index,
3900 : : info->delta[dim]);
3901 : : break;
3902 : :
3903 : 0 : default:
3904 : 0 : gcc_unreachable ();
3905 : : }
3906 : : }
3907 : : else
3908 : : {
3909 : : /* Temporary array or derived type component. */
3910 : 68226 : gcc_assert (se->loop);
3911 : 68226 : index = se->loop->loopvar[se->loop->order[i]];
3912 : :
3913 : : /* Pointer functions can have stride[0] different from unity.
3914 : : Use the stride returned by the function call and stored in
3915 : : the descriptor for the temporary. */
3916 : 68226 : if (se->ss && se->ss->info->type == GFC_SS_FUNCTION
3917 : 6928 : && se->ss->info->expr
3918 : 6928 : && se->ss->info->expr->symtree
3919 : 6928 : && se->ss->info->expr->symtree->n.sym->result
3920 : 6515 : && se->ss->info->expr->symtree->n.sym->result->attr.pointer)
3921 : 144 : stride = gfc_conv_descriptor_stride_get (info->descriptor,
3922 : : gfc_rank_cst[dim]);
3923 : :
3924 : 68226 : if (info->delta[dim] && !integer_zerop (info->delta[dim]))
3925 : 700 : index = fold_build2_loc (input_location, PLUS_EXPR,
3926 : : gfc_array_index_type, index, info->delta[dim]);
3927 : : }
3928 : :
3929 : : /* Multiply by the stride. */
3930 : 231360 : if (stride != NULL && !integer_onep (stride))
3931 : 69609 : index = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
3932 : : index, stride);
3933 : :
3934 : 231360 : return index;
3935 : : }
3936 : :
3937 : :
3938 : : /* Build a scalarized array reference using the vptr 'size'. */
3939 : :
3940 : : static bool
3941 : 178204 : build_class_array_ref (gfc_se *se, tree base, tree index)
3942 : : {
3943 : 178204 : tree size;
3944 : 178204 : tree decl = NULL_TREE;
3945 : 178204 : tree tmp;
3946 : 178204 : gfc_expr *expr = se->ss->info->expr;
3947 : 178204 : gfc_expr *class_expr;
3948 : 178204 : gfc_typespec *ts;
3949 : 178204 : gfc_symbol *sym;
3950 : :
3951 : 178204 : tmp = !VAR_P (base) ? gfc_get_class_from_expr (base) : NULL_TREE;
3952 : :
3953 : 84098 : if (tmp != NULL_TREE)
3954 : : decl = tmp;
3955 : : else
3956 : : {
3957 : : /* The base expression does not contain a class component, either
3958 : : because it is a temporary array or array descriptor. Class
3959 : : array functions are correctly resolved above. */
3960 : 175024 : if (!expr
3961 : 175024 : || (expr->ts.type != BT_CLASS
3962 : 161753 : && !gfc_is_class_array_ref (expr, NULL)))
3963 : 174637 : return false;
3964 : :
3965 : : /* Obtain the expression for the class entity or component that is
3966 : : followed by an array reference, which is not an element, so that
3967 : : the span of the array can be obtained. */
3968 : 387 : class_expr = gfc_find_and_cut_at_last_class_ref (expr, false, &ts);
3969 : :
3970 : 387 : if (!ts)
3971 : : return false;
3972 : :
3973 : 362 : sym = (!class_expr && expr) ? expr->symtree->n.sym : NULL;
3974 : 0 : if (sym && sym->attr.function
3975 : 0 : && sym == sym->result
3976 : 0 : && sym->backend_decl == current_function_decl)
3977 : : /* The temporary is the data field of the class data component
3978 : : of the current function. */
3979 : 0 : decl = gfc_get_fake_result_decl (sym, 0);
3980 : 362 : else if (sym)
3981 : : {
3982 : 0 : if (decl == NULL_TREE)
3983 : 0 : decl = expr->symtree->n.sym->backend_decl;
3984 : : /* For class arrays the tree containing the class is stored in
3985 : : GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl.
3986 : : For all others it's sym's backend_decl directly. */
3987 : 0 : if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl))
3988 : 0 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
3989 : : }
3990 : : else
3991 : 362 : decl = gfc_get_class_from_gfc_expr (class_expr);
3992 : :
3993 : 362 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
3994 : 0 : decl = build_fold_indirect_ref_loc (input_location, decl);
3995 : :
3996 : 362 : if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl)))
3997 : : return false;
3998 : : }
3999 : :
4000 : 3542 : se->class_vptr = gfc_evaluate_now (gfc_class_vptr_get (decl), &se->pre);
4001 : :
4002 : 3542 : size = gfc_class_vtab_size_get (decl);
4003 : : /* For unlimited polymorphic entities then _len component needs to be
4004 : : multiplied with the size. */
4005 : 3542 : size = gfc_resize_class_size_with_len (&se->pre, decl, size);
4006 : 3542 : size = fold_convert (TREE_TYPE (index), size);
4007 : :
4008 : : /* Return the element in the se expression. */
4009 : 3542 : se->expr = gfc_build_spanned_array_ref (base, index, size);
4010 : 3542 : return true;
4011 : : }
4012 : :
4013 : :
4014 : : /* Indicates that the tree EXPR is a reference to an array that can’t
4015 : : have any negative stride. */
4016 : :
4017 : : static bool
4018 : 288561 : non_negative_strides_array_p (tree expr)
4019 : : {
4020 : 301015 : if (expr == NULL_TREE)
4021 : : return false;
4022 : :
4023 : 301015 : tree type = TREE_TYPE (expr);
4024 : 301015 : if (POINTER_TYPE_P (type))
4025 : 64677 : type = TREE_TYPE (type);
4026 : :
4027 : 301015 : if (TYPE_LANG_SPECIFIC (type))
4028 : : {
4029 : 301015 : gfc_array_kind array_kind = GFC_TYPE_ARRAY_AKIND (type);
4030 : :
4031 : 301015 : if (array_kind == GFC_ARRAY_ALLOCATABLE
4032 : 301015 : || array_kind == GFC_ARRAY_ASSUMED_SHAPE_CONT)
4033 : : return true;
4034 : : }
4035 : :
4036 : : /* An array with descriptor can have negative strides.
4037 : : We try to be conservative and return false by default here
4038 : : if we don’t recognize a contiguous array instead of
4039 : : returning false if we can identify a non-contiguous one. */
4040 : 249197 : if (!GFC_ARRAY_TYPE_P (type))
4041 : : return false;
4042 : :
4043 : : /* If the array was originally a dummy with a descriptor, strides can be
4044 : : negative. */
4045 : 217421 : if (DECL_P (expr)
4046 : 208828 : && DECL_LANG_SPECIFIC (expr)
4047 : 45043 : && GFC_DECL_SAVED_DESCRIPTOR (expr)
4048 : 229894 : && GFC_DECL_SAVED_DESCRIPTOR (expr) != expr)
4049 : 12454 : return non_negative_strides_array_p (GFC_DECL_SAVED_DESCRIPTOR (expr));
4050 : :
4051 : : return true;
4052 : : }
4053 : :
4054 : :
4055 : : /* Build a scalarized reference to an array. */
4056 : :
4057 : : static void
4058 : 178204 : gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar,
4059 : : bool tmp_array = false)
4060 : : {
4061 : 178204 : gfc_array_info *info;
4062 : 178204 : tree decl = NULL_TREE;
4063 : 178204 : tree index;
4064 : 178204 : tree base;
4065 : 178204 : gfc_ss *ss;
4066 : 178204 : gfc_expr *expr;
4067 : 178204 : int n;
4068 : :
4069 : 178204 : ss = se->ss;
4070 : 178204 : expr = ss->info->expr;
4071 : 178204 : info = &ss->info->data.array;
4072 : 178204 : if (ar)
4073 : 120952 : n = se->loop->order[0];
4074 : : else
4075 : : n = 0;
4076 : :
4077 : 178204 : index = conv_array_index_offset (se, ss, ss->dim[n], n, ar, info->stride0);
4078 : : /* Add the offset for this dimension to the stored offset for all other
4079 : : dimensions. */
4080 : 178204 : if (info->offset && !integer_zerop (info->offset))
4081 : 129442 : index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4082 : : index, info->offset);
4083 : :
4084 : 178204 : base = build_fold_indirect_ref_loc (input_location, info->data);
4085 : :
4086 : : /* Use the vptr 'size' field to access the element of a class array. */
4087 : 178204 : if (build_class_array_ref (se, base, index))
4088 : 3542 : return;
4089 : :
4090 : 174662 : if (get_CFI_desc (NULL, expr, &decl, ar))
4091 : 442 : decl = build_fold_indirect_ref_loc (input_location, decl);
4092 : :
4093 : : /* A pointer array component can be detected from its field decl. Fix
4094 : : the descriptor, mark the resulting variable decl and pass it to
4095 : : gfc_build_array_ref. */
4096 : 174662 : if (is_pointer_array (info->descriptor)
4097 : 174662 : || (expr && expr->ts.deferred && info->descriptor
4098 : 2443 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info->descriptor))))
4099 : : {
4100 : 8334 : if (TREE_CODE (info->descriptor) == COMPONENT_REF)
4101 : 1452 : decl = info->descriptor;
4102 : 6882 : else if (INDIRECT_REF_P (info->descriptor))
4103 : 1427 : decl = TREE_OPERAND (info->descriptor, 0);
4104 : :
4105 : 8334 : if (decl == NULL_TREE)
4106 : 5455 : decl = info->descriptor;
4107 : : }
4108 : :
4109 : 174662 : bool non_negative_stride = tmp_array
4110 : 174662 : || non_negative_strides_array_p (info->descriptor);
4111 : 174662 : se->expr = gfc_build_array_ref (base, index, decl,
4112 : : non_negative_stride);
4113 : : }
4114 : :
4115 : :
4116 : : /* Translate access of temporary array. */
4117 : :
4118 : : void
4119 : 57252 : gfc_conv_tmp_array_ref (gfc_se * se)
4120 : : {
4121 : 57252 : se->string_length = se->ss->info->string_length;
4122 : 57252 : gfc_conv_scalarized_array_ref (se, NULL, true);
4123 : 57252 : gfc_advance_se_ss_chain (se);
4124 : 57252 : }
4125 : :
4126 : : /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
4127 : :
4128 : : static void
4129 : 255895 : add_to_offset (tree *cst_offset, tree *offset, tree t)
4130 : : {
4131 : 255895 : if (TREE_CODE (t) == INTEGER_CST)
4132 : 128290 : *cst_offset = int_const_binop (PLUS_EXPR, *cst_offset, t);
4133 : : else
4134 : : {
4135 : 127605 : if (!integer_zerop (*offset))
4136 : 46704 : *offset = fold_build2_loc (input_location, PLUS_EXPR,
4137 : : gfc_array_index_type, *offset, t);
4138 : : else
4139 : 80901 : *offset = t;
4140 : : }
4141 : 255895 : }
4142 : :
4143 : :
4144 : : static tree
4145 : 170769 : build_array_ref (tree desc, tree offset, tree decl, tree vptr)
4146 : : {
4147 : 170769 : tree tmp;
4148 : 170769 : tree type;
4149 : 170769 : tree cdesc;
4150 : :
4151 : : /* For class arrays the class declaration is stored in the saved
4152 : : descriptor. */
4153 : 170769 : if (INDIRECT_REF_P (desc)
4154 : 7264 : && DECL_LANG_SPECIFIC (TREE_OPERAND (desc, 0))
4155 : 173033 : && GFC_DECL_SAVED_DESCRIPTOR (TREE_OPERAND (desc, 0)))
4156 : 834 : cdesc = gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (
4157 : : TREE_OPERAND (desc, 0)));
4158 : : else
4159 : : cdesc = desc;
4160 : :
4161 : : /* Class container types do not always have the GFC_CLASS_TYPE_P
4162 : : but the canonical type does. */
4163 : 170769 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdesc))
4164 : 170769 : && TREE_CODE (cdesc) == COMPONENT_REF)
4165 : : {
4166 : 8914 : type = TREE_TYPE (TREE_OPERAND (cdesc, 0));
4167 : 8914 : if (TYPE_CANONICAL (type)
4168 : 8914 : && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type)))
4169 : 3267 : vptr = gfc_class_vptr_get (TREE_OPERAND (cdesc, 0));
4170 : : }
4171 : :
4172 : 170769 : tmp = gfc_conv_array_data (desc);
4173 : 170769 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
4174 : 170769 : tmp = gfc_build_array_ref (tmp, offset, decl,
4175 : 170769 : non_negative_strides_array_p (desc),
4176 : : vptr);
4177 : 170769 : return tmp;
4178 : : }
4179 : :
4180 : :
4181 : : /* Build an array reference. se->expr already holds the array descriptor.
4182 : : This should be either a variable, indirect variable reference or component
4183 : : reference. For arrays which do not have a descriptor, se->expr will be
4184 : : the data pointer.
4185 : : a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
4186 : :
4187 : : void
4188 : 239346 : gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
4189 : : locus * where)
4190 : : {
4191 : 239346 : int n;
4192 : 239346 : tree offset, cst_offset;
4193 : 239346 : tree tmp;
4194 : 239346 : tree stride;
4195 : 239346 : tree decl = NULL_TREE;
4196 : 239346 : gfc_se indexse;
4197 : 239346 : gfc_se tmpse;
4198 : 239346 : gfc_symbol * sym = expr->symtree->n.sym;
4199 : 239346 : char *var_name = NULL;
4200 : :
4201 : 239346 : if (ar->stat)
4202 : : {
4203 : 3 : gfc_se statse;
4204 : :
4205 : 3 : gfc_init_se (&statse, NULL);
4206 : 3 : gfc_conv_expr_lhs (&statse, ar->stat);
4207 : 3 : gfc_add_block_to_block (&se->pre, &statse.pre);
4208 : 3 : gfc_add_modify (&se->pre, statse.expr, integer_zero_node);
4209 : : }
4210 : 239346 : if (ar->dimen == 0)
4211 : : {
4212 : 3682 : gcc_assert (ar->codimen || sym->attr.select_rank_temporary
4213 : : || (ar->as && ar->as->corank));
4214 : :
4215 : 3682 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
4216 : 825 : se->expr = build_fold_indirect_ref (gfc_conv_array_data (se->expr));
4217 : : else
4218 : : {
4219 : 2857 : if (GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr))
4220 : 2857 : && TREE_CODE (TREE_TYPE (se->expr)) == POINTER_TYPE)
4221 : 1930 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
4222 : :
4223 : : /* Use the actual tree type and not the wrapped coarray. */
4224 : 2857 : if (!se->want_pointer)
4225 : 2034 : se->expr = fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se->expr)),
4226 : : se->expr);
4227 : : }
4228 : :
4229 : 124634 : return;
4230 : : }
4231 : :
4232 : : /* Handle scalarized references separately. */
4233 : 235664 : if (ar->type != AR_ELEMENT)
4234 : : {
4235 : 120952 : gfc_conv_scalarized_array_ref (se, ar);
4236 : 120952 : gfc_advance_se_ss_chain (se);
4237 : 120952 : return;
4238 : : }
4239 : :
4240 : 114712 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
4241 : 11493 : var_name = abridged_ref_name (expr, ar);
4242 : :
4243 : 114712 : decl = se->expr;
4244 : 114712 : if (UNLIMITED_POLY(sym)
4245 : 98 : && IS_CLASS_ARRAY (sym)
4246 : 97 : && sym->attr.dummy
4247 : 54 : && ar->as->type != AS_DEFERRED)
4248 : 42 : decl = sym->backend_decl;
4249 : :
4250 : 114712 : cst_offset = offset = gfc_index_zero_node;
4251 : 114712 : add_to_offset (&cst_offset, &offset, gfc_conv_array_offset (decl));
4252 : :
4253 : : /* Calculate the offsets from all the dimensions. Make sure to associate
4254 : : the final offset so that we form a chain of loop invariant summands. */
4255 : 255895 : for (n = ar->dimen - 1; n >= 0; n--)
4256 : : {
4257 : : /* Calculate the index for this dimension. */
4258 : 141183 : gfc_init_se (&indexse, se);
4259 : 141183 : gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
4260 : 141183 : gfc_add_block_to_block (&se->pre, &indexse.pre);
4261 : :
4262 : 141183 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && ! expr->no_bounds_check)
4263 : : {
4264 : : /* Check array bounds. */
4265 : 15035 : tree cond;
4266 : 15035 : char *msg;
4267 : :
4268 : : /* Evaluate the indexse.expr only once. */
4269 : 15035 : indexse.expr = save_expr (indexse.expr);
4270 : :
4271 : : /* Lower bound. */
4272 : 15035 : tmp = gfc_conv_array_lbound (decl, n);
4273 : 15035 : if (sym->attr.temporary)
4274 : : {
4275 : 18 : gfc_init_se (&tmpse, se);
4276 : 18 : gfc_conv_expr_type (&tmpse, ar->as->lower[n],
4277 : : gfc_array_index_type);
4278 : 18 : gfc_add_block_to_block (&se->pre, &tmpse.pre);
4279 : 18 : tmp = tmpse.expr;
4280 : : }
4281 : :
4282 : 15035 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
4283 : : indexse.expr, tmp);
4284 : 15035 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4285 : : "below lower bound of %%ld", n+1, var_name);
4286 : 15035 : gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
4287 : : fold_convert (long_integer_type_node,
4288 : : indexse.expr),
4289 : : fold_convert (long_integer_type_node, tmp));
4290 : 15035 : free (msg);
4291 : :
4292 : : /* Upper bound, but not for the last dimension of assumed-size
4293 : : arrays. */
4294 : 15035 : if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE)
4295 : : {
4296 : 13302 : tmp = gfc_conv_array_ubound (decl, n);
4297 : 13302 : if (sym->attr.temporary)
4298 : : {
4299 : 18 : gfc_init_se (&tmpse, se);
4300 : 18 : gfc_conv_expr_type (&tmpse, ar->as->upper[n],
4301 : : gfc_array_index_type);
4302 : 18 : gfc_add_block_to_block (&se->pre, &tmpse.pre);
4303 : 18 : tmp = tmpse.expr;
4304 : : }
4305 : :
4306 : 13302 : cond = fold_build2_loc (input_location, GT_EXPR,
4307 : : logical_type_node, indexse.expr, tmp);
4308 : 13302 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4309 : : "above upper bound of %%ld", n+1, var_name);
4310 : 13302 : gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
4311 : : fold_convert (long_integer_type_node,
4312 : : indexse.expr),
4313 : : fold_convert (long_integer_type_node, tmp));
4314 : 13302 : free (msg);
4315 : : }
4316 : : }
4317 : :
4318 : : /* Multiply the index by the stride. */
4319 : 141183 : stride = gfc_conv_array_stride (decl, n);
4320 : 141183 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4321 : : indexse.expr, stride);
4322 : :
4323 : : /* And add it to the total. */
4324 : 141183 : add_to_offset (&cst_offset, &offset, tmp);
4325 : : }
4326 : :
4327 : 114712 : if (!integer_zerop (cst_offset))
4328 : 61189 : offset = fold_build2_loc (input_location, PLUS_EXPR,
4329 : : gfc_array_index_type, offset, cst_offset);
4330 : :
4331 : : /* A pointer array component can be detected from its field decl. Fix
4332 : : the descriptor, mark the resulting variable decl and pass it to
4333 : : build_array_ref. */
4334 : 114712 : decl = NULL_TREE;
4335 : 114712 : if (get_CFI_desc (sym, expr, &decl, ar))
4336 : 3589 : decl = build_fold_indirect_ref_loc (input_location, decl);
4337 : 113963 : if (!expr->ts.deferred && !sym->attr.codimension
4338 : 226975 : && is_pointer_array (se->expr))
4339 : : {
4340 : 4842 : if (TREE_CODE (se->expr) == COMPONENT_REF)
4341 : 1454 : decl = se->expr;
4342 : 3388 : else if (INDIRECT_REF_P (se->expr))
4343 : 983 : decl = TREE_OPERAND (se->expr, 0);
4344 : : else
4345 : 2405 : decl = se->expr;
4346 : : }
4347 : 109870 : else if (expr->ts.deferred
4348 : 109121 : || (sym->ts.type == BT_CHARACTER
4349 : 14386 : && sym->attr.select_type_temporary))
4350 : : {
4351 : 2453 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
4352 : : {
4353 : 2417 : decl = se->expr;
4354 : 2417 : if (INDIRECT_REF_P (decl))
4355 : 20 : decl = TREE_OPERAND (decl, 0);
4356 : : }
4357 : : else
4358 : 36 : decl = sym->backend_decl;
4359 : : }
4360 : 107417 : else if (sym->ts.type == BT_CLASS)
4361 : : {
4362 : 2084 : if (UNLIMITED_POLY (sym))
4363 : : {
4364 : 98 : gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr);
4365 : 98 : gfc_init_se (&tmpse, NULL);
4366 : 98 : gfc_conv_expr (&tmpse, class_expr);
4367 : 98 : if (!se->class_vptr)
4368 : 98 : se->class_vptr = gfc_class_vptr_get (tmpse.expr);
4369 : 98 : gfc_free_expr (class_expr);
4370 : 98 : decl = tmpse.expr;
4371 : 98 : }
4372 : : else
4373 : 1986 : decl = NULL_TREE;
4374 : : }
4375 : :
4376 : 114712 : free (var_name);
4377 : 114712 : se->expr = build_array_ref (se->expr, offset, decl, se->class_vptr);
4378 : : }
4379 : :
4380 : :
4381 : : /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
4382 : : LOOP_DIM dimension (if any) to array's offset. */
4383 : :
4384 : : static void
4385 : 53156 : add_array_offset (stmtblock_t *pblock, gfc_loopinfo *loop, gfc_ss *ss,
4386 : : gfc_array_ref *ar, int array_dim, int loop_dim)
4387 : : {
4388 : 53156 : gfc_se se;
4389 : 53156 : gfc_array_info *info;
4390 : 53156 : tree stride, index;
4391 : :
4392 : 53156 : info = &ss->info->data.array;
4393 : :
4394 : 53156 : gfc_init_se (&se, NULL);
4395 : 53156 : se.loop = loop;
4396 : 53156 : se.expr = info->descriptor;
4397 : 53156 : stride = gfc_conv_array_stride (info->descriptor, array_dim);
4398 : 53156 : index = conv_array_index_offset (&se, ss, array_dim, loop_dim, ar, stride);
4399 : 53156 : gfc_add_block_to_block (pblock, &se.pre);
4400 : :
4401 : 53156 : info->offset = fold_build2_loc (input_location, PLUS_EXPR,
4402 : : gfc_array_index_type,
4403 : : info->offset, index);
4404 : 53156 : info->offset = gfc_evaluate_now (info->offset, pblock);
4405 : 53156 : }
4406 : :
4407 : :
4408 : : /* Generate the code to be executed immediately before entering a
4409 : : scalarization loop. */
4410 : :
4411 : : static void
4412 : 132834 : gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
4413 : : stmtblock_t * pblock)
4414 : : {
4415 : 132834 : tree stride;
4416 : 132834 : gfc_ss_info *ss_info;
4417 : 132834 : gfc_array_info *info;
4418 : 132834 : gfc_ss_type ss_type;
4419 : 132834 : gfc_ss *ss, *pss;
4420 : 132834 : gfc_loopinfo *ploop;
4421 : 132834 : gfc_array_ref *ar;
4422 : :
4423 : : /* This code will be executed before entering the scalarization loop
4424 : : for this dimension. */
4425 : 404526 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4426 : : {
4427 : 271692 : ss_info = ss->info;
4428 : :
4429 : 271692 : if ((ss_info->useflags & flag) == 0)
4430 : 1468 : continue;
4431 : :
4432 : 270224 : ss_type = ss_info->type;
4433 : 326174 : if (ss_type != GFC_SS_SECTION
4434 : : && ss_type != GFC_SS_FUNCTION
4435 : 270224 : && ss_type != GFC_SS_CONSTRUCTOR
4436 : 270224 : && ss_type != GFC_SS_COMPONENT)
4437 : 55950 : continue;
4438 : :
4439 : 214274 : info = &ss_info->data.array;
4440 : :
4441 : 214274 : gcc_assert (dim < ss->dimen);
4442 : 214274 : gcc_assert (ss->dimen == loop->dimen);
4443 : :
4444 : 214274 : if (info->ref)
4445 : 149961 : ar = &info->ref->u.ar;
4446 : : else
4447 : : ar = NULL;
4448 : :
4449 : 214274 : if (dim == loop->dimen - 1 && loop->parent != NULL)
4450 : : {
4451 : : /* If we are in the outermost dimension of this loop, the previous
4452 : : dimension shall be in the parent loop. */
4453 : 3455 : gcc_assert (ss->parent != NULL);
4454 : :
4455 : 3455 : pss = ss->parent;
4456 : 3455 : ploop = loop->parent;
4457 : :
4458 : : /* ss and ss->parent are about the same array. */
4459 : 3455 : gcc_assert (ss_info == pss->info);
4460 : : }
4461 : : else
4462 : : {
4463 : : ploop = loop;
4464 : : pss = ss;
4465 : : }
4466 : :
4467 : 214274 : if (dim == loop->dimen - 1 && loop->parent == NULL)
4468 : : {
4469 : 165293 : gcc_assert (0 == ploop->order[0]);
4470 : :
4471 : 330586 : stride = gfc_conv_array_stride (info->descriptor,
4472 : 165293 : innermost_ss (ss)->dim[0]);
4473 : :
4474 : : /* Calculate the stride of the innermost loop. Hopefully this will
4475 : : allow the backend optimizers to do their stuff more effectively.
4476 : : */
4477 : 165293 : info->stride0 = gfc_evaluate_now (stride, pblock);
4478 : :
4479 : : /* For the outermost loop calculate the offset due to any
4480 : : elemental dimensions. It will have been initialized with the
4481 : : base offset of the array. */
4482 : 165293 : if (info->ref)
4483 : : {
4484 : 263909 : for (int i = 0; i < ar->dimen; i++)
4485 : : {
4486 : 151955 : if (ar->dimen_type[i] != DIMEN_ELEMENT)
4487 : 147780 : continue;
4488 : :
4489 : 4175 : add_array_offset (pblock, loop, ss, ar, i, /* unused */ -1);
4490 : : }
4491 : : }
4492 : : }
4493 : : else
4494 : : {
4495 : 48981 : int i;
4496 : :
4497 : 48981 : if (dim == loop->dimen - 1)
4498 : : i = 0;
4499 : : else
4500 : 45526 : i = dim + 1;
4501 : :
4502 : : /* For the time being, there is no loop reordering. */
4503 : 48981 : gcc_assert (i == ploop->order[i]);
4504 : 48981 : i = ploop->order[i];
4505 : :
4506 : : /* Add the offset for the previous loop dimension. */
4507 : 48981 : add_array_offset (pblock, ploop, ss, ar, pss->dim[i], i);
4508 : : }
4509 : :
4510 : : /* Remember this offset for the second loop. */
4511 : 214274 : if (dim == loop->temp_dim - 1 && loop->parent == NULL)
4512 : 50356 : info->saved_offset = info->offset;
4513 : : }
4514 : 132834 : }
4515 : :
4516 : :
4517 : : /* Start a scalarized expression. Creates a scope and declares loop
4518 : : variables. */
4519 : :
4520 : : void
4521 : 106008 : gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
4522 : : {
4523 : 106008 : int dim;
4524 : 106008 : int n;
4525 : 106008 : int flags;
4526 : :
4527 : 106008 : gcc_assert (!loop->array_parameter);
4528 : :
4529 : 237455 : for (dim = loop->dimen - 1; dim >= 0; dim--)
4530 : : {
4531 : 131447 : n = loop->order[dim];
4532 : :
4533 : 131447 : gfc_start_block (&loop->code[n]);
4534 : :
4535 : : /* Create the loop variable. */
4536 : 131447 : loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
4537 : :
4538 : 131447 : if (dim < loop->temp_dim)
4539 : : flags = 3;
4540 : : else
4541 : 91013 : flags = 1;
4542 : : /* Calculate values that will be constant within this loop. */
4543 : 131447 : gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
4544 : : }
4545 : 106008 : gfc_start_block (pbody);
4546 : 106008 : }
4547 : :
4548 : :
4549 : : /* Generates the actual loop code for a scalarization loop. */
4550 : :
4551 : : static void
4552 : 143648 : gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
4553 : : stmtblock_t * pbody)
4554 : : {
4555 : 143648 : stmtblock_t block;
4556 : 143648 : tree cond;
4557 : 143648 : tree tmp;
4558 : 143648 : tree loopbody;
4559 : 143648 : tree exit_label;
4560 : 143648 : tree stmt;
4561 : 143648 : tree init;
4562 : 143648 : tree incr;
4563 : :
4564 : 143648 : if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS
4565 : : | OMPWS_SCALARIZER_BODY))
4566 : : == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS)
4567 : 108 : && n == loop->dimen - 1)
4568 : : {
4569 : : /* We create an OMP_FOR construct for the outermost scalarized loop. */
4570 : 80 : init = make_tree_vec (1);
4571 : 80 : cond = make_tree_vec (1);
4572 : 80 : incr = make_tree_vec (1);
4573 : :
4574 : : /* Cycle statement is implemented with a goto. Exit statement must not
4575 : : be present for this loop. */
4576 : 80 : exit_label = gfc_build_label_decl (NULL_TREE);
4577 : 80 : TREE_USED (exit_label) = 1;
4578 : :
4579 : : /* Label for cycle statements (if needed). */
4580 : 80 : tmp = build1_v (LABEL_EXPR, exit_label);
4581 : 80 : gfc_add_expr_to_block (pbody, tmp);
4582 : :
4583 : 80 : stmt = make_node (OMP_FOR);
4584 : :
4585 : 80 : TREE_TYPE (stmt) = void_type_node;
4586 : 80 : OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody);
4587 : :
4588 : 80 : OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location,
4589 : : OMP_CLAUSE_SCHEDULE);
4590 : 80 : OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt))
4591 : 80 : = OMP_CLAUSE_SCHEDULE_STATIC;
4592 : 80 : if (ompws_flags & OMPWS_NOWAIT)
4593 : 33 : OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt))
4594 : 66 : = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT);
4595 : :
4596 : : /* Initialize the loopvar. */
4597 : 80 : TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n],
4598 : : loop->from[n]);
4599 : 80 : OMP_FOR_INIT (stmt) = init;
4600 : : /* The exit condition. */
4601 : 80 : TREE_VEC_ELT (cond, 0) = build2_loc (input_location, LE_EXPR,
4602 : : logical_type_node,
4603 : : loop->loopvar[n], loop->to[n]);
4604 : 80 : SET_EXPR_LOCATION (TREE_VEC_ELT (cond, 0), input_location);
4605 : 80 : OMP_FOR_COND (stmt) = cond;
4606 : : /* Increment the loopvar. */
4607 : 80 : tmp = build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4608 : : loop->loopvar[n], gfc_index_one_node);
4609 : 80 : TREE_VEC_ELT (incr, 0) = fold_build2_loc (input_location, MODIFY_EXPR,
4610 : : void_type_node, loop->loopvar[n], tmp);
4611 : 80 : OMP_FOR_INCR (stmt) = incr;
4612 : :
4613 : 80 : ompws_flags &= ~OMPWS_CURR_SINGLEUNIT;
4614 : 80 : gfc_add_expr_to_block (&loop->code[n], stmt);
4615 : : }
4616 : : else
4617 : : {
4618 : 287136 : bool reverse_loop = (loop->reverse[n] == GFC_REVERSE_SET)
4619 : 143568 : && (loop->temp_ss == NULL);
4620 : :
4621 : 143568 : loopbody = gfc_finish_block (pbody);
4622 : :
4623 : 143568 : if (reverse_loop)
4624 : 202 : std::swap (loop->from[n], loop->to[n]);
4625 : :
4626 : : /* Initialize the loopvar. */
4627 : 143568 : if (loop->loopvar[n] != loop->from[n])
4628 : 142748 : gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
4629 : :
4630 : 143568 : exit_label = gfc_build_label_decl (NULL_TREE);
4631 : :
4632 : : /* Generate the loop body. */
4633 : 143568 : gfc_init_block (&block);
4634 : :
4635 : : /* The exit condition. */
4636 : 286934 : cond = fold_build2_loc (input_location, reverse_loop ? LT_EXPR : GT_EXPR,
4637 : : logical_type_node, loop->loopvar[n], loop->to[n]);
4638 : 143568 : tmp = build1_v (GOTO_EXPR, exit_label);
4639 : 143568 : TREE_USED (exit_label) = 1;
4640 : 143568 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
4641 : 143568 : gfc_add_expr_to_block (&block, tmp);
4642 : :
4643 : : /* The main body. */
4644 : 143568 : gfc_add_expr_to_block (&block, loopbody);
4645 : :
4646 : : /* Increment the loopvar. */
4647 : 286934 : tmp = fold_build2_loc (input_location,
4648 : : reverse_loop ? MINUS_EXPR : PLUS_EXPR,
4649 : : gfc_array_index_type, loop->loopvar[n],
4650 : : gfc_index_one_node);
4651 : :
4652 : 143568 : gfc_add_modify (&block, loop->loopvar[n], tmp);
4653 : :
4654 : : /* Build the loop. */
4655 : 143568 : tmp = gfc_finish_block (&block);
4656 : 143568 : tmp = build1_v (LOOP_EXPR, tmp);
4657 : 143568 : gfc_add_expr_to_block (&loop->code[n], tmp);
4658 : :
4659 : : /* Add the exit label. */
4660 : 143568 : tmp = build1_v (LABEL_EXPR, exit_label);
4661 : 143568 : gfc_add_expr_to_block (&loop->code[n], tmp);
4662 : : }
4663 : :
4664 : 143648 : }
4665 : :
4666 : :
4667 : : /* Finishes and generates the loops for a scalarized expression. */
4668 : :
4669 : : void
4670 : 110159 : gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
4671 : : {
4672 : 110159 : int dim;
4673 : 110159 : int n;
4674 : 110159 : gfc_ss *ss;
4675 : 110159 : stmtblock_t *pblock;
4676 : 110159 : tree tmp;
4677 : :
4678 : 110159 : pblock = body;
4679 : : /* Generate the loops. */
4680 : 245748 : for (dim = 0; dim < loop->dimen; dim++)
4681 : : {
4682 : 135589 : n = loop->order[dim];
4683 : 135589 : gfc_trans_scalarized_loop_end (loop, n, pblock);
4684 : 135589 : loop->loopvar[n] = NULL_TREE;
4685 : 135589 : pblock = &loop->code[n];
4686 : : }
4687 : :
4688 : 110159 : tmp = gfc_finish_block (pblock);
4689 : 110159 : gfc_add_expr_to_block (&loop->pre, tmp);
4690 : :
4691 : : /* Clear all the used flags. */
4692 : 325298 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4693 : 215139 : if (ss->parent == NULL)
4694 : 211621 : ss->info->useflags = 0;
4695 : 110159 : }
4696 : :
4697 : :
4698 : : /* Finish the main body of a scalarized expression, and start the secondary
4699 : : copying body. */
4700 : :
4701 : : void
4702 : 6672 : gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
4703 : : {
4704 : 6672 : int dim;
4705 : 6672 : int n;
4706 : 6672 : stmtblock_t *pblock;
4707 : 6672 : gfc_ss *ss;
4708 : :
4709 : 6672 : pblock = body;
4710 : : /* We finish as many loops as are used by the temporary. */
4711 : 8059 : for (dim = 0; dim < loop->temp_dim - 1; dim++)
4712 : : {
4713 : 1387 : n = loop->order[dim];
4714 : 1387 : gfc_trans_scalarized_loop_end (loop, n, pblock);
4715 : 1387 : loop->loopvar[n] = NULL_TREE;
4716 : 1387 : pblock = &loop->code[n];
4717 : : }
4718 : :
4719 : : /* We don't want to finish the outermost loop entirely. */
4720 : 6672 : n = loop->order[loop->temp_dim - 1];
4721 : 6672 : gfc_trans_scalarized_loop_end (loop, n, pblock);
4722 : :
4723 : : /* Restore the initial offsets. */
4724 : 19439 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4725 : : {
4726 : 12767 : gfc_ss_type ss_type;
4727 : 12767 : gfc_ss_info *ss_info;
4728 : :
4729 : 12767 : ss_info = ss->info;
4730 : :
4731 : 12767 : if ((ss_info->useflags & 2) == 0)
4732 : 3584 : continue;
4733 : :
4734 : 9183 : ss_type = ss_info->type;
4735 : 9337 : if (ss_type != GFC_SS_SECTION
4736 : : && ss_type != GFC_SS_FUNCTION
4737 : 9183 : && ss_type != GFC_SS_CONSTRUCTOR
4738 : 9183 : && ss_type != GFC_SS_COMPONENT)
4739 : 154 : continue;
4740 : :
4741 : 9029 : ss_info->data.array.offset = ss_info->data.array.saved_offset;
4742 : : }
4743 : :
4744 : : /* Restart all the inner loops we just finished. */
4745 : 8059 : for (dim = loop->temp_dim - 2; dim >= 0; dim--)
4746 : : {
4747 : 1387 : n = loop->order[dim];
4748 : :
4749 : 1387 : gfc_start_block (&loop->code[n]);
4750 : :
4751 : 1387 : loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
4752 : :
4753 : 1387 : gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
4754 : : }
4755 : :
4756 : : /* Start a block for the secondary copying code. */
4757 : 6672 : gfc_start_block (body);
4758 : 6672 : }
4759 : :
4760 : :
4761 : : /* Precalculate (either lower or upper) bound of an array section.
4762 : : BLOCK: Block in which the (pre)calculation code will go.
4763 : : BOUNDS[DIM]: Where the bound value will be stored once evaluated.
4764 : : VALUES[DIM]: Specified bound (NULL <=> unspecified).
4765 : : DESC: Array descriptor from which the bound will be picked if unspecified
4766 : : (either lower or upper bound according to LBOUND). */
4767 : :
4768 : : static void
4769 : 477448 : evaluate_bound (stmtblock_t *block, tree *bounds, gfc_expr ** values,
4770 : : tree desc, int dim, bool lbound, bool deferred)
4771 : : {
4772 : 477448 : gfc_se se;
4773 : 477448 : gfc_expr * input_val = values[dim];
4774 : 477448 : tree *output = &bounds[dim];
4775 : :
4776 : :
4777 : 477448 : if (input_val)
4778 : : {
4779 : : /* Specified section bound. */
4780 : 45793 : gfc_init_se (&se, NULL);
4781 : 45793 : gfc_conv_expr_type (&se, input_val, gfc_array_index_type);
4782 : 45793 : gfc_add_block_to_block (block, &se.pre);
4783 : 45793 : *output = se.expr;
4784 : : }
4785 : 431655 : else if (deferred && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
4786 : : {
4787 : : /* The gfc_conv_array_lbound () routine returns a constant zero for
4788 : : deferred length arrays, which in the scalarizer wreaks havoc, when
4789 : : copying to a (newly allocated) one-based array.
4790 : : Keep returning the actual result in sync for both bounds. */
4791 : 179238 : *output = lbound ? gfc_conv_descriptor_lbound_get (desc,
4792 : : gfc_rank_cst[dim]):
4793 : 59809 : gfc_conv_descriptor_ubound_get (desc,
4794 : : gfc_rank_cst[dim]);
4795 : : }
4796 : : else
4797 : : {
4798 : : /* No specific bound specified so use the bound of the array. */
4799 : 465033 : *output = lbound ? gfc_conv_array_lbound (desc, dim) :
4800 : 152807 : gfc_conv_array_ubound (desc, dim);
4801 : : }
4802 : 477448 : *output = gfc_evaluate_now (*output, block);
4803 : 477448 : }
4804 : :
4805 : :
4806 : : /* Calculate the lower bound of an array section. */
4807 : :
4808 : : static void
4809 : 239225 : gfc_conv_section_startstride (stmtblock_t * block, gfc_ss * ss, int dim)
4810 : : {
4811 : 239225 : gfc_expr *stride = NULL;
4812 : 239225 : tree desc;
4813 : 239225 : gfc_se se;
4814 : 239225 : gfc_array_info *info;
4815 : 239225 : gfc_array_ref *ar;
4816 : :
4817 : 239225 : gcc_assert (ss->info->type == GFC_SS_SECTION);
4818 : :
4819 : 239225 : info = &ss->info->data.array;
4820 : 239225 : ar = &info->ref->u.ar;
4821 : :
4822 : 239225 : if (ar->dimen_type[dim] == DIMEN_VECTOR)
4823 : : {
4824 : : /* We use a zero-based index to access the vector. */
4825 : 752 : info->start[dim] = gfc_index_zero_node;
4826 : 752 : info->end[dim] = NULL;
4827 : 752 : info->stride[dim] = gfc_index_one_node;
4828 : 752 : return;
4829 : : }
4830 : :
4831 : 238473 : gcc_assert (ar->dimen_type[dim] == DIMEN_RANGE
4832 : : || ar->dimen_type[dim] == DIMEN_THIS_IMAGE);
4833 : 238473 : desc = info->descriptor;
4834 : 238473 : stride = ar->stride[dim];
4835 : :
4836 : :
4837 : : /* Calculate the start of the range. For vector subscripts this will
4838 : : be the range of the vector. */
4839 : 238473 : evaluate_bound (block, info->start, ar->start, desc, dim, true,
4840 : 238473 : ar->as->type == AS_DEFERRED);
4841 : :
4842 : : /* Similarly calculate the end. Although this is not used in the
4843 : : scalarizer, it is needed when checking bounds and where the end
4844 : : is an expression with side-effects. */
4845 : 238473 : evaluate_bound (block, info->end, ar->end, desc, dim, false,
4846 : 238473 : ar->as->type == AS_DEFERRED);
4847 : :
4848 : :
4849 : : /* Calculate the stride. */
4850 : 238473 : if (stride == NULL)
4851 : 226423 : info->stride[dim] = gfc_index_one_node;
4852 : : else
4853 : : {
4854 : 12050 : gfc_init_se (&se, NULL);
4855 : 12050 : gfc_conv_expr_type (&se, stride, gfc_array_index_type);
4856 : 12050 : gfc_add_block_to_block (block, &se.pre);
4857 : 12050 : info->stride[dim] = gfc_evaluate_now (se.expr, block);
4858 : : }
4859 : : }
4860 : :
4861 : :
4862 : : /* Generate in INNER the bounds checking code along the dimension DIM for
4863 : : the array associated with SS_INFO. */
4864 : :
4865 : : static void
4866 : 23767 : add_check_section_in_array_bounds (stmtblock_t *inner, gfc_ss_info *ss_info,
4867 : : int dim)
4868 : : {
4869 : 23767 : gfc_expr *expr = ss_info->expr;
4870 : 23767 : locus *expr_loc = &expr->where;
4871 : 23767 : const char *expr_name = expr->symtree->name;
4872 : :
4873 : 23767 : gfc_array_info *info = &ss_info->data.array;
4874 : :
4875 : 23767 : bool check_upper;
4876 : 23767 : if (dim == info->ref->u.ar.dimen - 1
4877 : 20244 : && info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
4878 : : check_upper = false;
4879 : : else
4880 : 23471 : check_upper = true;
4881 : :
4882 : : /* Zero stride is not allowed. */
4883 : 23767 : tree tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
4884 : : info->stride[dim], gfc_index_zero_node);
4885 : 23767 : char * msg = xasprintf ("Zero stride is not allowed, for dimension %d "
4886 : : "of array '%s'", dim + 1, expr_name);
4887 : 23767 : gfc_trans_runtime_check (true, false, tmp, inner, expr_loc, msg);
4888 : 23767 : free (msg);
4889 : :
4890 : 23767 : tree desc = info->descriptor;
4891 : :
4892 : : /* This is the run-time equivalent of resolve.cc's
4893 : : check_dimension. The logical is more readable there
4894 : : than it is here, with all the trees. */
4895 : 23767 : tree lbound = gfc_conv_array_lbound (desc, dim);
4896 : 23767 : tree end = info->end[dim];
4897 : 23767 : tree ubound = check_upper ? gfc_conv_array_ubound (desc, dim) : NULL_TREE;
4898 : :
4899 : : /* non_zerosized is true when the selected range is not
4900 : : empty. */
4901 : 23767 : tree stride_pos = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
4902 : : info->stride[dim], gfc_index_zero_node);
4903 : 23767 : tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
4904 : : info->start[dim], end);
4905 : 23767 : stride_pos = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4906 : : logical_type_node, stride_pos, tmp);
4907 : :
4908 : 23767 : tree stride_neg = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
4909 : : info->stride[dim], gfc_index_zero_node);
4910 : 23767 : tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
4911 : : info->start[dim], end);
4912 : 23767 : stride_neg = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4913 : : logical_type_node, stride_neg, tmp);
4914 : 23767 : tree non_zerosized = fold_build2_loc (input_location, TRUTH_OR_EXPR,
4915 : : logical_type_node, stride_pos,
4916 : : stride_neg);
4917 : :
4918 : : /* Check the start of the range against the lower and upper
4919 : : bounds of the array, if the range is not empty.
4920 : : If upper bound is present, include both bounds in the
4921 : : error message. */
4922 : 23767 : if (check_upper)
4923 : : {
4924 : 23471 : tmp = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
4925 : : info->start[dim], lbound);
4926 : 23471 : tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
4927 : : non_zerosized, tmp);
4928 : 23471 : tree tmp2 = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
4929 : : info->start[dim], ubound);
4930 : 23471 : tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
4931 : : non_zerosized, tmp2);
4932 : 23471 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' outside of "
4933 : : "expected range (%%ld:%%ld)", dim + 1, expr_name);
4934 : 23471 : gfc_trans_runtime_check (true, false, tmp, inner, expr_loc, msg,
4935 : : fold_convert (long_integer_type_node, info->start[dim]),
4936 : : fold_convert (long_integer_type_node, lbound),
4937 : : fold_convert (long_integer_type_node, ubound));
4938 : 23471 : gfc_trans_runtime_check (true, false, tmp2, inner, expr_loc, msg,
4939 : : fold_convert (long_integer_type_node, info->start[dim]),
4940 : : fold_convert (long_integer_type_node, lbound),
4941 : : fold_convert (long_integer_type_node, ubound));
4942 : 23471 : free (msg);
4943 : : }
4944 : : else
4945 : : {
4946 : 296 : tmp = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
4947 : : info->start[dim], lbound);
4948 : 296 : tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
4949 : : non_zerosized, tmp);
4950 : 296 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' below "
4951 : : "lower bound of %%ld", dim + 1, expr_name);
4952 : 296 : gfc_trans_runtime_check (true, false, tmp, inner, expr_loc, msg,
4953 : : fold_convert (long_integer_type_node, info->start[dim]),
4954 : : fold_convert (long_integer_type_node, lbound));
4955 : 296 : free (msg);
4956 : : }
4957 : :
4958 : : /* Compute the last element of the range, which is not
4959 : : necessarily "end" (think 0:5:3, which doesn't contain 5)
4960 : : and check it against both lower and upper bounds. */
4961 : :
4962 : 23767 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4963 : : end, info->start[dim]);
4964 : 23767 : tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR, gfc_array_index_type,
4965 : : tmp, info->stride[dim]);
4966 : 23767 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4967 : : end, tmp);
4968 : 23767 : tree tmp2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
4969 : : tmp, lbound);
4970 : 23767 : tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
4971 : : non_zerosized, tmp2);
4972 : 23767 : if (check_upper)
4973 : : {
4974 : 23471 : tree tmp3 = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
4975 : : tmp, ubound);
4976 : 23471 : tmp3 = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
4977 : : non_zerosized, tmp3);
4978 : 23471 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' outside of "
4979 : : "expected range (%%ld:%%ld)", dim + 1, expr_name);
4980 : 23471 : gfc_trans_runtime_check (true, false, tmp2, inner, expr_loc, msg,
4981 : : fold_convert (long_integer_type_node, tmp),
4982 : : fold_convert (long_integer_type_node, ubound),
4983 : : fold_convert (long_integer_type_node, lbound));
4984 : 23471 : gfc_trans_runtime_check (true, false, tmp3, inner, expr_loc, msg,
4985 : : fold_convert (long_integer_type_node, tmp),
4986 : : fold_convert (long_integer_type_node, ubound),
4987 : : fold_convert (long_integer_type_node, lbound));
4988 : 23471 : free (msg);
4989 : : }
4990 : : else
4991 : : {
4992 : 296 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' below "
4993 : : "lower bound of %%ld", dim + 1, expr_name);
4994 : 296 : gfc_trans_runtime_check (true, false, tmp2, inner, expr_loc, msg,
4995 : : fold_convert (long_integer_type_node, tmp),
4996 : : fold_convert (long_integer_type_node, lbound));
4997 : 296 : free (msg);
4998 : : }
4999 : 23767 : }
5000 : :
5001 : :
5002 : : /* Tells whether we need to generate bounds checking code for the array
5003 : : associated with SS. */
5004 : :
5005 : : bool
5006 : 24860 : bounds_check_needed (gfc_ss *ss)
5007 : : {
5008 : : /* Catch allocatable lhs in f2003. */
5009 : 24860 : if (flag_realloc_lhs && ss->no_bounds_check)
5010 : : return false;
5011 : :
5012 : 24483 : gfc_ss_info *ss_info = ss->info;
5013 : 24483 : if (ss_info->type == GFC_SS_SECTION)
5014 : : return true;
5015 : :
5016 : 4066 : if (!(ss_info->type == GFC_SS_INTRINSIC
5017 : 227 : && ss_info->expr
5018 : 227 : && ss_info->expr->expr_type == EXPR_FUNCTION))
5019 : : return false;
5020 : :
5021 : 227 : gfc_intrinsic_sym *isym = ss_info->expr->value.function.isym;
5022 : 227 : if (!(isym
5023 : 227 : && (isym->id == GFC_ISYM_MAXLOC
5024 : 203 : || isym->id == GFC_ISYM_MINLOC)))
5025 : : return false;
5026 : :
5027 : 34 : return gfc_inline_intrinsic_function_p (ss_info->expr);
5028 : : }
5029 : :
5030 : :
5031 : : /* Calculates the range start and stride for a SS chain. Also gets the
5032 : : descriptor and data pointer. The range of vector subscripts is the size
5033 : : of the vector. Array bounds are also checked. */
5034 : :
5035 : : void
5036 : 169910 : gfc_conv_ss_startstride (gfc_loopinfo * loop)
5037 : : {
5038 : 169910 : int n;
5039 : 169910 : tree tmp;
5040 : 169910 : gfc_ss *ss;
5041 : :
5042 : 169910 : gfc_loopinfo * const outer_loop = outermost_loop (loop);
5043 : :
5044 : 169910 : loop->dimen = 0;
5045 : : /* Determine the rank of the loop. */
5046 : 188016 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5047 : : {
5048 : 188016 : switch (ss->info->type)
5049 : : {
5050 : 159474 : case GFC_SS_SECTION:
5051 : 159474 : case GFC_SS_CONSTRUCTOR:
5052 : 159474 : case GFC_SS_FUNCTION:
5053 : 159474 : case GFC_SS_COMPONENT:
5054 : 159474 : loop->dimen = ss->dimen;
5055 : 159474 : goto done;
5056 : :
5057 : : /* As usual, lbound and ubound are exceptions!. */
5058 : 10436 : case GFC_SS_INTRINSIC:
5059 : 10436 : switch (ss->info->expr->value.function.isym->id)
5060 : : {
5061 : 10436 : case GFC_ISYM_LBOUND:
5062 : 10436 : case GFC_ISYM_UBOUND:
5063 : 10436 : case GFC_ISYM_LCOBOUND:
5064 : 10436 : case GFC_ISYM_UCOBOUND:
5065 : 10436 : case GFC_ISYM_MAXLOC:
5066 : 10436 : case GFC_ISYM_MINLOC:
5067 : 10436 : case GFC_ISYM_SHAPE:
5068 : 10436 : case GFC_ISYM_THIS_IMAGE:
5069 : 10436 : loop->dimen = ss->dimen;
5070 : 10436 : goto done;
5071 : :
5072 : : default:
5073 : : break;
5074 : : }
5075 : :
5076 : 18106 : default:
5077 : 18106 : break;
5078 : : }
5079 : : }
5080 : :
5081 : : /* We should have determined the rank of the expression by now. If
5082 : : not, that's bad news. */
5083 : 0 : gcc_unreachable ();
5084 : :
5085 : : done:
5086 : : /* Loop over all the SS in the chain. */
5087 : 439908 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5088 : : {
5089 : 269998 : gfc_ss_info *ss_info;
5090 : 269998 : gfc_array_info *info;
5091 : 269998 : gfc_expr *expr;
5092 : :
5093 : 269998 : ss_info = ss->info;
5094 : 269998 : expr = ss_info->expr;
5095 : 269998 : info = &ss_info->data.array;
5096 : :
5097 : 269998 : if (expr && expr->shape && !info->shape)
5098 : 158814 : info->shape = expr->shape;
5099 : :
5100 : 269998 : switch (ss_info->type)
5101 : : {
5102 : 172649 : case GFC_SS_SECTION:
5103 : : /* Get the descriptor for the array. If it is a cross loops array,
5104 : : we got the descriptor already in the outermost loop. */
5105 : 172649 : if (ss->parent == NULL)
5106 : 169245 : gfc_conv_ss_descriptor (&outer_loop->pre, ss,
5107 : 169245 : !loop->array_parameter);
5108 : :
5109 : 411346 : for (n = 0; n < ss->dimen; n++)
5110 : 238697 : gfc_conv_section_startstride (&outer_loop->pre, ss, ss->dim[n]);
5111 : : break;
5112 : :
5113 : 10673 : case GFC_SS_INTRINSIC:
5114 : 10673 : switch (expr->value.function.isym->id)
5115 : : {
5116 : 2705 : case GFC_ISYM_MINLOC:
5117 : 2705 : case GFC_ISYM_MAXLOC:
5118 : 2705 : {
5119 : 2705 : gfc_se se;
5120 : 2705 : gfc_init_se (&se, nullptr);
5121 : 2705 : se.loop = loop;
5122 : 2705 : se.ss = ss;
5123 : 2705 : gfc_conv_intrinsic_function (&se, expr);
5124 : 2705 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
5125 : 2705 : gfc_add_block_to_block (&outer_loop->post, &se.post);
5126 : :
5127 : 2705 : info->descriptor = se.expr;
5128 : :
5129 : 2705 : info->data = gfc_conv_array_data (info->descriptor);
5130 : 2705 : info->data = gfc_evaluate_now (info->data, &outer_loop->pre);
5131 : :
5132 : 2705 : gfc_expr *array = expr->value.function.actual->expr;
5133 : 2705 : tree rank = build_int_cst (gfc_array_index_type, array->rank);
5134 : :
5135 : 2705 : tree tmp = fold_build2_loc (input_location, MINUS_EXPR,
5136 : : gfc_array_index_type, rank,
5137 : : gfc_index_one_node);
5138 : :
5139 : 2705 : info->end[0] = gfc_evaluate_now (tmp, &outer_loop->pre);
5140 : 2705 : info->start[0] = gfc_index_zero_node;
5141 : 2705 : info->stride[0] = gfc_index_one_node;
5142 : 2705 : info->offset = gfc_index_zero_node;
5143 : 2705 : continue;
5144 : 2705 : }
5145 : :
5146 : : /* Fall through to supply start and stride. */
5147 : 2980 : case GFC_ISYM_LBOUND:
5148 : 2980 : case GFC_ISYM_UBOUND:
5149 : : /* This is the variant without DIM=... */
5150 : 2980 : gcc_assert (expr->value.function.actual->next->expr == NULL);
5151 : : /* Fall through. */
5152 : :
5153 : 7755 : case GFC_ISYM_SHAPE:
5154 : 7755 : {
5155 : 7755 : gfc_expr *arg;
5156 : :
5157 : 7755 : arg = expr->value.function.actual->expr;
5158 : 7755 : if (arg->rank == -1)
5159 : : {
5160 : 1157 : gfc_se se;
5161 : 1157 : tree rank, tmp;
5162 : :
5163 : : /* The rank (hence the return value's shape) is unknown,
5164 : : we have to retrieve it. */
5165 : 1157 : gfc_init_se (&se, NULL);
5166 : 1157 : se.descriptor_only = 1;
5167 : 1157 : gfc_conv_expr (&se, arg);
5168 : : /* This is a bare variable, so there is no preliminary
5169 : : or cleanup code unless -std=f202y and bounds checking
5170 : : is on. */
5171 : 1157 : if (!((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
5172 : 0 : && (gfc_option.allow_std & GFC_STD_F202Y)))
5173 : 1157 : gcc_assert (se.pre.head == NULL_TREE
5174 : : && se.post.head == NULL_TREE);
5175 : 1157 : rank = gfc_conv_descriptor_rank (se.expr);
5176 : 1157 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
5177 : : gfc_array_index_type,
5178 : : fold_convert (gfc_array_index_type,
5179 : : rank),
5180 : : gfc_index_one_node);
5181 : 1157 : info->end[0] = gfc_evaluate_now (tmp, &outer_loop->pre);
5182 : 1157 : info->start[0] = gfc_index_zero_node;
5183 : 1157 : info->stride[0] = gfc_index_one_node;
5184 : 1157 : continue;
5185 : 1157 : }
5186 : : /* Otherwise fall through GFC_SS_FUNCTION. */
5187 : : gcc_fallthrough ();
5188 : : }
5189 : : case GFC_ISYM_LCOBOUND:
5190 : : case GFC_ISYM_UCOBOUND:
5191 : : case GFC_ISYM_THIS_IMAGE:
5192 : : break;
5193 : :
5194 : 0 : default:
5195 : 0 : continue;
5196 : 0 : }
5197 : :
5198 : : /* FALLTHRU */
5199 : : case GFC_SS_CONSTRUCTOR:
5200 : : case GFC_SS_FUNCTION:
5201 : 121133 : for (n = 0; n < ss->dimen; n++)
5202 : : {
5203 : 65150 : int dim = ss->dim[n];
5204 : :
5205 : 65150 : info->start[dim] = gfc_index_zero_node;
5206 : 65150 : info->end[dim] = gfc_index_zero_node;
5207 : 65150 : info->stride[dim] = gfc_index_one_node;
5208 : : }
5209 : : break;
5210 : :
5211 : : default:
5212 : : break;
5213 : : }
5214 : : }
5215 : :
5216 : : /* The rest is just runtime bounds checking. */
5217 : 169910 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
5218 : : {
5219 : 16837 : stmtblock_t block;
5220 : 16837 : tree size[GFC_MAX_DIMENSIONS];
5221 : 16837 : tree tmp3;
5222 : 16837 : gfc_array_info *info;
5223 : 16837 : char *msg;
5224 : 16837 : int dim;
5225 : :
5226 : 16837 : gfc_start_block (&block);
5227 : :
5228 : 53927 : for (n = 0; n < loop->dimen; n++)
5229 : 20253 : size[n] = NULL_TREE;
5230 : :
5231 : : /* If there is a constructor involved, derive size[] from its shape. */
5232 : 38885 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5233 : : {
5234 : 24515 : gfc_ss_info *ss_info;
5235 : :
5236 : 24515 : ss_info = ss->info;
5237 : 24515 : info = &ss_info->data.array;
5238 : :
5239 : 24515 : if (ss_info->type == GFC_SS_CONSTRUCTOR && info->shape)
5240 : : {
5241 : 5198 : for (n = 0; n < loop->dimen; n++)
5242 : : {
5243 : 2731 : if (size[n] == NULL)
5244 : : {
5245 : 2731 : gcc_assert (info->shape[n]);
5246 : 2731 : size[n] = gfc_conv_mpz_to_tree (info->shape[n],
5247 : : gfc_index_integer_kind);
5248 : : }
5249 : : }
5250 : : break;
5251 : : }
5252 : : }
5253 : :
5254 : 41697 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5255 : : {
5256 : 24860 : stmtblock_t inner;
5257 : 24860 : gfc_ss_info *ss_info;
5258 : 24860 : gfc_expr *expr;
5259 : 24860 : locus *expr_loc;
5260 : 24860 : const char *expr_name;
5261 : 24860 : char *ref_name = NULL;
5262 : :
5263 : 24860 : if (!bounds_check_needed (ss))
5264 : 4409 : continue;
5265 : :
5266 : 20451 : ss_info = ss->info;
5267 : 20451 : expr = ss_info->expr;
5268 : 20451 : expr_loc = &expr->where;
5269 : 20451 : if (expr->ref)
5270 : 20417 : expr_name = ref_name = abridged_ref_name (expr, NULL);
5271 : : else
5272 : 34 : expr_name = expr->symtree->name;
5273 : :
5274 : 20451 : gfc_start_block (&inner);
5275 : :
5276 : : /* TODO: range checking for mapped dimensions. */
5277 : 20451 : info = &ss_info->data.array;
5278 : :
5279 : : /* This code only checks ranges. Elemental and vector
5280 : : dimensions are checked later. */
5281 : 64717 : for (n = 0; n < loop->dimen; n++)
5282 : : {
5283 : 23815 : dim = ss->dim[n];
5284 : 23815 : if (ss_info->type == GFC_SS_SECTION)
5285 : : {
5286 : 23781 : if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
5287 : 14 : continue;
5288 : :
5289 : 23767 : add_check_section_in_array_bounds (&inner, ss_info, dim);
5290 : : }
5291 : :
5292 : : /* Check the section sizes match. */
5293 : 23801 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
5294 : : gfc_array_index_type, info->end[dim],
5295 : : info->start[dim]);
5296 : 23801 : tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
5297 : : gfc_array_index_type, tmp,
5298 : : info->stride[dim]);
5299 : 23801 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
5300 : : gfc_array_index_type,
5301 : : gfc_index_one_node, tmp);
5302 : 23801 : tmp = fold_build2_loc (input_location, MAX_EXPR,
5303 : : gfc_array_index_type, tmp,
5304 : 23801 : build_int_cst (gfc_array_index_type, 0));
5305 : : /* We remember the size of the first section, and check all the
5306 : : others against this. */
5307 : 23801 : if (size[n])
5308 : : {
5309 : 7162 : tmp3 = fold_build2_loc (input_location, NE_EXPR,
5310 : : logical_type_node, tmp, size[n]);
5311 : 7162 : if (ss_info->type == GFC_SS_INTRINSIC)
5312 : 0 : msg = xasprintf ("Extent mismatch for dimension %d of the "
5313 : : "result of intrinsic '%s' (%%ld/%%ld)",
5314 : : dim + 1, expr_name);
5315 : : else
5316 : 7162 : msg = xasprintf ("Array bound mismatch for dimension %d "
5317 : : "of array '%s' (%%ld/%%ld)",
5318 : : dim + 1, expr_name);
5319 : :
5320 : 7162 : gfc_trans_runtime_check (true, false, tmp3, &inner,
5321 : : expr_loc, msg,
5322 : : fold_convert (long_integer_type_node, tmp),
5323 : : fold_convert (long_integer_type_node, size[n]));
5324 : :
5325 : 7162 : free (msg);
5326 : : }
5327 : : else
5328 : 16639 : size[n] = gfc_evaluate_now (tmp, &inner);
5329 : : }
5330 : :
5331 : 20451 : tmp = gfc_finish_block (&inner);
5332 : :
5333 : : /* For optional arguments, only check bounds if the argument is
5334 : : present. */
5335 : 20451 : if ((expr->symtree->n.sym->attr.optional
5336 : 20451 : || expr->symtree->n.sym->attr.not_always_present)
5337 : 308 : && expr->symtree->n.sym->attr.dummy)
5338 : 307 : tmp = build3_v (COND_EXPR,
5339 : : gfc_conv_expr_present (expr->symtree->n.sym),
5340 : : tmp, build_empty_stmt (input_location));
5341 : :
5342 : 20451 : gfc_add_expr_to_block (&block, tmp);
5343 : :
5344 : 20451 : free (ref_name);
5345 : : }
5346 : :
5347 : 16837 : tmp = gfc_finish_block (&block);
5348 : 16837 : gfc_add_expr_to_block (&outer_loop->pre, tmp);
5349 : : }
5350 : :
5351 : 172350 : for (loop = loop->nested; loop; loop = loop->next)
5352 : 2440 : gfc_conv_ss_startstride (loop);
5353 : 169910 : }
5354 : :
5355 : : /* Return true if both symbols could refer to the same data object. Does
5356 : : not take account of aliasing due to equivalence statements. */
5357 : :
5358 : : static bool
5359 : 13001 : symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym, bool lsym_pointer,
5360 : : bool lsym_target, bool rsym_pointer, bool rsym_target)
5361 : : {
5362 : : /* Aliasing isn't possible if the symbols have different base types,
5363 : : except for complex types where an inquiry reference (%RE, %IM) could
5364 : : alias with a real type with the same kind parameter. */
5365 : 13001 : if (!gfc_compare_types (&lsym->ts, &rsym->ts)
5366 : 13001 : && !(((lsym->ts.type == BT_COMPLEX && rsym->ts.type == BT_REAL)
5367 : 4502 : || (lsym->ts.type == BT_REAL && rsym->ts.type == BT_COMPLEX))
5368 : 76 : && lsym->ts.kind == rsym->ts.kind))
5369 : : return false;
5370 : :
5371 : : /* Pointers can point to other pointers and target objects. */
5372 : :
5373 : 8512 : if ((lsym_pointer && (rsym_pointer || rsym_target))
5374 : 8303 : || (rsym_pointer && (lsym_pointer || lsym_target)))
5375 : : return true;
5376 : :
5377 : : /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
5378 : : and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
5379 : : checked above. */
5380 : 8390 : if (lsym_target && rsym_target
5381 : 14 : && ((lsym->attr.dummy && !lsym->attr.contiguous
5382 : 0 : && (!lsym->attr.dimension || lsym->as->type == AS_ASSUMED_SHAPE))
5383 : 14 : || (rsym->attr.dummy && !rsym->attr.contiguous
5384 : 6 : && (!rsym->attr.dimension
5385 : 6 : || rsym->as->type == AS_ASSUMED_SHAPE))))
5386 : 6 : return true;
5387 : :
5388 : : return false;
5389 : : }
5390 : :
5391 : :
5392 : : /* Return true if the two SS could be aliased, i.e. both point to the same data
5393 : : object. */
5394 : : /* TODO: resolve aliases based on frontend expressions. */
5395 : :
5396 : : static int
5397 : 11078 : gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
5398 : : {
5399 : 11078 : gfc_ref *lref;
5400 : 11078 : gfc_ref *rref;
5401 : 11078 : gfc_expr *lexpr, *rexpr;
5402 : 11078 : gfc_symbol *lsym;
5403 : 11078 : gfc_symbol *rsym;
5404 : 11078 : bool lsym_pointer, lsym_target, rsym_pointer, rsym_target;
5405 : :
5406 : 11078 : lexpr = lss->info->expr;
5407 : 11078 : rexpr = rss->info->expr;
5408 : :
5409 : 11078 : lsym = lexpr->symtree->n.sym;
5410 : 11078 : rsym = rexpr->symtree->n.sym;
5411 : :
5412 : 11078 : lsym_pointer = lsym->attr.pointer;
5413 : 11078 : lsym_target = lsym->attr.target;
5414 : 11078 : rsym_pointer = rsym->attr.pointer;
5415 : 11078 : rsym_target = rsym->attr.target;
5416 : :
5417 : 11078 : if (symbols_could_alias (lsym, rsym, lsym_pointer, lsym_target,
5418 : : rsym_pointer, rsym_target))
5419 : : return 1;
5420 : :
5421 : 10988 : if (rsym->ts.type != BT_DERIVED && rsym->ts.type != BT_CLASS
5422 : 9857 : && lsym->ts.type != BT_DERIVED && lsym->ts.type != BT_CLASS)
5423 : : return 0;
5424 : :
5425 : : /* For derived types we must check all the component types. We can ignore
5426 : : array references as these will have the same base type as the previous
5427 : : component ref. */
5428 : 2358 : for (lref = lexpr->ref; lref != lss->info->data.array.ref; lref = lref->next)
5429 : : {
5430 : 859 : if (lref->type != REF_COMPONENT)
5431 : 89 : continue;
5432 : :
5433 : 770 : lsym_pointer = lsym_pointer || lref->u.c.sym->attr.pointer;
5434 : 770 : lsym_target = lsym_target || lref->u.c.sym->attr.target;
5435 : :
5436 : 770 : if (symbols_could_alias (lref->u.c.sym, rsym, lsym_pointer, lsym_target,
5437 : : rsym_pointer, rsym_target))
5438 : : return 1;
5439 : :
5440 : 770 : if ((lsym_pointer && (rsym_pointer || rsym_target))
5441 : 755 : || (rsym_pointer && (lsym_pointer || lsym_target)))
5442 : : {
5443 : 6 : if (gfc_compare_types (&lref->u.c.component->ts,
5444 : : &rsym->ts))
5445 : : return 1;
5446 : : }
5447 : :
5448 : 1174 : for (rref = rexpr->ref; rref != rss->info->data.array.ref;
5449 : 410 : rref = rref->next)
5450 : : {
5451 : 411 : if (rref->type != REF_COMPONENT)
5452 : 36 : continue;
5453 : :
5454 : 375 : rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
5455 : 375 : rsym_target = lsym_target || rref->u.c.sym->attr.target;
5456 : :
5457 : 375 : if (symbols_could_alias (lref->u.c.sym, rref->u.c.sym,
5458 : : lsym_pointer, lsym_target,
5459 : : rsym_pointer, rsym_target))
5460 : : return 1;
5461 : :
5462 : 374 : if ((lsym_pointer && (rsym_pointer || rsym_target))
5463 : 370 : || (rsym_pointer && (lsym_pointer || lsym_target)))
5464 : : {
5465 : 0 : if (gfc_compare_types (&lref->u.c.component->ts,
5466 : 0 : &rref->u.c.sym->ts))
5467 : : return 1;
5468 : 0 : if (gfc_compare_types (&lref->u.c.sym->ts,
5469 : 0 : &rref->u.c.component->ts))
5470 : : return 1;
5471 : 0 : if (gfc_compare_types (&lref->u.c.component->ts,
5472 : 0 : &rref->u.c.component->ts))
5473 : : return 1;
5474 : : }
5475 : : }
5476 : : }
5477 : :
5478 : 1499 : lsym_pointer = lsym->attr.pointer;
5479 : 1499 : lsym_target = lsym->attr.target;
5480 : :
5481 : 2271 : for (rref = rexpr->ref; rref != rss->info->data.array.ref; rref = rref->next)
5482 : : {
5483 : 925 : if (rref->type != REF_COMPONENT)
5484 : : break;
5485 : :
5486 : 778 : rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
5487 : 778 : rsym_target = lsym_target || rref->u.c.sym->attr.target;
5488 : :
5489 : 778 : if (symbols_could_alias (rref->u.c.sym, lsym,
5490 : : lsym_pointer, lsym_target,
5491 : : rsym_pointer, rsym_target))
5492 : : return 1;
5493 : :
5494 : 778 : if ((lsym_pointer && (rsym_pointer || rsym_target))
5495 : 760 : || (rsym_pointer && (lsym_pointer || lsym_target)))
5496 : : {
5497 : 6 : if (gfc_compare_types (&lsym->ts, &rref->u.c.component->ts))
5498 : : return 1;
5499 : : }
5500 : : }
5501 : :
5502 : : return 0;
5503 : : }
5504 : :
5505 : :
5506 : : /* Resolve array data dependencies. Creates a temporary if required. */
5507 : : /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
5508 : : dependency.cc. */
5509 : :
5510 : : void
5511 : 35538 : gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
5512 : : gfc_ss * rss)
5513 : : {
5514 : 35538 : gfc_ss *ss;
5515 : 35538 : gfc_ref *lref;
5516 : 35538 : gfc_ref *rref;
5517 : 35538 : gfc_ss_info *ss_info;
5518 : 35538 : gfc_expr *dest_expr;
5519 : 35538 : gfc_expr *ss_expr;
5520 : 35538 : int nDepend = 0;
5521 : 35538 : int i, j;
5522 : :
5523 : 35538 : loop->temp_ss = NULL;
5524 : 35538 : dest_expr = dest->info->expr;
5525 : :
5526 : 76595 : for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
5527 : : {
5528 : 42118 : ss_info = ss->info;
5529 : 42118 : ss_expr = ss_info->expr;
5530 : :
5531 : 42118 : if (ss_info->array_outer_dependency)
5532 : : {
5533 : : nDepend = 1;
5534 : : break;
5535 : : }
5536 : :
5537 : 42008 : if (ss_info->type != GFC_SS_SECTION)
5538 : : {
5539 : 28516 : if (flag_realloc_lhs
5540 : 27613 : && dest_expr != ss_expr
5541 : 27613 : && gfc_is_reallocatable_lhs (dest_expr)
5542 : 34744 : && ss_expr->rank)
5543 : 2775 : nDepend = gfc_check_dependency (dest_expr, ss_expr, true);
5544 : :
5545 : : /* Check for cases like c(:)(1:2) = c(2)(2:3) */
5546 : 28516 : if (!nDepend && dest_expr->rank > 0
5547 : 28107 : && dest_expr->ts.type == BT_CHARACTER
5548 : 4134 : && ss_expr->expr_type == EXPR_VARIABLE)
5549 : :
5550 : 157 : nDepend = gfc_check_dependency (dest_expr, ss_expr, false);
5551 : :
5552 : 28516 : if (ss_info->type == GFC_SS_REFERENCE
5553 : 28516 : && gfc_check_dependency (dest_expr, ss_expr, false))
5554 : 182 : ss_info->data.scalar.needs_temporary = 1;
5555 : :
5556 : 28516 : if (nDepend)
5557 : : break;
5558 : : else
5559 : 28095 : continue;
5560 : : }
5561 : :
5562 : 13492 : if (dest_expr->symtree->n.sym != ss_expr->symtree->n.sym)
5563 : : {
5564 : 11078 : if (gfc_could_be_alias (dest, ss)
5565 : 11078 : || gfc_are_equivalenced_arrays (dest_expr, ss_expr))
5566 : : {
5567 : : nDepend = 1;
5568 : : break;
5569 : : }
5570 : : }
5571 : : else
5572 : : {
5573 : 2414 : lref = dest_expr->ref;
5574 : 2414 : rref = ss_expr->ref;
5575 : :
5576 : 2414 : nDepend = gfc_dep_resolver (lref, rref, &loop->reverse[0]);
5577 : :
5578 : 2414 : if (nDepend == 1)
5579 : : break;
5580 : :
5581 : 4707 : for (i = 0; i < dest->dimen; i++)
5582 : 6354 : for (j = 0; j < ss->dimen; j++)
5583 : 3775 : if (i != j
5584 : 1133 : && dest->dim[i] == ss->dim[j])
5585 : : {
5586 : : /* If we don't access array elements in the same order,
5587 : : there is a dependency. */
5588 : 63 : nDepend = 1;
5589 : 63 : goto temporary;
5590 : : }
5591 : : #if 0
5592 : : /* TODO : loop shifting. */
5593 : : if (nDepend == 1)
5594 : : {
5595 : : /* Mark the dimensions for LOOP SHIFTING */
5596 : : for (n = 0; n < loop->dimen; n++)
5597 : : {
5598 : : int dim = dest->data.info.dim[n];
5599 : :
5600 : : if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
5601 : : depends[n] = 2;
5602 : : else if (! gfc_is_same_range (&lref->u.ar,
5603 : : &rref->u.ar, dim, 0))
5604 : : depends[n] = 1;
5605 : : }
5606 : :
5607 : : /* Put all the dimensions with dependencies in the
5608 : : innermost loops. */
5609 : : dim = 0;
5610 : : for (n = 0; n < loop->dimen; n++)
5611 : : {
5612 : : gcc_assert (loop->order[n] == n);
5613 : : if (depends[n])
5614 : : loop->order[dim++] = n;
5615 : : }
5616 : : for (n = 0; n < loop->dimen; n++)
5617 : : {
5618 : : if (! depends[n])
5619 : : loop->order[dim++] = n;
5620 : : }
5621 : :
5622 : : gcc_assert (dim == loop->dimen);
5623 : : break;
5624 : : }
5625 : : #endif
5626 : : }
5627 : : }
5628 : :
5629 : 707 : temporary:
5630 : :
5631 : 35538 : if (nDepend == 1)
5632 : : {
5633 : 1061 : tree base_type = gfc_typenode_for_spec (&dest_expr->ts);
5634 : 1061 : if (GFC_ARRAY_TYPE_P (base_type)
5635 : 1061 : || GFC_DESCRIPTOR_TYPE_P (base_type))
5636 : 0 : base_type = gfc_get_element_type (base_type);
5637 : 1061 : loop->temp_ss = gfc_get_temp_ss (base_type, dest->info->string_length,
5638 : : loop->dimen);
5639 : 1061 : gfc_add_ss_to_loop (loop, loop->temp_ss);
5640 : : }
5641 : : else
5642 : 34477 : loop->temp_ss = NULL;
5643 : 35538 : }
5644 : :
5645 : :
5646 : : /* Browse through each array's information from the scalarizer and set the loop
5647 : : bounds according to the "best" one (per dimension), i.e. the one which
5648 : : provides the most information (constant bounds, shape, etc.). */
5649 : :
5650 : : static void
5651 : 169910 : set_loop_bounds (gfc_loopinfo *loop)
5652 : : {
5653 : 169910 : int n, dim, spec_dim;
5654 : 169910 : gfc_array_info *info;
5655 : 169910 : gfc_array_info *specinfo;
5656 : 169910 : gfc_ss *ss;
5657 : 169910 : tree tmp;
5658 : 169910 : gfc_ss **loopspec;
5659 : 169910 : bool dynamic[GFC_MAX_DIMENSIONS];
5660 : 169910 : mpz_t *cshape;
5661 : 169910 : mpz_t i;
5662 : 169910 : bool nonoptional_arr;
5663 : :
5664 : 169910 : gfc_loopinfo * const outer_loop = outermost_loop (loop);
5665 : :
5666 : 169910 : loopspec = loop->specloop;
5667 : :
5668 : 169910 : mpz_init (i);
5669 : 399908 : for (n = 0; n < loop->dimen; n++)
5670 : : {
5671 : 229998 : loopspec[n] = NULL;
5672 : 229998 : dynamic[n] = false;
5673 : :
5674 : : /* If there are both optional and nonoptional array arguments, scalarize
5675 : : over the nonoptional; otherwise, it does not matter as then all
5676 : : (optional) arrays have to be present per F2008, 125.2.12p3(6). */
5677 : :
5678 : 229998 : nonoptional_arr = false;
5679 : :
5680 : 267624 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5681 : 267604 : if (ss->info->type != GFC_SS_SCALAR && ss->info->type != GFC_SS_TEMP
5682 : 234695 : && ss->info->type != GFC_SS_REFERENCE && !ss->info->can_be_null_ref)
5683 : : {
5684 : : nonoptional_arr = true;
5685 : : break;
5686 : : }
5687 : :
5688 : : /* We use one SS term, and use that to determine the bounds of the
5689 : : loop for this dimension. We try to pick the simplest term. */
5690 : 599302 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5691 : : {
5692 : 369304 : gfc_ss_type ss_type;
5693 : :
5694 : 369304 : ss_type = ss->info->type;
5695 : 430126 : if (ss_type == GFC_SS_SCALAR
5696 : 369304 : || ss_type == GFC_SS_TEMP
5697 : 315262 : || ss_type == GFC_SS_REFERENCE
5698 : 308759 : || (ss->info->can_be_null_ref && nonoptional_arr))
5699 : 60822 : continue;
5700 : :
5701 : 308482 : info = &ss->info->data.array;
5702 : 308482 : dim = ss->dim[n];
5703 : :
5704 : 308482 : if (loopspec[n] != NULL)
5705 : : {
5706 : 78484 : specinfo = &loopspec[n]->info->data.array;
5707 : 78484 : spec_dim = loopspec[n]->dim[n];
5708 : : }
5709 : : else
5710 : : {
5711 : : /* Silence uninitialized warnings. */
5712 : : specinfo = NULL;
5713 : : spec_dim = 0;
5714 : : }
5715 : :
5716 : 308482 : if (info->shape)
5717 : : {
5718 : : /* The frontend has worked out the size for us. */
5719 : 206920 : if (!loopspec[n]
5720 : 55948 : || !specinfo->shape
5721 : 251235 : || !integer_zerop (specinfo->start[spec_dim]))
5722 : : /* Prefer zero-based descriptors if possible. */
5723 : 190245 : loopspec[n] = ss;
5724 : 206920 : continue;
5725 : : }
5726 : :
5727 : 101562 : if (ss_type == GFC_SS_CONSTRUCTOR)
5728 : : {
5729 : 1266 : gfc_constructor_base base;
5730 : : /* An unknown size constructor will always be rank one.
5731 : : Higher rank constructors will either have known shape,
5732 : : or still be wrapped in a call to reshape. */
5733 : 1266 : gcc_assert (loop->dimen == 1);
5734 : :
5735 : : /* Always prefer to use the constructor bounds if the size
5736 : : can be determined at compile time. Prefer not to otherwise,
5737 : : since the general case involves realloc, and it's better to
5738 : : avoid that overhead if possible. */
5739 : 1266 : base = ss->info->expr->value.constructor;
5740 : 1266 : dynamic[n] = gfc_get_array_constructor_size (&i, base);
5741 : 1266 : if (!dynamic[n] || !loopspec[n])
5742 : 1081 : loopspec[n] = ss;
5743 : 1266 : continue;
5744 : 1266 : }
5745 : :
5746 : : /* Avoid using an allocatable lhs in an assignment, since
5747 : : there might be a reallocation coming. */
5748 : 100296 : if (loopspec[n] && ss->is_alloc_lhs)
5749 : 6323 : continue;
5750 : :
5751 : 93973 : if (!loopspec[n])
5752 : 77945 : loopspec[n] = ss;
5753 : : /* Criteria for choosing a loop specifier (most important first):
5754 : : doesn't need realloc
5755 : : stride of one
5756 : : known stride
5757 : : known lower bound
5758 : : known upper bound
5759 : : */
5760 : 16028 : else if (loopspec[n]->info->type == GFC_SS_CONSTRUCTOR && dynamic[n])
5761 : 172 : loopspec[n] = ss;
5762 : 15856 : else if (integer_onep (info->stride[dim])
5763 : 15856 : && !integer_onep (specinfo->stride[spec_dim]))
5764 : 120 : loopspec[n] = ss;
5765 : 15736 : else if (INTEGER_CST_P (info->stride[dim])
5766 : 15548 : && !INTEGER_CST_P (specinfo->stride[spec_dim]))
5767 : 0 : loopspec[n] = ss;
5768 : 15736 : else if (INTEGER_CST_P (info->start[dim])
5769 : 4181 : && !INTEGER_CST_P (specinfo->start[spec_dim])
5770 : 744 : && integer_onep (info->stride[dim])
5771 : 372 : == integer_onep (specinfo->stride[spec_dim])
5772 : 15736 : && INTEGER_CST_P (info->stride[dim])
5773 : 345 : == INTEGER_CST_P (specinfo->stride[spec_dim]))
5774 : 345 : loopspec[n] = ss;
5775 : : /* We don't work out the upper bound.
5776 : : else if (INTEGER_CST_P (info->finish[n])
5777 : : && ! INTEGER_CST_P (specinfo->finish[n]))
5778 : : loopspec[n] = ss; */
5779 : : }
5780 : :
5781 : : /* We should have found the scalarization loop specifier. If not,
5782 : : that's bad news. */
5783 : 229998 : gcc_assert (loopspec[n]);
5784 : :
5785 : 229998 : info = &loopspec[n]->info->data.array;
5786 : 229998 : dim = loopspec[n]->dim[n];
5787 : :
5788 : : /* Set the extents of this range. */
5789 : 229998 : cshape = info->shape;
5790 : 229998 : if (cshape && INTEGER_CST_P (info->start[dim])
5791 : 162406 : && INTEGER_CST_P (info->stride[dim]))
5792 : : {
5793 : 162406 : loop->from[n] = info->start[dim];
5794 : 162406 : mpz_set (i, cshape[get_array_ref_dim_for_loop_dim (loopspec[n], n)]);
5795 : 162406 : mpz_sub_ui (i, i, 1);
5796 : : /* To = from + (size - 1) * stride. */
5797 : 162406 : tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
5798 : 162406 : if (!integer_onep (info->stride[dim]))
5799 : 8328 : tmp = fold_build2_loc (input_location, MULT_EXPR,
5800 : : gfc_array_index_type, tmp,
5801 : : info->stride[dim]);
5802 : 162406 : loop->to[n] = fold_build2_loc (input_location, PLUS_EXPR,
5803 : : gfc_array_index_type,
5804 : : loop->from[n], tmp);
5805 : : }
5806 : : else
5807 : : {
5808 : 67592 : loop->from[n] = info->start[dim];
5809 : 67592 : switch (loopspec[n]->info->type)
5810 : : {
5811 : 810 : case GFC_SS_CONSTRUCTOR:
5812 : : /* The upper bound is calculated when we expand the
5813 : : constructor. */
5814 : 810 : gcc_assert (loop->to[n] == NULL_TREE);
5815 : : break;
5816 : :
5817 : 61425 : case GFC_SS_SECTION:
5818 : : /* Use the end expression if it exists and is not constant,
5819 : : so that it is only evaluated once. */
5820 : 61425 : loop->to[n] = info->end[dim];
5821 : 61425 : break;
5822 : :
5823 : 4596 : case GFC_SS_FUNCTION:
5824 : : /* The loop bound will be set when we generate the call. */
5825 : 4596 : gcc_assert (loop->to[n] == NULL_TREE);
5826 : : break;
5827 : :
5828 : 755 : case GFC_SS_INTRINSIC:
5829 : 755 : {
5830 : 755 : gfc_expr *expr = loopspec[n]->info->expr;
5831 : :
5832 : : /* The {l,u}bound of an assumed rank. */
5833 : 755 : if (expr->value.function.isym->id == GFC_ISYM_SHAPE)
5834 : 243 : gcc_assert (expr->value.function.actual->expr->rank == -1);
5835 : : else
5836 : 512 : gcc_assert ((expr->value.function.isym->id == GFC_ISYM_LBOUND
5837 : : || expr->value.function.isym->id == GFC_ISYM_UBOUND)
5838 : : && expr->value.function.actual->next->expr == NULL
5839 : : && expr->value.function.actual->expr->rank == -1);
5840 : :
5841 : 755 : loop->to[n] = info->end[dim];
5842 : 755 : break;
5843 : : }
5844 : :
5845 : 6 : case GFC_SS_COMPONENT:
5846 : 6 : {
5847 : 6 : if (info->end[dim] != NULL_TREE)
5848 : : {
5849 : 6 : loop->to[n] = info->end[dim];
5850 : 6 : break;
5851 : : }
5852 : : else
5853 : 0 : gcc_unreachable ();
5854 : : }
5855 : :
5856 : 0 : default:
5857 : 0 : gcc_unreachable ();
5858 : : }
5859 : : }
5860 : :
5861 : : /* Transform everything so we have a simple incrementing variable. */
5862 : 229998 : if (integer_onep (info->stride[dim]))
5863 : 219751 : info->delta[dim] = gfc_index_zero_node;
5864 : : else
5865 : : {
5866 : : /* Set the delta for this section. */
5867 : 10247 : info->delta[dim] = gfc_evaluate_now (loop->from[n], &outer_loop->pre);
5868 : : /* Number of iterations is (end - start + step) / step.
5869 : : with start = 0, this simplifies to
5870 : : last = end / step;
5871 : : for (i = 0; i<=last; i++){...}; */
5872 : 10247 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
5873 : : gfc_array_index_type, loop->to[n],
5874 : : loop->from[n]);
5875 : 10247 : tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
5876 : : gfc_array_index_type, tmp, info->stride[dim]);
5877 : 10247 : tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
5878 : 10247 : tmp, build_int_cst (gfc_array_index_type, -1));
5879 : 10247 : loop->to[n] = gfc_evaluate_now (tmp, &outer_loop->pre);
5880 : : /* Make the loop variable start at 0. */
5881 : 10247 : loop->from[n] = gfc_index_zero_node;
5882 : : }
5883 : : }
5884 : 169910 : mpz_clear (i);
5885 : :
5886 : 172350 : for (loop = loop->nested; loop; loop = loop->next)
5887 : 2440 : set_loop_bounds (loop);
5888 : 169910 : }
5889 : :
5890 : :
5891 : : /* Initialize the scalarization loop. Creates the loop variables. Determines
5892 : : the range of the loop variables. Creates a temporary if required.
5893 : : Also generates code for scalar expressions which have been
5894 : : moved outside the loop. */
5895 : :
5896 : : void
5897 : 167470 : gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
5898 : : {
5899 : 167470 : gfc_ss *tmp_ss;
5900 : 167470 : tree tmp;
5901 : :
5902 : 167470 : set_loop_bounds (loop);
5903 : :
5904 : : /* Add all the scalar code that can be taken out of the loops.
5905 : : This may include calculating the loop bounds, so do it before
5906 : : allocating the temporary. */
5907 : 167470 : gfc_add_loop_ss_code (loop, loop->ss, false, where);
5908 : :
5909 : 167470 : tmp_ss = loop->temp_ss;
5910 : : /* If we want a temporary then create it. */
5911 : 167470 : if (tmp_ss != NULL)
5912 : : {
5913 : 11080 : gfc_ss_info *tmp_ss_info;
5914 : :
5915 : 11080 : tmp_ss_info = tmp_ss->info;
5916 : 11080 : gcc_assert (tmp_ss_info->type == GFC_SS_TEMP);
5917 : 11080 : gcc_assert (loop->parent == NULL);
5918 : :
5919 : : /* Make absolutely sure that this is a complete type. */
5920 : 11080 : if (tmp_ss_info->string_length)
5921 : 2648 : tmp_ss_info->data.temp.type
5922 : 2648 : = gfc_get_character_type_len_for_eltype
5923 : 2648 : (TREE_TYPE (tmp_ss_info->data.temp.type),
5924 : : tmp_ss_info->string_length);
5925 : :
5926 : 11080 : tmp = tmp_ss_info->data.temp.type;
5927 : 11080 : memset (&tmp_ss_info->data.array, 0, sizeof (gfc_array_info));
5928 : 11080 : tmp_ss_info->type = GFC_SS_SECTION;
5929 : :
5930 : 11080 : gcc_assert (tmp_ss->dimen != 0);
5931 : :
5932 : 11080 : gfc_trans_create_temp_array (&loop->pre, &loop->post, tmp_ss, tmp,
5933 : : NULL_TREE, false, true, false, where);
5934 : : }
5935 : :
5936 : : /* For array parameters we don't have loop variables, so don't calculate the
5937 : : translations. */
5938 : 167470 : if (!loop->array_parameter)
5939 : 103727 : gfc_set_delta (loop);
5940 : 167470 : }
5941 : :
5942 : :
5943 : : /* Calculates how to transform from loop variables to array indices for each
5944 : : array: once loop bounds are chosen, sets the difference (DELTA field) between
5945 : : loop bounds and array reference bounds, for each array info. */
5946 : :
5947 : : void
5948 : 106598 : gfc_set_delta (gfc_loopinfo *loop)
5949 : : {
5950 : 106598 : gfc_ss *ss, **loopspec;
5951 : 106598 : gfc_array_info *info;
5952 : 106598 : tree tmp;
5953 : 106598 : int n, dim;
5954 : :
5955 : 106598 : gfc_loopinfo * const outer_loop = outermost_loop (loop);
5956 : :
5957 : 106598 : loopspec = loop->specloop;
5958 : :
5959 : : /* Calculate the translation from loop variables to array indices. */
5960 : 323171 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5961 : : {
5962 : 216573 : gfc_ss_type ss_type;
5963 : :
5964 : 216573 : ss_type = ss->info->type;
5965 : 216573 : if (ss_type != GFC_SS_SECTION
5966 : 216573 : && ss_type != GFC_SS_COMPONENT
5967 : 87343 : && ss_type != GFC_SS_CONSTRUCTOR)
5968 : 53315 : continue;
5969 : :
5970 : : info = &ss->info->data.array;
5971 : :
5972 : 366911 : for (n = 0; n < ss->dimen; n++)
5973 : : {
5974 : : /* If we are specifying the range the delta is already set. */
5975 : 203653 : if (loopspec[n] != ss)
5976 : : {
5977 : 108695 : dim = ss->dim[n];
5978 : :
5979 : : /* Calculate the offset relative to the loop variable.
5980 : : First multiply by the stride. */
5981 : 108695 : tmp = loop->from[n];
5982 : 108695 : if (!integer_onep (info->stride[dim]))
5983 : 2927 : tmp = fold_build2_loc (input_location, MULT_EXPR,
5984 : : gfc_array_index_type,
5985 : : tmp, info->stride[dim]);
5986 : :
5987 : : /* Then subtract this from our starting value. */
5988 : 108695 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
5989 : : gfc_array_index_type,
5990 : : info->start[dim], tmp);
5991 : :
5992 : 108695 : info->delta[dim] = gfc_evaluate_now (tmp, &outer_loop->pre);
5993 : : }
5994 : : }
5995 : : }
5996 : :
5997 : 109126 : for (loop = loop->nested; loop; loop = loop->next)
5998 : 2528 : gfc_set_delta (loop);
5999 : 106598 : }
6000 : :
6001 : :
6002 : : /* Calculate the size of a given array dimension from the bounds. This
6003 : : is simply (ubound - lbound + 1) if this expression is positive
6004 : : or 0 if it is negative (pick either one if it is zero). Optionally
6005 : : (if or_expr is present) OR the (expression != 0) condition to it. */
6006 : :
6007 : : tree
6008 : 21960 : gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr)
6009 : : {
6010 : 21960 : tree res;
6011 : 21960 : tree cond;
6012 : :
6013 : : /* Calculate (ubound - lbound + 1). */
6014 : 21960 : res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6015 : : ubound, lbound);
6016 : 21960 : res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res,
6017 : : gfc_index_one_node);
6018 : :
6019 : : /* Check whether the size for this dimension is negative. */
6020 : 21960 : cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, res,
6021 : : gfc_index_zero_node);
6022 : 21960 : res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
6023 : : gfc_index_zero_node, res);
6024 : :
6025 : : /* Build OR expression. */
6026 : 21960 : if (or_expr)
6027 : 17083 : *or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
6028 : : logical_type_node, *or_expr, cond);
6029 : :
6030 : 21960 : return res;
6031 : : }
6032 : :
6033 : :
6034 : : /* For an array descriptor, get the total number of elements. This is just
6035 : : the product of the extents along from_dim to to_dim. */
6036 : :
6037 : : static tree
6038 : 1832 : gfc_conv_descriptor_size_1 (tree desc, int from_dim, int to_dim)
6039 : : {
6040 : 1832 : tree res;
6041 : 1832 : int dim;
6042 : :
6043 : 1832 : res = gfc_index_one_node;
6044 : :
6045 : 4463 : for (dim = from_dim; dim < to_dim; ++dim)
6046 : : {
6047 : 2631 : tree lbound;
6048 : 2631 : tree ubound;
6049 : 2631 : tree extent;
6050 : :
6051 : 2631 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
6052 : 2631 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
6053 : :
6054 : 2631 : extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
6055 : 2631 : res = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6056 : : res, extent);
6057 : : }
6058 : :
6059 : 1832 : return res;
6060 : : }
6061 : :
6062 : :
6063 : : /* Full size of an array. */
6064 : :
6065 : : tree
6066 : 1802 : gfc_conv_descriptor_size (tree desc, int rank)
6067 : : {
6068 : 1802 : return gfc_conv_descriptor_size_1 (desc, 0, rank);
6069 : : }
6070 : :
6071 : :
6072 : : /* Size of a coarray for all dimensions but the last. */
6073 : :
6074 : : tree
6075 : 30 : gfc_conv_descriptor_cosize (tree desc, int rank, int corank)
6076 : : {
6077 : 30 : return gfc_conv_descriptor_size_1 (desc, rank, rank + corank - 1);
6078 : : }
6079 : :
6080 : :
6081 : : /* Fills in an array descriptor, and returns the size of the array.
6082 : : The size will be a simple_val, ie a variable or a constant. Also
6083 : : calculates the offset of the base. The pointer argument overflow,
6084 : : which should be of integer type, will increase in value if overflow
6085 : : occurs during the size calculation. Returns the size of the array.
6086 : : {
6087 : : stride = 1;
6088 : : offset = 0;
6089 : : for (n = 0; n < rank; n++)
6090 : : {
6091 : : a.lbound[n] = specified_lower_bound;
6092 : : offset = offset + a.lbond[n] * stride;
6093 : : size = 1 - lbound;
6094 : : a.ubound[n] = specified_upper_bound;
6095 : : a.stride[n] = stride;
6096 : : size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
6097 : : overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
6098 : : stride = stride * size;
6099 : : }
6100 : : for (n = rank; n < rank+corank; n++)
6101 : : (Set lcobound/ucobound as above.)
6102 : : element_size = sizeof (array element);
6103 : : if (!rank)
6104 : : return element_size
6105 : : stride = (size_t) stride;
6106 : : overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
6107 : : stride = stride * element_size;
6108 : : return (stride);
6109 : : } */
6110 : : /*GCC ARRAYS*/
6111 : :
6112 : : static tree
6113 : 11516 : gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
6114 : : gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
6115 : : stmtblock_t * descriptor_block, tree * overflow,
6116 : : tree expr3_elem_size, tree *nelems, gfc_expr *expr3,
6117 : : tree expr3_desc, bool e3_has_nodescriptor, gfc_expr *expr,
6118 : : tree *element_size, bool explicit_ts)
6119 : : {
6120 : 11516 : tree type;
6121 : 11516 : tree tmp;
6122 : 11516 : tree size;
6123 : 11516 : tree offset;
6124 : 11516 : tree stride;
6125 : 11516 : tree or_expr;
6126 : 11516 : tree thencase;
6127 : 11516 : tree elsecase;
6128 : 11516 : tree cond;
6129 : 11516 : tree var;
6130 : 11516 : stmtblock_t thenblock;
6131 : 11516 : stmtblock_t elseblock;
6132 : 11516 : gfc_expr *ubound;
6133 : 11516 : gfc_se se;
6134 : 11516 : int n;
6135 : :
6136 : 11516 : type = TREE_TYPE (descriptor);
6137 : :
6138 : 11516 : stride = gfc_index_one_node;
6139 : 11516 : offset = gfc_index_zero_node;
6140 : :
6141 : : /* Set the dtype before the alloc, because registration of coarrays needs
6142 : : it initialized. */
6143 : 11516 : if (expr->ts.type == BT_CHARACTER
6144 : 989 : && expr->ts.deferred
6145 : 482 : && VAR_P (expr->ts.u.cl->backend_decl))
6146 : : {
6147 : 305 : type = gfc_typenode_for_spec (&expr->ts);
6148 : 305 : tmp = gfc_conv_descriptor_dtype (descriptor);
6149 : 305 : gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type));
6150 : : }
6151 : 11211 : else if (expr->ts.type == BT_CHARACTER
6152 : 684 : && expr->ts.deferred
6153 : 177 : && TREE_CODE (descriptor) == COMPONENT_REF)
6154 : : {
6155 : : /* Deferred character components have their string length tucked away
6156 : : in a hidden field of the derived type. Obtain that and use it to
6157 : : set the dtype. The charlen backend decl is zero because the field
6158 : : type is zero length. */
6159 : 159 : gfc_ref *ref;
6160 : 159 : tmp = NULL_TREE;
6161 : 159 : for (ref = expr->ref; ref; ref = ref->next)
6162 : 159 : if (ref->type == REF_COMPONENT
6163 : 159 : && gfc_deferred_strlen (ref->u.c.component, &tmp))
6164 : : break;
6165 : 159 : gcc_assert (tmp != NULL_TREE);
6166 : 159 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
6167 : 159 : TREE_OPERAND (descriptor, 0), tmp, NULL_TREE);
6168 : 159 : tmp = fold_convert (gfc_charlen_type_node, tmp);
6169 : 159 : type = gfc_get_character_type_len (expr->ts.kind, tmp);
6170 : 159 : tmp = gfc_conv_descriptor_dtype (descriptor);
6171 : 159 : gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type));
6172 : 159 : }
6173 : 11052 : else if (expr3_desc && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr3_desc)))
6174 : : {
6175 : 889 : tmp = gfc_conv_descriptor_dtype (descriptor);
6176 : 889 : gfc_add_modify (pblock, tmp, gfc_conv_descriptor_dtype (expr3_desc));
6177 : : }
6178 : 10163 : else if (expr->ts.type == BT_CLASS && !explicit_ts
6179 : 1240 : && expr3 && expr3->ts.type != BT_CLASS
6180 : 343 : && expr3_elem_size != NULL_TREE && expr3_desc == NULL_TREE)
6181 : : {
6182 : 343 : tmp = gfc_conv_descriptor_elem_len (descriptor);
6183 : 343 : gfc_add_modify (pblock, tmp,
6184 : 343 : fold_convert (TREE_TYPE (tmp), expr3_elem_size));
6185 : : }
6186 : : else
6187 : : {
6188 : 9820 : tmp = gfc_conv_descriptor_dtype (descriptor);
6189 : 9820 : gfc_add_modify (pblock, tmp, gfc_get_dtype (type));
6190 : : }
6191 : :
6192 : 11516 : or_expr = logical_false_node;
6193 : :
6194 : 28599 : for (n = 0; n < rank; n++)
6195 : : {
6196 : 17083 : tree conv_lbound;
6197 : 17083 : tree conv_ubound;
6198 : :
6199 : : /* We have 3 possibilities for determining the size of the array:
6200 : : lower == NULL => lbound = 1, ubound = upper[n]
6201 : : upper[n] = NULL => lbound = 1, ubound = lower[n]
6202 : : upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
6203 : 17083 : ubound = upper[n];
6204 : :
6205 : : /* Set lower bound. */
6206 : 17083 : gfc_init_se (&se, NULL);
6207 : 17083 : if (expr3_desc != NULL_TREE)
6208 : : {
6209 : 1352 : if (e3_has_nodescriptor)
6210 : : /* The lbound of nondescriptor arrays like array constructors,
6211 : : nonallocatable/nonpointer function results/variables,
6212 : : start at zero, but when allocating it, the standard expects
6213 : : the array to start at one. */
6214 : 863 : se.expr = gfc_index_one_node;
6215 : : else
6216 : 489 : se.expr = gfc_conv_descriptor_lbound_get (expr3_desc,
6217 : : gfc_rank_cst[n]);
6218 : : }
6219 : 15731 : else if (lower == NULL)
6220 : 12713 : se.expr = gfc_index_one_node;
6221 : : else
6222 : : {
6223 : 3018 : gcc_assert (lower[n]);
6224 : 3018 : if (ubound)
6225 : : {
6226 : 2369 : gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
6227 : 2369 : gfc_add_block_to_block (pblock, &se.pre);
6228 : : }
6229 : : else
6230 : : {
6231 : 649 : se.expr = gfc_index_one_node;
6232 : 649 : ubound = lower[n];
6233 : : }
6234 : : }
6235 : 17083 : gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
6236 : : gfc_rank_cst[n], se.expr);
6237 : 17083 : conv_lbound = se.expr;
6238 : :
6239 : : /* Work out the offset for this component. */
6240 : 17083 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6241 : : se.expr, stride);
6242 : 17083 : offset = fold_build2_loc (input_location, MINUS_EXPR,
6243 : : gfc_array_index_type, offset, tmp);
6244 : :
6245 : : /* Set upper bound. */
6246 : 17083 : gfc_init_se (&se, NULL);
6247 : 17083 : if (expr3_desc != NULL_TREE)
6248 : : {
6249 : 1352 : if (e3_has_nodescriptor)
6250 : : {
6251 : : /* The lbound of nondescriptor arrays like array constructors,
6252 : : nonallocatable/nonpointer function results/variables,
6253 : : start at zero, but when allocating it, the standard expects
6254 : : the array to start at one. Therefore fix the upper bound to be
6255 : : (desc.ubound - desc.lbound) + 1. */
6256 : 863 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
6257 : : gfc_array_index_type,
6258 : : gfc_conv_descriptor_ubound_get (
6259 : : expr3_desc, gfc_rank_cst[n]),
6260 : : gfc_conv_descriptor_lbound_get (
6261 : : expr3_desc, gfc_rank_cst[n]));
6262 : 863 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
6263 : : gfc_array_index_type, tmp,
6264 : : gfc_index_one_node);
6265 : 863 : se.expr = gfc_evaluate_now (tmp, pblock);
6266 : : }
6267 : : else
6268 : 489 : se.expr = gfc_conv_descriptor_ubound_get (expr3_desc,
6269 : : gfc_rank_cst[n]);
6270 : : }
6271 : : else
6272 : : {
6273 : 15731 : gcc_assert (ubound);
6274 : 15731 : gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
6275 : 15731 : gfc_add_block_to_block (pblock, &se.pre);
6276 : 15731 : if (ubound->expr_type == EXPR_FUNCTION)
6277 : 712 : se.expr = gfc_evaluate_now (se.expr, pblock);
6278 : : }
6279 : 17083 : gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
6280 : : gfc_rank_cst[n], se.expr);
6281 : 17083 : conv_ubound = se.expr;
6282 : :
6283 : : /* Store the stride. */
6284 : 17083 : gfc_conv_descriptor_stride_set (descriptor_block, descriptor,
6285 : : gfc_rank_cst[n], stride);
6286 : :
6287 : : /* Calculate size and check whether extent is negative. */
6288 : 17083 : size = gfc_conv_array_extent_dim (conv_lbound, conv_ubound, &or_expr);
6289 : 17083 : size = gfc_evaluate_now (size, pblock);
6290 : :
6291 : : /* Check whether multiplying the stride by the number of
6292 : : elements in this dimension would overflow. We must also check
6293 : : whether the current dimension has zero size in order to avoid
6294 : : division by zero.
6295 : : */
6296 : 17083 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
6297 : : gfc_array_index_type,
6298 : 17083 : fold_convert (gfc_array_index_type,
6299 : : TYPE_MAX_VALUE (gfc_array_index_type)),
6300 : : size);
6301 : 17083 : cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
6302 : : logical_type_node, tmp, stride),
6303 : : PRED_FORTRAN_OVERFLOW);
6304 : 17083 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
6305 : : integer_one_node, integer_zero_node);
6306 : 17083 : cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
6307 : : logical_type_node, size,
6308 : : gfc_index_zero_node),
6309 : : PRED_FORTRAN_SIZE_ZERO);
6310 : 17083 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
6311 : : integer_zero_node, tmp);
6312 : 17083 : tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
6313 : : *overflow, tmp);
6314 : 17083 : *overflow = gfc_evaluate_now (tmp, pblock);
6315 : :
6316 : : /* Multiply the stride by the number of elements in this dimension. */
6317 : 17083 : stride = fold_build2_loc (input_location, MULT_EXPR,
6318 : : gfc_array_index_type, stride, size);
6319 : 17083 : stride = gfc_evaluate_now (stride, pblock);
6320 : : }
6321 : :
6322 : 12023 : for (n = rank; n < rank + corank; n++)
6323 : : {
6324 : 507 : ubound = upper[n];
6325 : :
6326 : : /* Set lower bound. */
6327 : 507 : gfc_init_se (&se, NULL);
6328 : 507 : if (lower == NULL || lower[n] == NULL)
6329 : : {
6330 : 287 : gcc_assert (n == rank + corank - 1);
6331 : 287 : se.expr = gfc_index_one_node;
6332 : : }
6333 : : else
6334 : : {
6335 : 220 : if (ubound || n == rank + corank - 1)
6336 : : {
6337 : 142 : gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
6338 : 142 : gfc_add_block_to_block (pblock, &se.pre);
6339 : : }
6340 : : else
6341 : : {
6342 : 78 : se.expr = gfc_index_one_node;
6343 : 78 : ubound = lower[n];
6344 : : }
6345 : : }
6346 : 507 : gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
6347 : : gfc_rank_cst[n], se.expr);
6348 : :
6349 : 507 : if (n < rank + corank - 1)
6350 : : {
6351 : 147 : gfc_init_se (&se, NULL);
6352 : 147 : gcc_assert (ubound);
6353 : 147 : gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
6354 : 147 : gfc_add_block_to_block (pblock, &se.pre);
6355 : 147 : gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
6356 : : gfc_rank_cst[n], se.expr);
6357 : : }
6358 : : }
6359 : :
6360 : : /* The stride is the number of elements in the array, so multiply by the
6361 : : size of an element to get the total size. Obviously, if there is a
6362 : : SOURCE expression (expr3) we must use its element size. */
6363 : 11516 : if (expr3_elem_size != NULL_TREE)
6364 : 2857 : tmp = expr3_elem_size;
6365 : 8659 : else if (expr3 != NULL)
6366 : : {
6367 : 0 : if (expr3->ts.type == BT_CLASS)
6368 : : {
6369 : 0 : gfc_se se_sz;
6370 : 0 : gfc_expr *sz = gfc_copy_expr (expr3);
6371 : 0 : gfc_add_vptr_component (sz);
6372 : 0 : gfc_add_size_component (sz);
6373 : 0 : gfc_init_se (&se_sz, NULL);
6374 : 0 : gfc_conv_expr (&se_sz, sz);
6375 : 0 : gfc_free_expr (sz);
6376 : 0 : tmp = se_sz.expr;
6377 : : }
6378 : : else
6379 : : {
6380 : 0 : tmp = gfc_typenode_for_spec (&expr3->ts);
6381 : 0 : tmp = TYPE_SIZE_UNIT (tmp);
6382 : : }
6383 : : }
6384 : : else
6385 : 8659 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
6386 : :
6387 : : /* Convert to size_t. */
6388 : 11516 : *element_size = fold_convert (size_type_node, tmp);
6389 : :
6390 : 11516 : if (rank == 0)
6391 : : return *element_size;
6392 : :
6393 : 11359 : *nelems = gfc_evaluate_now (stride, pblock);
6394 : 11359 : stride = fold_convert (size_type_node, stride);
6395 : :
6396 : : /* First check for overflow. Since an array of type character can
6397 : : have zero element_size, we must check for that before
6398 : : dividing. */
6399 : 11359 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
6400 : : size_type_node,
6401 : 11359 : TYPE_MAX_VALUE (size_type_node), *element_size);
6402 : 11359 : cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
6403 : : logical_type_node, tmp, stride),
6404 : : PRED_FORTRAN_OVERFLOW);
6405 : 11359 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
6406 : : integer_one_node, integer_zero_node);
6407 : 11359 : cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
6408 : : logical_type_node, *element_size,
6409 : 11359 : build_int_cst (size_type_node, 0)),
6410 : : PRED_FORTRAN_SIZE_ZERO);
6411 : 11359 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
6412 : : integer_zero_node, tmp);
6413 : 11359 : tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
6414 : : *overflow, tmp);
6415 : 11359 : *overflow = gfc_evaluate_now (tmp, pblock);
6416 : :
6417 : 11359 : size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
6418 : : stride, *element_size);
6419 : :
6420 : 11359 : if (poffset != NULL)
6421 : : {
6422 : 11359 : offset = gfc_evaluate_now (offset, pblock);
6423 : 11359 : *poffset = offset;
6424 : : }
6425 : :
6426 : 11359 : if (integer_zerop (or_expr))
6427 : : return size;
6428 : 3459 : if (integer_onep (or_expr))
6429 : 593 : return build_int_cst (size_type_node, 0);
6430 : :
6431 : 2866 : var = gfc_create_var (TREE_TYPE (size), "size");
6432 : 2866 : gfc_start_block (&thenblock);
6433 : 2866 : gfc_add_modify (&thenblock, var, build_int_cst (size_type_node, 0));
6434 : 2866 : thencase = gfc_finish_block (&thenblock);
6435 : :
6436 : 2866 : gfc_start_block (&elseblock);
6437 : 2866 : gfc_add_modify (&elseblock, var, size);
6438 : 2866 : elsecase = gfc_finish_block (&elseblock);
6439 : :
6440 : 2866 : tmp = gfc_evaluate_now (or_expr, pblock);
6441 : 2866 : tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
6442 : 2866 : gfc_add_expr_to_block (pblock, tmp);
6443 : :
6444 : 2866 : return var;
6445 : : }
6446 : :
6447 : :
6448 : : /* Retrieve the last ref from the chain. This routine is specific to
6449 : : gfc_array_allocate ()'s needs. */
6450 : :
6451 : : bool
6452 : 17620 : retrieve_last_ref (gfc_ref **ref_in, gfc_ref **prev_ref_in)
6453 : : {
6454 : 17620 : gfc_ref *ref, *prev_ref;
6455 : :
6456 : 17620 : ref = *ref_in;
6457 : : /* Prevent warnings for uninitialized variables. */
6458 : 17620 : prev_ref = *prev_ref_in;
6459 : 24016 : while (ref && ref->next != NULL)
6460 : : {
6461 : 6396 : gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
6462 : : || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
6463 : : prev_ref = ref;
6464 : : ref = ref->next;
6465 : : }
6466 : :
6467 : 17620 : if (ref == NULL || ref->type != REF_ARRAY)
6468 : : return false;
6469 : :
6470 : 12658 : *ref_in = ref;
6471 : 12658 : *prev_ref_in = prev_ref;
6472 : 12658 : return true;
6473 : : }
6474 : :
6475 : : /* Initializes the descriptor and generates a call to _gfor_allocate. Does
6476 : : the work for an ALLOCATE statement. */
6477 : : /*GCC ARRAYS*/
6478 : :
6479 : : bool
6480 : 16478 : gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
6481 : : tree errlen, tree label_finish, tree expr3_elem_size,
6482 : : tree *nelems, gfc_expr *expr3, tree e3_arr_desc,
6483 : : bool e3_has_nodescriptor, gfc_omp_namelist *omp_alloc,
6484 : : bool explicit_ts)
6485 : : {
6486 : 16478 : tree tmp;
6487 : 16478 : tree pointer;
6488 : 16478 : tree offset = NULL_TREE;
6489 : 16478 : tree token = NULL_TREE;
6490 : 16478 : tree size;
6491 : 16478 : tree msg;
6492 : 16478 : tree error = NULL_TREE;
6493 : 16478 : tree overflow; /* Boolean storing whether size calculation overflows. */
6494 : 16478 : tree var_overflow = NULL_TREE;
6495 : 16478 : tree cond;
6496 : 16478 : tree set_descriptor;
6497 : 16478 : tree not_prev_allocated = NULL_TREE;
6498 : 16478 : tree element_size = NULL_TREE;
6499 : 16478 : stmtblock_t set_descriptor_block;
6500 : 16478 : stmtblock_t elseblock;
6501 : 16478 : gfc_expr **lower;
6502 : 16478 : gfc_expr **upper;
6503 : 16478 : gfc_ref *ref, *prev_ref = NULL, *coref;
6504 : 16478 : bool allocatable, coarray, dimension, alloc_w_e3_arr_spec = false,
6505 : : non_ulimate_coarray_ptr_comp;
6506 : 16478 : tree omp_cond = NULL_TREE, omp_alt_alloc = NULL_TREE;
6507 : :
6508 : 16478 : ref = expr->ref;
6509 : :
6510 : : /* Find the last reference in the chain. */
6511 : 16478 : if (!retrieve_last_ref (&ref, &prev_ref))
6512 : : return false;
6513 : :
6514 : : /* Take the allocatable and coarray properties solely from the expr-ref's
6515 : : attributes and not from source=-expression. */
6516 : 11516 : if (!prev_ref)
6517 : : {
6518 : 8039 : allocatable = expr->symtree->n.sym->attr.allocatable;
6519 : 8039 : dimension = expr->symtree->n.sym->attr.dimension;
6520 : 8039 : non_ulimate_coarray_ptr_comp = false;
6521 : : }
6522 : : else
6523 : : {
6524 : 3477 : allocatable = prev_ref->u.c.component->attr.allocatable;
6525 : : /* Pointer components in coarrayed derived types must be treated
6526 : : specially in that they are registered without a check if the are
6527 : : already associated. This does not hold for ultimate coarray
6528 : : pointers. */
6529 : 3477 : non_ulimate_coarray_ptr_comp = (prev_ref->u.c.component->attr.pointer
6530 : 3477 : && !prev_ref->u.c.component->attr.codimension);
6531 : 3477 : dimension = prev_ref->u.c.component->attr.dimension;
6532 : : }
6533 : :
6534 : : /* For allocatable/pointer arrays in derived types, one of the refs has to be
6535 : : a coarray. In this case it does not matter whether we are on this_image
6536 : : or not. */
6537 : 11516 : coarray = false;
6538 : 27314 : for (coref = expr->ref; coref; coref = coref->next)
6539 : 16320 : if (coref->type == REF_ARRAY && coref->u.ar.codimen > 0)
6540 : : {
6541 : : coarray = true;
6542 : : break;
6543 : : }
6544 : :
6545 : 11516 : if (!dimension)
6546 : 157 : gcc_assert (coarray);
6547 : :
6548 : 11516 : if (ref->u.ar.type == AR_FULL && expr3 != NULL)
6549 : : {
6550 : 1142 : gfc_ref *old_ref = ref;
6551 : : /* F08:C633: Array shape from expr3. */
6552 : 1142 : ref = expr3->ref;
6553 : :
6554 : : /* Find the last reference in the chain. */
6555 : 1142 : if (!retrieve_last_ref (&ref, &prev_ref))
6556 : : {
6557 : 0 : if (expr3->expr_type == EXPR_FUNCTION
6558 : 0 : && gfc_expr_attr (expr3).dimension)
6559 : 0 : ref = old_ref;
6560 : : else
6561 : 0 : return false;
6562 : : }
6563 : : alloc_w_e3_arr_spec = true;
6564 : : }
6565 : :
6566 : : /* Figure out the size of the array. */
6567 : 11516 : switch (ref->u.ar.type)
6568 : : {
6569 : 8767 : case AR_ELEMENT:
6570 : 8767 : if (!coarray)
6571 : : {
6572 : 8291 : lower = NULL;
6573 : 8291 : upper = ref->u.ar.start;
6574 : 8291 : break;
6575 : : }
6576 : : /* Fall through. */
6577 : :
6578 : 2113 : case AR_SECTION:
6579 : 2113 : lower = ref->u.ar.start;
6580 : 2113 : upper = ref->u.ar.end;
6581 : 2113 : break;
6582 : :
6583 : 1112 : case AR_FULL:
6584 : 1112 : gcc_assert (ref->u.ar.as->type == AS_EXPLICIT
6585 : : || alloc_w_e3_arr_spec);
6586 : :
6587 : 1112 : lower = ref->u.ar.as->lower;
6588 : 1112 : upper = ref->u.ar.as->upper;
6589 : 1112 : break;
6590 : :
6591 : 0 : default:
6592 : 0 : gcc_unreachable ();
6593 : 11516 : break;
6594 : : }
6595 : :
6596 : 11516 : overflow = integer_zero_node;
6597 : :
6598 : 11516 : if (expr->ts.type == BT_CHARACTER
6599 : 989 : && TREE_CODE (se->string_length) == COMPONENT_REF
6600 : 159 : && expr->ts.u.cl->backend_decl != se->string_length
6601 : 159 : && VAR_P (expr->ts.u.cl->backend_decl))
6602 : 0 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
6603 : 0 : fold_convert (TREE_TYPE (expr->ts.u.cl->backend_decl),
6604 : : se->string_length));
6605 : :
6606 : 11516 : gfc_init_block (&set_descriptor_block);
6607 : : /* Take the corank only from the actual ref and not from the coref. The
6608 : : later will mislead the generation of the array dimensions for allocatable/
6609 : : pointer components in derived types. */
6610 : 22412 : size = gfc_array_init_size (se->expr, alloc_w_e3_arr_spec ? expr->rank
6611 : 10374 : : ref->u.ar.as->rank,
6612 : 522 : coarray ? ref->u.ar.as->corank : 0,
6613 : : &offset, lower, upper,
6614 : : &se->pre, &set_descriptor_block, &overflow,
6615 : : expr3_elem_size, nelems, expr3, e3_arr_desc,
6616 : : e3_has_nodescriptor, expr, &element_size,
6617 : : explicit_ts);
6618 : :
6619 : 11516 : if (dimension)
6620 : : {
6621 : 11359 : var_overflow = gfc_create_var (integer_type_node, "overflow");
6622 : 11359 : gfc_add_modify (&se->pre, var_overflow, overflow);
6623 : :
6624 : 11359 : if (status == NULL_TREE)
6625 : : {
6626 : : /* Generate the block of code handling overflow. */
6627 : 11148 : msg = gfc_build_addr_expr (pchar_type_node,
6628 : : gfc_build_localized_cstring_const
6629 : : ("Integer overflow when calculating the amount of "
6630 : : "memory to allocate"));
6631 : 11148 : error = build_call_expr_loc (input_location,
6632 : : gfor_fndecl_runtime_error, 1, msg);
6633 : : }
6634 : : else
6635 : : {
6636 : 211 : tree status_type = TREE_TYPE (status);
6637 : 211 : stmtblock_t set_status_block;
6638 : :
6639 : 211 : gfc_start_block (&set_status_block);
6640 : 211 : gfc_add_modify (&set_status_block, status,
6641 : 211 : build_int_cst (status_type, LIBERROR_ALLOCATION));
6642 : 211 : error = gfc_finish_block (&set_status_block);
6643 : : }
6644 : : }
6645 : :
6646 : : /* Allocate memory to store the data. */
6647 : 11516 : if (POINTER_TYPE_P (TREE_TYPE (se->expr)))
6648 : 0 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
6649 : :
6650 : 11516 : if (coarray && flag_coarray == GFC_FCOARRAY_LIB)
6651 : : {
6652 : 290 : pointer = non_ulimate_coarray_ptr_comp ? se->expr
6653 : 221 : : gfc_conv_descriptor_data_get (se->expr);
6654 : 290 : token = gfc_conv_descriptor_token (se->expr);
6655 : 290 : token = gfc_build_addr_expr (NULL_TREE, token);
6656 : : }
6657 : : else
6658 : : {
6659 : 11226 : pointer = gfc_conv_descriptor_data_get (se->expr);
6660 : 11226 : if (omp_alloc)
6661 : 30 : omp_cond = boolean_true_node;
6662 : : }
6663 : 11516 : STRIP_NOPS (pointer);
6664 : :
6665 : 11516 : if (allocatable)
6666 : : {
6667 : 9448 : not_prev_allocated = gfc_create_var (logical_type_node,
6668 : : "not_prev_allocated");
6669 : 9448 : tmp = fold_build2_loc (input_location, EQ_EXPR,
6670 : : logical_type_node, pointer,
6671 : 9448 : build_int_cst (TREE_TYPE (pointer), 0));
6672 : :
6673 : 9448 : gfc_add_modify (&se->pre, not_prev_allocated, tmp);
6674 : : }
6675 : :
6676 : 11516 : gfc_start_block (&elseblock);
6677 : :
6678 : 11516 : tree succ_add_expr = NULL_TREE;
6679 : 11516 : if (omp_cond)
6680 : : {
6681 : 30 : tree align, alloc, sz;
6682 : 30 : gfc_se se2;
6683 : 30 : if (omp_alloc->u2.allocator)
6684 : : {
6685 : 7 : gfc_init_se (&se2, NULL);
6686 : 7 : gfc_conv_expr (&se2, omp_alloc->u2.allocator);
6687 : 7 : gfc_add_block_to_block (&elseblock, &se2.pre);
6688 : 7 : alloc = gfc_evaluate_now (se2.expr, &elseblock);
6689 : 7 : gfc_add_block_to_block (&elseblock, &se2.post);
6690 : : }
6691 : : else
6692 : 23 : alloc = build_zero_cst (ptr_type_node);
6693 : 30 : tmp = TREE_TYPE (TREE_TYPE (pointer));
6694 : 30 : if (tmp == void_type_node)
6695 : 30 : tmp = gfc_typenode_for_spec (&expr->ts, 0);
6696 : 30 : if (omp_alloc->u.align)
6697 : : {
6698 : 15 : gfc_init_se (&se2, NULL);
6699 : 15 : gfc_conv_expr (&se2, omp_alloc->u.align);
6700 : 15 : gcc_assert (CONSTANT_CLASS_P (se2.expr)
6701 : : && se2.pre.head == NULL
6702 : : && se2.post.head == NULL);
6703 : 15 : align = build_int_cst (size_type_node,
6704 : 15 : MAX (tree_to_uhwi (se2.expr),
6705 : : TYPE_ALIGN_UNIT (tmp)));
6706 : : }
6707 : : else
6708 : 15 : align = build_int_cst (size_type_node, TYPE_ALIGN_UNIT (tmp));
6709 : 30 : sz = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
6710 : : fold_convert (size_type_node, size),
6711 : 30 : build_int_cst (size_type_node, 1));
6712 : 30 : omp_alt_alloc = builtin_decl_explicit (BUILT_IN_GOMP_ALLOC);
6713 : 30 : DECL_ATTRIBUTES (omp_alt_alloc)
6714 : 30 : = tree_cons (get_identifier ("omp allocator"),
6715 : : build_tree_list (NULL_TREE, alloc),
6716 : 30 : DECL_ATTRIBUTES (omp_alt_alloc));
6717 : 30 : omp_alt_alloc = build_call_expr (omp_alt_alloc, 3, align, sz, alloc);
6718 : 30 : succ_add_expr = fold_build2_loc (input_location, MODIFY_EXPR,
6719 : : void_type_node,
6720 : : gfc_conv_descriptor_version (se->expr),
6721 : 30 : build_int_cst (integer_type_node, 1));
6722 : : }
6723 : :
6724 : : /* The allocatable variant takes the old pointer as first argument. */
6725 : 11516 : if (allocatable)
6726 : 9898 : gfc_allocate_allocatable (&elseblock, pointer, size, token,
6727 : : status, errmsg, errlen, label_finish, expr,
6728 : 450 : coref != NULL ? coref->u.ar.as->corank : 0,
6729 : : omp_cond, omp_alt_alloc, succ_add_expr);
6730 : 2068 : else if (non_ulimate_coarray_ptr_comp && token)
6731 : : /* The token is set only for GFC_FCOARRAY_LIB mode. */
6732 : 69 : gfc_allocate_using_caf_lib (&elseblock, pointer, size, token, status,
6733 : : errmsg, errlen,
6734 : : GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY);
6735 : : else
6736 : 1999 : gfc_allocate_using_malloc (&elseblock, pointer, size, status,
6737 : : omp_cond, omp_alt_alloc, succ_add_expr);
6738 : :
6739 : 11516 : if (dimension)
6740 : : {
6741 : 11359 : cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
6742 : : logical_type_node, var_overflow, integer_zero_node),
6743 : : PRED_FORTRAN_OVERFLOW);
6744 : 11359 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6745 : : error, gfc_finish_block (&elseblock));
6746 : : }
6747 : : else
6748 : 157 : tmp = gfc_finish_block (&elseblock);
6749 : :
6750 : 11516 : gfc_add_expr_to_block (&se->pre, tmp);
6751 : :
6752 : : /* Update the array descriptor with the offset and the span. */
6753 : 11516 : if (dimension)
6754 : : {
6755 : 11359 : gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
6756 : 11359 : tmp = fold_convert (gfc_array_index_type, element_size);
6757 : 11359 : gfc_conv_descriptor_span_set (&set_descriptor_block, se->expr, tmp);
6758 : : }
6759 : :
6760 : 11516 : set_descriptor = gfc_finish_block (&set_descriptor_block);
6761 : 11516 : if (status != NULL_TREE)
6762 : : {
6763 : 225 : cond = fold_build2_loc (input_location, EQ_EXPR,
6764 : : logical_type_node, status,
6765 : 225 : build_int_cst (TREE_TYPE (status), 0));
6766 : :
6767 : 225 : if (not_prev_allocated != NULL_TREE)
6768 : 209 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
6769 : : logical_type_node, cond, not_prev_allocated);
6770 : :
6771 : 225 : gfc_add_expr_to_block (&se->pre,
6772 : : fold_build3_loc (input_location, COND_EXPR, void_type_node,
6773 : : cond,
6774 : : set_descriptor,
6775 : : build_empty_stmt (input_location)));
6776 : : }
6777 : : else
6778 : 11291 : gfc_add_expr_to_block (&se->pre, set_descriptor);
6779 : :
6780 : 11516 : expr->symtree->n.sym->allocated_in_scope = 1;
6781 : :
6782 : 11516 : return true;
6783 : : }
6784 : :
6785 : :
6786 : : /* Create an array constructor from an initialization expression.
6787 : : We assume the frontend already did any expansions and conversions. */
6788 : :
6789 : : tree
6790 : 7301 : gfc_conv_array_initializer (tree type, gfc_expr * expr)
6791 : : {
6792 : 7301 : gfc_constructor *c;
6793 : 7301 : tree tmp;
6794 : 7301 : gfc_se se;
6795 : 7301 : tree index, range;
6796 : 7301 : vec<constructor_elt, va_gc> *v = NULL;
6797 : :
6798 : 7301 : if (expr->expr_type == EXPR_VARIABLE
6799 : 0 : && expr->symtree->n.sym->attr.flavor == FL_PARAMETER
6800 : 0 : && expr->symtree->n.sym->value)
6801 : 7301 : expr = expr->symtree->n.sym->value;
6802 : :
6803 : 7301 : switch (expr->expr_type)
6804 : : {
6805 : 1084 : case EXPR_CONSTANT:
6806 : 1084 : case EXPR_STRUCTURE:
6807 : : /* A single scalar or derived type value. Create an array with all
6808 : : elements equal to that value. */
6809 : 1084 : gfc_init_se (&se, NULL);
6810 : :
6811 : 1084 : if (expr->expr_type == EXPR_CONSTANT)
6812 : 377 : gfc_conv_constant (&se, expr);
6813 : : else
6814 : 707 : gfc_conv_structure (&se, expr, 1);
6815 : :
6816 : 2168 : if (tree_int_cst_lt (TYPE_MAX_VALUE (TYPE_DOMAIN (type)),
6817 : 1084 : TYPE_MIN_VALUE (TYPE_DOMAIN (type))))
6818 : : break;
6819 : 2144 : else if (tree_int_cst_equal (TYPE_MIN_VALUE (TYPE_DOMAIN (type)),
6820 : 1072 : TYPE_MAX_VALUE (TYPE_DOMAIN (type))))
6821 : 144 : range = TYPE_MIN_VALUE (TYPE_DOMAIN (type));
6822 : : else
6823 : 1856 : range = build2 (RANGE_EXPR, gfc_array_index_type,
6824 : 928 : TYPE_MIN_VALUE (TYPE_DOMAIN (type)),
6825 : 928 : TYPE_MAX_VALUE (TYPE_DOMAIN (type)));
6826 : 1072 : CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
6827 : 1072 : break;
6828 : :
6829 : 6217 : case EXPR_ARRAY:
6830 : : /* Create a vector of all the elements. */
6831 : 6217 : for (c = gfc_constructor_first (expr->value.constructor);
6832 : 162675 : c && c->expr; c = gfc_constructor_next (c))
6833 : : {
6834 : 156458 : if (c->iterator)
6835 : : {
6836 : : /* Problems occur when we get something like
6837 : : integer :: a(lots) = (/(i, i=1, lots)/) */
6838 : 0 : gfc_fatal_error ("The number of elements in the array "
6839 : : "constructor at %L requires an increase of "
6840 : : "the allowed %d upper limit. See "
6841 : : "%<-fmax-array-constructor%> option",
6842 : : &expr->where, flag_max_array_constructor);
6843 : : return NULL_TREE;
6844 : : }
6845 : 156458 : if (mpz_cmp_si (c->offset, 0) != 0)
6846 : 150498 : index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
6847 : : else
6848 : : index = NULL_TREE;
6849 : :
6850 : 156458 : if (mpz_cmp_si (c->repeat, 1) > 0)
6851 : : {
6852 : 127 : tree tmp1, tmp2;
6853 : 127 : mpz_t maxval;
6854 : :
6855 : 127 : mpz_init (maxval);
6856 : 127 : mpz_add (maxval, c->offset, c->repeat);
6857 : 127 : mpz_sub_ui (maxval, maxval, 1);
6858 : 127 : tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
6859 : 127 : if (mpz_cmp_si (c->offset, 0) != 0)
6860 : : {
6861 : 27 : mpz_add_ui (maxval, c->offset, 1);
6862 : 27 : tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
6863 : : }
6864 : : else
6865 : 100 : tmp1 = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
6866 : :
6867 : 127 : range = fold_build2 (RANGE_EXPR, gfc_array_index_type, tmp1, tmp2);
6868 : 127 : mpz_clear (maxval);
6869 : : }
6870 : : else
6871 : : range = NULL;
6872 : :
6873 : 156458 : gfc_init_se (&se, NULL);
6874 : 156458 : switch (c->expr->expr_type)
6875 : : {
6876 : 155228 : case EXPR_CONSTANT:
6877 : 155228 : gfc_conv_constant (&se, c->expr);
6878 : :
6879 : : /* See gfortran.dg/charlen_15.f90 for instance. */
6880 : 155228 : if (TREE_CODE (se.expr) == STRING_CST
6881 : 4974 : && TREE_CODE (type) == ARRAY_TYPE)
6882 : : {
6883 : : tree atype = type;
6884 : 9948 : while (TREE_CODE (TREE_TYPE (atype)) == ARRAY_TYPE)
6885 : 4974 : atype = TREE_TYPE (atype);
6886 : 4974 : gcc_checking_assert (TREE_CODE (TREE_TYPE (atype))
6887 : : == INTEGER_TYPE);
6888 : 4974 : gcc_checking_assert (TREE_TYPE (TREE_TYPE (se.expr))
6889 : : == TREE_TYPE (atype));
6890 : 4974 : if (tree_to_uhwi (TYPE_SIZE_UNIT (TREE_TYPE (se.expr)))
6891 : 4974 : > tree_to_uhwi (TYPE_SIZE_UNIT (atype)))
6892 : : {
6893 : 0 : unsigned HOST_WIDE_INT size
6894 : 0 : = tree_to_uhwi (TYPE_SIZE_UNIT (atype));
6895 : 0 : const char *p = TREE_STRING_POINTER (se.expr);
6896 : :
6897 : 0 : se.expr = build_string (size, p);
6898 : : }
6899 : 4974 : TREE_TYPE (se.expr) = atype;
6900 : : }
6901 : : break;
6902 : :
6903 : 1230 : case EXPR_STRUCTURE:
6904 : 1230 : gfc_conv_structure (&se, c->expr, 1);
6905 : 1230 : break;
6906 : :
6907 : 0 : default:
6908 : : /* Catch those occasional beasts that do not simplify
6909 : : for one reason or another, assuming that if they are
6910 : : standard defying the frontend will catch them. */
6911 : 0 : gfc_conv_expr (&se, c->expr);
6912 : 0 : break;
6913 : : }
6914 : :
6915 : 156458 : if (range == NULL_TREE)
6916 : 156331 : CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
6917 : : else
6918 : : {
6919 : 127 : if (index != NULL_TREE)
6920 : 27 : CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
6921 : 156585 : CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
6922 : : }
6923 : : }
6924 : : break;
6925 : :
6926 : 0 : case EXPR_NULL:
6927 : 0 : return gfc_build_null_descriptor (type);
6928 : :
6929 : 0 : default:
6930 : 0 : gcc_unreachable ();
6931 : : }
6932 : :
6933 : : /* Create a constructor from the list of elements. */
6934 : 7301 : tmp = build_constructor (type, v);
6935 : 7301 : TREE_CONSTANT (tmp) = 1;
6936 : 7301 : return tmp;
6937 : : }
6938 : :
6939 : :
6940 : : /* Generate code to evaluate non-constant coarray cobounds. */
6941 : :
6942 : : void
6943 : 19329 : gfc_trans_array_cobounds (tree type, stmtblock_t * pblock,
6944 : : const gfc_symbol *sym)
6945 : : {
6946 : 19329 : int dim;
6947 : 19329 : tree ubound;
6948 : 19329 : tree lbound;
6949 : 19329 : gfc_se se;
6950 : 19329 : gfc_array_spec *as;
6951 : :
6952 : 19329 : as = IS_CLASS_COARRAY_OR_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
6953 : :
6954 : 20064 : for (dim = as->rank; dim < as->rank + as->corank; dim++)
6955 : : {
6956 : : /* Evaluate non-constant array bound expressions.
6957 : : F2008 4.5.6.3 para 6: If a specification expression in a scoping unit
6958 : : references a function, the result is finalized before execution of the
6959 : : executable constructs in the scoping unit.
6960 : : Adding the finalblocks enables this. */
6961 : 735 : lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
6962 : 735 : if (as->lower[dim] && !INTEGER_CST_P (lbound))
6963 : : {
6964 : 96 : gfc_init_se (&se, NULL);
6965 : 96 : gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
6966 : 96 : gfc_add_block_to_block (pblock, &se.pre);
6967 : 96 : gfc_add_block_to_block (pblock, &se.finalblock);
6968 : 96 : gfc_add_modify (pblock, lbound, se.expr);
6969 : : }
6970 : 735 : ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
6971 : 735 : if (as->upper[dim] && !INTEGER_CST_P (ubound))
6972 : : {
6973 : 50 : gfc_init_se (&se, NULL);
6974 : 50 : gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
6975 : 50 : gfc_add_block_to_block (pblock, &se.pre);
6976 : 50 : gfc_add_block_to_block (pblock, &se.finalblock);
6977 : 50 : gfc_add_modify (pblock, ubound, se.expr);
6978 : : }
6979 : : }
6980 : 19329 : }
6981 : :
6982 : :
6983 : : /* Generate code to evaluate non-constant array bounds. Sets *poffset and
6984 : : returns the size (in elements) of the array. */
6985 : :
6986 : : tree
6987 : 12478 : gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
6988 : : stmtblock_t * pblock)
6989 : : {
6990 : 12478 : gfc_array_spec *as;
6991 : 12478 : tree size;
6992 : 12478 : tree stride;
6993 : 12478 : tree offset;
6994 : 12478 : tree ubound;
6995 : 12478 : tree lbound;
6996 : 12478 : tree tmp;
6997 : 12478 : gfc_se se;
6998 : :
6999 : 12478 : int dim;
7000 : :
7001 : 12478 : as = IS_CLASS_COARRAY_OR_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
7002 : :
7003 : 12478 : size = gfc_index_one_node;
7004 : 12478 : offset = gfc_index_zero_node;
7005 : 12478 : stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
7006 : 12478 : if (stride && VAR_P (stride))
7007 : 124 : gfc_add_modify (pblock, stride, gfc_index_one_node);
7008 : 28186 : for (dim = 0; dim < as->rank; dim++)
7009 : : {
7010 : : /* Evaluate non-constant array bound expressions.
7011 : : F2008 4.5.6.3 para 6: If a specification expression in a scoping unit
7012 : : references a function, the result is finalized before execution of the
7013 : : executable constructs in the scoping unit.
7014 : : Adding the finalblocks enables this. */
7015 : 15708 : lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
7016 : 15708 : if (as->lower[dim] && !INTEGER_CST_P (lbound))
7017 : : {
7018 : 469 : gfc_init_se (&se, NULL);
7019 : 469 : gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
7020 : 469 : gfc_add_block_to_block (pblock, &se.pre);
7021 : 469 : gfc_add_block_to_block (pblock, &se.finalblock);
7022 : 469 : gfc_add_modify (pblock, lbound, se.expr);
7023 : : }
7024 : 15708 : ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
7025 : 15708 : if (as->upper[dim] && !INTEGER_CST_P (ubound))
7026 : : {
7027 : 9377 : gfc_init_se (&se, NULL);
7028 : 9377 : gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
7029 : 9377 : gfc_add_block_to_block (pblock, &se.pre);
7030 : 9377 : gfc_add_block_to_block (pblock, &se.finalblock);
7031 : 9377 : gfc_add_modify (pblock, ubound, se.expr);
7032 : : }
7033 : : /* The offset of this dimension. offset = offset - lbound * stride. */
7034 : 15708 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7035 : : lbound, size);
7036 : 15708 : offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7037 : : offset, tmp);
7038 : :
7039 : : /* The size of this dimension, and the stride of the next. */
7040 : 15708 : if (dim + 1 < as->rank)
7041 : 3376 : stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
7042 : : else
7043 : 12332 : stride = GFC_TYPE_ARRAY_SIZE (type);
7044 : :
7045 : 15708 : if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
7046 : : {
7047 : : /* Calculate stride = size * (ubound + 1 - lbound). */
7048 : 9561 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
7049 : : gfc_array_index_type,
7050 : : gfc_index_one_node, lbound);
7051 : 9561 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
7052 : : gfc_array_index_type, ubound, tmp);
7053 : 9561 : tmp = fold_build2_loc (input_location, MULT_EXPR,
7054 : : gfc_array_index_type, size, tmp);
7055 : 9561 : if (stride)
7056 : 9561 : gfc_add_modify (pblock, stride, tmp);
7057 : : else
7058 : 0 : stride = gfc_evaluate_now (tmp, pblock);
7059 : :
7060 : : /* Make sure that negative size arrays are translated
7061 : : to being zero size. */
7062 : 9561 : tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
7063 : : stride, gfc_index_zero_node);
7064 : 9561 : tmp = fold_build3_loc (input_location, COND_EXPR,
7065 : : gfc_array_index_type, tmp,
7066 : : stride, gfc_index_zero_node);
7067 : 9561 : gfc_add_modify (pblock, stride, tmp);
7068 : : }
7069 : :
7070 : : size = stride;
7071 : : }
7072 : :
7073 : 12478 : gfc_trans_array_cobounds (type, pblock, sym);
7074 : 12478 : gfc_trans_vla_type_sizes (sym, pblock);
7075 : :
7076 : 12478 : *poffset = offset;
7077 : 12478 : return size;
7078 : : }
7079 : :
7080 : :
7081 : : /* Generate code to initialize/allocate an array variable. */
7082 : :
7083 : : void
7084 : 29711 : gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
7085 : : gfc_wrapped_block * block)
7086 : : {
7087 : 29711 : stmtblock_t init;
7088 : 29711 : tree type;
7089 : 29711 : tree tmp = NULL_TREE;
7090 : 29711 : tree size;
7091 : 29711 : tree offset;
7092 : 29711 : tree space;
7093 : 29711 : tree inittree;
7094 : 29711 : bool onstack;
7095 : 29711 : bool back;
7096 : :
7097 : 29711 : gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
7098 : :
7099 : : /* Do nothing for USEd variables. */
7100 : 29711 : if (sym->attr.use_assoc)
7101 : 24787 : return;
7102 : :
7103 : 29671 : type = TREE_TYPE (decl);
7104 : 29671 : gcc_assert (GFC_ARRAY_TYPE_P (type));
7105 : 29671 : onstack = TREE_CODE (type) != POINTER_TYPE;
7106 : :
7107 : : /* In the case of non-dummy symbols with dependencies on an old-fashioned
7108 : : function result (ie. proc_name = proc_name->result), gfc_add_init_cleanup
7109 : : must be called with the last, optional argument false so that the alloc-
7110 : : ation occurs after the processing of the result. */
7111 : 29671 : back = sym->fn_result_dep;
7112 : :
7113 : 29671 : gfc_init_block (&init);
7114 : :
7115 : : /* Evaluate character string length. */
7116 : 29671 : if (sym->ts.type == BT_CHARACTER
7117 : 2922 : && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
7118 : : {
7119 : 43 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7120 : :
7121 : 43 : gfc_trans_vla_type_sizes (sym, &init);
7122 : :
7123 : : /* Emit a DECL_EXPR for this variable, which will cause the
7124 : : gimplifier to allocate storage, and all that good stuff. */
7125 : 43 : tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
7126 : 43 : gfc_add_expr_to_block (&init, tmp);
7127 : 43 : if (sym->attr.omp_allocate)
7128 : : {
7129 : : /* Save location of size calculation to ensure GOMP_alloc is placed
7130 : : after it. */
7131 : 0 : tree omp_alloc = lookup_attribute ("omp allocate",
7132 : 0 : DECL_ATTRIBUTES (decl));
7133 : 0 : TREE_CHAIN (TREE_CHAIN (TREE_VALUE (omp_alloc)))
7134 : 0 : = build_tree_list (NULL_TREE, tsi_stmt (tsi_last (init.head)));
7135 : : }
7136 : : }
7137 : :
7138 : 29469 : if (onstack)
7139 : : {
7140 : 24607 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE,
7141 : : back);
7142 : 24607 : return;
7143 : : }
7144 : :
7145 : 5064 : type = TREE_TYPE (type);
7146 : :
7147 : 5064 : gcc_assert (!sym->attr.use_assoc);
7148 : 5064 : gcc_assert (!sym->module);
7149 : :
7150 : 5064 : if (sym->ts.type == BT_CHARACTER
7151 : 202 : && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
7152 : 94 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7153 : :
7154 : 5064 : size = gfc_trans_array_bounds (type, sym, &offset, &init);
7155 : :
7156 : : /* Don't actually allocate space for Cray Pointees. */
7157 : 5064 : if (sym->attr.cray_pointee)
7158 : : {
7159 : 140 : if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
7160 : 49 : gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
7161 : :
7162 : 140 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
7163 : 140 : return;
7164 : : }
7165 : 4924 : if (sym->attr.omp_allocate)
7166 : : {
7167 : : /* The size is the number of elements in the array, so multiply by the
7168 : : size of an element to get the total size. */
7169 : 7 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
7170 : 7 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7171 : : size, fold_convert (gfc_array_index_type, tmp));
7172 : 7 : size = gfc_evaluate_now (size, &init);
7173 : :
7174 : 7 : tree omp_alloc = lookup_attribute ("omp allocate",
7175 : 7 : DECL_ATTRIBUTES (decl));
7176 : 7 : TREE_CHAIN (TREE_CHAIN (TREE_VALUE (omp_alloc)))
7177 : 7 : = build_tree_list (size, NULL_TREE);
7178 : 7 : space = NULL_TREE;
7179 : : }
7180 : 4917 : else if (flag_stack_arrays)
7181 : : {
7182 : 11 : gcc_assert (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE);
7183 : 11 : space = build_decl (gfc_get_location (&sym->declared_at),
7184 : : VAR_DECL, create_tmp_var_name ("A"),
7185 : 11 : TREE_TYPE (TREE_TYPE (decl)));
7186 : 11 : gfc_trans_vla_type_sizes (sym, &init);
7187 : : }
7188 : : else
7189 : : {
7190 : : /* The size is the number of elements in the array, so multiply by the
7191 : : size of an element to get the total size. */
7192 : 4906 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
7193 : 4906 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7194 : : size, fold_convert (gfc_array_index_type, tmp));
7195 : :
7196 : : /* Allocate memory to hold the data. */
7197 : 4906 : tmp = gfc_call_malloc (&init, TREE_TYPE (decl), size);
7198 : 4906 : gfc_add_modify (&init, decl, tmp);
7199 : :
7200 : : /* Free the temporary. */
7201 : 4906 : tmp = gfc_call_free (decl);
7202 : 4906 : space = NULL_TREE;
7203 : : }
7204 : :
7205 : : /* Set offset of the array. */
7206 : 4924 : if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
7207 : 363 : gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
7208 : :
7209 : : /* Automatic arrays should not have initializers. */
7210 : 4924 : gcc_assert (!sym->value);
7211 : :
7212 : 4924 : inittree = gfc_finish_block (&init);
7213 : :
7214 : 4924 : if (space)
7215 : : {
7216 : 11 : tree addr;
7217 : 11 : pushdecl (space);
7218 : :
7219 : : /* Don't create new scope, emit the DECL_EXPR in exactly the scope
7220 : : where also space is located. */
7221 : 11 : gfc_init_block (&init);
7222 : 11 : tmp = fold_build1_loc (input_location, DECL_EXPR,
7223 : 11 : TREE_TYPE (space), space);
7224 : 11 : gfc_add_expr_to_block (&init, tmp);
7225 : 11 : addr = fold_build1_loc (gfc_get_location (&sym->declared_at),
7226 : 11 : ADDR_EXPR, TREE_TYPE (decl), space);
7227 : 11 : gfc_add_modify (&init, decl, addr);
7228 : 11 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE,
7229 : : back);
7230 : 11 : tmp = NULL_TREE;
7231 : : }
7232 : 4924 : gfc_add_init_cleanup (block, inittree, tmp, back);
7233 : : }
7234 : :
7235 : :
7236 : : /* Generate entry and exit code for g77 calling convention arrays. */
7237 : :
7238 : : void
7239 : 7160 : gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block)
7240 : : {
7241 : 7160 : tree parm;
7242 : 7160 : tree type;
7243 : 7160 : tree offset;
7244 : 7160 : tree tmp;
7245 : 7160 : tree stmt;
7246 : 7160 : stmtblock_t init;
7247 : :
7248 : 7160 : location_t loc = input_location;
7249 : 7160 : input_location = gfc_get_location (&sym->declared_at);
7250 : :
7251 : : /* Descriptor type. */
7252 : 7160 : parm = sym->backend_decl;
7253 : 7160 : type = TREE_TYPE (parm);
7254 : 7160 : gcc_assert (GFC_ARRAY_TYPE_P (type));
7255 : :
7256 : 7160 : gfc_start_block (&init);
7257 : :
7258 : 7160 : if (sym->ts.type == BT_CHARACTER
7259 : 661 : && VAR_P (sym->ts.u.cl->backend_decl))
7260 : 79 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7261 : :
7262 : : /* Evaluate the bounds of the array. */
7263 : 7160 : gfc_trans_array_bounds (type, sym, &offset, &init);
7264 : :
7265 : : /* Set the offset. */
7266 : 7160 : if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
7267 : 1203 : gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
7268 : :
7269 : : /* Set the pointer itself if we aren't using the parameter directly. */
7270 : 7160 : if (TREE_CODE (parm) != PARM_DECL)
7271 : : {
7272 : 559 : tmp = GFC_DECL_SAVED_DESCRIPTOR (parm);
7273 : 559 : if (sym->ts.type == BT_CLASS)
7274 : : {
7275 : 239 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
7276 : 239 : tmp = gfc_class_data_get (tmp);
7277 : 239 : tmp = gfc_conv_descriptor_data_get (tmp);
7278 : : }
7279 : 559 : tmp = convert (TREE_TYPE (parm), tmp);
7280 : 559 : gfc_add_modify (&init, parm, tmp);
7281 : : }
7282 : 7160 : stmt = gfc_finish_block (&init);
7283 : :
7284 : 7160 : input_location = loc;
7285 : :
7286 : : /* Add the initialization code to the start of the function. */
7287 : :
7288 : 7160 : if ((sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.optional)
7289 : : || sym->attr.optional
7290 : 7160 : || sym->attr.not_always_present)
7291 : : {
7292 : 539 : tree nullify;
7293 : 539 : if (TREE_CODE (parm) != PARM_DECL)
7294 : 105 : nullify = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
7295 : : parm, null_pointer_node);
7296 : : else
7297 : 434 : nullify = build_empty_stmt (input_location);
7298 : 539 : tmp = gfc_conv_expr_present (sym, true);
7299 : 539 : stmt = build3_v (COND_EXPR, tmp, stmt, nullify);
7300 : : }
7301 : :
7302 : 7160 : gfc_add_init_cleanup (block, stmt, NULL_TREE);
7303 : 7160 : }
7304 : :
7305 : :
7306 : : /* Modify the descriptor of an array parameter so that it has the
7307 : : correct lower bound. Also move the upper bound accordingly.
7308 : : If the array is not packed, it will be copied into a temporary.
7309 : : For each dimension we set the new lower and upper bounds. Then we copy the
7310 : : stride and calculate the offset for this dimension. We also work out
7311 : : what the stride of a packed array would be, and see it the two match.
7312 : : If the array need repacking, we set the stride to the values we just
7313 : : calculated, recalculate the offset and copy the array data.
7314 : : Code is also added to copy the data back at the end of the function.
7315 : : */
7316 : :
7317 : : void
7318 : 12411 : gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
7319 : : gfc_wrapped_block * block)
7320 : : {
7321 : 12411 : tree size;
7322 : 12411 : tree type;
7323 : 12411 : tree offset;
7324 : 12411 : stmtblock_t init;
7325 : 12411 : tree stmtInit, stmtCleanup;
7326 : 12411 : tree lbound;
7327 : 12411 : tree ubound;
7328 : 12411 : tree dubound;
7329 : 12411 : tree dlbound;
7330 : 12411 : tree dumdesc;
7331 : 12411 : tree tmp;
7332 : 12411 : tree stride, stride2;
7333 : 12411 : tree stmt_packed;
7334 : 12411 : tree stmt_unpacked;
7335 : 12411 : tree partial;
7336 : 12411 : gfc_se se;
7337 : 12411 : int n;
7338 : 12411 : int checkparm;
7339 : 12411 : int no_repack;
7340 : 12411 : bool optional_arg;
7341 : 12411 : gfc_array_spec *as;
7342 : 12411 : bool is_classarray = IS_CLASS_COARRAY_OR_ARRAY (sym);
7343 : :
7344 : : /* Do nothing for pointer and allocatable arrays. */
7345 : 12411 : if ((sym->ts.type != BT_CLASS && sym->attr.pointer)
7346 : 12314 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer)
7347 : 12314 : || sym->attr.allocatable
7348 : 12208 : || (is_classarray && CLASS_DATA (sym)->attr.allocatable))
7349 : 5861 : return;
7350 : :
7351 : 724 : if ((!is_classarray
7352 : 724 : || (is_classarray && CLASS_DATA (sym)->as->type == AS_EXPLICIT))
7353 : 11664 : && sym->attr.dummy && !sym->attr.elemental && gfc_is_nodesc_array (sym))
7354 : : {
7355 : 5658 : gfc_trans_g77_array (sym, block);
7356 : 5658 : return;
7357 : : }
7358 : :
7359 : 6550 : location_t loc = input_location;
7360 : 6550 : input_location = gfc_get_location (&sym->declared_at);
7361 : :
7362 : : /* Descriptor type. */
7363 : 6550 : type = TREE_TYPE (tmpdesc);
7364 : 6550 : gcc_assert (GFC_ARRAY_TYPE_P (type));
7365 : 6550 : dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
7366 : 6550 : if (is_classarray)
7367 : : /* For a class array the dummy array descriptor is in the _class
7368 : : component. */
7369 : 563 : dumdesc = gfc_class_data_get (dumdesc);
7370 : : else
7371 : 5987 : dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc);
7372 : 6550 : as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
7373 : 6550 : gfc_start_block (&init);
7374 : :
7375 : 6550 : if (sym->ts.type == BT_CHARACTER
7376 : 764 : && VAR_P (sym->ts.u.cl->backend_decl))
7377 : 87 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7378 : :
7379 : : /* TODO: Fix the exclusion of class arrays from extent checking. */
7380 : 1045 : checkparm = (as->type == AS_EXPLICIT && !is_classarray
7381 : 7576 : && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
7382 : :
7383 : 6550 : no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
7384 : 6549 : || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
7385 : :
7386 : 6550 : if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
7387 : : {
7388 : : /* For non-constant shape arrays we only check if the first dimension
7389 : : is contiguous. Repacking higher dimensions wouldn't gain us
7390 : : anything as we still don't know the array stride. */
7391 : 1 : partial = gfc_create_var (logical_type_node, "partial");
7392 : 1 : TREE_USED (partial) = 1;
7393 : 1 : tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
7394 : 1 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, tmp,
7395 : : gfc_index_one_node);
7396 : 1 : gfc_add_modify (&init, partial, tmp);
7397 : : }
7398 : : else
7399 : : partial = NULL_TREE;
7400 : :
7401 : : /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
7402 : : here, however I think it does the right thing. */
7403 : 6550 : if (no_repack)
7404 : : {
7405 : : /* Set the first stride. */
7406 : 6548 : stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
7407 : 6548 : stride = gfc_evaluate_now (stride, &init);
7408 : :
7409 : 6548 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7410 : : stride, gfc_index_zero_node);
7411 : 6548 : tmp = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
7412 : : tmp, gfc_index_one_node, stride);
7413 : 6548 : stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
7414 : 6548 : gfc_add_modify (&init, stride, tmp);
7415 : :
7416 : : /* Allow the user to disable array repacking. */
7417 : 6548 : stmt_unpacked = NULL_TREE;
7418 : : }
7419 : : else
7420 : : {
7421 : 2 : gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
7422 : : /* A library call to repack the array if necessary. */
7423 : 2 : tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
7424 : 2 : stmt_unpacked = build_call_expr_loc (input_location,
7425 : : gfor_fndecl_in_pack, 1, tmp);
7426 : :
7427 : 2 : stride = gfc_index_one_node;
7428 : :
7429 : 2 : if (warn_array_temporaries)
7430 : : {
7431 : 1 : locus where;
7432 : 1 : gfc_locus_from_location (&where, loc);
7433 : 1 : gfc_warning (OPT_Warray_temporaries,
7434 : : "Creating array temporary at %L", &where);
7435 : : }
7436 : : }
7437 : :
7438 : : /* This is for the case where the array data is used directly without
7439 : : calling the repack function. */
7440 : 6550 : if (no_repack || partial != NULL_TREE)
7441 : 6549 : stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
7442 : : else
7443 : : stmt_packed = NULL_TREE;
7444 : :
7445 : : /* Assign the data pointer. */
7446 : 6550 : if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
7447 : : {
7448 : : /* Don't repack unknown shape arrays when the first stride is 1. */
7449 : 1 : tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (stmt_packed),
7450 : : partial, stmt_packed, stmt_unpacked);
7451 : : }
7452 : : else
7453 : 6549 : tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
7454 : 6550 : gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp));
7455 : :
7456 : 6550 : offset = gfc_index_zero_node;
7457 : 6550 : size = gfc_index_one_node;
7458 : :
7459 : : /* Evaluate the bounds of the array. */
7460 : 15359 : for (n = 0; n < as->rank; n++)
7461 : : {
7462 : 8809 : if (checkparm || !as->upper[n])
7463 : : {
7464 : : /* Get the bounds of the actual parameter. */
7465 : 7529 : dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]);
7466 : 7529 : dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]);
7467 : : }
7468 : : else
7469 : : {
7470 : : dubound = NULL_TREE;
7471 : : dlbound = NULL_TREE;
7472 : : }
7473 : :
7474 : 8809 : lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
7475 : 8809 : if (!INTEGER_CST_P (lbound))
7476 : : {
7477 : 45 : gfc_init_se (&se, NULL);
7478 : 45 : gfc_conv_expr_type (&se, as->lower[n],
7479 : : gfc_array_index_type);
7480 : 45 : gfc_add_block_to_block (&init, &se.pre);
7481 : 45 : gfc_add_modify (&init, lbound, se.expr);
7482 : : }
7483 : :
7484 : 8809 : ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
7485 : : /* Set the desired upper bound. */
7486 : 8809 : if (as->upper[n])
7487 : : {
7488 : : /* We know what we want the upper bound to be. */
7489 : 1338 : if (!INTEGER_CST_P (ubound))
7490 : : {
7491 : 632 : gfc_init_se (&se, NULL);
7492 : 632 : gfc_conv_expr_type (&se, as->upper[n],
7493 : : gfc_array_index_type);
7494 : 632 : gfc_add_block_to_block (&init, &se.pre);
7495 : 632 : gfc_add_modify (&init, ubound, se.expr);
7496 : : }
7497 : :
7498 : : /* Check the sizes match. */
7499 : 1338 : if (checkparm)
7500 : : {
7501 : : /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
7502 : 58 : char * msg;
7503 : 58 : tree temp;
7504 : 58 : locus where;
7505 : :
7506 : 58 : gfc_locus_from_location (&where, loc);
7507 : 58 : temp = fold_build2_loc (input_location, MINUS_EXPR,
7508 : : gfc_array_index_type, ubound, lbound);
7509 : 58 : temp = fold_build2_loc (input_location, PLUS_EXPR,
7510 : : gfc_array_index_type,
7511 : : gfc_index_one_node, temp);
7512 : 58 : stride2 = fold_build2_loc (input_location, MINUS_EXPR,
7513 : : gfc_array_index_type, dubound,
7514 : : dlbound);
7515 : 58 : stride2 = fold_build2_loc (input_location, PLUS_EXPR,
7516 : : gfc_array_index_type,
7517 : : gfc_index_one_node, stride2);
7518 : 58 : tmp = fold_build2_loc (input_location, NE_EXPR,
7519 : : gfc_array_index_type, temp, stride2);
7520 : 58 : msg = xasprintf ("Dimension %d of array '%s' has extent "
7521 : : "%%ld instead of %%ld", n+1, sym->name);
7522 : :
7523 : 58 : gfc_trans_runtime_check (true, false, tmp, &init, &where, msg,
7524 : : fold_convert (long_integer_type_node, temp),
7525 : : fold_convert (long_integer_type_node, stride2));
7526 : :
7527 : 58 : free (msg);
7528 : : }
7529 : : }
7530 : : else
7531 : : {
7532 : : /* For assumed shape arrays move the upper bound by the same amount
7533 : : as the lower bound. */
7534 : 7471 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
7535 : : gfc_array_index_type, dubound, dlbound);
7536 : 7471 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
7537 : : gfc_array_index_type, tmp, lbound);
7538 : 7471 : gfc_add_modify (&init, ubound, tmp);
7539 : : }
7540 : : /* The offset of this dimension. offset = offset - lbound * stride. */
7541 : 8809 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7542 : : lbound, stride);
7543 : 8809 : offset = fold_build2_loc (input_location, MINUS_EXPR,
7544 : : gfc_array_index_type, offset, tmp);
7545 : :
7546 : : /* The size of this dimension, and the stride of the next. */
7547 : 8809 : if (n + 1 < as->rank)
7548 : : {
7549 : 2259 : stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
7550 : :
7551 : 2259 : if (no_repack || partial != NULL_TREE)
7552 : 2258 : stmt_unpacked =
7553 : 2258 : gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]);
7554 : :
7555 : : /* Figure out the stride if not a known constant. */
7556 : 2259 : if (!INTEGER_CST_P (stride))
7557 : : {
7558 : 2258 : if (no_repack)
7559 : : stmt_packed = NULL_TREE;
7560 : : else
7561 : : {
7562 : : /* Calculate stride = size * (ubound + 1 - lbound). */
7563 : 0 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
7564 : : gfc_array_index_type,
7565 : : gfc_index_one_node, lbound);
7566 : 0 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
7567 : : gfc_array_index_type, ubound, tmp);
7568 : 0 : size = fold_build2_loc (input_location, MULT_EXPR,
7569 : : gfc_array_index_type, size, tmp);
7570 : 0 : stmt_packed = size;
7571 : : }
7572 : :
7573 : : /* Assign the stride. */
7574 : 2258 : if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
7575 : 0 : tmp = fold_build3_loc (input_location, COND_EXPR,
7576 : : gfc_array_index_type, partial,
7577 : : stmt_unpacked, stmt_packed);
7578 : : else
7579 : 2258 : tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
7580 : 2258 : gfc_add_modify (&init, stride, tmp);
7581 : : }
7582 : : }
7583 : : else
7584 : : {
7585 : 6550 : stride = GFC_TYPE_ARRAY_SIZE (type);
7586 : :
7587 : 6550 : if (stride && !INTEGER_CST_P (stride))
7588 : : {
7589 : : /* Calculate size = stride * (ubound + 1 - lbound). */
7590 : 6549 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
7591 : : gfc_array_index_type,
7592 : : gfc_index_one_node, lbound);
7593 : 6549 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
7594 : : gfc_array_index_type,
7595 : : ubound, tmp);
7596 : 19647 : tmp = fold_build2_loc (input_location, MULT_EXPR,
7597 : : gfc_array_index_type,
7598 : 6549 : GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
7599 : 6549 : gfc_add_modify (&init, stride, tmp);
7600 : : }
7601 : : }
7602 : : }
7603 : :
7604 : 6550 : gfc_trans_array_cobounds (type, &init, sym);
7605 : :
7606 : : /* Set the offset. */
7607 : 6550 : if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
7608 : 6548 : gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
7609 : :
7610 : 6550 : gfc_trans_vla_type_sizes (sym, &init);
7611 : :
7612 : 6550 : stmtInit = gfc_finish_block (&init);
7613 : :
7614 : : /* Only do the entry/initialization code if the arg is present. */
7615 : 6550 : dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
7616 : 6550 : optional_arg = (sym->attr.optional
7617 : 6550 : || (sym->ns->proc_name->attr.entry_master
7618 : 79 : && sym->attr.dummy));
7619 : : if (optional_arg)
7620 : : {
7621 : 716 : tree zero_init = fold_convert (TREE_TYPE (tmpdesc), null_pointer_node);
7622 : 716 : zero_init = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
7623 : : tmpdesc, zero_init);
7624 : 716 : tmp = gfc_conv_expr_present (sym, true);
7625 : 716 : stmtInit = build3_v (COND_EXPR, tmp, stmtInit, zero_init);
7626 : : }
7627 : :
7628 : : /* Cleanup code. */
7629 : 6550 : if (no_repack)
7630 : : stmtCleanup = NULL_TREE;
7631 : : else
7632 : : {
7633 : 2 : stmtblock_t cleanup;
7634 : 2 : gfc_start_block (&cleanup);
7635 : :
7636 : 2 : if (sym->attr.intent != INTENT_IN)
7637 : : {
7638 : : /* Copy the data back. */
7639 : 2 : tmp = build_call_expr_loc (input_location,
7640 : : gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
7641 : 2 : gfc_add_expr_to_block (&cleanup, tmp);
7642 : : }
7643 : :
7644 : : /* Free the temporary. */
7645 : 2 : tmp = gfc_call_free (tmpdesc);
7646 : 2 : gfc_add_expr_to_block (&cleanup, tmp);
7647 : :
7648 : 2 : stmtCleanup = gfc_finish_block (&cleanup);
7649 : :
7650 : : /* Only do the cleanup if the array was repacked. */
7651 : 2 : if (is_classarray)
7652 : : /* For a class array the dummy array descriptor is in the _class
7653 : : component. */
7654 : 1 : tmp = gfc_class_data_get (dumdesc);
7655 : : else
7656 : 1 : tmp = build_fold_indirect_ref_loc (input_location, dumdesc);
7657 : 2 : tmp = gfc_conv_descriptor_data_get (tmp);
7658 : 2 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
7659 : : tmp, tmpdesc);
7660 : 2 : stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
7661 : : build_empty_stmt (input_location));
7662 : :
7663 : 2 : if (optional_arg)
7664 : : {
7665 : 0 : tmp = gfc_conv_expr_present (sym);
7666 : 0 : stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
7667 : : build_empty_stmt (input_location));
7668 : : }
7669 : : }
7670 : :
7671 : : /* We don't need to free any memory allocated by internal_pack as it will
7672 : : be freed at the end of the function by pop_context. */
7673 : 6550 : gfc_add_init_cleanup (block, stmtInit, stmtCleanup);
7674 : :
7675 : 6550 : input_location = loc;
7676 : : }
7677 : :
7678 : :
7679 : : /* Calculate the overall offset, including subreferences. */
7680 : : void
7681 : 56959 : gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
7682 : : bool subref, gfc_expr *expr)
7683 : : {
7684 : 56959 : tree tmp;
7685 : 56959 : tree field;
7686 : 56959 : tree stride;
7687 : 56959 : tree index;
7688 : 56959 : gfc_ref *ref;
7689 : 56959 : gfc_se start;
7690 : 56959 : int n;
7691 : :
7692 : : /* If offset is NULL and this is not a subreferenced array, there is
7693 : : nothing to do. */
7694 : 56959 : if (offset == NULL_TREE)
7695 : : {
7696 : 1017 : if (subref)
7697 : 115 : offset = gfc_index_zero_node;
7698 : : else
7699 : 902 : return;
7700 : : }
7701 : :
7702 : 56057 : tmp = build_array_ref (desc, offset, NULL, NULL);
7703 : :
7704 : : /* Offset the data pointer for pointer assignments from arrays with
7705 : : subreferences; e.g. my_integer => my_type(:)%integer_component. */
7706 : 56057 : if (subref)
7707 : : {
7708 : : /* Go past the array reference. */
7709 : 769 : for (ref = expr->ref; ref; ref = ref->next)
7710 : 769 : if (ref->type == REF_ARRAY &&
7711 : 683 : ref->u.ar.type != AR_ELEMENT)
7712 : : {
7713 : 659 : ref = ref->next;
7714 : 659 : break;
7715 : : }
7716 : :
7717 : : /* Calculate the offset for each subsequent subreference. */
7718 : 1290 : for (; ref; ref = ref->next)
7719 : : {
7720 : 631 : switch (ref->type)
7721 : : {
7722 : 264 : case REF_COMPONENT:
7723 : 264 : field = ref->u.c.component->backend_decl;
7724 : 264 : gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
7725 : 528 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
7726 : 264 : TREE_TYPE (field),
7727 : : tmp, field, NULL_TREE);
7728 : 264 : break;
7729 : :
7730 : 319 : case REF_SUBSTRING:
7731 : 319 : gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
7732 : 319 : gfc_init_se (&start, NULL);
7733 : 319 : gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
7734 : 319 : gfc_add_block_to_block (block, &start.pre);
7735 : 319 : tmp = gfc_build_array_ref (tmp, start.expr, NULL);
7736 : 319 : break;
7737 : :
7738 : 24 : case REF_ARRAY:
7739 : 24 : gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
7740 : : && ref->u.ar.type == AR_ELEMENT);
7741 : :
7742 : : /* TODO - Add bounds checking. */
7743 : 24 : stride = gfc_index_one_node;
7744 : 24 : index = gfc_index_zero_node;
7745 : 55 : for (n = 0; n < ref->u.ar.dimen; n++)
7746 : : {
7747 : 31 : tree itmp;
7748 : 31 : tree jtmp;
7749 : :
7750 : : /* Update the index. */
7751 : 31 : gfc_init_se (&start, NULL);
7752 : 31 : gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
7753 : 31 : itmp = gfc_evaluate_now (start.expr, block);
7754 : 31 : gfc_init_se (&start, NULL);
7755 : 31 : gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
7756 : 31 : jtmp = gfc_evaluate_now (start.expr, block);
7757 : 31 : itmp = fold_build2_loc (input_location, MINUS_EXPR,
7758 : : gfc_array_index_type, itmp, jtmp);
7759 : 31 : itmp = fold_build2_loc (input_location, MULT_EXPR,
7760 : : gfc_array_index_type, itmp, stride);
7761 : 31 : index = fold_build2_loc (input_location, PLUS_EXPR,
7762 : : gfc_array_index_type, itmp, index);
7763 : 31 : index = gfc_evaluate_now (index, block);
7764 : :
7765 : : /* Update the stride. */
7766 : 31 : gfc_init_se (&start, NULL);
7767 : 31 : gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
7768 : 31 : itmp = fold_build2_loc (input_location, MINUS_EXPR,
7769 : : gfc_array_index_type, start.expr,
7770 : : jtmp);
7771 : 31 : itmp = fold_build2_loc (input_location, PLUS_EXPR,
7772 : : gfc_array_index_type,
7773 : : gfc_index_one_node, itmp);
7774 : 31 : stride = fold_build2_loc (input_location, MULT_EXPR,
7775 : : gfc_array_index_type, stride, itmp);
7776 : 31 : stride = gfc_evaluate_now (stride, block);
7777 : : }
7778 : :
7779 : : /* Apply the index to obtain the array element. */
7780 : 24 : tmp = gfc_build_array_ref (tmp, index, NULL);
7781 : 24 : break;
7782 : :
7783 : 24 : case REF_INQUIRY:
7784 : 24 : switch (ref->u.i)
7785 : : {
7786 : 18 : case INQUIRY_RE:
7787 : 36 : tmp = fold_build1_loc (input_location, REALPART_EXPR,
7788 : 18 : TREE_TYPE (TREE_TYPE (tmp)), tmp);
7789 : 18 : break;
7790 : :
7791 : 6 : case INQUIRY_IM:
7792 : 12 : tmp = fold_build1_loc (input_location, IMAGPART_EXPR,
7793 : 6 : TREE_TYPE (TREE_TYPE (tmp)), tmp);
7794 : 6 : break;
7795 : :
7796 : : default:
7797 : : break;
7798 : : }
7799 : : break;
7800 : :
7801 : 0 : default:
7802 : 0 : gcc_unreachable ();
7803 : 631 : break;
7804 : : }
7805 : : }
7806 : : }
7807 : :
7808 : : /* Set the target data pointer. */
7809 : 56057 : offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
7810 : :
7811 : : /* Check for optional dummy argument being present. Arguments of BIND(C)
7812 : : procedures are excepted here since they are handled differently. */
7813 : 56057 : if (expr->expr_type == EXPR_VARIABLE
7814 : 49415 : && expr->symtree->n.sym->attr.dummy
7815 : 49415 : && expr->symtree->n.sym->attr.optional
7816 : 57048 : && !is_CFI_desc (NULL, expr))
7817 : 1622 : offset = build3_loc (input_location, COND_EXPR, TREE_TYPE (offset),
7818 : 811 : gfc_conv_expr_present (expr->symtree->n.sym), offset,
7819 : 811 : fold_convert (TREE_TYPE (offset), gfc_index_zero_node));
7820 : :
7821 : 56057 : gfc_conv_descriptor_data_set (block, parm, offset);
7822 : : }
7823 : :
7824 : :
7825 : : /* gfc_conv_expr_descriptor needs the string length an expression
7826 : : so that the size of the temporary can be obtained. This is done
7827 : : by adding up the string lengths of all the elements in the
7828 : : expression. Function with non-constant expressions have their
7829 : : string lengths mapped onto the actual arguments using the
7830 : : interface mapping machinery in trans-expr.cc. */
7831 : : static void
7832 : 1495 : get_array_charlen (gfc_expr *expr, gfc_se *se)
7833 : : {
7834 : 1495 : gfc_interface_mapping mapping;
7835 : 1495 : gfc_formal_arglist *formal;
7836 : 1495 : gfc_actual_arglist *arg;
7837 : 1495 : gfc_se tse;
7838 : 1495 : gfc_expr *e;
7839 : :
7840 : 1495 : if (expr->ts.u.cl->length
7841 : 1495 : && gfc_is_constant_expr (expr->ts.u.cl->length))
7842 : : {
7843 : 1151 : if (!expr->ts.u.cl->backend_decl)
7844 : 438 : gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
7845 : 1283 : return;
7846 : : }
7847 : :
7848 : 344 : switch (expr->expr_type)
7849 : : {
7850 : 130 : case EXPR_ARRAY:
7851 : :
7852 : : /* This is somewhat brutal. The expression for the first
7853 : : element of the array is evaluated and assigned to a
7854 : : new string length for the original expression. */
7855 : 130 : e = gfc_constructor_first (expr->value.constructor)->expr;
7856 : :
7857 : 130 : gfc_init_se (&tse, NULL);
7858 : :
7859 : : /* Avoid evaluating trailing array references since all we need is
7860 : : the string length. */
7861 : 130 : if (e->rank)
7862 : 38 : tse.descriptor_only = 1;
7863 : 130 : if (e->rank && e->expr_type != EXPR_VARIABLE)
7864 : 1 : gfc_conv_expr_descriptor (&tse, e);
7865 : : else
7866 : 129 : gfc_conv_expr (&tse, e);
7867 : :
7868 : 130 : gfc_add_block_to_block (&se->pre, &tse.pre);
7869 : 130 : gfc_add_block_to_block (&se->post, &tse.post);
7870 : :
7871 : 130 : if (!expr->ts.u.cl->backend_decl || !VAR_P (expr->ts.u.cl->backend_decl))
7872 : : {
7873 : 87 : expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
7874 : 87 : expr->ts.u.cl->backend_decl =
7875 : 87 : gfc_create_var (gfc_charlen_type_node, "sln");
7876 : : }
7877 : :
7878 : 130 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
7879 : : tse.string_length);
7880 : :
7881 : : /* Make sure that deferred length components point to the hidden
7882 : : string_length component. */
7883 : 130 : if (TREE_CODE (tse.expr) == COMPONENT_REF
7884 : 25 : && TREE_CODE (tse.string_length) == COMPONENT_REF
7885 : 149 : && TREE_OPERAND (tse.expr, 0) == TREE_OPERAND (tse.string_length, 0))
7886 : 19 : e->ts.u.cl->backend_decl = expr->ts.u.cl->backend_decl;
7887 : :
7888 : : return;
7889 : :
7890 : 90 : case EXPR_OP:
7891 : 90 : get_array_charlen (expr->value.op.op1, se);
7892 : :
7893 : : /* For parentheses the expression ts.u.cl should be identical. */
7894 : 90 : if (expr->value.op.op == INTRINSIC_PARENTHESES)
7895 : : {
7896 : 2 : if (expr->value.op.op1->ts.u.cl != expr->ts.u.cl)
7897 : 2 : expr->ts.u.cl->backend_decl
7898 : 2 : = expr->value.op.op1->ts.u.cl->backend_decl;
7899 : 2 : return;
7900 : : }
7901 : :
7902 : 176 : expr->ts.u.cl->backend_decl =
7903 : 88 : gfc_create_var (gfc_charlen_type_node, "sln");
7904 : :
7905 : 88 : if (expr->value.op.op2)
7906 : : {
7907 : 88 : get_array_charlen (expr->value.op.op2, se);
7908 : :
7909 : 88 : gcc_assert (expr->value.op.op == INTRINSIC_CONCAT);
7910 : :
7911 : : /* Add the string lengths and assign them to the expression
7912 : : string length backend declaration. */
7913 : 88 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
7914 : : fold_build2_loc (input_location, PLUS_EXPR,
7915 : : gfc_charlen_type_node,
7916 : 88 : expr->value.op.op1->ts.u.cl->backend_decl,
7917 : 88 : expr->value.op.op2->ts.u.cl->backend_decl));
7918 : : }
7919 : : else
7920 : 0 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
7921 : 0 : expr->value.op.op1->ts.u.cl->backend_decl);
7922 : : break;
7923 : :
7924 : 43 : case EXPR_FUNCTION:
7925 : 43 : if (expr->value.function.esym == NULL
7926 : 37 : || expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
7927 : : {
7928 : 6 : gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
7929 : 6 : break;
7930 : : }
7931 : :
7932 : : /* Map expressions involving the dummy arguments onto the actual
7933 : : argument expressions. */
7934 : 37 : gfc_init_interface_mapping (&mapping);
7935 : 37 : formal = gfc_sym_get_dummy_args (expr->symtree->n.sym);
7936 : 37 : arg = expr->value.function.actual;
7937 : :
7938 : : /* Set se = NULL in the calls to the interface mapping, to suppress any
7939 : : backend stuff. */
7940 : 113 : for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
7941 : : {
7942 : 38 : if (!arg->expr)
7943 : 0 : continue;
7944 : 38 : if (formal->sym)
7945 : 38 : gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
7946 : : }
7947 : :
7948 : 37 : gfc_init_se (&tse, NULL);
7949 : :
7950 : : /* Build the expression for the character length and convert it. */
7951 : 37 : gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length);
7952 : :
7953 : 37 : gfc_add_block_to_block (&se->pre, &tse.pre);
7954 : 37 : gfc_add_block_to_block (&se->post, &tse.post);
7955 : 37 : tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
7956 : 74 : tse.expr = fold_build2_loc (input_location, MAX_EXPR,
7957 : 37 : TREE_TYPE (tse.expr), tse.expr,
7958 : 37 : build_zero_cst (TREE_TYPE (tse.expr)));
7959 : 37 : expr->ts.u.cl->backend_decl = tse.expr;
7960 : 37 : gfc_free_interface_mapping (&mapping);
7961 : 37 : break;
7962 : :
7963 : 81 : default:
7964 : 81 : gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
7965 : 81 : break;
7966 : : }
7967 : : }
7968 : :
7969 : :
7970 : : /* Helper function to check dimensions. */
7971 : : static bool
7972 : 144 : transposed_dims (gfc_ss *ss)
7973 : : {
7974 : 144 : int n;
7975 : :
7976 : 166938 : for (n = 0; n < ss->dimen; n++)
7977 : 86242 : if (ss->dim[n] != n)
7978 : : return true;
7979 : : return false;
7980 : : }
7981 : :
7982 : :
7983 : : /* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
7984 : : AR_FULL, suitable for the scalarizer. */
7985 : :
7986 : : static gfc_ss *
7987 : 1143 : walk_coarray (gfc_expr *e)
7988 : : {
7989 : 1143 : gfc_ss *ss;
7990 : :
7991 : 1143 : ss = gfc_walk_expr (e);
7992 : :
7993 : : /* Fix scalar coarray. */
7994 : 1143 : if (ss == gfc_ss_terminator)
7995 : : {
7996 : 226 : gfc_ref *ref;
7997 : :
7998 : 226 : ref = e->ref;
7999 : 343 : while (ref)
8000 : : {
8001 : 343 : if (ref->type == REF_ARRAY
8002 : 226 : && ref->u.ar.codimen > 0)
8003 : : break;
8004 : :
8005 : 117 : ref = ref->next;
8006 : : }
8007 : :
8008 : 226 : gcc_assert (ref != NULL);
8009 : 226 : if (ref->u.ar.type == AR_ELEMENT)
8010 : 212 : ref->u.ar.type = AR_SECTION;
8011 : 226 : ss = gfc_reverse_ss (gfc_walk_array_ref (ss, e, ref, false));
8012 : : }
8013 : :
8014 : 1143 : return ss;
8015 : : }
8016 : :
8017 : : gfc_array_spec *
8018 : 1768 : get_coarray_as (const gfc_expr *e)
8019 : : {
8020 : 1768 : gfc_array_spec *as;
8021 : 1768 : gfc_symbol *sym = e->symtree->n.sym;
8022 : 1768 : gfc_component *comp;
8023 : :
8024 : 1768 : if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.codimension)
8025 : 551 : as = CLASS_DATA (sym)->as;
8026 : 1217 : else if (sym->attr.codimension)
8027 : 1171 : as = sym->as;
8028 : : else
8029 : : as = nullptr;
8030 : :
8031 : 4187 : for (gfc_ref *ref = e->ref; ref; ref = ref->next)
8032 : : {
8033 : 2419 : switch (ref->type)
8034 : : {
8035 : 651 : case REF_COMPONENT:
8036 : 651 : comp = ref->u.c.component;
8037 : 651 : if (comp->ts.type == BT_CLASS && CLASS_DATA (comp)->attr.codimension)
8038 : 18 : as = CLASS_DATA (comp)->as;
8039 : 633 : else if (comp->ts.type != BT_CLASS && comp->attr.codimension)
8040 : 597 : as = comp->as;
8041 : : break;
8042 : :
8043 : : case REF_ARRAY:
8044 : : case REF_SUBSTRING:
8045 : : case REF_INQUIRY:
8046 : : break;
8047 : : }
8048 : : }
8049 : :
8050 : 1768 : return as;
8051 : : }
8052 : :
8053 : : bool
8054 : 134464 : is_explicit_coarray (gfc_expr *expr)
8055 : : {
8056 : 134464 : if (!gfc_is_coarray (expr))
8057 : : return false;
8058 : :
8059 : 1768 : gfc_array_spec *cas = get_coarray_as (expr);
8060 : 1768 : return cas && cas->cotype == AS_EXPLICIT;
8061 : : }
8062 : :
8063 : : /* Convert an array for passing as an actual argument. Expressions and
8064 : : vector subscripts are evaluated and stored in a temporary, which is then
8065 : : passed. For whole arrays the descriptor is passed. For array sections
8066 : : a modified copy of the descriptor is passed, but using the original data.
8067 : :
8068 : : This function is also used for array pointer assignments, and there
8069 : : are three cases:
8070 : :
8071 : : - se->want_pointer && !se->direct_byref
8072 : : EXPR is an actual argument. On exit, se->expr contains a
8073 : : pointer to the array descriptor.
8074 : :
8075 : : - !se->want_pointer && !se->direct_byref
8076 : : EXPR is an actual argument to an intrinsic function or the
8077 : : left-hand side of a pointer assignment. On exit, se->expr
8078 : : contains the descriptor for EXPR.
8079 : :
8080 : : - !se->want_pointer && se->direct_byref
8081 : : EXPR is the right-hand side of a pointer assignment and
8082 : : se->expr is the descriptor for the previously-evaluated
8083 : : left-hand side. The function creates an assignment from
8084 : : EXPR to se->expr.
8085 : :
8086 : :
8087 : : The se->force_tmp flag disables the non-copying descriptor optimization
8088 : : that is used for transpose. It may be used in cases where there is an
8089 : : alias between the transpose argument and another argument in the same
8090 : : function call. */
8091 : :
8092 : : void
8093 : 150236 : gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
8094 : : {
8095 : 150236 : gfc_ss *ss;
8096 : 150236 : gfc_ss_type ss_type;
8097 : 150236 : gfc_ss_info *ss_info;
8098 : 150236 : gfc_loopinfo loop;
8099 : 150236 : gfc_array_info *info;
8100 : 150236 : int need_tmp;
8101 : 150236 : int n;
8102 : 150236 : tree tmp;
8103 : 150236 : tree desc;
8104 : 150236 : stmtblock_t block;
8105 : 150236 : tree start;
8106 : 150236 : int full;
8107 : 150236 : bool subref_array_target = false;
8108 : 150236 : bool deferred_array_component = false;
8109 : 150236 : bool substr = false;
8110 : 150236 : gfc_expr *arg, *ss_expr;
8111 : :
8112 : 150236 : if (se->want_coarray || expr->rank == 0)
8113 : 1143 : ss = walk_coarray (expr);
8114 : : else
8115 : 149093 : ss = gfc_walk_expr (expr);
8116 : :
8117 : 150236 : gcc_assert (ss != NULL);
8118 : 150236 : gcc_assert (ss != gfc_ss_terminator);
8119 : :
8120 : 150236 : ss_info = ss->info;
8121 : 150236 : ss_type = ss_info->type;
8122 : 150236 : ss_expr = ss_info->expr;
8123 : :
8124 : : /* Special case: TRANSPOSE which needs no temporary. */
8125 : 155407 : while (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym
8126 : 155140 : && (arg = gfc_get_noncopying_intrinsic_argument (expr)) != NULL)
8127 : : {
8128 : : /* This is a call to transpose which has already been handled by the
8129 : : scalarizer, so that we just need to get its argument's descriptor. */
8130 : 407 : gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
8131 : 407 : expr = expr->value.function.actual->expr;
8132 : : }
8133 : :
8134 : 150236 : if (!se->direct_byref)
8135 : 288826 : se->unlimited_polymorphic = UNLIMITED_POLY (expr);
8136 : :
8137 : : /* Special case things we know we can pass easily. */
8138 : 150236 : switch (expr->expr_type)
8139 : : {
8140 : 134630 : case EXPR_VARIABLE:
8141 : : /* If we have a linear array section, we can pass it directly.
8142 : : Otherwise we need to copy it into a temporary. */
8143 : :
8144 : 134630 : gcc_assert (ss_type == GFC_SS_SECTION);
8145 : 134630 : gcc_assert (ss_expr == expr);
8146 : 134630 : info = &ss_info->data.array;
8147 : :
8148 : : /* Get the descriptor for the array. */
8149 : 134630 : gfc_conv_ss_descriptor (&se->pre, ss, 0);
8150 : 134630 : desc = info->descriptor;
8151 : :
8152 : : /* The charlen backend decl for deferred character components cannot
8153 : : be used because it is fixed at zero. Instead, the hidden string
8154 : : length component is used. */
8155 : 134630 : if (expr->ts.type == BT_CHARACTER
8156 : 19363 : && expr->ts.deferred
8157 : 2680 : && TREE_CODE (desc) == COMPONENT_REF)
8158 : 134630 : deferred_array_component = true;
8159 : :
8160 : 134630 : substr = info->ref && info->ref->next
8161 : 135331 : && info->ref->next->type == REF_SUBSTRING;
8162 : :
8163 : 134630 : subref_array_target = (is_subref_array (expr)
8164 : 134630 : && (se->direct_byref
8165 : 2265 : || expr->ts.type == BT_CHARACTER));
8166 : 134630 : need_tmp = (gfc_ref_needs_temporary_p (expr->ref)
8167 : 134630 : && !subref_array_target);
8168 : :
8169 : 134630 : if (se->force_tmp)
8170 : : need_tmp = 1;
8171 : 134560 : else if (se->force_no_tmp)
8172 : : need_tmp = 0;
8173 : :
8174 : 128417 : if (need_tmp)
8175 : : full = 0;
8176 : 134464 : else if (is_explicit_coarray (expr))
8177 : : full = 0;
8178 : 133853 : else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
8179 : : {
8180 : : /* Create a new descriptor if the array doesn't have one. */
8181 : : full = 0;
8182 : : }
8183 : 86724 : else if (info->ref->u.ar.type == AR_FULL || se->descriptor_only)
8184 : : full = 1;
8185 : 7812 : else if (se->direct_byref)
8186 : : full = 0;
8187 : 7480 : else if (info->ref->u.ar.dimen == 0 && !info->ref->next)
8188 : : full = 1;
8189 : 7374 : else if (info->ref->u.ar.type == AR_SECTION && se->want_pointer)
8190 : : full = 0;
8191 : : else
8192 : 3551 : full = gfc_full_array_ref_p (info->ref, NULL);
8193 : :
8194 : 161827 : if (full && !transposed_dims (ss))
8195 : : {
8196 : 79201 : if (se->direct_byref && !se->byref_noassign)
8197 : : {
8198 : 1005 : struct lang_type *lhs_ls
8199 : 1005 : = TYPE_LANG_SPECIFIC (TREE_TYPE (se->expr)),
8200 : 1005 : *rhs_ls = TYPE_LANG_SPECIFIC (TREE_TYPE (desc));
8201 : : /* When only the array_kind differs, do a view_convert. */
8202 : 1005 : tmp = lhs_ls && rhs_ls && lhs_ls->rank == rhs_ls->rank
8203 : 1005 : && lhs_ls->akind != rhs_ls->akind
8204 : 1357 : ? build1 (VIEW_CONVERT_EXPR, TREE_TYPE (se->expr), desc)
8205 : : : desc;
8206 : : /* Copy the descriptor for pointer assignments. */
8207 : 1005 : gfc_add_modify (&se->pre, se->expr, tmp);
8208 : :
8209 : : /* Add any offsets from subreferences. */
8210 : 1005 : gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
8211 : : subref_array_target, expr);
8212 : :
8213 : : /* ....and set the span field. */
8214 : 1005 : if (ss_info->expr->ts.type == BT_CHARACTER)
8215 : 141 : tmp = gfc_conv_descriptor_span_get (desc);
8216 : : else
8217 : 864 : tmp = gfc_get_array_span (desc, expr);
8218 : 1005 : gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp);
8219 : : }
8220 : 78196 : else if (se->want_pointer)
8221 : : {
8222 : : /* We pass full arrays directly. This means that pointers and
8223 : : allocatable arrays should also work. */
8224 : 13451 : se->expr = gfc_build_addr_expr (NULL_TREE, desc);
8225 : : }
8226 : : else
8227 : : {
8228 : 64745 : se->expr = desc;
8229 : : }
8230 : :
8231 : 79201 : if (expr->ts.type == BT_CHARACTER && !deferred_array_component)
8232 : 8247 : se->string_length = gfc_get_expr_charlen (expr);
8233 : : /* The ss_info string length is returned set to the value of the
8234 : : hidden string length component. */
8235 : 70712 : else if (deferred_array_component)
8236 : 242 : se->string_length = ss_info->string_length;
8237 : :
8238 : 79201 : se->class_container = ss_info->class_container;
8239 : :
8240 : 79201 : gfc_free_ss_chain (ss);
8241 : 158528 : return;
8242 : : }
8243 : : break;
8244 : :
8245 : 4764 : case EXPR_FUNCTION:
8246 : : /* A transformational function return value will be a temporary
8247 : : array descriptor. We still need to go through the scalarizer
8248 : : to create the descriptor. Elemental functions are handled as
8249 : : arbitrary expressions, i.e. copy to a temporary. */
8250 : :
8251 : 4764 : if (se->direct_byref)
8252 : : {
8253 : 126 : gcc_assert (ss_type == GFC_SS_FUNCTION && ss_expr == expr);
8254 : :
8255 : : /* For pointer assignments pass the descriptor directly. */
8256 : 126 : if (se->ss == NULL)
8257 : 126 : se->ss = ss;
8258 : : else
8259 : 0 : gcc_assert (se->ss == ss);
8260 : :
8261 : 126 : if (!is_pointer_array (se->expr))
8262 : : {
8263 : 120 : tmp = gfc_get_element_type (TREE_TYPE (se->expr));
8264 : 120 : tmp = fold_convert (gfc_array_index_type,
8265 : : size_in_bytes (tmp));
8266 : 120 : gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp);
8267 : : }
8268 : :
8269 : 126 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
8270 : 126 : gfc_conv_expr (se, expr);
8271 : :
8272 : 126 : gfc_free_ss_chain (ss);
8273 : 126 : return;
8274 : : }
8275 : :
8276 : 4638 : if (ss_expr != expr || ss_type != GFC_SS_FUNCTION)
8277 : : {
8278 : 3268 : if (ss_expr != expr)
8279 : : /* Elemental function. */
8280 : 2543 : gcc_assert ((expr->value.function.esym != NULL
8281 : : && expr->value.function.esym->attr.elemental)
8282 : : || (expr->value.function.isym != NULL
8283 : : && expr->value.function.isym->elemental)
8284 : : || (gfc_expr_attr (expr).proc_pointer
8285 : : && gfc_expr_attr (expr).elemental)
8286 : : || gfc_inline_intrinsic_function_p (expr));
8287 : :
8288 : 3268 : need_tmp = 1;
8289 : 3268 : if (expr->ts.type == BT_CHARACTER
8290 : 35 : && expr->ts.u.cl->length
8291 : 29 : && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
8292 : 13 : get_array_charlen (expr, se);
8293 : :
8294 : : info = NULL;
8295 : : }
8296 : : else
8297 : : {
8298 : : /* Transformational function. */
8299 : 1370 : info = &ss_info->data.array;
8300 : 1370 : need_tmp = 0;
8301 : : }
8302 : : break;
8303 : :
8304 : 10152 : case EXPR_ARRAY:
8305 : : /* Constant array constructors don't need a temporary. */
8306 : 10152 : if (ss_type == GFC_SS_CONSTRUCTOR
8307 : 10152 : && expr->ts.type != BT_CHARACTER
8308 : 19128 : && gfc_constant_array_constructor_p (expr->value.constructor))
8309 : : {
8310 : 6629 : need_tmp = 0;
8311 : 6629 : info = &ss_info->data.array;
8312 : : }
8313 : : else
8314 : : {
8315 : : need_tmp = 1;
8316 : : info = NULL;
8317 : : }
8318 : : break;
8319 : :
8320 : : default:
8321 : : /* Something complicated. Copy it into a temporary. */
8322 : : need_tmp = 1;
8323 : : info = NULL;
8324 : : break;
8325 : : }
8326 : :
8327 : : /* If we are creating a temporary, we don't need to bother about aliases
8328 : : anymore. */
8329 : 63428 : if (need_tmp)
8330 : 7647 : se->force_tmp = 0;
8331 : :
8332 : 70909 : gfc_init_loopinfo (&loop);
8333 : :
8334 : : /* Associate the SS with the loop. */
8335 : 70909 : gfc_add_ss_to_loop (&loop, ss);
8336 : :
8337 : : /* Tell the scalarizer not to bother creating loop variables, etc. */
8338 : 70909 : if (!need_tmp)
8339 : 63262 : loop.array_parameter = 1;
8340 : : else
8341 : : /* The right-hand side of a pointer assignment mustn't use a temporary. */
8342 : 7647 : gcc_assert (!se->direct_byref);
8343 : :
8344 : : /* Do we need bounds checking or not? */
8345 : 70909 : ss->no_bounds_check = expr->no_bounds_check;
8346 : :
8347 : : /* Setup the scalarizing loops and bounds. */
8348 : 70909 : gfc_conv_ss_startstride (&loop);
8349 : :
8350 : : /* Add bounds-checking for elemental dimensions. */
8351 : 70909 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !expr->no_bounds_check)
8352 : 6649 : array_bound_check_elemental (se, ss, expr);
8353 : :
8354 : 70909 : if (need_tmp)
8355 : : {
8356 : 7647 : if (expr->ts.type == BT_CHARACTER
8357 : 1384 : && (!expr->ts.u.cl->backend_decl || expr->expr_type == EXPR_ARRAY))
8358 : 1304 : get_array_charlen (expr, se);
8359 : :
8360 : : /* Tell the scalarizer to make a temporary. */
8361 : 7647 : loop.temp_ss = gfc_get_temp_ss (gfc_typenode_for_spec (&expr->ts),
8362 : 7647 : ((expr->ts.type == BT_CHARACTER)
8363 : 1384 : ? expr->ts.u.cl->backend_decl
8364 : : : NULL),
8365 : : loop.dimen);
8366 : :
8367 : 7647 : se->string_length = loop.temp_ss->info->string_length;
8368 : 7647 : gcc_assert (loop.temp_ss->dimen == loop.dimen);
8369 : 7647 : gfc_add_ss_to_loop (&loop, loop.temp_ss);
8370 : : }
8371 : :
8372 : 70909 : gfc_conv_loop_setup (&loop, & expr->where);
8373 : :
8374 : 70909 : if (need_tmp)
8375 : : {
8376 : : /* Copy into a temporary and pass that. We don't need to copy the data
8377 : : back because expressions and vector subscripts must be INTENT_IN. */
8378 : : /* TODO: Optimize passing function return values. */
8379 : 7647 : gfc_se lse;
8380 : 7647 : gfc_se rse;
8381 : 7647 : bool deep_copy;
8382 : :
8383 : : /* Start the copying loops. */
8384 : 7647 : gfc_mark_ss_chain_used (loop.temp_ss, 1);
8385 : 7647 : gfc_mark_ss_chain_used (ss, 1);
8386 : 7647 : gfc_start_scalarized_body (&loop, &block);
8387 : :
8388 : : /* Copy each data element. */
8389 : 7647 : gfc_init_se (&lse, NULL);
8390 : 7647 : gfc_copy_loopinfo_to_se (&lse, &loop);
8391 : 7647 : gfc_init_se (&rse, NULL);
8392 : 7647 : gfc_copy_loopinfo_to_se (&rse, &loop);
8393 : :
8394 : 7647 : lse.ss = loop.temp_ss;
8395 : 7647 : rse.ss = ss;
8396 : :
8397 : 7647 : gfc_conv_tmp_array_ref (&lse);
8398 : 7647 : if (expr->ts.type == BT_CHARACTER)
8399 : : {
8400 : 1384 : gfc_conv_expr (&rse, expr);
8401 : 1384 : if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
8402 : 1087 : rse.expr = build_fold_indirect_ref_loc (input_location,
8403 : : rse.expr);
8404 : : }
8405 : : else
8406 : 6263 : gfc_conv_expr_val (&rse, expr);
8407 : :
8408 : 7647 : gfc_add_block_to_block (&block, &rse.pre);
8409 : 7647 : gfc_add_block_to_block (&block, &lse.pre);
8410 : :
8411 : 7647 : lse.string_length = rse.string_length;
8412 : :
8413 : 15294 : deep_copy = !se->data_not_needed
8414 : 7647 : && (expr->expr_type == EXPR_VARIABLE
8415 : 7228 : || expr->expr_type == EXPR_ARRAY);
8416 : 7647 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts,
8417 : : deep_copy, false);
8418 : 7647 : gfc_add_expr_to_block (&block, tmp);
8419 : :
8420 : : /* Finish the copying loops. */
8421 : 7647 : gfc_trans_scalarizing_loops (&loop, &block);
8422 : :
8423 : 7647 : desc = loop.temp_ss->info->data.array.descriptor;
8424 : : }
8425 : 64632 : else if (expr->expr_type == EXPR_FUNCTION && !transposed_dims (ss))
8426 : : {
8427 : 1357 : desc = info->descriptor;
8428 : 1357 : se->string_length = ss_info->string_length;
8429 : : }
8430 : : else
8431 : : {
8432 : : /* We pass sections without copying to a temporary. Make a new
8433 : : descriptor and point it at the section we want. The loop variable
8434 : : limits will be the limits of the section.
8435 : : A function may decide to repack the array to speed up access, but
8436 : : we're not bothered about that here. */
8437 : 61905 : int dim, ndim, codim;
8438 : 61905 : tree parm;
8439 : 61905 : tree parmtype;
8440 : 61905 : tree dtype;
8441 : 61905 : tree stride;
8442 : 61905 : tree from;
8443 : 61905 : tree to;
8444 : 61905 : tree base;
8445 : 61905 : tree offset;
8446 : :
8447 : 61905 : ndim = info->ref ? info->ref->u.ar.dimen : ss->dimen;
8448 : :
8449 : 61905 : if (se->want_coarray)
8450 : : {
8451 : 502 : gfc_array_ref *ar = &info->ref->u.ar;
8452 : :
8453 : 502 : codim = expr->corank;
8454 : 1030 : for (n = 0; n < codim - 1; n++)
8455 : : {
8456 : : /* Make sure we are not lost somehow. */
8457 : 528 : gcc_assert (ar->dimen_type[n + ndim] == DIMEN_THIS_IMAGE);
8458 : :
8459 : : /* Make sure the call to gfc_conv_section_startstride won't
8460 : : generate unnecessary code to calculate stride. */
8461 : 528 : gcc_assert (ar->stride[n + ndim] == NULL);
8462 : :
8463 : 528 : gfc_conv_section_startstride (&loop.pre, ss, n + ndim);
8464 : 528 : loop.from[n + loop.dimen] = info->start[n + ndim];
8465 : 528 : loop.to[n + loop.dimen] = info->end[n + ndim];
8466 : : }
8467 : :
8468 : 502 : gcc_assert (n == codim - 1);
8469 : 502 : evaluate_bound (&loop.pre, info->start, ar->start,
8470 : : info->descriptor, n + ndim, true,
8471 : 502 : ar->as->type == AS_DEFERRED);
8472 : 502 : loop.from[n + loop.dimen] = info->start[n + ndim];
8473 : : }
8474 : : else
8475 : : codim = 0;
8476 : :
8477 : : /* Set the string_length for a character array. */
8478 : 61905 : if (expr->ts.type == BT_CHARACTER)
8479 : : {
8480 : 10857 : if (deferred_array_component && !substr)
8481 : 37 : se->string_length = ss_info->string_length;
8482 : : else
8483 : 10820 : se->string_length = gfc_get_expr_charlen (expr);
8484 : :
8485 : 10857 : if (VAR_P (se->string_length)
8486 : 942 : && expr->ts.u.cl->backend_decl == se->string_length)
8487 : 936 : tmp = ss_info->string_length;
8488 : : else
8489 : : tmp = se->string_length;
8490 : :
8491 : 10857 : if (expr->ts.deferred && expr->ts.u.cl->backend_decl
8492 : 168 : && VAR_P (expr->ts.u.cl->backend_decl))
8493 : 108 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, tmp);
8494 : : else
8495 : 10749 : expr->ts.u.cl->backend_decl = tmp;
8496 : : }
8497 : :
8498 : : /* If we have an array section, are assigning or passing an array
8499 : : section argument make sure that the lower bound is 1. References
8500 : : to the full array should otherwise keep the original bounds. */
8501 : 61905 : if (!info->ref || info->ref->u.ar.type != AR_FULL)
8502 : 76286 : for (dim = 0; dim < loop.dimen; dim++)
8503 : 46036 : if (!integer_onep (loop.from[dim]))
8504 : : {
8505 : 26558 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
8506 : : gfc_array_index_type, gfc_index_one_node,
8507 : : loop.from[dim]);
8508 : 26558 : loop.to[dim] = fold_build2_loc (input_location, PLUS_EXPR,
8509 : : gfc_array_index_type,
8510 : : loop.to[dim], tmp);
8511 : 26558 : loop.from[dim] = gfc_index_one_node;
8512 : : }
8513 : :
8514 : 61905 : desc = info->descriptor;
8515 : 61905 : if (se->direct_byref && !se->byref_noassign)
8516 : : {
8517 : : /* For pointer assignments we fill in the destination. */
8518 : 2587 : parm = se->expr;
8519 : 2587 : parmtype = TREE_TYPE (parm);
8520 : : }
8521 : : else
8522 : : {
8523 : : /* Otherwise make a new one. */
8524 : 59318 : if (expr->ts.type == BT_CHARACTER)
8525 : 10229 : parmtype = gfc_typenode_for_spec (&expr->ts);
8526 : : else
8527 : 49089 : parmtype = gfc_get_element_type (TREE_TYPE (desc));
8528 : :
8529 : 59318 : parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, codim,
8530 : : loop.from, loop.to, 0,
8531 : : GFC_ARRAY_UNKNOWN, false);
8532 : 59318 : parm = gfc_create_var (parmtype, "parm");
8533 : :
8534 : : /* When expression is a class object, then add the class' handle to
8535 : : the parm_decl. */
8536 : 59318 : if (expr->ts.type == BT_CLASS && expr->expr_type == EXPR_VARIABLE)
8537 : : {
8538 : 1122 : gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr);
8539 : 1122 : gfc_se classse;
8540 : :
8541 : : /* class_expr can be NULL, when no _class ref is in expr.
8542 : : We must not fix this here with a gfc_fix_class_ref (). */
8543 : 1122 : if (class_expr)
8544 : : {
8545 : 1112 : gfc_init_se (&classse, NULL);
8546 : 1112 : gfc_conv_expr (&classse, class_expr);
8547 : 1112 : gfc_free_expr (class_expr);
8548 : :
8549 : 1112 : gcc_assert (classse.pre.head == NULL_TREE
8550 : : && classse.post.head == NULL_TREE);
8551 : 1112 : gfc_allocate_lang_decl (parm);
8552 : 1112 : GFC_DECL_SAVED_DESCRIPTOR (parm) = classse.expr;
8553 : : }
8554 : : }
8555 : : }
8556 : :
8557 : 61905 : if (expr->ts.type == BT_CHARACTER
8558 : 61905 : && VAR_P (TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (parm)))))
8559 : : {
8560 : 0 : tree elem_len = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (parm)));
8561 : 0 : gfc_add_modify (&loop.pre, elem_len,
8562 : 0 : fold_convert (TREE_TYPE (elem_len),
8563 : : gfc_get_array_span (desc, expr)));
8564 : : }
8565 : :
8566 : : /* Set the span field. */
8567 : 61905 : tmp = NULL_TREE;
8568 : 61905 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
8569 : 7552 : tmp = gfc_conv_descriptor_span_get (desc);
8570 : : else
8571 : 54353 : tmp = gfc_get_array_span (desc, expr);
8572 : 61905 : if (tmp)
8573 : 61825 : gfc_conv_descriptor_span_set (&loop.pre, parm, tmp);
8574 : :
8575 : : /* The following can be somewhat confusing. We have two
8576 : : descriptors, a new one and the original array.
8577 : : {parm, parmtype, dim} refer to the new one.
8578 : : {desc, type, n, loop} refer to the original, which maybe
8579 : : a descriptorless array.
8580 : : The bounds of the scalarization are the bounds of the section.
8581 : : We don't have to worry about numeric overflows when calculating
8582 : : the offsets because all elements are within the array data. */
8583 : :
8584 : : /* Set the dtype. */
8585 : 61905 : tmp = gfc_conv_descriptor_dtype (parm);
8586 : 61905 : if (se->unlimited_polymorphic)
8587 : 565 : dtype = gfc_get_dtype (TREE_TYPE (desc), &loop.dimen);
8588 : 61340 : else if (expr->ts.type == BT_ASSUMED)
8589 : : {
8590 : 127 : tree tmp2 = desc;
8591 : 127 : if (DECL_LANG_SPECIFIC (tmp2) && GFC_DECL_SAVED_DESCRIPTOR (tmp2))
8592 : 127 : tmp2 = GFC_DECL_SAVED_DESCRIPTOR (tmp2);
8593 : 127 : if (POINTER_TYPE_P (TREE_TYPE (tmp2)))
8594 : 127 : tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
8595 : 127 : dtype = gfc_conv_descriptor_dtype (tmp2);
8596 : : }
8597 : : else
8598 : 61213 : dtype = gfc_get_dtype (parmtype);
8599 : 61905 : gfc_add_modify (&loop.pre, tmp, dtype);
8600 : :
8601 : : /* The 1st element in the section. */
8602 : 61905 : base = gfc_index_zero_node;
8603 : 61905 : if (expr->ts.type == BT_CHARACTER && expr->rank == 0 && codim)
8604 : 6 : base = gfc_index_one_node;
8605 : :
8606 : : /* The offset from the 1st element in the section. */
8607 : : offset = gfc_index_zero_node;
8608 : :
8609 : 158667 : for (n = 0; n < ndim; n++)
8610 : : {
8611 : 96762 : stride = gfc_conv_array_stride (desc, n);
8612 : :
8613 : : /* Work out the 1st element in the section. */
8614 : 96762 : if (info->ref
8615 : 89807 : && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
8616 : : {
8617 : 1141 : gcc_assert (info->subscript[n]
8618 : : && info->subscript[n]->info->type == GFC_SS_SCALAR);
8619 : 1141 : start = info->subscript[n]->info->data.scalar.value;
8620 : : }
8621 : : else
8622 : : {
8623 : : /* Evaluate and remember the start of the section. */
8624 : 95621 : start = info->start[n];
8625 : 95621 : stride = gfc_evaluate_now (stride, &loop.pre);
8626 : : }
8627 : :
8628 : 96762 : tmp = gfc_conv_array_lbound (desc, n);
8629 : 96762 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
8630 : : start, tmp);
8631 : 96762 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
8632 : : tmp, stride);
8633 : 96762 : base = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
8634 : : base, tmp);
8635 : :
8636 : 96762 : if (info->ref
8637 : 89807 : && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
8638 : : {
8639 : : /* For elemental dimensions, we only need the 1st
8640 : : element in the section. */
8641 : 1141 : continue;
8642 : : }
8643 : :
8644 : : /* Vector subscripts need copying and are handled elsewhere. */
8645 : 95621 : if (info->ref)
8646 : 88666 : gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
8647 : :
8648 : : /* look for the corresponding scalarizer dimension: dim. */
8649 : 143252 : for (dim = 0; dim < ndim; dim++)
8650 : 143252 : if (ss->dim[dim] == n)
8651 : : break;
8652 : :
8653 : : /* loop exited early: the DIM being looked for has been found. */
8654 : 95621 : gcc_assert (dim < ndim);
8655 : :
8656 : : /* Set the new lower bound. */
8657 : 95621 : from = loop.from[dim];
8658 : 95621 : to = loop.to[dim];
8659 : :
8660 : 95621 : gfc_conv_descriptor_lbound_set (&loop.pre, parm,
8661 : : gfc_rank_cst[dim], from);
8662 : :
8663 : : /* Set the new upper bound. */
8664 : 95621 : gfc_conv_descriptor_ubound_set (&loop.pre, parm,
8665 : : gfc_rank_cst[dim], to);
8666 : :
8667 : : /* Multiply the stride by the section stride to get the
8668 : : total stride. */
8669 : 95621 : stride = fold_build2_loc (input_location, MULT_EXPR,
8670 : : gfc_array_index_type,
8671 : : stride, info->stride[n]);
8672 : :
8673 : 95621 : tmp = fold_build2_loc (input_location, MULT_EXPR,
8674 : 95621 : TREE_TYPE (offset), stride, from);
8675 : 95621 : offset = fold_build2_loc (input_location, MINUS_EXPR,
8676 : 95621 : TREE_TYPE (offset), offset, tmp);
8677 : :
8678 : : /* Store the new stride. */
8679 : 95621 : gfc_conv_descriptor_stride_set (&loop.pre, parm,
8680 : : gfc_rank_cst[dim], stride);
8681 : : }
8682 : :
8683 : 62935 : for (n = loop.dimen; n < loop.dimen + codim; n++)
8684 : : {
8685 : 1030 : from = loop.from[n];
8686 : 1030 : to = loop.to[n];
8687 : 1030 : gfc_conv_descriptor_lbound_set (&loop.pre, parm,
8688 : : gfc_rank_cst[n], from);
8689 : 1030 : if (n < loop.dimen + codim - 1)
8690 : 528 : gfc_conv_descriptor_ubound_set (&loop.pre, parm,
8691 : : gfc_rank_cst[n], to);
8692 : : }
8693 : :
8694 : 61905 : if (se->data_not_needed)
8695 : 5963 : gfc_conv_descriptor_data_set (&loop.pre, parm,
8696 : : gfc_index_zero_node);
8697 : : else
8698 : : /* Point the data pointer at the 1st element in the section. */
8699 : 55942 : gfc_get_dataptr_offset (&loop.pre, parm, desc, base,
8700 : : subref_array_target, expr);
8701 : :
8702 : 61905 : gfc_conv_descriptor_offset_set (&loop.pre, parm, offset);
8703 : :
8704 : 61905 : if (flag_coarray == GFC_FCOARRAY_LIB && expr->corank)
8705 : : {
8706 : 190 : tmp = INDIRECT_REF_P (desc) ? TREE_OPERAND (desc, 0) : desc;
8707 : 190 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
8708 : : {
8709 : 12 : tmp = gfc_conv_descriptor_token (tmp);
8710 : : }
8711 : 178 : else if (DECL_P (tmp) && DECL_LANG_SPECIFIC (tmp)
8712 : 220 : && GFC_DECL_TOKEN (tmp) != NULL_TREE)
8713 : 34 : tmp = GFC_DECL_TOKEN (tmp);
8714 : : else
8715 : : {
8716 : 144 : tmp = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (tmp));
8717 : : }
8718 : :
8719 : 190 : gfc_add_modify (&loop.pre, gfc_conv_descriptor_token (parm), tmp);
8720 : : }
8721 : : desc = parm;
8722 : : }
8723 : :
8724 : : /* For class arrays add the class tree into the saved descriptor to
8725 : : enable getting of _vptr and the like. */
8726 : 70909 : if (expr->expr_type == EXPR_VARIABLE && VAR_P (desc)
8727 : 54544 : && IS_CLASS_ARRAY (expr->symtree->n.sym))
8728 : : {
8729 : 1097 : gfc_allocate_lang_decl (desc);
8730 : 1097 : GFC_DECL_SAVED_DESCRIPTOR (desc) =
8731 : 1097 : DECL_LANG_SPECIFIC (expr->symtree->n.sym->backend_decl) ?
8732 : 1011 : GFC_DECL_SAVED_DESCRIPTOR (expr->symtree->n.sym->backend_decl)
8733 : : : expr->symtree->n.sym->backend_decl;
8734 : : }
8735 : 69812 : else if (expr->expr_type == EXPR_ARRAY && VAR_P (desc)
8736 : 10152 : && IS_CLASS_ARRAY (expr))
8737 : : {
8738 : 12 : tree vtype;
8739 : 12 : gfc_allocate_lang_decl (desc);
8740 : 12 : tmp = gfc_create_var (expr->ts.u.derived->backend_decl, "class");
8741 : 12 : GFC_DECL_SAVED_DESCRIPTOR (desc) = tmp;
8742 : 12 : vtype = gfc_class_vptr_get (tmp);
8743 : 12 : gfc_add_modify (&se->pre, vtype,
8744 : 12 : gfc_build_addr_expr (TREE_TYPE (vtype),
8745 : 12 : gfc_find_vtab (&expr->ts)->backend_decl));
8746 : : }
8747 : 70909 : if (!se->direct_byref || se->byref_noassign)
8748 : : {
8749 : : /* Get a pointer to the new descriptor. */
8750 : 68322 : if (se->want_pointer)
8751 : 38583 : se->expr = gfc_build_addr_expr (NULL_TREE, desc);
8752 : : else
8753 : 29739 : se->expr = desc;
8754 : : }
8755 : :
8756 : 70909 : gfc_add_block_to_block (&se->pre, &loop.pre);
8757 : 70909 : gfc_add_block_to_block (&se->post, &loop.post);
8758 : :
8759 : : /* Cleanup the scalarizer. */
8760 : 70909 : gfc_cleanup_loop (&loop);
8761 : : }
8762 : :
8763 : :
8764 : : /* Calculate the array size (number of elements); if dim != NULL_TREE,
8765 : : return size for that dim (dim=0..rank-1; only for GFC_DESCRIPTOR_TYPE_P).
8766 : : If !expr && descriptor array, the rank is taken from the descriptor. */
8767 : : tree
8768 : 14651 : gfc_tree_array_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree dim)
8769 : : {
8770 : 14651 : if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
8771 : : {
8772 : 34 : gcc_assert (dim == NULL_TREE);
8773 : 34 : return GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
8774 : : }
8775 : 14617 : tree size, tmp, rank = NULL_TREE, cond = NULL_TREE;
8776 : 14617 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
8777 : 14617 : enum gfc_array_kind akind = GFC_TYPE_ARRAY_AKIND (TREE_TYPE (desc));
8778 : 14617 : if (expr == NULL || expr->rank < 0)
8779 : 3032 : rank = fold_convert (signed_char_type_node,
8780 : : gfc_conv_descriptor_rank (desc));
8781 : : else
8782 : 11585 : rank = build_int_cst (signed_char_type_node, expr->rank);
8783 : :
8784 : 14617 : if (dim || (expr && expr->rank == 1))
8785 : : {
8786 : 4356 : if (!dim)
8787 : 4356 : dim = gfc_index_zero_node;
8788 : 12964 : tree ubound = gfc_conv_descriptor_ubound_get (desc, dim);
8789 : 12964 : tree lbound = gfc_conv_descriptor_lbound_get (desc, dim);
8790 : :
8791 : 12964 : size = fold_build2_loc (input_location, MINUS_EXPR,
8792 : : gfc_array_index_type, ubound, lbound);
8793 : 12964 : size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
8794 : : size, gfc_index_one_node);
8795 : : /* if (!allocatable && !pointer && assumed rank)
8796 : : size = (idx == rank && ubound[rank-1] == -1 ? -1 : size;
8797 : : else
8798 : : size = max (0, size); */
8799 : 12964 : size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
8800 : : size, gfc_index_zero_node);
8801 : 12964 : if (akind == GFC_ARRAY_ASSUMED_RANK_CONT
8802 : 12964 : || akind == GFC_ARRAY_ASSUMED_RANK)
8803 : : {
8804 : 2345 : tmp = fold_build2_loc (input_location, MINUS_EXPR, signed_char_type_node,
8805 : 2345 : rank, build_int_cst (signed_char_type_node, 1));
8806 : 2345 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
8807 : : fold_convert (signed_char_type_node, dim),
8808 : : tmp);
8809 : 2345 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
8810 : : gfc_conv_descriptor_ubound_get (desc, dim),
8811 : 2345 : build_int_cst (gfc_array_index_type, -1));
8812 : 2345 : cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
8813 : : cond, tmp);
8814 : 2345 : tmp = build_int_cst (gfc_array_index_type, -1);
8815 : 2345 : size = build3_loc (input_location, COND_EXPR, gfc_array_index_type,
8816 : : cond, tmp, size);
8817 : : }
8818 : 12964 : return size;
8819 : : }
8820 : :
8821 : : /* size = 1. */
8822 : 1653 : size = gfc_create_var (gfc_array_index_type, "size");
8823 : 1653 : gfc_add_modify (block, size, build_int_cst (TREE_TYPE (size), 1));
8824 : 1653 : tree extent = gfc_create_var (gfc_array_index_type, "extent");
8825 : :
8826 : 1653 : stmtblock_t cond_block, loop_body;
8827 : 1653 : gfc_init_block (&cond_block);
8828 : 1653 : gfc_init_block (&loop_body);
8829 : :
8830 : : /* Loop: for (i = 0; i < rank; ++i). */
8831 : 1653 : tree idx = gfc_create_var (signed_char_type_node, "idx");
8832 : : /* Loop body. */
8833 : : /* #if (assumed-rank + !allocatable && !pointer)
8834 : : if (idx == rank - 1 && dim[idx].ubound == -1)
8835 : : extent = -1;
8836 : : else
8837 : : #endif
8838 : : extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1
8839 : : if (extent < 0)
8840 : : extent = 0
8841 : : size *= extent. */
8842 : 1653 : cond = NULL_TREE;
8843 : 1653 : if (akind == GFC_ARRAY_ASSUMED_RANK_CONT || akind == GFC_ARRAY_ASSUMED_RANK)
8844 : : {
8845 : 459 : tmp = fold_build2_loc (input_location, MINUS_EXPR, signed_char_type_node,
8846 : 459 : rank, build_int_cst (signed_char_type_node, 1));
8847 : 459 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
8848 : : idx, tmp);
8849 : 459 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
8850 : : gfc_conv_descriptor_ubound_get (desc, idx),
8851 : 459 : build_int_cst (gfc_array_index_type, -1));
8852 : 459 : cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
8853 : : cond, tmp);
8854 : : }
8855 : 1653 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8856 : : gfc_conv_descriptor_ubound_get (desc, idx),
8857 : : gfc_conv_descriptor_lbound_get (desc, idx));
8858 : 1653 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
8859 : : tmp, gfc_index_one_node);
8860 : 1653 : gfc_add_modify (&cond_block, extent, tmp);
8861 : 1653 : tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
8862 : : extent, gfc_index_zero_node);
8863 : 1653 : tmp = build3_v (COND_EXPR, tmp,
8864 : : fold_build2_loc (input_location, MODIFY_EXPR,
8865 : : gfc_array_index_type,
8866 : : extent, gfc_index_zero_node),
8867 : : build_empty_stmt (input_location));
8868 : 1653 : gfc_add_expr_to_block (&cond_block, tmp);
8869 : 1653 : tmp = gfc_finish_block (&cond_block);
8870 : 1653 : if (cond)
8871 : 459 : tmp = build3_v (COND_EXPR, cond,
8872 : : fold_build2_loc (input_location, MODIFY_EXPR,
8873 : : gfc_array_index_type, extent,
8874 : : build_int_cst (gfc_array_index_type, -1)),
8875 : : tmp);
8876 : 1653 : gfc_add_expr_to_block (&loop_body, tmp);
8877 : : /* size *= extent. */
8878 : 1653 : gfc_add_modify (&loop_body, size,
8879 : : fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
8880 : : size, extent));
8881 : : /* Generate loop. */
8882 : 3306 : gfc_simple_for_loop (block, idx, build_int_cst (TREE_TYPE (idx), 0), rank, LT_EXPR,
8883 : 1653 : build_int_cst (TREE_TYPE (idx), 1),
8884 : : gfc_finish_block (&loop_body));
8885 : 1653 : return size;
8886 : : }
8887 : :
8888 : : /* Helper function for gfc_conv_array_parameter if array size needs to be
8889 : : computed. */
8890 : :
8891 : : static void
8892 : 102 : array_parameter_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree *size)
8893 : : {
8894 : 102 : tree elem;
8895 : 102 : *size = gfc_tree_array_size (block, desc, expr, NULL);
8896 : 102 : elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
8897 : 102 : *size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
8898 : : *size, fold_convert (gfc_array_index_type, elem));
8899 : 102 : }
8900 : :
8901 : : /* Helper function - return true if the argument is a pointer. */
8902 : :
8903 : : static bool
8904 : 733 : is_pointer (gfc_expr *e)
8905 : : {
8906 : 733 : gfc_symbol *sym;
8907 : :
8908 : 733 : if (e->expr_type != EXPR_VARIABLE || e->symtree == NULL)
8909 : : return false;
8910 : :
8911 : 733 : sym = e->symtree->n.sym;
8912 : 733 : if (sym == NULL)
8913 : : return false;
8914 : :
8915 : 733 : return sym->attr.pointer || sym->attr.proc_pointer;
8916 : : }
8917 : :
8918 : : /* Convert an array for passing as an actual parameter. */
8919 : :
8920 : : void
8921 : 63394 : gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr, bool g77,
8922 : : const gfc_symbol *fsym, const char *proc_name,
8923 : : tree *size, tree *lbshift, tree *packed)
8924 : : {
8925 : 63394 : tree ptr;
8926 : 63394 : tree desc;
8927 : 63394 : tree tmp = NULL_TREE;
8928 : 63394 : tree stmt;
8929 : 63394 : tree parent = DECL_CONTEXT (current_function_decl);
8930 : 63394 : tree ctree;
8931 : 63394 : tree pack_attr = NULL_TREE; /* Set when packing class arrays. */
8932 : 63394 : bool full_array_var;
8933 : 63394 : bool this_array_result;
8934 : 63394 : bool contiguous;
8935 : 63394 : bool no_pack;
8936 : 63394 : bool array_constructor;
8937 : 63394 : bool good_allocatable;
8938 : 63394 : bool ultimate_ptr_comp;
8939 : 63394 : bool ultimate_alloc_comp;
8940 : 63394 : bool readonly;
8941 : 63394 : gfc_symbol *sym;
8942 : 63394 : stmtblock_t block;
8943 : 63394 : gfc_ref *ref;
8944 : :
8945 : 63394 : ultimate_ptr_comp = false;
8946 : 63394 : ultimate_alloc_comp = false;
8947 : :
8948 : 64073 : for (ref = expr->ref; ref; ref = ref->next)
8949 : : {
8950 : 52356 : if (ref->next == NULL)
8951 : : break;
8952 : :
8953 : 679 : if (ref->type == REF_COMPONENT)
8954 : : {
8955 : 607 : ultimate_ptr_comp = ref->u.c.component->attr.pointer;
8956 : 607 : ultimate_alloc_comp = ref->u.c.component->attr.allocatable;
8957 : : }
8958 : : }
8959 : :
8960 : 63394 : full_array_var = false;
8961 : 63394 : contiguous = false;
8962 : :
8963 : 63394 : if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp)
8964 : 51585 : full_array_var = gfc_full_array_ref_p (ref, &contiguous);
8965 : :
8966 : 51585 : sym = full_array_var ? expr->symtree->n.sym : NULL;
8967 : :
8968 : : /* The symbol should have an array specification. */
8969 : 60592 : gcc_assert (!sym || sym->as || ref->u.ar.as);
8970 : :
8971 : 63394 : if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
8972 : : {
8973 : 673 : get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
8974 : 673 : expr->ts.u.cl->backend_decl = tmp;
8975 : 673 : se->string_length = tmp;
8976 : : }
8977 : :
8978 : : /* Is this the result of the enclosing procedure? */
8979 : 63394 : this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
8980 : 58 : if (this_array_result
8981 : 58 : && (sym->backend_decl != current_function_decl)
8982 : 0 : && (sym->backend_decl != parent))
8983 : 63394 : this_array_result = false;
8984 : :
8985 : : /* Passing an optional dummy argument as actual to an optional dummy? */
8986 : 63394 : bool pass_optional;
8987 : 63394 : pass_optional = fsym && fsym->attr.optional && sym && sym->attr.optional;
8988 : :
8989 : : /* Passing address of the array if it is not pointer or assumed-shape. */
8990 : 63394 : if (full_array_var && g77 && !this_array_result
8991 : 15260 : && sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
8992 : : {
8993 : 12268 : tmp = gfc_get_symbol_decl (sym);
8994 : :
8995 : 12268 : if (sym->ts.type == BT_CHARACTER)
8996 : 2741 : se->string_length = sym->ts.u.cl->backend_decl;
8997 : :
8998 : 12268 : if (!sym->attr.pointer
8999 : 11763 : && sym->as
9000 : 11763 : && sym->as->type != AS_ASSUMED_SHAPE
9001 : 11519 : && sym->as->type != AS_DEFERRED
9002 : 10126 : && sym->as->type != AS_ASSUMED_RANK
9003 : 10058 : && !sym->attr.allocatable)
9004 : : {
9005 : : /* Some variables are declared directly, others are declared as
9006 : : pointers and allocated on the heap. */
9007 : 9606 : if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
9008 : 2469 : se->expr = tmp;
9009 : : else
9010 : 7137 : se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
9011 : 9606 : if (size)
9012 : 34 : array_parameter_size (&se->pre, tmp, expr, size);
9013 : 16130 : return;
9014 : : }
9015 : :
9016 : 2662 : if (sym->attr.allocatable)
9017 : : {
9018 : 1725 : if (sym->attr.dummy || sym->attr.result)
9019 : : {
9020 : 1092 : gfc_conv_expr_descriptor (se, expr);
9021 : 1092 : tmp = se->expr;
9022 : : }
9023 : 1725 : if (size)
9024 : 6 : array_parameter_size (&se->pre, tmp, expr, size);
9025 : 1725 : se->expr = gfc_conv_array_data (tmp);
9026 : 1725 : if (pass_optional)
9027 : : {
9028 : 18 : tree cond = gfc_conv_expr_present (sym);
9029 : 36 : se->expr = build3_loc (input_location, COND_EXPR,
9030 : 18 : TREE_TYPE (se->expr), cond, se->expr,
9031 : 18 : fold_convert (TREE_TYPE (se->expr),
9032 : : null_pointer_node));
9033 : : }
9034 : 1725 : return;
9035 : : }
9036 : : }
9037 : :
9038 : : /* A convenient reduction in scope. */
9039 : 52063 : contiguous = g77 && !this_array_result && contiguous;
9040 : :
9041 : : /* There is no need to pack and unpack the array, if it is contiguous
9042 : : and not a deferred- or assumed-shape array, or if it is simply
9043 : : contiguous. */
9044 : 52063 : no_pack = false;
9045 : : // clang-format off
9046 : 52063 : if (sym)
9047 : : {
9048 : 37542 : symbol_attribute *attr = &(IS_CLASS_ARRAY (sym)
9049 : : ? CLASS_DATA (sym)->attr : sym->attr);
9050 : 229 : gfc_array_spec *as = IS_CLASS_ARRAY (sym)
9051 : 37771 : ? CLASS_DATA (sym)->as : sym->as;
9052 : 37542 : no_pack = (as
9053 : 37285 : && !attr->pointer
9054 : 34066 : && as->type != AS_DEFERRED
9055 : 24609 : && as->type != AS_ASSUMED_RANK
9056 : 59593 : && as->type != AS_ASSUMED_SHAPE);
9057 : : }
9058 : 52063 : if (ref && ref->u.ar.as)
9059 : 40344 : no_pack = no_pack
9060 : 40344 : || (ref->u.ar.as->type != AS_DEFERRED
9061 : : && ref->u.ar.as->type != AS_ASSUMED_RANK
9062 : : && ref->u.ar.as->type != AS_ASSUMED_SHAPE);
9063 : 104126 : no_pack = contiguous
9064 : 52063 : && (no_pack || gfc_is_simply_contiguous (expr, false, true));
9065 : : // clang-format on
9066 : :
9067 : : /* If we have an EXPR_OP or a function returning an explicit-shaped
9068 : : or allocatable array, an array temporary will be generated which
9069 : : does not need to be packed / unpacked if passed to an
9070 : : explicit-shape dummy array. */
9071 : :
9072 : 52063 : if (g77)
9073 : : {
9074 : 5862 : if (expr->expr_type == EXPR_OP)
9075 : : no_pack = 1;
9076 : 5785 : else if (expr->expr_type == EXPR_FUNCTION && expr->value.function.esym)
9077 : : {
9078 : 41 : gfc_symbol *result = expr->value.function.esym->result;
9079 : 41 : if (result->attr.dimension
9080 : 41 : && (result->as->type == AS_EXPLICIT
9081 : : || result->attr.allocatable
9082 : 14 : || result->attr.contiguous))
9083 : 52063 : no_pack = 1;
9084 : : }
9085 : : }
9086 : :
9087 : : /* Array constructors are always contiguous and do not need packing. */
9088 : 52063 : array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY;
9089 : :
9090 : : /* Same is true of contiguous sections from allocatable variables. */
9091 : 104126 : good_allocatable = contiguous
9092 : 4046 : && expr->symtree
9093 : 56109 : && expr->symtree->n.sym->attr.allocatable;
9094 : :
9095 : : /* Or ultimate allocatable components. */
9096 : 52063 : ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
9097 : :
9098 : 52063 : if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp)
9099 : : {
9100 : 4413 : gfc_conv_expr_descriptor (se, expr);
9101 : : /* Deallocate the allocatable components of structures that are
9102 : : not variable. */
9103 : 4413 : if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
9104 : 2913 : && expr->ts.u.derived->attr.alloc_comp
9105 : 1639 : && expr->expr_type != EXPR_VARIABLE)
9106 : : {
9107 : 2 : tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, se->expr, expr->rank);
9108 : :
9109 : : /* The components shall be deallocated before their containing entity. */
9110 : 2 : gfc_prepend_expr_to_block (&se->post, tmp);
9111 : : }
9112 : 4413 : if (expr->ts.type == BT_CHARACTER && expr->expr_type != EXPR_FUNCTION)
9113 : 279 : se->string_length = expr->ts.u.cl->backend_decl;
9114 : 4413 : if (size)
9115 : 32 : array_parameter_size (&se->pre, se->expr, expr, size);
9116 : 4413 : se->expr = gfc_conv_array_data (se->expr);
9117 : 4413 : return;
9118 : : }
9119 : :
9120 : 47650 : if (fsym && fsym->ts.type == BT_CLASS)
9121 : : {
9122 : 1211 : gcc_assert (se->expr);
9123 : : ctree = se->expr;
9124 : : }
9125 : : else
9126 : : ctree = NULL_TREE;
9127 : :
9128 : 47650 : if (this_array_result)
9129 : : {
9130 : : /* Result of the enclosing function. */
9131 : 58 : gfc_conv_expr_descriptor (se, expr);
9132 : 58 : if (size)
9133 : 0 : array_parameter_size (&se->pre, se->expr, expr, size);
9134 : 58 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
9135 : :
9136 : 18 : if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
9137 : 76 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
9138 : 18 : se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location,
9139 : : se->expr));
9140 : :
9141 : 58 : return;
9142 : : }
9143 : : else
9144 : : {
9145 : : /* Every other type of array. */
9146 : 47592 : se->want_pointer = (ctree) ? 0 : 1;
9147 : 47592 : se->want_coarray = expr->corank;
9148 : 47592 : gfc_conv_expr_descriptor (se, expr);
9149 : :
9150 : 47592 : if (size)
9151 : 30 : array_parameter_size (&se->pre,
9152 : : build_fold_indirect_ref_loc (input_location,
9153 : : se->expr),
9154 : : expr, size);
9155 : 47592 : if (ctree)
9156 : : {
9157 : 1211 : stmtblock_t block;
9158 : :
9159 : 1211 : gfc_init_block (&block);
9160 : 1211 : if (lbshift && *lbshift)
9161 : : {
9162 : : /* Apply a shift of the lbound when supplied. */
9163 : 98 : for (int dim = 0; dim < expr->rank; ++dim)
9164 : 49 : gfc_conv_shift_descriptor_lbound (&block, se->expr, dim,
9165 : : *lbshift);
9166 : : }
9167 : 1211 : tmp = gfc_class_data_get (ctree);
9168 : 1211 : if (expr->rank > 1 && CLASS_DATA (fsym)->as->rank != expr->rank
9169 : 84 : && CLASS_DATA (fsym)->as->type == AS_EXPLICIT && !no_pack)
9170 : : {
9171 : 36 : tree arr = gfc_create_var (TREE_TYPE (tmp), "parm");
9172 : 36 : gfc_conv_descriptor_data_set (&block, arr,
9173 : : gfc_conv_descriptor_data_get (
9174 : : se->expr));
9175 : 36 : gfc_conv_descriptor_lbound_set (&block, arr, gfc_index_zero_node,
9176 : : gfc_index_zero_node);
9177 : 36 : gfc_conv_descriptor_ubound_set (
9178 : : &block, arr, gfc_index_zero_node,
9179 : : gfc_conv_descriptor_size (se->expr, expr->rank));
9180 : 36 : gfc_conv_descriptor_stride_set (
9181 : : &block, arr, gfc_index_zero_node,
9182 : : gfc_conv_descriptor_stride_get (se->expr, gfc_index_zero_node));
9183 : 36 : gfc_add_modify (&block, gfc_conv_descriptor_dtype (arr),
9184 : : gfc_conv_descriptor_dtype (se->expr));
9185 : 36 : gfc_add_modify (&block, gfc_conv_descriptor_rank (arr),
9186 : 36 : build_int_cst (signed_char_type_node, 1));
9187 : 36 : gfc_conv_descriptor_span_set (&block, arr,
9188 : : gfc_conv_descriptor_span_get (arr));
9189 : 36 : gfc_conv_descriptor_offset_set (&block, arr, gfc_index_zero_node);
9190 : 36 : se->expr = arr;
9191 : : }
9192 : 1211 : gfc_class_array_data_assign (&block, tmp, se->expr, true);
9193 : :
9194 : : /* Handle optional. */
9195 : 1211 : if (fsym && fsym->attr.optional && sym && sym->attr.optional)
9196 : 348 : tmp = build3_v (COND_EXPR, gfc_conv_expr_present (sym),
9197 : : gfc_finish_block (&block),
9198 : : build_empty_stmt (input_location));
9199 : : else
9200 : 863 : tmp = gfc_finish_block (&block);
9201 : :
9202 : 1211 : gfc_add_expr_to_block (&se->pre, tmp);
9203 : : }
9204 : : }
9205 : :
9206 : : /* Deallocate the allocatable components of structures that are
9207 : : not variable, for descriptorless arguments.
9208 : : Arguments with a descriptor are handled in gfc_conv_procedure_call. */
9209 : 47592 : if (g77 && (expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
9210 : 75 : && expr->ts.u.derived->attr.alloc_comp
9211 : 21 : && expr->expr_type != EXPR_VARIABLE)
9212 : : {
9213 : 0 : tmp = build_fold_indirect_ref_loc (input_location, se->expr);
9214 : 0 : tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank);
9215 : :
9216 : : /* The components shall be deallocated before their containing entity. */
9217 : 0 : gfc_prepend_expr_to_block (&se->post, tmp);
9218 : : }
9219 : :
9220 : 46161 : if (g77 || (fsym && fsym->attr.contiguous
9221 : 1527 : && !gfc_is_simply_contiguous (expr, false, true)))
9222 : : {
9223 : 1575 : tree origptr = NULL_TREE, packedptr = NULL_TREE;
9224 : :
9225 : 1575 : desc = se->expr;
9226 : :
9227 : : /* For contiguous arrays, save the original value of the descriptor. */
9228 : 1575 : if (!g77 && !ctree)
9229 : : {
9230 : 48 : origptr = gfc_create_var (pvoid_type_node, "origptr");
9231 : 48 : tmp = build_fold_indirect_ref_loc (input_location, desc);
9232 : 48 : tmp = gfc_conv_array_data (tmp);
9233 : 96 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
9234 : 48 : TREE_TYPE (origptr), origptr,
9235 : 48 : fold_convert (TREE_TYPE (origptr), tmp));
9236 : 48 : gfc_add_expr_to_block (&se->pre, tmp);
9237 : : }
9238 : :
9239 : : /* Repack the array. */
9240 : 1575 : if (warn_array_temporaries)
9241 : : {
9242 : 28 : if (fsym)
9243 : 18 : gfc_warning (OPT_Warray_temporaries,
9244 : : "Creating array temporary at %L for argument %qs",
9245 : 18 : &expr->where, fsym->name);
9246 : : else
9247 : 10 : gfc_warning (OPT_Warray_temporaries,
9248 : : "Creating array temporary at %L", &expr->where);
9249 : : }
9250 : :
9251 : : /* When optimizing, we can use gfc_conv_subref_array_arg for
9252 : : making the packing and unpacking operation visible to the
9253 : : optimizers. */
9254 : :
9255 : 1431 : if (g77 && flag_inline_arg_packing && expr->expr_type == EXPR_VARIABLE
9256 : 733 : && !is_pointer (expr) && ! gfc_has_dimen_vector_ref (expr)
9257 : 349 : && !(expr->symtree->n.sym->as
9258 : 320 : && expr->symtree->n.sym->as->type == AS_ASSUMED_RANK)
9259 : 1924 : && (fsym == NULL || fsym->ts.type != BT_ASSUMED))
9260 : : {
9261 : 328 : gfc_conv_subref_array_arg (se, expr, g77,
9262 : 137 : fsym ? fsym->attr.intent : INTENT_INOUT,
9263 : : false, fsym, proc_name, sym, true);
9264 : 328 : return;
9265 : : }
9266 : :
9267 : 1247 : if (ctree)
9268 : : {
9269 : 96 : packedptr
9270 : 96 : = gfc_build_addr_expr (NULL_TREE, gfc_create_var (TREE_TYPE (ctree),
9271 : : "packed"));
9272 : 96 : if (fsym)
9273 : : {
9274 : 96 : int pack_mask = 0;
9275 : :
9276 : : /* Set bit 0 to the mask, when this is an unlimited_poly
9277 : : class. */
9278 : 96 : if (CLASS_DATA (fsym)->ts.u.derived->attr.unlimited_polymorphic)
9279 : 36 : pack_mask = 1 << 0;
9280 : 96 : pack_attr = build_int_cst (integer_type_node, pack_mask);
9281 : : }
9282 : : else
9283 : 0 : pack_attr = integer_zero_node;
9284 : :
9285 : 96 : gfc_add_expr_to_block (
9286 : : &se->pre,
9287 : : build_call_expr_loc (input_location, gfor_fndecl_in_pack_class, 4,
9288 : : packedptr,
9289 : : gfc_build_addr_expr (NULL_TREE, ctree),
9290 : 96 : size_in_bytes (TREE_TYPE (ctree)), pack_attr));
9291 : 96 : ptr = gfc_conv_array_data (gfc_class_data_get (packedptr));
9292 : 96 : se->expr = packedptr;
9293 : 96 : if (packed)
9294 : 96 : *packed = packedptr;
9295 : : }
9296 : : else
9297 : : {
9298 : 1151 : ptr = build_call_expr_loc (input_location, gfor_fndecl_in_pack, 1,
9299 : : desc);
9300 : :
9301 : 1151 : if (fsym && fsym->attr.optional && sym && sym->attr.optional)
9302 : : {
9303 : 11 : tmp = gfc_conv_expr_present (sym);
9304 : 22 : ptr = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
9305 : 11 : tmp, fold_convert (TREE_TYPE (se->expr), ptr),
9306 : 11 : fold_convert (TREE_TYPE (se->expr),
9307 : : null_pointer_node));
9308 : : }
9309 : :
9310 : 1151 : ptr = gfc_evaluate_now (ptr, &se->pre);
9311 : : }
9312 : :
9313 : : /* Use the packed data for the actual argument, except for contiguous arrays,
9314 : : where the descriptor's data component is set. */
9315 : 1247 : if (g77)
9316 : 1103 : se->expr = ptr;
9317 : : else
9318 : : {
9319 : 144 : tmp = build_fold_indirect_ref_loc (input_location, desc);
9320 : :
9321 : 144 : gfc_ss * ss = gfc_walk_expr (expr);
9322 : 288 : if (!transposed_dims (ss))
9323 : : {
9324 : 138 : if (!ctree)
9325 : 48 : gfc_conv_descriptor_data_set (&se->pre, tmp, ptr);
9326 : : }
9327 : 6 : else if (!ctree)
9328 : : {
9329 : 0 : tree old_field, new_field;
9330 : :
9331 : : /* The original descriptor has transposed dims so we can't reuse
9332 : : it directly; we have to create a new one. */
9333 : 0 : tree old_desc = tmp;
9334 : 0 : tree new_desc = gfc_create_var (TREE_TYPE (old_desc), "arg_desc");
9335 : :
9336 : 0 : old_field = gfc_conv_descriptor_dtype (old_desc);
9337 : 0 : new_field = gfc_conv_descriptor_dtype (new_desc);
9338 : 0 : gfc_add_modify (&se->pre, new_field, old_field);
9339 : :
9340 : 0 : old_field = gfc_conv_descriptor_offset (old_desc);
9341 : 0 : new_field = gfc_conv_descriptor_offset (new_desc);
9342 : 0 : gfc_add_modify (&se->pre, new_field, old_field);
9343 : :
9344 : 0 : for (int i = 0; i < expr->rank; i++)
9345 : : {
9346 : 0 : old_field = gfc_conv_descriptor_dimension (old_desc,
9347 : 0 : gfc_rank_cst[get_array_ref_dim_for_loop_dim (ss, i)]);
9348 : 0 : new_field = gfc_conv_descriptor_dimension (new_desc,
9349 : : gfc_rank_cst[i]);
9350 : 0 : gfc_add_modify (&se->pre, new_field, old_field);
9351 : : }
9352 : :
9353 : 0 : if (flag_coarray == GFC_FCOARRAY_LIB
9354 : 0 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (old_desc))
9355 : 0 : && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (old_desc))
9356 : : == GFC_ARRAY_ALLOCATABLE)
9357 : : {
9358 : 0 : old_field = gfc_conv_descriptor_token (old_desc);
9359 : 0 : new_field = gfc_conv_descriptor_token (new_desc);
9360 : 0 : gfc_add_modify (&se->pre, new_field, old_field);
9361 : : }
9362 : :
9363 : 0 : gfc_conv_descriptor_data_set (&se->pre, new_desc, ptr);
9364 : 0 : se->expr = gfc_build_addr_expr (NULL_TREE, new_desc);
9365 : : }
9366 : 144 : gfc_free_ss (ss);
9367 : : }
9368 : :
9369 : 1247 : if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
9370 : : {
9371 : 8 : char * msg;
9372 : :
9373 : 8 : if (fsym && proc_name)
9374 : 8 : msg = xasprintf ("An array temporary was created for argument "
9375 : 8 : "'%s' of procedure '%s'", fsym->name, proc_name);
9376 : : else
9377 : 0 : msg = xasprintf ("An array temporary was created");
9378 : :
9379 : 8 : tmp = build_fold_indirect_ref_loc (input_location,
9380 : : desc);
9381 : 8 : tmp = gfc_conv_array_data (tmp);
9382 : 8 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9383 : 8 : fold_convert (TREE_TYPE (tmp), ptr), tmp);
9384 : :
9385 : 8 : if (pass_optional)
9386 : 6 : tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
9387 : : logical_type_node,
9388 : : gfc_conv_expr_present (sym), tmp);
9389 : :
9390 : 8 : gfc_trans_runtime_check (false, true, tmp, &se->pre,
9391 : : &expr->where, msg);
9392 : 8 : free (msg);
9393 : : }
9394 : :
9395 : 1247 : gfc_start_block (&block);
9396 : :
9397 : : /* Copy the data back. If input expr is read-only, e.g. a PARAMETER
9398 : : array, copying back modified values is undefined behavior. */
9399 : 2494 : readonly = (expr->expr_type == EXPR_VARIABLE
9400 : 854 : && expr->symtree
9401 : 2101 : && expr->symtree->n.sym->attr.flavor == FL_PARAMETER);
9402 : :
9403 : 1247 : if ((fsym == NULL || fsym->attr.intent != INTENT_IN) && !readonly)
9404 : : {
9405 : 1114 : if (ctree)
9406 : : {
9407 : 66 : tmp = gfc_build_addr_expr (NULL_TREE, ctree);
9408 : 66 : tmp = build_call_expr_loc (input_location,
9409 : : gfor_fndecl_in_unpack_class, 4, tmp,
9410 : : packedptr,
9411 : 66 : size_in_bytes (TREE_TYPE (ctree)),
9412 : : pack_attr);
9413 : : }
9414 : : else
9415 : 1048 : tmp = build_call_expr_loc (input_location, gfor_fndecl_in_unpack, 2,
9416 : : desc, ptr);
9417 : 1114 : gfc_add_expr_to_block (&block, tmp);
9418 : : }
9419 : 133 : else if (ctree && fsym->attr.intent == INTENT_IN)
9420 : : {
9421 : : /* Need to free the memory for class arrays, that got packed. */
9422 : 30 : gfc_add_expr_to_block (&block, gfc_call_free (ptr));
9423 : : }
9424 : :
9425 : : /* Free the temporary. */
9426 : 1144 : if (!ctree)
9427 : 1151 : gfc_add_expr_to_block (&block, gfc_call_free (ptr));
9428 : :
9429 : 1247 : stmt = gfc_finish_block (&block);
9430 : :
9431 : 1247 : gfc_init_block (&block);
9432 : : /* Only if it was repacked. This code needs to be executed before the
9433 : : loop cleanup code. */
9434 : 1247 : tmp = (ctree) ? desc : build_fold_indirect_ref_loc (input_location, desc);
9435 : 1247 : tmp = gfc_conv_array_data (tmp);
9436 : 1247 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9437 : 1247 : fold_convert (TREE_TYPE (tmp), ptr), tmp);
9438 : :
9439 : 1247 : if (pass_optional)
9440 : 11 : tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
9441 : : logical_type_node,
9442 : : gfc_conv_expr_present (sym), tmp);
9443 : :
9444 : 1247 : tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
9445 : :
9446 : 1247 : gfc_add_expr_to_block (&block, tmp);
9447 : 1247 : gfc_add_block_to_block (&block, &se->post);
9448 : :
9449 : 1247 : gfc_init_block (&se->post);
9450 : :
9451 : : /* Reset the descriptor pointer. */
9452 : 1247 : if (!g77 && !ctree)
9453 : : {
9454 : 48 : tmp = build_fold_indirect_ref_loc (input_location, desc);
9455 : 48 : gfc_conv_descriptor_data_set (&se->post, tmp, origptr);
9456 : : }
9457 : :
9458 : 1247 : gfc_add_block_to_block (&se->post, &block);
9459 : : }
9460 : : }
9461 : :
9462 : :
9463 : : /* This helper function calculates the size in words of a full array. */
9464 : :
9465 : : tree
9466 : 15287 : gfc_full_array_size (stmtblock_t *block, tree decl, int rank)
9467 : : {
9468 : 15287 : tree idx;
9469 : 15287 : tree nelems;
9470 : 15287 : tree tmp;
9471 : 15287 : if (rank < 0)
9472 : 0 : idx = gfc_conv_descriptor_rank (decl);
9473 : : else
9474 : 15287 : idx = gfc_rank_cst[rank - 1];
9475 : 15287 : nelems = gfc_conv_descriptor_ubound_get (decl, idx);
9476 : 15287 : tmp = gfc_conv_descriptor_lbound_get (decl, idx);
9477 : 15287 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
9478 : : nelems, tmp);
9479 : 15287 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
9480 : : tmp, gfc_index_one_node);
9481 : 15287 : tmp = gfc_evaluate_now (tmp, block);
9482 : :
9483 : 15287 : nelems = gfc_conv_descriptor_stride_get (decl, idx);
9484 : 15287 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9485 : : nelems, tmp);
9486 : 15287 : return gfc_evaluate_now (tmp, block);
9487 : : }
9488 : :
9489 : :
9490 : : /* Allocate dest to the same size as src, and copy src -> dest.
9491 : : If no_malloc is set, only the copy is done. */
9492 : :
9493 : : static tree
9494 : 6565 : duplicate_allocatable (tree dest, tree src, tree type, int rank,
9495 : : bool no_malloc, bool no_memcpy, tree str_sz,
9496 : : tree add_when_allocated)
9497 : : {
9498 : 6565 : tree tmp;
9499 : 6565 : tree eltype;
9500 : 6565 : tree size;
9501 : 6565 : tree nelems;
9502 : 6565 : tree null_cond;
9503 : 6565 : tree null_data;
9504 : 6565 : stmtblock_t block;
9505 : :
9506 : : /* If the source is null, set the destination to null. Then,
9507 : : allocate memory to the destination. */
9508 : 6565 : gfc_init_block (&block);
9509 : :
9510 : 6565 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
9511 : : {
9512 : 1964 : gfc_add_modify (&block, dest, fold_convert (type, null_pointer_node));
9513 : 1964 : null_data = gfc_finish_block (&block);
9514 : :
9515 : 1964 : gfc_init_block (&block);
9516 : 1964 : eltype = TREE_TYPE (type);
9517 : 1964 : if (str_sz != NULL_TREE)
9518 : : size = str_sz;
9519 : : else
9520 : 1672 : size = TYPE_SIZE_UNIT (eltype);
9521 : :
9522 : 1964 : if (!no_malloc)
9523 : : {
9524 : 1964 : tmp = gfc_call_malloc (&block, type, size);
9525 : 1964 : gfc_add_modify (&block, dest, fold_convert (type, tmp));
9526 : : }
9527 : :
9528 : 1964 : if (!no_memcpy)
9529 : : {
9530 : 1539 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
9531 : 1539 : tmp = build_call_expr_loc (input_location, tmp, 3, dest, src,
9532 : : fold_convert (size_type_node, size));
9533 : 1539 : gfc_add_expr_to_block (&block, tmp);
9534 : : }
9535 : : }
9536 : : else
9537 : : {
9538 : 4601 : gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
9539 : 4601 : null_data = gfc_finish_block (&block);
9540 : :
9541 : 4601 : gfc_init_block (&block);
9542 : 4601 : if (rank)
9543 : 4590 : nelems = gfc_full_array_size (&block, src, rank);
9544 : : else
9545 : 11 : nelems = gfc_index_one_node;
9546 : :
9547 : : /* If type is not the array type, then it is the element type. */
9548 : 4601 : if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type))
9549 : 4571 : eltype = gfc_get_element_type (type);
9550 : : else
9551 : : eltype = type;
9552 : :
9553 : 4601 : if (str_sz != NULL_TREE)
9554 : 43 : tmp = fold_convert (gfc_array_index_type, str_sz);
9555 : : else
9556 : 4558 : tmp = fold_convert (gfc_array_index_type,
9557 : : TYPE_SIZE_UNIT (eltype));
9558 : :
9559 : 4601 : tmp = gfc_evaluate_now (tmp, &block);
9560 : 4601 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9561 : : nelems, tmp);
9562 : 4601 : if (!no_malloc)
9563 : : {
9564 : 4550 : tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src));
9565 : 4550 : tmp = gfc_call_malloc (&block, tmp, size);
9566 : 4550 : gfc_conv_descriptor_data_set (&block, dest, tmp);
9567 : : }
9568 : :
9569 : : /* We know the temporary and the value will be the same length,
9570 : : so can use memcpy. */
9571 : 4601 : if (!no_memcpy)
9572 : : {
9573 : 4171 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
9574 : 4171 : tmp = build_call_expr_loc (input_location, tmp, 3,
9575 : : gfc_conv_descriptor_data_get (dest),
9576 : : gfc_conv_descriptor_data_get (src),
9577 : : fold_convert (size_type_node, size));
9578 : 4171 : gfc_add_expr_to_block (&block, tmp);
9579 : : }
9580 : : }
9581 : :
9582 : 6565 : gfc_add_expr_to_block (&block, add_when_allocated);
9583 : 6565 : tmp = gfc_finish_block (&block);
9584 : :
9585 : : /* Null the destination if the source is null; otherwise do
9586 : : the allocate and copy. */
9587 : 6565 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src)))
9588 : : null_cond = src;
9589 : : else
9590 : 4601 : null_cond = gfc_conv_descriptor_data_get (src);
9591 : :
9592 : 6565 : null_cond = convert (pvoid_type_node, null_cond);
9593 : 6565 : null_cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9594 : : null_cond, null_pointer_node);
9595 : 6565 : return build3_v (COND_EXPR, null_cond, tmp, null_data);
9596 : : }
9597 : :
9598 : :
9599 : : /* Allocate dest to the same size as src, and copy data src -> dest. */
9600 : :
9601 : : tree
9602 : 5293 : gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank,
9603 : : tree add_when_allocated)
9604 : : {
9605 : 5293 : return duplicate_allocatable (dest, src, type, rank, false, false,
9606 : 5293 : NULL_TREE, add_when_allocated);
9607 : : }
9608 : :
9609 : :
9610 : : /* Copy data src -> dest. */
9611 : :
9612 : : tree
9613 : 51 : gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
9614 : : {
9615 : 51 : return duplicate_allocatable (dest, src, type, rank, true, false,
9616 : 51 : NULL_TREE, NULL_TREE);
9617 : : }
9618 : :
9619 : : /* Allocate dest to the same size as src, but don't copy anything. */
9620 : :
9621 : : tree
9622 : 855 : gfc_duplicate_allocatable_nocopy (tree dest, tree src, tree type, int rank)
9623 : : {
9624 : 855 : return duplicate_allocatable (dest, src, type, rank, false, true,
9625 : 855 : NULL_TREE, NULL_TREE);
9626 : : }
9627 : :
9628 : : static tree
9629 : 55 : duplicate_allocatable_coarray (tree dest, tree dest_tok, tree src, tree type,
9630 : : int rank, tree add_when_allocated)
9631 : : {
9632 : 55 : tree tmp;
9633 : 55 : tree size;
9634 : 55 : tree nelems;
9635 : 55 : tree null_cond;
9636 : 55 : tree null_data;
9637 : 55 : stmtblock_t block, globalblock;
9638 : :
9639 : : /* If the source is null, set the destination to null. Then,
9640 : : allocate memory to the destination. */
9641 : 55 : gfc_init_block (&block);
9642 : 55 : gfc_init_block (&globalblock);
9643 : :
9644 : 55 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
9645 : : {
9646 : 15 : gfc_se se;
9647 : 15 : symbol_attribute attr;
9648 : 15 : tree dummy_desc;
9649 : :
9650 : 15 : gfc_init_se (&se, NULL);
9651 : 15 : gfc_clear_attr (&attr);
9652 : 15 : attr.allocatable = 1;
9653 : 15 : dummy_desc = gfc_conv_scalar_to_descriptor (&se, dest, attr);
9654 : 15 : gfc_add_block_to_block (&globalblock, &se.pre);
9655 : 15 : size = TYPE_SIZE_UNIT (TREE_TYPE (type));
9656 : :
9657 : 15 : gfc_add_modify (&block, dest, fold_convert (type, null_pointer_node));
9658 : 15 : gfc_allocate_using_caf_lib (&block, dummy_desc, size,
9659 : : gfc_build_addr_expr (NULL_TREE, dest_tok),
9660 : : NULL_TREE, NULL_TREE, NULL_TREE,
9661 : : GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
9662 : 15 : gfc_add_modify (&block, dest, gfc_conv_descriptor_data_get (dummy_desc));
9663 : 15 : null_data = gfc_finish_block (&block);
9664 : :
9665 : 15 : gfc_init_block (&block);
9666 : :
9667 : 15 : gfc_allocate_using_caf_lib (&block, dummy_desc,
9668 : : fold_convert (size_type_node, size),
9669 : : gfc_build_addr_expr (NULL_TREE, dest_tok),
9670 : : NULL_TREE, NULL_TREE, NULL_TREE,
9671 : : GFC_CAF_COARRAY_ALLOC);
9672 : 15 : gfc_add_modify (&block, dest, gfc_conv_descriptor_data_get (dummy_desc));
9673 : :
9674 : 15 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
9675 : 15 : tmp = build_call_expr_loc (input_location, tmp, 3, dest, src,
9676 : : fold_convert (size_type_node, size));
9677 : 15 : gfc_add_expr_to_block (&block, tmp);
9678 : : }
9679 : : else
9680 : : {
9681 : : /* Set the rank or unitialized memory access may be reported. */
9682 : 40 : tmp = gfc_conv_descriptor_rank (dest);
9683 : 40 : gfc_add_modify (&globalblock, tmp, build_int_cst (TREE_TYPE (tmp), rank));
9684 : :
9685 : 40 : if (rank)
9686 : 40 : nelems = gfc_full_array_size (&globalblock, src, rank);
9687 : : else
9688 : 0 : nelems = integer_one_node;
9689 : :
9690 : 40 : tmp = fold_convert (size_type_node,
9691 : : TYPE_SIZE_UNIT (gfc_get_element_type (type)));
9692 : 40 : size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
9693 : : fold_convert (size_type_node, nelems), tmp);
9694 : :
9695 : 40 : gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
9696 : 40 : gfc_allocate_using_caf_lib (&block, dest, fold_convert (size_type_node,
9697 : : size),
9698 : : gfc_build_addr_expr (NULL_TREE, dest_tok),
9699 : : NULL_TREE, NULL_TREE, NULL_TREE,
9700 : : GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
9701 : 40 : null_data = gfc_finish_block (&block);
9702 : :
9703 : 40 : gfc_init_block (&block);
9704 : 40 : gfc_allocate_using_caf_lib (&block, dest,
9705 : : fold_convert (size_type_node, size),
9706 : : gfc_build_addr_expr (NULL_TREE, dest_tok),
9707 : : NULL_TREE, NULL_TREE, NULL_TREE,
9708 : : GFC_CAF_COARRAY_ALLOC);
9709 : :
9710 : 40 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
9711 : 40 : tmp = build_call_expr_loc (input_location, tmp, 3,
9712 : : gfc_conv_descriptor_data_get (dest),
9713 : : gfc_conv_descriptor_data_get (src),
9714 : : fold_convert (size_type_node, size));
9715 : 40 : gfc_add_expr_to_block (&block, tmp);
9716 : : }
9717 : 55 : gfc_add_expr_to_block (&block, add_when_allocated);
9718 : 55 : tmp = gfc_finish_block (&block);
9719 : :
9720 : : /* Null the destination if the source is null; otherwise do
9721 : : the register and copy. */
9722 : 55 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src)))
9723 : : null_cond = src;
9724 : : else
9725 : 40 : null_cond = gfc_conv_descriptor_data_get (src);
9726 : :
9727 : 55 : null_cond = convert (pvoid_type_node, null_cond);
9728 : 55 : null_cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9729 : : null_cond, null_pointer_node);
9730 : 55 : gfc_add_expr_to_block (&globalblock, build3_v (COND_EXPR, null_cond, tmp,
9731 : : null_data));
9732 : 55 : return gfc_finish_block (&globalblock);
9733 : : }
9734 : :
9735 : :
9736 : : /* Helper function to abstract whether coarray processing is enabled. */
9737 : :
9738 : : static bool
9739 : 73 : caf_enabled (int caf_mode)
9740 : : {
9741 : 73 : return (caf_mode & GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY)
9742 : 73 : == GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY;
9743 : : }
9744 : :
9745 : :
9746 : : /* Helper function to abstract whether coarray processing is enabled
9747 : : and we are in a derived type coarray. */
9748 : :
9749 : : static bool
9750 : 7920 : caf_in_coarray (int caf_mode)
9751 : : {
9752 : 7920 : static const int pat = GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
9753 : : | GFC_STRUCTURE_CAF_MODE_IN_COARRAY;
9754 : 7920 : return (caf_mode & pat) == pat;
9755 : : }
9756 : :
9757 : :
9758 : : /* Helper function to abstract whether coarray is to deallocate only. */
9759 : :
9760 : : bool
9761 : 306 : gfc_caf_is_dealloc_only (int caf_mode)
9762 : : {
9763 : 306 : return (caf_mode & GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY)
9764 : 306 : == GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY;
9765 : : }
9766 : :
9767 : :
9768 : : /* Recursively traverse an object of derived type, generating code to
9769 : : deallocate, nullify or copy allocatable components. This is the work horse
9770 : : function for the functions named in this enum. */
9771 : :
9772 : : enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP,
9773 : : COPY_ALLOC_COMP, COPY_ONLY_ALLOC_COMP, REASSIGN_CAF_COMP,
9774 : : ALLOCATE_PDT_COMP, DEALLOCATE_PDT_COMP, CHECK_PDT_DUMMY,
9775 : : BCAST_ALLOC_COMP};
9776 : :
9777 : : static gfc_actual_arglist *pdt_param_list;
9778 : :
9779 : : static tree
9780 : 15548 : structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
9781 : : int rank, int purpose, int caf_mode,
9782 : : gfc_co_subroutines_args *args,
9783 : : bool no_finalization = false)
9784 : : {
9785 : 15548 : gfc_component *c;
9786 : 15548 : gfc_loopinfo loop;
9787 : 15548 : stmtblock_t fnblock;
9788 : 15548 : stmtblock_t loopbody;
9789 : 15548 : stmtblock_t tmpblock;
9790 : 15548 : tree decl_type;
9791 : 15548 : tree tmp;
9792 : 15548 : tree comp;
9793 : 15548 : tree dcmp;
9794 : 15548 : tree nelems;
9795 : 15548 : tree index;
9796 : 15548 : tree var;
9797 : 15548 : tree cdecl;
9798 : 15548 : tree ctype;
9799 : 15548 : tree vref, dref;
9800 : 15548 : tree null_cond = NULL_TREE;
9801 : 15548 : tree add_when_allocated;
9802 : 15548 : tree dealloc_fndecl;
9803 : 15548 : tree caf_token;
9804 : 15548 : gfc_symbol *vtab;
9805 : 15548 : int caf_dereg_mode;
9806 : 15548 : symbol_attribute *attr;
9807 : 15548 : bool deallocate_called;
9808 : 15548 : static hash_set<gfc_symbol *> seen_derived_types;
9809 : :
9810 : 15548 : gfc_init_block (&fnblock);
9811 : :
9812 : 15548 : decl_type = TREE_TYPE (decl);
9813 : :
9814 : 15548 : if ((POINTER_TYPE_P (decl_type))
9815 : : || (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == 0))
9816 : : {
9817 : 1216 : decl = build_fold_indirect_ref_loc (input_location, decl);
9818 : : /* Deref dest in sync with decl, but only when it is not NULL. */
9819 : 1216 : if (dest)
9820 : 91 : dest = build_fold_indirect_ref_loc (input_location, dest);
9821 : :
9822 : : /* Update the decl_type because it got dereferenced. */
9823 : 1216 : decl_type = TREE_TYPE (decl);
9824 : : }
9825 : :
9826 : : /* If this is an array of derived types with allocatable components
9827 : : build a loop and recursively call this function. */
9828 : 15548 : if (TREE_CODE (decl_type) == ARRAY_TYPE
9829 : 15548 : || (GFC_DESCRIPTOR_TYPE_P (decl_type) && rank != 0))
9830 : : {
9831 : 2557 : tmp = gfc_conv_array_data (decl);
9832 : 2557 : var = build_fold_indirect_ref_loc (input_location, tmp);
9833 : :
9834 : : /* Get the number of elements - 1 and set the counter. */
9835 : 2557 : if (GFC_DESCRIPTOR_TYPE_P (decl_type))
9836 : : {
9837 : : /* Use the descriptor for an allocatable array. Since this
9838 : : is a full array reference, we only need the descriptor
9839 : : information from dimension = rank. */
9840 : 1777 : tmp = gfc_full_array_size (&fnblock, decl, rank);
9841 : 1777 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
9842 : : gfc_array_index_type, tmp,
9843 : : gfc_index_one_node);
9844 : :
9845 : 1777 : null_cond = gfc_conv_descriptor_data_get (decl);
9846 : 1777 : null_cond = fold_build2_loc (input_location, NE_EXPR,
9847 : : logical_type_node, null_cond,
9848 : 1777 : build_int_cst (TREE_TYPE (null_cond), 0));
9849 : : }
9850 : : else
9851 : : {
9852 : : /* Otherwise use the TYPE_DOMAIN information. */
9853 : 780 : tmp = array_type_nelts_minus_one (decl_type);
9854 : 780 : tmp = fold_convert (gfc_array_index_type, tmp);
9855 : : }
9856 : :
9857 : : /* Remember that this is, in fact, the no. of elements - 1. */
9858 : 2557 : nelems = gfc_evaluate_now (tmp, &fnblock);
9859 : 2557 : index = gfc_create_var (gfc_array_index_type, "S");
9860 : :
9861 : : /* Build the body of the loop. */
9862 : 2557 : gfc_init_block (&loopbody);
9863 : :
9864 : 2557 : vref = gfc_build_array_ref (var, index, NULL);
9865 : :
9866 : 2557 : if (purpose == COPY_ALLOC_COMP || purpose == COPY_ONLY_ALLOC_COMP)
9867 : : {
9868 : 489 : tmp = build_fold_indirect_ref_loc (input_location,
9869 : : gfc_conv_array_data (dest));
9870 : 489 : dref = gfc_build_array_ref (tmp, index, NULL);
9871 : 489 : tmp = structure_alloc_comps (der_type, vref, dref, rank,
9872 : : COPY_ALLOC_COMP, caf_mode, args,
9873 : : no_finalization);
9874 : : }
9875 : : else
9876 : 2068 : tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose,
9877 : : caf_mode, args, no_finalization);
9878 : :
9879 : 2557 : gfc_add_expr_to_block (&loopbody, tmp);
9880 : :
9881 : : /* Build the loop and return. */
9882 : 2557 : gfc_init_loopinfo (&loop);
9883 : 2557 : loop.dimen = 1;
9884 : 2557 : loop.from[0] = gfc_index_zero_node;
9885 : 2557 : loop.loopvar[0] = index;
9886 : 2557 : loop.to[0] = nelems;
9887 : 2557 : gfc_trans_scalarizing_loops (&loop, &loopbody);
9888 : 2557 : gfc_add_block_to_block (&fnblock, &loop.pre);
9889 : :
9890 : 2557 : tmp = gfc_finish_block (&fnblock);
9891 : : /* When copying allocateable components, the above implements the
9892 : : deep copy. Nevertheless is a deep copy only allowed, when the current
9893 : : component is allocated, for which code will be generated in
9894 : : gfc_duplicate_allocatable (), where the deep copy code is just added
9895 : : into the if's body, by adding tmp (the deep copy code) as last
9896 : : argument to gfc_duplicate_allocatable (). */
9897 : 2557 : if (purpose == COPY_ALLOC_COMP && caf_mode == 0
9898 : 2557 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
9899 : 413 : tmp = gfc_duplicate_allocatable (dest, decl, decl_type, rank,
9900 : : tmp);
9901 : 2144 : else if (null_cond != NULL_TREE)
9902 : 1364 : tmp = build3_v (COND_EXPR, null_cond, tmp,
9903 : : build_empty_stmt (input_location));
9904 : :
9905 : 2557 : return tmp;
9906 : : }
9907 : :
9908 : 12991 : if (purpose == DEALLOCATE_ALLOC_COMP && der_type->attr.pdt_type)
9909 : : {
9910 : 35 : tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
9911 : : DEALLOCATE_PDT_COMP, 0, args,
9912 : : no_finalization);
9913 : 35 : gfc_add_expr_to_block (&fnblock, tmp);
9914 : : }
9915 : 12956 : else if (purpose == ALLOCATE_PDT_COMP && der_type->attr.alloc_comp)
9916 : : {
9917 : 14 : tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
9918 : : NULLIFY_ALLOC_COMP, 0, args,
9919 : : no_finalization);
9920 : 14 : gfc_add_expr_to_block (&fnblock, tmp);
9921 : : }
9922 : :
9923 : : /* Still having a descriptor array of rank == 0 here, indicates an
9924 : : allocatable coarrays. Dereference it correctly. */
9925 : 12991 : if (GFC_DESCRIPTOR_TYPE_P (decl_type))
9926 : : {
9927 : 4 : decl = build_fold_indirect_ref (gfc_conv_array_data (decl));
9928 : : }
9929 : : /* Otherwise, act on the components or recursively call self to
9930 : : act on a chain of components. */
9931 : 12991 : seen_derived_types.add (der_type);
9932 : 36286 : for (c = der_type->components; c; c = c->next)
9933 : : {
9934 : 23295 : bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED
9935 : 23295 : || c->ts.type == BT_CLASS)
9936 : 23295 : && c->ts.u.derived->attr.alloc_comp;
9937 : 23295 : bool same_type
9938 : : = (c->ts.type == BT_DERIVED
9939 : 4656 : && seen_derived_types.contains (c->ts.u.derived))
9940 : 27209 : || (c->ts.type == BT_CLASS
9941 : 2094 : && seen_derived_types.contains (CLASS_DATA (c)->ts.u.derived));
9942 : :
9943 : 46590 : bool is_pdt_type = c->ts.type == BT_DERIVED
9944 : 23295 : && c->ts.u.derived->attr.pdt_type;
9945 : :
9946 : 23295 : cdecl = c->backend_decl;
9947 : 23295 : ctype = TREE_TYPE (cdecl);
9948 : :
9949 : 23295 : switch (purpose)
9950 : : {
9951 : :
9952 : 3 : case BCAST_ALLOC_COMP:
9953 : :
9954 : 3 : tree ubound;
9955 : 3 : tree cdesc;
9956 : 3 : stmtblock_t derived_type_block;
9957 : :
9958 : 3 : gfc_init_block (&tmpblock);
9959 : :
9960 : 3 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
9961 : : decl, cdecl, NULL_TREE);
9962 : :
9963 : : /* Shortcut to get the attributes of the component. */
9964 : 3 : if (c->ts.type == BT_CLASS)
9965 : : {
9966 : 0 : attr = &CLASS_DATA (c)->attr;
9967 : 0 : if (attr->class_pointer)
9968 : 0 : continue;
9969 : : }
9970 : : else
9971 : : {
9972 : 3 : attr = &c->attr;
9973 : 3 : if (attr->pointer)
9974 : 0 : continue;
9975 : : }
9976 : :
9977 : : /* Do not broadcast a caf_token. These are local to the image. */
9978 : 3 : if (attr->caf_token)
9979 : 1 : continue;
9980 : :
9981 : 2 : add_when_allocated = NULL_TREE;
9982 : 2 : if (cmp_has_alloc_comps
9983 : 0 : && !c->attr.pointer && !c->attr.proc_pointer)
9984 : : {
9985 : 0 : if (c->ts.type == BT_CLASS)
9986 : : {
9987 : 0 : rank = CLASS_DATA (c)->as ? CLASS_DATA (c)->as->rank : 0;
9988 : 0 : add_when_allocated
9989 : 0 : = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
9990 : : comp, NULL_TREE, rank, purpose,
9991 : : caf_mode, args, no_finalization);
9992 : : }
9993 : : else
9994 : : {
9995 : 0 : rank = c->as ? c->as->rank : 0;
9996 : 0 : add_when_allocated = structure_alloc_comps (c->ts.u.derived,
9997 : : comp, NULL_TREE,
9998 : : rank, purpose,
9999 : : caf_mode, args,
10000 : : no_finalization);
10001 : : }
10002 : : }
10003 : :
10004 : 2 : gfc_init_block (&derived_type_block);
10005 : 2 : if (add_when_allocated)
10006 : 0 : gfc_add_expr_to_block (&derived_type_block, add_when_allocated);
10007 : 2 : tmp = gfc_finish_block (&derived_type_block);
10008 : 2 : gfc_add_expr_to_block (&tmpblock, tmp);
10009 : :
10010 : : /* Convert the component into a rank 1 descriptor type. */
10011 : 2 : if (attr->dimension)
10012 : : {
10013 : 0 : tmp = gfc_get_element_type (TREE_TYPE (comp));
10014 : 0 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
10015 : 0 : ubound = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (comp));
10016 : : else
10017 : 0 : ubound = gfc_full_array_size (&tmpblock, comp,
10018 : 0 : c->ts.type == BT_CLASS
10019 : 0 : ? CLASS_DATA (c)->as->rank
10020 : 0 : : c->as->rank);
10021 : : }
10022 : : else
10023 : : {
10024 : 2 : tmp = TREE_TYPE (comp);
10025 : 2 : ubound = build_int_cst (gfc_array_index_type, 1);
10026 : : }
10027 : :
10028 : : /* Treat strings like arrays. Or the other way around, do not
10029 : : * generate an additional array layer for scalar components. */
10030 : 2 : if (attr->dimension || c->ts.type == BT_CHARACTER)
10031 : : {
10032 : 0 : cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node,
10033 : : &ubound, 1,
10034 : : GFC_ARRAY_ALLOCATABLE, false);
10035 : :
10036 : 0 : cdesc = gfc_create_var (cdesc, "cdesc");
10037 : 0 : DECL_ARTIFICIAL (cdesc) = 1;
10038 : :
10039 : 0 : gfc_add_modify (&tmpblock, gfc_conv_descriptor_dtype (cdesc),
10040 : : gfc_get_dtype_rank_type (1, tmp));
10041 : 0 : gfc_conv_descriptor_lbound_set (&tmpblock, cdesc,
10042 : : gfc_index_zero_node,
10043 : : gfc_index_one_node);
10044 : 0 : gfc_conv_descriptor_stride_set (&tmpblock, cdesc,
10045 : : gfc_index_zero_node,
10046 : : gfc_index_one_node);
10047 : 0 : gfc_conv_descriptor_ubound_set (&tmpblock, cdesc,
10048 : : gfc_index_zero_node, ubound);
10049 : : }
10050 : : else
10051 : : /* Prevent warning. */
10052 : : cdesc = NULL_TREE;
10053 : :
10054 : 2 : if (attr->dimension)
10055 : : {
10056 : 0 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
10057 : 0 : comp = gfc_conv_descriptor_data_get (comp);
10058 : : else
10059 : 0 : comp = gfc_build_addr_expr (NULL_TREE, comp);
10060 : : }
10061 : : else
10062 : : {
10063 : 2 : gfc_se se;
10064 : :
10065 : 2 : gfc_init_se (&se, NULL);
10066 : :
10067 : 2 : comp = gfc_conv_scalar_to_descriptor (&se, comp,
10068 : 2 : c->ts.type == BT_CLASS
10069 : 2 : ? CLASS_DATA (c)->attr
10070 : : : c->attr);
10071 : 2 : if (c->ts.type == BT_CHARACTER)
10072 : 0 : comp = gfc_build_addr_expr (NULL_TREE, comp);
10073 : 2 : gfc_add_block_to_block (&tmpblock, &se.pre);
10074 : : }
10075 : :
10076 : 2 : if (attr->dimension || c->ts.type == BT_CHARACTER)
10077 : 0 : gfc_conv_descriptor_data_set (&tmpblock, cdesc, comp);
10078 : : else
10079 : 2 : cdesc = comp;
10080 : :
10081 : 2 : tree fndecl;
10082 : :
10083 : 2 : fndecl = build_call_expr_loc (input_location,
10084 : : gfor_fndecl_co_broadcast, 5,
10085 : : gfc_build_addr_expr (pvoid_type_node,cdesc),
10086 : : args->image_index,
10087 : : null_pointer_node, null_pointer_node,
10088 : : null_pointer_node);
10089 : :
10090 : 2 : gfc_add_expr_to_block (&tmpblock, fndecl);
10091 : 2 : gfc_add_block_to_block (&fnblock, &tmpblock);
10092 : :
10093 : 19532 : break;
10094 : :
10095 : 9688 : case DEALLOCATE_ALLOC_COMP:
10096 : :
10097 : 9688 : gfc_init_block (&tmpblock);
10098 : :
10099 : 9688 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10100 : : decl, cdecl, NULL_TREE);
10101 : :
10102 : : /* Shortcut to get the attributes of the component. */
10103 : 9688 : if (c->ts.type == BT_CLASS)
10104 : : {
10105 : 946 : attr = &CLASS_DATA (c)->attr;
10106 : 946 : if (attr->class_pointer || c->attr.proc_pointer)
10107 : 18 : continue;
10108 : : }
10109 : : else
10110 : : {
10111 : 8742 : attr = &c->attr;
10112 : 8742 : if (attr->pointer || attr->proc_pointer)
10113 : 130 : continue;
10114 : : }
10115 : :
10116 : 9540 : if (!no_finalization && ((c->ts.type == BT_DERIVED && !c->attr.pointer)
10117 : 7419 : || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer)))
10118 : : /* Call the finalizer, which will free the memory and nullify the
10119 : : pointer of an array. */
10120 : 2703 : deallocate_called = gfc_add_comp_finalizer_call (&tmpblock, comp, c,
10121 : 2703 : caf_enabled (caf_mode))
10122 : 2703 : && attr->dimension;
10123 : : else
10124 : : deallocate_called = false;
10125 : :
10126 : : /* Add the _class ref for classes. */
10127 : 9540 : if (c->ts.type == BT_CLASS && attr->allocatable)
10128 : 928 : comp = gfc_class_data_get (comp);
10129 : :
10130 : 9540 : add_when_allocated = NULL_TREE;
10131 : 9540 : if (cmp_has_alloc_comps
10132 : 1920 : && !c->attr.pointer && !c->attr.proc_pointer
10133 : : && !same_type
10134 : 1920 : && !deallocate_called)
10135 : : {
10136 : : /* Add checked deallocation of the components. This code is
10137 : : obviously added because the finalizer is not trusted to free
10138 : : all memory. */
10139 : 1256 : if (c->ts.type == BT_CLASS)
10140 : : {
10141 : 241 : rank = CLASS_DATA (c)->as ? CLASS_DATA (c)->as->rank : 0;
10142 : 241 : add_when_allocated
10143 : 241 : = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
10144 : : comp, NULL_TREE, rank, purpose,
10145 : : caf_mode, args, no_finalization);
10146 : : }
10147 : : else
10148 : : {
10149 : 1015 : rank = c->as ? c->as->rank : 0;
10150 : 1015 : add_when_allocated = structure_alloc_comps (c->ts.u.derived,
10151 : : comp, NULL_TREE,
10152 : : rank, purpose,
10153 : : caf_mode, args,
10154 : : no_finalization);
10155 : : }
10156 : : }
10157 : :
10158 : 6540 : if (attr->allocatable && !same_type
10159 : 15596 : && (!attr->codimension || caf_enabled (caf_mode)))
10160 : : {
10161 : : /* Handle all types of components besides components of the
10162 : : same_type as the current one, because those would create an
10163 : : endless loop. */
10164 : 12100 : caf_dereg_mode = (caf_in_coarray (caf_mode)
10165 : 51 : && (attr->dimension || c->caf_token))
10166 : 5999 : || attr->codimension
10167 : 6122 : ? (gfc_caf_is_dealloc_only (caf_mode)
10168 : : ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
10169 : : : GFC_CAF_COARRAY_DEREGISTER)
10170 : : : GFC_CAF_COARRAY_NOCOARRAY;
10171 : :
10172 : 6050 : caf_token = NULL_TREE;
10173 : : /* Coarray components are handled directly by
10174 : : deallocate_with_status. */
10175 : 6050 : if (!attr->codimension
10176 : 6029 : && caf_dereg_mode != GFC_CAF_COARRAY_NOCOARRAY)
10177 : : {
10178 : 51 : if (c->caf_token)
10179 : 17 : caf_token
10180 : 17 : = fold_build3_loc (input_location, COMPONENT_REF,
10181 : 17 : TREE_TYPE (gfc_comp_caf_token (c)),
10182 : : decl, gfc_comp_caf_token (c),
10183 : : NULL_TREE);
10184 : 34 : else if (attr->dimension && !attr->proc_pointer)
10185 : 34 : caf_token = gfc_conv_descriptor_token (comp);
10186 : : }
10187 : :
10188 : 6050 : tmp = gfc_deallocate_with_status (comp, NULL_TREE, NULL_TREE,
10189 : : NULL_TREE, NULL_TREE, true,
10190 : : NULL, caf_dereg_mode, NULL_TREE,
10191 : : add_when_allocated, caf_token);
10192 : :
10193 : 6050 : gfc_add_expr_to_block (&tmpblock, tmp);
10194 : : }
10195 : 3490 : else if (attr->allocatable && !attr->codimension
10196 : 484 : && !deallocate_called)
10197 : : {
10198 : : /* Case of recursive allocatable derived types. */
10199 : 484 : tree is_allocated;
10200 : 484 : tree ubound;
10201 : 484 : tree cdesc;
10202 : 484 : stmtblock_t dealloc_block;
10203 : :
10204 : 484 : gfc_init_block (&dealloc_block);
10205 : 484 : if (add_when_allocated)
10206 : 0 : gfc_add_expr_to_block (&dealloc_block, add_when_allocated);
10207 : :
10208 : : /* Convert the component into a rank 1 descriptor type. */
10209 : 484 : if (attr->dimension)
10210 : : {
10211 : 52 : tmp = gfc_get_element_type (TREE_TYPE (comp));
10212 : 52 : ubound = gfc_full_array_size (&dealloc_block, comp,
10213 : 52 : c->ts.type == BT_CLASS
10214 : 0 : ? CLASS_DATA (c)->as->rank
10215 : 52 : : c->as->rank);
10216 : : }
10217 : : else
10218 : : {
10219 : 432 : tmp = TREE_TYPE (comp);
10220 : 432 : ubound = build_int_cst (gfc_array_index_type, 1);
10221 : : }
10222 : :
10223 : 484 : cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node,
10224 : : &ubound, 1,
10225 : : GFC_ARRAY_ALLOCATABLE, false);
10226 : :
10227 : 484 : cdesc = gfc_create_var (cdesc, "cdesc");
10228 : 484 : DECL_ARTIFICIAL (cdesc) = 1;
10229 : :
10230 : 484 : gfc_add_modify (&dealloc_block, gfc_conv_descriptor_dtype (cdesc),
10231 : : gfc_get_dtype_rank_type (1, tmp));
10232 : 484 : gfc_conv_descriptor_lbound_set (&dealloc_block, cdesc,
10233 : : gfc_index_zero_node,
10234 : : gfc_index_one_node);
10235 : 484 : gfc_conv_descriptor_stride_set (&dealloc_block, cdesc,
10236 : : gfc_index_zero_node,
10237 : : gfc_index_one_node);
10238 : 484 : gfc_conv_descriptor_ubound_set (&dealloc_block, cdesc,
10239 : : gfc_index_zero_node, ubound);
10240 : :
10241 : 484 : if (attr->dimension)
10242 : 52 : comp = gfc_conv_descriptor_data_get (comp);
10243 : :
10244 : 484 : gfc_conv_descriptor_data_set (&dealloc_block, cdesc, comp);
10245 : :
10246 : : /* Now call the deallocator. */
10247 : 484 : vtab = gfc_find_vtab (&c->ts);
10248 : 484 : if (vtab->backend_decl == NULL)
10249 : 28 : gfc_get_symbol_decl (vtab);
10250 : 484 : tmp = gfc_build_addr_expr (NULL_TREE, vtab->backend_decl);
10251 : 484 : dealloc_fndecl = gfc_vptr_deallocate_get (tmp);
10252 : 484 : dealloc_fndecl = build_fold_indirect_ref_loc (input_location,
10253 : : dealloc_fndecl);
10254 : 484 : tmp = build_int_cst (TREE_TYPE (comp), 0);
10255 : 484 : is_allocated = fold_build2_loc (input_location, NE_EXPR,
10256 : : logical_type_node, tmp,
10257 : : comp);
10258 : 484 : cdesc = gfc_build_addr_expr (NULL_TREE, cdesc);
10259 : :
10260 : 484 : tmp = build_call_expr_loc (input_location,
10261 : : dealloc_fndecl, 1,
10262 : : cdesc);
10263 : 484 : gfc_add_expr_to_block (&dealloc_block, tmp);
10264 : :
10265 : 484 : tmp = gfc_finish_block (&dealloc_block);
10266 : :
10267 : 484 : tmp = fold_build3_loc (input_location, COND_EXPR,
10268 : : void_type_node, is_allocated, tmp,
10269 : : build_empty_stmt (input_location));
10270 : :
10271 : 484 : gfc_add_expr_to_block (&tmpblock, tmp);
10272 : 484 : }
10273 : 3006 : else if (add_when_allocated)
10274 : 519 : gfc_add_expr_to_block (&tmpblock, add_when_allocated);
10275 : :
10276 : 928 : if (c->ts.type == BT_CLASS && attr->allocatable
10277 : 10468 : && (!attr->codimension || !caf_enabled (caf_mode)))
10278 : : {
10279 : : /* Finally, reset the vptr to the declared type vtable and, if
10280 : : necessary reset the _len field.
10281 : :
10282 : : First recover the reference to the component and obtain
10283 : : the vptr. */
10284 : 913 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10285 : : decl, cdecl, NULL_TREE);
10286 : 913 : tmp = gfc_class_vptr_get (comp);
10287 : :
10288 : 913 : if (UNLIMITED_POLY (c))
10289 : : {
10290 : : /* Both vptr and _len field should be nulled. */
10291 : 175 : gfc_add_modify (&tmpblock, tmp,
10292 : 175 : build_int_cst (TREE_TYPE (tmp), 0));
10293 : 175 : tmp = gfc_class_len_get (comp);
10294 : 175 : gfc_add_modify (&tmpblock, tmp,
10295 : 175 : build_int_cst (TREE_TYPE (tmp), 0));
10296 : : }
10297 : : else
10298 : : {
10299 : : /* Build the vtable address and set the vptr with it. */
10300 : 738 : gfc_reset_vptr (&tmpblock, nullptr, tmp, c->ts.u.derived);
10301 : : }
10302 : : }
10303 : :
10304 : : /* Now add the deallocation of this component. */
10305 : 9540 : gfc_add_block_to_block (&fnblock, &tmpblock);
10306 : 9540 : break;
10307 : :
10308 : 3819 : case NULLIFY_ALLOC_COMP:
10309 : : /* Nullify
10310 : : - allocatable components (regular or in class)
10311 : : - components that have allocatable components
10312 : : - pointer components when in a coarray.
10313 : : Skip everything else especially proc_pointers, which may come
10314 : : coupled with the regular pointer attribute. */
10315 : 5044 : if (c->attr.proc_pointer
10316 : 3819 : || !(c->attr.allocatable || (c->ts.type == BT_CLASS
10317 : 412 : && CLASS_DATA (c)->attr.allocatable)
10318 : 1543 : || (cmp_has_alloc_comps
10319 : 234 : && ((c->ts.type == BT_DERIVED && !c->attr.pointer)
10320 : 18 : || (c->ts.type == BT_CLASS
10321 : 12 : && !CLASS_DATA (c)->attr.class_pointer)))
10322 : 1327 : || (caf_in_coarray (caf_mode) && c->attr.pointer)))
10323 : 1225 : continue;
10324 : :
10325 : : /* Process class components first, because they always have the
10326 : : pointer-attribute set which would be caught wrong else. */
10327 : 2594 : if (c->ts.type == BT_CLASS
10328 : 399 : && (CLASS_DATA (c)->attr.allocatable
10329 : 399 : || CLASS_DATA (c)->attr.class_pointer))
10330 : : {
10331 : 399 : tree class_ref;
10332 : :
10333 : : /* Allocatable CLASS components. */
10334 : 399 : class_ref = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10335 : : decl, cdecl, NULL_TREE);
10336 : :
10337 : 399 : comp = gfc_class_data_get (class_ref);
10338 : 399 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
10339 : 215 : gfc_conv_descriptor_data_set (&fnblock, comp,
10340 : : null_pointer_node);
10341 : : else
10342 : : {
10343 : 184 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
10344 : : void_type_node, comp,
10345 : 184 : build_int_cst (TREE_TYPE (comp), 0));
10346 : 184 : gfc_add_expr_to_block (&fnblock, tmp);
10347 : : }
10348 : :
10349 : : /* The dynamic type of a disassociated pointer or unallocated
10350 : : allocatable variable is its declared type. An unlimited
10351 : : polymorphic entity has no declared type. */
10352 : 399 : gfc_reset_vptr (&fnblock, nullptr, class_ref, c->ts.u.derived);
10353 : :
10354 : 399 : cmp_has_alloc_comps = false;
10355 : 399 : }
10356 : : /* Coarrays need the component to be nulled before the api-call
10357 : : is made. */
10358 : 2195 : else if (c->attr.pointer || c->attr.allocatable)
10359 : : {
10360 : 1979 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10361 : : decl, cdecl, NULL_TREE);
10362 : 1979 : if (c->attr.dimension || c->attr.codimension)
10363 : 1393 : gfc_conv_descriptor_data_set (&fnblock, comp,
10364 : : null_pointer_node);
10365 : : else
10366 : 586 : gfc_add_modify (&fnblock, comp,
10367 : 586 : build_int_cst (TREE_TYPE (comp), 0));
10368 : 1979 : if (gfc_deferred_strlen (c, &comp))
10369 : : {
10370 : 249 : comp = fold_build3_loc (input_location, COMPONENT_REF,
10371 : 249 : TREE_TYPE (comp),
10372 : : decl, comp, NULL_TREE);
10373 : 498 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
10374 : 249 : TREE_TYPE (comp), comp,
10375 : 249 : build_int_cst (TREE_TYPE (comp), 0));
10376 : 249 : gfc_add_expr_to_block (&fnblock, tmp);
10377 : : }
10378 : : cmp_has_alloc_comps = false;
10379 : : }
10380 : :
10381 : 2594 : if (flag_coarray == GFC_FCOARRAY_LIB && caf_in_coarray (caf_mode))
10382 : : {
10383 : : /* Register a component of a derived type coarray with the
10384 : : coarray library. Do not register ultimate component
10385 : : coarrays here. They are treated like regular coarrays and
10386 : : are either allocated on all images or on none. */
10387 : 126 : tree token;
10388 : :
10389 : 126 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10390 : : decl, cdecl, NULL_TREE);
10391 : 126 : if (c->attr.dimension)
10392 : : {
10393 : : /* Set the dtype, because caf_register needs it. */
10394 : 100 : gfc_add_modify (&fnblock, gfc_conv_descriptor_dtype (comp),
10395 : 100 : gfc_get_dtype (TREE_TYPE (comp)));
10396 : 100 : tmp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10397 : : decl, cdecl, NULL_TREE);
10398 : 100 : token = gfc_conv_descriptor_token (tmp);
10399 : : }
10400 : : else
10401 : : {
10402 : 26 : gfc_se se;
10403 : :
10404 : 26 : gfc_init_se (&se, NULL);
10405 : 52 : token = fold_build3_loc (input_location, COMPONENT_REF,
10406 : : pvoid_type_node, decl,
10407 : 26 : gfc_comp_caf_token (c), NULL_TREE);
10408 : 26 : comp = gfc_conv_scalar_to_descriptor (&se, comp,
10409 : 26 : c->ts.type == BT_CLASS
10410 : 26 : ? CLASS_DATA (c)->attr
10411 : : : c->attr);
10412 : 26 : gfc_add_block_to_block (&fnblock, &se.pre);
10413 : : }
10414 : :
10415 : 126 : gfc_allocate_using_caf_lib (&fnblock, comp, size_zero_node,
10416 : : gfc_build_addr_expr (NULL_TREE,
10417 : : token),
10418 : : NULL_TREE, NULL_TREE, NULL_TREE,
10419 : : GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
10420 : : }
10421 : :
10422 : 2594 : if (cmp_has_alloc_comps)
10423 : : {
10424 : 216 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10425 : : decl, cdecl, NULL_TREE);
10426 : 216 : rank = c->as ? c->as->rank : 0;
10427 : 216 : tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
10428 : : rank, purpose, caf_mode, args,
10429 : : no_finalization);
10430 : 216 : gfc_add_expr_to_block (&fnblock, tmp);
10431 : : }
10432 : : break;
10433 : :
10434 : 29 : case REASSIGN_CAF_COMP:
10435 : 29 : if (caf_enabled (caf_mode)
10436 : 29 : && (c->attr.codimension
10437 : 23 : || (c->ts.type == BT_CLASS
10438 : 2 : && (CLASS_DATA (c)->attr.coarray_comp
10439 : 2 : || caf_in_coarray (caf_mode)))
10440 : 21 : || (c->ts.type == BT_DERIVED
10441 : 7 : && (c->ts.u.derived->attr.coarray_comp
10442 : 6 : || caf_in_coarray (caf_mode))))
10443 : 44 : && !same_type)
10444 : : {
10445 : 13 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10446 : : decl, cdecl, NULL_TREE);
10447 : 13 : dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10448 : : dest, cdecl, NULL_TREE);
10449 : :
10450 : 13 : if (c->attr.codimension)
10451 : : {
10452 : 6 : if (c->ts.type == BT_CLASS)
10453 : : {
10454 : 0 : comp = gfc_class_data_get (comp);
10455 : 0 : dcmp = gfc_class_data_get (dcmp);
10456 : : }
10457 : 6 : gfc_conv_descriptor_data_set (&fnblock, dcmp,
10458 : : gfc_conv_descriptor_data_get (comp));
10459 : : }
10460 : : else
10461 : : {
10462 : 7 : tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
10463 : : rank, purpose, caf_mode
10464 : : | GFC_STRUCTURE_CAF_MODE_IN_COARRAY,
10465 : : args, no_finalization);
10466 : 7 : gfc_add_expr_to_block (&fnblock, tmp);
10467 : : }
10468 : : }
10469 : : break;
10470 : :
10471 : 7613 : case COPY_ALLOC_COMP:
10472 : 7613 : if (c->attr.pointer || c->attr.proc_pointer)
10473 : 156 : continue;
10474 : :
10475 : : /* We need source and destination components. */
10476 : 7457 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl,
10477 : : cdecl, NULL_TREE);
10478 : 7457 : dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, dest,
10479 : : cdecl, NULL_TREE);
10480 : 7457 : dcmp = fold_convert (TREE_TYPE (comp), dcmp);
10481 : :
10482 : 7457 : if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
10483 : : {
10484 : 706 : tree ftn_tree;
10485 : 706 : tree size;
10486 : 706 : tree dst_data;
10487 : 706 : tree src_data;
10488 : 706 : tree null_data;
10489 : :
10490 : 706 : dst_data = gfc_class_data_get (dcmp);
10491 : 706 : src_data = gfc_class_data_get (comp);
10492 : 706 : size = fold_convert (size_type_node,
10493 : : gfc_class_vtab_size_get (comp));
10494 : :
10495 : 706 : if (CLASS_DATA (c)->attr.dimension)
10496 : : {
10497 : 696 : nelems = gfc_conv_descriptor_size (src_data,
10498 : 348 : CLASS_DATA (c)->as->rank);
10499 : 348 : size = fold_build2_loc (input_location, MULT_EXPR,
10500 : : size_type_node, size,
10501 : : fold_convert (size_type_node,
10502 : : nelems));
10503 : : }
10504 : : else
10505 : 358 : nelems = build_int_cst (size_type_node, 1);
10506 : :
10507 : 706 : if (CLASS_DATA (c)->attr.dimension
10508 : 706 : || CLASS_DATA (c)->attr.codimension)
10509 : : {
10510 : 356 : src_data = gfc_conv_descriptor_data_get (src_data);
10511 : 356 : dst_data = gfc_conv_descriptor_data_get (dst_data);
10512 : : }
10513 : :
10514 : 706 : gfc_init_block (&tmpblock);
10515 : :
10516 : 706 : gfc_add_modify (&tmpblock, gfc_class_vptr_get (dcmp),
10517 : : gfc_class_vptr_get (comp));
10518 : :
10519 : : /* Copy the unlimited '_len' field. If it is greater than zero
10520 : : (ie. a character(_len)), multiply it by size and use this
10521 : : for the malloc call. */
10522 : 706 : if (UNLIMITED_POLY (c))
10523 : : {
10524 : 135 : gfc_add_modify (&tmpblock, gfc_class_len_get (dcmp),
10525 : : gfc_class_len_get (comp));
10526 : 135 : size = gfc_resize_class_size_with_len (&tmpblock, comp, size);
10527 : : }
10528 : :
10529 : : /* Coarray component have to have the same allocation status and
10530 : : shape/type-parameter/effective-type on the LHS and RHS of an
10531 : : intrinsic assignment. Hence, we did not deallocated them - and
10532 : : do not allocate them here. */
10533 : 706 : if (!CLASS_DATA (c)->attr.codimension)
10534 : : {
10535 : 691 : ftn_tree = builtin_decl_explicit (BUILT_IN_MALLOC);
10536 : 691 : tmp = build_call_expr_loc (input_location, ftn_tree, 1, size);
10537 : 691 : gfc_add_modify (&tmpblock, dst_data,
10538 : 691 : fold_convert (TREE_TYPE (dst_data), tmp));
10539 : : }
10540 : :
10541 : 1397 : tmp = gfc_copy_class_to_class (comp, dcmp, nelems,
10542 : 706 : UNLIMITED_POLY (c));
10543 : 706 : gfc_add_expr_to_block (&tmpblock, tmp);
10544 : 706 : tmp = gfc_finish_block (&tmpblock);
10545 : :
10546 : 706 : gfc_init_block (&tmpblock);
10547 : 706 : gfc_add_modify (&tmpblock, dst_data,
10548 : 706 : fold_convert (TREE_TYPE (dst_data),
10549 : : null_pointer_node));
10550 : 706 : null_data = gfc_finish_block (&tmpblock);
10551 : :
10552 : 706 : null_cond = fold_build2_loc (input_location, NE_EXPR,
10553 : : logical_type_node, src_data,
10554 : : null_pointer_node);
10555 : :
10556 : 706 : gfc_add_expr_to_block (&fnblock, build3_v (COND_EXPR, null_cond,
10557 : : tmp, null_data));
10558 : 706 : continue;
10559 : 706 : }
10560 : :
10561 : : /* To implement guarded deep copy, i.e., deep copy only allocatable
10562 : : components that are really allocated, the deep copy code has to
10563 : : be generated first and then added to the if-block in
10564 : : gfc_duplicate_allocatable (). */
10565 : 6751 : if (cmp_has_alloc_comps && !c->attr.proc_pointer && !same_type)
10566 : : {
10567 : 1079 : rank = c->as ? c->as->rank : 0;
10568 : 1079 : tmp = fold_convert (TREE_TYPE (dcmp), comp);
10569 : 1079 : gfc_add_modify (&fnblock, dcmp, tmp);
10570 : 1079 : add_when_allocated = structure_alloc_comps (c->ts.u.derived,
10571 : : comp, dcmp,
10572 : : rank, purpose,
10573 : : caf_mode, args,
10574 : : no_finalization);
10575 : : }
10576 : : else
10577 : : add_when_allocated = NULL_TREE;
10578 : :
10579 : 6751 : if (gfc_deferred_strlen (c, &tmp))
10580 : : {
10581 : 335 : tree len, size;
10582 : 335 : len = tmp;
10583 : 335 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
10584 : 335 : TREE_TYPE (len),
10585 : : decl, len, NULL_TREE);
10586 : 335 : len = fold_build3_loc (input_location, COMPONENT_REF,
10587 : 335 : TREE_TYPE (len),
10588 : : dest, len, NULL_TREE);
10589 : 335 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
10590 : 335 : TREE_TYPE (len), len, tmp);
10591 : 335 : gfc_add_expr_to_block (&fnblock, tmp);
10592 : 335 : size = size_of_string_in_bytes (c->ts.kind, len);
10593 : : /* This component cannot have allocatable components,
10594 : : therefore add_when_allocated of duplicate_allocatable ()
10595 : : is always NULL. */
10596 : 335 : rank = c->as ? c->as->rank : 0;
10597 : 335 : tmp = duplicate_allocatable (dcmp, comp, ctype, rank,
10598 : : false, false, size, NULL_TREE);
10599 : 335 : gfc_add_expr_to_block (&fnblock, tmp);
10600 : : }
10601 : 6416 : else if (c->attr.pdt_array)
10602 : : {
10603 : 31 : tmp = duplicate_allocatable (dcmp, comp, ctype,
10604 : 31 : c->as ? c->as->rank : 0,
10605 : : false, false, NULL_TREE, NULL_TREE);
10606 : 31 : gfc_add_expr_to_block (&fnblock, tmp);
10607 : : }
10608 : 6385 : else if (c->attr.allocatable && !c->attr.proc_pointer
10609 : 6385 : && (!(cmp_has_alloc_comps && c->as) || c->attr.codimension
10610 : 318 : || caf_in_coarray (caf_mode)))
10611 : : {
10612 : 3241 : rank = c->as ? c->as->rank : 0;
10613 : 3241 : if (c->attr.codimension)
10614 : 15 : tmp = gfc_copy_allocatable_data (dcmp, comp, ctype, rank);
10615 : 3226 : else if (flag_coarray == GFC_FCOARRAY_LIB
10616 : 3226 : && caf_in_coarray (caf_mode))
10617 : : {
10618 : 55 : tree dst_tok;
10619 : 55 : if (c->as)
10620 : 40 : dst_tok = gfc_conv_descriptor_token (dcmp);
10621 : : else
10622 : : {
10623 : 15 : dst_tok
10624 : 15 : = fold_build3_loc (input_location, COMPONENT_REF,
10625 : : pvoid_type_node, dest,
10626 : 15 : gfc_comp_caf_token (c), NULL_TREE);
10627 : : }
10628 : 55 : tmp
10629 : 55 : = duplicate_allocatable_coarray (dcmp, dst_tok, comp, ctype,
10630 : : rank, add_when_allocated);
10631 : : }
10632 : : else
10633 : 3171 : tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank,
10634 : : add_when_allocated);
10635 : 3241 : gfc_add_expr_to_block (&fnblock, tmp);
10636 : : }
10637 : : else
10638 : 3144 : if (cmp_has_alloc_comps || is_pdt_type)
10639 : 1052 : gfc_add_expr_to_block (&fnblock, add_when_allocated);
10640 : :
10641 : : break;
10642 : :
10643 : 900 : case ALLOCATE_PDT_COMP:
10644 : :
10645 : 900 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10646 : : decl, cdecl, NULL_TREE);
10647 : :
10648 : : /* Set the PDT KIND and LEN fields. */
10649 : 900 : if (c->attr.pdt_kind || c->attr.pdt_len)
10650 : : {
10651 : 439 : gfc_se tse;
10652 : 439 : gfc_expr *c_expr = NULL;
10653 : 439 : gfc_actual_arglist *param = pdt_param_list;
10654 : 439 : gfc_init_se (&tse, NULL);
10655 : 1767 : for (; param; param = param->next)
10656 : 889 : if (param->name && !strcmp (c->name, param->name))
10657 : 415 : c_expr = param->expr;
10658 : :
10659 : 439 : if (!c_expr)
10660 : 24 : c_expr = c->initializer;
10661 : :
10662 : 24 : if (c_expr)
10663 : : {
10664 : 439 : gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp));
10665 : 439 : gfc_add_modify (&fnblock, comp, tse.expr);
10666 : : }
10667 : : }
10668 : :
10669 : 900 : if (c->attr.pdt_string)
10670 : : {
10671 : 72 : gfc_se tse;
10672 : 72 : gfc_init_se (&tse, NULL);
10673 : 72 : tree strlen = NULL_TREE;
10674 : 72 : gfc_expr *e = gfc_copy_expr (c->ts.u.cl->length);
10675 : : /* Convert the parameterized string length to its value. The
10676 : : string length is stored in a hidden field in the same way as
10677 : : deferred string lengths. */
10678 : 72 : gfc_insert_parameter_exprs (e, pdt_param_list);
10679 : 72 : if (gfc_deferred_strlen (c, &strlen) && strlen != NULL_TREE)
10680 : : {
10681 : 72 : gfc_conv_expr_type (&tse, e,
10682 : 72 : TREE_TYPE (strlen));
10683 : 72 : strlen = fold_build3_loc (input_location, COMPONENT_REF,
10684 : 72 : TREE_TYPE (strlen),
10685 : : decl, strlen, NULL_TREE);
10686 : 72 : gfc_add_modify (&fnblock, strlen, tse.expr);
10687 : 72 : c->ts.u.cl->backend_decl = strlen;
10688 : : }
10689 : 72 : gfc_free_expr (e);
10690 : :
10691 : : /* Scalar parameterized strings can be allocated now. */
10692 : 72 : if (!c->as)
10693 : : {
10694 : 72 : tmp = fold_convert (gfc_array_index_type, strlen);
10695 : 72 : tmp = size_of_string_in_bytes (c->ts.kind, tmp);
10696 : 72 : tmp = gfc_evaluate_now (tmp, &fnblock);
10697 : 72 : tmp = gfc_call_malloc (&fnblock, TREE_TYPE (comp), tmp);
10698 : 72 : gfc_add_modify (&fnblock, comp, tmp);
10699 : : }
10700 : : }
10701 : :
10702 : : /* Allocate parameterized arrays of parameterized derived types. */
10703 : 900 : if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT)
10704 : 735 : && !((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
10705 : 62 : && (c->ts.u.derived && c->ts.u.derived->attr.pdt_type)))
10706 : 673 : continue;
10707 : :
10708 : 227 : if (c->ts.type == BT_CLASS)
10709 : 0 : comp = gfc_class_data_get (comp);
10710 : :
10711 : 227 : if (c->attr.pdt_array)
10712 : : {
10713 : 165 : gfc_se tse;
10714 : 165 : int i;
10715 : 165 : tree size = gfc_index_one_node;
10716 : 165 : tree offset = gfc_index_zero_node;
10717 : 165 : tree lower, upper;
10718 : 165 : gfc_expr *e;
10719 : :
10720 : : /* This chunk takes the expressions for 'lower' and 'upper'
10721 : : in the arrayspec and substitutes in the expressions for
10722 : : the parameters from 'pdt_param_list'. The descriptor
10723 : : fields can then be filled from the values so obtained. */
10724 : 165 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)));
10725 : 408 : for (i = 0; i < c->as->rank; i++)
10726 : : {
10727 : 243 : gfc_init_se (&tse, NULL);
10728 : 243 : e = gfc_copy_expr (c->as->lower[i]);
10729 : 243 : gfc_insert_parameter_exprs (e, pdt_param_list);
10730 : 243 : gfc_conv_expr_type (&tse, e, gfc_array_index_type);
10731 : 243 : gfc_free_expr (e);
10732 : 243 : lower = tse.expr;
10733 : 243 : gfc_conv_descriptor_lbound_set (&fnblock, comp,
10734 : : gfc_rank_cst[i],
10735 : : lower);
10736 : 243 : e = gfc_copy_expr (c->as->upper[i]);
10737 : 243 : gfc_insert_parameter_exprs (e, pdt_param_list);
10738 : 243 : gfc_conv_expr_type (&tse, e, gfc_array_index_type);
10739 : 243 : gfc_free_expr (e);
10740 : 243 : upper = tse.expr;
10741 : 243 : gfc_conv_descriptor_ubound_set (&fnblock, comp,
10742 : : gfc_rank_cst[i],
10743 : : upper);
10744 : 243 : gfc_conv_descriptor_stride_set (&fnblock, comp,
10745 : : gfc_rank_cst[i],
10746 : : size);
10747 : 243 : size = gfc_evaluate_now (size, &fnblock);
10748 : 243 : offset = fold_build2_loc (input_location,
10749 : : MINUS_EXPR,
10750 : : gfc_array_index_type,
10751 : : offset, size);
10752 : 243 : offset = gfc_evaluate_now (offset, &fnblock);
10753 : 243 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
10754 : : gfc_array_index_type,
10755 : : upper, lower);
10756 : 243 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
10757 : : gfc_array_index_type,
10758 : : tmp, gfc_index_one_node);
10759 : 243 : size = fold_build2_loc (input_location, MULT_EXPR,
10760 : : gfc_array_index_type, size, tmp);
10761 : : }
10762 : 165 : gfc_conv_descriptor_offset_set (&fnblock, comp, offset);
10763 : 165 : if (c->ts.type == BT_CLASS)
10764 : : {
10765 : 0 : tmp = gfc_get_vptr_from_expr (comp);
10766 : 0 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
10767 : 0 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
10768 : 0 : tmp = gfc_vptr_size_get (tmp);
10769 : : }
10770 : : else
10771 : 165 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (ctype));
10772 : 165 : tmp = fold_convert (gfc_array_index_type, tmp);
10773 : 165 : size = fold_build2_loc (input_location, MULT_EXPR,
10774 : : gfc_array_index_type, size, tmp);
10775 : 165 : size = gfc_evaluate_now (size, &fnblock);
10776 : 165 : tmp = gfc_call_malloc (&fnblock, NULL, size);
10777 : 165 : gfc_conv_descriptor_data_set (&fnblock, comp, tmp);
10778 : 165 : tmp = gfc_conv_descriptor_dtype (comp);
10779 : 165 : gfc_add_modify (&fnblock, tmp, gfc_get_dtype (ctype));
10780 : :
10781 : 165 : if (c->initializer && c->initializer->rank)
10782 : : {
10783 : 48 : gfc_init_se (&tse, NULL);
10784 : 48 : e = gfc_copy_expr (c->initializer);
10785 : 48 : gfc_insert_parameter_exprs (e, pdt_param_list);
10786 : 48 : gfc_conv_expr_descriptor (&tse, e);
10787 : 48 : gfc_add_block_to_block (&fnblock, &tse.pre);
10788 : 48 : gfc_free_expr (e);
10789 : 48 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
10790 : 48 : tmp = build_call_expr_loc (input_location, tmp, 3,
10791 : : gfc_conv_descriptor_data_get (comp),
10792 : : gfc_conv_descriptor_data_get (tse.expr),
10793 : : fold_convert (size_type_node, size));
10794 : 48 : gfc_add_expr_to_block (&fnblock, tmp);
10795 : 48 : gfc_add_block_to_block (&fnblock, &tse.post);
10796 : : }
10797 : : }
10798 : :
10799 : : /* Recurse in to PDT components. */
10800 : 227 : if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
10801 : 74 : && c->ts.u.derived && c->ts.u.derived->attr.pdt_type
10802 : 74 : && !(c->attr.pointer || c->attr.allocatable))
10803 : : {
10804 : 48 : bool is_deferred = false;
10805 : 48 : gfc_actual_arglist *tail = c->param_list;
10806 : :
10807 : 126 : for (; tail; tail = tail->next)
10808 : 78 : if (!tail->expr)
10809 : 24 : is_deferred = true;
10810 : :
10811 : 48 : tail = is_deferred ? pdt_param_list : c->param_list;
10812 : 48 : tmp = gfc_allocate_pdt_comp (c->ts.u.derived, comp,
10813 : 48 : c->as ? c->as->rank : 0,
10814 : : tail);
10815 : 48 : gfc_add_expr_to_block (&fnblock, tmp);
10816 : : }
10817 : :
10818 : : break;
10819 : :
10820 : 979 : case DEALLOCATE_PDT_COMP:
10821 : : /* Deallocate array or parameterized string length components
10822 : : of parameterized derived types. */
10823 : 979 : if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT)
10824 : 797 : && !c->attr.pdt_string
10825 : 731 : && !((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
10826 : 91 : && (c->ts.u.derived && c->ts.u.derived->attr.pdt_type)))
10827 : 640 : continue;
10828 : :
10829 : 339 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10830 : : decl, cdecl, NULL_TREE);
10831 : 339 : if (c->ts.type == BT_CLASS)
10832 : 0 : comp = gfc_class_data_get (comp);
10833 : :
10834 : : /* Recurse in to PDT components. */
10835 : 339 : if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
10836 : 97 : && c->ts.u.derived && c->ts.u.derived->attr.pdt_type
10837 : 97 : && (!c->attr.pointer && !c->attr.allocatable))
10838 : : {
10839 : 42 : tmp = gfc_deallocate_pdt_comp (c->ts.u.derived, comp,
10840 : 42 : c->as ? c->as->rank : 0);
10841 : 42 : gfc_add_expr_to_block (&fnblock, tmp);
10842 : : }
10843 : :
10844 : 339 : if (c->attr.pdt_array || c->attr.pdt_string)
10845 : : {
10846 : 248 : tmp = comp;
10847 : 248 : if (c->attr.pdt_array)
10848 : 182 : tmp = gfc_conv_descriptor_data_get (comp);
10849 : 248 : null_cond = fold_build2_loc (input_location, NE_EXPR,
10850 : : logical_type_node, tmp,
10851 : 248 : build_int_cst (TREE_TYPE (tmp), 0));
10852 : 248 : if (flag_openmp_allocators)
10853 : : {
10854 : 0 : tree cd, t;
10855 : 0 : if (c->attr.pdt_array)
10856 : 0 : cd = fold_build2_loc (input_location, EQ_EXPR,
10857 : : boolean_type_node,
10858 : : gfc_conv_descriptor_version (comp),
10859 : 0 : build_int_cst (integer_type_node, 1));
10860 : : else
10861 : 0 : cd = gfc_omp_call_is_alloc (tmp);
10862 : 0 : t = builtin_decl_explicit (BUILT_IN_GOMP_FREE);
10863 : 0 : t = build_call_expr_loc (input_location, t, 1, tmp);
10864 : :
10865 : 0 : stmtblock_t tblock;
10866 : 0 : gfc_init_block (&tblock);
10867 : 0 : gfc_add_expr_to_block (&tblock, t);
10868 : 0 : if (c->attr.pdt_array)
10869 : 0 : gfc_add_modify (&tblock, gfc_conv_descriptor_version (comp),
10870 : : integer_zero_node);
10871 : 0 : tmp = build3_loc (input_location, COND_EXPR, void_type_node,
10872 : : cd, gfc_finish_block (&tblock),
10873 : : gfc_call_free (tmp));
10874 : : }
10875 : : else
10876 : 248 : tmp = gfc_call_free (tmp);
10877 : 248 : tmp = build3_v (COND_EXPR, null_cond, tmp,
10878 : : build_empty_stmt (input_location));
10879 : 248 : gfc_add_expr_to_block (&fnblock, tmp);
10880 : :
10881 : 248 : if (c->attr.pdt_array)
10882 : 182 : gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
10883 : : else
10884 : : {
10885 : 66 : tmp = fold_convert (TREE_TYPE (comp), null_pointer_node);
10886 : 66 : gfc_add_modify (&fnblock, comp, tmp);
10887 : : }
10888 : : }
10889 : :
10890 : : break;
10891 : :
10892 : 264 : case CHECK_PDT_DUMMY:
10893 : :
10894 : 264 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10895 : : decl, cdecl, NULL_TREE);
10896 : 264 : if (c->ts.type == BT_CLASS)
10897 : 0 : comp = gfc_class_data_get (comp);
10898 : :
10899 : : /* Recurse in to PDT components. */
10900 : 264 : if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
10901 : 0 : && c->ts.u.derived && c->ts.u.derived->attr.pdt_type)
10902 : : {
10903 : 0 : tmp = gfc_check_pdt_dummy (c->ts.u.derived, comp,
10904 : 0 : c->as ? c->as->rank : 0,
10905 : : pdt_param_list);
10906 : 0 : gfc_add_expr_to_block (&fnblock, tmp);
10907 : : }
10908 : :
10909 : 264 : if (!c->attr.pdt_len)
10910 : 216 : continue;
10911 : : else
10912 : : {
10913 : 48 : gfc_se tse;
10914 : 48 : gfc_expr *c_expr = NULL;
10915 : 48 : gfc_actual_arglist *param = pdt_param_list;
10916 : :
10917 : 48 : gfc_init_se (&tse, NULL);
10918 : 186 : for (; param; param = param->next)
10919 : 90 : if (!strcmp (c->name, param->name)
10920 : 48 : && param->spec_type == SPEC_EXPLICIT)
10921 : 30 : c_expr = param->expr;
10922 : :
10923 : 48 : if (c_expr)
10924 : : {
10925 : 30 : tree error, cond, cname;
10926 : 30 : gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp));
10927 : 30 : cond = fold_build2_loc (input_location, NE_EXPR,
10928 : : logical_type_node,
10929 : : comp, tse.expr);
10930 : 30 : cname = gfc_build_cstring_const (c->name);
10931 : 30 : cname = gfc_build_addr_expr (pchar_type_node, cname);
10932 : 30 : error = gfc_trans_runtime_error (true, NULL,
10933 : : "The value of the PDT LEN "
10934 : : "parameter '%s' does not "
10935 : : "agree with that in the "
10936 : : "dummy declaration",
10937 : : cname);
10938 : 30 : tmp = fold_build3_loc (input_location, COND_EXPR,
10939 : : void_type_node, cond, error,
10940 : : build_empty_stmt (input_location));
10941 : 30 : gfc_add_expr_to_block (&fnblock, tmp);
10942 : : }
10943 : : }
10944 : 48 : break;
10945 : :
10946 : 0 : default:
10947 : 0 : gcc_unreachable ();
10948 : 3765 : break;
10949 : : }
10950 : : }
10951 : 12991 : seen_derived_types.remove (der_type);
10952 : :
10953 : 12991 : return gfc_finish_block (&fnblock);
10954 : : }
10955 : :
10956 : : /* Recursively traverse an object of derived type, generating code to
10957 : : nullify allocatable components. */
10958 : :
10959 : : tree
10960 : 2182 : gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
10961 : : int caf_mode)
10962 : : {
10963 : 2182 : return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
10964 : : NULLIFY_ALLOC_COMP,
10965 : : GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode,
10966 : 2182 : NULL);
10967 : : }
10968 : :
10969 : :
10970 : : /* Recursively traverse an object of derived type, generating code to
10971 : : deallocate allocatable components. */
10972 : :
10973 : : tree
10974 : 2435 : gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
10975 : : int caf_mode)
10976 : : {
10977 : 2435 : return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
10978 : : DEALLOCATE_ALLOC_COMP,
10979 : : GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode,
10980 : 2435 : NULL);
10981 : : }
10982 : :
10983 : : tree
10984 : 1 : gfc_bcast_alloc_comp (gfc_symbol *derived, gfc_expr *expr, int rank,
10985 : : tree image_index, tree stat, tree errmsg,
10986 : : tree errmsg_len)
10987 : : {
10988 : 1 : tree tmp, array;
10989 : 1 : gfc_se argse;
10990 : 1 : stmtblock_t block, post_block;
10991 : 1 : gfc_co_subroutines_args args;
10992 : :
10993 : 1 : args.image_index = image_index;
10994 : 1 : args.stat = stat;
10995 : 1 : args.errmsg = errmsg;
10996 : 1 : args.errmsg_len = errmsg_len;
10997 : :
10998 : 1 : if (rank == 0)
10999 : : {
11000 : 1 : gfc_start_block (&block);
11001 : 1 : gfc_init_block (&post_block);
11002 : 1 : gfc_init_se (&argse, NULL);
11003 : 1 : gfc_conv_expr (&argse, expr);
11004 : 1 : gfc_add_block_to_block (&block, &argse.pre);
11005 : 1 : gfc_add_block_to_block (&post_block, &argse.post);
11006 : 1 : array = argse.expr;
11007 : : }
11008 : : else
11009 : : {
11010 : 0 : gfc_init_se (&argse, NULL);
11011 : 0 : argse.want_pointer = 1;
11012 : 0 : gfc_conv_expr_descriptor (&argse, expr);
11013 : 0 : array = argse.expr;
11014 : : }
11015 : :
11016 : 1 : tmp = structure_alloc_comps (derived, array, NULL_TREE, rank,
11017 : : BCAST_ALLOC_COMP,
11018 : : GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY,
11019 : : &args);
11020 : 1 : return tmp;
11021 : : }
11022 : :
11023 : : /* Recursively traverse an object of derived type, generating code to
11024 : : deallocate allocatable components. But do not deallocate coarrays.
11025 : : To be used for intrinsic assignment, which may not change the allocation
11026 : : status of coarrays. */
11027 : :
11028 : : tree
11029 : 1757 : gfc_deallocate_alloc_comp_no_caf (gfc_symbol * der_type, tree decl, int rank,
11030 : : bool no_finalization)
11031 : : {
11032 : 1757 : return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11033 : : DEALLOCATE_ALLOC_COMP, 0, NULL,
11034 : 1757 : no_finalization);
11035 : : }
11036 : :
11037 : :
11038 : : tree
11039 : 4 : gfc_reassign_alloc_comp_caf (gfc_symbol *der_type, tree decl, tree dest)
11040 : : {
11041 : 4 : return structure_alloc_comps (der_type, decl, dest, 0, REASSIGN_CAF_COMP,
11042 : : GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY,
11043 : 4 : NULL);
11044 : : }
11045 : :
11046 : :
11047 : : /* Recursively traverse an object of derived type, generating code to
11048 : : copy it and its allocatable components. */
11049 : :
11050 : : tree
11051 : 3373 : gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank,
11052 : : int caf_mode)
11053 : : {
11054 : 3373 : return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP,
11055 : 3373 : caf_mode, NULL);
11056 : : }
11057 : :
11058 : :
11059 : : /* Recursively traverse an object of derived type, generating code to
11060 : : copy it and its allocatable components, while suppressing any
11061 : : finalization that might occur. This is used in the finalization of
11062 : : function results. */
11063 : :
11064 : : tree
11065 : 37 : gfc_copy_alloc_comp_no_fini (gfc_symbol * der_type, tree decl, tree dest,
11066 : : int rank, int caf_mode)
11067 : : {
11068 : 37 : return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP,
11069 : 37 : caf_mode, NULL, true);
11070 : : }
11071 : :
11072 : :
11073 : : /* Recursively traverse an object of derived type, generating code to
11074 : : copy only its allocatable components. */
11075 : :
11076 : : tree
11077 : 0 : gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
11078 : : {
11079 : 0 : return structure_alloc_comps (der_type, decl, dest, rank,
11080 : 0 : COPY_ONLY_ALLOC_COMP, 0, NULL);
11081 : : }
11082 : :
11083 : :
11084 : : /* Recursively traverse an object of parameterized derived type, generating
11085 : : code to allocate parameterized components. */
11086 : :
11087 : : tree
11088 : 280 : gfc_allocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank,
11089 : : gfc_actual_arglist *param_list)
11090 : : {
11091 : 280 : tree res;
11092 : 280 : gfc_actual_arglist *old_param_list = pdt_param_list;
11093 : 280 : pdt_param_list = param_list;
11094 : 280 : res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11095 : : ALLOCATE_PDT_COMP, 0, NULL);
11096 : 280 : pdt_param_list = old_param_list;
11097 : 280 : return res;
11098 : : }
11099 : :
11100 : : /* Recursively traverse an object of parameterized derived type, generating
11101 : : code to deallocate parameterized components. */
11102 : :
11103 : : tree
11104 : 267 : gfc_deallocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank)
11105 : : {
11106 : 267 : return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11107 : 267 : DEALLOCATE_PDT_COMP, 0, NULL);
11108 : : }
11109 : :
11110 : :
11111 : : /* Recursively traverse a dummy of parameterized derived type to check the
11112 : : values of LEN parameters. */
11113 : :
11114 : : tree
11115 : 48 : gfc_check_pdt_dummy (gfc_symbol * der_type, tree decl, int rank,
11116 : : gfc_actual_arglist *param_list)
11117 : : {
11118 : 48 : tree res;
11119 : 48 : gfc_actual_arglist *old_param_list = pdt_param_list;
11120 : 48 : pdt_param_list = param_list;
11121 : 48 : res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11122 : : CHECK_PDT_DUMMY, 0, NULL);
11123 : 48 : pdt_param_list = old_param_list;
11124 : 48 : return res;
11125 : : }
11126 : :
11127 : :
11128 : : /* Returns the value of LBOUND for an expression. This could be broken out
11129 : : from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
11130 : : called by gfc_alloc_allocatable_for_assignment. */
11131 : : static tree
11132 : 944 : get_std_lbound (gfc_expr *expr, tree desc, int dim, bool assumed_size)
11133 : : {
11134 : 944 : tree lbound;
11135 : 944 : tree ubound;
11136 : 944 : tree stride;
11137 : 944 : tree cond, cond1, cond3, cond4;
11138 : 944 : tree tmp;
11139 : 944 : gfc_ref *ref;
11140 : :
11141 : 944 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
11142 : : {
11143 : 461 : tmp = gfc_rank_cst[dim];
11144 : 461 : lbound = gfc_conv_descriptor_lbound_get (desc, tmp);
11145 : 461 : ubound = gfc_conv_descriptor_ubound_get (desc, tmp);
11146 : 461 : stride = gfc_conv_descriptor_stride_get (desc, tmp);
11147 : 461 : cond1 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
11148 : : ubound, lbound);
11149 : 461 : cond3 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
11150 : : stride, gfc_index_zero_node);
11151 : 461 : cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
11152 : : logical_type_node, cond3, cond1);
11153 : 461 : cond4 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
11154 : : stride, gfc_index_zero_node);
11155 : 461 : if (assumed_size)
11156 : 0 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
11157 : 0 : tmp, build_int_cst (gfc_array_index_type,
11158 : 0 : expr->rank - 1));
11159 : : else
11160 : 461 : cond = logical_false_node;
11161 : :
11162 : 461 : cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
11163 : : logical_type_node, cond3, cond4);
11164 : 461 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
11165 : : logical_type_node, cond, cond1);
11166 : :
11167 : 461 : return fold_build3_loc (input_location, COND_EXPR,
11168 : : gfc_array_index_type, cond,
11169 : 461 : lbound, gfc_index_one_node);
11170 : : }
11171 : :
11172 : 483 : if (expr->expr_type == EXPR_FUNCTION)
11173 : : {
11174 : : /* A conversion function, so use the argument. */
11175 : 7 : gcc_assert (expr->value.function.isym
11176 : : && expr->value.function.isym->conversion);
11177 : 7 : expr = expr->value.function.actual->expr;
11178 : : }
11179 : :
11180 : 483 : if (expr->expr_type == EXPR_VARIABLE)
11181 : : {
11182 : 483 : tmp = TREE_TYPE (expr->symtree->n.sym->backend_decl);
11183 : 1278 : for (ref = expr->ref; ref; ref = ref->next)
11184 : : {
11185 : 795 : if (ref->type == REF_COMPONENT
11186 : 263 : && ref->u.c.component->as
11187 : 214 : && ref->next
11188 : 214 : && ref->next->u.ar.type == AR_FULL)
11189 : 172 : tmp = TREE_TYPE (ref->u.c.component->backend_decl);
11190 : : }
11191 : 483 : return GFC_TYPE_ARRAY_LBOUND(tmp, dim);
11192 : : }
11193 : :
11194 : 0 : return gfc_index_one_node;
11195 : : }
11196 : :
11197 : :
11198 : : /* Returns true if an expression represents an lhs that can be reallocated
11199 : : on assignment. */
11200 : :
11201 : : bool
11202 : 622958 : gfc_is_reallocatable_lhs (gfc_expr *expr)
11203 : : {
11204 : 622958 : gfc_ref * ref;
11205 : 622958 : gfc_symbol *sym;
11206 : :
11207 : 622958 : if (!expr->ref)
11208 : : return false;
11209 : :
11210 : 193912 : sym = expr->symtree->n.sym;
11211 : :
11212 : 193912 : if (sym->attr.associate_var && !expr->ref)
11213 : : return false;
11214 : :
11215 : : /* An allocatable class variable with no reference. */
11216 : 193912 : if (sym->ts.type == BT_CLASS
11217 : 7649 : && (!sym->attr.associate_var || sym->attr.select_rank_temporary)
11218 : 7481 : && CLASS_DATA (sym)->attr.allocatable
11219 : : && expr->ref
11220 : 4831 : && ((expr->ref->type == REF_ARRAY && expr->ref->u.ar.type == AR_FULL
11221 : 0 : && expr->ref->next == NULL)
11222 : 4831 : || (expr->ref->type == REF_COMPONENT
11223 : 4831 : && strcmp (expr->ref->u.c.component->name, "_data") == 0
11224 : 4029 : && (expr->ref->next == NULL
11225 : 3250 : || (expr->ref->next->type == REF_ARRAY
11226 : 3250 : && expr->ref->next->u.ar.type == AR_FULL
11227 : 2676 : && expr->ref->next->next == NULL)))))
11228 : : return true;
11229 : :
11230 : : /* An allocatable variable. */
11231 : 190652 : if (sym->attr.allocatable
11232 : 42001 : && (!sym->attr.associate_var || sym->attr.select_rank_temporary)
11233 : : && expr->ref
11234 : 42001 : && expr->ref->type == REF_ARRAY
11235 : 40437 : && expr->ref->u.ar.type == AR_FULL)
11236 : : return true;
11237 : :
11238 : : /* All that can be left are allocatable components. */
11239 : 165654 : if (sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
11240 : : return false;
11241 : :
11242 : : /* Find a component ref followed by an array reference. */
11243 : 82365 : for (ref = expr->ref; ref; ref = ref->next)
11244 : 57087 : if (ref->next
11245 : 31809 : && ref->type == REF_COMPONENT
11246 : 18901 : && ref->next->type == REF_ARRAY
11247 : 14337 : && !ref->next->next)
11248 : : break;
11249 : :
11250 : 36557 : if (!ref)
11251 : : return false;
11252 : :
11253 : : /* Return true if valid reallocatable lhs. */
11254 : 11279 : if (ref->u.c.component->attr.allocatable
11255 : 5075 : && ref->next->u.ar.type == AR_FULL)
11256 : 3633 : return true;
11257 : :
11258 : : return false;
11259 : : }
11260 : :
11261 : :
11262 : : static tree
11263 : 56 : concat_str_length (gfc_expr* expr)
11264 : : {
11265 : 56 : tree type;
11266 : 56 : tree len1;
11267 : 56 : tree len2;
11268 : 56 : gfc_se se;
11269 : :
11270 : 56 : type = gfc_typenode_for_spec (&expr->value.op.op1->ts);
11271 : 56 : len1 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
11272 : 56 : if (len1 == NULL_TREE)
11273 : : {
11274 : 56 : if (expr->value.op.op1->expr_type == EXPR_OP)
11275 : 31 : len1 = concat_str_length (expr->value.op.op1);
11276 : 25 : else if (expr->value.op.op1->expr_type == EXPR_CONSTANT)
11277 : 25 : len1 = build_int_cst (gfc_charlen_type_node,
11278 : 25 : expr->value.op.op1->value.character.length);
11279 : 0 : else if (expr->value.op.op1->ts.u.cl->length)
11280 : : {
11281 : 0 : gfc_init_se (&se, NULL);
11282 : 0 : gfc_conv_expr (&se, expr->value.op.op1->ts.u.cl->length);
11283 : 0 : len1 = se.expr;
11284 : : }
11285 : : else
11286 : : {
11287 : : /* Last resort! */
11288 : 0 : gfc_init_se (&se, NULL);
11289 : 0 : se.want_pointer = 1;
11290 : 0 : se.descriptor_only = 1;
11291 : 0 : gfc_conv_expr (&se, expr->value.op.op1);
11292 : 0 : len1 = se.string_length;
11293 : : }
11294 : : }
11295 : :
11296 : 56 : type = gfc_typenode_for_spec (&expr->value.op.op2->ts);
11297 : 56 : len2 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
11298 : 56 : if (len2 == NULL_TREE)
11299 : : {
11300 : 31 : if (expr->value.op.op2->expr_type == EXPR_OP)
11301 : 0 : len2 = concat_str_length (expr->value.op.op2);
11302 : 31 : else if (expr->value.op.op2->expr_type == EXPR_CONSTANT)
11303 : 25 : len2 = build_int_cst (gfc_charlen_type_node,
11304 : 25 : expr->value.op.op2->value.character.length);
11305 : 6 : else if (expr->value.op.op2->ts.u.cl->length)
11306 : : {
11307 : 6 : gfc_init_se (&se, NULL);
11308 : 6 : gfc_conv_expr (&se, expr->value.op.op2->ts.u.cl->length);
11309 : 6 : len2 = se.expr;
11310 : : }
11311 : : else
11312 : : {
11313 : : /* Last resort! */
11314 : 0 : gfc_init_se (&se, NULL);
11315 : 0 : se.want_pointer = 1;
11316 : 0 : se.descriptor_only = 1;
11317 : 0 : gfc_conv_expr (&se, expr->value.op.op2);
11318 : 0 : len2 = se.string_length;
11319 : : }
11320 : : }
11321 : :
11322 : 56 : gcc_assert(len1 && len2);
11323 : 56 : len1 = fold_convert (gfc_charlen_type_node, len1);
11324 : 56 : len2 = fold_convert (gfc_charlen_type_node, len2);
11325 : :
11326 : 56 : return fold_build2_loc (input_location, PLUS_EXPR,
11327 : 56 : gfc_charlen_type_node, len1, len2);
11328 : : }
11329 : :
11330 : :
11331 : : /* Allocate the lhs of an assignment to an allocatable array, otherwise
11332 : : reallocate it. */
11333 : :
11334 : : tree
11335 : 5731 : gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
11336 : : gfc_expr *expr1,
11337 : : gfc_expr *expr2)
11338 : : {
11339 : 5731 : stmtblock_t realloc_block;
11340 : 5731 : stmtblock_t alloc_block;
11341 : 5731 : stmtblock_t fblock;
11342 : 5731 : stmtblock_t loop_pre_block;
11343 : 5731 : gfc_ref *ref;
11344 : 5731 : gfc_ss *rss;
11345 : 5731 : gfc_ss *lss;
11346 : 5731 : gfc_array_info *linfo;
11347 : 5731 : tree realloc_expr;
11348 : 5731 : tree alloc_expr;
11349 : 5731 : tree size1;
11350 : 5731 : tree size2;
11351 : 5731 : tree elemsize1;
11352 : 5731 : tree elemsize2;
11353 : 5731 : tree array1;
11354 : 5731 : tree cond_null;
11355 : 5731 : tree cond;
11356 : 5731 : tree tmp;
11357 : 5731 : tree tmp2;
11358 : 5731 : tree lbound;
11359 : 5731 : tree ubound;
11360 : 5731 : tree desc;
11361 : 5731 : tree old_desc;
11362 : 5731 : tree desc2;
11363 : 5731 : tree offset;
11364 : 5731 : tree jump_label1;
11365 : 5731 : tree jump_label2;
11366 : 5731 : tree lbd;
11367 : 5731 : tree class_expr2 = NULL_TREE;
11368 : 5731 : int n;
11369 : 5731 : int dim;
11370 : 5731 : gfc_array_spec * as;
11371 : 5731 : bool coarray = (flag_coarray == GFC_FCOARRAY_LIB
11372 : 5731 : && gfc_caf_attr (expr1, true).codimension);
11373 : 5731 : tree token;
11374 : 5731 : gfc_se caf_se;
11375 : :
11376 : : /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
11377 : : Find the lhs expression in the loop chain and set expr1 and
11378 : : expr2 accordingly. */
11379 : 5731 : if (expr1->expr_type == EXPR_FUNCTION && expr2 == NULL)
11380 : : {
11381 : 160 : expr2 = expr1;
11382 : : /* Find the ss for the lhs. */
11383 : 160 : lss = loop->ss;
11384 : 320 : for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
11385 : 320 : if (lss->info->expr && lss->info->expr->expr_type == EXPR_VARIABLE)
11386 : : break;
11387 : 160 : if (lss == gfc_ss_terminator)
11388 : : return NULL_TREE;
11389 : 160 : expr1 = lss->info->expr;
11390 : : }
11391 : :
11392 : : /* Bail out if this is not a valid allocate on assignment. */
11393 : 5731 : if (!gfc_is_reallocatable_lhs (expr1)
11394 : 5731 : || (expr2 && !expr2->rank))
11395 : : return NULL_TREE;
11396 : :
11397 : : /* Find the ss for the lhs. */
11398 : 5731 : lss = loop->ss;
11399 : 14577 : for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
11400 : 14577 : if (lss->info->expr == expr1)
11401 : : break;
11402 : :
11403 : 5731 : if (lss == gfc_ss_terminator)
11404 : : return NULL_TREE;
11405 : :
11406 : 5731 : linfo = &lss->info->data.array;
11407 : :
11408 : : /* Find an ss for the rhs. For operator expressions, we see the
11409 : : ss's for the operands. Any one of these will do. */
11410 : 5731 : rss = loop->ss;
11411 : 6207 : for (; rss && rss != gfc_ss_terminator; rss = rss->loop_chain)
11412 : 6207 : if (rss->info->expr != expr1 && rss != loop->temp_ss)
11413 : : break;
11414 : :
11415 : 5731 : if (expr2 && rss == gfc_ss_terminator)
11416 : : return NULL_TREE;
11417 : :
11418 : : /* Ensure that the string length from the current scope is used. */
11419 : 5731 : if (expr2->ts.type == BT_CHARACTER
11420 : 877 : && expr2->expr_type == EXPR_FUNCTION
11421 : 130 : && !expr2->value.function.isym)
11422 : 21 : expr2->ts.u.cl->backend_decl = rss->info->string_length;
11423 : :
11424 : 5731 : gfc_start_block (&fblock);
11425 : :
11426 : : /* Since the lhs is allocatable, this must be a descriptor type.
11427 : : Get the data and array size. */
11428 : 5731 : desc = linfo->descriptor;
11429 : 5731 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
11430 : 5731 : array1 = gfc_conv_descriptor_data_get (desc);
11431 : :
11432 : 5731 : if (expr2)
11433 : 5731 : desc2 = rss->info->data.array.descriptor;
11434 : : else
11435 : : desc2 = NULL_TREE;
11436 : :
11437 : : /* Get the old lhs element size for deferred character and class expr1. */
11438 : 5731 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
11439 : : {
11440 : 577 : if (expr1->ts.u.cl->backend_decl
11441 : 577 : && VAR_P (expr1->ts.u.cl->backend_decl))
11442 : : elemsize1 = expr1->ts.u.cl->backend_decl;
11443 : : else
11444 : 63 : elemsize1 = lss->info->string_length;
11445 : 577 : tree unit_size = TYPE_SIZE_UNIT (gfc_get_char_type (expr1->ts.kind));
11446 : 1154 : elemsize1 = fold_build2_loc (input_location, MULT_EXPR,
11447 : 577 : TREE_TYPE (elemsize1), elemsize1,
11448 : 577 : fold_convert (TREE_TYPE (elemsize1), unit_size));
11449 : :
11450 : 577 : }
11451 : 5154 : else if (expr1->ts.type == BT_CLASS)
11452 : : {
11453 : : /* Unfortunately, the lhs vptr is set too early in many cases.
11454 : : Play it safe by using the descriptor element length. */
11455 : 549 : tmp = gfc_conv_descriptor_elem_len (desc);
11456 : 549 : elemsize1 = fold_convert (gfc_array_index_type, tmp);
11457 : : }
11458 : : else
11459 : : elemsize1 = NULL_TREE;
11460 : 1126 : if (elemsize1 != NULL_TREE)
11461 : 1126 : elemsize1 = gfc_evaluate_now (elemsize1, &fblock);
11462 : :
11463 : : /* Get the new lhs size in bytes. */
11464 : 5731 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
11465 : : {
11466 : 577 : if (expr2->ts.deferred)
11467 : : {
11468 : 183 : if (expr2->ts.u.cl->backend_decl
11469 : 183 : && VAR_P (expr2->ts.u.cl->backend_decl))
11470 : : tmp = expr2->ts.u.cl->backend_decl;
11471 : : else
11472 : 0 : tmp = rss->info->string_length;
11473 : : }
11474 : : else
11475 : : {
11476 : 394 : tmp = expr2->ts.u.cl->backend_decl;
11477 : 394 : if (!tmp && expr2->expr_type == EXPR_OP
11478 : 25 : && expr2->value.op.op == INTRINSIC_CONCAT)
11479 : : {
11480 : 25 : tmp = concat_str_length (expr2);
11481 : 25 : expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
11482 : : }
11483 : 12 : else if (!tmp && expr2->ts.u.cl->length)
11484 : : {
11485 : 12 : gfc_se tmpse;
11486 : 12 : gfc_init_se (&tmpse, NULL);
11487 : 12 : gfc_conv_expr_type (&tmpse, expr2->ts.u.cl->length,
11488 : : gfc_charlen_type_node);
11489 : 12 : tmp = tmpse.expr;
11490 : 12 : expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
11491 : : }
11492 : 394 : tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
11493 : : }
11494 : :
11495 : 577 : if (expr1->ts.u.cl->backend_decl
11496 : 577 : && VAR_P (expr1->ts.u.cl->backend_decl))
11497 : 514 : gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
11498 : : else
11499 : 63 : gfc_add_modify (&fblock, lss->info->string_length, tmp);
11500 : :
11501 : 577 : if (expr1->ts.kind > 1)
11502 : 12 : tmp = fold_build2_loc (input_location, MULT_EXPR,
11503 : 6 : TREE_TYPE (tmp),
11504 : 6 : tmp, build_int_cst (TREE_TYPE (tmp),
11505 : 6 : expr1->ts.kind));
11506 : : }
11507 : 5154 : else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
11508 : : {
11509 : 251 : tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts)));
11510 : 251 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
11511 : : fold_convert (gfc_array_index_type, tmp),
11512 : 251 : expr1->ts.u.cl->backend_decl);
11513 : : }
11514 : 4903 : else if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS)
11515 : 110 : tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
11516 : 4793 : else if (expr1->ts.type == BT_CLASS && expr2->ts.type == BT_CLASS)
11517 : : {
11518 : 268 : tmp = expr2->rank ? gfc_get_class_from_expr (desc2) : NULL_TREE;
11519 : 268 : if (tmp == NULL_TREE && expr2->expr_type == EXPR_VARIABLE)
11520 : 24 : tmp = class_expr2 = gfc_get_class_from_gfc_expr (expr2);
11521 : :
11522 : 31 : if (tmp != NULL_TREE)
11523 : 261 : tmp = gfc_class_vtab_size_get (tmp);
11524 : : else
11525 : 7 : tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&CLASS_DATA (expr2)->ts));
11526 : : }
11527 : : else
11528 : 4525 : tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
11529 : 5731 : elemsize2 = fold_convert (gfc_array_index_type, tmp);
11530 : 5731 : elemsize2 = gfc_evaluate_now (elemsize2, &fblock);
11531 : :
11532 : : /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
11533 : : deallocated if expr is an array of different shape or any of the
11534 : : corresponding length type parameter values of variable and expr
11535 : : differ." This assures F95 compatibility. */
11536 : 5731 : jump_label1 = gfc_build_label_decl (NULL_TREE);
11537 : 5731 : jump_label2 = gfc_build_label_decl (NULL_TREE);
11538 : :
11539 : : /* Allocate if data is NULL. */
11540 : 5731 : cond_null = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
11541 : 5731 : array1, build_int_cst (TREE_TYPE (array1), 0));
11542 : 5731 : cond_null= gfc_evaluate_now (cond_null, &fblock);
11543 : :
11544 : : /* If the data is null, set the descriptor bounds and offset. This suppresses
11545 : : the maybe used uninitialized warning and forces the use of malloc because
11546 : : the size is zero in all dimensions. Note that this block is only executed
11547 : : if the lhs is unallocated and is only applied once in any namespace.
11548 : : Component references are not subject to the warnings. */
11549 : 10454 : for (ref = expr1->ref; ref; ref = ref->next)
11550 : 5926 : if (ref->type == REF_COMPONENT)
11551 : : break;
11552 : :
11553 : 5731 : if (!expr1->symtree->n.sym->allocated_in_scope && !ref)
11554 : : {
11555 : 2378 : gfc_start_block (&loop_pre_block);
11556 : 8153 : for (n = 0; n < expr1->rank; n++)
11557 : : {
11558 : 3397 : gfc_conv_descriptor_lbound_set (&loop_pre_block, desc,
11559 : : gfc_rank_cst[n],
11560 : : gfc_index_one_node);
11561 : 3397 : gfc_conv_descriptor_ubound_set (&loop_pre_block, desc,
11562 : : gfc_rank_cst[n],
11563 : : gfc_index_zero_node);
11564 : 3397 : gfc_conv_descriptor_stride_set (&loop_pre_block, desc,
11565 : : gfc_rank_cst[n],
11566 : : gfc_index_zero_node);
11567 : : }
11568 : :
11569 : 2378 : tmp = gfc_conv_descriptor_offset (desc);
11570 : 2378 : gfc_add_modify (&loop_pre_block, tmp, gfc_index_zero_node);
11571 : :
11572 : 2378 : tmp = fold_build2_loc (input_location, EQ_EXPR,
11573 : : logical_type_node, array1,
11574 : 2378 : build_int_cst (TREE_TYPE (array1), 0));
11575 : 2378 : tmp = build3_v (COND_EXPR, tmp,
11576 : : gfc_finish_block (&loop_pre_block),
11577 : : build_empty_stmt (input_location));
11578 : 2378 : gfc_prepend_expr_to_block (&loop->pre, tmp);
11579 : :
11580 : 2378 : expr1->symtree->n.sym->allocated_in_scope = 1;
11581 : : }
11582 : :
11583 : 5731 : tmp = build3_v (COND_EXPR, cond_null,
11584 : : build1_v (GOTO_EXPR, jump_label1),
11585 : : build_empty_stmt (input_location));
11586 : 5731 : gfc_add_expr_to_block (&fblock, tmp);
11587 : :
11588 : : /* Get arrayspec if expr is a full array. */
11589 : 5731 : if (expr2 && expr2->expr_type == EXPR_FUNCTION
11590 : 2694 : && expr2->value.function.isym
11591 : 2254 : && expr2->value.function.isym->conversion)
11592 : : {
11593 : : /* For conversion functions, take the arg. */
11594 : 243 : gfc_expr *arg = expr2->value.function.actual->expr;
11595 : 243 : as = gfc_get_full_arrayspec_from_expr (arg);
11596 : 243 : }
11597 : : else if (expr2)
11598 : 5488 : as = gfc_get_full_arrayspec_from_expr (expr2);
11599 : : else
11600 : : as = NULL;
11601 : :
11602 : : /* If the lhs shape is not the same as the rhs jump to setting the
11603 : : bounds and doing the reallocation....... */
11604 : 14499 : for (n = 0; n < expr1->rank; n++)
11605 : : {
11606 : : /* Check the shape. */
11607 : 8768 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
11608 : 8768 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
11609 : 8768 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
11610 : : gfc_array_index_type,
11611 : : loop->to[n], loop->from[n]);
11612 : 8768 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
11613 : : gfc_array_index_type,
11614 : : tmp, lbound);
11615 : 8768 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
11616 : : gfc_array_index_type,
11617 : : tmp, ubound);
11618 : 8768 : cond = fold_build2_loc (input_location, NE_EXPR,
11619 : : logical_type_node,
11620 : : tmp, gfc_index_zero_node);
11621 : 8768 : tmp = build3_v (COND_EXPR, cond,
11622 : : build1_v (GOTO_EXPR, jump_label1),
11623 : : build_empty_stmt (input_location));
11624 : 8768 : gfc_add_expr_to_block (&fblock, tmp);
11625 : : }
11626 : :
11627 : : /* ...else if the element lengths are not the same also go to
11628 : : setting the bounds and doing the reallocation.... */
11629 : 5731 : if (elemsize1 != NULL_TREE)
11630 : : {
11631 : 1126 : cond = fold_build2_loc (input_location, NE_EXPR,
11632 : : logical_type_node,
11633 : : elemsize1, elemsize2);
11634 : 1126 : tmp = build3_v (COND_EXPR, cond,
11635 : : build1_v (GOTO_EXPR, jump_label1),
11636 : : build_empty_stmt (input_location));
11637 : 1126 : gfc_add_expr_to_block (&fblock, tmp);
11638 : : }
11639 : :
11640 : : /* ....else jump past the (re)alloc code. */
11641 : 5731 : tmp = build1_v (GOTO_EXPR, jump_label2);
11642 : 5731 : gfc_add_expr_to_block (&fblock, tmp);
11643 : :
11644 : : /* Add the label to start automatic (re)allocation. */
11645 : 5731 : tmp = build1_v (LABEL_EXPR, jump_label1);
11646 : 5731 : gfc_add_expr_to_block (&fblock, tmp);
11647 : :
11648 : : /* Get the rhs size and fix it. */
11649 : 5731 : size2 = gfc_index_one_node;
11650 : 14499 : for (n = 0; n < expr2->rank; n++)
11651 : : {
11652 : 8768 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
11653 : : gfc_array_index_type,
11654 : : loop->to[n], loop->from[n]);
11655 : 8768 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
11656 : : gfc_array_index_type,
11657 : : tmp, gfc_index_one_node);
11658 : 8768 : size2 = fold_build2_loc (input_location, MULT_EXPR,
11659 : : gfc_array_index_type,
11660 : : tmp, size2);
11661 : : }
11662 : 5731 : size2 = gfc_evaluate_now (size2, &fblock);
11663 : :
11664 : : /* Deallocation of allocatable components will have to occur on
11665 : : reallocation. Fix the old descriptor now. */
11666 : 5731 : if ((expr1->ts.type == BT_DERIVED)
11667 : 260 : && expr1->ts.u.derived->attr.alloc_comp)
11668 : 87 : old_desc = gfc_evaluate_now (desc, &fblock);
11669 : : else
11670 : : old_desc = NULL_TREE;
11671 : :
11672 : : /* Now modify the lhs descriptor and the associated scalarizer
11673 : : variables. F2003 7.4.1.3: "If variable is or becomes an
11674 : : unallocated allocatable variable, then it is allocated with each
11675 : : deferred type parameter equal to the corresponding type parameters
11676 : : of expr , with the shape of expr , and with each lower bound equal
11677 : : to the corresponding element of LBOUND(expr)."
11678 : : Reuse size1 to keep a dimension-by-dimension track of the
11679 : : stride of the new array. */
11680 : 5731 : size1 = gfc_index_one_node;
11681 : 5731 : offset = gfc_index_zero_node;
11682 : :
11683 : 14499 : for (n = 0; n < expr2->rank; n++)
11684 : : {
11685 : 8768 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
11686 : : gfc_array_index_type,
11687 : : loop->to[n], loop->from[n]);
11688 : 8768 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
11689 : : gfc_array_index_type,
11690 : : tmp, gfc_index_one_node);
11691 : :
11692 : 8768 : lbound = gfc_index_one_node;
11693 : 8768 : ubound = tmp;
11694 : :
11695 : 8768 : if (as)
11696 : : {
11697 : 1888 : lbd = get_std_lbound (expr2, desc2, n,
11698 : 944 : as->type == AS_ASSUMED_SIZE);
11699 : 944 : ubound = fold_build2_loc (input_location,
11700 : : MINUS_EXPR,
11701 : : gfc_array_index_type,
11702 : : ubound, lbound);
11703 : 944 : ubound = fold_build2_loc (input_location,
11704 : : PLUS_EXPR,
11705 : : gfc_array_index_type,
11706 : : ubound, lbd);
11707 : 944 : lbound = lbd;
11708 : : }
11709 : :
11710 : 8768 : gfc_conv_descriptor_lbound_set (&fblock, desc,
11711 : : gfc_rank_cst[n],
11712 : : lbound);
11713 : 8768 : gfc_conv_descriptor_ubound_set (&fblock, desc,
11714 : : gfc_rank_cst[n],
11715 : : ubound);
11716 : 8768 : gfc_conv_descriptor_stride_set (&fblock, desc,
11717 : : gfc_rank_cst[n],
11718 : : size1);
11719 : 8768 : lbound = gfc_conv_descriptor_lbound_get (desc,
11720 : : gfc_rank_cst[n]);
11721 : 8768 : tmp2 = fold_build2_loc (input_location, MULT_EXPR,
11722 : : gfc_array_index_type,
11723 : : lbound, size1);
11724 : 8768 : offset = fold_build2_loc (input_location, MINUS_EXPR,
11725 : : gfc_array_index_type,
11726 : : offset, tmp2);
11727 : 8768 : size1 = fold_build2_loc (input_location, MULT_EXPR,
11728 : : gfc_array_index_type,
11729 : : tmp, size1);
11730 : : }
11731 : :
11732 : : /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
11733 : : the array offset is saved and the info.offset is used for a
11734 : : running offset. Use the saved_offset instead. */
11735 : 5731 : tmp = gfc_conv_descriptor_offset (desc);
11736 : 5731 : gfc_add_modify (&fblock, tmp, offset);
11737 : 5731 : if (linfo->saved_offset
11738 : 5731 : && VAR_P (linfo->saved_offset))
11739 : 5731 : gfc_add_modify (&fblock, linfo->saved_offset, tmp);
11740 : :
11741 : : /* Now set the deltas for the lhs. */
11742 : 14499 : for (n = 0; n < expr1->rank; n++)
11743 : : {
11744 : 8768 : tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
11745 : 8768 : dim = lss->dim[n];
11746 : 8768 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
11747 : : gfc_array_index_type, tmp,
11748 : : loop->from[dim]);
11749 : 8768 : if (linfo->delta[dim] && VAR_P (linfo->delta[dim]))
11750 : 8430 : gfc_add_modify (&fblock, linfo->delta[dim], tmp);
11751 : : }
11752 : :
11753 : : /* Take into account _len of unlimited polymorphic entities, so that span
11754 : : for array descriptors and allocation sizes are computed correctly. */
11755 : 5731 : if (UNLIMITED_POLY (expr2))
11756 : : {
11757 : 92 : tree len = gfc_class_len_get (TREE_OPERAND (desc2, 0));
11758 : 92 : len = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
11759 : : fold_convert (size_type_node, len),
11760 : : size_one_node);
11761 : 92 : elemsize2 = fold_build2_loc (input_location, MULT_EXPR,
11762 : : gfc_array_index_type, elemsize2,
11763 : : fold_convert (gfc_array_index_type, len));
11764 : : }
11765 : :
11766 : 5731 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
11767 : 5731 : gfc_conv_descriptor_span_set (&fblock, desc, elemsize2);
11768 : :
11769 : 5731 : size2 = fold_build2_loc (input_location, MULT_EXPR,
11770 : : gfc_array_index_type,
11771 : : elemsize2, size2);
11772 : 5731 : size2 = fold_convert (size_type_node, size2);
11773 : 5731 : size2 = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
11774 : : size2, size_one_node);
11775 : 5731 : size2 = gfc_evaluate_now (size2, &fblock);
11776 : :
11777 : : /* For deferred character length, the 'size' field of the dtype might
11778 : : have changed so set the dtype. */
11779 : 5731 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
11780 : 5731 : && expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
11781 : : {
11782 : 577 : tree type;
11783 : 577 : tmp = gfc_conv_descriptor_dtype (desc);
11784 : 577 : if (expr2->ts.u.cl->backend_decl)
11785 : 577 : type = gfc_typenode_for_spec (&expr2->ts);
11786 : : else
11787 : 0 : type = gfc_typenode_for_spec (&expr1->ts);
11788 : :
11789 : 577 : gfc_add_modify (&fblock, tmp,
11790 : : gfc_get_dtype_rank_type (expr1->rank,type));
11791 : : }
11792 : 5154 : else if (expr1->ts.type == BT_CLASS)
11793 : : {
11794 : 549 : tree type;
11795 : 549 : tmp = gfc_conv_descriptor_dtype (desc);
11796 : :
11797 : 549 : if (expr2->ts.type != BT_CLASS)
11798 : 281 : type = gfc_typenode_for_spec (&expr2->ts);
11799 : : else
11800 : 268 : type = gfc_get_character_type_len (1, elemsize2);
11801 : :
11802 : 549 : gfc_add_modify (&fblock, tmp,
11803 : : gfc_get_dtype_rank_type (expr2->rank,type));
11804 : : /* Set the _len field as well... */
11805 : 549 : if (UNLIMITED_POLY (expr1))
11806 : : {
11807 : 202 : tmp = gfc_class_len_get (TREE_OPERAND (desc, 0));
11808 : 202 : if (expr2->ts.type == BT_CHARACTER)
11809 : 49 : gfc_add_modify (&fblock, tmp,
11810 : 49 : fold_convert (TREE_TYPE (tmp),
11811 : : TYPE_SIZE_UNIT (type)));
11812 : 153 : else if (UNLIMITED_POLY (expr2))
11813 : 92 : gfc_add_modify (&fblock, tmp,
11814 : 92 : gfc_class_len_get (TREE_OPERAND (desc2, 0)));
11815 : : else
11816 : 61 : gfc_add_modify (&fblock, tmp,
11817 : 61 : build_int_cst (TREE_TYPE (tmp), 0));
11818 : : }
11819 : : /* ...and the vptr. */
11820 : 549 : tmp = gfc_class_vptr_get (TREE_OPERAND (desc, 0));
11821 : 549 : if (expr2->ts.type == BT_CLASS && !VAR_P (desc2)
11822 : 261 : && TREE_CODE (desc2) == COMPONENT_REF)
11823 : : {
11824 : 237 : tmp2 = gfc_get_class_from_expr (desc2);
11825 : 237 : tmp2 = gfc_class_vptr_get (tmp2);
11826 : : }
11827 : 312 : else if (expr2->ts.type == BT_CLASS && class_expr2 != NULL_TREE)
11828 : 24 : tmp2 = gfc_class_vptr_get (class_expr2);
11829 : : else
11830 : : {
11831 : 288 : tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts));
11832 : 288 : tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2);
11833 : : }
11834 : :
11835 : 549 : gfc_add_modify (&fblock, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
11836 : : }
11837 : 4605 : else if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
11838 : : {
11839 : 38 : gfc_add_modify (&fblock, gfc_conv_descriptor_dtype (desc),
11840 : 38 : gfc_get_dtype (TREE_TYPE (desc)));
11841 : : }
11842 : :
11843 : : /* Realloc expression. Note that the scalarizer uses desc.data
11844 : : in the array reference - (*desc.data)[<element>]. */
11845 : 5731 : gfc_init_block (&realloc_block);
11846 : 5731 : gfc_init_se (&caf_se, NULL);
11847 : :
11848 : 5731 : if (coarray)
11849 : : {
11850 : 38 : token = gfc_get_ultimate_alloc_ptr_comps_caf_token (&caf_se, expr1);
11851 : 38 : if (token == NULL_TREE)
11852 : : {
11853 : 8 : tmp = gfc_get_tree_for_caf_expr (expr1);
11854 : 8 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
11855 : 6 : tmp = build_fold_indirect_ref (tmp);
11856 : 8 : gfc_get_caf_token_offset (&caf_se, &token, NULL, tmp, NULL_TREE,
11857 : : expr1);
11858 : 8 : token = gfc_build_addr_expr (NULL_TREE, token);
11859 : : }
11860 : :
11861 : 38 : gfc_add_block_to_block (&realloc_block, &caf_se.pre);
11862 : : }
11863 : 5731 : if ((expr1->ts.type == BT_DERIVED)
11864 : 260 : && expr1->ts.u.derived->attr.alloc_comp)
11865 : : {
11866 : 87 : tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, old_desc,
11867 : : expr1->rank, true);
11868 : 87 : gfc_add_expr_to_block (&realloc_block, tmp);
11869 : : }
11870 : :
11871 : 5731 : if (!coarray)
11872 : : {
11873 : 5693 : tmp = build_call_expr_loc (input_location,
11874 : : builtin_decl_explicit (BUILT_IN_REALLOC), 2,
11875 : : fold_convert (pvoid_type_node, array1),
11876 : : size2);
11877 : 5693 : if (flag_openmp_allocators)
11878 : : {
11879 : 2 : tree cond, omp_tmp;
11880 : 2 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
11881 : : gfc_conv_descriptor_version (desc),
11882 : 2 : build_int_cst (integer_type_node, 1));
11883 : 2 : omp_tmp = builtin_decl_explicit (BUILT_IN_GOMP_REALLOC);
11884 : 2 : omp_tmp = build_call_expr_loc (input_location, omp_tmp, 4,
11885 : : fold_convert (pvoid_type_node, array1), size2,
11886 : : build_zero_cst (ptr_type_node),
11887 : : build_zero_cst (ptr_type_node));
11888 : 2 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond,
11889 : : omp_tmp, tmp);
11890 : : }
11891 : :
11892 : 5693 : gfc_conv_descriptor_data_set (&realloc_block, desc, tmp);
11893 : : }
11894 : : else
11895 : : {
11896 : 38 : tmp = build_call_expr_loc (input_location,
11897 : : gfor_fndecl_caf_deregister, 5, token,
11898 : 38 : build_int_cst (integer_type_node,
11899 : 38 : GFC_CAF_COARRAY_DEALLOCATE_ONLY),
11900 : : null_pointer_node, null_pointer_node,
11901 : : integer_zero_node);
11902 : 38 : gfc_add_expr_to_block (&realloc_block, tmp);
11903 : 76 : tmp = build_call_expr_loc (input_location,
11904 : : gfor_fndecl_caf_register,
11905 : : 7, size2,
11906 : 38 : build_int_cst (integer_type_node,
11907 : 38 : GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY),
11908 : : token, gfc_build_addr_expr (NULL_TREE, desc),
11909 : : null_pointer_node, null_pointer_node,
11910 : : integer_zero_node);
11911 : 38 : gfc_add_expr_to_block (&realloc_block, tmp);
11912 : : }
11913 : :
11914 : 5731 : if ((expr1->ts.type == BT_DERIVED)
11915 : 260 : && expr1->ts.u.derived->attr.alloc_comp)
11916 : : {
11917 : 87 : tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc,
11918 : : expr1->rank);
11919 : 87 : gfc_add_expr_to_block (&realloc_block, tmp);
11920 : : }
11921 : :
11922 : 5731 : gfc_add_block_to_block (&realloc_block, &caf_se.post);
11923 : 5731 : realloc_expr = gfc_finish_block (&realloc_block);
11924 : :
11925 : : /* Malloc expression. */
11926 : 5731 : gfc_init_block (&alloc_block);
11927 : 5731 : if (!coarray)
11928 : : {
11929 : 5693 : tmp = build_call_expr_loc (input_location,
11930 : : builtin_decl_explicit (BUILT_IN_MALLOC),
11931 : : 1, size2);
11932 : 5693 : gfc_conv_descriptor_data_set (&alloc_block,
11933 : : desc, tmp);
11934 : : }
11935 : : else
11936 : : {
11937 : 76 : tmp = build_call_expr_loc (input_location,
11938 : : gfor_fndecl_caf_register,
11939 : : 7, size2,
11940 : 38 : build_int_cst (integer_type_node,
11941 : 38 : GFC_CAF_COARRAY_ALLOC),
11942 : : token, gfc_build_addr_expr (NULL_TREE, desc),
11943 : : null_pointer_node, null_pointer_node,
11944 : : integer_zero_node);
11945 : 38 : gfc_add_expr_to_block (&alloc_block, tmp);
11946 : : }
11947 : :
11948 : :
11949 : : /* We already set the dtype in the case of deferred character
11950 : : length arrays and class lvalues. */
11951 : 5731 : if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
11952 : 5731 : && ((expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
11953 : 5154 : || coarray))
11954 : 10847 : && expr1->ts.type != BT_CLASS)
11955 : : {
11956 : 4567 : tmp = gfc_conv_descriptor_dtype (desc);
11957 : 4567 : gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
11958 : : }
11959 : :
11960 : 5731 : if ((expr1->ts.type == BT_DERIVED)
11961 : 260 : && expr1->ts.u.derived->attr.alloc_comp)
11962 : : {
11963 : 87 : tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc,
11964 : : expr1->rank);
11965 : 87 : gfc_add_expr_to_block (&alloc_block, tmp);
11966 : : }
11967 : 5731 : alloc_expr = gfc_finish_block (&alloc_block);
11968 : :
11969 : : /* Malloc if not allocated; realloc otherwise. */
11970 : 5731 : tmp = build3_v (COND_EXPR, cond_null, alloc_expr, realloc_expr);
11971 : 5731 : gfc_add_expr_to_block (&fblock, tmp);
11972 : :
11973 : : /* Make sure that the scalarizer data pointer is updated. */
11974 : 5731 : if (linfo->data && VAR_P (linfo->data))
11975 : : {
11976 : 5182 : tmp = gfc_conv_descriptor_data_get (desc);
11977 : 5182 : gfc_add_modify (&fblock, linfo->data, tmp);
11978 : : }
11979 : :
11980 : : /* Add the label for same shape lhs and rhs. */
11981 : 5731 : tmp = build1_v (LABEL_EXPR, jump_label2);
11982 : 5731 : gfc_add_expr_to_block (&fblock, tmp);
11983 : :
11984 : 5731 : return gfc_finish_block (&fblock);
11985 : : }
11986 : :
11987 : :
11988 : : /* Initialize class descriptor's TKR information. */
11989 : :
11990 : : void
11991 : 2781 : gfc_trans_class_array (gfc_symbol * sym, gfc_wrapped_block * block)
11992 : : {
11993 : 2781 : tree type, etype;
11994 : 2781 : tree tmp;
11995 : 2781 : tree descriptor;
11996 : 2781 : stmtblock_t init;
11997 : 2781 : int rank;
11998 : :
11999 : : /* Make sure the frontend gets these right. */
12000 : 2781 : gcc_assert (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
12001 : : && (CLASS_DATA (sym)->attr.class_pointer
12002 : : || CLASS_DATA (sym)->attr.allocatable));
12003 : :
12004 : 2781 : gcc_assert (VAR_P (sym->backend_decl)
12005 : : || TREE_CODE (sym->backend_decl) == PARM_DECL);
12006 : :
12007 : 2781 : if (sym->attr.dummy)
12008 : 1388 : return;
12009 : :
12010 : 2781 : descriptor = gfc_class_data_get (sym->backend_decl);
12011 : 2781 : type = TREE_TYPE (descriptor);
12012 : :
12013 : 2781 : if (type == NULL || !GFC_DESCRIPTOR_TYPE_P (type))
12014 : : return;
12015 : :
12016 : 1393 : location_t loc = input_location;
12017 : 1393 : input_location = gfc_get_location (&sym->declared_at);
12018 : 1393 : gfc_init_block (&init);
12019 : :
12020 : 1393 : rank = CLASS_DATA (sym)->as ? (CLASS_DATA (sym)->as->rank) : (0);
12021 : 1393 : gcc_assert (rank>=0);
12022 : 1393 : tmp = gfc_conv_descriptor_dtype (descriptor);
12023 : 1393 : etype = gfc_get_element_type (type);
12024 : 1393 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (tmp), tmp,
12025 : : gfc_get_dtype_rank_type (rank, etype));
12026 : 1393 : gfc_add_expr_to_block (&init, tmp);
12027 : :
12028 : 1393 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
12029 : 1393 : input_location = loc;
12030 : : }
12031 : :
12032 : :
12033 : : /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
12034 : : Do likewise, recursively if necessary, with the allocatable components of
12035 : : derived types. This function is also called for assumed-rank arrays, which
12036 : : are always dummy arguments. */
12037 : :
12038 : : void
12039 : 16466 : gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
12040 : : {
12041 : 16466 : tree type;
12042 : 16466 : tree tmp;
12043 : 16466 : tree descriptor;
12044 : 16466 : stmtblock_t init;
12045 : 16466 : stmtblock_t cleanup;
12046 : 16466 : int rank;
12047 : 16466 : bool sym_has_alloc_comp, has_finalizer;
12048 : :
12049 : 32932 : sym_has_alloc_comp = (sym->ts.type == BT_DERIVED
12050 : 10458 : || sym->ts.type == BT_CLASS)
12051 : 16466 : && sym->ts.u.derived->attr.alloc_comp;
12052 : 16466 : has_finalizer = gfc_may_be_finalized (sym->ts);
12053 : :
12054 : : /* Make sure the frontend gets these right. */
12055 : 16466 : gcc_assert (sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp
12056 : : || has_finalizer
12057 : : || (sym->as->type == AS_ASSUMED_RANK && sym->attr.dummy));
12058 : :
12059 : 16466 : location_t loc = input_location;
12060 : 16466 : input_location = gfc_get_location (&sym->declared_at);
12061 : 16466 : gfc_init_block (&init);
12062 : :
12063 : 16466 : gcc_assert (VAR_P (sym->backend_decl)
12064 : : || TREE_CODE (sym->backend_decl) == PARM_DECL);
12065 : :
12066 : 16466 : if (sym->ts.type == BT_CHARACTER
12067 : 1255 : && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
12068 : : {
12069 : 726 : if (sym->ts.deferred && !sym->ts.u.cl->length && !sym->attr.dummy)
12070 : 534 : gfc_add_modify (&init, sym->ts.u.cl->backend_decl,
12071 : 534 : build_zero_cst (TREE_TYPE (sym->ts.u.cl->backend_decl)));
12072 : 726 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
12073 : 726 : gfc_trans_vla_type_sizes (sym, &init);
12074 : :
12075 : : /* Presence check of optional deferred-length character dummy. */
12076 : 726 : if (sym->ts.deferred && sym->attr.dummy && sym->attr.optional)
12077 : : {
12078 : 43 : tmp = gfc_finish_block (&init);
12079 : 43 : tmp = build3_v (COND_EXPR, gfc_conv_expr_present (sym),
12080 : : tmp, build_empty_stmt (input_location));
12081 : 43 : gfc_add_expr_to_block (&init, tmp);
12082 : : }
12083 : : }
12084 : :
12085 : : /* Dummy, use associated and result variables don't need anything special. */
12086 : 16466 : if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result)
12087 : : {
12088 : 685 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
12089 : 685 : input_location = loc;
12090 : 899 : return;
12091 : : }
12092 : :
12093 : 15781 : descriptor = sym->backend_decl;
12094 : :
12095 : : /* Although static, derived types with default initializers and
12096 : : allocatable components must not be nulled wholesale; instead they
12097 : : are treated component by component. */
12098 : 15781 : if (TREE_STATIC (descriptor) && !sym_has_alloc_comp && !has_finalizer)
12099 : : {
12100 : : /* SAVEd variables are not freed on exit. */
12101 : 214 : gfc_trans_static_array_pointer (sym);
12102 : :
12103 : 214 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
12104 : 214 : input_location = loc;
12105 : 214 : return;
12106 : : }
12107 : :
12108 : : /* Get the descriptor type. */
12109 : 15567 : type = TREE_TYPE (sym->backend_decl);
12110 : :
12111 : 15567 : if ((sym_has_alloc_comp || (has_finalizer && sym->ts.type != BT_CLASS))
12112 : 4650 : && !(sym->attr.pointer || sym->attr.allocatable))
12113 : : {
12114 : 2525 : if (!sym->attr.save
12115 : 2165 : && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program))
12116 : : {
12117 : 2165 : if (sym->value == NULL
12118 : 2165 : || !gfc_has_default_initializer (sym->ts.u.derived))
12119 : : {
12120 : 1857 : rank = sym->as ? sym->as->rank : 0;
12121 : 1857 : tmp = gfc_nullify_alloc_comp (sym->ts.u.derived,
12122 : : descriptor, rank);
12123 : 1857 : gfc_add_expr_to_block (&init, tmp);
12124 : : }
12125 : : else
12126 : 308 : gfc_init_default_dt (sym, &init, false);
12127 : : }
12128 : : }
12129 : 13042 : else if (!GFC_DESCRIPTOR_TYPE_P (type))
12130 : : {
12131 : : /* If the backend_decl is not a descriptor, we must have a pointer
12132 : : to one. */
12133 : 1653 : descriptor = build_fold_indirect_ref_loc (input_location,
12134 : : sym->backend_decl);
12135 : 1653 : type = TREE_TYPE (descriptor);
12136 : : }
12137 : :
12138 : : /* NULLIFY the data pointer for non-saved allocatables, or for non-saved
12139 : : pointers when -fcheck=pointer is specified. */
12140 : 26956 : if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save
12141 : 26943 : && (sym->attr.allocatable
12142 : 3210 : || (sym->attr.pointer && (gfc_option.rtcheck & GFC_RTCHECK_POINTER))))
12143 : : {
12144 : 8209 : gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node);
12145 : 8209 : if (flag_coarray == GFC_FCOARRAY_LIB && sym->attr.codimension)
12146 : : {
12147 : : /* Declare the variable static so its array descriptor stays present
12148 : : after leaving the scope. It may still be accessed through another
12149 : : image. This may happen, for example, with the caf_mpi
12150 : : implementation. */
12151 : 90 : TREE_STATIC (descriptor) = 1;
12152 : 90 : tmp = gfc_conv_descriptor_token (descriptor);
12153 : 90 : gfc_add_modify (&init, tmp, fold_convert (TREE_TYPE (tmp),
12154 : : null_pointer_node));
12155 : : }
12156 : : }
12157 : :
12158 : : /* Set initial TKR for pointers and allocatables */
12159 : 15567 : if (GFC_DESCRIPTOR_TYPE_P (type)
12160 : 15567 : && (sym->attr.pointer || sym->attr.allocatable))
12161 : : {
12162 : 11389 : tree etype;
12163 : :
12164 : 11389 : gcc_assert (sym->as && sym->as->rank>=0);
12165 : 11389 : tmp = gfc_conv_descriptor_dtype (descriptor);
12166 : 11389 : etype = gfc_get_element_type (type);
12167 : 11389 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
12168 : 11389 : TREE_TYPE (tmp), tmp,
12169 : 11389 : gfc_get_dtype_rank_type (sym->as->rank, etype));
12170 : 11389 : gfc_add_expr_to_block (&init, tmp);
12171 : : }
12172 : 15567 : input_location = loc;
12173 : 15567 : gfc_init_block (&cleanup);
12174 : :
12175 : : /* Allocatable arrays need to be freed when they go out of scope.
12176 : : The allocatable components of pointers must not be touched. */
12177 : 15567 : if (!sym->attr.allocatable && has_finalizer && sym->ts.type != BT_CLASS
12178 : 480 : && !sym->attr.pointer && !sym->attr.artificial && !sym->attr.save
12179 : 230 : && !sym->ns->proc_name->attr.is_main_program)
12180 : : {
12181 : 192 : gfc_expr *e;
12182 : 192 : sym->attr.referenced = 1;
12183 : 192 : e = gfc_lval_expr_from_sym (sym);
12184 : 192 : gfc_add_finalizer_call (&cleanup, e);
12185 : 192 : gfc_free_expr (e);
12186 : 192 : }
12187 : 15375 : else if ((!sym->attr.allocatable || !has_finalizer)
12188 : 15264 : && sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
12189 : 4202 : && !sym->attr.pointer && !sym->attr.save
12190 : 2163 : && !(sym->attr.artificial && sym->name[0] == '_')
12191 : 2108 : && !sym->ns->proc_name->attr.is_main_program)
12192 : : {
12193 : 562 : int rank;
12194 : 562 : rank = sym->as ? sym->as->rank : 0;
12195 : 562 : tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank,
12196 : 562 : (sym->attr.codimension
12197 : 2 : && flag_coarray == GFC_FCOARRAY_LIB)
12198 : : ? GFC_STRUCTURE_CAF_MODE_IN_COARRAY
12199 : : : 0);
12200 : 562 : gfc_add_expr_to_block (&cleanup, tmp);
12201 : : }
12202 : :
12203 : 15567 : if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension)
12204 : 8173 : && !sym->attr.save && !sym->attr.result
12205 : 8166 : && !sym->ns->proc_name->attr.is_main_program)
12206 : : {
12207 : 4427 : gfc_expr *e;
12208 : 4427 : e = has_finalizer ? gfc_lval_expr_from_sym (sym) : NULL;
12209 : 8854 : tmp = gfc_deallocate_with_status (sym->backend_decl, NULL_TREE, NULL_TREE,
12210 : : NULL_TREE, NULL_TREE, true, e,
12211 : 4427 : sym->attr.codimension
12212 : : ? GFC_CAF_COARRAY_DEREGISTER
12213 : : : GFC_CAF_COARRAY_NOCOARRAY,
12214 : : NULL_TREE, gfc_finish_block (&cleanup));
12215 : 4427 : if (e)
12216 : 32 : gfc_free_expr (e);
12217 : 4427 : gfc_init_block (&cleanup);
12218 : 4427 : gfc_add_expr_to_block (&cleanup, tmp);
12219 : : }
12220 : :
12221 : 15567 : gfc_add_init_cleanup (block, gfc_finish_block (&init),
12222 : : gfc_finish_block (&cleanup));
12223 : : }
12224 : :
12225 : : /************ Expression Walking Functions ******************/
12226 : :
12227 : : /* Walk a variable reference.
12228 : :
12229 : : Possible extension - multiple component subscripts.
12230 : : x(:,:) = foo%a(:)%b(:)
12231 : : Transforms to
12232 : : forall (i=..., j=...)
12233 : : x(i,j) = foo%a(j)%b(i)
12234 : : end forall
12235 : : This adds a fair amount of complexity because you need to deal with more
12236 : : than one ref. Maybe handle in a similar manner to vector subscripts.
12237 : : Maybe not worth the effort. */
12238 : :
12239 : :
12240 : : static gfc_ss *
12241 : 647263 : gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
12242 : : {
12243 : 647263 : gfc_ref *ref;
12244 : :
12245 : 647263 : gfc_fix_class_refs (expr);
12246 : :
12247 : 752068 : for (ref = expr->ref; ref; ref = ref->next)
12248 : 412294 : if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
12249 : : break;
12250 : :
12251 : 647263 : return gfc_walk_array_ref (ss, expr, ref);
12252 : : }
12253 : :
12254 : : gfc_ss *
12255 : 647489 : gfc_walk_array_ref (gfc_ss *ss, gfc_expr *expr, gfc_ref *ref, bool array_only)
12256 : : {
12257 : 647489 : gfc_array_ref *ar;
12258 : 647489 : gfc_ss *newss;
12259 : 647489 : int n;
12260 : :
12261 : 962810 : for (; ref; ref = ref->next)
12262 : : {
12263 : 315321 : if (ref->type == REF_SUBSTRING)
12264 : : {
12265 : 1280 : ss = gfc_get_scalar_ss (ss, ref->u.ss.start);
12266 : 1280 : if (ref->u.ss.end)
12267 : 1254 : ss = gfc_get_scalar_ss (ss, ref->u.ss.end);
12268 : : }
12269 : :
12270 : : /* We're only interested in array sections from now on. */
12271 : 315321 : if (ref->type != REF_ARRAY
12272 : 307973 : || (array_only && ref->u.ar.as && ref->u.ar.as->rank == 0))
12273 : 7445 : continue;
12274 : :
12275 : 307876 : ar = &ref->u.ar;
12276 : :
12277 : 307876 : switch (ar->type)
12278 : : {
12279 : 188 : case AR_ELEMENT:
12280 : 423 : for (n = ar->dimen - 1; n >= 0; n--)
12281 : 235 : ss = gfc_get_scalar_ss (ss, ar->start[n]);
12282 : : break;
12283 : :
12284 : 254986 : case AR_FULL:
12285 : : /* Assumed shape arrays from interface mapping need this fix. */
12286 : 254986 : if (!ar->as && expr->symtree->n.sym->as)
12287 : : {
12288 : 6 : ar->as = gfc_get_array_spec();
12289 : 6 : *ar->as = *expr->symtree->n.sym->as;
12290 : : }
12291 : 254986 : newss = gfc_get_array_ss (ss, expr, ar->as->rank, GFC_SS_SECTION);
12292 : 254986 : newss->info->data.array.ref = ref;
12293 : :
12294 : : /* Make sure array is the same as array(:,:), this way
12295 : : we don't need to special case all the time. */
12296 : 254986 : ar->dimen = ar->as->rank;
12297 : 590239 : for (n = 0; n < ar->dimen; n++)
12298 : : {
12299 : 335253 : ar->dimen_type[n] = DIMEN_RANGE;
12300 : :
12301 : 335253 : gcc_assert (ar->start[n] == NULL);
12302 : 335253 : gcc_assert (ar->end[n] == NULL);
12303 : 335253 : gcc_assert (ar->stride[n] == NULL);
12304 : : }
12305 : : ss = newss;
12306 : : break;
12307 : :
12308 : 52702 : case AR_SECTION:
12309 : 52702 : newss = gfc_get_array_ss (ss, expr, 0, GFC_SS_SECTION);
12310 : 52702 : newss->info->data.array.ref = ref;
12311 : :
12312 : : /* We add SS chains for all the subscripts in the section. */
12313 : 134766 : for (n = 0; n < ar->dimen; n++)
12314 : : {
12315 : 82064 : gfc_ss *indexss;
12316 : :
12317 : 82064 : switch (ar->dimen_type[n])
12318 : : {
12319 : 6115 : case DIMEN_ELEMENT:
12320 : : /* Add SS for elemental (scalar) subscripts. */
12321 : 6115 : gcc_assert (ar->start[n]);
12322 : 6115 : indexss = gfc_get_scalar_ss (gfc_ss_terminator, ar->start[n]);
12323 : 6115 : indexss->loop_chain = gfc_ss_terminator;
12324 : 6115 : newss->info->data.array.subscript[n] = indexss;
12325 : 6115 : break;
12326 : :
12327 : 75143 : case DIMEN_RANGE:
12328 : : /* We don't add anything for sections, just remember this
12329 : : dimension for later. */
12330 : 75143 : newss->dim[newss->dimen] = n;
12331 : 75143 : newss->dimen++;
12332 : 75143 : break;
12333 : :
12334 : 806 : case DIMEN_VECTOR:
12335 : : /* Create a GFC_SS_VECTOR index in which we can store
12336 : : the vector's descriptor. */
12337 : 806 : indexss = gfc_get_array_ss (gfc_ss_terminator, ar->start[n],
12338 : : 1, GFC_SS_VECTOR);
12339 : 806 : indexss->loop_chain = gfc_ss_terminator;
12340 : 806 : newss->info->data.array.subscript[n] = indexss;
12341 : 806 : newss->dim[newss->dimen] = n;
12342 : 806 : newss->dimen++;
12343 : 806 : break;
12344 : :
12345 : 0 : default:
12346 : : /* We should know what sort of section it is by now. */
12347 : 0 : gcc_unreachable ();
12348 : : }
12349 : : }
12350 : : /* We should have at least one non-elemental dimension,
12351 : : unless we are creating a descriptor for a (scalar) coarray. */
12352 : 52702 : gcc_assert (newss->dimen > 0
12353 : : || newss->info->data.array.ref->u.ar.as->corank > 0);
12354 : : ss = newss;
12355 : : break;
12356 : :
12357 : 0 : default:
12358 : : /* We should know what sort of section it is by now. */
12359 : 0 : gcc_unreachable ();
12360 : : }
12361 : :
12362 : : }
12363 : 647489 : return ss;
12364 : : }
12365 : :
12366 : :
12367 : : /* Walk an expression operator. If only one operand of a binary expression is
12368 : : scalar, we must also add the scalar term to the SS chain. */
12369 : :
12370 : : static gfc_ss *
12371 : 51527 : gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
12372 : : {
12373 : 51527 : gfc_ss *head;
12374 : 51527 : gfc_ss *head2;
12375 : :
12376 : 51527 : head = gfc_walk_subexpr (ss, expr->value.op.op1);
12377 : 51527 : if (expr->value.op.op2 == NULL)
12378 : : head2 = head;
12379 : : else
12380 : 49605 : head2 = gfc_walk_subexpr (head, expr->value.op.op2);
12381 : :
12382 : : /* All operands are scalar. Pass back and let the caller deal with it. */
12383 : 51527 : if (head2 == ss)
12384 : : return head2;
12385 : :
12386 : : /* All operands require scalarization. */
12387 : 47094 : if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
12388 : : return head2;
12389 : :
12390 : : /* One of the operands needs scalarization, the other is scalar.
12391 : : Create a gfc_ss for the scalar expression. */
12392 : 16170 : if (head == ss)
12393 : : {
12394 : : /* First operand is scalar. We build the chain in reverse order, so
12395 : : add the scalar SS after the second operand. */
12396 : : head = head2;
12397 : 2152 : while (head && head->next != ss)
12398 : : head = head->next;
12399 : : /* Check we haven't somehow broken the chain. */
12400 : 1909 : gcc_assert (head);
12401 : 1909 : head->next = gfc_get_scalar_ss (ss, expr->value.op.op1);
12402 : : }
12403 : : else /* head2 == head */
12404 : : {
12405 : 14261 : gcc_assert (head2 == head);
12406 : : /* Second operand is scalar. */
12407 : 14261 : head2 = gfc_get_scalar_ss (head2, expr->value.op.op2);
12408 : : }
12409 : :
12410 : : return head2;
12411 : : }
12412 : :
12413 : :
12414 : : /* Reverse a SS chain. */
12415 : :
12416 : : gfc_ss *
12417 : 816235 : gfc_reverse_ss (gfc_ss * ss)
12418 : : {
12419 : 816235 : gfc_ss *next;
12420 : 816235 : gfc_ss *head;
12421 : :
12422 : 816235 : gcc_assert (ss != NULL);
12423 : :
12424 : : head = gfc_ss_terminator;
12425 : 1224334 : while (ss != gfc_ss_terminator)
12426 : : {
12427 : 408099 : next = ss->next;
12428 : : /* Check we didn't somehow break the chain. */
12429 : 408099 : gcc_assert (next != NULL);
12430 : 408099 : ss->next = head;
12431 : 408099 : head = ss;
12432 : 408099 : ss = next;
12433 : : }
12434 : :
12435 : 816235 : return (head);
12436 : : }
12437 : :
12438 : :
12439 : : /* Given an expression referring to a procedure, return the symbol of its
12440 : : interface. We can't get the procedure symbol directly as we have to handle
12441 : : the case of (deferred) type-bound procedures. */
12442 : :
12443 : : gfc_symbol *
12444 : 160 : gfc_get_proc_ifc_for_expr (gfc_expr *procedure_ref)
12445 : : {
12446 : 160 : gfc_symbol *sym;
12447 : 160 : gfc_ref *ref;
12448 : :
12449 : 160 : if (procedure_ref == NULL)
12450 : : return NULL;
12451 : :
12452 : : /* Normal procedure case. */
12453 : 160 : if (procedure_ref->expr_type == EXPR_FUNCTION
12454 : 160 : && procedure_ref->value.function.esym)
12455 : : sym = procedure_ref->value.function.esym;
12456 : : else
12457 : 24 : sym = procedure_ref->symtree->n.sym;
12458 : :
12459 : : /* Typebound procedure case. */
12460 : 208 : for (ref = procedure_ref->ref; ref; ref = ref->next)
12461 : : {
12462 : 48 : if (ref->type == REF_COMPONENT
12463 : 48 : && ref->u.c.component->attr.proc_pointer)
12464 : 24 : sym = ref->u.c.component->ts.interface;
12465 : : else
12466 : : sym = NULL;
12467 : : }
12468 : :
12469 : : return sym;
12470 : : }
12471 : :
12472 : :
12473 : : /* Given an expression referring to an intrinsic function call,
12474 : : return the intrinsic symbol. */
12475 : :
12476 : : gfc_intrinsic_sym *
12477 : 7765 : gfc_get_intrinsic_for_expr (gfc_expr *call)
12478 : : {
12479 : 7765 : if (call == NULL)
12480 : : return NULL;
12481 : :
12482 : : /* Normal procedure case. */
12483 : 2341 : if (call->expr_type == EXPR_FUNCTION)
12484 : 2235 : return call->value.function.isym;
12485 : : else
12486 : : return NULL;
12487 : : }
12488 : :
12489 : :
12490 : : /* Indicates whether an argument to an intrinsic function should be used in
12491 : : scalarization. It is usually the case, except for some intrinsics
12492 : : requiring the value to be constant, and using the value at compile time only.
12493 : : As the value is not used at runtime in those cases, we don’t produce code
12494 : : for it, and it should not be visible to the scalarizer.
12495 : : FUNCTION is the intrinsic function being called, ACTUAL_ARG is the actual
12496 : : argument being examined in that call, and ARG_NUM the index number
12497 : : of ACTUAL_ARG in the list of arguments.
12498 : : The intrinsic procedure’s dummy argument associated with ACTUAL_ARG is
12499 : : identified using the name in ACTUAL_ARG if it is present (that is: if it’s
12500 : : a keyword argument), otherwise using ARG_NUM. */
12501 : :
12502 : : static bool
12503 : 36536 : arg_evaluated_for_scalarization (gfc_intrinsic_sym *function,
12504 : : gfc_dummy_arg *dummy_arg)
12505 : : {
12506 : 36536 : if (function != NULL && dummy_arg != NULL)
12507 : : {
12508 : 12276 : switch (function->id)
12509 : : {
12510 : 241 : case GFC_ISYM_INDEX:
12511 : 241 : case GFC_ISYM_LEN_TRIM:
12512 : 241 : case GFC_ISYM_MASKL:
12513 : 241 : case GFC_ISYM_MASKR:
12514 : 241 : case GFC_ISYM_SCAN:
12515 : 241 : case GFC_ISYM_VERIFY:
12516 : 241 : if (strcmp ("kind", gfc_dummy_arg_get_name (*dummy_arg)) == 0)
12517 : : return false;
12518 : : /* Fallthrough. */
12519 : :
12520 : : default:
12521 : : break;
12522 : : }
12523 : : }
12524 : :
12525 : : return true;
12526 : : }
12527 : :
12528 : :
12529 : : /* Walk the arguments of an elemental function.
12530 : : PROC_EXPR is used to check whether an argument is permitted to be absent. If
12531 : : it is NULL, we don't do the check and the argument is assumed to be present.
12532 : : */
12533 : :
12534 : : gfc_ss *
12535 : 25810 : gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
12536 : : gfc_intrinsic_sym *intrinsic_sym,
12537 : : gfc_ss_type type)
12538 : : {
12539 : 25810 : int scalar;
12540 : 25810 : gfc_ss *head;
12541 : 25810 : gfc_ss *tail;
12542 : 25810 : gfc_ss *newss;
12543 : :
12544 : 25810 : head = gfc_ss_terminator;
12545 : 25810 : tail = NULL;
12546 : :
12547 : 25810 : scalar = 1;
12548 : 63802 : for (; arg; arg = arg->next)
12549 : : {
12550 : 37992 : gfc_dummy_arg * const dummy_arg = arg->associated_dummy;
12551 : 39481 : if (!arg->expr
12552 : 36686 : || arg->expr->expr_type == EXPR_NULL
12553 : 74528 : || !arg_evaluated_for_scalarization (intrinsic_sym, dummy_arg))
12554 : 1489 : continue;
12555 : :
12556 : 36503 : newss = gfc_walk_subexpr (head, arg->expr);
12557 : 36503 : if (newss == head)
12558 : : {
12559 : : /* Scalar argument. */
12560 : 18334 : gcc_assert (type == GFC_SS_SCALAR || type == GFC_SS_REFERENCE);
12561 : 18334 : newss = gfc_get_scalar_ss (head, arg->expr);
12562 : 18334 : newss->info->type = type;
12563 : 18334 : if (dummy_arg)
12564 : 15368 : newss->info->data.scalar.dummy_arg = dummy_arg;
12565 : : }
12566 : : else
12567 : : scalar = 0;
12568 : :
12569 : 33537 : if (dummy_arg != NULL
12570 : 25717 : && gfc_dummy_arg_is_optional (*dummy_arg)
12571 : 2492 : && arg->expr->expr_type == EXPR_VARIABLE
12572 : 35241 : && (gfc_expr_attr (arg->expr).optional
12573 : 1223 : || gfc_expr_attr (arg->expr).allocatable
12574 : 36450 : || gfc_expr_attr (arg->expr).pointer))
12575 : 1005 : newss->info->can_be_null_ref = true;
12576 : :
12577 : 36503 : head = newss;
12578 : 36503 : if (!tail)
12579 : : {
12580 : : tail = head;
12581 : 31516 : while (tail->next != gfc_ss_terminator)
12582 : : tail = tail->next;
12583 : : }
12584 : : }
12585 : :
12586 : 25810 : if (scalar)
12587 : : {
12588 : : /* If all the arguments are scalar we don't need the argument SS. */
12589 : 10161 : gfc_free_ss_chain (head);
12590 : : /* Pass it back. */
12591 : 10161 : return ss;
12592 : : }
12593 : :
12594 : : /* Add it onto the existing chain. */
12595 : 15649 : tail->next = ss;
12596 : 15649 : return head;
12597 : : }
12598 : :
12599 : :
12600 : : /* Walk a function call. Scalar functions are passed back, and taken out of
12601 : : scalarization loops. For elemental functions we walk their arguments.
12602 : : The result of functions returning arrays is stored in a temporary outside
12603 : : the loop, so that the function is only called once. Hence we do not need
12604 : : to walk their arguments. */
12605 : :
12606 : : static gfc_ss *
12607 : 59434 : gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
12608 : : {
12609 : 59434 : gfc_intrinsic_sym *isym;
12610 : 59434 : gfc_symbol *sym;
12611 : 59434 : gfc_component *comp = NULL;
12612 : :
12613 : 59434 : isym = expr->value.function.isym;
12614 : :
12615 : : /* Handle intrinsic functions separately. */
12616 : 59434 : if (isym)
12617 : 51864 : return gfc_walk_intrinsic_function (ss, expr, isym);
12618 : :
12619 : 7570 : sym = expr->value.function.esym;
12620 : 7570 : if (!sym)
12621 : 546 : sym = expr->symtree->n.sym;
12622 : :
12623 : 7570 : if (gfc_is_class_array_function (expr))
12624 : 228 : return gfc_get_array_ss (ss, expr,
12625 : 228 : CLASS_DATA (expr->value.function.esym->result)->as->rank,
12626 : 228 : GFC_SS_FUNCTION);
12627 : :
12628 : : /* A function that returns arrays. */
12629 : 7342 : comp = gfc_get_proc_ptr_comp (expr);
12630 : 6944 : if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
12631 : 7342 : || (comp && comp->attr.dimension))
12632 : 2586 : return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
12633 : :
12634 : : /* Walk the parameters of an elemental function. For now we always pass
12635 : : by reference. */
12636 : 4756 : if (sym->attr.elemental || (comp && comp->attr.elemental))
12637 : : {
12638 : 2199 : gfc_ss *old_ss = ss;
12639 : :
12640 : 2199 : ss = gfc_walk_elemental_function_args (old_ss,
12641 : : expr->value.function.actual,
12642 : : gfc_get_intrinsic_for_expr (expr),
12643 : : GFC_SS_REFERENCE);
12644 : 2199 : if (ss != old_ss
12645 : 1163 : && (comp
12646 : 1102 : || sym->attr.proc_pointer
12647 : : || sym->attr.if_source != IFSRC_DECL
12648 : 1102 : || sym->attr.array_outer_dependency))
12649 : 224 : ss->info->array_outer_dependency = 1;
12650 : : }
12651 : :
12652 : : /* Scalar functions are OK as these are evaluated outside the scalarization
12653 : : loop. Pass back and let the caller deal with it. */
12654 : : return ss;
12655 : : }
12656 : :
12657 : :
12658 : : /* An array temporary is constructed for array constructors. */
12659 : :
12660 : : static gfc_ss *
12661 : 48563 : gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
12662 : : {
12663 : 0 : return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_CONSTRUCTOR);
12664 : : }
12665 : :
12666 : :
12667 : : /* Walk an expression. Add walked expressions to the head of the SS chain.
12668 : : A wholly scalar expression will not be added. */
12669 : :
12670 : : gfc_ss *
12671 : 956807 : gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
12672 : : {
12673 : 956807 : gfc_ss *head;
12674 : :
12675 : 956807 : switch (expr->expr_type)
12676 : : {
12677 : 647263 : case EXPR_VARIABLE:
12678 : 647263 : head = gfc_walk_variable_expr (ss, expr);
12679 : 647263 : return head;
12680 : :
12681 : 51527 : case EXPR_OP:
12682 : 51527 : head = gfc_walk_op_expr (ss, expr);
12683 : 51527 : return head;
12684 : :
12685 : 59434 : case EXPR_FUNCTION:
12686 : 59434 : head = gfc_walk_function_expr (ss, expr);
12687 : 59434 : return head;
12688 : :
12689 : : case EXPR_CONSTANT:
12690 : : case EXPR_NULL:
12691 : : case EXPR_STRUCTURE:
12692 : : /* Pass back and let the caller deal with it. */
12693 : : break;
12694 : :
12695 : 48563 : case EXPR_ARRAY:
12696 : 48563 : head = gfc_walk_array_constructor (ss, expr);
12697 : 48563 : return head;
12698 : :
12699 : : case EXPR_SUBSTRING:
12700 : : /* Pass back and let the caller deal with it. */
12701 : : break;
12702 : :
12703 : 0 : default:
12704 : 0 : gfc_internal_error ("bad expression type during walk (%d)",
12705 : : expr->expr_type);
12706 : : }
12707 : : return ss;
12708 : : }
12709 : :
12710 : :
12711 : : /* Entry point for expression walking.
12712 : : A return value equal to the passed chain means this is
12713 : : a scalar expression. It is up to the caller to take whatever action is
12714 : : necessary to translate these. */
12715 : :
12716 : : gfc_ss *
12717 : 813799 : gfc_walk_expr (gfc_expr * expr)
12718 : : {
12719 : 813799 : gfc_ss *res;
12720 : :
12721 : 813799 : res = gfc_walk_subexpr (gfc_ss_terminator, expr);
12722 : 813799 : return gfc_reverse_ss (res);
12723 : : }
|
