Line data Source code
1 : /* Array translation routines
2 : Copyright (C) 2002-2026 Free Software Foundation, Inc.
3 : Contributed by Paul Brook <paul@nowt.org>
4 : and Steven Bosscher <s.bosscher@student.tudelft.nl>
5 :
6 : This file is part of GCC.
7 :
8 : GCC is free software; you can redistribute it and/or modify it under
9 : the terms of the GNU General Public License as published by the Free
10 : Software Foundation; either version 3, or (at your option) any later
11 : version.
12 :
13 : GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 : WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 : FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
16 : for more details.
17 :
18 : You should have received a copy of the GNU General Public License
19 : along with GCC; see the file COPYING3. If not see
20 : <http://www.gnu.org/licenses/>. */
21 :
22 : /* trans-array.cc-- Various array related code, including scalarization,
23 : allocation, initialization and other support routines. */
24 :
25 : /* How the scalarizer works.
26 : In gfortran, array expressions use the same core routines as scalar
27 : expressions.
28 : First, a Scalarization State (SS) chain is built. This is done by walking
29 : the expression tree, and building a linear list of the terms in the
30 : expression. As the tree is walked, scalar subexpressions are translated.
31 :
32 : The scalarization parameters are stored in a gfc_loopinfo structure.
33 : First the start and stride of each term is calculated by
34 : gfc_conv_ss_startstride. During this process the expressions for the array
35 : descriptors and data pointers are also translated.
36 :
37 : If the expression is an assignment, we must then resolve any dependencies.
38 : In Fortran all the rhs values of an assignment must be evaluated before
39 : any assignments take place. This can require a temporary array to store the
40 : values. We also require a temporary when we are passing array expressions
41 : or vector subscripts as procedure parameters.
42 :
43 : Array sections are passed without copying to a temporary. These use the
44 : scalarizer to determine the shape of the section. The flag
45 : loop->array_parameter tells the scalarizer that the actual values and loop
46 : variables will not be required.
47 :
48 : The function gfc_conv_loop_setup generates the scalarization setup code.
49 : It determines the range of the scalarizing loop variables. If a temporary
50 : is required, this is created and initialized. Code for scalar expressions
51 : taken outside the loop is also generated at this time. Next the offset and
52 : scaling required to translate from loop variables to array indices for each
53 : term is calculated.
54 :
55 : A call to gfc_start_scalarized_body marks the start of the scalarized
56 : expression. This creates a scope and declares the loop variables. Before
57 : calling this gfc_make_ss_chain_used must be used to indicate which terms
58 : will be used inside this loop.
59 :
60 : The scalar gfc_conv_* functions are then used to build the main body of the
61 : scalarization loop. Scalarization loop variables and precalculated scalar
62 : values are automatically substituted. Note that gfc_advance_se_ss_chain
63 : must be used, rather than changing the se->ss directly.
64 :
65 : For assignment expressions requiring a temporary two sub loops are
66 : generated. The first stores the result of the expression in the temporary,
67 : the second copies it to the result. A call to
68 : gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
69 : the start of the copying loop. The temporary may be less than full rank.
70 :
71 : Finally gfc_trans_scalarizing_loops is called to generate the implicit do
72 : loops. The loops are added to the pre chain of the loopinfo. The post
73 : chain may still contain cleanup code.
74 :
75 : After the loop code has been added into its parent scope gfc_cleanup_loop
76 : is called to free all the SS allocated by the scalarizer. */
77 :
78 : #include "config.h"
79 : #include "system.h"
80 : #include "coretypes.h"
81 : #include "options.h"
82 : #include "tree.h"
83 : #include "gfortran.h"
84 : #include "gimple-expr.h"
85 : #include "tree-iterator.h"
86 : #include "stringpool.h" /* Required by "attribs.h". */
87 : #include "attribs.h" /* For lookup_attribute. */
88 : #include "trans.h"
89 : #include "fold-const.h"
90 : #include "stor-layout.h" /* For min_align_of_type. */
91 : #include "constructor.h"
92 : #include "trans-types.h"
93 : #include "trans-array.h"
94 : #include "trans-const.h"
95 : #include "dependency.h"
96 : #include "trans-descriptor.h"
97 : #include "cgraph.h" /* For cgraph_node::add_new_function. */
98 : #include "function.h" /* For push_struct_function. */
99 :
100 : static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor_base);
101 :
102 : /* The contents of this structure aren't actually used, just the address. */
103 : static gfc_ss gfc_ss_terminator_var;
104 : gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var;
105 :
106 :
107 : static tree
108 60460 : gfc_array_dataptr_type (tree desc)
109 : {
110 60460 : return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
111 : }
112 :
113 : /* Build expressions to access members of the CFI descriptor. */
114 : #define CFI_FIELD_BASE_ADDR 0
115 : #define CFI_FIELD_ELEM_LEN 1
116 : #define CFI_FIELD_VERSION 2
117 : #define CFI_FIELD_RANK 3
118 : #define CFI_FIELD_ATTRIBUTE 4
119 : #define CFI_FIELD_TYPE 5
120 : #define CFI_FIELD_DIM 6
121 :
122 : #define CFI_DIM_FIELD_LOWER_BOUND 0
123 : #define CFI_DIM_FIELD_EXTENT 1
124 : #define CFI_DIM_FIELD_SM 2
125 :
126 : static tree
127 84943 : gfc_get_cfi_descriptor_field (tree desc, unsigned field_idx)
128 : {
129 84943 : tree type = TREE_TYPE (desc);
130 84943 : gcc_assert (TREE_CODE (type) == RECORD_TYPE
131 : && TYPE_FIELDS (type)
132 : && (strcmp ("base_addr",
133 : IDENTIFIER_POINTER (DECL_NAME (TYPE_FIELDS (type))))
134 : == 0));
135 84943 : tree field = gfc_advance_chain (TYPE_FIELDS (type), field_idx);
136 84943 : gcc_assert (field != NULL_TREE);
137 :
138 84943 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
139 84943 : desc, field, NULL_TREE);
140 : }
141 :
142 : tree
143 14201 : gfc_get_cfi_desc_base_addr (tree desc)
144 : {
145 14201 : return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_BASE_ADDR);
146 : }
147 :
148 : tree
149 10681 : gfc_get_cfi_desc_elem_len (tree desc)
150 : {
151 10681 : return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_ELEM_LEN);
152 : }
153 :
154 : tree
155 7191 : gfc_get_cfi_desc_version (tree desc)
156 : {
157 7191 : return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_VERSION);
158 : }
159 :
160 : tree
161 7816 : gfc_get_cfi_desc_rank (tree desc)
162 : {
163 7816 : return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_RANK);
164 : }
165 :
166 : tree
167 7283 : gfc_get_cfi_desc_type (tree desc)
168 : {
169 7283 : return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_TYPE);
170 : }
171 :
172 : tree
173 7191 : gfc_get_cfi_desc_attribute (tree desc)
174 : {
175 7191 : return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_ATTRIBUTE);
176 : }
177 :
178 : static tree
179 30580 : gfc_get_cfi_dim_item (tree desc, tree idx, unsigned field_idx)
180 : {
181 30580 : tree tmp = gfc_get_cfi_descriptor_field (desc, CFI_FIELD_DIM);
182 30580 : tmp = gfc_build_array_ref (tmp, idx, NULL_TREE, true);
183 30580 : tree field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), field_idx);
184 30580 : gcc_assert (field != NULL_TREE);
185 30580 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
186 30580 : tmp, field, NULL_TREE);
187 : }
188 :
189 : tree
190 6786 : gfc_get_cfi_dim_lbound (tree desc, tree idx)
191 : {
192 6786 : return gfc_get_cfi_dim_item (desc, idx, CFI_DIM_FIELD_LOWER_BOUND);
193 : }
194 :
195 : tree
196 11926 : gfc_get_cfi_dim_extent (tree desc, tree idx)
197 : {
198 11926 : return gfc_get_cfi_dim_item (desc, idx, CFI_DIM_FIELD_EXTENT);
199 : }
200 :
201 : tree
202 11868 : gfc_get_cfi_dim_sm (tree desc, tree idx)
203 : {
204 11868 : return gfc_get_cfi_dim_item (desc, idx, CFI_DIM_FIELD_SM);
205 : }
206 :
207 : #undef CFI_FIELD_BASE_ADDR
208 : #undef CFI_FIELD_ELEM_LEN
209 : #undef CFI_FIELD_VERSION
210 : #undef CFI_FIELD_RANK
211 : #undef CFI_FIELD_ATTRIBUTE
212 : #undef CFI_FIELD_TYPE
213 : #undef CFI_FIELD_DIM
214 :
215 : #undef CFI_DIM_FIELD_LOWER_BOUND
216 : #undef CFI_DIM_FIELD_EXTENT
217 : #undef CFI_DIM_FIELD_SM
218 :
219 :
220 : /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
221 : flags & 1 = Main loop body.
222 : flags & 2 = temp copy loop. */
223 :
224 : void
225 178003 : gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
226 : {
227 417844 : for (; ss != gfc_ss_terminator; ss = ss->next)
228 239841 : ss->info->useflags = flags;
229 178003 : }
230 :
231 :
232 : /* Free a gfc_ss chain. */
233 :
234 : void
235 186605 : gfc_free_ss_chain (gfc_ss * ss)
236 : {
237 186605 : gfc_ss *next;
238 :
239 381421 : while (ss != gfc_ss_terminator)
240 : {
241 194816 : gcc_assert (ss != NULL);
242 194816 : next = ss->next;
243 194816 : gfc_free_ss (ss);
244 194816 : ss = next;
245 : }
246 186605 : }
247 :
248 :
249 : static void
250 505838 : free_ss_info (gfc_ss_info *ss_info)
251 : {
252 505838 : int n;
253 :
254 505838 : ss_info->refcount--;
255 505838 : if (ss_info->refcount > 0)
256 : return;
257 :
258 501091 : gcc_assert (ss_info->refcount == 0);
259 :
260 501091 : switch (ss_info->type)
261 : {
262 : case GFC_SS_SECTION:
263 5574688 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
264 5226270 : if (ss_info->data.array.subscript[n])
265 7894 : gfc_free_ss_chain (ss_info->data.array.subscript[n]);
266 : break;
267 :
268 : default:
269 : break;
270 : }
271 :
272 501091 : free (ss_info);
273 : }
274 :
275 :
276 : /* Free a SS. */
277 :
278 : void
279 505838 : gfc_free_ss (gfc_ss * ss)
280 : {
281 505838 : free_ss_info (ss->info);
282 505838 : free (ss);
283 505838 : }
284 :
285 :
286 : /* Creates and initializes an array type gfc_ss struct. */
287 :
288 : gfc_ss *
289 423666 : gfc_get_array_ss (gfc_ss *next, gfc_expr *expr, int dimen, gfc_ss_type type)
290 : {
291 423666 : gfc_ss *ss;
292 423666 : gfc_ss_info *ss_info;
293 423666 : int i;
294 :
295 423666 : ss_info = gfc_get_ss_info ();
296 423666 : ss_info->refcount++;
297 423666 : ss_info->type = type;
298 423666 : ss_info->expr = expr;
299 :
300 423666 : ss = gfc_get_ss ();
301 423666 : ss->info = ss_info;
302 423666 : ss->next = next;
303 423666 : ss->dimen = dimen;
304 890765 : for (i = 0; i < ss->dimen; i++)
305 467099 : ss->dim[i] = i;
306 :
307 423666 : return ss;
308 : }
309 :
310 :
311 : /* Creates and initializes a temporary type gfc_ss struct. */
312 :
313 : gfc_ss *
314 11830 : gfc_get_temp_ss (tree type, tree string_length, int dimen)
315 : {
316 11830 : gfc_ss *ss;
317 11830 : gfc_ss_info *ss_info;
318 11830 : int i;
319 :
320 11830 : ss_info = gfc_get_ss_info ();
321 11830 : ss_info->refcount++;
322 11830 : ss_info->type = GFC_SS_TEMP;
323 11830 : ss_info->string_length = string_length;
324 11830 : ss_info->data.temp.type = type;
325 :
326 11830 : ss = gfc_get_ss ();
327 11830 : ss->info = ss_info;
328 11830 : ss->next = gfc_ss_terminator;
329 11830 : ss->dimen = dimen;
330 26411 : for (i = 0; i < ss->dimen; i++)
331 14581 : ss->dim[i] = i;
332 :
333 11830 : return ss;
334 : }
335 :
336 :
337 : /* Creates and initializes a scalar type gfc_ss struct. */
338 :
339 : gfc_ss *
340 67720 : gfc_get_scalar_ss (gfc_ss *next, gfc_expr *expr)
341 : {
342 67720 : gfc_ss *ss;
343 67720 : gfc_ss_info *ss_info;
344 :
345 67720 : ss_info = gfc_get_ss_info ();
346 67720 : ss_info->refcount++;
347 67720 : ss_info->type = GFC_SS_SCALAR;
348 67720 : ss_info->expr = expr;
349 :
350 67720 : ss = gfc_get_ss ();
351 67720 : ss->info = ss_info;
352 67720 : ss->next = next;
353 :
354 67720 : return ss;
355 : }
356 :
357 :
358 : /* Free all the SS associated with a loop. */
359 :
360 : void
361 187894 : gfc_cleanup_loop (gfc_loopinfo * loop)
362 : {
363 187894 : gfc_loopinfo *loop_next, **ploop;
364 187894 : gfc_ss *ss;
365 187894 : gfc_ss *next;
366 :
367 187894 : ss = loop->ss;
368 498537 : while (ss != gfc_ss_terminator)
369 : {
370 310643 : gcc_assert (ss != NULL);
371 310643 : next = ss->loop_chain;
372 310643 : gfc_free_ss (ss);
373 310643 : ss = next;
374 : }
375 :
376 : /* Remove reference to self in the parent loop. */
377 187894 : if (loop->parent)
378 3364 : for (ploop = &loop->parent->nested; *ploop; ploop = &(*ploop)->next)
379 3364 : if (*ploop == loop)
380 : {
381 3364 : *ploop = loop->next;
382 3364 : break;
383 : }
384 :
385 : /* Free non-freed nested loops. */
386 191258 : for (loop = loop->nested; loop; loop = loop_next)
387 : {
388 3364 : loop_next = loop->next;
389 3364 : gfc_cleanup_loop (loop);
390 3364 : free (loop);
391 : }
392 187894 : }
393 :
394 :
395 : static void
396 255556 : set_ss_loop (gfc_ss *ss, gfc_loopinfo *loop)
397 : {
398 255556 : int n;
399 :
400 575440 : for (; ss != gfc_ss_terminator; ss = ss->next)
401 : {
402 319884 : ss->loop = loop;
403 :
404 319884 : if (ss->info->type == GFC_SS_SCALAR
405 : || ss->info->type == GFC_SS_REFERENCE
406 270303 : || ss->info->type == GFC_SS_TEMP)
407 61411 : continue;
408 :
409 4135568 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
410 3877095 : if (ss->info->data.array.subscript[n] != NULL)
411 7623 : set_ss_loop (ss->info->data.array.subscript[n], loop);
412 : }
413 255556 : }
414 :
415 :
416 : /* Associate a SS chain with a loop. */
417 :
418 : void
419 247933 : gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
420 : {
421 247933 : gfc_ss *ss;
422 247933 : gfc_loopinfo *nested_loop;
423 :
424 247933 : if (head == gfc_ss_terminator)
425 : return;
426 :
427 247933 : set_ss_loop (head, loop);
428 :
429 247933 : ss = head;
430 808127 : for (; ss && ss != gfc_ss_terminator; ss = ss->next)
431 : {
432 312261 : if (ss->nested_ss)
433 : {
434 4740 : nested_loop = ss->nested_ss->loop;
435 :
436 : /* More than one ss can belong to the same loop. Hence, we add the
437 : loop to the chain only if it is different from the previously
438 : added one, to avoid duplicate nested loops. */
439 4740 : if (nested_loop != loop->nested)
440 : {
441 3364 : gcc_assert (nested_loop->parent == NULL);
442 3364 : nested_loop->parent = loop;
443 :
444 3364 : gcc_assert (nested_loop->next == NULL);
445 3364 : nested_loop->next = loop->nested;
446 3364 : loop->nested = nested_loop;
447 : }
448 : else
449 1376 : gcc_assert (nested_loop->parent == loop);
450 : }
451 :
452 312261 : if (ss->next == gfc_ss_terminator)
453 247933 : ss->loop_chain = loop->ss;
454 : else
455 : ss->loop_chain = ss->next;
456 : }
457 247933 : gcc_assert (ss == gfc_ss_terminator);
458 247933 : loop->ss = head;
459 : }
460 :
461 :
462 : /* Returns true if the expression is an array pointer. The tree must be a
463 : descriptor. */
464 :
465 : static bool
466 551975 : is_pointer_array (tree expr)
467 : {
468 551975 : if (expr == NULL_TREE
469 551975 : || !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr))
470 677808 : || GFC_CLASS_TYPE_P (TREE_TYPE (expr)))
471 : return false;
472 :
473 125833 : if (VAR_P (expr)
474 125833 : && GFC_DECL_PTR_ARRAY_P (expr))
475 : return true;
476 :
477 118370 : if (TREE_CODE (expr) == PARM_DECL
478 118370 : && GFC_DECL_PTR_ARRAY_P (expr))
479 : return true;
480 :
481 118370 : if (INDIRECT_REF_P (expr)
482 118370 : && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 0)))
483 : return true;
484 :
485 : /* The field declaration is marked as a pointer array. */
486 115813 : if (TREE_CODE (expr) == COMPONENT_REF
487 115813 : && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 1)))
488 3915 : return true;
489 :
490 : return false;
491 : }
492 :
493 :
494 : /* If the elements of the array are spaced by the span of its descriptor,
495 : return the decl that provides that span, otherwise NULL_TREE. This is
496 : either a descriptor or the local decl of a descriptorless dummy array,
497 : which keeps the descriptor it was built from as the saved one. */
498 :
499 : static bool
500 551975 : is_span_addressed_array (tree expr)
501 : {
502 551975 : if (is_pointer_array (expr))
503 : {
504 : /* For classes, index arrays using the size from the virtual pointer if
505 : the array is contiguous. Otherwise use the span. */
506 13935 : if (TREE_CODE (expr) == COMPONENT_REF
507 3915 : && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (expr, 0)))
508 14161 : && TYPE_LANG_SPECIFIC (TREE_TYPE (expr)))
509 : {
510 226 : switch (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (expr)))
511 : {
512 : case GFC_ARRAY_ASSUMED_SHAPE_CONT:
513 : case GFC_ARRAY_ASSUMED_RANK_CONT:
514 : case GFC_ARRAY_ASSUMED_RANK_ALLOCATABLE:
515 : case GFC_ARRAY_ASSUMED_RANK_POINTER_CONT:
516 : case GFC_ARRAY_ALLOCATABLE:
517 : case GFC_ARRAY_POINTER_CONT:
518 : return false;
519 :
520 : default:
521 : break;
522 : }
523 : }
524 :
525 13935 : return true;
526 : }
527 :
528 538040 : if (VAR_P (expr)
529 469731 : && GFC_DECL_PTR_ARRAY_P (expr)
530 246 : && !GFC_DECL_CLASS (expr)
531 246 : && GFC_ARRAY_TYPE_P (TREE_TYPE (expr))
532 246 : && DECL_LANG_SPECIFIC (expr)
533 538286 : && GFC_DECL_SAVED_DESCRIPTOR (expr))
534 246 : return true;
535 :
536 : return false;
537 : }
538 :
539 :
540 : /* Return true if the spacing of the elements of a directly passed actual
541 : argument can be folded into the strides of the dummy's descriptor, so
542 : that the elements are addressed by a constant element length instead of
543 : by the span. */
544 :
545 : bool
546 13219 : gfc_span_folds_into_stride (gfc_symbol *sym)
547 : {
548 13219 : if (!gfc_dummy_requires_direct_arg (sym))
549 : return false;
550 :
551 : /* A character element length is not necessarily constant and a complex or
552 : derived type can be larger than its alignment. */
553 6289 : if (sym->ts.type != BT_INTEGER
554 4773 : && sym->ts.type != BT_REAL
555 1309 : && sym->ts.type != BT_LOGICAL)
556 : return false;
557 :
558 : /* An assumed rank dummy has no strides to fold the spacing into. */
559 4980 : if (!sym->as || sym->as->type != AS_ASSUMED_SHAPE || sym->as->rank < 1)
560 : return false;
561 :
562 4846 : tree etype = gfc_typenode_for_spec (&sym->ts);
563 4846 : tree size = etype ? TYPE_SIZE_UNIT (etype) : NULL_TREE;
564 :
565 4846 : return (size
566 4846 : && tree_fits_uhwi_p (size)
567 9692 : && tree_to_uhwi (size) == min_align_of_type (etype));
568 : }
569 :
570 :
571 : /* Check if a dummy argument must be addressed using the span of its
572 : descriptor. Where the spacing of the elements is folded into the strides
573 : instead, the dummy is addressed like any other array and its descriptor is
574 : built with the element length as span, so it is not span addressed. */
575 :
576 : bool
577 596196 : gfc_is_span_addressed_dummy (gfc_symbol *sym)
578 : {
579 596196 : return gfc_dummy_requires_direct_arg (sym)
580 596196 : && !gfc_span_folds_into_stride (sym);
581 : }
582 :
583 :
584 : /* Set se->expr to a test that the span of the descriptor of ARG is the
585 : element length, ie. that its elements are not subobjects of larger
586 : ones. */
587 :
588 : void
589 90 : gfc_conv_span_is_elem_len (gfc_se *se, gfc_expr *arg)
590 : {
591 90 : gfc_se argse;
592 90 : gfc_ss *ss;
593 :
594 90 : if (arg->ts.type == BT_CLASS)
595 0 : gfc_add_class_array_ref (arg);
596 :
597 90 : ss = gfc_walk_expr (arg);
598 90 : gcc_assert (ss != gfc_ss_terminator);
599 :
600 90 : gfc_init_se (&argse, NULL);
601 90 : argse.data_not_needed = 1;
602 90 : gfc_conv_expr_descriptor (&argse, arg);
603 90 : gfc_add_block_to_block (&se->pre, &argse.pre);
604 90 : gfc_add_block_to_block (&se->post, &argse.post);
605 90 : gfc_free_ss_chain (ss);
606 :
607 90 : tree desc = gfc_evaluate_now (argse.expr, &se->pre);
608 90 : tree span = gfc_conv_descriptor_span_get (desc);
609 90 : tree elem_len = fold_convert (TREE_TYPE (span),
610 : gfc_conv_descriptor_elem_len_get (desc));
611 90 : se->expr = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
612 : span, elem_len);
613 90 : }
614 :
615 :
616 : /* If the symbol or expression reference a CFI descriptor, return the
617 : pointer to the converted gfc descriptor. If an array reference is
618 : present as the last argument, check that it is the one applied to
619 : the CFI descriptor in the expression. Note that the CFI object is
620 : always the symbol in the expression! */
621 :
622 : static bool
623 381631 : get_CFI_desc (gfc_symbol *sym, gfc_expr *expr,
624 : tree *desc, gfc_array_ref *ar)
625 : {
626 381631 : tree tmp;
627 :
628 381631 : if (!is_CFI_desc (sym, expr))
629 : return false;
630 :
631 4727 : if (expr && ar)
632 : {
633 4061 : if (!(expr->ref && expr->ref->type == REF_ARRAY)
634 4043 : || (&expr->ref->u.ar != ar))
635 : return false;
636 : }
637 :
638 4697 : if (sym == NULL)
639 1108 : tmp = expr->symtree->n.sym->backend_decl;
640 : else
641 3589 : tmp = sym->backend_decl;
642 :
643 4697 : if (tmp && DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp))
644 0 : tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
645 :
646 4697 : *desc = tmp;
647 4697 : return true;
648 : }
649 :
650 :
651 : /* A helper function for gfc_get_array_span that returns the array element size
652 : of a class entity. */
653 : static tree
654 1149 : class_array_element_size (tree decl, bool unlimited)
655 : {
656 : /* Class dummys usually require extraction from the saved descriptor,
657 : which gfc_class_vptr_get does for us if necessary. This, of course,
658 : will be a component of the class object. */
659 1149 : tree vptr = gfc_class_vptr_get (decl);
660 : /* If this is an unlimited polymorphic entity with a character payload,
661 : the element size will be corrected for the string length. */
662 1149 : if (unlimited)
663 1058 : return gfc_resize_class_size_with_len (NULL,
664 529 : TREE_OPERAND (vptr, 0),
665 529 : gfc_vptr_size_get (vptr));
666 : else
667 620 : return gfc_vptr_size_get (vptr);
668 : }
669 :
670 :
671 : /* Return the span of an array. */
672 :
673 : tree
674 59733 : gfc_get_array_span (tree desc, gfc_expr *expr)
675 : {
676 59733 : tree tmp;
677 59733 : gfc_symbol *sym = (expr && expr->expr_type == EXPR_VARIABLE) ?
678 52323 : expr->symtree->n.sym : NULL;
679 :
680 59733 : if (tree span = GFC_DECL_GET_SPAN (desc))
681 : /* A span addressed dummy loaded its span on entry. */
682 : tmp = span;
683 59589 : else if (is_span_addressed_array (desc)
684 59589 : || (get_CFI_desc (NULL, expr, &desc, NULL)
685 1332 : && (POINTER_TYPE_P (TREE_TYPE (desc))
686 666 : ? GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (desc)))
687 0 : : GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))))
688 : /* This will have the span field set. */
689 632 : tmp = gfc_conv_descriptor_span_get (gfc_get_span_descriptor (desc));
690 58957 : else if (expr->ts.type == BT_ASSUMED)
691 : {
692 127 : if (DECL_LANG_SPECIFIC (desc) && GFC_DECL_SAVED_DESCRIPTOR (desc))
693 127 : desc = GFC_DECL_SAVED_DESCRIPTOR (desc);
694 127 : if (POINTER_TYPE_P (TREE_TYPE (desc)))
695 127 : desc = build_fold_indirect_ref_loc (input_location, desc);
696 127 : tmp = gfc_conv_descriptor_span_get (desc);
697 : }
698 58830 : else if (TREE_CODE (desc) == COMPONENT_REF
699 497 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
700 58935 : && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (desc, 0))))
701 : /* The descriptor is the _data field of a class object. */
702 32 : tmp = class_array_element_size (TREE_OPERAND (desc, 0),
703 32 : UNLIMITED_POLY (expr));
704 58798 : else if (sym && sym->ts.type == BT_CLASS
705 1173 : && expr->ref->type == REF_COMPONENT
706 1173 : && expr->ref->next->type == REF_ARRAY
707 1173 : && expr->ref->next->next == NULL
708 1155 : && CLASS_DATA (sym)->attr.dimension)
709 : /* Having escaped the above, this can only be a class array dummy. */
710 1117 : tmp = class_array_element_size (sym->backend_decl,
711 1117 : UNLIMITED_POLY (sym));
712 : else
713 : {
714 : /* If none of the fancy stuff works, the span is the element
715 : size of the array. Attempt to deal with unbounded character
716 : types if possible. Otherwise, return NULL_TREE. */
717 57681 : tmp = gfc_get_element_type (TREE_TYPE (desc));
718 57681 : if (tmp && TREE_CODE (tmp) == ARRAY_TYPE && TYPE_STRING_FLAG (tmp))
719 : {
720 11017 : gcc_assert (expr->ts.type == BT_CHARACTER);
721 :
722 11017 : tmp = gfc_get_character_len_in_bytes (tmp);
723 :
724 11017 : if (tmp == NULL_TREE || integer_zerop (tmp))
725 : {
726 68 : tree bs;
727 :
728 68 : tmp = gfc_get_expr_charlen (expr);
729 68 : tmp = fold_convert (gfc_array_index_type, tmp);
730 68 : bs = build_int_cst (gfc_array_index_type, expr->ts.kind);
731 68 : tmp = fold_build2_loc (input_location, MULT_EXPR,
732 : gfc_array_index_type, tmp, bs);
733 : }
734 :
735 21966 : tmp = (tmp && !integer_zerop (tmp))
736 21966 : ? (fold_convert (gfc_array_index_type, tmp)) : (NULL_TREE);
737 : }
738 : else
739 46664 : tmp = fold_convert (gfc_array_index_type,
740 : size_in_bytes (tmp));
741 : }
742 59733 : return tmp;
743 : }
744 :
745 :
746 : /* Generate an initializer for a static pointer or allocatable array. */
747 :
748 : void
749 276 : gfc_trans_static_array_pointer (gfc_symbol * sym)
750 : {
751 276 : tree type;
752 :
753 276 : gcc_assert (TREE_STATIC (sym->backend_decl));
754 : /* Just zero the data member. */
755 276 : type = TREE_TYPE (sym->backend_decl);
756 276 : DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
757 276 : }
758 :
759 :
760 : /* If the bounds of SE's loop have not yet been set, see if they can be
761 : determined from array spec AS, which is the array spec of a called
762 : function. MAPPING maps the callee's dummy arguments to the values
763 : that the caller is passing. Add any initialization and finalization
764 : code to SE. */
765 :
766 : void
767 8949 : gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
768 : gfc_se * se, gfc_array_spec * as)
769 : {
770 8949 : int n, dim, total_dim;
771 8949 : gfc_se tmpse;
772 8949 : gfc_ss *ss;
773 8949 : tree lower;
774 8949 : tree upper;
775 8949 : tree tmp;
776 :
777 8949 : total_dim = 0;
778 :
779 8949 : if (!as || as->type != AS_EXPLICIT)
780 7788 : return;
781 :
782 2347 : for (ss = se->ss; ss; ss = ss->parent)
783 : {
784 1186 : total_dim += ss->loop->dimen;
785 2727 : for (n = 0; n < ss->loop->dimen; n++)
786 : {
787 : /* The bound is known, nothing to do. */
788 1541 : if (ss->loop->to[n] != NULL_TREE)
789 485 : continue;
790 :
791 1056 : dim = ss->dim[n];
792 1056 : gcc_assert (dim < as->rank);
793 1056 : gcc_assert (ss->loop->dimen <= as->rank);
794 :
795 : /* Evaluate the lower bound. */
796 1056 : gfc_init_se (&tmpse, NULL);
797 1056 : gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
798 1056 : gfc_add_block_to_block (&se->pre, &tmpse.pre);
799 1056 : gfc_add_block_to_block (&se->post, &tmpse.post);
800 1056 : lower = fold_convert (gfc_array_index_type, tmpse.expr);
801 :
802 : /* ...and the upper bound. */
803 1056 : gfc_init_se (&tmpse, NULL);
804 1056 : gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
805 1056 : gfc_add_block_to_block (&se->pre, &tmpse.pre);
806 1056 : gfc_add_block_to_block (&se->post, &tmpse.post);
807 1056 : upper = fold_convert (gfc_array_index_type, tmpse.expr);
808 :
809 : /* Set the upper bound of the loop to UPPER - LOWER. */
810 1056 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
811 : gfc_array_index_type, upper, lower);
812 1056 : tmp = gfc_evaluate_now (tmp, &se->pre);
813 1056 : ss->loop->to[n] = tmp;
814 : }
815 : }
816 :
817 1161 : gcc_assert (total_dim == as->rank);
818 : }
819 :
820 :
821 : /* Generate code to allocate an array temporary, or create a variable to
822 : hold the data. If size is NULL, zero the descriptor so that the
823 : callee will allocate the array. If DEALLOC is true, also generate code to
824 : free the array afterwards.
825 :
826 : If INITIAL is not NULL, it is packed using internal_pack and the result used
827 : as data instead of allocating a fresh, uninitialized area of memory.
828 :
829 : Initialization code is added to PRE and finalization code to POST.
830 : DYNAMIC is true if the caller may want to extend the array later
831 : using realloc. This prevents us from putting the array on the stack. */
832 :
833 : static void
834 28770 : gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
835 : gfc_array_info * info, tree size, tree nelem,
836 : tree initial, bool dynamic, bool dealloc)
837 : {
838 28770 : tree tmp;
839 28770 : tree desc;
840 28770 : bool onstack;
841 :
842 28770 : desc = info->descriptor;
843 28770 : info->offset = gfc_index_zero_node;
844 28770 : if (size == NULL_TREE || (dynamic && integer_zerop (size)))
845 : {
846 : /* A callee allocated array. */
847 3051 : gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
848 3051 : onstack = false;
849 : }
850 : else
851 : {
852 : /* Allocate the temporary. */
853 51438 : onstack = !dynamic && initial == NULL_TREE
854 25719 : && (flag_stack_arrays
855 25334 : || gfc_can_put_var_on_stack (size));
856 :
857 5361 : if (onstack)
858 : {
859 : /* Make a temporary variable to hold the data. */
860 20358 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (nelem),
861 : nelem, gfc_index_one_node);
862 20358 : tmp = gfc_evaluate_now (tmp, pre);
863 20358 : tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
864 : tmp);
865 20358 : tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
866 : tmp);
867 20358 : tmp = gfc_create_var (tmp, "A");
868 : /* If we're here only because of -fstack-arrays we have to
869 : emit a DECL_EXPR to make the gimplifier emit alloca calls. */
870 20358 : if (!gfc_can_put_var_on_stack (size))
871 17 : gfc_add_expr_to_block (pre,
872 : fold_build1_loc (input_location,
873 17 : DECL_EXPR, TREE_TYPE (tmp),
874 : tmp));
875 20358 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
876 20358 : gfc_conv_descriptor_data_set (pre, desc, tmp);
877 : }
878 : else
879 : {
880 : /* Allocate memory to hold the data or call internal_pack. */
881 5361 : if (initial == NULL_TREE)
882 : {
883 5218 : tmp = gfc_call_malloc (pre, NULL, size);
884 5218 : tmp = gfc_evaluate_now (tmp, pre);
885 : }
886 : else
887 : {
888 143 : tree packed;
889 143 : tree source_data;
890 143 : tree was_packed;
891 143 : stmtblock_t do_copying;
892 :
893 143 : tmp = TREE_TYPE (initial); /* Pointer to descriptor. */
894 143 : gcc_assert (TREE_CODE (tmp) == POINTER_TYPE);
895 143 : tmp = TREE_TYPE (tmp); /* The descriptor itself. */
896 143 : tmp = gfc_get_element_type (tmp);
897 143 : packed = gfc_create_var (build_pointer_type (tmp), "data");
898 :
899 143 : tmp = build_call_expr_loc (input_location,
900 : gfor_fndecl_in_pack, 1, initial);
901 143 : tmp = fold_convert (TREE_TYPE (packed), tmp);
902 143 : gfc_add_modify (pre, packed, tmp);
903 :
904 143 : tmp = build_fold_indirect_ref_loc (input_location,
905 : initial);
906 143 : source_data = gfc_conv_descriptor_data_get (tmp);
907 :
908 : /* internal_pack may return source->data without any allocation
909 : or copying if it is already packed. If that's the case, we
910 : need to allocate and copy manually. */
911 :
912 143 : gfc_start_block (&do_copying);
913 143 : tmp = gfc_call_malloc (&do_copying, NULL, size);
914 143 : tmp = fold_convert (TREE_TYPE (packed), tmp);
915 143 : gfc_add_modify (&do_copying, packed, tmp);
916 143 : tmp = gfc_build_memcpy_call (packed, source_data, size);
917 143 : gfc_add_expr_to_block (&do_copying, tmp);
918 :
919 143 : was_packed = fold_build2_loc (input_location, EQ_EXPR,
920 : logical_type_node, packed,
921 : source_data);
922 143 : tmp = gfc_finish_block (&do_copying);
923 143 : tmp = build3_v (COND_EXPR, was_packed, tmp,
924 : build_empty_stmt (input_location));
925 143 : gfc_add_expr_to_block (pre, tmp);
926 :
927 143 : tmp = fold_convert (pvoid_type_node, packed);
928 : }
929 :
930 5361 : gfc_conv_descriptor_data_set (pre, desc, tmp);
931 : }
932 : }
933 28770 : info->data = gfc_conv_descriptor_data_get (desc);
934 :
935 : /* The offset is zero because we create temporaries with a zero
936 : lower bound. */
937 28770 : gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node);
938 :
939 28770 : if (dealloc && !onstack)
940 : {
941 : /* Free the temporary. */
942 7994 : tmp = gfc_conv_descriptor_data_get (desc);
943 7994 : tmp = gfc_call_free (tmp);
944 7994 : gfc_add_expr_to_block (post, tmp);
945 : }
946 28770 : }
947 :
948 :
949 : /* Get the scalarizer array dimension corresponding to actual array dimension
950 : given by ARRAY_DIM.
951 :
952 : For example, if SS represents the array ref a(1,:,:,1), it is a
953 : bidimensional scalarizer array, and the result would be 0 for ARRAY_DIM=1,
954 : and 1 for ARRAY_DIM=2.
955 : If SS represents transpose(a(:,1,1,:)), it is again a bidimensional
956 : scalarizer array, and the result would be 1 for ARRAY_DIM=0 and 0 for
957 : ARRAY_DIM=3.
958 : If SS represents sum(a(:,:,:,1), dim=1), it is a 2+1-dimensional scalarizer
959 : array. If called on the inner ss, the result would be respectively 0,1,2 for
960 : ARRAY_DIM=0,1,2. If called on the outer ss, the result would be 0,1
961 : for ARRAY_DIM=1,2. */
962 :
963 : static int
964 266981 : get_scalarizer_dim_for_array_dim (gfc_ss *ss, int array_dim)
965 : {
966 266981 : int array_ref_dim;
967 266981 : int n;
968 :
969 266981 : array_ref_dim = 0;
970 :
971 540095 : for (; ss; ss = ss->parent)
972 700557 : for (n = 0; n < ss->dimen; n++)
973 427443 : if (ss->dim[n] < array_dim)
974 77336 : array_ref_dim++;
975 :
976 266981 : return array_ref_dim;
977 : }
978 :
979 :
980 : static gfc_ss *
981 225374 : innermost_ss (gfc_ss *ss)
982 : {
983 416260 : while (ss->nested_ss != NULL)
984 : ss = ss->nested_ss;
985 :
986 408052 : return ss;
987 : }
988 :
989 :
990 :
991 : /* Get the array reference dimension corresponding to the given loop dimension.
992 : It is different from the true array dimension given by the dim array in
993 : the case of a partial array reference (i.e. a(:,:,1,:) for example)
994 : It is different from the loop dimension in the case of a transposed array.
995 : */
996 :
997 : static int
998 225374 : get_array_ref_dim_for_loop_dim (gfc_ss *ss, int loop_dim)
999 : {
1000 225374 : return get_scalarizer_dim_for_array_dim (innermost_ss (ss),
1001 225374 : ss->dim[loop_dim]);
1002 : }
1003 :
1004 :
1005 : /* Use the information in the ss to obtain the required information about
1006 : the type and size of an array temporary, when the lhs in an assignment
1007 : is a class expression. */
1008 :
1009 : static tree
1010 327 : get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype,
1011 : gfc_ss **fcnss)
1012 : {
1013 327 : gfc_ss *loop_ss = ss->loop->ss;
1014 327 : gfc_ss *lhs_ss;
1015 327 : gfc_ss *rhs_ss;
1016 327 : gfc_ss *fcn_ss = NULL;
1017 327 : tree tmp;
1018 327 : tree tmp2;
1019 327 : tree vptr;
1020 327 : tree class_expr = NULL_TREE;
1021 327 : tree lhs_class_expr = NULL_TREE;
1022 327 : bool unlimited_rhs = false;
1023 327 : bool unlimited_lhs = false;
1024 327 : bool rhs_function = false;
1025 327 : bool unlimited_arg1 = false;
1026 327 : gfc_symbol *vtab;
1027 327 : tree cntnr = NULL_TREE;
1028 :
1029 : /* The second element in the loop chain contains the source for the
1030 : class temporary created in gfc_trans_create_temp_array. */
1031 327 : rhs_ss = loop_ss->loop_chain;
1032 :
1033 327 : if (rhs_ss != gfc_ss_terminator
1034 303 : && rhs_ss->info
1035 303 : && rhs_ss->info->expr
1036 303 : && rhs_ss->info->expr->ts.type == BT_CLASS
1037 182 : && rhs_ss->info->data.array.descriptor)
1038 : {
1039 170 : if (rhs_ss->info->expr->expr_type != EXPR_VARIABLE)
1040 56 : class_expr
1041 56 : = gfc_get_class_from_expr (rhs_ss->info->data.array.descriptor);
1042 : else
1043 114 : class_expr = gfc_get_class_from_gfc_expr (rhs_ss->info->expr);
1044 170 : unlimited_rhs = UNLIMITED_POLY (rhs_ss->info->expr);
1045 170 : if (rhs_ss->info->expr->expr_type == EXPR_FUNCTION)
1046 : rhs_function = true;
1047 : }
1048 :
1049 : /* Usually, ss points to the function. When the function call is an actual
1050 : argument, it is instead rhs_ss because the ss chain is shifted by one. */
1051 327 : *fcnss = fcn_ss = rhs_function ? rhs_ss : ss;
1052 :
1053 : /* If this is a transformational function with a class result, the info
1054 : class_container field points to the class container of arg1. */
1055 327 : if (class_expr != NULL_TREE
1056 151 : && fcn_ss->info && fcn_ss->info->expr
1057 91 : && fcn_ss->info->expr->expr_type == EXPR_FUNCTION
1058 91 : && fcn_ss->info->expr->value.function.isym
1059 60 : && fcn_ss->info->expr->value.function.isym->transformational)
1060 : {
1061 60 : cntnr = ss->info->class_container;
1062 60 : unlimited_arg1
1063 60 : = UNLIMITED_POLY (fcn_ss->info->expr->value.function.actual->expr);
1064 : }
1065 :
1066 : /* For an assignment the lhs is the next element in the loop chain.
1067 : If we have a class rhs, this had better be a class variable
1068 : expression! Otherwise, the class container from arg1 can be used
1069 : to set the vptr and len fields of the result class container. */
1070 327 : lhs_ss = rhs_ss->loop_chain;
1071 327 : if (lhs_ss && lhs_ss != gfc_ss_terminator
1072 225 : && lhs_ss->info && lhs_ss->info->expr
1073 225 : && lhs_ss->info->expr->expr_type ==EXPR_VARIABLE
1074 225 : && lhs_ss->info->expr->ts.type == BT_CLASS)
1075 : {
1076 225 : tmp = lhs_ss->info->data.array.descriptor;
1077 225 : unlimited_lhs = UNLIMITED_POLY (rhs_ss->info->expr);
1078 : }
1079 102 : else if (cntnr != NULL_TREE)
1080 : {
1081 54 : tmp = gfc_class_vptr_get (class_expr);
1082 54 : gfc_add_modify (pre, tmp, fold_convert (TREE_TYPE (tmp),
1083 : gfc_class_vptr_get (cntnr)));
1084 54 : if (unlimited_rhs)
1085 : {
1086 6 : tmp = gfc_class_len_get (class_expr);
1087 6 : if (unlimited_arg1)
1088 6 : gfc_add_modify (pre, tmp, gfc_class_len_get (cntnr));
1089 : }
1090 : tmp = NULL_TREE;
1091 : }
1092 : else
1093 : tmp = NULL_TREE;
1094 :
1095 : /* Get the lhs class expression. */
1096 231 : if (tmp != NULL_TREE && lhs_ss->loop_chain == gfc_ss_terminator)
1097 213 : lhs_class_expr = gfc_get_class_from_expr (tmp);
1098 : else
1099 : return class_expr;
1100 :
1101 213 : gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (lhs_class_expr)));
1102 :
1103 : /* Set the lhs vptr and, if necessary, the _len field. */
1104 213 : if (class_expr)
1105 : {
1106 : /* Both lhs and rhs are class expressions. */
1107 79 : tmp = gfc_class_vptr_get (lhs_class_expr);
1108 158 : gfc_add_modify (pre, tmp,
1109 79 : fold_convert (TREE_TYPE (tmp),
1110 : gfc_class_vptr_get (class_expr)));
1111 79 : if (unlimited_lhs)
1112 : {
1113 31 : gcc_assert (unlimited_rhs);
1114 31 : tmp = gfc_class_len_get (lhs_class_expr);
1115 31 : tmp2 = gfc_class_len_get (class_expr);
1116 31 : gfc_add_modify (pre, tmp, tmp2);
1117 : }
1118 : }
1119 134 : else if (rhs_ss->info->data.array.descriptor)
1120 : {
1121 : /* lhs is class and rhs is intrinsic or derived type. */
1122 128 : *eltype = TREE_TYPE (rhs_ss->info->data.array.descriptor);
1123 128 : *eltype = gfc_get_element_type (*eltype);
1124 128 : vtab = gfc_find_vtab (&rhs_ss->info->expr->ts);
1125 128 : vptr = vtab->backend_decl;
1126 128 : if (vptr == NULL_TREE)
1127 24 : vptr = gfc_get_symbol_decl (vtab);
1128 128 : vptr = gfc_build_addr_expr (NULL_TREE, vptr);
1129 128 : tmp = gfc_class_vptr_get (lhs_class_expr);
1130 128 : gfc_add_modify (pre, tmp,
1131 128 : fold_convert (TREE_TYPE (tmp), vptr));
1132 :
1133 128 : if (unlimited_lhs)
1134 : {
1135 0 : tmp = gfc_class_len_get (lhs_class_expr);
1136 0 : if (rhs_ss->info
1137 0 : && rhs_ss->info->expr
1138 0 : && rhs_ss->info->expr->ts.type == BT_CHARACTER)
1139 0 : tmp2 = build_int_cst (TREE_TYPE (tmp),
1140 0 : rhs_ss->info->expr->ts.kind);
1141 : else
1142 0 : tmp2 = build_int_cst (TREE_TYPE (tmp), 0);
1143 0 : gfc_add_modify (pre, tmp, tmp2);
1144 : }
1145 : }
1146 :
1147 : return class_expr;
1148 : }
1149 :
1150 :
1151 :
1152 : /* Generate code to create and initialize the descriptor for a temporary
1153 : array. This is used for both temporaries needed by the scalarizer, and
1154 : functions returning arrays. Adjusts the loop variables to be
1155 : zero-based, and calculates the loop bounds for callee allocated arrays.
1156 : Allocate the array unless it's callee allocated (we have a callee
1157 : allocated array if 'callee_alloc' is true, or if loop->to[n] is
1158 : NULL_TREE for any n). Also fills in the descriptor, data and offset
1159 : fields of info if known. Returns the size of the array, or NULL for a
1160 : callee allocated array.
1161 :
1162 : 'eltype' == NULL signals that the temporary should be a class object.
1163 : The 'initial' expression is used to obtain the size of the dynamic
1164 : type; otherwise the allocation and initialization proceeds as for any
1165 : other expression
1166 :
1167 : PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
1168 : gfc_trans_allocate_array_storage. */
1169 :
1170 : tree
1171 28770 : gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
1172 : tree eltype, tree initial, bool dynamic,
1173 : bool dealloc, bool callee_alloc, locus * where)
1174 : {
1175 28770 : gfc_loopinfo *loop;
1176 28770 : gfc_ss *s;
1177 28770 : gfc_array_info *info;
1178 28770 : tree from[GFC_MAX_DIMENSIONS], to[GFC_MAX_DIMENSIONS];
1179 28770 : tree type;
1180 28770 : tree desc;
1181 28770 : tree tmp;
1182 28770 : tree size;
1183 28770 : tree nelem;
1184 28770 : tree cond;
1185 28770 : tree or_expr;
1186 28770 : tree elemsize;
1187 28770 : tree class_expr = NULL_TREE;
1188 28770 : gfc_ss *fcn_ss = NULL;
1189 28770 : int n, dim, tmp_dim;
1190 28770 : int total_dim = 0;
1191 :
1192 : /* This signals a class array for which we need the size of the
1193 : dynamic type. Generate an eltype and then the class expression. */
1194 28770 : if (eltype == NULL_TREE && initial)
1195 : {
1196 0 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial)));
1197 0 : class_expr = build_fold_indirect_ref_loc (input_location, initial);
1198 : /* Obtain the structure (class) expression. */
1199 0 : class_expr = gfc_get_class_from_expr (class_expr);
1200 0 : gcc_assert (class_expr);
1201 : }
1202 :
1203 : /* Otherwise, some expressions, such as class functions, arising from
1204 : dependency checking in assignments come here with class element type.
1205 : The descriptor can be obtained from the ss->info and then converted
1206 : to the class object. */
1207 28770 : if (class_expr == NULL_TREE && GFC_CLASS_TYPE_P (eltype))
1208 327 : class_expr = get_class_info_from_ss (pre, ss, &eltype, &fcn_ss);
1209 :
1210 : /* If the dynamic type is not available, use the declared type. */
1211 28770 : if (eltype && GFC_CLASS_TYPE_P (eltype))
1212 199 : eltype = gfc_get_element_type (TREE_TYPE (TYPE_FIELDS (eltype)));
1213 :
1214 28770 : if (class_expr == NULL_TREE)
1215 28619 : elemsize = fold_convert (gfc_array_index_type,
1216 : TYPE_SIZE_UNIT (eltype));
1217 : else
1218 : {
1219 : /* Unlimited polymorphic entities are initialised with NULL vptr. They
1220 : can be tested for by checking if the len field is present. If so
1221 : test the vptr before using the vtable size. */
1222 151 : tmp = gfc_class_vptr_get (class_expr);
1223 151 : tmp = fold_build2_loc (input_location, NE_EXPR,
1224 : logical_type_node,
1225 151 : tmp, build_int_cst (TREE_TYPE (tmp), 0));
1226 151 : elemsize = fold_build3_loc (input_location, COND_EXPR,
1227 : gfc_array_index_type,
1228 : tmp,
1229 : gfc_class_vtab_size_get (class_expr),
1230 : gfc_index_zero_node);
1231 151 : elemsize = gfc_evaluate_now (elemsize, pre);
1232 151 : elemsize = gfc_resize_class_size_with_len (pre, class_expr, elemsize);
1233 : /* Casting the data as a character of the dynamic length ensures that
1234 : assignment of elements works when needed. */
1235 151 : eltype = gfc_get_character_type_len (1, elemsize);
1236 : }
1237 :
1238 28770 : memset (from, 0, sizeof (from));
1239 28770 : memset (to, 0, sizeof (to));
1240 :
1241 28770 : info = &ss->info->data.array;
1242 :
1243 28770 : gcc_assert (ss->dimen > 0);
1244 28770 : gcc_assert (ss->loop->dimen == ss->dimen);
1245 :
1246 28770 : if (warn_array_temporaries && where)
1247 207 : gfc_warning (OPT_Warray_temporaries,
1248 : "Creating array temporary at %L", where);
1249 :
1250 : /* Set the lower bound to zero. */
1251 57575 : for (s = ss; s; s = s->parent)
1252 : {
1253 28805 : loop = s->loop;
1254 :
1255 28805 : total_dim += loop->dimen;
1256 66874 : for (n = 0; n < loop->dimen; n++)
1257 : {
1258 38069 : dim = s->dim[n];
1259 :
1260 : /* Callee allocated arrays may not have a known bound yet. */
1261 38069 : if (loop->to[n])
1262 34536 : loop->to[n] = gfc_evaluate_now (
1263 : fold_build2_loc (input_location, MINUS_EXPR,
1264 : gfc_array_index_type,
1265 : loop->to[n], loop->from[n]),
1266 : pre);
1267 38069 : loop->from[n] = gfc_index_zero_node;
1268 :
1269 : /* We have just changed the loop bounds, we must clear the
1270 : corresponding specloop, so that delta calculation is not skipped
1271 : later in gfc_set_delta. */
1272 38069 : loop->specloop[n] = NULL;
1273 :
1274 : /* We are constructing the temporary's descriptor based on the loop
1275 : dimensions. As the dimensions may be accessed in arbitrary order
1276 : (think of transpose) the size taken from the n'th loop may not map
1277 : to the n'th dimension of the array. We need to reconstruct loop
1278 : infos in the right order before using it to set the descriptor
1279 : bounds. */
1280 38069 : tmp_dim = get_scalarizer_dim_for_array_dim (ss, dim);
1281 38069 : from[tmp_dim] = loop->from[n];
1282 38069 : to[tmp_dim] = loop->to[n];
1283 :
1284 38069 : info->delta[dim] = gfc_index_zero_node;
1285 38069 : info->start[dim] = gfc_index_zero_node;
1286 38069 : info->end[dim] = gfc_index_zero_node;
1287 38069 : info->stride[dim] = gfc_index_one_node;
1288 : }
1289 : }
1290 :
1291 : /* Initialize the descriptor. */
1292 28770 : type =
1293 28770 : gfc_get_array_type_bounds (eltype, total_dim, 0, from, to, 1,
1294 : GFC_ARRAY_UNKNOWN, true);
1295 28770 : desc = gfc_create_var (type, "atmp");
1296 28770 : GFC_DECL_PACKED_ARRAY (desc) = 1;
1297 :
1298 : /* Emit a DECL_EXPR for the variable sized array type in
1299 : GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
1300 : sizes works correctly. */
1301 28770 : tree arraytype = TREE_TYPE (GFC_TYPE_ARRAY_DATAPTR_TYPE (type));
1302 28770 : if (! TYPE_NAME (arraytype))
1303 28770 : TYPE_NAME (arraytype) = build_decl (UNKNOWN_LOCATION, TYPE_DECL,
1304 : NULL_TREE, arraytype);
1305 28770 : gfc_add_expr_to_block (pre, build1 (DECL_EXPR,
1306 28770 : arraytype, TYPE_NAME (arraytype)));
1307 :
1308 28770 : if (fcn_ss && fcn_ss->info && fcn_ss->info->class_container)
1309 : {
1310 90 : suppress_warning (desc);
1311 90 : TREE_USED (desc) = 0;
1312 : }
1313 :
1314 28770 : if (class_expr != NULL_TREE
1315 28619 : || (fcn_ss && fcn_ss->info && fcn_ss->info->class_container))
1316 : {
1317 181 : tree class_data;
1318 181 : tree dtype;
1319 181 : gfc_expr *expr1 = fcn_ss ? fcn_ss->info->expr : NULL;
1320 181 : bool rank_changer;
1321 :
1322 : /* Pick out these transformational functions because they change the rank
1323 : or shape of the first argument. This requires that the class type be
1324 : changed, the dtype updated and the correct rank used. */
1325 121 : rank_changer = expr1 && expr1->expr_type == EXPR_FUNCTION
1326 121 : && expr1->value.function.isym
1327 271 : && (expr1->value.function.isym->id == GFC_ISYM_RESHAPE
1328 : || expr1->value.function.isym->id == GFC_ISYM_SPREAD
1329 : || expr1->value.function.isym->id == GFC_ISYM_PACK
1330 : || expr1->value.function.isym->id == GFC_ISYM_UNPACK);
1331 :
1332 : /* Create a class temporary for the result using the lhs class object. */
1333 181 : if (class_expr != NULL_TREE && !rank_changer)
1334 : {
1335 103 : tmp = gfc_create_var (TREE_TYPE (class_expr), "ctmp");
1336 103 : gfc_add_modify (pre, tmp, class_expr);
1337 : }
1338 : else
1339 : {
1340 78 : tree vptr;
1341 78 : class_expr = fcn_ss->info->class_container;
1342 78 : gcc_assert (expr1);
1343 :
1344 : /* Build a new class container using the arg1 class object. The class
1345 : typespec must be rebuilt because the rank might have changed. */
1346 78 : gfc_typespec ts = CLASS_DATA (expr1)->ts;
1347 78 : symbol_attribute attr = CLASS_DATA (expr1)->attr;
1348 78 : gfc_change_class (&ts, &attr, NULL, expr1->rank, 0);
1349 78 : tmp = gfc_create_var (gfc_typenode_for_spec (&ts), "ctmp");
1350 78 : fcn_ss->info->class_container = tmp;
1351 :
1352 : /* Set the vptr and obtain the element size. */
1353 78 : vptr = gfc_class_vptr_get (tmp);
1354 156 : gfc_add_modify (pre, vptr,
1355 78 : fold_convert (TREE_TYPE (vptr),
1356 : gfc_class_vptr_get (class_expr)));
1357 78 : elemsize = gfc_class_vtab_size_get (class_expr);
1358 :
1359 : /* Set the _len field, if necessary. */
1360 78 : if (UNLIMITED_POLY (expr1))
1361 : {
1362 18 : gfc_add_modify (pre, gfc_class_len_get (tmp),
1363 : gfc_class_len_get (class_expr));
1364 18 : elemsize = gfc_resize_class_size_with_len (pre, class_expr,
1365 : elemsize);
1366 : }
1367 :
1368 78 : elemsize = gfc_evaluate_now (elemsize, pre);
1369 : }
1370 :
1371 181 : class_data = gfc_class_data_get (tmp);
1372 :
1373 181 : if (rank_changer)
1374 : {
1375 : /* Take the dtype from the class expression. */
1376 72 : tree class_descr = gfc_class_data_get (class_expr);
1377 72 : dtype = gfc_conv_descriptor_dtype_get (class_descr);
1378 72 : gfc_conv_descriptor_dtype_set (pre, desc, dtype);
1379 :
1380 : /* These transformational functions change the rank. */
1381 72 : gfc_conv_descriptor_rank_set (pre, desc, ss->loop->dimen);
1382 72 : fcn_ss->info->class_container = NULL_TREE;
1383 : }
1384 :
1385 : /* Assign the new descriptor to the _data field. This allows the
1386 : vptr _copy to be used for scalarized assignment since the class
1387 : temporary can be found from the descriptor. */
1388 181 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1389 181 : TREE_TYPE (desc), desc);
1390 181 : gfc_add_modify (pre, class_data, tmp);
1391 :
1392 : /* Point desc to the class _data field. */
1393 181 : desc = class_data;
1394 181 : }
1395 : else
1396 : {
1397 : /* Fill in the array dtype. */
1398 28589 : gfc_conv_descriptor_dtype_set (pre, desc,
1399 28589 : gfc_get_dtype (TREE_TYPE (desc)));
1400 : }
1401 :
1402 28770 : info->descriptor = desc;
1403 28770 : size = gfc_index_one_node;
1404 :
1405 : /*
1406 : Fill in the bounds and stride. This is a packed array, so:
1407 :
1408 : size = 1;
1409 : for (n = 0; n < rank; n++)
1410 : {
1411 : stride[n] = size
1412 : delta = ubound[n] + 1 - lbound[n];
1413 : size = size * delta;
1414 : }
1415 : size = size * sizeof(element);
1416 : */
1417 :
1418 28770 : or_expr = NULL_TREE;
1419 :
1420 : /* If there is at least one null loop->to[n], it is a callee allocated
1421 : array. */
1422 63306 : for (n = 0; n < total_dim; n++)
1423 36715 : if (to[n] == NULL_TREE)
1424 : {
1425 : size = NULL_TREE;
1426 : break;
1427 : }
1428 :
1429 28770 : if (size == NULL_TREE)
1430 4368 : for (s = ss; s; s = s->parent)
1431 5727 : for (n = 0; n < s->loop->dimen; n++)
1432 : {
1433 3538 : dim = get_scalarizer_dim_for_array_dim (ss, s->dim[n]);
1434 :
1435 : /* For a callee allocated array express the loop bounds in terms
1436 : of the descriptor fields. */
1437 3538 : tmp = fold_build2_loc (input_location,
1438 : MINUS_EXPR, gfc_array_index_type,
1439 : gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]),
1440 : gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]));
1441 3538 : s->loop->to[n] = tmp;
1442 : }
1443 : else
1444 : {
1445 61122 : for (n = 0; n < total_dim; n++)
1446 : {
1447 : /* Store the stride and bound components in the descriptor. */
1448 34531 : gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size);
1449 :
1450 34531 : gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
1451 : gfc_index_zero_node);
1452 :
1453 34531 : gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], to[n]);
1454 :
1455 34531 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
1456 : gfc_array_index_type,
1457 : to[n], gfc_index_one_node);
1458 :
1459 : /* Check whether the size for this dimension is negative. */
1460 34531 : cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
1461 : tmp, gfc_index_zero_node);
1462 34531 : cond = gfc_evaluate_now (cond, pre);
1463 :
1464 34531 : if (n == 0)
1465 : or_expr = cond;
1466 : else
1467 7940 : or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1468 : logical_type_node, or_expr, cond);
1469 :
1470 34531 : size = fold_build2_loc (input_location, MULT_EXPR,
1471 : gfc_array_index_type, size, tmp);
1472 34531 : size = gfc_evaluate_now (size, pre);
1473 : }
1474 : }
1475 :
1476 : /* Get the size of the array. */
1477 28770 : if (size && !callee_alloc)
1478 : {
1479 : /* If or_expr is true, then the extent in at least one
1480 : dimension is zero and the size is set to zero. */
1481 26365 : size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
1482 : or_expr, gfc_index_zero_node, size);
1483 :
1484 26365 : nelem = size;
1485 26365 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
1486 : size, elemsize);
1487 : }
1488 : else
1489 : {
1490 : nelem = size;
1491 : size = NULL_TREE;
1492 : }
1493 :
1494 : /* Set the span. */
1495 28770 : tmp = fold_convert (gfc_array_index_type, elemsize);
1496 28770 : gfc_conv_descriptor_span_set (pre, desc, tmp);
1497 :
1498 28770 : gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
1499 : dynamic, dealloc);
1500 :
1501 57575 : while (ss->parent)
1502 : ss = ss->parent;
1503 :
1504 28770 : if (ss->dimen > ss->loop->temp_dim)
1505 24909 : ss->loop->temp_dim = ss->dimen;
1506 :
1507 28770 : return size;
1508 : }
1509 :
1510 :
1511 : /* Return the number of iterations in a loop that starts at START,
1512 : ends at END, and has step STEP. */
1513 :
1514 : static tree
1515 1078 : gfc_get_iteration_count (tree start, tree end, tree step)
1516 : {
1517 1078 : tree tmp;
1518 1078 : tree type;
1519 :
1520 1078 : type = TREE_TYPE (step);
1521 1078 : tmp = fold_build2_loc (input_location, MINUS_EXPR, type, end, start);
1522 1078 : tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, type, tmp, step);
1523 1078 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp,
1524 : build_int_cst (type, 1));
1525 1078 : tmp = fold_build2_loc (input_location, MAX_EXPR, type, tmp,
1526 : build_int_cst (type, 0));
1527 1078 : return fold_convert (gfc_array_index_type, tmp);
1528 : }
1529 :
1530 :
1531 : /* Return true if the bounds of iterator I can only be determined
1532 : at run time. */
1533 :
1534 : static inline bool
1535 2363 : gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
1536 : {
1537 2363 : return (i->start->expr_type != EXPR_CONSTANT
1538 1945 : || i->end->expr_type != EXPR_CONSTANT
1539 2536 : || i->step->expr_type != EXPR_CONSTANT);
1540 : }
1541 :
1542 :
1543 : /* Split the size of constructor element EXPR into the sum of two terms,
1544 : one of which can be determined at compile time and one of which must
1545 : be calculated at run time. Set *SIZE to the former and return true
1546 : if the latter might be nonzero. */
1547 :
1548 : static bool
1549 3290 : gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
1550 : {
1551 3290 : if (expr->expr_type == EXPR_ARRAY)
1552 685 : return gfc_get_array_constructor_size (size, expr->value.constructor);
1553 2605 : else if (expr->rank > 0)
1554 : {
1555 : /* Calculate everything at run time. */
1556 1031 : mpz_set_ui (*size, 0);
1557 1031 : return true;
1558 : }
1559 : else
1560 : {
1561 : /* A single element. */
1562 1574 : mpz_set_ui (*size, 1);
1563 1574 : return false;
1564 : }
1565 : }
1566 :
1567 :
1568 : /* Like gfc_get_array_constructor_element_size, but applied to the whole
1569 : of array constructor C. */
1570 :
1571 : static bool
1572 3030 : gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base)
1573 : {
1574 3030 : gfc_constructor *c;
1575 3030 : gfc_iterator *i;
1576 3030 : mpz_t val;
1577 3030 : mpz_t len;
1578 3030 : bool dynamic;
1579 :
1580 3030 : mpz_set_ui (*size, 0);
1581 3030 : mpz_init (len);
1582 3030 : mpz_init (val);
1583 :
1584 3030 : dynamic = false;
1585 7408 : for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1586 : {
1587 4378 : i = c->iterator;
1588 4378 : if (i && gfc_iterator_has_dynamic_bounds (i))
1589 : dynamic = true;
1590 : else
1591 : {
1592 2739 : dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
1593 2739 : if (i)
1594 : {
1595 : /* Multiply the static part of the element size by the
1596 : number of iterations. */
1597 128 : mpz_sub (val, i->end->value.integer, i->start->value.integer);
1598 128 : mpz_fdiv_q (val, val, i->step->value.integer);
1599 128 : mpz_add_ui (val, val, 1);
1600 128 : if (mpz_sgn (val) > 0)
1601 92 : mpz_mul (len, len, val);
1602 : else
1603 36 : mpz_set_ui (len, 0);
1604 : }
1605 2739 : mpz_add (*size, *size, len);
1606 : }
1607 : }
1608 3030 : mpz_clear (len);
1609 3030 : mpz_clear (val);
1610 3030 : return dynamic;
1611 : }
1612 :
1613 :
1614 : /* Make sure offset is a variable. */
1615 :
1616 : static void
1617 3329 : gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
1618 : tree * offsetvar)
1619 : {
1620 : /* We should have already created the offset variable. We cannot
1621 : create it here because we may be in an inner scope. */
1622 3329 : gcc_assert (*offsetvar != NULL_TREE);
1623 3329 : gfc_add_modify (pblock, *offsetvar, *poffset);
1624 3329 : *poffset = *offsetvar;
1625 3329 : TREE_USED (*offsetvar) = 1;
1626 3329 : }
1627 :
1628 :
1629 : /* Variables needed for bounds-checking. */
1630 : static bool first_len;
1631 : static tree first_len_val;
1632 : static bool typespec_chararray_ctor;
1633 :
1634 : /* Return true if DER has any CLASS allocatable component. Such components
1635 : are initialised by VIEW_CONVERT in structure constructors (a bitwise copy
1636 : of the class descriptor), so their _data pointer may refer to a non-heap
1637 : object and must not be passed to gfc_deallocate_alloc_comp_no_caf. */
1638 :
1639 : static bool
1640 4794 : has_class_alloc_comp (gfc_symbol *der)
1641 : {
1642 12859 : for (gfc_component *c = der->components; c; c = c->next)
1643 8131 : if (c->ts.type == BT_CLASS && !c->attr.class_pointer)
1644 : return true;
1645 : return false;
1646 : }
1647 :
1648 : static void
1649 12974 : gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
1650 : tree offset, gfc_se * se, gfc_expr * expr)
1651 : {
1652 12974 : tree tmp, offset_eval;
1653 :
1654 12974 : gfc_conv_expr (se, expr);
1655 :
1656 : /* Store the value. */
1657 12974 : tmp = build_fold_indirect_ref_loc (input_location,
1658 : gfc_conv_descriptor_data_get (desc));
1659 :
1660 : /* The offset may change, so get its value now and use that to free memory. */
1661 12974 : offset_eval = gfc_evaluate_now (offset, &se->pre);
1662 12974 : tmp = gfc_build_array_ref (tmp, offset_eval, NULL);
1663 :
1664 12974 : if (expr->ts.type == BT_DERIVED
1665 4703 : && (expr->expr_type == EXPR_FUNCTION
1666 4619 : || (expr->expr_type == EXPR_STRUCTURE
1667 4015 : && !has_class_alloc_comp (expr->ts.u.derived)))
1668 17031 : && expr->ts.u.derived->attr.alloc_comp)
1669 800 : gfc_add_expr_to_block (&se->finalblock,
1670 : gfc_deallocate_alloc_comp_no_caf (expr->ts.u.derived,
1671 : tmp, expr->rank,
1672 : true));
1673 :
1674 12974 : if (expr->ts.type == BT_CHARACTER)
1675 : {
1676 2154 : int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
1677 2154 : tree esize;
1678 :
1679 2154 : esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)));
1680 2154 : esize = fold_convert (gfc_charlen_type_node, esize);
1681 4308 : esize = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
1682 2154 : TREE_TYPE (esize), esize,
1683 2154 : build_int_cst (TREE_TYPE (esize),
1684 2154 : gfc_character_kinds[i].bit_size / 8));
1685 :
1686 2154 : gfc_conv_string_parameter (se);
1687 2154 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
1688 : {
1689 : /* The temporary is an array of pointers. */
1690 6 : se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1691 6 : gfc_add_modify (&se->pre, tmp, se->expr);
1692 : }
1693 : else
1694 : {
1695 : /* The temporary is an array of string values. */
1696 2148 : tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp);
1697 : /* We know the temporary and the value will be the same length,
1698 : so can use memcpy. */
1699 2148 : gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind,
1700 : se->string_length, se->expr, expr->ts.kind);
1701 : }
1702 2154 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !typespec_chararray_ctor)
1703 : {
1704 310 : if (first_len)
1705 : {
1706 130 : gfc_add_modify (&se->pre, first_len_val,
1707 130 : fold_convert (TREE_TYPE (first_len_val),
1708 : se->string_length));
1709 130 : first_len = false;
1710 : }
1711 : else
1712 : {
1713 : /* Verify that all constructor elements are of the same
1714 : length. */
1715 180 : tree rhs = fold_convert (TREE_TYPE (first_len_val),
1716 : se->string_length);
1717 180 : tree cond = fold_build2_loc (input_location, NE_EXPR,
1718 : logical_type_node, first_len_val,
1719 : rhs);
1720 180 : gfc_trans_runtime_check
1721 180 : (true, false, cond, &se->pre, &expr->where,
1722 : "Different CHARACTER lengths (%ld/%ld) in array constructor",
1723 : fold_convert (long_integer_type_node, first_len_val),
1724 : fold_convert (long_integer_type_node, se->string_length));
1725 : }
1726 : }
1727 : }
1728 10820 : else if (GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
1729 10820 : && !GFC_CLASS_TYPE_P (gfc_get_element_type (TREE_TYPE (desc))))
1730 : {
1731 : /* Assignment of a CLASS array constructor to a derived type array. */
1732 24 : if (expr->expr_type == EXPR_FUNCTION)
1733 18 : se->expr = gfc_evaluate_now (se->expr, pblock);
1734 24 : se->expr = gfc_class_data_get (se->expr);
1735 24 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
1736 24 : se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1737 24 : gfc_add_modify (&se->pre, tmp, se->expr);
1738 : }
1739 : else
1740 : {
1741 : /* TODO: Should the frontend already have done this conversion? */
1742 10796 : se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1743 10796 : gfc_add_modify (&se->pre, tmp, se->expr);
1744 : }
1745 :
1746 12974 : gfc_add_block_to_block (pblock, &se->pre);
1747 12974 : gfc_add_block_to_block (pblock, &se->post);
1748 12974 : }
1749 :
1750 :
1751 : /* Add the contents of an array to the constructor. DYNAMIC is as for
1752 : gfc_trans_array_constructor_value. */
1753 :
1754 : static void
1755 1141 : gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
1756 : tree type ATTRIBUTE_UNUSED,
1757 : tree desc, gfc_expr * expr,
1758 : tree * poffset, tree * offsetvar,
1759 : bool dynamic)
1760 : {
1761 1141 : gfc_se se;
1762 1141 : gfc_ss *ss;
1763 1141 : gfc_loopinfo loop;
1764 1141 : stmtblock_t body;
1765 1141 : tree tmp;
1766 1141 : tree size;
1767 1141 : int n;
1768 :
1769 : /* We need this to be a variable so we can increment it. */
1770 1141 : gfc_put_offset_into_var (pblock, poffset, offsetvar);
1771 :
1772 1141 : gfc_init_se (&se, NULL);
1773 :
1774 : /* Walk the array expression. */
1775 1141 : ss = gfc_walk_expr (expr);
1776 1141 : gcc_assert (ss != gfc_ss_terminator);
1777 :
1778 : /* Initialize the scalarizer. */
1779 1141 : gfc_init_loopinfo (&loop);
1780 1141 : gfc_add_ss_to_loop (&loop, ss);
1781 :
1782 : /* Initialize the loop. */
1783 1141 : gfc_conv_ss_startstride (&loop);
1784 1141 : gfc_conv_loop_setup (&loop, &expr->where);
1785 :
1786 : /* Make sure the constructed array has room for the new data. */
1787 1141 : if (dynamic)
1788 : {
1789 : /* Set SIZE to the total number of elements in the subarray. */
1790 515 : size = gfc_index_one_node;
1791 1042 : for (n = 0; n < loop.dimen; n++)
1792 : {
1793 527 : tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
1794 : gfc_index_one_node);
1795 527 : size = fold_build2_loc (input_location, MULT_EXPR,
1796 : gfc_array_index_type, size, tmp);
1797 : }
1798 :
1799 : /* Grow the constructed array by SIZE elements. */
1800 515 : gfc_grow_array (&loop.pre, desc, size);
1801 : }
1802 :
1803 : /* Make the loop body. */
1804 1141 : gfc_mark_ss_chain_used (ss, 1);
1805 1141 : gfc_start_scalarized_body (&loop, &body);
1806 1141 : gfc_copy_loopinfo_to_se (&se, &loop);
1807 1141 : se.ss = ss;
1808 :
1809 1141 : gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
1810 1141 : gcc_assert (se.ss == gfc_ss_terminator);
1811 :
1812 : /* Increment the offset. */
1813 1141 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1814 : *poffset, gfc_index_one_node);
1815 1141 : gfc_add_modify (&body, *poffset, tmp);
1816 :
1817 : /* Finish the loop. */
1818 1141 : gfc_trans_scalarizing_loops (&loop, &body);
1819 1141 : gfc_add_block_to_block (&loop.pre, &loop.post);
1820 1141 : tmp = gfc_finish_block (&loop.pre);
1821 1141 : gfc_add_expr_to_block (pblock, tmp);
1822 :
1823 1141 : gfc_cleanup_loop (&loop);
1824 1141 : }
1825 :
1826 :
1827 : /* Return true if every leaf element of an array constructor is a function
1828 : reference returning derived type DER, which has allocatable components.
1829 : Such results are moved (shallow-copied) into the constructor temporary, so
1830 : the temporary owns their allocatable components and they can all be freed
1831 : in a single sweep over the whole temporary. Returns false as soon as an
1832 : element is anything else - notably a variable, whose allocatable components
1833 : are aliased rather than owned by the temporary and must not be freed. */
1834 :
1835 : static bool
1836 521 : gfc_constructor_is_owned_alloc_comp (gfc_constructor_base base,
1837 : gfc_symbol *der)
1838 : {
1839 521 : gfc_constructor *c;
1840 :
1841 521 : if (base == NULL)
1842 : return false;
1843 :
1844 1369 : for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1845 : {
1846 1065 : gfc_expr *e = c->expr;
1847 1065 : if (e->expr_type == EXPR_ARRAY)
1848 : {
1849 54 : if (!gfc_constructor_is_owned_alloc_comp (e->value.constructor, der))
1850 : return false;
1851 : }
1852 1011 : else if (!(e->ts.type == BT_DERIVED
1853 1011 : && (e->expr_type == EXPR_FUNCTION
1854 972 : || (e->expr_type == EXPR_STRUCTURE
1855 779 : && !has_class_alloc_comp (e->ts.u.derived)))
1856 794 : && e->ts.u.derived == der))
1857 : return false;
1858 : }
1859 : return true;
1860 : }
1861 :
1862 :
1863 : /* Assign the values to the elements of an array constructor. DYNAMIC
1864 : is true if descriptor DESC only contains enough data for the static
1865 : size calculated by gfc_get_array_constructor_size. When true, memory
1866 : for the dynamic parts must be allocated using realloc. OWNED_SWEEP is
1867 : true when the caller will free the allocatable components of every
1868 : constructor element in one sweep over the whole temporary; in that case
1869 : the per-element finalization built here is suppressed to avoid a double
1870 : free. */
1871 :
1872 : static void
1873 8467 : gfc_trans_array_constructor_value (stmtblock_t * pblock,
1874 : stmtblock_t * finalblock,
1875 : tree type, tree desc,
1876 : gfc_constructor_base base, tree * poffset,
1877 : tree * offsetvar, bool dynamic,
1878 : bool owned_sweep)
1879 : {
1880 8467 : tree tmp;
1881 8467 : tree start = NULL_TREE;
1882 8467 : tree end = NULL_TREE;
1883 8467 : tree step = NULL_TREE;
1884 8467 : stmtblock_t body;
1885 8467 : gfc_se se;
1886 8467 : mpz_t size;
1887 8467 : gfc_constructor *c;
1888 8467 : gfc_typespec ts;
1889 8467 : int ctr = 0;
1890 :
1891 8467 : tree shadow_loopvar = NULL_TREE;
1892 8467 : gfc_saved_var saved_loopvar;
1893 :
1894 8467 : ts.type = BT_UNKNOWN;
1895 8467 : mpz_init (size);
1896 23057 : for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1897 : {
1898 14590 : ctr++;
1899 : /* If this is an iterator or an array, the offset must be a variable. */
1900 14590 : if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
1901 2188 : gfc_put_offset_into_var (pblock, poffset, offsetvar);
1902 :
1903 : /* Shadowing the iterator avoids changing its value and saves us from
1904 : keeping track of it. Further, it makes sure that there's always a
1905 : backend-decl for the symbol, even if there wasn't one before,
1906 : e.g. in the case of an iterator that appears in a specification
1907 : expression in an interface mapping. */
1908 14590 : if (c->iterator)
1909 : {
1910 1489 : gfc_symbol *sym;
1911 1489 : tree type;
1912 :
1913 : /* Evaluate loop bounds before substituting the loop variable
1914 : in case they depend on it. Such a case is invalid, but it is
1915 : not more expensive to do the right thing here.
1916 : See PR 44354. */
1917 1489 : gfc_init_se (&se, NULL);
1918 1489 : gfc_conv_expr_val (&se, c->iterator->start);
1919 1489 : gfc_add_block_to_block (pblock, &se.pre);
1920 1489 : start = gfc_evaluate_now (se.expr, pblock);
1921 :
1922 1489 : gfc_init_se (&se, NULL);
1923 1489 : gfc_conv_expr_val (&se, c->iterator->end);
1924 1489 : gfc_add_block_to_block (pblock, &se.pre);
1925 1489 : end = gfc_evaluate_now (se.expr, pblock);
1926 :
1927 1489 : gfc_init_se (&se, NULL);
1928 1489 : gfc_conv_expr_val (&se, c->iterator->step);
1929 1489 : gfc_add_block_to_block (pblock, &se.pre);
1930 1489 : step = gfc_evaluate_now (se.expr, pblock);
1931 :
1932 1489 : sym = c->iterator->var->symtree->n.sym;
1933 1489 : type = gfc_typenode_for_spec (&sym->ts);
1934 :
1935 1489 : shadow_loopvar = gfc_create_var (type, "shadow_loopvar");
1936 1489 : gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar);
1937 : }
1938 :
1939 14590 : gfc_start_block (&body);
1940 :
1941 14590 : if (c->expr->expr_type == EXPR_ARRAY)
1942 : {
1943 : /* Array constructors can be nested. */
1944 1511 : gfc_trans_array_constructor_value (&body, finalblock, type,
1945 : desc, c->expr->value.constructor,
1946 : poffset, offsetvar, dynamic,
1947 : owned_sweep);
1948 : }
1949 13079 : else if (c->expr->rank > 0)
1950 : {
1951 1141 : gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
1952 : poffset, offsetvar, dynamic);
1953 : }
1954 : else
1955 : {
1956 : /* This code really upsets the gimplifier so don't bother for now. */
1957 : gfc_constructor *p;
1958 : HOST_WIDE_INT n;
1959 : HOST_WIDE_INT size;
1960 :
1961 : p = c;
1962 : n = 0;
1963 13746 : while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1964 : {
1965 1808 : p = gfc_constructor_next (p);
1966 1808 : n++;
1967 : }
1968 : /* Constructor with few constant elements, or element size not
1969 : known at compile time (e.g. deferred-length character). */
1970 11938 : if (n < 4 || !INTEGER_CST_P (TYPE_SIZE_UNIT (type)))
1971 : {
1972 : /* Scalar values. */
1973 11833 : gfc_init_se (&se, NULL);
1974 11833 : if (IS_PDT (c->expr) && c->expr->expr_type == EXPR_STRUCTURE)
1975 288 : c->expr->must_finalize = 1;
1976 :
1977 11833 : gfc_trans_array_ctor_element (&body, desc, *poffset,
1978 : &se, c->expr);
1979 :
1980 11833 : *poffset = fold_build2_loc (input_location, PLUS_EXPR,
1981 : gfc_array_index_type,
1982 : *poffset, gfc_index_one_node);
1983 : /* Unless the whole temporary is being swept by the caller, add
1984 : the per-element finalization. The sweep is used when every
1985 : element is an owned function result, which is the only way to
1986 : correctly free elements produced inside an implied-do loop. */
1987 11833 : if (finalblock && !owned_sweep)
1988 508 : gfc_add_block_to_block (finalblock, &se.finalblock);
1989 : }
1990 : else
1991 : {
1992 : /* Collect multiple scalar constants into a constructor. */
1993 105 : vec<constructor_elt, va_gc> *v = NULL;
1994 105 : tree init;
1995 105 : tree bound;
1996 105 : tree tmptype;
1997 105 : HOST_WIDE_INT idx = 0;
1998 :
1999 105 : p = c;
2000 : /* Count the number of consecutive scalar constants. */
2001 837 : while (p && !(p->iterator
2002 745 : || p->expr->expr_type != EXPR_CONSTANT))
2003 : {
2004 732 : gfc_init_se (&se, NULL);
2005 732 : gfc_conv_constant (&se, p->expr);
2006 :
2007 732 : if (c->expr->ts.type != BT_CHARACTER)
2008 660 : se.expr = fold_convert (type, se.expr);
2009 : /* For constant character array constructors we build
2010 : an array of pointers. */
2011 72 : else if (POINTER_TYPE_P (type))
2012 0 : se.expr = gfc_build_addr_expr
2013 0 : (gfc_get_pchar_type (p->expr->ts.kind),
2014 : se.expr);
2015 :
2016 732 : CONSTRUCTOR_APPEND_ELT (v,
2017 : build_int_cst (gfc_array_index_type,
2018 : idx++),
2019 : se.expr);
2020 732 : c = p;
2021 732 : p = gfc_constructor_next (p);
2022 : }
2023 :
2024 105 : bound = size_int (n - 1);
2025 : /* Create an array type to hold them. */
2026 105 : tmptype = build_range_type (gfc_array_index_type,
2027 : gfc_index_zero_node, bound);
2028 105 : tmptype = build_array_type (type, tmptype);
2029 :
2030 105 : init = build_constructor (tmptype, v);
2031 105 : TREE_CONSTANT (init) = 1;
2032 105 : TREE_STATIC (init) = 1;
2033 : /* Create a static variable to hold the data. */
2034 105 : tmp = gfc_create_var (tmptype, "data");
2035 105 : TREE_STATIC (tmp) = 1;
2036 105 : TREE_CONSTANT (tmp) = 1;
2037 105 : TREE_READONLY (tmp) = 1;
2038 105 : DECL_INITIAL (tmp) = init;
2039 105 : init = tmp;
2040 :
2041 : /* Use BUILTIN_MEMCPY to assign the values. */
2042 105 : tmp = gfc_conv_descriptor_data_get (desc);
2043 105 : tmp = build_fold_indirect_ref_loc (input_location,
2044 : tmp);
2045 105 : tmp = gfc_build_array_ref (tmp, *poffset, NULL);
2046 105 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
2047 105 : init = gfc_build_addr_expr (NULL_TREE, init);
2048 :
2049 105 : size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
2050 105 : bound = build_int_cst (size_type_node, n * size);
2051 105 : tmp = build_call_expr_loc (input_location,
2052 : builtin_decl_explicit (BUILT_IN_MEMCPY),
2053 : 3, tmp, init, bound);
2054 105 : gfc_add_expr_to_block (&body, tmp);
2055 :
2056 105 : *poffset = fold_build2_loc (input_location, PLUS_EXPR,
2057 : gfc_array_index_type, *poffset,
2058 105 : build_int_cst (gfc_array_index_type, n));
2059 : }
2060 11938 : if (!INTEGER_CST_P (*poffset))
2061 : {
2062 1791 : gfc_add_modify (&body, *offsetvar, *poffset);
2063 1791 : *poffset = *offsetvar;
2064 : }
2065 :
2066 11938 : if (!c->iterator)
2067 11938 : ts = c->expr->ts;
2068 : }
2069 :
2070 : /* The frontend should already have done any expansions
2071 : at compile-time. */
2072 14590 : if (!c->iterator)
2073 : {
2074 : /* Pass the code as is. */
2075 13101 : tmp = gfc_finish_block (&body);
2076 13101 : gfc_add_expr_to_block (pblock, tmp);
2077 : }
2078 : else
2079 : {
2080 : /* Build the implied do-loop. */
2081 1489 : stmtblock_t implied_do_block;
2082 1489 : tree cond;
2083 1489 : tree exit_label;
2084 1489 : tree loopbody;
2085 1489 : tree tmp2;
2086 :
2087 1489 : loopbody = gfc_finish_block (&body);
2088 :
2089 : /* Create a new block that holds the implied-do loop. A temporary
2090 : loop-variable is used. */
2091 1489 : gfc_start_block(&implied_do_block);
2092 :
2093 : /* Initialize the loop. */
2094 1489 : gfc_add_modify (&implied_do_block, shadow_loopvar, start);
2095 :
2096 : /* If this array expands dynamically, and the number of iterations
2097 : is not constant, we won't have allocated space for the static
2098 : part of C->EXPR's size. Do that now. */
2099 1489 : if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
2100 : {
2101 : /* Get the number of iterations. */
2102 551 : tmp = gfc_get_iteration_count (shadow_loopvar, end, step);
2103 :
2104 : /* Get the static part of C->EXPR's size. */
2105 551 : gfc_get_array_constructor_element_size (&size, c->expr);
2106 551 : tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
2107 :
2108 : /* Grow the array by TMP * TMP2 elements. */
2109 551 : tmp = fold_build2_loc (input_location, MULT_EXPR,
2110 : gfc_array_index_type, tmp, tmp2);
2111 551 : gfc_grow_array (&implied_do_block, desc, tmp);
2112 : }
2113 :
2114 : /* Generate the loop body. */
2115 1489 : exit_label = gfc_build_label_decl (NULL_TREE);
2116 1489 : gfc_start_block (&body);
2117 :
2118 : /* Generate the exit condition. Depending on the sign of
2119 : the step variable we have to generate the correct
2120 : comparison. */
2121 1489 : tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2122 1489 : step, build_int_cst (TREE_TYPE (step), 0));
2123 1489 : cond = fold_build3_loc (input_location, COND_EXPR,
2124 : logical_type_node, tmp,
2125 : fold_build2_loc (input_location, GT_EXPR,
2126 : logical_type_node, shadow_loopvar, end),
2127 : fold_build2_loc (input_location, LT_EXPR,
2128 : logical_type_node, shadow_loopvar, end));
2129 1489 : tmp = build1_v (GOTO_EXPR, exit_label);
2130 1489 : TREE_USED (exit_label) = 1;
2131 1489 : tmp = build3_v (COND_EXPR, cond, tmp,
2132 : build_empty_stmt (input_location));
2133 1489 : gfc_add_expr_to_block (&body, tmp);
2134 :
2135 : /* The main loop body. */
2136 1489 : gfc_add_expr_to_block (&body, loopbody);
2137 :
2138 : /* Increase loop variable by step. */
2139 1489 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
2140 1489 : TREE_TYPE (shadow_loopvar), shadow_loopvar,
2141 : step);
2142 1489 : gfc_add_modify (&body, shadow_loopvar, tmp);
2143 :
2144 : /* Finish the loop. */
2145 1489 : tmp = gfc_finish_block (&body);
2146 1489 : tmp = build1_v (LOOP_EXPR, tmp);
2147 1489 : gfc_add_expr_to_block (&implied_do_block, tmp);
2148 :
2149 : /* Add the exit label. */
2150 1489 : tmp = build1_v (LABEL_EXPR, exit_label);
2151 1489 : gfc_add_expr_to_block (&implied_do_block, tmp);
2152 :
2153 : /* Finish the implied-do loop. */
2154 1489 : tmp = gfc_finish_block(&implied_do_block);
2155 1489 : gfc_add_expr_to_block(pblock, tmp);
2156 :
2157 1489 : gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar);
2158 : }
2159 : }
2160 :
2161 : /* F2008 4.5.6.3 para 5: If an executable construct references a structure
2162 : constructor or array constructor, the entity created by the constructor is
2163 : finalized after execution of the innermost executable construct containing
2164 : the reference. This, in fact, was later deleted by the Combined Technical
2165 : Corrigenda 1 TO 4 for fortran 2008 (f08/0011).
2166 :
2167 : Transmit finalization of this constructor through 'finalblock'. */
2168 8467 : if ((gfc_option.allow_std & (GFC_STD_F2008 | GFC_STD_F2003))
2169 8467 : && !(gfc_option.allow_std & GFC_STD_GNU)
2170 70 : && finalblock != NULL
2171 24 : && gfc_may_be_finalized (ts)
2172 18 : && ctr > 0 && desc != NULL_TREE
2173 8485 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
2174 : {
2175 18 : symbol_attribute attr;
2176 18 : gfc_se fse;
2177 18 : locus loc;
2178 18 : gfc_locus_from_location (&loc, input_location);
2179 18 : gfc_warning (0, "The structure constructor at %L has been"
2180 : " finalized. This feature was removed by f08/0011."
2181 : " Use -std=f2018 or -std=gnu to eliminate the"
2182 : " finalization.", &loc);
2183 18 : attr.pointer = attr.allocatable = 0;
2184 18 : gfc_init_se (&fse, NULL);
2185 18 : fse.expr = desc;
2186 18 : gfc_finalize_tree_expr (&fse, ts.u.derived, attr, 1);
2187 18 : gfc_add_block_to_block (finalblock, &fse.pre);
2188 18 : gfc_add_block_to_block (finalblock, &fse.finalblock);
2189 18 : gfc_add_block_to_block (finalblock, &fse.post);
2190 : }
2191 :
2192 8467 : mpz_clear (size);
2193 8467 : }
2194 :
2195 :
2196 : /* The array constructor code can create a string length with an operand
2197 : in the form of a temporary variable. This variable will retain its
2198 : context (current_function_decl). If we store this length tree in a
2199 : gfc_charlen structure which is shared by a variable in another
2200 : context, the resulting gfc_charlen structure with a variable in a
2201 : different context, we could trip the assertion in expand_expr_real_1
2202 : when it sees that a variable has been created in one context and
2203 : referenced in another.
2204 :
2205 : If this might be the case, we create a new gfc_charlen structure and
2206 : link it into the current namespace. */
2207 :
2208 : static void
2209 8484 : store_backend_decl (gfc_charlen **clp, tree len, bool force_new_cl)
2210 : {
2211 8484 : if (force_new_cl)
2212 : {
2213 8456 : gfc_charlen *new_cl = gfc_new_charlen (gfc_current_ns, *clp);
2214 8456 : *clp = new_cl;
2215 : }
2216 8484 : (*clp)->backend_decl = len;
2217 8484 : }
2218 :
2219 : /* A catch-all to obtain the string length for anything that is not
2220 : a substring of non-constant length, a constant, array or variable. */
2221 :
2222 : static void
2223 293 : get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
2224 : {
2225 293 : gfc_se se;
2226 :
2227 : /* Don't bother if we already know the length is a constant. */
2228 293 : if (*len && INTEGER_CST_P (*len))
2229 52 : return;
2230 :
2231 241 : if (!e->ref && e->ts.u.cl && e->ts.u.cl->length
2232 35 : && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
2233 : {
2234 : /* This is easy. */
2235 1 : gfc_conv_const_charlen (e->ts.u.cl);
2236 1 : *len = e->ts.u.cl->backend_decl;
2237 : }
2238 : else
2239 : {
2240 : /* Otherwise, be brutal even if inefficient. */
2241 240 : gfc_init_se (&se, NULL);
2242 :
2243 : /* No function call, in case of side effects. */
2244 240 : se.no_function_call = 1;
2245 240 : if (e->rank == 0)
2246 121 : gfc_conv_expr (&se, e);
2247 : else
2248 119 : gfc_conv_expr_descriptor (&se, e);
2249 :
2250 : /* Fix the value. */
2251 240 : *len = gfc_evaluate_now (se.string_length, &se.pre);
2252 :
2253 240 : gfc_add_block_to_block (block, &se.pre);
2254 240 : gfc_add_block_to_block (block, &se.post);
2255 :
2256 240 : store_backend_decl (&e->ts.u.cl, *len, true);
2257 : }
2258 : }
2259 :
2260 :
2261 : /* Figure out the string length of a variable reference expression.
2262 : Used by get_array_ctor_strlen. */
2263 :
2264 : static void
2265 882 : get_array_ctor_var_strlen (stmtblock_t *block, gfc_expr * expr, tree * len)
2266 : {
2267 882 : gfc_ref *ref;
2268 882 : gfc_typespec *ts;
2269 882 : mpz_t char_len;
2270 882 : gfc_se se;
2271 :
2272 : /* Don't bother if we already know the length is a constant. */
2273 882 : if (*len && INTEGER_CST_P (*len))
2274 551 : return;
2275 :
2276 395 : ts = &expr->symtree->n.sym->ts;
2277 626 : for (ref = expr->ref; ref; ref = ref->next)
2278 : {
2279 295 : switch (ref->type)
2280 : {
2281 186 : case REF_ARRAY:
2282 : /* Array references don't change the string length. */
2283 186 : if (ts->deferred)
2284 112 : get_array_ctor_all_strlen (block, expr, len);
2285 : break;
2286 :
2287 45 : case REF_COMPONENT:
2288 : /* Use the length of the component. */
2289 45 : ts = &ref->u.c.component->ts;
2290 45 : break;
2291 :
2292 64 : case REF_SUBSTRING:
2293 64 : if (ref->u.ss.end == NULL
2294 52 : || ref->u.ss.start->expr_type != EXPR_CONSTANT
2295 52 : || ref->u.ss.end->expr_type != EXPR_CONSTANT)
2296 : {
2297 : /* Note that this might evaluate expr. */
2298 45 : get_array_ctor_all_strlen (block, expr, len);
2299 45 : return;
2300 : }
2301 19 : mpz_init_set_ui (char_len, 1);
2302 19 : mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
2303 19 : mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
2304 19 : *len = gfc_conv_mpz_to_tree_type (char_len, gfc_charlen_type_node);
2305 19 : mpz_clear (char_len);
2306 19 : return;
2307 :
2308 : case REF_INQUIRY:
2309 : break;
2310 :
2311 0 : default:
2312 0 : gcc_unreachable ();
2313 : }
2314 : }
2315 :
2316 : /* A last ditch attempt that is sometimes needed for deferred characters. */
2317 331 : if (!ts->u.cl->backend_decl)
2318 : {
2319 7 : gfc_init_se (&se, NULL);
2320 7 : if (expr->rank)
2321 0 : gfc_conv_expr_descriptor (&se, expr);
2322 : else
2323 7 : gfc_conv_expr (&se, expr);
2324 7 : gcc_assert (se.string_length != NULL_TREE);
2325 7 : gfc_add_block_to_block (block, &se.pre);
2326 7 : ts->u.cl->backend_decl = se.string_length;
2327 : }
2328 :
2329 331 : *len = ts->u.cl->backend_decl;
2330 : }
2331 :
2332 :
2333 : /* Figure out the string length of a character array constructor.
2334 : If len is NULL, don't calculate the length; this happens for recursive calls
2335 : when a sub-array-constructor is an element but not at the first position,
2336 : so when we're not interested in the length.
2337 : Returns TRUE if all elements are character constants. */
2338 :
2339 : bool
2340 8843 : get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len)
2341 : {
2342 8843 : gfc_constructor *c;
2343 8843 : bool is_const;
2344 :
2345 8843 : is_const = true;
2346 :
2347 8843 : if (gfc_constructor_first (base) == NULL)
2348 : {
2349 273 : if (len)
2350 273 : *len = build_int_cstu (gfc_charlen_type_node, 0);
2351 : return is_const;
2352 : }
2353 :
2354 : /* Loop over all constructor elements to find out is_const, but in len we
2355 : want to store the length of the first, not the last, element. We can
2356 : of course exit the loop as soon as is_const is found to be false. */
2357 8570 : for (c = gfc_constructor_first (base);
2358 46899 : c && is_const; c = gfc_constructor_next (c))
2359 : {
2360 38329 : switch (c->expr->expr_type)
2361 : {
2362 37208 : case EXPR_CONSTANT:
2363 37208 : if (len && !(*len && INTEGER_CST_P (*len)))
2364 386 : *len = build_int_cstu (gfc_charlen_type_node,
2365 386 : c->expr->value.character.length);
2366 : break;
2367 :
2368 43 : case EXPR_ARRAY:
2369 43 : if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
2370 38329 : is_const = false;
2371 : break;
2372 :
2373 942 : case EXPR_VARIABLE:
2374 942 : is_const = false;
2375 942 : if (len)
2376 882 : get_array_ctor_var_strlen (block, c->expr, len);
2377 : break;
2378 :
2379 136 : default:
2380 136 : is_const = false;
2381 136 : if (len)
2382 136 : get_array_ctor_all_strlen (block, c->expr, len);
2383 : break;
2384 : }
2385 :
2386 : /* After the first iteration, we don't want the length modified. */
2387 38329 : len = NULL;
2388 : }
2389 :
2390 : return is_const;
2391 : }
2392 :
2393 : /* Check whether the array constructor C consists entirely of constant
2394 : elements, and if so returns the number of those elements, otherwise
2395 : return zero. Note, an empty or NULL array constructor returns zero. */
2396 :
2397 : unsigned HOST_WIDE_INT
2398 61131 : gfc_constant_array_constructor_p (gfc_constructor_base base)
2399 : {
2400 61131 : unsigned HOST_WIDE_INT nelem = 0;
2401 :
2402 61131 : gfc_constructor *c = gfc_constructor_first (base);
2403 549731 : while (c)
2404 : {
2405 434801 : if (c->iterator
2406 433196 : || c->expr->rank > 0
2407 432386 : || c->expr->expr_type != EXPR_CONSTANT)
2408 : return 0;
2409 427469 : c = gfc_constructor_next (c);
2410 427469 : nelem++;
2411 : }
2412 : return nelem;
2413 : }
2414 :
2415 :
2416 : /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
2417 : and the tree type of it's elements, TYPE, return a static constant
2418 : variable that is compile-time initialized. */
2419 :
2420 : tree
2421 43112 : gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
2422 : {
2423 43112 : tree tmptype, init, tmp;
2424 43112 : HOST_WIDE_INT nelem;
2425 43112 : gfc_constructor *c;
2426 43112 : gfc_array_spec as;
2427 43112 : gfc_se se;
2428 43112 : int i;
2429 43112 : vec<constructor_elt, va_gc> *v = NULL;
2430 :
2431 : /* First traverse the constructor list, converting the constants
2432 : to tree to build an initializer. */
2433 43112 : nelem = 0;
2434 43112 : c = gfc_constructor_first (expr->value.constructor);
2435 429801 : while (c)
2436 : {
2437 343577 : gfc_init_se (&se, NULL);
2438 343577 : gfc_conv_constant (&se, c->expr);
2439 343577 : if (c->expr->ts.type != BT_CHARACTER)
2440 307289 : se.expr = fold_convert (type, se.expr);
2441 36288 : else if (POINTER_TYPE_P (type))
2442 36288 : se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
2443 : se.expr);
2444 343577 : CONSTRUCTOR_APPEND_ELT (v, build_int_cst (gfc_array_index_type, nelem),
2445 : se.expr);
2446 343577 : c = gfc_constructor_next (c);
2447 343577 : nelem++;
2448 : }
2449 :
2450 : /* Next determine the tree type for the array. We use the gfortran
2451 : front-end's gfc_get_nodesc_array_type in order to create a suitable
2452 : GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
2453 :
2454 43112 : memset (&as, 0, sizeof (gfc_array_spec));
2455 :
2456 43112 : as.rank = expr->rank;
2457 43112 : as.type = AS_EXPLICIT;
2458 43112 : if (!expr->shape)
2459 : {
2460 4 : as.lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
2461 4 : as.upper[0] = gfc_get_int_expr (gfc_default_integer_kind,
2462 : NULL, nelem - 1);
2463 : }
2464 : else
2465 92949 : for (i = 0; i < expr->rank; i++)
2466 : {
2467 49841 : int tmp = (int) mpz_get_si (expr->shape[i]);
2468 49841 : as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
2469 49841 : as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind,
2470 49841 : NULL, tmp - 1);
2471 : }
2472 :
2473 43112 : tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
2474 :
2475 : /* as is not needed anymore. */
2476 136069 : for (i = 0; i < as.rank + as.corank; i++)
2477 : {
2478 49845 : gfc_free_expr (as.lower[i]);
2479 49845 : gfc_free_expr (as.upper[i]);
2480 : }
2481 :
2482 43112 : init = build_constructor (tmptype, v);
2483 :
2484 43112 : TREE_CONSTANT (init) = 1;
2485 43112 : TREE_STATIC (init) = 1;
2486 :
2487 43112 : tmp = build_decl (input_location, VAR_DECL, create_tmp_var_name ("A"),
2488 : tmptype);
2489 43112 : DECL_ARTIFICIAL (tmp) = 1;
2490 43112 : DECL_IGNORED_P (tmp) = 1;
2491 43112 : TREE_STATIC (tmp) = 1;
2492 43112 : TREE_CONSTANT (tmp) = 1;
2493 43112 : TREE_READONLY (tmp) = 1;
2494 43112 : DECL_INITIAL (tmp) = init;
2495 43112 : pushdecl (tmp);
2496 :
2497 43112 : return tmp;
2498 : }
2499 :
2500 :
2501 : /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
2502 : This mostly initializes the scalarizer state info structure with the
2503 : appropriate values to directly use the array created by the function
2504 : gfc_build_constant_array_constructor. */
2505 :
2506 : static void
2507 37129 : trans_constant_array_constructor (gfc_ss * ss, tree type)
2508 : {
2509 37129 : gfc_array_info *info;
2510 37129 : tree tmp;
2511 37129 : int i;
2512 :
2513 37129 : tmp = gfc_build_constant_array_constructor (ss->info->expr, type);
2514 :
2515 37129 : info = &ss->info->data.array;
2516 :
2517 37129 : info->descriptor = tmp;
2518 37129 : info->data = gfc_build_addr_expr (NULL_TREE, tmp);
2519 37129 : info->offset = gfc_index_zero_node;
2520 :
2521 78107 : for (i = 0; i < ss->dimen; i++)
2522 : {
2523 40978 : info->delta[i] = gfc_index_zero_node;
2524 40978 : info->start[i] = gfc_index_zero_node;
2525 40978 : info->end[i] = gfc_index_zero_node;
2526 40978 : info->stride[i] = gfc_index_one_node;
2527 : }
2528 37129 : }
2529 :
2530 :
2531 : static int
2532 37136 : get_rank (gfc_loopinfo *loop)
2533 : {
2534 37136 : int rank;
2535 :
2536 37136 : rank = 0;
2537 159550 : for (; loop; loop = loop->parent)
2538 79781 : rank += loop->dimen;
2539 :
2540 42633 : return rank;
2541 : }
2542 :
2543 :
2544 : /* Helper routine of gfc_trans_array_constructor to determine if the
2545 : bounds of the loop specified by LOOP are constant and simple enough
2546 : to use with trans_constant_array_constructor. Returns the
2547 : iteration count of the loop if suitable, and NULL_TREE otherwise. */
2548 :
2549 : static tree
2550 37136 : constant_array_constructor_loop_size (gfc_loopinfo * l)
2551 : {
2552 37136 : gfc_loopinfo *loop;
2553 37136 : tree size = gfc_index_one_node;
2554 37136 : tree tmp;
2555 37136 : int i, total_dim;
2556 :
2557 37136 : total_dim = get_rank (l);
2558 :
2559 74272 : for (loop = l; loop; loop = loop->parent)
2560 : {
2561 78133 : for (i = 0; i < loop->dimen; i++)
2562 : {
2563 : /* If the bounds aren't constant, return NULL_TREE. */
2564 40997 : if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
2565 : return NULL_TREE;
2566 40991 : if (!integer_zerop (loop->from[i]))
2567 : {
2568 : /* Only allow nonzero "from" in one-dimensional arrays. */
2569 0 : if (total_dim != 1)
2570 : return NULL_TREE;
2571 0 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2572 : gfc_array_index_type,
2573 : loop->to[i], loop->from[i]);
2574 : }
2575 : else
2576 40991 : tmp = loop->to[i];
2577 40991 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
2578 : gfc_array_index_type, tmp, gfc_index_one_node);
2579 40991 : size = fold_build2_loc (input_location, MULT_EXPR,
2580 : gfc_array_index_type, size, tmp);
2581 : }
2582 : }
2583 :
2584 : return size;
2585 : }
2586 :
2587 :
2588 : static tree *
2589 44085 : get_loop_upper_bound_for_array (gfc_ss *array, int array_dim)
2590 : {
2591 44085 : gfc_ss *ss;
2592 44085 : int n;
2593 :
2594 44085 : gcc_assert (array->nested_ss == NULL);
2595 :
2596 44085 : for (ss = array; ss; ss = ss->parent)
2597 44085 : for (n = 0; n < ss->loop->dimen; n++)
2598 44085 : if (array_dim == get_array_ref_dim_for_loop_dim (ss, n))
2599 44085 : return &(ss->loop->to[n]);
2600 :
2601 0 : gcc_unreachable ();
2602 : }
2603 :
2604 :
2605 : static gfc_loopinfo *
2606 725519 : outermost_loop (gfc_loopinfo * loop)
2607 : {
2608 946125 : while (loop->parent != NULL)
2609 : loop = loop->parent;
2610 :
2611 732207 : return loop;
2612 : }
2613 :
2614 :
2615 : /* Array constructors are handled by constructing a temporary, then using that
2616 : within the scalarization loop. This is not optimal, but seems by far the
2617 : simplest method. */
2618 :
2619 : static void
2620 44085 : trans_array_constructor (gfc_ss * ss, locus * where)
2621 : {
2622 44085 : gfc_constructor_base c;
2623 44085 : tree offset;
2624 44085 : tree offsetvar;
2625 44085 : tree desc;
2626 44085 : tree type;
2627 44085 : tree tmp;
2628 44085 : tree *loop_ubound0;
2629 44085 : bool dynamic;
2630 44085 : bool old_first_len, old_typespec_chararray_ctor;
2631 44085 : tree old_first_len_val;
2632 44085 : gfc_loopinfo *loop, *outer_loop;
2633 44085 : gfc_ss_info *ss_info;
2634 44085 : gfc_expr *expr;
2635 44085 : gfc_ss *s;
2636 44085 : tree neg_len;
2637 44085 : char *msg;
2638 44085 : stmtblock_t finalblock;
2639 44085 : bool finalize_required;
2640 44085 : bool owned_sweep = false;
2641 :
2642 : /* Save the old values for nested checking. */
2643 44085 : old_first_len = first_len;
2644 44085 : old_first_len_val = first_len_val;
2645 44085 : old_typespec_chararray_ctor = typespec_chararray_ctor;
2646 :
2647 44085 : loop = ss->loop;
2648 44085 : outer_loop = outermost_loop (loop);
2649 44085 : ss_info = ss->info;
2650 44085 : expr = ss_info->expr;
2651 :
2652 : /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
2653 : typespec was given for the array constructor. */
2654 88170 : typespec_chararray_ctor = (expr->ts.type == BT_CHARACTER
2655 8244 : && expr->ts.u.cl
2656 52329 : && expr->ts.u.cl->length_from_typespec);
2657 :
2658 44085 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2659 2542 : && expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
2660 : {
2661 1468 : first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
2662 1468 : first_len = true;
2663 : }
2664 :
2665 44085 : gcc_assert (ss->dimen == ss->loop->dimen);
2666 :
2667 44085 : c = expr->value.constructor;
2668 44085 : if (expr->ts.type == BT_CHARACTER)
2669 : {
2670 8244 : bool const_string;
2671 8244 : bool force_new_cl = false;
2672 :
2673 : /* get_array_ctor_strlen walks the elements of the constructor, if a
2674 : typespec was given, we already know the string length and want the one
2675 : specified there. */
2676 8244 : if (typespec_chararray_ctor && expr->ts.u.cl->length
2677 520 : && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
2678 : {
2679 28 : gfc_se length_se;
2680 :
2681 28 : const_string = false;
2682 28 : gfc_init_se (&length_se, NULL);
2683 28 : gfc_conv_expr_type (&length_se, expr->ts.u.cl->length,
2684 : gfc_charlen_type_node);
2685 28 : ss_info->string_length = length_se.expr;
2686 :
2687 : /* Check if the character length is negative. If it is, then
2688 : set LEN = 0. */
2689 28 : neg_len = fold_build2_loc (input_location, LT_EXPR,
2690 : logical_type_node, ss_info->string_length,
2691 28 : build_zero_cst (TREE_TYPE
2692 : (ss_info->string_length)));
2693 : /* Print a warning if bounds checking is enabled. */
2694 28 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2695 : {
2696 18 : msg = xasprintf ("Negative character length treated as LEN = 0");
2697 18 : gfc_trans_runtime_check (false, true, neg_len, &length_se.pre,
2698 : where, msg);
2699 18 : free (msg);
2700 : }
2701 :
2702 28 : ss_info->string_length
2703 28 : = fold_build3_loc (input_location, COND_EXPR,
2704 : gfc_charlen_type_node, neg_len,
2705 : build_zero_cst
2706 28 : (TREE_TYPE (ss_info->string_length)),
2707 : ss_info->string_length);
2708 28 : ss_info->string_length = gfc_evaluate_now (ss_info->string_length,
2709 : &length_se.pre);
2710 28 : gfc_add_block_to_block (&outer_loop->pre, &length_se.pre);
2711 28 : gfc_add_block_to_block (&outer_loop->post, &length_se.post);
2712 28 : }
2713 : else
2714 : {
2715 8216 : const_string = get_array_ctor_strlen (&outer_loop->pre, c,
2716 : &ss_info->string_length);
2717 8216 : force_new_cl = true;
2718 :
2719 : /* Initialize "len" with string length for bounds checking. */
2720 8216 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2721 1486 : && !typespec_chararray_ctor
2722 1468 : && ss_info->string_length)
2723 : {
2724 1468 : gfc_se length_se;
2725 :
2726 1468 : gfc_init_se (&length_se, NULL);
2727 1468 : gfc_add_modify (&length_se.pre, first_len_val,
2728 1468 : fold_convert (TREE_TYPE (first_len_val),
2729 : ss_info->string_length));
2730 1468 : ss_info->string_length = gfc_evaluate_now (ss_info->string_length,
2731 : &length_se.pre);
2732 1468 : gfc_add_block_to_block (&outer_loop->pre, &length_se.pre);
2733 1468 : gfc_add_block_to_block (&outer_loop->post, &length_se.post);
2734 : }
2735 : }
2736 :
2737 : /* Complex character array constructors should have been taken care of
2738 : and not end up here. */
2739 8244 : gcc_assert (ss_info->string_length);
2740 :
2741 8244 : store_backend_decl (&expr->ts.u.cl, ss_info->string_length, force_new_cl);
2742 :
2743 8244 : type = gfc_get_character_type_len (expr->ts.kind, ss_info->string_length);
2744 8244 : if (const_string)
2745 7286 : type = build_pointer_type (type);
2746 : }
2747 : else
2748 35866 : type = gfc_typenode_for_spec (expr->ts.type == BT_CLASS
2749 25 : ? &CLASS_DATA (expr)->ts : &expr->ts);
2750 :
2751 : /* See if the constructor determines the loop bounds. */
2752 44085 : dynamic = false;
2753 :
2754 44085 : loop_ubound0 = get_loop_upper_bound_for_array (ss, 0);
2755 :
2756 86718 : if (expr->shape && get_rank (loop) > 1 && *loop_ubound0 == NULL_TREE)
2757 : {
2758 : /* We have a multidimensional parameter. */
2759 0 : for (s = ss; s; s = s->parent)
2760 : {
2761 : int n;
2762 0 : for (n = 0; n < s->loop->dimen; n++)
2763 : {
2764 0 : s->loop->from[n] = gfc_index_zero_node;
2765 0 : s->loop->to[n] = gfc_conv_mpz_to_tree (expr->shape[s->dim[n]],
2766 : gfc_index_integer_kind);
2767 0 : s->loop->to[n] = fold_build2_loc (input_location, MINUS_EXPR,
2768 : gfc_array_index_type,
2769 0 : s->loop->to[n],
2770 : gfc_index_one_node);
2771 : }
2772 : }
2773 : }
2774 :
2775 44085 : if (*loop_ubound0 == NULL_TREE)
2776 : {
2777 893 : mpz_t size;
2778 :
2779 : /* We should have a 1-dimensional, zero-based loop. */
2780 893 : gcc_assert (loop->parent == NULL && loop->nested == NULL);
2781 893 : gcc_assert (loop->dimen == 1);
2782 893 : gcc_assert (integer_zerop (loop->from[0]));
2783 :
2784 : /* Split the constructor size into a static part and a dynamic part.
2785 : Allocate the static size up-front and record whether the dynamic
2786 : size might be nonzero. */
2787 893 : mpz_init (size);
2788 893 : dynamic = gfc_get_array_constructor_size (&size, c);
2789 893 : mpz_sub_ui (size, size, 1);
2790 893 : loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
2791 893 : mpz_clear (size);
2792 : }
2793 :
2794 : /* Special case constant array constructors. */
2795 893 : if (!dynamic)
2796 : {
2797 43217 : unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
2798 43217 : if (nelem > 0)
2799 : {
2800 37136 : tree size = constant_array_constructor_loop_size (loop);
2801 37130 : if (size && compare_tree_int (size, nelem) == 0
2802 74266 : && TREE_CODE (TYPE_SIZE (type)) == INTEGER_CST)
2803 : {
2804 37129 : trans_constant_array_constructor (ss, type);
2805 37129 : goto finish;
2806 : }
2807 : }
2808 : }
2809 :
2810 6956 : gfc_trans_create_temp_array (&outer_loop->pre, &outer_loop->post, ss, type,
2811 : NULL_TREE, dynamic, true, false, where);
2812 :
2813 6956 : desc = ss_info->data.array.descriptor;
2814 6956 : offset = gfc_index_zero_node;
2815 6956 : offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
2816 6956 : suppress_warning (offsetvar);
2817 6956 : TREE_USED (offsetvar) = 0;
2818 :
2819 6956 : gfc_init_block (&finalblock);
2820 6956 : finalize_required = expr->must_finalize;
2821 6956 : if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
2822 : finalize_required = true;
2823 :
2824 6956 : if (IS_PDT (expr))
2825 : finalize_required = true;
2826 :
2827 : /* If every element of the constructor is a function result with allocatable
2828 : components, those components are owned by the temporary and are freed in a
2829 : single sweep over the whole array below. This is the only way to free the
2830 : elements produced inside an implied-do loop, where a single compile-time
2831 : element stands for many runtime elements. */
2832 13833 : owned_sweep = finalize_required
2833 558 : && expr->ts.type == BT_DERIVED
2834 558 : && expr->ts.u.derived->attr.alloc_comp
2835 7344 : && gfc_constructor_is_owned_alloc_comp (c, expr->ts.u.derived);
2836 :
2837 6956 : gfc_trans_array_constructor_value (&outer_loop->pre,
2838 : finalize_required ? &finalblock : NULL,
2839 : type, desc, c, &offset, &offsetvar,
2840 : dynamic, owned_sweep);
2841 :
2842 6956 : if (owned_sweep)
2843 250 : gfc_add_expr_to_block (&finalblock,
2844 250 : gfc_deallocate_alloc_comp_no_caf (expr->ts.u.derived,
2845 : desc, 1, true));
2846 :
2847 : /* If the array grows dynamically, the upper bound of the loop variable
2848 : is determined by the array's final upper bound. */
2849 6956 : if (dynamic)
2850 : {
2851 868 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2852 : gfc_array_index_type,
2853 : offsetvar, gfc_index_one_node);
2854 868 : tmp = gfc_evaluate_now (tmp, &outer_loop->pre);
2855 868 : if (*loop_ubound0 && VAR_P (*loop_ubound0))
2856 0 : gfc_add_modify (&outer_loop->pre, *loop_ubound0, tmp);
2857 : else
2858 868 : *loop_ubound0 = tmp;
2859 : }
2860 :
2861 6956 : if (TREE_USED (offsetvar))
2862 2188 : pushdecl (offsetvar);
2863 : else
2864 4768 : gcc_assert (INTEGER_CST_P (offset));
2865 :
2866 : #if 0
2867 : /* Disable bound checking for now because it's probably broken. */
2868 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2869 : {
2870 : gcc_unreachable ();
2871 : }
2872 : #endif
2873 :
2874 4768 : finish:
2875 : /* Restore old values of globals. */
2876 44085 : first_len = old_first_len;
2877 44085 : first_len_val = old_first_len_val;
2878 44085 : typespec_chararray_ctor = old_typespec_chararray_ctor;
2879 :
2880 : /* F2008 4.5.6.3 para 5: If an executable construct references a structure
2881 : constructor or array constructor, the entity created by the constructor is
2882 : finalized after execution of the innermost executable construct containing
2883 : the reference. */
2884 44085 : if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
2885 1782 : && finalblock.head != NULL_TREE)
2886 328 : gfc_prepend_expr_to_block (&loop->post, finalblock.head);
2887 44085 : }
2888 :
2889 :
2890 : /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
2891 : called after evaluating all of INFO's vector dimensions. Go through
2892 : each such vector dimension and see if we can now fill in any missing
2893 : loop bounds. */
2894 :
2895 : static void
2896 185708 : set_vector_loop_bounds (gfc_ss * ss)
2897 : {
2898 185708 : gfc_loopinfo *loop, *outer_loop;
2899 185708 : gfc_array_info *info;
2900 185708 : gfc_se se;
2901 185708 : tree tmp;
2902 185708 : tree desc;
2903 185708 : tree zero;
2904 185708 : int n;
2905 185708 : int dim;
2906 :
2907 185708 : outer_loop = outermost_loop (ss->loop);
2908 :
2909 185708 : info = &ss->info->data.array;
2910 :
2911 376052 : for (; ss; ss = ss->parent)
2912 : {
2913 190344 : loop = ss->loop;
2914 :
2915 452418 : for (n = 0; n < loop->dimen; n++)
2916 : {
2917 262074 : dim = ss->dim[n];
2918 262074 : if (info->ref->u.ar.dimen_type[dim] != DIMEN_VECTOR
2919 986 : || loop->to[n] != NULL)
2920 261894 : continue;
2921 :
2922 : /* Loop variable N indexes vector dimension DIM, and we don't
2923 : yet know the upper bound of loop variable N. Set it to the
2924 : difference between the vector's upper and lower bounds. */
2925 180 : gcc_assert (loop->from[n] == gfc_index_zero_node);
2926 180 : gcc_assert (info->subscript[dim]
2927 : && info->subscript[dim]->info->type == GFC_SS_VECTOR);
2928 :
2929 180 : gfc_init_se (&se, NULL);
2930 180 : desc = info->subscript[dim]->info->data.array.descriptor;
2931 180 : zero = gfc_rank_cst[0];
2932 180 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2933 : gfc_array_index_type,
2934 : gfc_conv_descriptor_ubound_get (desc, zero),
2935 : gfc_conv_descriptor_lbound_get (desc, zero));
2936 180 : tmp = gfc_evaluate_now (tmp, &outer_loop->pre);
2937 180 : loop->to[n] = tmp;
2938 : }
2939 : }
2940 185708 : }
2941 :
2942 :
2943 : /* Tells whether a scalar argument to an elemental procedure is saved out
2944 : of a scalarization loop as a value or as a reference. */
2945 :
2946 : bool
2947 46401 : gfc_scalar_elemental_arg_saved_as_reference (gfc_ss_info * ss_info)
2948 : {
2949 46401 : if (ss_info->type != GFC_SS_REFERENCE)
2950 : return false;
2951 :
2952 10306 : if (ss_info->data.scalar.needs_temporary)
2953 : return false;
2954 :
2955 : /* If the actual argument can be absent (in other words, it can
2956 : be a NULL reference), don't try to evaluate it; pass instead
2957 : the reference directly. */
2958 9918 : if (ss_info->can_be_null_ref)
2959 : return true;
2960 :
2961 : /* If the expression is of polymorphic type, it's actual size is not known,
2962 : so we avoid copying it anywhere. */
2963 9242 : if (ss_info->data.scalar.dummy_arg
2964 1402 : && gfc_dummy_arg_get_typespec (*ss_info->data.scalar.dummy_arg).type
2965 : == BT_CLASS
2966 9366 : && ss_info->expr->ts.type == BT_CLASS)
2967 : return true;
2968 :
2969 : /* If the expression is a data reference of aggregate type,
2970 : and the data reference is not used on the left hand side,
2971 : avoid a copy by saving a reference to the content. */
2972 9218 : if (!ss_info->data.scalar.needs_temporary
2973 9218 : && (ss_info->expr->ts.type == BT_DERIVED
2974 8230 : || ss_info->expr->ts.type == BT_CLASS)
2975 10254 : && gfc_expr_is_variable (ss_info->expr))
2976 : return true;
2977 :
2978 : /* Otherwise the expression is evaluated to a temporary variable before the
2979 : scalarization loop. */
2980 : return false;
2981 : }
2982 :
2983 :
2984 : /* Add the pre and post chains for all the scalar expressions in a SS chain
2985 : to loop. This is called after the loop parameters have been calculated,
2986 : but before the actual scalarizing loops. */
2987 :
2988 : static void
2989 195573 : gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
2990 : locus * where)
2991 : {
2992 195573 : gfc_loopinfo *nested_loop, *outer_loop;
2993 195573 : gfc_se se;
2994 195573 : gfc_ss_info *ss_info;
2995 195573 : gfc_array_info *info;
2996 195573 : gfc_expr *expr;
2997 195573 : int n;
2998 :
2999 : /* Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise,
3000 : arguments could get evaluated multiple times. */
3001 195573 : if (ss->is_alloc_lhs)
3002 203 : return;
3003 :
3004 514790 : outer_loop = outermost_loop (loop);
3005 :
3006 : /* TODO: This can generate bad code if there are ordering dependencies,
3007 : e.g., a callee allocated function and an unknown size constructor. */
3008 : gcc_assert (ss != NULL);
3009 :
3010 514790 : for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
3011 : {
3012 319420 : gcc_assert (ss);
3013 :
3014 : /* Cross loop arrays are handled from within the most nested loop. */
3015 319420 : if (ss->nested_ss != NULL)
3016 4740 : continue;
3017 :
3018 314680 : ss_info = ss->info;
3019 314680 : expr = ss_info->expr;
3020 314680 : info = &ss_info->data.array;
3021 :
3022 314680 : switch (ss_info->type)
3023 : {
3024 44365 : case GFC_SS_SCALAR:
3025 : /* Scalar expression. Evaluate this now. This includes elemental
3026 : dimension indices, but not array section bounds. */
3027 44365 : gfc_init_se (&se, NULL);
3028 44365 : gfc_conv_expr (&se, expr);
3029 44365 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3030 :
3031 44365 : if (expr->ts.type != BT_CHARACTER
3032 44365 : && !gfc_is_alloc_class_scalar_function (expr))
3033 : {
3034 : /* Move the evaluation of scalar expressions outside the
3035 : scalarization loop, except for WHERE assignments. */
3036 40327 : if (subscript)
3037 6599 : se.expr = convert(gfc_array_index_type, se.expr);
3038 40327 : if (!ss_info->where)
3039 39913 : se.expr = gfc_evaluate_now (se.expr, &outer_loop->pre);
3040 40327 : gfc_add_block_to_block (&outer_loop->pre, &se.post);
3041 : }
3042 : else
3043 4038 : gfc_add_block_to_block (&outer_loop->post, &se.post);
3044 :
3045 44365 : ss_info->data.scalar.value = se.expr;
3046 44365 : ss_info->string_length = se.string_length;
3047 44365 : break;
3048 :
3049 5153 : case GFC_SS_REFERENCE:
3050 : /* Scalar argument to elemental procedure. */
3051 5153 : gfc_init_se (&se, NULL);
3052 5153 : if (gfc_scalar_elemental_arg_saved_as_reference (ss_info))
3053 844 : gfc_conv_expr_reference (&se, expr);
3054 : else
3055 : {
3056 : /* Evaluate the argument outside the loop and pass
3057 : a reference to the value. */
3058 4309 : gfc_conv_expr (&se, expr);
3059 : }
3060 :
3061 : /* Ensure that a pointer to the string is stored. */
3062 5153 : if (expr->ts.type == BT_CHARACTER)
3063 174 : gfc_conv_string_parameter (&se);
3064 :
3065 5153 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3066 5153 : gfc_add_block_to_block (&outer_loop->post, &se.post);
3067 5153 : if (gfc_is_class_scalar_expr (expr))
3068 : /* This is necessary because the dynamic type will always be
3069 : large than the declared type. In consequence, assigning
3070 : the value to a temporary could segfault.
3071 : OOP-TODO: see if this is generally correct or is the value
3072 : has to be written to an allocated temporary, whose address
3073 : is passed via ss_info. */
3074 48 : ss_info->data.scalar.value = se.expr;
3075 : else
3076 5105 : ss_info->data.scalar.value = gfc_evaluate_now (se.expr,
3077 : &outer_loop->pre);
3078 :
3079 5153 : ss_info->string_length = se.string_length;
3080 5153 : break;
3081 :
3082 : case GFC_SS_SECTION:
3083 : /* Add the expressions for scalar and vector subscripts. */
3084 2971328 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
3085 2785620 : if (info->subscript[n])
3086 7585 : gfc_add_loop_ss_code (loop, info->subscript[n], true, where);
3087 :
3088 185708 : set_vector_loop_bounds (ss);
3089 185708 : break;
3090 :
3091 986 : case GFC_SS_VECTOR:
3092 : /* Get the vector's descriptor and store it in SS. */
3093 986 : gfc_init_se (&se, NULL);
3094 986 : gfc_conv_expr_descriptor (&se, expr);
3095 986 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3096 986 : gfc_add_block_to_block (&outer_loop->post, &se.post);
3097 986 : info->descriptor = se.expr;
3098 986 : break;
3099 :
3100 11698 : case GFC_SS_INTRINSIC:
3101 11698 : gfc_add_intrinsic_ss_code (loop, ss);
3102 11698 : break;
3103 :
3104 9788 : case GFC_SS_FUNCTION:
3105 9788 : {
3106 : /* Array function return value. We call the function and save its
3107 : result in a temporary for use inside the loop. */
3108 9788 : gfc_init_se (&se, NULL);
3109 9788 : se.loop = loop;
3110 9788 : se.ss = ss;
3111 9788 : bool class_func = gfc_is_class_array_function (expr);
3112 9788 : if (class_func)
3113 183 : expr->must_finalize = 1;
3114 9788 : gfc_conv_expr (&se, expr);
3115 9788 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3116 9788 : if (class_func
3117 183 : && se.expr
3118 9971 : && GFC_CLASS_TYPE_P (TREE_TYPE (se.expr)))
3119 : {
3120 183 : tree tmp = gfc_class_data_get (se.expr);
3121 183 : info->descriptor = tmp;
3122 183 : info->data = gfc_conv_descriptor_data_get (tmp);
3123 183 : info->offset = gfc_conv_descriptor_offset_get (tmp);
3124 366 : for (gfc_ss *s = ss; s; s = s->parent)
3125 378 : for (int n = 0; n < s->dimen; n++)
3126 : {
3127 195 : int dim = s->dim[n];
3128 195 : tree tree_dim = gfc_rank_cst[dim];
3129 :
3130 195 : tree start;
3131 195 : start = gfc_conv_descriptor_lbound_get (tmp, tree_dim);
3132 195 : start = gfc_evaluate_now (start, &outer_loop->pre);
3133 195 : info->start[dim] = start;
3134 :
3135 195 : tree end;
3136 195 : end = gfc_conv_descriptor_ubound_get (tmp, tree_dim);
3137 195 : end = gfc_evaluate_now (end, &outer_loop->pre);
3138 195 : info->end[dim] = end;
3139 :
3140 195 : tree stride;
3141 195 : stride = gfc_conv_descriptor_stride_get (tmp, tree_dim);
3142 195 : stride = gfc_evaluate_now (stride, &outer_loop->pre);
3143 195 : info->stride[dim] = stride;
3144 : }
3145 : }
3146 9788 : gfc_add_block_to_block (&outer_loop->post, &se.post);
3147 9788 : gfc_add_block_to_block (&outer_loop->post, &se.finalblock);
3148 9788 : ss_info->string_length = se.string_length;
3149 : }
3150 9788 : break;
3151 :
3152 44085 : case GFC_SS_CONSTRUCTOR:
3153 44085 : if (expr->ts.type == BT_CHARACTER
3154 8244 : && ss_info->string_length == NULL
3155 8244 : && expr->ts.u.cl
3156 8244 : && expr->ts.u.cl->length
3157 7943 : && expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
3158 : {
3159 7867 : gfc_init_se (&se, NULL);
3160 7867 : gfc_conv_expr_type (&se, expr->ts.u.cl->length,
3161 : gfc_charlen_type_node);
3162 7867 : ss_info->string_length = se.expr;
3163 7867 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3164 7867 : gfc_add_block_to_block (&outer_loop->post, &se.post);
3165 : }
3166 44085 : trans_array_constructor (ss, where);
3167 44085 : break;
3168 :
3169 : case GFC_SS_TEMP:
3170 : case GFC_SS_COMPONENT:
3171 : /* Do nothing. These are handled elsewhere. */
3172 : break;
3173 :
3174 0 : default:
3175 0 : gcc_unreachable ();
3176 : }
3177 : }
3178 :
3179 195370 : if (!subscript)
3180 191149 : for (nested_loop = loop->nested; nested_loop;
3181 3364 : nested_loop = nested_loop->next)
3182 3364 : gfc_add_loop_ss_code (nested_loop, nested_loop->ss, subscript, where);
3183 : }
3184 :
3185 :
3186 : /* Given an array descriptor expression DESCR and its data pointer DATA, decide
3187 : whether to either save the data pointer to a variable and use the variable or
3188 : use the data pointer expression directly without any intermediary variable.
3189 : */
3190 :
3191 : static bool
3192 132605 : save_descriptor_data (tree descr, tree data)
3193 : {
3194 132605 : return !(DECL_P (data)
3195 120983 : || (TREE_CODE (data) == ADDR_EXPR
3196 71014 : && DECL_P (TREE_OPERAND (data, 0)))
3197 53148 : || (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (descr))
3198 49529 : && TREE_CODE (descr) == COMPONENT_REF
3199 11831 : && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (descr, 0)))));
3200 : }
3201 :
3202 :
3203 : /* Type of the DATA argument passed to walk_tree by substitute_subexpr_in_expr
3204 : and used by maybe_substitute_expr. */
3205 :
3206 : typedef struct
3207 : {
3208 : tree target, repl;
3209 : }
3210 : substitute_t;
3211 :
3212 :
3213 : /* Check if the expression in *TP is equal to the substitution target provided
3214 : in DATA->TARGET and replace it with DATA->REPL in that case. This is a
3215 : callback function for use with walk_tree. */
3216 :
3217 : static tree
3218 22779 : maybe_substitute_expr (tree *tp, int *walk_subtree, void *data)
3219 : {
3220 22779 : substitute_t *subst = (substitute_t *) data;
3221 22779 : if (*tp == subst->target)
3222 : {
3223 4336 : *tp = subst->repl;
3224 4336 : *walk_subtree = 0;
3225 : }
3226 :
3227 22779 : return NULL_TREE;
3228 : }
3229 :
3230 :
3231 : /* Substitute in EXPR any occurrence of TARGET with REPLACEMENT. */
3232 :
3233 : static void
3234 3993 : substitute_subexpr_in_expr (tree target, tree replacement, tree expr)
3235 : {
3236 3993 : substitute_t subst;
3237 3993 : subst.target = target;
3238 3993 : subst.repl = replacement;
3239 :
3240 3993 : walk_tree (&expr, maybe_substitute_expr, &subst, nullptr);
3241 3993 : }
3242 :
3243 :
3244 : /* Save REF to a fresh variable in all of REPLACEMENT_ROOTS, appending extra
3245 : code to CODE. Before returning, add REF to REPLACEMENT_ROOTS and clear
3246 : REF. */
3247 :
3248 : static void
3249 3815 : save_ref (tree &code, tree &ref, vec<tree> &replacement_roots)
3250 : {
3251 3815 : stmtblock_t tmp_block;
3252 3815 : gfc_init_block (&tmp_block);
3253 3815 : tree var = gfc_evaluate_now (ref, &tmp_block);
3254 3815 : gfc_add_expr_to_block (&tmp_block, code);
3255 3815 : code = gfc_finish_block (&tmp_block);
3256 :
3257 3815 : unsigned i;
3258 3815 : tree repl_root;
3259 7808 : FOR_EACH_VEC_ELT (replacement_roots, i, repl_root)
3260 3993 : substitute_subexpr_in_expr (ref, var, repl_root);
3261 :
3262 3815 : replacement_roots.safe_push (ref);
3263 3815 : ref = NULL_TREE;
3264 3815 : }
3265 :
3266 :
3267 : /* If REF isn't shared with code in PREVIOUS_CODE, replace it with a fresh
3268 : variable in all of REPLACEMENT_ROOTS, appending extra code to CODE. */
3269 :
3270 : static void
3271 3887 : maybe_save_ref (tree &code, tree &ref, vec<tree> &replacement_roots,
3272 : stmtblock_t *previous_code)
3273 : {
3274 3887 : if (find_tree (previous_code->head, ref))
3275 : return;
3276 :
3277 3815 : save_ref (code, ref, replacement_roots);
3278 : }
3279 :
3280 :
3281 : /* Save the descriptor reference VALUE to storage pointed by DESC_PTR. Before
3282 : that, try to create fresh variables to factor subexpressions of VALUE, if
3283 : those subexpressions aren't shared with code in PRELIMINARY_CODE. Add any
3284 : necessary additional code (initialization of variables typically) to BLOCK.
3285 :
3286 : The candidate references to factoring are dereferenced pointers because they
3287 : are cheap to copy and array descriptors because they are often the base of
3288 : multiple subreferences. */
3289 :
3290 : static void
3291 333784 : set_factored_descriptor_value (tree *desc_ptr, tree value, stmtblock_t *block,
3292 : stmtblock_t *preliminary_code)
3293 : {
3294 : /* As the reference is processed from outer to inner, variable definitions
3295 : will be generated in reversed order, so can't be put directly in BLOCK.
3296 : We use temporary blocks instead, which we save in ACCUMULATED_CODE, and
3297 : only append to BLOCK at the end. */
3298 333784 : tree accumulated_code = NULL_TREE;
3299 :
3300 : /* The current candidate to factoring. */
3301 333784 : tree saveable_ref = NULL_TREE;
3302 :
3303 : /* The root expressions in which we look for subexpressions to replace with
3304 : variables. */
3305 333784 : auto_vec<tree> replacement_roots;
3306 333784 : replacement_roots.safe_push (value);
3307 :
3308 333784 : tree data_ref = value;
3309 333784 : tree next_ref = NULL_TREE;
3310 :
3311 : /* If the candidate reference is not followed by a subreference, it can't be
3312 : saved to a variable as it may be reallocatable, and we have to keep the
3313 : parent reference to be able to store the new pointer value in case of
3314 : reallocation. */
3315 333784 : bool maybe_reallocatable = true;
3316 :
3317 558108 : while (true)
3318 : {
3319 445946 : if (!maybe_reallocatable
3320 445946 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (data_ref)))
3321 2494 : saveable_ref = data_ref;
3322 :
3323 445946 : if (TREE_CODE (data_ref) == INDIRECT_REF)
3324 : {
3325 60277 : next_ref = TREE_OPERAND (data_ref, 0);
3326 :
3327 60277 : if (!maybe_reallocatable)
3328 : {
3329 15210 : if (saveable_ref != NULL_TREE && saveable_ref != data_ref)
3330 : {
3331 : /* A reference worth saving has been seen, and now the pointer
3332 : to the current reference is also worth saving. If the
3333 : previous reference to save wasn't the current one, do save
3334 : it now. Otherwise drop it as we prefer saving the
3335 : pointer. */
3336 1911 : maybe_save_ref (accumulated_code, saveable_ref,
3337 : replacement_roots, preliminary_code);
3338 : }
3339 :
3340 : /* Don't evaluate the pointer to a variable yet; do it only if the
3341 : variable would be significantly more simple than the reference
3342 : it replaces. That is if the reference contains anything
3343 : different from NOPs, COMPONENTs and DECLs. */
3344 15210 : saveable_ref = next_ref;
3345 : }
3346 : }
3347 385669 : else if (TREE_CODE (data_ref) == COMPONENT_REF)
3348 : {
3349 42502 : maybe_reallocatable = false;
3350 42502 : next_ref = TREE_OPERAND (data_ref, 0);
3351 : }
3352 343167 : else if (TREE_CODE (data_ref) == NOP_EXPR)
3353 3761 : next_ref = TREE_OPERAND (data_ref, 0);
3354 : else
3355 : {
3356 339406 : if (DECL_P (data_ref))
3357 : break;
3358 :
3359 7276 : if (TREE_CODE (data_ref) == ARRAY_REF)
3360 : {
3361 5622 : maybe_reallocatable = false;
3362 5622 : next_ref = TREE_OPERAND (data_ref, 0);
3363 : }
3364 :
3365 7276 : if (saveable_ref != NULL_TREE)
3366 : /* We have seen a reference worth saving. Do it now. */
3367 1976 : maybe_save_ref (accumulated_code, saveable_ref, replacement_roots,
3368 : preliminary_code);
3369 :
3370 7276 : if (TREE_CODE (data_ref) != ARRAY_REF)
3371 : break;
3372 : }
3373 :
3374 112162 : data_ref = next_ref;
3375 : }
3376 :
3377 333784 : *desc_ptr = value;
3378 333784 : gfc_add_expr_to_block (block, accumulated_code);
3379 333784 : }
3380 :
3381 :
3382 : /* Translate expressions for the descriptor and data pointer of a SS. */
3383 : /*GCC ARRAYS*/
3384 :
3385 : static void
3386 333784 : gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
3387 : {
3388 333784 : gfc_se se;
3389 333784 : gfc_ss_info *ss_info;
3390 333784 : gfc_array_info *info;
3391 333784 : tree tmp;
3392 :
3393 333784 : ss_info = ss->info;
3394 333784 : info = &ss_info->data.array;
3395 :
3396 : /* Get the descriptor for the array to be scalarized. */
3397 333784 : gcc_assert (ss_info->expr->expr_type == EXPR_VARIABLE);
3398 333784 : gfc_init_se (&se, NULL);
3399 333784 : se.descriptor_only = 1;
3400 333784 : gfc_conv_expr_lhs (&se, ss_info->expr);
3401 333784 : stmtblock_t tmp_block;
3402 333784 : gfc_init_block (&tmp_block);
3403 333784 : set_factored_descriptor_value (&info->descriptor, se.expr, &tmp_block,
3404 : &se.pre);
3405 333784 : gfc_add_block_to_block (block, &se.pre);
3406 333784 : gfc_add_block_to_block (block, &tmp_block);
3407 333784 : ss_info->string_length = se.string_length;
3408 333784 : ss_info->class_container = se.class_container;
3409 :
3410 333784 : if (base)
3411 : {
3412 125817 : if (ss_info->expr->ts.type == BT_CHARACTER && !ss_info->expr->ts.deferred
3413 23000 : && ss_info->expr->ts.u.cl->length == NULL)
3414 : {
3415 : /* Emit a DECL_EXPR for the variable sized array type in
3416 : GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
3417 : sizes works correctly. */
3418 1169 : tree arraytype = TREE_TYPE (
3419 : GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (info->descriptor)));
3420 1169 : if (! TYPE_NAME (arraytype))
3421 917 : TYPE_NAME (arraytype) = build_decl (UNKNOWN_LOCATION, TYPE_DECL,
3422 : NULL_TREE, arraytype);
3423 1169 : gfc_add_expr_to_block (block, build1 (DECL_EXPR, arraytype,
3424 1169 : TYPE_NAME (arraytype)));
3425 : }
3426 : /* Also the data pointer. */
3427 125817 : tmp = gfc_conv_array_data (se.expr);
3428 : /* If this is a variable or address or a class array, use it directly.
3429 : Otherwise we must evaluate it now to avoid breaking dependency
3430 : analysis by pulling the expressions for elemental array indices
3431 : inside the loop. */
3432 125817 : if (save_descriptor_data (se.expr, tmp) && !ss->is_alloc_lhs)
3433 37488 : tmp = gfc_evaluate_now (tmp, block);
3434 125817 : info->data = tmp;
3435 :
3436 125817 : tmp = gfc_conv_array_offset (se.expr);
3437 125817 : if (!ss->is_alloc_lhs)
3438 119232 : tmp = gfc_evaluate_now (tmp, block);
3439 125817 : info->offset = tmp;
3440 :
3441 : /* Make absolutely sure that the saved_offset is indeed saved
3442 : so that the variable is still accessible after the loops
3443 : are translated. */
3444 125817 : info->saved_offset = info->offset;
3445 : }
3446 333784 : }
3447 :
3448 :
3449 : /* Initialize a gfc_loopinfo structure. */
3450 :
3451 : void
3452 195136 : gfc_init_loopinfo (gfc_loopinfo * loop)
3453 : {
3454 195136 : int n;
3455 :
3456 195136 : memset (loop, 0, sizeof (gfc_loopinfo));
3457 195136 : gfc_init_block (&loop->pre);
3458 195136 : gfc_init_block (&loop->post);
3459 :
3460 : /* Initially scalarize in order and default to no loop reversal. */
3461 3317312 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
3462 : {
3463 2927040 : loop->order[n] = n;
3464 2927040 : loop->reverse[n] = GFC_INHIBIT_REVERSE;
3465 : }
3466 :
3467 195136 : loop->ss = gfc_ss_terminator;
3468 195136 : }
3469 :
3470 :
3471 : /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
3472 : chain. */
3473 :
3474 : void
3475 194930 : gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
3476 : {
3477 194930 : se->loop = loop;
3478 194930 : }
3479 :
3480 :
3481 : /* Return an expression for the data pointer of an array. */
3482 :
3483 : tree
3484 342971 : gfc_conv_array_data (tree descriptor)
3485 : {
3486 342971 : tree type;
3487 :
3488 342971 : type = TREE_TYPE (descriptor);
3489 342971 : if (GFC_ARRAY_TYPE_P (type))
3490 : {
3491 240149 : if (TREE_CODE (type) == POINTER_TYPE)
3492 : return descriptor;
3493 : else
3494 : {
3495 : /* Descriptorless arrays. */
3496 178579 : return gfc_build_addr_expr (NULL_TREE, descriptor);
3497 : }
3498 : }
3499 : else
3500 102822 : return gfc_conv_descriptor_data_get (descriptor);
3501 : }
3502 :
3503 :
3504 : /* Return an expression for the base offset of an array. */
3505 :
3506 : tree
3507 254999 : gfc_conv_array_offset (tree descriptor)
3508 : {
3509 254999 : tree type;
3510 :
3511 254999 : type = TREE_TYPE (descriptor);
3512 254999 : if (GFC_ARRAY_TYPE_P (type))
3513 181737 : return GFC_TYPE_ARRAY_OFFSET (type);
3514 : else
3515 73262 : return gfc_conv_descriptor_offset_get (descriptor);
3516 : }
3517 :
3518 :
3519 : /* Get an expression for the array stride. */
3520 :
3521 : tree
3522 506279 : gfc_conv_array_stride (tree descriptor, int dim)
3523 : {
3524 506279 : tree tmp;
3525 506279 : tree type;
3526 :
3527 506279 : type = TREE_TYPE (descriptor);
3528 :
3529 : /* For descriptorless arrays use the array size. */
3530 506279 : tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
3531 506279 : if (tmp != NULL_TREE)
3532 : return tmp;
3533 :
3534 116029 : tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]);
3535 116029 : return tmp;
3536 : }
3537 :
3538 :
3539 : /* Like gfc_conv_array_stride, but for the lower bound. */
3540 :
3541 : tree
3542 323806 : gfc_conv_array_lbound (tree descriptor, int dim)
3543 : {
3544 323806 : tree tmp;
3545 323806 : tree type;
3546 :
3547 323806 : type = TREE_TYPE (descriptor);
3548 :
3549 323806 : tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
3550 323806 : if (tmp != NULL_TREE)
3551 : return tmp;
3552 :
3553 18813 : tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]);
3554 18813 : return tmp;
3555 : }
3556 :
3557 :
3558 : /* Like gfc_conv_array_stride, but for the upper bound. */
3559 :
3560 : tree
3561 209800 : gfc_conv_array_ubound (tree descriptor, int dim)
3562 : {
3563 209800 : tree tmp;
3564 209800 : tree type;
3565 :
3566 209800 : type = TREE_TYPE (descriptor);
3567 :
3568 209800 : tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
3569 209800 : if (tmp != NULL_TREE)
3570 : return tmp;
3571 :
3572 : /* This should only ever happen when passing an assumed shape array
3573 : as an actual parameter. The value will never be used. */
3574 8225 : if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
3575 554 : return gfc_index_zero_node;
3576 :
3577 7671 : tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]);
3578 7671 : return tmp;
3579 : }
3580 :
3581 :
3582 : /* Generate abridged name of a part-ref for use in bounds-check message.
3583 : Cases:
3584 : (1) for an ordinary array variable x return "x"
3585 : (2) for z a DT scalar and array component x (at level 1) return "z%%x"
3586 : (3) for z a DT scalar and array component x (at level > 1) or
3587 : for z a DT array and array x (at any number of levels): "z...%%x"
3588 : */
3589 :
3590 : static char *
3591 36604 : abridged_ref_name (gfc_expr * expr, gfc_array_ref * ar)
3592 : {
3593 36604 : gfc_ref *ref;
3594 36604 : gfc_symbol *sym;
3595 36604 : char *ref_name = NULL;
3596 36604 : const char *comp_name = NULL;
3597 36604 : int len_sym, last_len = 0, level = 0;
3598 36604 : bool sym_is_array;
3599 :
3600 36604 : gcc_assert (expr->expr_type == EXPR_VARIABLE && expr->ref != NULL);
3601 :
3602 36604 : sym = expr->symtree->n.sym;
3603 72821 : sym_is_array = (sym->ts.type != BT_CLASS
3604 36604 : ? sym->as != NULL
3605 387 : : IS_CLASS_ARRAY (sym));
3606 36604 : len_sym = strlen (sym->name);
3607 :
3608 : /* Scan ref chain to get name of the array component (when ar != NULL) or
3609 : array section, determine depth and remember its component name. */
3610 52135 : for (ref = expr->ref; ref; ref = ref->next)
3611 : {
3612 38053 : if (ref->type == REF_COMPONENT
3613 1048 : && strcmp (ref->u.c.component->name, "_data") != 0)
3614 : {
3615 918 : level++;
3616 918 : comp_name = ref->u.c.component->name;
3617 918 : continue;
3618 : }
3619 :
3620 37135 : if (ref->type != REF_ARRAY)
3621 150 : continue;
3622 :
3623 36985 : if (ar)
3624 : {
3625 15971 : if (&ref->u.ar == ar)
3626 : break;
3627 : }
3628 21014 : else if (ref->u.ar.type == AR_SECTION)
3629 : break;
3630 : }
3631 :
3632 36604 : if (level > 0)
3633 800 : last_len = strlen (comp_name);
3634 :
3635 : /* Provide a buffer sufficiently large to hold "x...%%z". */
3636 36604 : ref_name = XNEWVEC (char, len_sym + last_len + 6);
3637 36604 : strcpy (ref_name, sym->name);
3638 :
3639 36604 : if (level == 1 && !sym_is_array)
3640 : {
3641 442 : strcat (ref_name, "%%");
3642 442 : strcat (ref_name, comp_name);
3643 : }
3644 36162 : else if (level > 0)
3645 : {
3646 358 : strcat (ref_name, "...%%");
3647 358 : strcat (ref_name, comp_name);
3648 : }
3649 :
3650 36604 : return ref_name;
3651 : }
3652 :
3653 :
3654 : /* Generate code to perform an array index bound check. */
3655 :
3656 : static tree
3657 5774 : trans_array_bound_check (stmtblock_t *block, gfc_ss *ss, tree index, int n,
3658 : locus * where, bool check_upper,
3659 : const char *compname = NULL)
3660 : {
3661 5774 : tree fault;
3662 5774 : tree tmp_lo, tmp_up;
3663 5774 : tree descriptor;
3664 5774 : char *msg;
3665 5774 : char *ref_name = NULL;
3666 5774 : const char * name = NULL;
3667 5774 : gfc_expr *expr;
3668 :
3669 5774 : if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
3670 : return index;
3671 :
3672 252 : descriptor = ss->info->data.array.descriptor;
3673 :
3674 252 : index = gfc_evaluate_now (index, block);
3675 :
3676 : /* We find a name for the error message. */
3677 252 : name = ss->info->expr->symtree->n.sym->name;
3678 252 : gcc_assert (name != NULL);
3679 :
3680 : /* When we have a component ref, get name of the array section.
3681 : Note that there can only be one part ref. */
3682 252 : expr = ss->info->expr;
3683 252 : if (expr->ref && !compname)
3684 160 : name = ref_name = abridged_ref_name (expr, NULL);
3685 :
3686 252 : if (VAR_P (descriptor))
3687 162 : name = IDENTIFIER_POINTER (DECL_NAME (descriptor));
3688 :
3689 : /* Use given (array component) name. */
3690 252 : if (compname)
3691 92 : name = compname;
3692 :
3693 : /* If upper bound is present, include both bounds in the error message. */
3694 252 : if (check_upper)
3695 : {
3696 225 : tmp_lo = gfc_conv_array_lbound (descriptor, n);
3697 225 : tmp_up = gfc_conv_array_ubound (descriptor, n);
3698 :
3699 225 : if (name)
3700 225 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3701 : "outside of expected range (%%ld:%%ld)", n+1, name);
3702 : else
3703 0 : msg = xasprintf ("Index '%%ld' of dimension %d "
3704 : "outside of expected range (%%ld:%%ld)", n+1);
3705 :
3706 225 : fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3707 : index, tmp_lo);
3708 225 : gfc_trans_runtime_check (true, false, fault, block, where, msg,
3709 : fold_convert (long_integer_type_node, index),
3710 : fold_convert (long_integer_type_node, tmp_lo),
3711 : fold_convert (long_integer_type_node, tmp_up));
3712 225 : fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3713 : index, tmp_up);
3714 225 : gfc_trans_runtime_check (true, false, fault, block, where, msg,
3715 : fold_convert (long_integer_type_node, index),
3716 : fold_convert (long_integer_type_node, tmp_lo),
3717 : fold_convert (long_integer_type_node, tmp_up));
3718 225 : free (msg);
3719 : }
3720 : else
3721 : {
3722 27 : tmp_lo = gfc_conv_array_lbound (descriptor, n);
3723 :
3724 27 : if (name)
3725 27 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3726 : "below lower bound of %%ld", n+1, name);
3727 : else
3728 0 : msg = xasprintf ("Index '%%ld' of dimension %d "
3729 : "below lower bound of %%ld", n+1);
3730 :
3731 27 : fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3732 : index, tmp_lo);
3733 27 : gfc_trans_runtime_check (true, false, fault, block, where, msg,
3734 : fold_convert (long_integer_type_node, index),
3735 : fold_convert (long_integer_type_node, tmp_lo));
3736 27 : free (msg);
3737 : }
3738 :
3739 252 : free (ref_name);
3740 252 : return index;
3741 : }
3742 :
3743 :
3744 : /* Helper functions to detect impure functions in an expression. */
3745 :
3746 : static const char *impure_name = NULL;
3747 : static bool
3748 108 : expr_contains_impure_fcn (gfc_expr *e, gfc_symbol* sym ATTRIBUTE_UNUSED,
3749 : int* g ATTRIBUTE_UNUSED)
3750 : {
3751 108 : if (e && e->expr_type == EXPR_FUNCTION
3752 6 : && !gfc_pure_function (e, &impure_name)
3753 111 : && !gfc_implicit_pure_function (e))
3754 3 : return true;
3755 :
3756 : return false;
3757 : }
3758 :
3759 : static bool
3760 92 : gfc_expr_contains_impure_fcn (gfc_expr *e)
3761 : {
3762 92 : impure_name = NULL;
3763 92 : return gfc_traverse_expr (e, NULL, &expr_contains_impure_fcn, 0);
3764 : }
3765 :
3766 :
3767 : /* Generate code for bounds checking for elemental dimensions. */
3768 :
3769 : static void
3770 6688 : array_bound_check_elemental (stmtblock_t *block, gfc_ss * ss, gfc_expr * expr)
3771 : {
3772 6688 : gfc_array_ref *ar;
3773 6688 : gfc_ref *ref;
3774 6688 : char *var_name = NULL;
3775 6688 : int dim;
3776 :
3777 6688 : if (expr->expr_type == EXPR_VARIABLE)
3778 : {
3779 12533 : for (ref = expr->ref; ref; ref = ref->next)
3780 : {
3781 6303 : if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
3782 : {
3783 3953 : ar = &ref->u.ar;
3784 3953 : var_name = abridged_ref_name (expr, ar);
3785 12111 : for (dim = 0; dim < ar->dimen; dim++)
3786 : {
3787 4205 : if (ar->dimen_type[dim] == DIMEN_ELEMENT)
3788 : {
3789 92 : if (gfc_expr_contains_impure_fcn (ar->start[dim]))
3790 3 : gfc_warning_now (0, "Bounds checking of the elemental "
3791 : "index at %L will cause two calls to "
3792 : "%qs, which is not declared to be "
3793 : "PURE or is not implicitly pure.",
3794 3 : &ar->start[dim]->where, impure_name);
3795 92 : gfc_se indexse;
3796 92 : gfc_init_se (&indexse, NULL);
3797 92 : gfc_conv_expr_type (&indexse, ar->start[dim],
3798 : gfc_array_index_type);
3799 92 : gfc_add_block_to_block (block, &indexse.pre);
3800 92 : trans_array_bound_check (block, ss, indexse.expr, dim,
3801 : &ar->where,
3802 92 : ar->as->type != AS_ASSUMED_SIZE
3803 0 : || dim < ar->dimen - 1,
3804 : var_name);
3805 : }
3806 : }
3807 3953 : free (var_name);
3808 : }
3809 : }
3810 : }
3811 6688 : }
3812 :
3813 :
3814 : /* Return the offset for an index. Performs bound checking for elemental
3815 : dimensions. Single element references are processed separately.
3816 : DIM is the array dimension, I is the loop dimension. */
3817 :
3818 : static tree
3819 258421 : conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i,
3820 : gfc_array_ref * ar, tree stride)
3821 : {
3822 258421 : gfc_array_info *info;
3823 258421 : tree index;
3824 258421 : tree desc;
3825 258421 : tree data;
3826 :
3827 258421 : info = &ss->info->data.array;
3828 :
3829 : /* Get the index into the array for this dimension. */
3830 258421 : if (ar)
3831 : {
3832 183578 : gcc_assert (ar->type != AR_ELEMENT);
3833 183578 : switch (ar->dimen_type[dim])
3834 : {
3835 0 : case DIMEN_THIS_IMAGE:
3836 0 : gcc_unreachable ();
3837 4699 : break;
3838 4699 : case DIMEN_ELEMENT:
3839 : /* Elemental dimension. */
3840 4699 : gcc_assert (info->subscript[dim]
3841 : && info->subscript[dim]->info->type == GFC_SS_SCALAR);
3842 : /* We've already translated this value outside the loop. */
3843 4699 : index = info->subscript[dim]->info->data.scalar.value;
3844 :
3845 9474 : index = trans_array_bound_check (&se->pre, ss, index, dim, &ar->where,
3846 4699 : ar->as->type != AS_ASSUMED_SIZE
3847 76 : || dim < ar->dimen - 1);
3848 4699 : break;
3849 :
3850 983 : case DIMEN_VECTOR:
3851 983 : gcc_assert (info && se->loop);
3852 983 : gcc_assert (info->subscript[dim]
3853 : && info->subscript[dim]->info->type == GFC_SS_VECTOR);
3854 983 : desc = info->subscript[dim]->info->data.array.descriptor;
3855 :
3856 : /* Get a zero-based index into the vector. */
3857 983 : index = fold_build2_loc (input_location, MINUS_EXPR,
3858 : gfc_array_index_type,
3859 : se->loop->loopvar[i], se->loop->from[i]);
3860 :
3861 : /* Multiply the index by the stride. */
3862 983 : index = fold_build2_loc (input_location, MULT_EXPR,
3863 : gfc_array_index_type,
3864 : index, gfc_conv_array_stride (desc, 0));
3865 :
3866 : /* Read the vector to get an index into info->descriptor. */
3867 983 : data = build_fold_indirect_ref_loc (input_location,
3868 : gfc_conv_array_data (desc));
3869 983 : index = gfc_build_array_ref (data, index, NULL);
3870 983 : index = gfc_evaluate_now (index, &se->pre);
3871 983 : index = fold_convert (gfc_array_index_type, index);
3872 :
3873 : /* Do any bounds checking on the final info->descriptor index. */
3874 1972 : index = trans_array_bound_check (&se->pre, ss, index, dim, &ar->where,
3875 983 : ar->as->type != AS_ASSUMED_SIZE
3876 6 : || dim < ar->dimen - 1);
3877 983 : break;
3878 :
3879 177896 : case DIMEN_RANGE:
3880 : /* Scalarized dimension. */
3881 177896 : gcc_assert (info && se->loop);
3882 :
3883 : /* Multiply the loop variable by the stride and delta. */
3884 177896 : index = se->loop->loopvar[i];
3885 177896 : if (!integer_onep (info->stride[dim]))
3886 6990 : index = fold_build2_loc (input_location, MULT_EXPR,
3887 : gfc_array_index_type, index,
3888 : info->stride[dim]);
3889 177896 : if (!integer_zerop (info->delta[dim]))
3890 68581 : index = fold_build2_loc (input_location, PLUS_EXPR,
3891 : gfc_array_index_type, index,
3892 : info->delta[dim]);
3893 : break;
3894 :
3895 0 : default:
3896 0 : gcc_unreachable ();
3897 : }
3898 : }
3899 : else
3900 : {
3901 : /* Temporary array or derived type component. */
3902 74843 : gcc_assert (se->loop);
3903 74843 : index = se->loop->loopvar[se->loop->order[i]];
3904 :
3905 : /* Pointer functions can have stride[0] different from unity.
3906 : Use the stride returned by the function call and stored in
3907 : the descriptor for the temporary. */
3908 74843 : if (se->ss && se->ss->info->type == GFC_SS_FUNCTION
3909 8106 : && se->ss->info->expr
3910 8106 : && se->ss->info->expr->symtree
3911 8106 : && se->ss->info->expr->symtree->n.sym->result
3912 7666 : && se->ss->info->expr->symtree->n.sym->result->attr.pointer)
3913 174 : stride = gfc_conv_descriptor_stride_get (info->descriptor,
3914 : gfc_rank_cst[dim]);
3915 :
3916 74843 : if (info->delta[dim] && !integer_zerop (info->delta[dim]))
3917 804 : index = fold_build2_loc (input_location, PLUS_EXPR,
3918 : gfc_array_index_type, index, info->delta[dim]);
3919 : }
3920 :
3921 : /* Multiply by the stride. */
3922 258421 : if (stride != NULL && !integer_onep (stride))
3923 78765 : index = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
3924 : index, stride);
3925 :
3926 258421 : return index;
3927 : }
3928 :
3929 :
3930 : /* Build a scalarized array reference using the vptr 'size'. */
3931 :
3932 : static bool
3933 198498 : build_class_array_ref (gfc_se *se, tree base, tree index)
3934 : {
3935 198498 : tree size;
3936 198498 : tree decl = NULL_TREE;
3937 198498 : tree tmp;
3938 198498 : gfc_expr *expr = se->ss->info->expr;
3939 198498 : gfc_expr *class_expr;
3940 198498 : gfc_typespec *ts;
3941 198498 : gfc_symbol *sym;
3942 :
3943 198498 : tmp = !VAR_P (base) ? gfc_get_class_from_expr (base) : NULL_TREE;
3944 :
3945 93466 : if (tmp != NULL_TREE)
3946 : decl = tmp;
3947 : else
3948 : {
3949 : /* The base expression does not contain a class component, either
3950 : because it is a temporary array or array descriptor. Class
3951 : array functions are correctly resolved above. */
3952 195041 : if (!expr
3953 195041 : || (expr->ts.type != BT_CLASS
3954 180736 : && !gfc_is_class_array_ref (expr, NULL)))
3955 : return false;
3956 :
3957 : /* Obtain the expression for the class entity or component that is
3958 : followed by an array reference, which is not an element, so that
3959 : the span of the array can be obtained. */
3960 483 : class_expr = gfc_find_and_cut_at_last_class_ref (expr, false, &ts);
3961 :
3962 483 : if (!ts)
3963 : return false;
3964 :
3965 458 : sym = (!class_expr && expr) ? expr->symtree->n.sym : NULL;
3966 0 : if (sym && sym->attr.function
3967 0 : && sym == sym->result
3968 0 : && sym->backend_decl == current_function_decl)
3969 : /* The temporary is the data field of the class data component
3970 : of the current function. */
3971 0 : decl = gfc_get_fake_result_decl (sym, 0);
3972 458 : else if (sym)
3973 : {
3974 0 : if (decl == NULL_TREE)
3975 0 : decl = expr->symtree->n.sym->backend_decl;
3976 : /* For class arrays the tree containing the class is stored in
3977 : GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl.
3978 : For all others it's sym's backend_decl directly. */
3979 0 : if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl))
3980 0 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
3981 : }
3982 : else
3983 458 : decl = gfc_get_class_from_gfc_expr (class_expr);
3984 :
3985 458 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
3986 0 : decl = build_fold_indirect_ref_loc (input_location, decl);
3987 :
3988 458 : if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl)))
3989 : return false;
3990 : }
3991 :
3992 3915 : se->class_vptr = gfc_evaluate_now (gfc_class_vptr_get (decl), &se->pre);
3993 :
3994 3915 : size = gfc_class_vtab_size_get (decl);
3995 : /* For unlimited polymorphic entities then _len component needs to be
3996 : multiplied with the size. */
3997 3915 : size = gfc_resize_class_size_with_len (&se->pre, decl, size);
3998 3915 : size = fold_convert (TREE_TYPE (index), size);
3999 :
4000 : /* Return the element in the se expression. */
4001 3915 : se->expr = gfc_build_spanned_array_ref (base, index, size);
4002 3915 : return true;
4003 : }
4004 :
4005 :
4006 : /* Indicates that the tree EXPR is a reference to an array that can’t
4007 : have any negative stride. */
4008 :
4009 : static bool
4010 320861 : non_negative_strides_array_p (tree expr)
4011 : {
4012 334938 : if (expr == NULL_TREE)
4013 : return false;
4014 :
4015 334938 : tree type = TREE_TYPE (expr);
4016 334938 : if (POINTER_TYPE_P (type))
4017 75867 : type = TREE_TYPE (type);
4018 :
4019 334938 : if (TYPE_LANG_SPECIFIC (type))
4020 : {
4021 334938 : gfc_array_kind array_kind = GFC_TYPE_ARRAY_AKIND (type);
4022 :
4023 334938 : if (array_kind == GFC_ARRAY_ALLOCATABLE
4024 334938 : || array_kind == GFC_ARRAY_ASSUMED_SHAPE_CONT)
4025 : return true;
4026 : }
4027 :
4028 : /* An array with descriptor can have negative strides.
4029 : We try to be conservative and return false by default here
4030 : if we don’t recognize a contiguous array instead of
4031 : returning false if we can identify a non-contiguous one. */
4032 276874 : if (!GFC_ARRAY_TYPE_P (type))
4033 : return false;
4034 :
4035 : /* If the array was originally a dummy with a descriptor, strides can be
4036 : negative. */
4037 241172 : if (DECL_P (expr)
4038 232076 : && DECL_LANG_SPECIFIC (expr)
4039 48852 : && GFC_DECL_SAVED_DESCRIPTOR (expr)
4040 255268 : && GFC_DECL_SAVED_DESCRIPTOR (expr) != expr)
4041 14077 : return non_negative_strides_array_p (GFC_DECL_SAVED_DESCRIPTOR (expr));
4042 :
4043 : return true;
4044 : }
4045 :
4046 :
4047 : /* Build a scalarized reference to an array. */
4048 :
4049 : static void
4050 198498 : gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar,
4051 : bool tmp_array = false)
4052 : {
4053 198498 : gfc_array_info *info;
4054 198498 : tree decl = NULL_TREE;
4055 198498 : tree index;
4056 198498 : tree base;
4057 198498 : gfc_ss *ss;
4058 198498 : gfc_expr *expr;
4059 198498 : int n;
4060 :
4061 198498 : ss = se->ss;
4062 198498 : expr = ss->info->expr;
4063 198498 : info = &ss->info->data.array;
4064 198498 : if (ar)
4065 135831 : n = se->loop->order[0];
4066 : else
4067 : n = 0;
4068 :
4069 198498 : index = conv_array_index_offset (se, ss, ss->dim[n], n, ar, info->stride0);
4070 : /* Add the offset for this dimension to the stored offset for all other
4071 : dimensions. */
4072 198498 : if (info->offset && !integer_zerop (info->offset))
4073 145579 : index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4074 : index, info->offset);
4075 :
4076 198498 : base = build_fold_indirect_ref_loc (input_location, info->data);
4077 :
4078 : /* Use the vptr 'size' field to access the element of a class array. */
4079 198498 : if (build_class_array_ref (se, base, index))
4080 3915 : return;
4081 :
4082 194583 : if (get_CFI_desc (NULL, expr, &decl, ar))
4083 442 : decl = build_fold_indirect_ref_loc (input_location, decl);
4084 :
4085 : /* A pointer array component can be detected from its field decl. Fix
4086 : the descriptor, mark the resulting variable decl and pass it to
4087 : gfc_build_array_ref. */
4088 194583 : if (is_span_addressed_array (info->descriptor)
4089 194583 : || (expr && ((expr->ts.deferred && info->descriptor
4090 2842 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info->descriptor)))
4091 194583 : || (expr && gfc_expr_attr (expr).pdt_string))))
4092 : {
4093 9902 : if (TREE_CODE (info->descriptor) == COMPONENT_REF)
4094 1642 : decl = info->descriptor;
4095 8260 : else if (INDIRECT_REF_P (info->descriptor))
4096 1491 : decl = TREE_OPERAND (info->descriptor, 0);
4097 :
4098 9902 : if (decl == NULL_TREE)
4099 6769 : decl = info->descriptor;
4100 : }
4101 :
4102 194583 : bool non_negative_stride = tmp_array
4103 194583 : || non_negative_strides_array_p (info->descriptor);
4104 194583 : se->expr = gfc_build_array_ref (base, index, decl,
4105 : non_negative_stride);
4106 : }
4107 :
4108 :
4109 : /* Translate access of temporary array. */
4110 :
4111 : void
4112 62667 : gfc_conv_tmp_array_ref (gfc_se * se)
4113 : {
4114 62667 : se->string_length = se->ss->info->string_length;
4115 62667 : gfc_conv_scalarized_array_ref (se, NULL, true);
4116 62667 : gfc_advance_se_ss_chain (se);
4117 62667 : }
4118 :
4119 : /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
4120 :
4121 : static void
4122 283696 : add_to_offset (tree *cst_offset, tree *offset, tree t)
4123 : {
4124 283696 : if (TREE_CODE (t) == INTEGER_CST)
4125 142906 : *cst_offset = int_const_binop (PLUS_EXPR, *cst_offset, t);
4126 : else
4127 : {
4128 140790 : if (!integer_zerop (*offset))
4129 49071 : *offset = fold_build2_loc (input_location, PLUS_EXPR,
4130 : gfc_array_index_type, *offset, t);
4131 : else
4132 91719 : *offset = t;
4133 : }
4134 283696 : }
4135 :
4136 :
4137 : static tree
4138 188551 : build_array_ref (tree desc, tree offset, tree decl, tree vptr)
4139 : {
4140 188551 : tree tmp;
4141 188551 : tree type;
4142 188551 : tree cdesc;
4143 :
4144 : /* For class arrays the class declaration is stored in the saved
4145 : descriptor. */
4146 188551 : if (INDIRECT_REF_P (desc)
4147 7376 : && DECL_LANG_SPECIFIC (TREE_OPERAND (desc, 0))
4148 190897 : && GFC_DECL_SAVED_DESCRIPTOR (TREE_OPERAND (desc, 0)))
4149 911 : cdesc = gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (
4150 : TREE_OPERAND (desc, 0)));
4151 : else
4152 : cdesc = desc;
4153 :
4154 : /* Class container types do not always have the GFC_CLASS_TYPE_P
4155 : but the canonical type does. */
4156 188551 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdesc))
4157 188551 : && TREE_CODE (cdesc) == COMPONENT_REF)
4158 : {
4159 11884 : type = TREE_TYPE (TREE_OPERAND (cdesc, 0));
4160 11884 : if (TYPE_CANONICAL (type)
4161 11884 : && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type)))
4162 : {
4163 3709 : vptr = gfc_class_vptr_get (TREE_OPERAND (cdesc, 0));
4164 : /* Pass the class container as decl so that gfc_build_array_ref can
4165 : correct the element size for an unlimited polymorphic character
4166 : payload (the _len field), which the vptr size alone omits. Only do
4167 : this for a genuine array element reference; a scalar coarray has
4168 : nothing to span-correct and gfc_build_array_ref asserts decl is null
4169 : for it. */
4170 3709 : if (decl == NULL_TREE
4171 3709 : && GFC_TYPE_ARRAY_RANK (TREE_TYPE (cdesc)) > 0)
4172 3420 : decl = TREE_OPERAND (cdesc, 0);
4173 : }
4174 : }
4175 :
4176 188551 : if (decl == NULL_TREE
4177 188551 : && is_span_addressed_array (desc))
4178 : decl = desc;
4179 :
4180 188551 : tmp = gfc_conv_array_data (desc);
4181 188551 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
4182 188551 : tmp = gfc_build_array_ref (tmp, offset, decl,
4183 : non_negative_strides_array_p (desc),
4184 : vptr);
4185 188551 : return tmp;
4186 : }
4187 :
4188 :
4189 : /* Build an array reference. se->expr already holds the array descriptor.
4190 : This should be either a variable, indirect variable reference or component
4191 : reference. For arrays which do not have a descriptor, se->expr will be
4192 : the data pointer.
4193 : a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
4194 :
4195 : void
4196 268513 : gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
4197 : locus * where)
4198 : {
4199 268513 : int n;
4200 268513 : tree offset, cst_offset;
4201 268513 : tree tmp;
4202 268513 : tree stride;
4203 268513 : tree decl = NULL_TREE;
4204 268513 : gfc_se indexse;
4205 268513 : gfc_se tmpse;
4206 268513 : gfc_symbol * sym = expr->symtree->n.sym;
4207 268513 : char *var_name = NULL;
4208 :
4209 268513 : if (ar->stat)
4210 : {
4211 3 : gfc_se statse;
4212 :
4213 3 : gfc_init_se (&statse, NULL);
4214 3 : gfc_conv_expr_lhs (&statse, ar->stat);
4215 3 : gfc_add_block_to_block (&se->pre, &statse.pre);
4216 3 : gfc_add_modify (&se->pre, statse.expr, integer_zero_node);
4217 : }
4218 268513 : if (ar->dimen == 0)
4219 : {
4220 4591 : gcc_assert (ar->codimen || sym->attr.select_rank_temporary
4221 : || (ar->as && ar->as->corank));
4222 :
4223 4591 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
4224 1002 : se->expr = build_fold_indirect_ref (gfc_conv_array_data (se->expr));
4225 : else
4226 : {
4227 3589 : if (GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr))
4228 3589 : && TREE_CODE (TREE_TYPE (se->expr)) == POINTER_TYPE)
4229 2626 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
4230 :
4231 : /* Use the actual tree type and not the wrapped coarray. */
4232 3589 : if (!se->want_pointer)
4233 2608 : se->expr = fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se->expr)),
4234 : se->expr);
4235 : }
4236 :
4237 140422 : return;
4238 : }
4239 :
4240 : /* Handle scalarized references separately. */
4241 263922 : if (ar->type != AR_ELEMENT)
4242 : {
4243 135831 : gfc_conv_scalarized_array_ref (se, ar);
4244 135831 : gfc_advance_se_ss_chain (se);
4245 135831 : return;
4246 : }
4247 :
4248 128091 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
4249 11849 : var_name = abridged_ref_name (expr, ar);
4250 :
4251 128091 : decl = se->expr;
4252 128091 : if (UNLIMITED_POLY(sym)
4253 104 : && IS_CLASS_ARRAY (sym)
4254 103 : && sym->attr.dummy
4255 60 : && ar->as->type != AS_DEFERRED)
4256 48 : decl = sym->backend_decl;
4257 :
4258 128091 : cst_offset = offset = gfc_index_zero_node;
4259 128091 : add_to_offset (&cst_offset, &offset, gfc_conv_array_offset (decl));
4260 :
4261 : /* Calculate the offsets from all the dimensions. Make sure to associate
4262 : the final offset so that we form a chain of loop invariant summands. */
4263 283696 : for (n = ar->dimen - 1; n >= 0; n--)
4264 : {
4265 : /* Calculate the index for this dimension. */
4266 155605 : gfc_init_se (&indexse, se);
4267 155605 : gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
4268 155605 : gfc_add_block_to_block (&se->pre, &indexse.pre);
4269 :
4270 155605 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && ! expr->no_bounds_check)
4271 : {
4272 : /* Check array bounds. */
4273 15389 : tree cond;
4274 15389 : char *msg;
4275 :
4276 : /* Evaluate the indexse.expr only once. */
4277 15389 : indexse.expr = save_expr (indexse.expr);
4278 :
4279 : /* Lower bound. */
4280 15389 : tmp = gfc_conv_array_lbound (decl, n);
4281 15389 : if (sym->attr.temporary)
4282 : {
4283 18 : gfc_init_se (&tmpse, se);
4284 18 : gfc_conv_expr_type (&tmpse, ar->as->lower[n],
4285 : gfc_array_index_type);
4286 18 : gfc_add_block_to_block (&se->pre, &tmpse.pre);
4287 18 : tmp = tmpse.expr;
4288 : }
4289 :
4290 15389 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
4291 : indexse.expr, tmp);
4292 15389 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4293 : "below lower bound of %%ld", n+1, var_name);
4294 15389 : gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
4295 : fold_convert (long_integer_type_node,
4296 : indexse.expr),
4297 : fold_convert (long_integer_type_node, tmp));
4298 15389 : free (msg);
4299 :
4300 : /* Upper bound, but not for the last dimension of assumed-size
4301 : arrays. */
4302 15389 : if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE)
4303 : {
4304 13656 : tmp = gfc_conv_array_ubound (decl, n);
4305 13656 : if (sym->attr.temporary)
4306 : {
4307 18 : gfc_init_se (&tmpse, se);
4308 18 : gfc_conv_expr_type (&tmpse, ar->as->upper[n],
4309 : gfc_array_index_type);
4310 18 : gfc_add_block_to_block (&se->pre, &tmpse.pre);
4311 18 : tmp = tmpse.expr;
4312 : }
4313 :
4314 13656 : cond = fold_build2_loc (input_location, GT_EXPR,
4315 : logical_type_node, indexse.expr, tmp);
4316 13656 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4317 : "above upper bound of %%ld", n+1, var_name);
4318 13656 : gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
4319 : fold_convert (long_integer_type_node,
4320 : indexse.expr),
4321 : fold_convert (long_integer_type_node, tmp));
4322 13656 : free (msg);
4323 : }
4324 : }
4325 :
4326 : /* Multiply the index by the stride. */
4327 155605 : stride = gfc_conv_array_stride (decl, n);
4328 155605 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4329 : indexse.expr, stride);
4330 :
4331 : /* And add it to the total. */
4332 155605 : add_to_offset (&cst_offset, &offset, tmp);
4333 : }
4334 :
4335 128091 : if (!integer_zerop (cst_offset))
4336 67988 : offset = fold_build2_loc (input_location, PLUS_EXPR,
4337 : gfc_array_index_type, offset, cst_offset);
4338 :
4339 : /* A pointer array component can be detected from its field decl. Fix
4340 : the descriptor, mark the resulting variable decl and pass it to
4341 : build_array_ref. */
4342 128091 : decl = NULL_TREE;
4343 128091 : if (get_CFI_desc (sym, expr, &decl, ar))
4344 3589 : decl = build_fold_indirect_ref_loc (input_location, decl);
4345 126948 : if (!expr->ts.deferred && !sym->attr.codimension
4346 252813 : && is_span_addressed_array (se->expr))
4347 : {
4348 5391 : if (INDIRECT_REF_P (se->expr))
4349 990 : decl = TREE_OPERAND (se->expr, 0);
4350 : else
4351 4401 : decl = se->expr;
4352 : }
4353 122700 : else if (expr->ts.deferred
4354 121557 : || (sym->ts.type == BT_CHARACTER
4355 15455 : && sym->attr.select_type_temporary)
4356 242541 : || (expr->ts.type == BT_CHARACTER
4357 15880 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr))
4358 5380 : && gfc_expr_attr (expr).pdt_string))
4359 : {
4360 2967 : decl = se->expr;
4361 2967 : if (INDIRECT_REF_P (decl))
4362 20 : decl = TREE_OPERAND (decl, 0);
4363 : }
4364 119733 : else if (sym->ts.type == BT_CLASS)
4365 : {
4366 2263 : if (UNLIMITED_POLY (sym))
4367 : {
4368 103 : gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr);
4369 103 : gfc_init_se (&tmpse, NULL);
4370 103 : gfc_conv_expr (&tmpse, class_expr);
4371 103 : if (!se->class_vptr)
4372 103 : se->class_vptr = gfc_class_vptr_get (tmpse.expr);
4373 103 : gfc_free_expr (class_expr);
4374 103 : decl = tmpse.expr;
4375 103 : }
4376 : else
4377 2160 : decl = NULL_TREE;
4378 : }
4379 :
4380 128091 : free (var_name);
4381 128091 : se->expr = build_array_ref (se->expr, offset, decl, se->class_vptr);
4382 : }
4383 :
4384 :
4385 : /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
4386 : LOOP_DIM dimension (if any) to array's offset. */
4387 :
4388 : static void
4389 59923 : add_array_offset (stmtblock_t *pblock, gfc_loopinfo *loop, gfc_ss *ss,
4390 : gfc_array_ref *ar, int array_dim, int loop_dim)
4391 : {
4392 59923 : gfc_se se;
4393 59923 : gfc_array_info *info;
4394 59923 : tree stride, index;
4395 :
4396 59923 : info = &ss->info->data.array;
4397 :
4398 59923 : gfc_init_se (&se, NULL);
4399 59923 : se.loop = loop;
4400 59923 : se.expr = info->descriptor;
4401 59923 : stride = gfc_conv_array_stride (info->descriptor, array_dim);
4402 59923 : index = conv_array_index_offset (&se, ss, array_dim, loop_dim, ar, stride);
4403 59923 : gfc_add_block_to_block (pblock, &se.pre);
4404 :
4405 59923 : info->offset = fold_build2_loc (input_location, PLUS_EXPR,
4406 : gfc_array_index_type,
4407 : info->offset, index);
4408 59923 : info->offset = gfc_evaluate_now (info->offset, pblock);
4409 59923 : }
4410 :
4411 :
4412 : /* Generate the code to be executed immediately before entering a
4413 : scalarization loop. */
4414 :
4415 : static void
4416 149699 : gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
4417 : stmtblock_t * pblock)
4418 : {
4419 149699 : tree stride;
4420 149699 : gfc_ss_info *ss_info;
4421 149699 : gfc_array_info *info;
4422 149699 : gfc_ss_type ss_type;
4423 149699 : gfc_ss *ss, *pss;
4424 149699 : gfc_loopinfo *ploop;
4425 149699 : gfc_array_ref *ar;
4426 :
4427 : /* This code will be executed before entering the scalarization loop
4428 : for this dimension. */
4429 455839 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4430 : {
4431 306140 : ss_info = ss->info;
4432 :
4433 306140 : if ((ss_info->useflags & flag) == 0)
4434 1476 : continue;
4435 :
4436 304664 : ss_type = ss_info->type;
4437 371426 : if (ss_type != GFC_SS_SECTION
4438 : && ss_type != GFC_SS_FUNCTION
4439 304664 : && ss_type != GFC_SS_CONSTRUCTOR
4440 304664 : && ss_type != GFC_SS_COMPONENT)
4441 66762 : continue;
4442 :
4443 237902 : info = &ss_info->data.array;
4444 :
4445 237902 : gcc_assert (dim < ss->dimen);
4446 237902 : gcc_assert (ss->dimen == loop->dimen);
4447 :
4448 237902 : if (info->ref)
4449 167696 : ar = &info->ref->u.ar;
4450 : else
4451 : ar = NULL;
4452 :
4453 237902 : if (dim == loop->dimen - 1 && loop->parent != NULL)
4454 : {
4455 : /* If we are in the outermost dimension of this loop, the previous
4456 : dimension shall be in the parent loop. */
4457 4687 : gcc_assert (ss->parent != NULL);
4458 :
4459 4687 : pss = ss->parent;
4460 4687 : ploop = loop->parent;
4461 :
4462 : /* ss and ss->parent are about the same array. */
4463 4687 : gcc_assert (ss_info == pss->info);
4464 : }
4465 : else
4466 : {
4467 : ploop = loop;
4468 : pss = ss;
4469 : }
4470 :
4471 237902 : if (dim == loop->dimen - 1 && loop->parent == NULL)
4472 : {
4473 182678 : gcc_assert (0 == ploop->order[0]);
4474 :
4475 365356 : stride = gfc_conv_array_stride (info->descriptor,
4476 182678 : innermost_ss (ss)->dim[0]);
4477 :
4478 : /* Calculate the stride of the innermost loop. Hopefully this will
4479 : allow the backend optimizers to do their stuff more effectively.
4480 : */
4481 182678 : info->stride0 = gfc_evaluate_now (stride, pblock);
4482 :
4483 : /* For the outermost loop calculate the offset due to any
4484 : elemental dimensions. It will have been initialized with the
4485 : base offset of the array. */
4486 182678 : if (info->ref)
4487 : {
4488 294637 : for (int i = 0; i < ar->dimen; i++)
4489 : {
4490 169989 : if (ar->dimen_type[i] != DIMEN_ELEMENT)
4491 165290 : continue;
4492 :
4493 4699 : add_array_offset (pblock, loop, ss, ar, i, /* unused */ -1);
4494 : }
4495 : }
4496 : }
4497 : else
4498 : {
4499 55224 : int i;
4500 :
4501 55224 : if (dim == loop->dimen - 1)
4502 : i = 0;
4503 : else
4504 50537 : i = dim + 1;
4505 :
4506 : /* For the time being, there is no loop reordering. */
4507 55224 : gcc_assert (i == ploop->order[i]);
4508 55224 : i = ploop->order[i];
4509 :
4510 : /* Add the offset for the previous loop dimension. */
4511 55224 : add_array_offset (pblock, ploop, ss, ar, pss->dim[i], i);
4512 : }
4513 :
4514 : /* Remember this offset for the second loop. */
4515 237902 : if (dim == loop->temp_dim - 1 && loop->parent == NULL)
4516 55637 : info->saved_offset = info->offset;
4517 : }
4518 149699 : }
4519 :
4520 :
4521 : /* Start a scalarized expression. Creates a scope and declares loop
4522 : variables. */
4523 :
4524 : void
4525 119081 : gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
4526 : {
4527 119081 : int dim;
4528 119081 : int n;
4529 119081 : int flags;
4530 :
4531 119081 : gcc_assert (!loop->array_parameter);
4532 :
4533 267184 : for (dim = loop->dimen - 1; dim >= 0; dim--)
4534 : {
4535 148103 : n = loop->order[dim];
4536 :
4537 148103 : gfc_start_block (&loop->code[n]);
4538 :
4539 : /* Create the loop variable. */
4540 148103 : loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
4541 :
4542 148103 : if (dim < loop->temp_dim)
4543 : flags = 3;
4544 : else
4545 101523 : flags = 1;
4546 : /* Calculate values that will be constant within this loop. */
4547 148103 : gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
4548 : }
4549 119081 : gfc_start_block (pbody);
4550 119081 : }
4551 :
4552 :
4553 : /* Generates the actual loop code for a scalarization loop. */
4554 :
4555 : static void
4556 164479 : gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
4557 : stmtblock_t * pbody)
4558 : {
4559 164479 : stmtblock_t block;
4560 164479 : tree cond;
4561 164479 : tree tmp;
4562 164479 : tree loopbody;
4563 164479 : tree exit_label;
4564 164479 : tree stmt;
4565 164479 : tree init;
4566 164479 : tree incr;
4567 :
4568 164479 : if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS
4569 : | OMPWS_SCALARIZER_BODY))
4570 : == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS)
4571 108 : && n == loop->dimen - 1)
4572 : {
4573 : /* We create an OMP_FOR construct for the outermost scalarized loop. */
4574 80 : init = make_tree_vec (1);
4575 80 : cond = make_tree_vec (1);
4576 80 : incr = make_tree_vec (1);
4577 :
4578 : /* Cycle statement is implemented with a goto. Exit statement must not
4579 : be present for this loop. */
4580 80 : exit_label = gfc_build_label_decl (NULL_TREE);
4581 80 : TREE_USED (exit_label) = 1;
4582 :
4583 : /* Label for cycle statements (if needed). */
4584 80 : tmp = build1_v (LABEL_EXPR, exit_label);
4585 80 : gfc_add_expr_to_block (pbody, tmp);
4586 :
4587 80 : stmt = make_node (OMP_FOR);
4588 :
4589 80 : TREE_TYPE (stmt) = void_type_node;
4590 80 : OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody);
4591 :
4592 80 : OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location,
4593 : OMP_CLAUSE_SCHEDULE);
4594 80 : OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt))
4595 80 : = OMP_CLAUSE_SCHEDULE_STATIC;
4596 80 : if (ompws_flags & OMPWS_NOWAIT)
4597 33 : OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt))
4598 66 : = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT);
4599 :
4600 : /* Initialize the loopvar. */
4601 80 : TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n],
4602 : loop->from[n]);
4603 80 : OMP_FOR_INIT (stmt) = init;
4604 : /* The exit condition. */
4605 80 : TREE_VEC_ELT (cond, 0) = build2_loc (input_location, LE_EXPR,
4606 : logical_type_node,
4607 : loop->loopvar[n], loop->to[n]);
4608 80 : SET_EXPR_LOCATION (TREE_VEC_ELT (cond, 0), input_location);
4609 80 : OMP_FOR_COND (stmt) = cond;
4610 : /* Increment the loopvar. */
4611 80 : tmp = build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4612 : loop->loopvar[n], gfc_index_one_node);
4613 80 : TREE_VEC_ELT (incr, 0) = fold_build2_loc (input_location, MODIFY_EXPR,
4614 : void_type_node, loop->loopvar[n], tmp);
4615 80 : OMP_FOR_INCR (stmt) = incr;
4616 :
4617 80 : ompws_flags &= ~OMPWS_CURR_SINGLEUNIT;
4618 80 : gfc_add_expr_to_block (&loop->code[n], stmt);
4619 : }
4620 : else
4621 : {
4622 328798 : bool reverse_loop = (loop->reverse[n] == GFC_REVERSE_SET)
4623 164399 : && (loop->temp_ss == NULL);
4624 :
4625 164399 : loopbody = gfc_finish_block (pbody);
4626 :
4627 164399 : if (reverse_loop)
4628 204 : std::swap (loop->from[n], loop->to[n]);
4629 :
4630 : /* Initialize the loopvar. */
4631 164399 : if (loop->loopvar[n] != loop->from[n])
4632 163578 : gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
4633 :
4634 164399 : exit_label = gfc_build_label_decl (NULL_TREE);
4635 :
4636 : /* Generate the loop body. */
4637 164399 : gfc_init_block (&block);
4638 :
4639 : /* The exit condition. */
4640 328594 : cond = fold_build2_loc (input_location, reverse_loop ? LT_EXPR : GT_EXPR,
4641 : logical_type_node, loop->loopvar[n], loop->to[n]);
4642 164399 : tmp = build1_v (GOTO_EXPR, exit_label);
4643 164399 : TREE_USED (exit_label) = 1;
4644 164399 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
4645 164399 : gfc_add_expr_to_block (&block, tmp);
4646 :
4647 : /* The main body. */
4648 164399 : gfc_add_expr_to_block (&block, loopbody);
4649 :
4650 : /* Increment the loopvar. */
4651 328594 : tmp = fold_build2_loc (input_location,
4652 : reverse_loop ? MINUS_EXPR : PLUS_EXPR,
4653 : gfc_array_index_type, loop->loopvar[n],
4654 : gfc_index_one_node);
4655 :
4656 164399 : gfc_add_modify (&block, loop->loopvar[n], tmp);
4657 :
4658 : /* Build the loop. */
4659 164399 : tmp = gfc_finish_block (&block);
4660 164399 : tmp = build1_v (LOOP_EXPR, tmp);
4661 164399 : gfc_add_expr_to_block (&loop->code[n], tmp);
4662 :
4663 : /* Add the exit label. */
4664 164399 : tmp = build1_v (LABEL_EXPR, exit_label);
4665 164399 : gfc_add_expr_to_block (&loop->code[n], tmp);
4666 : }
4667 :
4668 164479 : }
4669 :
4670 :
4671 : /* Finishes and generates the loops for a scalarized expression. */
4672 :
4673 : void
4674 125637 : gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
4675 : {
4676 125637 : int dim;
4677 125637 : int n;
4678 125637 : gfc_ss *ss;
4679 125637 : stmtblock_t *pblock;
4680 125637 : tree tmp;
4681 :
4682 125637 : pblock = body;
4683 : /* Generate the loops. */
4684 280287 : for (dim = 0; dim < loop->dimen; dim++)
4685 : {
4686 154650 : n = loop->order[dim];
4687 154650 : gfc_trans_scalarized_loop_end (loop, n, pblock);
4688 154650 : loop->loopvar[n] = NULL_TREE;
4689 154650 : pblock = &loop->code[n];
4690 : }
4691 :
4692 125637 : tmp = gfc_finish_block (pblock);
4693 125637 : gfc_add_expr_to_block (&loop->pre, tmp);
4694 :
4695 : /* Clear all the used flags. */
4696 366872 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4697 241235 : if (ss->parent == NULL)
4698 236485 : ss->info->useflags = 0;
4699 125637 : }
4700 :
4701 :
4702 : /* Finish the main body of a scalarized expression, and start the secondary
4703 : copying body. */
4704 :
4705 : void
4706 8233 : gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
4707 : {
4708 8233 : int dim;
4709 8233 : int n;
4710 8233 : stmtblock_t *pblock;
4711 8233 : gfc_ss *ss;
4712 :
4713 8233 : pblock = body;
4714 : /* We finish as many loops as are used by the temporary. */
4715 9829 : for (dim = 0; dim < loop->temp_dim - 1; dim++)
4716 : {
4717 1596 : n = loop->order[dim];
4718 1596 : gfc_trans_scalarized_loop_end (loop, n, pblock);
4719 1596 : loop->loopvar[n] = NULL_TREE;
4720 1596 : pblock = &loop->code[n];
4721 : }
4722 :
4723 : /* We don't want to finish the outermost loop entirely. */
4724 8233 : n = loop->order[loop->temp_dim - 1];
4725 8233 : gfc_trans_scalarized_loop_end (loop, n, pblock);
4726 :
4727 : /* Restore the initial offsets. */
4728 23603 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4729 : {
4730 15370 : gfc_ss_type ss_type;
4731 15370 : gfc_ss_info *ss_info;
4732 :
4733 15370 : ss_info = ss->info;
4734 :
4735 15370 : if ((ss_info->useflags & 2) == 0)
4736 4546 : continue;
4737 :
4738 10824 : ss_type = ss_info->type;
4739 10978 : if (ss_type != GFC_SS_SECTION
4740 : && ss_type != GFC_SS_FUNCTION
4741 10824 : && ss_type != GFC_SS_CONSTRUCTOR
4742 10824 : && ss_type != GFC_SS_COMPONENT)
4743 154 : continue;
4744 :
4745 10670 : ss_info->data.array.offset = ss_info->data.array.saved_offset;
4746 : }
4747 :
4748 : /* Restart all the inner loops we just finished. */
4749 9829 : for (dim = loop->temp_dim - 2; dim >= 0; dim--)
4750 : {
4751 1596 : n = loop->order[dim];
4752 :
4753 1596 : gfc_start_block (&loop->code[n]);
4754 :
4755 1596 : loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
4756 :
4757 1596 : gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
4758 : }
4759 :
4760 : /* Start a block for the secondary copying code. */
4761 8233 : gfc_start_block (body);
4762 8233 : }
4763 :
4764 :
4765 : /* Precalculate (either lower or upper) bound of an array section.
4766 : BLOCK: Block in which the (pre)calculation code will go.
4767 : BOUNDS[DIM]: Where the bound value will be stored once evaluated.
4768 : VALUES[DIM]: Specified bound (NULL <=> unspecified).
4769 : DESC: Array descriptor from which the bound will be picked if unspecified
4770 : (either lower or upper bound according to LBOUND). */
4771 :
4772 : static void
4773 525187 : evaluate_bound (stmtblock_t *block, tree *bounds, gfc_expr ** values,
4774 : tree desc, int dim, bool lbound, bool deferred, bool save_value)
4775 : {
4776 525187 : gfc_se se;
4777 525187 : gfc_expr * input_val = values[dim];
4778 525187 : tree *output = &bounds[dim];
4779 :
4780 525187 : if (input_val)
4781 : {
4782 : /* Specified section bound. */
4783 48270 : gfc_init_se (&se, NULL);
4784 48270 : gfc_conv_expr_type (&se, input_val, gfc_array_index_type);
4785 48270 : gfc_add_block_to_block (block, &se.pre);
4786 48270 : *output = se.expr;
4787 : }
4788 476917 : else if (deferred && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
4789 : {
4790 : /* The gfc_conv_array_lbound () routine returns a constant zero for
4791 : deferred length arrays, which in the scalarizer wreaks havoc, when
4792 : copying to a (newly allocated) one-based array.
4793 : Keep returning the actual result in sync for both bounds. */
4794 194930 : *output = lbound ? gfc_conv_descriptor_lbound_get (desc,
4795 : gfc_rank_cst[dim]):
4796 65090 : gfc_conv_descriptor_ubound_get (desc,
4797 : gfc_rank_cst[dim]);
4798 : }
4799 : else
4800 : {
4801 : /* No specific bound specified so use the bound of the array. */
4802 517173 : *output = lbound ? gfc_conv_array_lbound (desc, dim) :
4803 170096 : gfc_conv_array_ubound (desc, dim);
4804 : }
4805 525187 : if (save_value)
4806 505793 : *output = gfc_evaluate_now (*output, block);
4807 525187 : }
4808 :
4809 :
4810 : /* Calculate the lower bound of an array section. */
4811 :
4812 : static void
4813 263204 : gfc_conv_section_startstride (stmtblock_t * block, gfc_ss * ss, int dim)
4814 : {
4815 263204 : gfc_expr *stride = NULL;
4816 263204 : tree desc;
4817 263204 : gfc_se se;
4818 263204 : gfc_array_info *info;
4819 263204 : gfc_array_ref *ar;
4820 :
4821 263204 : gcc_assert (ss->info->type == GFC_SS_SECTION);
4822 :
4823 263204 : info = &ss->info->data.array;
4824 263204 : ar = &info->ref->u.ar;
4825 :
4826 263204 : if (ar->dimen_type[dim] == DIMEN_VECTOR)
4827 : {
4828 : /* We use a zero-based index to access the vector. */
4829 986 : info->start[dim] = gfc_index_zero_node;
4830 986 : info->end[dim] = NULL;
4831 986 : info->stride[dim] = gfc_index_one_node;
4832 986 : return;
4833 : }
4834 :
4835 262218 : gcc_assert (ar->dimen_type[dim] == DIMEN_RANGE
4836 : || ar->dimen_type[dim] == DIMEN_THIS_IMAGE);
4837 262218 : desc = info->descriptor;
4838 262218 : stride = ar->stride[dim];
4839 262218 : bool save_value = !ss->is_alloc_lhs;
4840 :
4841 : /* Calculate the start of the range. For vector subscripts this will
4842 : be the range of the vector. */
4843 262218 : evaluate_bound (block, info->start, ar->start, desc, dim, true,
4844 262218 : ar->as->type == AS_DEFERRED, save_value);
4845 :
4846 : /* Similarly calculate the end. Although this is not used in the
4847 : scalarizer, it is needed when checking bounds and where the end
4848 : is an expression with side-effects. */
4849 262218 : evaluate_bound (block, info->end, ar->end, desc, dim, false,
4850 262218 : ar->as->type == AS_DEFERRED, save_value);
4851 :
4852 :
4853 : /* Calculate the stride. */
4854 262218 : if (stride == NULL)
4855 249282 : info->stride[dim] = gfc_index_one_node;
4856 : else
4857 : {
4858 12936 : gfc_init_se (&se, NULL);
4859 12936 : gfc_conv_expr_type (&se, stride, gfc_array_index_type);
4860 12936 : gfc_add_block_to_block (block, &se.pre);
4861 12936 : tree value = se.expr;
4862 12936 : if (save_value)
4863 12936 : info->stride[dim] = gfc_evaluate_now (value, block);
4864 : else
4865 0 : info->stride[dim] = value;
4866 : }
4867 : }
4868 :
4869 :
4870 : /* Generate in INNER the bounds checking code along the dimension DIM for
4871 : the array associated with SS_INFO. */
4872 :
4873 : static void
4874 24078 : add_check_section_in_array_bounds (stmtblock_t *inner, gfc_ss_info *ss_info,
4875 : int dim)
4876 : {
4877 24078 : gfc_expr *expr = ss_info->expr;
4878 24078 : locus *expr_loc = &expr->where;
4879 24078 : const char *expr_name = expr->symtree->name;
4880 :
4881 24078 : gfc_array_info *info = &ss_info->data.array;
4882 :
4883 24078 : bool check_upper;
4884 24078 : if (dim == info->ref->u.ar.dimen - 1
4885 20451 : && info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
4886 : check_upper = false;
4887 : else
4888 23782 : check_upper = true;
4889 :
4890 : /* Zero stride is not allowed. */
4891 24078 : tree tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
4892 : info->stride[dim], gfc_index_zero_node);
4893 24078 : char * msg = xasprintf ("Zero stride is not allowed, for dimension %d "
4894 : "of array '%s'", dim + 1, expr_name);
4895 24078 : gfc_trans_runtime_check (true, false, tmp, inner, expr_loc, msg);
4896 24078 : free (msg);
4897 :
4898 24078 : tree desc = info->descriptor;
4899 :
4900 : /* This is the run-time equivalent of resolve.cc's
4901 : check_dimension. The logical is more readable there
4902 : than it is here, with all the trees. */
4903 24078 : tree lbound = gfc_conv_array_lbound (desc, dim);
4904 24078 : tree end = info->end[dim];
4905 24078 : tree ubound = check_upper ? gfc_conv_array_ubound (desc, dim) : NULL_TREE;
4906 :
4907 : /* non_zerosized is true when the selected range is not
4908 : empty. */
4909 24078 : tree stride_pos = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
4910 : info->stride[dim], gfc_index_zero_node);
4911 24078 : tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
4912 : info->start[dim], end);
4913 24078 : stride_pos = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4914 : logical_type_node, stride_pos, tmp);
4915 :
4916 24078 : tree stride_neg = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
4917 : info->stride[dim], gfc_index_zero_node);
4918 24078 : tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
4919 : info->start[dim], end);
4920 24078 : stride_neg = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4921 : logical_type_node, stride_neg, tmp);
4922 24078 : tree non_zerosized = fold_build2_loc (input_location, TRUTH_OR_EXPR,
4923 : logical_type_node, stride_pos,
4924 : stride_neg);
4925 :
4926 : /* Check the start of the range against the lower and upper
4927 : bounds of the array, if the range is not empty.
4928 : If upper bound is present, include both bounds in the
4929 : error message. */
4930 24078 : if (check_upper)
4931 : {
4932 23782 : tmp = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
4933 : info->start[dim], lbound);
4934 23782 : tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
4935 : non_zerosized, tmp);
4936 23782 : tree tmp2 = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
4937 : info->start[dim], ubound);
4938 23782 : tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
4939 : non_zerosized, tmp2);
4940 23782 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' outside of "
4941 : "expected range (%%ld:%%ld)", dim + 1, expr_name);
4942 23782 : gfc_trans_runtime_check (true, false, tmp, inner, expr_loc, msg,
4943 : fold_convert (long_integer_type_node, info->start[dim]),
4944 : fold_convert (long_integer_type_node, lbound),
4945 : fold_convert (long_integer_type_node, ubound));
4946 23782 : gfc_trans_runtime_check (true, false, tmp2, inner, expr_loc, msg,
4947 : fold_convert (long_integer_type_node, info->start[dim]),
4948 : fold_convert (long_integer_type_node, lbound),
4949 : fold_convert (long_integer_type_node, ubound));
4950 23782 : free (msg);
4951 : }
4952 : else
4953 : {
4954 296 : tmp = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
4955 : info->start[dim], lbound);
4956 296 : tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
4957 : non_zerosized, tmp);
4958 296 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' below "
4959 : "lower bound of %%ld", dim + 1, expr_name);
4960 296 : gfc_trans_runtime_check (true, false, tmp, inner, expr_loc, msg,
4961 : fold_convert (long_integer_type_node, info->start[dim]),
4962 : fold_convert (long_integer_type_node, lbound));
4963 296 : free (msg);
4964 : }
4965 :
4966 : /* Compute the last element of the range, which is not
4967 : necessarily "end" (think 0:5:3, which doesn't contain 5)
4968 : and check it against both lower and upper bounds. */
4969 :
4970 24078 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4971 : end, info->start[dim]);
4972 24078 : tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR, gfc_array_index_type,
4973 : tmp, info->stride[dim]);
4974 24078 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4975 : end, tmp);
4976 24078 : tree tmp2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
4977 : tmp, lbound);
4978 24078 : tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
4979 : non_zerosized, tmp2);
4980 24078 : if (check_upper)
4981 : {
4982 23782 : tree tmp3 = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
4983 : tmp, ubound);
4984 23782 : tmp3 = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
4985 : non_zerosized, tmp3);
4986 23782 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' outside of "
4987 : "expected range (%%ld:%%ld)", dim + 1, expr_name);
4988 23782 : gfc_trans_runtime_check (true, false, tmp2, inner, expr_loc, msg,
4989 : fold_convert (long_integer_type_node, tmp),
4990 : fold_convert (long_integer_type_node, ubound),
4991 : fold_convert (long_integer_type_node, lbound));
4992 23782 : gfc_trans_runtime_check (true, false, tmp3, inner, expr_loc, msg,
4993 : fold_convert (long_integer_type_node, tmp),
4994 : fold_convert (long_integer_type_node, ubound),
4995 : fold_convert (long_integer_type_node, lbound));
4996 23782 : free (msg);
4997 : }
4998 : else
4999 : {
5000 296 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' below "
5001 : "lower bound of %%ld", dim + 1, expr_name);
5002 296 : gfc_trans_runtime_check (true, false, tmp2, inner, expr_loc, msg,
5003 : fold_convert (long_integer_type_node, tmp),
5004 : fold_convert (long_integer_type_node, lbound));
5005 296 : free (msg);
5006 : }
5007 24078 : }
5008 :
5009 :
5010 : /* Tells whether we need to generate bounds checking code for the array
5011 : associated with SS. */
5012 :
5013 : bool
5014 25045 : bounds_check_needed (gfc_ss *ss)
5015 : {
5016 : /* Catch allocatable lhs in f2003. */
5017 25045 : if (flag_realloc_lhs && ss->no_bounds_check)
5018 : return false;
5019 :
5020 24768 : gfc_ss_info *ss_info = ss->info;
5021 24768 : if (ss_info->type == GFC_SS_SECTION)
5022 : return true;
5023 :
5024 4126 : if (!(ss_info->type == GFC_SS_INTRINSIC
5025 227 : && ss_info->expr
5026 227 : && ss_info->expr->expr_type == EXPR_FUNCTION))
5027 : return false;
5028 :
5029 227 : gfc_intrinsic_sym *isym = ss_info->expr->value.function.isym;
5030 227 : if (!(isym
5031 227 : && (isym->id == GFC_ISYM_MAXLOC
5032 203 : || isym->id == GFC_ISYM_MINLOC)))
5033 : return false;
5034 :
5035 34 : return gfc_inline_intrinsic_function_p (ss_info->expr);
5036 : }
5037 :
5038 :
5039 : /* Calculates the range start and stride for a SS chain. Also gets the
5040 : descriptor and data pointer. The range of vector subscripts is the size
5041 : of the vector. Array bounds are also checked. */
5042 :
5043 : void
5044 187988 : gfc_conv_ss_startstride (gfc_loopinfo * loop)
5045 : {
5046 187988 : int n;
5047 187988 : tree tmp;
5048 187988 : gfc_ss *ss;
5049 :
5050 187988 : gfc_loopinfo * const outer_loop = outermost_loop (loop);
5051 :
5052 187988 : loop->dimen = 0;
5053 : /* Determine the rank of the loop. */
5054 208670 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5055 : {
5056 208670 : switch (ss->info->type)
5057 : {
5058 176583 : case GFC_SS_SECTION:
5059 176583 : case GFC_SS_CONSTRUCTOR:
5060 176583 : case GFC_SS_FUNCTION:
5061 176583 : case GFC_SS_COMPONENT:
5062 176583 : loop->dimen = ss->dimen;
5063 176583 : goto done;
5064 :
5065 : /* As usual, lbound and ubound are exceptions!. */
5066 11405 : case GFC_SS_INTRINSIC:
5067 11405 : switch (ss->info->expr->value.function.isym->id)
5068 : {
5069 11405 : case GFC_ISYM_LBOUND:
5070 11405 : case GFC_ISYM_UBOUND:
5071 11405 : case GFC_ISYM_COSHAPE:
5072 11405 : case GFC_ISYM_LCOBOUND:
5073 11405 : case GFC_ISYM_UCOBOUND:
5074 11405 : case GFC_ISYM_MAXLOC:
5075 11405 : case GFC_ISYM_MINLOC:
5076 11405 : case GFC_ISYM_SHAPE:
5077 11405 : case GFC_ISYM_THIS_IMAGE:
5078 11405 : loop->dimen = ss->dimen;
5079 11405 : goto done;
5080 :
5081 : default:
5082 : break;
5083 : }
5084 :
5085 20682 : default:
5086 20682 : break;
5087 : }
5088 : }
5089 :
5090 : /* We should have determined the rank of the expression by now. If
5091 : not, that's bad news. */
5092 0 : gcc_unreachable ();
5093 :
5094 187988 : done:
5095 : /* Loop over all the SS in the chain. */
5096 488399 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5097 : {
5098 300411 : gfc_ss_info *ss_info;
5099 300411 : gfc_array_info *info;
5100 300411 : gfc_expr *expr;
5101 :
5102 300411 : ss_info = ss->info;
5103 300411 : expr = ss_info->expr;
5104 300411 : info = &ss_info->data.array;
5105 :
5106 300411 : if (expr && expr->shape && !info->shape)
5107 173779 : info->shape = expr->shape;
5108 :
5109 300411 : switch (ss_info->type)
5110 : {
5111 190547 : case GFC_SS_SECTION:
5112 : /* Get the descriptor for the array. If it is a cross loops array,
5113 : we got the descriptor already in the outermost loop. */
5114 190547 : if (ss->parent == NULL)
5115 185911 : gfc_conv_ss_descriptor (&outer_loop->pre, ss,
5116 185911 : !loop->array_parameter);
5117 :
5118 452923 : for (n = 0; n < ss->dimen; n++)
5119 262376 : gfc_conv_section_startstride (&outer_loop->pre, ss, ss->dim[n]);
5120 : break;
5121 :
5122 11698 : case GFC_SS_INTRINSIC:
5123 11698 : switch (expr->value.function.isym->id)
5124 : {
5125 3297 : case GFC_ISYM_MINLOC:
5126 3297 : case GFC_ISYM_MAXLOC:
5127 3297 : {
5128 3297 : gfc_se se;
5129 3297 : gfc_init_se (&se, nullptr);
5130 3297 : se.loop = loop;
5131 3297 : se.ss = ss;
5132 3297 : gfc_conv_intrinsic_function (&se, expr);
5133 3297 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
5134 3297 : gfc_add_block_to_block (&outer_loop->post, &se.post);
5135 :
5136 3297 : info->descriptor = se.expr;
5137 :
5138 3297 : info->data = gfc_conv_array_data (info->descriptor);
5139 3297 : info->data = gfc_evaluate_now (info->data, &outer_loop->pre);
5140 :
5141 3297 : gfc_expr *array = expr->value.function.actual->expr;
5142 3297 : tree rank = build_int_cst (gfc_array_index_type, array->rank);
5143 :
5144 3297 : tree tmp = fold_build2_loc (input_location, MINUS_EXPR,
5145 : gfc_array_index_type, rank,
5146 : gfc_index_one_node);
5147 :
5148 3297 : info->end[0] = gfc_evaluate_now (tmp, &outer_loop->pre);
5149 3297 : info->start[0] = gfc_index_zero_node;
5150 3297 : info->stride[0] = gfc_index_one_node;
5151 3297 : info->offset = gfc_index_zero_node;
5152 3297 : continue;
5153 3297 : }
5154 :
5155 : /* Fall through to supply start and stride. */
5156 3004 : case GFC_ISYM_LBOUND:
5157 3004 : case GFC_ISYM_UBOUND:
5158 : /* This is the variant without DIM=... */
5159 3004 : gcc_assert (expr->value.function.actual->next->expr == NULL);
5160 : /* Fall through. */
5161 :
5162 8022 : case GFC_ISYM_SHAPE:
5163 8022 : {
5164 8022 : gfc_expr *arg;
5165 :
5166 8022 : arg = expr->value.function.actual->expr;
5167 8022 : if (arg->rank == -1)
5168 : {
5169 1175 : gfc_se se;
5170 1175 : tree rank, tmp;
5171 :
5172 : /* The rank (hence the return value's shape) is unknown,
5173 : we have to retrieve it. */
5174 1175 : gfc_init_se (&se, NULL);
5175 1175 : se.descriptor_only = 1;
5176 1175 : gfc_conv_expr (&se, arg);
5177 : /* This is a bare variable, so there is no preliminary
5178 : or cleanup code unless -std=f202y and bounds checking
5179 : is on. */
5180 1175 : if (!((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
5181 0 : && (gfc_option.allow_std & GFC_STD_F202Y)))
5182 1175 : gcc_assert (se.pre.head == NULL_TREE
5183 : && se.post.head == NULL_TREE);
5184 1175 : rank = gfc_conv_descriptor_rank_get (se.expr);
5185 1175 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
5186 : gfc_array_index_type,
5187 : fold_convert (gfc_array_index_type,
5188 : rank),
5189 : gfc_index_one_node);
5190 1175 : info->end[0] = gfc_evaluate_now (tmp, &outer_loop->pre);
5191 1175 : info->start[0] = gfc_index_zero_node;
5192 1175 : info->stride[0] = gfc_index_one_node;
5193 1175 : continue;
5194 1175 : }
5195 : /* Otherwise fall through GFC_SS_FUNCTION. */
5196 : gcc_fallthrough ();
5197 : }
5198 : case GFC_ISYM_COSHAPE:
5199 : case GFC_ISYM_LCOBOUND:
5200 : case GFC_ISYM_UCOBOUND:
5201 : case GFC_ISYM_THIS_IMAGE:
5202 : break;
5203 :
5204 0 : default:
5205 0 : continue;
5206 0 : }
5207 :
5208 : /* FALLTHRU */
5209 : case GFC_SS_CONSTRUCTOR:
5210 : case GFC_SS_FUNCTION:
5211 133088 : for (n = 0; n < ss->dimen; n++)
5212 : {
5213 71745 : int dim = ss->dim[n];
5214 :
5215 71745 : info->start[dim] = gfc_index_zero_node;
5216 71745 : if (ss_info->type != GFC_SS_FUNCTION)
5217 57046 : info->end[dim] = gfc_index_zero_node;
5218 71745 : info->stride[dim] = gfc_index_one_node;
5219 : }
5220 : break;
5221 :
5222 : default:
5223 : break;
5224 : }
5225 : }
5226 :
5227 : /* The rest is just runtime bounds checking. */
5228 187988 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
5229 : {
5230 16945 : stmtblock_t block;
5231 16945 : tree size[GFC_MAX_DIMENSIONS];
5232 16945 : tree tmp3;
5233 16945 : gfc_array_info *info;
5234 16945 : char *msg;
5235 16945 : int dim;
5236 :
5237 16945 : gfc_start_block (&block);
5238 :
5239 54257 : for (n = 0; n < loop->dimen; n++)
5240 20367 : size[n] = NULL_TREE;
5241 :
5242 : /* If there is a constructor involved, derive size[] from its shape. */
5243 39164 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5244 : {
5245 24699 : gfc_ss_info *ss_info;
5246 :
5247 24699 : ss_info = ss->info;
5248 24699 : info = &ss_info->data.array;
5249 :
5250 24699 : if (ss_info->type == GFC_SS_CONSTRUCTOR && info->shape)
5251 : {
5252 5224 : for (n = 0; n < loop->dimen; n++)
5253 : {
5254 2744 : if (size[n] == NULL)
5255 : {
5256 2744 : gcc_assert (info->shape[n]);
5257 2744 : size[n] = gfc_conv_mpz_to_tree (info->shape[n],
5258 : gfc_index_integer_kind);
5259 : }
5260 : }
5261 : break;
5262 : }
5263 : }
5264 :
5265 41990 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5266 : {
5267 25045 : stmtblock_t inner;
5268 25045 : gfc_ss_info *ss_info;
5269 25045 : gfc_expr *expr;
5270 25045 : locus *expr_loc;
5271 25045 : const char *expr_name;
5272 25045 : char *ref_name = NULL;
5273 :
5274 25045 : if (!bounds_check_needed (ss))
5275 4369 : continue;
5276 :
5277 20676 : ss_info = ss->info;
5278 20676 : expr = ss_info->expr;
5279 20676 : expr_loc = &expr->where;
5280 20676 : if (expr->ref)
5281 20642 : expr_name = ref_name = abridged_ref_name (expr, NULL);
5282 : else
5283 34 : expr_name = expr->symtree->name;
5284 :
5285 20676 : gfc_start_block (&inner);
5286 :
5287 : /* TODO: range checking for mapped dimensions. */
5288 20676 : info = &ss_info->data.array;
5289 :
5290 : /* This code only checks ranges. Elemental and vector
5291 : dimensions are checked later. */
5292 65478 : for (n = 0; n < loop->dimen; n++)
5293 : {
5294 24126 : dim = ss->dim[n];
5295 24126 : if (ss_info->type == GFC_SS_SECTION)
5296 : {
5297 24092 : if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
5298 14 : continue;
5299 :
5300 24078 : add_check_section_in_array_bounds (&inner, ss_info, dim);
5301 : }
5302 :
5303 : /* Check the section sizes match. */
5304 24112 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
5305 : gfc_array_index_type, info->end[dim],
5306 : info->start[dim]);
5307 24112 : tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
5308 : gfc_array_index_type, tmp,
5309 : info->stride[dim]);
5310 24112 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
5311 : gfc_array_index_type,
5312 : gfc_index_one_node, tmp);
5313 24112 : tmp = fold_build2_loc (input_location, MAX_EXPR,
5314 : gfc_array_index_type, tmp,
5315 : build_int_cst (gfc_array_index_type, 0));
5316 : /* We remember the size of the first section, and check all the
5317 : others against this. */
5318 24112 : if (size[n])
5319 : {
5320 7193 : tmp3 = fold_build2_loc (input_location, NE_EXPR,
5321 : logical_type_node, tmp, size[n]);
5322 7193 : if (ss_info->type == GFC_SS_INTRINSIC)
5323 0 : msg = xasprintf ("Extent mismatch for dimension %d of the "
5324 : "result of intrinsic '%s' (%%ld/%%ld)",
5325 : dim + 1, expr_name);
5326 : else
5327 7193 : msg = xasprintf ("Array bound mismatch for dimension %d "
5328 : "of array '%s' (%%ld/%%ld)",
5329 : dim + 1, expr_name);
5330 :
5331 7193 : gfc_trans_runtime_check (true, false, tmp3, &inner,
5332 : expr_loc, msg,
5333 : fold_convert (long_integer_type_node, tmp),
5334 : fold_convert (long_integer_type_node, size[n]));
5335 :
5336 7193 : free (msg);
5337 : }
5338 : else
5339 16919 : size[n] = gfc_evaluate_now (tmp, &inner);
5340 : }
5341 :
5342 20676 : tmp = gfc_finish_block (&inner);
5343 :
5344 : /* For optional arguments, only check bounds if the argument is
5345 : present. */
5346 20676 : if ((expr->symtree->n.sym->attr.optional
5347 20368 : || expr->symtree->n.sym->attr.not_always_present)
5348 308 : && expr->symtree->n.sym->attr.dummy)
5349 307 : tmp = build3_v (COND_EXPR,
5350 : gfc_conv_expr_present (expr->symtree->n.sym),
5351 : tmp, build_empty_stmt (input_location));
5352 :
5353 20676 : gfc_add_expr_to_block (&block, tmp);
5354 :
5355 20676 : free (ref_name);
5356 : }
5357 :
5358 16945 : tmp = gfc_finish_block (&block);
5359 16945 : gfc_add_expr_to_block (&outer_loop->pre, tmp);
5360 : }
5361 :
5362 191352 : for (loop = loop->nested; loop; loop = loop->next)
5363 3364 : gfc_conv_ss_startstride (loop);
5364 187988 : }
5365 :
5366 : /* Return true if both symbols could refer to the same data object. Does
5367 : not take account of aliasing due to equivalence statements. */
5368 :
5369 : static bool
5370 14032 : symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym, bool lsym_pointer,
5371 : bool lsym_target, bool rsym_pointer, bool rsym_target)
5372 : {
5373 : /* Aliasing isn't possible if the symbols have different base types,
5374 : except for complex types where an inquiry reference (%RE, %IM) could
5375 : alias with a real type with the same kind parameter. */
5376 14032 : if (!gfc_compare_types (&lsym->ts, &rsym->ts)
5377 14032 : && !(((lsym->ts.type == BT_COMPLEX && rsym->ts.type == BT_REAL)
5378 5073 : || (lsym->ts.type == BT_REAL && rsym->ts.type == BT_COMPLEX))
5379 76 : && lsym->ts.kind == rsym->ts.kind))
5380 : return false;
5381 :
5382 : /* Pointers can point to other pointers and target objects. */
5383 :
5384 8972 : if ((lsym_pointer && (rsym_pointer || rsym_target))
5385 8763 : || (rsym_pointer && (lsym_pointer || lsym_target)))
5386 : return true;
5387 :
5388 : /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
5389 : and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
5390 : checked above. */
5391 8849 : if (lsym_target && rsym_target
5392 14 : && ((lsym->attr.dummy && !lsym->attr.contiguous
5393 0 : && (!lsym->attr.dimension || lsym->as->type == AS_ASSUMED_SHAPE))
5394 14 : || (rsym->attr.dummy && !rsym->attr.contiguous
5395 6 : && (!rsym->attr.dimension
5396 6 : || rsym->as->type == AS_ASSUMED_SHAPE))))
5397 6 : return true;
5398 :
5399 : return false;
5400 : }
5401 :
5402 :
5403 : /* Return true if the two SS could be aliased, i.e. both point to the same data
5404 : object. */
5405 : /* TODO: resolve aliases based on frontend expressions. */
5406 :
5407 : static int
5408 11710 : gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
5409 : {
5410 11710 : gfc_ref *lref;
5411 11710 : gfc_ref *rref;
5412 11710 : gfc_expr *lexpr, *rexpr;
5413 11710 : gfc_symbol *lsym;
5414 11710 : gfc_symbol *rsym;
5415 11710 : bool lsym_pointer, lsym_target, rsym_pointer, rsym_target;
5416 :
5417 11710 : lexpr = lss->info->expr;
5418 11710 : rexpr = rss->info->expr;
5419 :
5420 11710 : lsym = lexpr->symtree->n.sym;
5421 11710 : rsym = rexpr->symtree->n.sym;
5422 :
5423 11710 : lsym_pointer = lsym->attr.pointer;
5424 11710 : lsym_target = lsym->attr.target;
5425 11710 : rsym_pointer = rsym->attr.pointer;
5426 11710 : rsym_target = rsym->attr.target;
5427 :
5428 11710 : if (symbols_could_alias (lsym, rsym, lsym_pointer, lsym_target,
5429 : rsym_pointer, rsym_target))
5430 : return 1;
5431 :
5432 11619 : if (rsym->ts.type != BT_DERIVED && rsym->ts.type != BT_CLASS
5433 10184 : && lsym->ts.type != BT_DERIVED && lsym->ts.type != BT_CLASS)
5434 : return 0;
5435 :
5436 : /* For derived types we must check all the component types. We can ignore
5437 : array references as these will have the same base type as the previous
5438 : component ref. */
5439 2968 : for (lref = lexpr->ref; lref != lss->info->data.array.ref; lref = lref->next)
5440 : {
5441 1085 : if (lref->type != REF_COMPONENT)
5442 107 : continue;
5443 :
5444 978 : lsym_pointer = lsym_pointer || lref->u.c.sym->attr.pointer;
5445 978 : lsym_target = lsym_target || lref->u.c.sym->attr.target;
5446 :
5447 978 : if (symbols_could_alias (lref->u.c.sym, rsym, lsym_pointer, lsym_target,
5448 : rsym_pointer, rsym_target))
5449 : return 1;
5450 :
5451 978 : if ((lsym_pointer && (rsym_pointer || rsym_target))
5452 963 : || (rsym_pointer && (lsym_pointer || lsym_target)))
5453 : {
5454 6 : if (gfc_compare_types (&lref->u.c.component->ts,
5455 : &rsym->ts))
5456 : return 1;
5457 : }
5458 :
5459 1468 : for (rref = rexpr->ref; rref != rss->info->data.array.ref;
5460 496 : rref = rref->next)
5461 : {
5462 497 : if (rref->type != REF_COMPONENT)
5463 36 : continue;
5464 :
5465 461 : rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
5466 461 : rsym_target = lsym_target || rref->u.c.sym->attr.target;
5467 :
5468 461 : if (symbols_could_alias (lref->u.c.sym, rref->u.c.sym,
5469 : lsym_pointer, lsym_target,
5470 : rsym_pointer, rsym_target))
5471 : return 1;
5472 :
5473 460 : if ((lsym_pointer && (rsym_pointer || rsym_target))
5474 456 : || (rsym_pointer && (lsym_pointer || lsym_target)))
5475 : {
5476 0 : if (gfc_compare_types (&lref->u.c.component->ts,
5477 0 : &rref->u.c.sym->ts))
5478 : return 1;
5479 0 : if (gfc_compare_types (&lref->u.c.sym->ts,
5480 0 : &rref->u.c.component->ts))
5481 : return 1;
5482 0 : if (gfc_compare_types (&lref->u.c.component->ts,
5483 0 : &rref->u.c.component->ts))
5484 : return 1;
5485 : }
5486 : }
5487 : }
5488 :
5489 1883 : lsym_pointer = lsym->attr.pointer;
5490 1883 : lsym_target = lsym->attr.target;
5491 :
5492 2760 : for (rref = rexpr->ref; rref != rss->info->data.array.ref; rref = rref->next)
5493 : {
5494 1030 : if (rref->type != REF_COMPONENT)
5495 : break;
5496 :
5497 883 : rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
5498 883 : rsym_target = lsym_target || rref->u.c.sym->attr.target;
5499 :
5500 883 : if (symbols_could_alias (rref->u.c.sym, lsym,
5501 : lsym_pointer, lsym_target,
5502 : rsym_pointer, rsym_target))
5503 : return 1;
5504 :
5505 883 : if ((lsym_pointer && (rsym_pointer || rsym_target))
5506 865 : || (rsym_pointer && (lsym_pointer || lsym_target)))
5507 : {
5508 6 : if (gfc_compare_types (&lsym->ts, &rref->u.c.component->ts))
5509 : return 1;
5510 : }
5511 : }
5512 :
5513 : return 0;
5514 : }
5515 :
5516 :
5517 : /* Resolve array data dependencies. Creates a temporary if required. */
5518 : /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
5519 : dependency.cc. */
5520 :
5521 : void
5522 39078 : gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
5523 : gfc_ss * rss)
5524 : {
5525 39078 : gfc_ss *ss;
5526 39078 : gfc_ref *lref;
5527 39078 : gfc_ref *rref;
5528 39078 : gfc_ss_info *ss_info;
5529 39078 : gfc_expr *dest_expr;
5530 39078 : gfc_expr *ss_expr;
5531 39078 : int nDepend = 0;
5532 39078 : int i, j;
5533 :
5534 39078 : loop->temp_ss = NULL;
5535 39078 : dest_expr = dest->info->expr;
5536 :
5537 84082 : for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
5538 : {
5539 46197 : ss_info = ss->info;
5540 46197 : ss_expr = ss_info->expr;
5541 :
5542 46197 : if (ss_info->array_outer_dependency)
5543 : {
5544 : nDepend = 1;
5545 : break;
5546 : }
5547 :
5548 46080 : if (ss_info->type != GFC_SS_SECTION)
5549 : {
5550 31545 : if (flag_realloc_lhs
5551 30463 : && dest_expr != ss_expr
5552 30463 : && gfc_is_reallocatable_lhs (dest_expr)
5553 38806 : && ss_expr->rank)
5554 3530 : nDepend = gfc_check_dependency (dest_expr, ss_expr, true);
5555 :
5556 : /* Check for cases like c(:)(1:2) = c(2)(2:3) */
5557 31545 : if (!nDepend && dest_expr->rank > 0
5558 31015 : && dest_expr->ts.type == BT_CHARACTER
5559 4838 : && ss_expr->expr_type == EXPR_VARIABLE)
5560 :
5561 165 : nDepend = gfc_check_dependency (dest_expr, ss_expr, false);
5562 :
5563 31545 : if (ss_info->type == GFC_SS_REFERENCE
5564 31545 : && gfc_check_dependency (dest_expr, ss_expr, false))
5565 194 : ss_info->data.scalar.needs_temporary = 1;
5566 :
5567 31545 : if (nDepend)
5568 : break;
5569 : else
5570 31003 : continue;
5571 : }
5572 :
5573 14535 : if (dest_expr->symtree->n.sym != ss_expr->symtree->n.sym)
5574 : {
5575 11710 : if (gfc_could_be_alias (dest, ss)
5576 11710 : || gfc_are_equivalenced_arrays (dest_expr, ss_expr))
5577 : {
5578 : nDepend = 1;
5579 : break;
5580 : }
5581 : }
5582 : else
5583 : {
5584 2825 : lref = dest_expr->ref;
5585 2825 : rref = ss_expr->ref;
5586 :
5587 2825 : nDepend = gfc_dep_resolver (lref, rref, &loop->reverse[0]);
5588 :
5589 2825 : if (nDepend == 1)
5590 : break;
5591 :
5592 5638 : for (i = 0; i < dest->dimen; i++)
5593 7630 : for (j = 0; j < ss->dimen; j++)
5594 4528 : if (i != j
5595 1363 : && dest->dim[i] == ss->dim[j])
5596 : {
5597 : /* If we don't access array elements in the same order,
5598 : there is a dependency. */
5599 63 : nDepend = 1;
5600 63 : goto temporary;
5601 : }
5602 : #if 0
5603 : /* TODO : loop shifting. */
5604 : if (nDepend == 1)
5605 : {
5606 : /* Mark the dimensions for LOOP SHIFTING */
5607 : for (n = 0; n < loop->dimen; n++)
5608 : {
5609 : int dim = dest->data.info.dim[n];
5610 :
5611 : if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
5612 : depends[n] = 2;
5613 : else if (! gfc_is_same_range (&lref->u.ar,
5614 : &rref->u.ar, dim, 0))
5615 : depends[n] = 1;
5616 : }
5617 :
5618 : /* Put all the dimensions with dependencies in the
5619 : innermost loops. */
5620 : dim = 0;
5621 : for (n = 0; n < loop->dimen; n++)
5622 : {
5623 : gcc_assert (loop->order[n] == n);
5624 : if (depends[n])
5625 : loop->order[dim++] = n;
5626 : }
5627 : for (n = 0; n < loop->dimen; n++)
5628 : {
5629 : if (! depends[n])
5630 : loop->order[dim++] = n;
5631 : }
5632 :
5633 : gcc_assert (dim == loop->dimen);
5634 : break;
5635 : }
5636 : #endif
5637 : }
5638 : }
5639 :
5640 831 : temporary:
5641 :
5642 39078 : if (nDepend == 1)
5643 : {
5644 1193 : tree base_type = gfc_typenode_for_spec (&dest_expr->ts);
5645 1193 : if (GFC_ARRAY_TYPE_P (base_type)
5646 1193 : || GFC_DESCRIPTOR_TYPE_P (base_type))
5647 0 : base_type = gfc_get_element_type (base_type);
5648 1193 : loop->temp_ss = gfc_get_temp_ss (base_type, dest->info->string_length,
5649 : loop->dimen);
5650 1193 : gfc_add_ss_to_loop (loop, loop->temp_ss);
5651 : }
5652 : else
5653 37885 : loop->temp_ss = NULL;
5654 39078 : }
5655 :
5656 :
5657 : /* Browse through each array's information from the scalarizer and set the loop
5658 : bounds according to the "best" one (per dimension), i.e. the one which
5659 : provides the most information (constant bounds, shape, etc.). */
5660 :
5661 : static void
5662 187988 : set_loop_bounds (gfc_loopinfo *loop)
5663 : {
5664 187988 : int n, dim, spec_dim;
5665 187988 : gfc_array_info *info;
5666 187988 : gfc_array_info *specinfo;
5667 187988 : gfc_ss *ss;
5668 187988 : tree tmp;
5669 187988 : gfc_ss **loopspec;
5670 187988 : bool dynamic[GFC_MAX_DIMENSIONS];
5671 187988 : mpz_t *cshape;
5672 187988 : mpz_t i;
5673 187988 : bool nonoptional_arr;
5674 :
5675 187988 : gfc_loopinfo * const outer_loop = outermost_loop (loop);
5676 :
5677 187988 : loopspec = loop->specloop;
5678 :
5679 187988 : mpz_init (i);
5680 629980 : for (n = 0; n < loop->dimen; n++)
5681 : {
5682 254004 : loopspec[n] = NULL;
5683 254004 : dynamic[n] = false;
5684 :
5685 : /* If there are both optional and nonoptional array arguments, scalarize
5686 : over the nonoptional; otherwise, it does not matter as then all
5687 : (optional) arrays have to be present per F2008, 125.2.12p3(6). */
5688 :
5689 254004 : nonoptional_arr = false;
5690 :
5691 296400 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5692 296380 : if (ss->info->type != GFC_SS_SCALAR && ss->info->type != GFC_SS_TEMP
5693 260581 : && ss->info->type != GFC_SS_REFERENCE && !ss->info->can_be_null_ref)
5694 : {
5695 : nonoptional_arr = true;
5696 : break;
5697 : }
5698 :
5699 : /* We use one SS term, and use that to determine the bounds of the
5700 : loop for this dimension. We try to pick the simplest term. */
5701 664933 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5702 : {
5703 410929 : gfc_ss_type ss_type;
5704 :
5705 410929 : ss_type = ss->info->type;
5706 482418 : if (ss_type == GFC_SS_SCALAR
5707 410929 : || ss_type == GFC_SS_TEMP
5708 348722 : || ss_type == GFC_SS_REFERENCE
5709 339723 : || (ss->info->can_be_null_ref && nonoptional_arr))
5710 71489 : continue;
5711 :
5712 339440 : info = &ss->info->data.array;
5713 339440 : dim = ss->dim[n];
5714 :
5715 339440 : if (loopspec[n] != NULL)
5716 : {
5717 85436 : specinfo = &loopspec[n]->info->data.array;
5718 85436 : spec_dim = loopspec[n]->dim[n];
5719 : }
5720 : else
5721 : {
5722 : /* Silence uninitialized warnings. */
5723 : specinfo = NULL;
5724 : spec_dim = 0;
5725 : }
5726 :
5727 339440 : if (info->shape)
5728 : {
5729 : /* The frontend has worked out the size for us. */
5730 228829 : if (!loopspec[n]
5731 60482 : || !specinfo->shape
5732 276170 : || !integer_zerop (specinfo->start[spec_dim]))
5733 : /* Prefer zero-based descriptors if possible. */
5734 211600 : loopspec[n] = ss;
5735 228829 : continue;
5736 : }
5737 :
5738 110611 : if (ss_type == GFC_SS_CONSTRUCTOR)
5739 : {
5740 1452 : gfc_constructor_base base;
5741 : /* An unknown size constructor will always be rank one.
5742 : Higher rank constructors will either have known shape,
5743 : or still be wrapped in a call to reshape. */
5744 1452 : gcc_assert (loop->dimen == 1);
5745 :
5746 : /* Always prefer to use the constructor bounds if the size
5747 : can be determined at compile time. Prefer not to otherwise,
5748 : since the general case involves realloc, and it's better to
5749 : avoid that overhead if possible. */
5750 1452 : base = ss->info->expr->value.constructor;
5751 1452 : dynamic[n] = gfc_get_array_constructor_size (&i, base);
5752 1452 : if (!dynamic[n] || !loopspec[n])
5753 1229 : loopspec[n] = ss;
5754 1452 : continue;
5755 1452 : }
5756 :
5757 : /* Avoid using an allocatable lhs in an assignment, since
5758 : there might be a reallocation coming. */
5759 109159 : if (loopspec[n] && ss->is_alloc_lhs)
5760 9697 : continue;
5761 :
5762 99462 : if (!loopspec[n])
5763 84428 : loopspec[n] = ss;
5764 : /* Criteria for choosing a loop specifier (most important first):
5765 : doesn't need realloc
5766 : stride of one
5767 : known stride
5768 : known lower bound
5769 : known upper bound
5770 : */
5771 15034 : else if (loopspec[n]->info->type == GFC_SS_CONSTRUCTOR && dynamic[n])
5772 235 : loopspec[n] = ss;
5773 14799 : else if (integer_onep (info->stride[dim])
5774 14799 : && !integer_onep (specinfo->stride[spec_dim]))
5775 120 : loopspec[n] = ss;
5776 14679 : else if (INTEGER_CST_P (info->stride[dim])
5777 14455 : && !INTEGER_CST_P (specinfo->stride[spec_dim]))
5778 0 : loopspec[n] = ss;
5779 14679 : else if (INTEGER_CST_P (info->start[dim])
5780 4522 : && !INTEGER_CST_P (specinfo->start[spec_dim])
5781 856 : && integer_onep (info->stride[dim])
5782 428 : == integer_onep (specinfo->stride[spec_dim])
5783 14679 : && INTEGER_CST_P (info->stride[dim])
5784 401 : == INTEGER_CST_P (specinfo->stride[spec_dim]))
5785 401 : loopspec[n] = ss;
5786 : /* We don't work out the upper bound.
5787 : else if (INTEGER_CST_P (info->finish[n])
5788 : && ! INTEGER_CST_P (specinfo->finish[n]))
5789 : loopspec[n] = ss; */
5790 : }
5791 :
5792 : /* We should have found the scalarization loop specifier. If not,
5793 : that's bad news. */
5794 254004 : gcc_assert (loopspec[n]);
5795 :
5796 254004 : info = &loopspec[n]->info->data.array;
5797 254004 : dim = loopspec[n]->dim[n];
5798 :
5799 : /* Set the extents of this range. */
5800 254004 : cshape = info->shape;
5801 254004 : if (cshape && INTEGER_CST_P (info->start[dim])
5802 181289 : && INTEGER_CST_P (info->stride[dim]))
5803 : {
5804 181289 : loop->from[n] = info->start[dim];
5805 181289 : mpz_set (i, cshape[get_array_ref_dim_for_loop_dim (loopspec[n], n)]);
5806 181289 : mpz_sub_ui (i, i, 1);
5807 : /* To = from + (size - 1) * stride. */
5808 181289 : tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
5809 181289 : if (!integer_onep (info->stride[dim]))
5810 8803 : tmp = fold_build2_loc (input_location, MULT_EXPR,
5811 : gfc_array_index_type, tmp,
5812 : info->stride[dim]);
5813 181289 : loop->to[n] = fold_build2_loc (input_location, PLUS_EXPR,
5814 : gfc_array_index_type,
5815 : loop->from[n], tmp);
5816 : }
5817 : else
5818 : {
5819 72715 : loop->from[n] = info->start[dim];
5820 72715 : switch (loopspec[n]->info->type)
5821 : {
5822 893 : case GFC_SS_CONSTRUCTOR:
5823 : /* The upper bound is calculated when we expand the
5824 : constructor. */
5825 893 : gcc_assert (loop->to[n] == NULL_TREE);
5826 : break;
5827 :
5828 66028 : case GFC_SS_SECTION:
5829 : /* Use the end expression if it exists and is not constant,
5830 : so that it is only evaluated once. */
5831 66028 : loop->to[n] = info->end[dim];
5832 66028 : break;
5833 :
5834 5015 : case GFC_SS_FUNCTION:
5835 : /* The loop bound will be set when we generate the call. */
5836 5015 : gcc_assert (loop->to[n] == NULL_TREE);
5837 : break;
5838 :
5839 767 : case GFC_SS_INTRINSIC:
5840 767 : {
5841 767 : gfc_expr *expr = loopspec[n]->info->expr;
5842 :
5843 : /* The {l,u}bound of an assumed rank. */
5844 767 : if (expr->value.function.isym->id == GFC_ISYM_SHAPE)
5845 255 : gcc_assert (expr->value.function.actual->expr->rank == -1);
5846 : else
5847 512 : gcc_assert ((expr->value.function.isym->id == GFC_ISYM_LBOUND
5848 : || expr->value.function.isym->id == GFC_ISYM_UBOUND)
5849 : && expr->value.function.actual->next->expr == NULL
5850 : && expr->value.function.actual->expr->rank == -1);
5851 :
5852 767 : loop->to[n] = info->end[dim];
5853 767 : break;
5854 : }
5855 :
5856 12 : case GFC_SS_COMPONENT:
5857 12 : {
5858 12 : if (info->end[dim] != NULL_TREE)
5859 : {
5860 12 : loop->to[n] = info->end[dim];
5861 12 : break;
5862 : }
5863 : else
5864 0 : gcc_unreachable ();
5865 : }
5866 :
5867 0 : default:
5868 0 : gcc_unreachable ();
5869 : }
5870 : }
5871 :
5872 : /* Transform everything so we have a simple incrementing variable. */
5873 254004 : if (integer_onep (info->stride[dim]))
5874 243026 : info->delta[dim] = gfc_index_zero_node;
5875 : else
5876 : {
5877 : /* Set the delta for this section. */
5878 10978 : info->delta[dim] = gfc_evaluate_now (loop->from[n], &outer_loop->pre);
5879 : /* Number of iterations is (end - start + step) / step.
5880 : with start = 0, this simplifies to
5881 : last = end / step;
5882 : for (i = 0; i<=last; i++){...}; */
5883 10978 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
5884 : gfc_array_index_type, loop->to[n],
5885 : loop->from[n]);
5886 10978 : tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
5887 : gfc_array_index_type, tmp, info->stride[dim]);
5888 10978 : tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
5889 : tmp, build_int_cst (gfc_array_index_type, -1));
5890 10978 : loop->to[n] = gfc_evaluate_now (tmp, &outer_loop->pre);
5891 : /* Make the loop variable start at 0. */
5892 10978 : loop->from[n] = gfc_index_zero_node;
5893 : }
5894 : }
5895 187988 : mpz_clear (i);
5896 :
5897 191352 : for (loop = loop->nested; loop; loop = loop->next)
5898 3364 : set_loop_bounds (loop);
5899 187988 : }
5900 :
5901 :
5902 : /* Last attempt to set the loop bounds, in case they depend on an allocatable
5903 : function result. */
5904 :
5905 : static void
5906 187988 : late_set_loop_bounds (gfc_loopinfo *loop)
5907 : {
5908 187988 : int n, dim;
5909 187988 : gfc_array_info *info;
5910 187988 : gfc_ss **loopspec;
5911 :
5912 187988 : loopspec = loop->specloop;
5913 :
5914 441992 : for (n = 0; n < loop->dimen; n++)
5915 : {
5916 : /* Set the extents of this range. */
5917 254004 : if (loop->from[n] == NULL_TREE
5918 254004 : || loop->to[n] == NULL_TREE)
5919 : {
5920 : /* We should have found the scalarization loop specifier. If not,
5921 : that's bad news. */
5922 455 : gcc_assert (loopspec[n]);
5923 :
5924 455 : info = &loopspec[n]->info->data.array;
5925 455 : dim = loopspec[n]->dim[n];
5926 :
5927 455 : if (loopspec[n]->info->type == GFC_SS_FUNCTION
5928 455 : && info->start[dim]
5929 455 : && info->end[dim])
5930 : {
5931 153 : loop->from[n] = info->start[dim];
5932 153 : loop->to[n] = info->end[dim];
5933 : }
5934 : }
5935 : }
5936 :
5937 191352 : for (loop = loop->nested; loop; loop = loop->next)
5938 3364 : late_set_loop_bounds (loop);
5939 187988 : }
5940 :
5941 :
5942 : /* Initialize the scalarization loop. Creates the loop variables. Determines
5943 : the range of the loop variables. Creates a temporary if required.
5944 : Also generates code for scalar expressions which have been
5945 : moved outside the loop. */
5946 :
5947 : void
5948 184624 : gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
5949 : {
5950 184624 : gfc_ss *tmp_ss;
5951 184624 : tree tmp;
5952 :
5953 184624 : set_loop_bounds (loop);
5954 :
5955 : /* Add all the scalar code that can be taken out of the loops.
5956 : This may include calculating the loop bounds, so do it before
5957 : allocating the temporary. */
5958 184624 : gfc_add_loop_ss_code (loop, loop->ss, false, where);
5959 :
5960 184624 : late_set_loop_bounds (loop);
5961 :
5962 184624 : tmp_ss = loop->temp_ss;
5963 : /* If we want a temporary then create it. */
5964 184624 : if (tmp_ss != NULL)
5965 : {
5966 11830 : gfc_ss_info *tmp_ss_info;
5967 :
5968 11830 : tmp_ss_info = tmp_ss->info;
5969 11830 : gcc_assert (tmp_ss_info->type == GFC_SS_TEMP);
5970 11830 : gcc_assert (loop->parent == NULL);
5971 :
5972 : /* Make absolutely sure that this is a complete type. */
5973 11830 : if (tmp_ss_info->string_length)
5974 2833 : tmp_ss_info->data.temp.type
5975 2833 : = gfc_get_character_type_len_for_eltype
5976 2833 : (TREE_TYPE (tmp_ss_info->data.temp.type),
5977 : tmp_ss_info->string_length);
5978 :
5979 11830 : tmp = tmp_ss_info->data.temp.type;
5980 11830 : memset (&tmp_ss_info->data.array, 0, sizeof (gfc_array_info));
5981 11830 : tmp_ss_info->type = GFC_SS_SECTION;
5982 :
5983 11830 : gcc_assert (tmp_ss->dimen != 0);
5984 :
5985 11830 : gfc_trans_create_temp_array (&loop->pre, &loop->post, tmp_ss, tmp,
5986 : NULL_TREE, false, true, false, where);
5987 : }
5988 :
5989 : /* For array parameters we don't have loop variables, so don't calculate the
5990 : translations. */
5991 184624 : if (!loop->array_parameter)
5992 115919 : gfc_set_delta (loop);
5993 184624 : }
5994 :
5995 :
5996 : /* Calculates how to transform from loop variables to array indices for each
5997 : array: once loop bounds are chosen, sets the difference (DELTA field) between
5998 : loop bounds and array reference bounds, for each array info. */
5999 :
6000 : void
6001 119750 : gfc_set_delta (gfc_loopinfo *loop)
6002 : {
6003 119750 : gfc_ss *ss, **loopspec;
6004 119750 : gfc_array_info *info;
6005 119750 : tree tmp;
6006 119750 : int n, dim;
6007 :
6008 119750 : gfc_loopinfo * const outer_loop = outermost_loop (loop);
6009 :
6010 119750 : loopspec = loop->specloop;
6011 :
6012 : /* Calculate the translation from loop variables to array indices. */
6013 362589 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
6014 : {
6015 242839 : gfc_ss_type ss_type;
6016 :
6017 242839 : ss_type = ss->info->type;
6018 62026 : if (!(ss_type == GFC_SS_SECTION
6019 242839 : || ss_type == GFC_SS_COMPONENT
6020 98707 : || ss_type == GFC_SS_CONSTRUCTOR
6021 : || (ss_type == GFC_SS_FUNCTION
6022 8342 : && gfc_is_class_array_function (ss->info->expr))))
6023 61874 : continue;
6024 :
6025 180965 : info = &ss->info->data.array;
6026 :
6027 406425 : for (n = 0; n < ss->dimen; n++)
6028 : {
6029 : /* If we are specifying the range the delta is already set. */
6030 225460 : if (loopspec[n] != ss)
6031 : {
6032 117388 : dim = ss->dim[n];
6033 :
6034 : /* Calculate the offset relative to the loop variable.
6035 : First multiply by the stride. */
6036 117388 : tmp = loop->from[n];
6037 117388 : if (!integer_onep (info->stride[dim]))
6038 3132 : tmp = fold_build2_loc (input_location, MULT_EXPR,
6039 : gfc_array_index_type,
6040 : tmp, info->stride[dim]);
6041 :
6042 : /* Then subtract this from our starting value. */
6043 117388 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
6044 : gfc_array_index_type,
6045 : info->start[dim], tmp);
6046 :
6047 117388 : if (ss->is_alloc_lhs)
6048 9697 : info->delta[dim] = tmp;
6049 : else
6050 107691 : info->delta[dim] = gfc_evaluate_now (tmp, &outer_loop->pre);
6051 : }
6052 : }
6053 : }
6054 :
6055 123202 : for (loop = loop->nested; loop; loop = loop->next)
6056 3452 : gfc_set_delta (loop);
6057 119750 : }
6058 :
6059 :
6060 : /* Calculate the size of a given array dimension from the bounds. This
6061 : is simply (ubound - lbound + 1) if this expression is positive
6062 : or 0 if it is negative (pick either one if it is zero). Optionally
6063 : (if or_expr is present) OR the (expression != 0) condition to it. */
6064 :
6065 : tree
6066 23546 : gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr)
6067 : {
6068 23546 : tree res;
6069 23546 : tree cond;
6070 :
6071 : /* Calculate (ubound - lbound + 1). */
6072 23546 : res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6073 : ubound, lbound);
6074 23546 : res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res,
6075 : gfc_index_one_node);
6076 :
6077 : /* Check whether the size for this dimension is negative. */
6078 23546 : cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, res,
6079 : gfc_index_zero_node);
6080 23546 : res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
6081 : gfc_index_zero_node, res);
6082 :
6083 : /* Build OR expression. */
6084 23546 : if (or_expr)
6085 18107 : *or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
6086 : logical_type_node, *or_expr, cond);
6087 :
6088 23546 : return res;
6089 : }
6090 :
6091 :
6092 : /* Fills in an array descriptor, and returns the size of the array.
6093 : The size will be a simple_val, ie a variable or a constant. Also
6094 : calculates the offset of the base. The pointer argument overflow,
6095 : which should be of integer type, will increase in value if overflow
6096 : occurs during the size calculation. Returns the size of the array.
6097 : {
6098 : stride = 1;
6099 : offset = 0;
6100 : for (n = 0; n < rank; n++)
6101 : {
6102 : a.lbound[n] = specified_lower_bound;
6103 : offset = offset + a.lbond[n] * stride;
6104 : size = 1 - lbound;
6105 : a.ubound[n] = specified_upper_bound;
6106 : a.stride[n] = stride;
6107 : size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
6108 : overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
6109 : stride = stride * size;
6110 : }
6111 : for (n = rank; n < rank+corank; n++)
6112 : (Set lcobound/ucobound as above.)
6113 : element_size = sizeof (array element);
6114 : if (!rank)
6115 : return element_size
6116 : stride = (size_t) stride;
6117 : overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
6118 : stride = stride * element_size;
6119 : return (stride);
6120 : } */
6121 : /*GCC ARRAYS*/
6122 :
6123 : static tree
6124 12473 : gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
6125 : gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
6126 : stmtblock_t * descriptor_block, tree * overflow,
6127 : tree expr3_elem_size, gfc_expr *expr3, tree expr3_desc,
6128 : bool e3_has_nodescriptor, gfc_expr *expr,
6129 : tree *element_size, bool explicit_ts)
6130 : {
6131 12473 : tree type;
6132 12473 : tree tmp;
6133 12473 : tree size;
6134 12473 : tree offset;
6135 12473 : tree stride;
6136 12473 : tree or_expr;
6137 12473 : tree thencase;
6138 12473 : tree elsecase;
6139 12473 : tree cond;
6140 12473 : tree var;
6141 12473 : stmtblock_t thenblock;
6142 12473 : stmtblock_t elseblock;
6143 12473 : gfc_expr *ubound;
6144 12473 : gfc_se se;
6145 12473 : int n;
6146 :
6147 12473 : if (expr->ts.type == BT_CLASS
6148 1728 : && expr3_desc != NULL_TREE
6149 12847 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr3_desc)))
6150 374 : type = TREE_TYPE (expr3_desc);
6151 : else
6152 12099 : type = TREE_TYPE (descriptor);
6153 :
6154 :
6155 12473 : stride = gfc_index_one_node;
6156 12473 : offset = gfc_index_zero_node;
6157 :
6158 : /* Set the dtype before the alloc, because registration of coarrays needs
6159 : it initialized. */
6160 12473 : if (expr->ts.type == BT_CHARACTER
6161 1103 : && expr->ts.deferred
6162 563 : && VAR_P (expr->ts.u.cl->backend_decl))
6163 : {
6164 378 : type = gfc_typenode_for_spec (&expr->ts);
6165 378 : gfc_conv_descriptor_dtype_set (pblock, descriptor,
6166 : gfc_get_dtype_rank_type (rank, type));
6167 : }
6168 12095 : else if (expr->ts.type == BT_CHARACTER
6169 725 : && expr->ts.deferred
6170 185 : && TREE_CODE (descriptor) == COMPONENT_REF)
6171 : {
6172 : /* Deferred character components have their string length tucked away
6173 : in a hidden field of the derived type. Obtain that and use it to
6174 : set the dtype. The charlen backend decl is zero because the field
6175 : type is zero length. */
6176 167 : gfc_ref *ref;
6177 167 : tmp = NULL_TREE;
6178 167 : for (ref = expr->ref; ref; ref = ref->next)
6179 167 : if (ref->type == REF_COMPONENT
6180 167 : && gfc_deferred_strlen (ref->u.c.component, &tmp))
6181 : break;
6182 167 : gcc_assert (tmp != NULL_TREE);
6183 167 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
6184 167 : TREE_OPERAND (descriptor, 0), tmp, NULL_TREE);
6185 167 : tmp = fold_convert (gfc_charlen_type_node, tmp);
6186 167 : type = gfc_get_character_type_len (expr->ts.kind, tmp);
6187 167 : gfc_conv_descriptor_dtype_set (pblock, descriptor,
6188 : gfc_get_dtype_rank_type (rank, type));
6189 167 : }
6190 11928 : else if (expr3_desc && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr3_desc)))
6191 964 : gfc_conv_descriptor_dtype_set (pblock, descriptor,
6192 : gfc_conv_descriptor_dtype_get (expr3_desc));
6193 10964 : else if (expr->ts.type == BT_CLASS && !explicit_ts
6194 1354 : && expr3 && expr3->ts.type != BT_CLASS
6195 355 : && expr3_elem_size != NULL_TREE && expr3_desc == NULL_TREE)
6196 : {
6197 355 : gfc_conv_descriptor_dtype_set (pblock, descriptor, gfc_get_dtype (type));
6198 355 : gfc_conv_descriptor_elem_len_set (pblock, descriptor, expr3_elem_size);
6199 : }
6200 : else
6201 10609 : gfc_conv_descriptor_dtype_set (pblock, descriptor, gfc_get_dtype (type));
6202 :
6203 12473 : or_expr = logical_false_node;
6204 :
6205 30580 : for (n = 0; n < rank; n++)
6206 : {
6207 18107 : tree conv_lbound;
6208 18107 : tree conv_ubound;
6209 :
6210 : /* We have 3 possibilities for determining the size of the array:
6211 : lower == NULL => lbound = 1, ubound = upper[n]
6212 : upper[n] = NULL => lbound = 1, ubound = lower[n]
6213 : upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
6214 18107 : ubound = upper[n];
6215 :
6216 : /* Set lower bound. */
6217 18107 : gfc_init_se (&se, NULL);
6218 18107 : if (expr3_desc != NULL_TREE)
6219 : {
6220 1507 : if (e3_has_nodescriptor)
6221 : /* The lbound of nondescriptor arrays like array constructors,
6222 : nonallocatable/nonpointer function results/variables,
6223 : start at zero, but when allocating it, the standard expects
6224 : the array to start at one. */
6225 979 : se.expr = gfc_index_one_node;
6226 : else
6227 528 : se.expr = gfc_conv_descriptor_lbound_get (expr3_desc,
6228 : gfc_rank_cst[n]);
6229 : }
6230 16600 : else if (lower == NULL)
6231 13395 : se.expr = gfc_index_one_node;
6232 : else
6233 : {
6234 3205 : gcc_assert (lower[n]);
6235 3205 : if (ubound)
6236 : {
6237 2457 : gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
6238 2457 : gfc_add_block_to_block (pblock, &se.pre);
6239 : }
6240 : else
6241 : {
6242 748 : se.expr = gfc_index_one_node;
6243 748 : ubound = lower[n];
6244 : }
6245 : }
6246 18107 : gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
6247 : gfc_rank_cst[n], se.expr);
6248 18107 : conv_lbound = se.expr;
6249 :
6250 : /* Work out the offset for this component. */
6251 18107 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6252 : se.expr, stride);
6253 18107 : offset = fold_build2_loc (input_location, MINUS_EXPR,
6254 : gfc_array_index_type, offset, tmp);
6255 :
6256 : /* Set upper bound. */
6257 18107 : gfc_init_se (&se, NULL);
6258 18107 : if (expr3_desc != NULL_TREE)
6259 : {
6260 1507 : if (e3_has_nodescriptor)
6261 : {
6262 : /* The lbound of nondescriptor arrays like array constructors,
6263 : nonallocatable/nonpointer function results/variables,
6264 : start at zero, but when allocating it, the standard expects
6265 : the array to start at one. Therefore fix the upper bound to be
6266 : (desc.ubound - desc.lbound) + 1. */
6267 979 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
6268 : gfc_array_index_type,
6269 : gfc_conv_descriptor_ubound_get (
6270 : expr3_desc, gfc_rank_cst[n]),
6271 : gfc_conv_descriptor_lbound_get (
6272 : expr3_desc, gfc_rank_cst[n]));
6273 979 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
6274 : gfc_array_index_type, tmp,
6275 : gfc_index_one_node);
6276 979 : se.expr = gfc_evaluate_now (tmp, pblock);
6277 : }
6278 : else
6279 528 : se.expr = gfc_conv_descriptor_ubound_get (expr3_desc,
6280 : gfc_rank_cst[n]);
6281 : }
6282 : else
6283 : {
6284 16600 : gcc_assert (ubound);
6285 16600 : gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
6286 16600 : gfc_add_block_to_block (pblock, &se.pre);
6287 16600 : if (ubound->expr_type == EXPR_FUNCTION)
6288 781 : se.expr = gfc_evaluate_now (se.expr, pblock);
6289 : }
6290 18107 : gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
6291 : gfc_rank_cst[n], se.expr);
6292 18107 : conv_ubound = se.expr;
6293 :
6294 : /* Store the stride. */
6295 18107 : gfc_conv_descriptor_stride_set (descriptor_block, descriptor,
6296 : gfc_rank_cst[n], stride);
6297 :
6298 : /* Calculate size and check whether extent is negative. */
6299 18107 : size = gfc_conv_array_extent_dim (conv_lbound, conv_ubound, &or_expr);
6300 18107 : size = gfc_evaluate_now (size, pblock);
6301 :
6302 : /* Check whether multiplying the stride by the number of
6303 : elements in this dimension would overflow. We must also check
6304 : whether the current dimension has zero size in order to avoid
6305 : division by zero.
6306 : */
6307 18107 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
6308 : gfc_array_index_type,
6309 18107 : fold_convert (gfc_array_index_type,
6310 : TYPE_MAX_VALUE (gfc_array_index_type)),
6311 : size);
6312 18107 : cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
6313 : logical_type_node, tmp, stride),
6314 : PRED_FORTRAN_OVERFLOW);
6315 18107 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
6316 : integer_one_node, integer_zero_node);
6317 18107 : cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
6318 : logical_type_node, size,
6319 : gfc_index_zero_node),
6320 : PRED_FORTRAN_SIZE_ZERO);
6321 18107 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
6322 : integer_zero_node, tmp);
6323 18107 : tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
6324 : *overflow, tmp);
6325 18107 : *overflow = gfc_evaluate_now (tmp, pblock);
6326 :
6327 : /* Multiply the stride by the number of elements in this dimension. */
6328 18107 : stride = fold_build2_loc (input_location, MULT_EXPR,
6329 : gfc_array_index_type, stride, size);
6330 18107 : stride = gfc_evaluate_now (stride, pblock);
6331 : }
6332 :
6333 13183 : for (n = rank; n < rank + corank; n++)
6334 : {
6335 710 : ubound = upper[n];
6336 :
6337 : /* Set lower bound. */
6338 710 : gfc_init_se (&se, NULL);
6339 710 : if (lower == NULL || lower[n] == NULL)
6340 : {
6341 429 : gcc_assert (n == rank + corank - 1);
6342 429 : se.expr = gfc_index_one_node;
6343 : }
6344 : else
6345 : {
6346 281 : if (ubound || n == rank + corank - 1)
6347 : {
6348 184 : gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
6349 184 : gfc_add_block_to_block (pblock, &se.pre);
6350 : }
6351 : else
6352 : {
6353 97 : se.expr = gfc_index_one_node;
6354 97 : ubound = lower[n];
6355 : }
6356 : }
6357 710 : gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
6358 : gfc_rank_cst[n], se.expr);
6359 :
6360 710 : if (n < rank + corank - 1)
6361 : {
6362 181 : gfc_init_se (&se, NULL);
6363 181 : gcc_assert (ubound);
6364 181 : gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
6365 181 : gfc_add_block_to_block (pblock, &se.pre);
6366 181 : gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
6367 : gfc_rank_cst[n], se.expr);
6368 : }
6369 : }
6370 :
6371 : /* The stride is the number of elements in the array, so multiply by the
6372 : size of an element to get the total size. Obviously, if there is a
6373 : SOURCE expression (expr3) we must use its element size. */
6374 12473 : if (expr3_elem_size != NULL_TREE)
6375 3163 : tmp = expr3_elem_size;
6376 9310 : else if (expr3 != NULL)
6377 : {
6378 0 : if (expr3->ts.type == BT_CLASS)
6379 : {
6380 0 : gfc_se se_sz;
6381 0 : gfc_expr *sz = gfc_copy_expr (expr3);
6382 0 : gfc_add_vptr_component (sz);
6383 0 : gfc_add_size_component (sz);
6384 0 : gfc_init_se (&se_sz, NULL);
6385 0 : gfc_conv_expr (&se_sz, sz);
6386 0 : gfc_free_expr (sz);
6387 0 : tmp = se_sz.expr;
6388 : }
6389 : else
6390 : {
6391 0 : tmp = gfc_typenode_for_spec (&expr3->ts);
6392 0 : tmp = TYPE_SIZE_UNIT (tmp);
6393 : }
6394 : }
6395 : else
6396 9310 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
6397 :
6398 : /* Convert to size_t. */
6399 12473 : *element_size = fold_convert (size_type_node, tmp);
6400 :
6401 12473 : if (rank == 0)
6402 : return *element_size;
6403 :
6404 12226 : stride = fold_convert (size_type_node, stride);
6405 :
6406 : /* First check for overflow. Since an array of type character can
6407 : have zero element_size, we must check for that before
6408 : dividing. */
6409 12226 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
6410 : size_type_node,
6411 12226 : TYPE_MAX_VALUE (size_type_node), *element_size);
6412 12226 : cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
6413 : logical_type_node, tmp, stride),
6414 : PRED_FORTRAN_OVERFLOW);
6415 12226 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
6416 : integer_one_node, integer_zero_node);
6417 12226 : cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
6418 : logical_type_node, *element_size,
6419 : build_int_cst (size_type_node, 0)),
6420 : PRED_FORTRAN_SIZE_ZERO);
6421 12226 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
6422 : integer_zero_node, tmp);
6423 12226 : tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
6424 : *overflow, tmp);
6425 12226 : *overflow = gfc_evaluate_now (tmp, pblock);
6426 :
6427 12226 : size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
6428 : stride, *element_size);
6429 :
6430 12226 : if (poffset != NULL)
6431 : {
6432 12226 : offset = gfc_evaluate_now (offset, pblock);
6433 12226 : *poffset = offset;
6434 : }
6435 :
6436 12226 : if (integer_zerop (or_expr))
6437 : return size;
6438 3679 : if (integer_onep (or_expr))
6439 605 : return build_int_cst (size_type_node, 0);
6440 :
6441 3074 : var = gfc_create_var (TREE_TYPE (size), "size");
6442 3074 : gfc_start_block (&thenblock);
6443 3074 : gfc_add_modify (&thenblock, var, build_int_cst (size_type_node, 0));
6444 3074 : thencase = gfc_finish_block (&thenblock);
6445 :
6446 3074 : gfc_start_block (&elseblock);
6447 3074 : gfc_add_modify (&elseblock, var, size);
6448 3074 : elsecase = gfc_finish_block (&elseblock);
6449 :
6450 3074 : tmp = gfc_evaluate_now (or_expr, pblock);
6451 3074 : tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
6452 3074 : gfc_add_expr_to_block (pblock, tmp);
6453 :
6454 3074 : return var;
6455 : }
6456 :
6457 :
6458 : /* Retrieve the last ref from the chain. This routine is specific to
6459 : gfc_array_allocate ()'s needs. */
6460 :
6461 : bool
6462 19072 : retrieve_last_ref (gfc_ref **ref_in, gfc_ref **prev_ref_in)
6463 : {
6464 19072 : gfc_ref *ref, *prev_ref;
6465 :
6466 19072 : ref = *ref_in;
6467 : /* Prevent warnings for uninitialized variables. */
6468 19072 : prev_ref = *prev_ref_in;
6469 26648 : while (ref && ref->next != NULL)
6470 : {
6471 7576 : gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
6472 : || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
6473 7576 : prev_ref = ref;
6474 7576 : ref = ref->next;
6475 : }
6476 :
6477 19072 : if (ref == NULL || ref->type != REF_ARRAY)
6478 : return false;
6479 :
6480 13722 : *ref_in = ref;
6481 13722 : *prev_ref_in = prev_ref;
6482 13722 : return true;
6483 : }
6484 :
6485 : /* Initializes the descriptor and generates a call to _gfor_allocate. Does
6486 : the work for an ALLOCATE statement. */
6487 : /*GCC ARRAYS*/
6488 :
6489 : bool
6490 17823 : gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
6491 : tree errlen, tree label_finish, tree expr3_elem_size,
6492 : gfc_expr *expr3, tree e3_arr_desc, bool e3_has_nodescriptor,
6493 : gfc_omp_namelist *omp_alloc, bool explicit_ts)
6494 : {
6495 17823 : tree tmp;
6496 17823 : tree pointer;
6497 17823 : tree offset = NULL_TREE;
6498 17823 : tree token = NULL_TREE;
6499 17823 : tree size;
6500 17823 : tree msg;
6501 17823 : tree error = NULL_TREE;
6502 17823 : tree overflow; /* Boolean storing whether size calculation overflows. */
6503 17823 : tree var_overflow = NULL_TREE;
6504 17823 : tree cond;
6505 17823 : tree set_descriptor;
6506 17823 : tree not_prev_allocated = NULL_TREE;
6507 17823 : tree element_size = NULL_TREE;
6508 17823 : stmtblock_t set_descriptor_block;
6509 17823 : stmtblock_t elseblock;
6510 17823 : gfc_expr **lower;
6511 17823 : gfc_expr **upper;
6512 17823 : gfc_ref *ref, *prev_ref = NULL, *coref;
6513 17823 : bool allocatable, coarray, dimension, alloc_w_e3_arr_spec = false,
6514 : non_ulimate_coarray_ptr_comp;
6515 17823 : tree omp_cond = NULL_TREE, omp_alt_alloc = NULL_TREE;
6516 :
6517 17823 : ref = expr->ref;
6518 :
6519 : /* Find the last reference in the chain. */
6520 17823 : if (!retrieve_last_ref (&ref, &prev_ref))
6521 : return false;
6522 :
6523 : /* Take the allocatable and coarray properties solely from the expr-ref's
6524 : attributes and not from source=-expression. */
6525 12473 : if (!prev_ref)
6526 : {
6527 8450 : allocatable = expr->symtree->n.sym->attr.allocatable;
6528 8450 : dimension = expr->symtree->n.sym->attr.dimension;
6529 8450 : non_ulimate_coarray_ptr_comp = false;
6530 : }
6531 : else
6532 : {
6533 4023 : allocatable = prev_ref->u.c.component->attr.allocatable;
6534 : /* Pointer components in coarrayed derived types must be treated
6535 : specially in that they are registered without a check if the are
6536 : already associated. This does not hold for ultimate coarray
6537 : pointers. */
6538 8046 : non_ulimate_coarray_ptr_comp = (prev_ref->u.c.component->attr.pointer
6539 4023 : && !prev_ref->u.c.component->attr.codimension);
6540 4023 : dimension = prev_ref->u.c.component->attr.dimension;
6541 : }
6542 :
6543 : /* For allocatable/pointer arrays in derived types, one of the refs has to be
6544 : a coarray. In this case it does not matter whether we are on this_image
6545 : or not. */
6546 12473 : coarray = false;
6547 30009 : for (coref = expr->ref; coref; coref = coref->next)
6548 18240 : if (coref->type == REF_ARRAY && coref->u.ar.codimen > 0)
6549 : {
6550 : coarray = true;
6551 : break;
6552 : }
6553 :
6554 12473 : if (!dimension)
6555 247 : gcc_assert (coarray);
6556 :
6557 12473 : if (ref->u.ar.type == AR_FULL && expr3 != NULL)
6558 : {
6559 1249 : gfc_ref *old_ref = ref;
6560 : /* F08:C633: Array shape from expr3. */
6561 1249 : ref = expr3->ref;
6562 :
6563 : /* Find the last reference in the chain. */
6564 1249 : if (!retrieve_last_ref (&ref, &prev_ref))
6565 : {
6566 0 : if (expr3->expr_type == EXPR_FUNCTION
6567 0 : && gfc_expr_attr (expr3).dimension)
6568 0 : ref = old_ref;
6569 : else
6570 0 : return false;
6571 : }
6572 : alloc_w_e3_arr_spec = true;
6573 : }
6574 :
6575 : /* Figure out the size of the array. */
6576 12473 : switch (ref->u.ar.type)
6577 : {
6578 9548 : case AR_ELEMENT:
6579 9548 : if (!coarray)
6580 : {
6581 8896 : lower = NULL;
6582 8896 : upper = ref->u.ar.start;
6583 8896 : break;
6584 : }
6585 : /* Fall through. */
6586 :
6587 2359 : case AR_SECTION:
6588 2359 : lower = ref->u.ar.start;
6589 2359 : upper = ref->u.ar.end;
6590 2359 : break;
6591 :
6592 1218 : case AR_FULL:
6593 1218 : gcc_assert (ref->u.ar.as->type == AS_EXPLICIT
6594 : || alloc_w_e3_arr_spec);
6595 :
6596 1218 : lower = ref->u.ar.as->lower;
6597 1218 : upper = ref->u.ar.as->upper;
6598 1218 : break;
6599 :
6600 0 : default:
6601 0 : gcc_unreachable ();
6602 12473 : break;
6603 : }
6604 :
6605 12473 : overflow = integer_zero_node;
6606 :
6607 12473 : if (expr->ts.type == BT_CHARACTER
6608 1103 : && TREE_CODE (se->string_length) == COMPONENT_REF
6609 167 : && expr->ts.u.cl->backend_decl != se->string_length
6610 167 : && VAR_P (expr->ts.u.cl->backend_decl))
6611 0 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
6612 0 : fold_convert (TREE_TYPE (expr->ts.u.cl->backend_decl),
6613 : se->string_length));
6614 :
6615 12473 : gfc_init_block (&set_descriptor_block);
6616 : /* Take the corank only from the actual ref and not from the coref. The
6617 : later will mislead the generation of the array dimensions for allocatable/
6618 : pointer components in derived types. */
6619 24401 : size = gfc_array_init_size (se->expr, alloc_w_e3_arr_spec ? expr->rank
6620 11224 : : ref->u.ar.as->rank,
6621 704 : coarray ? ref->u.ar.as->corank : 0,
6622 : &offset, lower, upper,
6623 : &se->pre, &set_descriptor_block, &overflow,
6624 : expr3_elem_size, expr3, e3_arr_desc,
6625 : e3_has_nodescriptor, expr, &element_size,
6626 : explicit_ts);
6627 :
6628 12473 : if (dimension)
6629 : {
6630 12226 : var_overflow = gfc_create_var (integer_type_node, "overflow");
6631 12226 : gfc_add_modify (&se->pre, var_overflow, overflow);
6632 :
6633 12226 : if (status == NULL_TREE)
6634 : {
6635 : /* Generate the block of code handling overflow. */
6636 11998 : msg = gfc_build_addr_expr (pchar_type_node,
6637 : gfc_build_localized_cstring_const
6638 : ("Integer overflow when calculating the amount of "
6639 : "memory to allocate"));
6640 11998 : error = build_call_expr_loc (input_location,
6641 : gfor_fndecl_runtime_error, 1, msg);
6642 : }
6643 : else
6644 : {
6645 228 : tree status_type = TREE_TYPE (status);
6646 228 : stmtblock_t set_status_block;
6647 :
6648 228 : gfc_start_block (&set_status_block);
6649 228 : gfc_add_modify (&set_status_block, status,
6650 : build_int_cst (status_type, LIBERROR_ALLOCATION));
6651 228 : error = gfc_finish_block (&set_status_block);
6652 : }
6653 : }
6654 :
6655 : /* Allocate memory to store the data. */
6656 12473 : if (POINTER_TYPE_P (TREE_TYPE (se->expr)))
6657 0 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
6658 :
6659 12473 : if (coarray && flag_coarray == GFC_FCOARRAY_LIB)
6660 : {
6661 451 : pointer = non_ulimate_coarray_ptr_comp ? se->expr
6662 379 : : gfc_conv_descriptor_data_get (se->expr);
6663 451 : token = gfc_conv_descriptor_token (se->expr);
6664 451 : token = gfc_build_addr_expr (NULL_TREE, token);
6665 : }
6666 : else
6667 : {
6668 12022 : pointer = gfc_conv_descriptor_data_get (se->expr);
6669 12022 : if (omp_alloc)
6670 33 : omp_cond = boolean_true_node;
6671 : }
6672 12473 : STRIP_NOPS (pointer);
6673 :
6674 12473 : if (allocatable)
6675 : {
6676 10271 : not_prev_allocated = gfc_create_var (logical_type_node,
6677 : "not_prev_allocated");
6678 10271 : tmp = fold_build2_loc (input_location, EQ_EXPR,
6679 : logical_type_node, pointer,
6680 10271 : build_int_cst (TREE_TYPE (pointer), 0));
6681 :
6682 10271 : gfc_add_modify (&se->pre, not_prev_allocated, tmp);
6683 : }
6684 :
6685 12473 : gfc_start_block (&elseblock);
6686 :
6687 12473 : tree succ_add_expr = NULL_TREE;
6688 12473 : if (omp_cond)
6689 : {
6690 33 : tree align, alloc, sz;
6691 33 : gfc_se se2;
6692 33 : if (omp_alloc->u2.allocator)
6693 : {
6694 10 : gfc_init_se (&se2, NULL);
6695 10 : gfc_conv_expr (&se2, omp_alloc->u2.allocator);
6696 10 : gfc_add_block_to_block (&elseblock, &se2.pre);
6697 10 : alloc = gfc_evaluate_now (se2.expr, &elseblock);
6698 10 : gfc_add_block_to_block (&elseblock, &se2.post);
6699 : }
6700 : else
6701 23 : alloc = build_zero_cst (ptr_type_node);
6702 33 : tmp = TREE_TYPE (TREE_TYPE (pointer));
6703 33 : if (tmp == void_type_node)
6704 33 : tmp = gfc_typenode_for_spec (&expr->ts, 0);
6705 33 : if (omp_alloc->u.align)
6706 : {
6707 17 : gfc_init_se (&se2, NULL);
6708 17 : gfc_conv_expr (&se2, omp_alloc->u.align);
6709 17 : gcc_assert (CONSTANT_CLASS_P (se2.expr)
6710 : && se2.pre.head == NULL
6711 : && se2.post.head == NULL);
6712 17 : align = build_int_cst (size_type_node,
6713 17 : MAX (tree_to_uhwi (se2.expr),
6714 : TYPE_ALIGN_UNIT (tmp)));
6715 : }
6716 : else
6717 16 : align = build_int_cst (size_type_node, TYPE_ALIGN_UNIT (tmp));
6718 33 : sz = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
6719 : fold_convert (size_type_node, size),
6720 : build_int_cst (size_type_node, 1));
6721 33 : omp_alt_alloc = builtin_decl_explicit (BUILT_IN_GOMP_ALLOC);
6722 33 : DECL_ATTRIBUTES (omp_alt_alloc)
6723 33 : = tree_cons (get_identifier ("omp allocator"),
6724 : build_tree_list (NULL_TREE, alloc),
6725 33 : DECL_ATTRIBUTES (omp_alt_alloc));
6726 33 : omp_alt_alloc = build_call_expr (omp_alt_alloc, 3, align, sz, alloc);
6727 33 : stmtblock_t tmp_block;
6728 33 : gfc_init_block (&tmp_block);
6729 33 : gfc_conv_descriptor_version_set (&tmp_block, se->expr, integer_one_node);
6730 33 : succ_add_expr = gfc_finish_block (&tmp_block);
6731 : }
6732 :
6733 : /* The allocatable variant takes the old pointer as first argument. */
6734 12473 : if (allocatable)
6735 10900 : gfc_allocate_allocatable (&elseblock, pointer, size, token,
6736 : status, errmsg, errlen, label_finish, expr,
6737 629 : coref != NULL ? coref->u.ar.as->corank : 0,
6738 : omp_cond, omp_alt_alloc, succ_add_expr);
6739 2202 : else if (non_ulimate_coarray_ptr_comp && token)
6740 : /* The token is set only for GFC_FCOARRAY_LIB mode. */
6741 72 : gfc_allocate_using_caf_lib (&elseblock, pointer, size, token, status,
6742 : errmsg, errlen,
6743 : GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY);
6744 : else
6745 2130 : gfc_allocate_using_malloc (&elseblock, pointer, size, status,
6746 : omp_cond, omp_alt_alloc, succ_add_expr);
6747 :
6748 12473 : if (dimension)
6749 : {
6750 12226 : cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
6751 : logical_type_node, var_overflow, integer_zero_node),
6752 : PRED_FORTRAN_OVERFLOW);
6753 12226 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6754 : error, gfc_finish_block (&elseblock));
6755 : }
6756 : else
6757 247 : tmp = gfc_finish_block (&elseblock);
6758 :
6759 12473 : gfc_add_expr_to_block (&se->pre, tmp);
6760 :
6761 : /* Update the array descriptor with the offset and the span. */
6762 12473 : if (dimension)
6763 : {
6764 12226 : gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
6765 12226 : tmp = fold_convert (gfc_array_index_type, element_size);
6766 12226 : gfc_conv_descriptor_span_set (&set_descriptor_block, se->expr, tmp);
6767 : }
6768 :
6769 12473 : set_descriptor = gfc_finish_block (&set_descriptor_block);
6770 12473 : if (status != NULL_TREE)
6771 : {
6772 244 : cond = fold_build2_loc (input_location, EQ_EXPR,
6773 : logical_type_node, status,
6774 244 : build_int_cst (TREE_TYPE (status), 0));
6775 :
6776 244 : if (not_prev_allocated != NULL_TREE)
6777 228 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
6778 : logical_type_node, cond, not_prev_allocated);
6779 :
6780 244 : gfc_add_expr_to_block (&se->pre,
6781 : fold_build3_loc (input_location, COND_EXPR, void_type_node,
6782 : cond,
6783 : set_descriptor,
6784 : build_empty_stmt (input_location)));
6785 : }
6786 : else
6787 12229 : gfc_add_expr_to_block (&se->pre, set_descriptor);
6788 :
6789 : return true;
6790 : }
6791 :
6792 :
6793 : /* Create an array constructor from an initialization expression.
6794 : We assume the frontend already did any expansions and conversions. */
6795 :
6796 : tree
6797 7913 : gfc_conv_array_initializer (tree type, gfc_expr * expr)
6798 : {
6799 7913 : gfc_constructor *c;
6800 7913 : tree tmp;
6801 7913 : gfc_se se;
6802 7913 : tree index, range;
6803 7913 : vec<constructor_elt, va_gc> *v = NULL;
6804 :
6805 7913 : if (expr->expr_type == EXPR_VARIABLE
6806 1 : && expr->symtree->n.sym->attr.flavor == FL_PARAMETER
6807 1 : && expr->symtree->n.sym->value
6808 1 : && !expr->ref)
6809 7913 : expr = expr->symtree->n.sym->value;
6810 :
6811 : /* After parameter substitution the expression should be a constant, array
6812 : constructor, structure constructor, or NULL. Anything else is invalid
6813 : and must not ICE later in lowering. */
6814 7913 : if (expr->expr_type != EXPR_CONSTANT
6815 7513 : && expr->expr_type != EXPR_STRUCTURE
6816 6691 : && expr->expr_type != EXPR_ARRAY
6817 4 : && expr->expr_type != EXPR_NULL)
6818 : {
6819 4 : gfc_error ("Array initializer at %L does not reduce to a constant "
6820 : "expression", &expr->where);
6821 4 : return build_constructor (type, NULL);
6822 : }
6823 :
6824 7909 : switch (expr->expr_type)
6825 : {
6826 1222 : case EXPR_CONSTANT:
6827 1222 : case EXPR_STRUCTURE:
6828 : /* A single scalar or derived type value. Create an array with all
6829 : elements equal to that value. */
6830 1222 : gfc_init_se (&se, NULL);
6831 :
6832 1222 : if (expr->expr_type == EXPR_CONSTANT)
6833 400 : gfc_conv_constant (&se, expr);
6834 : else
6835 822 : gfc_conv_structure (&se, expr, 1);
6836 :
6837 2444 : if (tree_int_cst_lt (TYPE_MAX_VALUE (TYPE_DOMAIN (type)),
6838 1222 : TYPE_MIN_VALUE (TYPE_DOMAIN (type))))
6839 : break;
6840 2420 : else if (tree_int_cst_equal (TYPE_MIN_VALUE (TYPE_DOMAIN (type)),
6841 1210 : TYPE_MAX_VALUE (TYPE_DOMAIN (type))))
6842 179 : range = TYPE_MIN_VALUE (TYPE_DOMAIN (type));
6843 : else
6844 2062 : range = build2 (RANGE_EXPR, gfc_array_index_type,
6845 1031 : TYPE_MIN_VALUE (TYPE_DOMAIN (type)),
6846 1031 : TYPE_MAX_VALUE (TYPE_DOMAIN (type)));
6847 1210 : CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
6848 1210 : break;
6849 :
6850 6687 : case EXPR_ARRAY:
6851 : /* Create a vector of all the elements. */
6852 6687 : for (c = gfc_constructor_first (expr->value.constructor);
6853 165144 : c && c->expr; c = gfc_constructor_next (c))
6854 : {
6855 158457 : if (c->iterator)
6856 : {
6857 : /* Problems occur when we get something like
6858 : integer :: a(lots) = (/(i, i=1, lots)/) */
6859 0 : gfc_fatal_error ("The number of elements in the array "
6860 : "constructor at %L requires an increase of "
6861 : "the allowed %d upper limit. See "
6862 : "%<-fmax-array-constructor%> option",
6863 : &expr->where, flag_max_array_constructor);
6864 : return NULL_TREE;
6865 : }
6866 158457 : index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
6867 :
6868 158457 : if (mpz_cmp_si (c->repeat, 1) > 0)
6869 : {
6870 127 : tree tmp1, tmp2;
6871 127 : mpz_t maxval;
6872 :
6873 127 : mpz_init (maxval);
6874 127 : mpz_add (maxval, c->offset, c->repeat);
6875 127 : mpz_sub_ui (maxval, maxval, 1);
6876 127 : tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
6877 127 : if (mpz_cmp_si (c->offset, 0) != 0)
6878 : {
6879 27 : mpz_add_ui (maxval, c->offset, 1);
6880 27 : tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
6881 : }
6882 : else
6883 100 : tmp1 = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
6884 :
6885 127 : range = fold_build2 (RANGE_EXPR, gfc_array_index_type, tmp1, tmp2);
6886 127 : mpz_clear (maxval);
6887 : }
6888 : else
6889 : range = NULL;
6890 :
6891 158457 : gfc_init_se (&se, NULL);
6892 158457 : switch (c->expr->expr_type)
6893 : {
6894 156956 : case EXPR_CONSTANT:
6895 156956 : gfc_conv_constant (&se, c->expr);
6896 :
6897 : /* See gfortran.dg/charlen_15.f90 for instance. */
6898 156956 : if (TREE_CODE (se.expr) == STRING_CST
6899 5350 : && TREE_CODE (type) == ARRAY_TYPE)
6900 : {
6901 : tree atype = type;
6902 10700 : while (TREE_CODE (TREE_TYPE (atype)) == ARRAY_TYPE)
6903 5350 : atype = TREE_TYPE (atype);
6904 5350 : gcc_checking_assert (TREE_CODE (TREE_TYPE (atype))
6905 : == INTEGER_TYPE);
6906 5350 : gcc_checking_assert (TREE_TYPE (TREE_TYPE (se.expr))
6907 : == TREE_TYPE (atype));
6908 5350 : if (tree_to_uhwi (TYPE_SIZE_UNIT (TREE_TYPE (se.expr)))
6909 5350 : > tree_to_uhwi (TYPE_SIZE_UNIT (atype)))
6910 : {
6911 0 : unsigned HOST_WIDE_INT size
6912 0 : = tree_to_uhwi (TYPE_SIZE_UNIT (atype));
6913 0 : const char *p = TREE_STRING_POINTER (se.expr);
6914 :
6915 0 : se.expr = build_string (size, p);
6916 : }
6917 5350 : TREE_TYPE (se.expr) = atype;
6918 : }
6919 : break;
6920 :
6921 1501 : case EXPR_STRUCTURE:
6922 1501 : gfc_conv_structure (&se, c->expr, 1);
6923 1501 : break;
6924 :
6925 0 : default:
6926 : /* Catch those occasional beasts that do not simplify
6927 : for one reason or another, assuming that if they are
6928 : standard defying the frontend will catch them. */
6929 0 : gfc_conv_expr (&se, c->expr);
6930 0 : break;
6931 : }
6932 :
6933 158457 : if (range == NULL_TREE)
6934 158330 : CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
6935 : else
6936 : {
6937 127 : if (!integer_zerop (index))
6938 27 : CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
6939 158584 : CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
6940 : }
6941 : }
6942 : break;
6943 :
6944 0 : case EXPR_NULL:
6945 0 : return gfc_build_null_descriptor (type);
6946 :
6947 : default:
6948 : gcc_unreachable ();
6949 : }
6950 :
6951 : /* Create a constructor from the list of elements. */
6952 7909 : tmp = build_constructor (type, v);
6953 7909 : TREE_CONSTANT (tmp) = 1;
6954 7909 : return tmp;
6955 : }
6956 :
6957 :
6958 : /* Generate code to evaluate non-constant coarray cobounds. */
6959 :
6960 : void
6961 21901 : gfc_trans_array_cobounds (tree type, stmtblock_t * pblock,
6962 : const gfc_symbol *sym)
6963 : {
6964 21901 : int dim;
6965 21901 : tree ubound;
6966 21901 : tree lbound;
6967 21901 : gfc_se se;
6968 21901 : gfc_array_spec *as;
6969 :
6970 21901 : as = IS_CLASS_COARRAY_OR_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
6971 :
6972 22905 : for (dim = as->rank; dim < as->rank + as->corank; dim++)
6973 : {
6974 : /* Evaluate non-constant array bound expressions.
6975 : F2008 4.5.6.3 para 6: If a specification expression in a scoping unit
6976 : references a function, the result is finalized before execution of the
6977 : executable constructs in the scoping unit.
6978 : Adding the finalblocks enables this. */
6979 1004 : lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
6980 1004 : if (as->lower[dim] && !INTEGER_CST_P (lbound))
6981 : {
6982 114 : gfc_init_se (&se, NULL);
6983 114 : gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
6984 114 : gfc_add_block_to_block (pblock, &se.pre);
6985 114 : gfc_add_block_to_block (pblock, &se.finalblock);
6986 114 : gfc_add_modify (pblock, lbound, se.expr);
6987 : }
6988 1004 : ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
6989 1004 : if (as->upper[dim] && !INTEGER_CST_P (ubound))
6990 : {
6991 60 : gfc_init_se (&se, NULL);
6992 60 : gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
6993 60 : gfc_add_block_to_block (pblock, &se.pre);
6994 60 : gfc_add_block_to_block (pblock, &se.finalblock);
6995 60 : gfc_add_modify (pblock, ubound, se.expr);
6996 : }
6997 : }
6998 21901 : }
6999 :
7000 :
7001 : /* Generate code to evaluate non-constant array bounds. Sets *poffset and
7002 : returns the size (in elements) of the array. */
7003 :
7004 : tree
7005 14100 : gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
7006 : stmtblock_t * pblock)
7007 : {
7008 14100 : gfc_array_spec *as;
7009 14100 : tree size;
7010 14100 : tree stride;
7011 14100 : tree offset;
7012 14100 : tree ubound;
7013 14100 : tree lbound;
7014 14100 : tree tmp;
7015 14100 : gfc_se se;
7016 :
7017 14100 : int dim;
7018 :
7019 14100 : as = IS_CLASS_COARRAY_OR_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
7020 :
7021 14100 : size = gfc_index_one_node;
7022 14100 : offset = gfc_index_zero_node;
7023 14100 : stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
7024 14100 : if (stride && VAR_P (stride))
7025 124 : gfc_add_modify (pblock, stride, gfc_index_one_node);
7026 31469 : for (dim = 0; dim < as->rank; dim++)
7027 : {
7028 : /* Evaluate non-constant array bound expressions.
7029 : F2008 4.5.6.3 para 6: If a specification expression in a scoping unit
7030 : references a function, the result is finalized before execution of the
7031 : executable constructs in the scoping unit.
7032 : Adding the finalblocks enables this. */
7033 17369 : lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
7034 17369 : if (as->lower[dim] && !INTEGER_CST_P (lbound))
7035 : {
7036 475 : gfc_init_se (&se, NULL);
7037 475 : gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
7038 475 : gfc_add_block_to_block (pblock, &se.pre);
7039 475 : gfc_add_block_to_block (pblock, &se.finalblock);
7040 475 : gfc_add_modify (pblock, lbound, se.expr);
7041 : }
7042 17369 : ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
7043 17369 : if (as->upper[dim] && !INTEGER_CST_P (ubound))
7044 : {
7045 10727 : gfc_init_se (&se, NULL);
7046 10727 : gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
7047 10727 : gfc_add_block_to_block (pblock, &se.pre);
7048 10727 : gfc_add_block_to_block (pblock, &se.finalblock);
7049 10727 : gfc_add_modify (pblock, ubound, se.expr);
7050 : }
7051 : /* The offset of this dimension. offset = offset - lbound * stride. */
7052 17369 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7053 : lbound, size);
7054 17369 : offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7055 : offset, tmp);
7056 :
7057 : /* The size of this dimension, and the stride of the next. */
7058 17369 : if (dim + 1 < as->rank)
7059 3468 : stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
7060 : else
7061 13901 : stride = GFC_TYPE_ARRAY_SIZE (type);
7062 :
7063 17369 : if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
7064 : {
7065 : /* Calculate stride = size * (ubound + 1 - lbound). */
7066 10918 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
7067 : gfc_array_index_type,
7068 : gfc_index_one_node, lbound);
7069 10918 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
7070 : gfc_array_index_type, ubound, tmp);
7071 10918 : tmp = fold_build2_loc (input_location, MULT_EXPR,
7072 : gfc_array_index_type, size, tmp);
7073 10918 : if (stride)
7074 10918 : gfc_add_modify (pblock, stride, tmp);
7075 : else
7076 0 : stride = gfc_evaluate_now (tmp, pblock);
7077 :
7078 : /* Make sure that negative size arrays are translated
7079 : to being zero size. */
7080 10918 : tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
7081 : stride, gfc_index_zero_node);
7082 10918 : tmp = fold_build3_loc (input_location, COND_EXPR,
7083 : gfc_array_index_type, tmp,
7084 : stride, gfc_index_zero_node);
7085 10918 : gfc_add_modify (pblock, stride, tmp);
7086 : }
7087 :
7088 17369 : size = stride;
7089 : }
7090 :
7091 14100 : gfc_trans_array_cobounds (type, pblock, sym);
7092 14100 : gfc_trans_vla_type_sizes (sym, pblock);
7093 :
7094 14100 : *poffset = offset;
7095 14100 : return size;
7096 : }
7097 :
7098 :
7099 : /* Generate code to initialize/allocate an array variable. */
7100 :
7101 : void
7102 32399 : gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
7103 : gfc_wrapped_block * block)
7104 : {
7105 32399 : stmtblock_t init;
7106 32399 : tree type;
7107 32399 : tree tmp = NULL_TREE;
7108 32399 : tree size;
7109 32399 : tree offset;
7110 32399 : tree space;
7111 32399 : tree inittree;
7112 32399 : bool onstack;
7113 32399 : bool back;
7114 :
7115 32399 : gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
7116 :
7117 : /* Do nothing for USEd variables. */
7118 32399 : if (sym->attr.use_assoc)
7119 26197 : return;
7120 :
7121 32350 : type = TREE_TYPE (decl);
7122 32350 : gcc_assert (GFC_ARRAY_TYPE_P (type));
7123 32350 : onstack = TREE_CODE (type) != POINTER_TYPE;
7124 :
7125 : /* In the case of non-dummy symbols with dependencies on an old-fashioned
7126 : function result (ie. proc_name = proc_name->result), gfc_add_init_cleanup
7127 : must be called with the last, optional argument false so that the alloc-
7128 : ation occurs after the processing of the result. */
7129 32350 : back = sym->fn_result_dep;
7130 :
7131 32350 : gfc_init_block (&init);
7132 :
7133 : /* Evaluate character string length. */
7134 32350 : if (sym->ts.type == BT_CHARACTER
7135 3104 : && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
7136 : {
7137 49 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7138 :
7139 49 : gfc_trans_vla_type_sizes (sym, &init);
7140 :
7141 : /* Emit a DECL_EXPR for this variable, which will cause the
7142 : gimplifier to allocate storage, and all that good stuff. */
7143 49 : tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
7144 49 : gfc_add_expr_to_block (&init, tmp);
7145 49 : if (sym->attr.omp_allocate)
7146 : {
7147 : /* Save location of size calculation to ensure GOMP_alloc is placed
7148 : after it. */
7149 0 : tree omp_alloc = lookup_attribute ("omp allocate",
7150 0 : DECL_ATTRIBUTES (decl));
7151 0 : TREE_CHAIN (TREE_CHAIN (TREE_VALUE (omp_alloc)))
7152 0 : = build_tree_list (NULL_TREE, tsi_stmt (tsi_last (init.head)));
7153 : }
7154 : }
7155 :
7156 32148 : if (onstack)
7157 : {
7158 26008 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE,
7159 : back);
7160 26008 : return;
7161 : }
7162 :
7163 6342 : type = TREE_TYPE (type);
7164 :
7165 6342 : gcc_assert (!sym->attr.use_assoc);
7166 6342 : gcc_assert (!sym->module);
7167 :
7168 6342 : if (sym->ts.type == BT_CHARACTER
7169 202 : && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
7170 94 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7171 :
7172 6342 : size = gfc_trans_array_bounds (type, sym, &offset, &init);
7173 :
7174 : /* Don't actually allocate space for Cray Pointees. */
7175 6342 : if (sym->attr.cray_pointee)
7176 : {
7177 140 : if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
7178 49 : gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
7179 :
7180 140 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
7181 140 : return;
7182 : }
7183 6202 : if (sym->attr.omp_allocate)
7184 : {
7185 : /* The size is the number of elements in the array, so multiply by the
7186 : size of an element to get the total size. */
7187 7 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
7188 7 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7189 : size, fold_convert (gfc_array_index_type, tmp));
7190 7 : size = gfc_evaluate_now (size, &init);
7191 :
7192 7 : tree omp_alloc = lookup_attribute ("omp allocate",
7193 7 : DECL_ATTRIBUTES (decl));
7194 7 : TREE_CHAIN (TREE_CHAIN (TREE_VALUE (omp_alloc)))
7195 7 : = build_tree_list (size, NULL_TREE);
7196 7 : space = NULL_TREE;
7197 : }
7198 6195 : else if (flag_stack_arrays)
7199 : {
7200 18 : gcc_assert (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE);
7201 18 : space = build_decl (gfc_get_location (&sym->declared_at),
7202 : VAR_DECL, create_tmp_var_name ("A"),
7203 18 : TREE_TYPE (TREE_TYPE (decl)));
7204 18 : gfc_trans_vla_type_sizes (sym, &init);
7205 : }
7206 : else
7207 : {
7208 : /* The size is the number of elements in the array, so multiply by the
7209 : size of an element to get the total size. */
7210 6177 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
7211 6177 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7212 : size, fold_convert (gfc_array_index_type, tmp));
7213 :
7214 : /* Allocate memory to hold the data. */
7215 6177 : tmp = gfc_call_malloc (&init, TREE_TYPE (decl), size);
7216 6177 : gfc_add_modify (&init, decl, tmp);
7217 :
7218 : /* Free the temporary. */
7219 6177 : tmp = gfc_call_free (decl);
7220 6177 : space = NULL_TREE;
7221 : }
7222 :
7223 : /* Set offset of the array. */
7224 6202 : if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
7225 388 : gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
7226 :
7227 : /* Automatic arrays should not have initializers. */
7228 6202 : gcc_assert (!sym->value);
7229 :
7230 6202 : inittree = gfc_finish_block (&init);
7231 :
7232 6202 : if (space)
7233 : {
7234 18 : tree addr;
7235 18 : pushdecl (space);
7236 :
7237 : /* Don't create new scope, emit the DECL_EXPR in exactly the scope
7238 : where also space is located. */
7239 18 : gfc_init_block (&init);
7240 18 : tmp = fold_build1_loc (input_location, DECL_EXPR,
7241 18 : TREE_TYPE (space), space);
7242 18 : gfc_add_expr_to_block (&init, tmp);
7243 18 : addr = fold_build1_loc (gfc_get_location (&sym->declared_at),
7244 18 : ADDR_EXPR, TREE_TYPE (decl), space);
7245 18 : gfc_add_modify (&init, decl, addr);
7246 18 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE,
7247 : back);
7248 18 : tmp = NULL_TREE;
7249 : }
7250 6202 : gfc_add_init_cleanup (block, inittree, tmp, back);
7251 : }
7252 :
7253 :
7254 : /* Generate entry and exit code for g77 calling convention arrays. */
7255 :
7256 : void
7257 7504 : gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block)
7258 : {
7259 7504 : tree parm;
7260 7504 : tree type;
7261 7504 : tree offset;
7262 7504 : tree tmp;
7263 7504 : tree stmt;
7264 7504 : stmtblock_t init;
7265 :
7266 7504 : location_t loc = input_location;
7267 7504 : input_location = gfc_get_location (&sym->declared_at);
7268 :
7269 : /* Descriptor type. */
7270 7504 : parm = sym->backend_decl;
7271 7504 : type = TREE_TYPE (parm);
7272 7504 : gcc_assert (GFC_ARRAY_TYPE_P (type));
7273 :
7274 7504 : gfc_start_block (&init);
7275 :
7276 7504 : if (sym->ts.type == BT_CHARACTER
7277 752 : && VAR_P (sym->ts.u.cl->backend_decl))
7278 85 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7279 :
7280 : /* Evaluate the bounds of the array. */
7281 7504 : gfc_trans_array_bounds (type, sym, &offset, &init);
7282 :
7283 : /* Set the offset. */
7284 7504 : if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
7285 1214 : gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
7286 :
7287 : /* Set the pointer itself if we aren't using the parameter directly. */
7288 7504 : if (TREE_CODE (parm) != PARM_DECL)
7289 : {
7290 618 : tmp = GFC_DECL_SAVED_DESCRIPTOR (parm);
7291 618 : if (sym->ts.type == BT_CLASS)
7292 : {
7293 243 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
7294 243 : tmp = gfc_class_data_get (tmp);
7295 243 : tmp = gfc_conv_descriptor_data_get (tmp);
7296 : }
7297 618 : tmp = convert (TREE_TYPE (parm), tmp);
7298 618 : gfc_add_modify (&init, parm, tmp);
7299 : }
7300 7504 : stmt = gfc_finish_block (&init);
7301 :
7302 7504 : input_location = loc;
7303 :
7304 : /* Add the initialization code to the start of the function. */
7305 :
7306 7504 : if ((sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.optional)
7307 7504 : || sym->attr.optional
7308 7010 : || sym->attr.not_always_present)
7309 : {
7310 554 : tree nullify;
7311 554 : if (TREE_CODE (parm) != PARM_DECL)
7312 105 : nullify = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
7313 : parm, null_pointer_node);
7314 : else
7315 449 : nullify = build_empty_stmt (input_location);
7316 554 : tmp = gfc_conv_expr_present (sym, true);
7317 554 : stmt = build3_v (COND_EXPR, tmp, stmt, nullify);
7318 : }
7319 :
7320 7504 : gfc_add_init_cleanup (block, stmt, NULL_TREE);
7321 7504 : }
7322 :
7323 :
7324 : /* Modify the descriptor of an array parameter so that it has the
7325 : correct lower bound. Also move the upper bound accordingly.
7326 : If the array is not packed, it will be copied into a temporary.
7327 : For each dimension we set the new lower and upper bounds. Then we copy the
7328 : stride and calculate the offset for this dimension. We also work out
7329 : what the stride of a packed array would be, and see it the two match.
7330 : If the array need repacking, we set the stride to the values we just
7331 : calculated, recalculate the offset and copy the array data.
7332 : Code is also added to copy the data back at the end of the function.
7333 : */
7334 :
7335 : void
7336 13534 : gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
7337 : gfc_wrapped_block * block)
7338 : {
7339 13534 : tree size;
7340 13534 : tree type;
7341 13534 : tree offset;
7342 13534 : stmtblock_t init;
7343 13534 : tree stmtInit, stmtCleanup;
7344 13534 : tree lbound;
7345 13534 : tree ubound;
7346 13534 : tree dubound;
7347 13534 : tree dlbound;
7348 13534 : tree dumdesc;
7349 13534 : tree tmp;
7350 13534 : tree stride, stride2;
7351 13534 : tree stmt_packed;
7352 13534 : tree stmt_unpacked;
7353 13534 : tree partial;
7354 13534 : gfc_se se;
7355 13534 : int n;
7356 13534 : int checkparm;
7357 13534 : int no_repack;
7358 13534 : bool optional_arg;
7359 13534 : gfc_array_spec *as;
7360 13534 : bool is_classarray = IS_CLASS_COARRAY_OR_ARRAY (sym);
7361 :
7362 : /* Do nothing for pointer and allocatable arrays. */
7363 13534 : if ((sym->ts.type != BT_CLASS && sym->attr.pointer)
7364 13437 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer)
7365 13437 : || sym->attr.allocatable
7366 13331 : || (is_classarray && CLASS_DATA (sym)->attr.allocatable))
7367 6160 : return;
7368 :
7369 886 : if ((!is_classarray
7370 886 : || (is_classarray && CLASS_DATA (sym)->as->type == AS_EXPLICIT))
7371 12629 : && sym->attr.dummy && !sym->attr.elemental && gfc_is_nodesc_array (sym))
7372 : {
7373 5957 : gfc_trans_g77_array (sym, block);
7374 5957 : return;
7375 : }
7376 :
7377 7374 : location_t loc = input_location;
7378 7374 : input_location = gfc_get_location (&sym->declared_at);
7379 :
7380 : /* Descriptor type. */
7381 7374 : type = TREE_TYPE (tmpdesc);
7382 7374 : gcc_assert (GFC_ARRAY_TYPE_P (type));
7383 7374 : dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
7384 7374 : if (is_classarray)
7385 : /* For a class array the dummy array descriptor is in the _class
7386 : component. */
7387 721 : dumdesc = gfc_class_data_get (dumdesc);
7388 : else
7389 6653 : dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc);
7390 7374 : as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
7391 7374 : gfc_start_block (&init);
7392 :
7393 7374 : if (sym->ts.type == BT_CHARACTER
7394 822 : && VAR_P (sym->ts.u.cl->backend_decl))
7395 87 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7396 :
7397 : /* TODO: Fix the exclusion of class arrays from extent checking. */
7398 1084 : checkparm = (as->type == AS_EXPLICIT && !is_classarray
7399 8439 : && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
7400 :
7401 7374 : no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
7402 7373 : || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
7403 :
7404 7374 : if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
7405 : {
7406 : /* For non-constant shape arrays we only check if the first dimension
7407 : is contiguous. Repacking higher dimensions wouldn't gain us
7408 : anything as we still don't know the array stride. */
7409 1 : partial = gfc_create_var (logical_type_node, "partial");
7410 1 : TREE_USED (partial) = 1;
7411 1 : tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
7412 1 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, tmp,
7413 : gfc_index_one_node);
7414 1 : gfc_add_modify (&init, partial, tmp);
7415 : }
7416 : else
7417 : partial = NULL_TREE;
7418 :
7419 : /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
7420 : here, however I think it does the right thing. */
7421 7374 : if (no_repack)
7422 : {
7423 : /* Set the first stride. */
7424 7372 : stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
7425 7372 : stride = gfc_evaluate_now (stride, &init);
7426 :
7427 7372 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7428 : stride, gfc_index_zero_node);
7429 7372 : tmp = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
7430 : tmp, gfc_index_one_node, stride);
7431 7372 : stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
7432 7372 : gfc_add_modify (&init, stride, tmp);
7433 :
7434 : /* Allow the user to disable array repacking. */
7435 7372 : stmt_unpacked = NULL_TREE;
7436 : }
7437 : else
7438 : {
7439 2 : gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
7440 : /* A library call to repack the array if necessary. */
7441 2 : tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
7442 2 : stmt_unpacked = build_call_expr_loc (input_location,
7443 : gfor_fndecl_in_pack, 1, tmp);
7444 :
7445 2 : stride = gfc_index_one_node;
7446 :
7447 2 : if (warn_array_temporaries)
7448 : {
7449 1 : locus where;
7450 1 : gfc_locus_from_location (&where, loc);
7451 1 : gfc_warning (OPT_Warray_temporaries,
7452 : "Creating array temporary at %L", &where);
7453 : }
7454 : }
7455 :
7456 : /* This is for the case where the array data is used directly without
7457 : calling the repack function. */
7458 7374 : if (no_repack || partial != NULL_TREE)
7459 7373 : stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
7460 : else
7461 : stmt_packed = NULL_TREE;
7462 :
7463 : /* Assign the data pointer. */
7464 7374 : if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
7465 : {
7466 : /* Don't repack unknown shape arrays when the first stride is 1. */
7467 1 : tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (stmt_packed),
7468 : partial, stmt_packed, stmt_unpacked);
7469 : }
7470 : else
7471 7373 : tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
7472 7374 : gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp));
7473 :
7474 7374 : offset = gfc_index_zero_node;
7475 7374 : size = gfc_index_one_node;
7476 :
7477 : /* Evaluate the bounds of the array. */
7478 17190 : for (n = 0; n < as->rank; n++)
7479 : {
7480 9816 : if (checkparm || !as->upper[n])
7481 : {
7482 : /* Get the bounds of the actual parameter. */
7483 8497 : dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]);
7484 8497 : dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]);
7485 : }
7486 : else
7487 : {
7488 : dubound = NULL_TREE;
7489 : dlbound = NULL_TREE;
7490 : }
7491 :
7492 9816 : lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
7493 9816 : if (!INTEGER_CST_P (lbound))
7494 : {
7495 46 : gfc_init_se (&se, NULL);
7496 46 : gfc_conv_expr_type (&se, as->lower[n],
7497 : gfc_array_index_type);
7498 46 : gfc_add_block_to_block (&init, &se.pre);
7499 46 : gfc_add_modify (&init, lbound, se.expr);
7500 : }
7501 :
7502 9816 : ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
7503 : /* Set the desired upper bound. */
7504 9816 : if (as->upper[n])
7505 : {
7506 : /* We know what we want the upper bound to be. */
7507 1377 : if (!INTEGER_CST_P (ubound))
7508 : {
7509 639 : gfc_init_se (&se, NULL);
7510 639 : gfc_conv_expr_type (&se, as->upper[n],
7511 : gfc_array_index_type);
7512 639 : gfc_add_block_to_block (&init, &se.pre);
7513 639 : gfc_add_modify (&init, ubound, se.expr);
7514 : }
7515 :
7516 : /* Check the sizes match. */
7517 1377 : if (checkparm)
7518 : {
7519 : /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
7520 58 : char * msg;
7521 58 : tree temp;
7522 58 : locus where;
7523 :
7524 58 : gfc_locus_from_location (&where, loc);
7525 58 : temp = fold_build2_loc (input_location, MINUS_EXPR,
7526 : gfc_array_index_type, ubound, lbound);
7527 58 : temp = fold_build2_loc (input_location, PLUS_EXPR,
7528 : gfc_array_index_type,
7529 : gfc_index_one_node, temp);
7530 58 : stride2 = fold_build2_loc (input_location, MINUS_EXPR,
7531 : gfc_array_index_type, dubound,
7532 : dlbound);
7533 58 : stride2 = fold_build2_loc (input_location, PLUS_EXPR,
7534 : gfc_array_index_type,
7535 : gfc_index_one_node, stride2);
7536 58 : tmp = fold_build2_loc (input_location, NE_EXPR,
7537 : gfc_array_index_type, temp, stride2);
7538 58 : msg = xasprintf ("Dimension %d of array '%s' has extent "
7539 : "%%ld instead of %%ld", n+1, sym->name);
7540 :
7541 58 : gfc_trans_runtime_check (true, false, tmp, &init, &where, msg,
7542 : fold_convert (long_integer_type_node, temp),
7543 : fold_convert (long_integer_type_node, stride2));
7544 :
7545 58 : free (msg);
7546 : }
7547 : }
7548 : else
7549 : {
7550 : /* For assumed shape arrays move the upper bound by the same amount
7551 : as the lower bound. */
7552 8439 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
7553 : gfc_array_index_type, dubound, dlbound);
7554 8439 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
7555 : gfc_array_index_type, tmp, lbound);
7556 8439 : gfc_add_modify (&init, ubound, tmp);
7557 : }
7558 : /* The offset of this dimension. offset = offset - lbound * stride. */
7559 9816 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7560 : lbound, stride);
7561 9816 : offset = fold_build2_loc (input_location, MINUS_EXPR,
7562 : gfc_array_index_type, offset, tmp);
7563 :
7564 : /* The size of this dimension, and the stride of the next. */
7565 9816 : if (n + 1 < as->rank)
7566 : {
7567 2442 : stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
7568 :
7569 2442 : if (no_repack || partial != NULL_TREE)
7570 2441 : stmt_unpacked =
7571 2441 : gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]);
7572 :
7573 : /* Figure out the stride if not a known constant. */
7574 2442 : if (!INTEGER_CST_P (stride))
7575 : {
7576 2441 : if (no_repack)
7577 : stmt_packed = NULL_TREE;
7578 : else
7579 : {
7580 : /* Calculate stride = size * (ubound + 1 - lbound). */
7581 0 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
7582 : gfc_array_index_type,
7583 : gfc_index_one_node, lbound);
7584 0 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
7585 : gfc_array_index_type, ubound, tmp);
7586 0 : size = fold_build2_loc (input_location, MULT_EXPR,
7587 : gfc_array_index_type, size, tmp);
7588 0 : stmt_packed = size;
7589 : }
7590 :
7591 : /* Assign the stride. */
7592 2441 : if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
7593 0 : tmp = fold_build3_loc (input_location, COND_EXPR,
7594 : gfc_array_index_type, partial,
7595 : stmt_unpacked, stmt_packed);
7596 : else
7597 2441 : tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
7598 2441 : gfc_add_modify (&init, stride, tmp);
7599 : }
7600 : }
7601 : else
7602 : {
7603 7374 : stride = GFC_TYPE_ARRAY_SIZE (type);
7604 :
7605 7374 : if (stride && !INTEGER_CST_P (stride))
7606 : {
7607 : /* Calculate size = stride * (ubound + 1 - lbound). */
7608 7373 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
7609 : gfc_array_index_type,
7610 : gfc_index_one_node, lbound);
7611 7373 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
7612 : gfc_array_index_type,
7613 : ubound, tmp);
7614 22119 : tmp = fold_build2_loc (input_location, MULT_EXPR,
7615 : gfc_array_index_type,
7616 7373 : GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
7617 7373 : gfc_add_modify (&init, stride, tmp);
7618 : }
7619 : }
7620 : }
7621 :
7622 7374 : gfc_trans_array_cobounds (type, &init, sym);
7623 :
7624 : /* Set the offset. */
7625 7374 : if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
7626 7372 : gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
7627 :
7628 : /* Fold the element spacing of the actual argument into the strides and the
7629 : offset, so that the elements are addressed by the constant element length
7630 : rather than by a span loaded from the descriptor. */
7631 7374 : if (DECL_LANG_SPECIFIC (tmpdesc) && GFC_DECL_SPAN_NORMALIZED (tmpdesc))
7632 : {
7633 451 : tree element = fold_convert (gfc_array_index_type,
7634 : TYPE_SIZE_UNIT (gfc_get_element_type (type)));
7635 451 : tree span = gfc_evaluate_now (gfc_conv_descriptor_span_get (dumdesc),
7636 : &init);
7637 451 : tree unit = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7638 451 : span, element);
7639 451 : tree factor = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
7640 451 : gfc_array_index_type, span, element);
7641 451 : factor = gfc_evaluate_now (factor, &init);
7642 :
7643 1403 : auto scale = [&] (tree var)
7644 : {
7645 952 : tree scaled = fold_build2_loc (input_location, MULT_EXPR,
7646 : gfc_array_index_type, var, factor);
7647 952 : scaled = fold_build3_loc (input_location, COND_EXPR,
7648 : gfc_array_index_type, unit, var, scaled);
7649 952 : gfc_add_modify (&init, var, scaled);
7650 1403 : };
7651 :
7652 : /* A span addressed dummy is never repacked, so its strides and its
7653 : offset are all variables loaded from the descriptor. */
7654 952 : for (n = 0; n < as->rank; n++)
7655 : {
7656 501 : gcc_assert (VAR_P (GFC_TYPE_ARRAY_STRIDE (type, n)));
7657 501 : scale (GFC_TYPE_ARRAY_STRIDE (type, n));
7658 : }
7659 :
7660 451 : gcc_assert (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)));
7661 451 : scale (GFC_TYPE_ARRAY_OFFSET (type));
7662 : }
7663 :
7664 : /* Load the span once here, like the bounds above, so that element
7665 : addressing does not reload it from the descriptor. The descriptor
7666 : itself is not available in an outlined region, such as an OpenMP
7667 : target region, whereas this local variable is. */
7668 7374 : if (tree span = GFC_DECL_GET_SPAN (tmpdesc))
7669 156 : gfc_add_modify (&init, span, gfc_conv_descriptor_span_get (dumdesc));
7670 :
7671 7374 : gfc_trans_vla_type_sizes (sym, &init);
7672 :
7673 7374 : stmtInit = gfc_finish_block (&init);
7674 :
7675 : /* Only do the entry/initialization code if the arg is present. */
7676 7374 : dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
7677 7374 : optional_arg = (sym->attr.optional
7678 7374 : || (sym->ns->proc_name->attr.entry_master
7679 79 : && sym->attr.dummy));
7680 : if (optional_arg)
7681 : {
7682 783 : tree zero_init = fold_convert (TREE_TYPE (tmpdesc), null_pointer_node);
7683 783 : zero_init = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
7684 : tmpdesc, zero_init);
7685 783 : tmp = gfc_conv_expr_present (sym, true);
7686 783 : stmtInit = build3_v (COND_EXPR, tmp, stmtInit, zero_init);
7687 : }
7688 :
7689 : /* Cleanup code. */
7690 7374 : if (no_repack)
7691 : stmtCleanup = NULL_TREE;
7692 : else
7693 : {
7694 2 : stmtblock_t cleanup;
7695 2 : gfc_start_block (&cleanup);
7696 :
7697 2 : if (sym->attr.intent != INTENT_IN)
7698 : {
7699 : /* Copy the data back. */
7700 2 : tmp = build_call_expr_loc (input_location,
7701 : gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
7702 2 : gfc_add_expr_to_block (&cleanup, tmp);
7703 : }
7704 :
7705 : /* Free the temporary. */
7706 2 : tmp = gfc_call_free (tmpdesc);
7707 2 : gfc_add_expr_to_block (&cleanup, tmp);
7708 :
7709 2 : stmtCleanup = gfc_finish_block (&cleanup);
7710 :
7711 : /* Only do the cleanup if the array was repacked. */
7712 2 : if (is_classarray)
7713 : /* For a class array the dummy array descriptor is in the _class
7714 : component. */
7715 1 : tmp = gfc_class_data_get (dumdesc);
7716 : else
7717 1 : tmp = build_fold_indirect_ref_loc (input_location, dumdesc);
7718 2 : tmp = gfc_conv_descriptor_data_get (tmp);
7719 2 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
7720 : tmp, tmpdesc);
7721 2 : stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
7722 : build_empty_stmt (input_location));
7723 :
7724 2 : if (optional_arg)
7725 : {
7726 0 : tmp = gfc_conv_expr_present (sym);
7727 0 : stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
7728 : build_empty_stmt (input_location));
7729 : }
7730 : }
7731 :
7732 : /* We don't need to free any memory allocated by internal_pack as it will
7733 : be freed at the end of the function by pop_context. */
7734 7374 : gfc_add_init_cleanup (block, stmtInit, stmtCleanup);
7735 :
7736 7374 : input_location = loc;
7737 : }
7738 :
7739 :
7740 : /* Calculate the overall offset, including subreferences. */
7741 : void
7742 61397 : gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
7743 : bool subref, gfc_expr *expr)
7744 : {
7745 61397 : tree tmp;
7746 61397 : tree field;
7747 61397 : tree stride;
7748 61397 : tree index;
7749 61397 : gfc_ref *ref;
7750 61397 : gfc_se start;
7751 61397 : int n;
7752 :
7753 : /* If offset is NULL and this is not a subreferenced array, there is
7754 : nothing to do. */
7755 61397 : if (offset == NULL_TREE)
7756 : {
7757 1108 : if (subref)
7758 171 : offset = gfc_index_zero_node;
7759 : else
7760 937 : return;
7761 : }
7762 :
7763 : /* An array whose elements are spaced by the span needs pointer arithmetic
7764 : to reference an element. */
7765 60460 : tmp = build_array_ref (desc, offset, NULL, NULL);
7766 :
7767 : /* Offset the data pointer for pointer assignments from arrays with
7768 : subreferences; e.g. my_integer => my_type(:)%integer_component. */
7769 60460 : if (subref)
7770 : {
7771 : /* Go past the array reference. */
7772 1272 : for (ref = expr->ref; ref; ref = ref->next)
7773 1272 : if (ref->type == REF_ARRAY &&
7774 1137 : ref->u.ar.type != AR_ELEMENT)
7775 : {
7776 1113 : ref = ref->next;
7777 1113 : break;
7778 : }
7779 :
7780 : /* Calculate the offset for each subsequent subreference. */
7781 2082 : for (; ref; ref = ref->next)
7782 : {
7783 969 : switch (ref->type)
7784 : {
7785 541 : case REF_COMPONENT:
7786 541 : field = ref->u.c.component->backend_decl;
7787 541 : gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
7788 1082 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
7789 541 : TREE_TYPE (field),
7790 : tmp, field, NULL_TREE);
7791 541 : break;
7792 :
7793 320 : case REF_SUBSTRING:
7794 320 : gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
7795 320 : gfc_init_se (&start, NULL);
7796 320 : gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
7797 320 : gfc_add_block_to_block (block, &start.pre);
7798 320 : tmp = gfc_build_array_ref (tmp, start.expr, NULL);
7799 320 : break;
7800 :
7801 24 : case REF_ARRAY:
7802 24 : gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
7803 : && ref->u.ar.type == AR_ELEMENT);
7804 :
7805 : /* TODO - Add bounds checking. */
7806 24 : stride = gfc_index_one_node;
7807 24 : index = gfc_index_zero_node;
7808 55 : for (n = 0; n < ref->u.ar.dimen; n++)
7809 : {
7810 31 : tree itmp;
7811 31 : tree jtmp;
7812 :
7813 : /* Update the index. */
7814 31 : gfc_init_se (&start, NULL);
7815 31 : gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
7816 31 : itmp = gfc_evaluate_now (start.expr, block);
7817 31 : gfc_init_se (&start, NULL);
7818 31 : gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
7819 31 : jtmp = gfc_evaluate_now (start.expr, block);
7820 31 : itmp = fold_build2_loc (input_location, MINUS_EXPR,
7821 : gfc_array_index_type, itmp, jtmp);
7822 31 : itmp = fold_build2_loc (input_location, MULT_EXPR,
7823 : gfc_array_index_type, itmp, stride);
7824 31 : index = fold_build2_loc (input_location, PLUS_EXPR,
7825 : gfc_array_index_type, itmp, index);
7826 31 : index = gfc_evaluate_now (index, block);
7827 :
7828 : /* Update the stride. */
7829 31 : gfc_init_se (&start, NULL);
7830 31 : gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
7831 31 : itmp = fold_build2_loc (input_location, MINUS_EXPR,
7832 : gfc_array_index_type, start.expr,
7833 : jtmp);
7834 31 : itmp = fold_build2_loc (input_location, PLUS_EXPR,
7835 : gfc_array_index_type,
7836 : gfc_index_one_node, itmp);
7837 31 : stride = fold_build2_loc (input_location, MULT_EXPR,
7838 : gfc_array_index_type, stride, itmp);
7839 31 : stride = gfc_evaluate_now (stride, block);
7840 : }
7841 :
7842 : /* Apply the index to obtain the array element. */
7843 24 : tmp = gfc_build_array_ref (tmp, index, NULL);
7844 24 : break;
7845 :
7846 84 : case REF_INQUIRY:
7847 84 : switch (ref->u.i)
7848 : {
7849 60 : case INQUIRY_RE:
7850 120 : tmp = fold_build1_loc (input_location, REALPART_EXPR,
7851 60 : TREE_TYPE (TREE_TYPE (tmp)), tmp);
7852 60 : break;
7853 :
7854 24 : case INQUIRY_IM:
7855 48 : tmp = fold_build1_loc (input_location, IMAGPART_EXPR,
7856 24 : TREE_TYPE (TREE_TYPE (tmp)), tmp);
7857 24 : break;
7858 :
7859 : default:
7860 : break;
7861 : }
7862 : break;
7863 :
7864 0 : default:
7865 0 : gcc_unreachable ();
7866 969 : break;
7867 : }
7868 : }
7869 : }
7870 :
7871 : /* Set the target data pointer. */
7872 60460 : offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
7873 :
7874 : /* Check for optional dummy argument being present. Arguments of BIND(C)
7875 : procedures are excepted here since they are handled differently. */
7876 60460 : if (expr->expr_type == EXPR_VARIABLE
7877 53037 : && expr->symtree->n.sym->attr.dummy
7878 6539 : && expr->symtree->n.sym->attr.optional
7879 61452 : && !is_CFI_desc (NULL, expr))
7880 1624 : offset = build3_loc (input_location, COND_EXPR, TREE_TYPE (offset),
7881 812 : gfc_conv_expr_present (expr->symtree->n.sym), offset,
7882 812 : fold_convert (TREE_TYPE (offset), gfc_index_zero_node));
7883 :
7884 60460 : gfc_conv_descriptor_data_set (block, parm, offset);
7885 : }
7886 :
7887 :
7888 : /* gfc_conv_expr_descriptor needs the string length an expression
7889 : so that the size of the temporary can be obtained. This is done
7890 : by adding up the string lengths of all the elements in the
7891 : expression. Function with non-constant expressions have their
7892 : string lengths mapped onto the actual arguments using the
7893 : interface mapping machinery in trans-expr.cc. */
7894 : static void
7895 1584 : get_array_charlen (gfc_expr *expr, gfc_se *se)
7896 : {
7897 1584 : gfc_interface_mapping mapping;
7898 1584 : gfc_formal_arglist *formal;
7899 1584 : gfc_actual_arglist *arg;
7900 1584 : gfc_se tse;
7901 1584 : gfc_expr *e;
7902 :
7903 1584 : if (expr->ts.u.cl->length
7904 1584 : && gfc_is_constant_expr (expr->ts.u.cl->length))
7905 : {
7906 1237 : if (!expr->ts.u.cl->backend_decl)
7907 471 : gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
7908 1369 : return;
7909 : }
7910 :
7911 347 : switch (expr->expr_type)
7912 : {
7913 130 : case EXPR_ARRAY:
7914 :
7915 : /* This is somewhat brutal. The expression for the first
7916 : element of the array is evaluated and assigned to a
7917 : new string length for the original expression. */
7918 130 : e = gfc_constructor_first (expr->value.constructor)->expr;
7919 :
7920 130 : gfc_init_se (&tse, NULL);
7921 :
7922 : /* Avoid evaluating trailing array references since all we need is
7923 : the string length. */
7924 130 : if (e->rank)
7925 38 : tse.descriptor_only = 1;
7926 130 : if (e->rank && e->expr_type != EXPR_VARIABLE)
7927 1 : gfc_conv_expr_descriptor (&tse, e);
7928 : else
7929 129 : gfc_conv_expr (&tse, e);
7930 :
7931 130 : gfc_add_block_to_block (&se->pre, &tse.pre);
7932 130 : gfc_add_block_to_block (&se->post, &tse.post);
7933 :
7934 130 : if (!expr->ts.u.cl->backend_decl || !VAR_P (expr->ts.u.cl->backend_decl))
7935 : {
7936 87 : expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
7937 87 : expr->ts.u.cl->backend_decl =
7938 87 : gfc_create_var (gfc_charlen_type_node, "sln");
7939 : }
7940 :
7941 130 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
7942 : tse.string_length);
7943 :
7944 : /* Make sure that deferred length components point to the hidden
7945 : string_length component. */
7946 130 : if (TREE_CODE (tse.expr) == COMPONENT_REF
7947 25 : && TREE_CODE (tse.string_length) == COMPONENT_REF
7948 149 : && TREE_OPERAND (tse.expr, 0) == TREE_OPERAND (tse.string_length, 0))
7949 19 : e->ts.u.cl->backend_decl = expr->ts.u.cl->backend_decl;
7950 :
7951 : return;
7952 :
7953 91 : case EXPR_OP:
7954 91 : get_array_charlen (expr->value.op.op1, se);
7955 :
7956 : /* For parentheses the expression ts.u.cl should be identical. */
7957 91 : if (expr->value.op.op == INTRINSIC_PARENTHESES)
7958 : {
7959 2 : if (expr->value.op.op1->ts.u.cl != expr->ts.u.cl)
7960 2 : expr->ts.u.cl->backend_decl
7961 2 : = expr->value.op.op1->ts.u.cl->backend_decl;
7962 : return;
7963 : }
7964 :
7965 178 : expr->ts.u.cl->backend_decl =
7966 89 : gfc_create_var (gfc_charlen_type_node, "sln");
7967 :
7968 89 : if (expr->value.op.op2)
7969 : {
7970 89 : get_array_charlen (expr->value.op.op2, se);
7971 :
7972 89 : gcc_assert (expr->value.op.op == INTRINSIC_CONCAT);
7973 :
7974 : /* Add the string lengths and assign them to the expression
7975 : string length backend declaration. */
7976 89 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
7977 : fold_build2_loc (input_location, PLUS_EXPR,
7978 : gfc_charlen_type_node,
7979 89 : expr->value.op.op1->ts.u.cl->backend_decl,
7980 89 : expr->value.op.op2->ts.u.cl->backend_decl));
7981 : }
7982 : else
7983 0 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
7984 0 : expr->value.op.op1->ts.u.cl->backend_decl);
7985 : break;
7986 :
7987 44 : case EXPR_FUNCTION:
7988 44 : if (expr->value.function.esym == NULL
7989 37 : || expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
7990 : {
7991 7 : gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
7992 7 : break;
7993 : }
7994 :
7995 : /* Map expressions involving the dummy arguments onto the actual
7996 : argument expressions. */
7997 37 : gfc_init_interface_mapping (&mapping);
7998 37 : formal = gfc_sym_get_dummy_args (expr->symtree->n.sym);
7999 37 : arg = expr->value.function.actual;
8000 :
8001 : /* Set se = NULL in the calls to the interface mapping, to suppress any
8002 : backend stuff. */
8003 113 : for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
8004 : {
8005 38 : if (!arg->expr)
8006 0 : continue;
8007 38 : if (formal->sym)
8008 38 : gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
8009 : }
8010 :
8011 37 : gfc_init_se (&tse, NULL);
8012 :
8013 : /* Build the expression for the character length and convert it. */
8014 37 : gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length);
8015 :
8016 37 : gfc_add_block_to_block (&se->pre, &tse.pre);
8017 37 : gfc_add_block_to_block (&se->post, &tse.post);
8018 37 : tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
8019 74 : tse.expr = fold_build2_loc (input_location, MAX_EXPR,
8020 37 : TREE_TYPE (tse.expr), tse.expr,
8021 37 : build_zero_cst (TREE_TYPE (tse.expr)));
8022 37 : expr->ts.u.cl->backend_decl = tse.expr;
8023 37 : gfc_free_interface_mapping (&mapping);
8024 37 : break;
8025 :
8026 82 : default:
8027 82 : gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
8028 82 : break;
8029 : }
8030 : }
8031 :
8032 :
8033 : /* Helper function to check dimensions. */
8034 : static bool
8035 0 : transposed_dims (gfc_ss *ss)
8036 : {
8037 0 : int n;
8038 :
8039 180580 : for (n = 0; n < ss->dimen; n++)
8040 90498 : if (ss->dim[n] != n)
8041 : return true;
8042 : return false;
8043 : }
8044 :
8045 :
8046 : /* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
8047 : AR_FULL, suitable for the scalarizer. */
8048 :
8049 : static gfc_ss *
8050 1657 : walk_coarray (gfc_expr *e)
8051 : {
8052 1657 : gfc_ss *ss;
8053 :
8054 1657 : ss = gfc_walk_expr (e);
8055 :
8056 : /* Fix scalar coarray. */
8057 1657 : if (ss == gfc_ss_terminator)
8058 : {
8059 481 : gfc_ref *ref;
8060 :
8061 481 : ref = e->ref;
8062 659 : while (ref)
8063 : {
8064 659 : if (ref->type == REF_ARRAY
8065 481 : && ref->u.ar.codimen > 0)
8066 : break;
8067 :
8068 178 : ref = ref->next;
8069 : }
8070 :
8071 481 : gcc_assert (ref != NULL);
8072 481 : if (ref->u.ar.type == AR_ELEMENT)
8073 463 : ref->u.ar.type = AR_SECTION;
8074 481 : ss = gfc_reverse_ss (gfc_walk_array_ref (ss, e, ref, false));
8075 : }
8076 :
8077 1657 : return ss;
8078 : }
8079 :
8080 : gfc_array_spec *
8081 2328 : get_coarray_as (const gfc_expr *e)
8082 : {
8083 2328 : gfc_array_spec *as;
8084 2328 : gfc_symbol *sym = e->symtree->n.sym;
8085 2328 : gfc_component *comp;
8086 :
8087 2328 : if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.codimension)
8088 631 : as = CLASS_DATA (sym)->as;
8089 1697 : else if (sym->attr.codimension)
8090 1637 : as = sym->as;
8091 : else
8092 : as = nullptr;
8093 :
8094 5389 : for (gfc_ref *ref = e->ref; ref; ref = ref->next)
8095 : {
8096 3061 : switch (ref->type)
8097 : {
8098 733 : case REF_COMPONENT:
8099 733 : comp = ref->u.c.component;
8100 733 : if (comp->ts.type == BT_CLASS && CLASS_DATA (comp)->attr.codimension)
8101 18 : as = CLASS_DATA (comp)->as;
8102 715 : else if (comp->ts.type != BT_CLASS && comp->attr.codimension)
8103 691 : as = comp->as;
8104 : break;
8105 :
8106 : case REF_ARRAY:
8107 : case REF_SUBSTRING:
8108 : case REF_INQUIRY:
8109 : break;
8110 : }
8111 : }
8112 :
8113 2328 : return as;
8114 : }
8115 :
8116 : bool
8117 147588 : is_explicit_coarray (gfc_expr *expr)
8118 : {
8119 147588 : if (!gfc_is_coarray (expr))
8120 : return false;
8121 :
8122 2328 : gfc_array_spec *cas = get_coarray_as (expr);
8123 2328 : return cas && cas->cotype == AS_EXPLICIT;
8124 : }
8125 :
8126 : /* Convert an array for passing as an actual argument. Expressions and
8127 : vector subscripts are evaluated and stored in a temporary, which is then
8128 : passed. For whole arrays the descriptor is passed. For array sections
8129 : a modified copy of the descriptor is passed, but using the original data.
8130 :
8131 : This function is also used for array pointer assignments, and there
8132 : are three cases:
8133 :
8134 : - se->want_pointer && !se->direct_byref
8135 : EXPR is an actual argument. On exit, se->expr contains a
8136 : pointer to the array descriptor.
8137 :
8138 : - !se->want_pointer && !se->direct_byref
8139 : EXPR is an actual argument to an intrinsic function or the
8140 : left-hand side of a pointer assignment. On exit, se->expr
8141 : contains the descriptor for EXPR.
8142 :
8143 : - !se->want_pointer && se->direct_byref
8144 : EXPR is the right-hand side of a pointer assignment and
8145 : se->expr is the descriptor for the previously-evaluated
8146 : left-hand side. The function creates an assignment from
8147 : EXPR to se->expr.
8148 :
8149 :
8150 : The se->force_tmp flag disables the non-copying descriptor optimization
8151 : that is used for transpose. It may be used in cases where there is an
8152 : alias between the transpose argument and another argument in the same
8153 : function call. */
8154 :
8155 : void
8156 164493 : gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
8157 : {
8158 164493 : gfc_ss *ss;
8159 164493 : gfc_ss_type ss_type;
8160 164493 : gfc_ss_info *ss_info;
8161 164493 : gfc_loopinfo loop;
8162 164493 : gfc_array_info *info;
8163 164493 : int need_tmp;
8164 164493 : int n;
8165 164493 : tree tmp;
8166 164493 : tree desc;
8167 164493 : stmtblock_t block;
8168 164493 : tree start;
8169 164493 : int full;
8170 164493 : bool subref_array_target = false;
8171 164493 : bool deferred_array_component = false;
8172 164493 : bool substr = false;
8173 164493 : gfc_expr *arg, *ss_expr;
8174 :
8175 164493 : if (se->want_coarray || expr->rank == 0)
8176 1657 : ss = walk_coarray (expr);
8177 : else
8178 162836 : ss = gfc_walk_expr (expr);
8179 :
8180 164493 : gcc_assert (ss != NULL);
8181 164493 : gcc_assert (ss != gfc_ss_terminator);
8182 :
8183 164493 : ss_info = ss->info;
8184 164493 : ss_type = ss_info->type;
8185 164493 : ss_expr = ss_info->expr;
8186 :
8187 : /* Special case: TRANSPOSE which needs no temporary. */
8188 170078 : while (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym
8189 169676 : && (arg = gfc_get_noncopying_intrinsic_argument (expr)) != NULL)
8190 : {
8191 : /* This is a call to transpose which has already been handled by the
8192 : scalarizer, so that we just need to get its argument's descriptor. */
8193 444 : gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
8194 444 : expr = expr->value.function.actual->expr;
8195 : }
8196 :
8197 164493 : if (!se->direct_byref)
8198 315817 : se->unlimited_polymorphic = UNLIMITED_POLY (expr);
8199 :
8200 : /* Special case things we know we can pass easily. */
8201 164493 : switch (expr->expr_type)
8202 : {
8203 147873 : case EXPR_VARIABLE:
8204 : /* If we have a linear array section, we can pass it directly.
8205 : Otherwise we need to copy it into a temporary. */
8206 :
8207 147873 : gcc_assert (ss_type == GFC_SS_SECTION);
8208 147873 : gcc_assert (ss_expr == expr);
8209 147873 : info = &ss_info->data.array;
8210 :
8211 : /* Get the descriptor for the array. */
8212 147873 : gfc_conv_ss_descriptor (&se->pre, ss, 0);
8213 147873 : desc = info->descriptor;
8214 :
8215 : /* The charlen backend decl for deferred character components cannot
8216 : be used because it is fixed at zero. Instead, the hidden string
8217 : length component is used. */
8218 147873 : if (expr->ts.type == BT_CHARACTER
8219 20407 : && expr->ts.deferred
8220 2878 : && TREE_CODE (desc) == COMPONENT_REF)
8221 147873 : deferred_array_component = true;
8222 :
8223 147873 : substr = info->ref && info->ref->next
8224 148932 : && info->ref->next->type == REF_SUBSTRING;
8225 :
8226 147873 : subref_array_target = (is_subref_array (expr)
8227 147873 : && (se->direct_byref
8228 3506 : || se->force_no_tmp
8229 2859 : || expr->ts.type == BT_CHARACTER));
8230 147873 : need_tmp = (gfc_ref_needs_temporary_p (expr->ref)
8231 147873 : && !subref_array_target);
8232 :
8233 147873 : if (se->force_tmp)
8234 : need_tmp = 1;
8235 147690 : else if (se->force_no_tmp)
8236 : need_tmp = 0;
8237 :
8238 141027 : if (need_tmp)
8239 : full = 0;
8240 147588 : else if (is_explicit_coarray (expr))
8241 : full = 0;
8242 146711 : else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
8243 : {
8244 : /* Create a new descriptor if the array doesn't have one. */
8245 : full = 0;
8246 : }
8247 96207 : else if (info->ref->u.ar.type == AR_FULL || se->descriptor_only)
8248 : full = 1;
8249 8190 : else if (se->direct_byref)
8250 : full = 0;
8251 7827 : else if (info->ref->u.ar.dimen == 0 && !info->ref->next)
8252 : full = 1;
8253 7617 : else if (info->ref->u.ar.type == AR_SECTION && se->want_pointer)
8254 : full = 0;
8255 : else
8256 3675 : full = gfc_full_array_ref_p (info->ref, NULL);
8257 :
8258 : /* A subobject of the array elements is described by a new descriptor,
8259 : whose element type is that of the subobject and whose span is the
8260 : element size of the array. */
8261 147873 : if (subref_array_target && !se->direct_byref
8262 1386 : && info->ref && info->ref->next)
8263 : full = 0;
8264 :
8265 236031 : if (full && !transposed_dims (ss))
8266 : {
8267 88435 : if (se->direct_byref && !se->byref_noassign)
8268 : {
8269 1108 : struct lang_type *lhs_ls
8270 1108 : = TYPE_LANG_SPECIFIC (TREE_TYPE (se->expr)),
8271 1108 : *rhs_ls = TYPE_LANG_SPECIFIC (TREE_TYPE (desc));
8272 : /* When only the array_kind differs, do a view_convert. */
8273 1516 : tmp = lhs_ls && rhs_ls && lhs_ls->rank == rhs_ls->rank
8274 1108 : && lhs_ls->akind != rhs_ls->akind
8275 1516 : ? build1 (VIEW_CONVERT_EXPR, TREE_TYPE (se->expr), desc)
8276 : : desc;
8277 : /* Copy the descriptor for pointer assignments. */
8278 1108 : gfc_add_modify (&se->pre, se->expr, tmp);
8279 :
8280 : /* Add any offsets from subreferences. */
8281 1108 : gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
8282 : subref_array_target, expr);
8283 :
8284 : /* ....and set the span field. */
8285 1108 : if (ss_info->expr->ts.type == BT_CHARACTER)
8286 147 : tmp = gfc_conv_descriptor_span_get (desc);
8287 : else
8288 961 : tmp = gfc_get_array_span (desc, expr);
8289 1108 : gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp);
8290 1108 : }
8291 87327 : else if (se->want_pointer)
8292 : {
8293 : /* We pass full arrays directly. This means that pointers and
8294 : allocatable arrays should also work. */
8295 14224 : se->expr = gfc_build_addr_expr (NULL_TREE, desc);
8296 : }
8297 : else
8298 : {
8299 73103 : se->expr = desc;
8300 : }
8301 :
8302 88435 : if (expr->ts.type == BT_CHARACTER && !deferred_array_component)
8303 8516 : se->string_length = gfc_get_expr_charlen (expr);
8304 : /* The ss_info string length is returned set to the value of the
8305 : hidden string length component. */
8306 79650 : else if (deferred_array_component)
8307 269 : se->string_length = ss_info->string_length;
8308 :
8309 88435 : se->class_container = ss_info->class_container;
8310 :
8311 88435 : gfc_free_ss_chain (ss);
8312 177026 : return;
8313 : }
8314 : break;
8315 :
8316 5141 : case EXPR_FUNCTION:
8317 : /* A transformational function return value will be a temporary
8318 : array descriptor. We still need to go through the scalarizer
8319 : to create the descriptor. Elemental functions are handled as
8320 : arbitrary expressions, i.e. copy to a temporary. */
8321 :
8322 5141 : if (se->direct_byref)
8323 : {
8324 156 : gcc_assert (ss_type == GFC_SS_FUNCTION && ss_expr == expr);
8325 :
8326 : /* For pointer assignments pass the descriptor directly. */
8327 156 : if (se->ss == NULL)
8328 156 : se->ss = ss;
8329 : else
8330 0 : gcc_assert (se->ss == ss);
8331 :
8332 156 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
8333 156 : gfc_conv_expr (se, expr);
8334 :
8335 156 : gfc_free_ss_chain (ss);
8336 156 : return;
8337 : }
8338 :
8339 4985 : if (ss_expr != expr || ss_type != GFC_SS_FUNCTION)
8340 : {
8341 3325 : if (ss_expr != expr)
8342 : /* Elemental function. */
8343 2576 : gcc_assert ((expr->value.function.esym != NULL
8344 : && expr->value.function.esym->attr.elemental)
8345 : || (expr->value.function.isym != NULL
8346 : && expr->value.function.isym->elemental)
8347 : || (gfc_expr_attr (expr).proc_pointer
8348 : && gfc_expr_attr (expr).elemental)
8349 : || gfc_inline_intrinsic_function_p (expr));
8350 :
8351 3325 : need_tmp = 1;
8352 3325 : if (expr->ts.type == BT_CHARACTER
8353 35 : && expr->ts.u.cl->length
8354 29 : && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
8355 13 : get_array_charlen (expr, se);
8356 :
8357 : info = NULL;
8358 : }
8359 : else
8360 : {
8361 : /* Transformational function. */
8362 1660 : info = &ss_info->data.array;
8363 1660 : need_tmp = 0;
8364 : }
8365 : break;
8366 :
8367 10721 : case EXPR_ARRAY:
8368 : /* Constant array constructors don't need a temporary. */
8369 10721 : if (ss_type == GFC_SS_CONSTRUCTOR
8370 10721 : && expr->ts.type != BT_CHARACTER
8371 20183 : && gfc_constant_array_constructor_p (expr->value.constructor))
8372 : {
8373 7410 : need_tmp = 0;
8374 7410 : info = &ss_info->data.array;
8375 : }
8376 : else
8377 : {
8378 : need_tmp = 1;
8379 : info = NULL;
8380 : }
8381 : break;
8382 :
8383 : default:
8384 : /* Something complicated. Copy it into a temporary. */
8385 : need_tmp = 1;
8386 : info = NULL;
8387 : break;
8388 : }
8389 :
8390 : /* If we are creating a temporary, we don't need to bother about aliases
8391 : anymore. */
8392 68521 : if (need_tmp)
8393 7679 : se->force_tmp = 0;
8394 :
8395 75902 : gfc_init_loopinfo (&loop);
8396 :
8397 : /* Associate the SS with the loop. */
8398 75902 : gfc_add_ss_to_loop (&loop, ss);
8399 :
8400 : /* Tell the scalarizer not to bother creating loop variables, etc. */
8401 75902 : if (!need_tmp)
8402 68223 : loop.array_parameter = 1;
8403 : else
8404 : /* The right-hand side of a pointer assignment mustn't use a temporary. */
8405 7679 : gcc_assert (!se->direct_byref);
8406 :
8407 : /* Do we need bounds checking or not? */
8408 75902 : ss->no_bounds_check = expr->no_bounds_check;
8409 :
8410 : /* Setup the scalarizing loops and bounds. */
8411 75902 : gfc_conv_ss_startstride (&loop);
8412 :
8413 : /* Add bounds-checking for elemental dimensions. */
8414 75902 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !expr->no_bounds_check)
8415 6688 : array_bound_check_elemental (&outermost_loop (&loop)->pre, ss, expr);
8416 :
8417 75902 : if (need_tmp)
8418 : {
8419 7679 : if (expr->ts.type == BT_CHARACTER
8420 1499 : && (!expr->ts.u.cl->backend_decl || expr->expr_type == EXPR_ARRAY))
8421 1391 : get_array_charlen (expr, se);
8422 :
8423 : /* Tell the scalarizer to make a temporary. */
8424 7679 : loop.temp_ss = gfc_get_temp_ss (gfc_typenode_for_spec (&expr->ts),
8425 7679 : ((expr->ts.type == BT_CHARACTER)
8426 1499 : ? expr->ts.u.cl->backend_decl
8427 : : NULL),
8428 : loop.dimen);
8429 :
8430 7679 : se->string_length = loop.temp_ss->info->string_length;
8431 7679 : gcc_assert (loop.temp_ss->dimen == loop.dimen);
8432 7679 : gfc_add_ss_to_loop (&loop, loop.temp_ss);
8433 : }
8434 :
8435 75902 : gfc_conv_loop_setup (&loop, & expr->where);
8436 :
8437 75902 : if (need_tmp)
8438 : {
8439 : /* Copy into a temporary and pass that. We don't need to copy the data
8440 : back because expressions and vector subscripts must be INTENT_IN. */
8441 : /* TODO: Optimize passing function return values. */
8442 7679 : gfc_se lse;
8443 7679 : gfc_se rse;
8444 7679 : bool deep_copy;
8445 :
8446 : /* Start the copying loops. */
8447 7679 : gfc_mark_ss_chain_used (loop.temp_ss, 1);
8448 7679 : gfc_mark_ss_chain_used (ss, 1);
8449 7679 : gfc_start_scalarized_body (&loop, &block);
8450 :
8451 : /* Copy each data element. */
8452 7679 : gfc_init_se (&lse, NULL);
8453 7679 : gfc_copy_loopinfo_to_se (&lse, &loop);
8454 7679 : gfc_init_se (&rse, NULL);
8455 7679 : gfc_copy_loopinfo_to_se (&rse, &loop);
8456 :
8457 7679 : lse.ss = loop.temp_ss;
8458 7679 : rse.ss = ss;
8459 :
8460 7679 : gfc_conv_tmp_array_ref (&lse);
8461 7679 : if (expr->ts.type == BT_CHARACTER)
8462 : {
8463 1499 : gfc_conv_expr (&rse, expr);
8464 1499 : if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
8465 1069 : rse.expr = build_fold_indirect_ref_loc (input_location,
8466 : rse.expr);
8467 : }
8468 : else
8469 6180 : gfc_conv_expr_val (&rse, expr);
8470 :
8471 7679 : gfc_add_block_to_block (&block, &rse.pre);
8472 7679 : gfc_add_block_to_block (&block, &lse.pre);
8473 :
8474 7679 : lse.string_length = rse.string_length;
8475 :
8476 15358 : deep_copy = !se->data_not_needed
8477 7679 : && (expr->expr_type == EXPR_VARIABLE
8478 7141 : || expr->expr_type == EXPR_ARRAY);
8479 7679 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts,
8480 : deep_copy, false);
8481 7679 : gfc_add_expr_to_block (&block, tmp);
8482 :
8483 : /* Finish the copying loops. */
8484 7679 : gfc_trans_scalarizing_loops (&loop, &block);
8485 :
8486 7679 : desc = loop.temp_ss->info->data.array.descriptor;
8487 : }
8488 69883 : else if (expr->expr_type == EXPR_FUNCTION && !transposed_dims (ss))
8489 : {
8490 1647 : desc = info->descriptor;
8491 1647 : se->string_length = ss_info->string_length;
8492 : }
8493 : else
8494 : {
8495 : /* We pass sections without copying to a temporary. Make a new
8496 : descriptor and point it at the section we want. The loop variable
8497 : limits will be the limits of the section.
8498 : A function may decide to repack the array to speed up access, but
8499 : we're not bothered about that here. */
8500 66576 : int dim, ndim, codim;
8501 66576 : tree parm;
8502 66576 : tree parmtype;
8503 66576 : tree dtype;
8504 66576 : tree stride;
8505 66576 : tree from;
8506 66576 : tree to;
8507 66576 : tree base;
8508 66576 : tree offset;
8509 :
8510 66576 : ndim = info->ref ? info->ref->u.ar.dimen : ss->dimen;
8511 :
8512 66576 : if (se->want_coarray)
8513 : {
8514 751 : gfc_array_ref *ar = &info->ref->u.ar;
8515 :
8516 751 : codim = expr->corank;
8517 1579 : for (n = 0; n < codim - 1; n++)
8518 : {
8519 : /* Make sure we are not lost somehow. */
8520 828 : gcc_assert (ar->dimen_type[n + ndim] == DIMEN_THIS_IMAGE);
8521 :
8522 : /* Make sure the call to gfc_conv_section_startstride won't
8523 : generate unnecessary code to calculate stride. */
8524 828 : gcc_assert (ar->stride[n + ndim] == NULL);
8525 :
8526 828 : gfc_conv_section_startstride (&loop.pre, ss, n + ndim);
8527 828 : loop.from[n + loop.dimen] = info->start[n + ndim];
8528 828 : loop.to[n + loop.dimen] = info->end[n + ndim];
8529 : }
8530 :
8531 751 : gcc_assert (n == codim - 1);
8532 751 : evaluate_bound (&loop.pre, info->start, ar->start,
8533 : info->descriptor, n + ndim, true,
8534 751 : ar->as->type == AS_DEFERRED, true);
8535 751 : loop.from[n + loop.dimen] = info->start[n + ndim];
8536 : }
8537 : else
8538 : codim = 0;
8539 :
8540 : /* Set the string_length for a character array. */
8541 66576 : if (expr->ts.type == BT_CHARACTER)
8542 : {
8543 11578 : if (deferred_array_component && !substr)
8544 37 : se->string_length = ss_info->string_length;
8545 : else
8546 11541 : se->string_length = gfc_get_expr_charlen (expr);
8547 :
8548 11578 : if (VAR_P (se->string_length)
8549 990 : && expr->ts.u.cl->backend_decl == se->string_length)
8550 984 : tmp = ss_info->string_length;
8551 : else
8552 : tmp = se->string_length;
8553 :
8554 11578 : if (expr->ts.deferred && expr->ts.u.cl->backend_decl
8555 205 : && VAR_P (expr->ts.u.cl->backend_decl))
8556 150 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, tmp);
8557 : else
8558 11428 : expr->ts.u.cl->backend_decl = tmp;
8559 : }
8560 :
8561 : /* If we have an array section, are assigning or passing an array
8562 : section argument make sure that the lower bound is 1. References
8563 : to the full array should otherwise keep the original bounds. */
8564 66576 : if (!info->ref || info->ref->u.ar.type != AR_FULL)
8565 85034 : for (dim = 0; dim < loop.dimen; dim++)
8566 51605 : if (!integer_onep (loop.from[dim]))
8567 : {
8568 27955 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
8569 : gfc_array_index_type, gfc_index_one_node,
8570 : loop.from[dim]);
8571 27955 : loop.to[dim] = fold_build2_loc (input_location, PLUS_EXPR,
8572 : gfc_array_index_type,
8573 : loop.to[dim], tmp);
8574 27955 : loop.from[dim] = gfc_index_one_node;
8575 : }
8576 :
8577 66576 : desc = info->descriptor;
8578 66576 : if (se->direct_byref && !se->byref_noassign)
8579 : {
8580 : /* For pointer assignments we fill in the destination. */
8581 2832 : parm = se->expr;
8582 2832 : parmtype = TREE_TYPE (parm);
8583 : }
8584 : else
8585 : {
8586 : /* Otherwise make a new one. The element type is that of the
8587 : subobject for a subreference of the array. */
8588 63744 : if (expr->ts.type == BT_CHARACTER
8589 52860 : || (subref_array_target && !se->direct_byref))
8590 : {
8591 11052 : gfc_typespec *ts = &expr->ts;
8592 11052 : if (ts->type == BT_CLASS
8593 6 : && ts->u.derived->attr.is_class)
8594 6 : ts = &ts->u.derived->components->ts;
8595 11052 : parmtype = gfc_typenode_for_spec (ts);
8596 11052 : }
8597 : else
8598 52692 : parmtype = gfc_get_element_type (TREE_TYPE (desc));
8599 :
8600 63744 : parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, codim,
8601 : loop.from, loop.to, 0,
8602 : GFC_ARRAY_UNKNOWN, false);
8603 63744 : parm = gfc_create_var (parmtype, "parm");
8604 :
8605 : /* When expression is a class object, then add the class' handle to
8606 : the parm_decl. */
8607 63744 : if (expr->ts.type == BT_CLASS && expr->expr_type == EXPR_VARIABLE)
8608 : {
8609 1292 : gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr);
8610 1292 : gfc_se classse;
8611 :
8612 : /* class_expr can be NULL, when no _class ref is in expr.
8613 : We must not fix this here with a gfc_fix_class_ref (). */
8614 1292 : if (class_expr)
8615 : {
8616 1282 : gfc_init_se (&classse, NULL);
8617 1282 : gfc_conv_expr (&classse, class_expr);
8618 1282 : gfc_free_expr (class_expr);
8619 :
8620 1282 : gcc_assert (classse.pre.head == NULL_TREE
8621 : && classse.post.head == NULL_TREE);
8622 1282 : gfc_allocate_lang_decl (parm);
8623 1282 : GFC_DECL_SAVED_DESCRIPTOR (parm) = classse.expr;
8624 : }
8625 : }
8626 : }
8627 :
8628 66576 : if (expr->ts.type == BT_CHARACTER
8629 66576 : && VAR_P (TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (parm)))))
8630 : {
8631 0 : tree elem_len = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (parm)));
8632 0 : gfc_add_modify (&loop.pre, elem_len,
8633 0 : fold_convert (TREE_TYPE (elem_len),
8634 : gfc_get_array_span (desc, expr)));
8635 : }
8636 :
8637 : /* Set the span field. */
8638 66576 : tmp = NULL_TREE;
8639 66576 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
8640 7804 : tmp = gfc_conv_descriptor_span_get (desc);
8641 : else
8642 58772 : tmp = gfc_get_array_span (desc, expr);
8643 66576 : if (tmp)
8644 66508 : gfc_conv_descriptor_span_set (&loop.pre, parm, tmp);
8645 :
8646 : /* The following can be somewhat confusing. We have two
8647 : descriptors, a new one and the original array.
8648 : {parm, parmtype, dim} refer to the new one.
8649 : {desc, type, n, loop} refer to the original, which maybe
8650 : a descriptorless array.
8651 : The bounds of the scalarization are the bounds of the section.
8652 : We don't have to worry about numeric overflows when calculating
8653 : the offsets because all elements are within the array data. */
8654 :
8655 : /* Set the dtype. */
8656 66576 : if (se->unlimited_polymorphic)
8657 715 : dtype = gfc_get_dtype (TREE_TYPE (desc), &loop.dimen);
8658 65861 : else if (expr->ts.type == BT_ASSUMED)
8659 : {
8660 127 : tree tmp2 = desc;
8661 127 : if (DECL_LANG_SPECIFIC (tmp2) && GFC_DECL_SAVED_DESCRIPTOR (tmp2))
8662 127 : tmp2 = GFC_DECL_SAVED_DESCRIPTOR (tmp2);
8663 127 : if (POINTER_TYPE_P (TREE_TYPE (tmp2)))
8664 127 : tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
8665 127 : dtype = gfc_conv_descriptor_dtype_get (tmp2);
8666 : }
8667 : else
8668 65734 : dtype = gfc_get_dtype (parmtype);
8669 66576 : gfc_conv_descriptor_dtype_set (&loop.pre, parm, dtype);
8670 :
8671 : /* The 1st element in the section. */
8672 66576 : base = gfc_index_zero_node;
8673 66576 : if (expr->ts.type == BT_CHARACTER && expr->rank == 0 && codim)
8674 6 : base = gfc_index_one_node;
8675 :
8676 : /* The offset from the 1st element in the section. */
8677 66576 : offset = gfc_index_zero_node;
8678 :
8679 170523 : for (n = 0; n < ndim; n++)
8680 : {
8681 103947 : stride = gfc_conv_array_stride (desc, n);
8682 :
8683 : /* Work out the 1st element in the section. */
8684 103947 : if (info->ref
8685 96079 : && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
8686 : {
8687 1329 : gcc_assert (info->subscript[n]
8688 : && info->subscript[n]->info->type == GFC_SS_SCALAR);
8689 1329 : start = info->subscript[n]->info->data.scalar.value;
8690 : }
8691 : else
8692 : {
8693 : /* Evaluate and remember the start of the section. */
8694 102618 : start = info->start[n];
8695 102618 : stride = gfc_evaluate_now (stride, &loop.pre);
8696 : }
8697 :
8698 103947 : tmp = gfc_conv_array_lbound (desc, n);
8699 103947 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
8700 : start, tmp);
8701 103947 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
8702 : tmp, stride);
8703 103947 : base = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
8704 : base, tmp);
8705 :
8706 103947 : if (info->ref
8707 96079 : && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
8708 : {
8709 : /* For elemental dimensions, we only need the 1st
8710 : element in the section. */
8711 1329 : continue;
8712 : }
8713 :
8714 : /* Vector subscripts need copying and are handled elsewhere. */
8715 102618 : if (info->ref)
8716 94750 : gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
8717 :
8718 : /* look for the corresponding scalarizer dimension: dim. */
8719 153617 : for (dim = 0; dim < ndim; dim++)
8720 153617 : if (ss->dim[dim] == n)
8721 : break;
8722 :
8723 : /* loop exited early: the DIM being looked for has been found. */
8724 102618 : gcc_assert (dim < ndim);
8725 :
8726 : /* Set the new lower bound. */
8727 102618 : from = loop.from[dim];
8728 102618 : to = loop.to[dim];
8729 :
8730 102618 : gfc_conv_descriptor_lbound_set (&loop.pre, parm,
8731 : gfc_rank_cst[dim], from);
8732 :
8733 : /* Set the new upper bound. */
8734 102618 : gfc_conv_descriptor_ubound_set (&loop.pre, parm,
8735 : gfc_rank_cst[dim], to);
8736 :
8737 : /* Multiply the stride by the section stride to get the
8738 : total stride. */
8739 102618 : stride = fold_build2_loc (input_location, MULT_EXPR,
8740 : gfc_array_index_type,
8741 : stride, info->stride[n]);
8742 :
8743 102618 : tmp = fold_build2_loc (input_location, MULT_EXPR,
8744 102618 : TREE_TYPE (offset), stride, from);
8745 102618 : offset = fold_build2_loc (input_location, MINUS_EXPR,
8746 102618 : TREE_TYPE (offset), offset, tmp);
8747 :
8748 : /* Store the new stride. */
8749 102618 : gfc_conv_descriptor_stride_set (&loop.pre, parm,
8750 : gfc_rank_cst[dim], stride);
8751 : }
8752 :
8753 : /* For deferred-length character we need to take the dynamic length
8754 : into account for the dataptr offset. */
8755 66576 : if (expr->ts.type == BT_CHARACTER
8756 11578 : && expr->ts.deferred
8757 211 : && expr->ts.u.cl->backend_decl
8758 211 : && VAR_P (expr->ts.u.cl->backend_decl))
8759 : {
8760 150 : tree base_type = TREE_TYPE (base);
8761 150 : base = fold_build2_loc (input_location, MULT_EXPR, base_type, base,
8762 : fold_convert (base_type,
8763 : expr->ts.u.cl->backend_decl));
8764 : }
8765 :
8766 68155 : for (n = loop.dimen; n < loop.dimen + codim; n++)
8767 : {
8768 1579 : from = loop.from[n];
8769 1579 : to = loop.to[n];
8770 1579 : gfc_conv_descriptor_lbound_set (&loop.pre, parm,
8771 : gfc_rank_cst[n], from);
8772 1579 : if (n < loop.dimen + codim - 1)
8773 828 : gfc_conv_descriptor_ubound_set (&loop.pre, parm,
8774 : gfc_rank_cst[n], to);
8775 : }
8776 :
8777 66576 : if (se->data_not_needed)
8778 6287 : gfc_conv_descriptor_data_set (&loop.pre, parm,
8779 : gfc_index_zero_node);
8780 : else
8781 : /* Point the data pointer at the 1st element in the section. */
8782 60289 : gfc_get_dataptr_offset (&loop.pre, parm, desc, base,
8783 : subref_array_target, expr);
8784 :
8785 66576 : gfc_conv_descriptor_offset_set (&loop.pre, parm, offset);
8786 :
8787 66576 : if (flag_coarray == GFC_FCOARRAY_LIB && expr->corank)
8788 : {
8789 448 : tmp = INDIRECT_REF_P (desc) ? TREE_OPERAND (desc, 0) : desc;
8790 448 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
8791 : {
8792 24 : tmp = gfc_conv_descriptor_token (tmp);
8793 : }
8794 424 : else if (DECL_P (tmp) && DECL_LANG_SPECIFIC (tmp)
8795 504 : && GFC_DECL_TOKEN (tmp) != NULL_TREE)
8796 64 : tmp = GFC_DECL_TOKEN (tmp);
8797 : else
8798 : {
8799 360 : tmp = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (tmp));
8800 : }
8801 :
8802 448 : gfc_conv_descriptor_token_set (&loop.pre, parm, tmp);
8803 : }
8804 : desc = parm;
8805 : }
8806 :
8807 : /* For class arrays add the class tree into the saved descriptor to
8808 : enable getting of _vptr and the like. */
8809 75902 : if (expr->expr_type == EXPR_VARIABLE && VAR_P (desc)
8810 58408 : && IS_CLASS_ARRAY (expr->symtree->n.sym))
8811 : {
8812 1228 : gfc_allocate_lang_decl (desc);
8813 1228 : GFC_DECL_SAVED_DESCRIPTOR (desc) =
8814 1228 : DECL_LANG_SPECIFIC (expr->symtree->n.sym->backend_decl) ?
8815 1130 : GFC_DECL_SAVED_DESCRIPTOR (expr->symtree->n.sym->backend_decl)
8816 : : expr->symtree->n.sym->backend_decl;
8817 : }
8818 74674 : else if (expr->expr_type == EXPR_ARRAY && VAR_P (desc)
8819 10721 : && IS_CLASS_ARRAY (expr))
8820 : {
8821 12 : tree vtype;
8822 12 : gfc_allocate_lang_decl (desc);
8823 12 : tmp = gfc_create_var (expr->ts.u.derived->backend_decl, "class");
8824 12 : GFC_DECL_SAVED_DESCRIPTOR (desc) = tmp;
8825 12 : vtype = gfc_class_vptr_get (tmp);
8826 12 : gfc_add_modify (&se->pre, vtype,
8827 12 : gfc_build_addr_expr (TREE_TYPE (vtype),
8828 12 : gfc_find_vtab (&expr->ts)->backend_decl));
8829 : }
8830 75902 : if (!se->direct_byref || se->byref_noassign)
8831 : {
8832 : /* Get a pointer to the new descriptor. */
8833 73070 : if (se->want_pointer)
8834 40934 : se->expr = gfc_build_addr_expr (NULL_TREE, desc);
8835 : else
8836 32136 : se->expr = desc;
8837 : }
8838 :
8839 75902 : gfc_add_block_to_block (&se->pre, &loop.pre);
8840 75902 : gfc_add_block_to_block (&se->post, &loop.post);
8841 :
8842 : /* Cleanup the scalarizer. */
8843 75902 : gfc_cleanup_loop (&loop);
8844 : }
8845 :
8846 :
8847 : /* Calculate the array size (number of elements); if dim != NULL_TREE,
8848 : return size for that dim (dim=0..rank-1; only for GFC_DESCRIPTOR_TYPE_P).
8849 : If !expr && descriptor array, the rank is taken from the descriptor. */
8850 : tree
8851 15946 : gfc_tree_array_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree dim)
8852 : {
8853 15946 : if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
8854 : {
8855 40 : gcc_assert (dim == NULL_TREE);
8856 40 : return GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
8857 : }
8858 15906 : tree size, tmp, rank = NULL_TREE, cond = NULL_TREE;
8859 15906 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
8860 15906 : enum gfc_array_kind akind = GFC_TYPE_ARRAY_AKIND (TREE_TYPE (desc));
8861 15906 : if (expr == NULL || expr->rank < 0)
8862 3701 : rank = gfc_conv_descriptor_rank_get (desc);
8863 : else
8864 12205 : rank = gfc_rank_cst[expr->rank];
8865 :
8866 15906 : if (dim || (expr && expr->rank == 1))
8867 : {
8868 4799 : if (dim)
8869 9439 : dim = fold_convert_loc (input_location, gfc_array_dim_rank_type, dim);
8870 : else
8871 4799 : dim = gfc_rank_cst[0];
8872 14238 : tree ubound = gfc_conv_descriptor_ubound_get (desc, dim);
8873 14238 : tree lbound = gfc_conv_descriptor_lbound_get (desc, dim);
8874 :
8875 14238 : size = fold_build2_loc (input_location, MINUS_EXPR,
8876 : gfc_array_index_type, ubound, lbound);
8877 14238 : size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
8878 : size, gfc_index_one_node);
8879 : /* if (!allocatable && !pointer && assumed rank)
8880 : size = (idx == rank && ubound[rank-1] == -1 ? -1 : size;
8881 : else
8882 : size = max (0, size); */
8883 14238 : size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
8884 : size, gfc_index_zero_node);
8885 14238 : if (akind == GFC_ARRAY_ASSUMED_RANK_CONT
8886 14238 : || akind == GFC_ARRAY_ASSUMED_RANK)
8887 : {
8888 3002 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
8889 : gfc_array_dim_rank_type, rank,
8890 : gfc_rank_cst[1]);
8891 3002 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
8892 : dim, tmp);
8893 3002 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
8894 : gfc_conv_descriptor_ubound_get (desc, dim),
8895 : build_int_cst (gfc_array_index_type, -1));
8896 3002 : cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
8897 : cond, tmp);
8898 3002 : tmp = build_int_cst (gfc_array_index_type, -1);
8899 3002 : size = build3_loc (input_location, COND_EXPR, gfc_array_index_type,
8900 : cond, tmp, size);
8901 : }
8902 : return size;
8903 : }
8904 :
8905 : /* size = 1. */
8906 1668 : size = gfc_create_var (gfc_array_index_type, "size");
8907 1668 : gfc_add_modify (block, size, build_int_cst (TREE_TYPE (size), 1));
8908 1668 : tree extent = gfc_create_var (gfc_array_index_type, "extent");
8909 :
8910 1668 : stmtblock_t cond_block, loop_body;
8911 1668 : gfc_init_block (&cond_block);
8912 1668 : gfc_init_block (&loop_body);
8913 :
8914 : /* Loop: for (i = 0; i < rank; ++i). */
8915 1668 : tree idx = gfc_create_var (gfc_array_dim_rank_type, "idx");
8916 : /* Loop body. */
8917 : /* #if (assumed-rank + !allocatable && !pointer)
8918 : if (idx + 1 == rank && dim[idx].ubound == -1)
8919 : extent = -1;
8920 : else
8921 : #endif
8922 : extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1
8923 : if (extent < 0)
8924 : extent = 0
8925 : size *= extent. */
8926 1668 : cond = NULL_TREE;
8927 1668 : if (akind == GFC_ARRAY_ASSUMED_RANK_CONT || akind == GFC_ARRAY_ASSUMED_RANK)
8928 : {
8929 471 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
8930 : gfc_array_dim_rank_type, idx, gfc_rank_cst[1]);
8931 471 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
8932 : tmp, rank);
8933 471 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
8934 : gfc_conv_descriptor_ubound_get (desc, idx),
8935 : build_int_cst (gfc_array_index_type, -1));
8936 471 : cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
8937 : cond, tmp);
8938 : }
8939 1668 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8940 : gfc_conv_descriptor_ubound_get (desc, idx),
8941 : gfc_conv_descriptor_lbound_get (desc, idx));
8942 1668 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
8943 : tmp, gfc_index_one_node);
8944 1668 : gfc_add_modify (&cond_block, extent, tmp);
8945 1668 : tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
8946 : extent, gfc_index_zero_node);
8947 1668 : tmp = build3_v (COND_EXPR, tmp,
8948 : fold_build2_loc (input_location, MODIFY_EXPR,
8949 : gfc_array_index_type,
8950 : extent, gfc_index_zero_node),
8951 : build_empty_stmt (input_location));
8952 1668 : gfc_add_expr_to_block (&cond_block, tmp);
8953 1668 : tmp = gfc_finish_block (&cond_block);
8954 1668 : if (cond)
8955 471 : tmp = build3_v (COND_EXPR, cond,
8956 : fold_build2_loc (input_location, MODIFY_EXPR,
8957 : gfc_array_index_type, extent,
8958 : build_int_cst (gfc_array_index_type, -1)),
8959 : tmp);
8960 1668 : gfc_add_expr_to_block (&loop_body, tmp);
8961 : /* size *= extent. */
8962 1668 : gfc_add_modify (&loop_body, size,
8963 : fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
8964 : size, extent));
8965 : /* Generate loop. */
8966 3336 : gfc_simple_for_loop (block, idx, build_int_cst (TREE_TYPE (idx), 0), rank, LT_EXPR,
8967 1668 : build_int_cst (TREE_TYPE (idx), 1),
8968 : gfc_finish_block (&loop_body));
8969 1668 : return size;
8970 : }
8971 :
8972 : /* Helper function for gfc_conv_array_parameter if array size needs to be
8973 : computed. */
8974 :
8975 : static void
8976 152 : array_parameter_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree *size)
8977 : {
8978 152 : tree elem;
8979 152 : *size = gfc_tree_array_size (block, desc, expr, NULL);
8980 152 : elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
8981 152 : *size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
8982 : *size, fold_convert (gfc_array_index_type, elem));
8983 152 : }
8984 :
8985 : /* Helper function - return true if the argument is a pointer. */
8986 :
8987 : static bool
8988 720 : is_pointer (gfc_expr *e)
8989 : {
8990 720 : gfc_symbol *sym;
8991 :
8992 720 : if (e->expr_type != EXPR_VARIABLE || e->symtree == NULL)
8993 : return false;
8994 :
8995 720 : sym = e->symtree->n.sym;
8996 720 : if (sym == NULL)
8997 : return false;
8998 :
8999 720 : return sym->attr.pointer || sym->attr.proc_pointer;
9000 : }
9001 :
9002 : /* Assumed-rank actual argument: the caller only allocates storage for dtype
9003 : rank dimensions. Copying GFC_MAX_DIMENSIONS dim entries would read past the
9004 : physical end of the descriptor. Copy the header fields explicitly and use a
9005 : runtime-sized memcpy for the dim[] entries. */
9006 : void
9007 78 : gfc_resize_assumed_rank_dim_field (gfc_se *se, stmtblock_t *block, tree desc)
9008 : {
9009 78 : tree rank, dim_field, dim_size, copy_size, dst_ptr, src_ptr;
9010 :
9011 78 : gfc_conv_descriptor_data_set (block, desc,
9012 : gfc_conv_descriptor_data_get (se->expr));
9013 78 : gfc_conv_descriptor_offset_set (block, desc,
9014 : gfc_conv_descriptor_offset_get (se->expr));
9015 78 : gfc_conv_descriptor_dtype_set (block, desc,
9016 : gfc_conv_descriptor_dtype_get (se->expr));
9017 78 : rank = fold_convert (size_type_node, gfc_conv_descriptor_rank_get (se->expr));
9018 78 : dim_field = gfc_get_descriptor_dimension (se->expr);
9019 78 : dim_size = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (dim_field)));
9020 78 : copy_size = fold_build2_loc (input_location, MULT_EXPR,
9021 : size_type_node, rank, dim_size);
9022 78 : dst_ptr = gfc_build_addr_expr (pvoid_type_node,
9023 : gfc_get_descriptor_dimension (desc));
9024 78 : src_ptr = gfc_build_addr_expr (pvoid_type_node, dim_field);
9025 78 : gfc_add_expr_to_block (block, build_call_expr_loc (input_location,
9026 : builtin_decl_explicit (BUILT_IN_MEMCPY),
9027 : 3, dst_ptr, src_ptr, copy_size));
9028 78 : }
9029 :
9030 : /* Convert an array for passing as an actual parameter. */
9031 :
9032 : void
9033 67080 : gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr, bool g77,
9034 : const gfc_symbol *fsym, const char *proc_name,
9035 : tree *size, tree *lbshift, tree *packed)
9036 : {
9037 67080 : tree ptr;
9038 67080 : tree desc;
9039 67080 : tree tmp = NULL_TREE;
9040 67080 : tree stmt;
9041 67080 : tree parent = DECL_CONTEXT (current_function_decl);
9042 67080 : tree ctree;
9043 67080 : tree pack_attr = NULL_TREE; /* Set when packing class arrays. */
9044 67080 : bool full_array_var;
9045 67080 : bool this_array_result;
9046 67080 : bool contiguous;
9047 67080 : bool no_pack;
9048 67080 : bool array_constructor;
9049 67080 : bool good_allocatable;
9050 67080 : bool ultimate_ptr_comp;
9051 67080 : bool ultimate_alloc_comp;
9052 67080 : bool readonly;
9053 67080 : gfc_symbol *sym;
9054 67080 : stmtblock_t block;
9055 67080 : gfc_ref *ref;
9056 :
9057 67080 : ultimate_ptr_comp = false;
9058 67080 : ultimate_alloc_comp = false;
9059 :
9060 68015 : for (ref = expr->ref; ref; ref = ref->next)
9061 : {
9062 56378 : if (ref->next == NULL)
9063 : break;
9064 :
9065 935 : if (ref->type == REF_COMPONENT)
9066 : {
9067 741 : ultimate_ptr_comp = ref->u.c.component->attr.pointer;
9068 741 : ultimate_alloc_comp = ref->u.c.component->attr.allocatable;
9069 : }
9070 : }
9071 :
9072 67080 : full_array_var = false;
9073 67080 : contiguous = false;
9074 :
9075 67080 : if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp)
9076 55312 : full_array_var = gfc_full_array_ref_p (ref, &contiguous);
9077 :
9078 55312 : sym = full_array_var ? expr->symtree->n.sym : NULL;
9079 :
9080 : /* The symbol should have an array specification. */
9081 63934 : gcc_assert (!sym || sym->as || ref->u.ar.as);
9082 :
9083 67080 : if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
9084 : {
9085 708 : if (expr->ts.u.cl->length_from_typespec && expr->ts.u.cl->length)
9086 : {
9087 : /* The constructor has an explicit character type-spec length
9088 : so convert it directly. */
9089 126 : gfc_se cse;
9090 126 : gfc_init_se (&cse, NULL);
9091 126 : gfc_conv_expr_type (&cse, expr->ts.u.cl->length,
9092 : gfc_charlen_type_node);
9093 126 : gfc_add_block_to_block (&se->pre, &cse.pre);
9094 126 : tmp = cse.expr;
9095 126 : }
9096 : else
9097 582 : get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
9098 :
9099 708 : expr->ts.u.cl->backend_decl = tmp;
9100 708 : se->string_length = tmp;
9101 : }
9102 :
9103 : /* Is this the result of the enclosing procedure? */
9104 67080 : this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
9105 58 : if (this_array_result
9106 58 : && (sym->backend_decl != current_function_decl)
9107 0 : && (sym->backend_decl != parent))
9108 67080 : this_array_result = false;
9109 :
9110 : /* Passing an optional dummy argument as actual to an optional dummy? */
9111 67080 : bool pass_optional;
9112 67080 : pass_optional = fsym && fsym->attr.optional && sym && sym->attr.optional;
9113 :
9114 : /* Passing address of the array if it is not pointer or assumed-shape. */
9115 67080 : if (full_array_var && g77 && !this_array_result
9116 16348 : && sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
9117 : {
9118 12613 : tmp = gfc_get_symbol_decl (sym);
9119 :
9120 12613 : if (sym->ts.type == BT_CHARACTER)
9121 2821 : se->string_length = sym->ts.u.cl->backend_decl;
9122 :
9123 12613 : if (!sym->attr.pointer
9124 12122 : && sym->as
9125 12122 : && sym->as->type != AS_ASSUMED_SHAPE
9126 11871 : && sym->as->type != AS_DEFERRED
9127 10375 : && sym->as->type != AS_ASSUMED_RANK
9128 10299 : && !sym->attr.allocatable)
9129 : {
9130 : /* Some variables are declared directly, others are declared as
9131 : pointers and allocated on the heap. */
9132 9793 : if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
9133 2518 : se->expr = tmp;
9134 : else
9135 7275 : se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
9136 9793 : if (size)
9137 40 : array_parameter_size (&se->pre, tmp, expr, size);
9138 17252 : return;
9139 : }
9140 :
9141 2820 : if (sym->attr.allocatable)
9142 : {
9143 1882 : if (sym->attr.dummy || sym->attr.result)
9144 : {
9145 1176 : gfc_conv_expr_descriptor (se, expr);
9146 1176 : tmp = se->expr;
9147 : }
9148 1882 : if (size)
9149 14 : array_parameter_size (&se->pre, tmp, expr, size);
9150 1882 : se->expr = gfc_conv_array_data (tmp);
9151 1882 : if (pass_optional)
9152 : {
9153 18 : tree cond = gfc_conv_expr_present (sym);
9154 36 : se->expr = build3_loc (input_location, COND_EXPR,
9155 18 : TREE_TYPE (se->expr), cond, se->expr,
9156 18 : fold_convert (TREE_TYPE (se->expr),
9157 : null_pointer_node));
9158 : }
9159 : return;
9160 : }
9161 : }
9162 :
9163 : /* A convenient reduction in scope. */
9164 55405 : contiguous = g77 && !this_array_result && contiguous;
9165 :
9166 : /* There is no need to pack and unpack the array, if it is contiguous
9167 : and not a deferred- or assumed-shape array, or if it is simply
9168 : contiguous. */
9169 55405 : no_pack = false;
9170 : // clang-format off
9171 55405 : if (sym)
9172 : {
9173 40620 : symbol_attribute *attr = &(IS_CLASS_ARRAY (sym)
9174 : ? CLASS_DATA (sym)->attr : sym->attr);
9175 40620 : gfc_array_spec *as = IS_CLASS_ARRAY (sym)
9176 40620 : ? CLASS_DATA (sym)->as : sym->as;
9177 40620 : no_pack = (as
9178 40329 : && !attr->pointer
9179 37045 : && as->type != AS_DEFERRED
9180 27321 : && as->type != AS_ASSUMED_RANK
9181 64642 : && as->type != AS_ASSUMED_SHAPE);
9182 : }
9183 55405 : if (ref && ref->u.ar.as)
9184 43658 : no_pack = no_pack
9185 43658 : || (ref->u.ar.as->type != AS_DEFERRED
9186 : && ref->u.ar.as->type != AS_ASSUMED_RANK
9187 : && ref->u.ar.as->type != AS_ASSUMED_SHAPE);
9188 110810 : no_pack = contiguous
9189 55405 : && (no_pack || gfc_is_simply_contiguous (expr, false, true));
9190 : // clang-format on
9191 :
9192 : /* If we have an EXPR_OP or a function returning an explicit-shaped
9193 : or allocatable array, an array temporary will be generated which
9194 : does not need to be packed / unpacked if passed to an
9195 : explicit-shape dummy array. */
9196 :
9197 55405 : if (g77)
9198 : {
9199 6622 : if (expr->expr_type == EXPR_OP)
9200 : no_pack = 1;
9201 6545 : else if (expr->expr_type == EXPR_FUNCTION && expr->value.function.esym)
9202 : {
9203 34 : gfc_symbol *result = expr->value.function.esym->result;
9204 34 : if (result->attr.dimension
9205 34 : && (result->as->type == AS_EXPLICIT
9206 7 : || result->attr.allocatable
9207 0 : || result->attr.contiguous))
9208 55405 : no_pack = 1;
9209 : }
9210 : }
9211 :
9212 : /* Array constructors are always contiguous and do not need packing. */
9213 55405 : array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY;
9214 :
9215 : /* Same is true of contiguous sections from allocatable variables. */
9216 110810 : good_allocatable = contiguous
9217 4810 : && expr->symtree
9218 60215 : && expr->symtree->n.sym->attr.allocatable;
9219 :
9220 : /* Or ultimate allocatable components. */
9221 55405 : ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
9222 :
9223 55405 : if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp)
9224 : {
9225 5190 : gfc_conv_expr_descriptor (se, expr);
9226 : /* Deallocate the allocatable components of structures that are
9227 : not variable. */
9228 5190 : if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
9229 3638 : && expr->ts.u.derived->attr.alloc_comp
9230 2179 : && expr->expr_type != EXPR_VARIABLE)
9231 : {
9232 2 : tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, se->expr, expr->rank);
9233 :
9234 : /* The components shall be deallocated before their containing entity. */
9235 2 : gfc_prepend_expr_to_block (&se->post, tmp);
9236 : }
9237 5190 : if (expr->ts.type == BT_CHARACTER && expr->expr_type != EXPR_FUNCTION)
9238 309 : se->string_length = expr->ts.u.cl->backend_decl;
9239 5190 : if (size)
9240 68 : array_parameter_size (&se->pre, se->expr, expr, size);
9241 5190 : se->expr = gfc_conv_array_data (se->expr);
9242 5190 : return;
9243 : }
9244 :
9245 50215 : if (fsym && fsym->ts.type == BT_CLASS)
9246 : {
9247 1266 : gcc_assert (se->expr);
9248 : ctree = se->expr;
9249 : }
9250 : else
9251 : ctree = NULL_TREE;
9252 :
9253 50215 : if (this_array_result)
9254 : {
9255 : /* Result of the enclosing function. */
9256 58 : gfc_conv_expr_descriptor (se, expr);
9257 58 : if (size)
9258 0 : array_parameter_size (&se->pre, se->expr, expr, size);
9259 58 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
9260 :
9261 18 : if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
9262 76 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
9263 18 : se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location,
9264 : se->expr));
9265 :
9266 : return;
9267 : }
9268 : else
9269 : {
9270 : /* Every other type of array. */
9271 50157 : se->want_pointer = (ctree) ? 0 : 1;
9272 50157 : se->want_coarray = expr->corank;
9273 50157 : gfc_conv_expr_descriptor (se, expr);
9274 :
9275 50157 : if (size)
9276 30 : array_parameter_size (&se->pre,
9277 : build_fold_indirect_ref_loc (input_location,
9278 : se->expr),
9279 : expr, size);
9280 50157 : if (ctree)
9281 : {
9282 1266 : stmtblock_t block;
9283 :
9284 1266 : gfc_init_block (&block);
9285 1266 : if (lbshift && *lbshift)
9286 : {
9287 : /* Apply a shift of the lbound when supplied. */
9288 98 : for (int dim = 0; dim < expr->rank; ++dim)
9289 49 : gfc_conv_shift_descriptor_lbound (&block, se->expr, dim,
9290 : *lbshift);
9291 : }
9292 1266 : tmp = gfc_class_data_get (ctree);
9293 1266 : if (expr->rank > 1 && CLASS_DATA (fsym)->as->rank != expr->rank
9294 84 : && CLASS_DATA (fsym)->as->type == AS_EXPLICIT && !no_pack)
9295 : {
9296 36 : tree arr = gfc_create_var (TREE_TYPE (tmp), "parm");
9297 36 : gfc_conv_descriptor_data_set (&block, arr,
9298 : gfc_conv_descriptor_data_get (
9299 : se->expr));
9300 36 : gfc_conv_descriptor_lbound_set (&block, arr, gfc_index_zero_node,
9301 : gfc_index_zero_node);
9302 36 : gfc_conv_descriptor_ubound_set (
9303 : &block, arr, gfc_index_zero_node,
9304 : gfc_conv_descriptor_size (se->expr, expr->rank));
9305 36 : gfc_conv_descriptor_stride_set (
9306 : &block, arr, gfc_index_zero_node,
9307 : gfc_conv_descriptor_stride_get (se->expr, gfc_index_zero_node));
9308 36 : tree dtype_val = gfc_conv_descriptor_dtype_get (se->expr);
9309 36 : gfc_conv_descriptor_dtype_set (&block, arr, dtype_val);
9310 36 : gfc_conv_descriptor_rank_set (&block, arr, 1);
9311 36 : gfc_conv_descriptor_span_set (&block, arr,
9312 : gfc_conv_descriptor_span_get (arr));
9313 36 : gfc_conv_descriptor_offset_set (&block, arr, gfc_index_zero_node);
9314 36 : se->expr = arr;
9315 : }
9316 1266 : if (expr->rank == -1)
9317 78 : gfc_resize_assumed_rank_dim_field (se, &block, tmp);
9318 1188 : else if (CLASS_DATA (fsym)->as->rank == -1)
9319 397 : gfc_class_array_data_assign (&block, tmp, se->expr, false);
9320 : else
9321 791 : gfc_class_array_data_assign (&block, tmp, se->expr, true);
9322 :
9323 : /* Handle optional. */
9324 1266 : if (fsym && fsym->attr.optional && sym && sym->attr.optional)
9325 348 : tmp = build3_v (COND_EXPR, gfc_conv_expr_present (sym),
9326 : gfc_finish_block (&block),
9327 : build_empty_stmt (input_location));
9328 : else
9329 918 : tmp = gfc_finish_block (&block);
9330 :
9331 1266 : gfc_add_expr_to_block (&se->pre, tmp);
9332 : }
9333 48891 : else if (pass_optional && full_array_var && sym->as && sym->as->rank != 0)
9334 : {
9335 : /* Perform calculation of bounds and strides of optional array dummy
9336 : only if the argument is present. */
9337 219 : tmp = build3_v (COND_EXPR, gfc_conv_expr_present (sym),
9338 : gfc_finish_block (&se->pre),
9339 : build_empty_stmt (input_location));
9340 219 : gfc_add_expr_to_block (&se->pre, tmp);
9341 : }
9342 : }
9343 :
9344 : /* Deallocate the allocatable components of structures that are
9345 : not variable, for descriptorless arguments.
9346 : Arguments with a descriptor are handled in gfc_conv_procedure_call. */
9347 50157 : if (g77 && (expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
9348 78 : && expr->ts.u.derived->attr.alloc_comp
9349 18 : && expr->expr_type != EXPR_VARIABLE)
9350 : {
9351 0 : tmp = build_fold_indirect_ref_loc (input_location, se->expr);
9352 0 : tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank);
9353 :
9354 : /* The components shall be deallocated before their containing entity. */
9355 0 : gfc_prepend_expr_to_block (&se->post, tmp);
9356 : }
9357 :
9358 48743 : if (g77 || (fsym && fsym->attr.contiguous
9359 1580 : && !gfc_is_simply_contiguous (expr, false, true)))
9360 : {
9361 1594 : tree origptr = NULL_TREE, packedptr = NULL_TREE;
9362 :
9363 1594 : desc = se->expr;
9364 :
9365 : /* For contiguous arrays, save the original value of the descriptor. */
9366 1594 : if (!g77 && !ctree)
9367 : {
9368 84 : origptr = gfc_create_var (pvoid_type_node, "origptr");
9369 84 : tmp = build_fold_indirect_ref_loc (input_location, desc);
9370 84 : tmp = gfc_conv_array_data (tmp);
9371 168 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
9372 84 : TREE_TYPE (origptr), origptr,
9373 84 : fold_convert (TREE_TYPE (origptr), tmp));
9374 84 : gfc_add_expr_to_block (&se->pre, tmp);
9375 : }
9376 :
9377 : /* Repack the array. */
9378 1594 : if (warn_array_temporaries)
9379 : {
9380 28 : if (fsym)
9381 18 : gfc_warning (OPT_Warray_temporaries,
9382 : "Creating array temporary at %L for argument %qs",
9383 18 : &expr->where, fsym->name);
9384 : else
9385 10 : gfc_warning (OPT_Warray_temporaries,
9386 : "Creating array temporary at %L", &expr->where);
9387 : }
9388 :
9389 : /* When optimizing, we can use gfc_conv_subref_array_arg for
9390 : making the packing and unpacking operation visible to the
9391 : optimizers. */
9392 :
9393 1414 : if (g77 && flag_inline_arg_packing && expr->expr_type == EXPR_VARIABLE
9394 720 : && !is_pointer (expr) && ! gfc_has_dimen_vector_ref (expr)
9395 350 : && !(expr->symtree->n.sym->as
9396 332 : && expr->symtree->n.sym->as->type == AS_ASSUMED_RANK)
9397 1944 : && (fsym == NULL || fsym->ts.type != BT_ASSUMED))
9398 : {
9399 329 : gfc_conv_subref_array_arg (se, expr, g77,
9400 153 : fsym ? fsym->attr.intent : INTENT_INOUT,
9401 : false, fsym, proc_name, sym, true);
9402 329 : return;
9403 : }
9404 :
9405 1265 : if (ctree)
9406 : {
9407 96 : packedptr
9408 96 : = gfc_build_addr_expr (NULL_TREE, gfc_create_var (TREE_TYPE (ctree),
9409 : "packed"));
9410 96 : if (fsym)
9411 : {
9412 96 : int pack_mask = 0;
9413 :
9414 : /* Set bit 0 to the mask, when this is an unlimited_poly
9415 : class. */
9416 96 : if (CLASS_DATA (fsym)->ts.u.derived->attr.unlimited_polymorphic)
9417 36 : pack_mask = 1 << 0;
9418 96 : pack_attr = build_int_cst (integer_type_node, pack_mask);
9419 : }
9420 : else
9421 0 : pack_attr = integer_zero_node;
9422 :
9423 96 : gfc_add_expr_to_block (
9424 : &se->pre,
9425 : build_call_expr_loc (input_location, gfor_fndecl_in_pack_class, 4,
9426 : packedptr,
9427 : gfc_build_addr_expr (NULL_TREE, ctree),
9428 96 : size_in_bytes (TREE_TYPE (ctree)), pack_attr));
9429 96 : ptr = gfc_conv_array_data (gfc_class_data_get (packedptr));
9430 96 : se->expr = packedptr;
9431 96 : if (packed)
9432 96 : *packed = packedptr;
9433 : }
9434 : else
9435 : {
9436 1169 : ptr = build_call_expr_loc (input_location, gfor_fndecl_in_pack, 1,
9437 : desc);
9438 :
9439 1169 : if (fsym && fsym->attr.optional && sym && sym->attr.optional)
9440 : {
9441 11 : tmp = gfc_conv_expr_present (sym);
9442 22 : ptr = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
9443 11 : tmp, fold_convert (TREE_TYPE (se->expr), ptr),
9444 11 : fold_convert (TREE_TYPE (se->expr),
9445 : null_pointer_node));
9446 : }
9447 :
9448 1169 : ptr = gfc_evaluate_now (ptr, &se->pre);
9449 : }
9450 :
9451 : /* Use the packed data for the actual argument, except for contiguous arrays,
9452 : where the descriptor's data component is set. */
9453 1265 : if (g77)
9454 1085 : se->expr = ptr;
9455 : else
9456 : {
9457 180 : tmp = build_fold_indirect_ref_loc (input_location, desc);
9458 :
9459 180 : if (!ctree)
9460 : {
9461 : /* The original descriptor may have transposed dims so we
9462 : can't reuse it directly; we have to create a new one. */
9463 84 : tree old_field;
9464 84 : tree old_desc = tmp;
9465 84 : tree new_desc = gfc_create_var (TREE_TYPE (old_desc), "arg_desc");
9466 :
9467 84 : old_field = gfc_conv_descriptor_dtype_get (old_desc);
9468 84 : gfc_conv_descriptor_dtype_set (&se->pre, new_desc, old_field);
9469 :
9470 84 : if (expr->rank == -1)
9471 : {
9472 12 : tree idx = gfc_create_var (gfc_array_dim_rank_type, "idx");
9473 12 : tree stride = gfc_create_var (gfc_array_index_type, "stride");
9474 12 : stmtblock_t loop_body;
9475 :
9476 12 : gfc_conv_descriptor_offset_set (&se->pre, new_desc,
9477 : gfc_index_zero_node);
9478 12 : gfc_conv_descriptor_span_set (&se->pre, new_desc,
9479 : gfc_conv_descriptor_span_get
9480 : (old_desc));
9481 12 : gfc_add_modify (&se->pre, stride, gfc_index_one_node);
9482 :
9483 12 : gfc_init_block (&loop_body);
9484 :
9485 12 : old_field = gfc_conv_descriptor_lbound_get (old_desc, idx);
9486 12 : gfc_conv_descriptor_lbound_set (&loop_body, new_desc, idx,
9487 : old_field);
9488 :
9489 12 : old_field = gfc_conv_descriptor_ubound_get (old_desc, idx);
9490 12 : gfc_conv_descriptor_ubound_set (&loop_body, new_desc, idx,
9491 : old_field);
9492 :
9493 12 : gfc_conv_descriptor_stride_set (&loop_body, new_desc, idx,
9494 : stride);
9495 :
9496 12 : tree offset = fold_build2_loc (input_location, MULT_EXPR,
9497 : gfc_array_index_type, stride,
9498 : gfc_conv_descriptor_lbound_get
9499 : (new_desc, idx));
9500 12 : offset = fold_build2_loc (input_location, MINUS_EXPR,
9501 : gfc_array_index_type,
9502 : gfc_conv_descriptor_offset_get
9503 : (new_desc), offset);
9504 12 : gfc_conv_descriptor_offset_set (&loop_body, new_desc, offset);
9505 :
9506 12 : tree extent = gfc_conv_array_extent_dim
9507 12 : (gfc_conv_descriptor_lbound_get (new_desc, idx),
9508 : gfc_conv_descriptor_ubound_get (new_desc, idx),
9509 : NULL);
9510 12 : extent = fold_build2_loc (input_location, MULT_EXPR,
9511 : gfc_array_index_type, stride,
9512 : extent);
9513 12 : gfc_add_modify (&loop_body, stride, extent);
9514 :
9515 36 : gfc_simple_for_loop (&se->pre, idx,
9516 12 : build_int_cst (TREE_TYPE (idx), 0),
9517 : gfc_conv_descriptor_rank_get (old_desc),
9518 : LT_EXPR,
9519 12 : build_int_cst (TREE_TYPE (idx), 1),
9520 : gfc_finish_block (&loop_body));
9521 : }
9522 : else
9523 : {
9524 72 : tree offset = gfc_index_zero_node;
9525 :
9526 72 : tree stride = gfc_index_one_node;
9527 :
9528 102 : for (int i = 0; i < expr->rank; i++)
9529 : {
9530 102 : tree dim = gfc_rank_cst[i];
9531 :
9532 102 : tree lbound = gfc_conv_descriptor_lbound_get (old_desc,
9533 : dim);
9534 102 : lbound = gfc_evaluate_now (lbound, &se->pre);
9535 102 : gfc_conv_descriptor_lbound_set (&se->pre, new_desc, dim,
9536 : lbound);
9537 :
9538 102 : tree ubound = gfc_conv_descriptor_ubound_get (old_desc,
9539 : dim);
9540 102 : ubound = gfc_evaluate_now (ubound, &se->pre);
9541 102 : gfc_conv_descriptor_ubound_set (&se->pre, new_desc, dim,
9542 : ubound);
9543 :
9544 102 : gfc_conv_descriptor_stride_set (&se->pre, new_desc, dim,
9545 : stride);
9546 :
9547 102 : tree tmp = fold_build2_loc (input_location, MULT_EXPR,
9548 : gfc_array_index_type,
9549 : stride, lbound);
9550 102 : offset = fold_build2_loc (input_location, MINUS_EXPR,
9551 : gfc_array_index_type,
9552 : offset, tmp);
9553 102 : offset = gfc_evaluate_now (offset, &se->pre);
9554 :
9555 : /* Now calculate the stride for next dimension, unless the
9556 : current dimension is the last one. */
9557 102 : if (i == expr->rank - 1)
9558 : break;
9559 :
9560 30 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
9561 : gfc_array_index_type,
9562 : lbound, gfc_index_one_node);
9563 30 : tree extent = fold_build2_loc (input_location, MINUS_EXPR,
9564 : gfc_array_index_type,
9565 : ubound, tmp);
9566 30 : stride = fold_build2_loc (input_location, MULT_EXPR,
9567 : gfc_array_index_type,
9568 : stride, extent);
9569 30 : stride = gfc_evaluate_now (stride, &se->pre);
9570 : }
9571 :
9572 72 : gfc_conv_descriptor_offset_set (&se->pre, new_desc, offset);
9573 : }
9574 :
9575 84 : if (flag_coarray == GFC_FCOARRAY_LIB
9576 0 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (old_desc))
9577 84 : && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (old_desc))
9578 : == GFC_ARRAY_ALLOCATABLE)
9579 : {
9580 0 : old_field = gfc_conv_descriptor_token (old_desc);
9581 0 : gfc_conv_descriptor_token_set (&se->pre, new_desc,
9582 : old_field);
9583 : }
9584 :
9585 84 : gfc_conv_descriptor_data_set (&se->pre, new_desc, ptr);
9586 84 : se->expr = gfc_build_addr_expr (NULL_TREE, new_desc);
9587 : }
9588 : }
9589 :
9590 1265 : if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
9591 : {
9592 8 : char * msg;
9593 :
9594 8 : if (fsym && proc_name)
9595 8 : msg = xasprintf ("An array temporary was created for argument "
9596 8 : "'%s' of procedure '%s'", fsym->name, proc_name);
9597 : else
9598 0 : msg = xasprintf ("An array temporary was created");
9599 :
9600 8 : tmp = build_fold_indirect_ref_loc (input_location,
9601 : desc);
9602 8 : tmp = gfc_conv_array_data (tmp);
9603 8 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9604 8 : fold_convert (TREE_TYPE (tmp), ptr), tmp);
9605 :
9606 8 : if (pass_optional)
9607 6 : tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
9608 : logical_type_node,
9609 : gfc_conv_expr_present (sym), tmp);
9610 :
9611 8 : gfc_trans_runtime_check (false, true, tmp, &se->pre,
9612 : &expr->where, msg);
9613 8 : free (msg);
9614 : }
9615 :
9616 1265 : gfc_start_block (&block);
9617 :
9618 : /* Copy the data back. If input expr is read-only, e.g. a PARAMETER
9619 : array, copying back modified values is undefined behavior. */
9620 2530 : readonly = (expr->expr_type == EXPR_VARIABLE
9621 860 : && expr->symtree
9622 2125 : && expr->symtree->n.sym->attr.flavor == FL_PARAMETER);
9623 :
9624 1265 : if ((fsym == NULL || fsym->attr.intent != INTENT_IN) && !readonly)
9625 : {
9626 1108 : if (ctree)
9627 : {
9628 66 : tmp = gfc_build_addr_expr (NULL_TREE, ctree);
9629 66 : tmp = build_call_expr_loc (input_location,
9630 : gfor_fndecl_in_unpack_class, 4, tmp,
9631 : packedptr,
9632 66 : size_in_bytes (TREE_TYPE (ctree)),
9633 : pack_attr);
9634 : }
9635 : else
9636 1042 : tmp = build_call_expr_loc (input_location, gfor_fndecl_in_unpack, 2,
9637 : desc, ptr);
9638 1108 : gfc_add_expr_to_block (&block, tmp);
9639 : }
9640 157 : else if (ctree && fsym->attr.intent == INTENT_IN)
9641 : {
9642 : /* Need to free the memory for class arrays, that got packed. */
9643 30 : gfc_add_expr_to_block (&block, gfc_call_free (ptr));
9644 : }
9645 :
9646 : /* Free the temporary. */
9647 1138 : if (!ctree)
9648 1169 : gfc_add_expr_to_block (&block, gfc_call_free (ptr));
9649 :
9650 1265 : stmt = gfc_finish_block (&block);
9651 :
9652 1265 : gfc_init_block (&block);
9653 : /* Only if it was repacked. This code needs to be executed before the
9654 : loop cleanup code. */
9655 1265 : tmp = (ctree) ? desc : build_fold_indirect_ref_loc (input_location, desc);
9656 1265 : tmp = gfc_conv_array_data (tmp);
9657 1265 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9658 1265 : fold_convert (TREE_TYPE (tmp), ptr), tmp);
9659 :
9660 1265 : if (pass_optional)
9661 11 : tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
9662 : logical_type_node,
9663 : gfc_conv_expr_present (sym), tmp);
9664 :
9665 1265 : tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
9666 :
9667 1265 : gfc_add_expr_to_block (&block, tmp);
9668 1265 : gfc_add_block_to_block (&block, &se->post);
9669 :
9670 1265 : gfc_init_block (&se->post);
9671 :
9672 : /* Reset the descriptor pointer. */
9673 1265 : if (!g77 && !ctree)
9674 : {
9675 84 : tmp = build_fold_indirect_ref_loc (input_location, desc);
9676 84 : gfc_conv_descriptor_data_set (&se->post, tmp, origptr);
9677 : }
9678 :
9679 1265 : gfc_add_block_to_block (&se->post, &block);
9680 : }
9681 : }
9682 :
9683 :
9684 : /* This helper function calculates the size in words of a full array. */
9685 :
9686 : tree
9687 21642 : gfc_full_array_size (stmtblock_t *block, tree decl, int rank)
9688 : {
9689 21642 : tree idx;
9690 21642 : tree nelems;
9691 21642 : tree tmp;
9692 21642 : if (rank < 0)
9693 0 : idx = gfc_conv_descriptor_rank_get (decl);
9694 : else
9695 21642 : idx = gfc_rank_cst[rank - 1];
9696 21642 : nelems = gfc_conv_descriptor_ubound_get (decl, idx);
9697 21642 : tmp = gfc_conv_descriptor_lbound_get (decl, idx);
9698 21642 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
9699 : nelems, tmp);
9700 21642 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
9701 : tmp, gfc_index_one_node);
9702 21642 : tmp = gfc_evaluate_now (tmp, block);
9703 :
9704 21642 : nelems = gfc_conv_descriptor_stride_get (decl, idx);
9705 21642 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9706 : nelems, tmp);
9707 21642 : return gfc_evaluate_now (tmp, block);
9708 : }
9709 :
9710 :
9711 : /* Allocate dest to the same size as src, and copy src -> dest.
9712 : If no_malloc is set, only the copy is done. */
9713 :
9714 : static tree
9715 10685 : duplicate_allocatable (tree dest, tree src, tree type, int rank,
9716 : bool no_malloc, bool no_memcpy, tree str_sz,
9717 : tree add_when_allocated)
9718 : {
9719 10685 : tree tmp;
9720 10685 : tree eltype;
9721 10685 : tree size;
9722 10685 : tree nelems;
9723 10685 : tree null_cond;
9724 10685 : tree null_data;
9725 10685 : stmtblock_t block;
9726 :
9727 : /* If the source is null, set the destination to null. Then,
9728 : allocate memory to the destination. */
9729 10685 : gfc_init_block (&block);
9730 :
9731 10685 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
9732 : {
9733 2610 : gfc_add_modify (&block, dest, fold_convert (type, null_pointer_node));
9734 2610 : null_data = gfc_finish_block (&block);
9735 :
9736 2610 : gfc_init_block (&block);
9737 2610 : eltype = TREE_TYPE (type);
9738 2610 : if (str_sz != NULL_TREE)
9739 : size = str_sz;
9740 : else
9741 2230 : size = TYPE_SIZE_UNIT (eltype);
9742 :
9743 2610 : if (!no_malloc)
9744 : {
9745 2610 : tmp = gfc_call_malloc (&block, type, size);
9746 2610 : gfc_add_modify (&block, dest, fold_convert (type, tmp));
9747 : }
9748 :
9749 2610 : if (!no_memcpy)
9750 : {
9751 1815 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
9752 1815 : tmp = build_call_expr_loc (input_location, tmp, 3, dest, src,
9753 : fold_convert (size_type_node, size));
9754 1815 : gfc_add_expr_to_block (&block, tmp);
9755 : }
9756 : }
9757 : else
9758 : {
9759 8075 : gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
9760 8075 : null_data = gfc_finish_block (&block);
9761 :
9762 8075 : gfc_init_block (&block);
9763 8075 : if (rank)
9764 8060 : nelems = gfc_full_array_size (&block, src, rank);
9765 : else
9766 15 : nelems = gfc_index_one_node;
9767 :
9768 : /* If type is not the array type, then it is the element type. */
9769 8075 : if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type))
9770 8045 : eltype = gfc_get_element_type (type);
9771 : else
9772 : eltype = type;
9773 :
9774 8075 : if (str_sz != NULL_TREE)
9775 43 : tmp = fold_convert (gfc_array_index_type, str_sz);
9776 : else
9777 8032 : tmp = fold_convert (gfc_array_index_type,
9778 : TYPE_SIZE_UNIT (eltype));
9779 :
9780 8075 : tmp = gfc_evaluate_now (tmp, &block);
9781 8075 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9782 : nelems, tmp);
9783 8075 : if (!no_malloc)
9784 : {
9785 8007 : tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src));
9786 8007 : tmp = gfc_call_malloc (&block, tmp, size);
9787 8007 : gfc_conv_descriptor_data_set (&block, dest, tmp);
9788 : }
9789 :
9790 : /* We know the temporary and the value will be the same length,
9791 : so can use memcpy. */
9792 8075 : if (!no_memcpy)
9793 : {
9794 6714 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
9795 6714 : tmp = build_call_expr_loc (input_location, tmp, 3,
9796 : gfc_conv_descriptor_data_get (dest),
9797 : gfc_conv_descriptor_data_get (src),
9798 : fold_convert (size_type_node, size));
9799 6714 : gfc_add_expr_to_block (&block, tmp);
9800 : }
9801 : }
9802 :
9803 10685 : gfc_add_expr_to_block (&block, add_when_allocated);
9804 10685 : tmp = gfc_finish_block (&block);
9805 :
9806 : /* Null the destination if the source is null; otherwise do
9807 : the allocate and copy. */
9808 10685 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src)))
9809 : null_cond = src;
9810 : else
9811 8075 : null_cond = gfc_conv_descriptor_data_get (src);
9812 :
9813 10685 : null_cond = convert (pvoid_type_node, null_cond);
9814 10685 : null_cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9815 : null_cond, null_pointer_node);
9816 10685 : return build3_v (COND_EXPR, null_cond, tmp, null_data);
9817 : }
9818 :
9819 :
9820 : /* Allocate dest to the same size as src, and copy data src -> dest. */
9821 :
9822 : tree
9823 7736 : gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank,
9824 : tree add_when_allocated)
9825 : {
9826 7736 : return duplicate_allocatable (dest, src, type, rank, false, false,
9827 7736 : NULL_TREE, add_when_allocated);
9828 : }
9829 :
9830 :
9831 : /* Copy data src -> dest. */
9832 :
9833 : tree
9834 68 : gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
9835 : {
9836 68 : return duplicate_allocatable (dest, src, type, rank, true, false,
9837 68 : NULL_TREE, NULL_TREE);
9838 : }
9839 :
9840 : /* Allocate dest to the same size as src, but don't copy anything. */
9841 :
9842 : tree
9843 2156 : gfc_duplicate_allocatable_nocopy (tree dest, tree src, tree type, int rank)
9844 : {
9845 2156 : return duplicate_allocatable (dest, src, type, rank, false, true,
9846 2156 : NULL_TREE, NULL_TREE);
9847 : }
9848 :
9849 : static tree
9850 62 : duplicate_allocatable_coarray (tree dest, tree dest_tok, tree src, tree type,
9851 : int rank, tree add_when_allocated)
9852 : {
9853 62 : tree tmp;
9854 62 : tree size;
9855 62 : tree nelems;
9856 62 : tree null_cond;
9857 62 : tree null_data;
9858 62 : stmtblock_t block, globalblock;
9859 :
9860 : /* If the source is null, set the destination to null. Then,
9861 : allocate memory to the destination. */
9862 62 : gfc_init_block (&block);
9863 62 : gfc_init_block (&globalblock);
9864 :
9865 62 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
9866 : {
9867 18 : gfc_se se;
9868 18 : symbol_attribute attr;
9869 18 : tree dummy_desc;
9870 :
9871 18 : gfc_init_se (&se, NULL);
9872 18 : gfc_clear_attr (&attr);
9873 18 : attr.allocatable = 1;
9874 18 : dummy_desc = gfc_conv_scalar_to_descriptor (&se, dest, attr);
9875 18 : gfc_add_block_to_block (&globalblock, &se.pre);
9876 18 : size = TYPE_SIZE_UNIT (TREE_TYPE (type));
9877 :
9878 18 : gfc_add_modify (&block, dest, fold_convert (type, null_pointer_node));
9879 18 : gfc_allocate_using_caf_lib (&block, dummy_desc, size,
9880 : gfc_build_addr_expr (NULL_TREE, dest_tok),
9881 : NULL_TREE, NULL_TREE, NULL_TREE,
9882 : GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
9883 18 : gfc_add_modify (&block, dest, gfc_conv_descriptor_data_get (dummy_desc));
9884 18 : null_data = gfc_finish_block (&block);
9885 :
9886 18 : gfc_init_block (&block);
9887 :
9888 18 : gfc_allocate_using_caf_lib (&block, dummy_desc,
9889 : fold_convert (size_type_node, size),
9890 : gfc_build_addr_expr (NULL_TREE, dest_tok),
9891 : NULL_TREE, NULL_TREE, NULL_TREE,
9892 : GFC_CAF_COARRAY_ALLOC);
9893 18 : gfc_add_modify (&block, dest, gfc_conv_descriptor_data_get (dummy_desc));
9894 :
9895 18 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
9896 18 : tmp = build_call_expr_loc (input_location, tmp, 3, dest, src,
9897 : fold_convert (size_type_node, size));
9898 18 : gfc_add_expr_to_block (&block, tmp);
9899 : }
9900 : else
9901 : {
9902 : /* Set the rank or uninitialized memory access may be reported. */
9903 44 : gfc_conv_descriptor_rank_set (&globalblock, dest, rank);
9904 :
9905 44 : if (rank)
9906 44 : nelems = gfc_full_array_size (&globalblock, src, rank);
9907 : else
9908 0 : nelems = integer_one_node;
9909 :
9910 44 : tmp = fold_convert (size_type_node,
9911 : TYPE_SIZE_UNIT (gfc_get_element_type (type)));
9912 44 : size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
9913 : fold_convert (size_type_node, nelems), tmp);
9914 :
9915 44 : gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
9916 44 : gfc_allocate_using_caf_lib (&block, dest, fold_convert (size_type_node,
9917 : size),
9918 : gfc_build_addr_expr (NULL_TREE, dest_tok),
9919 : NULL_TREE, NULL_TREE, NULL_TREE,
9920 : GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
9921 44 : null_data = gfc_finish_block (&block);
9922 :
9923 44 : gfc_init_block (&block);
9924 44 : gfc_allocate_using_caf_lib (&block, dest,
9925 : fold_convert (size_type_node, size),
9926 : gfc_build_addr_expr (NULL_TREE, dest_tok),
9927 : NULL_TREE, NULL_TREE, NULL_TREE,
9928 : GFC_CAF_COARRAY_ALLOC);
9929 :
9930 44 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
9931 44 : tmp = build_call_expr_loc (input_location, tmp, 3,
9932 : gfc_conv_descriptor_data_get (dest),
9933 : gfc_conv_descriptor_data_get (src),
9934 : fold_convert (size_type_node, size));
9935 44 : gfc_add_expr_to_block (&block, tmp);
9936 : }
9937 62 : gfc_add_expr_to_block (&block, add_when_allocated);
9938 62 : tmp = gfc_finish_block (&block);
9939 :
9940 : /* Null the destination if the source is null; otherwise do
9941 : the register and copy. */
9942 62 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src)))
9943 : null_cond = src;
9944 : else
9945 44 : null_cond = gfc_conv_descriptor_data_get (src);
9946 :
9947 62 : null_cond = convert (pvoid_type_node, null_cond);
9948 62 : null_cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9949 : null_cond, null_pointer_node);
9950 62 : gfc_add_expr_to_block (&globalblock, build3_v (COND_EXPR, null_cond, tmp,
9951 : null_data));
9952 62 : return gfc_finish_block (&globalblock);
9953 : }
9954 :
9955 :
9956 : /* Helper function to abstract whether coarray processing is enabled. */
9957 :
9958 : static bool
9959 4155 : caf_enabled (int caf_mode)
9960 : {
9961 4155 : return (caf_mode & GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY)
9962 4155 : == GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY;
9963 : }
9964 :
9965 :
9966 : /* Helper function to abstract whether coarray processing is enabled
9967 : and we are in a derived type coarray. */
9968 :
9969 : static bool
9970 13663 : caf_in_coarray (int caf_mode)
9971 : {
9972 13663 : static const int pat = GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
9973 : | GFC_STRUCTURE_CAF_MODE_IN_COARRAY;
9974 13663 : return (caf_mode & pat) == pat;
9975 : }
9976 :
9977 :
9978 : /* Helper function to abstract whether coarray is to deallocate only. */
9979 :
9980 : bool
9981 421 : gfc_caf_is_dealloc_only (int caf_mode)
9982 : {
9983 421 : return (caf_mode & GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY)
9984 421 : == GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY;
9985 : }
9986 :
9987 :
9988 : /* Recursively traverse an object of derived type, generating code to
9989 : deallocate, nullify or copy allocatable components. This is the work horse
9990 : function for the functions named in this enum. */
9991 :
9992 : enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP,
9993 : COPY_ALLOC_COMP, COPY_ONLY_ALLOC_COMP, REASSIGN_CAF_COMP,
9994 : ALLOCATE_PDT_COMP, DEALLOCATE_PDT_COMP, CHECK_PDT_DUMMY,
9995 : CHECK_PDT_INTENT_OUT_DUMMY, BCAST_ALLOC_COMP};
9996 :
9997 : static gfc_actual_arglist *pdt_param_list;
9998 : static bool generating_copy_helper;
9999 : static hash_set<gfc_symbol *> seen_derived_types;
10000 :
10001 : /* Forward declaration of structure_alloc_comps for wrapper generator. */
10002 : static tree structure_alloc_comps (gfc_symbol *, tree, tree, int, int, int,
10003 : gfc_co_subroutines_args *, bool);
10004 :
10005 : /* Generate a wrapper function that performs element-wise deep copy for
10006 : recursive allocatable array components. This wrapper is passed as a
10007 : function pointer to the runtime helper _gfortran_cfi_deep_copy_array,
10008 : allowing recursion to happen at runtime instead of compile time. */
10009 :
10010 : static tree
10011 487 : get_copy_helper_function_type (void)
10012 : {
10013 487 : static tree fn_type = NULL_TREE;
10014 487 : if (fn_type == NULL_TREE)
10015 99 : fn_type = build_function_type_list (void_type_node,
10016 : pvoid_type_node,
10017 : pvoid_type_node,
10018 : NULL_TREE);
10019 487 : return fn_type;
10020 : }
10021 :
10022 : static tree
10023 1688 : get_copy_helper_pointer_type (void)
10024 : {
10025 1688 : static tree ptr_type = NULL_TREE;
10026 1688 : if (ptr_type == NULL_TREE)
10027 99 : ptr_type = build_pointer_type (get_copy_helper_function_type ());
10028 1688 : return ptr_type;
10029 : }
10030 :
10031 : static tree
10032 388 : generate_element_copy_wrapper (gfc_symbol *der_type, tree comp_type,
10033 : int purpose, int caf_mode)
10034 : {
10035 388 : tree fndecl, fntype, result_decl;
10036 388 : tree dest_parm, src_parm, dest_typed, src_typed;
10037 388 : tree der_type_ptr;
10038 388 : stmtblock_t block;
10039 388 : tree decls;
10040 388 : tree body;
10041 :
10042 388 : fntype = get_copy_helper_function_type ();
10043 :
10044 388 : fndecl = build_decl (input_location, FUNCTION_DECL,
10045 : create_tmp_var_name ("copy_element"),
10046 : fntype);
10047 :
10048 388 : TREE_STATIC (fndecl) = 1;
10049 388 : TREE_USED (fndecl) = 1;
10050 388 : DECL_ARTIFICIAL (fndecl) = 1;
10051 388 : DECL_IGNORED_P (fndecl) = 0;
10052 388 : TREE_PUBLIC (fndecl) = 0;
10053 388 : DECL_UNINLINABLE (fndecl) = 1;
10054 388 : DECL_EXTERNAL (fndecl) = 0;
10055 388 : DECL_CONTEXT (fndecl) = NULL_TREE;
10056 388 : DECL_INITIAL (fndecl) = make_node (BLOCK);
10057 388 : BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
10058 :
10059 388 : result_decl = build_decl (input_location, RESULT_DECL, NULL_TREE,
10060 : void_type_node);
10061 388 : DECL_ARTIFICIAL (result_decl) = 1;
10062 388 : DECL_IGNORED_P (result_decl) = 1;
10063 388 : DECL_CONTEXT (result_decl) = fndecl;
10064 388 : DECL_RESULT (fndecl) = result_decl;
10065 :
10066 388 : dest_parm = build_decl (input_location, PARM_DECL,
10067 : get_identifier ("dest"), pvoid_type_node);
10068 388 : src_parm = build_decl (input_location, PARM_DECL,
10069 : get_identifier ("src"), pvoid_type_node);
10070 :
10071 388 : DECL_ARTIFICIAL (dest_parm) = 1;
10072 388 : DECL_ARTIFICIAL (src_parm) = 1;
10073 388 : DECL_ARG_TYPE (dest_parm) = pvoid_type_node;
10074 388 : DECL_ARG_TYPE (src_parm) = pvoid_type_node;
10075 388 : DECL_CONTEXT (dest_parm) = fndecl;
10076 388 : DECL_CONTEXT (src_parm) = fndecl;
10077 :
10078 388 : DECL_ARGUMENTS (fndecl) = dest_parm;
10079 388 : TREE_CHAIN (dest_parm) = src_parm;
10080 :
10081 388 : push_struct_function (fndecl);
10082 388 : cfun->function_end_locus = input_location;
10083 :
10084 388 : pushlevel ();
10085 388 : gfc_init_block (&block);
10086 :
10087 388 : bool saved_generating = generating_copy_helper;
10088 388 : generating_copy_helper = true;
10089 :
10090 : /* When generating a wrapper, we need a fresh type tracking state to
10091 : avoid inheriting the parent context's seen_derived_types, which would
10092 : cause infinite recursion when the wrapper tries to handle the same
10093 : recursive type. Save elements, clear the set, generate wrapper, then
10094 : restore elements. */
10095 388 : vec<gfc_symbol *> saved_symbols = vNULL;
10096 388 : for (hash_set<gfc_symbol *>::iterator it = seen_derived_types.begin ();
10097 930 : it != seen_derived_types.end (); ++it)
10098 542 : saved_symbols.safe_push (*it);
10099 388 : seen_derived_types.empty ();
10100 :
10101 388 : der_type_ptr = build_pointer_type (comp_type);
10102 388 : dest_typed = fold_convert (der_type_ptr, dest_parm);
10103 388 : src_typed = fold_convert (der_type_ptr, src_parm);
10104 :
10105 388 : dest_typed = build_fold_indirect_ref (dest_typed);
10106 388 : src_typed = build_fold_indirect_ref (src_typed);
10107 :
10108 388 : body = structure_alloc_comps (der_type, src_typed, dest_typed,
10109 : 0, purpose, caf_mode, NULL, false);
10110 388 : gfc_add_expr_to_block (&block, body);
10111 :
10112 : /* Restore saved symbols. */
10113 388 : seen_derived_types.empty ();
10114 930 : for (unsigned i = 0; i < saved_symbols.length (); i++)
10115 542 : seen_derived_types.add (saved_symbols[i]);
10116 388 : saved_symbols.release ();
10117 388 : generating_copy_helper = saved_generating;
10118 :
10119 388 : body = gfc_finish_block (&block);
10120 388 : decls = getdecls ();
10121 :
10122 388 : poplevel (1, 1);
10123 :
10124 776 : DECL_SAVED_TREE (fndecl)
10125 388 : = fold_build3_loc (DECL_SOURCE_LOCATION (fndecl), BIND_EXPR,
10126 388 : void_type_node, decls, body, DECL_INITIAL (fndecl));
10127 :
10128 388 : pop_cfun ();
10129 :
10130 : /* Use finalize_function with no_collect=true to skip the ggc_collect
10131 : call that add_new_function would trigger. This function is called
10132 : during tree lowering of structure_alloc_comps where caller stack
10133 : frames hold locally-computed tree nodes (COMPONENT_REFs etc.) that
10134 : are not yet attached to any GC root. A collection at this point
10135 : would free those nodes and cause segfaults. PR124235. */
10136 388 : cgraph_node::finalize_function (fndecl, true);
10137 :
10138 388 : return build1 (ADDR_EXPR, get_copy_helper_pointer_type (), fndecl);
10139 : }
10140 :
10141 : static tree
10142 27791 : structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
10143 : int rank, int purpose, int caf_mode,
10144 : gfc_co_subroutines_args *args,
10145 : bool no_finalization = false)
10146 : {
10147 27791 : gfc_component *c;
10148 27791 : gfc_loopinfo loop;
10149 27791 : stmtblock_t fnblock;
10150 27791 : stmtblock_t loopbody;
10151 27791 : stmtblock_t tmpblock;
10152 27791 : tree decl_type;
10153 27791 : tree tmp;
10154 27791 : tree comp;
10155 27791 : tree dcmp;
10156 27791 : tree nelems;
10157 27791 : tree index;
10158 27791 : tree var;
10159 27791 : tree cdecl;
10160 27791 : tree ctype;
10161 27791 : tree vref, dref;
10162 27791 : tree null_cond = NULL_TREE;
10163 27791 : tree add_when_allocated;
10164 27791 : tree dealloc_fndecl;
10165 27791 : tree caf_token;
10166 27791 : gfc_symbol *vtab;
10167 27791 : int caf_dereg_mode;
10168 27791 : symbol_attribute *attr;
10169 27791 : bool deallocate_called;
10170 27791 : bool intent_out = purpose == CHECK_PDT_INTENT_OUT_DUMMY;
10171 :
10172 27791 : gfc_init_block (&fnblock);
10173 :
10174 27791 : decl_type = TREE_TYPE (decl);
10175 :
10176 27791 : if ((POINTER_TYPE_P (decl_type))
10177 : || (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == 0))
10178 : {
10179 1722 : decl = build_fold_indirect_ref_loc (input_location, decl);
10180 : /* Deref dest in sync with decl, but only when it is not NULL. */
10181 1722 : if (dest)
10182 124 : dest = build_fold_indirect_ref_loc (input_location, dest);
10183 :
10184 : /* Update the decl_type because it got dereferenced. */
10185 1722 : decl_type = TREE_TYPE (decl);
10186 : }
10187 :
10188 : /* If this is an array of derived types with allocatable components
10189 : build a loop and recursively call this function. */
10190 27791 : if (TREE_CODE (decl_type) == ARRAY_TYPE
10191 27791 : || (GFC_DESCRIPTOR_TYPE_P (decl_type) && rank != 0))
10192 : {
10193 4918 : tmp = gfc_conv_array_data (decl);
10194 4918 : var = build_fold_indirect_ref_loc (input_location, tmp);
10195 :
10196 : /* Get the number of elements - 1 and set the counter. */
10197 4918 : if (GFC_DESCRIPTOR_TYPE_P (decl_type))
10198 : {
10199 : /* Use the descriptor for an allocatable array. Since this
10200 : is a full array reference, we only need the descriptor
10201 : information from dimension = rank. */
10202 3566 : tmp = gfc_full_array_size (&fnblock, decl, rank);
10203 3566 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
10204 : gfc_array_index_type, tmp,
10205 : gfc_index_one_node);
10206 :
10207 3566 : null_cond = gfc_conv_descriptor_data_get (decl);
10208 3566 : null_cond = fold_build2_loc (input_location, NE_EXPR,
10209 : logical_type_node, null_cond,
10210 3566 : build_int_cst (TREE_TYPE (null_cond), 0));
10211 : }
10212 : else
10213 : {
10214 : /* Otherwise use the TYPE_DOMAIN information. */
10215 1352 : tmp = array_type_nelts_minus_one (decl_type);
10216 1352 : tmp = fold_convert (gfc_array_index_type, tmp);
10217 : }
10218 :
10219 : /* Remember that this is, in fact, the no. of elements - 1. */
10220 4918 : nelems = gfc_evaluate_now (tmp, &fnblock);
10221 4918 : index = gfc_create_var (gfc_array_index_type, "S");
10222 :
10223 : /* Build the body of the loop. */
10224 4918 : gfc_init_block (&loopbody);
10225 :
10226 4918 : vref = gfc_build_array_ref (var, index, NULL);
10227 :
10228 4918 : if (purpose == COPY_ALLOC_COMP || purpose == COPY_ONLY_ALLOC_COMP)
10229 : {
10230 1095 : tmp = build_fold_indirect_ref_loc (input_location,
10231 : gfc_conv_array_data (dest));
10232 1095 : dref = gfc_build_array_ref (tmp, index, NULL);
10233 1095 : tmp = structure_alloc_comps (der_type, vref, dref, rank,
10234 : COPY_ALLOC_COMP, caf_mode, args,
10235 : no_finalization);
10236 : }
10237 : else
10238 3823 : tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose,
10239 : caf_mode, args, no_finalization);
10240 :
10241 4918 : gfc_add_expr_to_block (&loopbody, tmp);
10242 :
10243 : /* Build the loop and return. */
10244 4918 : gfc_init_loopinfo (&loop);
10245 4918 : loop.dimen = 1;
10246 4918 : loop.from[0] = gfc_index_zero_node;
10247 4918 : loop.loopvar[0] = index;
10248 4918 : loop.to[0] = nelems;
10249 4918 : gfc_trans_scalarizing_loops (&loop, &loopbody);
10250 4918 : gfc_add_block_to_block (&fnblock, &loop.pre);
10251 :
10252 4918 : tmp = gfc_finish_block (&fnblock);
10253 : /* When copying allocateable components, the above implements the
10254 : deep copy. Nevertheless is a deep copy only allowed, when the current
10255 : component is allocated, for which code will be generated in
10256 : gfc_duplicate_allocatable (), where the deep copy code is just added
10257 : into the if's body, by adding tmp (the deep copy code) as last
10258 : argument to gfc_duplicate_allocatable (). */
10259 4918 : if (purpose == COPY_ALLOC_COMP && caf_mode == 0
10260 4918 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
10261 816 : tmp = gfc_duplicate_allocatable (dest, decl, decl_type, rank,
10262 : tmp);
10263 4102 : else if (null_cond != NULL_TREE)
10264 2750 : tmp = build3_v (COND_EXPR, null_cond, tmp,
10265 : build_empty_stmt (input_location));
10266 :
10267 4918 : return tmp;
10268 : }
10269 :
10270 22873 : if (purpose == DEALLOCATE_ALLOC_COMP && der_type->attr.pdt_type)
10271 : {
10272 923 : tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
10273 : DEALLOCATE_PDT_COMP, 0, args,
10274 : no_finalization);
10275 923 : gfc_add_expr_to_block (&fnblock, tmp);
10276 : }
10277 21950 : else if (purpose == ALLOCATE_PDT_COMP && der_type->attr.alloc_comp)
10278 : {
10279 130 : tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
10280 : NULLIFY_ALLOC_COMP, 0, args,
10281 : no_finalization);
10282 130 : gfc_add_expr_to_block (&fnblock, tmp);
10283 : }
10284 :
10285 : /* Still having a descriptor array of rank == 0 here, indicates an
10286 : allocatable coarrays. Dereference it correctly. */
10287 22873 : if (GFC_DESCRIPTOR_TYPE_P (decl_type))
10288 : {
10289 23 : decl = build_fold_indirect_ref (gfc_conv_array_data (decl));
10290 : }
10291 : /* Otherwise, act on the components or recursively call self to
10292 : act on a chain of components. */
10293 22873 : seen_derived_types.add (der_type);
10294 67245 : for (c = der_type->components; c; c = c->next)
10295 : {
10296 44372 : bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED
10297 44372 : || c->ts.type == BT_CLASS)
10298 44372 : && c->ts.u.derived->attr.alloc_comp;
10299 44372 : bool same_type
10300 : = (c->ts.type == BT_DERIVED
10301 10425 : && seen_derived_types.contains (c->ts.u.derived))
10302 51835 : || (c->ts.type == BT_CLASS
10303 2398 : && seen_derived_types.contains (CLASS_DATA (c)->ts.u.derived));
10304 44372 : bool inside_wrapper = generating_copy_helper;
10305 :
10306 44372 : bool is_pdt_type = IS_PDT (c);
10307 44372 : tree strlen = NULL_TREE;
10308 :
10309 44372 : cdecl = c->backend_decl;
10310 44372 : ctype = TREE_TYPE (cdecl);
10311 :
10312 44372 : switch (purpose)
10313 : {
10314 :
10315 3 : case BCAST_ALLOC_COMP:
10316 :
10317 3 : tree ubound;
10318 3 : tree cdesc;
10319 3 : stmtblock_t derived_type_block;
10320 :
10321 3 : gfc_init_block (&tmpblock);
10322 :
10323 3 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10324 : decl, cdecl, NULL_TREE);
10325 :
10326 : /* Shortcut to get the attributes of the component. */
10327 3 : if (c->ts.type == BT_CLASS)
10328 : {
10329 0 : attr = &CLASS_DATA (c)->attr;
10330 0 : if (attr->class_pointer)
10331 0 : continue;
10332 : }
10333 : else
10334 : {
10335 3 : attr = &c->attr;
10336 3 : if (attr->pointer)
10337 0 : continue;
10338 : }
10339 :
10340 : /* Do not broadcast a caf_token. These are local to the image. */
10341 3 : if (attr->caf_token)
10342 1 : continue;
10343 :
10344 2 : add_when_allocated = NULL_TREE;
10345 2 : if (cmp_has_alloc_comps
10346 0 : && !c->attr.pointer && !c->attr.proc_pointer)
10347 : {
10348 0 : if (c->ts.type == BT_CLASS)
10349 : {
10350 0 : rank = CLASS_DATA (c)->as ? CLASS_DATA (c)->as->rank : 0;
10351 0 : add_when_allocated
10352 0 : = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
10353 : comp, NULL_TREE, rank, purpose,
10354 : caf_mode, args, no_finalization);
10355 : }
10356 : else
10357 : {
10358 0 : rank = c->as ? c->as->rank : 0;
10359 0 : add_when_allocated = structure_alloc_comps (c->ts.u.derived,
10360 : comp, NULL_TREE,
10361 : rank, purpose,
10362 : caf_mode, args,
10363 : no_finalization);
10364 : }
10365 : }
10366 :
10367 2 : gfc_init_block (&derived_type_block);
10368 2 : if (add_when_allocated)
10369 0 : gfc_add_expr_to_block (&derived_type_block, add_when_allocated);
10370 2 : tmp = gfc_finish_block (&derived_type_block);
10371 2 : gfc_add_expr_to_block (&tmpblock, tmp);
10372 :
10373 : /* Convert the component into a rank 1 descriptor type. */
10374 2 : if (attr->dimension)
10375 : {
10376 0 : tmp = gfc_get_element_type (TREE_TYPE (comp));
10377 0 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
10378 0 : ubound = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (comp));
10379 : else
10380 0 : ubound = gfc_full_array_size (&tmpblock, comp,
10381 0 : c->ts.type == BT_CLASS
10382 0 : ? CLASS_DATA (c)->as->rank
10383 0 : : c->as->rank);
10384 : }
10385 : else
10386 : {
10387 2 : tmp = TREE_TYPE (comp);
10388 2 : ubound = build_int_cst (gfc_array_index_type, 1);
10389 : }
10390 :
10391 : /* Treat strings like arrays. Or the other way around, do not
10392 : * generate an additional array layer for scalar components. */
10393 2 : if (attr->dimension || c->ts.type == BT_CHARACTER)
10394 : {
10395 0 : cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node,
10396 : &ubound, 1,
10397 : GFC_ARRAY_ALLOCATABLE, false);
10398 :
10399 0 : cdesc = gfc_create_var (cdesc, "cdesc");
10400 0 : DECL_ARTIFICIAL (cdesc) = 1;
10401 :
10402 0 : gfc_conv_descriptor_dtype_set (&tmpblock, cdesc,
10403 : gfc_get_dtype_rank_type (1, tmp));
10404 0 : gfc_conv_descriptor_lbound_set (&tmpblock, cdesc,
10405 : gfc_index_zero_node,
10406 : gfc_index_one_node);
10407 0 : gfc_conv_descriptor_stride_set (&tmpblock, cdesc,
10408 : gfc_index_zero_node,
10409 : gfc_index_one_node);
10410 0 : gfc_conv_descriptor_ubound_set (&tmpblock, cdesc,
10411 : gfc_index_zero_node, ubound);
10412 : }
10413 : else
10414 : /* Prevent warning. */
10415 : cdesc = NULL_TREE;
10416 :
10417 2 : if (attr->dimension)
10418 : {
10419 0 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
10420 0 : comp = gfc_conv_descriptor_data_get (comp);
10421 : else
10422 0 : comp = gfc_build_addr_expr (NULL_TREE, comp);
10423 : }
10424 : else
10425 : {
10426 2 : gfc_se se;
10427 :
10428 2 : gfc_init_se (&se, NULL);
10429 :
10430 2 : comp = gfc_conv_scalar_to_descriptor (&se, comp,
10431 2 : c->ts.type == BT_CLASS
10432 2 : ? CLASS_DATA (c)->attr
10433 : : c->attr);
10434 2 : if (c->ts.type == BT_CHARACTER)
10435 0 : comp = gfc_build_addr_expr (NULL_TREE, comp);
10436 2 : gfc_add_block_to_block (&tmpblock, &se.pre);
10437 : }
10438 :
10439 2 : if (attr->dimension || c->ts.type == BT_CHARACTER)
10440 0 : gfc_conv_descriptor_data_set (&tmpblock, cdesc, comp);
10441 : else
10442 2 : cdesc = comp;
10443 :
10444 2 : tree fndecl;
10445 :
10446 2 : fndecl = build_call_expr_loc (input_location,
10447 : gfor_fndecl_co_broadcast, 5,
10448 : gfc_build_addr_expr (pvoid_type_node,cdesc),
10449 : args->image_index,
10450 : null_pointer_node, null_pointer_node,
10451 : null_pointer_node);
10452 :
10453 2 : gfc_add_expr_to_block (&tmpblock, fndecl);
10454 2 : gfc_add_block_to_block (&fnblock, &tmpblock);
10455 :
10456 35151 : break;
10457 :
10458 16347 : case DEALLOCATE_ALLOC_COMP:
10459 :
10460 16347 : gfc_init_block (&tmpblock);
10461 :
10462 16347 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10463 : decl, cdecl, NULL_TREE);
10464 :
10465 : /* Shortcut to get the attributes of the component. */
10466 16347 : if (c->ts.type == BT_CLASS)
10467 : {
10468 1082 : attr = &CLASS_DATA (c)->attr;
10469 1082 : if (attr->class_pointer || c->attr.proc_pointer)
10470 18 : continue;
10471 : }
10472 : else
10473 : {
10474 15265 : attr = &c->attr;
10475 15265 : if (attr->pointer || attr->proc_pointer)
10476 143 : continue;
10477 : }
10478 :
10479 16186 : if (!no_finalization && ((c->ts.type == BT_DERIVED && !c->attr.pointer)
10480 9539 : || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer)))
10481 : /* Call the finalizer, which will free the memory and nullify the
10482 : pointer of an array. */
10483 4080 : deallocate_called = gfc_add_comp_finalizer_call (&tmpblock, comp, c,
10484 : caf_enabled (caf_mode))
10485 4080 : && attr->dimension;
10486 : else
10487 : deallocate_called = false;
10488 :
10489 : /* Add the _class ref for classes. */
10490 16186 : if (c->ts.type == BT_CLASS && attr->allocatable)
10491 1064 : comp = gfc_class_data_get (comp);
10492 :
10493 16186 : add_when_allocated = NULL_TREE;
10494 16186 : if (cmp_has_alloc_comps
10495 3507 : && !c->attr.pointer && !c->attr.proc_pointer
10496 : && !same_type
10497 3507 : && !deallocate_called)
10498 : {
10499 : /* Add checked deallocation of the components. This code is
10500 : obviously added because the finalizer is not trusted to free
10501 : all memory. */
10502 2167 : if (c->ts.type == BT_CLASS)
10503 : {
10504 242 : rank = CLASS_DATA (c)->as ? CLASS_DATA (c)->as->rank : 0;
10505 242 : add_when_allocated
10506 242 : = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
10507 : comp, NULL_TREE, rank, purpose,
10508 : caf_mode, args, no_finalization);
10509 : }
10510 : else
10511 : {
10512 1925 : rank = c->as ? c->as->rank : 0;
10513 1925 : add_when_allocated = structure_alloc_comps (c->ts.u.derived,
10514 : comp, NULL_TREE,
10515 : rank, purpose,
10516 : caf_mode, args,
10517 : no_finalization);
10518 : }
10519 : }
10520 :
10521 10229 : if (attr->allocatable && !same_type
10522 25326 : && (!attr->codimension || caf_enabled (caf_mode)))
10523 : {
10524 : /* Handle all types of components besides components of the
10525 : same_type as the current one, because those would create an
10526 : endless loop. */
10527 51 : caf_dereg_mode = (caf_in_coarray (caf_mode)
10528 58 : && (attr->dimension || c->caf_token))
10529 9076 : || attr->codimension
10530 9211 : ? (gfc_caf_is_dealloc_only (caf_mode)
10531 : ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
10532 : : GFC_CAF_COARRAY_DEREGISTER)
10533 : : GFC_CAF_COARRAY_NOCOARRAY;
10534 :
10535 9133 : caf_token = NULL_TREE;
10536 : /* Coarray components are handled directly by
10537 : deallocate_with_status. */
10538 9133 : if (!attr->codimension
10539 9112 : && caf_dereg_mode != GFC_CAF_COARRAY_NOCOARRAY)
10540 : {
10541 57 : if (c->caf_token)
10542 19 : caf_token
10543 19 : = fold_build3_loc (input_location, COMPONENT_REF,
10544 19 : TREE_TYPE (gfc_comp_caf_token (c)),
10545 : decl, gfc_comp_caf_token (c),
10546 : NULL_TREE);
10547 38 : else if (attr->dimension && !attr->proc_pointer)
10548 38 : caf_token = gfc_conv_descriptor_token (comp);
10549 : }
10550 :
10551 9133 : tmp = gfc_deallocate_with_status (comp, NULL_TREE, NULL_TREE,
10552 : NULL_TREE, NULL_TREE, true,
10553 : NULL, caf_dereg_mode, NULL_TREE,
10554 : add_when_allocated, caf_token);
10555 :
10556 9133 : gfc_add_expr_to_block (&tmpblock, tmp);
10557 : }
10558 7053 : else if (attr->allocatable && !attr->codimension
10559 1089 : && !deallocate_called)
10560 : {
10561 : /* Case of recursive allocatable derived types. */
10562 1089 : tree is_allocated;
10563 1089 : tree ubound;
10564 1089 : tree cdesc;
10565 1089 : stmtblock_t dealloc_block;
10566 :
10567 1089 : gfc_init_block (&dealloc_block);
10568 1089 : if (add_when_allocated)
10569 0 : gfc_add_expr_to_block (&dealloc_block, add_when_allocated);
10570 :
10571 : /* Convert the component into a rank 1 descriptor type. */
10572 1089 : if (attr->dimension)
10573 : {
10574 327 : tmp = gfc_get_element_type (TREE_TYPE (comp));
10575 327 : ubound = gfc_full_array_size (&dealloc_block, comp,
10576 327 : c->ts.type == BT_CLASS
10577 0 : ? CLASS_DATA (c)->as->rank
10578 327 : : c->as->rank);
10579 : }
10580 : else
10581 : {
10582 762 : tmp = TREE_TYPE (comp);
10583 762 : ubound = build_int_cst (gfc_array_index_type, 1);
10584 : }
10585 :
10586 1089 : cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node,
10587 : &ubound, 1,
10588 : GFC_ARRAY_ALLOCATABLE, false);
10589 :
10590 1089 : cdesc = gfc_create_var (cdesc, "cdesc");
10591 1089 : DECL_ARTIFICIAL (cdesc) = 1;
10592 :
10593 1089 : gfc_conv_descriptor_dtype_set (&dealloc_block, cdesc,
10594 : gfc_get_dtype_rank_type (1, tmp));
10595 1089 : gfc_conv_descriptor_lbound_set (&dealloc_block, cdesc,
10596 : gfc_index_zero_node,
10597 : gfc_index_one_node);
10598 1089 : gfc_conv_descriptor_stride_set (&dealloc_block, cdesc,
10599 : gfc_index_zero_node,
10600 : gfc_index_one_node);
10601 1089 : gfc_conv_descriptor_ubound_set (&dealloc_block, cdesc,
10602 : gfc_index_zero_node, ubound);
10603 :
10604 1089 : if (attr->dimension)
10605 327 : comp = gfc_conv_descriptor_data_get (comp);
10606 :
10607 1089 : gfc_conv_descriptor_data_set (&dealloc_block, cdesc, comp);
10608 :
10609 : /* Now call the deallocator. */
10610 1089 : vtab = gfc_find_vtab (&c->ts);
10611 1089 : if (vtab->backend_decl == NULL)
10612 53 : gfc_get_symbol_decl (vtab);
10613 1089 : tmp = gfc_build_addr_expr (NULL_TREE, vtab->backend_decl);
10614 1089 : dealloc_fndecl = gfc_vptr_deallocate_get (tmp);
10615 1089 : dealloc_fndecl = build_fold_indirect_ref_loc (input_location,
10616 : dealloc_fndecl);
10617 1089 : tmp = build_int_cst (TREE_TYPE (comp), 0);
10618 1089 : is_allocated = fold_build2_loc (input_location, NE_EXPR,
10619 : logical_type_node, tmp,
10620 : comp);
10621 1089 : cdesc = gfc_build_addr_expr (NULL_TREE, cdesc);
10622 :
10623 1089 : tmp = build_call_expr_loc (input_location,
10624 : dealloc_fndecl, 1,
10625 : cdesc);
10626 1089 : gfc_add_expr_to_block (&dealloc_block, tmp);
10627 :
10628 1089 : tmp = gfc_finish_block (&dealloc_block);
10629 :
10630 1089 : tmp = fold_build3_loc (input_location, COND_EXPR,
10631 : void_type_node, is_allocated, tmp,
10632 : build_empty_stmt (input_location));
10633 :
10634 1089 : gfc_add_expr_to_block (&tmpblock, tmp);
10635 1089 : }
10636 5964 : else if (add_when_allocated)
10637 1139 : gfc_add_expr_to_block (&tmpblock, add_when_allocated);
10638 :
10639 1064 : if (c->ts.type == BT_CLASS && attr->allocatable
10640 17250 : && (!attr->codimension || !caf_enabled (caf_mode)))
10641 : {
10642 : /* Finally, reset the vptr to the declared type vtable and, if
10643 : necessary reset the _len field.
10644 :
10645 : First recover the reference to the component and obtain
10646 : the vptr. */
10647 1049 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10648 : decl, cdecl, NULL_TREE);
10649 1049 : tmp = gfc_class_vptr_get (comp);
10650 :
10651 1049 : if (UNLIMITED_POLY (c))
10652 : {
10653 : /* Both vptr and _len field should be nulled. */
10654 231 : gfc_add_modify (&tmpblock, tmp,
10655 231 : build_int_cst (TREE_TYPE (tmp), 0));
10656 231 : tmp = gfc_class_len_get (comp);
10657 231 : gfc_add_modify (&tmpblock, tmp,
10658 231 : build_int_cst (TREE_TYPE (tmp), 0));
10659 : }
10660 : else
10661 : {
10662 : /* Build the vtable address and set the vptr with it. */
10663 818 : gfc_reset_vptr (&tmpblock, nullptr, tmp, c->ts.u.derived);
10664 : }
10665 : }
10666 :
10667 : /* Now add the deallocation of this component. */
10668 16186 : gfc_add_block_to_block (&fnblock, &tmpblock);
10669 16186 : break;
10670 :
10671 6310 : case NULLIFY_ALLOC_COMP:
10672 : /* Nullify
10673 : - allocatable components (regular or in class)
10674 : - components that have allocatable components
10675 : - pointer components when in a coarray.
10676 : Skip everything else especially proc_pointers, which may come
10677 : coupled with the regular pointer attribute. */
10678 8512 : if (c->attr.proc_pointer
10679 6310 : || !(c->attr.allocatable || (c->ts.type == BT_CLASS
10680 506 : && CLASS_DATA (c)->attr.allocatable)
10681 2823 : || (cmp_has_alloc_comps
10682 538 : && ((c->ts.type == BT_DERIVED && !c->attr.pointer)
10683 18 : || (c->ts.type == BT_CLASS
10684 12 : && !CLASS_DATA (c)->attr.class_pointer)))
10685 2303 : || (caf_in_coarray (caf_mode) && c->attr.pointer)))
10686 2202 : continue;
10687 :
10688 : /* Process class components first, because they always have the
10689 : pointer-attribute set which would be caught wrong else. */
10690 4108 : if (c->ts.type == BT_CLASS
10691 493 : && (CLASS_DATA (c)->attr.allocatable
10692 0 : || CLASS_DATA (c)->attr.class_pointer))
10693 : {
10694 493 : tree class_ref;
10695 :
10696 : /* Allocatable CLASS components. */
10697 493 : class_ref = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10698 : decl, cdecl, NULL_TREE);
10699 :
10700 493 : comp = gfc_class_data_get (class_ref);
10701 493 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
10702 275 : gfc_conv_descriptor_data_set (&fnblock, comp,
10703 : null_pointer_node);
10704 : else
10705 : {
10706 218 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
10707 : void_type_node, comp,
10708 218 : build_int_cst (TREE_TYPE (comp), 0));
10709 218 : gfc_add_expr_to_block (&fnblock, tmp);
10710 : }
10711 :
10712 : /* The dynamic type of a disassociated pointer or unallocated
10713 : allocatable variable is its declared type. An unlimited
10714 : polymorphic entity has no declared type. */
10715 493 : gfc_reset_vptr (&fnblock, nullptr, class_ref, c->ts.u.derived);
10716 :
10717 493 : cmp_has_alloc_comps = false;
10718 493 : }
10719 : /* Coarrays need the component to be nulled before the api-call
10720 : is made. */
10721 3615 : else if (c->attr.pointer || c->attr.allocatable)
10722 : {
10723 3095 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10724 : decl, cdecl, NULL_TREE);
10725 3095 : if (c->attr.dimension || c->attr.codimension)
10726 2211 : gfc_conv_descriptor_data_set (&fnblock, comp,
10727 : null_pointer_node);
10728 : else
10729 884 : gfc_add_modify (&fnblock, comp,
10730 884 : build_int_cst (TREE_TYPE (comp), 0));
10731 3095 : if (!c->attr.pdt_string && gfc_deferred_strlen (c, &comp))
10732 : {
10733 323 : comp = fold_build3_loc (input_location, COMPONENT_REF,
10734 323 : TREE_TYPE (comp),
10735 : decl, comp, NULL_TREE);
10736 646 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
10737 323 : TREE_TYPE (comp), comp,
10738 323 : build_int_cst (TREE_TYPE (comp), 0));
10739 323 : gfc_add_expr_to_block (&fnblock, tmp);
10740 : }
10741 : cmp_has_alloc_comps = false;
10742 : }
10743 :
10744 4108 : if (flag_coarray == GFC_FCOARRAY_LIB && caf_in_coarray (caf_mode))
10745 : {
10746 : /* Register a component of a derived type coarray with the
10747 : coarray library. Do not register ultimate component
10748 : coarrays here. They are treated like regular coarrays and
10749 : are either allocated on all images or on none. */
10750 132 : tree token;
10751 :
10752 132 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10753 : decl, cdecl, NULL_TREE);
10754 132 : if (c->attr.dimension)
10755 : {
10756 : /* Set the dtype, because caf_register needs it. */
10757 104 : tree dtype_val = gfc_get_dtype (TREE_TYPE (comp));
10758 104 : gfc_conv_descriptor_dtype_set (&fnblock, comp, dtype_val);
10759 104 : tmp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10760 : decl, cdecl, NULL_TREE);
10761 104 : token = gfc_conv_descriptor_token (tmp);
10762 : }
10763 : else
10764 : {
10765 28 : gfc_se se;
10766 :
10767 28 : gfc_init_se (&se, NULL);
10768 56 : token = fold_build3_loc (input_location, COMPONENT_REF,
10769 : pvoid_type_node, decl,
10770 28 : gfc_comp_caf_token (c), NULL_TREE);
10771 28 : comp = gfc_conv_scalar_to_descriptor (&se, comp,
10772 28 : c->ts.type == BT_CLASS
10773 28 : ? CLASS_DATA (c)->attr
10774 : : c->attr);
10775 28 : gfc_add_block_to_block (&fnblock, &se.pre);
10776 : }
10777 :
10778 132 : gfc_allocate_using_caf_lib (&fnblock, comp, size_zero_node,
10779 : gfc_build_addr_expr (NULL_TREE,
10780 : token),
10781 : NULL_TREE, NULL_TREE, NULL_TREE,
10782 : GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
10783 : }
10784 :
10785 4108 : if (cmp_has_alloc_comps)
10786 : {
10787 520 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10788 : decl, cdecl, NULL_TREE);
10789 520 : rank = c->as ? c->as->rank : 0;
10790 520 : tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
10791 : rank, purpose, caf_mode, args,
10792 : no_finalization);
10793 520 : gfc_add_expr_to_block (&fnblock, tmp);
10794 : }
10795 : break;
10796 :
10797 30 : case REASSIGN_CAF_COMP:
10798 30 : if (caf_enabled (caf_mode)
10799 30 : && (c->attr.codimension
10800 23 : || (c->ts.type == BT_CLASS
10801 2 : && (CLASS_DATA (c)->attr.coarray_comp
10802 2 : || caf_in_coarray (caf_mode)))
10803 21 : || (c->ts.type == BT_DERIVED
10804 7 : && (c->ts.u.derived->attr.coarray_comp
10805 6 : || caf_in_coarray (caf_mode))))
10806 46 : && !same_type)
10807 : {
10808 14 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10809 : decl, cdecl, NULL_TREE);
10810 14 : dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10811 : dest, cdecl, NULL_TREE);
10812 :
10813 14 : if (c->attr.codimension)
10814 : {
10815 7 : if (c->ts.type == BT_CLASS)
10816 : {
10817 0 : comp = gfc_class_data_get (comp);
10818 0 : dcmp = gfc_class_data_get (dcmp);
10819 : }
10820 7 : gfc_conv_descriptor_data_set (&fnblock, dcmp,
10821 : gfc_conv_descriptor_data_get (comp));
10822 : }
10823 : else
10824 : {
10825 7 : tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
10826 : rank, purpose, caf_mode
10827 : | GFC_STRUCTURE_CAF_MODE_IN_COARRAY,
10828 : args, no_finalization);
10829 7 : gfc_add_expr_to_block (&fnblock, tmp);
10830 : }
10831 : }
10832 : break;
10833 :
10834 13465 : case COPY_ALLOC_COMP:
10835 13465 : if (c->attr.pointer || c->attr.proc_pointer)
10836 153 : continue;
10837 :
10838 : /* We need source and destination components. */
10839 13312 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl,
10840 : cdecl, NULL_TREE);
10841 13312 : dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, dest,
10842 : cdecl, NULL_TREE);
10843 13312 : dcmp = fold_convert (TREE_TYPE (comp), dcmp);
10844 :
10845 13312 : if (IS_PDT (c) && !c->attr.allocatable)
10846 : {
10847 129 : tmp = gfc_copy_alloc_comp (c->ts.u.derived, comp, dcmp,
10848 : 0, 0);
10849 129 : gfc_add_expr_to_block (&fnblock, tmp);
10850 129 : continue;
10851 : }
10852 :
10853 13183 : if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
10854 : {
10855 780 : tree ftn_tree;
10856 780 : tree size;
10857 780 : tree dst_data;
10858 780 : tree src_data;
10859 780 : tree null_data;
10860 :
10861 780 : dst_data = gfc_class_data_get (dcmp);
10862 780 : src_data = gfc_class_data_get (comp);
10863 780 : size = fold_convert (size_type_node,
10864 : gfc_class_vtab_size_get (comp));
10865 :
10866 780 : if (CLASS_DATA (c)->attr.dimension)
10867 : {
10868 752 : nelems = gfc_conv_descriptor_size (src_data,
10869 376 : CLASS_DATA (c)->as->rank);
10870 376 : size = fold_build2_loc (input_location, MULT_EXPR,
10871 : size_type_node, size,
10872 : fold_convert (size_type_node,
10873 : nelems));
10874 : }
10875 : else
10876 404 : nelems = build_int_cst (size_type_node, 1);
10877 :
10878 780 : if (CLASS_DATA (c)->attr.dimension
10879 404 : || CLASS_DATA (c)->attr.codimension)
10880 : {
10881 384 : src_data = gfc_conv_descriptor_data_get (src_data);
10882 384 : dst_data = gfc_conv_descriptor_data_get (dst_data);
10883 : }
10884 :
10885 780 : gfc_init_block (&tmpblock);
10886 :
10887 780 : gfc_add_modify (&tmpblock, gfc_class_vptr_get (dcmp),
10888 : gfc_class_vptr_get (comp));
10889 :
10890 : /* Copy the unlimited '_len' field. If it is greater than zero
10891 : (ie. a character(_len)), multiply it by size and use this
10892 : for the malloc call. */
10893 780 : if (UNLIMITED_POLY (c))
10894 : {
10895 158 : gfc_add_modify (&tmpblock, gfc_class_len_get (dcmp),
10896 : gfc_class_len_get (comp));
10897 158 : size = gfc_resize_class_size_with_len (&tmpblock, comp, size);
10898 : }
10899 :
10900 : /* Coarray component have to have the same allocation status and
10901 : shape/type-parameter/effective-type on the LHS and RHS of an
10902 : intrinsic assignment. Hence, we did not deallocated them - and
10903 : do not allocate them here. */
10904 780 : if (!CLASS_DATA (c)->attr.codimension)
10905 : {
10906 765 : ftn_tree = builtin_decl_explicit (BUILT_IN_MALLOC);
10907 765 : tmp = build_call_expr_loc (input_location, ftn_tree, 1, size);
10908 765 : gfc_add_modify (&tmpblock, dst_data,
10909 765 : fold_convert (TREE_TYPE (dst_data), tmp));
10910 : }
10911 :
10912 1545 : tmp = gfc_copy_class_to_class (comp, dcmp, nelems,
10913 780 : UNLIMITED_POLY (c));
10914 780 : gfc_add_expr_to_block (&tmpblock, tmp);
10915 780 : tmp = gfc_finish_block (&tmpblock);
10916 :
10917 780 : gfc_init_block (&tmpblock);
10918 780 : gfc_add_modify (&tmpblock, dst_data,
10919 780 : fold_convert (TREE_TYPE (dst_data),
10920 : null_pointer_node));
10921 780 : null_data = gfc_finish_block (&tmpblock);
10922 :
10923 780 : null_cond = fold_build2_loc (input_location, NE_EXPR,
10924 : logical_type_node, src_data,
10925 : null_pointer_node);
10926 :
10927 780 : gfc_add_expr_to_block (&fnblock, build3_v (COND_EXPR, null_cond,
10928 : tmp, null_data));
10929 780 : continue;
10930 780 : }
10931 :
10932 : /* To implement guarded deep copy, i.e., deep copy only allocatable
10933 : components that are really allocated, the deep copy code has to
10934 : be generated first and then added to the if-block in
10935 : gfc_duplicate_allocatable (). */
10936 12403 : if (cmp_has_alloc_comps && !c->attr.proc_pointer && !same_type)
10937 : {
10938 1923 : rank = c->as ? c->as->rank : 0;
10939 1923 : tmp = fold_convert (TREE_TYPE (dcmp), comp);
10940 1923 : gfc_add_modify (&fnblock, dcmp, tmp);
10941 1923 : add_when_allocated = structure_alloc_comps (c->ts.u.derived,
10942 : comp, dcmp,
10943 : rank, purpose,
10944 : caf_mode, args,
10945 : no_finalization);
10946 : }
10947 : else
10948 : add_when_allocated = NULL_TREE;
10949 :
10950 12403 : if (gfc_deferred_strlen (c, &tmp))
10951 : {
10952 423 : tree len, size;
10953 423 : len = tmp;
10954 423 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
10955 423 : TREE_TYPE (len),
10956 : decl, len, NULL_TREE);
10957 423 : len = fold_build3_loc (input_location, COMPONENT_REF,
10958 423 : TREE_TYPE (len),
10959 : dest, len, NULL_TREE);
10960 423 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
10961 423 : TREE_TYPE (len), len, tmp);
10962 423 : gfc_add_expr_to_block (&fnblock, tmp);
10963 423 : size = size_of_string_in_bytes (c->ts.kind, len);
10964 : /* This component cannot have allocatable components,
10965 : therefore add_when_allocated of duplicate_allocatable ()
10966 : is always NULL. */
10967 423 : rank = c->as ? c->as->rank : 0;
10968 423 : tmp = duplicate_allocatable (dcmp, comp, ctype, rank,
10969 : false, false, size, NULL_TREE);
10970 423 : gfc_add_expr_to_block (&fnblock, tmp);
10971 : }
10972 11980 : else if (c->attr.pdt_array
10973 302 : && !c->attr.allocatable && !c->attr.pointer)
10974 : {
10975 302 : tmp = duplicate_allocatable (dcmp, comp, ctype,
10976 302 : c->as ? c->as->rank : 0,
10977 : false, false, NULL_TREE, NULL_TREE);
10978 302 : gfc_add_expr_to_block (&fnblock, tmp);
10979 : }
10980 : /* Special case: recursive allocatable array components require
10981 : runtime helpers to avoid compile-time infinite recursion. Generate
10982 : a call to _gfortran_cfi_deep_copy_array with an element copy
10983 : wrapper. When inside a wrapper, reuse current_function_decl. */
10984 6945 : else if (c->attr.allocatable && cmp_has_alloc_comps && same_type
10985 1300 : && purpose == COPY_ALLOC_COMP && !c->attr.proc_pointer
10986 1300 : && !c->attr.codimension && !caf_in_coarray (caf_mode)
10987 12978 : && c->ts.type == BT_DERIVED && c->ts.u.derived != NULL)
10988 : {
10989 1300 : tree copy_wrapper, call, dest_addr, src_addr, elem_type;
10990 1300 : tree helper_ptr_type;
10991 1300 : tree alloc_expr;
10992 1300 : int comp_rank;
10993 :
10994 : /* Get the element type from ctype (already the component
10995 : type). For arrays we need the element type, not the array
10996 : type. */
10997 1300 : elem_type = ctype;
10998 1300 : if (GFC_DESCRIPTOR_TYPE_P (ctype))
10999 930 : elem_type = gfc_get_element_type (ctype);
11000 370 : else if (TREE_CODE (ctype) == ARRAY_TYPE)
11001 0 : elem_type = TREE_TYPE (ctype);
11002 370 : else if (!c->as)
11003 370 : elem_type = TREE_TYPE (TREE_TYPE (comp));
11004 :
11005 1300 : helper_ptr_type = get_copy_helper_pointer_type ();
11006 :
11007 1300 : comp_rank = c->as ? c->as->rank : 0;
11008 1300 : alloc_expr = gfc_duplicate_allocatable_nocopy (dcmp, comp, ctype,
11009 : comp_rank);
11010 1300 : gfc_add_expr_to_block (&fnblock, alloc_expr);
11011 :
11012 : /* Generate or reuse the element copy helper. Inside an
11013 : existing helper we can reuse the current function to
11014 : prevent recursive generation. */
11015 1300 : if (inside_wrapper)
11016 912 : copy_wrapper
11017 912 : = gfc_build_addr_expr (NULL_TREE, current_function_decl);
11018 : else
11019 388 : copy_wrapper
11020 388 : = generate_element_copy_wrapper (c->ts.u.derived, elem_type,
11021 : purpose, caf_mode);
11022 1300 : copy_wrapper = fold_convert (helper_ptr_type, copy_wrapper);
11023 :
11024 1300 : if (c->as)
11025 : {
11026 : /* Build addresses of descriptors. */
11027 930 : dest_addr = gfc_build_addr_expr (pvoid_type_node, dcmp);
11028 930 : src_addr = gfc_build_addr_expr (pvoid_type_node, comp);
11029 : }
11030 : else
11031 : {
11032 : /* For scalars, create separate descriptors for source and
11033 : dest, then pass their addresses. */
11034 370 : gfc_se se;
11035 370 : gfc_init_se (&se, NULL);
11036 370 : tmp = gfc_conv_scalar_to_descriptor (&se, dcmp, c->attr);
11037 370 : dest_addr = gfc_build_addr_expr (pvoid_type_node, tmp);
11038 370 : tmp = gfc_conv_scalar_to_descriptor (&se, comp, c->attr);
11039 370 : src_addr = gfc_build_addr_expr (pvoid_type_node, tmp);
11040 370 : gfc_add_block_to_block (&fnblock, &se.pre);
11041 : }
11042 :
11043 : /* Build call: _gfortran_cfi_deep_copy_array (&dcmp, &comp, wrapper). */
11044 1300 : call = build_call_expr_loc (input_location,
11045 : gfor_fndecl_cfi_deep_copy_array, 3,
11046 : dest_addr, src_addr,
11047 : copy_wrapper);
11048 :
11049 1300 : gfc_add_expr_to_block (&fnblock, call);
11050 : }
11051 : /* For allocatable arrays with nested allocatable components,
11052 : add_when_allocated already includes gfc_duplicate_allocatable
11053 : (from the recursive structure_alloc_comps call at line 10290-10293),
11054 : so we must not call it again here. PR121628 added an
11055 : add_when_allocated != NULL clause that was redundant for scalars
11056 : (already handled by !c->as) and wrong for arrays (double alloc). */
11057 5645 : else if (c->attr.allocatable && !c->attr.proc_pointer
11058 16023 : && (!cmp_has_alloc_comps
11059 775 : || !c->as
11060 661 : || c->attr.codimension
11061 658 : || caf_in_coarray (caf_mode)))
11062 : {
11063 4993 : rank = c->as ? c->as->rank : 0;
11064 4993 : if (c->attr.codimension)
11065 20 : tmp = gfc_copy_allocatable_data (dcmp, comp, ctype, rank);
11066 4973 : else if (flag_coarray == GFC_FCOARRAY_LIB
11067 4973 : && caf_in_coarray (caf_mode))
11068 : {
11069 62 : tree dst_tok;
11070 62 : if (c->as)
11071 44 : dst_tok = gfc_conv_descriptor_token (dcmp);
11072 : else
11073 : {
11074 18 : dst_tok
11075 18 : = fold_build3_loc (input_location, COMPONENT_REF,
11076 : pvoid_type_node, dest,
11077 18 : gfc_comp_caf_token (c), NULL_TREE);
11078 : }
11079 62 : tmp
11080 62 : = duplicate_allocatable_coarray (dcmp, dst_tok, comp, ctype,
11081 : rank, add_when_allocated);
11082 : }
11083 : else
11084 4911 : tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank,
11085 : add_when_allocated);
11086 4993 : gfc_add_expr_to_block (&fnblock, tmp);
11087 : }
11088 : else
11089 5385 : if (cmp_has_alloc_comps || is_pdt_type)
11090 1956 : gfc_add_expr_to_block (&fnblock, add_when_allocated);
11091 :
11092 : break;
11093 :
11094 2900 : case ALLOCATE_PDT_COMP:
11095 :
11096 2900 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
11097 : decl, cdecl, NULL_TREE);
11098 :
11099 : /* Set the PDT KIND and LEN fields. */
11100 2900 : if (c->attr.pdt_kind || c->attr.pdt_len)
11101 : {
11102 1231 : gfc_se tse;
11103 1231 : gfc_expr *c_expr = NULL;
11104 1231 : gfc_actual_arglist *param = pdt_param_list;
11105 1231 : gfc_init_se (&tse, NULL);
11106 4629 : for (; param; param = param->next)
11107 2167 : if (param->name && !strcmp (c->name, param->name))
11108 1231 : c_expr = param->expr;
11109 :
11110 1231 : if (!c_expr)
11111 18 : c_expr = c->initializer;
11112 :
11113 18 : if (c_expr)
11114 : {
11115 1213 : gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp));
11116 1213 : gfc_add_block_to_block (&fnblock, &tse.pre);
11117 1213 : gfc_add_modify (&fnblock, comp, tse.expr);
11118 1213 : gfc_add_block_to_block (&fnblock, &tse.post);
11119 : }
11120 1231 : }
11121 1669 : else if (c->initializer && !c->attr.pdt_string && !c->attr.pdt_array
11122 279 : && !c->as && !IS_PDT (c)) /* Take care of arrays. */
11123 : {
11124 115 : gfc_se tse;
11125 115 : gfc_expr *c_expr;
11126 115 : gfc_init_se (&tse, NULL);
11127 115 : c_expr = c->initializer;
11128 115 : gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp));
11129 115 : gfc_add_block_to_block (&fnblock, &tse.pre);
11130 115 : gfc_add_modify (&fnblock, comp, tse.expr);
11131 115 : gfc_add_block_to_block (&fnblock, &tse.post);
11132 : }
11133 :
11134 2900 : if (c->attr.pdt_string)
11135 : {
11136 162 : gfc_se tse;
11137 162 : gfc_init_se (&tse, NULL);
11138 162 : gfc_expr *e = gfc_copy_expr (c->ts.u.cl->length);
11139 : /* Convert the parameterized string length to its value. The
11140 : string length is stored in a hidden field in the same way as
11141 : deferred string lengths. */
11142 162 : gfc_insert_parameter_exprs (e, pdt_param_list);
11143 162 : if (gfc_deferred_strlen (c, &strlen) && strlen != NULL_TREE)
11144 : {
11145 162 : gfc_conv_expr_type (&tse, e,
11146 162 : TREE_TYPE (strlen));
11147 162 : strlen = fold_build3_loc (input_location, COMPONENT_REF,
11148 162 : TREE_TYPE (strlen),
11149 : decl, strlen, NULL_TREE);
11150 162 : gfc_add_block_to_block (&fnblock, &tse.pre);
11151 162 : gfc_add_modify (&fnblock, strlen, tse.expr);
11152 162 : gfc_add_block_to_block (&fnblock, &tse.post);
11153 162 : c->ts.u.cl->backend_decl = strlen;
11154 : }
11155 162 : gfc_free_expr (e);
11156 :
11157 : /* Scalar parameterized strings can be allocated now. */
11158 162 : if (!c->as)
11159 : {
11160 102 : tmp = fold_convert (gfc_array_index_type, strlen);
11161 102 : tmp = size_of_string_in_bytes (c->ts.kind, tmp);
11162 102 : tmp = gfc_evaluate_now (tmp, &fnblock);
11163 102 : tmp = gfc_call_malloc (&fnblock, TREE_TYPE (comp), tmp);
11164 102 : gfc_add_modify (&fnblock, comp, tmp);
11165 : }
11166 : }
11167 :
11168 : /* Allocate parameterized arrays of parameterized derived types. */
11169 2900 : if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT)
11170 2403 : && !(IS_PDT (c) || IS_CLASS_PDT (c)))
11171 2177 : continue;
11172 :
11173 723 : if (c->ts.type == BT_CLASS)
11174 0 : comp = gfc_class_data_get (comp);
11175 :
11176 723 : if (c->attr.pdt_array
11177 723 : || (c->attr.pdt_string
11178 0 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp))))
11179 : {
11180 497 : gfc_se tse;
11181 497 : int i;
11182 497 : tree size = gfc_index_one_node;
11183 497 : tree offset = gfc_index_zero_node;
11184 497 : tree lower, upper;
11185 497 : gfc_expr *e;
11186 :
11187 : /* This chunk takes the expressions for 'lower' and 'upper'
11188 : in the arrayspec and substitutes in the expressions for
11189 : the parameters from 'pdt_param_list'. The descriptor
11190 : fields can then be filled from the values so obtained. */
11191 497 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)));
11192 1096 : for (i = 0; i < c->as->rank; i++)
11193 : {
11194 599 : gfc_init_se (&tse, NULL);
11195 599 : e = gfc_copy_expr (c->as->lower[i]);
11196 599 : gfc_insert_parameter_exprs (e, pdt_param_list);
11197 599 : gfc_conv_expr_type (&tse, e, gfc_array_index_type);
11198 599 : gfc_free_expr (e);
11199 599 : lower = tse.expr;
11200 599 : gfc_add_block_to_block (&fnblock, &tse.pre);
11201 599 : gfc_conv_descriptor_lbound_set (&fnblock, comp,
11202 : gfc_rank_cst[i],
11203 : lower);
11204 599 : gfc_add_block_to_block (&fnblock, &tse.post);
11205 599 : e = gfc_copy_expr (c->as->upper[i]);
11206 599 : gfc_insert_parameter_exprs (e, pdt_param_list);
11207 599 : gfc_conv_expr_type (&tse, e, gfc_array_index_type);
11208 599 : gfc_free_expr (e);
11209 599 : upper = tse.expr;
11210 599 : gfc_add_block_to_block (&fnblock, &tse.pre);
11211 599 : gfc_conv_descriptor_ubound_set (&fnblock, comp,
11212 : gfc_rank_cst[i],
11213 : upper);
11214 599 : gfc_add_block_to_block (&fnblock, &tse.post);
11215 599 : gfc_conv_descriptor_stride_set (&fnblock, comp,
11216 : gfc_rank_cst[i],
11217 : size);
11218 599 : size = gfc_evaluate_now (size, &fnblock);
11219 599 : tmp = fold_build2_loc (input_location,
11220 : MULT_EXPR,
11221 : gfc_array_index_type,
11222 : lower, size);
11223 599 : offset = fold_build2_loc (input_location,
11224 : MINUS_EXPR,
11225 : gfc_array_index_type,
11226 : offset, tmp);
11227 599 : offset = gfc_evaluate_now (offset, &fnblock);
11228 599 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
11229 : gfc_array_index_type,
11230 : upper, lower);
11231 599 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
11232 : gfc_array_index_type,
11233 : tmp, gfc_index_one_node);
11234 599 : size = fold_build2_loc (input_location, MULT_EXPR,
11235 : gfc_array_index_type, size, tmp);
11236 : }
11237 497 : gfc_conv_descriptor_offset_set (&fnblock, comp, offset);
11238 497 : if (c->ts.type == BT_CLASS)
11239 : {
11240 0 : tmp = gfc_get_vptr_from_expr (comp);
11241 0 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
11242 0 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
11243 0 : tmp = gfc_vptr_size_get (tmp);
11244 : }
11245 497 : else if (strlen != NULL_TREE)
11246 54 : tmp = strlen;
11247 : else
11248 443 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (ctype));
11249 497 : tmp = fold_convert (gfc_array_index_type, tmp);
11250 497 : size = fold_build2_loc (input_location, MULT_EXPR,
11251 : gfc_array_index_type, size, tmp);
11252 497 : size = gfc_evaluate_now (size, &fnblock);
11253 497 : tmp = gfc_call_malloc (&fnblock, NULL, size);
11254 497 : gfc_conv_descriptor_data_set (&fnblock, comp, tmp);
11255 497 : gfc_conv_descriptor_dtype_set (&fnblock, comp,
11256 : gfc_get_dtype (ctype));
11257 497 : if (strlen != NULL_TREE)
11258 : {
11259 54 : tmp = gfc_conv_descriptor_elem_len_get (comp);
11260 54 : gfc_add_modify (&fnblock, tmp, fold_convert (TREE_TYPE (tmp), strlen));
11261 54 : gfc_conv_descriptor_span_set (&fnblock, comp, strlen);
11262 : }
11263 :
11264 497 : if (c->initializer && c->initializer->rank)
11265 : {
11266 0 : gfc_init_se (&tse, NULL);
11267 0 : e = gfc_copy_expr (c->initializer);
11268 0 : gfc_insert_parameter_exprs (e, pdt_param_list);
11269 0 : gfc_conv_expr_descriptor (&tse, e);
11270 0 : gfc_add_block_to_block (&fnblock, &tse.pre);
11271 0 : gfc_free_expr (e);
11272 0 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
11273 0 : tmp = build_call_expr_loc (input_location, tmp, 3,
11274 : gfc_conv_descriptor_data_get (comp),
11275 : gfc_conv_descriptor_data_get (tse.expr),
11276 : fold_convert (size_type_node, size));
11277 0 : gfc_add_expr_to_block (&fnblock, tmp);
11278 0 : gfc_add_block_to_block (&fnblock, &tse.post);
11279 : }
11280 : }
11281 :
11282 : /* Recurse in to PDT components. */
11283 723 : if ((IS_PDT (c) || IS_CLASS_PDT (c))
11284 240 : && !(c->attr.pointer || c->attr.allocatable))
11285 : {
11286 152 : gfc_actual_arglist *tail = c->param_list, *parms;
11287 152 : bool ext;
11288 :
11289 152 : ext = gfc_get_derived_super_type (der_type) == c->ts.u.derived;
11290 :
11291 406 : for (; tail; tail = tail->next)
11292 266 : if (tail->spec_type != SPEC_EXPLICIT && tail->expr)
11293 : break;
11294 :
11295 152 : if (tail && ext)
11296 : /* 'der_type' extends the type of this component but has no
11297 : type parameters of its own and so some of the components
11298 : might be assumed. The pdt_param_list will have what is
11299 : needed. */
11300 12 : parms = pdt_param_list;
11301 : else
11302 : /* Otherwise, use the component's type parameters. */
11303 : {
11304 140 : tail = parms = c->param_list;
11305 382 : for (; tail; tail = tail->next)
11306 242 : if (tail->expr)
11307 218 : gfc_insert_parameter_exprs (tail->expr, pdt_param_list);
11308 : }
11309 :
11310 152 : tmp = gfc_allocate_pdt_comp (c->ts.u.derived, comp,
11311 152 : c->as ? c->as->rank : 0,
11312 : parms);
11313 152 : gfc_add_expr_to_block (&fnblock, tmp);
11314 : }
11315 :
11316 : break;
11317 :
11318 4811 : case DEALLOCATE_PDT_COMP:
11319 : /* Deallocate array or parameterized string length components
11320 : of parameterized derived types. */
11321 4811 : if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT)
11322 3927 : && !c->attr.pdt_string
11323 3801 : && !(IS_PDT (c) || IS_CLASS_PDT (c)))
11324 3289 : continue;
11325 :
11326 1522 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
11327 : decl, cdecl, NULL_TREE);
11328 1522 : if (c->ts.type == BT_CLASS)
11329 0 : comp = gfc_class_data_get (comp);
11330 :
11331 : /* Recurse in to PDT components. */
11332 1522 : if ((IS_PDT (c) || IS_CLASS_PDT (c))
11333 550 : && (!c->attr.pointer && !c->attr.allocatable))
11334 : {
11335 359 : tmp = gfc_deallocate_pdt_comp (c->ts.u.derived, comp,
11336 359 : c->as ? c->as->rank : 0);
11337 359 : gfc_add_expr_to_block (&fnblock, tmp);
11338 : }
11339 :
11340 1522 : if (c->attr.pdt_array || c->attr.pdt_string)
11341 : {
11342 1010 : tmp = comp;
11343 1010 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
11344 890 : tmp = gfc_conv_descriptor_data_get (comp);
11345 1010 : null_cond = fold_build2_loc (input_location, NE_EXPR,
11346 : logical_type_node, tmp,
11347 1010 : build_int_cst (TREE_TYPE (tmp), 0));
11348 1010 : if (flag_openmp_allocators)
11349 : {
11350 0 : tree cd, t;
11351 0 : if (c->attr.pdt_array)
11352 : {
11353 0 : tree version_val = gfc_conv_descriptor_version_get (comp);
11354 0 : cd = fold_build2_loc (input_location, EQ_EXPR,
11355 : boolean_type_node, version_val,
11356 : integer_one_node);
11357 : }
11358 : else
11359 0 : cd = gfc_omp_call_is_alloc (tmp);
11360 0 : t = builtin_decl_explicit (BUILT_IN_GOMP_FREE);
11361 0 : t = build_call_expr_loc (input_location, t, 1, tmp);
11362 :
11363 0 : stmtblock_t tblock;
11364 0 : gfc_init_block (&tblock);
11365 0 : gfc_add_expr_to_block (&tblock, t);
11366 0 : if (c->attr.pdt_array)
11367 0 : gfc_conv_descriptor_version_set (&tblock, comp,
11368 : integer_zero_node);
11369 0 : tmp = build3_loc (input_location, COND_EXPR, void_type_node,
11370 : cd, gfc_finish_block (&tblock),
11371 : gfc_call_free (tmp));
11372 : }
11373 : else
11374 1010 : tmp = gfc_call_free (tmp);
11375 1010 : tmp = build3_v (COND_EXPR, null_cond, tmp,
11376 : build_empty_stmt (input_location));
11377 1010 : gfc_add_expr_to_block (&fnblock, tmp);
11378 :
11379 1010 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
11380 890 : gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
11381 : else
11382 : {
11383 120 : tmp = fold_convert (TREE_TYPE (comp), null_pointer_node);
11384 120 : gfc_add_modify (&fnblock, comp, tmp);
11385 : }
11386 : }
11387 :
11388 : break;
11389 :
11390 506 : case CHECK_PDT_DUMMY:
11391 506 : case CHECK_PDT_INTENT_OUT_DUMMY:
11392 :
11393 506 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
11394 : decl, cdecl, NULL_TREE);
11395 506 : if (c->ts.type == BT_CLASS)
11396 0 : comp = gfc_class_data_get (comp);
11397 :
11398 : /* Recurse in to PDT components. */
11399 506 : if (((c->ts.type == BT_DERIVED
11400 44 : && !c->attr.allocatable && !c->attr.pointer)
11401 464 : || (c->ts.type == BT_CLASS
11402 0 : && !CLASS_DATA (c)->attr.allocatable
11403 0 : && !CLASS_DATA (c)->attr.pointer))
11404 42 : && c->ts.u.derived && c->ts.u.derived->attr.pdt_type)
11405 : {
11406 12 : tmp = gfc_check_pdt_dummy (c->ts.u.derived, comp,
11407 12 : c->as ? c->as->rank : 0,
11408 : pdt_param_list, intent_out);
11409 12 : gfc_add_expr_to_block (&fnblock, tmp);
11410 : }
11411 :
11412 506 : if (!c->attr.pdt_len)
11413 : {
11414 422 : gfc_se tse;
11415 753 : if (!intent_out
11416 122 : || c->attr.codimension
11417 122 : || c->attr.pointer
11418 122 : || IS_PDT (c) || IS_CLASS_PDT (c)
11419 122 : || c->attr.pdt_comp || c->attr.pdt_kind
11420 121 : || !c->initializer
11421 513 : || !gfc_is_constant_expr (c->initializer)) // Just in case!
11422 331 : continue;
11423 :
11424 : /* F2023 19.6.5(24) "Invocation of a procedure that has a
11425 : nonpointer, nonallocatable INTENT (OUT) dummy argument causes
11426 : all nonpointer default-initialized subcomponents of the dummy
11427 : argument to become defined." */
11428 91 : if (c->initializer->expr_type == EXPR_CONSTANT)
11429 : {
11430 31 : gfc_init_se (&tse, NULL);
11431 31 : gfc_conv_expr (&tse, c->initializer);
11432 31 : gfc_add_modify (&fnblock, comp, tse.expr);
11433 : }
11434 60 : else if (c->initializer->expr_type == EXPR_STRUCTURE)
11435 : {
11436 30 : tmp = gfc_trans_structure_assign (comp, c->initializer,
11437 : true, false);
11438 30 : gfc_add_expr_to_block (&fnblock, tmp);
11439 : }
11440 30 : else if (c->initializer->expr_type == EXPR_ARRAY)
11441 : {
11442 30 : tree type = TREE_TYPE (TREE_TYPE (comp));
11443 30 : tree len = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (comp));
11444 30 : len = fold_build2_loc (input_location, MULT_EXPR,
11445 30 : TREE_TYPE (len), len,
11446 30 : TYPE_SIZE_UNIT (type));
11447 :
11448 30 : tmp = gfc_build_constant_array_constructor (c->initializer, type);
11449 30 : tmp = gfc_build_memcpy_call (gfc_conv_array_data (comp), tmp, len);
11450 30 : gfc_add_expr_to_block (&fnblock, tmp);
11451 : }
11452 : else
11453 0 : continue;
11454 : }
11455 : else
11456 : {
11457 84 : gfc_se tse;
11458 84 : gfc_expr *c_expr = NULL;
11459 84 : gfc_actual_arglist *param = pdt_param_list;
11460 84 : gfc_init_se (&tse, NULL);
11461 300 : for (; param; param = param->next)
11462 132 : if (!strcmp (c->name, param->name)
11463 84 : && param->spec_type == SPEC_EXPLICIT)
11464 54 : c_expr = param->expr;
11465 :
11466 84 : if (c_expr)
11467 : {
11468 54 : tree error, cond, cname;
11469 54 : gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp));
11470 54 : cond = fold_build2_loc (input_location, NE_EXPR,
11471 : logical_type_node,
11472 : comp, tse.expr);
11473 54 : cname = gfc_build_cstring_const (c->name);
11474 54 : cname = gfc_build_addr_expr (pchar_type_node, cname);
11475 54 : error = gfc_trans_runtime_error (true, NULL,
11476 : "The value of the PDT LEN "
11477 : "parameter '%s' does not "
11478 : "agree with that in the "
11479 : "dummy declaration",
11480 : cname);
11481 54 : tmp = fold_build3_loc (input_location, COND_EXPR,
11482 : void_type_node, cond, error,
11483 : build_empty_stmt (input_location));
11484 54 : gfc_add_expr_to_block (&fnblock, tmp);
11485 : }
11486 : }
11487 : break;
11488 :
11489 0 : default:
11490 0 : gcc_unreachable ();
11491 9223 : break;
11492 : }
11493 : }
11494 22873 : seen_derived_types.remove (der_type);
11495 :
11496 22873 : return gfc_finish_block (&fnblock);
11497 : }
11498 :
11499 : /* Recursively traverse an object of derived type, generating code to
11500 : nullify allocatable components. */
11501 :
11502 : tree
11503 3192 : gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
11504 : int caf_mode)
11505 : {
11506 3192 : return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11507 : NULLIFY_ALLOC_COMP,
11508 : GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode,
11509 3192 : NULL);
11510 : }
11511 :
11512 :
11513 : /* Recursively traverse an object of derived type, generating code to
11514 : deallocate allocatable components. */
11515 :
11516 : tree
11517 3211 : gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
11518 : int caf_mode, bool no_finalization)
11519 : {
11520 3211 : return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11521 : DEALLOCATE_ALLOC_COMP,
11522 : GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode,
11523 3211 : NULL, no_finalization);
11524 : }
11525 :
11526 : tree
11527 1 : gfc_bcast_alloc_comp (gfc_symbol *derived, gfc_expr *expr, int rank,
11528 : tree image_index, tree stat, tree errmsg,
11529 : tree errmsg_len)
11530 : {
11531 1 : tree tmp, array;
11532 1 : gfc_se argse;
11533 1 : stmtblock_t block, post_block;
11534 1 : gfc_co_subroutines_args args;
11535 :
11536 1 : args.image_index = image_index;
11537 1 : args.stat = stat;
11538 1 : args.errmsg = errmsg;
11539 1 : args.errmsg_len = errmsg_len;
11540 :
11541 1 : if (rank == 0)
11542 : {
11543 1 : gfc_start_block (&block);
11544 1 : gfc_init_block (&post_block);
11545 1 : gfc_init_se (&argse, NULL);
11546 1 : gfc_conv_expr (&argse, expr);
11547 1 : gfc_add_block_to_block (&block, &argse.pre);
11548 1 : gfc_add_block_to_block (&post_block, &argse.post);
11549 1 : array = argse.expr;
11550 : }
11551 : else
11552 : {
11553 0 : gfc_init_se (&argse, NULL);
11554 0 : argse.want_pointer = 1;
11555 0 : gfc_conv_expr_descriptor (&argse, expr);
11556 0 : array = argse.expr;
11557 : }
11558 :
11559 1 : tmp = structure_alloc_comps (derived, array, NULL_TREE, rank,
11560 : BCAST_ALLOC_COMP,
11561 : GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY,
11562 : &args);
11563 1 : return tmp;
11564 : }
11565 :
11566 : /* Recursively traverse an object of derived type, generating code to
11567 : deallocate allocatable components. But do not deallocate coarrays.
11568 : To be used for intrinsic assignment, which may not change the allocation
11569 : status of coarrays. */
11570 :
11571 : tree
11572 3623 : gfc_deallocate_alloc_comp_no_caf (gfc_symbol * der_type, tree decl, int rank,
11573 : bool no_finalization)
11574 : {
11575 3623 : return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11576 : DEALLOCATE_ALLOC_COMP, 0, NULL,
11577 3623 : no_finalization);
11578 : }
11579 :
11580 :
11581 : tree
11582 5 : gfc_reassign_alloc_comp_caf (gfc_symbol *der_type, tree decl, tree dest)
11583 : {
11584 5 : return structure_alloc_comps (der_type, decl, dest, 0, REASSIGN_CAF_COMP,
11585 : GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY,
11586 5 : NULL);
11587 : }
11588 :
11589 :
11590 : /* Recursively traverse an object of derived type, generating code to
11591 : copy it and its allocatable components. */
11592 :
11593 : tree
11594 4838 : gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank,
11595 : int caf_mode)
11596 : {
11597 4838 : return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP,
11598 4838 : caf_mode, NULL);
11599 : }
11600 :
11601 :
11602 : /* Recursively traverse an object of derived type, generating code to
11603 : copy it and its allocatable components, while suppressing any
11604 : finalization that might occur. This is used in the finalization of
11605 : function results. */
11606 :
11607 : tree
11608 38 : gfc_copy_alloc_comp_no_fini (gfc_symbol * der_type, tree decl, tree dest,
11609 : int rank, int caf_mode)
11610 : {
11611 38 : return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP,
11612 38 : caf_mode, NULL, true);
11613 : }
11614 :
11615 :
11616 : /* Recursively traverse an object of derived type, generating code to
11617 : copy only its allocatable components. */
11618 :
11619 : tree
11620 0 : gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
11621 : {
11622 0 : return structure_alloc_comps (der_type, decl, dest, rank,
11623 0 : COPY_ONLY_ALLOC_COMP, 0, NULL);
11624 : }
11625 :
11626 :
11627 : /* Recursively traverse an object of parameterized derived type, generating
11628 : code to allocate parameterized components. */
11629 :
11630 : tree
11631 943 : gfc_allocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank,
11632 : gfc_actual_arglist *param_list)
11633 : {
11634 943 : tree res;
11635 943 : gfc_actual_arglist *old_param_list = pdt_param_list;
11636 943 : pdt_param_list = param_list;
11637 943 : res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11638 : ALLOCATE_PDT_COMP, 0, NULL);
11639 943 : pdt_param_list = old_param_list;
11640 943 : return res;
11641 : }
11642 :
11643 : /* Recursively traverse an object of parameterized derived type, generating
11644 : code to deallocate parameterized components. */
11645 :
11646 : tree
11647 1664 : gfc_deallocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank)
11648 : {
11649 : /* A type without parameterized components causes gimplifier problems. */
11650 1664 : if (!has_parameterized_comps (der_type))
11651 : return NULL_TREE;
11652 :
11653 847 : return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11654 847 : DEALLOCATE_PDT_COMP, 0, NULL);
11655 : }
11656 :
11657 :
11658 : /* Recursively traverse a dummy of parameterized derived type to check the
11659 : values of LEN parameters. */
11660 :
11661 : tree
11662 117 : gfc_check_pdt_dummy (gfc_symbol * der_type, tree decl, int rank,
11663 : gfc_actual_arglist *param_list, bool intent_out)
11664 : {
11665 117 : tree res;
11666 117 : gfc_actual_arglist *old_param_list = pdt_param_list;
11667 117 : pdt_param_list = param_list;
11668 203 : res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11669 : intent_out ? CHECK_PDT_INTENT_OUT_DUMMY :
11670 : CHECK_PDT_DUMMY,
11671 : 0, NULL);
11672 117 : pdt_param_list = old_param_list;
11673 117 : return res;
11674 : }
11675 :
11676 :
11677 : /* Returns the value of LBOUND for an expression. This could be broken out
11678 : from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
11679 : called by gfc_alloc_allocatable_for_assignment. */
11680 : static tree
11681 1090 : get_std_lbound (gfc_expr *expr, tree desc, int dim, bool assumed_size)
11682 : {
11683 1090 : tree lbound;
11684 1090 : tree ubound;
11685 1090 : tree stride;
11686 1090 : tree cond, cond1, cond3, cond4;
11687 1090 : tree tmp;
11688 1090 : gfc_ref *ref;
11689 :
11690 1090 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
11691 : {
11692 508 : tmp = gfc_rank_cst[dim];
11693 508 : lbound = gfc_conv_descriptor_lbound_get (desc, tmp);
11694 508 : ubound = gfc_conv_descriptor_ubound_get (desc, tmp);
11695 508 : stride = gfc_conv_descriptor_stride_get (desc, tmp);
11696 508 : cond1 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
11697 : ubound, lbound);
11698 508 : cond3 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
11699 : stride, gfc_index_zero_node);
11700 508 : cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
11701 : logical_type_node, cond3, cond1);
11702 508 : cond4 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
11703 : stride, gfc_index_zero_node);
11704 508 : if (assumed_size)
11705 0 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
11706 : tmp, build_int_cst (gfc_array_index_type,
11707 0 : expr->rank - 1));
11708 : else
11709 508 : cond = logical_false_node;
11710 :
11711 508 : cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
11712 : logical_type_node, cond3, cond4);
11713 508 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
11714 : logical_type_node, cond, cond1);
11715 :
11716 508 : return fold_build3_loc (input_location, COND_EXPR,
11717 : gfc_array_index_type, cond,
11718 508 : lbound, gfc_index_one_node);
11719 : }
11720 :
11721 582 : if (expr->expr_type == EXPR_FUNCTION)
11722 : {
11723 : /* A conversion function, so use the argument. */
11724 7 : gcc_assert (expr->value.function.isym
11725 : && expr->value.function.isym->conversion);
11726 7 : expr = expr->value.function.actual->expr;
11727 : }
11728 :
11729 582 : if (expr->expr_type == EXPR_VARIABLE)
11730 : {
11731 582 : tmp = TREE_TYPE (expr->symtree->n.sym->backend_decl);
11732 1508 : for (ref = expr->ref; ref; ref = ref->next)
11733 : {
11734 926 : if (ref->type == REF_COMPONENT
11735 295 : && ref->u.c.component->as
11736 246 : && ref->next
11737 246 : && ref->next->u.ar.type == AR_FULL)
11738 204 : tmp = TREE_TYPE (ref->u.c.component->backend_decl);
11739 : }
11740 582 : return GFC_TYPE_ARRAY_LBOUND(tmp, dim);
11741 : }
11742 :
11743 0 : return gfc_index_one_node;
11744 : }
11745 :
11746 :
11747 : /* Returns true if an expression represents an lhs that can be reallocated
11748 : on assignment. */
11749 :
11750 : bool
11751 643788 : gfc_is_reallocatable_lhs (gfc_expr *expr)
11752 : {
11753 643788 : gfc_ref * ref;
11754 643788 : gfc_symbol *sym;
11755 :
11756 643788 : if (!flag_realloc_lhs)
11757 : return false;
11758 :
11759 643288 : if (!expr->ref)
11760 : return false;
11761 :
11762 217298 : sym = expr->symtree->n.sym;
11763 :
11764 217298 : if (sym->attr.associate_var && !expr->ref)
11765 : return false;
11766 :
11767 : /* An allocatable class variable with no reference. */
11768 217298 : if (sym->ts.type == BT_CLASS
11769 6721 : && (!sym->attr.associate_var || sym->attr.select_rank_temporary)
11770 6561 : && CLASS_DATA (sym)->attr.allocatable
11771 : && expr->ref
11772 4023 : && ((expr->ref->type == REF_ARRAY && expr->ref->u.ar.type == AR_FULL
11773 703 : && expr->ref->next == NULL)
11774 3393 : || (expr->ref->type == REF_COMPONENT
11775 3052 : && strcmp (expr->ref->u.c.component->name, "_data") == 0
11776 2171 : && (expr->ref->next == NULL
11777 2171 : || (expr->ref->next->type == REF_ARRAY
11778 2171 : && expr->ref->next->u.ar.type == AR_FULL
11779 1749 : && expr->ref->next->next == NULL)))))
11780 : return true;
11781 :
11782 : /* An allocatable variable. */
11783 215059 : if (sym->attr.allocatable
11784 46944 : && (!sym->attr.associate_var || sym->attr.select_rank_temporary)
11785 : && expr->ref
11786 46944 : && expr->ref->type == REF_ARRAY
11787 45413 : && expr->ref->u.ar.type == AR_FULL)
11788 : return true;
11789 :
11790 : /* All that can be left are allocatable components. */
11791 186992 : if (sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
11792 : return false;
11793 :
11794 : /* Find a component ref followed by an array reference. */
11795 93439 : for (ref = expr->ref; ref; ref = ref->next)
11796 65483 : if (ref->next
11797 37527 : && ref->type == REF_COMPONENT
11798 21484 : && ref->next->type == REF_ARRAY
11799 17737 : && !ref->next->next)
11800 : break;
11801 :
11802 41376 : if (!ref)
11803 : return false;
11804 :
11805 : /* Return true if valid reallocatable lhs. */
11806 13420 : if (ref->u.c.component->attr.allocatable
11807 6618 : && ref->next->u.ar.type == AR_FULL)
11808 4968 : return true;
11809 :
11810 : return false;
11811 : }
11812 :
11813 :
11814 : static tree
11815 56 : concat_str_length (gfc_expr* expr)
11816 : {
11817 56 : tree type;
11818 56 : tree len1;
11819 56 : tree len2;
11820 56 : gfc_se se;
11821 :
11822 56 : type = gfc_typenode_for_spec (&expr->value.op.op1->ts);
11823 56 : len1 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
11824 56 : if (len1 == NULL_TREE)
11825 : {
11826 56 : if (expr->value.op.op1->expr_type == EXPR_OP)
11827 31 : len1 = concat_str_length (expr->value.op.op1);
11828 25 : else if (expr->value.op.op1->expr_type == EXPR_CONSTANT)
11829 25 : len1 = build_int_cst (gfc_charlen_type_node,
11830 25 : expr->value.op.op1->value.character.length);
11831 0 : else if (expr->value.op.op1->ts.u.cl->length)
11832 : {
11833 0 : gfc_init_se (&se, NULL);
11834 0 : gfc_conv_expr (&se, expr->value.op.op1->ts.u.cl->length);
11835 0 : len1 = se.expr;
11836 : }
11837 : else
11838 : {
11839 : /* Last resort! */
11840 0 : gfc_init_se (&se, NULL);
11841 0 : se.want_pointer = 1;
11842 0 : se.descriptor_only = 1;
11843 0 : gfc_conv_expr (&se, expr->value.op.op1);
11844 0 : len1 = se.string_length;
11845 : }
11846 : }
11847 :
11848 56 : type = gfc_typenode_for_spec (&expr->value.op.op2->ts);
11849 56 : len2 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
11850 56 : if (len2 == NULL_TREE)
11851 : {
11852 31 : if (expr->value.op.op2->expr_type == EXPR_OP)
11853 0 : len2 = concat_str_length (expr->value.op.op2);
11854 31 : else if (expr->value.op.op2->expr_type == EXPR_CONSTANT)
11855 25 : len2 = build_int_cst (gfc_charlen_type_node,
11856 25 : expr->value.op.op2->value.character.length);
11857 6 : else if (expr->value.op.op2->ts.u.cl->length)
11858 : {
11859 6 : gfc_init_se (&se, NULL);
11860 6 : gfc_conv_expr (&se, expr->value.op.op2->ts.u.cl->length);
11861 6 : len2 = se.expr;
11862 : }
11863 : else
11864 : {
11865 : /* Last resort! */
11866 0 : gfc_init_se (&se, NULL);
11867 0 : se.want_pointer = 1;
11868 0 : se.descriptor_only = 1;
11869 0 : gfc_conv_expr (&se, expr->value.op.op2);
11870 0 : len2 = se.string_length;
11871 : }
11872 : }
11873 :
11874 56 : gcc_assert(len1 && len2);
11875 56 : len1 = fold_convert (gfc_charlen_type_node, len1);
11876 56 : len2 = fold_convert (gfc_charlen_type_node, len2);
11877 :
11878 56 : return fold_build2_loc (input_location, PLUS_EXPR,
11879 56 : gfc_charlen_type_node, len1, len2);
11880 : }
11881 :
11882 :
11883 : /* Among the scalarization chain of LOOP, find the element associated with an
11884 : allocatable array on the lhs of an assignment and evaluate its fields
11885 : (bounds, offset, etc) to new variables, putting the new code in BLOCK. This
11886 : function is to be called after putting the reallocation code in BLOCK and
11887 : before the beginning of the scalarization loop body.
11888 :
11889 : The fields to be saved are expected to hold on entry to the function
11890 : expressions referencing the array descriptor. Especially the expressions
11891 : shouldn't be already temporary variable references as the value saved before
11892 : reallocation would be incorrect after reallocation.
11893 : At the end of the function, the expressions have been replaced with variable
11894 : references. */
11895 :
11896 : static void
11897 6788 : update_reallocated_descriptor (stmtblock_t *block, gfc_loopinfo *loop)
11898 : {
11899 23632 : for (gfc_ss *s = loop->ss; s != gfc_ss_terminator; s = s->loop_chain)
11900 : {
11901 16844 : if (!s->is_alloc_lhs)
11902 10056 : continue;
11903 :
11904 6788 : gcc_assert (s->info->type == GFC_SS_SECTION);
11905 6788 : gfc_array_info *info = &s->info->data.array;
11906 :
11907 : #define SAVE_VALUE(value) \
11908 : do \
11909 : { \
11910 : value = gfc_evaluate_now (value, block); \
11911 : } \
11912 : while (0)
11913 :
11914 6788 : if (save_descriptor_data (info->descriptor, info->data))
11915 5948 : SAVE_VALUE (info->data);
11916 6788 : SAVE_VALUE (info->offset);
11917 6788 : info->saved_offset = info->offset;
11918 16787 : for (int i = 0; i < s->dimen; i++)
11919 : {
11920 9999 : int dim = s->dim[i];
11921 9999 : SAVE_VALUE (info->start[dim]);
11922 9999 : SAVE_VALUE (info->end[dim]);
11923 9999 : SAVE_VALUE (info->stride[dim]);
11924 9999 : SAVE_VALUE (info->delta[dim]);
11925 : }
11926 :
11927 : #undef SAVE_VALUE
11928 : }
11929 6788 : }
11930 :
11931 :
11932 : /* Allocate the lhs of an assignment to an allocatable array, otherwise
11933 : reallocate it. */
11934 :
11935 : tree
11936 6788 : gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
11937 : gfc_expr *expr1,
11938 : gfc_expr *expr2)
11939 : {
11940 6788 : stmtblock_t realloc_block;
11941 6788 : stmtblock_t alloc_block;
11942 6788 : stmtblock_t fblock;
11943 6788 : stmtblock_t loop_pre_block;
11944 6788 : gfc_ref *ref;
11945 6788 : gfc_ss *rss;
11946 6788 : gfc_ss *lss;
11947 6788 : gfc_array_info *linfo;
11948 6788 : tree realloc_expr;
11949 6788 : tree alloc_expr;
11950 6788 : tree size1;
11951 6788 : tree size2;
11952 6788 : tree elemsize1;
11953 6788 : tree elemsize2;
11954 6788 : tree array1;
11955 6788 : tree cond_null;
11956 6788 : tree cond;
11957 6788 : tree tmp;
11958 6788 : tree tmp2;
11959 6788 : tree lbound;
11960 6788 : tree ubound;
11961 6788 : tree desc;
11962 6788 : tree old_desc;
11963 6788 : tree desc2;
11964 6788 : tree offset;
11965 6788 : tree jump_label1;
11966 6788 : tree jump_label2;
11967 6788 : tree lbd;
11968 6788 : tree class_expr2 = NULL_TREE;
11969 6788 : int n;
11970 6788 : gfc_array_spec * as;
11971 6788 : bool coarray = (flag_coarray == GFC_FCOARRAY_LIB
11972 6788 : && gfc_caf_attr (expr1, true).codimension);
11973 6788 : tree token;
11974 6788 : gfc_se caf_se;
11975 :
11976 : /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
11977 : Find the lhs expression in the loop chain and set expr1 and
11978 : expr2 accordingly. */
11979 6788 : if (expr1->expr_type == EXPR_FUNCTION && expr2 == NULL)
11980 : {
11981 203 : expr2 = expr1;
11982 : /* Find the ss for the lhs. */
11983 203 : lss = loop->ss;
11984 406 : for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
11985 406 : if (lss->info->expr && lss->info->expr->expr_type == EXPR_VARIABLE)
11986 : break;
11987 203 : if (lss == gfc_ss_terminator)
11988 : return NULL_TREE;
11989 203 : expr1 = lss->info->expr;
11990 : }
11991 :
11992 : /* Bail out if this is not a valid allocate on assignment. */
11993 6788 : if (!gfc_is_reallocatable_lhs (expr1)
11994 6788 : || (expr2 && !expr2->rank))
11995 : return NULL_TREE;
11996 :
11997 : /* Find the ss for the lhs. */
11998 6788 : lss = loop->ss;
11999 16844 : for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
12000 16844 : if (lss->info->expr == expr1)
12001 : break;
12002 :
12003 6788 : if (lss == gfc_ss_terminator)
12004 : return NULL_TREE;
12005 :
12006 6788 : linfo = &lss->info->data.array;
12007 :
12008 : /* Find an ss for the rhs. For operator expressions, we see the
12009 : ss's for the operands. Any one of these will do. */
12010 6788 : rss = loop->ss;
12011 7392 : for (; rss && rss != gfc_ss_terminator; rss = rss->loop_chain)
12012 7392 : if (rss->info->expr != expr1 && rss != loop->temp_ss)
12013 : break;
12014 :
12015 6788 : if (expr2 && rss == gfc_ss_terminator)
12016 : return NULL_TREE;
12017 :
12018 : /* Ensure that the string length from the current scope is used. */
12019 6788 : if (expr2->ts.type == BT_CHARACTER
12020 1013 : && expr2->expr_type == EXPR_FUNCTION
12021 130 : && !expr2->value.function.isym)
12022 21 : expr2->ts.u.cl->backend_decl = rss->info->string_length;
12023 :
12024 : /* Since the lhs is allocatable, this must be a descriptor type.
12025 : Get the data and array size. */
12026 6788 : desc = linfo->descriptor;
12027 6788 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
12028 6788 : array1 = gfc_conv_descriptor_data_get (desc);
12029 :
12030 : /* If the data is null, set the descriptor bounds and offset. This suppresses
12031 : the maybe used uninitialized warning. Note that the always false variable
12032 : prevents this block from ever being executed, and makes sure that the
12033 : optimizers are able to remove it. Component references are not subject to
12034 : the warnings, so we don't uselessly complicate the generated code for them.
12035 : */
12036 12086 : for (ref = expr1->ref; ref; ref = ref->next)
12037 7025 : if (ref->type == REF_COMPONENT)
12038 : break;
12039 :
12040 6788 : if (!ref)
12041 : {
12042 5061 : stmtblock_t unalloc_init_block;
12043 5061 : gfc_init_block (&unalloc_init_block);
12044 5061 : tree guard = gfc_create_var (logical_type_node, "unallocated_init_guard");
12045 5061 : gfc_add_modify (&unalloc_init_block, guard, logical_false_node);
12046 :
12047 5061 : gfc_start_block (&loop_pre_block);
12048 18037 : for (n = 0; n < expr1->rank; n++)
12049 : {
12050 7915 : gfc_conv_descriptor_lbound_set (&loop_pre_block, desc,
12051 : gfc_rank_cst[n],
12052 : gfc_index_one_node);
12053 7915 : gfc_conv_descriptor_ubound_set (&loop_pre_block, desc,
12054 : gfc_rank_cst[n],
12055 : gfc_index_zero_node);
12056 7915 : gfc_conv_descriptor_stride_set (&loop_pre_block, desc,
12057 : gfc_rank_cst[n],
12058 : gfc_index_zero_node);
12059 : }
12060 :
12061 5061 : gfc_conv_descriptor_offset_set (&loop_pre_block, desc,
12062 : gfc_index_zero_node);
12063 :
12064 5061 : tmp = fold_build2_loc (input_location, EQ_EXPR,
12065 : logical_type_node, array1,
12066 5061 : build_int_cst (TREE_TYPE (array1), 0));
12067 5061 : tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
12068 : logical_type_node, tmp, guard);
12069 5061 : tmp = build3_v (COND_EXPR, tmp,
12070 : gfc_finish_block (&loop_pre_block),
12071 : build_empty_stmt (input_location));
12072 5061 : gfc_prepend_expr_to_block (&loop->pre, tmp);
12073 5061 : gfc_prepend_expr_to_block (&loop->pre,
12074 : gfc_finish_block (&unalloc_init_block));
12075 : }
12076 :
12077 6788 : gfc_start_block (&fblock);
12078 :
12079 6788 : if (expr2)
12080 6788 : desc2 = rss->info->data.array.descriptor;
12081 : else
12082 : desc2 = NULL_TREE;
12083 :
12084 : /* Get the old lhs element size for deferred character and class expr1. */
12085 6788 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12086 : {
12087 687 : if (expr1->ts.u.cl->backend_decl
12088 687 : && VAR_P (expr1->ts.u.cl->backend_decl))
12089 : elemsize1 = expr1->ts.u.cl->backend_decl;
12090 : else
12091 70 : elemsize1 = lss->info->string_length;
12092 687 : tree unit_size = TYPE_SIZE_UNIT (gfc_get_char_type (expr1->ts.kind));
12093 1374 : elemsize1 = fold_build2_loc (input_location, MULT_EXPR,
12094 687 : TREE_TYPE (elemsize1), elemsize1,
12095 687 : fold_convert (TREE_TYPE (elemsize1), unit_size));
12096 :
12097 687 : }
12098 6101 : else if (expr1->ts.type == BT_CLASS)
12099 : {
12100 : /* Unfortunately, the lhs vptr is set too early in many cases.
12101 : Play it safe by using the descriptor element length. */
12102 669 : tmp = gfc_conv_descriptor_elem_len_get (desc);
12103 669 : elemsize1 = fold_convert (gfc_array_index_type, tmp);
12104 : }
12105 : else
12106 : elemsize1 = NULL_TREE;
12107 1356 : if (elemsize1 != NULL_TREE)
12108 1356 : elemsize1 = gfc_evaluate_now (elemsize1, &fblock);
12109 :
12110 : /* Get the new lhs size in bytes. */
12111 6788 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12112 : {
12113 687 : if (expr2->ts.deferred)
12114 : {
12115 183 : if (expr2->ts.u.cl->backend_decl
12116 183 : && VAR_P (expr2->ts.u.cl->backend_decl))
12117 : tmp = expr2->ts.u.cl->backend_decl;
12118 : else
12119 0 : tmp = rss->info->string_length;
12120 : }
12121 : else
12122 : {
12123 504 : tmp = expr2->ts.u.cl->backend_decl;
12124 504 : if (!tmp && expr2->expr_type == EXPR_OP
12125 25 : && expr2->value.op.op == INTRINSIC_CONCAT)
12126 : {
12127 25 : tmp = concat_str_length (expr2);
12128 25 : expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
12129 : }
12130 12 : else if (!tmp && expr2->ts.u.cl->length)
12131 : {
12132 12 : gfc_se tmpse;
12133 12 : gfc_init_se (&tmpse, NULL);
12134 12 : gfc_conv_expr_type (&tmpse, expr2->ts.u.cl->length,
12135 : gfc_charlen_type_node);
12136 12 : tmp = tmpse.expr;
12137 12 : expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
12138 : }
12139 504 : tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
12140 : }
12141 :
12142 687 : if (expr1->ts.u.cl->backend_decl
12143 687 : && VAR_P (expr1->ts.u.cl->backend_decl))
12144 617 : gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
12145 : else
12146 70 : gfc_add_modify (&fblock, lss->info->string_length, tmp);
12147 :
12148 687 : if (expr1->ts.kind > 1)
12149 12 : tmp = fold_build2_loc (input_location, MULT_EXPR,
12150 6 : TREE_TYPE (tmp),
12151 6 : tmp, build_int_cst (TREE_TYPE (tmp),
12152 6 : expr1->ts.kind));
12153 : }
12154 6101 : else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
12155 : {
12156 277 : tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts)));
12157 277 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
12158 : fold_convert (gfc_array_index_type, tmp),
12159 277 : expr1->ts.u.cl->backend_decl);
12160 : }
12161 5824 : else if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS)
12162 164 : tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
12163 5660 : else if (expr1->ts.type == BT_CLASS && expr2->ts.type == BT_CLASS)
12164 : {
12165 298 : tmp = expr2->rank ? gfc_get_class_from_expr (desc2) : NULL_TREE;
12166 298 : if (tmp == NULL_TREE && expr2->expr_type == EXPR_VARIABLE)
12167 54 : tmp = class_expr2 = gfc_get_class_from_gfc_expr (expr2);
12168 :
12169 61 : if (tmp != NULL_TREE)
12170 291 : tmp = gfc_class_vtab_size_get (tmp);
12171 : else
12172 7 : tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&CLASS_DATA (expr2)->ts));
12173 : }
12174 : else
12175 5362 : tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
12176 6788 : elemsize2 = fold_convert (gfc_array_index_type, tmp);
12177 6788 : elemsize2 = gfc_evaluate_now (elemsize2, &fblock);
12178 :
12179 : /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
12180 : deallocated if expr is an array of different shape or any of the
12181 : corresponding length type parameter values of variable and expr
12182 : differ." This assures F95 compatibility. */
12183 6788 : jump_label1 = gfc_build_label_decl (NULL_TREE);
12184 6788 : jump_label2 = gfc_build_label_decl (NULL_TREE);
12185 :
12186 : /* Allocate if data is NULL. */
12187 6788 : cond_null = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
12188 6788 : array1, build_int_cst (TREE_TYPE (array1), 0));
12189 6788 : cond_null= gfc_evaluate_now (cond_null, &fblock);
12190 :
12191 6788 : tmp = build3_v (COND_EXPR, cond_null,
12192 : build1_v (GOTO_EXPR, jump_label1),
12193 : build_empty_stmt (input_location));
12194 6788 : gfc_add_expr_to_block (&fblock, tmp);
12195 :
12196 : /* Get arrayspec if expr is a full array. */
12197 6788 : if (expr2 && expr2->expr_type == EXPR_FUNCTION
12198 2814 : && expr2->value.function.isym
12199 2295 : && expr2->value.function.isym->conversion)
12200 : {
12201 : /* For conversion functions, take the arg. */
12202 245 : gfc_expr *arg = expr2->value.function.actual->expr;
12203 245 : as = gfc_get_full_arrayspec_from_expr (arg);
12204 245 : }
12205 : else if (expr2)
12206 6543 : as = gfc_get_full_arrayspec_from_expr (expr2);
12207 : else
12208 : as = NULL;
12209 :
12210 : /* If the lhs shape is not the same as the rhs jump to setting the
12211 : bounds and doing the reallocation....... */
12212 16787 : for (n = 0; n < expr1->rank; n++)
12213 : {
12214 : /* Check the shape. */
12215 9999 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
12216 9999 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
12217 9999 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
12218 : gfc_array_index_type,
12219 : loop->to[n], loop->from[n]);
12220 9999 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
12221 : gfc_array_index_type,
12222 : tmp, lbound);
12223 9999 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
12224 : gfc_array_index_type,
12225 : tmp, ubound);
12226 9999 : cond = fold_build2_loc (input_location, NE_EXPR,
12227 : logical_type_node,
12228 : tmp, gfc_index_zero_node);
12229 9999 : tmp = build3_v (COND_EXPR, cond,
12230 : build1_v (GOTO_EXPR, jump_label1),
12231 : build_empty_stmt (input_location));
12232 9999 : gfc_add_expr_to_block (&fblock, tmp);
12233 : }
12234 :
12235 : /* ...else if the element lengths are not the same also go to
12236 : setting the bounds and doing the reallocation.... */
12237 6788 : if (elemsize1 != NULL_TREE)
12238 : {
12239 1356 : cond = fold_build2_loc (input_location, NE_EXPR,
12240 : logical_type_node,
12241 : elemsize1, elemsize2);
12242 1356 : tmp = build3_v (COND_EXPR, cond,
12243 : build1_v (GOTO_EXPR, jump_label1),
12244 : build_empty_stmt (input_location));
12245 1356 : gfc_add_expr_to_block (&fblock, tmp);
12246 : }
12247 :
12248 : /* ....else jump past the (re)alloc code. */
12249 6788 : tmp = build1_v (GOTO_EXPR, jump_label2);
12250 6788 : gfc_add_expr_to_block (&fblock, tmp);
12251 :
12252 : /* Add the label to start automatic (re)allocation. */
12253 6788 : tmp = build1_v (LABEL_EXPR, jump_label1);
12254 6788 : gfc_add_expr_to_block (&fblock, tmp);
12255 :
12256 : /* Get the rhs size and fix it. */
12257 6788 : size2 = gfc_index_one_node;
12258 16787 : for (n = 0; n < expr2->rank; n++)
12259 : {
12260 9999 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
12261 : gfc_array_index_type,
12262 : loop->to[n], loop->from[n]);
12263 9999 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
12264 : gfc_array_index_type,
12265 : tmp, gfc_index_one_node);
12266 9999 : size2 = fold_build2_loc (input_location, MULT_EXPR,
12267 : gfc_array_index_type,
12268 : tmp, size2);
12269 : }
12270 6788 : size2 = gfc_evaluate_now (size2, &fblock);
12271 :
12272 : /* Deallocation of allocatable components will have to occur on
12273 : reallocation. Fix the old descriptor now. */
12274 6788 : if ((expr1->ts.type == BT_DERIVED)
12275 441 : && expr1->ts.u.derived->attr.alloc_comp)
12276 200 : old_desc = gfc_evaluate_now (desc, &fblock);
12277 : else
12278 : old_desc = NULL_TREE;
12279 :
12280 : /* Now modify the lhs descriptor and the associated scalarizer
12281 : variables. F2003 7.4.1.3: "If variable is or becomes an
12282 : unallocated allocatable variable, then it is allocated with each
12283 : deferred type parameter equal to the corresponding type parameters
12284 : of expr , with the shape of expr , and with each lower bound equal
12285 : to the corresponding element of LBOUND(expr)."
12286 : Reuse size1 to keep a dimension-by-dimension track of the
12287 : stride of the new array. */
12288 6788 : size1 = gfc_index_one_node;
12289 6788 : offset = gfc_index_zero_node;
12290 :
12291 16787 : for (n = 0; n < expr2->rank; n++)
12292 : {
12293 9999 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
12294 : gfc_array_index_type,
12295 : loop->to[n], loop->from[n]);
12296 9999 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
12297 : gfc_array_index_type,
12298 : tmp, gfc_index_one_node);
12299 :
12300 9999 : lbound = gfc_index_one_node;
12301 9999 : ubound = tmp;
12302 :
12303 9999 : if (as)
12304 : {
12305 2180 : lbd = get_std_lbound (expr2, desc2, n,
12306 1090 : as->type == AS_ASSUMED_SIZE);
12307 1090 : ubound = fold_build2_loc (input_location,
12308 : MINUS_EXPR,
12309 : gfc_array_index_type,
12310 : ubound, lbound);
12311 1090 : ubound = fold_build2_loc (input_location,
12312 : PLUS_EXPR,
12313 : gfc_array_index_type,
12314 : ubound, lbd);
12315 1090 : lbound = lbd;
12316 : }
12317 :
12318 9999 : gfc_conv_descriptor_lbound_set (&fblock, desc,
12319 : gfc_rank_cst[n],
12320 : lbound);
12321 9999 : gfc_conv_descriptor_ubound_set (&fblock, desc,
12322 : gfc_rank_cst[n],
12323 : ubound);
12324 9999 : gfc_conv_descriptor_stride_set (&fblock, desc,
12325 : gfc_rank_cst[n],
12326 : size1);
12327 9999 : lbound = gfc_conv_descriptor_lbound_get (desc,
12328 : gfc_rank_cst[n]);
12329 9999 : tmp2 = fold_build2_loc (input_location, MULT_EXPR,
12330 : gfc_array_index_type,
12331 : lbound, size1);
12332 9999 : offset = fold_build2_loc (input_location, MINUS_EXPR,
12333 : gfc_array_index_type,
12334 : offset, tmp2);
12335 9999 : size1 = fold_build2_loc (input_location, MULT_EXPR,
12336 : gfc_array_index_type,
12337 : tmp, size1);
12338 : }
12339 :
12340 : /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
12341 : the array offset is saved and the info.offset is used for a
12342 : running offset. Use the saved_offset instead. */
12343 6788 : gfc_conv_descriptor_offset_set (&fblock, desc, offset);
12344 :
12345 : /* Take into account _len of unlimited polymorphic entities, so that span
12346 : for array descriptors and allocation sizes are computed correctly. */
12347 6788 : if (UNLIMITED_POLY (expr2))
12348 : {
12349 110 : tree len = gfc_class_len_get (TREE_OPERAND (desc2, 0));
12350 110 : len = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
12351 : fold_convert (size_type_node, len),
12352 : size_one_node);
12353 110 : elemsize2 = fold_build2_loc (input_location, MULT_EXPR,
12354 : gfc_array_index_type, elemsize2,
12355 : fold_convert (gfc_array_index_type, len));
12356 : }
12357 :
12358 6788 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
12359 6788 : gfc_conv_descriptor_span_set (&fblock, desc, elemsize2);
12360 :
12361 6788 : size2 = fold_build2_loc (input_location, MULT_EXPR,
12362 : gfc_array_index_type,
12363 : elemsize2, size2);
12364 6788 : size2 = fold_convert (size_type_node, size2);
12365 6788 : size2 = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
12366 : size2, size_one_node);
12367 6788 : size2 = gfc_evaluate_now (size2, &fblock);
12368 :
12369 : /* For deferred character length, the 'size' field of the dtype might
12370 : have changed so set the dtype. */
12371 6788 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
12372 6788 : && expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12373 : {
12374 687 : tree type;
12375 687 : if (expr2->ts.u.cl->backend_decl)
12376 687 : type = gfc_typenode_for_spec (&expr2->ts);
12377 : else
12378 0 : type = gfc_typenode_for_spec (&expr1->ts);
12379 :
12380 687 : gfc_conv_descriptor_dtype_set (&fblock, desc,
12381 : gfc_get_dtype_rank_type (expr1->rank,
12382 : type));
12383 : }
12384 6101 : else if (expr1->ts.type == BT_CLASS)
12385 : {
12386 669 : tree type;
12387 :
12388 669 : if (expr2->ts.type != BT_CLASS)
12389 371 : type = gfc_typenode_for_spec (&expr2->ts);
12390 : else
12391 298 : type = gfc_get_character_type_len (1, elemsize2);
12392 :
12393 669 : gfc_conv_descriptor_dtype_set (&fblock, desc,
12394 : gfc_get_dtype_rank_type (expr2->rank,
12395 : type));
12396 :
12397 : /* Set the _len field as well... */
12398 669 : if (UNLIMITED_POLY (expr1))
12399 : {
12400 274 : tmp = gfc_class_len_get (TREE_OPERAND (desc, 0));
12401 274 : if (expr2->ts.type == BT_CHARACTER)
12402 49 : gfc_add_modify (&fblock, tmp,
12403 49 : fold_convert (TREE_TYPE (tmp),
12404 : TYPE_SIZE_UNIT (type)));
12405 225 : else if (UNLIMITED_POLY (expr2))
12406 110 : gfc_add_modify (&fblock, tmp,
12407 110 : gfc_class_len_get (TREE_OPERAND (desc2, 0)));
12408 : else
12409 115 : gfc_add_modify (&fblock, tmp,
12410 115 : build_int_cst (TREE_TYPE (tmp), 0));
12411 : }
12412 : /* ...and the vptr. */
12413 669 : tmp = gfc_class_vptr_get (TREE_OPERAND (desc, 0));
12414 669 : if (expr2->ts.type == BT_CLASS && !VAR_P (desc2)
12415 291 : && TREE_CODE (desc2) == COMPONENT_REF)
12416 : {
12417 237 : tmp2 = gfc_get_class_from_expr (desc2);
12418 237 : tmp2 = gfc_class_vptr_get (tmp2);
12419 : }
12420 432 : else if (expr2->ts.type == BT_CLASS && class_expr2 != NULL_TREE)
12421 54 : tmp2 = gfc_class_vptr_get (class_expr2);
12422 : else
12423 : {
12424 378 : tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts));
12425 378 : tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2);
12426 : }
12427 :
12428 669 : gfc_add_modify (&fblock, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
12429 : }
12430 5432 : else if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
12431 39 : gfc_conv_descriptor_dtype_set (&fblock, desc,
12432 39 : gfc_get_dtype (TREE_TYPE (desc)));
12433 :
12434 : /* Realloc expression. Note that the scalarizer uses desc.data
12435 : in the array reference - (*desc.data)[<element>]. */
12436 6788 : gfc_init_block (&realloc_block);
12437 6788 : gfc_init_se (&caf_se, NULL);
12438 :
12439 6788 : if (coarray)
12440 : {
12441 39 : token = gfc_get_ultimate_alloc_ptr_comps_caf_token (&caf_se, expr1);
12442 39 : if (token == NULL_TREE)
12443 : {
12444 9 : tmp = gfc_get_tree_for_caf_expr (expr1);
12445 9 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
12446 6 : tmp = build_fold_indirect_ref (tmp);
12447 9 : gfc_get_caf_token_offset (&caf_se, &token, NULL, tmp, NULL_TREE,
12448 : expr1);
12449 9 : token = gfc_build_addr_expr (NULL_TREE, token);
12450 : }
12451 :
12452 39 : gfc_add_block_to_block (&realloc_block, &caf_se.pre);
12453 : }
12454 6788 : if ((expr1->ts.type == BT_DERIVED)
12455 441 : && expr1->ts.u.derived->attr.alloc_comp)
12456 : {
12457 200 : tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, old_desc,
12458 : expr1->rank, true);
12459 200 : gfc_add_expr_to_block (&realloc_block, tmp);
12460 : }
12461 :
12462 6788 : if (!coarray)
12463 : {
12464 6749 : tmp = build_call_expr_loc (input_location,
12465 : builtin_decl_explicit (BUILT_IN_REALLOC), 2,
12466 : fold_convert (pvoid_type_node, array1),
12467 : size2);
12468 6749 : if (flag_openmp_allocators)
12469 : {
12470 2 : tree cond, omp_tmp;
12471 2 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
12472 : gfc_conv_descriptor_version_get (desc),
12473 : integer_one_node);
12474 2 : omp_tmp = builtin_decl_explicit (BUILT_IN_GOMP_REALLOC);
12475 2 : omp_tmp = build_call_expr_loc (input_location, omp_tmp, 4,
12476 : fold_convert (pvoid_type_node, array1), size2,
12477 : build_zero_cst (ptr_type_node),
12478 : build_zero_cst (ptr_type_node));
12479 2 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond,
12480 : omp_tmp, tmp);
12481 : }
12482 :
12483 6749 : gfc_conv_descriptor_data_set (&realloc_block, desc, tmp);
12484 : }
12485 : else
12486 : {
12487 39 : tmp = build_call_expr_loc (input_location,
12488 : gfor_fndecl_caf_deregister, 5, token,
12489 : build_int_cst (integer_type_node,
12490 : GFC_CAF_COARRAY_DEALLOCATE_ONLY),
12491 : null_pointer_node, null_pointer_node,
12492 : integer_zero_node);
12493 39 : gfc_add_expr_to_block (&realloc_block, tmp);
12494 39 : tmp = build_call_expr_loc (input_location,
12495 : gfor_fndecl_caf_register,
12496 : 7, size2,
12497 : build_int_cst (integer_type_node,
12498 : GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY),
12499 : token, gfc_build_addr_expr (NULL_TREE, desc),
12500 : null_pointer_node, null_pointer_node,
12501 : integer_zero_node);
12502 39 : gfc_add_expr_to_block (&realloc_block, tmp);
12503 : }
12504 :
12505 6788 : if ((expr1->ts.type == BT_DERIVED)
12506 441 : && expr1->ts.u.derived->attr.alloc_comp)
12507 : {
12508 200 : tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc,
12509 : expr1->rank);
12510 200 : gfc_add_expr_to_block (&realloc_block, tmp);
12511 : }
12512 :
12513 6788 : gfc_add_block_to_block (&realloc_block, &caf_se.post);
12514 6788 : realloc_expr = gfc_finish_block (&realloc_block);
12515 :
12516 : /* Malloc expression. */
12517 6788 : gfc_init_block (&alloc_block);
12518 6788 : if (!coarray)
12519 : {
12520 6749 : tmp = build_call_expr_loc (input_location,
12521 : builtin_decl_explicit (BUILT_IN_MALLOC),
12522 : 1, size2);
12523 6749 : gfc_conv_descriptor_data_set (&alloc_block,
12524 : desc, tmp);
12525 : }
12526 : else
12527 : {
12528 39 : tmp = build_call_expr_loc (input_location,
12529 : gfor_fndecl_caf_register,
12530 : 7, size2,
12531 : build_int_cst (integer_type_node,
12532 : GFC_CAF_COARRAY_ALLOC),
12533 : token, gfc_build_addr_expr (NULL_TREE, desc),
12534 : null_pointer_node, null_pointer_node,
12535 : integer_zero_node);
12536 39 : gfc_add_expr_to_block (&alloc_block, tmp);
12537 : }
12538 :
12539 :
12540 : /* We already set the dtype in the case of deferred character
12541 : length arrays and class lvalues. */
12542 6788 : if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
12543 6788 : && ((expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12544 6101 : || coarray))
12545 12850 : && expr1->ts.type != BT_CLASS)
12546 5393 : gfc_conv_descriptor_dtype_set (&alloc_block, desc,
12547 5393 : gfc_get_dtype (TREE_TYPE (desc)));
12548 :
12549 6788 : if ((expr1->ts.type == BT_DERIVED)
12550 441 : && expr1->ts.u.derived->attr.alloc_comp)
12551 : {
12552 200 : tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc,
12553 : expr1->rank);
12554 200 : gfc_add_expr_to_block (&alloc_block, tmp);
12555 : }
12556 6788 : alloc_expr = gfc_finish_block (&alloc_block);
12557 :
12558 : /* Malloc if not allocated; realloc otherwise. */
12559 6788 : tmp = build3_v (COND_EXPR, cond_null, alloc_expr, realloc_expr);
12560 6788 : gfc_add_expr_to_block (&fblock, tmp);
12561 :
12562 : /* Add the label for same shape lhs and rhs. */
12563 6788 : tmp = build1_v (LABEL_EXPR, jump_label2);
12564 6788 : gfc_add_expr_to_block (&fblock, tmp);
12565 :
12566 6788 : tree realloc_code = gfc_finish_block (&fblock);
12567 :
12568 6788 : stmtblock_t result_block;
12569 6788 : gfc_init_block (&result_block);
12570 6788 : gfc_add_expr_to_block (&result_block, realloc_code);
12571 6788 : update_reallocated_descriptor (&result_block, loop);
12572 :
12573 6788 : return gfc_finish_block (&result_block);
12574 : }
12575 :
12576 :
12577 : /* Initialize class descriptor's TKR information. */
12578 :
12579 : void
12580 3118 : gfc_trans_class_array (gfc_symbol * sym, gfc_wrapped_block * block)
12581 : {
12582 3118 : tree type, etype;
12583 3118 : tree descriptor;
12584 3118 : stmtblock_t init;
12585 3118 : int rank;
12586 :
12587 : /* Make sure the frontend gets these right. */
12588 3118 : gcc_assert (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
12589 : && (CLASS_DATA (sym)->attr.class_pointer
12590 : || CLASS_DATA (sym)->attr.allocatable));
12591 :
12592 3118 : gcc_assert (VAR_P (sym->backend_decl)
12593 : || TREE_CODE (sym->backend_decl) == PARM_DECL);
12594 :
12595 3118 : if (sym->attr.dummy)
12596 1514 : return;
12597 :
12598 3118 : descriptor = gfc_class_data_get (sym->backend_decl);
12599 3118 : type = TREE_TYPE (descriptor);
12600 :
12601 3118 : if (type == NULL || !GFC_DESCRIPTOR_TYPE_P (type))
12602 : return;
12603 :
12604 1604 : location_t loc = input_location;
12605 1604 : input_location = gfc_get_location (&sym->declared_at);
12606 1604 : gfc_init_block (&init);
12607 :
12608 1604 : rank = CLASS_DATA (sym)->as ? (CLASS_DATA (sym)->as->rank) : (0);
12609 1604 : gcc_assert (rank>=0);
12610 1604 : etype = gfc_get_element_type (type);
12611 1604 : gfc_conv_descriptor_dtype_set (&init, descriptor,
12612 : gfc_get_dtype_rank_type (rank, etype));
12613 :
12614 1604 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
12615 1604 : input_location = loc;
12616 : }
12617 :
12618 :
12619 : /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
12620 : Do likewise, recursively if necessary, with the allocatable components of
12621 : derived types. This function is also called for assumed-rank arrays, which
12622 : are always dummy arguments. */
12623 :
12624 : void
12625 18505 : gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
12626 : {
12627 18505 : tree type;
12628 18505 : tree tmp;
12629 18505 : tree descriptor;
12630 18505 : stmtblock_t init;
12631 18505 : stmtblock_t cleanup;
12632 18505 : int rank;
12633 18505 : bool sym_has_alloc_comp, has_finalizer;
12634 :
12635 37010 : sym_has_alloc_comp = (sym->ts.type == BT_DERIVED
12636 11051 : || sym->ts.type == BT_CLASS)
12637 18505 : && sym->ts.u.derived->attr.alloc_comp;
12638 18505 : has_finalizer = gfc_may_be_finalized (sym->ts);
12639 :
12640 : /* Make sure the frontend gets these right. */
12641 18505 : gcc_assert (sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp
12642 : || has_finalizer
12643 : || (sym->as->type == AS_ASSUMED_RANK && sym->attr.dummy));
12644 :
12645 18505 : location_t loc = input_location;
12646 18505 : input_location = gfc_get_location (&sym->declared_at);
12647 18505 : gfc_init_block (&init);
12648 :
12649 18505 : gcc_assert (VAR_P (sym->backend_decl)
12650 : || TREE_CODE (sym->backend_decl) == PARM_DECL);
12651 :
12652 18505 : if (sym->ts.type == BT_CHARACTER
12653 1420 : && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
12654 : {
12655 836 : if (sym->ts.deferred && !sym->ts.u.cl->length && !sym->attr.dummy)
12656 : {
12657 625 : tree len_expr = sym->ts.u.cl->backend_decl;
12658 625 : tree init_val = build_zero_cst (TREE_TYPE (len_expr));
12659 625 : if (VAR_P (len_expr)
12660 625 : && sym->attr.save
12661 680 : && !DECL_INITIAL (len_expr))
12662 55 : DECL_INITIAL (len_expr) = init_val;
12663 : else
12664 570 : gfc_add_modify (&init, len_expr, init_val);
12665 : }
12666 836 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
12667 836 : gfc_trans_vla_type_sizes (sym, &init);
12668 :
12669 : /* Presence check of optional deferred-length character dummy. */
12670 836 : if (sym->ts.deferred && sym->attr.dummy && sym->attr.optional)
12671 : {
12672 43 : tmp = gfc_finish_block (&init);
12673 43 : tmp = build3_v (COND_EXPR, gfc_conv_expr_present (sym),
12674 : tmp, build_empty_stmt (input_location));
12675 43 : gfc_add_expr_to_block (&init, tmp);
12676 : }
12677 : }
12678 :
12679 : /* Dummy, use associated and result variables don't need anything special. */
12680 18505 : if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result)
12681 : {
12682 930 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
12683 930 : input_location = loc;
12684 1206 : return;
12685 : }
12686 :
12687 17575 : descriptor = sym->backend_decl;
12688 :
12689 : /* Although static, derived types with default initializers and
12690 : allocatable components must not be nulled wholesale; instead they
12691 : are treated component by component. */
12692 17575 : if (TREE_STATIC (descriptor) && !sym_has_alloc_comp && !has_finalizer)
12693 : {
12694 : /* SAVEd variables are not freed on exit. */
12695 276 : gfc_trans_static_array_pointer (sym);
12696 :
12697 276 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
12698 276 : input_location = loc;
12699 276 : return;
12700 : }
12701 :
12702 : /* Get the descriptor type. */
12703 17299 : type = TREE_TYPE (sym->backend_decl);
12704 :
12705 17299 : if ((sym_has_alloc_comp || (has_finalizer && sym->ts.type != BT_CLASS))
12706 5786 : && !(sym->attr.pointer || sym->attr.allocatable))
12707 : {
12708 3012 : if (!sym->attr.save
12709 2603 : && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program))
12710 : {
12711 2603 : if (sym->value == NULL
12712 2603 : || !gfc_has_default_initializer (sym->ts.u.derived))
12713 : {
12714 2141 : rank = sym->as ? sym->as->rank : 0;
12715 2141 : tmp = gfc_nullify_alloc_comp (sym->ts.u.derived,
12716 : descriptor, rank);
12717 2141 : gfc_add_expr_to_block (&init, tmp);
12718 : }
12719 : else
12720 462 : gfc_init_default_dt (sym, &init, false);
12721 : }
12722 : }
12723 14287 : else if (!GFC_DESCRIPTOR_TYPE_P (type))
12724 : {
12725 : /* If the backend_decl is not a descriptor, we must have a pointer
12726 : to one. */
12727 2183 : descriptor = build_fold_indirect_ref_loc (input_location,
12728 : sym->backend_decl);
12729 2183 : type = TREE_TYPE (descriptor);
12730 : }
12731 :
12732 : /* NULLIFY the data pointer for non-saved allocatables, or for non-saved
12733 : pointers when -fcheck=pointer is specified. */
12734 17299 : if (GFC_DESCRIPTOR_TYPE_P (type)
12735 17299 : && (sym->attr.allocatable || sym->attr.pointer))
12736 : {
12737 12104 : if (flag_coarray == GFC_FCOARRAY_LIB
12738 359 : && sym->attr.codimension
12739 185 : && !sym->attr.save)
12740 : {
12741 : /* Declare the variable static so its array descriptor stays present
12742 : after leaving the scope. It may still be accessed through another
12743 : image. This may happen, for example, with the caf_mpi
12744 : implementation. */
12745 185 : TREE_STATIC (descriptor) = 1;
12746 : }
12747 12104 : gfc_init_descriptor_variable (&init, sym, descriptor);
12748 : }
12749 :
12750 17299 : input_location = loc;
12751 17299 : gfc_init_block (&cleanup);
12752 :
12753 : /* Allocatable arrays need to be freed when they go out of scope.
12754 : The allocatable components of pointers must not be touched. */
12755 17299 : if (!sym->attr.allocatable && has_finalizer && sym->ts.type != BT_CLASS
12756 628 : && !sym->attr.pointer && !sym->attr.artificial && !sym->attr.save
12757 333 : && !sym->ns->proc_name->attr.is_main_program)
12758 : {
12759 294 : gfc_expr *e;
12760 294 : sym->attr.referenced = 1;
12761 294 : e = gfc_lval_expr_from_sym (sym);
12762 294 : gfc_add_finalizer_call (&cleanup, e);
12763 294 : gfc_free_expr (e);
12764 294 : }
12765 17005 : else if ((!sym->attr.allocatable || !has_finalizer)
12766 16881 : && sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
12767 5205 : && !sym->attr.pointer && !sym->attr.save
12768 2587 : && !(sym->attr.artificial && sym->name[0] == '_')
12769 2532 : && !sym->ns->proc_name->attr.is_main_program)
12770 : {
12771 688 : int rank;
12772 688 : rank = sym->as ? sym->as->rank : 0;
12773 688 : tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank,
12774 688 : (sym->attr.codimension
12775 3 : && flag_coarray == GFC_FCOARRAY_LIB)
12776 : ? GFC_STRUCTURE_CAF_MODE_IN_COARRAY
12777 : : 0);
12778 688 : gfc_add_expr_to_block (&cleanup, tmp);
12779 : }
12780 :
12781 17299 : if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension)
12782 8783 : && !sym->attr.save && !sym->attr.result
12783 8776 : && !sym->ns->proc_name->attr.is_main_program)
12784 : {
12785 4572 : gfc_expr *e;
12786 4572 : e = has_finalizer ? gfc_lval_expr_from_sym (sym) : NULL;
12787 9144 : tmp = gfc_deallocate_with_status (sym->backend_decl, NULL_TREE, NULL_TREE,
12788 : NULL_TREE, NULL_TREE, true, e,
12789 4572 : sym->attr.codimension
12790 : ? GFC_CAF_COARRAY_DEREGISTER
12791 : : GFC_CAF_COARRAY_NOCOARRAY,
12792 : NULL_TREE, gfc_finish_block (&cleanup));
12793 4572 : if (e)
12794 45 : gfc_free_expr (e);
12795 4572 : gfc_init_block (&cleanup);
12796 4572 : gfc_add_expr_to_block (&cleanup, tmp);
12797 : }
12798 :
12799 17299 : gfc_add_init_cleanup (block, gfc_finish_block (&init),
12800 : gfc_finish_block (&cleanup));
12801 : }
12802 :
12803 : /************ Expression Walking Functions ******************/
12804 :
12805 : /* Walk a variable reference.
12806 :
12807 : Possible extension - multiple component subscripts.
12808 : x(:,:) = foo%a(:)%b(:)
12809 : Transforms to
12810 : forall (i=..., j=...)
12811 : x(i,j) = foo%a(j)%b(i)
12812 : end forall
12813 : This adds a fair amount of complexity because you need to deal with more
12814 : than one ref. Maybe handle in a similar manner to vector subscripts.
12815 : Maybe not worth the effort. */
12816 :
12817 :
12818 : static gfc_ss *
12819 700470 : gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
12820 : {
12821 700470 : gfc_ref *ref;
12822 :
12823 700470 : gfc_fix_class_refs (expr);
12824 :
12825 820058 : for (ref = expr->ref; ref; ref = ref->next)
12826 457132 : if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
12827 : break;
12828 :
12829 700470 : return gfc_walk_array_ref (ss, expr, ref);
12830 : }
12831 :
12832 : gfc_ss *
12833 700951 : gfc_walk_array_ref (gfc_ss *ss, gfc_expr *expr, gfc_ref *ref, bool array_only)
12834 : {
12835 700951 : gfc_array_ref *ar;
12836 700951 : gfc_ss *newss;
12837 700951 : int n;
12838 :
12839 1048981 : for (; ref; ref = ref->next)
12840 : {
12841 348030 : if (ref->type == REF_SUBSTRING)
12842 : {
12843 1314 : ss = gfc_get_scalar_ss (ss, ref->u.ss.start);
12844 1314 : if (ref->u.ss.end)
12845 1288 : ss = gfc_get_scalar_ss (ss, ref->u.ss.end);
12846 : }
12847 :
12848 : /* We're only interested in array sections from now on. */
12849 348030 : if (ref->type != REF_ARRAY
12850 338421 : || (array_only && ref->u.ar.as && ref->u.ar.as->rank == 0))
12851 9724 : continue;
12852 :
12853 338306 : ar = &ref->u.ar;
12854 :
12855 338306 : switch (ar->type)
12856 : {
12857 326 : case AR_ELEMENT:
12858 699 : for (n = ar->dimen - 1; n >= 0; n--)
12859 373 : ss = gfc_get_scalar_ss (ss, ar->start[n]);
12860 : break;
12861 :
12862 280986 : case AR_FULL:
12863 : /* Assumed shape arrays from interface mapping need this fix. */
12864 280986 : if (!ar->as && expr->symtree->n.sym->as)
12865 : {
12866 6 : ar->as = gfc_get_array_spec();
12867 6 : *ar->as = *expr->symtree->n.sym->as;
12868 : }
12869 280986 : newss = gfc_get_array_ss (ss, expr, ar->as->rank, GFC_SS_SECTION);
12870 280986 : newss->info->data.array.ref = ref;
12871 :
12872 : /* Make sure array is the same as array(:,:), this way
12873 : we don't need to special case all the time. */
12874 280986 : ar->dimen = ar->as->rank;
12875 644302 : for (n = 0; n < ar->dimen; n++)
12876 : {
12877 363316 : ar->dimen_type[n] = DIMEN_RANGE;
12878 :
12879 363316 : gcc_assert (ar->start[n] == NULL);
12880 363316 : gcc_assert (ar->end[n] == NULL);
12881 363316 : gcc_assert (ar->stride[n] == NULL);
12882 : }
12883 : ss = newss;
12884 : break;
12885 :
12886 56994 : case AR_SECTION:
12887 56994 : newss = gfc_get_array_ss (ss, expr, 0, GFC_SS_SECTION);
12888 56994 : newss->info->data.array.ref = ref;
12889 :
12890 : /* We add SS chains for all the subscripts in the section. */
12891 146527 : for (n = 0; n < ar->dimen; n++)
12892 : {
12893 89533 : gfc_ss *indexss;
12894 :
12895 89533 : switch (ar->dimen_type[n])
12896 : {
12897 6925 : case DIMEN_ELEMENT:
12898 : /* Add SS for elemental (scalar) subscripts. */
12899 6925 : gcc_assert (ar->start[n]);
12900 6925 : indexss = gfc_get_scalar_ss (gfc_ss_terminator, ar->start[n]);
12901 6925 : indexss->loop_chain = gfc_ss_terminator;
12902 6925 : newss->info->data.array.subscript[n] = indexss;
12903 6925 : break;
12904 :
12905 81562 : case DIMEN_RANGE:
12906 : /* We don't add anything for sections, just remember this
12907 : dimension for later. */
12908 81562 : newss->dim[newss->dimen] = n;
12909 81562 : newss->dimen++;
12910 81562 : break;
12911 :
12912 1046 : case DIMEN_VECTOR:
12913 : /* Create a GFC_SS_VECTOR index in which we can store
12914 : the vector's descriptor. */
12915 1046 : indexss = gfc_get_array_ss (gfc_ss_terminator, ar->start[n],
12916 : 1, GFC_SS_VECTOR);
12917 1046 : indexss->loop_chain = gfc_ss_terminator;
12918 1046 : newss->info->data.array.subscript[n] = indexss;
12919 1046 : newss->dim[newss->dimen] = n;
12920 1046 : newss->dimen++;
12921 1046 : break;
12922 :
12923 0 : default:
12924 : /* We should know what sort of section it is by now. */
12925 0 : gcc_unreachable ();
12926 : }
12927 : }
12928 : /* We should have at least one non-elemental dimension,
12929 : unless we are creating a descriptor for a (scalar) coarray. */
12930 56994 : gcc_assert (newss->dimen > 0
12931 : || newss->info->data.array.ref->u.ar.as->corank > 0);
12932 : ss = newss;
12933 : break;
12934 :
12935 0 : default:
12936 : /* We should know what sort of section it is by now. */
12937 0 : gcc_unreachable ();
12938 : }
12939 :
12940 : }
12941 700951 : return ss;
12942 : }
12943 :
12944 :
12945 : /* Walk an expression operator. If only one operand of a binary expression is
12946 : scalar, we must also add the scalar term to the SS chain. */
12947 :
12948 : static gfc_ss *
12949 58853 : gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
12950 : {
12951 58853 : gfc_ss *head;
12952 58853 : gfc_ss *head2;
12953 :
12954 58853 : head = gfc_walk_subexpr (ss, expr->value.op.op1);
12955 58853 : if (expr->value.op.op2 == NULL)
12956 : head2 = head;
12957 : else
12958 56156 : head2 = gfc_walk_subexpr (head, expr->value.op.op2);
12959 :
12960 : /* All operands are scalar. Pass back and let the caller deal with it. */
12961 58853 : if (head2 == ss)
12962 : return head2;
12963 :
12964 : /* All operands require scalarization. */
12965 53017 : if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
12966 : return head2;
12967 :
12968 : /* One of the operands needs scalarization, the other is scalar.
12969 : Create a gfc_ss for the scalar expression. */
12970 19640 : if (head == ss)
12971 : {
12972 : /* First operand is scalar. We build the chain in reverse order, so
12973 : add the scalar SS after the second operand. */
12974 : head = head2;
12975 2292 : while (head && head->next != ss)
12976 : head = head->next;
12977 : /* Check we haven't somehow broken the chain. */
12978 2049 : gcc_assert (head);
12979 2049 : head->next = gfc_get_scalar_ss (ss, expr->value.op.op1);
12980 : }
12981 : else /* head2 == head */
12982 : {
12983 17591 : gcc_assert (head2 == head);
12984 : /* Second operand is scalar. */
12985 17591 : head2 = gfc_get_scalar_ss (head2, expr->value.op.op2);
12986 : }
12987 :
12988 : return head2;
12989 : }
12990 :
12991 : static gfc_ss *
12992 36 : gfc_walk_conditional_expr (gfc_ss *ss, gfc_expr *expr)
12993 : {
12994 36 : gfc_ss *head;
12995 :
12996 36 : head = gfc_walk_subexpr (ss, expr->value.conditional.true_expr);
12997 36 : head = gfc_walk_subexpr (head, expr->value.conditional.false_expr);
12998 36 : return head;
12999 : }
13000 :
13001 : /* Reverse a SS chain. */
13002 :
13003 : gfc_ss *
13004 878682 : gfc_reverse_ss (gfc_ss * ss)
13005 : {
13006 878682 : gfc_ss *next;
13007 878682 : gfc_ss *head;
13008 :
13009 878682 : gcc_assert (ss != NULL);
13010 :
13011 : head = gfc_ss_terminator;
13012 1327813 : while (ss != gfc_ss_terminator)
13013 : {
13014 449131 : next = ss->next;
13015 : /* Check we didn't somehow break the chain. */
13016 449131 : gcc_assert (next != NULL);
13017 449131 : ss->next = head;
13018 449131 : head = ss;
13019 449131 : ss = next;
13020 : }
13021 :
13022 878682 : return (head);
13023 : }
13024 :
13025 :
13026 : /* Given an expression referring to a procedure, return the symbol of its
13027 : interface. We can't get the procedure symbol directly as we have to handle
13028 : the case of (deferred) type-bound procedures. */
13029 :
13030 : gfc_symbol *
13031 161 : gfc_get_proc_ifc_for_expr (gfc_expr *procedure_ref)
13032 : {
13033 161 : gfc_symbol *sym;
13034 161 : gfc_ref *ref;
13035 :
13036 161 : if (procedure_ref == NULL)
13037 : return NULL;
13038 :
13039 : /* Normal procedure case. */
13040 161 : if (procedure_ref->expr_type == EXPR_FUNCTION
13041 161 : && procedure_ref->value.function.esym)
13042 : sym = procedure_ref->value.function.esym;
13043 : else
13044 24 : sym = procedure_ref->symtree->n.sym;
13045 :
13046 : /* Typebound procedure case. */
13047 209 : for (ref = procedure_ref->ref; ref; ref = ref->next)
13048 : {
13049 48 : if (ref->type == REF_COMPONENT
13050 48 : && ref->u.c.component->attr.proc_pointer)
13051 24 : sym = ref->u.c.component->ts.interface;
13052 : else
13053 : sym = NULL;
13054 : }
13055 :
13056 : return sym;
13057 : }
13058 :
13059 :
13060 : /* Given an expression referring to an intrinsic function call,
13061 : return the intrinsic symbol. */
13062 :
13063 : gfc_intrinsic_sym *
13064 7970 : gfc_get_intrinsic_for_expr (gfc_expr *call)
13065 : {
13066 7970 : if (call == NULL)
13067 : return NULL;
13068 :
13069 : /* Normal procedure case. */
13070 2372 : if (call->expr_type == EXPR_FUNCTION)
13071 2266 : return call->value.function.isym;
13072 : else
13073 : return NULL;
13074 : }
13075 :
13076 :
13077 : /* Indicates whether an argument to an intrinsic function should be used in
13078 : scalarization. It is usually the case, except for some intrinsics
13079 : requiring the value to be constant, and using the value at compile time only.
13080 : As the value is not used at runtime in those cases, we don’t produce code
13081 : for it, and it should not be visible to the scalarizer.
13082 : FUNCTION is the intrinsic function being called, ACTUAL_ARG is the actual
13083 : argument being examined in that call, and ARG_NUM the index number
13084 : of ACTUAL_ARG in the list of arguments.
13085 : The intrinsic procedure’s dummy argument associated with ACTUAL_ARG is
13086 : identified using the name in ACTUAL_ARG if it is present (that is: if it’s
13087 : a keyword argument), otherwise using ARG_NUM. */
13088 :
13089 : static bool
13090 38133 : arg_evaluated_for_scalarization (gfc_intrinsic_sym *function,
13091 : gfc_dummy_arg *dummy_arg)
13092 : {
13093 38133 : if (function != NULL && dummy_arg != NULL)
13094 : {
13095 12497 : switch (function->id)
13096 : {
13097 241 : case GFC_ISYM_INDEX:
13098 241 : case GFC_ISYM_LEN_TRIM:
13099 241 : case GFC_ISYM_MASKL:
13100 241 : case GFC_ISYM_MASKR:
13101 241 : case GFC_ISYM_SCAN:
13102 241 : case GFC_ISYM_VERIFY:
13103 241 : if (strcmp ("kind", gfc_dummy_arg_get_name (*dummy_arg)) == 0)
13104 33 : return false;
13105 : /* Fallthrough. */
13106 :
13107 : default:
13108 : break;
13109 : }
13110 : }
13111 :
13112 : return true;
13113 : }
13114 :
13115 :
13116 : /* Walk the arguments of an elemental function.
13117 : PROC_EXPR is used to check whether an argument is permitted to be absent. If
13118 : it is NULL, we don't do the check and the argument is assumed to be present.
13119 : */
13120 :
13121 : gfc_ss *
13122 27108 : gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
13123 : gfc_intrinsic_sym *intrinsic_sym,
13124 : gfc_ss_type type)
13125 : {
13126 27108 : int scalar;
13127 27108 : gfc_ss *head;
13128 27108 : gfc_ss *tail;
13129 27108 : gfc_ss *newss;
13130 :
13131 27108 : head = gfc_ss_terminator;
13132 27108 : tail = NULL;
13133 :
13134 27108 : scalar = 1;
13135 66711 : for (; arg; arg = arg->next)
13136 : {
13137 39603 : gfc_dummy_arg * const dummy_arg = arg->associated_dummy;
13138 41106 : if (!arg->expr
13139 38283 : || arg->expr->expr_type == EXPR_NULL
13140 77736 : || !arg_evaluated_for_scalarization (intrinsic_sym, dummy_arg))
13141 1503 : continue;
13142 :
13143 38100 : newss = gfc_walk_subexpr (head, arg->expr);
13144 38100 : if (newss == head)
13145 : {
13146 : /* Scalar argument. */
13147 18617 : gcc_assert (type == GFC_SS_SCALAR || type == GFC_SS_REFERENCE);
13148 18617 : newss = gfc_get_scalar_ss (head, arg->expr);
13149 18617 : newss->info->type = type;
13150 18617 : if (dummy_arg)
13151 15469 : newss->info->data.scalar.dummy_arg = dummy_arg;
13152 : }
13153 : else
13154 : scalar = 0;
13155 :
13156 34952 : if (dummy_arg != NULL
13157 26468 : && gfc_dummy_arg_is_optional (*dummy_arg)
13158 2544 : && arg->expr->expr_type == EXPR_VARIABLE
13159 36662 : && (gfc_expr_attr (arg->expr).optional
13160 1199 : || gfc_expr_attr (arg->expr).allocatable
13161 38100 : || gfc_expr_attr (arg->expr).pointer))
13162 1023 : newss->info->can_be_null_ref = true;
13163 :
13164 38100 : head = newss;
13165 38100 : if (!tail)
13166 : {
13167 : tail = head;
13168 33838 : while (tail->next != gfc_ss_terminator)
13169 : tail = tail->next;
13170 : }
13171 : }
13172 :
13173 27108 : if (scalar)
13174 : {
13175 : /* If all the arguments are scalar we don't need the argument SS. */
13176 10397 : gfc_free_ss_chain (head);
13177 : /* Pass it back. */
13178 10397 : return ss;
13179 : }
13180 :
13181 : /* Add it onto the existing chain. */
13182 16711 : tail->next = ss;
13183 16711 : return head;
13184 : }
13185 :
13186 :
13187 : /* Walk a function call. Scalar functions are passed back, and taken out of
13188 : scalarization loops. For elemental functions we walk their arguments.
13189 : The result of functions returning arrays is stored in a temporary outside
13190 : the loop, so that the function is only called once. Hence we do not need
13191 : to walk their arguments. */
13192 :
13193 : static gfc_ss *
13194 64212 : gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
13195 : {
13196 64212 : gfc_intrinsic_sym *isym;
13197 64212 : gfc_symbol *sym;
13198 64212 : gfc_component *comp = NULL;
13199 :
13200 64212 : isym = expr->value.function.isym;
13201 :
13202 : /* Handle intrinsic functions separately. */
13203 64212 : if (isym)
13204 56148 : return gfc_walk_intrinsic_function (ss, expr, isym);
13205 :
13206 8064 : sym = expr->value.function.esym;
13207 8064 : if (!sym)
13208 546 : sym = expr->symtree->n.sym;
13209 :
13210 8064 : if (gfc_is_class_array_function (expr))
13211 234 : return gfc_get_array_ss (ss, expr,
13212 234 : CLASS_DATA (expr->value.function.esym->result)->as->rank,
13213 234 : GFC_SS_FUNCTION);
13214 :
13215 : /* A function that returns arrays. */
13216 7830 : comp = gfc_get_proc_ptr_comp (expr);
13217 7432 : if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
13218 7830 : || (comp && comp->attr.dimension))
13219 3004 : return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
13220 :
13221 : /* Walk the parameters of an elemental function. For now we always pass
13222 : by reference. */
13223 4826 : if (sym->attr.elemental || (comp && comp->attr.elemental))
13224 : {
13225 2230 : gfc_ss *old_ss = ss;
13226 :
13227 2230 : ss = gfc_walk_elemental_function_args (old_ss,
13228 : expr->value.function.actual,
13229 : gfc_get_intrinsic_for_expr (expr),
13230 : GFC_SS_REFERENCE);
13231 2230 : if (ss != old_ss
13232 1194 : && (comp
13233 1133 : || sym->attr.proc_pointer
13234 1133 : || sym->attr.if_source != IFSRC_DECL
13235 1011 : || sym->attr.array_outer_dependency))
13236 231 : ss->info->array_outer_dependency = 1;
13237 : }
13238 :
13239 : /* Scalar functions are OK as these are evaluated outside the scalarization
13240 : loop. Pass back and let the caller deal with it. */
13241 : return ss;
13242 : }
13243 :
13244 :
13245 : /* An array temporary is constructed for array constructors. */
13246 :
13247 : static gfc_ss *
13248 51851 : gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
13249 : {
13250 0 : return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_CONSTRUCTOR);
13251 : }
13252 :
13253 :
13254 : /* Walk an expression. Add walked expressions to the head of the SS chain.
13255 : A wholly scalar expression will not be added. */
13256 :
13257 : gfc_ss *
13258 1035955 : gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
13259 : {
13260 1035955 : gfc_ss *head;
13261 :
13262 1035955 : switch (expr->expr_type)
13263 : {
13264 700470 : case EXPR_VARIABLE:
13265 700470 : head = gfc_walk_variable_expr (ss, expr);
13266 700470 : return head;
13267 :
13268 58853 : case EXPR_OP:
13269 58853 : head = gfc_walk_op_expr (ss, expr);
13270 58853 : return head;
13271 :
13272 36 : case EXPR_CONDITIONAL:
13273 36 : head = gfc_walk_conditional_expr (ss, expr);
13274 36 : return head;
13275 :
13276 64212 : case EXPR_FUNCTION:
13277 64212 : head = gfc_walk_function_expr (ss, expr);
13278 64212 : return head;
13279 :
13280 : case EXPR_CONSTANT:
13281 : case EXPR_NULL:
13282 : case EXPR_STRUCTURE:
13283 : /* Pass back and let the caller deal with it. */
13284 : break;
13285 :
13286 51851 : case EXPR_ARRAY:
13287 51851 : head = gfc_walk_array_constructor (ss, expr);
13288 51851 : return head;
13289 :
13290 : case EXPR_SUBSTRING:
13291 : /* Pass back and let the caller deal with it. */
13292 : break;
13293 :
13294 0 : default:
13295 0 : gfc_internal_error ("bad expression type during walk (%d)",
13296 : expr->expr_type);
13297 : }
13298 : return ss;
13299 : }
13300 :
13301 :
13302 : /* Entry point for expression walking.
13303 : A return value equal to the passed chain means this is
13304 : a scalar expression. It is up to the caller to take whatever action is
13305 : necessary to translate these. */
13306 :
13307 : gfc_ss *
13308 875745 : gfc_walk_expr (gfc_expr * expr)
13309 : {
13310 875745 : gfc_ss *res;
13311 :
13312 875745 : res = gfc_walk_subexpr (gfc_ss_terminator, expr);
13313 875745 : return gfc_reverse_ss (res);
13314 : }
|
