Line data Source code
1 : /* Array translation routines
2 : Copyright (C) 2002-2026 Free Software Foundation, Inc.
3 : Contributed by Paul Brook <paul@nowt.org>
4 : and Steven Bosscher <s.bosscher@student.tudelft.nl>
5 :
6 : This file is part of GCC.
7 :
8 : GCC is free software; you can redistribute it and/or modify it under
9 : the terms of the GNU General Public License as published by the Free
10 : Software Foundation; either version 3, or (at your option) any later
11 : version.
12 :
13 : GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 : WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 : FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
16 : for more details.
17 :
18 : You should have received a copy of the GNU General Public License
19 : along with GCC; see the file COPYING3. If not see
20 : <http://www.gnu.org/licenses/>. */
21 :
22 : /* trans-array.cc-- Various array related code, including scalarization,
23 : allocation, initialization and other support routines. */
24 :
25 : /* How the scalarizer works.
26 : In gfortran, array expressions use the same core routines as scalar
27 : expressions.
28 : First, a Scalarization State (SS) chain is built. This is done by walking
29 : the expression tree, and building a linear list of the terms in the
30 : expression. As the tree is walked, scalar subexpressions are translated.
31 :
32 : The scalarization parameters are stored in a gfc_loopinfo structure.
33 : First the start and stride of each term is calculated by
34 : gfc_conv_ss_startstride. During this process the expressions for the array
35 : descriptors and data pointers are also translated.
36 :
37 : If the expression is an assignment, we must then resolve any dependencies.
38 : In Fortran all the rhs values of an assignment must be evaluated before
39 : any assignments take place. This can require a temporary array to store the
40 : values. We also require a temporary when we are passing array expressions
41 : or vector subscripts as procedure parameters.
42 :
43 : Array sections are passed without copying to a temporary. These use the
44 : scalarizer to determine the shape of the section. The flag
45 : loop->array_parameter tells the scalarizer that the actual values and loop
46 : variables will not be required.
47 :
48 : The function gfc_conv_loop_setup generates the scalarization setup code.
49 : It determines the range of the scalarizing loop variables. If a temporary
50 : is required, this is created and initialized. Code for scalar expressions
51 : taken outside the loop is also generated at this time. Next the offset and
52 : scaling required to translate from loop variables to array indices for each
53 : term is calculated.
54 :
55 : A call to gfc_start_scalarized_body marks the start of the scalarized
56 : expression. This creates a scope and declares the loop variables. Before
57 : calling this gfc_make_ss_chain_used must be used to indicate which terms
58 : will be used inside this loop.
59 :
60 : The scalar gfc_conv_* functions are then used to build the main body of the
61 : scalarization loop. Scalarization loop variables and precalculated scalar
62 : values are automatically substituted. Note that gfc_advance_se_ss_chain
63 : must be used, rather than changing the se->ss directly.
64 :
65 : For assignment expressions requiring a temporary two sub loops are
66 : generated. The first stores the result of the expression in the temporary,
67 : the second copies it to the result. A call to
68 : gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
69 : the start of the copying loop. The temporary may be less than full rank.
70 :
71 : Finally gfc_trans_scalarizing_loops is called to generate the implicit do
72 : loops. The loops are added to the pre chain of the loopinfo. The post
73 : chain may still contain cleanup code.
74 :
75 : After the loop code has been added into its parent scope gfc_cleanup_loop
76 : is called to free all the SS allocated by the scalarizer. */
77 :
78 : #include "config.h"
79 : #include "system.h"
80 : #include "coretypes.h"
81 : #include "options.h"
82 : #include "tree.h"
83 : #include "gfortran.h"
84 : #include "gimple-expr.h"
85 : #include "tree-iterator.h"
86 : #include "stringpool.h" /* Required by "attribs.h". */
87 : #include "attribs.h" /* For lookup_attribute. */
88 : #include "trans.h"
89 : #include "fold-const.h"
90 : #include "constructor.h"
91 : #include "trans-types.h"
92 : #include "trans-array.h"
93 : #include "trans-const.h"
94 : #include "dependency.h"
95 : #include "trans-descriptor.h"
96 : #include "cgraph.h" /* For cgraph_node::add_new_function. */
97 : #include "function.h" /* For push_struct_function. */
98 :
99 : static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor_base);
100 :
101 : /* The contents of this structure aren't actually used, just the address. */
102 : static gfc_ss gfc_ss_terminator_var;
103 : gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var;
104 :
105 :
106 : static tree
107 59611 : gfc_array_dataptr_type (tree desc)
108 : {
109 59611 : return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
110 : }
111 :
112 : /* Build expressions to access members of the CFI descriptor. */
113 : #define CFI_FIELD_BASE_ADDR 0
114 : #define CFI_FIELD_ELEM_LEN 1
115 : #define CFI_FIELD_VERSION 2
116 : #define CFI_FIELD_RANK 3
117 : #define CFI_FIELD_ATTRIBUTE 4
118 : #define CFI_FIELD_TYPE 5
119 : #define CFI_FIELD_DIM 6
120 :
121 : #define CFI_DIM_FIELD_LOWER_BOUND 0
122 : #define CFI_DIM_FIELD_EXTENT 1
123 : #define CFI_DIM_FIELD_SM 2
124 :
125 : static tree
126 84943 : gfc_get_cfi_descriptor_field (tree desc, unsigned field_idx)
127 : {
128 84943 : tree type = TREE_TYPE (desc);
129 84943 : gcc_assert (TREE_CODE (type) == RECORD_TYPE
130 : && TYPE_FIELDS (type)
131 : && (strcmp ("base_addr",
132 : IDENTIFIER_POINTER (DECL_NAME (TYPE_FIELDS (type))))
133 : == 0));
134 84943 : tree field = gfc_advance_chain (TYPE_FIELDS (type), field_idx);
135 84943 : gcc_assert (field != NULL_TREE);
136 :
137 84943 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
138 84943 : desc, field, NULL_TREE);
139 : }
140 :
141 : tree
142 14201 : gfc_get_cfi_desc_base_addr (tree desc)
143 : {
144 14201 : return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_BASE_ADDR);
145 : }
146 :
147 : tree
148 10681 : gfc_get_cfi_desc_elem_len (tree desc)
149 : {
150 10681 : return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_ELEM_LEN);
151 : }
152 :
153 : tree
154 7191 : gfc_get_cfi_desc_version (tree desc)
155 : {
156 7191 : return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_VERSION);
157 : }
158 :
159 : tree
160 7816 : gfc_get_cfi_desc_rank (tree desc)
161 : {
162 7816 : return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_RANK);
163 : }
164 :
165 : tree
166 7283 : gfc_get_cfi_desc_type (tree desc)
167 : {
168 7283 : return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_TYPE);
169 : }
170 :
171 : tree
172 7191 : gfc_get_cfi_desc_attribute (tree desc)
173 : {
174 7191 : return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_ATTRIBUTE);
175 : }
176 :
177 : static tree
178 30580 : gfc_get_cfi_dim_item (tree desc, tree idx, unsigned field_idx)
179 : {
180 30580 : tree tmp = gfc_get_cfi_descriptor_field (desc, CFI_FIELD_DIM);
181 30580 : tmp = gfc_build_array_ref (tmp, idx, NULL_TREE, true);
182 30580 : tree field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), field_idx);
183 30580 : gcc_assert (field != NULL_TREE);
184 30580 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
185 30580 : tmp, field, NULL_TREE);
186 : }
187 :
188 : tree
189 6786 : gfc_get_cfi_dim_lbound (tree desc, tree idx)
190 : {
191 6786 : return gfc_get_cfi_dim_item (desc, idx, CFI_DIM_FIELD_LOWER_BOUND);
192 : }
193 :
194 : tree
195 11926 : gfc_get_cfi_dim_extent (tree desc, tree idx)
196 : {
197 11926 : return gfc_get_cfi_dim_item (desc, idx, CFI_DIM_FIELD_EXTENT);
198 : }
199 :
200 : tree
201 11868 : gfc_get_cfi_dim_sm (tree desc, tree idx)
202 : {
203 11868 : return gfc_get_cfi_dim_item (desc, idx, CFI_DIM_FIELD_SM);
204 : }
205 :
206 : #undef CFI_FIELD_BASE_ADDR
207 : #undef CFI_FIELD_ELEM_LEN
208 : #undef CFI_FIELD_VERSION
209 : #undef CFI_FIELD_RANK
210 : #undef CFI_FIELD_ATTRIBUTE
211 : #undef CFI_FIELD_TYPE
212 : #undef CFI_FIELD_DIM
213 :
214 : #undef CFI_DIM_FIELD_LOWER_BOUND
215 : #undef CFI_DIM_FIELD_EXTENT
216 : #undef CFI_DIM_FIELD_SM
217 :
218 :
219 : /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
220 : flags & 1 = Main loop body.
221 : flags & 2 = temp copy loop. */
222 :
223 : void
224 173740 : gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
225 : {
226 408344 : for (; ss != gfc_ss_terminator; ss = ss->next)
227 234604 : ss->info->useflags = flags;
228 173740 : }
229 :
230 :
231 : /* Free a gfc_ss chain. */
232 :
233 : void
234 182626 : gfc_free_ss_chain (gfc_ss * ss)
235 : {
236 182626 : gfc_ss *next;
237 :
238 373470 : while (ss != gfc_ss_terminator)
239 : {
240 190844 : gcc_assert (ss != NULL);
241 190844 : next = ss->next;
242 190844 : gfc_free_ss (ss);
243 190844 : ss = next;
244 : }
245 182626 : }
246 :
247 :
248 : static void
249 495867 : free_ss_info (gfc_ss_info *ss_info)
250 : {
251 495867 : int n;
252 :
253 495867 : ss_info->refcount--;
254 495867 : if (ss_info->refcount > 0)
255 : return;
256 :
257 491120 : gcc_assert (ss_info->refcount == 0);
258 :
259 491120 : switch (ss_info->type)
260 : {
261 : case GFC_SS_SECTION:
262 5452704 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
263 5111910 : if (ss_info->data.array.subscript[n])
264 7755 : gfc_free_ss_chain (ss_info->data.array.subscript[n]);
265 : break;
266 :
267 : default:
268 : break;
269 : }
270 :
271 491120 : free (ss_info);
272 : }
273 :
274 :
275 : /* Free a SS. */
276 :
277 : void
278 495867 : gfc_free_ss (gfc_ss * ss)
279 : {
280 495867 : free_ss_info (ss->info);
281 495867 : free (ss);
282 495867 : }
283 :
284 :
285 : /* Creates and initializes an array type gfc_ss struct. */
286 :
287 : gfc_ss *
288 414844 : gfc_get_array_ss (gfc_ss *next, gfc_expr *expr, int dimen, gfc_ss_type type)
289 : {
290 414844 : gfc_ss *ss;
291 414844 : gfc_ss_info *ss_info;
292 414844 : int i;
293 :
294 414844 : ss_info = gfc_get_ss_info ();
295 414844 : ss_info->refcount++;
296 414844 : ss_info->type = type;
297 414844 : ss_info->expr = expr;
298 :
299 414844 : ss = gfc_get_ss ();
300 414844 : ss->info = ss_info;
301 414844 : ss->next = next;
302 414844 : ss->dimen = dimen;
303 874120 : for (i = 0; i < ss->dimen; i++)
304 459276 : ss->dim[i] = i;
305 :
306 414844 : return ss;
307 : }
308 :
309 :
310 : /* Creates and initializes a temporary type gfc_ss struct. */
311 :
312 : gfc_ss *
313 11384 : gfc_get_temp_ss (tree type, tree string_length, int dimen)
314 : {
315 11384 : gfc_ss *ss;
316 11384 : gfc_ss_info *ss_info;
317 11384 : int i;
318 :
319 11384 : ss_info = gfc_get_ss_info ();
320 11384 : ss_info->refcount++;
321 11384 : ss_info->type = GFC_SS_TEMP;
322 11384 : ss_info->string_length = string_length;
323 11384 : ss_info->data.temp.type = type;
324 :
325 11384 : ss = gfc_get_ss ();
326 11384 : ss->info = ss_info;
327 11384 : ss->next = gfc_ss_terminator;
328 11384 : ss->dimen = dimen;
329 25489 : for (i = 0; i < ss->dimen; i++)
330 14105 : ss->dim[i] = i;
331 :
332 11384 : return ss;
333 : }
334 :
335 :
336 : /* Creates and initializes a scalar type gfc_ss struct. */
337 :
338 : gfc_ss *
339 66957 : gfc_get_scalar_ss (gfc_ss *next, gfc_expr *expr)
340 : {
341 66957 : gfc_ss *ss;
342 66957 : gfc_ss_info *ss_info;
343 :
344 66957 : ss_info = gfc_get_ss_info ();
345 66957 : ss_info->refcount++;
346 66957 : ss_info->type = GFC_SS_SCALAR;
347 66957 : ss_info->expr = expr;
348 :
349 66957 : ss = gfc_get_ss ();
350 66957 : ss->info = ss_info;
351 66957 : ss->next = next;
352 :
353 66957 : return ss;
354 : }
355 :
356 :
357 : /* Free all the SS associated with a loop. */
358 :
359 : void
360 184131 : gfc_cleanup_loop (gfc_loopinfo * loop)
361 : {
362 184131 : gfc_loopinfo *loop_next, **ploop;
363 184131 : gfc_ss *ss;
364 184131 : gfc_ss *next;
365 :
366 184131 : ss = loop->ss;
367 488775 : while (ss != gfc_ss_terminator)
368 : {
369 304644 : gcc_assert (ss != NULL);
370 304644 : next = ss->loop_chain;
371 304644 : gfc_free_ss (ss);
372 304644 : ss = next;
373 : }
374 :
375 : /* Remove reference to self in the parent loop. */
376 184131 : if (loop->parent)
377 3364 : for (ploop = &loop->parent->nested; *ploop; ploop = &(*ploop)->next)
378 3364 : if (*ploop == loop)
379 : {
380 3364 : *ploop = loop->next;
381 3364 : break;
382 : }
383 :
384 : /* Free non-freed nested loops. */
385 187495 : for (loop = loop->nested; loop; loop = loop_next)
386 : {
387 3364 : loop_next = loop->next;
388 3364 : gfc_cleanup_loop (loop);
389 3364 : free (loop);
390 : }
391 184131 : }
392 :
393 :
394 : static void
395 250387 : set_ss_loop (gfc_ss *ss, gfc_loopinfo *loop)
396 : {
397 250387 : int n;
398 :
399 564135 : for (; ss != gfc_ss_terminator; ss = ss->next)
400 : {
401 313748 : ss->loop = loop;
402 :
403 313748 : if (ss->info->type == GFC_SS_SCALAR
404 : || ss->info->type == GFC_SS_REFERENCE
405 264903 : || ss->info->type == GFC_SS_TEMP)
406 60229 : continue;
407 :
408 4056304 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
409 3802785 : if (ss->info->data.array.subscript[n] != NULL)
410 7486 : set_ss_loop (ss->info->data.array.subscript[n], loop);
411 : }
412 250387 : }
413 :
414 :
415 : /* Associate a SS chain with a loop. */
416 :
417 : void
418 242901 : gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
419 : {
420 242901 : gfc_ss *ss;
421 242901 : gfc_loopinfo *nested_loop;
422 :
423 242901 : if (head == gfc_ss_terminator)
424 : return;
425 :
426 242901 : set_ss_loop (head, loop);
427 :
428 242901 : ss = head;
429 792064 : for (; ss && ss != gfc_ss_terminator; ss = ss->next)
430 : {
431 306262 : if (ss->nested_ss)
432 : {
433 4740 : nested_loop = ss->nested_ss->loop;
434 :
435 : /* More than one ss can belong to the same loop. Hence, we add the
436 : loop to the chain only if it is different from the previously
437 : added one, to avoid duplicate nested loops. */
438 4740 : if (nested_loop != loop->nested)
439 : {
440 3364 : gcc_assert (nested_loop->parent == NULL);
441 3364 : nested_loop->parent = loop;
442 :
443 3364 : gcc_assert (nested_loop->next == NULL);
444 3364 : nested_loop->next = loop->nested;
445 3364 : loop->nested = nested_loop;
446 : }
447 : else
448 1376 : gcc_assert (nested_loop->parent == loop);
449 : }
450 :
451 306262 : if (ss->next == gfc_ss_terminator)
452 242901 : ss->loop_chain = loop->ss;
453 : else
454 63361 : ss->loop_chain = ss->next;
455 : }
456 242901 : gcc_assert (ss == gfc_ss_terminator);
457 242901 : loop->ss = head;
458 : }
459 :
460 :
461 : /* Returns true if the expression is an array pointer. */
462 :
463 : static bool
464 370861 : is_pointer_array (tree expr)
465 : {
466 370861 : if (expr == NULL_TREE
467 370861 : || !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr))
468 468658 : || GFC_CLASS_TYPE_P (TREE_TYPE (expr)))
469 : return false;
470 :
471 97797 : if (VAR_P (expr)
472 97797 : && GFC_DECL_PTR_ARRAY_P (expr))
473 : return true;
474 :
475 91386 : if (TREE_CODE (expr) == PARM_DECL
476 91386 : && GFC_DECL_PTR_ARRAY_P (expr))
477 : return true;
478 :
479 91386 : if (INDIRECT_REF_P (expr)
480 91386 : && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 0)))
481 : return true;
482 :
483 : /* The field declaration is marked as an pointer array. */
484 88957 : if (TREE_CODE (expr) == COMPONENT_REF
485 15901 : && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 1))
486 92130 : && !GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (expr, 1))))
487 3173 : return true;
488 :
489 : return false;
490 : }
491 :
492 :
493 : /* If the symbol or expression reference a CFI descriptor, return the
494 : pointer to the converted gfc descriptor. If an array reference is
495 : present as the last argument, check that it is the one applied to
496 : the CFI descriptor in the expression. Note that the CFI object is
497 : always the symbol in the expression! */
498 :
499 : static bool
500 373587 : get_CFI_desc (gfc_symbol *sym, gfc_expr *expr,
501 : tree *desc, gfc_array_ref *ar)
502 : {
503 373587 : tree tmp;
504 :
505 373587 : if (!is_CFI_desc (sym, expr))
506 : return false;
507 :
508 4727 : if (expr && ar)
509 : {
510 4061 : if (!(expr->ref && expr->ref->type == REF_ARRAY)
511 4043 : || (&expr->ref->u.ar != ar))
512 : return false;
513 : }
514 :
515 4697 : if (sym == NULL)
516 1108 : tmp = expr->symtree->n.sym->backend_decl;
517 : else
518 3589 : tmp = sym->backend_decl;
519 :
520 4697 : if (tmp && DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp))
521 0 : tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
522 :
523 4697 : *desc = tmp;
524 4697 : return true;
525 : }
526 :
527 :
528 : /* A helper function for gfc_get_array_span that returns the array element size
529 : of a class entity. */
530 : static tree
531 1143 : class_array_element_size (tree decl, bool unlimited)
532 : {
533 : /* Class dummys usually require extraction from the saved descriptor,
534 : which gfc_class_vptr_get does for us if necessary. This, of course,
535 : will be a component of the class object. */
536 1143 : tree vptr = gfc_class_vptr_get (decl);
537 : /* If this is an unlimited polymorphic entity with a character payload,
538 : the element size will be corrected for the string length. */
539 1143 : if (unlimited)
540 1034 : return gfc_resize_class_size_with_len (NULL,
541 517 : TREE_OPERAND (vptr, 0),
542 517 : gfc_vptr_size_get (vptr));
543 : else
544 626 : return gfc_vptr_size_get (vptr);
545 : }
546 :
547 :
548 : /* Return the span of an array. */
549 :
550 : tree
551 58808 : gfc_get_array_span (tree desc, gfc_expr *expr)
552 : {
553 58808 : tree tmp;
554 58808 : gfc_symbol *sym = (expr && expr->expr_type == EXPR_VARIABLE) ?
555 51528 : expr->symtree->n.sym : NULL;
556 :
557 58808 : if (is_pointer_array (desc)
558 58808 : || (get_CFI_desc (NULL, expr, &desc, NULL)
559 1332 : && (POINTER_TYPE_P (TREE_TYPE (desc))
560 666 : ? GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (desc)))
561 0 : : GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))))
562 : {
563 558 : if (POINTER_TYPE_P (TREE_TYPE (desc)))
564 0 : desc = build_fold_indirect_ref_loc (input_location, desc);
565 :
566 : /* This will have the span field set. */
567 558 : tmp = gfc_conv_descriptor_span_get (desc);
568 : }
569 58250 : else if (expr->ts.type == BT_ASSUMED)
570 : {
571 127 : if (DECL_LANG_SPECIFIC (desc) && GFC_DECL_SAVED_DESCRIPTOR (desc))
572 127 : desc = GFC_DECL_SAVED_DESCRIPTOR (desc);
573 127 : if (POINTER_TYPE_P (TREE_TYPE (desc)))
574 127 : desc = build_fold_indirect_ref_loc (input_location, desc);
575 127 : tmp = gfc_conv_descriptor_span_get (desc);
576 : }
577 58123 : else if (TREE_CODE (desc) == COMPONENT_REF
578 562 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
579 58252 : && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (desc, 0))))
580 : /* The descriptor is the _data field of a class object. */
581 56 : tmp = class_array_element_size (TREE_OPERAND (desc, 0),
582 56 : UNLIMITED_POLY (expr));
583 58067 : else if (sym && sym->ts.type == BT_CLASS
584 1143 : && expr->ref->type == REF_COMPONENT
585 1143 : && expr->ref->next->type == REF_ARRAY
586 1143 : && expr->ref->next->next == NULL
587 1125 : && CLASS_DATA (sym)->attr.dimension)
588 : /* Having escaped the above, this can only be a class array dummy. */
589 1087 : tmp = class_array_element_size (sym->backend_decl,
590 1087 : UNLIMITED_POLY (sym));
591 : else
592 : {
593 : /* If none of the fancy stuff works, the span is the element
594 : size of the array. Attempt to deal with unbounded character
595 : types if possible. Otherwise, return NULL_TREE. */
596 56980 : tmp = gfc_get_element_type (TREE_TYPE (desc));
597 56980 : if (tmp && TREE_CODE (tmp) == ARRAY_TYPE && TYPE_STRING_FLAG (tmp))
598 : {
599 11089 : gcc_assert (expr->ts.type == BT_CHARACTER);
600 :
601 11089 : tmp = gfc_get_character_len_in_bytes (tmp);
602 :
603 11089 : if (tmp == NULL_TREE || integer_zerop (tmp))
604 : {
605 80 : tree bs;
606 :
607 80 : tmp = gfc_get_expr_charlen (expr);
608 80 : tmp = fold_convert (gfc_array_index_type, tmp);
609 80 : bs = build_int_cst (gfc_array_index_type, expr->ts.kind);
610 80 : tmp = fold_build2_loc (input_location, MULT_EXPR,
611 : gfc_array_index_type, tmp, bs);
612 : }
613 :
614 22098 : tmp = (tmp && !integer_zerop (tmp))
615 22098 : ? (fold_convert (gfc_array_index_type, tmp)) : (NULL_TREE);
616 : }
617 : else
618 45891 : tmp = fold_convert (gfc_array_index_type,
619 : size_in_bytes (tmp));
620 : }
621 58808 : return tmp;
622 : }
623 :
624 :
625 : /* Generate an initializer for a static pointer or allocatable array. */
626 :
627 : void
628 276 : gfc_trans_static_array_pointer (gfc_symbol * sym)
629 : {
630 276 : tree type;
631 :
632 276 : gcc_assert (TREE_STATIC (sym->backend_decl));
633 : /* Just zero the data member. */
634 276 : type = TREE_TYPE (sym->backend_decl);
635 276 : DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
636 276 : }
637 :
638 :
639 : /* If the bounds of SE's loop have not yet been set, see if they can be
640 : determined from array spec AS, which is the array spec of a called
641 : function. MAPPING maps the callee's dummy arguments to the values
642 : that the caller is passing. Add any initialization and finalization
643 : code to SE. */
644 :
645 : void
646 8737 : gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
647 : gfc_se * se, gfc_array_spec * as)
648 : {
649 8737 : int n, dim, total_dim;
650 8737 : gfc_se tmpse;
651 8737 : gfc_ss *ss;
652 8737 : tree lower;
653 8737 : tree upper;
654 8737 : tree tmp;
655 :
656 8737 : total_dim = 0;
657 :
658 8737 : if (!as || as->type != AS_EXPLICIT)
659 7576 : return;
660 :
661 2347 : for (ss = se->ss; ss; ss = ss->parent)
662 : {
663 1186 : total_dim += ss->loop->dimen;
664 2727 : for (n = 0; n < ss->loop->dimen; n++)
665 : {
666 : /* The bound is known, nothing to do. */
667 1541 : if (ss->loop->to[n] != NULL_TREE)
668 485 : continue;
669 :
670 1056 : dim = ss->dim[n];
671 1056 : gcc_assert (dim < as->rank);
672 1056 : gcc_assert (ss->loop->dimen <= as->rank);
673 :
674 : /* Evaluate the lower bound. */
675 1056 : gfc_init_se (&tmpse, NULL);
676 1056 : gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
677 1056 : gfc_add_block_to_block (&se->pre, &tmpse.pre);
678 1056 : gfc_add_block_to_block (&se->post, &tmpse.post);
679 1056 : lower = fold_convert (gfc_array_index_type, tmpse.expr);
680 :
681 : /* ...and the upper bound. */
682 1056 : gfc_init_se (&tmpse, NULL);
683 1056 : gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
684 1056 : gfc_add_block_to_block (&se->pre, &tmpse.pre);
685 1056 : gfc_add_block_to_block (&se->post, &tmpse.post);
686 1056 : upper = fold_convert (gfc_array_index_type, tmpse.expr);
687 :
688 : /* Set the upper bound of the loop to UPPER - LOWER. */
689 1056 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
690 : gfc_array_index_type, upper, lower);
691 1056 : tmp = gfc_evaluate_now (tmp, &se->pre);
692 1056 : ss->loop->to[n] = tmp;
693 : }
694 : }
695 :
696 1161 : gcc_assert (total_dim == as->rank);
697 : }
698 :
699 :
700 : /* Generate code to allocate an array temporary, or create a variable to
701 : hold the data. If size is NULL, zero the descriptor so that the
702 : callee will allocate the array. If DEALLOC is true, also generate code to
703 : free the array afterwards.
704 :
705 : If INITIAL is not NULL, it is packed using internal_pack and the result used
706 : as data instead of allocating a fresh, uninitialized area of memory.
707 :
708 : Initialization code is added to PRE and finalization code to POST.
709 : DYNAMIC is true if the caller may want to extend the array later
710 : using realloc. This prevents us from putting the array on the stack. */
711 :
712 : static void
713 27948 : gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
714 : gfc_array_info * info, tree size, tree nelem,
715 : tree initial, bool dynamic, bool dealloc)
716 : {
717 27948 : tree tmp;
718 27948 : tree desc;
719 27948 : bool onstack;
720 :
721 27948 : desc = info->descriptor;
722 27948 : info->offset = gfc_index_zero_node;
723 27948 : if (size == NULL_TREE || (dynamic && integer_zerop (size)))
724 : {
725 : /* A callee allocated array. */
726 2883 : gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
727 2883 : onstack = false;
728 : }
729 : else
730 : {
731 : /* Allocate the temporary. */
732 50130 : onstack = !dynamic && initial == NULL_TREE
733 25065 : && (flag_stack_arrays
734 24680 : || gfc_can_put_var_on_stack (size));
735 :
736 25065 : if (onstack)
737 : {
738 : /* Make a temporary variable to hold the data. */
739 19961 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (nelem),
740 : nelem, gfc_index_one_node);
741 19961 : tmp = gfc_evaluate_now (tmp, pre);
742 19961 : tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
743 : tmp);
744 19961 : tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
745 : tmp);
746 19961 : tmp = gfc_create_var (tmp, "A");
747 : /* If we're here only because of -fstack-arrays we have to
748 : emit a DECL_EXPR to make the gimplifier emit alloca calls. */
749 19961 : if (!gfc_can_put_var_on_stack (size))
750 17 : gfc_add_expr_to_block (pre,
751 : fold_build1_loc (input_location,
752 17 : DECL_EXPR, TREE_TYPE (tmp),
753 : tmp));
754 19961 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
755 19961 : gfc_conv_descriptor_data_set (pre, desc, tmp);
756 : }
757 : else
758 : {
759 : /* Allocate memory to hold the data or call internal_pack. */
760 5104 : if (initial == NULL_TREE)
761 : {
762 4961 : tmp = gfc_call_malloc (pre, NULL, size);
763 4961 : tmp = gfc_evaluate_now (tmp, pre);
764 : }
765 : else
766 : {
767 143 : tree packed;
768 143 : tree source_data;
769 143 : tree was_packed;
770 143 : stmtblock_t do_copying;
771 :
772 143 : tmp = TREE_TYPE (initial); /* Pointer to descriptor. */
773 143 : gcc_assert (TREE_CODE (tmp) == POINTER_TYPE);
774 143 : tmp = TREE_TYPE (tmp); /* The descriptor itself. */
775 143 : tmp = gfc_get_element_type (tmp);
776 143 : packed = gfc_create_var (build_pointer_type (tmp), "data");
777 :
778 143 : tmp = build_call_expr_loc (input_location,
779 : gfor_fndecl_in_pack, 1, initial);
780 143 : tmp = fold_convert (TREE_TYPE (packed), tmp);
781 143 : gfc_add_modify (pre, packed, tmp);
782 :
783 143 : tmp = build_fold_indirect_ref_loc (input_location,
784 : initial);
785 143 : source_data = gfc_conv_descriptor_data_get (tmp);
786 :
787 : /* internal_pack may return source->data without any allocation
788 : or copying if it is already packed. If that's the case, we
789 : need to allocate and copy manually. */
790 :
791 143 : gfc_start_block (&do_copying);
792 143 : tmp = gfc_call_malloc (&do_copying, NULL, size);
793 143 : tmp = fold_convert (TREE_TYPE (packed), tmp);
794 143 : gfc_add_modify (&do_copying, packed, tmp);
795 143 : tmp = gfc_build_memcpy_call (packed, source_data, size);
796 143 : gfc_add_expr_to_block (&do_copying, tmp);
797 :
798 143 : was_packed = fold_build2_loc (input_location, EQ_EXPR,
799 : logical_type_node, packed,
800 : source_data);
801 143 : tmp = gfc_finish_block (&do_copying);
802 143 : tmp = build3_v (COND_EXPR, was_packed, tmp,
803 : build_empty_stmt (input_location));
804 143 : gfc_add_expr_to_block (pre, tmp);
805 :
806 143 : tmp = fold_convert (pvoid_type_node, packed);
807 : }
808 :
809 5104 : gfc_conv_descriptor_data_set (pre, desc, tmp);
810 : }
811 : }
812 27948 : info->data = gfc_conv_descriptor_data_get (desc);
813 :
814 : /* The offset is zero because we create temporaries with a zero
815 : lower bound. */
816 27948 : gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node);
817 :
818 27948 : if (dealloc && !onstack)
819 : {
820 : /* Free the temporary. */
821 7737 : tmp = gfc_conv_descriptor_data_get (desc);
822 7737 : tmp = gfc_call_free (tmp);
823 7737 : gfc_add_expr_to_block (post, tmp);
824 : }
825 27948 : }
826 :
827 :
828 : /* Get the scalarizer array dimension corresponding to actual array dimension
829 : given by ARRAY_DIM.
830 :
831 : For example, if SS represents the array ref a(1,:,:,1), it is a
832 : bidimensional scalarizer array, and the result would be 0 for ARRAY_DIM=1,
833 : and 1 for ARRAY_DIM=2.
834 : If SS represents transpose(a(:,1,1,:)), it is again a bidimensional
835 : scalarizer array, and the result would be 1 for ARRAY_DIM=0 and 0 for
836 : ARRAY_DIM=3.
837 : If SS represents sum(a(:,:,:,1), dim=1), it is a 2+1-dimensional scalarizer
838 : array. If called on the inner ss, the result would be respectively 0,1,2 for
839 : ARRAY_DIM=0,1,2. If called on the outer ss, the result would be 0,1
840 : for ARRAY_DIM=1,2. */
841 :
842 : static int
843 262581 : get_scalarizer_dim_for_array_dim (gfc_ss *ss, int array_dim)
844 : {
845 262581 : int array_ref_dim;
846 262581 : int n;
847 :
848 262581 : array_ref_dim = 0;
849 :
850 531295 : for (; ss; ss = ss->parent)
851 691205 : for (n = 0; n < ss->dimen; n++)
852 422491 : if (ss->dim[n] < array_dim)
853 77069 : array_ref_dim++;
854 :
855 262581 : return array_ref_dim;
856 : }
857 :
858 :
859 : static gfc_ss *
860 221988 : innermost_ss (gfc_ss *ss)
861 : {
862 408686 : while (ss->nested_ss != NULL)
863 : ss = ss->nested_ss;
864 :
865 400478 : return ss;
866 : }
867 :
868 :
869 :
870 : /* Get the array reference dimension corresponding to the given loop dimension.
871 : It is different from the true array dimension given by the dim array in
872 : the case of a partial array reference (i.e. a(:,:,1,:) for example)
873 : It is different from the loop dimension in the case of a transposed array.
874 : */
875 :
876 : static int
877 221988 : get_array_ref_dim_for_loop_dim (gfc_ss *ss, int loop_dim)
878 : {
879 221988 : return get_scalarizer_dim_for_array_dim (innermost_ss (ss),
880 221988 : ss->dim[loop_dim]);
881 : }
882 :
883 :
884 : /* Use the information in the ss to obtain the required information about
885 : the type and size of an array temporary, when the lhs in an assignment
886 : is a class expression. */
887 :
888 : static tree
889 327 : get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype,
890 : gfc_ss **fcnss)
891 : {
892 327 : gfc_ss *loop_ss = ss->loop->ss;
893 327 : gfc_ss *lhs_ss;
894 327 : gfc_ss *rhs_ss;
895 327 : gfc_ss *fcn_ss = NULL;
896 327 : tree tmp;
897 327 : tree tmp2;
898 327 : tree vptr;
899 327 : tree class_expr = NULL_TREE;
900 327 : tree lhs_class_expr = NULL_TREE;
901 327 : bool unlimited_rhs = false;
902 327 : bool unlimited_lhs = false;
903 327 : bool rhs_function = false;
904 327 : bool unlimited_arg1 = false;
905 327 : gfc_symbol *vtab;
906 327 : tree cntnr = NULL_TREE;
907 :
908 : /* The second element in the loop chain contains the source for the
909 : class temporary created in gfc_trans_create_temp_array. */
910 327 : rhs_ss = loop_ss->loop_chain;
911 :
912 327 : if (rhs_ss != gfc_ss_terminator
913 303 : && rhs_ss->info
914 303 : && rhs_ss->info->expr
915 303 : && rhs_ss->info->expr->ts.type == BT_CLASS
916 182 : && rhs_ss->info->data.array.descriptor)
917 : {
918 170 : if (rhs_ss->info->expr->expr_type != EXPR_VARIABLE)
919 56 : class_expr
920 56 : = gfc_get_class_from_expr (rhs_ss->info->data.array.descriptor);
921 : else
922 114 : class_expr = gfc_get_class_from_gfc_expr (rhs_ss->info->expr);
923 170 : unlimited_rhs = UNLIMITED_POLY (rhs_ss->info->expr);
924 170 : if (rhs_ss->info->expr->expr_type == EXPR_FUNCTION)
925 : rhs_function = true;
926 : }
927 :
928 : /* Usually, ss points to the function. When the function call is an actual
929 : argument, it is instead rhs_ss because the ss chain is shifted by one. */
930 327 : *fcnss = fcn_ss = rhs_function ? rhs_ss : ss;
931 :
932 : /* If this is a transformational function with a class result, the info
933 : class_container field points to the class container of arg1. */
934 327 : if (class_expr != NULL_TREE
935 151 : && fcn_ss->info && fcn_ss->info->expr
936 91 : && fcn_ss->info->expr->expr_type == EXPR_FUNCTION
937 91 : && fcn_ss->info->expr->value.function.isym
938 60 : && fcn_ss->info->expr->value.function.isym->transformational)
939 : {
940 60 : cntnr = ss->info->class_container;
941 60 : unlimited_arg1
942 60 : = UNLIMITED_POLY (fcn_ss->info->expr->value.function.actual->expr);
943 : }
944 :
945 : /* For an assignment the lhs is the next element in the loop chain.
946 : If we have a class rhs, this had better be a class variable
947 : expression! Otherwise, the class container from arg1 can be used
948 : to set the vptr and len fields of the result class container. */
949 327 : lhs_ss = rhs_ss->loop_chain;
950 327 : if (lhs_ss && lhs_ss != gfc_ss_terminator
951 225 : && lhs_ss->info && lhs_ss->info->expr
952 225 : && lhs_ss->info->expr->expr_type ==EXPR_VARIABLE
953 225 : && lhs_ss->info->expr->ts.type == BT_CLASS)
954 : {
955 225 : tmp = lhs_ss->info->data.array.descriptor;
956 225 : unlimited_lhs = UNLIMITED_POLY (rhs_ss->info->expr);
957 : }
958 102 : else if (cntnr != NULL_TREE)
959 : {
960 54 : tmp = gfc_class_vptr_get (class_expr);
961 54 : gfc_add_modify (pre, tmp, fold_convert (TREE_TYPE (tmp),
962 : gfc_class_vptr_get (cntnr)));
963 54 : if (unlimited_rhs)
964 : {
965 6 : tmp = gfc_class_len_get (class_expr);
966 6 : if (unlimited_arg1)
967 6 : gfc_add_modify (pre, tmp, gfc_class_len_get (cntnr));
968 : }
969 : tmp = NULL_TREE;
970 : }
971 : else
972 : tmp = NULL_TREE;
973 :
974 : /* Get the lhs class expression. */
975 225 : if (tmp != NULL_TREE && lhs_ss->loop_chain == gfc_ss_terminator)
976 213 : lhs_class_expr = gfc_get_class_from_expr (tmp);
977 : else
978 114 : return class_expr;
979 :
980 213 : gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (lhs_class_expr)));
981 :
982 : /* Set the lhs vptr and, if necessary, the _len field. */
983 213 : if (class_expr)
984 : {
985 : /* Both lhs and rhs are class expressions. */
986 79 : tmp = gfc_class_vptr_get (lhs_class_expr);
987 158 : gfc_add_modify (pre, tmp,
988 79 : fold_convert (TREE_TYPE (tmp),
989 : gfc_class_vptr_get (class_expr)));
990 79 : if (unlimited_lhs)
991 : {
992 31 : gcc_assert (unlimited_rhs);
993 31 : tmp = gfc_class_len_get (lhs_class_expr);
994 31 : tmp2 = gfc_class_len_get (class_expr);
995 31 : gfc_add_modify (pre, tmp, tmp2);
996 : }
997 : }
998 134 : else if (rhs_ss->info->data.array.descriptor)
999 : {
1000 : /* lhs is class and rhs is intrinsic or derived type. */
1001 128 : *eltype = TREE_TYPE (rhs_ss->info->data.array.descriptor);
1002 128 : *eltype = gfc_get_element_type (*eltype);
1003 128 : vtab = gfc_find_vtab (&rhs_ss->info->expr->ts);
1004 128 : vptr = vtab->backend_decl;
1005 128 : if (vptr == NULL_TREE)
1006 24 : vptr = gfc_get_symbol_decl (vtab);
1007 128 : vptr = gfc_build_addr_expr (NULL_TREE, vptr);
1008 128 : tmp = gfc_class_vptr_get (lhs_class_expr);
1009 128 : gfc_add_modify (pre, tmp,
1010 128 : fold_convert (TREE_TYPE (tmp), vptr));
1011 :
1012 128 : if (unlimited_lhs)
1013 : {
1014 0 : tmp = gfc_class_len_get (lhs_class_expr);
1015 0 : if (rhs_ss->info
1016 0 : && rhs_ss->info->expr
1017 0 : && rhs_ss->info->expr->ts.type == BT_CHARACTER)
1018 0 : tmp2 = build_int_cst (TREE_TYPE (tmp),
1019 0 : rhs_ss->info->expr->ts.kind);
1020 : else
1021 0 : tmp2 = build_int_cst (TREE_TYPE (tmp), 0);
1022 0 : gfc_add_modify (pre, tmp, tmp2);
1023 : }
1024 : }
1025 :
1026 : return class_expr;
1027 : }
1028 :
1029 :
1030 :
1031 : /* Generate code to create and initialize the descriptor for a temporary
1032 : array. This is used for both temporaries needed by the scalarizer, and
1033 : functions returning arrays. Adjusts the loop variables to be
1034 : zero-based, and calculates the loop bounds for callee allocated arrays.
1035 : Allocate the array unless it's callee allocated (we have a callee
1036 : allocated array if 'callee_alloc' is true, or if loop->to[n] is
1037 : NULL_TREE for any n). Also fills in the descriptor, data and offset
1038 : fields of info if known. Returns the size of the array, or NULL for a
1039 : callee allocated array.
1040 :
1041 : 'eltype' == NULL signals that the temporary should be a class object.
1042 : The 'initial' expression is used to obtain the size of the dynamic
1043 : type; otherwise the allocation and initialization proceeds as for any
1044 : other expression
1045 :
1046 : PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
1047 : gfc_trans_allocate_array_storage. */
1048 :
1049 : tree
1050 27948 : gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
1051 : tree eltype, tree initial, bool dynamic,
1052 : bool dealloc, bool callee_alloc, locus * where)
1053 : {
1054 27948 : gfc_loopinfo *loop;
1055 27948 : gfc_ss *s;
1056 27948 : gfc_array_info *info;
1057 27948 : tree from[GFC_MAX_DIMENSIONS], to[GFC_MAX_DIMENSIONS];
1058 27948 : tree type;
1059 27948 : tree desc;
1060 27948 : tree tmp;
1061 27948 : tree size;
1062 27948 : tree nelem;
1063 27948 : tree cond;
1064 27948 : tree or_expr;
1065 27948 : tree elemsize;
1066 27948 : tree class_expr = NULL_TREE;
1067 27948 : gfc_ss *fcn_ss = NULL;
1068 27948 : int n, dim, tmp_dim;
1069 27948 : int total_dim = 0;
1070 :
1071 : /* This signals a class array for which we need the size of the
1072 : dynamic type. Generate an eltype and then the class expression. */
1073 27948 : if (eltype == NULL_TREE && initial)
1074 : {
1075 0 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial)));
1076 0 : class_expr = build_fold_indirect_ref_loc (input_location, initial);
1077 : /* Obtain the structure (class) expression. */
1078 0 : class_expr = gfc_get_class_from_expr (class_expr);
1079 0 : gcc_assert (class_expr);
1080 : }
1081 :
1082 : /* Otherwise, some expressions, such as class functions, arising from
1083 : dependency checking in assignments come here with class element type.
1084 : The descriptor can be obtained from the ss->info and then converted
1085 : to the class object. */
1086 27948 : if (class_expr == NULL_TREE && GFC_CLASS_TYPE_P (eltype))
1087 327 : class_expr = get_class_info_from_ss (pre, ss, &eltype, &fcn_ss);
1088 :
1089 : /* If the dynamic type is not available, use the declared type. */
1090 27948 : if (eltype && GFC_CLASS_TYPE_P (eltype))
1091 199 : eltype = gfc_get_element_type (TREE_TYPE (TYPE_FIELDS (eltype)));
1092 :
1093 27948 : if (class_expr == NULL_TREE)
1094 27797 : elemsize = fold_convert (gfc_array_index_type,
1095 : TYPE_SIZE_UNIT (eltype));
1096 : else
1097 : {
1098 : /* Unlimited polymorphic entities are initialised with NULL vptr. They
1099 : can be tested for by checking if the len field is present. If so
1100 : test the vptr before using the vtable size. */
1101 151 : tmp = gfc_class_vptr_get (class_expr);
1102 151 : tmp = fold_build2_loc (input_location, NE_EXPR,
1103 : logical_type_node,
1104 151 : tmp, build_int_cst (TREE_TYPE (tmp), 0));
1105 151 : elemsize = fold_build3_loc (input_location, COND_EXPR,
1106 : gfc_array_index_type,
1107 : tmp,
1108 : gfc_class_vtab_size_get (class_expr),
1109 : gfc_index_zero_node);
1110 151 : elemsize = gfc_evaluate_now (elemsize, pre);
1111 151 : elemsize = gfc_resize_class_size_with_len (pre, class_expr, elemsize);
1112 : /* Casting the data as a character of the dynamic length ensures that
1113 : assignment of elements works when needed. */
1114 151 : eltype = gfc_get_character_type_len (1, elemsize);
1115 : }
1116 :
1117 27948 : memset (from, 0, sizeof (from));
1118 27948 : memset (to, 0, sizeof (to));
1119 :
1120 27948 : info = &ss->info->data.array;
1121 :
1122 27948 : gcc_assert (ss->dimen > 0);
1123 27948 : gcc_assert (ss->loop->dimen == ss->dimen);
1124 :
1125 27948 : if (warn_array_temporaries && where)
1126 207 : gfc_warning (OPT_Warray_temporaries,
1127 : "Creating array temporary at %L", where);
1128 :
1129 : /* Set the lower bound to zero. */
1130 55931 : for (s = ss; s; s = s->parent)
1131 : {
1132 27983 : loop = s->loop;
1133 :
1134 27983 : total_dim += loop->dimen;
1135 65176 : for (n = 0; n < loop->dimen; n++)
1136 : {
1137 37193 : dim = s->dim[n];
1138 :
1139 : /* Callee allocated arrays may not have a known bound yet. */
1140 37193 : if (loop->to[n])
1141 33798 : loop->to[n] = gfc_evaluate_now (
1142 : fold_build2_loc (input_location, MINUS_EXPR,
1143 : gfc_array_index_type,
1144 : loop->to[n], loop->from[n]),
1145 : pre);
1146 37193 : loop->from[n] = gfc_index_zero_node;
1147 :
1148 : /* We have just changed the loop bounds, we must clear the
1149 : corresponding specloop, so that delta calculation is not skipped
1150 : later in gfc_set_delta. */
1151 37193 : loop->specloop[n] = NULL;
1152 :
1153 : /* We are constructing the temporary's descriptor based on the loop
1154 : dimensions. As the dimensions may be accessed in arbitrary order
1155 : (think of transpose) the size taken from the n'th loop may not map
1156 : to the n'th dimension of the array. We need to reconstruct loop
1157 : infos in the right order before using it to set the descriptor
1158 : bounds. */
1159 37193 : tmp_dim = get_scalarizer_dim_for_array_dim (ss, dim);
1160 37193 : from[tmp_dim] = loop->from[n];
1161 37193 : to[tmp_dim] = loop->to[n];
1162 :
1163 37193 : info->delta[dim] = gfc_index_zero_node;
1164 37193 : info->start[dim] = gfc_index_zero_node;
1165 37193 : info->end[dim] = gfc_index_zero_node;
1166 37193 : info->stride[dim] = gfc_index_one_node;
1167 : }
1168 : }
1169 :
1170 : /* Initialize the descriptor. */
1171 27948 : type =
1172 27948 : gfc_get_array_type_bounds (eltype, total_dim, 0, from, to, 1,
1173 : GFC_ARRAY_UNKNOWN, true);
1174 27948 : desc = gfc_create_var (type, "atmp");
1175 27948 : GFC_DECL_PACKED_ARRAY (desc) = 1;
1176 :
1177 : /* Emit a DECL_EXPR for the variable sized array type in
1178 : GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
1179 : sizes works correctly. */
1180 27948 : tree arraytype = TREE_TYPE (GFC_TYPE_ARRAY_DATAPTR_TYPE (type));
1181 27948 : if (! TYPE_NAME (arraytype))
1182 27948 : TYPE_NAME (arraytype) = build_decl (UNKNOWN_LOCATION, TYPE_DECL,
1183 : NULL_TREE, arraytype);
1184 27948 : gfc_add_expr_to_block (pre, build1 (DECL_EXPR,
1185 27948 : arraytype, TYPE_NAME (arraytype)));
1186 :
1187 27948 : if (fcn_ss && fcn_ss->info && fcn_ss->info->class_container)
1188 : {
1189 90 : suppress_warning (desc);
1190 90 : TREE_USED (desc) = 0;
1191 : }
1192 :
1193 27948 : if (class_expr != NULL_TREE
1194 27797 : || (fcn_ss && fcn_ss->info && fcn_ss->info->class_container))
1195 : {
1196 181 : tree class_data;
1197 181 : tree dtype;
1198 181 : gfc_expr *expr1 = fcn_ss ? fcn_ss->info->expr : NULL;
1199 181 : bool rank_changer;
1200 :
1201 : /* Pick out these transformational functions because they change the rank
1202 : or shape of the first argument. This requires that the class type be
1203 : changed, the dtype updated and the correct rank used. */
1204 121 : rank_changer = expr1 && expr1->expr_type == EXPR_FUNCTION
1205 121 : && expr1->value.function.isym
1206 271 : && (expr1->value.function.isym->id == GFC_ISYM_RESHAPE
1207 : || expr1->value.function.isym->id == GFC_ISYM_SPREAD
1208 : || expr1->value.function.isym->id == GFC_ISYM_PACK
1209 : || expr1->value.function.isym->id == GFC_ISYM_UNPACK);
1210 :
1211 : /* Create a class temporary for the result using the lhs class object. */
1212 181 : if (class_expr != NULL_TREE && !rank_changer)
1213 : {
1214 103 : tmp = gfc_create_var (TREE_TYPE (class_expr), "ctmp");
1215 103 : gfc_add_modify (pre, tmp, class_expr);
1216 : }
1217 : else
1218 : {
1219 78 : tree vptr;
1220 78 : class_expr = fcn_ss->info->class_container;
1221 78 : gcc_assert (expr1);
1222 :
1223 : /* Build a new class container using the arg1 class object. The class
1224 : typespec must be rebuilt because the rank might have changed. */
1225 78 : gfc_typespec ts = CLASS_DATA (expr1)->ts;
1226 78 : symbol_attribute attr = CLASS_DATA (expr1)->attr;
1227 78 : gfc_change_class (&ts, &attr, NULL, expr1->rank, 0);
1228 78 : tmp = gfc_create_var (gfc_typenode_for_spec (&ts), "ctmp");
1229 78 : fcn_ss->info->class_container = tmp;
1230 :
1231 : /* Set the vptr and obtain the element size. */
1232 78 : vptr = gfc_class_vptr_get (tmp);
1233 156 : gfc_add_modify (pre, vptr,
1234 78 : fold_convert (TREE_TYPE (vptr),
1235 : gfc_class_vptr_get (class_expr)));
1236 78 : elemsize = gfc_class_vtab_size_get (class_expr);
1237 :
1238 : /* Set the _len field, if necessary. */
1239 78 : if (UNLIMITED_POLY (expr1))
1240 : {
1241 18 : gfc_add_modify (pre, gfc_class_len_get (tmp),
1242 : gfc_class_len_get (class_expr));
1243 18 : elemsize = gfc_resize_class_size_with_len (pre, class_expr,
1244 : elemsize);
1245 : }
1246 :
1247 78 : elemsize = gfc_evaluate_now (elemsize, pre);
1248 : }
1249 :
1250 181 : class_data = gfc_class_data_get (tmp);
1251 :
1252 181 : if (rank_changer)
1253 : {
1254 : /* Take the dtype from the class expression. */
1255 72 : dtype = gfc_conv_descriptor_dtype (gfc_class_data_get (class_expr));
1256 72 : tmp = gfc_conv_descriptor_dtype (desc);
1257 72 : gfc_add_modify (pre, tmp, dtype);
1258 :
1259 : /* These transformational functions change the rank. */
1260 72 : tmp = gfc_conv_descriptor_rank (desc);
1261 72 : gfc_add_modify (pre, tmp,
1262 72 : build_int_cst (TREE_TYPE (tmp), ss->loop->dimen));
1263 72 : fcn_ss->info->class_container = NULL_TREE;
1264 : }
1265 :
1266 : /* Assign the new descriptor to the _data field. This allows the
1267 : vptr _copy to be used for scalarized assignment since the class
1268 : temporary can be found from the descriptor. */
1269 181 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1270 181 : TREE_TYPE (desc), desc);
1271 181 : gfc_add_modify (pre, class_data, tmp);
1272 :
1273 : /* Point desc to the class _data field. */
1274 181 : desc = class_data;
1275 181 : }
1276 : else
1277 : {
1278 : /* Fill in the array dtype. */
1279 27767 : tmp = gfc_conv_descriptor_dtype (desc);
1280 27767 : gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
1281 : }
1282 :
1283 27948 : info->descriptor = desc;
1284 27948 : size = gfc_index_one_node;
1285 :
1286 : /*
1287 : Fill in the bounds and stride. This is a packed array, so:
1288 :
1289 : size = 1;
1290 : for (n = 0; n < rank; n++)
1291 : {
1292 : stride[n] = size
1293 : delta = ubound[n] + 1 - lbound[n];
1294 : size = size * delta;
1295 : }
1296 : size = size * sizeof(element);
1297 : */
1298 :
1299 27948 : or_expr = NULL_TREE;
1300 :
1301 : /* If there is at least one null loop->to[n], it is a callee allocated
1302 : array. */
1303 61746 : for (n = 0; n < total_dim; n++)
1304 35845 : if (to[n] == NULL_TREE)
1305 : {
1306 : size = NULL_TREE;
1307 : break;
1308 : }
1309 :
1310 27948 : if (size == NULL_TREE)
1311 4104 : for (s = ss; s; s = s->parent)
1312 5457 : for (n = 0; n < s->loop->dimen; n++)
1313 : {
1314 3400 : dim = get_scalarizer_dim_for_array_dim (ss, s->dim[n]);
1315 :
1316 : /* For a callee allocated array express the loop bounds in terms
1317 : of the descriptor fields. */
1318 3400 : tmp = fold_build2_loc (input_location,
1319 : MINUS_EXPR, gfc_array_index_type,
1320 : gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]),
1321 : gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]));
1322 3400 : s->loop->to[n] = tmp;
1323 : }
1324 : else
1325 : {
1326 59694 : for (n = 0; n < total_dim; n++)
1327 : {
1328 : /* Store the stride and bound components in the descriptor. */
1329 33793 : gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size);
1330 :
1331 33793 : gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
1332 : gfc_index_zero_node);
1333 :
1334 33793 : gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], to[n]);
1335 :
1336 33793 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
1337 : gfc_array_index_type,
1338 : to[n], gfc_index_one_node);
1339 :
1340 : /* Check whether the size for this dimension is negative. */
1341 33793 : cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
1342 : tmp, gfc_index_zero_node);
1343 33793 : cond = gfc_evaluate_now (cond, pre);
1344 :
1345 33793 : if (n == 0)
1346 : or_expr = cond;
1347 : else
1348 7892 : or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1349 : logical_type_node, or_expr, cond);
1350 :
1351 33793 : size = fold_build2_loc (input_location, MULT_EXPR,
1352 : gfc_array_index_type, size, tmp);
1353 33793 : size = gfc_evaluate_now (size, pre);
1354 : }
1355 : }
1356 :
1357 : /* Get the size of the array. */
1358 27948 : if (size && !callee_alloc)
1359 : {
1360 : /* If or_expr is true, then the extent in at least one
1361 : dimension is zero and the size is set to zero. */
1362 25711 : size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
1363 : or_expr, gfc_index_zero_node, size);
1364 :
1365 25711 : nelem = size;
1366 25711 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
1367 : size, elemsize);
1368 : }
1369 : else
1370 : {
1371 : nelem = size;
1372 : size = NULL_TREE;
1373 : }
1374 :
1375 : /* Set the span. */
1376 27948 : tmp = fold_convert (gfc_array_index_type, elemsize);
1377 27948 : gfc_conv_descriptor_span_set (pre, desc, tmp);
1378 :
1379 27948 : gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
1380 : dynamic, dealloc);
1381 :
1382 55931 : while (ss->parent)
1383 : ss = ss->parent;
1384 :
1385 27948 : if (ss->dimen > ss->loop->temp_dim)
1386 24163 : ss->loop->temp_dim = ss->dimen;
1387 :
1388 27948 : return size;
1389 : }
1390 :
1391 :
1392 : /* Return the number of iterations in a loop that starts at START,
1393 : ends at END, and has step STEP. */
1394 :
1395 : static tree
1396 1078 : gfc_get_iteration_count (tree start, tree end, tree step)
1397 : {
1398 1078 : tree tmp;
1399 1078 : tree type;
1400 :
1401 1078 : type = TREE_TYPE (step);
1402 1078 : tmp = fold_build2_loc (input_location, MINUS_EXPR, type, end, start);
1403 1078 : tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, type, tmp, step);
1404 1078 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp,
1405 : build_int_cst (type, 1));
1406 1078 : tmp = fold_build2_loc (input_location, MAX_EXPR, type, tmp,
1407 : build_int_cst (type, 0));
1408 1078 : return fold_convert (gfc_array_index_type, tmp);
1409 : }
1410 :
1411 :
1412 : /* Return true if the bounds of iterator I can only be determined
1413 : at run time. */
1414 :
1415 : static inline bool
1416 2363 : gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
1417 : {
1418 2363 : return (i->start->expr_type != EXPR_CONSTANT
1419 1945 : || i->end->expr_type != EXPR_CONSTANT
1420 2536 : || i->step->expr_type != EXPR_CONSTANT);
1421 : }
1422 :
1423 :
1424 : /* Split the size of constructor element EXPR into the sum of two terms,
1425 : one of which can be determined at compile time and one of which must
1426 : be calculated at run time. Set *SIZE to the former and return true
1427 : if the latter might be nonzero. */
1428 :
1429 : static bool
1430 3290 : gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
1431 : {
1432 3290 : if (expr->expr_type == EXPR_ARRAY)
1433 685 : return gfc_get_array_constructor_size (size, expr->value.constructor);
1434 2605 : else if (expr->rank > 0)
1435 : {
1436 : /* Calculate everything at run time. */
1437 1031 : mpz_set_ui (*size, 0);
1438 1031 : return true;
1439 : }
1440 : else
1441 : {
1442 : /* A single element. */
1443 1574 : mpz_set_ui (*size, 1);
1444 1574 : return false;
1445 : }
1446 : }
1447 :
1448 :
1449 : /* Like gfc_get_array_constructor_element_size, but applied to the whole
1450 : of array constructor C. */
1451 :
1452 : static bool
1453 3030 : gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base)
1454 : {
1455 3030 : gfc_constructor *c;
1456 3030 : gfc_iterator *i;
1457 3030 : mpz_t val;
1458 3030 : mpz_t len;
1459 3030 : bool dynamic;
1460 :
1461 3030 : mpz_set_ui (*size, 0);
1462 3030 : mpz_init (len);
1463 3030 : mpz_init (val);
1464 :
1465 3030 : dynamic = false;
1466 7408 : for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1467 : {
1468 4378 : i = c->iterator;
1469 4378 : if (i && gfc_iterator_has_dynamic_bounds (i))
1470 : dynamic = true;
1471 : else
1472 : {
1473 2739 : dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
1474 2739 : if (i)
1475 : {
1476 : /* Multiply the static part of the element size by the
1477 : number of iterations. */
1478 128 : mpz_sub (val, i->end->value.integer, i->start->value.integer);
1479 128 : mpz_fdiv_q (val, val, i->step->value.integer);
1480 128 : mpz_add_ui (val, val, 1);
1481 128 : if (mpz_sgn (val) > 0)
1482 92 : mpz_mul (len, len, val);
1483 : else
1484 36 : mpz_set_ui (len, 0);
1485 : }
1486 2739 : mpz_add (*size, *size, len);
1487 : }
1488 : }
1489 3030 : mpz_clear (len);
1490 3030 : mpz_clear (val);
1491 3030 : return dynamic;
1492 : }
1493 :
1494 :
1495 : /* Make sure offset is a variable. */
1496 :
1497 : static void
1498 3321 : gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
1499 : tree * offsetvar)
1500 : {
1501 : /* We should have already created the offset variable. We cannot
1502 : create it here because we may be in an inner scope. */
1503 3321 : gcc_assert (*offsetvar != NULL_TREE);
1504 3321 : gfc_add_modify (pblock, *offsetvar, *poffset);
1505 3321 : *poffset = *offsetvar;
1506 3321 : TREE_USED (*offsetvar) = 1;
1507 3321 : }
1508 :
1509 :
1510 : /* Variables needed for bounds-checking. */
1511 : static bool first_len;
1512 : static tree first_len_val;
1513 : static bool typespec_chararray_ctor;
1514 :
1515 : /* Return true if DER has any CLASS allocatable component. Such components
1516 : are initialised by VIEW_CONVERT in structure constructors (a bitwise copy
1517 : of the class descriptor), so their _data pointer may refer to a non-heap
1518 : object and must not be passed to gfc_deallocate_alloc_comp_no_caf. */
1519 :
1520 : static bool
1521 4481 : has_class_alloc_comp (gfc_symbol *der)
1522 : {
1523 11962 : for (gfc_component *c = der->components; c; c = c->next)
1524 7547 : if (c->ts.type == BT_CLASS && !c->attr.class_pointer)
1525 : return true;
1526 : return false;
1527 : }
1528 :
1529 : static void
1530 12517 : gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
1531 : tree offset, gfc_se * se, gfc_expr * expr)
1532 : {
1533 12517 : tree tmp, offset_eval;
1534 :
1535 12517 : gfc_conv_expr (se, expr);
1536 :
1537 : /* Store the value. */
1538 12517 : tmp = build_fold_indirect_ref_loc (input_location,
1539 : gfc_conv_descriptor_data_get (desc));
1540 :
1541 : /* The offset may change, so get its value now and use that to free memory. */
1542 12517 : offset_eval = gfc_evaluate_now (offset, &se->pre);
1543 12517 : tmp = gfc_build_array_ref (tmp, offset_eval, NULL);
1544 :
1545 12517 : if (expr->ts.type == BT_DERIVED
1546 4390 : && (expr->expr_type == EXPR_FUNCTION
1547 4306 : || (expr->expr_type == EXPR_STRUCTURE
1548 3702 : && !has_class_alloc_comp (expr->ts.u.derived)))
1549 16261 : && expr->ts.u.derived->attr.alloc_comp)
1550 800 : gfc_add_expr_to_block (&se->finalblock,
1551 : gfc_deallocate_alloc_comp_no_caf (expr->ts.u.derived,
1552 : tmp, expr->rank,
1553 : true));
1554 :
1555 12517 : if (expr->ts.type == BT_CHARACTER)
1556 : {
1557 2140 : int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
1558 2140 : tree esize;
1559 :
1560 2140 : esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)));
1561 2140 : esize = fold_convert (gfc_charlen_type_node, esize);
1562 4280 : esize = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
1563 2140 : TREE_TYPE (esize), esize,
1564 2140 : build_int_cst (TREE_TYPE (esize),
1565 2140 : gfc_character_kinds[i].bit_size / 8));
1566 :
1567 2140 : gfc_conv_string_parameter (se);
1568 2140 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
1569 : {
1570 : /* The temporary is an array of pointers. */
1571 6 : se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1572 6 : gfc_add_modify (&se->pre, tmp, se->expr);
1573 : }
1574 : else
1575 : {
1576 : /* The temporary is an array of string values. */
1577 2134 : tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp);
1578 : /* We know the temporary and the value will be the same length,
1579 : so can use memcpy. */
1580 2134 : gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind,
1581 : se->string_length, se->expr, expr->ts.kind);
1582 : }
1583 2140 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !typespec_chararray_ctor)
1584 : {
1585 310 : if (first_len)
1586 : {
1587 130 : gfc_add_modify (&se->pre, first_len_val,
1588 130 : fold_convert (TREE_TYPE (first_len_val),
1589 : se->string_length));
1590 130 : first_len = false;
1591 : }
1592 : else
1593 : {
1594 : /* Verify that all constructor elements are of the same
1595 : length. */
1596 180 : tree rhs = fold_convert (TREE_TYPE (first_len_val),
1597 : se->string_length);
1598 180 : tree cond = fold_build2_loc (input_location, NE_EXPR,
1599 : logical_type_node, first_len_val,
1600 : rhs);
1601 180 : gfc_trans_runtime_check
1602 180 : (true, false, cond, &se->pre, &expr->where,
1603 : "Different CHARACTER lengths (%ld/%ld) in array constructor",
1604 : fold_convert (long_integer_type_node, first_len_val),
1605 : fold_convert (long_integer_type_node, se->string_length));
1606 : }
1607 : }
1608 : }
1609 10377 : else if (GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
1610 10377 : && !GFC_CLASS_TYPE_P (gfc_get_element_type (TREE_TYPE (desc))))
1611 : {
1612 : /* Assignment of a CLASS array constructor to a derived type array. */
1613 24 : if (expr->expr_type == EXPR_FUNCTION)
1614 18 : se->expr = gfc_evaluate_now (se->expr, pblock);
1615 24 : se->expr = gfc_class_data_get (se->expr);
1616 24 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
1617 24 : se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1618 24 : gfc_add_modify (&se->pre, tmp, se->expr);
1619 : }
1620 : else
1621 : {
1622 : /* TODO: Should the frontend already have done this conversion? */
1623 10353 : se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1624 10353 : gfc_add_modify (&se->pre, tmp, se->expr);
1625 : }
1626 :
1627 12517 : gfc_add_block_to_block (pblock, &se->pre);
1628 12517 : gfc_add_block_to_block (pblock, &se->post);
1629 12517 : }
1630 :
1631 :
1632 : /* Add the contents of an array to the constructor. DYNAMIC is as for
1633 : gfc_trans_array_constructor_value. */
1634 :
1635 : static void
1636 1141 : gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
1637 : tree type ATTRIBUTE_UNUSED,
1638 : tree desc, gfc_expr * expr,
1639 : tree * poffset, tree * offsetvar,
1640 : bool dynamic)
1641 : {
1642 1141 : gfc_se se;
1643 1141 : gfc_ss *ss;
1644 1141 : gfc_loopinfo loop;
1645 1141 : stmtblock_t body;
1646 1141 : tree tmp;
1647 1141 : tree size;
1648 1141 : int n;
1649 :
1650 : /* We need this to be a variable so we can increment it. */
1651 1141 : gfc_put_offset_into_var (pblock, poffset, offsetvar);
1652 :
1653 1141 : gfc_init_se (&se, NULL);
1654 :
1655 : /* Walk the array expression. */
1656 1141 : ss = gfc_walk_expr (expr);
1657 1141 : gcc_assert (ss != gfc_ss_terminator);
1658 :
1659 : /* Initialize the scalarizer. */
1660 1141 : gfc_init_loopinfo (&loop);
1661 1141 : gfc_add_ss_to_loop (&loop, ss);
1662 :
1663 : /* Initialize the loop. */
1664 1141 : gfc_conv_ss_startstride (&loop);
1665 1141 : gfc_conv_loop_setup (&loop, &expr->where);
1666 :
1667 : /* Make sure the constructed array has room for the new data. */
1668 1141 : if (dynamic)
1669 : {
1670 : /* Set SIZE to the total number of elements in the subarray. */
1671 515 : size = gfc_index_one_node;
1672 1042 : for (n = 0; n < loop.dimen; n++)
1673 : {
1674 527 : tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
1675 : gfc_index_one_node);
1676 527 : size = fold_build2_loc (input_location, MULT_EXPR,
1677 : gfc_array_index_type, size, tmp);
1678 : }
1679 :
1680 : /* Grow the constructed array by SIZE elements. */
1681 515 : gfc_grow_array (&loop.pre, desc, size);
1682 : }
1683 :
1684 : /* Make the loop body. */
1685 1141 : gfc_mark_ss_chain_used (ss, 1);
1686 1141 : gfc_start_scalarized_body (&loop, &body);
1687 1141 : gfc_copy_loopinfo_to_se (&se, &loop);
1688 1141 : se.ss = ss;
1689 :
1690 1141 : gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
1691 1141 : gcc_assert (se.ss == gfc_ss_terminator);
1692 :
1693 : /* Increment the offset. */
1694 1141 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1695 : *poffset, gfc_index_one_node);
1696 1141 : gfc_add_modify (&body, *poffset, tmp);
1697 :
1698 : /* Finish the loop. */
1699 1141 : gfc_trans_scalarizing_loops (&loop, &body);
1700 1141 : gfc_add_block_to_block (&loop.pre, &loop.post);
1701 1141 : tmp = gfc_finish_block (&loop.pre);
1702 1141 : gfc_add_expr_to_block (pblock, tmp);
1703 :
1704 1141 : gfc_cleanup_loop (&loop);
1705 1141 : }
1706 :
1707 :
1708 : /* Return true if every leaf element of an array constructor is a function
1709 : reference returning derived type DER, which has allocatable components.
1710 : Such results are moved (shallow-copied) into the constructor temporary, so
1711 : the temporary owns their allocatable components and they can all be freed
1712 : in a single sweep over the whole temporary. Returns false as soon as an
1713 : element is anything else - notably a variable, whose allocatable components
1714 : are aliased rather than owned by the temporary and must not be freed. */
1715 :
1716 : static bool
1717 521 : gfc_constructor_is_owned_alloc_comp (gfc_constructor_base base,
1718 : gfc_symbol *der)
1719 : {
1720 521 : gfc_constructor *c;
1721 :
1722 521 : if (base == NULL)
1723 : return false;
1724 :
1725 1369 : for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1726 : {
1727 1065 : gfc_expr *e = c->expr;
1728 1065 : if (e->expr_type == EXPR_ARRAY)
1729 : {
1730 54 : if (!gfc_constructor_is_owned_alloc_comp (e->value.constructor, der))
1731 : return false;
1732 : }
1733 1011 : else if (!(e->ts.type == BT_DERIVED
1734 1011 : && (e->expr_type == EXPR_FUNCTION
1735 972 : || (e->expr_type == EXPR_STRUCTURE
1736 779 : && !has_class_alloc_comp (e->ts.u.derived)))
1737 794 : && e->ts.u.derived == der))
1738 : return false;
1739 : }
1740 : return true;
1741 : }
1742 :
1743 :
1744 : /* Assign the values to the elements of an array constructor. DYNAMIC
1745 : is true if descriptor DESC only contains enough data for the static
1746 : size calculated by gfc_get_array_constructor_size. When true, memory
1747 : for the dynamic parts must be allocated using realloc. OWNED_SWEEP is
1748 : true when the caller will free the allocatable components of every
1749 : constructor element in one sweep over the whole temporary; in that case
1750 : the per-element finalization built here is suppressed to avoid a double
1751 : free. */
1752 :
1753 : static void
1754 8301 : gfc_trans_array_constructor_value (stmtblock_t * pblock,
1755 : stmtblock_t * finalblock,
1756 : tree type, tree desc,
1757 : gfc_constructor_base base, tree * poffset,
1758 : tree * offsetvar, bool dynamic,
1759 : bool owned_sweep)
1760 : {
1761 8301 : tree tmp;
1762 8301 : tree start = NULL_TREE;
1763 8301 : tree end = NULL_TREE;
1764 8301 : tree step = NULL_TREE;
1765 8301 : stmtblock_t body;
1766 8301 : gfc_se se;
1767 8301 : mpz_t size;
1768 8301 : gfc_constructor *c;
1769 8301 : gfc_typespec ts;
1770 8301 : int ctr = 0;
1771 :
1772 8301 : tree shadow_loopvar = NULL_TREE;
1773 8301 : gfc_saved_var saved_loopvar;
1774 :
1775 8301 : ts.type = BT_UNKNOWN;
1776 8301 : mpz_init (size);
1777 22426 : for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1778 : {
1779 14125 : ctr++;
1780 : /* If this is an iterator or an array, the offset must be a variable. */
1781 14125 : if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
1782 2180 : gfc_put_offset_into_var (pblock, poffset, offsetvar);
1783 :
1784 : /* Shadowing the iterator avoids changing its value and saves us from
1785 : keeping track of it. Further, it makes sure that there's always a
1786 : backend-decl for the symbol, even if there wasn't one before,
1787 : e.g. in the case of an iterator that appears in a specification
1788 : expression in an interface mapping. */
1789 14125 : if (c->iterator)
1790 : {
1791 1481 : gfc_symbol *sym;
1792 1481 : tree type;
1793 :
1794 : /* Evaluate loop bounds before substituting the loop variable
1795 : in case they depend on it. Such a case is invalid, but it is
1796 : not more expensive to do the right thing here.
1797 : See PR 44354. */
1798 1481 : gfc_init_se (&se, NULL);
1799 1481 : gfc_conv_expr_val (&se, c->iterator->start);
1800 1481 : gfc_add_block_to_block (pblock, &se.pre);
1801 1481 : start = gfc_evaluate_now (se.expr, pblock);
1802 :
1803 1481 : gfc_init_se (&se, NULL);
1804 1481 : gfc_conv_expr_val (&se, c->iterator->end);
1805 1481 : gfc_add_block_to_block (pblock, &se.pre);
1806 1481 : end = gfc_evaluate_now (se.expr, pblock);
1807 :
1808 1481 : gfc_init_se (&se, NULL);
1809 1481 : gfc_conv_expr_val (&se, c->iterator->step);
1810 1481 : gfc_add_block_to_block (pblock, &se.pre);
1811 1481 : step = gfc_evaluate_now (se.expr, pblock);
1812 :
1813 1481 : sym = c->iterator->var->symtree->n.sym;
1814 1481 : type = gfc_typenode_for_spec (&sym->ts);
1815 :
1816 1481 : shadow_loopvar = gfc_create_var (type, "shadow_loopvar");
1817 1481 : gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar);
1818 : }
1819 :
1820 14125 : gfc_start_block (&body);
1821 :
1822 14125 : if (c->expr->expr_type == EXPR_ARRAY)
1823 : {
1824 : /* Array constructors can be nested. */
1825 1503 : gfc_trans_array_constructor_value (&body, finalblock, type,
1826 : desc, c->expr->value.constructor,
1827 : poffset, offsetvar, dynamic,
1828 : owned_sweep);
1829 : }
1830 12622 : else if (c->expr->rank > 0)
1831 : {
1832 1141 : gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
1833 : poffset, offsetvar, dynamic);
1834 : }
1835 : else
1836 : {
1837 : /* This code really upsets the gimplifier so don't bother for now. */
1838 : gfc_constructor *p;
1839 : HOST_WIDE_INT n;
1840 : HOST_WIDE_INT size;
1841 :
1842 : p = c;
1843 : n = 0;
1844 13286 : while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1845 : {
1846 1805 : p = gfc_constructor_next (p);
1847 1805 : n++;
1848 : }
1849 : /* Constructor with few constant elements, or element size not
1850 : known at compile time (e.g. deferred-length character). */
1851 11481 : if (n < 4 || !INTEGER_CST_P (TYPE_SIZE_UNIT (type)))
1852 : {
1853 : /* Scalar values. */
1854 11376 : gfc_init_se (&se, NULL);
1855 11376 : if (IS_PDT (c->expr) && c->expr->expr_type == EXPR_STRUCTURE)
1856 276 : c->expr->must_finalize = 1;
1857 :
1858 11376 : gfc_trans_array_ctor_element (&body, desc, *poffset,
1859 : &se, c->expr);
1860 :
1861 11376 : *poffset = fold_build2_loc (input_location, PLUS_EXPR,
1862 : gfc_array_index_type,
1863 : *poffset, gfc_index_one_node);
1864 : /* Unless the whole temporary is being swept by the caller, add
1865 : the per-element finalization. The sweep is used when every
1866 : element is an owned function result, which is the only way to
1867 : correctly free elements produced inside an implied-do loop. */
1868 11376 : if (finalblock && !owned_sweep)
1869 496 : gfc_add_block_to_block (finalblock, &se.finalblock);
1870 : }
1871 : else
1872 : {
1873 : /* Collect multiple scalar constants into a constructor. */
1874 105 : vec<constructor_elt, va_gc> *v = NULL;
1875 105 : tree init;
1876 105 : tree bound;
1877 105 : tree tmptype;
1878 105 : HOST_WIDE_INT idx = 0;
1879 :
1880 105 : p = c;
1881 : /* Count the number of consecutive scalar constants. */
1882 837 : while (p && !(p->iterator
1883 745 : || p->expr->expr_type != EXPR_CONSTANT))
1884 : {
1885 732 : gfc_init_se (&se, NULL);
1886 732 : gfc_conv_constant (&se, p->expr);
1887 :
1888 732 : if (c->expr->ts.type != BT_CHARACTER)
1889 660 : se.expr = fold_convert (type, se.expr);
1890 : /* For constant character array constructors we build
1891 : an array of pointers. */
1892 72 : else if (POINTER_TYPE_P (type))
1893 0 : se.expr = gfc_build_addr_expr
1894 0 : (gfc_get_pchar_type (p->expr->ts.kind),
1895 : se.expr);
1896 :
1897 732 : CONSTRUCTOR_APPEND_ELT (v,
1898 : build_int_cst (gfc_array_index_type,
1899 : idx++),
1900 : se.expr);
1901 732 : c = p;
1902 732 : p = gfc_constructor_next (p);
1903 : }
1904 :
1905 105 : bound = size_int (n - 1);
1906 : /* Create an array type to hold them. */
1907 105 : tmptype = build_range_type (gfc_array_index_type,
1908 : gfc_index_zero_node, bound);
1909 105 : tmptype = build_array_type (type, tmptype);
1910 :
1911 105 : init = build_constructor (tmptype, v);
1912 105 : TREE_CONSTANT (init) = 1;
1913 105 : TREE_STATIC (init) = 1;
1914 : /* Create a static variable to hold the data. */
1915 105 : tmp = gfc_create_var (tmptype, "data");
1916 105 : TREE_STATIC (tmp) = 1;
1917 105 : TREE_CONSTANT (tmp) = 1;
1918 105 : TREE_READONLY (tmp) = 1;
1919 105 : DECL_INITIAL (tmp) = init;
1920 105 : init = tmp;
1921 :
1922 : /* Use BUILTIN_MEMCPY to assign the values. */
1923 105 : tmp = gfc_conv_descriptor_data_get (desc);
1924 105 : tmp = build_fold_indirect_ref_loc (input_location,
1925 : tmp);
1926 105 : tmp = gfc_build_array_ref (tmp, *poffset, NULL);
1927 105 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1928 105 : init = gfc_build_addr_expr (NULL_TREE, init);
1929 :
1930 105 : size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1931 105 : bound = build_int_cst (size_type_node, n * size);
1932 105 : tmp = build_call_expr_loc (input_location,
1933 : builtin_decl_explicit (BUILT_IN_MEMCPY),
1934 : 3, tmp, init, bound);
1935 105 : gfc_add_expr_to_block (&body, tmp);
1936 :
1937 105 : *poffset = fold_build2_loc (input_location, PLUS_EXPR,
1938 : gfc_array_index_type, *poffset,
1939 105 : build_int_cst (gfc_array_index_type, n));
1940 : }
1941 11481 : if (!INTEGER_CST_P (*poffset))
1942 : {
1943 1783 : gfc_add_modify (&body, *offsetvar, *poffset);
1944 1783 : *poffset = *offsetvar;
1945 : }
1946 :
1947 11481 : if (!c->iterator)
1948 11481 : ts = c->expr->ts;
1949 : }
1950 :
1951 : /* The frontend should already have done any expansions
1952 : at compile-time. */
1953 14125 : if (!c->iterator)
1954 : {
1955 : /* Pass the code as is. */
1956 12644 : tmp = gfc_finish_block (&body);
1957 12644 : gfc_add_expr_to_block (pblock, tmp);
1958 : }
1959 : else
1960 : {
1961 : /* Build the implied do-loop. */
1962 1481 : stmtblock_t implied_do_block;
1963 1481 : tree cond;
1964 1481 : tree exit_label;
1965 1481 : tree loopbody;
1966 1481 : tree tmp2;
1967 :
1968 1481 : loopbody = gfc_finish_block (&body);
1969 :
1970 : /* Create a new block that holds the implied-do loop. A temporary
1971 : loop-variable is used. */
1972 1481 : gfc_start_block(&implied_do_block);
1973 :
1974 : /* Initialize the loop. */
1975 1481 : gfc_add_modify (&implied_do_block, shadow_loopvar, start);
1976 :
1977 : /* If this array expands dynamically, and the number of iterations
1978 : is not constant, we won't have allocated space for the static
1979 : part of C->EXPR's size. Do that now. */
1980 1481 : if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1981 : {
1982 : /* Get the number of iterations. */
1983 551 : tmp = gfc_get_iteration_count (shadow_loopvar, end, step);
1984 :
1985 : /* Get the static part of C->EXPR's size. */
1986 551 : gfc_get_array_constructor_element_size (&size, c->expr);
1987 551 : tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1988 :
1989 : /* Grow the array by TMP * TMP2 elements. */
1990 551 : tmp = fold_build2_loc (input_location, MULT_EXPR,
1991 : gfc_array_index_type, tmp, tmp2);
1992 551 : gfc_grow_array (&implied_do_block, desc, tmp);
1993 : }
1994 :
1995 : /* Generate the loop body. */
1996 1481 : exit_label = gfc_build_label_decl (NULL_TREE);
1997 1481 : gfc_start_block (&body);
1998 :
1999 : /* Generate the exit condition. Depending on the sign of
2000 : the step variable we have to generate the correct
2001 : comparison. */
2002 1481 : tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2003 1481 : step, build_int_cst (TREE_TYPE (step), 0));
2004 1481 : cond = fold_build3_loc (input_location, COND_EXPR,
2005 : logical_type_node, tmp,
2006 : fold_build2_loc (input_location, GT_EXPR,
2007 : logical_type_node, shadow_loopvar, end),
2008 : fold_build2_loc (input_location, LT_EXPR,
2009 : logical_type_node, shadow_loopvar, end));
2010 1481 : tmp = build1_v (GOTO_EXPR, exit_label);
2011 1481 : TREE_USED (exit_label) = 1;
2012 1481 : tmp = build3_v (COND_EXPR, cond, tmp,
2013 : build_empty_stmt (input_location));
2014 1481 : gfc_add_expr_to_block (&body, tmp);
2015 :
2016 : /* The main loop body. */
2017 1481 : gfc_add_expr_to_block (&body, loopbody);
2018 :
2019 : /* Increase loop variable by step. */
2020 1481 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
2021 1481 : TREE_TYPE (shadow_loopvar), shadow_loopvar,
2022 : step);
2023 1481 : gfc_add_modify (&body, shadow_loopvar, tmp);
2024 :
2025 : /* Finish the loop. */
2026 1481 : tmp = gfc_finish_block (&body);
2027 1481 : tmp = build1_v (LOOP_EXPR, tmp);
2028 1481 : gfc_add_expr_to_block (&implied_do_block, tmp);
2029 :
2030 : /* Add the exit label. */
2031 1481 : tmp = build1_v (LABEL_EXPR, exit_label);
2032 1481 : gfc_add_expr_to_block (&implied_do_block, tmp);
2033 :
2034 : /* Finish the implied-do loop. */
2035 1481 : tmp = gfc_finish_block(&implied_do_block);
2036 1481 : gfc_add_expr_to_block(pblock, tmp);
2037 :
2038 1481 : gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar);
2039 : }
2040 : }
2041 :
2042 : /* F2008 4.5.6.3 para 5: If an executable construct references a structure
2043 : constructor or array constructor, the entity created by the constructor is
2044 : finalized after execution of the innermost executable construct containing
2045 : the reference. This, in fact, was later deleted by the Combined Technical
2046 : Corrigenda 1 TO 4 for fortran 2008 (f08/0011).
2047 :
2048 : Transmit finalization of this constructor through 'finalblock'. */
2049 8301 : if ((gfc_option.allow_std & (GFC_STD_F2008 | GFC_STD_F2003))
2050 8301 : && !(gfc_option.allow_std & GFC_STD_GNU)
2051 70 : && finalblock != NULL
2052 24 : && gfc_may_be_finalized (ts)
2053 18 : && ctr > 0 && desc != NULL_TREE
2054 8319 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
2055 : {
2056 18 : symbol_attribute attr;
2057 18 : gfc_se fse;
2058 18 : locus loc;
2059 18 : gfc_locus_from_location (&loc, input_location);
2060 18 : gfc_warning (0, "The structure constructor at %L has been"
2061 : " finalized. This feature was removed by f08/0011."
2062 : " Use -std=f2018 or -std=gnu to eliminate the"
2063 : " finalization.", &loc);
2064 18 : attr.pointer = attr.allocatable = 0;
2065 18 : gfc_init_se (&fse, NULL);
2066 18 : fse.expr = desc;
2067 18 : gfc_finalize_tree_expr (&fse, ts.u.derived, attr, 1);
2068 18 : gfc_add_block_to_block (finalblock, &fse.pre);
2069 18 : gfc_add_block_to_block (finalblock, &fse.finalblock);
2070 18 : gfc_add_block_to_block (finalblock, &fse.post);
2071 : }
2072 :
2073 8301 : mpz_clear (size);
2074 8301 : }
2075 :
2076 :
2077 : /* The array constructor code can create a string length with an operand
2078 : in the form of a temporary variable. This variable will retain its
2079 : context (current_function_decl). If we store this length tree in a
2080 : gfc_charlen structure which is shared by a variable in another
2081 : context, the resulting gfc_charlen structure with a variable in a
2082 : different context, we could trip the assertion in expand_expr_real_1
2083 : when it sees that a variable has been created in one context and
2084 : referenced in another.
2085 :
2086 : If this might be the case, we create a new gfc_charlen structure and
2087 : link it into the current namespace. */
2088 :
2089 : static void
2090 8465 : store_backend_decl (gfc_charlen **clp, tree len, bool force_new_cl)
2091 : {
2092 8465 : if (force_new_cl)
2093 : {
2094 8438 : gfc_charlen *new_cl = gfc_new_charlen (gfc_current_ns, *clp);
2095 8438 : *clp = new_cl;
2096 : }
2097 8465 : (*clp)->backend_decl = len;
2098 8465 : }
2099 :
2100 : /* A catch-all to obtain the string length for anything that is not
2101 : a substring of non-constant length, a constant, array or variable. */
2102 :
2103 : static void
2104 330 : get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
2105 : {
2106 330 : gfc_se se;
2107 :
2108 : /* Don't bother if we already know the length is a constant. */
2109 330 : if (*len && INTEGER_CST_P (*len))
2110 52 : return;
2111 :
2112 278 : if (!e->ref && e->ts.u.cl && e->ts.u.cl->length
2113 29 : && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
2114 : {
2115 : /* This is easy. */
2116 1 : gfc_conv_const_charlen (e->ts.u.cl);
2117 1 : *len = e->ts.u.cl->backend_decl;
2118 : }
2119 : else
2120 : {
2121 : /* Otherwise, be brutal even if inefficient. */
2122 277 : gfc_init_se (&se, NULL);
2123 :
2124 : /* No function call, in case of side effects. */
2125 277 : se.no_function_call = 1;
2126 277 : if (e->rank == 0)
2127 134 : gfc_conv_expr (&se, e);
2128 : else
2129 143 : gfc_conv_expr_descriptor (&se, e);
2130 :
2131 : /* Fix the value. */
2132 277 : *len = gfc_evaluate_now (se.string_length, &se.pre);
2133 :
2134 277 : gfc_add_block_to_block (block, &se.pre);
2135 277 : gfc_add_block_to_block (block, &se.post);
2136 :
2137 277 : store_backend_decl (&e->ts.u.cl, *len, true);
2138 : }
2139 : }
2140 :
2141 :
2142 : /* Figure out the string length of a variable reference expression.
2143 : Used by get_array_ctor_strlen. */
2144 :
2145 : static void
2146 930 : get_array_ctor_var_strlen (stmtblock_t *block, gfc_expr * expr, tree * len)
2147 : {
2148 930 : gfc_ref *ref;
2149 930 : gfc_typespec *ts;
2150 930 : mpz_t char_len;
2151 930 : gfc_se se;
2152 :
2153 : /* Don't bother if we already know the length is a constant. */
2154 930 : if (*len && INTEGER_CST_P (*len))
2155 557 : return;
2156 :
2157 468 : ts = &expr->symtree->n.sym->ts;
2158 747 : for (ref = expr->ref; ref; ref = ref->next)
2159 : {
2160 374 : switch (ref->type)
2161 : {
2162 234 : case REF_ARRAY:
2163 : /* Array references don't change the string length. */
2164 234 : if (ts->deferred)
2165 136 : get_array_ctor_all_strlen (block, expr, len);
2166 : break;
2167 :
2168 45 : case REF_COMPONENT:
2169 : /* Use the length of the component. */
2170 45 : ts = &ref->u.c.component->ts;
2171 45 : break;
2172 :
2173 95 : case REF_SUBSTRING:
2174 95 : if (ref->u.ss.end == NULL
2175 83 : || ref->u.ss.start->expr_type != EXPR_CONSTANT
2176 64 : || ref->u.ss.end->expr_type != EXPR_CONSTANT)
2177 : {
2178 : /* Note that this might evaluate expr. */
2179 64 : get_array_ctor_all_strlen (block, expr, len);
2180 64 : return;
2181 : }
2182 31 : mpz_init_set_ui (char_len, 1);
2183 31 : mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
2184 31 : mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
2185 31 : *len = gfc_conv_mpz_to_tree_type (char_len, gfc_charlen_type_node);
2186 31 : mpz_clear (char_len);
2187 31 : return;
2188 :
2189 : case REF_INQUIRY:
2190 : break;
2191 :
2192 0 : default:
2193 0 : gcc_unreachable ();
2194 : }
2195 : }
2196 :
2197 : /* A last ditch attempt that is sometimes needed for deferred characters. */
2198 373 : if (!ts->u.cl->backend_decl)
2199 : {
2200 19 : gfc_init_se (&se, NULL);
2201 19 : if (expr->rank)
2202 12 : gfc_conv_expr_descriptor (&se, expr);
2203 : else
2204 7 : gfc_conv_expr (&se, expr);
2205 19 : gcc_assert (se.string_length != NULL_TREE);
2206 19 : gfc_add_block_to_block (block, &se.pre);
2207 19 : ts->u.cl->backend_decl = se.string_length;
2208 : }
2209 :
2210 373 : *len = ts->u.cl->backend_decl;
2211 : }
2212 :
2213 :
2214 : /* Figure out the string length of a character array constructor.
2215 : If len is NULL, don't calculate the length; this happens for recursive calls
2216 : when a sub-array-constructor is an element but not at the first position,
2217 : so when we're not interested in the length.
2218 : Returns TRUE if all elements are character constants. */
2219 :
2220 : bool
2221 8914 : get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len)
2222 : {
2223 8914 : gfc_constructor *c;
2224 8914 : bool is_const;
2225 :
2226 8914 : is_const = true;
2227 :
2228 8914 : if (gfc_constructor_first (base) == NULL)
2229 : {
2230 315 : if (len)
2231 315 : *len = build_int_cstu (gfc_charlen_type_node, 0);
2232 315 : return is_const;
2233 : }
2234 :
2235 : /* Loop over all constructor elements to find out is_const, but in len we
2236 : want to store the length of the first, not the last, element. We can
2237 : of course exit the loop as soon as is_const is found to be false. */
2238 8599 : for (c = gfc_constructor_first (base);
2239 46896 : c && is_const; c = gfc_constructor_next (c))
2240 : {
2241 38297 : switch (c->expr->expr_type)
2242 : {
2243 37134 : case EXPR_CONSTANT:
2244 37134 : if (len && !(*len && INTEGER_CST_P (*len)))
2245 422 : *len = build_int_cstu (gfc_charlen_type_node,
2246 422 : c->expr->value.character.length);
2247 : break;
2248 :
2249 43 : case EXPR_ARRAY:
2250 43 : if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
2251 1151 : is_const = false;
2252 : break;
2253 :
2254 990 : case EXPR_VARIABLE:
2255 990 : is_const = false;
2256 990 : if (len)
2257 930 : get_array_ctor_var_strlen (block, c->expr, len);
2258 : break;
2259 :
2260 130 : default:
2261 130 : is_const = false;
2262 130 : if (len)
2263 130 : get_array_ctor_all_strlen (block, c->expr, len);
2264 : break;
2265 : }
2266 :
2267 : /* After the first iteration, we don't want the length modified. */
2268 38297 : len = NULL;
2269 : }
2270 :
2271 : return is_const;
2272 : }
2273 :
2274 : /* Check whether the array constructor C consists entirely of constant
2275 : elements, and if so returns the number of those elements, otherwise
2276 : return zero. Note, an empty or NULL array constructor returns zero. */
2277 :
2278 : unsigned HOST_WIDE_INT
2279 59774 : gfc_constant_array_constructor_p (gfc_constructor_base base)
2280 : {
2281 59774 : unsigned HOST_WIDE_INT nelem = 0;
2282 :
2283 59774 : gfc_constructor *c = gfc_constructor_first (base);
2284 543172 : while (c)
2285 : {
2286 430666 : if (c->iterator
2287 429071 : || c->expr->rank > 0
2288 428261 : || c->expr->expr_type != EXPR_CONSTANT)
2289 : return 0;
2290 423624 : c = gfc_constructor_next (c);
2291 423624 : nelem++;
2292 : }
2293 : return nelem;
2294 : }
2295 :
2296 :
2297 : /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
2298 : and the tree type of it's elements, TYPE, return a static constant
2299 : variable that is compile-time initialized. */
2300 :
2301 : tree
2302 42159 : gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
2303 : {
2304 42159 : tree tmptype, init, tmp;
2305 42159 : HOST_WIDE_INT nelem;
2306 42159 : gfc_constructor *c;
2307 42159 : gfc_array_spec as;
2308 42159 : gfc_se se;
2309 42159 : int i;
2310 42159 : vec<constructor_elt, va_gc> *v = NULL;
2311 :
2312 : /* First traverse the constructor list, converting the constants
2313 : to tree to build an initializer. */
2314 42159 : nelem = 0;
2315 42159 : c = gfc_constructor_first (expr->value.constructor);
2316 424423 : while (c)
2317 : {
2318 340105 : gfc_init_se (&se, NULL);
2319 340105 : gfc_conv_constant (&se, c->expr);
2320 340105 : if (c->expr->ts.type != BT_CHARACTER)
2321 303939 : se.expr = fold_convert (type, se.expr);
2322 36166 : else if (POINTER_TYPE_P (type))
2323 36166 : se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
2324 : se.expr);
2325 340105 : CONSTRUCTOR_APPEND_ELT (v, build_int_cst (gfc_array_index_type, nelem),
2326 : se.expr);
2327 340105 : c = gfc_constructor_next (c);
2328 340105 : nelem++;
2329 : }
2330 :
2331 : /* Next determine the tree type for the array. We use the gfortran
2332 : front-end's gfc_get_nodesc_array_type in order to create a suitable
2333 : GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
2334 :
2335 42159 : memset (&as, 0, sizeof (gfc_array_spec));
2336 :
2337 42159 : as.rank = expr->rank;
2338 42159 : as.type = AS_EXPLICIT;
2339 42159 : if (!expr->shape)
2340 : {
2341 4 : as.lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
2342 4 : as.upper[0] = gfc_get_int_expr (gfc_default_integer_kind,
2343 : NULL, nelem - 1);
2344 : }
2345 : else
2346 91013 : for (i = 0; i < expr->rank; i++)
2347 : {
2348 48858 : int tmp = (int) mpz_get_si (expr->shape[i]);
2349 48858 : as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
2350 48858 : as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind,
2351 48858 : NULL, tmp - 1);
2352 : }
2353 :
2354 42159 : tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
2355 :
2356 : /* as is not needed anymore. */
2357 133180 : for (i = 0; i < as.rank + as.corank; i++)
2358 : {
2359 48862 : gfc_free_expr (as.lower[i]);
2360 48862 : gfc_free_expr (as.upper[i]);
2361 : }
2362 :
2363 42159 : init = build_constructor (tmptype, v);
2364 :
2365 42159 : TREE_CONSTANT (init) = 1;
2366 42159 : TREE_STATIC (init) = 1;
2367 :
2368 42159 : tmp = build_decl (input_location, VAR_DECL, create_tmp_var_name ("A"),
2369 : tmptype);
2370 42159 : DECL_ARTIFICIAL (tmp) = 1;
2371 42159 : DECL_IGNORED_P (tmp) = 1;
2372 42159 : TREE_STATIC (tmp) = 1;
2373 42159 : TREE_CONSTANT (tmp) = 1;
2374 42159 : TREE_READONLY (tmp) = 1;
2375 42159 : DECL_INITIAL (tmp) = init;
2376 42159 : pushdecl (tmp);
2377 :
2378 42159 : return tmp;
2379 : }
2380 :
2381 :
2382 : /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
2383 : This mostly initializes the scalarizer state info structure with the
2384 : appropriate values to directly use the array created by the function
2385 : gfc_build_constant_array_constructor. */
2386 :
2387 : static void
2388 36260 : trans_constant_array_constructor (gfc_ss * ss, tree type)
2389 : {
2390 36260 : gfc_array_info *info;
2391 36260 : tree tmp;
2392 36260 : int i;
2393 :
2394 36260 : tmp = gfc_build_constant_array_constructor (ss->info->expr, type);
2395 :
2396 36260 : info = &ss->info->data.array;
2397 :
2398 36260 : info->descriptor = tmp;
2399 36260 : info->data = gfc_build_addr_expr (NULL_TREE, tmp);
2400 36260 : info->offset = gfc_index_zero_node;
2401 :
2402 76351 : for (i = 0; i < ss->dimen; i++)
2403 : {
2404 40091 : info->delta[i] = gfc_index_zero_node;
2405 40091 : info->start[i] = gfc_index_zero_node;
2406 40091 : info->end[i] = gfc_index_zero_node;
2407 40091 : info->stride[i] = gfc_index_one_node;
2408 : }
2409 36260 : }
2410 :
2411 :
2412 : static int
2413 36266 : get_rank (gfc_loopinfo *loop)
2414 : {
2415 36266 : int rank;
2416 :
2417 36266 : rank = 0;
2418 155756 : for (; loop; loop = loop->parent)
2419 77884 : rank += loop->dimen;
2420 :
2421 41606 : return rank;
2422 : }
2423 :
2424 :
2425 : /* Helper routine of gfc_trans_array_constructor to determine if the
2426 : bounds of the loop specified by LOOP are constant and simple enough
2427 : to use with trans_constant_array_constructor. Returns the
2428 : iteration count of the loop if suitable, and NULL_TREE otherwise. */
2429 :
2430 : static tree
2431 36266 : constant_array_constructor_loop_size (gfc_loopinfo * l)
2432 : {
2433 36266 : gfc_loopinfo *loop;
2434 36266 : tree size = gfc_index_one_node;
2435 36266 : tree tmp;
2436 36266 : int i, total_dim;
2437 :
2438 36266 : total_dim = get_rank (l);
2439 :
2440 72532 : for (loop = l; loop; loop = loop->parent)
2441 : {
2442 76375 : for (i = 0; i < loop->dimen; i++)
2443 : {
2444 : /* If the bounds aren't constant, return NULL_TREE. */
2445 40109 : if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
2446 : return NULL_TREE;
2447 40103 : if (!integer_zerop (loop->from[i]))
2448 : {
2449 : /* Only allow nonzero "from" in one-dimensional arrays. */
2450 0 : if (total_dim != 1)
2451 : return NULL_TREE;
2452 0 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2453 : gfc_array_index_type,
2454 : loop->to[i], loop->from[i]);
2455 : }
2456 : else
2457 40103 : tmp = loop->to[i];
2458 40103 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
2459 : gfc_array_index_type, tmp, gfc_index_one_node);
2460 40103 : size = fold_build2_loc (input_location, MULT_EXPR,
2461 : gfc_array_index_type, size, tmp);
2462 : }
2463 : }
2464 :
2465 : return size;
2466 : }
2467 :
2468 :
2469 : static tree *
2470 43058 : get_loop_upper_bound_for_array (gfc_ss *array, int array_dim)
2471 : {
2472 43058 : gfc_ss *ss;
2473 43058 : int n;
2474 :
2475 43058 : gcc_assert (array->nested_ss == NULL);
2476 :
2477 43058 : for (ss = array; ss; ss = ss->parent)
2478 43058 : for (n = 0; n < ss->loop->dimen; n++)
2479 43058 : if (array_dim == get_array_ref_dim_for_loop_dim (ss, n))
2480 43058 : return &(ss->loop->to[n]);
2481 :
2482 0 : gcc_unreachable ();
2483 : }
2484 :
2485 :
2486 : static gfc_loopinfo *
2487 710779 : outermost_loop (gfc_loopinfo * loop)
2488 : {
2489 927497 : while (loop->parent != NULL)
2490 : loop = loop->parent;
2491 :
2492 717467 : return loop;
2493 : }
2494 :
2495 :
2496 : /* Array constructors are handled by constructing a temporary, then using that
2497 : within the scalarization loop. This is not optimal, but seems by far the
2498 : simplest method. */
2499 :
2500 : static void
2501 43058 : trans_array_constructor (gfc_ss * ss, locus * where)
2502 : {
2503 43058 : gfc_constructor_base c;
2504 43058 : tree offset;
2505 43058 : tree offsetvar;
2506 43058 : tree desc;
2507 43058 : tree type;
2508 43058 : tree tmp;
2509 43058 : tree *loop_ubound0;
2510 43058 : bool dynamic;
2511 43058 : bool old_first_len, old_typespec_chararray_ctor;
2512 43058 : tree old_first_len_val;
2513 43058 : gfc_loopinfo *loop, *outer_loop;
2514 43058 : gfc_ss_info *ss_info;
2515 43058 : gfc_expr *expr;
2516 43058 : gfc_ss *s;
2517 43058 : tree neg_len;
2518 43058 : char *msg;
2519 43058 : stmtblock_t finalblock;
2520 43058 : bool finalize_required;
2521 43058 : bool owned_sweep = false;
2522 :
2523 : /* Save the old values for nested checking. */
2524 43058 : old_first_len = first_len;
2525 43058 : old_first_len_val = first_len_val;
2526 43058 : old_typespec_chararray_ctor = typespec_chararray_ctor;
2527 :
2528 43058 : loop = ss->loop;
2529 43058 : outer_loop = outermost_loop (loop);
2530 43058 : ss_info = ss->info;
2531 43058 : expr = ss_info->expr;
2532 :
2533 : /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
2534 : typespec was given for the array constructor. */
2535 86116 : typespec_chararray_ctor = (expr->ts.type == BT_CHARACTER
2536 8188 : && expr->ts.u.cl
2537 51246 : && expr->ts.u.cl->length_from_typespec);
2538 :
2539 43058 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2540 2542 : && expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
2541 : {
2542 1468 : first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
2543 1468 : first_len = true;
2544 : }
2545 :
2546 43058 : gcc_assert (ss->dimen == ss->loop->dimen);
2547 :
2548 43058 : c = expr->value.constructor;
2549 43058 : if (expr->ts.type == BT_CHARACTER)
2550 : {
2551 8188 : bool const_string;
2552 8188 : bool force_new_cl = false;
2553 :
2554 : /* get_array_ctor_strlen walks the elements of the constructor, if a
2555 : typespec was given, we already know the string length and want the one
2556 : specified there. */
2557 8188 : if (typespec_chararray_ctor && expr->ts.u.cl->length
2558 518 : && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
2559 : {
2560 27 : gfc_se length_se;
2561 :
2562 27 : const_string = false;
2563 27 : gfc_init_se (&length_se, NULL);
2564 27 : gfc_conv_expr_type (&length_se, expr->ts.u.cl->length,
2565 : gfc_charlen_type_node);
2566 27 : ss_info->string_length = length_se.expr;
2567 :
2568 : /* Check if the character length is negative. If it is, then
2569 : set LEN = 0. */
2570 27 : neg_len = fold_build2_loc (input_location, LT_EXPR,
2571 : logical_type_node, ss_info->string_length,
2572 27 : build_zero_cst (TREE_TYPE
2573 : (ss_info->string_length)));
2574 : /* Print a warning if bounds checking is enabled. */
2575 27 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2576 : {
2577 18 : msg = xasprintf ("Negative character length treated as LEN = 0");
2578 18 : gfc_trans_runtime_check (false, true, neg_len, &length_se.pre,
2579 : where, msg);
2580 18 : free (msg);
2581 : }
2582 :
2583 27 : ss_info->string_length
2584 27 : = fold_build3_loc (input_location, COND_EXPR,
2585 : gfc_charlen_type_node, neg_len,
2586 : build_zero_cst
2587 27 : (TREE_TYPE (ss_info->string_length)),
2588 : ss_info->string_length);
2589 27 : ss_info->string_length = gfc_evaluate_now (ss_info->string_length,
2590 : &length_se.pre);
2591 27 : gfc_add_block_to_block (&outer_loop->pre, &length_se.pre);
2592 27 : gfc_add_block_to_block (&outer_loop->post, &length_se.post);
2593 27 : }
2594 : else
2595 : {
2596 8161 : const_string = get_array_ctor_strlen (&outer_loop->pre, c,
2597 : &ss_info->string_length);
2598 8161 : force_new_cl = true;
2599 :
2600 : /* Initialize "len" with string length for bounds checking. */
2601 8161 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2602 1486 : && !typespec_chararray_ctor
2603 1468 : && ss_info->string_length)
2604 : {
2605 1468 : gfc_se length_se;
2606 :
2607 1468 : gfc_init_se (&length_se, NULL);
2608 1468 : gfc_add_modify (&length_se.pre, first_len_val,
2609 1468 : fold_convert (TREE_TYPE (first_len_val),
2610 : ss_info->string_length));
2611 1468 : ss_info->string_length = gfc_evaluate_now (ss_info->string_length,
2612 : &length_se.pre);
2613 1468 : gfc_add_block_to_block (&outer_loop->pre, &length_se.pre);
2614 1468 : gfc_add_block_to_block (&outer_loop->post, &length_se.post);
2615 : }
2616 : }
2617 :
2618 : /* Complex character array constructors should have been taken care of
2619 : and not end up here. */
2620 8188 : gcc_assert (ss_info->string_length);
2621 :
2622 8188 : store_backend_decl (&expr->ts.u.cl, ss_info->string_length, force_new_cl);
2623 :
2624 8188 : type = gfc_get_character_type_len (expr->ts.kind, ss_info->string_length);
2625 8188 : if (const_string)
2626 7237 : type = build_pointer_type (type);
2627 : }
2628 : else
2629 34895 : type = gfc_typenode_for_spec (expr->ts.type == BT_CLASS
2630 25 : ? &CLASS_DATA (expr)->ts : &expr->ts);
2631 :
2632 : /* See if the constructor determines the loop bounds. */
2633 43058 : dynamic = false;
2634 :
2635 43058 : loop_ubound0 = get_loop_upper_bound_for_array (ss, 0);
2636 :
2637 84664 : if (expr->shape && get_rank (loop) > 1 && *loop_ubound0 == NULL_TREE)
2638 : {
2639 : /* We have a multidimensional parameter. */
2640 0 : for (s = ss; s; s = s->parent)
2641 : {
2642 : int n;
2643 0 : for (n = 0; n < s->loop->dimen; n++)
2644 : {
2645 0 : s->loop->from[n] = gfc_index_zero_node;
2646 0 : s->loop->to[n] = gfc_conv_mpz_to_tree (expr->shape[s->dim[n]],
2647 : gfc_index_integer_kind);
2648 0 : s->loop->to[n] = fold_build2_loc (input_location, MINUS_EXPR,
2649 : gfc_array_index_type,
2650 0 : s->loop->to[n],
2651 : gfc_index_one_node);
2652 : }
2653 : }
2654 : }
2655 :
2656 43058 : if (*loop_ubound0 == NULL_TREE)
2657 : {
2658 893 : mpz_t size;
2659 :
2660 : /* We should have a 1-dimensional, zero-based loop. */
2661 893 : gcc_assert (loop->parent == NULL && loop->nested == NULL);
2662 893 : gcc_assert (loop->dimen == 1);
2663 893 : gcc_assert (integer_zerop (loop->from[0]));
2664 :
2665 : /* Split the constructor size into a static part and a dynamic part.
2666 : Allocate the static size up-front and record whether the dynamic
2667 : size might be nonzero. */
2668 893 : mpz_init (size);
2669 893 : dynamic = gfc_get_array_constructor_size (&size, c);
2670 893 : mpz_sub_ui (size, size, 1);
2671 893 : loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
2672 893 : mpz_clear (size);
2673 : }
2674 :
2675 : /* Special case constant array constructors. */
2676 893 : if (!dynamic)
2677 : {
2678 42190 : unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
2679 42190 : if (nelem > 0)
2680 : {
2681 36266 : tree size = constant_array_constructor_loop_size (loop);
2682 36266 : if (size && compare_tree_int (size, nelem) == 0)
2683 : {
2684 36260 : trans_constant_array_constructor (ss, type);
2685 36260 : goto finish;
2686 : }
2687 : }
2688 : }
2689 :
2690 6798 : gfc_trans_create_temp_array (&outer_loop->pre, &outer_loop->post, ss, type,
2691 : NULL_TREE, dynamic, true, false, where);
2692 :
2693 6798 : desc = ss_info->data.array.descriptor;
2694 6798 : offset = gfc_index_zero_node;
2695 6798 : offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
2696 6798 : suppress_warning (offsetvar);
2697 6798 : TREE_USED (offsetvar) = 0;
2698 :
2699 6798 : gfc_init_block (&finalblock);
2700 6798 : finalize_required = expr->must_finalize;
2701 6798 : if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
2702 : finalize_required = true;
2703 :
2704 6798 : if (IS_PDT (expr))
2705 : finalize_required = true;
2706 :
2707 : /* If every element of the constructor is a function result with allocatable
2708 : components, those components are owned by the temporary and are freed in a
2709 : single sweep over the whole array below. This is the only way to free the
2710 : elements produced inside an implied-do loop, where a single compile-time
2711 : element stands for many runtime elements. */
2712 14075 : owned_sweep = finalize_required
2713 552 : && expr->ts.type == BT_DERIVED
2714 552 : && expr->ts.u.derived->attr.alloc_comp
2715 7192 : && gfc_constructor_is_owned_alloc_comp (c, expr->ts.u.derived);
2716 :
2717 6798 : gfc_trans_array_constructor_value (&outer_loop->pre,
2718 : finalize_required ? &finalblock : NULL,
2719 : type, desc, c, &offset, &offsetvar,
2720 : dynamic, owned_sweep);
2721 :
2722 6798 : if (owned_sweep)
2723 250 : gfc_add_expr_to_block (&finalblock,
2724 250 : gfc_deallocate_alloc_comp_no_caf (expr->ts.u.derived,
2725 : desc, 1, true));
2726 :
2727 : /* If the array grows dynamically, the upper bound of the loop variable
2728 : is determined by the array's final upper bound. */
2729 6798 : if (dynamic)
2730 : {
2731 868 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2732 : gfc_array_index_type,
2733 : offsetvar, gfc_index_one_node);
2734 868 : tmp = gfc_evaluate_now (tmp, &outer_loop->pre);
2735 868 : if (*loop_ubound0 && VAR_P (*loop_ubound0))
2736 0 : gfc_add_modify (&outer_loop->pre, *loop_ubound0, tmp);
2737 : else
2738 868 : *loop_ubound0 = tmp;
2739 : }
2740 :
2741 6798 : if (TREE_USED (offsetvar))
2742 2180 : pushdecl (offsetvar);
2743 : else
2744 4618 : gcc_assert (INTEGER_CST_P (offset));
2745 :
2746 : #if 0
2747 : /* Disable bound checking for now because it's probably broken. */
2748 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2749 : {
2750 : gcc_unreachable ();
2751 : }
2752 : #endif
2753 :
2754 4618 : finish:
2755 : /* Restore old values of globals. */
2756 43058 : first_len = old_first_len;
2757 43058 : first_len_val = old_first_len_val;
2758 43058 : typespec_chararray_ctor = old_typespec_chararray_ctor;
2759 :
2760 : /* F2008 4.5.6.3 para 5: If an executable construct references a structure
2761 : constructor or array constructor, the entity created by the constructor is
2762 : finalized after execution of the innermost executable construct containing
2763 : the reference. */
2764 43058 : if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
2765 1725 : && finalblock.head != NULL_TREE)
2766 322 : gfc_prepend_expr_to_block (&loop->post, finalblock.head);
2767 43058 : }
2768 :
2769 :
2770 : /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
2771 : called after evaluating all of INFO's vector dimensions. Go through
2772 : each such vector dimension and see if we can now fill in any missing
2773 : loop bounds. */
2774 :
2775 : static void
2776 182152 : set_vector_loop_bounds (gfc_ss * ss)
2777 : {
2778 182152 : gfc_loopinfo *loop, *outer_loop;
2779 182152 : gfc_array_info *info;
2780 182152 : gfc_se se;
2781 182152 : tree tmp;
2782 182152 : tree desc;
2783 182152 : tree zero;
2784 182152 : int n;
2785 182152 : int dim;
2786 :
2787 182152 : outer_loop = outermost_loop (ss->loop);
2788 :
2789 182152 : info = &ss->info->data.array;
2790 :
2791 368940 : for (; ss; ss = ss->parent)
2792 : {
2793 186788 : loop = ss->loop;
2794 :
2795 444927 : for (n = 0; n < loop->dimen; n++)
2796 : {
2797 258139 : dim = ss->dim[n];
2798 258139 : if (info->ref->u.ar.dimen_type[dim] != DIMEN_VECTOR
2799 980 : || loop->to[n] != NULL)
2800 257959 : continue;
2801 :
2802 : /* Loop variable N indexes vector dimension DIM, and we don't
2803 : yet know the upper bound of loop variable N. Set it to the
2804 : difference between the vector's upper and lower bounds. */
2805 180 : gcc_assert (loop->from[n] == gfc_index_zero_node);
2806 180 : gcc_assert (info->subscript[dim]
2807 : && info->subscript[dim]->info->type == GFC_SS_VECTOR);
2808 :
2809 180 : gfc_init_se (&se, NULL);
2810 180 : desc = info->subscript[dim]->info->data.array.descriptor;
2811 180 : zero = gfc_rank_cst[0];
2812 180 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2813 : gfc_array_index_type,
2814 : gfc_conv_descriptor_ubound_get (desc, zero),
2815 : gfc_conv_descriptor_lbound_get (desc, zero));
2816 180 : tmp = gfc_evaluate_now (tmp, &outer_loop->pre);
2817 180 : loop->to[n] = tmp;
2818 : }
2819 : }
2820 182152 : }
2821 :
2822 :
2823 : /* Tells whether a scalar argument to an elemental procedure is saved out
2824 : of a scalarization loop as a value or as a reference. */
2825 :
2826 : bool
2827 45790 : gfc_scalar_elemental_arg_saved_as_reference (gfc_ss_info * ss_info)
2828 : {
2829 45790 : if (ss_info->type != GFC_SS_REFERENCE)
2830 : return false;
2831 :
2832 10294 : if (ss_info->data.scalar.needs_temporary)
2833 : return false;
2834 :
2835 : /* If the actual argument can be absent (in other words, it can
2836 : be a NULL reference), don't try to evaluate it; pass instead
2837 : the reference directly. */
2838 9918 : if (ss_info->can_be_null_ref)
2839 : return true;
2840 :
2841 : /* If the expression is of polymorphic type, it's actual size is not known,
2842 : so we avoid copying it anywhere. */
2843 9242 : if (ss_info->data.scalar.dummy_arg
2844 1402 : && gfc_dummy_arg_get_typespec (*ss_info->data.scalar.dummy_arg).type
2845 : == BT_CLASS
2846 9366 : && ss_info->expr->ts.type == BT_CLASS)
2847 : return true;
2848 :
2849 : /* If the expression is a data reference of aggregate type,
2850 : and the data reference is not used on the left hand side,
2851 : avoid a copy by saving a reference to the content. */
2852 9218 : if (!ss_info->data.scalar.needs_temporary
2853 9218 : && (ss_info->expr->ts.type == BT_DERIVED
2854 8230 : || ss_info->expr->ts.type == BT_CLASS)
2855 10254 : && gfc_expr_is_variable (ss_info->expr))
2856 : return true;
2857 :
2858 : /* Otherwise the expression is evaluated to a temporary variable before the
2859 : scalarization loop. */
2860 : return false;
2861 : }
2862 :
2863 :
2864 : /* Add the pre and post chains for all the scalar expressions in a SS chain
2865 : to loop. This is called after the loop parameters have been calculated,
2866 : but before the actual scalarizing loops. */
2867 :
2868 : static void
2869 191685 : gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
2870 : locus * where)
2871 : {
2872 191685 : gfc_loopinfo *nested_loop, *outer_loop;
2873 191685 : gfc_se se;
2874 191685 : gfc_ss_info *ss_info;
2875 191685 : gfc_array_info *info;
2876 191685 : gfc_expr *expr;
2877 191685 : int n;
2878 :
2879 : /* Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise,
2880 : arguments could get evaluated multiple times. */
2881 191685 : if (ss->is_alloc_lhs)
2882 203 : return;
2883 :
2884 504766 : outer_loop = outermost_loop (loop);
2885 :
2886 : /* TODO: This can generate bad code if there are ordering dependencies,
2887 : e.g., a callee allocated function and an unknown size constructor. */
2888 : gcc_assert (ss != NULL);
2889 :
2890 504766 : for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
2891 : {
2892 313284 : gcc_assert (ss);
2893 :
2894 : /* Cross loop arrays are handled from within the most nested loop. */
2895 313284 : if (ss->nested_ss != NULL)
2896 4740 : continue;
2897 :
2898 308544 : ss_info = ss->info;
2899 308544 : expr = ss_info->expr;
2900 308544 : info = &ss_info->data.array;
2901 :
2902 308544 : switch (ss_info->type)
2903 : {
2904 43635 : case GFC_SS_SCALAR:
2905 : /* Scalar expression. Evaluate this now. This includes elemental
2906 : dimension indices, but not array section bounds. */
2907 43635 : gfc_init_se (&se, NULL);
2908 43635 : gfc_conv_expr (&se, expr);
2909 43635 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
2910 :
2911 43635 : if (expr->ts.type != BT_CHARACTER
2912 43635 : && !gfc_is_alloc_class_scalar_function (expr))
2913 : {
2914 : /* Move the evaluation of scalar expressions outside the
2915 : scalarization loop, except for WHERE assignments. */
2916 39641 : if (subscript)
2917 6468 : se.expr = convert(gfc_array_index_type, se.expr);
2918 39641 : if (!ss_info->where)
2919 39227 : se.expr = gfc_evaluate_now (se.expr, &outer_loop->pre);
2920 39641 : gfc_add_block_to_block (&outer_loop->pre, &se.post);
2921 : }
2922 : else
2923 3994 : gfc_add_block_to_block (&outer_loop->post, &se.post);
2924 :
2925 43635 : ss_info->data.scalar.value = se.expr;
2926 43635 : ss_info->string_length = se.string_length;
2927 43635 : break;
2928 :
2929 5147 : case GFC_SS_REFERENCE:
2930 : /* Scalar argument to elemental procedure. */
2931 5147 : gfc_init_se (&se, NULL);
2932 5147 : if (gfc_scalar_elemental_arg_saved_as_reference (ss_info))
2933 844 : gfc_conv_expr_reference (&se, expr);
2934 : else
2935 : {
2936 : /* Evaluate the argument outside the loop and pass
2937 : a reference to the value. */
2938 4303 : gfc_conv_expr (&se, expr);
2939 : }
2940 :
2941 : /* Ensure that a pointer to the string is stored. */
2942 5147 : if (expr->ts.type == BT_CHARACTER)
2943 174 : gfc_conv_string_parameter (&se);
2944 :
2945 5147 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
2946 5147 : gfc_add_block_to_block (&outer_loop->post, &se.post);
2947 5147 : if (gfc_is_class_scalar_expr (expr))
2948 : /* This is necessary because the dynamic type will always be
2949 : large than the declared type. In consequence, assigning
2950 : the value to a temporary could segfault.
2951 : OOP-TODO: see if this is generally correct or is the value
2952 : has to be written to an allocated temporary, whose address
2953 : is passed via ss_info. */
2954 48 : ss_info->data.scalar.value = se.expr;
2955 : else
2956 5099 : ss_info->data.scalar.value = gfc_evaluate_now (se.expr,
2957 : &outer_loop->pre);
2958 :
2959 5147 : ss_info->string_length = se.string_length;
2960 5147 : break;
2961 :
2962 : case GFC_SS_SECTION:
2963 : /* Add the expressions for scalar and vector subscripts. */
2964 2914432 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2965 2732280 : if (info->subscript[n])
2966 7448 : gfc_add_loop_ss_code (loop, info->subscript[n], true, where);
2967 :
2968 182152 : set_vector_loop_bounds (ss);
2969 182152 : break;
2970 :
2971 980 : case GFC_SS_VECTOR:
2972 : /* Get the vector's descriptor and store it in SS. */
2973 980 : gfc_init_se (&se, NULL);
2974 980 : gfc_conv_expr_descriptor (&se, expr);
2975 980 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
2976 980 : gfc_add_block_to_block (&outer_loop->post, &se.post);
2977 980 : info->descriptor = se.expr;
2978 980 : break;
2979 :
2980 11581 : case GFC_SS_INTRINSIC:
2981 11581 : gfc_add_intrinsic_ss_code (loop, ss);
2982 11581 : break;
2983 :
2984 9570 : case GFC_SS_FUNCTION:
2985 9570 : {
2986 : /* Array function return value. We call the function and save its
2987 : result in a temporary for use inside the loop. */
2988 9570 : gfc_init_se (&se, NULL);
2989 9570 : se.loop = loop;
2990 9570 : se.ss = ss;
2991 9570 : bool class_func = gfc_is_class_array_function (expr);
2992 9570 : if (class_func)
2993 183 : expr->must_finalize = 1;
2994 9570 : gfc_conv_expr (&se, expr);
2995 9570 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
2996 9570 : if (class_func
2997 183 : && se.expr
2998 9753 : && GFC_CLASS_TYPE_P (TREE_TYPE (se.expr)))
2999 : {
3000 183 : tree tmp = gfc_class_data_get (se.expr);
3001 183 : info->descriptor = tmp;
3002 183 : info->data = gfc_conv_descriptor_data_get (tmp);
3003 183 : info->offset = gfc_conv_descriptor_offset_get (tmp);
3004 366 : for (gfc_ss *s = ss; s; s = s->parent)
3005 378 : for (int n = 0; n < s->dimen; n++)
3006 : {
3007 195 : int dim = s->dim[n];
3008 195 : tree tree_dim = gfc_rank_cst[dim];
3009 :
3010 195 : tree start;
3011 195 : start = gfc_conv_descriptor_lbound_get (tmp, tree_dim);
3012 195 : start = gfc_evaluate_now (start, &outer_loop->pre);
3013 195 : info->start[dim] = start;
3014 :
3015 195 : tree end;
3016 195 : end = gfc_conv_descriptor_ubound_get (tmp, tree_dim);
3017 195 : end = gfc_evaluate_now (end, &outer_loop->pre);
3018 195 : info->end[dim] = end;
3019 :
3020 195 : tree stride;
3021 195 : stride = gfc_conv_descriptor_stride_get (tmp, tree_dim);
3022 195 : stride = gfc_evaluate_now (stride, &outer_loop->pre);
3023 195 : info->stride[dim] = stride;
3024 : }
3025 : }
3026 9570 : gfc_add_block_to_block (&outer_loop->post, &se.post);
3027 9570 : gfc_add_block_to_block (&outer_loop->post, &se.finalblock);
3028 9570 : ss_info->string_length = se.string_length;
3029 : }
3030 9570 : break;
3031 :
3032 43058 : case GFC_SS_CONSTRUCTOR:
3033 43058 : if (expr->ts.type == BT_CHARACTER
3034 8188 : && ss_info->string_length == NULL
3035 8188 : && expr->ts.u.cl
3036 8188 : && expr->ts.u.cl->length
3037 7844 : && expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
3038 : {
3039 7793 : gfc_init_se (&se, NULL);
3040 7793 : gfc_conv_expr_type (&se, expr->ts.u.cl->length,
3041 : gfc_charlen_type_node);
3042 7793 : ss_info->string_length = se.expr;
3043 7793 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3044 7793 : gfc_add_block_to_block (&outer_loop->post, &se.post);
3045 : }
3046 43058 : trans_array_constructor (ss, where);
3047 43058 : break;
3048 :
3049 : case GFC_SS_TEMP:
3050 : case GFC_SS_COMPONENT:
3051 : /* Do nothing. These are handled elsewhere. */
3052 : break;
3053 :
3054 0 : default:
3055 0 : gcc_unreachable ();
3056 : }
3057 : }
3058 :
3059 191482 : if (!subscript)
3060 187398 : for (nested_loop = loop->nested; nested_loop;
3061 3364 : nested_loop = nested_loop->next)
3062 3364 : gfc_add_loop_ss_code (nested_loop, nested_loop->ss, subscript, where);
3063 : }
3064 :
3065 :
3066 : /* Given an array descriptor expression DESCR and its data pointer DATA, decide
3067 : whether to either save the data pointer to a variable and use the variable or
3068 : use the data pointer expression directly without any intermediary variable.
3069 : */
3070 :
3071 : static bool
3072 129731 : save_descriptor_data (tree descr, tree data)
3073 : {
3074 129731 : return !(DECL_P (data)
3075 118689 : || (TREE_CODE (data) == ADDR_EXPR
3076 70082 : && DECL_P (TREE_OPERAND (data, 0)))
3077 51714 : || (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (descr))
3078 48215 : && TREE_CODE (descr) == COMPONENT_REF
3079 11189 : && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (descr, 0)))));
3080 : }
3081 :
3082 :
3083 : /* Type of the DATA argument passed to walk_tree by substitute_subexpr_in_expr
3084 : and used by maybe_substitute_expr. */
3085 :
3086 : typedef struct
3087 : {
3088 : tree target, repl;
3089 : }
3090 : substitute_t;
3091 :
3092 :
3093 : /* Check if the expression in *TP is equal to the substitution target provided
3094 : in DATA->TARGET and replace it with DATA->REPL in that case. This is a
3095 : callback function for use with walk_tree. */
3096 :
3097 : static tree
3098 21411 : maybe_substitute_expr (tree *tp, int *walk_subtree, void *data)
3099 : {
3100 21411 : substitute_t *subst = (substitute_t *) data;
3101 21411 : if (*tp == subst->target)
3102 : {
3103 4102 : *tp = subst->repl;
3104 4102 : *walk_subtree = 0;
3105 : }
3106 :
3107 21411 : return NULL_TREE;
3108 : }
3109 :
3110 :
3111 : /* Substitute in EXPR any occurrence of TARGET with REPLACEMENT. */
3112 :
3113 : static void
3114 3795 : substitute_subexpr_in_expr (tree target, tree replacement, tree expr)
3115 : {
3116 3795 : substitute_t subst;
3117 3795 : subst.target = target;
3118 3795 : subst.repl = replacement;
3119 :
3120 3795 : walk_tree (&expr, maybe_substitute_expr, &subst, nullptr);
3121 3795 : }
3122 :
3123 :
3124 : /* Save REF to a fresh variable in all of REPLACEMENT_ROOTS, appending extra
3125 : code to CODE. Before returning, add REF to REPLACEMENT_ROOTS and clear
3126 : REF. */
3127 :
3128 : static void
3129 3623 : save_ref (tree &code, tree &ref, vec<tree> &replacement_roots)
3130 : {
3131 3623 : stmtblock_t tmp_block;
3132 3623 : gfc_init_block (&tmp_block);
3133 3623 : tree var = gfc_evaluate_now (ref, &tmp_block);
3134 3623 : gfc_add_expr_to_block (&tmp_block, code);
3135 3623 : code = gfc_finish_block (&tmp_block);
3136 :
3137 3623 : unsigned i;
3138 3623 : tree repl_root;
3139 7418 : FOR_EACH_VEC_ELT (replacement_roots, i, repl_root)
3140 3795 : substitute_subexpr_in_expr (ref, var, repl_root);
3141 :
3142 3623 : replacement_roots.safe_push (ref);
3143 3623 : ref = NULL_TREE;
3144 3623 : }
3145 :
3146 :
3147 : /* If REF isn't shared with code in PREVIOUS_CODE, replace it with a fresh
3148 : variable in all of REPLACEMENT_ROOTS, appending extra code to CODE. */
3149 :
3150 : static void
3151 3695 : maybe_save_ref (tree &code, tree &ref, vec<tree> &replacement_roots,
3152 : stmtblock_t *previous_code)
3153 : {
3154 3695 : if (find_tree (previous_code->head, ref))
3155 : return;
3156 :
3157 3623 : save_ref (code, ref, replacement_roots);
3158 : }
3159 :
3160 :
3161 : /* Save the descriptor reference VALUE to storage pointed by DESC_PTR. Before
3162 : that, try to create fresh variables to factor subexpressions of VALUE, if
3163 : those subexpressions aren't shared with code in PRELIMINARY_CODE. Add any
3164 : necessary additional code (initialization of variables typically) to BLOCK.
3165 :
3166 : The candidate references to factoring are dereferenced pointers because they
3167 : are cheap to copy and array descriptors because they are often the base of
3168 : multiple subreferences. */
3169 :
3170 : static void
3171 326949 : set_factored_descriptor_value (tree *desc_ptr, tree value, stmtblock_t *block,
3172 : stmtblock_t *preliminary_code)
3173 : {
3174 : /* As the reference is processed from outer to inner, variable definitions
3175 : will be generated in reversed order, so can't be put directly in BLOCK.
3176 : We use temporary blocks instead, which we save in ACCUMULATED_CODE, and
3177 : only append to BLOCK at the end. */
3178 326949 : tree accumulated_code = NULL_TREE;
3179 :
3180 : /* The current candidate to factoring. */
3181 326949 : tree saveable_ref = NULL_TREE;
3182 :
3183 : /* The root expressions in which we look for subexpressions to replace with
3184 : variables. */
3185 326949 : auto_vec<tree> replacement_roots;
3186 326949 : replacement_roots.safe_push (value);
3187 :
3188 326949 : tree data_ref = value;
3189 326949 : tree next_ref = NULL_TREE;
3190 :
3191 : /* If the candidate reference is not followed by a subreference, it can't be
3192 : saved to a variable as it may be reallocatable, and we have to keep the
3193 : parent reference to be able to store the new pointer value in case of
3194 : reallocation. */
3195 326949 : bool maybe_reallocatable = true;
3196 :
3197 435444 : while (true)
3198 : {
3199 435444 : if (!maybe_reallocatable
3200 435444 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (data_ref)))
3201 2434 : saveable_ref = data_ref;
3202 :
3203 435444 : if (TREE_CODE (data_ref) == INDIRECT_REF)
3204 : {
3205 58549 : next_ref = TREE_OPERAND (data_ref, 0);
3206 :
3207 58549 : if (!maybe_reallocatable)
3208 : {
3209 14765 : if (saveable_ref != NULL_TREE && saveable_ref != data_ref)
3210 : {
3211 : /* A reference worth saving has been seen, and now the pointer
3212 : to the current reference is also worth saving. If the
3213 : previous reference to save wasn't the current one, do save
3214 : it now. Otherwise drop it as we prefer saving the
3215 : pointer. */
3216 1827 : maybe_save_ref (accumulated_code, saveable_ref,
3217 : replacement_roots, preliminary_code);
3218 : }
3219 :
3220 : /* Don't evaluate the pointer to a variable yet; do it only if the
3221 : variable would be significantly more simple than the reference
3222 : it replaces. That is if the reference contains anything
3223 : different from NOPs, COMPONENTs and DECLs. */
3224 14765 : saveable_ref = next_ref;
3225 : }
3226 : }
3227 376895 : else if (TREE_CODE (data_ref) == COMPONENT_REF)
3228 : {
3229 40839 : maybe_reallocatable = false;
3230 40839 : next_ref = TREE_OPERAND (data_ref, 0);
3231 : }
3232 336056 : else if (TREE_CODE (data_ref) == NOP_EXPR)
3233 3695 : next_ref = TREE_OPERAND (data_ref, 0);
3234 : else
3235 : {
3236 332361 : if (DECL_P (data_ref))
3237 : break;
3238 :
3239 6994 : if (TREE_CODE (data_ref) == ARRAY_REF)
3240 : {
3241 5412 : maybe_reallocatable = false;
3242 5412 : next_ref = TREE_OPERAND (data_ref, 0);
3243 : }
3244 :
3245 6994 : if (saveable_ref != NULL_TREE)
3246 : /* We have seen a reference worth saving. Do it now. */
3247 1868 : maybe_save_ref (accumulated_code, saveable_ref, replacement_roots,
3248 : preliminary_code);
3249 :
3250 6994 : if (TREE_CODE (data_ref) != ARRAY_REF)
3251 : break;
3252 : }
3253 :
3254 : data_ref = next_ref;
3255 : }
3256 :
3257 326949 : *desc_ptr = value;
3258 326949 : gfc_add_expr_to_block (block, accumulated_code);
3259 326949 : }
3260 :
3261 :
3262 : /* Translate expressions for the descriptor and data pointer of a SS. */
3263 : /*GCC ARRAYS*/
3264 :
3265 : static void
3266 326949 : gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
3267 : {
3268 326949 : gfc_se se;
3269 326949 : gfc_ss_info *ss_info;
3270 326949 : gfc_array_info *info;
3271 326949 : tree tmp;
3272 :
3273 326949 : ss_info = ss->info;
3274 326949 : info = &ss_info->data.array;
3275 :
3276 : /* Get the descriptor for the array to be scalarized. */
3277 326949 : gcc_assert (ss_info->expr->expr_type == EXPR_VARIABLE);
3278 326949 : gfc_init_se (&se, NULL);
3279 326949 : se.descriptor_only = 1;
3280 326949 : gfc_conv_expr_lhs (&se, ss_info->expr);
3281 326949 : stmtblock_t tmp_block;
3282 326949 : gfc_init_block (&tmp_block);
3283 326949 : set_factored_descriptor_value (&info->descriptor, se.expr, &tmp_block,
3284 : &se.pre);
3285 326949 : gfc_add_block_to_block (block, &se.pre);
3286 326949 : gfc_add_block_to_block (block, &tmp_block);
3287 326949 : ss_info->string_length = se.string_length;
3288 326949 : ss_info->class_container = se.class_container;
3289 :
3290 326949 : if (base)
3291 : {
3292 123076 : if (ss_info->expr->ts.type == BT_CHARACTER && !ss_info->expr->ts.deferred
3293 22772 : && ss_info->expr->ts.u.cl->length == NULL)
3294 : {
3295 : /* Emit a DECL_EXPR for the variable sized array type in
3296 : GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
3297 : sizes works correctly. */
3298 1097 : tree arraytype = TREE_TYPE (
3299 : GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (info->descriptor)));
3300 1097 : if (! TYPE_NAME (arraytype))
3301 899 : TYPE_NAME (arraytype) = build_decl (UNKNOWN_LOCATION, TYPE_DECL,
3302 : NULL_TREE, arraytype);
3303 1097 : gfc_add_expr_to_block (block, build1 (DECL_EXPR, arraytype,
3304 1097 : TYPE_NAME (arraytype)));
3305 : }
3306 : /* Also the data pointer. */
3307 123076 : tmp = gfc_conv_array_data (se.expr);
3308 : /* If this is a variable or address or a class array, use it directly.
3309 : Otherwise we must evaluate it now to avoid breaking dependency
3310 : analysis by pulling the expressions for elemental array indices
3311 : inside the loop. */
3312 123076 : if (save_descriptor_data (se.expr, tmp) && !ss->is_alloc_lhs)
3313 36404 : tmp = gfc_evaluate_now (tmp, block);
3314 123076 : info->data = tmp;
3315 :
3316 123076 : tmp = gfc_conv_array_offset (se.expr);
3317 123076 : if (!ss->is_alloc_lhs)
3318 116624 : tmp = gfc_evaluate_now (tmp, block);
3319 123076 : info->offset = tmp;
3320 :
3321 : /* Make absolutely sure that the saved_offset is indeed saved
3322 : so that the variable is still accessible after the loops
3323 : are translated. */
3324 123076 : info->saved_offset = info->offset;
3325 : }
3326 326949 : }
3327 :
3328 :
3329 : /* Initialize a gfc_loopinfo structure. */
3330 :
3331 : void
3332 191137 : gfc_init_loopinfo (gfc_loopinfo * loop)
3333 : {
3334 191137 : int n;
3335 :
3336 191137 : memset (loop, 0, sizeof (gfc_loopinfo));
3337 191137 : gfc_init_block (&loop->pre);
3338 191137 : gfc_init_block (&loop->post);
3339 :
3340 : /* Initially scalarize in order and default to no loop reversal. */
3341 3249329 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
3342 : {
3343 2867055 : loop->order[n] = n;
3344 2867055 : loop->reverse[n] = GFC_INHIBIT_REVERSE;
3345 : }
3346 :
3347 191137 : loop->ss = gfc_ss_terminator;
3348 191137 : }
3349 :
3350 :
3351 : /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
3352 : chain. */
3353 :
3354 : void
3355 190635 : gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
3356 : {
3357 190635 : se->loop = loop;
3358 190635 : }
3359 :
3360 :
3361 : /* Return an expression for the data pointer of an array. */
3362 :
3363 : tree
3364 335367 : gfc_conv_array_data (tree descriptor)
3365 : {
3366 335367 : tree type;
3367 :
3368 335367 : type = TREE_TYPE (descriptor);
3369 335367 : if (GFC_ARRAY_TYPE_P (type))
3370 : {
3371 235071 : if (TREE_CODE (type) == POINTER_TYPE)
3372 : return descriptor;
3373 : else
3374 : {
3375 : /* Descriptorless arrays. */
3376 176161 : return gfc_build_addr_expr (NULL_TREE, descriptor);
3377 : }
3378 : }
3379 : else
3380 100296 : return gfc_conv_descriptor_data_get (descriptor);
3381 : }
3382 :
3383 :
3384 : /* Return an expression for the base offset of an array. */
3385 :
3386 : tree
3387 248971 : gfc_conv_array_offset (tree descriptor)
3388 : {
3389 248971 : tree type;
3390 :
3391 248971 : type = TREE_TYPE (descriptor);
3392 248971 : if (GFC_ARRAY_TYPE_P (type))
3393 177549 : return GFC_TYPE_ARRAY_OFFSET (type);
3394 : else
3395 71422 : return gfc_conv_descriptor_offset_get (descriptor);
3396 : }
3397 :
3398 :
3399 : /* Get an expression for the array stride. */
3400 :
3401 : tree
3402 496515 : gfc_conv_array_stride (tree descriptor, int dim)
3403 : {
3404 496515 : tree tmp;
3405 496515 : tree type;
3406 :
3407 496515 : type = TREE_TYPE (descriptor);
3408 :
3409 : /* For descriptorless arrays use the array size. */
3410 496515 : tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
3411 496515 : if (tmp != NULL_TREE)
3412 : return tmp;
3413 :
3414 113860 : tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]);
3415 113860 : return tmp;
3416 : }
3417 :
3418 :
3419 : /* Like gfc_conv_array_stride, but for the lower bound. */
3420 :
3421 : tree
3422 319944 : gfc_conv_array_lbound (tree descriptor, int dim)
3423 : {
3424 319944 : tree tmp;
3425 319944 : tree type;
3426 :
3427 319944 : type = TREE_TYPE (descriptor);
3428 :
3429 319944 : tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
3430 319944 : if (tmp != NULL_TREE)
3431 : return tmp;
3432 :
3433 18669 : tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]);
3434 18669 : return tmp;
3435 : }
3436 :
3437 :
3438 : /* Like gfc_conv_array_stride, but for the upper bound. */
3439 :
3440 : tree
3441 207160 : gfc_conv_array_ubound (tree descriptor, int dim)
3442 : {
3443 207160 : tree tmp;
3444 207160 : tree type;
3445 :
3446 207160 : type = TREE_TYPE (descriptor);
3447 :
3448 207160 : tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
3449 207160 : if (tmp != NULL_TREE)
3450 : return tmp;
3451 :
3452 : /* This should only ever happen when passing an assumed shape array
3453 : as an actual parameter. The value will never be used. */
3454 8081 : if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
3455 554 : return gfc_index_zero_node;
3456 :
3457 7527 : tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]);
3458 7527 : return tmp;
3459 : }
3460 :
3461 :
3462 : /* Generate abridged name of a part-ref for use in bounds-check message.
3463 : Cases:
3464 : (1) for an ordinary array variable x return "x"
3465 : (2) for z a DT scalar and array component x (at level 1) return "z%%x"
3466 : (3) for z a DT scalar and array component x (at level > 1) or
3467 : for z a DT array and array x (at any number of levels): "z...%%x"
3468 : */
3469 :
3470 : static char *
3471 36604 : abridged_ref_name (gfc_expr * expr, gfc_array_ref * ar)
3472 : {
3473 36604 : gfc_ref *ref;
3474 36604 : gfc_symbol *sym;
3475 36604 : char *ref_name = NULL;
3476 36604 : const char *comp_name = NULL;
3477 36604 : int len_sym, last_len = 0, level = 0;
3478 36604 : bool sym_is_array;
3479 :
3480 36604 : gcc_assert (expr->expr_type == EXPR_VARIABLE && expr->ref != NULL);
3481 :
3482 36604 : sym = expr->symtree->n.sym;
3483 72821 : sym_is_array = (sym->ts.type != BT_CLASS
3484 36604 : ? sym->as != NULL
3485 387 : : IS_CLASS_ARRAY (sym));
3486 36604 : len_sym = strlen (sym->name);
3487 :
3488 : /* Scan ref chain to get name of the array component (when ar != NULL) or
3489 : array section, determine depth and remember its component name. */
3490 52135 : for (ref = expr->ref; ref; ref = ref->next)
3491 : {
3492 38053 : if (ref->type == REF_COMPONENT
3493 1048 : && strcmp (ref->u.c.component->name, "_data") != 0)
3494 : {
3495 918 : level++;
3496 918 : comp_name = ref->u.c.component->name;
3497 918 : continue;
3498 : }
3499 :
3500 37135 : if (ref->type != REF_ARRAY)
3501 150 : continue;
3502 :
3503 36985 : if (ar)
3504 : {
3505 15971 : if (&ref->u.ar == ar)
3506 : break;
3507 : }
3508 21014 : else if (ref->u.ar.type == AR_SECTION)
3509 : break;
3510 : }
3511 :
3512 36604 : if (level > 0)
3513 800 : last_len = strlen (comp_name);
3514 :
3515 : /* Provide a buffer sufficiently large to hold "x...%%z". */
3516 36604 : ref_name = XNEWVEC (char, len_sym + last_len + 6);
3517 36604 : strcpy (ref_name, sym->name);
3518 :
3519 36604 : if (level == 1 && !sym_is_array)
3520 : {
3521 442 : strcat (ref_name, "%%");
3522 442 : strcat (ref_name, comp_name);
3523 : }
3524 36162 : else if (level > 0)
3525 : {
3526 358 : strcat (ref_name, "...%%");
3527 358 : strcat (ref_name, comp_name);
3528 : }
3529 :
3530 36604 : return ref_name;
3531 : }
3532 :
3533 :
3534 : /* Generate code to perform an array index bound check. */
3535 :
3536 : static tree
3537 5701 : trans_array_bound_check (stmtblock_t *block, gfc_ss *ss, tree index, int n,
3538 : locus * where, bool check_upper,
3539 : const char *compname = NULL)
3540 : {
3541 5701 : tree fault;
3542 5701 : tree tmp_lo, tmp_up;
3543 5701 : tree descriptor;
3544 5701 : char *msg;
3545 5701 : char *ref_name = NULL;
3546 5701 : const char * name = NULL;
3547 5701 : gfc_expr *expr;
3548 :
3549 5701 : if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
3550 : return index;
3551 :
3552 252 : descriptor = ss->info->data.array.descriptor;
3553 :
3554 252 : index = gfc_evaluate_now (index, block);
3555 :
3556 : /* We find a name for the error message. */
3557 252 : name = ss->info->expr->symtree->n.sym->name;
3558 252 : gcc_assert (name != NULL);
3559 :
3560 : /* When we have a component ref, get name of the array section.
3561 : Note that there can only be one part ref. */
3562 252 : expr = ss->info->expr;
3563 252 : if (expr->ref && !compname)
3564 160 : name = ref_name = abridged_ref_name (expr, NULL);
3565 :
3566 252 : if (VAR_P (descriptor))
3567 162 : name = IDENTIFIER_POINTER (DECL_NAME (descriptor));
3568 :
3569 : /* Use given (array component) name. */
3570 252 : if (compname)
3571 92 : name = compname;
3572 :
3573 : /* If upper bound is present, include both bounds in the error message. */
3574 252 : if (check_upper)
3575 : {
3576 225 : tmp_lo = gfc_conv_array_lbound (descriptor, n);
3577 225 : tmp_up = gfc_conv_array_ubound (descriptor, n);
3578 :
3579 225 : if (name)
3580 225 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3581 : "outside of expected range (%%ld:%%ld)", n+1, name);
3582 : else
3583 0 : msg = xasprintf ("Index '%%ld' of dimension %d "
3584 : "outside of expected range (%%ld:%%ld)", n+1);
3585 :
3586 225 : fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3587 : index, tmp_lo);
3588 225 : gfc_trans_runtime_check (true, false, fault, block, where, msg,
3589 : fold_convert (long_integer_type_node, index),
3590 : fold_convert (long_integer_type_node, tmp_lo),
3591 : fold_convert (long_integer_type_node, tmp_up));
3592 225 : fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3593 : index, tmp_up);
3594 225 : gfc_trans_runtime_check (true, false, fault, block, where, msg,
3595 : fold_convert (long_integer_type_node, index),
3596 : fold_convert (long_integer_type_node, tmp_lo),
3597 : fold_convert (long_integer_type_node, tmp_up));
3598 225 : free (msg);
3599 : }
3600 : else
3601 : {
3602 27 : tmp_lo = gfc_conv_array_lbound (descriptor, n);
3603 :
3604 27 : if (name)
3605 27 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3606 : "below lower bound of %%ld", n+1, name);
3607 : else
3608 0 : msg = xasprintf ("Index '%%ld' of dimension %d "
3609 : "below lower bound of %%ld", n+1);
3610 :
3611 27 : fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3612 : index, tmp_lo);
3613 27 : gfc_trans_runtime_check (true, false, fault, block, where, msg,
3614 : fold_convert (long_integer_type_node, index),
3615 : fold_convert (long_integer_type_node, tmp_lo));
3616 27 : free (msg);
3617 : }
3618 :
3619 252 : free (ref_name);
3620 252 : return index;
3621 : }
3622 :
3623 :
3624 : /* Helper functions to detect impure functions in an expression. */
3625 :
3626 : static const char *impure_name = NULL;
3627 : static bool
3628 108 : expr_contains_impure_fcn (gfc_expr *e, gfc_symbol* sym ATTRIBUTE_UNUSED,
3629 : int* g ATTRIBUTE_UNUSED)
3630 : {
3631 108 : if (e && e->expr_type == EXPR_FUNCTION
3632 6 : && !gfc_pure_function (e, &impure_name)
3633 111 : && !gfc_implicit_pure_function (e))
3634 : return true;
3635 :
3636 : return false;
3637 : }
3638 :
3639 : static bool
3640 92 : gfc_expr_contains_impure_fcn (gfc_expr *e)
3641 : {
3642 92 : impure_name = NULL;
3643 92 : return gfc_traverse_expr (e, NULL, &expr_contains_impure_fcn, 0);
3644 : }
3645 :
3646 :
3647 : /* Generate code for bounds checking for elemental dimensions. */
3648 :
3649 : static void
3650 6688 : array_bound_check_elemental (stmtblock_t *block, gfc_ss * ss, gfc_expr * expr)
3651 : {
3652 6688 : gfc_array_ref *ar;
3653 6688 : gfc_ref *ref;
3654 6688 : char *var_name = NULL;
3655 6688 : int dim;
3656 :
3657 6688 : if (expr->expr_type == EXPR_VARIABLE)
3658 : {
3659 12533 : for (ref = expr->ref; ref; ref = ref->next)
3660 : {
3661 6303 : if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
3662 : {
3663 3953 : ar = &ref->u.ar;
3664 3953 : var_name = abridged_ref_name (expr, ar);
3665 8158 : for (dim = 0; dim < ar->dimen; dim++)
3666 : {
3667 4205 : if (ar->dimen_type[dim] == DIMEN_ELEMENT)
3668 : {
3669 92 : if (gfc_expr_contains_impure_fcn (ar->start[dim]))
3670 3 : gfc_warning_now (0, "Bounds checking of the elemental "
3671 : "index at %L will cause two calls to "
3672 : "%qs, which is not declared to be "
3673 : "PURE or is not implicitly pure.",
3674 3 : &ar->start[dim]->where, impure_name);
3675 92 : gfc_se indexse;
3676 92 : gfc_init_se (&indexse, NULL);
3677 92 : gfc_conv_expr_type (&indexse, ar->start[dim],
3678 : gfc_array_index_type);
3679 92 : gfc_add_block_to_block (block, &indexse.pre);
3680 92 : trans_array_bound_check (block, ss, indexse.expr, dim,
3681 : &ar->where,
3682 92 : ar->as->type != AS_ASSUMED_SIZE
3683 92 : || dim < ar->dimen - 1,
3684 : var_name);
3685 : }
3686 : }
3687 3953 : free (var_name);
3688 : }
3689 : }
3690 : }
3691 6688 : }
3692 :
3693 :
3694 : /* Return the offset for an index. Performs bound checking for elemental
3695 : dimensions. Single element references are processed separately.
3696 : DIM is the array dimension, I is the loop dimension. */
3697 :
3698 : static tree
3699 253766 : conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i,
3700 : gfc_array_ref * ar, tree stride)
3701 : {
3702 253766 : gfc_array_info *info;
3703 253766 : tree index;
3704 253766 : tree desc;
3705 253766 : tree data;
3706 :
3707 253766 : info = &ss->info->data.array;
3708 :
3709 : /* Get the index into the array for this dimension. */
3710 253766 : if (ar)
3711 : {
3712 180458 : gcc_assert (ar->type != AR_ELEMENT);
3713 180458 : switch (ar->dimen_type[dim])
3714 : {
3715 0 : case DIMEN_THIS_IMAGE:
3716 0 : gcc_unreachable ();
3717 4632 : break;
3718 4632 : case DIMEN_ELEMENT:
3719 : /* Elemental dimension. */
3720 4632 : gcc_assert (info->subscript[dim]
3721 : && info->subscript[dim]->info->type == GFC_SS_SCALAR);
3722 : /* We've already translated this value outside the loop. */
3723 4632 : index = info->subscript[dim]->info->data.scalar.value;
3724 :
3725 9264 : index = trans_array_bound_check (&se->pre, ss, index, dim, &ar->where,
3726 4632 : ar->as->type != AS_ASSUMED_SIZE
3727 4632 : || dim < ar->dimen - 1);
3728 4632 : break;
3729 :
3730 977 : case DIMEN_VECTOR:
3731 977 : gcc_assert (info && se->loop);
3732 977 : gcc_assert (info->subscript[dim]
3733 : && info->subscript[dim]->info->type == GFC_SS_VECTOR);
3734 977 : desc = info->subscript[dim]->info->data.array.descriptor;
3735 :
3736 : /* Get a zero-based index into the vector. */
3737 977 : index = fold_build2_loc (input_location, MINUS_EXPR,
3738 : gfc_array_index_type,
3739 : se->loop->loopvar[i], se->loop->from[i]);
3740 :
3741 : /* Multiply the index by the stride. */
3742 977 : index = fold_build2_loc (input_location, MULT_EXPR,
3743 : gfc_array_index_type,
3744 : index, gfc_conv_array_stride (desc, 0));
3745 :
3746 : /* Read the vector to get an index into info->descriptor. */
3747 977 : data = build_fold_indirect_ref_loc (input_location,
3748 : gfc_conv_array_data (desc));
3749 977 : index = gfc_build_array_ref (data, index, NULL);
3750 977 : index = gfc_evaluate_now (index, &se->pre);
3751 977 : index = fold_convert (gfc_array_index_type, index);
3752 :
3753 : /* Do any bounds checking on the final info->descriptor index. */
3754 1954 : index = trans_array_bound_check (&se->pre, ss, index, dim, &ar->where,
3755 977 : ar->as->type != AS_ASSUMED_SIZE
3756 977 : || dim < ar->dimen - 1);
3757 977 : break;
3758 :
3759 174849 : case DIMEN_RANGE:
3760 : /* Scalarized dimension. */
3761 174849 : gcc_assert (info && se->loop);
3762 :
3763 : /* Multiply the loop variable by the stride and delta. */
3764 174849 : index = se->loop->loopvar[i];
3765 174849 : if (!integer_onep (info->stride[dim]))
3766 6954 : index = fold_build2_loc (input_location, MULT_EXPR,
3767 : gfc_array_index_type, index,
3768 : info->stride[dim]);
3769 174849 : if (!integer_zerop (info->delta[dim]))
3770 67288 : index = fold_build2_loc (input_location, PLUS_EXPR,
3771 : gfc_array_index_type, index,
3772 : info->delta[dim]);
3773 : break;
3774 :
3775 0 : default:
3776 0 : gcc_unreachable ();
3777 : }
3778 : }
3779 : else
3780 : {
3781 : /* Temporary array or derived type component. */
3782 73308 : gcc_assert (se->loop);
3783 73308 : index = se->loop->loopvar[se->loop->order[i]];
3784 :
3785 : /* Pointer functions can have stride[0] different from unity.
3786 : Use the stride returned by the function call and stored in
3787 : the descriptor for the temporary. */
3788 73308 : if (se->ss && se->ss->info->type == GFC_SS_FUNCTION
3789 8032 : && se->ss->info->expr
3790 8032 : && se->ss->info->expr->symtree
3791 8032 : && se->ss->info->expr->symtree->n.sym->result
3792 7592 : && se->ss->info->expr->symtree->n.sym->result->attr.pointer)
3793 144 : stride = gfc_conv_descriptor_stride_get (info->descriptor,
3794 : gfc_rank_cst[dim]);
3795 :
3796 73308 : if (info->delta[dim] && !integer_zerop (info->delta[dim]))
3797 804 : index = fold_build2_loc (input_location, PLUS_EXPR,
3798 : gfc_array_index_type, index, info->delta[dim]);
3799 : }
3800 :
3801 : /* Multiply by the stride. */
3802 253766 : if (stride != NULL && !integer_onep (stride))
3803 77495 : index = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
3804 : index, stride);
3805 :
3806 253766 : return index;
3807 : }
3808 :
3809 :
3810 : /* Build a scalarized array reference using the vptr 'size'. */
3811 :
3812 : static bool
3813 194262 : build_class_array_ref (gfc_se *se, tree base, tree index)
3814 : {
3815 194262 : tree size;
3816 194262 : tree decl = NULL_TREE;
3817 194262 : tree tmp;
3818 194262 : gfc_expr *expr = se->ss->info->expr;
3819 194262 : gfc_expr *class_expr;
3820 194262 : gfc_typespec *ts;
3821 194262 : gfc_symbol *sym;
3822 :
3823 194262 : tmp = !VAR_P (base) ? gfc_get_class_from_expr (base) : NULL_TREE;
3824 :
3825 90861 : if (tmp != NULL_TREE)
3826 : decl = tmp;
3827 : else
3828 : {
3829 : /* The base expression does not contain a class component, either
3830 : because it is a temporary array or array descriptor. Class
3831 : array functions are correctly resolved above. */
3832 190913 : if (!expr
3833 190913 : || (expr->ts.type != BT_CLASS
3834 177126 : && !gfc_is_class_array_ref (expr, NULL)))
3835 190478 : return false;
3836 :
3837 : /* Obtain the expression for the class entity or component that is
3838 : followed by an array reference, which is not an element, so that
3839 : the span of the array can be obtained. */
3840 435 : class_expr = gfc_find_and_cut_at_last_class_ref (expr, false, &ts);
3841 :
3842 435 : if (!ts)
3843 : return false;
3844 :
3845 410 : sym = (!class_expr && expr) ? expr->symtree->n.sym : NULL;
3846 0 : if (sym && sym->attr.function
3847 0 : && sym == sym->result
3848 0 : && sym->backend_decl == current_function_decl)
3849 : /* The temporary is the data field of the class data component
3850 : of the current function. */
3851 0 : decl = gfc_get_fake_result_decl (sym, 0);
3852 410 : else if (sym)
3853 : {
3854 0 : if (decl == NULL_TREE)
3855 0 : decl = expr->symtree->n.sym->backend_decl;
3856 : /* For class arrays the tree containing the class is stored in
3857 : GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl.
3858 : For all others it's sym's backend_decl directly. */
3859 0 : if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl))
3860 0 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
3861 : }
3862 : else
3863 410 : decl = gfc_get_class_from_gfc_expr (class_expr);
3864 :
3865 410 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
3866 0 : decl = build_fold_indirect_ref_loc (input_location, decl);
3867 :
3868 410 : if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl)))
3869 : return false;
3870 : }
3871 :
3872 3759 : se->class_vptr = gfc_evaluate_now (gfc_class_vptr_get (decl), &se->pre);
3873 :
3874 3759 : size = gfc_class_vtab_size_get (decl);
3875 : /* For unlimited polymorphic entities then _len component needs to be
3876 : multiplied with the size. */
3877 3759 : size = gfc_resize_class_size_with_len (&se->pre, decl, size);
3878 3759 : size = fold_convert (TREE_TYPE (index), size);
3879 :
3880 : /* Return the element in the se expression. */
3881 3759 : se->expr = gfc_build_spanned_array_ref (base, index, size);
3882 3759 : return true;
3883 : }
3884 :
3885 :
3886 : /* Indicates that the tree EXPR is a reference to an array that can’t
3887 : have any negative stride. */
3888 :
3889 : static bool
3890 314138 : non_negative_strides_array_p (tree expr)
3891 : {
3892 327459 : if (expr == NULL_TREE)
3893 : return false;
3894 :
3895 327459 : tree type = TREE_TYPE (expr);
3896 327459 : if (POINTER_TYPE_P (type))
3897 72451 : type = TREE_TYPE (type);
3898 :
3899 327459 : if (TYPE_LANG_SPECIFIC (type))
3900 : {
3901 327459 : gfc_array_kind array_kind = GFC_TYPE_ARRAY_AKIND (type);
3902 :
3903 327459 : if (array_kind == GFC_ARRAY_ALLOCATABLE
3904 327459 : || array_kind == GFC_ARRAY_ASSUMED_SHAPE_CONT)
3905 : return true;
3906 : }
3907 :
3908 : /* An array with descriptor can have negative strides.
3909 : We try to be conservative and return false by default here
3910 : if we don’t recognize a contiguous array instead of
3911 : returning false if we can identify a non-contiguous one. */
3912 270353 : if (!GFC_ARRAY_TYPE_P (type))
3913 : return false;
3914 :
3915 : /* If the array was originally a dummy with a descriptor, strides can be
3916 : negative. */
3917 236270 : if (DECL_P (expr)
3918 227301 : && DECL_LANG_SPECIFIC (expr)
3919 47958 : && GFC_DECL_SAVED_DESCRIPTOR (expr)
3920 249610 : && GFC_DECL_SAVED_DESCRIPTOR (expr) != expr)
3921 13321 : return non_negative_strides_array_p (GFC_DECL_SAVED_DESCRIPTOR (expr));
3922 :
3923 : return true;
3924 : }
3925 :
3926 :
3927 : /* Build a scalarized reference to an array. */
3928 :
3929 : static void
3930 194262 : gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar,
3931 : bool tmp_array = false)
3932 : {
3933 194262 : gfc_array_info *info;
3934 194262 : tree decl = NULL_TREE;
3935 194262 : tree index;
3936 194262 : tree base;
3937 194262 : gfc_ss *ss;
3938 194262 : gfc_expr *expr;
3939 194262 : int n;
3940 :
3941 194262 : ss = se->ss;
3942 194262 : expr = ss->info->expr;
3943 194262 : info = &ss->info->data.array;
3944 194262 : if (ar)
3945 133058 : n = se->loop->order[0];
3946 : else
3947 : n = 0;
3948 :
3949 194262 : index = conv_array_index_offset (se, ss, ss->dim[n], n, ar, info->stride0);
3950 : /* Add the offset for this dimension to the stored offset for all other
3951 : dimensions. */
3952 194262 : if (info->offset && !integer_zerop (info->offset))
3953 142710 : index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3954 : index, info->offset);
3955 :
3956 194262 : base = build_fold_indirect_ref_loc (input_location, info->data);
3957 :
3958 : /* Use the vptr 'size' field to access the element of a class array. */
3959 194262 : if (build_class_array_ref (se, base, index))
3960 3759 : return;
3961 :
3962 190503 : if (get_CFI_desc (NULL, expr, &decl, ar))
3963 442 : decl = build_fold_indirect_ref_loc (input_location, decl);
3964 :
3965 : /* A pointer array component can be detected from its field decl. Fix
3966 : the descriptor, mark the resulting variable decl and pass it to
3967 : gfc_build_array_ref. */
3968 190503 : if (is_pointer_array (info->descriptor)
3969 190503 : || (expr && expr->ts.deferred && info->descriptor
3970 2913 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info->descriptor))))
3971 : {
3972 9143 : if (TREE_CODE (info->descriptor) == COMPONENT_REF)
3973 1588 : decl = info->descriptor;
3974 7555 : else if (INDIRECT_REF_P (info->descriptor))
3975 1485 : decl = TREE_OPERAND (info->descriptor, 0);
3976 :
3977 9143 : if (decl == NULL_TREE)
3978 6070 : decl = info->descriptor;
3979 : }
3980 :
3981 190503 : bool non_negative_stride = tmp_array
3982 190503 : || non_negative_strides_array_p (info->descriptor);
3983 190503 : se->expr = gfc_build_array_ref (base, index, decl,
3984 : non_negative_stride);
3985 : }
3986 :
3987 :
3988 : /* Translate access of temporary array. */
3989 :
3990 : void
3991 61204 : gfc_conv_tmp_array_ref (gfc_se * se)
3992 : {
3993 61204 : se->string_length = se->ss->info->string_length;
3994 61204 : gfc_conv_scalarized_array_ref (se, NULL, true);
3995 61204 : gfc_advance_se_ss_chain (se);
3996 61204 : }
3997 :
3998 : /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
3999 :
4000 : static void
4001 276447 : add_to_offset (tree *cst_offset, tree *offset, tree t)
4002 : {
4003 276447 : if (TREE_CODE (t) == INTEGER_CST)
4004 139341 : *cst_offset = int_const_binop (PLUS_EXPR, *cst_offset, t);
4005 : else
4006 : {
4007 137106 : if (!integer_zerop (*offset))
4008 47763 : *offset = fold_build2_loc (input_location, PLUS_EXPR,
4009 : gfc_array_index_type, *offset, t);
4010 : else
4011 89343 : *offset = t;
4012 : }
4013 276447 : }
4014 :
4015 :
4016 : static tree
4017 184445 : build_array_ref (tree desc, tree offset, tree decl, tree vptr)
4018 : {
4019 184445 : tree tmp;
4020 184445 : tree type;
4021 184445 : tree cdesc;
4022 :
4023 : /* For class arrays the class declaration is stored in the saved
4024 : descriptor. */
4025 184445 : if (INDIRECT_REF_P (desc)
4026 7335 : && DECL_LANG_SPECIFIC (TREE_OPERAND (desc, 0))
4027 186761 : && GFC_DECL_SAVED_DESCRIPTOR (TREE_OPERAND (desc, 0)))
4028 881 : cdesc = gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (
4029 : TREE_OPERAND (desc, 0)));
4030 : else
4031 : cdesc = desc;
4032 :
4033 : /* Class container types do not always have the GFC_CLASS_TYPE_P
4034 : but the canonical type does. */
4035 184445 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdesc))
4036 184445 : && TREE_CODE (cdesc) == COMPONENT_REF)
4037 : {
4038 11380 : type = TREE_TYPE (TREE_OPERAND (cdesc, 0));
4039 11380 : if (TYPE_CANONICAL (type)
4040 11380 : && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type)))
4041 : {
4042 3481 : vptr = gfc_class_vptr_get (TREE_OPERAND (cdesc, 0));
4043 : /* Pass the class container as decl so that gfc_build_array_ref can
4044 : correct the element size for an unlimited polymorphic character
4045 : payload (the _len field), which the vptr size alone omits. Only do
4046 : this for a genuine array element reference; a scalar coarray has
4047 : nothing to span-correct and gfc_build_array_ref asserts decl is null
4048 : for it. */
4049 3481 : if (decl == NULL_TREE
4050 3481 : && GFC_TYPE_ARRAY_RANK (TREE_TYPE (cdesc)) > 0)
4051 3357 : decl = TREE_OPERAND (cdesc, 0);
4052 : }
4053 : }
4054 :
4055 184445 : tmp = gfc_conv_array_data (desc);
4056 184445 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
4057 184445 : tmp = gfc_build_array_ref (tmp, offset, decl,
4058 184445 : non_negative_strides_array_p (desc),
4059 : vptr);
4060 184445 : return tmp;
4061 : }
4062 :
4063 :
4064 : /* Build an array reference. se->expr already holds the array descriptor.
4065 : This should be either a variable, indirect variable reference or component
4066 : reference. For arrays which do not have a descriptor, se->expr will be
4067 : the data pointer.
4068 : a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
4069 :
4070 : void
4071 262398 : gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
4072 : locus * where)
4073 : {
4074 262398 : int n;
4075 262398 : tree offset, cst_offset;
4076 262398 : tree tmp;
4077 262398 : tree stride;
4078 262398 : tree decl = NULL_TREE;
4079 262398 : gfc_se indexse;
4080 262398 : gfc_se tmpse;
4081 262398 : gfc_symbol * sym = expr->symtree->n.sym;
4082 262398 : char *var_name = NULL;
4083 :
4084 262398 : if (ar->stat)
4085 : {
4086 3 : gfc_se statse;
4087 :
4088 3 : gfc_init_se (&statse, NULL);
4089 3 : gfc_conv_expr_lhs (&statse, ar->stat);
4090 3 : gfc_add_block_to_block (&se->pre, &statse.pre);
4091 3 : gfc_add_modify (&se->pre, statse.expr, integer_zero_node);
4092 : }
4093 262398 : if (ar->dimen == 0)
4094 : {
4095 4506 : gcc_assert (ar->codimen || sym->attr.select_rank_temporary
4096 : || (ar->as && ar->as->corank));
4097 :
4098 4506 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
4099 961 : se->expr = build_fold_indirect_ref (gfc_conv_array_data (se->expr));
4100 : else
4101 : {
4102 3545 : if (GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr))
4103 3545 : && TREE_CODE (TREE_TYPE (se->expr)) == POINTER_TYPE)
4104 2598 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
4105 :
4106 : /* Use the actual tree type and not the wrapped coarray. */
4107 3545 : if (!se->want_pointer)
4108 2576 : se->expr = fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se->expr)),
4109 : se->expr);
4110 : }
4111 :
4112 137564 : return;
4113 : }
4114 :
4115 : /* Handle scalarized references separately. */
4116 257892 : if (ar->type != AR_ELEMENT)
4117 : {
4118 133058 : gfc_conv_scalarized_array_ref (se, ar);
4119 133058 : gfc_advance_se_ss_chain (se);
4120 133058 : return;
4121 : }
4122 :
4123 124834 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
4124 11849 : var_name = abridged_ref_name (expr, ar);
4125 :
4126 124834 : decl = se->expr;
4127 124834 : if (UNLIMITED_POLY(sym)
4128 104 : && IS_CLASS_ARRAY (sym)
4129 103 : && sym->attr.dummy
4130 60 : && ar->as->type != AS_DEFERRED)
4131 48 : decl = sym->backend_decl;
4132 :
4133 124834 : cst_offset = offset = gfc_index_zero_node;
4134 124834 : add_to_offset (&cst_offset, &offset, gfc_conv_array_offset (decl));
4135 :
4136 : /* Calculate the offsets from all the dimensions. Make sure to associate
4137 : the final offset so that we form a chain of loop invariant summands. */
4138 276447 : for (n = ar->dimen - 1; n >= 0; n--)
4139 : {
4140 : /* Calculate the index for this dimension. */
4141 151613 : gfc_init_se (&indexse, se);
4142 151613 : gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
4143 151613 : gfc_add_block_to_block (&se->pre, &indexse.pre);
4144 :
4145 151613 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && ! expr->no_bounds_check)
4146 : {
4147 : /* Check array bounds. */
4148 15389 : tree cond;
4149 15389 : char *msg;
4150 :
4151 : /* Evaluate the indexse.expr only once. */
4152 15389 : indexse.expr = save_expr (indexse.expr);
4153 :
4154 : /* Lower bound. */
4155 15389 : tmp = gfc_conv_array_lbound (decl, n);
4156 15389 : if (sym->attr.temporary)
4157 : {
4158 18 : gfc_init_se (&tmpse, se);
4159 18 : gfc_conv_expr_type (&tmpse, ar->as->lower[n],
4160 : gfc_array_index_type);
4161 18 : gfc_add_block_to_block (&se->pre, &tmpse.pre);
4162 18 : tmp = tmpse.expr;
4163 : }
4164 :
4165 15389 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
4166 : indexse.expr, tmp);
4167 15389 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4168 : "below lower bound of %%ld", n+1, var_name);
4169 15389 : gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
4170 : fold_convert (long_integer_type_node,
4171 : indexse.expr),
4172 : fold_convert (long_integer_type_node, tmp));
4173 15389 : free (msg);
4174 :
4175 : /* Upper bound, but not for the last dimension of assumed-size
4176 : arrays. */
4177 15389 : if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE)
4178 : {
4179 13656 : tmp = gfc_conv_array_ubound (decl, n);
4180 13656 : if (sym->attr.temporary)
4181 : {
4182 18 : gfc_init_se (&tmpse, se);
4183 18 : gfc_conv_expr_type (&tmpse, ar->as->upper[n],
4184 : gfc_array_index_type);
4185 18 : gfc_add_block_to_block (&se->pre, &tmpse.pre);
4186 18 : tmp = tmpse.expr;
4187 : }
4188 :
4189 13656 : cond = fold_build2_loc (input_location, GT_EXPR,
4190 : logical_type_node, indexse.expr, tmp);
4191 13656 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4192 : "above upper bound of %%ld", n+1, var_name);
4193 13656 : gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
4194 : fold_convert (long_integer_type_node,
4195 : indexse.expr),
4196 : fold_convert (long_integer_type_node, tmp));
4197 13656 : free (msg);
4198 : }
4199 : }
4200 :
4201 : /* Multiply the index by the stride. */
4202 151613 : stride = gfc_conv_array_stride (decl, n);
4203 151613 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4204 : indexse.expr, stride);
4205 :
4206 : /* And add it to the total. */
4207 151613 : add_to_offset (&cst_offset, &offset, tmp);
4208 : }
4209 :
4210 124834 : if (!integer_zerop (cst_offset))
4211 66536 : offset = fold_build2_loc (input_location, PLUS_EXPR,
4212 : gfc_array_index_type, offset, cst_offset);
4213 :
4214 : /* A pointer array component can be detected from its field decl. Fix
4215 : the descriptor, mark the resulting variable decl and pass it to
4216 : build_array_ref. */
4217 124834 : decl = NULL_TREE;
4218 124834 : if (get_CFI_desc (sym, expr, &decl, ar))
4219 3589 : decl = build_fold_indirect_ref_loc (input_location, decl);
4220 123775 : if (!expr->ts.deferred && !sym->attr.codimension
4221 246384 : && is_pointer_array (se->expr))
4222 : {
4223 5129 : if (TREE_CODE (se->expr) == COMPONENT_REF)
4224 1672 : decl = se->expr;
4225 3457 : else if (INDIRECT_REF_P (se->expr))
4226 984 : decl = TREE_OPERAND (se->expr, 0);
4227 : else
4228 2473 : decl = se->expr;
4229 : }
4230 119705 : else if (expr->ts.deferred
4231 118646 : || (sym->ts.type == BT_CHARACTER
4232 15335 : && sym->attr.select_type_temporary))
4233 : {
4234 2769 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
4235 : {
4236 2613 : decl = se->expr;
4237 2613 : if (INDIRECT_REF_P (decl))
4238 20 : decl = TREE_OPERAND (decl, 0);
4239 : }
4240 : else
4241 156 : decl = sym->backend_decl;
4242 : }
4243 116936 : else if (sym->ts.type == BT_CLASS)
4244 : {
4245 2237 : if (UNLIMITED_POLY (sym))
4246 : {
4247 104 : gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr);
4248 104 : gfc_init_se (&tmpse, NULL);
4249 104 : gfc_conv_expr (&tmpse, class_expr);
4250 104 : if (!se->class_vptr)
4251 104 : se->class_vptr = gfc_class_vptr_get (tmpse.expr);
4252 104 : gfc_free_expr (class_expr);
4253 104 : decl = tmpse.expr;
4254 104 : }
4255 : else
4256 2133 : decl = NULL_TREE;
4257 : }
4258 :
4259 124834 : free (var_name);
4260 124834 : se->expr = build_array_ref (se->expr, offset, decl, se->class_vptr);
4261 : }
4262 :
4263 :
4264 : /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
4265 : LOOP_DIM dimension (if any) to array's offset. */
4266 :
4267 : static void
4268 59504 : add_array_offset (stmtblock_t *pblock, gfc_loopinfo *loop, gfc_ss *ss,
4269 : gfc_array_ref *ar, int array_dim, int loop_dim)
4270 : {
4271 59504 : gfc_se se;
4272 59504 : gfc_array_info *info;
4273 59504 : tree stride, index;
4274 :
4275 59504 : info = &ss->info->data.array;
4276 :
4277 59504 : gfc_init_se (&se, NULL);
4278 59504 : se.loop = loop;
4279 59504 : se.expr = info->descriptor;
4280 59504 : stride = gfc_conv_array_stride (info->descriptor, array_dim);
4281 59504 : index = conv_array_index_offset (&se, ss, array_dim, loop_dim, ar, stride);
4282 59504 : gfc_add_block_to_block (pblock, &se.pre);
4283 :
4284 59504 : info->offset = fold_build2_loc (input_location, PLUS_EXPR,
4285 : gfc_array_index_type,
4286 : info->offset, index);
4287 59504 : info->offset = gfc_evaluate_now (info->offset, pblock);
4288 59504 : }
4289 :
4290 :
4291 : /* Generate the code to be executed immediately before entering a
4292 : scalarization loop. */
4293 :
4294 : static void
4295 146802 : gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
4296 : stmtblock_t * pblock)
4297 : {
4298 146802 : tree stride;
4299 146802 : gfc_ss_info *ss_info;
4300 146802 : gfc_array_info *info;
4301 146802 : gfc_ss_type ss_type;
4302 146802 : gfc_ss *ss, *pss;
4303 146802 : gfc_loopinfo *ploop;
4304 146802 : gfc_array_ref *ar;
4305 :
4306 : /* This code will be executed before entering the scalarization loop
4307 : for this dimension. */
4308 447590 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4309 : {
4310 300788 : ss_info = ss->info;
4311 :
4312 300788 : if ((ss_info->useflags & flag) == 0)
4313 1476 : continue;
4314 :
4315 299312 : ss_type = ss_info->type;
4316 365262 : if (ss_type != GFC_SS_SECTION
4317 : && ss_type != GFC_SS_FUNCTION
4318 299312 : && ss_type != GFC_SS_CONSTRUCTOR
4319 299312 : && ss_type != GFC_SS_COMPONENT)
4320 65950 : continue;
4321 :
4322 233362 : info = &ss_info->data.array;
4323 :
4324 233362 : gcc_assert (dim < ss->dimen);
4325 233362 : gcc_assert (ss->dimen == loop->dimen);
4326 :
4327 233362 : if (info->ref)
4328 164675 : ar = &info->ref->u.ar;
4329 : else
4330 : ar = NULL;
4331 :
4332 233362 : if (dim == loop->dimen - 1 && loop->parent != NULL)
4333 : {
4334 : /* If we are in the outermost dimension of this loop, the previous
4335 : dimension shall be in the parent loop. */
4336 4687 : gcc_assert (ss->parent != NULL);
4337 :
4338 4687 : pss = ss->parent;
4339 4687 : ploop = loop->parent;
4340 :
4341 : /* ss and ss->parent are about the same array. */
4342 4687 : gcc_assert (ss_info == pss->info);
4343 : }
4344 : else
4345 : {
4346 : ploop = loop;
4347 : pss = ss;
4348 : }
4349 :
4350 233362 : if (dim == loop->dimen - 1 && loop->parent == NULL)
4351 : {
4352 178490 : gcc_assert (0 == ploop->order[0]);
4353 :
4354 356980 : stride = gfc_conv_array_stride (info->descriptor,
4355 178490 : innermost_ss (ss)->dim[0]);
4356 :
4357 : /* Calculate the stride of the innermost loop. Hopefully this will
4358 : allow the backend optimizers to do their stuff more effectively.
4359 : */
4360 178490 : info->stride0 = gfc_evaluate_now (stride, pblock);
4361 :
4362 : /* For the outermost loop calculate the offset due to any
4363 : elemental dimensions. It will have been initialized with the
4364 : base offset of the array. */
4365 178490 : if (info->ref)
4366 : {
4367 288840 : for (int i = 0; i < ar->dimen; i++)
4368 : {
4369 166933 : if (ar->dimen_type[i] != DIMEN_ELEMENT)
4370 162301 : continue;
4371 :
4372 4632 : add_array_offset (pblock, loop, ss, ar, i, /* unused */ -1);
4373 : }
4374 : }
4375 : }
4376 : else
4377 : {
4378 54872 : int i;
4379 :
4380 54872 : if (dim == loop->dimen - 1)
4381 : i = 0;
4382 : else
4383 50185 : i = dim + 1;
4384 :
4385 : /* For the time being, there is no loop reordering. */
4386 54872 : gcc_assert (i == ploop->order[i]);
4387 54872 : i = ploop->order[i];
4388 :
4389 : /* Add the offset for the previous loop dimension. */
4390 54872 : add_array_offset (pblock, ploop, ss, ar, pss->dim[i], i);
4391 : }
4392 :
4393 : /* Remember this offset for the second loop. */
4394 233362 : if (dim == loop->temp_dim - 1 && loop->parent == NULL)
4395 54412 : info->saved_offset = info->offset;
4396 : }
4397 146802 : }
4398 :
4399 :
4400 : /* Start a scalarized expression. Creates a scope and declares loop
4401 : variables. */
4402 :
4403 : void
4404 116426 : gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
4405 : {
4406 116426 : int dim;
4407 116426 : int n;
4408 116426 : int flags;
4409 :
4410 116426 : gcc_assert (!loop->array_parameter);
4411 :
4412 261648 : for (dim = loop->dimen - 1; dim >= 0; dim--)
4413 : {
4414 145222 : n = loop->order[dim];
4415 :
4416 145222 : gfc_start_block (&loop->code[n]);
4417 :
4418 : /* Create the loop variable. */
4419 145222 : loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
4420 :
4421 145222 : if (dim < loop->temp_dim)
4422 : flags = 3;
4423 : else
4424 99324 : flags = 1;
4425 : /* Calculate values that will be constant within this loop. */
4426 145222 : gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
4427 : }
4428 116426 : gfc_start_block (pbody);
4429 116426 : }
4430 :
4431 :
4432 : /* Generates the actual loop code for a scalarization loop. */
4433 :
4434 : static void
4435 161324 : gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
4436 : stmtblock_t * pbody)
4437 : {
4438 161324 : stmtblock_t block;
4439 161324 : tree cond;
4440 161324 : tree tmp;
4441 161324 : tree loopbody;
4442 161324 : tree exit_label;
4443 161324 : tree stmt;
4444 161324 : tree init;
4445 161324 : tree incr;
4446 :
4447 161324 : if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS
4448 : | OMPWS_SCALARIZER_BODY))
4449 : == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS)
4450 108 : && n == loop->dimen - 1)
4451 : {
4452 : /* We create an OMP_FOR construct for the outermost scalarized loop. */
4453 80 : init = make_tree_vec (1);
4454 80 : cond = make_tree_vec (1);
4455 80 : incr = make_tree_vec (1);
4456 :
4457 : /* Cycle statement is implemented with a goto. Exit statement must not
4458 : be present for this loop. */
4459 80 : exit_label = gfc_build_label_decl (NULL_TREE);
4460 80 : TREE_USED (exit_label) = 1;
4461 :
4462 : /* Label for cycle statements (if needed). */
4463 80 : tmp = build1_v (LABEL_EXPR, exit_label);
4464 80 : gfc_add_expr_to_block (pbody, tmp);
4465 :
4466 80 : stmt = make_node (OMP_FOR);
4467 :
4468 80 : TREE_TYPE (stmt) = void_type_node;
4469 80 : OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody);
4470 :
4471 80 : OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location,
4472 : OMP_CLAUSE_SCHEDULE);
4473 80 : OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt))
4474 80 : = OMP_CLAUSE_SCHEDULE_STATIC;
4475 80 : if (ompws_flags & OMPWS_NOWAIT)
4476 33 : OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt))
4477 66 : = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT);
4478 :
4479 : /* Initialize the loopvar. */
4480 80 : TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n],
4481 : loop->from[n]);
4482 80 : OMP_FOR_INIT (stmt) = init;
4483 : /* The exit condition. */
4484 80 : TREE_VEC_ELT (cond, 0) = build2_loc (input_location, LE_EXPR,
4485 : logical_type_node,
4486 : loop->loopvar[n], loop->to[n]);
4487 80 : SET_EXPR_LOCATION (TREE_VEC_ELT (cond, 0), input_location);
4488 80 : OMP_FOR_COND (stmt) = cond;
4489 : /* Increment the loopvar. */
4490 80 : tmp = build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4491 : loop->loopvar[n], gfc_index_one_node);
4492 80 : TREE_VEC_ELT (incr, 0) = fold_build2_loc (input_location, MODIFY_EXPR,
4493 : void_type_node, loop->loopvar[n], tmp);
4494 80 : OMP_FOR_INCR (stmt) = incr;
4495 :
4496 80 : ompws_flags &= ~OMPWS_CURR_SINGLEUNIT;
4497 80 : gfc_add_expr_to_block (&loop->code[n], stmt);
4498 : }
4499 : else
4500 : {
4501 322488 : bool reverse_loop = (loop->reverse[n] == GFC_REVERSE_SET)
4502 161244 : && (loop->temp_ss == NULL);
4503 :
4504 161244 : loopbody = gfc_finish_block (pbody);
4505 :
4506 161244 : if (reverse_loop)
4507 204 : std::swap (loop->from[n], loop->to[n]);
4508 :
4509 : /* Initialize the loopvar. */
4510 161244 : if (loop->loopvar[n] != loop->from[n])
4511 160423 : gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
4512 :
4513 161244 : exit_label = gfc_build_label_decl (NULL_TREE);
4514 :
4515 : /* Generate the loop body. */
4516 161244 : gfc_init_block (&block);
4517 :
4518 : /* The exit condition. */
4519 322284 : cond = fold_build2_loc (input_location, reverse_loop ? LT_EXPR : GT_EXPR,
4520 : logical_type_node, loop->loopvar[n], loop->to[n]);
4521 161244 : tmp = build1_v (GOTO_EXPR, exit_label);
4522 161244 : TREE_USED (exit_label) = 1;
4523 161244 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
4524 161244 : gfc_add_expr_to_block (&block, tmp);
4525 :
4526 : /* The main body. */
4527 161244 : gfc_add_expr_to_block (&block, loopbody);
4528 :
4529 : /* Increment the loopvar. */
4530 322284 : tmp = fold_build2_loc (input_location,
4531 : reverse_loop ? MINUS_EXPR : PLUS_EXPR,
4532 : gfc_array_index_type, loop->loopvar[n],
4533 : gfc_index_one_node);
4534 :
4535 161244 : gfc_add_modify (&block, loop->loopvar[n], tmp);
4536 :
4537 : /* Build the loop. */
4538 161244 : tmp = gfc_finish_block (&block);
4539 161244 : tmp = build1_v (LOOP_EXPR, tmp);
4540 161244 : gfc_add_expr_to_block (&loop->code[n], tmp);
4541 :
4542 : /* Add the exit label. */
4543 161244 : tmp = build1_v (LABEL_EXPR, exit_label);
4544 161244 : gfc_add_expr_to_block (&loop->code[n], tmp);
4545 : }
4546 :
4547 161324 : }
4548 :
4549 :
4550 : /* Finishes and generates the loops for a scalarized expression. */
4551 :
4552 : void
4553 122740 : gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
4554 : {
4555 122740 : int dim;
4556 122740 : int n;
4557 122740 : gfc_ss *ss;
4558 122740 : stmtblock_t *pblock;
4559 122740 : tree tmp;
4560 :
4561 122740 : pblock = body;
4562 : /* Generate the loops. */
4563 274267 : for (dim = 0; dim < loop->dimen; dim++)
4564 : {
4565 151527 : n = loop->order[dim];
4566 151527 : gfc_trans_scalarized_loop_end (loop, n, pblock);
4567 151527 : loop->loopvar[n] = NULL_TREE;
4568 151527 : pblock = &loop->code[n];
4569 : }
4570 :
4571 122740 : tmp = gfc_finish_block (pblock);
4572 122740 : gfc_add_expr_to_block (&loop->pre, tmp);
4573 :
4574 : /* Clear all the used flags. */
4575 359077 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4576 236337 : if (ss->parent == NULL)
4577 231587 : ss->info->useflags = 0;
4578 122740 : }
4579 :
4580 :
4581 : /* Finish the main body of a scalarized expression, and start the secondary
4582 : copying body. */
4583 :
4584 : void
4585 8217 : gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
4586 : {
4587 8217 : int dim;
4588 8217 : int n;
4589 8217 : stmtblock_t *pblock;
4590 8217 : gfc_ss *ss;
4591 :
4592 8217 : pblock = body;
4593 : /* We finish as many loops as are used by the temporary. */
4594 9797 : for (dim = 0; dim < loop->temp_dim - 1; dim++)
4595 : {
4596 1580 : n = loop->order[dim];
4597 1580 : gfc_trans_scalarized_loop_end (loop, n, pblock);
4598 1580 : loop->loopvar[n] = NULL_TREE;
4599 1580 : pblock = &loop->code[n];
4600 : }
4601 :
4602 : /* We don't want to finish the outermost loop entirely. */
4603 8217 : n = loop->order[loop->temp_dim - 1];
4604 8217 : gfc_trans_scalarized_loop_end (loop, n, pblock);
4605 :
4606 : /* Restore the initial offsets. */
4607 23555 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4608 : {
4609 15338 : gfc_ss_type ss_type;
4610 15338 : gfc_ss_info *ss_info;
4611 :
4612 15338 : ss_info = ss->info;
4613 :
4614 15338 : if ((ss_info->useflags & 2) == 0)
4615 4546 : continue;
4616 :
4617 10792 : ss_type = ss_info->type;
4618 10946 : if (ss_type != GFC_SS_SECTION
4619 : && ss_type != GFC_SS_FUNCTION
4620 10792 : && ss_type != GFC_SS_CONSTRUCTOR
4621 10792 : && ss_type != GFC_SS_COMPONENT)
4622 154 : continue;
4623 :
4624 10638 : ss_info->data.array.offset = ss_info->data.array.saved_offset;
4625 : }
4626 :
4627 : /* Restart all the inner loops we just finished. */
4628 9797 : for (dim = loop->temp_dim - 2; dim >= 0; dim--)
4629 : {
4630 1580 : n = loop->order[dim];
4631 :
4632 1580 : gfc_start_block (&loop->code[n]);
4633 :
4634 1580 : loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
4635 :
4636 1580 : gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
4637 : }
4638 :
4639 : /* Start a block for the secondary copying code. */
4640 8217 : gfc_start_block (body);
4641 8217 : }
4642 :
4643 :
4644 : /* Precalculate (either lower or upper) bound of an array section.
4645 : BLOCK: Block in which the (pre)calculation code will go.
4646 : BOUNDS[DIM]: Where the bound value will be stored once evaluated.
4647 : VALUES[DIM]: Specified bound (NULL <=> unspecified).
4648 : DESC: Array descriptor from which the bound will be picked if unspecified
4649 : (either lower or upper bound according to LBOUND). */
4650 :
4651 : static void
4652 517252 : evaluate_bound (stmtblock_t *block, tree *bounds, gfc_expr ** values,
4653 : tree desc, int dim, bool lbound, bool deferred, bool save_value)
4654 : {
4655 517252 : gfc_se se;
4656 517252 : gfc_expr * input_val = values[dim];
4657 517252 : tree *output = &bounds[dim];
4658 :
4659 517252 : if (input_val)
4660 : {
4661 : /* Specified section bound. */
4662 47960 : gfc_init_se (&se, NULL);
4663 47960 : gfc_conv_expr_type (&se, input_val, gfc_array_index_type);
4664 47960 : gfc_add_block_to_block (block, &se.pre);
4665 47960 : *output = se.expr;
4666 : }
4667 469292 : else if (deferred && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
4668 : {
4669 : /* The gfc_conv_array_lbound () routine returns a constant zero for
4670 : deferred length arrays, which in the scalarizer wreaks havoc, when
4671 : copying to a (newly allocated) one-based array.
4672 : Keep returning the actual result in sync for both bounds. */
4673 191435 : *output = lbound ? gfc_conv_descriptor_lbound_get (desc,
4674 : gfc_rank_cst[dim]):
4675 63925 : gfc_conv_descriptor_ubound_get (desc,
4676 : gfc_rank_cst[dim]);
4677 : }
4678 : else
4679 : {
4680 : /* No specific bound specified so use the bound of the array. */
4681 509250 : *output = lbound ? gfc_conv_array_lbound (desc, dim) :
4682 167468 : gfc_conv_array_ubound (desc, dim);
4683 : }
4684 517252 : if (save_value)
4685 498136 : *output = gfc_evaluate_now (*output, block);
4686 517252 : }
4687 :
4688 :
4689 : /* Calculate the lower bound of an array section. */
4690 :
4691 : static void
4692 259259 : gfc_conv_section_startstride (stmtblock_t * block, gfc_ss * ss, int dim)
4693 : {
4694 259259 : gfc_expr *stride = NULL;
4695 259259 : tree desc;
4696 259259 : gfc_se se;
4697 259259 : gfc_array_info *info;
4698 259259 : gfc_array_ref *ar;
4699 :
4700 259259 : gcc_assert (ss->info->type == GFC_SS_SECTION);
4701 :
4702 259259 : info = &ss->info->data.array;
4703 259259 : ar = &info->ref->u.ar;
4704 :
4705 259259 : if (ar->dimen_type[dim] == DIMEN_VECTOR)
4706 : {
4707 : /* We use a zero-based index to access the vector. */
4708 980 : info->start[dim] = gfc_index_zero_node;
4709 980 : info->end[dim] = NULL;
4710 980 : info->stride[dim] = gfc_index_one_node;
4711 980 : return;
4712 : }
4713 :
4714 258279 : gcc_assert (ar->dimen_type[dim] == DIMEN_RANGE
4715 : || ar->dimen_type[dim] == DIMEN_THIS_IMAGE);
4716 258279 : desc = info->descriptor;
4717 258279 : stride = ar->stride[dim];
4718 258279 : bool save_value = !ss->is_alloc_lhs;
4719 :
4720 : /* Calculate the start of the range. For vector subscripts this will
4721 : be the range of the vector. */
4722 258279 : evaluate_bound (block, info->start, ar->start, desc, dim, true,
4723 258279 : ar->as->type == AS_DEFERRED, save_value);
4724 :
4725 : /* Similarly calculate the end. Although this is not used in the
4726 : scalarizer, it is needed when checking bounds and where the end
4727 : is an expression with side-effects. */
4728 258279 : evaluate_bound (block, info->end, ar->end, desc, dim, false,
4729 258279 : ar->as->type == AS_DEFERRED, save_value);
4730 :
4731 :
4732 : /* Calculate the stride. */
4733 258279 : if (stride == NULL)
4734 245475 : info->stride[dim] = gfc_index_one_node;
4735 : else
4736 : {
4737 12804 : gfc_init_se (&se, NULL);
4738 12804 : gfc_conv_expr_type (&se, stride, gfc_array_index_type);
4739 12804 : gfc_add_block_to_block (block, &se.pre);
4740 12804 : tree value = se.expr;
4741 12804 : if (save_value)
4742 12804 : info->stride[dim] = gfc_evaluate_now (value, block);
4743 : else
4744 0 : info->stride[dim] = value;
4745 : }
4746 : }
4747 :
4748 :
4749 : /* Generate in INNER the bounds checking code along the dimension DIM for
4750 : the array associated with SS_INFO. */
4751 :
4752 : static void
4753 24078 : add_check_section_in_array_bounds (stmtblock_t *inner, gfc_ss_info *ss_info,
4754 : int dim)
4755 : {
4756 24078 : gfc_expr *expr = ss_info->expr;
4757 24078 : locus *expr_loc = &expr->where;
4758 24078 : const char *expr_name = expr->symtree->name;
4759 :
4760 24078 : gfc_array_info *info = &ss_info->data.array;
4761 :
4762 24078 : bool check_upper;
4763 24078 : if (dim == info->ref->u.ar.dimen - 1
4764 20451 : && info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
4765 : check_upper = false;
4766 : else
4767 23782 : check_upper = true;
4768 :
4769 : /* Zero stride is not allowed. */
4770 24078 : tree tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
4771 : info->stride[dim], gfc_index_zero_node);
4772 24078 : char * msg = xasprintf ("Zero stride is not allowed, for dimension %d "
4773 : "of array '%s'", dim + 1, expr_name);
4774 24078 : gfc_trans_runtime_check (true, false, tmp, inner, expr_loc, msg);
4775 24078 : free (msg);
4776 :
4777 24078 : tree desc = info->descriptor;
4778 :
4779 : /* This is the run-time equivalent of resolve.cc's
4780 : check_dimension. The logical is more readable there
4781 : than it is here, with all the trees. */
4782 24078 : tree lbound = gfc_conv_array_lbound (desc, dim);
4783 24078 : tree end = info->end[dim];
4784 24078 : tree ubound = check_upper ? gfc_conv_array_ubound (desc, dim) : NULL_TREE;
4785 :
4786 : /* non_zerosized is true when the selected range is not
4787 : empty. */
4788 24078 : tree stride_pos = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
4789 : info->stride[dim], gfc_index_zero_node);
4790 24078 : tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
4791 : info->start[dim], end);
4792 24078 : stride_pos = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4793 : logical_type_node, stride_pos, tmp);
4794 :
4795 24078 : tree stride_neg = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
4796 : info->stride[dim], gfc_index_zero_node);
4797 24078 : tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
4798 : info->start[dim], end);
4799 24078 : stride_neg = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4800 : logical_type_node, stride_neg, tmp);
4801 24078 : tree non_zerosized = fold_build2_loc (input_location, TRUTH_OR_EXPR,
4802 : logical_type_node, stride_pos,
4803 : stride_neg);
4804 :
4805 : /* Check the start of the range against the lower and upper
4806 : bounds of the array, if the range is not empty.
4807 : If upper bound is present, include both bounds in the
4808 : error message. */
4809 24078 : if (check_upper)
4810 : {
4811 23782 : tmp = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
4812 : info->start[dim], lbound);
4813 23782 : tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
4814 : non_zerosized, tmp);
4815 23782 : tree tmp2 = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
4816 : info->start[dim], ubound);
4817 23782 : tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
4818 : non_zerosized, tmp2);
4819 23782 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' outside of "
4820 : "expected range (%%ld:%%ld)", dim + 1, expr_name);
4821 23782 : gfc_trans_runtime_check (true, false, tmp, inner, expr_loc, msg,
4822 : fold_convert (long_integer_type_node, info->start[dim]),
4823 : fold_convert (long_integer_type_node, lbound),
4824 : fold_convert (long_integer_type_node, ubound));
4825 23782 : gfc_trans_runtime_check (true, false, tmp2, inner, expr_loc, msg,
4826 : fold_convert (long_integer_type_node, info->start[dim]),
4827 : fold_convert (long_integer_type_node, lbound),
4828 : fold_convert (long_integer_type_node, ubound));
4829 23782 : free (msg);
4830 : }
4831 : else
4832 : {
4833 296 : tmp = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
4834 : info->start[dim], lbound);
4835 296 : tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
4836 : non_zerosized, tmp);
4837 296 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' below "
4838 : "lower bound of %%ld", dim + 1, expr_name);
4839 296 : gfc_trans_runtime_check (true, false, tmp, inner, expr_loc, msg,
4840 : fold_convert (long_integer_type_node, info->start[dim]),
4841 : fold_convert (long_integer_type_node, lbound));
4842 296 : free (msg);
4843 : }
4844 :
4845 : /* Compute the last element of the range, which is not
4846 : necessarily "end" (think 0:5:3, which doesn't contain 5)
4847 : and check it against both lower and upper bounds. */
4848 :
4849 24078 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4850 : end, info->start[dim]);
4851 24078 : tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR, gfc_array_index_type,
4852 : tmp, info->stride[dim]);
4853 24078 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4854 : end, tmp);
4855 24078 : tree tmp2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
4856 : tmp, lbound);
4857 24078 : tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
4858 : non_zerosized, tmp2);
4859 24078 : if (check_upper)
4860 : {
4861 23782 : tree tmp3 = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
4862 : tmp, ubound);
4863 23782 : tmp3 = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
4864 : non_zerosized, tmp3);
4865 23782 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' outside of "
4866 : "expected range (%%ld:%%ld)", dim + 1, expr_name);
4867 23782 : gfc_trans_runtime_check (true, false, tmp2, inner, expr_loc, msg,
4868 : fold_convert (long_integer_type_node, tmp),
4869 : fold_convert (long_integer_type_node, ubound),
4870 : fold_convert (long_integer_type_node, lbound));
4871 23782 : gfc_trans_runtime_check (true, false, tmp3, inner, expr_loc, msg,
4872 : fold_convert (long_integer_type_node, tmp),
4873 : fold_convert (long_integer_type_node, ubound),
4874 : fold_convert (long_integer_type_node, lbound));
4875 23782 : free (msg);
4876 : }
4877 : else
4878 : {
4879 296 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' below "
4880 : "lower bound of %%ld", dim + 1, expr_name);
4881 296 : gfc_trans_runtime_check (true, false, tmp2, inner, expr_loc, msg,
4882 : fold_convert (long_integer_type_node, tmp),
4883 : fold_convert (long_integer_type_node, lbound));
4884 296 : free (msg);
4885 : }
4886 24078 : }
4887 :
4888 :
4889 : /* Tells whether we need to generate bounds checking code for the array
4890 : associated with SS. */
4891 :
4892 : bool
4893 25045 : bounds_check_needed (gfc_ss *ss)
4894 : {
4895 : /* Catch allocatable lhs in f2003. */
4896 25045 : if (flag_realloc_lhs && ss->no_bounds_check)
4897 : return false;
4898 :
4899 24768 : gfc_ss_info *ss_info = ss->info;
4900 24768 : if (ss_info->type == GFC_SS_SECTION)
4901 : return true;
4902 :
4903 4126 : if (!(ss_info->type == GFC_SS_INTRINSIC
4904 227 : && ss_info->expr
4905 227 : && ss_info->expr->expr_type == EXPR_FUNCTION))
4906 : return false;
4907 :
4908 227 : gfc_intrinsic_sym *isym = ss_info->expr->value.function.isym;
4909 227 : if (!(isym
4910 227 : && (isym->id == GFC_ISYM_MAXLOC
4911 203 : || isym->id == GFC_ISYM_MINLOC)))
4912 : return false;
4913 :
4914 34 : return gfc_inline_intrinsic_function_p (ss_info->expr);
4915 : }
4916 :
4917 :
4918 : /* Calculates the range start and stride for a SS chain. Also gets the
4919 : descriptor and data pointer. The range of vector subscripts is the size
4920 : of the vector. Array bounds are also checked. */
4921 :
4922 : void
4923 184237 : gfc_conv_ss_startstride (gfc_loopinfo * loop)
4924 : {
4925 184237 : int n;
4926 184237 : tree tmp;
4927 184237 : gfc_ss *ss;
4928 :
4929 184237 : gfc_loopinfo * const outer_loop = outermost_loop (loop);
4930 :
4931 184237 : loop->dimen = 0;
4932 : /* Determine the rank of the loop. */
4933 204504 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4934 : {
4935 204504 : switch (ss->info->type)
4936 : {
4937 172915 : case GFC_SS_SECTION:
4938 172915 : case GFC_SS_CONSTRUCTOR:
4939 172915 : case GFC_SS_FUNCTION:
4940 172915 : case GFC_SS_COMPONENT:
4941 172915 : loop->dimen = ss->dimen;
4942 172915 : goto done;
4943 :
4944 : /* As usual, lbound and ubound are exceptions!. */
4945 11322 : case GFC_SS_INTRINSIC:
4946 11322 : switch (ss->info->expr->value.function.isym->id)
4947 : {
4948 11322 : case GFC_ISYM_LBOUND:
4949 11322 : case GFC_ISYM_UBOUND:
4950 11322 : case GFC_ISYM_COSHAPE:
4951 11322 : case GFC_ISYM_LCOBOUND:
4952 11322 : case GFC_ISYM_UCOBOUND:
4953 11322 : case GFC_ISYM_MAXLOC:
4954 11322 : case GFC_ISYM_MINLOC:
4955 11322 : case GFC_ISYM_SHAPE:
4956 11322 : case GFC_ISYM_THIS_IMAGE:
4957 11322 : loop->dimen = ss->dimen;
4958 11322 : goto done;
4959 :
4960 : default:
4961 : break;
4962 : }
4963 :
4964 20267 : default:
4965 20267 : break;
4966 : }
4967 : }
4968 :
4969 : /* We should have determined the rank of the expression by now. If
4970 : not, that's bad news. */
4971 0 : gcc_unreachable ();
4972 :
4973 : done:
4974 : /* Loop over all the SS in the chain. */
4975 479095 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4976 : {
4977 294858 : gfc_ss_info *ss_info;
4978 294858 : gfc_array_info *info;
4979 294858 : gfc_expr *expr;
4980 :
4981 294858 : ss_info = ss->info;
4982 294858 : expr = ss_info->expr;
4983 294858 : info = &ss_info->data.array;
4984 :
4985 294858 : if (expr && expr->shape && !info->shape)
4986 171089 : info->shape = expr->shape;
4987 :
4988 294858 : switch (ss_info->type)
4989 : {
4990 186991 : case GFC_SS_SECTION:
4991 : /* Get the descriptor for the array. If it is a cross loops array,
4992 : we got the descriptor already in the outermost loop. */
4993 186991 : if (ss->parent == NULL)
4994 182355 : gfc_conv_ss_descriptor (&outer_loop->pre, ss,
4995 182355 : !loop->array_parameter);
4996 :
4997 445432 : for (n = 0; n < ss->dimen; n++)
4998 258441 : gfc_conv_section_startstride (&outer_loop->pre, ss, ss->dim[n]);
4999 : break;
5000 :
5001 11581 : case GFC_SS_INTRINSIC:
5002 11581 : switch (expr->value.function.isym->id)
5003 : {
5004 3281 : case GFC_ISYM_MINLOC:
5005 3281 : case GFC_ISYM_MAXLOC:
5006 3281 : {
5007 3281 : gfc_se se;
5008 3281 : gfc_init_se (&se, nullptr);
5009 3281 : se.loop = loop;
5010 3281 : se.ss = ss;
5011 3281 : gfc_conv_intrinsic_function (&se, expr);
5012 3281 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
5013 3281 : gfc_add_block_to_block (&outer_loop->post, &se.post);
5014 :
5015 3281 : info->descriptor = se.expr;
5016 :
5017 3281 : info->data = gfc_conv_array_data (info->descriptor);
5018 3281 : info->data = gfc_evaluate_now (info->data, &outer_loop->pre);
5019 :
5020 3281 : gfc_expr *array = expr->value.function.actual->expr;
5021 3281 : tree rank = build_int_cst (gfc_array_index_type, array->rank);
5022 :
5023 3281 : tree tmp = fold_build2_loc (input_location, MINUS_EXPR,
5024 : gfc_array_index_type, rank,
5025 : gfc_index_one_node);
5026 :
5027 3281 : info->end[0] = gfc_evaluate_now (tmp, &outer_loop->pre);
5028 3281 : info->start[0] = gfc_index_zero_node;
5029 3281 : info->stride[0] = gfc_index_one_node;
5030 3281 : info->offset = gfc_index_zero_node;
5031 3281 : continue;
5032 3281 : }
5033 :
5034 : /* Fall through to supply start and stride. */
5035 3004 : case GFC_ISYM_LBOUND:
5036 3004 : case GFC_ISYM_UBOUND:
5037 : /* This is the variant without DIM=... */
5038 3004 : gcc_assert (expr->value.function.actual->next->expr == NULL);
5039 : /* Fall through. */
5040 :
5041 7992 : case GFC_ISYM_SHAPE:
5042 7992 : {
5043 7992 : gfc_expr *arg;
5044 :
5045 7992 : arg = expr->value.function.actual->expr;
5046 7992 : if (arg->rank == -1)
5047 : {
5048 1175 : gfc_se se;
5049 1175 : tree rank, tmp;
5050 :
5051 : /* The rank (hence the return value's shape) is unknown,
5052 : we have to retrieve it. */
5053 1175 : gfc_init_se (&se, NULL);
5054 1175 : se.descriptor_only = 1;
5055 1175 : gfc_conv_expr (&se, arg);
5056 : /* This is a bare variable, so there is no preliminary
5057 : or cleanup code unless -std=f202y and bounds checking
5058 : is on. */
5059 1175 : if (!((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
5060 0 : && (gfc_option.allow_std & GFC_STD_F202Y)))
5061 1175 : gcc_assert (se.pre.head == NULL_TREE
5062 : && se.post.head == NULL_TREE);
5063 1175 : rank = gfc_conv_descriptor_rank (se.expr);
5064 1175 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
5065 : gfc_array_index_type,
5066 : fold_convert (gfc_array_index_type,
5067 : rank),
5068 : gfc_index_one_node);
5069 1175 : info->end[0] = gfc_evaluate_now (tmp, &outer_loop->pre);
5070 1175 : info->start[0] = gfc_index_zero_node;
5071 1175 : info->stride[0] = gfc_index_one_node;
5072 1175 : continue;
5073 1175 : }
5074 : /* Otherwise fall through GFC_SS_FUNCTION. */
5075 : gcc_fallthrough ();
5076 : }
5077 : case GFC_ISYM_COSHAPE:
5078 : case GFC_ISYM_LCOBOUND:
5079 : case GFC_ISYM_UCOBOUND:
5080 : case GFC_ISYM_THIS_IMAGE:
5081 : break;
5082 :
5083 0 : default:
5084 0 : continue;
5085 0 : }
5086 :
5087 : /* FALLTHRU */
5088 : case GFC_SS_CONSTRUCTOR:
5089 : case GFC_SS_FUNCTION:
5090 130354 : for (n = 0; n < ss->dimen; n++)
5091 : {
5092 70357 : int dim = ss->dim[n];
5093 :
5094 70357 : info->start[dim] = gfc_index_zero_node;
5095 70357 : if (ss_info->type != GFC_SS_FUNCTION)
5096 55900 : info->end[dim] = gfc_index_zero_node;
5097 70357 : info->stride[dim] = gfc_index_one_node;
5098 : }
5099 : break;
5100 :
5101 : default:
5102 : break;
5103 : }
5104 : }
5105 :
5106 : /* The rest is just runtime bounds checking. */
5107 184237 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
5108 : {
5109 16945 : stmtblock_t block;
5110 16945 : tree size[GFC_MAX_DIMENSIONS];
5111 16945 : tree tmp3;
5112 16945 : gfc_array_info *info;
5113 16945 : char *msg;
5114 16945 : int dim;
5115 :
5116 16945 : gfc_start_block (&block);
5117 :
5118 54257 : for (n = 0; n < loop->dimen; n++)
5119 20367 : size[n] = NULL_TREE;
5120 :
5121 : /* If there is a constructor involved, derive size[] from its shape. */
5122 39164 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5123 : {
5124 24699 : gfc_ss_info *ss_info;
5125 :
5126 24699 : ss_info = ss->info;
5127 24699 : info = &ss_info->data.array;
5128 :
5129 24699 : if (ss_info->type == GFC_SS_CONSTRUCTOR && info->shape)
5130 : {
5131 5224 : for (n = 0; n < loop->dimen; n++)
5132 : {
5133 2744 : if (size[n] == NULL)
5134 : {
5135 2744 : gcc_assert (info->shape[n]);
5136 2744 : size[n] = gfc_conv_mpz_to_tree (info->shape[n],
5137 : gfc_index_integer_kind);
5138 : }
5139 : }
5140 : break;
5141 : }
5142 : }
5143 :
5144 41990 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5145 : {
5146 25045 : stmtblock_t inner;
5147 25045 : gfc_ss_info *ss_info;
5148 25045 : gfc_expr *expr;
5149 25045 : locus *expr_loc;
5150 25045 : const char *expr_name;
5151 25045 : char *ref_name = NULL;
5152 :
5153 25045 : if (!bounds_check_needed (ss))
5154 4369 : continue;
5155 :
5156 20676 : ss_info = ss->info;
5157 20676 : expr = ss_info->expr;
5158 20676 : expr_loc = &expr->where;
5159 20676 : if (expr->ref)
5160 20642 : expr_name = ref_name = abridged_ref_name (expr, NULL);
5161 : else
5162 34 : expr_name = expr->symtree->name;
5163 :
5164 20676 : gfc_start_block (&inner);
5165 :
5166 : /* TODO: range checking for mapped dimensions. */
5167 20676 : info = &ss_info->data.array;
5168 :
5169 : /* This code only checks ranges. Elemental and vector
5170 : dimensions are checked later. */
5171 65478 : for (n = 0; n < loop->dimen; n++)
5172 : {
5173 24126 : dim = ss->dim[n];
5174 24126 : if (ss_info->type == GFC_SS_SECTION)
5175 : {
5176 24092 : if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
5177 14 : continue;
5178 :
5179 24078 : add_check_section_in_array_bounds (&inner, ss_info, dim);
5180 : }
5181 :
5182 : /* Check the section sizes match. */
5183 24112 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
5184 : gfc_array_index_type, info->end[dim],
5185 : info->start[dim]);
5186 24112 : tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
5187 : gfc_array_index_type, tmp,
5188 : info->stride[dim]);
5189 24112 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
5190 : gfc_array_index_type,
5191 : gfc_index_one_node, tmp);
5192 24112 : tmp = fold_build2_loc (input_location, MAX_EXPR,
5193 : gfc_array_index_type, tmp,
5194 : build_int_cst (gfc_array_index_type, 0));
5195 : /* We remember the size of the first section, and check all the
5196 : others against this. */
5197 24112 : if (size[n])
5198 : {
5199 7193 : tmp3 = fold_build2_loc (input_location, NE_EXPR,
5200 : logical_type_node, tmp, size[n]);
5201 7193 : if (ss_info->type == GFC_SS_INTRINSIC)
5202 0 : msg = xasprintf ("Extent mismatch for dimension %d of the "
5203 : "result of intrinsic '%s' (%%ld/%%ld)",
5204 : dim + 1, expr_name);
5205 : else
5206 7193 : msg = xasprintf ("Array bound mismatch for dimension %d "
5207 : "of array '%s' (%%ld/%%ld)",
5208 : dim + 1, expr_name);
5209 :
5210 7193 : gfc_trans_runtime_check (true, false, tmp3, &inner,
5211 : expr_loc, msg,
5212 : fold_convert (long_integer_type_node, tmp),
5213 : fold_convert (long_integer_type_node, size[n]));
5214 :
5215 7193 : free (msg);
5216 : }
5217 : else
5218 16919 : size[n] = gfc_evaluate_now (tmp, &inner);
5219 : }
5220 :
5221 20676 : tmp = gfc_finish_block (&inner);
5222 :
5223 : /* For optional arguments, only check bounds if the argument is
5224 : present. */
5225 20676 : if ((expr->symtree->n.sym->attr.optional
5226 20368 : || expr->symtree->n.sym->attr.not_always_present)
5227 308 : && expr->symtree->n.sym->attr.dummy)
5228 307 : tmp = build3_v (COND_EXPR,
5229 : gfc_conv_expr_present (expr->symtree->n.sym),
5230 : tmp, build_empty_stmt (input_location));
5231 :
5232 20676 : gfc_add_expr_to_block (&block, tmp);
5233 :
5234 20676 : free (ref_name);
5235 : }
5236 :
5237 16945 : tmp = gfc_finish_block (&block);
5238 16945 : gfc_add_expr_to_block (&outer_loop->pre, tmp);
5239 : }
5240 :
5241 187601 : for (loop = loop->nested; loop; loop = loop->next)
5242 3364 : gfc_conv_ss_startstride (loop);
5243 184237 : }
5244 :
5245 : /* Return true if both symbols could refer to the same data object. Does
5246 : not take account of aliasing due to equivalence statements. */
5247 :
5248 : static bool
5249 13804 : symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym, bool lsym_pointer,
5250 : bool lsym_target, bool rsym_pointer, bool rsym_target)
5251 : {
5252 : /* Aliasing isn't possible if the symbols have different base types,
5253 : except for complex types where an inquiry reference (%RE, %IM) could
5254 : alias with a real type with the same kind parameter. */
5255 13804 : if (!gfc_compare_types (&lsym->ts, &rsym->ts)
5256 13804 : && !(((lsym->ts.type == BT_COMPLEX && rsym->ts.type == BT_REAL)
5257 4929 : || (lsym->ts.type == BT_REAL && rsym->ts.type == BT_COMPLEX))
5258 76 : && lsym->ts.kind == rsym->ts.kind))
5259 : return false;
5260 :
5261 : /* Pointers can point to other pointers and target objects. */
5262 :
5263 8888 : if ((lsym_pointer && (rsym_pointer || rsym_target))
5264 8679 : || (rsym_pointer && (lsym_pointer || lsym_target)))
5265 : return true;
5266 :
5267 : /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
5268 : and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
5269 : checked above. */
5270 8765 : if (lsym_target && rsym_target
5271 14 : && ((lsym->attr.dummy && !lsym->attr.contiguous
5272 0 : && (!lsym->attr.dimension || lsym->as->type == AS_ASSUMED_SHAPE))
5273 14 : || (rsym->attr.dummy && !rsym->attr.contiguous
5274 6 : && (!rsym->attr.dimension
5275 6 : || rsym->as->type == AS_ASSUMED_SHAPE))))
5276 6 : return true;
5277 :
5278 : return false;
5279 : }
5280 :
5281 :
5282 : /* Return true if the two SS could be aliased, i.e. both point to the same data
5283 : object. */
5284 : /* TODO: resolve aliases based on frontend expressions. */
5285 :
5286 : static int
5287 11614 : gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
5288 : {
5289 11614 : gfc_ref *lref;
5290 11614 : gfc_ref *rref;
5291 11614 : gfc_expr *lexpr, *rexpr;
5292 11614 : gfc_symbol *lsym;
5293 11614 : gfc_symbol *rsym;
5294 11614 : bool lsym_pointer, lsym_target, rsym_pointer, rsym_target;
5295 :
5296 11614 : lexpr = lss->info->expr;
5297 11614 : rexpr = rss->info->expr;
5298 :
5299 11614 : lsym = lexpr->symtree->n.sym;
5300 11614 : rsym = rexpr->symtree->n.sym;
5301 :
5302 11614 : lsym_pointer = lsym->attr.pointer;
5303 11614 : lsym_target = lsym->attr.target;
5304 11614 : rsym_pointer = rsym->attr.pointer;
5305 11614 : rsym_target = rsym->attr.target;
5306 :
5307 11614 : if (symbols_could_alias (lsym, rsym, lsym_pointer, lsym_target,
5308 : rsym_pointer, rsym_target))
5309 : return 1;
5310 :
5311 11523 : if (rsym->ts.type != BT_DERIVED && rsym->ts.type != BT_CLASS
5312 10136 : && lsym->ts.type != BT_DERIVED && lsym->ts.type != BT_CLASS)
5313 : return 0;
5314 :
5315 : /* For derived types we must check all the component types. We can ignore
5316 : array references as these will have the same base type as the previous
5317 : component ref. */
5318 2830 : for (lref = lexpr->ref; lref != lss->info->data.array.ref; lref = lref->next)
5319 : {
5320 1019 : if (lref->type != REF_COMPONENT)
5321 107 : continue;
5322 :
5323 912 : lsym_pointer = lsym_pointer || lref->u.c.sym->attr.pointer;
5324 912 : lsym_target = lsym_target || lref->u.c.sym->attr.target;
5325 :
5326 912 : if (symbols_could_alias (lref->u.c.sym, rsym, lsym_pointer, lsym_target,
5327 : rsym_pointer, rsym_target))
5328 : return 1;
5329 :
5330 912 : if ((lsym_pointer && (rsym_pointer || rsym_target))
5331 897 : || (rsym_pointer && (lsym_pointer || lsym_target)))
5332 : {
5333 6 : if (gfc_compare_types (&lref->u.c.component->ts,
5334 : &rsym->ts))
5335 : return 1;
5336 : }
5337 :
5338 1366 : for (rref = rexpr->ref; rref != rss->info->data.array.ref;
5339 460 : rref = rref->next)
5340 : {
5341 461 : if (rref->type != REF_COMPONENT)
5342 36 : continue;
5343 :
5344 425 : rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
5345 425 : rsym_target = lsym_target || rref->u.c.sym->attr.target;
5346 :
5347 425 : if (symbols_could_alias (lref->u.c.sym, rref->u.c.sym,
5348 : lsym_pointer, lsym_target,
5349 : rsym_pointer, rsym_target))
5350 : return 1;
5351 :
5352 424 : if ((lsym_pointer && (rsym_pointer || rsym_target))
5353 420 : || (rsym_pointer && (lsym_pointer || lsym_target)))
5354 : {
5355 0 : if (gfc_compare_types (&lref->u.c.component->ts,
5356 0 : &rref->u.c.sym->ts))
5357 : return 1;
5358 0 : if (gfc_compare_types (&lref->u.c.sym->ts,
5359 0 : &rref->u.c.component->ts))
5360 : return 1;
5361 0 : if (gfc_compare_types (&lref->u.c.component->ts,
5362 0 : &rref->u.c.component->ts))
5363 : return 1;
5364 : }
5365 : }
5366 : }
5367 :
5368 1811 : lsym_pointer = lsym->attr.pointer;
5369 1811 : lsym_target = lsym->attr.target;
5370 :
5371 2658 : for (rref = rexpr->ref; rref != rss->info->data.array.ref; rref = rref->next)
5372 : {
5373 1000 : if (rref->type != REF_COMPONENT)
5374 : break;
5375 :
5376 853 : rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
5377 853 : rsym_target = lsym_target || rref->u.c.sym->attr.target;
5378 :
5379 853 : if (symbols_could_alias (rref->u.c.sym, lsym,
5380 : lsym_pointer, lsym_target,
5381 : rsym_pointer, rsym_target))
5382 : return 1;
5383 :
5384 853 : if ((lsym_pointer && (rsym_pointer || rsym_target))
5385 835 : || (rsym_pointer && (lsym_pointer || lsym_target)))
5386 : {
5387 6 : if (gfc_compare_types (&lsym->ts, &rref->u.c.component->ts))
5388 : return 1;
5389 : }
5390 : }
5391 :
5392 : return 0;
5393 : }
5394 :
5395 :
5396 : /* Resolve array data dependencies. Creates a temporary if required. */
5397 : /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
5398 : dependency.cc. */
5399 :
5400 : void
5401 38355 : gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
5402 : gfc_ss * rss)
5403 : {
5404 38355 : gfc_ss *ss;
5405 38355 : gfc_ref *lref;
5406 38355 : gfc_ref *rref;
5407 38355 : gfc_ss_info *ss_info;
5408 38355 : gfc_expr *dest_expr;
5409 38355 : gfc_expr *ss_expr;
5410 38355 : int nDepend = 0;
5411 38355 : int i, j;
5412 :
5413 38355 : loop->temp_ss = NULL;
5414 38355 : dest_expr = dest->info->expr;
5415 :
5416 82582 : for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
5417 : {
5418 45420 : ss_info = ss->info;
5419 45420 : ss_expr = ss_info->expr;
5420 :
5421 45420 : if (ss_info->array_outer_dependency)
5422 : {
5423 : nDepend = 1;
5424 : break;
5425 : }
5426 :
5427 45303 : if (ss_info->type != GFC_SS_SECTION)
5428 : {
5429 30924 : if (flag_realloc_lhs
5430 29873 : && dest_expr != ss_expr
5431 29873 : && gfc_is_reallocatable_lhs (dest_expr)
5432 38071 : && ss_expr->rank)
5433 3439 : nDepend = gfc_check_dependency (dest_expr, ss_expr, true);
5434 :
5435 : /* Check for cases like c(:)(1:2) = c(2)(2:3) */
5436 30924 : if (!nDepend && dest_expr->rank > 0
5437 30394 : && dest_expr->ts.type == BT_CHARACTER
5438 4772 : && ss_expr->expr_type == EXPR_VARIABLE)
5439 :
5440 165 : nDepend = gfc_check_dependency (dest_expr, ss_expr, false);
5441 :
5442 30924 : if (ss_info->type == GFC_SS_REFERENCE
5443 30924 : && gfc_check_dependency (dest_expr, ss_expr, false))
5444 188 : ss_info->data.scalar.needs_temporary = 1;
5445 :
5446 30924 : if (nDepend)
5447 : break;
5448 : else
5449 30382 : continue;
5450 : }
5451 :
5452 14379 : if (dest_expr->symtree->n.sym != ss_expr->symtree->n.sym)
5453 : {
5454 11614 : if (gfc_could_be_alias (dest, ss)
5455 11614 : || gfc_are_equivalenced_arrays (dest_expr, ss_expr))
5456 : {
5457 : nDepend = 1;
5458 : break;
5459 : }
5460 : }
5461 : else
5462 : {
5463 2765 : lref = dest_expr->ref;
5464 2765 : rref = ss_expr->ref;
5465 :
5466 2765 : nDepend = gfc_dep_resolver (lref, rref, &loop->reverse[0]);
5467 :
5468 2765 : if (nDepend == 1)
5469 : break;
5470 :
5471 5518 : for (i = 0; i < dest->dimen; i++)
5472 7510 : for (j = 0; j < ss->dimen; j++)
5473 4468 : if (i != j
5474 1363 : && dest->dim[i] == ss->dim[j])
5475 : {
5476 : /* If we don't access array elements in the same order,
5477 : there is a dependency. */
5478 63 : nDepend = 1;
5479 63 : goto temporary;
5480 : }
5481 : #if 0
5482 : /* TODO : loop shifting. */
5483 : if (nDepend == 1)
5484 : {
5485 : /* Mark the dimensions for LOOP SHIFTING */
5486 : for (n = 0; n < loop->dimen; n++)
5487 : {
5488 : int dim = dest->data.info.dim[n];
5489 :
5490 : if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
5491 : depends[n] = 2;
5492 : else if (! gfc_is_same_range (&lref->u.ar,
5493 : &rref->u.ar, dim, 0))
5494 : depends[n] = 1;
5495 : }
5496 :
5497 : /* Put all the dimensions with dependencies in the
5498 : innermost loops. */
5499 : dim = 0;
5500 : for (n = 0; n < loop->dimen; n++)
5501 : {
5502 : gcc_assert (loop->order[n] == n);
5503 : if (depends[n])
5504 : loop->order[dim++] = n;
5505 : }
5506 : for (n = 0; n < loop->dimen; n++)
5507 : {
5508 : if (! depends[n])
5509 : loop->order[dim++] = n;
5510 : }
5511 :
5512 : gcc_assert (dim == loop->dimen);
5513 : break;
5514 : }
5515 : #endif
5516 : }
5517 : }
5518 :
5519 831 : temporary:
5520 :
5521 38355 : if (nDepend == 1)
5522 : {
5523 1193 : tree base_type = gfc_typenode_for_spec (&dest_expr->ts);
5524 1193 : if (GFC_ARRAY_TYPE_P (base_type)
5525 1193 : || GFC_DESCRIPTOR_TYPE_P (base_type))
5526 0 : base_type = gfc_get_element_type (base_type);
5527 1193 : loop->temp_ss = gfc_get_temp_ss (base_type, dest->info->string_length,
5528 : loop->dimen);
5529 1193 : gfc_add_ss_to_loop (loop, loop->temp_ss);
5530 : }
5531 : else
5532 37162 : loop->temp_ss = NULL;
5533 38355 : }
5534 :
5535 :
5536 : /* Browse through each array's information from the scalarizer and set the loop
5537 : bounds according to the "best" one (per dimension), i.e. the one which
5538 : provides the most information (constant bounds, shape, etc.). */
5539 :
5540 : static void
5541 184237 : set_loop_bounds (gfc_loopinfo *loop)
5542 : {
5543 184237 : int n, dim, spec_dim;
5544 184237 : gfc_array_info *info;
5545 184237 : gfc_array_info *specinfo;
5546 184237 : gfc_ss *ss;
5547 184237 : tree tmp;
5548 184237 : gfc_ss **loopspec;
5549 184237 : bool dynamic[GFC_MAX_DIMENSIONS];
5550 184237 : mpz_t *cshape;
5551 184237 : mpz_t i;
5552 184237 : bool nonoptional_arr;
5553 :
5554 184237 : gfc_loopinfo * const outer_loop = outermost_loop (loop);
5555 :
5556 184237 : loopspec = loop->specloop;
5557 :
5558 184237 : mpz_init (i);
5559 434127 : for (n = 0; n < loop->dimen; n++)
5560 : {
5561 249890 : loopspec[n] = NULL;
5562 249890 : dynamic[n] = false;
5563 :
5564 : /* If there are both optional and nonoptional array arguments, scalarize
5565 : over the nonoptional; otherwise, it does not matter as then all
5566 : (optional) arrays have to be present per F2008, 125.2.12p3(6). */
5567 :
5568 249890 : nonoptional_arr = false;
5569 :
5570 291323 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5571 291303 : if (ss->info->type != GFC_SS_SCALAR && ss->info->type != GFC_SS_TEMP
5572 256461 : && ss->info->type != GFC_SS_REFERENCE && !ss->info->can_be_null_ref)
5573 : {
5574 : nonoptional_arr = true;
5575 : break;
5576 : }
5577 :
5578 : /* We use one SS term, and use that to determine the bounds of the
5579 : loop for this dimension. We try to pick the simplest term. */
5580 654273 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5581 : {
5582 404383 : gfc_ss_type ss_type;
5583 :
5584 404383 : ss_type = ss->info->type;
5585 474695 : if (ss_type == GFC_SS_SCALAR
5586 404383 : || ss_type == GFC_SS_TEMP
5587 343341 : || ss_type == GFC_SS_REFERENCE
5588 334348 : || (ss->info->can_be_null_ref && nonoptional_arr))
5589 70312 : continue;
5590 :
5591 334071 : info = &ss->info->data.array;
5592 334071 : dim = ss->dim[n];
5593 :
5594 334071 : if (loopspec[n] != NULL)
5595 : {
5596 84181 : specinfo = &loopspec[n]->info->data.array;
5597 84181 : spec_dim = loopspec[n]->dim[n];
5598 : }
5599 : else
5600 : {
5601 : /* Silence uninitialized warnings. */
5602 : specinfo = NULL;
5603 : spec_dim = 0;
5604 : }
5605 :
5606 334071 : if (info->shape)
5607 : {
5608 : /* The frontend has worked out the size for us. */
5609 225875 : if (!loopspec[n]
5610 59485 : || !specinfo->shape
5611 272621 : || !integer_zerop (specinfo->start[spec_dim]))
5612 : /* Prefer zero-based descriptors if possible. */
5613 208884 : loopspec[n] = ss;
5614 225875 : continue;
5615 : }
5616 :
5617 108196 : if (ss_type == GFC_SS_CONSTRUCTOR)
5618 : {
5619 1452 : gfc_constructor_base base;
5620 : /* An unknown size constructor will always be rank one.
5621 : Higher rank constructors will either have known shape,
5622 : or still be wrapped in a call to reshape. */
5623 1452 : gcc_assert (loop->dimen == 1);
5624 :
5625 : /* Always prefer to use the constructor bounds if the size
5626 : can be determined at compile time. Prefer not to otherwise,
5627 : since the general case involves realloc, and it's better to
5628 : avoid that overhead if possible. */
5629 1452 : base = ss->info->expr->value.constructor;
5630 1452 : dynamic[n] = gfc_get_array_constructor_size (&i, base);
5631 1452 : if (!dynamic[n] || !loopspec[n])
5632 1229 : loopspec[n] = ss;
5633 1452 : continue;
5634 1452 : }
5635 :
5636 : /* Avoid using an allocatable lhs in an assignment, since
5637 : there might be a reallocation coming. */
5638 106744 : if (loopspec[n] && ss->is_alloc_lhs)
5639 9558 : continue;
5640 :
5641 97186 : if (!loopspec[n])
5642 82271 : loopspec[n] = ss;
5643 : /* Criteria for choosing a loop specifier (most important first):
5644 : doesn't need realloc
5645 : stride of one
5646 : known stride
5647 : known lower bound
5648 : known upper bound
5649 : */
5650 14915 : else if (loopspec[n]->info->type == GFC_SS_CONSTRUCTOR && dynamic[n])
5651 235 : loopspec[n] = ss;
5652 14680 : else if (integer_onep (info->stride[dim])
5653 14680 : && !integer_onep (specinfo->stride[spec_dim]))
5654 120 : loopspec[n] = ss;
5655 14560 : else if (INTEGER_CST_P (info->stride[dim])
5656 14336 : && !INTEGER_CST_P (specinfo->stride[spec_dim]))
5657 0 : loopspec[n] = ss;
5658 14560 : else if (INTEGER_CST_P (info->start[dim])
5659 4475 : && !INTEGER_CST_P (specinfo->start[spec_dim])
5660 856 : && integer_onep (info->stride[dim])
5661 428 : == integer_onep (specinfo->stride[spec_dim])
5662 14560 : && INTEGER_CST_P (info->stride[dim])
5663 401 : == INTEGER_CST_P (specinfo->stride[spec_dim]))
5664 401 : loopspec[n] = ss;
5665 : /* We don't work out the upper bound.
5666 : else if (INTEGER_CST_P (info->finish[n])
5667 : && ! INTEGER_CST_P (specinfo->finish[n]))
5668 : loopspec[n] = ss; */
5669 : }
5670 :
5671 : /* We should have found the scalarization loop specifier. If not,
5672 : that's bad news. */
5673 249890 : gcc_assert (loopspec[n]);
5674 :
5675 249890 : info = &loopspec[n]->info->data.array;
5676 249890 : dim = loopspec[n]->dim[n];
5677 :
5678 : /* Set the extents of this range. */
5679 249890 : cshape = info->shape;
5680 249890 : if (cshape && INTEGER_CST_P (info->start[dim])
5681 178930 : && INTEGER_CST_P (info->stride[dim]))
5682 : {
5683 178930 : loop->from[n] = info->start[dim];
5684 178930 : mpz_set (i, cshape[get_array_ref_dim_for_loop_dim (loopspec[n], n)]);
5685 178930 : mpz_sub_ui (i, i, 1);
5686 : /* To = from + (size - 1) * stride. */
5687 178930 : tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
5688 178930 : if (!integer_onep (info->stride[dim]))
5689 8737 : tmp = fold_build2_loc (input_location, MULT_EXPR,
5690 : gfc_array_index_type, tmp,
5691 : info->stride[dim]);
5692 178930 : loop->to[n] = fold_build2_loc (input_location, PLUS_EXPR,
5693 : gfc_array_index_type,
5694 : loop->from[n], tmp);
5695 : }
5696 : else
5697 : {
5698 70960 : loop->from[n] = info->start[dim];
5699 70960 : switch (loopspec[n]->info->type)
5700 : {
5701 893 : case GFC_SS_CONSTRUCTOR:
5702 : /* The upper bound is calculated when we expand the
5703 : constructor. */
5704 893 : gcc_assert (loop->to[n] == NULL_TREE);
5705 : break;
5706 :
5707 64417 : case GFC_SS_SECTION:
5708 : /* Use the end expression if it exists and is not constant,
5709 : so that it is only evaluated once. */
5710 64417 : loop->to[n] = info->end[dim];
5711 64417 : break;
5712 :
5713 4871 : case GFC_SS_FUNCTION:
5714 : /* The loop bound will be set when we generate the call. */
5715 4871 : gcc_assert (loop->to[n] == NULL_TREE);
5716 : break;
5717 :
5718 767 : case GFC_SS_INTRINSIC:
5719 767 : {
5720 767 : gfc_expr *expr = loopspec[n]->info->expr;
5721 :
5722 : /* The {l,u}bound of an assumed rank. */
5723 767 : if (expr->value.function.isym->id == GFC_ISYM_SHAPE)
5724 255 : gcc_assert (expr->value.function.actual->expr->rank == -1);
5725 : else
5726 512 : gcc_assert ((expr->value.function.isym->id == GFC_ISYM_LBOUND
5727 : || expr->value.function.isym->id == GFC_ISYM_UBOUND)
5728 : && expr->value.function.actual->next->expr == NULL
5729 : && expr->value.function.actual->expr->rank == -1);
5730 :
5731 767 : loop->to[n] = info->end[dim];
5732 767 : break;
5733 : }
5734 :
5735 12 : case GFC_SS_COMPONENT:
5736 12 : {
5737 12 : if (info->end[dim] != NULL_TREE)
5738 : {
5739 12 : loop->to[n] = info->end[dim];
5740 12 : break;
5741 : }
5742 : else
5743 0 : gcc_unreachable ();
5744 : }
5745 :
5746 0 : default:
5747 0 : gcc_unreachable ();
5748 : }
5749 : }
5750 :
5751 : /* Transform everything so we have a simple incrementing variable. */
5752 249890 : if (integer_onep (info->stride[dim]))
5753 239032 : info->delta[dim] = gfc_index_zero_node;
5754 : else
5755 : {
5756 : /* Set the delta for this section. */
5757 10858 : info->delta[dim] = gfc_evaluate_now (loop->from[n], &outer_loop->pre);
5758 : /* Number of iterations is (end - start + step) / step.
5759 : with start = 0, this simplifies to
5760 : last = end / step;
5761 : for (i = 0; i<=last; i++){...}; */
5762 10858 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
5763 : gfc_array_index_type, loop->to[n],
5764 : loop->from[n]);
5765 10858 : tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
5766 : gfc_array_index_type, tmp, info->stride[dim]);
5767 10858 : tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
5768 : tmp, build_int_cst (gfc_array_index_type, -1));
5769 10858 : loop->to[n] = gfc_evaluate_now (tmp, &outer_loop->pre);
5770 : /* Make the loop variable start at 0. */
5771 10858 : loop->from[n] = gfc_index_zero_node;
5772 : }
5773 : }
5774 184237 : mpz_clear (i);
5775 :
5776 187601 : for (loop = loop->nested; loop; loop = loop->next)
5777 3364 : set_loop_bounds (loop);
5778 184237 : }
5779 :
5780 :
5781 : /* Last attempt to set the loop bounds, in case they depend on an allocatable
5782 : function result. */
5783 :
5784 : static void
5785 184237 : late_set_loop_bounds (gfc_loopinfo *loop)
5786 : {
5787 184237 : int n, dim;
5788 184237 : gfc_array_info *info;
5789 184237 : gfc_ss **loopspec;
5790 :
5791 184237 : loopspec = loop->specloop;
5792 :
5793 434127 : for (n = 0; n < loop->dimen; n++)
5794 : {
5795 : /* Set the extents of this range. */
5796 249890 : if (loop->from[n] == NULL_TREE
5797 249890 : || loop->to[n] == NULL_TREE)
5798 : {
5799 : /* We should have found the scalarization loop specifier. If not,
5800 : that's bad news. */
5801 455 : gcc_assert (loopspec[n]);
5802 :
5803 455 : info = &loopspec[n]->info->data.array;
5804 455 : dim = loopspec[n]->dim[n];
5805 :
5806 455 : if (loopspec[n]->info->type == GFC_SS_FUNCTION
5807 455 : && info->start[dim]
5808 455 : && info->end[dim])
5809 : {
5810 153 : loop->from[n] = info->start[dim];
5811 153 : loop->to[n] = info->end[dim];
5812 : }
5813 : }
5814 : }
5815 :
5816 187601 : for (loop = loop->nested; loop; loop = loop->next)
5817 3364 : late_set_loop_bounds (loop);
5818 184237 : }
5819 :
5820 :
5821 : /* Initialize the scalarization loop. Creates the loop variables. Determines
5822 : the range of the loop variables. Creates a temporary if required.
5823 : Also generates code for scalar expressions which have been
5824 : moved outside the loop. */
5825 :
5826 : void
5827 180873 : gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
5828 : {
5829 180873 : gfc_ss *tmp_ss;
5830 180873 : tree tmp;
5831 :
5832 180873 : set_loop_bounds (loop);
5833 :
5834 : /* Add all the scalar code that can be taken out of the loops.
5835 : This may include calculating the loop bounds, so do it before
5836 : allocating the temporary. */
5837 180873 : gfc_add_loop_ss_code (loop, loop->ss, false, where);
5838 :
5839 180873 : late_set_loop_bounds (loop);
5840 :
5841 180873 : tmp_ss = loop->temp_ss;
5842 : /* If we want a temporary then create it. */
5843 180873 : if (tmp_ss != NULL)
5844 : {
5845 11384 : gfc_ss_info *tmp_ss_info;
5846 :
5847 11384 : tmp_ss_info = tmp_ss->info;
5848 11384 : gcc_assert (tmp_ss_info->type == GFC_SS_TEMP);
5849 11384 : gcc_assert (loop->parent == NULL);
5850 :
5851 : /* Make absolutely sure that this is a complete type. */
5852 11384 : if (tmp_ss_info->string_length)
5853 2772 : tmp_ss_info->data.temp.type
5854 2772 : = gfc_get_character_type_len_for_eltype
5855 2772 : (TREE_TYPE (tmp_ss_info->data.temp.type),
5856 : tmp_ss_info->string_length);
5857 :
5858 11384 : tmp = tmp_ss_info->data.temp.type;
5859 11384 : memset (&tmp_ss_info->data.array, 0, sizeof (gfc_array_info));
5860 11384 : tmp_ss_info->type = GFC_SS_SECTION;
5861 :
5862 11384 : gcc_assert (tmp_ss->dimen != 0);
5863 :
5864 11384 : gfc_trans_create_temp_array (&loop->pre, &loop->post, tmp_ss, tmp,
5865 : NULL_TREE, false, true, false, where);
5866 : }
5867 :
5868 : /* For array parameters we don't have loop variables, so don't calculate the
5869 : translations. */
5870 180873 : if (!loop->array_parameter)
5871 113264 : gfc_set_delta (loop);
5872 180873 : }
5873 :
5874 :
5875 : /* Calculates how to transform from loop variables to array indices for each
5876 : array: once loop bounds are chosen, sets the difference (DELTA field) between
5877 : loop bounds and array reference bounds, for each array info. */
5878 :
5879 : void
5880 117095 : gfc_set_delta (gfc_loopinfo *loop)
5881 : {
5882 117095 : gfc_ss *ss, **loopspec;
5883 117095 : gfc_array_info *info;
5884 117095 : tree tmp;
5885 117095 : int n, dim;
5886 :
5887 117095 : gfc_loopinfo * const outer_loop = outermost_loop (loop);
5888 :
5889 117095 : loopspec = loop->specloop;
5890 :
5891 : /* Calculate the translation from loop variables to array indices. */
5892 355024 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5893 : {
5894 237929 : gfc_ss_type ss_type;
5895 :
5896 237929 : ss_type = ss->info->type;
5897 61230 : if (!(ss_type == GFC_SS_SECTION
5898 237929 : || ss_type == GFC_SS_COMPONENT
5899 97014 : || ss_type == GFC_SS_CONSTRUCTOR
5900 : || (ss_type == GFC_SS_FUNCTION
5901 8268 : && gfc_is_class_array_function (ss->info->expr))))
5902 61078 : continue;
5903 :
5904 176851 : info = &ss->info->data.array;
5905 :
5906 397895 : for (n = 0; n < ss->dimen; n++)
5907 : {
5908 : /* If we are specifying the range the delta is already set. */
5909 221044 : if (loopspec[n] != ss)
5910 : {
5911 115120 : dim = ss->dim[n];
5912 :
5913 : /* Calculate the offset relative to the loop variable.
5914 : First multiply by the stride. */
5915 115120 : tmp = loop->from[n];
5916 115120 : if (!integer_onep (info->stride[dim]))
5917 3108 : tmp = fold_build2_loc (input_location, MULT_EXPR,
5918 : gfc_array_index_type,
5919 : tmp, info->stride[dim]);
5920 :
5921 : /* Then subtract this from our starting value. */
5922 115120 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
5923 : gfc_array_index_type,
5924 : info->start[dim], tmp);
5925 :
5926 115120 : if (ss->is_alloc_lhs)
5927 9558 : info->delta[dim] = tmp;
5928 : else
5929 105562 : info->delta[dim] = gfc_evaluate_now (tmp, &outer_loop->pre);
5930 : }
5931 : }
5932 : }
5933 :
5934 120547 : for (loop = loop->nested; loop; loop = loop->next)
5935 3452 : gfc_set_delta (loop);
5936 117095 : }
5937 :
5938 :
5939 : /* Calculate the size of a given array dimension from the bounds. This
5940 : is simply (ubound - lbound + 1) if this expression is positive
5941 : or 0 if it is negative (pick either one if it is zero). Optionally
5942 : (if or_expr is present) OR the (expression != 0) condition to it. */
5943 :
5944 : tree
5945 23186 : gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr)
5946 : {
5947 23186 : tree res;
5948 23186 : tree cond;
5949 :
5950 : /* Calculate (ubound - lbound + 1). */
5951 23186 : res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5952 : ubound, lbound);
5953 23186 : res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res,
5954 : gfc_index_one_node);
5955 :
5956 : /* Check whether the size for this dimension is negative. */
5957 23186 : cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, res,
5958 : gfc_index_zero_node);
5959 23186 : res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
5960 : gfc_index_zero_node, res);
5961 :
5962 : /* Build OR expression. */
5963 23186 : if (or_expr)
5964 17820 : *or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
5965 : logical_type_node, *or_expr, cond);
5966 :
5967 23186 : return res;
5968 : }
5969 :
5970 :
5971 : /* Fills in an array descriptor, and returns the size of the array.
5972 : The size will be a simple_val, ie a variable or a constant. Also
5973 : calculates the offset of the base. The pointer argument overflow,
5974 : which should be of integer type, will increase in value if overflow
5975 : occurs during the size calculation. Returns the size of the array.
5976 : {
5977 : stride = 1;
5978 : offset = 0;
5979 : for (n = 0; n < rank; n++)
5980 : {
5981 : a.lbound[n] = specified_lower_bound;
5982 : offset = offset + a.lbond[n] * stride;
5983 : size = 1 - lbound;
5984 : a.ubound[n] = specified_upper_bound;
5985 : a.stride[n] = stride;
5986 : size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
5987 : overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
5988 : stride = stride * size;
5989 : }
5990 : for (n = rank; n < rank+corank; n++)
5991 : (Set lcobound/ucobound as above.)
5992 : element_size = sizeof (array element);
5993 : if (!rank)
5994 : return element_size
5995 : stride = (size_t) stride;
5996 : overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
5997 : stride = stride * element_size;
5998 : return (stride);
5999 : } */
6000 : /*GCC ARRAYS*/
6001 :
6002 : static tree
6003 12178 : gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
6004 : gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
6005 : stmtblock_t * descriptor_block, tree * overflow,
6006 : tree expr3_elem_size, gfc_expr *expr3, tree expr3_desc,
6007 : bool e3_has_nodescriptor, gfc_expr *expr,
6008 : tree *element_size, bool explicit_ts)
6009 : {
6010 12178 : tree type;
6011 12178 : tree tmp;
6012 12178 : tree size;
6013 12178 : tree offset;
6014 12178 : tree stride;
6015 12178 : tree or_expr;
6016 12178 : tree thencase;
6017 12178 : tree elsecase;
6018 12178 : tree cond;
6019 12178 : tree var;
6020 12178 : stmtblock_t thenblock;
6021 12178 : stmtblock_t elseblock;
6022 12178 : gfc_expr *ubound;
6023 12178 : gfc_se se;
6024 12178 : int n;
6025 :
6026 12178 : type = TREE_TYPE (descriptor);
6027 :
6028 12178 : stride = gfc_index_one_node;
6029 12178 : offset = gfc_index_zero_node;
6030 :
6031 : /* Set the dtype before the alloc, because registration of coarrays needs
6032 : it initialized. */
6033 12178 : if (expr->ts.type == BT_CHARACTER
6034 1079 : && expr->ts.deferred
6035 545 : && VAR_P (expr->ts.u.cl->backend_decl))
6036 : {
6037 366 : type = gfc_typenode_for_spec (&expr->ts);
6038 366 : tmp = gfc_conv_descriptor_dtype (descriptor);
6039 366 : gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type));
6040 : }
6041 11812 : else if (expr->ts.type == BT_CHARACTER
6042 713 : && expr->ts.deferred
6043 179 : && TREE_CODE (descriptor) == COMPONENT_REF)
6044 : {
6045 : /* Deferred character components have their string length tucked away
6046 : in a hidden field of the derived type. Obtain that and use it to
6047 : set the dtype. The charlen backend decl is zero because the field
6048 : type is zero length. */
6049 161 : gfc_ref *ref;
6050 161 : tmp = NULL_TREE;
6051 161 : for (ref = expr->ref; ref; ref = ref->next)
6052 161 : if (ref->type == REF_COMPONENT
6053 161 : && gfc_deferred_strlen (ref->u.c.component, &tmp))
6054 : break;
6055 161 : gcc_assert (tmp != NULL_TREE);
6056 161 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
6057 161 : TREE_OPERAND (descriptor, 0), tmp, NULL_TREE);
6058 161 : tmp = fold_convert (gfc_charlen_type_node, tmp);
6059 161 : type = gfc_get_character_type_len (expr->ts.kind, tmp);
6060 161 : tmp = gfc_conv_descriptor_dtype (descriptor);
6061 161 : gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type));
6062 161 : }
6063 11651 : else if (expr3_desc && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr3_desc)))
6064 : {
6065 934 : tmp = gfc_conv_descriptor_dtype (descriptor);
6066 934 : gfc_add_modify (pblock, tmp, gfc_conv_descriptor_dtype (expr3_desc));
6067 : }
6068 10717 : else if (expr->ts.type == BT_CLASS && !explicit_ts
6069 1306 : && expr3 && expr3->ts.type != BT_CLASS
6070 355 : && expr3_elem_size != NULL_TREE && expr3_desc == NULL_TREE)
6071 : {
6072 355 : tmp = gfc_conv_descriptor_dtype (descriptor);
6073 355 : gfc_add_modify (pblock, tmp, gfc_get_dtype (type));
6074 355 : tmp = gfc_conv_descriptor_elem_len (descriptor);
6075 355 : gfc_add_modify (pblock, tmp,
6076 355 : fold_convert (TREE_TYPE (tmp), expr3_elem_size));
6077 : }
6078 : else
6079 : {
6080 10362 : tmp = gfc_conv_descriptor_dtype (descriptor);
6081 10362 : gfc_add_modify (pblock, tmp, gfc_get_dtype (type));
6082 : }
6083 :
6084 12178 : or_expr = logical_false_node;
6085 :
6086 29998 : for (n = 0; n < rank; n++)
6087 : {
6088 17820 : tree conv_lbound;
6089 17820 : tree conv_ubound;
6090 :
6091 : /* We have 3 possibilities for determining the size of the array:
6092 : lower == NULL => lbound = 1, ubound = upper[n]
6093 : upper[n] = NULL => lbound = 1, ubound = lower[n]
6094 : upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
6095 17820 : ubound = upper[n];
6096 :
6097 : /* Set lower bound. */
6098 17820 : gfc_init_se (&se, NULL);
6099 17820 : if (expr3_desc != NULL_TREE)
6100 : {
6101 1477 : if (e3_has_nodescriptor)
6102 : /* The lbound of nondescriptor arrays like array constructors,
6103 : nonallocatable/nonpointer function results/variables,
6104 : start at zero, but when allocating it, the standard expects
6105 : the array to start at one. */
6106 967 : se.expr = gfc_index_one_node;
6107 : else
6108 510 : se.expr = gfc_conv_descriptor_lbound_get (expr3_desc,
6109 : gfc_rank_cst[n]);
6110 : }
6111 16343 : else if (lower == NULL)
6112 13160 : se.expr = gfc_index_one_node;
6113 : else
6114 : {
6115 3183 : gcc_assert (lower[n]);
6116 3183 : if (ubound)
6117 : {
6118 2457 : gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
6119 2457 : gfc_add_block_to_block (pblock, &se.pre);
6120 : }
6121 : else
6122 : {
6123 726 : se.expr = gfc_index_one_node;
6124 726 : ubound = lower[n];
6125 : }
6126 : }
6127 17820 : gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
6128 : gfc_rank_cst[n], se.expr);
6129 17820 : conv_lbound = se.expr;
6130 :
6131 : /* Work out the offset for this component. */
6132 17820 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6133 : se.expr, stride);
6134 17820 : offset = fold_build2_loc (input_location, MINUS_EXPR,
6135 : gfc_array_index_type, offset, tmp);
6136 :
6137 : /* Set upper bound. */
6138 17820 : gfc_init_se (&se, NULL);
6139 17820 : if (expr3_desc != NULL_TREE)
6140 : {
6141 1477 : if (e3_has_nodescriptor)
6142 : {
6143 : /* The lbound of nondescriptor arrays like array constructors,
6144 : nonallocatable/nonpointer function results/variables,
6145 : start at zero, but when allocating it, the standard expects
6146 : the array to start at one. Therefore fix the upper bound to be
6147 : (desc.ubound - desc.lbound) + 1. */
6148 967 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
6149 : gfc_array_index_type,
6150 : gfc_conv_descriptor_ubound_get (
6151 : expr3_desc, gfc_rank_cst[n]),
6152 : gfc_conv_descriptor_lbound_get (
6153 : expr3_desc, gfc_rank_cst[n]));
6154 967 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
6155 : gfc_array_index_type, tmp,
6156 : gfc_index_one_node);
6157 967 : se.expr = gfc_evaluate_now (tmp, pblock);
6158 : }
6159 : else
6160 510 : se.expr = gfc_conv_descriptor_ubound_get (expr3_desc,
6161 : gfc_rank_cst[n]);
6162 : }
6163 : else
6164 : {
6165 16343 : gcc_assert (ubound);
6166 16343 : gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
6167 16343 : gfc_add_block_to_block (pblock, &se.pre);
6168 16343 : if (ubound->expr_type == EXPR_FUNCTION)
6169 779 : se.expr = gfc_evaluate_now (se.expr, pblock);
6170 : }
6171 17820 : gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
6172 : gfc_rank_cst[n], se.expr);
6173 17820 : conv_ubound = se.expr;
6174 :
6175 : /* Store the stride. */
6176 17820 : gfc_conv_descriptor_stride_set (descriptor_block, descriptor,
6177 : gfc_rank_cst[n], stride);
6178 :
6179 : /* Calculate size and check whether extent is negative. */
6180 17820 : size = gfc_conv_array_extent_dim (conv_lbound, conv_ubound, &or_expr);
6181 17820 : size = gfc_evaluate_now (size, pblock);
6182 :
6183 : /* Check whether multiplying the stride by the number of
6184 : elements in this dimension would overflow. We must also check
6185 : whether the current dimension has zero size in order to avoid
6186 : division by zero.
6187 : */
6188 17820 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
6189 : gfc_array_index_type,
6190 17820 : fold_convert (gfc_array_index_type,
6191 : TYPE_MAX_VALUE (gfc_array_index_type)),
6192 : size);
6193 17820 : cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
6194 : logical_type_node, tmp, stride),
6195 : PRED_FORTRAN_OVERFLOW);
6196 17820 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
6197 : integer_one_node, integer_zero_node);
6198 17820 : cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
6199 : logical_type_node, size,
6200 : gfc_index_zero_node),
6201 : PRED_FORTRAN_SIZE_ZERO);
6202 17820 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
6203 : integer_zero_node, tmp);
6204 17820 : tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
6205 : *overflow, tmp);
6206 17820 : *overflow = gfc_evaluate_now (tmp, pblock);
6207 :
6208 : /* Multiply the stride by the number of elements in this dimension. */
6209 17820 : stride = fold_build2_loc (input_location, MULT_EXPR,
6210 : gfc_array_index_type, stride, size);
6211 17820 : stride = gfc_evaluate_now (stride, pblock);
6212 : }
6213 :
6214 12819 : for (n = rank; n < rank + corank; n++)
6215 : {
6216 641 : ubound = upper[n];
6217 :
6218 : /* Set lower bound. */
6219 641 : gfc_init_se (&se, NULL);
6220 641 : if (lower == NULL || lower[n] == NULL)
6221 : {
6222 372 : gcc_assert (n == rank + corank - 1);
6223 372 : se.expr = gfc_index_one_node;
6224 : }
6225 : else
6226 : {
6227 269 : if (ubound || n == rank + corank - 1)
6228 : {
6229 175 : gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
6230 175 : gfc_add_block_to_block (pblock, &se.pre);
6231 : }
6232 : else
6233 : {
6234 94 : se.expr = gfc_index_one_node;
6235 94 : ubound = lower[n];
6236 : }
6237 : }
6238 641 : gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
6239 : gfc_rank_cst[n], se.expr);
6240 :
6241 641 : if (n < rank + corank - 1)
6242 : {
6243 178 : gfc_init_se (&se, NULL);
6244 178 : gcc_assert (ubound);
6245 178 : gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
6246 178 : gfc_add_block_to_block (pblock, &se.pre);
6247 178 : gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
6248 : gfc_rank_cst[n], se.expr);
6249 : }
6250 : }
6251 :
6252 : /* The stride is the number of elements in the array, so multiply by the
6253 : size of an element to get the total size. Obviously, if there is a
6254 : SOURCE expression (expr3) we must use its element size. */
6255 12178 : if (expr3_elem_size != NULL_TREE)
6256 3037 : tmp = expr3_elem_size;
6257 9141 : else if (expr3 != NULL)
6258 : {
6259 0 : if (expr3->ts.type == BT_CLASS)
6260 : {
6261 0 : gfc_se se_sz;
6262 0 : gfc_expr *sz = gfc_copy_expr (expr3);
6263 0 : gfc_add_vptr_component (sz);
6264 0 : gfc_add_size_component (sz);
6265 0 : gfc_init_se (&se_sz, NULL);
6266 0 : gfc_conv_expr (&se_sz, sz);
6267 0 : gfc_free_expr (sz);
6268 0 : tmp = se_sz.expr;
6269 : }
6270 : else
6271 : {
6272 0 : tmp = gfc_typenode_for_spec (&expr3->ts);
6273 0 : tmp = TYPE_SIZE_UNIT (tmp);
6274 : }
6275 : }
6276 : else
6277 9141 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
6278 :
6279 : /* Convert to size_t. */
6280 12178 : *element_size = fold_convert (size_type_node, tmp);
6281 :
6282 12178 : if (rank == 0)
6283 : return *element_size;
6284 :
6285 11975 : stride = fold_convert (size_type_node, stride);
6286 :
6287 : /* First check for overflow. Since an array of type character can
6288 : have zero element_size, we must check for that before
6289 : dividing. */
6290 11975 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
6291 : size_type_node,
6292 11975 : TYPE_MAX_VALUE (size_type_node), *element_size);
6293 11975 : cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
6294 : logical_type_node, tmp, stride),
6295 : PRED_FORTRAN_OVERFLOW);
6296 11975 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
6297 : integer_one_node, integer_zero_node);
6298 11975 : cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
6299 : logical_type_node, *element_size,
6300 : build_int_cst (size_type_node, 0)),
6301 : PRED_FORTRAN_SIZE_ZERO);
6302 11975 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
6303 : integer_zero_node, tmp);
6304 11975 : tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
6305 : *overflow, tmp);
6306 11975 : *overflow = gfc_evaluate_now (tmp, pblock);
6307 :
6308 11975 : size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
6309 : stride, *element_size);
6310 :
6311 11975 : if (poffset != NULL)
6312 : {
6313 11975 : offset = gfc_evaluate_now (offset, pblock);
6314 11975 : *poffset = offset;
6315 : }
6316 :
6317 11975 : if (integer_zerop (or_expr))
6318 : return size;
6319 3635 : if (integer_onep (or_expr))
6320 599 : return build_int_cst (size_type_node, 0);
6321 :
6322 3036 : var = gfc_create_var (TREE_TYPE (size), "size");
6323 3036 : gfc_start_block (&thenblock);
6324 3036 : gfc_add_modify (&thenblock, var, build_int_cst (size_type_node, 0));
6325 3036 : thencase = gfc_finish_block (&thenblock);
6326 :
6327 3036 : gfc_start_block (&elseblock);
6328 3036 : gfc_add_modify (&elseblock, var, size);
6329 3036 : elsecase = gfc_finish_block (&elseblock);
6330 :
6331 3036 : tmp = gfc_evaluate_now (or_expr, pblock);
6332 3036 : tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
6333 3036 : gfc_add_expr_to_block (pblock, tmp);
6334 :
6335 3036 : return var;
6336 : }
6337 :
6338 :
6339 : /* Retrieve the last ref from the chain. This routine is specific to
6340 : gfc_array_allocate ()'s needs. */
6341 :
6342 : bool
6343 18582 : retrieve_last_ref (gfc_ref **ref_in, gfc_ref **prev_ref_in)
6344 : {
6345 18582 : gfc_ref *ref, *prev_ref;
6346 :
6347 18582 : ref = *ref_in;
6348 : /* Prevent warnings for uninitialized variables. */
6349 18582 : prev_ref = *prev_ref_in;
6350 25776 : while (ref && ref->next != NULL)
6351 : {
6352 7194 : gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
6353 : || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
6354 : prev_ref = ref;
6355 : ref = ref->next;
6356 : }
6357 :
6358 18582 : if (ref == NULL || ref->type != REF_ARRAY)
6359 : return false;
6360 :
6361 13397 : *ref_in = ref;
6362 13397 : *prev_ref_in = prev_ref;
6363 13397 : return true;
6364 : }
6365 :
6366 : /* Initializes the descriptor and generates a call to _gfor_allocate. Does
6367 : the work for an ALLOCATE statement. */
6368 : /*GCC ARRAYS*/
6369 :
6370 : bool
6371 17363 : gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
6372 : tree errlen, tree label_finish, tree expr3_elem_size,
6373 : gfc_expr *expr3, tree e3_arr_desc, bool e3_has_nodescriptor,
6374 : gfc_omp_namelist *omp_alloc, bool explicit_ts)
6375 : {
6376 17363 : tree tmp;
6377 17363 : tree pointer;
6378 17363 : tree offset = NULL_TREE;
6379 17363 : tree token = NULL_TREE;
6380 17363 : tree size;
6381 17363 : tree msg;
6382 17363 : tree error = NULL_TREE;
6383 17363 : tree overflow; /* Boolean storing whether size calculation overflows. */
6384 17363 : tree var_overflow = NULL_TREE;
6385 17363 : tree cond;
6386 17363 : tree set_descriptor;
6387 17363 : tree not_prev_allocated = NULL_TREE;
6388 17363 : tree element_size = NULL_TREE;
6389 17363 : stmtblock_t set_descriptor_block;
6390 17363 : stmtblock_t elseblock;
6391 17363 : gfc_expr **lower;
6392 17363 : gfc_expr **upper;
6393 17363 : gfc_ref *ref, *prev_ref = NULL, *coref;
6394 17363 : bool allocatable, coarray, dimension, alloc_w_e3_arr_spec = false,
6395 : non_ulimate_coarray_ptr_comp;
6396 17363 : tree omp_cond = NULL_TREE, omp_alt_alloc = NULL_TREE;
6397 :
6398 17363 : ref = expr->ref;
6399 :
6400 : /* Find the last reference in the chain. */
6401 17363 : if (!retrieve_last_ref (&ref, &prev_ref))
6402 : return false;
6403 :
6404 : /* Take the allocatable and coarray properties solely from the expr-ref's
6405 : attributes and not from source=-expression. */
6406 12178 : if (!prev_ref)
6407 : {
6408 8308 : allocatable = expr->symtree->n.sym->attr.allocatable;
6409 8308 : dimension = expr->symtree->n.sym->attr.dimension;
6410 8308 : non_ulimate_coarray_ptr_comp = false;
6411 : }
6412 : else
6413 : {
6414 3870 : allocatable = prev_ref->u.c.component->attr.allocatable;
6415 : /* Pointer components in coarrayed derived types must be treated
6416 : specially in that they are registered without a check if the are
6417 : already associated. This does not hold for ultimate coarray
6418 : pointers. */
6419 7740 : non_ulimate_coarray_ptr_comp = (prev_ref->u.c.component->attr.pointer
6420 3870 : && !prev_ref->u.c.component->attr.codimension);
6421 3870 : dimension = prev_ref->u.c.component->attr.dimension;
6422 : }
6423 :
6424 : /* For allocatable/pointer arrays in derived types, one of the refs has to be
6425 : a coarray. In this case it does not matter whether we are on this_image
6426 : or not. */
6427 12178 : coarray = false;
6428 29205 : for (coref = expr->ref; coref; coref = coref->next)
6429 17665 : if (coref->type == REF_ARRAY && coref->u.ar.codimen > 0)
6430 : {
6431 : coarray = true;
6432 : break;
6433 : }
6434 :
6435 12178 : if (!dimension)
6436 203 : gcc_assert (coarray);
6437 :
6438 12178 : if (ref->u.ar.type == AR_FULL && expr3 != NULL)
6439 : {
6440 1219 : gfc_ref *old_ref = ref;
6441 : /* F08:C633: Array shape from expr3. */
6442 1219 : ref = expr3->ref;
6443 :
6444 : /* Find the last reference in the chain. */
6445 1219 : if (!retrieve_last_ref (&ref, &prev_ref))
6446 : {
6447 0 : if (expr3->expr_type == EXPR_FUNCTION
6448 0 : && gfc_expr_attr (expr3).dimension)
6449 0 : ref = old_ref;
6450 : else
6451 0 : return false;
6452 : }
6453 : alloc_w_e3_arr_spec = true;
6454 : }
6455 :
6456 : /* Figure out the size of the array. */
6457 12178 : switch (ref->u.ar.type)
6458 : {
6459 9283 : case AR_ELEMENT:
6460 9283 : if (!coarray)
6461 : {
6462 8697 : lower = NULL;
6463 8697 : upper = ref->u.ar.start;
6464 8697 : break;
6465 : }
6466 : /* Fall through. */
6467 :
6468 2293 : case AR_SECTION:
6469 2293 : lower = ref->u.ar.start;
6470 2293 : upper = ref->u.ar.end;
6471 2293 : break;
6472 :
6473 1188 : case AR_FULL:
6474 1188 : gcc_assert (ref->u.ar.as->type == AS_EXPLICIT
6475 : || alloc_w_e3_arr_spec);
6476 :
6477 1188 : lower = ref->u.ar.as->lower;
6478 1188 : upper = ref->u.ar.as->upper;
6479 1188 : break;
6480 :
6481 0 : default:
6482 0 : gcc_unreachable ();
6483 12178 : break;
6484 : }
6485 :
6486 12178 : overflow = integer_zero_node;
6487 :
6488 12178 : if (expr->ts.type == BT_CHARACTER
6489 1079 : && TREE_CODE (se->string_length) == COMPONENT_REF
6490 161 : && expr->ts.u.cl->backend_decl != se->string_length
6491 161 : && VAR_P (expr->ts.u.cl->backend_decl))
6492 0 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
6493 0 : fold_convert (TREE_TYPE (expr->ts.u.cl->backend_decl),
6494 : se->string_length));
6495 :
6496 12178 : gfc_init_block (&set_descriptor_block);
6497 : /* Take the corank only from the actual ref and not from the coref. The
6498 : later will mislead the generation of the array dimensions for allocatable/
6499 : pointer components in derived types. */
6500 23775 : size = gfc_array_init_size (se->expr, alloc_w_e3_arr_spec ? expr->rank
6501 10959 : : ref->u.ar.as->rank,
6502 638 : coarray ? ref->u.ar.as->corank : 0,
6503 : &offset, lower, upper,
6504 : &se->pre, &set_descriptor_block, &overflow,
6505 : expr3_elem_size, expr3, e3_arr_desc,
6506 : e3_has_nodescriptor, expr, &element_size,
6507 : explicit_ts);
6508 :
6509 12178 : if (dimension)
6510 : {
6511 11975 : var_overflow = gfc_create_var (integer_type_node, "overflow");
6512 11975 : gfc_add_modify (&se->pre, var_overflow, overflow);
6513 :
6514 11975 : if (status == NULL_TREE)
6515 : {
6516 : /* Generate the block of code handling overflow. */
6517 11753 : msg = gfc_build_addr_expr (pchar_type_node,
6518 : gfc_build_localized_cstring_const
6519 : ("Integer overflow when calculating the amount of "
6520 : "memory to allocate"));
6521 11753 : error = build_call_expr_loc (input_location,
6522 : gfor_fndecl_runtime_error, 1, msg);
6523 : }
6524 : else
6525 : {
6526 222 : tree status_type = TREE_TYPE (status);
6527 222 : stmtblock_t set_status_block;
6528 :
6529 222 : gfc_start_block (&set_status_block);
6530 222 : gfc_add_modify (&set_status_block, status,
6531 : build_int_cst (status_type, LIBERROR_ALLOCATION));
6532 222 : error = gfc_finish_block (&set_status_block);
6533 : }
6534 : }
6535 :
6536 : /* Allocate memory to store the data. */
6537 12178 : if (POINTER_TYPE_P (TREE_TYPE (se->expr)))
6538 0 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
6539 :
6540 12178 : if (coarray && flag_coarray == GFC_FCOARRAY_LIB)
6541 : {
6542 397 : pointer = non_ulimate_coarray_ptr_comp ? se->expr
6543 325 : : gfc_conv_descriptor_data_get (se->expr);
6544 397 : token = gfc_conv_descriptor_token (se->expr);
6545 397 : token = gfc_build_addr_expr (NULL_TREE, token);
6546 : }
6547 : else
6548 : {
6549 11781 : pointer = gfc_conv_descriptor_data_get (se->expr);
6550 11781 : if (omp_alloc)
6551 33 : omp_cond = boolean_true_node;
6552 : }
6553 12178 : STRIP_NOPS (pointer);
6554 :
6555 12178 : if (allocatable)
6556 : {
6557 9982 : not_prev_allocated = gfc_create_var (logical_type_node,
6558 : "not_prev_allocated");
6559 9982 : tmp = fold_build2_loc (input_location, EQ_EXPR,
6560 : logical_type_node, pointer,
6561 9982 : build_int_cst (TREE_TYPE (pointer), 0));
6562 :
6563 9982 : gfc_add_modify (&se->pre, not_prev_allocated, tmp);
6564 : }
6565 :
6566 12178 : gfc_start_block (&elseblock);
6567 :
6568 12178 : tree succ_add_expr = NULL_TREE;
6569 12178 : if (omp_cond)
6570 : {
6571 33 : tree align, alloc, sz;
6572 33 : gfc_se se2;
6573 33 : if (omp_alloc->u2.allocator)
6574 : {
6575 10 : gfc_init_se (&se2, NULL);
6576 10 : gfc_conv_expr (&se2, omp_alloc->u2.allocator);
6577 10 : gfc_add_block_to_block (&elseblock, &se2.pre);
6578 10 : alloc = gfc_evaluate_now (se2.expr, &elseblock);
6579 10 : gfc_add_block_to_block (&elseblock, &se2.post);
6580 : }
6581 : else
6582 23 : alloc = build_zero_cst (ptr_type_node);
6583 33 : tmp = TREE_TYPE (TREE_TYPE (pointer));
6584 33 : if (tmp == void_type_node)
6585 33 : tmp = gfc_typenode_for_spec (&expr->ts, 0);
6586 33 : if (omp_alloc->u.align)
6587 : {
6588 17 : gfc_init_se (&se2, NULL);
6589 17 : gfc_conv_expr (&se2, omp_alloc->u.align);
6590 17 : gcc_assert (CONSTANT_CLASS_P (se2.expr)
6591 : && se2.pre.head == NULL
6592 : && se2.post.head == NULL);
6593 17 : align = build_int_cst (size_type_node,
6594 17 : MAX (tree_to_uhwi (se2.expr),
6595 : TYPE_ALIGN_UNIT (tmp)));
6596 : }
6597 : else
6598 16 : align = build_int_cst (size_type_node, TYPE_ALIGN_UNIT (tmp));
6599 33 : sz = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
6600 : fold_convert (size_type_node, size),
6601 : build_int_cst (size_type_node, 1));
6602 33 : omp_alt_alloc = builtin_decl_explicit (BUILT_IN_GOMP_ALLOC);
6603 33 : DECL_ATTRIBUTES (omp_alt_alloc)
6604 33 : = tree_cons (get_identifier ("omp allocator"),
6605 : build_tree_list (NULL_TREE, alloc),
6606 33 : DECL_ATTRIBUTES (omp_alt_alloc));
6607 33 : omp_alt_alloc = build_call_expr (omp_alt_alloc, 3, align, sz, alloc);
6608 33 : succ_add_expr = fold_build2_loc (input_location, MODIFY_EXPR,
6609 : void_type_node,
6610 : gfc_conv_descriptor_version (se->expr),
6611 : build_int_cst (integer_type_node, 1));
6612 : }
6613 :
6614 : /* The allocatable variant takes the old pointer as first argument. */
6615 12178 : if (allocatable)
6616 10545 : gfc_allocate_allocatable (&elseblock, pointer, size, token,
6617 : status, errmsg, errlen, label_finish, expr,
6618 563 : coref != NULL ? coref->u.ar.as->corank : 0,
6619 : omp_cond, omp_alt_alloc, succ_add_expr);
6620 2196 : else if (non_ulimate_coarray_ptr_comp && token)
6621 : /* The token is set only for GFC_FCOARRAY_LIB mode. */
6622 72 : gfc_allocate_using_caf_lib (&elseblock, pointer, size, token, status,
6623 : errmsg, errlen,
6624 : GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY);
6625 : else
6626 2124 : gfc_allocate_using_malloc (&elseblock, pointer, size, status,
6627 : omp_cond, omp_alt_alloc, succ_add_expr);
6628 :
6629 12178 : if (dimension)
6630 : {
6631 11975 : cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
6632 : logical_type_node, var_overflow, integer_zero_node),
6633 : PRED_FORTRAN_OVERFLOW);
6634 11975 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6635 : error, gfc_finish_block (&elseblock));
6636 : }
6637 : else
6638 203 : tmp = gfc_finish_block (&elseblock);
6639 :
6640 12178 : gfc_add_expr_to_block (&se->pre, tmp);
6641 :
6642 : /* Update the array descriptor with the offset and the span. */
6643 12178 : if (dimension)
6644 : {
6645 11975 : gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
6646 11975 : tmp = fold_convert (gfc_array_index_type, element_size);
6647 11975 : gfc_conv_descriptor_span_set (&set_descriptor_block, se->expr, tmp);
6648 : }
6649 :
6650 12178 : set_descriptor = gfc_finish_block (&set_descriptor_block);
6651 12178 : if (status != NULL_TREE)
6652 : {
6653 238 : cond = fold_build2_loc (input_location, EQ_EXPR,
6654 : logical_type_node, status,
6655 238 : build_int_cst (TREE_TYPE (status), 0));
6656 :
6657 238 : if (not_prev_allocated != NULL_TREE)
6658 222 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
6659 : logical_type_node, cond, not_prev_allocated);
6660 :
6661 238 : gfc_add_expr_to_block (&se->pre,
6662 : fold_build3_loc (input_location, COND_EXPR, void_type_node,
6663 : cond,
6664 : set_descriptor,
6665 : build_empty_stmt (input_location)));
6666 : }
6667 : else
6668 11940 : gfc_add_expr_to_block (&se->pre, set_descriptor);
6669 :
6670 : return true;
6671 : }
6672 :
6673 :
6674 : /* Create an array constructor from an initialization expression.
6675 : We assume the frontend already did any expansions and conversions. */
6676 :
6677 : tree
6678 7771 : gfc_conv_array_initializer (tree type, gfc_expr * expr)
6679 : {
6680 7771 : gfc_constructor *c;
6681 7771 : tree tmp;
6682 7771 : gfc_se se;
6683 7771 : tree index, range;
6684 7771 : vec<constructor_elt, va_gc> *v = NULL;
6685 :
6686 7771 : if (expr->expr_type == EXPR_VARIABLE
6687 1 : && expr->symtree->n.sym->attr.flavor == FL_PARAMETER
6688 1 : && expr->symtree->n.sym->value
6689 1 : && !expr->ref)
6690 7771 : expr = expr->symtree->n.sym->value;
6691 :
6692 : /* After parameter substitution the expression should be a constant, array
6693 : constructor, structure constructor, or NULL. Anything else is invalid
6694 : and must not ICE later in lowering. */
6695 7771 : if (expr->expr_type != EXPR_CONSTANT
6696 7377 : && expr->expr_type != EXPR_STRUCTURE
6697 6611 : && expr->expr_type != EXPR_ARRAY
6698 4 : && expr->expr_type != EXPR_NULL)
6699 : {
6700 4 : gfc_error ("Array initializer at %L does not reduce to a constant "
6701 : "expression", &expr->where);
6702 4 : return build_constructor (type, NULL);
6703 : }
6704 :
6705 7767 : switch (expr->expr_type)
6706 : {
6707 1160 : case EXPR_CONSTANT:
6708 1160 : case EXPR_STRUCTURE:
6709 : /* A single scalar or derived type value. Create an array with all
6710 : elements equal to that value. */
6711 1160 : gfc_init_se (&se, NULL);
6712 :
6713 1160 : if (expr->expr_type == EXPR_CONSTANT)
6714 394 : gfc_conv_constant (&se, expr);
6715 : else
6716 766 : gfc_conv_structure (&se, expr, 1);
6717 :
6718 2320 : if (tree_int_cst_lt (TYPE_MAX_VALUE (TYPE_DOMAIN (type)),
6719 1160 : TYPE_MIN_VALUE (TYPE_DOMAIN (type))))
6720 : break;
6721 2296 : else if (tree_int_cst_equal (TYPE_MIN_VALUE (TYPE_DOMAIN (type)),
6722 1148 : TYPE_MAX_VALUE (TYPE_DOMAIN (type))))
6723 167 : range = TYPE_MIN_VALUE (TYPE_DOMAIN (type));
6724 : else
6725 1962 : range = build2 (RANGE_EXPR, gfc_array_index_type,
6726 981 : TYPE_MIN_VALUE (TYPE_DOMAIN (type)),
6727 981 : TYPE_MAX_VALUE (TYPE_DOMAIN (type)));
6728 1148 : CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
6729 1148 : break;
6730 :
6731 6607 : case EXPR_ARRAY:
6732 : /* Create a vector of all the elements. */
6733 6607 : for (c = gfc_constructor_first (expr->value.constructor);
6734 164739 : c && c->expr; c = gfc_constructor_next (c))
6735 : {
6736 158132 : if (c->iterator)
6737 : {
6738 : /* Problems occur when we get something like
6739 : integer :: a(lots) = (/(i, i=1, lots)/) */
6740 0 : gfc_fatal_error ("The number of elements in the array "
6741 : "constructor at %L requires an increase of "
6742 : "the allowed %d upper limit. See "
6743 : "%<-fmax-array-constructor%> option",
6744 : &expr->where, flag_max_array_constructor);
6745 : return NULL_TREE;
6746 : }
6747 158132 : index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
6748 :
6749 158132 : if (mpz_cmp_si (c->repeat, 1) > 0)
6750 : {
6751 127 : tree tmp1, tmp2;
6752 127 : mpz_t maxval;
6753 :
6754 127 : mpz_init (maxval);
6755 127 : mpz_add (maxval, c->offset, c->repeat);
6756 127 : mpz_sub_ui (maxval, maxval, 1);
6757 127 : tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
6758 127 : if (mpz_cmp_si (c->offset, 0) != 0)
6759 : {
6760 27 : mpz_add_ui (maxval, c->offset, 1);
6761 27 : tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
6762 : }
6763 : else
6764 100 : tmp1 = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
6765 :
6766 127 : range = fold_build2 (RANGE_EXPR, gfc_array_index_type, tmp1, tmp2);
6767 127 : mpz_clear (maxval);
6768 : }
6769 : else
6770 : range = NULL;
6771 :
6772 158132 : gfc_init_se (&se, NULL);
6773 158132 : switch (c->expr->expr_type)
6774 : {
6775 156650 : case EXPR_CONSTANT:
6776 156650 : gfc_conv_constant (&se, c->expr);
6777 :
6778 : /* See gfortran.dg/charlen_15.f90 for instance. */
6779 156650 : if (TREE_CODE (se.expr) == STRING_CST
6780 5260 : && TREE_CODE (type) == ARRAY_TYPE)
6781 : {
6782 : tree atype = type;
6783 10520 : while (TREE_CODE (TREE_TYPE (atype)) == ARRAY_TYPE)
6784 5260 : atype = TREE_TYPE (atype);
6785 5260 : gcc_checking_assert (TREE_CODE (TREE_TYPE (atype))
6786 : == INTEGER_TYPE);
6787 5260 : gcc_checking_assert (TREE_TYPE (TREE_TYPE (se.expr))
6788 : == TREE_TYPE (atype));
6789 5260 : if (tree_to_uhwi (TYPE_SIZE_UNIT (TREE_TYPE (se.expr)))
6790 5260 : > tree_to_uhwi (TYPE_SIZE_UNIT (atype)))
6791 : {
6792 0 : unsigned HOST_WIDE_INT size
6793 0 : = tree_to_uhwi (TYPE_SIZE_UNIT (atype));
6794 0 : const char *p = TREE_STRING_POINTER (se.expr);
6795 :
6796 0 : se.expr = build_string (size, p);
6797 : }
6798 5260 : TREE_TYPE (se.expr) = atype;
6799 : }
6800 : break;
6801 :
6802 1482 : case EXPR_STRUCTURE:
6803 1482 : gfc_conv_structure (&se, c->expr, 1);
6804 1482 : break;
6805 :
6806 0 : default:
6807 : /* Catch those occasional beasts that do not simplify
6808 : for one reason or another, assuming that if they are
6809 : standard defying the frontend will catch them. */
6810 0 : gfc_conv_expr (&se, c->expr);
6811 0 : break;
6812 : }
6813 :
6814 158132 : if (range == NULL_TREE)
6815 158005 : CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
6816 : else
6817 : {
6818 127 : if (!integer_zerop (index))
6819 27 : CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
6820 158259 : CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
6821 : }
6822 : }
6823 : break;
6824 :
6825 0 : case EXPR_NULL:
6826 0 : return gfc_build_null_descriptor (type);
6827 :
6828 0 : default:
6829 0 : gcc_unreachable ();
6830 : }
6831 :
6832 : /* Create a constructor from the list of elements. */
6833 7767 : tmp = build_constructor (type, v);
6834 7767 : TREE_CONSTANT (tmp) = 1;
6835 7767 : return tmp;
6836 : }
6837 :
6838 :
6839 : /* Generate code to evaluate non-constant coarray cobounds. */
6840 :
6841 : void
6842 21072 : gfc_trans_array_cobounds (tree type, stmtblock_t * pblock,
6843 : const gfc_symbol *sym)
6844 : {
6845 21072 : int dim;
6846 21072 : tree ubound;
6847 21072 : tree lbound;
6848 21072 : gfc_se se;
6849 21072 : gfc_array_spec *as;
6850 :
6851 21072 : as = IS_CLASS_COARRAY_OR_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
6852 :
6853 22049 : for (dim = as->rank; dim < as->rank + as->corank; dim++)
6854 : {
6855 : /* Evaluate non-constant array bound expressions.
6856 : F2008 4.5.6.3 para 6: If a specification expression in a scoping unit
6857 : references a function, the result is finalized before execution of the
6858 : executable constructs in the scoping unit.
6859 : Adding the finalblocks enables this. */
6860 977 : lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
6861 977 : if (as->lower[dim] && !INTEGER_CST_P (lbound))
6862 : {
6863 114 : gfc_init_se (&se, NULL);
6864 114 : gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
6865 114 : gfc_add_block_to_block (pblock, &se.pre);
6866 114 : gfc_add_block_to_block (pblock, &se.finalblock);
6867 114 : gfc_add_modify (pblock, lbound, se.expr);
6868 : }
6869 977 : ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
6870 977 : if (as->upper[dim] && !INTEGER_CST_P (ubound))
6871 : {
6872 60 : gfc_init_se (&se, NULL);
6873 60 : gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
6874 60 : gfc_add_block_to_block (pblock, &se.pre);
6875 60 : gfc_add_block_to_block (pblock, &se.finalblock);
6876 60 : gfc_add_modify (pblock, ubound, se.expr);
6877 : }
6878 : }
6879 21072 : }
6880 :
6881 :
6882 : /* Generate code to evaluate non-constant array bounds. Sets *poffset and
6883 : returns the size (in elements) of the array. */
6884 :
6885 : tree
6886 13709 : gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
6887 : stmtblock_t * pblock)
6888 : {
6889 13709 : gfc_array_spec *as;
6890 13709 : tree size;
6891 13709 : tree stride;
6892 13709 : tree offset;
6893 13709 : tree ubound;
6894 13709 : tree lbound;
6895 13709 : tree tmp;
6896 13709 : gfc_se se;
6897 :
6898 13709 : int dim;
6899 :
6900 13709 : as = IS_CLASS_COARRAY_OR_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
6901 :
6902 13709 : size = gfc_index_one_node;
6903 13709 : offset = gfc_index_zero_node;
6904 13709 : stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
6905 13709 : if (stride && VAR_P (stride))
6906 124 : gfc_add_modify (pblock, stride, gfc_index_one_node);
6907 30675 : for (dim = 0; dim < as->rank; dim++)
6908 : {
6909 : /* Evaluate non-constant array bound expressions.
6910 : F2008 4.5.6.3 para 6: If a specification expression in a scoping unit
6911 : references a function, the result is finalized before execution of the
6912 : executable constructs in the scoping unit.
6913 : Adding the finalblocks enables this. */
6914 16966 : lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
6915 16966 : if (as->lower[dim] && !INTEGER_CST_P (lbound))
6916 : {
6917 475 : gfc_init_se (&se, NULL);
6918 475 : gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
6919 475 : gfc_add_block_to_block (pblock, &se.pre);
6920 475 : gfc_add_block_to_block (pblock, &se.finalblock);
6921 475 : gfc_add_modify (pblock, lbound, se.expr);
6922 : }
6923 16966 : ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
6924 16966 : if (as->upper[dim] && !INTEGER_CST_P (ubound))
6925 : {
6926 10436 : gfc_init_se (&se, NULL);
6927 10436 : gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
6928 10436 : gfc_add_block_to_block (pblock, &se.pre);
6929 10436 : gfc_add_block_to_block (pblock, &se.finalblock);
6930 10436 : gfc_add_modify (pblock, ubound, se.expr);
6931 : }
6932 : /* The offset of this dimension. offset = offset - lbound * stride. */
6933 16966 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6934 : lbound, size);
6935 16966 : offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6936 : offset, tmp);
6937 :
6938 : /* The size of this dimension, and the stride of the next. */
6939 16966 : if (dim + 1 < as->rank)
6940 3456 : stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
6941 : else
6942 13510 : stride = GFC_TYPE_ARRAY_SIZE (type);
6943 :
6944 16966 : if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
6945 : {
6946 : /* Calculate stride = size * (ubound + 1 - lbound). */
6947 10626 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
6948 : gfc_array_index_type,
6949 : gfc_index_one_node, lbound);
6950 10626 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
6951 : gfc_array_index_type, ubound, tmp);
6952 10626 : tmp = fold_build2_loc (input_location, MULT_EXPR,
6953 : gfc_array_index_type, size, tmp);
6954 10626 : if (stride)
6955 10626 : gfc_add_modify (pblock, stride, tmp);
6956 : else
6957 0 : stride = gfc_evaluate_now (tmp, pblock);
6958 :
6959 : /* Make sure that negative size arrays are translated
6960 : to being zero size. */
6961 10626 : tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
6962 : stride, gfc_index_zero_node);
6963 10626 : tmp = fold_build3_loc (input_location, COND_EXPR,
6964 : gfc_array_index_type, tmp,
6965 : stride, gfc_index_zero_node);
6966 10626 : gfc_add_modify (pblock, stride, tmp);
6967 : }
6968 :
6969 : size = stride;
6970 : }
6971 :
6972 13709 : gfc_trans_array_cobounds (type, pblock, sym);
6973 13709 : gfc_trans_vla_type_sizes (sym, pblock);
6974 :
6975 13709 : *poffset = offset;
6976 13709 : return size;
6977 : }
6978 :
6979 :
6980 : /* Generate code to initialize/allocate an array variable. */
6981 :
6982 : void
6983 31745 : gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
6984 : gfc_wrapped_block * block)
6985 : {
6986 31745 : stmtblock_t init;
6987 31745 : tree type;
6988 31745 : tree tmp = NULL_TREE;
6989 31745 : tree size;
6990 31745 : tree offset;
6991 31745 : tree space;
6992 31745 : tree inittree;
6993 31745 : bool onstack;
6994 31745 : bool back;
6995 :
6996 31745 : gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
6997 :
6998 : /* Do nothing for USEd variables. */
6999 31745 : if (sym->attr.use_assoc)
7000 25805 : return;
7001 :
7002 31702 : type = TREE_TYPE (decl);
7003 31702 : gcc_assert (GFC_ARRAY_TYPE_P (type));
7004 31702 : onstack = TREE_CODE (type) != POINTER_TYPE;
7005 :
7006 : /* In the case of non-dummy symbols with dependencies on an old-fashioned
7007 : function result (ie. proc_name = proc_name->result), gfc_add_init_cleanup
7008 : must be called with the last, optional argument false so that the alloc-
7009 : ation occurs after the processing of the result. */
7010 31702 : back = sym->fn_result_dep;
7011 :
7012 31702 : gfc_init_block (&init);
7013 :
7014 : /* Evaluate character string length. */
7015 31702 : if (sym->ts.type == BT_CHARACTER
7016 3068 : && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
7017 : {
7018 43 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7019 :
7020 43 : gfc_trans_vla_type_sizes (sym, &init);
7021 :
7022 : /* Emit a DECL_EXPR for this variable, which will cause the
7023 : gimplifier to allocate storage, and all that good stuff. */
7024 43 : tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
7025 43 : gfc_add_expr_to_block (&init, tmp);
7026 43 : if (sym->attr.omp_allocate)
7027 : {
7028 : /* Save location of size calculation to ensure GOMP_alloc is placed
7029 : after it. */
7030 0 : tree omp_alloc = lookup_attribute ("omp allocate",
7031 0 : DECL_ATTRIBUTES (decl));
7032 0 : TREE_CHAIN (TREE_CHAIN (TREE_VALUE (omp_alloc)))
7033 0 : = build_tree_list (NULL_TREE, tsi_stmt (tsi_last (init.head)));
7034 : }
7035 : }
7036 :
7037 31500 : if (onstack)
7038 : {
7039 25622 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE,
7040 : back);
7041 25622 : return;
7042 : }
7043 :
7044 6080 : type = TREE_TYPE (type);
7045 :
7046 6080 : gcc_assert (!sym->attr.use_assoc);
7047 6080 : gcc_assert (!sym->module);
7048 :
7049 6080 : if (sym->ts.type == BT_CHARACTER
7050 202 : && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
7051 94 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7052 :
7053 6080 : size = gfc_trans_array_bounds (type, sym, &offset, &init);
7054 :
7055 : /* Don't actually allocate space for Cray Pointees. */
7056 6080 : if (sym->attr.cray_pointee)
7057 : {
7058 140 : if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
7059 49 : gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
7060 :
7061 140 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
7062 140 : return;
7063 : }
7064 5940 : if (sym->attr.omp_allocate)
7065 : {
7066 : /* The size is the number of elements in the array, so multiply by the
7067 : size of an element to get the total size. */
7068 7 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
7069 7 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7070 : size, fold_convert (gfc_array_index_type, tmp));
7071 7 : size = gfc_evaluate_now (size, &init);
7072 :
7073 7 : tree omp_alloc = lookup_attribute ("omp allocate",
7074 7 : DECL_ATTRIBUTES (decl));
7075 7 : TREE_CHAIN (TREE_CHAIN (TREE_VALUE (omp_alloc)))
7076 7 : = build_tree_list (size, NULL_TREE);
7077 7 : space = NULL_TREE;
7078 : }
7079 5933 : else if (flag_stack_arrays)
7080 : {
7081 14 : gcc_assert (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE);
7082 14 : space = build_decl (gfc_get_location (&sym->declared_at),
7083 : VAR_DECL, create_tmp_var_name ("A"),
7084 14 : TREE_TYPE (TREE_TYPE (decl)));
7085 14 : gfc_trans_vla_type_sizes (sym, &init);
7086 : }
7087 : else
7088 : {
7089 : /* The size is the number of elements in the array, so multiply by the
7090 : size of an element to get the total size. */
7091 5919 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
7092 5919 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7093 : size, fold_convert (gfc_array_index_type, tmp));
7094 :
7095 : /* Allocate memory to hold the data. */
7096 5919 : tmp = gfc_call_malloc (&init, TREE_TYPE (decl), size);
7097 5919 : gfc_add_modify (&init, decl, tmp);
7098 :
7099 : /* Free the temporary. */
7100 5919 : tmp = gfc_call_free (decl);
7101 5919 : space = NULL_TREE;
7102 : }
7103 :
7104 : /* Set offset of the array. */
7105 5940 : if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
7106 384 : gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
7107 :
7108 : /* Automatic arrays should not have initializers. */
7109 5940 : gcc_assert (!sym->value);
7110 :
7111 5940 : inittree = gfc_finish_block (&init);
7112 :
7113 5940 : if (space)
7114 : {
7115 14 : tree addr;
7116 14 : pushdecl (space);
7117 :
7118 : /* Don't create new scope, emit the DECL_EXPR in exactly the scope
7119 : where also space is located. */
7120 14 : gfc_init_block (&init);
7121 14 : tmp = fold_build1_loc (input_location, DECL_EXPR,
7122 14 : TREE_TYPE (space), space);
7123 14 : gfc_add_expr_to_block (&init, tmp);
7124 14 : addr = fold_build1_loc (gfc_get_location (&sym->declared_at),
7125 14 : ADDR_EXPR, TREE_TYPE (decl), space);
7126 14 : gfc_add_modify (&init, decl, addr);
7127 14 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE,
7128 : back);
7129 14 : tmp = NULL_TREE;
7130 : }
7131 5940 : gfc_add_init_cleanup (block, inittree, tmp, back);
7132 : }
7133 :
7134 :
7135 : /* Generate entry and exit code for g77 calling convention arrays. */
7136 :
7137 : void
7138 7375 : gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block)
7139 : {
7140 7375 : tree parm;
7141 7375 : tree type;
7142 7375 : tree offset;
7143 7375 : tree tmp;
7144 7375 : tree stmt;
7145 7375 : stmtblock_t init;
7146 :
7147 7375 : location_t loc = input_location;
7148 7375 : input_location = gfc_get_location (&sym->declared_at);
7149 :
7150 : /* Descriptor type. */
7151 7375 : parm = sym->backend_decl;
7152 7375 : type = TREE_TYPE (parm);
7153 7375 : gcc_assert (GFC_ARRAY_TYPE_P (type));
7154 :
7155 7375 : gfc_start_block (&init);
7156 :
7157 7375 : if (sym->ts.type == BT_CHARACTER
7158 722 : && VAR_P (sym->ts.u.cl->backend_decl))
7159 79 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7160 :
7161 : /* Evaluate the bounds of the array. */
7162 7375 : gfc_trans_array_bounds (type, sym, &offset, &init);
7163 :
7164 : /* Set the offset. */
7165 7375 : if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
7166 1214 : gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
7167 :
7168 : /* Set the pointer itself if we aren't using the parameter directly. */
7169 7375 : if (TREE_CODE (parm) != PARM_DECL)
7170 : {
7171 612 : tmp = GFC_DECL_SAVED_DESCRIPTOR (parm);
7172 612 : if (sym->ts.type == BT_CLASS)
7173 : {
7174 243 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
7175 243 : tmp = gfc_class_data_get (tmp);
7176 243 : tmp = gfc_conv_descriptor_data_get (tmp);
7177 : }
7178 612 : tmp = convert (TREE_TYPE (parm), tmp);
7179 612 : gfc_add_modify (&init, parm, tmp);
7180 : }
7181 7375 : stmt = gfc_finish_block (&init);
7182 :
7183 7375 : input_location = loc;
7184 :
7185 : /* Add the initialization code to the start of the function. */
7186 :
7187 7375 : if ((sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.optional)
7188 7375 : || sym->attr.optional
7189 6893 : || sym->attr.not_always_present)
7190 : {
7191 542 : tree nullify;
7192 542 : if (TREE_CODE (parm) != PARM_DECL)
7193 105 : nullify = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
7194 : parm, null_pointer_node);
7195 : else
7196 437 : nullify = build_empty_stmt (input_location);
7197 542 : tmp = gfc_conv_expr_present (sym, true);
7198 542 : stmt = build3_v (COND_EXPR, tmp, stmt, nullify);
7199 : }
7200 :
7201 7375 : gfc_add_init_cleanup (block, stmt, NULL_TREE);
7202 7375 : }
7203 :
7204 :
7205 : /* Modify the descriptor of an array parameter so that it has the
7206 : correct lower bound. Also move the upper bound accordingly.
7207 : If the array is not packed, it will be copied into a temporary.
7208 : For each dimension we set the new lower and upper bounds. Then we copy the
7209 : stride and calculate the offset for this dimension. We also work out
7210 : what the stride of a packed array would be, and see it the two match.
7211 : If the array need repacking, we set the stride to the values we just
7212 : calculated, recalculate the offset and copy the array data.
7213 : Code is also added to copy the data back at the end of the function.
7214 : */
7215 :
7216 : void
7217 13005 : gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
7218 : gfc_wrapped_block * block)
7219 : {
7220 13005 : tree size;
7221 13005 : tree type;
7222 13005 : tree offset;
7223 13005 : stmtblock_t init;
7224 13005 : tree stmtInit, stmtCleanup;
7225 13005 : tree lbound;
7226 13005 : tree ubound;
7227 13005 : tree dubound;
7228 13005 : tree dlbound;
7229 13005 : tree dumdesc;
7230 13005 : tree tmp;
7231 13005 : tree stride, stride2;
7232 13005 : tree stmt_packed;
7233 13005 : tree stmt_unpacked;
7234 13005 : tree partial;
7235 13005 : gfc_se se;
7236 13005 : int n;
7237 13005 : int checkparm;
7238 13005 : int no_repack;
7239 13005 : bool optional_arg;
7240 13005 : gfc_array_spec *as;
7241 13005 : bool is_classarray = IS_CLASS_COARRAY_OR_ARRAY (sym);
7242 :
7243 : /* Do nothing for pointer and allocatable arrays. */
7244 13005 : if ((sym->ts.type != BT_CLASS && sym->attr.pointer)
7245 12908 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer)
7246 12908 : || sym->attr.allocatable
7247 12802 : || (is_classarray && CLASS_DATA (sym)->attr.allocatable))
7248 6045 : return;
7249 :
7250 826 : if ((!is_classarray
7251 826 : || (is_classarray && CLASS_DATA (sym)->as->type == AS_EXPLICIT))
7252 12160 : && sym->attr.dummy && !sym->attr.elemental && gfc_is_nodesc_array (sym))
7253 : {
7254 5842 : gfc_trans_g77_array (sym, block);
7255 5842 : return;
7256 : }
7257 :
7258 6960 : location_t loc = input_location;
7259 6960 : input_location = gfc_get_location (&sym->declared_at);
7260 :
7261 : /* Descriptor type. */
7262 6960 : type = TREE_TYPE (tmpdesc);
7263 6960 : gcc_assert (GFC_ARRAY_TYPE_P (type));
7264 6960 : dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
7265 6960 : if (is_classarray)
7266 : /* For a class array the dummy array descriptor is in the _class
7267 : component. */
7268 661 : dumdesc = gfc_class_data_get (dumdesc);
7269 : else
7270 6299 : dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc);
7271 6960 : as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
7272 6960 : gfc_start_block (&init);
7273 :
7274 6960 : if (sym->ts.type == BT_CHARACTER
7275 786 : && VAR_P (sym->ts.u.cl->backend_decl))
7276 87 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7277 :
7278 : /* TODO: Fix the exclusion of class arrays from extent checking. */
7279 1084 : checkparm = (as->type == AS_EXPLICIT && !is_classarray
7280 8025 : && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
7281 :
7282 6960 : no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
7283 6959 : || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
7284 :
7285 6960 : if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
7286 : {
7287 : /* For non-constant shape arrays we only check if the first dimension
7288 : is contiguous. Repacking higher dimensions wouldn't gain us
7289 : anything as we still don't know the array stride. */
7290 1 : partial = gfc_create_var (logical_type_node, "partial");
7291 1 : TREE_USED (partial) = 1;
7292 1 : tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
7293 1 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, tmp,
7294 : gfc_index_one_node);
7295 1 : gfc_add_modify (&init, partial, tmp);
7296 : }
7297 : else
7298 : partial = NULL_TREE;
7299 :
7300 : /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
7301 : here, however I think it does the right thing. */
7302 6960 : if (no_repack)
7303 : {
7304 : /* Set the first stride. */
7305 6958 : stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
7306 6958 : stride = gfc_evaluate_now (stride, &init);
7307 :
7308 6958 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7309 : stride, gfc_index_zero_node);
7310 6958 : tmp = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
7311 : tmp, gfc_index_one_node, stride);
7312 6958 : stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
7313 6958 : gfc_add_modify (&init, stride, tmp);
7314 :
7315 : /* Allow the user to disable array repacking. */
7316 6958 : stmt_unpacked = NULL_TREE;
7317 : }
7318 : else
7319 : {
7320 2 : gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
7321 : /* A library call to repack the array if necessary. */
7322 2 : tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
7323 2 : stmt_unpacked = build_call_expr_loc (input_location,
7324 : gfor_fndecl_in_pack, 1, tmp);
7325 :
7326 2 : stride = gfc_index_one_node;
7327 :
7328 2 : if (warn_array_temporaries)
7329 : {
7330 1 : locus where;
7331 1 : gfc_locus_from_location (&where, loc);
7332 1 : gfc_warning (OPT_Warray_temporaries,
7333 : "Creating array temporary at %L", &where);
7334 : }
7335 : }
7336 :
7337 : /* This is for the case where the array data is used directly without
7338 : calling the repack function. */
7339 6960 : if (no_repack || partial != NULL_TREE)
7340 6959 : stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
7341 : else
7342 : stmt_packed = NULL_TREE;
7343 :
7344 : /* Assign the data pointer. */
7345 6960 : if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
7346 : {
7347 : /* Don't repack unknown shape arrays when the first stride is 1. */
7348 1 : tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (stmt_packed),
7349 : partial, stmt_packed, stmt_unpacked);
7350 : }
7351 : else
7352 6959 : tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
7353 6960 : gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp));
7354 :
7355 6960 : offset = gfc_index_zero_node;
7356 6960 : size = gfc_index_one_node;
7357 :
7358 : /* Evaluate the bounds of the array. */
7359 16294 : for (n = 0; n < as->rank; n++)
7360 : {
7361 9334 : if (checkparm || !as->upper[n])
7362 : {
7363 : /* Get the bounds of the actual parameter. */
7364 8015 : dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]);
7365 8015 : dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]);
7366 : }
7367 : else
7368 : {
7369 : dubound = NULL_TREE;
7370 : dlbound = NULL_TREE;
7371 : }
7372 :
7373 9334 : lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
7374 9334 : if (!INTEGER_CST_P (lbound))
7375 : {
7376 46 : gfc_init_se (&se, NULL);
7377 46 : gfc_conv_expr_type (&se, as->lower[n],
7378 : gfc_array_index_type);
7379 46 : gfc_add_block_to_block (&init, &se.pre);
7380 46 : gfc_add_modify (&init, lbound, se.expr);
7381 : }
7382 :
7383 9334 : ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
7384 : /* Set the desired upper bound. */
7385 9334 : if (as->upper[n])
7386 : {
7387 : /* We know what we want the upper bound to be. */
7388 1377 : if (!INTEGER_CST_P (ubound))
7389 : {
7390 639 : gfc_init_se (&se, NULL);
7391 639 : gfc_conv_expr_type (&se, as->upper[n],
7392 : gfc_array_index_type);
7393 639 : gfc_add_block_to_block (&init, &se.pre);
7394 639 : gfc_add_modify (&init, ubound, se.expr);
7395 : }
7396 :
7397 : /* Check the sizes match. */
7398 1377 : if (checkparm)
7399 : {
7400 : /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
7401 58 : char * msg;
7402 58 : tree temp;
7403 58 : locus where;
7404 :
7405 58 : gfc_locus_from_location (&where, loc);
7406 58 : temp = fold_build2_loc (input_location, MINUS_EXPR,
7407 : gfc_array_index_type, ubound, lbound);
7408 58 : temp = fold_build2_loc (input_location, PLUS_EXPR,
7409 : gfc_array_index_type,
7410 : gfc_index_one_node, temp);
7411 58 : stride2 = fold_build2_loc (input_location, MINUS_EXPR,
7412 : gfc_array_index_type, dubound,
7413 : dlbound);
7414 58 : stride2 = fold_build2_loc (input_location, PLUS_EXPR,
7415 : gfc_array_index_type,
7416 : gfc_index_one_node, stride2);
7417 58 : tmp = fold_build2_loc (input_location, NE_EXPR,
7418 : gfc_array_index_type, temp, stride2);
7419 58 : msg = xasprintf ("Dimension %d of array '%s' has extent "
7420 : "%%ld instead of %%ld", n+1, sym->name);
7421 :
7422 58 : gfc_trans_runtime_check (true, false, tmp, &init, &where, msg,
7423 : fold_convert (long_integer_type_node, temp),
7424 : fold_convert (long_integer_type_node, stride2));
7425 :
7426 58 : free (msg);
7427 : }
7428 : }
7429 : else
7430 : {
7431 : /* For assumed shape arrays move the upper bound by the same amount
7432 : as the lower bound. */
7433 7957 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
7434 : gfc_array_index_type, dubound, dlbound);
7435 7957 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
7436 : gfc_array_index_type, tmp, lbound);
7437 7957 : gfc_add_modify (&init, ubound, tmp);
7438 : }
7439 : /* The offset of this dimension. offset = offset - lbound * stride. */
7440 9334 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7441 : lbound, stride);
7442 9334 : offset = fold_build2_loc (input_location, MINUS_EXPR,
7443 : gfc_array_index_type, offset, tmp);
7444 :
7445 : /* The size of this dimension, and the stride of the next. */
7446 9334 : if (n + 1 < as->rank)
7447 : {
7448 2374 : stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
7449 :
7450 2374 : if (no_repack || partial != NULL_TREE)
7451 2373 : stmt_unpacked =
7452 2373 : gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]);
7453 :
7454 : /* Figure out the stride if not a known constant. */
7455 2374 : if (!INTEGER_CST_P (stride))
7456 : {
7457 2373 : if (no_repack)
7458 : stmt_packed = NULL_TREE;
7459 : else
7460 : {
7461 : /* Calculate stride = size * (ubound + 1 - lbound). */
7462 0 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
7463 : gfc_array_index_type,
7464 : gfc_index_one_node, lbound);
7465 0 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
7466 : gfc_array_index_type, ubound, tmp);
7467 0 : size = fold_build2_loc (input_location, MULT_EXPR,
7468 : gfc_array_index_type, size, tmp);
7469 0 : stmt_packed = size;
7470 : }
7471 :
7472 : /* Assign the stride. */
7473 2373 : if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
7474 0 : tmp = fold_build3_loc (input_location, COND_EXPR,
7475 : gfc_array_index_type, partial,
7476 : stmt_unpacked, stmt_packed);
7477 : else
7478 2373 : tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
7479 2373 : gfc_add_modify (&init, stride, tmp);
7480 : }
7481 : }
7482 : else
7483 : {
7484 6960 : stride = GFC_TYPE_ARRAY_SIZE (type);
7485 :
7486 6960 : if (stride && !INTEGER_CST_P (stride))
7487 : {
7488 : /* Calculate size = stride * (ubound + 1 - lbound). */
7489 6959 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
7490 : gfc_array_index_type,
7491 : gfc_index_one_node, lbound);
7492 6959 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
7493 : gfc_array_index_type,
7494 : ubound, tmp);
7495 20877 : tmp = fold_build2_loc (input_location, MULT_EXPR,
7496 : gfc_array_index_type,
7497 6959 : GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
7498 6959 : gfc_add_modify (&init, stride, tmp);
7499 : }
7500 : }
7501 : }
7502 :
7503 6960 : gfc_trans_array_cobounds (type, &init, sym);
7504 :
7505 : /* Set the offset. */
7506 6960 : if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
7507 6958 : gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
7508 :
7509 6960 : gfc_trans_vla_type_sizes (sym, &init);
7510 :
7511 6960 : stmtInit = gfc_finish_block (&init);
7512 :
7513 : /* Only do the entry/initialization code if the arg is present. */
7514 6960 : dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
7515 6960 : optional_arg = (sym->attr.optional
7516 6960 : || (sym->ns->proc_name->attr.entry_master
7517 79 : && sym->attr.dummy));
7518 : if (optional_arg)
7519 : {
7520 717 : tree zero_init = fold_convert (TREE_TYPE (tmpdesc), null_pointer_node);
7521 717 : zero_init = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
7522 : tmpdesc, zero_init);
7523 717 : tmp = gfc_conv_expr_present (sym, true);
7524 717 : stmtInit = build3_v (COND_EXPR, tmp, stmtInit, zero_init);
7525 : }
7526 :
7527 : /* Cleanup code. */
7528 6960 : if (no_repack)
7529 : stmtCleanup = NULL_TREE;
7530 : else
7531 : {
7532 2 : stmtblock_t cleanup;
7533 2 : gfc_start_block (&cleanup);
7534 :
7535 2 : if (sym->attr.intent != INTENT_IN)
7536 : {
7537 : /* Copy the data back. */
7538 2 : tmp = build_call_expr_loc (input_location,
7539 : gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
7540 2 : gfc_add_expr_to_block (&cleanup, tmp);
7541 : }
7542 :
7543 : /* Free the temporary. */
7544 2 : tmp = gfc_call_free (tmpdesc);
7545 2 : gfc_add_expr_to_block (&cleanup, tmp);
7546 :
7547 2 : stmtCleanup = gfc_finish_block (&cleanup);
7548 :
7549 : /* Only do the cleanup if the array was repacked. */
7550 2 : if (is_classarray)
7551 : /* For a class array the dummy array descriptor is in the _class
7552 : component. */
7553 1 : tmp = gfc_class_data_get (dumdesc);
7554 : else
7555 1 : tmp = build_fold_indirect_ref_loc (input_location, dumdesc);
7556 2 : tmp = gfc_conv_descriptor_data_get (tmp);
7557 2 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
7558 : tmp, tmpdesc);
7559 2 : stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
7560 : build_empty_stmt (input_location));
7561 :
7562 2 : if (optional_arg)
7563 : {
7564 0 : tmp = gfc_conv_expr_present (sym);
7565 0 : stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
7566 : build_empty_stmt (input_location));
7567 : }
7568 : }
7569 :
7570 : /* We don't need to free any memory allocated by internal_pack as it will
7571 : be freed at the end of the function by pop_context. */
7572 6960 : gfc_add_init_cleanup (block, stmtInit, stmtCleanup);
7573 :
7574 6960 : input_location = loc;
7575 : }
7576 :
7577 :
7578 : /* Calculate the overall offset, including subreferences. */
7579 : void
7580 60538 : gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
7581 : bool subref, gfc_expr *expr)
7582 : {
7583 60538 : tree tmp;
7584 60538 : tree field;
7585 60538 : tree stride;
7586 60538 : tree index;
7587 60538 : gfc_ref *ref;
7588 60538 : gfc_se start;
7589 60538 : int n;
7590 :
7591 : /* If offset is NULL and this is not a subreferenced array, there is
7592 : nothing to do. */
7593 60538 : if (offset == NULL_TREE)
7594 : {
7595 1066 : if (subref)
7596 139 : offset = gfc_index_zero_node;
7597 : else
7598 927 : return;
7599 : }
7600 :
7601 59611 : tmp = build_array_ref (desc, offset, NULL, NULL);
7602 :
7603 : /* Offset the data pointer for pointer assignments from arrays with
7604 : subreferences; e.g. my_integer => my_type(:)%integer_component. */
7605 59611 : if (subref)
7606 : {
7607 : /* Go past the array reference. */
7608 844 : for (ref = expr->ref; ref; ref = ref->next)
7609 844 : if (ref->type == REF_ARRAY &&
7610 757 : ref->u.ar.type != AR_ELEMENT)
7611 : {
7612 733 : ref = ref->next;
7613 733 : break;
7614 : }
7615 :
7616 : /* Calculate the offset for each subsequent subreference. */
7617 1438 : for (; ref; ref = ref->next)
7618 : {
7619 705 : switch (ref->type)
7620 : {
7621 301 : case REF_COMPONENT:
7622 301 : field = ref->u.c.component->backend_decl;
7623 301 : gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
7624 602 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
7625 301 : TREE_TYPE (field),
7626 : tmp, field, NULL_TREE);
7627 301 : break;
7628 :
7629 320 : case REF_SUBSTRING:
7630 320 : gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
7631 320 : gfc_init_se (&start, NULL);
7632 320 : gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
7633 320 : gfc_add_block_to_block (block, &start.pre);
7634 320 : tmp = gfc_build_array_ref (tmp, start.expr, NULL);
7635 320 : break;
7636 :
7637 24 : case REF_ARRAY:
7638 24 : gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
7639 : && ref->u.ar.type == AR_ELEMENT);
7640 :
7641 : /* TODO - Add bounds checking. */
7642 24 : stride = gfc_index_one_node;
7643 24 : index = gfc_index_zero_node;
7644 55 : for (n = 0; n < ref->u.ar.dimen; n++)
7645 : {
7646 31 : tree itmp;
7647 31 : tree jtmp;
7648 :
7649 : /* Update the index. */
7650 31 : gfc_init_se (&start, NULL);
7651 31 : gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
7652 31 : itmp = gfc_evaluate_now (start.expr, block);
7653 31 : gfc_init_se (&start, NULL);
7654 31 : gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
7655 31 : jtmp = gfc_evaluate_now (start.expr, block);
7656 31 : itmp = fold_build2_loc (input_location, MINUS_EXPR,
7657 : gfc_array_index_type, itmp, jtmp);
7658 31 : itmp = fold_build2_loc (input_location, MULT_EXPR,
7659 : gfc_array_index_type, itmp, stride);
7660 31 : index = fold_build2_loc (input_location, PLUS_EXPR,
7661 : gfc_array_index_type, itmp, index);
7662 31 : index = gfc_evaluate_now (index, block);
7663 :
7664 : /* Update the stride. */
7665 31 : gfc_init_se (&start, NULL);
7666 31 : gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
7667 31 : itmp = fold_build2_loc (input_location, MINUS_EXPR,
7668 : gfc_array_index_type, start.expr,
7669 : jtmp);
7670 31 : itmp = fold_build2_loc (input_location, PLUS_EXPR,
7671 : gfc_array_index_type,
7672 : gfc_index_one_node, itmp);
7673 31 : stride = fold_build2_loc (input_location, MULT_EXPR,
7674 : gfc_array_index_type, stride, itmp);
7675 31 : stride = gfc_evaluate_now (stride, block);
7676 : }
7677 :
7678 : /* Apply the index to obtain the array element. */
7679 24 : tmp = gfc_build_array_ref (tmp, index, NULL);
7680 24 : break;
7681 :
7682 60 : case REF_INQUIRY:
7683 60 : switch (ref->u.i)
7684 : {
7685 54 : case INQUIRY_RE:
7686 108 : tmp = fold_build1_loc (input_location, REALPART_EXPR,
7687 54 : TREE_TYPE (TREE_TYPE (tmp)), tmp);
7688 54 : break;
7689 :
7690 6 : case INQUIRY_IM:
7691 12 : tmp = fold_build1_loc (input_location, IMAGPART_EXPR,
7692 6 : TREE_TYPE (TREE_TYPE (tmp)), tmp);
7693 6 : break;
7694 :
7695 : default:
7696 : break;
7697 : }
7698 : break;
7699 :
7700 0 : default:
7701 0 : gcc_unreachable ();
7702 705 : break;
7703 : }
7704 : }
7705 : }
7706 :
7707 : /* Set the target data pointer. */
7708 59611 : offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
7709 :
7710 : /* Check for optional dummy argument being present. Arguments of BIND(C)
7711 : procedures are excepted here since they are handled differently. */
7712 59611 : if (expr->expr_type == EXPR_VARIABLE
7713 52318 : && expr->symtree->n.sym->attr.dummy
7714 6380 : && expr->symtree->n.sym->attr.optional
7715 60603 : && !is_CFI_desc (NULL, expr))
7716 1624 : offset = build3_loc (input_location, COND_EXPR, TREE_TYPE (offset),
7717 812 : gfc_conv_expr_present (expr->symtree->n.sym), offset,
7718 812 : fold_convert (TREE_TYPE (offset), gfc_index_zero_node));
7719 :
7720 59611 : gfc_conv_descriptor_data_set (block, parm, offset);
7721 : }
7722 :
7723 :
7724 : /* gfc_conv_expr_descriptor needs the string length an expression
7725 : so that the size of the temporary can be obtained. This is done
7726 : by adding up the string lengths of all the elements in the
7727 : expression. Function with non-constant expressions have their
7728 : string lengths mapped onto the actual arguments using the
7729 : interface mapping machinery in trans-expr.cc. */
7730 : static void
7731 1584 : get_array_charlen (gfc_expr *expr, gfc_se *se)
7732 : {
7733 1584 : gfc_interface_mapping mapping;
7734 1584 : gfc_formal_arglist *formal;
7735 1584 : gfc_actual_arglist *arg;
7736 1584 : gfc_se tse;
7737 1584 : gfc_expr *e;
7738 :
7739 1584 : if (expr->ts.u.cl->length
7740 1584 : && gfc_is_constant_expr (expr->ts.u.cl->length))
7741 : {
7742 1237 : if (!expr->ts.u.cl->backend_decl)
7743 471 : gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
7744 1369 : return;
7745 : }
7746 :
7747 347 : switch (expr->expr_type)
7748 : {
7749 130 : case EXPR_ARRAY:
7750 :
7751 : /* This is somewhat brutal. The expression for the first
7752 : element of the array is evaluated and assigned to a
7753 : new string length for the original expression. */
7754 130 : e = gfc_constructor_first (expr->value.constructor)->expr;
7755 :
7756 130 : gfc_init_se (&tse, NULL);
7757 :
7758 : /* Avoid evaluating trailing array references since all we need is
7759 : the string length. */
7760 130 : if (e->rank)
7761 38 : tse.descriptor_only = 1;
7762 130 : if (e->rank && e->expr_type != EXPR_VARIABLE)
7763 1 : gfc_conv_expr_descriptor (&tse, e);
7764 : else
7765 129 : gfc_conv_expr (&tse, e);
7766 :
7767 130 : gfc_add_block_to_block (&se->pre, &tse.pre);
7768 130 : gfc_add_block_to_block (&se->post, &tse.post);
7769 :
7770 130 : if (!expr->ts.u.cl->backend_decl || !VAR_P (expr->ts.u.cl->backend_decl))
7771 : {
7772 87 : expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
7773 87 : expr->ts.u.cl->backend_decl =
7774 87 : gfc_create_var (gfc_charlen_type_node, "sln");
7775 : }
7776 :
7777 130 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
7778 : tse.string_length);
7779 :
7780 : /* Make sure that deferred length components point to the hidden
7781 : string_length component. */
7782 130 : if (TREE_CODE (tse.expr) == COMPONENT_REF
7783 25 : && TREE_CODE (tse.string_length) == COMPONENT_REF
7784 149 : && TREE_OPERAND (tse.expr, 0) == TREE_OPERAND (tse.string_length, 0))
7785 19 : e->ts.u.cl->backend_decl = expr->ts.u.cl->backend_decl;
7786 :
7787 : return;
7788 :
7789 91 : case EXPR_OP:
7790 91 : get_array_charlen (expr->value.op.op1, se);
7791 :
7792 : /* For parentheses the expression ts.u.cl should be identical. */
7793 91 : if (expr->value.op.op == INTRINSIC_PARENTHESES)
7794 : {
7795 2 : if (expr->value.op.op1->ts.u.cl != expr->ts.u.cl)
7796 2 : expr->ts.u.cl->backend_decl
7797 2 : = expr->value.op.op1->ts.u.cl->backend_decl;
7798 2 : return;
7799 : }
7800 :
7801 178 : expr->ts.u.cl->backend_decl =
7802 89 : gfc_create_var (gfc_charlen_type_node, "sln");
7803 :
7804 89 : if (expr->value.op.op2)
7805 : {
7806 89 : get_array_charlen (expr->value.op.op2, se);
7807 :
7808 89 : gcc_assert (expr->value.op.op == INTRINSIC_CONCAT);
7809 :
7810 : /* Add the string lengths and assign them to the expression
7811 : string length backend declaration. */
7812 89 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
7813 : fold_build2_loc (input_location, PLUS_EXPR,
7814 : gfc_charlen_type_node,
7815 89 : expr->value.op.op1->ts.u.cl->backend_decl,
7816 89 : expr->value.op.op2->ts.u.cl->backend_decl));
7817 : }
7818 : else
7819 0 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
7820 0 : expr->value.op.op1->ts.u.cl->backend_decl);
7821 : break;
7822 :
7823 44 : case EXPR_FUNCTION:
7824 44 : if (expr->value.function.esym == NULL
7825 37 : || expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
7826 : {
7827 7 : gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
7828 7 : break;
7829 : }
7830 :
7831 : /* Map expressions involving the dummy arguments onto the actual
7832 : argument expressions. */
7833 37 : gfc_init_interface_mapping (&mapping);
7834 37 : formal = gfc_sym_get_dummy_args (expr->symtree->n.sym);
7835 37 : arg = expr->value.function.actual;
7836 :
7837 : /* Set se = NULL in the calls to the interface mapping, to suppress any
7838 : backend stuff. */
7839 113 : for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
7840 : {
7841 38 : if (!arg->expr)
7842 0 : continue;
7843 38 : if (formal->sym)
7844 38 : gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
7845 : }
7846 :
7847 37 : gfc_init_se (&tse, NULL);
7848 :
7849 : /* Build the expression for the character length and convert it. */
7850 37 : gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length);
7851 :
7852 37 : gfc_add_block_to_block (&se->pre, &tse.pre);
7853 37 : gfc_add_block_to_block (&se->post, &tse.post);
7854 37 : tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
7855 74 : tse.expr = fold_build2_loc (input_location, MAX_EXPR,
7856 37 : TREE_TYPE (tse.expr), tse.expr,
7857 37 : build_zero_cst (TREE_TYPE (tse.expr)));
7858 37 : expr->ts.u.cl->backend_decl = tse.expr;
7859 37 : gfc_free_interface_mapping (&mapping);
7860 37 : break;
7861 :
7862 82 : default:
7863 82 : gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
7864 82 : break;
7865 : }
7866 : }
7867 :
7868 :
7869 : /* Helper function to check dimensions. */
7870 : static bool
7871 0 : transposed_dims (gfc_ss *ss)
7872 : {
7873 0 : int n;
7874 :
7875 176376 : for (n = 0; n < ss->dimen; n++)
7876 88895 : if (ss->dim[n] != n)
7877 : return true;
7878 : return false;
7879 : }
7880 :
7881 :
7882 : /* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
7883 : AR_FULL, suitable for the scalarizer. */
7884 :
7885 : static gfc_ss *
7886 1510 : walk_coarray (gfc_expr *e)
7887 : {
7888 1510 : gfc_ss *ss;
7889 :
7890 1510 : ss = gfc_walk_expr (e);
7891 :
7892 : /* Fix scalar coarray. */
7893 1510 : if (ss == gfc_ss_terminator)
7894 : {
7895 357 : gfc_ref *ref;
7896 :
7897 357 : ref = e->ref;
7898 508 : while (ref)
7899 : {
7900 508 : if (ref->type == REF_ARRAY
7901 357 : && ref->u.ar.codimen > 0)
7902 : break;
7903 :
7904 151 : ref = ref->next;
7905 : }
7906 :
7907 357 : gcc_assert (ref != NULL);
7908 357 : if (ref->u.ar.type == AR_ELEMENT)
7909 339 : ref->u.ar.type = AR_SECTION;
7910 357 : ss = gfc_reverse_ss (gfc_walk_array_ref (ss, e, ref, false));
7911 : }
7912 :
7913 1510 : return ss;
7914 : }
7915 :
7916 : gfc_array_spec *
7917 2177 : get_coarray_as (const gfc_expr *e)
7918 : {
7919 2177 : gfc_array_spec *as;
7920 2177 : gfc_symbol *sym = e->symtree->n.sym;
7921 2177 : gfc_component *comp;
7922 :
7923 2177 : if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.codimension)
7924 595 : as = CLASS_DATA (sym)->as;
7925 1582 : else if (sym->attr.codimension)
7926 1522 : as = sym->as;
7927 : else
7928 : as = nullptr;
7929 :
7930 5069 : for (gfc_ref *ref = e->ref; ref; ref = ref->next)
7931 : {
7932 2892 : switch (ref->type)
7933 : {
7934 715 : case REF_COMPONENT:
7935 715 : comp = ref->u.c.component;
7936 715 : if (comp->ts.type == BT_CLASS && CLASS_DATA (comp)->attr.codimension)
7937 18 : as = CLASS_DATA (comp)->as;
7938 697 : else if (comp->ts.type != BT_CLASS && comp->attr.codimension)
7939 655 : as = comp->as;
7940 : break;
7941 :
7942 : case REF_ARRAY:
7943 : case REF_SUBSTRING:
7944 : case REF_INQUIRY:
7945 : break;
7946 : }
7947 : }
7948 :
7949 2177 : return as;
7950 : }
7951 :
7952 : bool
7953 144309 : is_explicit_coarray (gfc_expr *expr)
7954 : {
7955 144309 : if (!gfc_is_coarray (expr))
7956 : return false;
7957 :
7958 2177 : gfc_array_spec *cas = get_coarray_as (expr);
7959 2177 : return cas && cas->cotype == AS_EXPLICIT;
7960 : }
7961 :
7962 : /* Convert an array for passing as an actual argument. Expressions and
7963 : vector subscripts are evaluated and stored in a temporary, which is then
7964 : passed. For whole arrays the descriptor is passed. For array sections
7965 : a modified copy of the descriptor is passed, but using the original data.
7966 :
7967 : This function is also used for array pointer assignments, and there
7968 : are three cases:
7969 :
7970 : - se->want_pointer && !se->direct_byref
7971 : EXPR is an actual argument. On exit, se->expr contains a
7972 : pointer to the array descriptor.
7973 :
7974 : - !se->want_pointer && !se->direct_byref
7975 : EXPR is an actual argument to an intrinsic function or the
7976 : left-hand side of a pointer assignment. On exit, se->expr
7977 : contains the descriptor for EXPR.
7978 :
7979 : - !se->want_pointer && se->direct_byref
7980 : EXPR is the right-hand side of a pointer assignment and
7981 : se->expr is the descriptor for the previously-evaluated
7982 : left-hand side. The function creates an assignment from
7983 : EXPR to se->expr.
7984 :
7985 :
7986 : The se->force_tmp flag disables the non-copying descriptor optimization
7987 : that is used for transpose. It may be used in cases where there is an
7988 : alias between the transpose argument and another argument in the same
7989 : function call. */
7990 :
7991 : void
7992 160791 : gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
7993 : {
7994 160791 : gfc_ss *ss;
7995 160791 : gfc_ss_type ss_type;
7996 160791 : gfc_ss_info *ss_info;
7997 160791 : gfc_loopinfo loop;
7998 160791 : gfc_array_info *info;
7999 160791 : int need_tmp;
8000 160791 : int n;
8001 160791 : tree tmp;
8002 160791 : tree desc;
8003 160791 : stmtblock_t block;
8004 160791 : tree start;
8005 160791 : int full;
8006 160791 : bool subref_array_target = false;
8007 160791 : bool deferred_array_component = false;
8008 160791 : bool substr = false;
8009 160791 : gfc_expr *arg, *ss_expr;
8010 :
8011 160791 : if (se->want_coarray || expr->rank == 0)
8012 1510 : ss = walk_coarray (expr);
8013 : else
8014 159281 : ss = gfc_walk_expr (expr);
8015 :
8016 160791 : gcc_assert (ss != NULL);
8017 160791 : gcc_assert (ss != gfc_ss_terminator);
8018 :
8019 160791 : ss_info = ss->info;
8020 160791 : ss_type = ss_info->type;
8021 160791 : ss_expr = ss_info->expr;
8022 :
8023 : /* Special case: TRANSPOSE which needs no temporary. */
8024 166208 : while (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym
8025 165980 : && (arg = gfc_get_noncopying_intrinsic_argument (expr)) != NULL)
8026 : {
8027 : /* This is a call to transpose which has already been handled by the
8028 : scalarizer, so that we just need to get its argument's descriptor. */
8029 450 : gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
8030 450 : expr = expr->value.function.actual->expr;
8031 : }
8032 :
8033 160791 : if (!se->direct_byref)
8034 309139 : se->unlimited_polymorphic = UNLIMITED_POLY (expr);
8035 :
8036 : /* Special case things we know we can pass easily. */
8037 160791 : switch (expr->expr_type)
8038 : {
8039 144594 : case EXPR_VARIABLE:
8040 : /* If we have a linear array section, we can pass it directly.
8041 : Otherwise we need to copy it into a temporary. */
8042 :
8043 144594 : gcc_assert (ss_type == GFC_SS_SECTION);
8044 144594 : gcc_assert (ss_expr == expr);
8045 144594 : info = &ss_info->data.array;
8046 :
8047 : /* Get the descriptor for the array. */
8048 144594 : gfc_conv_ss_descriptor (&se->pre, ss, 0);
8049 144594 : desc = info->descriptor;
8050 :
8051 : /* The charlen backend decl for deferred character components cannot
8052 : be used because it is fixed at zero. Instead, the hidden string
8053 : length component is used. */
8054 144594 : if (expr->ts.type == BT_CHARACTER
8055 20252 : && expr->ts.deferred
8056 2831 : && TREE_CODE (desc) == COMPONENT_REF)
8057 144594 : deferred_array_component = true;
8058 :
8059 144594 : substr = info->ref && info->ref->next
8060 145422 : && info->ref->next->type == REF_SUBSTRING;
8061 :
8062 144594 : subref_array_target = (is_subref_array (expr)
8063 144594 : && (se->direct_byref
8064 2596 : || expr->ts.type == BT_CHARACTER));
8065 144594 : need_tmp = (gfc_ref_needs_temporary_p (expr->ref)
8066 144594 : && !subref_array_target);
8067 :
8068 144594 : if (se->force_tmp)
8069 : need_tmp = 1;
8070 144411 : else if (se->force_no_tmp)
8071 : need_tmp = 0;
8072 :
8073 138274 : if (need_tmp)
8074 : full = 0;
8075 144309 : else if (is_explicit_coarray (expr))
8076 : full = 0;
8077 143489 : else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
8078 : {
8079 : /* Create a new descriptor if the array doesn't have one. */
8080 : full = 0;
8081 : }
8082 93675 : else if (info->ref->u.ar.type == AR_FULL || se->descriptor_only)
8083 : full = 1;
8084 8063 : else if (se->direct_byref)
8085 : full = 0;
8086 7700 : else if (info->ref->u.ar.dimen == 0 && !info->ref->next)
8087 : full = 1;
8088 7559 : else if (info->ref->u.ar.type == AR_SECTION && se->want_pointer)
8089 : full = 0;
8090 : else
8091 3661 : full = gfc_full_array_ref_p (info->ref, NULL);
8092 :
8093 175449 : if (full && !transposed_dims (ss))
8094 : {
8095 85978 : if (se->direct_byref && !se->byref_noassign)
8096 : {
8097 1054 : struct lang_type *lhs_ls
8098 1054 : = TYPE_LANG_SPECIFIC (TREE_TYPE (se->expr)),
8099 1054 : *rhs_ls = TYPE_LANG_SPECIFIC (TREE_TYPE (desc));
8100 : /* When only the array_kind differs, do a view_convert. */
8101 1450 : tmp = lhs_ls && rhs_ls && lhs_ls->rank == rhs_ls->rank
8102 1054 : && lhs_ls->akind != rhs_ls->akind
8103 1450 : ? build1 (VIEW_CONVERT_EXPR, TREE_TYPE (se->expr), desc)
8104 : : desc;
8105 : /* Copy the descriptor for pointer assignments. */
8106 1054 : gfc_add_modify (&se->pre, se->expr, tmp);
8107 :
8108 : /* Add any offsets from subreferences. */
8109 1054 : gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
8110 : subref_array_target, expr);
8111 :
8112 : /* ....and set the span field. */
8113 1054 : if (ss_info->expr->ts.type == BT_CHARACTER)
8114 141 : tmp = gfc_conv_descriptor_span_get (desc);
8115 : else
8116 913 : tmp = gfc_get_array_span (desc, expr);
8117 1054 : gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp);
8118 1054 : }
8119 84924 : else if (se->want_pointer)
8120 : {
8121 : /* We pass full arrays directly. This means that pointers and
8122 : allocatable arrays should also work. */
8123 13937 : se->expr = gfc_build_addr_expr (NULL_TREE, desc);
8124 : }
8125 : else
8126 : {
8127 70987 : se->expr = desc;
8128 : }
8129 :
8130 85978 : if (expr->ts.type == BT_CHARACTER && !deferred_array_component)
8131 8397 : se->string_length = gfc_get_expr_charlen (expr);
8132 : /* The ss_info string length is returned set to the value of the
8133 : hidden string length component. */
8134 77318 : else if (deferred_array_component)
8135 263 : se->string_length = ss_info->string_length;
8136 :
8137 85978 : se->class_container = ss_info->class_container;
8138 :
8139 85978 : gfc_free_ss_chain (ss);
8140 172082 : return;
8141 : }
8142 : break;
8143 :
8144 4967 : case EXPR_FUNCTION:
8145 : /* A transformational function return value will be a temporary
8146 : array descriptor. We still need to go through the scalarizer
8147 : to create the descriptor. Elemental functions are handled as
8148 : arbitrary expressions, i.e. copy to a temporary. */
8149 :
8150 4967 : if (se->direct_byref)
8151 : {
8152 126 : gcc_assert (ss_type == GFC_SS_FUNCTION && ss_expr == expr);
8153 :
8154 : /* For pointer assignments pass the descriptor directly. */
8155 126 : if (se->ss == NULL)
8156 126 : se->ss = ss;
8157 : else
8158 0 : gcc_assert (se->ss == ss);
8159 :
8160 126 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
8161 126 : gfc_conv_expr (se, expr);
8162 :
8163 126 : gfc_free_ss_chain (ss);
8164 126 : return;
8165 : }
8166 :
8167 4841 : if (ss_expr != expr || ss_type != GFC_SS_FUNCTION)
8168 : {
8169 3325 : if (ss_expr != expr)
8170 : /* Elemental function. */
8171 2576 : gcc_assert ((expr->value.function.esym != NULL
8172 : && expr->value.function.esym->attr.elemental)
8173 : || (expr->value.function.isym != NULL
8174 : && expr->value.function.isym->elemental)
8175 : || (gfc_expr_attr (expr).proc_pointer
8176 : && gfc_expr_attr (expr).elemental)
8177 : || gfc_inline_intrinsic_function_p (expr));
8178 :
8179 3325 : need_tmp = 1;
8180 3325 : if (expr->ts.type == BT_CHARACTER
8181 35 : && expr->ts.u.cl->length
8182 29 : && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
8183 13 : get_array_charlen (expr, se);
8184 :
8185 : info = NULL;
8186 : }
8187 : else
8188 : {
8189 : /* Transformational function. */
8190 1516 : info = &ss_info->data.array;
8191 1516 : need_tmp = 0;
8192 : }
8193 : break;
8194 :
8195 10503 : case EXPR_ARRAY:
8196 : /* Constant array constructors don't need a temporary. */
8197 10503 : if (ss_type == GFC_SS_CONSTRUCTOR
8198 10503 : && expr->ts.type != BT_CHARACTER
8199 19747 : && gfc_constant_array_constructor_p (expr->value.constructor))
8200 : {
8201 7280 : need_tmp = 0;
8202 7280 : info = &ss_info->data.array;
8203 : }
8204 : else
8205 : {
8206 : need_tmp = 1;
8207 : info = NULL;
8208 : }
8209 : break;
8210 :
8211 : default:
8212 : /* Something complicated. Copy it into a temporary. */
8213 : need_tmp = 1;
8214 : info = NULL;
8215 : break;
8216 : }
8217 :
8218 : /* If we are creating a temporary, we don't need to bother about aliases
8219 : anymore. */
8220 67412 : if (need_tmp)
8221 7560 : se->force_tmp = 0;
8222 :
8223 74687 : gfc_init_loopinfo (&loop);
8224 :
8225 : /* Associate the SS with the loop. */
8226 74687 : gfc_add_ss_to_loop (&loop, ss);
8227 :
8228 : /* Tell the scalarizer not to bother creating loop variables, etc. */
8229 74687 : if (!need_tmp)
8230 67127 : loop.array_parameter = 1;
8231 : else
8232 : /* The right-hand side of a pointer assignment mustn't use a temporary. */
8233 7560 : gcc_assert (!se->direct_byref);
8234 :
8235 : /* Do we need bounds checking or not? */
8236 74687 : ss->no_bounds_check = expr->no_bounds_check;
8237 :
8238 : /* Setup the scalarizing loops and bounds. */
8239 74687 : gfc_conv_ss_startstride (&loop);
8240 :
8241 : /* Add bounds-checking for elemental dimensions. */
8242 74687 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !expr->no_bounds_check)
8243 6688 : array_bound_check_elemental (&outermost_loop (&loop)->pre, ss, expr);
8244 :
8245 74687 : if (need_tmp)
8246 : {
8247 7560 : if (expr->ts.type == BT_CHARACTER
8248 1498 : && (!expr->ts.u.cl->backend_decl || expr->expr_type == EXPR_ARRAY))
8249 1391 : get_array_charlen (expr, se);
8250 :
8251 : /* Tell the scalarizer to make a temporary. */
8252 7560 : loop.temp_ss = gfc_get_temp_ss (gfc_typenode_for_spec (&expr->ts),
8253 7560 : ((expr->ts.type == BT_CHARACTER)
8254 1498 : ? expr->ts.u.cl->backend_decl
8255 : : NULL),
8256 : loop.dimen);
8257 :
8258 7560 : se->string_length = loop.temp_ss->info->string_length;
8259 7560 : gcc_assert (loop.temp_ss->dimen == loop.dimen);
8260 7560 : gfc_add_ss_to_loop (&loop, loop.temp_ss);
8261 : }
8262 :
8263 74687 : gfc_conv_loop_setup (&loop, & expr->where);
8264 :
8265 74687 : if (need_tmp)
8266 : {
8267 : /* Copy into a temporary and pass that. We don't need to copy the data
8268 : back because expressions and vector subscripts must be INTENT_IN. */
8269 : /* TODO: Optimize passing function return values. */
8270 7560 : gfc_se lse;
8271 7560 : gfc_se rse;
8272 7560 : bool deep_copy;
8273 :
8274 : /* Start the copying loops. */
8275 7560 : gfc_mark_ss_chain_used (loop.temp_ss, 1);
8276 7560 : gfc_mark_ss_chain_used (ss, 1);
8277 7560 : gfc_start_scalarized_body (&loop, &block);
8278 :
8279 : /* Copy each data element. */
8280 7560 : gfc_init_se (&lse, NULL);
8281 7560 : gfc_copy_loopinfo_to_se (&lse, &loop);
8282 7560 : gfc_init_se (&rse, NULL);
8283 7560 : gfc_copy_loopinfo_to_se (&rse, &loop);
8284 :
8285 7560 : lse.ss = loop.temp_ss;
8286 7560 : rse.ss = ss;
8287 :
8288 7560 : gfc_conv_tmp_array_ref (&lse);
8289 7560 : if (expr->ts.type == BT_CHARACTER)
8290 : {
8291 1498 : gfc_conv_expr (&rse, expr);
8292 1498 : if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
8293 1176 : rse.expr = build_fold_indirect_ref_loc (input_location,
8294 : rse.expr);
8295 : }
8296 : else
8297 6062 : gfc_conv_expr_val (&rse, expr);
8298 :
8299 7560 : gfc_add_block_to_block (&block, &rse.pre);
8300 7560 : gfc_add_block_to_block (&block, &lse.pre);
8301 :
8302 7560 : lse.string_length = rse.string_length;
8303 :
8304 15120 : deep_copy = !se->data_not_needed
8305 7560 : && (expr->expr_type == EXPR_VARIABLE
8306 7022 : || expr->expr_type == EXPR_ARRAY);
8307 7560 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts,
8308 : deep_copy, false);
8309 7560 : gfc_add_expr_to_block (&block, tmp);
8310 :
8311 : /* Finish the copying loops. */
8312 7560 : gfc_trans_scalarizing_loops (&loop, &block);
8313 :
8314 7560 : desc = loop.temp_ss->info->data.array.descriptor;
8315 : }
8316 68643 : else if (expr->expr_type == EXPR_FUNCTION && !transposed_dims (ss))
8317 : {
8318 1503 : desc = info->descriptor;
8319 1503 : se->string_length = ss_info->string_length;
8320 : }
8321 : else
8322 : {
8323 : /* We pass sections without copying to a temporary. Make a new
8324 : descriptor and point it at the section we want. The loop variable
8325 : limits will be the limits of the section.
8326 : A function may decide to repack the array to speed up access, but
8327 : we're not bothered about that here. */
8328 65624 : int dim, ndim, codim;
8329 65624 : tree parm;
8330 65624 : tree parmtype;
8331 65624 : tree dtype;
8332 65624 : tree stride;
8333 65624 : tree from;
8334 65624 : tree to;
8335 65624 : tree base;
8336 65624 : tree offset;
8337 :
8338 65624 : ndim = info->ref ? info->ref->u.ar.dimen : ss->dimen;
8339 :
8340 65624 : if (se->want_coarray)
8341 : {
8342 694 : gfc_array_ref *ar = &info->ref->u.ar;
8343 :
8344 694 : codim = expr->corank;
8345 1512 : for (n = 0; n < codim - 1; n++)
8346 : {
8347 : /* Make sure we are not lost somehow. */
8348 818 : gcc_assert (ar->dimen_type[n + ndim] == DIMEN_THIS_IMAGE);
8349 :
8350 : /* Make sure the call to gfc_conv_section_startstride won't
8351 : generate unnecessary code to calculate stride. */
8352 818 : gcc_assert (ar->stride[n + ndim] == NULL);
8353 :
8354 818 : gfc_conv_section_startstride (&loop.pre, ss, n + ndim);
8355 818 : loop.from[n + loop.dimen] = info->start[n + ndim];
8356 818 : loop.to[n + loop.dimen] = info->end[n + ndim];
8357 : }
8358 :
8359 694 : gcc_assert (n == codim - 1);
8360 694 : evaluate_bound (&loop.pre, info->start, ar->start,
8361 : info->descriptor, n + ndim, true,
8362 694 : ar->as->type == AS_DEFERRED, true);
8363 694 : loop.from[n + loop.dimen] = info->start[n + ndim];
8364 : }
8365 : else
8366 : codim = 0;
8367 :
8368 : /* Set the string_length for a character array. */
8369 65624 : if (expr->ts.type == BT_CHARACTER)
8370 : {
8371 11548 : if (deferred_array_component && !substr)
8372 37 : se->string_length = ss_info->string_length;
8373 : else
8374 11511 : se->string_length = gfc_get_expr_charlen (expr);
8375 :
8376 11548 : if (VAR_P (se->string_length)
8377 990 : && expr->ts.u.cl->backend_decl == se->string_length)
8378 984 : tmp = ss_info->string_length;
8379 : else
8380 : tmp = se->string_length;
8381 :
8382 11548 : if (expr->ts.deferred && expr->ts.u.cl->backend_decl
8383 217 : && VAR_P (expr->ts.u.cl->backend_decl))
8384 156 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, tmp);
8385 : else
8386 11392 : expr->ts.u.cl->backend_decl = tmp;
8387 : }
8388 :
8389 : /* If we have an array section, are assigning or passing an array
8390 : section argument make sure that the lower bound is 1. References
8391 : to the full array should otherwise keep the original bounds. */
8392 65624 : if (!info->ref || info->ref->u.ar.type != AR_FULL)
8393 84265 : for (dim = 0; dim < loop.dimen; dim++)
8394 51209 : if (!integer_onep (loop.from[dim]))
8395 : {
8396 27671 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
8397 : gfc_array_index_type, gfc_index_one_node,
8398 : loop.from[dim]);
8399 27671 : loop.to[dim] = fold_build2_loc (input_location, PLUS_EXPR,
8400 : gfc_array_index_type,
8401 : loop.to[dim], tmp);
8402 27671 : loop.from[dim] = gfc_index_one_node;
8403 : }
8404 :
8405 65624 : desc = info->descriptor;
8406 65624 : if (se->direct_byref && !se->byref_noassign)
8407 : {
8408 : /* For pointer assignments we fill in the destination. */
8409 2670 : parm = se->expr;
8410 2670 : parmtype = TREE_TYPE (parm);
8411 : }
8412 : else
8413 : {
8414 : /* Otherwise make a new one. */
8415 62954 : if (expr->ts.type == BT_CHARACTER)
8416 10884 : parmtype = gfc_typenode_for_spec (&expr->ts);
8417 : else
8418 52070 : parmtype = gfc_get_element_type (TREE_TYPE (desc));
8419 :
8420 62954 : parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, codim,
8421 : loop.from, loop.to, 0,
8422 : GFC_ARRAY_UNKNOWN, false);
8423 62954 : parm = gfc_create_var (parmtype, "parm");
8424 :
8425 : /* When expression is a class object, then add the class' handle to
8426 : the parm_decl. */
8427 62954 : if (expr->ts.type == BT_CLASS && expr->expr_type == EXPR_VARIABLE)
8428 : {
8429 1220 : gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr);
8430 1220 : gfc_se classse;
8431 :
8432 : /* class_expr can be NULL, when no _class ref is in expr.
8433 : We must not fix this here with a gfc_fix_class_ref (). */
8434 1220 : if (class_expr)
8435 : {
8436 1210 : gfc_init_se (&classse, NULL);
8437 1210 : gfc_conv_expr (&classse, class_expr);
8438 1210 : gfc_free_expr (class_expr);
8439 :
8440 1210 : gcc_assert (classse.pre.head == NULL_TREE
8441 : && classse.post.head == NULL_TREE);
8442 1210 : gfc_allocate_lang_decl (parm);
8443 1210 : GFC_DECL_SAVED_DESCRIPTOR (parm) = classse.expr;
8444 : }
8445 : }
8446 : }
8447 :
8448 65624 : if (expr->ts.type == BT_CHARACTER
8449 65624 : && VAR_P (TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (parm)))))
8450 : {
8451 0 : tree elem_len = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (parm)));
8452 0 : gfc_add_modify (&loop.pre, elem_len,
8453 0 : fold_convert (TREE_TYPE (elem_len),
8454 : gfc_get_array_span (desc, expr)));
8455 : }
8456 :
8457 : /* Set the span field. */
8458 65624 : tmp = NULL_TREE;
8459 65624 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
8460 7729 : tmp = gfc_conv_descriptor_span_get (desc);
8461 : else
8462 57895 : tmp = gfc_get_array_span (desc, expr);
8463 65624 : if (tmp)
8464 65544 : gfc_conv_descriptor_span_set (&loop.pre, parm, tmp);
8465 :
8466 : /* The following can be somewhat confusing. We have two
8467 : descriptors, a new one and the original array.
8468 : {parm, parmtype, dim} refer to the new one.
8469 : {desc, type, n, loop} refer to the original, which maybe
8470 : a descriptorless array.
8471 : The bounds of the scalarization are the bounds of the section.
8472 : We don't have to worry about numeric overflows when calculating
8473 : the offsets because all elements are within the array data. */
8474 :
8475 : /* Set the dtype. */
8476 65624 : tmp = gfc_conv_descriptor_dtype (parm);
8477 65624 : if (se->unlimited_polymorphic)
8478 649 : dtype = gfc_get_dtype (TREE_TYPE (desc), &loop.dimen);
8479 64975 : else if (expr->ts.type == BT_ASSUMED)
8480 : {
8481 127 : tree tmp2 = desc;
8482 127 : if (DECL_LANG_SPECIFIC (tmp2) && GFC_DECL_SAVED_DESCRIPTOR (tmp2))
8483 127 : tmp2 = GFC_DECL_SAVED_DESCRIPTOR (tmp2);
8484 127 : if (POINTER_TYPE_P (TREE_TYPE (tmp2)))
8485 127 : tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
8486 127 : dtype = gfc_conv_descriptor_dtype (tmp2);
8487 : }
8488 : else
8489 64848 : dtype = gfc_get_dtype (parmtype);
8490 65624 : gfc_add_modify (&loop.pre, tmp, dtype);
8491 :
8492 : /* The 1st element in the section. */
8493 65624 : base = gfc_index_zero_node;
8494 65624 : if (expr->ts.type == BT_CHARACTER && expr->rank == 0 && codim)
8495 6 : base = gfc_index_one_node;
8496 :
8497 : /* The offset from the 1st element in the section. */
8498 : offset = gfc_index_zero_node;
8499 :
8500 168424 : for (n = 0; n < ndim; n++)
8501 : {
8502 102800 : stride = gfc_conv_array_stride (desc, n);
8503 :
8504 : /* Work out the 1st element in the section. */
8505 102800 : if (info->ref
8506 95062 : && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
8507 : {
8508 1265 : gcc_assert (info->subscript[n]
8509 : && info->subscript[n]->info->type == GFC_SS_SCALAR);
8510 1265 : start = info->subscript[n]->info->data.scalar.value;
8511 : }
8512 : else
8513 : {
8514 : /* Evaluate and remember the start of the section. */
8515 101535 : start = info->start[n];
8516 101535 : stride = gfc_evaluate_now (stride, &loop.pre);
8517 : }
8518 :
8519 102800 : tmp = gfc_conv_array_lbound (desc, n);
8520 102800 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
8521 : start, tmp);
8522 102800 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
8523 : tmp, stride);
8524 102800 : base = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
8525 : base, tmp);
8526 :
8527 102800 : if (info->ref
8528 95062 : && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
8529 : {
8530 : /* For elemental dimensions, we only need the 1st
8531 : element in the section. */
8532 1265 : continue;
8533 : }
8534 :
8535 : /* Vector subscripts need copying and are handled elsewhere. */
8536 101535 : if (info->ref)
8537 93797 : gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
8538 :
8539 : /* look for the corresponding scalarizer dimension: dim. */
8540 152336 : for (dim = 0; dim < ndim; dim++)
8541 152336 : if (ss->dim[dim] == n)
8542 : break;
8543 :
8544 : /* loop exited early: the DIM being looked for has been found. */
8545 101535 : gcc_assert (dim < ndim);
8546 :
8547 : /* Set the new lower bound. */
8548 101535 : from = loop.from[dim];
8549 101535 : to = loop.to[dim];
8550 :
8551 101535 : gfc_conv_descriptor_lbound_set (&loop.pre, parm,
8552 : gfc_rank_cst[dim], from);
8553 :
8554 : /* Set the new upper bound. */
8555 101535 : gfc_conv_descriptor_ubound_set (&loop.pre, parm,
8556 : gfc_rank_cst[dim], to);
8557 :
8558 : /* Multiply the stride by the section stride to get the
8559 : total stride. */
8560 101535 : stride = fold_build2_loc (input_location, MULT_EXPR,
8561 : gfc_array_index_type,
8562 : stride, info->stride[n]);
8563 :
8564 101535 : tmp = fold_build2_loc (input_location, MULT_EXPR,
8565 101535 : TREE_TYPE (offset), stride, from);
8566 101535 : offset = fold_build2_loc (input_location, MINUS_EXPR,
8567 101535 : TREE_TYPE (offset), offset, tmp);
8568 :
8569 : /* Store the new stride. */
8570 101535 : gfc_conv_descriptor_stride_set (&loop.pre, parm,
8571 : gfc_rank_cst[dim], stride);
8572 : }
8573 :
8574 : /* For deferred-length character we need to take the dynamic length
8575 : into account for the dataptr offset. */
8576 65624 : if (expr->ts.type == BT_CHARACTER
8577 11548 : && expr->ts.deferred
8578 223 : && expr->ts.u.cl->backend_decl
8579 223 : && VAR_P (expr->ts.u.cl->backend_decl))
8580 : {
8581 156 : tree base_type = TREE_TYPE (base);
8582 156 : base = fold_build2_loc (input_location, MULT_EXPR, base_type, base,
8583 : fold_convert (base_type,
8584 : expr->ts.u.cl->backend_decl));
8585 : }
8586 :
8587 67136 : for (n = loop.dimen; n < loop.dimen + codim; n++)
8588 : {
8589 1512 : from = loop.from[n];
8590 1512 : to = loop.to[n];
8591 1512 : gfc_conv_descriptor_lbound_set (&loop.pre, parm,
8592 : gfc_rank_cst[n], from);
8593 1512 : if (n < loop.dimen + codim - 1)
8594 818 : gfc_conv_descriptor_ubound_set (&loop.pre, parm,
8595 : gfc_rank_cst[n], to);
8596 : }
8597 :
8598 65624 : if (se->data_not_needed)
8599 6152 : gfc_conv_descriptor_data_set (&loop.pre, parm,
8600 : gfc_index_zero_node);
8601 : else
8602 : /* Point the data pointer at the 1st element in the section. */
8603 59472 : gfc_get_dataptr_offset (&loop.pre, parm, desc, base,
8604 : subref_array_target, expr);
8605 :
8606 65624 : gfc_conv_descriptor_offset_set (&loop.pre, parm, offset);
8607 :
8608 65624 : if (flag_coarray == GFC_FCOARRAY_LIB && expr->corank)
8609 : {
8610 404 : tmp = INDIRECT_REF_P (desc) ? TREE_OPERAND (desc, 0) : desc;
8611 404 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
8612 : {
8613 24 : tmp = gfc_conv_descriptor_token (tmp);
8614 : }
8615 380 : else if (DECL_P (tmp) && DECL_LANG_SPECIFIC (tmp)
8616 460 : && GFC_DECL_TOKEN (tmp) != NULL_TREE)
8617 64 : tmp = GFC_DECL_TOKEN (tmp);
8618 : else
8619 : {
8620 316 : tmp = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (tmp));
8621 : }
8622 :
8623 404 : gfc_add_modify (&loop.pre, gfc_conv_descriptor_token (parm), tmp);
8624 : }
8625 : desc = parm;
8626 : }
8627 :
8628 : /* For class arrays add the class tree into the saved descriptor to
8629 : enable getting of _vptr and the like. */
8630 74687 : if (expr->expr_type == EXPR_VARIABLE && VAR_P (desc)
8631 57700 : && IS_CLASS_ARRAY (expr->symtree->n.sym))
8632 : {
8633 1174 : gfc_allocate_lang_decl (desc);
8634 1174 : GFC_DECL_SAVED_DESCRIPTOR (desc) =
8635 1174 : DECL_LANG_SPECIFIC (expr->symtree->n.sym->backend_decl) ?
8636 1088 : GFC_DECL_SAVED_DESCRIPTOR (expr->symtree->n.sym->backend_decl)
8637 : : expr->symtree->n.sym->backend_decl;
8638 : }
8639 73513 : else if (expr->expr_type == EXPR_ARRAY && VAR_P (desc)
8640 10503 : && IS_CLASS_ARRAY (expr))
8641 : {
8642 12 : tree vtype;
8643 12 : gfc_allocate_lang_decl (desc);
8644 12 : tmp = gfc_create_var (expr->ts.u.derived->backend_decl, "class");
8645 12 : GFC_DECL_SAVED_DESCRIPTOR (desc) = tmp;
8646 12 : vtype = gfc_class_vptr_get (tmp);
8647 12 : gfc_add_modify (&se->pre, vtype,
8648 12 : gfc_build_addr_expr (TREE_TYPE (vtype),
8649 12 : gfc_find_vtab (&expr->ts)->backend_decl));
8650 : }
8651 74687 : if (!se->direct_byref || se->byref_noassign)
8652 : {
8653 : /* Get a pointer to the new descriptor. */
8654 72017 : if (se->want_pointer)
8655 40531 : se->expr = gfc_build_addr_expr (NULL_TREE, desc);
8656 : else
8657 31486 : se->expr = desc;
8658 : }
8659 :
8660 74687 : gfc_add_block_to_block (&se->pre, &loop.pre);
8661 74687 : gfc_add_block_to_block (&se->post, &loop.post);
8662 :
8663 : /* Cleanup the scalarizer. */
8664 74687 : gfc_cleanup_loop (&loop);
8665 : }
8666 :
8667 :
8668 : /* Calculate the array size (number of elements); if dim != NULL_TREE,
8669 : return size for that dim (dim=0..rank-1; only for GFC_DESCRIPTOR_TYPE_P).
8670 : If !expr && descriptor array, the rank is taken from the descriptor. */
8671 : tree
8672 15582 : gfc_tree_array_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree dim)
8673 : {
8674 15582 : if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
8675 : {
8676 40 : gcc_assert (dim == NULL_TREE);
8677 40 : return GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
8678 : }
8679 15542 : tree size, tmp, rank = NULL_TREE, cond = NULL_TREE;
8680 15542 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
8681 15542 : enum gfc_array_kind akind = GFC_TYPE_ARRAY_AKIND (TREE_TYPE (desc));
8682 15542 : if (expr == NULL || expr->rank < 0)
8683 3575 : rank = gfc_conv_descriptor_rank (desc);
8684 : else
8685 11967 : rank = gfc_rank_cst[expr->rank];
8686 :
8687 15542 : if (dim || (expr && expr->rank == 1))
8688 : {
8689 4669 : if (dim)
8690 9205 : dim = fold_convert_loc (input_location, gfc_array_dim_rank_type, dim);
8691 : else
8692 4669 : dim = gfc_rank_cst[0];
8693 13874 : tree ubound = gfc_conv_descriptor_ubound_get (desc, dim);
8694 13874 : tree lbound = gfc_conv_descriptor_lbound_get (desc, dim);
8695 :
8696 13874 : size = fold_build2_loc (input_location, MINUS_EXPR,
8697 : gfc_array_index_type, ubound, lbound);
8698 13874 : size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
8699 : size, gfc_index_one_node);
8700 : /* if (!allocatable && !pointer && assumed rank)
8701 : size = (idx == rank && ubound[rank-1] == -1 ? -1 : size;
8702 : else
8703 : size = max (0, size); */
8704 13874 : size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
8705 : size, gfc_index_zero_node);
8706 13874 : if (akind == GFC_ARRAY_ASSUMED_RANK_CONT
8707 13874 : || akind == GFC_ARRAY_ASSUMED_RANK)
8708 : {
8709 2876 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
8710 : gfc_array_dim_rank_type, rank,
8711 : gfc_rank_cst[1]);
8712 2876 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
8713 : dim, tmp);
8714 2876 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
8715 : gfc_conv_descriptor_ubound_get (desc, dim),
8716 : build_int_cst (gfc_array_index_type, -1));
8717 2876 : cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
8718 : cond, tmp);
8719 2876 : tmp = build_int_cst (gfc_array_index_type, -1);
8720 2876 : size = build3_loc (input_location, COND_EXPR, gfc_array_index_type,
8721 : cond, tmp, size);
8722 : }
8723 13874 : return size;
8724 : }
8725 :
8726 : /* size = 1. */
8727 1668 : size = gfc_create_var (gfc_array_index_type, "size");
8728 1668 : gfc_add_modify (block, size, build_int_cst (TREE_TYPE (size), 1));
8729 1668 : tree extent = gfc_create_var (gfc_array_index_type, "extent");
8730 :
8731 1668 : stmtblock_t cond_block, loop_body;
8732 1668 : gfc_init_block (&cond_block);
8733 1668 : gfc_init_block (&loop_body);
8734 :
8735 : /* Loop: for (i = 0; i < rank; ++i). */
8736 1668 : tree idx = gfc_create_var (gfc_array_dim_rank_type, "idx");
8737 : /* Loop body. */
8738 : /* #if (assumed-rank + !allocatable && !pointer)
8739 : if (idx + 1 == rank && dim[idx].ubound == -1)
8740 : extent = -1;
8741 : else
8742 : #endif
8743 : extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1
8744 : if (extent < 0)
8745 : extent = 0
8746 : size *= extent. */
8747 1668 : cond = NULL_TREE;
8748 1668 : if (akind == GFC_ARRAY_ASSUMED_RANK_CONT || akind == GFC_ARRAY_ASSUMED_RANK)
8749 : {
8750 471 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
8751 : gfc_array_dim_rank_type, idx, gfc_rank_cst[1]);
8752 471 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
8753 : tmp, rank);
8754 471 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
8755 : gfc_conv_descriptor_ubound_get (desc, idx),
8756 : build_int_cst (gfc_array_index_type, -1));
8757 471 : cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
8758 : cond, tmp);
8759 : }
8760 1668 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8761 : gfc_conv_descriptor_ubound_get (desc, idx),
8762 : gfc_conv_descriptor_lbound_get (desc, idx));
8763 1668 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
8764 : tmp, gfc_index_one_node);
8765 1668 : gfc_add_modify (&cond_block, extent, tmp);
8766 1668 : tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
8767 : extent, gfc_index_zero_node);
8768 1668 : tmp = build3_v (COND_EXPR, tmp,
8769 : fold_build2_loc (input_location, MODIFY_EXPR,
8770 : gfc_array_index_type,
8771 : extent, gfc_index_zero_node),
8772 : build_empty_stmt (input_location));
8773 1668 : gfc_add_expr_to_block (&cond_block, tmp);
8774 1668 : tmp = gfc_finish_block (&cond_block);
8775 1668 : if (cond)
8776 471 : tmp = build3_v (COND_EXPR, cond,
8777 : fold_build2_loc (input_location, MODIFY_EXPR,
8778 : gfc_array_index_type, extent,
8779 : build_int_cst (gfc_array_index_type, -1)),
8780 : tmp);
8781 1668 : gfc_add_expr_to_block (&loop_body, tmp);
8782 : /* size *= extent. */
8783 1668 : gfc_add_modify (&loop_body, size,
8784 : fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
8785 : size, extent));
8786 : /* Generate loop. */
8787 3336 : gfc_simple_for_loop (block, idx, build_int_cst (TREE_TYPE (idx), 0), rank, LT_EXPR,
8788 1668 : build_int_cst (TREE_TYPE (idx), 1),
8789 : gfc_finish_block (&loop_body));
8790 1668 : return size;
8791 : }
8792 :
8793 : /* Helper function for gfc_conv_array_parameter if array size needs to be
8794 : computed. */
8795 :
8796 : static void
8797 142 : array_parameter_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree *size)
8798 : {
8799 142 : tree elem;
8800 142 : *size = gfc_tree_array_size (block, desc, expr, NULL);
8801 142 : elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
8802 142 : *size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
8803 : *size, fold_convert (gfc_array_index_type, elem));
8804 142 : }
8805 :
8806 : /* Helper function - return true if the argument is a pointer. */
8807 :
8808 : static bool
8809 712 : is_pointer (gfc_expr *e)
8810 : {
8811 712 : gfc_symbol *sym;
8812 :
8813 712 : if (e->expr_type != EXPR_VARIABLE || e->symtree == NULL)
8814 : return false;
8815 :
8816 712 : sym = e->symtree->n.sym;
8817 712 : if (sym == NULL)
8818 : return false;
8819 :
8820 712 : return sym->attr.pointer || sym->attr.proc_pointer;
8821 : }
8822 :
8823 : /* Assumed-rank actual argument: the caller only allocates storage for dtype
8824 : rank dimensions. Copying GFC_MAX_DIMENSIONS dim entries would read past the
8825 : physical end of the descriptor. Copy the header fields explicitly and use a
8826 : runtime-sized memcpy for the dim[] entries. */
8827 : void
8828 78 : gfc_resize_assumed_rank_dim_field (gfc_se *se, stmtblock_t *block, tree desc)
8829 : {
8830 78 : tree rank, dim_field, dim_size, copy_size, dst_ptr, src_ptr;
8831 :
8832 78 : gfc_conv_descriptor_data_set (block, desc,
8833 : gfc_conv_descriptor_data_get (se->expr));
8834 78 : gfc_conv_descriptor_offset_set (block, desc,
8835 : gfc_conv_descriptor_offset_get (se->expr));
8836 78 : gfc_add_modify (block, gfc_conv_descriptor_dtype (desc),
8837 : gfc_conv_descriptor_dtype (se->expr));
8838 78 : rank = fold_convert (size_type_node, gfc_conv_descriptor_rank (se->expr));
8839 78 : dim_field = gfc_get_descriptor_dimension (se->expr);
8840 78 : dim_size = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (dim_field)));
8841 78 : copy_size = fold_build2_loc (input_location, MULT_EXPR,
8842 : size_type_node, rank, dim_size);
8843 78 : dst_ptr = gfc_build_addr_expr (pvoid_type_node,
8844 : gfc_get_descriptor_dimension (desc));
8845 78 : src_ptr = gfc_build_addr_expr (pvoid_type_node, dim_field);
8846 78 : gfc_add_expr_to_block (block, build_call_expr_loc (input_location,
8847 : builtin_decl_explicit (BUILT_IN_MEMCPY),
8848 : 3, dst_ptr, src_ptr, copy_size));
8849 78 : }
8850 :
8851 : /* Convert an array for passing as an actual parameter. */
8852 :
8853 : void
8854 66378 : gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr, bool g77,
8855 : const gfc_symbol *fsym, const char *proc_name,
8856 : tree *size, tree *lbshift, tree *packed)
8857 : {
8858 66378 : tree ptr;
8859 66378 : tree desc;
8860 66378 : tree tmp = NULL_TREE;
8861 66378 : tree stmt;
8862 66378 : tree parent = DECL_CONTEXT (current_function_decl);
8863 66378 : tree ctree;
8864 66378 : tree pack_attr = NULL_TREE; /* Set when packing class arrays. */
8865 66378 : bool full_array_var;
8866 66378 : bool this_array_result;
8867 66378 : bool contiguous;
8868 66378 : bool no_pack;
8869 66378 : bool array_constructor;
8870 66378 : bool good_allocatable;
8871 66378 : bool ultimate_ptr_comp;
8872 66378 : bool ultimate_alloc_comp;
8873 66378 : bool readonly;
8874 66378 : gfc_symbol *sym;
8875 66378 : stmtblock_t block;
8876 66378 : gfc_ref *ref;
8877 :
8878 66378 : ultimate_ptr_comp = false;
8879 66378 : ultimate_alloc_comp = false;
8880 :
8881 67123 : for (ref = expr->ref; ref; ref = ref->next)
8882 : {
8883 55519 : if (ref->next == NULL)
8884 : break;
8885 :
8886 745 : if (ref->type == REF_COMPONENT)
8887 : {
8888 661 : ultimate_ptr_comp = ref->u.c.component->attr.pointer;
8889 661 : ultimate_alloc_comp = ref->u.c.component->attr.allocatable;
8890 : }
8891 : }
8892 :
8893 66378 : full_array_var = false;
8894 66378 : contiguous = false;
8895 :
8896 66378 : if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp)
8897 54691 : full_array_var = gfc_full_array_ref_p (ref, &contiguous);
8898 :
8899 54691 : sym = full_array_var ? expr->symtree->n.sym : NULL;
8900 :
8901 : /* The symbol should have an array specification. */
8902 63420 : gcc_assert (!sym || sym->as || ref->u.ar.as);
8903 :
8904 66378 : if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
8905 : {
8906 708 : get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
8907 708 : expr->ts.u.cl->backend_decl = tmp;
8908 708 : se->string_length = tmp;
8909 : }
8910 :
8911 : /* Is this the result of the enclosing procedure? */
8912 66378 : this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
8913 58 : if (this_array_result
8914 58 : && (sym->backend_decl != current_function_decl)
8915 0 : && (sym->backend_decl != parent))
8916 66378 : this_array_result = false;
8917 :
8918 : /* Passing an optional dummy argument as actual to an optional dummy? */
8919 66378 : bool pass_optional;
8920 66378 : pass_optional = fsym && fsym->attr.optional && sym && sym->attr.optional;
8921 :
8922 : /* Passing address of the array if it is not pointer or assumed-shape. */
8923 66378 : if (full_array_var && g77 && !this_array_result
8924 16092 : && sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
8925 : {
8926 12515 : tmp = gfc_get_symbol_decl (sym);
8927 :
8928 12515 : if (sym->ts.type == BT_CHARACTER)
8929 2809 : se->string_length = sym->ts.u.cl->backend_decl;
8930 :
8931 12515 : if (!sym->attr.pointer
8932 12024 : && sym->as
8933 12024 : && sym->as->type != AS_ASSUMED_SHAPE
8934 11779 : && sym->as->type != AS_DEFERRED
8935 10283 : && sym->as->type != AS_ASSUMED_RANK
8936 10207 : && !sym->attr.allocatable)
8937 : {
8938 : /* Some variables are declared directly, others are declared as
8939 : pointers and allocated on the heap. */
8940 9701 : if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
8941 2515 : se->expr = tmp;
8942 : else
8943 7186 : se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
8944 9701 : if (size)
8945 40 : array_parameter_size (&se->pre, tmp, expr, size);
8946 16989 : return;
8947 : }
8948 :
8949 2814 : if (sym->attr.allocatable)
8950 : {
8951 1882 : if (sym->attr.dummy || sym->attr.result)
8952 : {
8953 1176 : gfc_conv_expr_descriptor (se, expr);
8954 1176 : tmp = se->expr;
8955 : }
8956 1882 : if (size)
8957 14 : array_parameter_size (&se->pre, tmp, expr, size);
8958 1882 : se->expr = gfc_conv_array_data (tmp);
8959 1882 : if (pass_optional)
8960 : {
8961 18 : tree cond = gfc_conv_expr_present (sym);
8962 36 : se->expr = build3_loc (input_location, COND_EXPR,
8963 18 : TREE_TYPE (se->expr), cond, se->expr,
8964 18 : fold_convert (TREE_TYPE (se->expr),
8965 : null_pointer_node));
8966 : }
8967 1882 : return;
8968 : }
8969 : }
8970 :
8971 : /* A convenient reduction in scope. */
8972 54795 : contiguous = g77 && !this_array_result && contiguous;
8973 :
8974 : /* There is no need to pack and unpack the array, if it is contiguous
8975 : and not a deferred- or assumed-shape array, or if it is simply
8976 : contiguous. */
8977 54795 : no_pack = false;
8978 : // clang-format off
8979 54795 : if (sym)
8980 : {
8981 40231 : symbol_attribute *attr = &(IS_CLASS_ARRAY (sym)
8982 : ? CLASS_DATA (sym)->attr : sym->attr);
8983 40231 : gfc_array_spec *as = IS_CLASS_ARRAY (sym)
8984 40231 : ? CLASS_DATA (sym)->as : sym->as;
8985 40231 : no_pack = (as
8986 39941 : && !attr->pointer
8987 36681 : && as->type != AS_DEFERRED
8988 27003 : && as->type != AS_ASSUMED_RANK
8989 64080 : && as->type != AS_ASSUMED_SHAPE);
8990 : }
8991 54795 : if (ref && ref->u.ar.as)
8992 43189 : no_pack = no_pack
8993 43189 : || (ref->u.ar.as->type != AS_DEFERRED
8994 : && ref->u.ar.as->type != AS_ASSUMED_RANK
8995 : && ref->u.ar.as->type != AS_ASSUMED_SHAPE);
8996 109590 : no_pack = contiguous
8997 54795 : && (no_pack || gfc_is_simply_contiguous (expr, false, true));
8998 : // clang-format on
8999 :
9000 : /* If we have an EXPR_OP or a function returning an explicit-shaped
9001 : or allocatable array, an array temporary will be generated which
9002 : does not need to be packed / unpacked if passed to an
9003 : explicit-shape dummy array. */
9004 :
9005 54795 : if (g77)
9006 : {
9007 6453 : if (expr->expr_type == EXPR_OP)
9008 : no_pack = 1;
9009 6376 : else if (expr->expr_type == EXPR_FUNCTION && expr->value.function.esym)
9010 : {
9011 41 : gfc_symbol *result = expr->value.function.esym->result;
9012 41 : if (result->attr.dimension
9013 41 : && (result->as->type == AS_EXPLICIT
9014 14 : || result->attr.allocatable
9015 7 : || result->attr.contiguous))
9016 112 : no_pack = 1;
9017 : }
9018 : }
9019 :
9020 : /* Array constructors are always contiguous and do not need packing. */
9021 54795 : array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY;
9022 :
9023 : /* Same is true of contiguous sections from allocatable variables. */
9024 109590 : good_allocatable = contiguous
9025 4644 : && expr->symtree
9026 59439 : && expr->symtree->n.sym->attr.allocatable;
9027 :
9028 : /* Or ultimate allocatable components. */
9029 54795 : ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
9030 :
9031 54795 : if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp)
9032 : {
9033 5027 : gfc_conv_expr_descriptor (se, expr);
9034 : /* Deallocate the allocatable components of structures that are
9035 : not variable. */
9036 5027 : if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
9037 3486 : && expr->ts.u.derived->attr.alloc_comp
9038 2083 : && expr->expr_type != EXPR_VARIABLE)
9039 : {
9040 2 : tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, se->expr, expr->rank);
9041 :
9042 : /* The components shall be deallocated before their containing entity. */
9043 2 : gfc_prepend_expr_to_block (&se->post, tmp);
9044 : }
9045 5027 : if (expr->ts.type == BT_CHARACTER && expr->expr_type != EXPR_FUNCTION)
9046 309 : se->string_length = expr->ts.u.cl->backend_decl;
9047 5027 : if (size)
9048 58 : array_parameter_size (&se->pre, se->expr, expr, size);
9049 5027 : se->expr = gfc_conv_array_data (se->expr);
9050 5027 : return;
9051 : }
9052 :
9053 49768 : if (fsym && fsym->ts.type == BT_CLASS)
9054 : {
9055 1254 : gcc_assert (se->expr);
9056 : ctree = se->expr;
9057 : }
9058 : else
9059 : ctree = NULL_TREE;
9060 :
9061 49768 : if (this_array_result)
9062 : {
9063 : /* Result of the enclosing function. */
9064 58 : gfc_conv_expr_descriptor (se, expr);
9065 58 : if (size)
9066 0 : array_parameter_size (&se->pre, se->expr, expr, size);
9067 58 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
9068 :
9069 18 : if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
9070 76 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
9071 18 : se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location,
9072 : se->expr));
9073 :
9074 58 : return;
9075 : }
9076 : else
9077 : {
9078 : /* Every other type of array. */
9079 49710 : se->want_pointer = (ctree) ? 0 : 1;
9080 49710 : se->want_coarray = expr->corank;
9081 49710 : gfc_conv_expr_descriptor (se, expr);
9082 :
9083 49710 : if (size)
9084 30 : array_parameter_size (&se->pre,
9085 : build_fold_indirect_ref_loc (input_location,
9086 : se->expr),
9087 : expr, size);
9088 49710 : if (ctree)
9089 : {
9090 1254 : stmtblock_t block;
9091 :
9092 1254 : gfc_init_block (&block);
9093 1254 : if (lbshift && *lbshift)
9094 : {
9095 : /* Apply a shift of the lbound when supplied. */
9096 98 : for (int dim = 0; dim < expr->rank; ++dim)
9097 49 : gfc_conv_shift_descriptor_lbound (&block, se->expr, dim,
9098 : *lbshift);
9099 : }
9100 1254 : tmp = gfc_class_data_get (ctree);
9101 1254 : if (expr->rank > 1 && CLASS_DATA (fsym)->as->rank != expr->rank
9102 84 : && CLASS_DATA (fsym)->as->type == AS_EXPLICIT && !no_pack)
9103 : {
9104 36 : tree arr = gfc_create_var (TREE_TYPE (tmp), "parm");
9105 36 : gfc_conv_descriptor_data_set (&block, arr,
9106 : gfc_conv_descriptor_data_get (
9107 : se->expr));
9108 36 : gfc_conv_descriptor_lbound_set (&block, arr, gfc_index_zero_node,
9109 : gfc_index_zero_node);
9110 36 : gfc_conv_descriptor_ubound_set (
9111 : &block, arr, gfc_index_zero_node,
9112 : gfc_conv_descriptor_size (se->expr, expr->rank));
9113 36 : gfc_conv_descriptor_stride_set (
9114 : &block, arr, gfc_index_zero_node,
9115 : gfc_conv_descriptor_stride_get (se->expr, gfc_index_zero_node));
9116 36 : gfc_add_modify (&block, gfc_conv_descriptor_dtype (arr),
9117 : gfc_conv_descriptor_dtype (se->expr));
9118 36 : gfc_add_modify (&block, gfc_conv_descriptor_rank (arr),
9119 : gfc_rank_cst[1]);
9120 36 : gfc_conv_descriptor_span_set (&block, arr,
9121 : gfc_conv_descriptor_span_get (arr));
9122 36 : gfc_conv_descriptor_offset_set (&block, arr, gfc_index_zero_node);
9123 36 : se->expr = arr;
9124 : }
9125 1254 : if (expr->rank == -1)
9126 78 : gfc_resize_assumed_rank_dim_field (se, &block, tmp);
9127 1176 : else if (CLASS_DATA (fsym)->as->rank == -1)
9128 397 : gfc_class_array_data_assign (&block, tmp, se->expr, false);
9129 : else
9130 779 : gfc_class_array_data_assign (&block, tmp, se->expr, true);
9131 :
9132 : /* Handle optional. */
9133 1254 : if (fsym && fsym->attr.optional && sym && sym->attr.optional)
9134 348 : tmp = build3_v (COND_EXPR, gfc_conv_expr_present (sym),
9135 : gfc_finish_block (&block),
9136 : build_empty_stmt (input_location));
9137 : else
9138 906 : tmp = gfc_finish_block (&block);
9139 :
9140 1254 : gfc_add_expr_to_block (&se->pre, tmp);
9141 : }
9142 48456 : else if (pass_optional && full_array_var && sym->as && sym->as->rank != 0)
9143 : {
9144 : /* Perform calculation of bounds and strides of optional array dummy
9145 : only if the argument is present. */
9146 219 : tmp = build3_v (COND_EXPR, gfc_conv_expr_present (sym),
9147 : gfc_finish_block (&se->pre),
9148 : build_empty_stmt (input_location));
9149 219 : gfc_add_expr_to_block (&se->pre, tmp);
9150 : }
9151 : }
9152 :
9153 : /* Deallocate the allocatable components of structures that are
9154 : not variable, for descriptorless arguments.
9155 : Arguments with a descriptor are handled in gfc_conv_procedure_call. */
9156 49710 : if (g77 && (expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
9157 72 : && expr->ts.u.derived->attr.alloc_comp
9158 18 : && expr->expr_type != EXPR_VARIABLE)
9159 : {
9160 0 : tmp = build_fold_indirect_ref_loc (input_location, se->expr);
9161 0 : tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank);
9162 :
9163 : /* The components shall be deallocated before their containing entity. */
9164 0 : gfc_prepend_expr_to_block (&se->post, tmp);
9165 : }
9166 :
9167 48302 : if (g77 || (fsym && fsym->attr.contiguous
9168 1585 : && !gfc_is_simply_contiguous (expr, false, true)))
9169 : {
9170 1588 : tree origptr = NULL_TREE, packedptr = NULL_TREE;
9171 :
9172 1588 : desc = se->expr;
9173 :
9174 : /* For contiguous arrays, save the original value of the descriptor. */
9175 1588 : if (!g77 && !ctree)
9176 : {
9177 84 : origptr = gfc_create_var (pvoid_type_node, "origptr");
9178 84 : tmp = build_fold_indirect_ref_loc (input_location, desc);
9179 84 : tmp = gfc_conv_array_data (tmp);
9180 168 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
9181 84 : TREE_TYPE (origptr), origptr,
9182 84 : fold_convert (TREE_TYPE (origptr), tmp));
9183 84 : gfc_add_expr_to_block (&se->pre, tmp);
9184 : }
9185 :
9186 : /* Repack the array. */
9187 1588 : if (warn_array_temporaries)
9188 : {
9189 28 : if (fsym)
9190 18 : gfc_warning (OPT_Warray_temporaries,
9191 : "Creating array temporary at %L for argument %qs",
9192 18 : &expr->where, fsym->name);
9193 : else
9194 10 : gfc_warning (OPT_Warray_temporaries,
9195 : "Creating array temporary at %L", &expr->where);
9196 : }
9197 :
9198 : /* When optimizing, we can use gfc_conv_subref_array_arg for
9199 : making the packing and unpacking operation visible to the
9200 : optimizers. */
9201 :
9202 1408 : if (g77 && flag_inline_arg_packing && expr->expr_type == EXPR_VARIABLE
9203 712 : && !is_pointer (expr) && ! gfc_has_dimen_vector_ref (expr)
9204 342 : && !(expr->symtree->n.sym->as
9205 324 : && expr->symtree->n.sym->as->type == AS_ASSUMED_RANK)
9206 1930 : && (fsym == NULL || fsym->ts.type != BT_ASSUMED))
9207 : {
9208 321 : gfc_conv_subref_array_arg (se, expr, g77,
9209 145 : fsym ? fsym->attr.intent : INTENT_INOUT,
9210 : false, fsym, proc_name, sym, true);
9211 321 : return;
9212 : }
9213 :
9214 1267 : if (ctree)
9215 : {
9216 96 : packedptr
9217 96 : = gfc_build_addr_expr (NULL_TREE, gfc_create_var (TREE_TYPE (ctree),
9218 : "packed"));
9219 96 : if (fsym)
9220 : {
9221 96 : int pack_mask = 0;
9222 :
9223 : /* Set bit 0 to the mask, when this is an unlimited_poly
9224 : class. */
9225 96 : if (CLASS_DATA (fsym)->ts.u.derived->attr.unlimited_polymorphic)
9226 36 : pack_mask = 1 << 0;
9227 96 : pack_attr = build_int_cst (integer_type_node, pack_mask);
9228 : }
9229 : else
9230 0 : pack_attr = integer_zero_node;
9231 :
9232 96 : gfc_add_expr_to_block (
9233 : &se->pre,
9234 : build_call_expr_loc (input_location, gfor_fndecl_in_pack_class, 4,
9235 : packedptr,
9236 : gfc_build_addr_expr (NULL_TREE, ctree),
9237 96 : size_in_bytes (TREE_TYPE (ctree)), pack_attr));
9238 96 : ptr = gfc_conv_array_data (gfc_class_data_get (packedptr));
9239 96 : se->expr = packedptr;
9240 96 : if (packed)
9241 96 : *packed = packedptr;
9242 : }
9243 : else
9244 : {
9245 1171 : ptr = build_call_expr_loc (input_location, gfor_fndecl_in_pack, 1,
9246 : desc);
9247 :
9248 1171 : if (fsym && fsym->attr.optional && sym && sym->attr.optional)
9249 : {
9250 11 : tmp = gfc_conv_expr_present (sym);
9251 22 : ptr = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
9252 11 : tmp, fold_convert (TREE_TYPE (se->expr), ptr),
9253 11 : fold_convert (TREE_TYPE (se->expr),
9254 : null_pointer_node));
9255 : }
9256 :
9257 1171 : ptr = gfc_evaluate_now (ptr, &se->pre);
9258 : }
9259 :
9260 : /* Use the packed data for the actual argument, except for contiguous arrays,
9261 : where the descriptor's data component is set. */
9262 1267 : if (g77)
9263 1087 : se->expr = ptr;
9264 : else
9265 : {
9266 180 : tmp = build_fold_indirect_ref_loc (input_location, desc);
9267 :
9268 180 : if (!ctree)
9269 : {
9270 : /* The original descriptor may have transposed dims so we
9271 : can't reuse it directly; we have to create a new one. */
9272 84 : tree old_field, new_field;
9273 84 : tree old_desc = tmp;
9274 84 : tree new_desc = gfc_create_var (TREE_TYPE (old_desc), "arg_desc");
9275 :
9276 84 : old_field = gfc_conv_descriptor_dtype (old_desc);
9277 84 : new_field = gfc_conv_descriptor_dtype (new_desc);
9278 84 : gfc_add_modify (&se->pre, new_field, old_field);
9279 :
9280 84 : if (expr->rank == -1)
9281 : {
9282 12 : tree idx = gfc_create_var (gfc_array_dim_rank_type, "idx");
9283 12 : tree stride = gfc_create_var (gfc_array_index_type, "stride");
9284 12 : stmtblock_t loop_body;
9285 :
9286 12 : gfc_conv_descriptor_offset_set (&se->pre, new_desc,
9287 : gfc_index_zero_node);
9288 12 : gfc_conv_descriptor_span_set (&se->pre, new_desc,
9289 : gfc_conv_descriptor_span_get
9290 : (old_desc));
9291 12 : gfc_add_modify (&se->pre, stride, gfc_index_one_node);
9292 :
9293 12 : gfc_init_block (&loop_body);
9294 :
9295 12 : old_field = gfc_conv_descriptor_lbound_get (old_desc, idx);
9296 12 : gfc_conv_descriptor_lbound_set (&loop_body, new_desc, idx,
9297 : old_field);
9298 :
9299 12 : old_field = gfc_conv_descriptor_ubound_get (old_desc, idx);
9300 12 : gfc_conv_descriptor_ubound_set (&loop_body, new_desc, idx,
9301 : old_field);
9302 :
9303 12 : gfc_conv_descriptor_stride_set (&loop_body, new_desc, idx,
9304 : stride);
9305 :
9306 12 : tree offset = fold_build2_loc (input_location, MULT_EXPR,
9307 : gfc_array_index_type, stride,
9308 : gfc_conv_descriptor_lbound_get
9309 : (new_desc, idx));
9310 12 : offset = fold_build2_loc (input_location, MINUS_EXPR,
9311 : gfc_array_index_type,
9312 : gfc_conv_descriptor_offset_get
9313 : (new_desc), offset);
9314 12 : gfc_conv_descriptor_offset_set (&loop_body, new_desc, offset);
9315 :
9316 12 : tree extent = gfc_conv_array_extent_dim
9317 12 : (gfc_conv_descriptor_lbound_get (new_desc, idx),
9318 : gfc_conv_descriptor_ubound_get (new_desc, idx),
9319 : NULL);
9320 12 : extent = fold_build2_loc (input_location, MULT_EXPR,
9321 : gfc_array_index_type, stride,
9322 : extent);
9323 12 : gfc_add_modify (&loop_body, stride, extent);
9324 :
9325 36 : gfc_simple_for_loop (&se->pre, idx,
9326 12 : build_int_cst (TREE_TYPE (idx), 0),
9327 : gfc_conv_descriptor_rank (old_desc),
9328 : LT_EXPR,
9329 12 : build_int_cst (TREE_TYPE (idx), 1),
9330 : gfc_finish_block (&loop_body));
9331 : }
9332 : else
9333 : {
9334 72 : tree offset = gfc_index_zero_node;
9335 :
9336 72 : tree stride = gfc_index_one_node;
9337 :
9338 102 : for (int i = 0; i < expr->rank; i++)
9339 : {
9340 102 : tree dim = gfc_rank_cst[i];
9341 :
9342 102 : tree lbound = gfc_conv_descriptor_lbound_get (old_desc,
9343 : dim);
9344 102 : lbound = gfc_evaluate_now (lbound, &se->pre);
9345 102 : gfc_conv_descriptor_lbound_set (&se->pre, new_desc, dim,
9346 : lbound);
9347 :
9348 102 : tree ubound = gfc_conv_descriptor_ubound_get (old_desc,
9349 : dim);
9350 102 : ubound = gfc_evaluate_now (ubound, &se->pre);
9351 102 : gfc_conv_descriptor_ubound_set (&se->pre, new_desc, dim,
9352 : ubound);
9353 :
9354 102 : gfc_conv_descriptor_stride_set (&se->pre, new_desc, dim,
9355 : stride);
9356 :
9357 102 : tree tmp = fold_build2_loc (input_location, MULT_EXPR,
9358 : gfc_array_index_type,
9359 : stride, lbound);
9360 102 : offset = fold_build2_loc (input_location, MINUS_EXPR,
9361 : gfc_array_index_type,
9362 : offset, tmp);
9363 102 : offset = gfc_evaluate_now (offset, &se->pre);
9364 :
9365 : /* Now calculate the stride for next dimension, unless the
9366 : current dimension is the last one. */
9367 102 : if (i == expr->rank - 1)
9368 : break;
9369 :
9370 30 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
9371 : gfc_array_index_type,
9372 : lbound, gfc_index_one_node);
9373 30 : tree extent = fold_build2_loc (input_location, MINUS_EXPR,
9374 : gfc_array_index_type,
9375 : ubound, tmp);
9376 30 : stride = fold_build2_loc (input_location, MULT_EXPR,
9377 : gfc_array_index_type,
9378 : stride, extent);
9379 30 : stride = gfc_evaluate_now (stride, &se->pre);
9380 : }
9381 :
9382 72 : gfc_conv_descriptor_offset_set (&se->pre, new_desc, offset);
9383 : }
9384 :
9385 84 : if (flag_coarray == GFC_FCOARRAY_LIB
9386 0 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (old_desc))
9387 84 : && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (old_desc))
9388 : == GFC_ARRAY_ALLOCATABLE)
9389 : {
9390 0 : old_field = gfc_conv_descriptor_token (old_desc);
9391 0 : new_field = gfc_conv_descriptor_token (new_desc);
9392 0 : gfc_add_modify (&se->pre, new_field, old_field);
9393 : }
9394 :
9395 84 : gfc_conv_descriptor_data_set (&se->pre, new_desc, ptr);
9396 84 : se->expr = gfc_build_addr_expr (NULL_TREE, new_desc);
9397 : }
9398 : }
9399 :
9400 1267 : if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
9401 : {
9402 8 : char * msg;
9403 :
9404 8 : if (fsym && proc_name)
9405 8 : msg = xasprintf ("An array temporary was created for argument "
9406 8 : "'%s' of procedure '%s'", fsym->name, proc_name);
9407 : else
9408 0 : msg = xasprintf ("An array temporary was created");
9409 :
9410 8 : tmp = build_fold_indirect_ref_loc (input_location,
9411 : desc);
9412 8 : tmp = gfc_conv_array_data (tmp);
9413 8 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9414 8 : fold_convert (TREE_TYPE (tmp), ptr), tmp);
9415 :
9416 8 : if (pass_optional)
9417 6 : tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
9418 : logical_type_node,
9419 : gfc_conv_expr_present (sym), tmp);
9420 :
9421 8 : gfc_trans_runtime_check (false, true, tmp, &se->pre,
9422 : &expr->where, msg);
9423 8 : free (msg);
9424 : }
9425 :
9426 1267 : gfc_start_block (&block);
9427 :
9428 : /* Copy the data back. If input expr is read-only, e.g. a PARAMETER
9429 : array, copying back modified values is undefined behavior. */
9430 2534 : readonly = (expr->expr_type == EXPR_VARIABLE
9431 856 : && expr->symtree
9432 2123 : && expr->symtree->n.sym->attr.flavor == FL_PARAMETER);
9433 :
9434 1267 : if ((fsym == NULL || fsym->attr.intent != INTENT_IN) && !readonly)
9435 : {
9436 1110 : if (ctree)
9437 : {
9438 66 : tmp = gfc_build_addr_expr (NULL_TREE, ctree);
9439 66 : tmp = build_call_expr_loc (input_location,
9440 : gfor_fndecl_in_unpack_class, 4, tmp,
9441 : packedptr,
9442 66 : size_in_bytes (TREE_TYPE (ctree)),
9443 : pack_attr);
9444 : }
9445 : else
9446 1044 : tmp = build_call_expr_loc (input_location, gfor_fndecl_in_unpack, 2,
9447 : desc, ptr);
9448 1110 : gfc_add_expr_to_block (&block, tmp);
9449 : }
9450 157 : else if (ctree && fsym->attr.intent == INTENT_IN)
9451 : {
9452 : /* Need to free the memory for class arrays, that got packed. */
9453 30 : gfc_add_expr_to_block (&block, gfc_call_free (ptr));
9454 : }
9455 :
9456 : /* Free the temporary. */
9457 1140 : if (!ctree)
9458 1171 : gfc_add_expr_to_block (&block, gfc_call_free (ptr));
9459 :
9460 1267 : stmt = gfc_finish_block (&block);
9461 :
9462 1267 : gfc_init_block (&block);
9463 : /* Only if it was repacked. This code needs to be executed before the
9464 : loop cleanup code. */
9465 1267 : tmp = (ctree) ? desc : build_fold_indirect_ref_loc (input_location, desc);
9466 1267 : tmp = gfc_conv_array_data (tmp);
9467 1267 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9468 1267 : fold_convert (TREE_TYPE (tmp), ptr), tmp);
9469 :
9470 1267 : if (pass_optional)
9471 11 : tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
9472 : logical_type_node,
9473 : gfc_conv_expr_present (sym), tmp);
9474 :
9475 1267 : tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
9476 :
9477 1267 : gfc_add_expr_to_block (&block, tmp);
9478 1267 : gfc_add_block_to_block (&block, &se->post);
9479 :
9480 1267 : gfc_init_block (&se->post);
9481 :
9482 : /* Reset the descriptor pointer. */
9483 1267 : if (!g77 && !ctree)
9484 : {
9485 84 : tmp = build_fold_indirect_ref_loc (input_location, desc);
9486 84 : gfc_conv_descriptor_data_set (&se->post, tmp, origptr);
9487 : }
9488 :
9489 1267 : gfc_add_block_to_block (&se->post, &block);
9490 : }
9491 : }
9492 :
9493 :
9494 : /* This helper function calculates the size in words of a full array. */
9495 :
9496 : tree
9497 21104 : gfc_full_array_size (stmtblock_t *block, tree decl, int rank)
9498 : {
9499 21104 : tree idx;
9500 21104 : tree nelems;
9501 21104 : tree tmp;
9502 21104 : if (rank < 0)
9503 0 : idx = gfc_conv_descriptor_rank (decl);
9504 : else
9505 21104 : idx = gfc_rank_cst[rank - 1];
9506 21104 : nelems = gfc_conv_descriptor_ubound_get (decl, idx);
9507 21104 : tmp = gfc_conv_descriptor_lbound_get (decl, idx);
9508 21104 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
9509 : nelems, tmp);
9510 21104 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
9511 : tmp, gfc_index_one_node);
9512 21104 : tmp = gfc_evaluate_now (tmp, block);
9513 :
9514 21104 : nelems = gfc_conv_descriptor_stride_get (decl, idx);
9515 21104 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9516 : nelems, tmp);
9517 21104 : return gfc_evaluate_now (tmp, block);
9518 : }
9519 :
9520 :
9521 : /* Allocate dest to the same size as src, and copy src -> dest.
9522 : If no_malloc is set, only the copy is done. */
9523 :
9524 : static tree
9525 9929 : duplicate_allocatable (tree dest, tree src, tree type, int rank,
9526 : bool no_malloc, bool no_memcpy, tree str_sz,
9527 : tree add_when_allocated)
9528 : {
9529 9929 : tree tmp;
9530 9929 : tree eltype;
9531 9929 : tree size;
9532 9929 : tree nelems;
9533 9929 : tree null_cond;
9534 9929 : tree null_data;
9535 9929 : stmtblock_t block;
9536 :
9537 : /* If the source is null, set the destination to null. Then,
9538 : allocate memory to the destination. */
9539 9929 : gfc_init_block (&block);
9540 :
9541 9929 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
9542 : {
9543 2236 : gfc_add_modify (&block, dest, fold_convert (type, null_pointer_node));
9544 2236 : null_data = gfc_finish_block (&block);
9545 :
9546 2236 : gfc_init_block (&block);
9547 2236 : eltype = TREE_TYPE (type);
9548 2236 : if (str_sz != NULL_TREE)
9549 : size = str_sz;
9550 : else
9551 1868 : size = TYPE_SIZE_UNIT (eltype);
9552 :
9553 2236 : if (!no_malloc)
9554 : {
9555 2236 : tmp = gfc_call_malloc (&block, type, size);
9556 2236 : gfc_add_modify (&block, dest, fold_convert (type, tmp));
9557 : }
9558 :
9559 2236 : if (!no_memcpy)
9560 : {
9561 1811 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
9562 1811 : tmp = build_call_expr_loc (input_location, tmp, 3, dest, src,
9563 : fold_convert (size_type_node, size));
9564 1811 : gfc_add_expr_to_block (&block, tmp);
9565 : }
9566 : }
9567 : else
9568 : {
9569 7693 : gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
9570 7693 : null_data = gfc_finish_block (&block);
9571 :
9572 7693 : gfc_init_block (&block);
9573 7693 : if (rank)
9574 7678 : nelems = gfc_full_array_size (&block, src, rank);
9575 : else
9576 15 : nelems = gfc_index_one_node;
9577 :
9578 : /* If type is not the array type, then it is the element type. */
9579 7693 : if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type))
9580 7663 : eltype = gfc_get_element_type (type);
9581 : else
9582 : eltype = type;
9583 :
9584 7693 : if (str_sz != NULL_TREE)
9585 43 : tmp = fold_convert (gfc_array_index_type, str_sz);
9586 : else
9587 7650 : tmp = fold_convert (gfc_array_index_type,
9588 : TYPE_SIZE_UNIT (eltype));
9589 :
9590 7693 : tmp = gfc_evaluate_now (tmp, &block);
9591 7693 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9592 : nelems, tmp);
9593 7693 : if (!no_malloc)
9594 : {
9595 7625 : tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src));
9596 7625 : tmp = gfc_call_malloc (&block, tmp, size);
9597 7625 : gfc_conv_descriptor_data_set (&block, dest, tmp);
9598 : }
9599 :
9600 : /* We know the temporary and the value will be the same length,
9601 : so can use memcpy. */
9602 7693 : if (!no_memcpy)
9603 : {
9604 6332 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
9605 6332 : tmp = build_call_expr_loc (input_location, tmp, 3,
9606 : gfc_conv_descriptor_data_get (dest),
9607 : gfc_conv_descriptor_data_get (src),
9608 : fold_convert (size_type_node, size));
9609 6332 : gfc_add_expr_to_block (&block, tmp);
9610 : }
9611 : }
9612 :
9613 9929 : gfc_add_expr_to_block (&block, add_when_allocated);
9614 9929 : tmp = gfc_finish_block (&block);
9615 :
9616 : /* Null the destination if the source is null; otherwise do
9617 : the allocate and copy. */
9618 9929 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src)))
9619 : null_cond = src;
9620 : else
9621 7693 : null_cond = gfc_conv_descriptor_data_get (src);
9622 :
9623 9929 : null_cond = convert (pvoid_type_node, null_cond);
9624 9929 : null_cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9625 : null_cond, null_pointer_node);
9626 9929 : return build3_v (COND_EXPR, null_cond, tmp, null_data);
9627 : }
9628 :
9629 :
9630 : /* Allocate dest to the same size as src, and copy data src -> dest. */
9631 :
9632 : tree
9633 7489 : gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank,
9634 : tree add_when_allocated)
9635 : {
9636 7489 : return duplicate_allocatable (dest, src, type, rank, false, false,
9637 7489 : NULL_TREE, add_when_allocated);
9638 : }
9639 :
9640 :
9641 : /* Copy data src -> dest. */
9642 :
9643 : tree
9644 68 : gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
9645 : {
9646 68 : return duplicate_allocatable (dest, src, type, rank, true, false,
9647 68 : NULL_TREE, NULL_TREE);
9648 : }
9649 :
9650 : /* Allocate dest to the same size as src, but don't copy anything. */
9651 :
9652 : tree
9653 1786 : gfc_duplicate_allocatable_nocopy (tree dest, tree src, tree type, int rank)
9654 : {
9655 1786 : return duplicate_allocatable (dest, src, type, rank, false, true,
9656 1786 : NULL_TREE, NULL_TREE);
9657 : }
9658 :
9659 : static tree
9660 62 : duplicate_allocatable_coarray (tree dest, tree dest_tok, tree src, tree type,
9661 : int rank, tree add_when_allocated)
9662 : {
9663 62 : tree tmp;
9664 62 : tree size;
9665 62 : tree nelems;
9666 62 : tree null_cond;
9667 62 : tree null_data;
9668 62 : stmtblock_t block, globalblock;
9669 :
9670 : /* If the source is null, set the destination to null. Then,
9671 : allocate memory to the destination. */
9672 62 : gfc_init_block (&block);
9673 62 : gfc_init_block (&globalblock);
9674 :
9675 62 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
9676 : {
9677 18 : gfc_se se;
9678 18 : symbol_attribute attr;
9679 18 : tree dummy_desc;
9680 :
9681 18 : gfc_init_se (&se, NULL);
9682 18 : gfc_clear_attr (&attr);
9683 18 : attr.allocatable = 1;
9684 18 : dummy_desc = gfc_conv_scalar_to_descriptor (&se, dest, attr);
9685 18 : gfc_add_block_to_block (&globalblock, &se.pre);
9686 18 : size = TYPE_SIZE_UNIT (TREE_TYPE (type));
9687 :
9688 18 : gfc_add_modify (&block, dest, fold_convert (type, null_pointer_node));
9689 18 : gfc_allocate_using_caf_lib (&block, dummy_desc, size,
9690 : gfc_build_addr_expr (NULL_TREE, dest_tok),
9691 : NULL_TREE, NULL_TREE, NULL_TREE,
9692 : GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
9693 18 : gfc_add_modify (&block, dest, gfc_conv_descriptor_data_get (dummy_desc));
9694 18 : null_data = gfc_finish_block (&block);
9695 :
9696 18 : gfc_init_block (&block);
9697 :
9698 18 : gfc_allocate_using_caf_lib (&block, dummy_desc,
9699 : fold_convert (size_type_node, size),
9700 : gfc_build_addr_expr (NULL_TREE, dest_tok),
9701 : NULL_TREE, NULL_TREE, NULL_TREE,
9702 : GFC_CAF_COARRAY_ALLOC);
9703 18 : gfc_add_modify (&block, dest, gfc_conv_descriptor_data_get (dummy_desc));
9704 :
9705 18 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
9706 18 : tmp = build_call_expr_loc (input_location, tmp, 3, dest, src,
9707 : fold_convert (size_type_node, size));
9708 18 : gfc_add_expr_to_block (&block, tmp);
9709 : }
9710 : else
9711 : {
9712 : /* Set the rank or uninitialized memory access may be reported. */
9713 44 : tmp = gfc_conv_descriptor_rank (dest);
9714 44 : gfc_add_modify (&globalblock, tmp, build_int_cst (TREE_TYPE (tmp), rank));
9715 :
9716 44 : if (rank)
9717 44 : nelems = gfc_full_array_size (&globalblock, src, rank);
9718 : else
9719 0 : nelems = integer_one_node;
9720 :
9721 44 : tmp = fold_convert (size_type_node,
9722 : TYPE_SIZE_UNIT (gfc_get_element_type (type)));
9723 44 : size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
9724 : fold_convert (size_type_node, nelems), tmp);
9725 :
9726 44 : gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
9727 44 : gfc_allocate_using_caf_lib (&block, dest, fold_convert (size_type_node,
9728 : size),
9729 : gfc_build_addr_expr (NULL_TREE, dest_tok),
9730 : NULL_TREE, NULL_TREE, NULL_TREE,
9731 : GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
9732 44 : null_data = gfc_finish_block (&block);
9733 :
9734 44 : gfc_init_block (&block);
9735 44 : gfc_allocate_using_caf_lib (&block, dest,
9736 : fold_convert (size_type_node, size),
9737 : gfc_build_addr_expr (NULL_TREE, dest_tok),
9738 : NULL_TREE, NULL_TREE, NULL_TREE,
9739 : GFC_CAF_COARRAY_ALLOC);
9740 :
9741 44 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
9742 44 : tmp = build_call_expr_loc (input_location, tmp, 3,
9743 : gfc_conv_descriptor_data_get (dest),
9744 : gfc_conv_descriptor_data_get (src),
9745 : fold_convert (size_type_node, size));
9746 44 : gfc_add_expr_to_block (&block, tmp);
9747 : }
9748 62 : gfc_add_expr_to_block (&block, add_when_allocated);
9749 62 : tmp = gfc_finish_block (&block);
9750 :
9751 : /* Null the destination if the source is null; otherwise do
9752 : the register and copy. */
9753 62 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src)))
9754 : null_cond = src;
9755 : else
9756 44 : null_cond = gfc_conv_descriptor_data_get (src);
9757 :
9758 62 : null_cond = convert (pvoid_type_node, null_cond);
9759 62 : null_cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9760 : null_cond, null_pointer_node);
9761 62 : gfc_add_expr_to_block (&globalblock, build3_v (COND_EXPR, null_cond, tmp,
9762 : null_data));
9763 62 : return gfc_finish_block (&globalblock);
9764 : }
9765 :
9766 :
9767 : /* Helper function to abstract whether coarray processing is enabled. */
9768 :
9769 : static bool
9770 75 : caf_enabled (int caf_mode)
9771 : {
9772 75 : return (caf_mode & GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY)
9773 75 : == GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY;
9774 : }
9775 :
9776 :
9777 : /* Helper function to abstract whether coarray processing is enabled
9778 : and we are in a derived type coarray. */
9779 :
9780 : static bool
9781 12763 : caf_in_coarray (int caf_mode)
9782 : {
9783 12763 : static const int pat = GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
9784 : | GFC_STRUCTURE_CAF_MODE_IN_COARRAY;
9785 12763 : return (caf_mode & pat) == pat;
9786 : }
9787 :
9788 :
9789 : /* Helper function to abstract whether coarray is to deallocate only. */
9790 :
9791 : bool
9792 352 : gfc_caf_is_dealloc_only (int caf_mode)
9793 : {
9794 352 : return (caf_mode & GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY)
9795 352 : == GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY;
9796 : }
9797 :
9798 :
9799 : /* Recursively traverse an object of derived type, generating code to
9800 : deallocate, nullify or copy allocatable components. This is the work horse
9801 : function for the functions named in this enum. */
9802 :
9803 : enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP,
9804 : COPY_ALLOC_COMP, COPY_ONLY_ALLOC_COMP, REASSIGN_CAF_COMP,
9805 : ALLOCATE_PDT_COMP, DEALLOCATE_PDT_COMP, CHECK_PDT_DUMMY,
9806 : BCAST_ALLOC_COMP};
9807 :
9808 : static gfc_actual_arglist *pdt_param_list;
9809 : static bool generating_copy_helper;
9810 : static hash_set<gfc_symbol *> seen_derived_types;
9811 :
9812 : /* Forward declaration of structure_alloc_comps for wrapper generator. */
9813 : static tree structure_alloc_comps (gfc_symbol *, tree, tree, int, int, int,
9814 : gfc_co_subroutines_args *, bool);
9815 :
9816 : /* Generate a wrapper function that performs element-wise deep copy for
9817 : recursive allocatable array components. This wrapper is passed as a
9818 : function pointer to the runtime helper _gfortran_cfi_deep_copy_array,
9819 : allowing recursion to happen at runtime instead of compile time. */
9820 :
9821 : static tree
9822 256 : get_copy_helper_function_type (void)
9823 : {
9824 256 : static tree fn_type = NULL_TREE;
9825 256 : if (fn_type == NULL_TREE)
9826 29 : fn_type = build_function_type_list (void_type_node,
9827 : pvoid_type_node,
9828 : pvoid_type_node,
9829 : NULL_TREE);
9830 256 : return fn_type;
9831 : }
9832 :
9833 : static tree
9834 1157 : get_copy_helper_pointer_type (void)
9835 : {
9836 1157 : static tree ptr_type = NULL_TREE;
9837 1157 : if (ptr_type == NULL_TREE)
9838 29 : ptr_type = build_pointer_type (get_copy_helper_function_type ());
9839 1157 : return ptr_type;
9840 : }
9841 :
9842 : static tree
9843 227 : generate_element_copy_wrapper (gfc_symbol *der_type, tree comp_type,
9844 : int purpose, int caf_mode)
9845 : {
9846 227 : tree fndecl, fntype, result_decl;
9847 227 : tree dest_parm, src_parm, dest_typed, src_typed;
9848 227 : tree der_type_ptr;
9849 227 : stmtblock_t block;
9850 227 : tree decls;
9851 227 : tree body;
9852 :
9853 227 : fntype = get_copy_helper_function_type ();
9854 :
9855 227 : fndecl = build_decl (input_location, FUNCTION_DECL,
9856 : create_tmp_var_name ("copy_element"),
9857 : fntype);
9858 :
9859 227 : TREE_STATIC (fndecl) = 1;
9860 227 : TREE_USED (fndecl) = 1;
9861 227 : DECL_ARTIFICIAL (fndecl) = 1;
9862 227 : DECL_IGNORED_P (fndecl) = 0;
9863 227 : TREE_PUBLIC (fndecl) = 0;
9864 227 : DECL_UNINLINABLE (fndecl) = 1;
9865 227 : DECL_EXTERNAL (fndecl) = 0;
9866 227 : DECL_CONTEXT (fndecl) = NULL_TREE;
9867 227 : DECL_INITIAL (fndecl) = make_node (BLOCK);
9868 227 : BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
9869 :
9870 227 : result_decl = build_decl (input_location, RESULT_DECL, NULL_TREE,
9871 : void_type_node);
9872 227 : DECL_ARTIFICIAL (result_decl) = 1;
9873 227 : DECL_IGNORED_P (result_decl) = 1;
9874 227 : DECL_CONTEXT (result_decl) = fndecl;
9875 227 : DECL_RESULT (fndecl) = result_decl;
9876 :
9877 227 : dest_parm = build_decl (input_location, PARM_DECL,
9878 : get_identifier ("dest"), pvoid_type_node);
9879 227 : src_parm = build_decl (input_location, PARM_DECL,
9880 : get_identifier ("src"), pvoid_type_node);
9881 :
9882 227 : DECL_ARTIFICIAL (dest_parm) = 1;
9883 227 : DECL_ARTIFICIAL (src_parm) = 1;
9884 227 : DECL_ARG_TYPE (dest_parm) = pvoid_type_node;
9885 227 : DECL_ARG_TYPE (src_parm) = pvoid_type_node;
9886 227 : DECL_CONTEXT (dest_parm) = fndecl;
9887 227 : DECL_CONTEXT (src_parm) = fndecl;
9888 :
9889 227 : DECL_ARGUMENTS (fndecl) = dest_parm;
9890 227 : TREE_CHAIN (dest_parm) = src_parm;
9891 :
9892 227 : push_struct_function (fndecl);
9893 227 : cfun->function_end_locus = input_location;
9894 :
9895 227 : pushlevel ();
9896 227 : gfc_init_block (&block);
9897 :
9898 227 : bool saved_generating = generating_copy_helper;
9899 227 : generating_copy_helper = true;
9900 :
9901 : /* When generating a wrapper, we need a fresh type tracking state to
9902 : avoid inheriting the parent context's seen_derived_types, which would
9903 : cause infinite recursion when the wrapper tries to handle the same
9904 : recursive type. Save elements, clear the set, generate wrapper, then
9905 : restore elements. */
9906 227 : vec<gfc_symbol *> saved_symbols = vNULL;
9907 227 : for (hash_set<gfc_symbol *>::iterator it = seen_derived_types.begin ();
9908 973 : it != seen_derived_types.end (); ++it)
9909 373 : saved_symbols.safe_push (*it);
9910 227 : seen_derived_types.empty ();
9911 :
9912 227 : der_type_ptr = build_pointer_type (comp_type);
9913 227 : dest_typed = fold_convert (der_type_ptr, dest_parm);
9914 227 : src_typed = fold_convert (der_type_ptr, src_parm);
9915 :
9916 227 : dest_typed = build_fold_indirect_ref (dest_typed);
9917 227 : src_typed = build_fold_indirect_ref (src_typed);
9918 :
9919 227 : body = structure_alloc_comps (der_type, src_typed, dest_typed,
9920 : 0, purpose, caf_mode, NULL, false);
9921 227 : gfc_add_expr_to_block (&block, body);
9922 :
9923 : /* Restore saved symbols. */
9924 227 : seen_derived_types.empty ();
9925 600 : for (unsigned i = 0; i < saved_symbols.length (); i++)
9926 373 : seen_derived_types.add (saved_symbols[i]);
9927 227 : saved_symbols.release ();
9928 227 : generating_copy_helper = saved_generating;
9929 :
9930 227 : body = gfc_finish_block (&block);
9931 227 : decls = getdecls ();
9932 :
9933 227 : poplevel (1, 1);
9934 :
9935 454 : DECL_SAVED_TREE (fndecl)
9936 227 : = fold_build3_loc (DECL_SOURCE_LOCATION (fndecl), BIND_EXPR,
9937 227 : void_type_node, decls, body, DECL_INITIAL (fndecl));
9938 :
9939 227 : pop_cfun ();
9940 :
9941 : /* Use finalize_function with no_collect=true to skip the ggc_collect
9942 : call that add_new_function would trigger. This function is called
9943 : during tree lowering of structure_alloc_comps where caller stack
9944 : frames hold locally-computed tree nodes (COMPONENT_REFs etc.) that
9945 : are not yet attached to any GC root. A collection at this point
9946 : would free those nodes and cause segfaults. PR124235. */
9947 227 : cgraph_node::finalize_function (fndecl, true);
9948 :
9949 227 : return build1 (ADDR_EXPR, get_copy_helper_pointer_type (), fndecl);
9950 : }
9951 :
9952 : static tree
9953 25596 : structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
9954 : int rank, int purpose, int caf_mode,
9955 : gfc_co_subroutines_args *args,
9956 : bool no_finalization = false)
9957 : {
9958 25596 : gfc_component *c;
9959 25596 : gfc_loopinfo loop;
9960 25596 : stmtblock_t fnblock;
9961 25596 : stmtblock_t loopbody;
9962 25596 : stmtblock_t tmpblock;
9963 25596 : tree decl_type;
9964 25596 : tree tmp;
9965 25596 : tree comp;
9966 25596 : tree dcmp;
9967 25596 : tree nelems;
9968 25596 : tree index;
9969 25596 : tree var;
9970 25596 : tree cdecl;
9971 25596 : tree ctype;
9972 25596 : tree vref, dref;
9973 25596 : tree null_cond = NULL_TREE;
9974 25596 : tree add_when_allocated;
9975 25596 : tree dealloc_fndecl;
9976 25596 : tree caf_token;
9977 25596 : gfc_symbol *vtab;
9978 25596 : int caf_dereg_mode;
9979 25596 : symbol_attribute *attr;
9980 25596 : bool deallocate_called;
9981 :
9982 25596 : gfc_init_block (&fnblock);
9983 :
9984 25596 : decl_type = TREE_TYPE (decl);
9985 :
9986 25596 : if ((POINTER_TYPE_P (decl_type))
9987 : || (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == 0))
9988 : {
9989 1567 : decl = build_fold_indirect_ref_loc (input_location, decl);
9990 : /* Deref dest in sync with decl, but only when it is not NULL. */
9991 1567 : if (dest)
9992 110 : dest = build_fold_indirect_ref_loc (input_location, dest);
9993 :
9994 : /* Update the decl_type because it got dereferenced. */
9995 1567 : decl_type = TREE_TYPE (decl);
9996 : }
9997 :
9998 : /* If this is an array of derived types with allocatable components
9999 : build a loop and recursively call this function. */
10000 25596 : if (TREE_CODE (decl_type) == ARRAY_TYPE
10001 25596 : || (GFC_DESCRIPTOR_TYPE_P (decl_type) && rank != 0))
10002 : {
10003 4694 : tmp = gfc_conv_array_data (decl);
10004 4694 : var = build_fold_indirect_ref_loc (input_location, tmp);
10005 :
10006 : /* Get the number of elements - 1 and set the counter. */
10007 4694 : if (GFC_DESCRIPTOR_TYPE_P (decl_type))
10008 : {
10009 : /* Use the descriptor for an allocatable array. Since this
10010 : is a full array reference, we only need the descriptor
10011 : information from dimension = rank. */
10012 3418 : tmp = gfc_full_array_size (&fnblock, decl, rank);
10013 3418 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
10014 : gfc_array_index_type, tmp,
10015 : gfc_index_one_node);
10016 :
10017 3418 : null_cond = gfc_conv_descriptor_data_get (decl);
10018 3418 : null_cond = fold_build2_loc (input_location, NE_EXPR,
10019 : logical_type_node, null_cond,
10020 3418 : build_int_cst (TREE_TYPE (null_cond), 0));
10021 : }
10022 : else
10023 : {
10024 : /* Otherwise use the TYPE_DOMAIN information. */
10025 1276 : tmp = array_type_nelts_minus_one (decl_type);
10026 1276 : tmp = fold_convert (gfc_array_index_type, tmp);
10027 : }
10028 :
10029 : /* Remember that this is, in fact, the no. of elements - 1. */
10030 4694 : nelems = gfc_evaluate_now (tmp, &fnblock);
10031 4694 : index = gfc_create_var (gfc_array_index_type, "S");
10032 :
10033 : /* Build the body of the loop. */
10034 4694 : gfc_init_block (&loopbody);
10035 :
10036 4694 : vref = gfc_build_array_ref (var, index, NULL);
10037 :
10038 4694 : if (purpose == COPY_ALLOC_COMP || purpose == COPY_ONLY_ALLOC_COMP)
10039 : {
10040 993 : tmp = build_fold_indirect_ref_loc (input_location,
10041 : gfc_conv_array_data (dest));
10042 993 : dref = gfc_build_array_ref (tmp, index, NULL);
10043 993 : tmp = structure_alloc_comps (der_type, vref, dref, rank,
10044 : COPY_ALLOC_COMP, caf_mode, args,
10045 : no_finalization);
10046 : }
10047 : else
10048 3701 : tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose,
10049 : caf_mode, args, no_finalization);
10050 :
10051 4694 : gfc_add_expr_to_block (&loopbody, tmp);
10052 :
10053 : /* Build the loop and return. */
10054 4694 : gfc_init_loopinfo (&loop);
10055 4694 : loop.dimen = 1;
10056 4694 : loop.from[0] = gfc_index_zero_node;
10057 4694 : loop.loopvar[0] = index;
10058 4694 : loop.to[0] = nelems;
10059 4694 : gfc_trans_scalarizing_loops (&loop, &loopbody);
10060 4694 : gfc_add_block_to_block (&fnblock, &loop.pre);
10061 :
10062 4694 : tmp = gfc_finish_block (&fnblock);
10063 : /* When copying allocateable components, the above implements the
10064 : deep copy. Nevertheless is a deep copy only allowed, when the current
10065 : component is allocated, for which code will be generated in
10066 : gfc_duplicate_allocatable (), where the deep copy code is just added
10067 : into the if's body, by adding tmp (the deep copy code) as last
10068 : argument to gfc_duplicate_allocatable (). */
10069 4694 : if (purpose == COPY_ALLOC_COMP && caf_mode == 0
10070 4694 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
10071 740 : tmp = gfc_duplicate_allocatable (dest, decl, decl_type, rank,
10072 : tmp);
10073 3954 : else if (null_cond != NULL_TREE)
10074 2678 : tmp = build3_v (COND_EXPR, null_cond, tmp,
10075 : build_empty_stmt (input_location));
10076 :
10077 4694 : return tmp;
10078 : }
10079 :
10080 20902 : if (purpose == DEALLOCATE_ALLOC_COMP && der_type->attr.pdt_type)
10081 : {
10082 833 : tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
10083 : DEALLOCATE_PDT_COMP, 0, args,
10084 : no_finalization);
10085 833 : gfc_add_expr_to_block (&fnblock, tmp);
10086 : }
10087 20069 : else if (purpose == ALLOCATE_PDT_COMP && der_type->attr.alloc_comp)
10088 : {
10089 125 : tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
10090 : NULLIFY_ALLOC_COMP, 0, args,
10091 : no_finalization);
10092 125 : gfc_add_expr_to_block (&fnblock, tmp);
10093 : }
10094 :
10095 : /* Still having a descriptor array of rank == 0 here, indicates an
10096 : allocatable coarrays. Dereference it correctly. */
10097 20902 : if (GFC_DESCRIPTOR_TYPE_P (decl_type))
10098 : {
10099 5 : decl = build_fold_indirect_ref (gfc_conv_array_data (decl));
10100 : }
10101 : /* Otherwise, act on the components or recursively call self to
10102 : act on a chain of components. */
10103 20902 : seen_derived_types.add (der_type);
10104 60383 : for (c = der_type->components; c; c = c->next)
10105 : {
10106 39481 : bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED
10107 39481 : || c->ts.type == BT_CLASS)
10108 39481 : && c->ts.u.derived->attr.alloc_comp;
10109 39481 : bool same_type
10110 : = (c->ts.type == BT_DERIVED
10111 9358 : && seen_derived_types.contains (c->ts.u.derived))
10112 46188 : || (c->ts.type == BT_CLASS
10113 2278 : && seen_derived_types.contains (CLASS_DATA (c)->ts.u.derived));
10114 39481 : bool inside_wrapper = generating_copy_helper;
10115 :
10116 39481 : bool is_pdt_type = IS_PDT (c);
10117 :
10118 39481 : cdecl = c->backend_decl;
10119 39481 : ctype = TREE_TYPE (cdecl);
10120 :
10121 39481 : switch (purpose)
10122 : {
10123 :
10124 3 : case BCAST_ALLOC_COMP:
10125 :
10126 3 : tree ubound;
10127 3 : tree cdesc;
10128 3 : stmtblock_t derived_type_block;
10129 :
10130 3 : gfc_init_block (&tmpblock);
10131 :
10132 3 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10133 : decl, cdecl, NULL_TREE);
10134 :
10135 : /* Shortcut to get the attributes of the component. */
10136 3 : if (c->ts.type == BT_CLASS)
10137 : {
10138 0 : attr = &CLASS_DATA (c)->attr;
10139 0 : if (attr->class_pointer)
10140 0 : continue;
10141 : }
10142 : else
10143 : {
10144 3 : attr = &c->attr;
10145 3 : if (attr->pointer)
10146 0 : continue;
10147 : }
10148 :
10149 : /* Do not broadcast a caf_token. These are local to the image. */
10150 3 : if (attr->caf_token)
10151 1 : continue;
10152 :
10153 2 : add_when_allocated = NULL_TREE;
10154 2 : if (cmp_has_alloc_comps
10155 0 : && !c->attr.pointer && !c->attr.proc_pointer)
10156 : {
10157 0 : if (c->ts.type == BT_CLASS)
10158 : {
10159 0 : rank = CLASS_DATA (c)->as ? CLASS_DATA (c)->as->rank : 0;
10160 0 : add_when_allocated
10161 0 : = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
10162 : comp, NULL_TREE, rank, purpose,
10163 : caf_mode, args, no_finalization);
10164 : }
10165 : else
10166 : {
10167 0 : rank = c->as ? c->as->rank : 0;
10168 0 : add_when_allocated = structure_alloc_comps (c->ts.u.derived,
10169 : comp, NULL_TREE,
10170 : rank, purpose,
10171 : caf_mode, args,
10172 : no_finalization);
10173 : }
10174 : }
10175 :
10176 2 : gfc_init_block (&derived_type_block);
10177 2 : if (add_when_allocated)
10178 0 : gfc_add_expr_to_block (&derived_type_block, add_when_allocated);
10179 2 : tmp = gfc_finish_block (&derived_type_block);
10180 2 : gfc_add_expr_to_block (&tmpblock, tmp);
10181 :
10182 : /* Convert the component into a rank 1 descriptor type. */
10183 2 : if (attr->dimension)
10184 : {
10185 0 : tmp = gfc_get_element_type (TREE_TYPE (comp));
10186 0 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
10187 0 : ubound = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (comp));
10188 : else
10189 0 : ubound = gfc_full_array_size (&tmpblock, comp,
10190 0 : c->ts.type == BT_CLASS
10191 0 : ? CLASS_DATA (c)->as->rank
10192 0 : : c->as->rank);
10193 : }
10194 : else
10195 : {
10196 2 : tmp = TREE_TYPE (comp);
10197 2 : ubound = build_int_cst (gfc_array_index_type, 1);
10198 : }
10199 :
10200 : /* Treat strings like arrays. Or the other way around, do not
10201 : * generate an additional array layer for scalar components. */
10202 2 : if (attr->dimension || c->ts.type == BT_CHARACTER)
10203 : {
10204 0 : cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node,
10205 : &ubound, 1,
10206 : GFC_ARRAY_ALLOCATABLE, false);
10207 :
10208 0 : cdesc = gfc_create_var (cdesc, "cdesc");
10209 0 : DECL_ARTIFICIAL (cdesc) = 1;
10210 :
10211 0 : gfc_add_modify (&tmpblock, gfc_conv_descriptor_dtype (cdesc),
10212 : gfc_get_dtype_rank_type (1, tmp));
10213 0 : gfc_conv_descriptor_lbound_set (&tmpblock, cdesc,
10214 : gfc_index_zero_node,
10215 : gfc_index_one_node);
10216 0 : gfc_conv_descriptor_stride_set (&tmpblock, cdesc,
10217 : gfc_index_zero_node,
10218 : gfc_index_one_node);
10219 0 : gfc_conv_descriptor_ubound_set (&tmpblock, cdesc,
10220 : gfc_index_zero_node, ubound);
10221 : }
10222 : else
10223 : /* Prevent warning. */
10224 : cdesc = NULL_TREE;
10225 :
10226 2 : if (attr->dimension)
10227 : {
10228 0 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
10229 0 : comp = gfc_conv_descriptor_data_get (comp);
10230 : else
10231 0 : comp = gfc_build_addr_expr (NULL_TREE, comp);
10232 : }
10233 : else
10234 : {
10235 2 : gfc_se se;
10236 :
10237 2 : gfc_init_se (&se, NULL);
10238 :
10239 2 : comp = gfc_conv_scalar_to_descriptor (&se, comp,
10240 2 : c->ts.type == BT_CLASS
10241 2 : ? CLASS_DATA (c)->attr
10242 : : c->attr);
10243 2 : if (c->ts.type == BT_CHARACTER)
10244 0 : comp = gfc_build_addr_expr (NULL_TREE, comp);
10245 2 : gfc_add_block_to_block (&tmpblock, &se.pre);
10246 : }
10247 :
10248 2 : if (attr->dimension || c->ts.type == BT_CHARACTER)
10249 0 : gfc_conv_descriptor_data_set (&tmpblock, cdesc, comp);
10250 : else
10251 2 : cdesc = comp;
10252 :
10253 2 : tree fndecl;
10254 :
10255 2 : fndecl = build_call_expr_loc (input_location,
10256 : gfor_fndecl_co_broadcast, 5,
10257 : gfc_build_addr_expr (pvoid_type_node,cdesc),
10258 : args->image_index,
10259 : null_pointer_node, null_pointer_node,
10260 : null_pointer_node);
10261 :
10262 2 : gfc_add_expr_to_block (&tmpblock, fndecl);
10263 2 : gfc_add_block_to_block (&fnblock, &tmpblock);
10264 :
10265 31935 : break;
10266 :
10267 15476 : case DEALLOCATE_ALLOC_COMP:
10268 :
10269 15476 : gfc_init_block (&tmpblock);
10270 :
10271 15476 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10272 : decl, cdecl, NULL_TREE);
10273 :
10274 : /* Shortcut to get the attributes of the component. */
10275 15476 : if (c->ts.type == BT_CLASS)
10276 : {
10277 1022 : attr = &CLASS_DATA (c)->attr;
10278 1022 : if (attr->class_pointer || c->attr.proc_pointer)
10279 18 : continue;
10280 : }
10281 : else
10282 : {
10283 14454 : attr = &c->attr;
10284 14454 : if (attr->pointer || attr->proc_pointer)
10285 143 : continue;
10286 : }
10287 :
10288 15315 : if (!no_finalization && ((c->ts.type == BT_DERIVED && !c->attr.pointer)
10289 8998 : || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer)))
10290 : /* Call the finalizer, which will free the memory and nullify the
10291 : pointer of an array. */
10292 3744 : deallocate_called = gfc_add_comp_finalizer_call (&tmpblock, comp, c,
10293 3744 : caf_enabled (caf_mode))
10294 3744 : && attr->dimension;
10295 : else
10296 : deallocate_called = false;
10297 :
10298 : /* Add the _class ref for classes. */
10299 15315 : if (c->ts.type == BT_CLASS && attr->allocatable)
10300 1004 : comp = gfc_class_data_get (comp);
10301 :
10302 15315 : add_when_allocated = NULL_TREE;
10303 15315 : if (cmp_has_alloc_comps
10304 3285 : && !c->attr.pointer && !c->attr.proc_pointer
10305 : && !same_type
10306 3285 : && !deallocate_called)
10307 : {
10308 : /* Add checked deallocation of the components. This code is
10309 : obviously added because the finalizer is not trusted to free
10310 : all memory. */
10311 1987 : if (c->ts.type == BT_CLASS)
10312 : {
10313 242 : rank = CLASS_DATA (c)->as ? CLASS_DATA (c)->as->rank : 0;
10314 242 : add_when_allocated
10315 242 : = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
10316 : comp, NULL_TREE, rank, purpose,
10317 : caf_mode, args, no_finalization);
10318 : }
10319 : else
10320 : {
10321 1745 : rank = c->as ? c->as->rank : 0;
10322 1745 : add_when_allocated = structure_alloc_comps (c->ts.u.derived,
10323 : comp, NULL_TREE,
10324 : rank, purpose,
10325 : caf_mode, args,
10326 : no_finalization);
10327 : }
10328 : }
10329 :
10330 9801 : if (attr->allocatable && !same_type
10331 24093 : && (!attr->codimension || caf_enabled (caf_mode)))
10332 : {
10333 : /* Handle all types of components besides components of the
10334 : same_type as the current one, because those would create an
10335 : endless loop. */
10336 51 : caf_dereg_mode = (caf_in_coarray (caf_mode)
10337 58 : && (attr->dimension || c->caf_token))
10338 8714 : || attr->codimension
10339 8849 : ? (gfc_caf_is_dealloc_only (caf_mode)
10340 : ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
10341 : : GFC_CAF_COARRAY_DEREGISTER)
10342 : : GFC_CAF_COARRAY_NOCOARRAY;
10343 :
10344 8771 : caf_token = NULL_TREE;
10345 : /* Coarray components are handled directly by
10346 : deallocate_with_status. */
10347 8771 : if (!attr->codimension
10348 8750 : && caf_dereg_mode != GFC_CAF_COARRAY_NOCOARRAY)
10349 : {
10350 57 : if (c->caf_token)
10351 19 : caf_token
10352 19 : = fold_build3_loc (input_location, COMPONENT_REF,
10353 19 : TREE_TYPE (gfc_comp_caf_token (c)),
10354 : decl, gfc_comp_caf_token (c),
10355 : NULL_TREE);
10356 38 : else if (attr->dimension && !attr->proc_pointer)
10357 38 : caf_token = gfc_conv_descriptor_token (comp);
10358 : }
10359 :
10360 8771 : tmp = gfc_deallocate_with_status (comp, NULL_TREE, NULL_TREE,
10361 : NULL_TREE, NULL_TREE, true,
10362 : NULL, caf_dereg_mode, NULL_TREE,
10363 : add_when_allocated, caf_token);
10364 :
10365 8771 : gfc_add_expr_to_block (&tmpblock, tmp);
10366 : }
10367 6544 : else if (attr->allocatable && !attr->codimension
10368 1023 : && !deallocate_called)
10369 : {
10370 : /* Case of recursive allocatable derived types. */
10371 1023 : tree is_allocated;
10372 1023 : tree ubound;
10373 1023 : tree cdesc;
10374 1023 : stmtblock_t dealloc_block;
10375 :
10376 1023 : gfc_init_block (&dealloc_block);
10377 1023 : if (add_when_allocated)
10378 0 : gfc_add_expr_to_block (&dealloc_block, add_when_allocated);
10379 :
10380 : /* Convert the component into a rank 1 descriptor type. */
10381 1023 : if (attr->dimension)
10382 : {
10383 417 : tmp = gfc_get_element_type (TREE_TYPE (comp));
10384 417 : ubound = gfc_full_array_size (&dealloc_block, comp,
10385 417 : c->ts.type == BT_CLASS
10386 0 : ? CLASS_DATA (c)->as->rank
10387 417 : : c->as->rank);
10388 : }
10389 : else
10390 : {
10391 606 : tmp = TREE_TYPE (comp);
10392 606 : ubound = build_int_cst (gfc_array_index_type, 1);
10393 : }
10394 :
10395 1023 : cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node,
10396 : &ubound, 1,
10397 : GFC_ARRAY_ALLOCATABLE, false);
10398 :
10399 1023 : cdesc = gfc_create_var (cdesc, "cdesc");
10400 1023 : DECL_ARTIFICIAL (cdesc) = 1;
10401 :
10402 1023 : gfc_add_modify (&dealloc_block, gfc_conv_descriptor_dtype (cdesc),
10403 : gfc_get_dtype_rank_type (1, tmp));
10404 1023 : gfc_conv_descriptor_lbound_set (&dealloc_block, cdesc,
10405 : gfc_index_zero_node,
10406 : gfc_index_one_node);
10407 1023 : gfc_conv_descriptor_stride_set (&dealloc_block, cdesc,
10408 : gfc_index_zero_node,
10409 : gfc_index_one_node);
10410 1023 : gfc_conv_descriptor_ubound_set (&dealloc_block, cdesc,
10411 : gfc_index_zero_node, ubound);
10412 :
10413 1023 : if (attr->dimension)
10414 417 : comp = gfc_conv_descriptor_data_get (comp);
10415 :
10416 1023 : gfc_conv_descriptor_data_set (&dealloc_block, cdesc, comp);
10417 :
10418 : /* Now call the deallocator. */
10419 1023 : vtab = gfc_find_vtab (&c->ts);
10420 1023 : if (vtab->backend_decl == NULL)
10421 47 : gfc_get_symbol_decl (vtab);
10422 1023 : tmp = gfc_build_addr_expr (NULL_TREE, vtab->backend_decl);
10423 1023 : dealloc_fndecl = gfc_vptr_deallocate_get (tmp);
10424 1023 : dealloc_fndecl = build_fold_indirect_ref_loc (input_location,
10425 : dealloc_fndecl);
10426 1023 : tmp = build_int_cst (TREE_TYPE (comp), 0);
10427 1023 : is_allocated = fold_build2_loc (input_location, NE_EXPR,
10428 : logical_type_node, tmp,
10429 : comp);
10430 1023 : cdesc = gfc_build_addr_expr (NULL_TREE, cdesc);
10431 :
10432 1023 : tmp = build_call_expr_loc (input_location,
10433 : dealloc_fndecl, 1,
10434 : cdesc);
10435 1023 : gfc_add_expr_to_block (&dealloc_block, tmp);
10436 :
10437 1023 : tmp = gfc_finish_block (&dealloc_block);
10438 :
10439 1023 : tmp = fold_build3_loc (input_location, COND_EXPR,
10440 : void_type_node, is_allocated, tmp,
10441 : build_empty_stmt (input_location));
10442 :
10443 1023 : gfc_add_expr_to_block (&tmpblock, tmp);
10444 1023 : }
10445 5521 : else if (add_when_allocated)
10446 991 : gfc_add_expr_to_block (&tmpblock, add_when_allocated);
10447 :
10448 1004 : if (c->ts.type == BT_CLASS && attr->allocatable
10449 16319 : && (!attr->codimension || !caf_enabled (caf_mode)))
10450 : {
10451 : /* Finally, reset the vptr to the declared type vtable and, if
10452 : necessary reset the _len field.
10453 :
10454 : First recover the reference to the component and obtain
10455 : the vptr. */
10456 989 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10457 : decl, cdecl, NULL_TREE);
10458 989 : tmp = gfc_class_vptr_get (comp);
10459 :
10460 989 : if (UNLIMITED_POLY (c))
10461 : {
10462 : /* Both vptr and _len field should be nulled. */
10463 219 : gfc_add_modify (&tmpblock, tmp,
10464 219 : build_int_cst (TREE_TYPE (tmp), 0));
10465 219 : tmp = gfc_class_len_get (comp);
10466 219 : gfc_add_modify (&tmpblock, tmp,
10467 219 : build_int_cst (TREE_TYPE (tmp), 0));
10468 : }
10469 : else
10470 : {
10471 : /* Build the vtable address and set the vptr with it. */
10472 770 : gfc_reset_vptr (&tmpblock, nullptr, tmp, c->ts.u.derived);
10473 : }
10474 : }
10475 :
10476 : /* Now add the deallocation of this component. */
10477 15315 : gfc_add_block_to_block (&fnblock, &tmpblock);
10478 15315 : break;
10479 :
10480 6143 : case NULLIFY_ALLOC_COMP:
10481 : /* Nullify
10482 : - allocatable components (regular or in class)
10483 : - components that have allocatable components
10484 : - pointer components when in a coarray.
10485 : Skip everything else especially proc_pointers, which may come
10486 : coupled with the regular pointer attribute. */
10487 8261 : if (c->attr.proc_pointer
10488 6143 : || !(c->attr.allocatable || (c->ts.type == BT_CLASS
10489 482 : && CLASS_DATA (c)->attr.allocatable)
10490 2739 : || (cmp_has_alloc_comps
10491 538 : && ((c->ts.type == BT_DERIVED && !c->attr.pointer)
10492 18 : || (c->ts.type == BT_CLASS
10493 12 : && !CLASS_DATA (c)->attr.class_pointer)))
10494 2219 : || (caf_in_coarray (caf_mode) && c->attr.pointer)))
10495 2118 : continue;
10496 :
10497 : /* Process class components first, because they always have the
10498 : pointer-attribute set which would be caught wrong else. */
10499 4025 : if (c->ts.type == BT_CLASS
10500 469 : && (CLASS_DATA (c)->attr.allocatable
10501 0 : || CLASS_DATA (c)->attr.class_pointer))
10502 : {
10503 469 : tree class_ref;
10504 :
10505 : /* Allocatable CLASS components. */
10506 469 : class_ref = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10507 : decl, cdecl, NULL_TREE);
10508 :
10509 469 : comp = gfc_class_data_get (class_ref);
10510 469 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
10511 257 : gfc_conv_descriptor_data_set (&fnblock, comp,
10512 : null_pointer_node);
10513 : else
10514 : {
10515 212 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
10516 : void_type_node, comp,
10517 212 : build_int_cst (TREE_TYPE (comp), 0));
10518 212 : gfc_add_expr_to_block (&fnblock, tmp);
10519 : }
10520 :
10521 : /* The dynamic type of a disassociated pointer or unallocated
10522 : allocatable variable is its declared type. An unlimited
10523 : polymorphic entity has no declared type. */
10524 469 : gfc_reset_vptr (&fnblock, nullptr, class_ref, c->ts.u.derived);
10525 :
10526 469 : cmp_has_alloc_comps = false;
10527 469 : }
10528 : /* Coarrays need the component to be nulled before the api-call
10529 : is made. */
10530 3556 : else if (c->attr.pointer || c->attr.allocatable)
10531 : {
10532 3036 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10533 : decl, cdecl, NULL_TREE);
10534 3036 : if (c->attr.dimension || c->attr.codimension)
10535 2163 : gfc_conv_descriptor_data_set (&fnblock, comp,
10536 : null_pointer_node);
10537 : else
10538 873 : gfc_add_modify (&fnblock, comp,
10539 873 : build_int_cst (TREE_TYPE (comp), 0));
10540 3036 : if (gfc_deferred_strlen (c, &comp))
10541 : {
10542 317 : comp = fold_build3_loc (input_location, COMPONENT_REF,
10543 317 : TREE_TYPE (comp),
10544 : decl, comp, NULL_TREE);
10545 634 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
10546 317 : TREE_TYPE (comp), comp,
10547 317 : build_int_cst (TREE_TYPE (comp), 0));
10548 317 : gfc_add_expr_to_block (&fnblock, tmp);
10549 : }
10550 : cmp_has_alloc_comps = false;
10551 : }
10552 :
10553 4025 : if (flag_coarray == GFC_FCOARRAY_LIB && caf_in_coarray (caf_mode))
10554 : {
10555 : /* Register a component of a derived type coarray with the
10556 : coarray library. Do not register ultimate component
10557 : coarrays here. They are treated like regular coarrays and
10558 : are either allocated on all images or on none. */
10559 132 : tree token;
10560 :
10561 132 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10562 : decl, cdecl, NULL_TREE);
10563 132 : if (c->attr.dimension)
10564 : {
10565 : /* Set the dtype, because caf_register needs it. */
10566 104 : gfc_add_modify (&fnblock, gfc_conv_descriptor_dtype (comp),
10567 104 : gfc_get_dtype (TREE_TYPE (comp)));
10568 104 : tmp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10569 : decl, cdecl, NULL_TREE);
10570 104 : token = gfc_conv_descriptor_token (tmp);
10571 : }
10572 : else
10573 : {
10574 28 : gfc_se se;
10575 :
10576 28 : gfc_init_se (&se, NULL);
10577 56 : token = fold_build3_loc (input_location, COMPONENT_REF,
10578 : pvoid_type_node, decl,
10579 28 : gfc_comp_caf_token (c), NULL_TREE);
10580 28 : comp = gfc_conv_scalar_to_descriptor (&se, comp,
10581 28 : c->ts.type == BT_CLASS
10582 28 : ? CLASS_DATA (c)->attr
10583 : : c->attr);
10584 28 : gfc_add_block_to_block (&fnblock, &se.pre);
10585 : }
10586 :
10587 132 : gfc_allocate_using_caf_lib (&fnblock, comp, size_zero_node,
10588 : gfc_build_addr_expr (NULL_TREE,
10589 : token),
10590 : NULL_TREE, NULL_TREE, NULL_TREE,
10591 : GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
10592 : }
10593 :
10594 4025 : if (cmp_has_alloc_comps)
10595 : {
10596 520 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10597 : decl, cdecl, NULL_TREE);
10598 520 : rank = c->as ? c->as->rank : 0;
10599 520 : tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
10600 : rank, purpose, caf_mode, args,
10601 : no_finalization);
10602 520 : gfc_add_expr_to_block (&fnblock, tmp);
10603 : }
10604 : break;
10605 :
10606 30 : case REASSIGN_CAF_COMP:
10607 30 : if (caf_enabled (caf_mode)
10608 30 : && (c->attr.codimension
10609 23 : || (c->ts.type == BT_CLASS
10610 2 : && (CLASS_DATA (c)->attr.coarray_comp
10611 2 : || caf_in_coarray (caf_mode)))
10612 21 : || (c->ts.type == BT_DERIVED
10613 7 : && (c->ts.u.derived->attr.coarray_comp
10614 6 : || caf_in_coarray (caf_mode))))
10615 46 : && !same_type)
10616 : {
10617 14 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10618 : decl, cdecl, NULL_TREE);
10619 14 : dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10620 : dest, cdecl, NULL_TREE);
10621 :
10622 14 : if (c->attr.codimension)
10623 : {
10624 7 : if (c->ts.type == BT_CLASS)
10625 : {
10626 0 : comp = gfc_class_data_get (comp);
10627 0 : dcmp = gfc_class_data_get (dcmp);
10628 : }
10629 7 : gfc_conv_descriptor_data_set (&fnblock, dcmp,
10630 : gfc_conv_descriptor_data_get (comp));
10631 : }
10632 : else
10633 : {
10634 7 : tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
10635 : rank, purpose, caf_mode
10636 : | GFC_STRUCTURE_CAF_MODE_IN_COARRAY,
10637 : args, no_finalization);
10638 7 : gfc_add_expr_to_block (&fnblock, tmp);
10639 : }
10640 : }
10641 : break;
10642 :
10643 11946 : case COPY_ALLOC_COMP:
10644 11946 : if (c->attr.pointer || c->attr.proc_pointer)
10645 153 : continue;
10646 :
10647 : /* We need source and destination components. */
10648 11793 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl,
10649 : cdecl, NULL_TREE);
10650 11793 : dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, dest,
10651 : cdecl, NULL_TREE);
10652 11793 : dcmp = fold_convert (TREE_TYPE (comp), dcmp);
10653 :
10654 11793 : if (IS_PDT (c) && !c->attr.allocatable)
10655 : {
10656 117 : tmp = gfc_copy_alloc_comp (c->ts.u.derived, comp, dcmp,
10657 : 0, 0);
10658 117 : gfc_add_expr_to_block (&fnblock, tmp);
10659 117 : continue;
10660 : }
10661 :
10662 11676 : if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
10663 : {
10664 744 : tree ftn_tree;
10665 744 : tree size;
10666 744 : tree dst_data;
10667 744 : tree src_data;
10668 744 : tree null_data;
10669 :
10670 744 : dst_data = gfc_class_data_get (dcmp);
10671 744 : src_data = gfc_class_data_get (comp);
10672 744 : size = fold_convert (size_type_node,
10673 : gfc_class_vtab_size_get (comp));
10674 :
10675 744 : if (CLASS_DATA (c)->attr.dimension)
10676 : {
10677 728 : nelems = gfc_conv_descriptor_size (src_data,
10678 364 : CLASS_DATA (c)->as->rank);
10679 364 : size = fold_build2_loc (input_location, MULT_EXPR,
10680 : size_type_node, size,
10681 : fold_convert (size_type_node,
10682 : nelems));
10683 : }
10684 : else
10685 380 : nelems = build_int_cst (size_type_node, 1);
10686 :
10687 744 : if (CLASS_DATA (c)->attr.dimension
10688 380 : || CLASS_DATA (c)->attr.codimension)
10689 : {
10690 372 : src_data = gfc_conv_descriptor_data_get (src_data);
10691 372 : dst_data = gfc_conv_descriptor_data_get (dst_data);
10692 : }
10693 :
10694 744 : gfc_init_block (&tmpblock);
10695 :
10696 744 : gfc_add_modify (&tmpblock, gfc_class_vptr_get (dcmp),
10697 : gfc_class_vptr_get (comp));
10698 :
10699 : /* Copy the unlimited '_len' field. If it is greater than zero
10700 : (ie. a character(_len)), multiply it by size and use this
10701 : for the malloc call. */
10702 744 : if (UNLIMITED_POLY (c))
10703 : {
10704 146 : gfc_add_modify (&tmpblock, gfc_class_len_get (dcmp),
10705 : gfc_class_len_get (comp));
10706 146 : size = gfc_resize_class_size_with_len (&tmpblock, comp, size);
10707 : }
10708 :
10709 : /* Coarray component have to have the same allocation status and
10710 : shape/type-parameter/effective-type on the LHS and RHS of an
10711 : intrinsic assignment. Hence, we did not deallocated them - and
10712 : do not allocate them here. */
10713 744 : if (!CLASS_DATA (c)->attr.codimension)
10714 : {
10715 729 : ftn_tree = builtin_decl_explicit (BUILT_IN_MALLOC);
10716 729 : tmp = build_call_expr_loc (input_location, ftn_tree, 1, size);
10717 729 : gfc_add_modify (&tmpblock, dst_data,
10718 729 : fold_convert (TREE_TYPE (dst_data), tmp));
10719 : }
10720 :
10721 1473 : tmp = gfc_copy_class_to_class (comp, dcmp, nelems,
10722 744 : UNLIMITED_POLY (c));
10723 744 : gfc_add_expr_to_block (&tmpblock, tmp);
10724 744 : tmp = gfc_finish_block (&tmpblock);
10725 :
10726 744 : gfc_init_block (&tmpblock);
10727 744 : gfc_add_modify (&tmpblock, dst_data,
10728 744 : fold_convert (TREE_TYPE (dst_data),
10729 : null_pointer_node));
10730 744 : null_data = gfc_finish_block (&tmpblock);
10731 :
10732 744 : null_cond = fold_build2_loc (input_location, NE_EXPR,
10733 : logical_type_node, src_data,
10734 : null_pointer_node);
10735 :
10736 744 : gfc_add_expr_to_block (&fnblock, build3_v (COND_EXPR, null_cond,
10737 : tmp, null_data));
10738 744 : continue;
10739 744 : }
10740 :
10741 : /* To implement guarded deep copy, i.e., deep copy only allocatable
10742 : components that are really allocated, the deep copy code has to
10743 : be generated first and then added to the if-block in
10744 : gfc_duplicate_allocatable (). */
10745 10932 : if (cmp_has_alloc_comps && !c->attr.proc_pointer && !same_type)
10746 : {
10747 1680 : rank = c->as ? c->as->rank : 0;
10748 1680 : tmp = fold_convert (TREE_TYPE (dcmp), comp);
10749 1680 : gfc_add_modify (&fnblock, dcmp, tmp);
10750 1680 : add_when_allocated = structure_alloc_comps (c->ts.u.derived,
10751 : comp, dcmp,
10752 : rank, purpose,
10753 : caf_mode, args,
10754 : no_finalization);
10755 : }
10756 : else
10757 : add_when_allocated = NULL_TREE;
10758 :
10759 10932 : if (gfc_deferred_strlen (c, &tmp))
10760 : {
10761 411 : tree len, size;
10762 411 : len = tmp;
10763 411 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
10764 411 : TREE_TYPE (len),
10765 : decl, len, NULL_TREE);
10766 411 : len = fold_build3_loc (input_location, COMPONENT_REF,
10767 411 : TREE_TYPE (len),
10768 : dest, len, NULL_TREE);
10769 411 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
10770 411 : TREE_TYPE (len), len, tmp);
10771 411 : gfc_add_expr_to_block (&fnblock, tmp);
10772 411 : size = size_of_string_in_bytes (c->ts.kind, len);
10773 : /* This component cannot have allocatable components,
10774 : therefore add_when_allocated of duplicate_allocatable ()
10775 : is always NULL. */
10776 411 : rank = c->as ? c->as->rank : 0;
10777 411 : tmp = duplicate_allocatable (dcmp, comp, ctype, rank,
10778 : false, false, size, NULL_TREE);
10779 411 : gfc_add_expr_to_block (&fnblock, tmp);
10780 : }
10781 10521 : else if (c->attr.pdt_array
10782 175 : && !c->attr.allocatable && !c->attr.pointer)
10783 : {
10784 175 : tmp = duplicate_allocatable (dcmp, comp, ctype,
10785 175 : c->as ? c->as->rank : 0,
10786 : false, false, NULL_TREE, NULL_TREE);
10787 175 : gfc_add_expr_to_block (&fnblock, tmp);
10788 : }
10789 : /* Special case: recursive allocatable array components require
10790 : runtime helpers to avoid compile-time infinite recursion. Generate
10791 : a call to _gfortran_cfi_deep_copy_array with an element copy
10792 : wrapper. When inside a wrapper, reuse current_function_decl. */
10793 6290 : else if (c->attr.allocatable && c->as && cmp_has_alloc_comps && same_type
10794 930 : && purpose == COPY_ALLOC_COMP && !c->attr.proc_pointer
10795 930 : && !c->attr.codimension && !caf_in_coarray (caf_mode)
10796 11276 : && c->ts.type == BT_DERIVED && c->ts.u.derived != NULL)
10797 : {
10798 930 : tree copy_wrapper, call, dest_addr, src_addr, elem_type;
10799 930 : tree helper_ptr_type;
10800 930 : tree alloc_expr;
10801 930 : int comp_rank;
10802 :
10803 : /* Get the element type from ctype (already the component
10804 : type). For arrays we need the element type, not the array
10805 : type. */
10806 930 : elem_type = ctype;
10807 930 : if (GFC_DESCRIPTOR_TYPE_P (ctype))
10808 930 : elem_type = gfc_get_element_type (ctype);
10809 0 : else if (TREE_CODE (ctype) == ARRAY_TYPE)
10810 0 : elem_type = TREE_TYPE (ctype);
10811 :
10812 930 : helper_ptr_type = get_copy_helper_pointer_type ();
10813 :
10814 930 : comp_rank = c->as ? c->as->rank : 0;
10815 930 : alloc_expr = gfc_duplicate_allocatable_nocopy (dcmp, comp, ctype,
10816 : comp_rank);
10817 930 : gfc_add_expr_to_block (&fnblock, alloc_expr);
10818 :
10819 : /* Generate or reuse the element copy helper. Inside an
10820 : existing helper we can reuse the current function to
10821 : prevent recursive generation. */
10822 930 : if (inside_wrapper)
10823 703 : copy_wrapper
10824 703 : = gfc_build_addr_expr (NULL_TREE, current_function_decl);
10825 : else
10826 227 : copy_wrapper
10827 227 : = generate_element_copy_wrapper (c->ts.u.derived, elem_type,
10828 : purpose, caf_mode);
10829 930 : copy_wrapper = fold_convert (helper_ptr_type, copy_wrapper);
10830 :
10831 : /* Build addresses of descriptors. */
10832 930 : dest_addr = gfc_build_addr_expr (pvoid_type_node, dcmp);
10833 930 : src_addr = gfc_build_addr_expr (pvoid_type_node, comp);
10834 :
10835 : /* Build call: _gfortran_cfi_deep_copy_array (&dcmp, &comp,
10836 : wrapper). */
10837 930 : call = build_call_expr_loc (input_location,
10838 : gfor_fndecl_cfi_deep_copy_array, 3,
10839 : dest_addr, src_addr,
10840 : copy_wrapper);
10841 930 : gfc_add_expr_to_block (&fnblock, call);
10842 : }
10843 : /* For allocatable arrays with nested allocatable components,
10844 : add_when_allocated already includes gfc_duplicate_allocatable
10845 : (from the recursive structure_alloc_comps call at line 10290-10293),
10846 : so we must not call it again here. PR121628 added an
10847 : add_when_allocated != NULL clause that was redundant for scalars
10848 : (already handled by !c->as) and wrong for arrays (double alloc). */
10849 5360 : else if (c->attr.allocatable && !c->attr.proc_pointer
10850 14776 : && (!cmp_has_alloc_comps
10851 810 : || !c->as
10852 585 : || c->attr.codimension
10853 582 : || caf_in_coarray (caf_mode)))
10854 : {
10855 4784 : rank = c->as ? c->as->rank : 0;
10856 4784 : if (c->attr.codimension)
10857 20 : tmp = gfc_copy_allocatable_data (dcmp, comp, ctype, rank);
10858 4764 : else if (flag_coarray == GFC_FCOARRAY_LIB
10859 4764 : && caf_in_coarray (caf_mode))
10860 : {
10861 62 : tree dst_tok;
10862 62 : if (c->as)
10863 44 : dst_tok = gfc_conv_descriptor_token (dcmp);
10864 : else
10865 : {
10866 18 : dst_tok
10867 18 : = fold_build3_loc (input_location, COMPONENT_REF,
10868 : pvoid_type_node, dest,
10869 18 : gfc_comp_caf_token (c), NULL_TREE);
10870 : }
10871 62 : tmp
10872 62 : = duplicate_allocatable_coarray (dcmp, dst_tok, comp, ctype,
10873 : rank, add_when_allocated);
10874 : }
10875 : else
10876 4702 : tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank,
10877 : add_when_allocated);
10878 4784 : gfc_add_expr_to_block (&fnblock, tmp);
10879 : }
10880 : else
10881 4632 : if (cmp_has_alloc_comps || is_pdt_type)
10882 1721 : gfc_add_expr_to_block (&fnblock, add_when_allocated);
10883 :
10884 : break;
10885 :
10886 1954 : case ALLOCATE_PDT_COMP:
10887 :
10888 1954 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10889 : decl, cdecl, NULL_TREE);
10890 :
10891 : /* Set the PDT KIND and LEN fields. */
10892 1954 : if (c->attr.pdt_kind || c->attr.pdt_len)
10893 : {
10894 895 : gfc_se tse;
10895 895 : gfc_expr *c_expr = NULL;
10896 895 : gfc_actual_arglist *param = pdt_param_list;
10897 895 : gfc_init_se (&tse, NULL);
10898 3219 : for (; param; param = param->next)
10899 1429 : if (param->name && !strcmp (c->name, param->name))
10900 883 : c_expr = param->expr;
10901 :
10902 895 : if (!c_expr)
10903 30 : c_expr = c->initializer;
10904 :
10905 30 : if (c_expr)
10906 : {
10907 877 : gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp));
10908 877 : gfc_add_block_to_block (&fnblock, &tse.pre);
10909 877 : gfc_add_modify (&fnblock, comp, tse.expr);
10910 877 : gfc_add_block_to_block (&fnblock, &tse.post);
10911 : }
10912 895 : }
10913 1059 : else if (c->initializer && !c->attr.pdt_string && !c->attr.pdt_array
10914 145 : && !c->as && !IS_PDT (c)) /* Take care of arrays. */
10915 : {
10916 49 : gfc_se tse;
10917 49 : gfc_expr *c_expr;
10918 49 : gfc_init_se (&tse, NULL);
10919 49 : c_expr = c->initializer;
10920 49 : gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp));
10921 49 : gfc_add_block_to_block (&fnblock, &tse.pre);
10922 49 : gfc_add_modify (&fnblock, comp, tse.expr);
10923 49 : gfc_add_block_to_block (&fnblock, &tse.post);
10924 : }
10925 :
10926 1954 : if (c->attr.pdt_string)
10927 : {
10928 90 : gfc_se tse;
10929 90 : gfc_init_se (&tse, NULL);
10930 90 : tree strlen = NULL_TREE;
10931 90 : gfc_expr *e = gfc_copy_expr (c->ts.u.cl->length);
10932 : /* Convert the parameterized string length to its value. The
10933 : string length is stored in a hidden field in the same way as
10934 : deferred string lengths. */
10935 90 : gfc_insert_parameter_exprs (e, pdt_param_list);
10936 90 : if (gfc_deferred_strlen (c, &strlen) && strlen != NULL_TREE)
10937 : {
10938 90 : gfc_conv_expr_type (&tse, e,
10939 90 : TREE_TYPE (strlen));
10940 90 : strlen = fold_build3_loc (input_location, COMPONENT_REF,
10941 90 : TREE_TYPE (strlen),
10942 : decl, strlen, NULL_TREE);
10943 90 : gfc_add_block_to_block (&fnblock, &tse.pre);
10944 90 : gfc_add_modify (&fnblock, strlen, tse.expr);
10945 90 : gfc_add_block_to_block (&fnblock, &tse.post);
10946 90 : c->ts.u.cl->backend_decl = strlen;
10947 : }
10948 90 : gfc_free_expr (e);
10949 :
10950 : /* Scalar parameterized strings can be allocated now. */
10951 90 : if (!c->as)
10952 : {
10953 90 : tmp = fold_convert (gfc_array_index_type, strlen);
10954 90 : tmp = size_of_string_in_bytes (c->ts.kind, tmp);
10955 90 : tmp = gfc_evaluate_now (tmp, &fnblock);
10956 90 : tmp = gfc_call_malloc (&fnblock, TREE_TYPE (comp), tmp);
10957 90 : gfc_add_modify (&fnblock, comp, tmp);
10958 : }
10959 : }
10960 :
10961 : /* Allocate parameterized arrays of parameterized derived types. */
10962 1954 : if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT)
10963 1673 : && !(IS_PDT (c) || IS_CLASS_PDT (c)))
10964 1487 : continue;
10965 :
10966 467 : if (c->ts.type == BT_CLASS)
10967 0 : comp = gfc_class_data_get (comp);
10968 :
10969 467 : if (c->attr.pdt_array)
10970 : {
10971 281 : gfc_se tse;
10972 281 : int i;
10973 281 : tree size = gfc_index_one_node;
10974 281 : tree offset = gfc_index_zero_node;
10975 281 : tree lower, upper;
10976 281 : gfc_expr *e;
10977 :
10978 : /* This chunk takes the expressions for 'lower' and 'upper'
10979 : in the arrayspec and substitutes in the expressions for
10980 : the parameters from 'pdt_param_list'. The descriptor
10981 : fields can then be filled from the values so obtained. */
10982 281 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)));
10983 664 : for (i = 0; i < c->as->rank; i++)
10984 : {
10985 383 : gfc_init_se (&tse, NULL);
10986 383 : e = gfc_copy_expr (c->as->lower[i]);
10987 383 : gfc_insert_parameter_exprs (e, pdt_param_list);
10988 383 : gfc_conv_expr_type (&tse, e, gfc_array_index_type);
10989 383 : gfc_free_expr (e);
10990 383 : lower = tse.expr;
10991 383 : gfc_add_block_to_block (&fnblock, &tse.pre);
10992 383 : gfc_conv_descriptor_lbound_set (&fnblock, comp,
10993 : gfc_rank_cst[i],
10994 : lower);
10995 383 : gfc_add_block_to_block (&fnblock, &tse.post);
10996 383 : e = gfc_copy_expr (c->as->upper[i]);
10997 383 : gfc_insert_parameter_exprs (e, pdt_param_list);
10998 383 : gfc_conv_expr_type (&tse, e, gfc_array_index_type);
10999 383 : gfc_free_expr (e);
11000 383 : upper = tse.expr;
11001 383 : gfc_add_block_to_block (&fnblock, &tse.pre);
11002 383 : gfc_conv_descriptor_ubound_set (&fnblock, comp,
11003 : gfc_rank_cst[i],
11004 : upper);
11005 383 : gfc_add_block_to_block (&fnblock, &tse.post);
11006 383 : gfc_conv_descriptor_stride_set (&fnblock, comp,
11007 : gfc_rank_cst[i],
11008 : size);
11009 383 : size = gfc_evaluate_now (size, &fnblock);
11010 383 : offset = fold_build2_loc (input_location,
11011 : MINUS_EXPR,
11012 : gfc_array_index_type,
11013 : offset, size);
11014 383 : offset = gfc_evaluate_now (offset, &fnblock);
11015 383 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
11016 : gfc_array_index_type,
11017 : upper, lower);
11018 383 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
11019 : gfc_array_index_type,
11020 : tmp, gfc_index_one_node);
11021 383 : size = fold_build2_loc (input_location, MULT_EXPR,
11022 : gfc_array_index_type, size, tmp);
11023 : }
11024 281 : gfc_conv_descriptor_offset_set (&fnblock, comp, offset);
11025 281 : if (c->ts.type == BT_CLASS)
11026 : {
11027 0 : tmp = gfc_get_vptr_from_expr (comp);
11028 0 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
11029 0 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
11030 0 : tmp = gfc_vptr_size_get (tmp);
11031 : }
11032 : else
11033 281 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (ctype));
11034 281 : tmp = fold_convert (gfc_array_index_type, tmp);
11035 281 : size = fold_build2_loc (input_location, MULT_EXPR,
11036 : gfc_array_index_type, size, tmp);
11037 281 : size = gfc_evaluate_now (size, &fnblock);
11038 281 : tmp = gfc_call_malloc (&fnblock, NULL, size);
11039 281 : gfc_conv_descriptor_data_set (&fnblock, comp, tmp);
11040 281 : tmp = gfc_conv_descriptor_dtype (comp);
11041 281 : gfc_add_modify (&fnblock, tmp, gfc_get_dtype (ctype));
11042 :
11043 281 : if (c->initializer && c->initializer->rank)
11044 : {
11045 0 : gfc_init_se (&tse, NULL);
11046 0 : e = gfc_copy_expr (c->initializer);
11047 0 : gfc_insert_parameter_exprs (e, pdt_param_list);
11048 0 : gfc_conv_expr_descriptor (&tse, e);
11049 0 : gfc_add_block_to_block (&fnblock, &tse.pre);
11050 0 : gfc_free_expr (e);
11051 0 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
11052 0 : tmp = build_call_expr_loc (input_location, tmp, 3,
11053 : gfc_conv_descriptor_data_get (comp),
11054 : gfc_conv_descriptor_data_get (tse.expr),
11055 : fold_convert (size_type_node, size));
11056 0 : gfc_add_expr_to_block (&fnblock, tmp);
11057 0 : gfc_add_block_to_block (&fnblock, &tse.post);
11058 : }
11059 : }
11060 :
11061 : /* Recurse in to PDT components. */
11062 467 : if ((IS_PDT (c) || IS_CLASS_PDT (c))
11063 200 : && !(c->attr.pointer || c->attr.allocatable))
11064 : {
11065 104 : gfc_actual_arglist *tail = c->param_list;
11066 :
11067 262 : for (; tail; tail = tail->next)
11068 158 : if (tail->expr)
11069 134 : gfc_insert_parameter_exprs (tail->expr, pdt_param_list);
11070 :
11071 104 : tmp = gfc_allocate_pdt_comp (c->ts.u.derived, comp,
11072 104 : c->as ? c->as->rank : 0,
11073 104 : c->param_list);
11074 104 : gfc_add_expr_to_block (&fnblock, tmp);
11075 : }
11076 :
11077 : break;
11078 :
11079 3593 : case DEALLOCATE_PDT_COMP:
11080 : /* Deallocate array or parameterized string length components
11081 : of parameterized derived types. */
11082 3593 : if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT)
11083 3051 : && !c->attr.pdt_string
11084 2943 : && !(IS_PDT (c) || IS_CLASS_PDT (c)))
11085 2479 : continue;
11086 :
11087 1114 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
11088 : decl, cdecl, NULL_TREE);
11089 1114 : if (c->ts.type == BT_CLASS)
11090 0 : comp = gfc_class_data_get (comp);
11091 :
11092 : /* Recurse in to PDT components. */
11093 1114 : if ((IS_PDT (c) || IS_CLASS_PDT (c))
11094 502 : && (!c->attr.pointer && !c->attr.allocatable))
11095 : {
11096 335 : tmp = gfc_deallocate_pdt_comp (c->ts.u.derived, comp,
11097 335 : c->as ? c->as->rank : 0);
11098 335 : gfc_add_expr_to_block (&fnblock, tmp);
11099 : }
11100 :
11101 1114 : if (c->attr.pdt_array || c->attr.pdt_string)
11102 : {
11103 650 : tmp = comp;
11104 650 : if (c->attr.pdt_array)
11105 542 : tmp = gfc_conv_descriptor_data_get (comp);
11106 650 : null_cond = fold_build2_loc (input_location, NE_EXPR,
11107 : logical_type_node, tmp,
11108 650 : build_int_cst (TREE_TYPE (tmp), 0));
11109 650 : if (flag_openmp_allocators)
11110 : {
11111 0 : tree cd, t;
11112 0 : if (c->attr.pdt_array)
11113 0 : cd = fold_build2_loc (input_location, EQ_EXPR,
11114 : boolean_type_node,
11115 : gfc_conv_descriptor_version (comp),
11116 : build_int_cst (integer_type_node, 1));
11117 : else
11118 0 : cd = gfc_omp_call_is_alloc (tmp);
11119 0 : t = builtin_decl_explicit (BUILT_IN_GOMP_FREE);
11120 0 : t = build_call_expr_loc (input_location, t, 1, tmp);
11121 :
11122 0 : stmtblock_t tblock;
11123 0 : gfc_init_block (&tblock);
11124 0 : gfc_add_expr_to_block (&tblock, t);
11125 0 : if (c->attr.pdt_array)
11126 0 : gfc_add_modify (&tblock, gfc_conv_descriptor_version (comp),
11127 : integer_zero_node);
11128 0 : tmp = build3_loc (input_location, COND_EXPR, void_type_node,
11129 : cd, gfc_finish_block (&tblock),
11130 : gfc_call_free (tmp));
11131 : }
11132 : else
11133 650 : tmp = gfc_call_free (tmp);
11134 650 : tmp = build3_v (COND_EXPR, null_cond, tmp,
11135 : build_empty_stmt (input_location));
11136 650 : gfc_add_expr_to_block (&fnblock, tmp);
11137 :
11138 650 : if (c->attr.pdt_array)
11139 542 : gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
11140 : else
11141 : {
11142 108 : tmp = fold_convert (TREE_TYPE (comp), null_pointer_node);
11143 108 : gfc_add_modify (&fnblock, comp, tmp);
11144 : }
11145 : }
11146 :
11147 : break;
11148 :
11149 336 : case CHECK_PDT_DUMMY:
11150 :
11151 336 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
11152 : decl, cdecl, NULL_TREE);
11153 336 : if (c->ts.type == BT_CLASS)
11154 0 : comp = gfc_class_data_get (comp);
11155 :
11156 : /* Recurse in to PDT components. */
11157 336 : if (((c->ts.type == BT_DERIVED
11158 14 : && !c->attr.allocatable && !c->attr.pointer)
11159 324 : || (c->ts.type == BT_CLASS
11160 0 : && !CLASS_DATA (c)->attr.allocatable
11161 0 : && !CLASS_DATA (c)->attr.pointer))
11162 12 : && c->ts.u.derived && c->ts.u.derived->attr.pdt_type)
11163 : {
11164 12 : tmp = gfc_check_pdt_dummy (c->ts.u.derived, comp,
11165 12 : c->as ? c->as->rank : 0,
11166 : pdt_param_list);
11167 12 : gfc_add_expr_to_block (&fnblock, tmp);
11168 : }
11169 :
11170 336 : if (!c->attr.pdt_len)
11171 288 : continue;
11172 : else
11173 : {
11174 48 : gfc_se tse;
11175 48 : gfc_expr *c_expr = NULL;
11176 48 : gfc_actual_arglist *param = pdt_param_list;
11177 :
11178 48 : gfc_init_se (&tse, NULL);
11179 186 : for (; param; param = param->next)
11180 90 : if (!strcmp (c->name, param->name)
11181 48 : && param->spec_type == SPEC_EXPLICIT)
11182 30 : c_expr = param->expr;
11183 :
11184 48 : if (c_expr)
11185 : {
11186 30 : tree error, cond, cname;
11187 30 : gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp));
11188 30 : cond = fold_build2_loc (input_location, NE_EXPR,
11189 : logical_type_node,
11190 : comp, tse.expr);
11191 30 : cname = gfc_build_cstring_const (c->name);
11192 30 : cname = gfc_build_addr_expr (pchar_type_node, cname);
11193 30 : error = gfc_trans_runtime_error (true, NULL,
11194 : "The value of the PDT LEN "
11195 : "parameter '%s' does not "
11196 : "agree with that in the "
11197 : "dummy declaration",
11198 : cname);
11199 30 : tmp = fold_build3_loc (input_location, COND_EXPR,
11200 : void_type_node, cond, error,
11201 : build_empty_stmt (input_location));
11202 30 : gfc_add_expr_to_block (&fnblock, tmp);
11203 : }
11204 : }
11205 48 : break;
11206 :
11207 0 : default:
11208 0 : gcc_unreachable ();
11209 7548 : break;
11210 : }
11211 : }
11212 20902 : seen_derived_types.remove (der_type);
11213 :
11214 20902 : return gfc_finish_block (&fnblock);
11215 : }
11216 :
11217 : /* Recursively traverse an object of derived type, generating code to
11218 : nullify allocatable components. */
11219 :
11220 : tree
11221 3114 : gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
11222 : int caf_mode)
11223 : {
11224 3114 : return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11225 : NULLIFY_ALLOC_COMP,
11226 : GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode,
11227 3114 : NULL);
11228 : }
11229 :
11230 :
11231 : /* Recursively traverse an object of derived type, generating code to
11232 : deallocate allocatable components. */
11233 :
11234 : tree
11235 3005 : gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
11236 : int caf_mode, bool no_finalization)
11237 : {
11238 3005 : return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11239 : DEALLOCATE_ALLOC_COMP,
11240 : GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode,
11241 3005 : NULL, no_finalization);
11242 : }
11243 :
11244 : tree
11245 1 : gfc_bcast_alloc_comp (gfc_symbol *derived, gfc_expr *expr, int rank,
11246 : tree image_index, tree stat, tree errmsg,
11247 : tree errmsg_len)
11248 : {
11249 1 : tree tmp, array;
11250 1 : gfc_se argse;
11251 1 : stmtblock_t block, post_block;
11252 1 : gfc_co_subroutines_args args;
11253 :
11254 1 : args.image_index = image_index;
11255 1 : args.stat = stat;
11256 1 : args.errmsg = errmsg;
11257 1 : args.errmsg_len = errmsg_len;
11258 :
11259 1 : if (rank == 0)
11260 : {
11261 1 : gfc_start_block (&block);
11262 1 : gfc_init_block (&post_block);
11263 1 : gfc_init_se (&argse, NULL);
11264 1 : gfc_conv_expr (&argse, expr);
11265 1 : gfc_add_block_to_block (&block, &argse.pre);
11266 1 : gfc_add_block_to_block (&post_block, &argse.post);
11267 1 : array = argse.expr;
11268 : }
11269 : else
11270 : {
11271 0 : gfc_init_se (&argse, NULL);
11272 0 : argse.want_pointer = 1;
11273 0 : gfc_conv_expr_descriptor (&argse, expr);
11274 0 : array = argse.expr;
11275 : }
11276 :
11277 1 : tmp = structure_alloc_comps (derived, array, NULL_TREE, rank,
11278 : BCAST_ALLOC_COMP,
11279 : GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY,
11280 : &args);
11281 1 : return tmp;
11282 : }
11283 :
11284 : /* Recursively traverse an object of derived type, generating code to
11285 : deallocate allocatable components. But do not deallocate coarrays.
11286 : To be used for intrinsic assignment, which may not change the allocation
11287 : status of coarrays. */
11288 :
11289 : tree
11290 3497 : gfc_deallocate_alloc_comp_no_caf (gfc_symbol * der_type, tree decl, int rank,
11291 : bool no_finalization)
11292 : {
11293 3497 : return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11294 : DEALLOCATE_ALLOC_COMP, 0, NULL,
11295 3497 : no_finalization);
11296 : }
11297 :
11298 :
11299 : tree
11300 5 : gfc_reassign_alloc_comp_caf (gfc_symbol *der_type, tree decl, tree dest)
11301 : {
11302 5 : return structure_alloc_comps (der_type, decl, dest, 0, REASSIGN_CAF_COMP,
11303 : GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY,
11304 5 : NULL);
11305 : }
11306 :
11307 :
11308 : /* Recursively traverse an object of derived type, generating code to
11309 : copy it and its allocatable components. */
11310 :
11311 : tree
11312 4489 : gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank,
11313 : int caf_mode)
11314 : {
11315 4489 : return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP,
11316 4489 : caf_mode, NULL);
11317 : }
11318 :
11319 :
11320 : /* Recursively traverse an object of derived type, generating code to
11321 : copy it and its allocatable components, while suppressing any
11322 : finalization that might occur. This is used in the finalization of
11323 : function results. */
11324 :
11325 : tree
11326 38 : gfc_copy_alloc_comp_no_fini (gfc_symbol * der_type, tree decl, tree dest,
11327 : int rank, int caf_mode)
11328 : {
11329 38 : return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP,
11330 38 : caf_mode, NULL, true);
11331 : }
11332 :
11333 :
11334 : /* Recursively traverse an object of derived type, generating code to
11335 : copy only its allocatable components. */
11336 :
11337 : tree
11338 0 : gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
11339 : {
11340 0 : return structure_alloc_comps (der_type, decl, dest, rank,
11341 0 : COPY_ONLY_ALLOC_COMP, 0, NULL);
11342 : }
11343 :
11344 :
11345 : /* Recursively traverse an object of parameterized derived type, generating
11346 : code to allocate parameterized components. */
11347 :
11348 : tree
11349 711 : gfc_allocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank,
11350 : gfc_actual_arglist *param_list)
11351 : {
11352 711 : tree res;
11353 711 : gfc_actual_arglist *old_param_list = pdt_param_list;
11354 711 : pdt_param_list = param_list;
11355 711 : res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11356 : ALLOCATE_PDT_COMP, 0, NULL);
11357 711 : pdt_param_list = old_param_list;
11358 711 : return res;
11359 : }
11360 :
11361 : /* Recursively traverse an object of parameterized derived type, generating
11362 : code to deallocate parameterized components. */
11363 :
11364 : tree
11365 1316 : gfc_deallocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank)
11366 : {
11367 : /* A type without parameterized components causes gimplifier problems. */
11368 1316 : if (!has_parameterized_comps (der_type))
11369 : return NULL_TREE;
11370 :
11371 583 : return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11372 583 : DEALLOCATE_PDT_COMP, 0, NULL);
11373 : }
11374 :
11375 :
11376 : /* Recursively traverse a dummy of parameterized derived type to check the
11377 : values of LEN parameters. */
11378 :
11379 : tree
11380 80 : gfc_check_pdt_dummy (gfc_symbol * der_type, tree decl, int rank,
11381 : gfc_actual_arglist *param_list)
11382 : {
11383 80 : tree res;
11384 80 : gfc_actual_arglist *old_param_list = pdt_param_list;
11385 80 : pdt_param_list = param_list;
11386 80 : res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11387 : CHECK_PDT_DUMMY, 0, NULL);
11388 80 : pdt_param_list = old_param_list;
11389 80 : return res;
11390 : }
11391 :
11392 :
11393 : /* Returns the value of LBOUND for an expression. This could be broken out
11394 : from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
11395 : called by gfc_alloc_allocatable_for_assignment. */
11396 : static tree
11397 1054 : get_std_lbound (gfc_expr *expr, tree desc, int dim, bool assumed_size)
11398 : {
11399 1054 : tree lbound;
11400 1054 : tree ubound;
11401 1054 : tree stride;
11402 1054 : tree cond, cond1, cond3, cond4;
11403 1054 : tree tmp;
11404 1054 : gfc_ref *ref;
11405 :
11406 1054 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
11407 : {
11408 508 : tmp = gfc_rank_cst[dim];
11409 508 : lbound = gfc_conv_descriptor_lbound_get (desc, tmp);
11410 508 : ubound = gfc_conv_descriptor_ubound_get (desc, tmp);
11411 508 : stride = gfc_conv_descriptor_stride_get (desc, tmp);
11412 508 : cond1 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
11413 : ubound, lbound);
11414 508 : cond3 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
11415 : stride, gfc_index_zero_node);
11416 508 : cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
11417 : logical_type_node, cond3, cond1);
11418 508 : cond4 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
11419 : stride, gfc_index_zero_node);
11420 508 : if (assumed_size)
11421 0 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
11422 : tmp, build_int_cst (gfc_array_index_type,
11423 0 : expr->rank - 1));
11424 : else
11425 508 : cond = logical_false_node;
11426 :
11427 508 : cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
11428 : logical_type_node, cond3, cond4);
11429 508 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
11430 : logical_type_node, cond, cond1);
11431 :
11432 508 : return fold_build3_loc (input_location, COND_EXPR,
11433 : gfc_array_index_type, cond,
11434 508 : lbound, gfc_index_one_node);
11435 : }
11436 :
11437 546 : if (expr->expr_type == EXPR_FUNCTION)
11438 : {
11439 : /* A conversion function, so use the argument. */
11440 7 : gcc_assert (expr->value.function.isym
11441 : && expr->value.function.isym->conversion);
11442 7 : expr = expr->value.function.actual->expr;
11443 : }
11444 :
11445 546 : if (expr->expr_type == EXPR_VARIABLE)
11446 : {
11447 546 : tmp = TREE_TYPE (expr->symtree->n.sym->backend_decl);
11448 1418 : for (ref = expr->ref; ref; ref = ref->next)
11449 : {
11450 872 : if (ref->type == REF_COMPONENT
11451 277 : && ref->u.c.component->as
11452 228 : && ref->next
11453 228 : && ref->next->u.ar.type == AR_FULL)
11454 186 : tmp = TREE_TYPE (ref->u.c.component->backend_decl);
11455 : }
11456 546 : return GFC_TYPE_ARRAY_LBOUND(tmp, dim);
11457 : }
11458 :
11459 0 : return gfc_index_one_node;
11460 : }
11461 :
11462 :
11463 : /* Returns true if an expression represents an lhs that can be reallocated
11464 : on assignment. */
11465 :
11466 : bool
11467 635055 : gfc_is_reallocatable_lhs (gfc_expr *expr)
11468 : {
11469 635055 : gfc_ref * ref;
11470 635055 : gfc_symbol *sym;
11471 :
11472 635055 : if (!flag_realloc_lhs)
11473 : return false;
11474 :
11475 634555 : if (!expr->ref)
11476 : return false;
11477 :
11478 213205 : sym = expr->symtree->n.sym;
11479 :
11480 213205 : if (sym->attr.associate_var && !expr->ref)
11481 : return false;
11482 :
11483 : /* An allocatable class variable with no reference. */
11484 213205 : if (sym->ts.type == BT_CLASS
11485 6258 : && (!sym->attr.associate_var || sym->attr.select_rank_temporary)
11486 6098 : && CLASS_DATA (sym)->attr.allocatable
11487 : && expr->ref
11488 3650 : && ((expr->ref->type == REF_ARRAY && expr->ref->u.ar.type == AR_FULL
11489 690 : && expr->ref->next == NULL)
11490 3033 : || (expr->ref->type == REF_COMPONENT
11491 2776 : && strcmp (expr->ref->u.c.component->name, "_data") == 0
11492 2039 : && (expr->ref->next == NULL
11493 2039 : || (expr->ref->next->type == REF_ARRAY
11494 2039 : && expr->ref->next->u.ar.type == AR_FULL
11495 1725 : && expr->ref->next->next == NULL)))))
11496 : return true;
11497 :
11498 : /* An allocatable variable. */
11499 211003 : if (sym->attr.allocatable
11500 46534 : && (!sym->attr.associate_var || sym->attr.select_rank_temporary)
11501 : && expr->ref
11502 46534 : && expr->ref->type == REF_ARRAY
11503 45057 : && expr->ref->u.ar.type == AR_FULL)
11504 : return true;
11505 :
11506 : /* All that can be left are allocatable components. */
11507 183161 : if (sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
11508 : return false;
11509 :
11510 : /* Find a component ref followed by an array reference. */
11511 88755 : for (ref = expr->ref; ref; ref = ref->next)
11512 62142 : if (ref->next
11513 35529 : && ref->type == REF_COMPONENT
11514 20320 : && ref->next->type == REF_ARRAY
11515 16753 : && !ref->next->next)
11516 : break;
11517 :
11518 39259 : if (!ref)
11519 : return false;
11520 :
11521 : /* Return true if valid reallocatable lhs. */
11522 12646 : if (ref->u.c.component->attr.allocatable
11523 6264 : && ref->next->u.ar.type == AR_FULL)
11524 4650 : return true;
11525 :
11526 : return false;
11527 : }
11528 :
11529 :
11530 : static tree
11531 56 : concat_str_length (gfc_expr* expr)
11532 : {
11533 56 : tree type;
11534 56 : tree len1;
11535 56 : tree len2;
11536 56 : gfc_se se;
11537 :
11538 56 : type = gfc_typenode_for_spec (&expr->value.op.op1->ts);
11539 56 : len1 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
11540 56 : if (len1 == NULL_TREE)
11541 : {
11542 56 : if (expr->value.op.op1->expr_type == EXPR_OP)
11543 31 : len1 = concat_str_length (expr->value.op.op1);
11544 25 : else if (expr->value.op.op1->expr_type == EXPR_CONSTANT)
11545 25 : len1 = build_int_cst (gfc_charlen_type_node,
11546 25 : expr->value.op.op1->value.character.length);
11547 0 : else if (expr->value.op.op1->ts.u.cl->length)
11548 : {
11549 0 : gfc_init_se (&se, NULL);
11550 0 : gfc_conv_expr (&se, expr->value.op.op1->ts.u.cl->length);
11551 0 : len1 = se.expr;
11552 : }
11553 : else
11554 : {
11555 : /* Last resort! */
11556 0 : gfc_init_se (&se, NULL);
11557 0 : se.want_pointer = 1;
11558 0 : se.descriptor_only = 1;
11559 0 : gfc_conv_expr (&se, expr->value.op.op1);
11560 0 : len1 = se.string_length;
11561 : }
11562 : }
11563 :
11564 56 : type = gfc_typenode_for_spec (&expr->value.op.op2->ts);
11565 56 : len2 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
11566 56 : if (len2 == NULL_TREE)
11567 : {
11568 31 : if (expr->value.op.op2->expr_type == EXPR_OP)
11569 0 : len2 = concat_str_length (expr->value.op.op2);
11570 31 : else if (expr->value.op.op2->expr_type == EXPR_CONSTANT)
11571 25 : len2 = build_int_cst (gfc_charlen_type_node,
11572 25 : expr->value.op.op2->value.character.length);
11573 6 : else if (expr->value.op.op2->ts.u.cl->length)
11574 : {
11575 6 : gfc_init_se (&se, NULL);
11576 6 : gfc_conv_expr (&se, expr->value.op.op2->ts.u.cl->length);
11577 6 : len2 = se.expr;
11578 : }
11579 : else
11580 : {
11581 : /* Last resort! */
11582 0 : gfc_init_se (&se, NULL);
11583 0 : se.want_pointer = 1;
11584 0 : se.descriptor_only = 1;
11585 0 : gfc_conv_expr (&se, expr->value.op.op2);
11586 0 : len2 = se.string_length;
11587 : }
11588 : }
11589 :
11590 56 : gcc_assert(len1 && len2);
11591 56 : len1 = fold_convert (gfc_charlen_type_node, len1);
11592 56 : len2 = fold_convert (gfc_charlen_type_node, len2);
11593 :
11594 56 : return fold_build2_loc (input_location, PLUS_EXPR,
11595 56 : gfc_charlen_type_node, len1, len2);
11596 : }
11597 :
11598 :
11599 : /* Among the scalarization chain of LOOP, find the element associated with an
11600 : allocatable array on the lhs of an assignment and evaluate its fields
11601 : (bounds, offset, etc) to new variables, putting the new code in BLOCK. This
11602 : function is to be called after putting the reallocation code in BLOCK and
11603 : before the beginning of the scalarization loop body.
11604 :
11605 : The fields to be saved are expected to hold on entry to the function
11606 : expressions referencing the array descriptor. Especially the expressions
11607 : shouldn't be already temporary variable references as the value saved before
11608 : reallocation would be incorrect after reallocation.
11609 : At the end of the function, the expressions have been replaced with variable
11610 : references. */
11611 :
11612 : static void
11613 6655 : update_reallocated_descriptor (stmtblock_t *block, gfc_loopinfo *loop)
11614 : {
11615 23233 : for (gfc_ss *s = loop->ss; s != gfc_ss_terminator; s = s->loop_chain)
11616 : {
11617 16578 : if (!s->is_alloc_lhs)
11618 9923 : continue;
11619 :
11620 6655 : gcc_assert (s->info->type == GFC_SS_SECTION);
11621 6655 : gfc_array_info *info = &s->info->data.array;
11622 :
11623 : #define SAVE_VALUE(value) \
11624 : do \
11625 : { \
11626 : value = gfc_evaluate_now (value, block); \
11627 : } \
11628 : while (0)
11629 :
11630 6655 : if (save_descriptor_data (info->descriptor, info->data))
11631 5839 : SAVE_VALUE (info->data);
11632 6655 : SAVE_VALUE (info->offset);
11633 6655 : info->saved_offset = info->offset;
11634 16515 : for (int i = 0; i < s->dimen; i++)
11635 : {
11636 9860 : int dim = s->dim[i];
11637 9860 : SAVE_VALUE (info->start[dim]);
11638 9860 : SAVE_VALUE (info->end[dim]);
11639 9860 : SAVE_VALUE (info->stride[dim]);
11640 9860 : SAVE_VALUE (info->delta[dim]);
11641 : }
11642 :
11643 : #undef SAVE_VALUE
11644 : }
11645 6655 : }
11646 :
11647 :
11648 : /* Allocate the lhs of an assignment to an allocatable array, otherwise
11649 : reallocate it. */
11650 :
11651 : tree
11652 6655 : gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
11653 : gfc_expr *expr1,
11654 : gfc_expr *expr2)
11655 : {
11656 6655 : stmtblock_t realloc_block;
11657 6655 : stmtblock_t alloc_block;
11658 6655 : stmtblock_t fblock;
11659 6655 : stmtblock_t loop_pre_block;
11660 6655 : gfc_ref *ref;
11661 6655 : gfc_ss *rss;
11662 6655 : gfc_ss *lss;
11663 6655 : gfc_array_info *linfo;
11664 6655 : tree realloc_expr;
11665 6655 : tree alloc_expr;
11666 6655 : tree size1;
11667 6655 : tree size2;
11668 6655 : tree elemsize1;
11669 6655 : tree elemsize2;
11670 6655 : tree array1;
11671 6655 : tree cond_null;
11672 6655 : tree cond;
11673 6655 : tree tmp;
11674 6655 : tree tmp2;
11675 6655 : tree lbound;
11676 6655 : tree ubound;
11677 6655 : tree desc;
11678 6655 : tree old_desc;
11679 6655 : tree desc2;
11680 6655 : tree offset;
11681 6655 : tree jump_label1;
11682 6655 : tree jump_label2;
11683 6655 : tree lbd;
11684 6655 : tree class_expr2 = NULL_TREE;
11685 6655 : int n;
11686 6655 : gfc_array_spec * as;
11687 6655 : bool coarray = (flag_coarray == GFC_FCOARRAY_LIB
11688 6655 : && gfc_caf_attr (expr1, true).codimension);
11689 6655 : tree token;
11690 6655 : gfc_se caf_se;
11691 :
11692 : /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
11693 : Find the lhs expression in the loop chain and set expr1 and
11694 : expr2 accordingly. */
11695 6655 : if (expr1->expr_type == EXPR_FUNCTION && expr2 == NULL)
11696 : {
11697 203 : expr2 = expr1;
11698 : /* Find the ss for the lhs. */
11699 203 : lss = loop->ss;
11700 406 : for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
11701 406 : if (lss->info->expr && lss->info->expr->expr_type == EXPR_VARIABLE)
11702 : break;
11703 203 : if (lss == gfc_ss_terminator)
11704 : return NULL_TREE;
11705 203 : expr1 = lss->info->expr;
11706 : }
11707 :
11708 : /* Bail out if this is not a valid allocate on assignment. */
11709 6655 : if (!gfc_is_reallocatable_lhs (expr1)
11710 6655 : || (expr2 && !expr2->rank))
11711 : return NULL_TREE;
11712 :
11713 : /* Find the ss for the lhs. */
11714 6655 : lss = loop->ss;
11715 16578 : for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
11716 16578 : if (lss->info->expr == expr1)
11717 : break;
11718 :
11719 6655 : if (lss == gfc_ss_terminator)
11720 : return NULL_TREE;
11721 :
11722 6655 : linfo = &lss->info->data.array;
11723 :
11724 : /* Find an ss for the rhs. For operator expressions, we see the
11725 : ss's for the operands. Any one of these will do. */
11726 6655 : rss = loop->ss;
11727 7259 : for (; rss && rss != gfc_ss_terminator; rss = rss->loop_chain)
11728 7259 : if (rss->info->expr != expr1 && rss != loop->temp_ss)
11729 : break;
11730 :
11731 6655 : if (expr2 && rss == gfc_ss_terminator)
11732 : return NULL_TREE;
11733 :
11734 : /* Ensure that the string length from the current scope is used. */
11735 6655 : if (expr2->ts.type == BT_CHARACTER
11736 983 : && expr2->expr_type == EXPR_FUNCTION
11737 130 : && !expr2->value.function.isym)
11738 21 : expr2->ts.u.cl->backend_decl = rss->info->string_length;
11739 :
11740 : /* Since the lhs is allocatable, this must be a descriptor type.
11741 : Get the data and array size. */
11742 6655 : desc = linfo->descriptor;
11743 6655 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
11744 6655 : array1 = gfc_conv_descriptor_data_get (desc);
11745 :
11746 : /* If the data is null, set the descriptor bounds and offset. This suppresses
11747 : the maybe used uninitialized warning. Note that the always false variable
11748 : prevents this block from ever being executed, and makes sure that the
11749 : optimizers are able to remove it. Component references are not subject to
11750 : the warnings, so we don't uselessly complicate the generated code for them.
11751 : */
11752 11886 : for (ref = expr1->ref; ref; ref = ref->next)
11753 6862 : if (ref->type == REF_COMPONENT)
11754 : break;
11755 :
11756 6655 : if (!ref)
11757 : {
11758 5024 : stmtblock_t unalloc_init_block;
11759 5024 : gfc_init_block (&unalloc_init_block);
11760 5024 : tree guard = gfc_create_var (logical_type_node, "unallocated_init_guard");
11761 5024 : gfc_add_modify (&unalloc_init_block, guard, logical_false_node);
11762 :
11763 5024 : gfc_start_block (&loop_pre_block);
11764 17920 : for (n = 0; n < expr1->rank; n++)
11765 : {
11766 7872 : gfc_conv_descriptor_lbound_set (&loop_pre_block, desc,
11767 : gfc_rank_cst[n],
11768 : gfc_index_one_node);
11769 7872 : gfc_conv_descriptor_ubound_set (&loop_pre_block, desc,
11770 : gfc_rank_cst[n],
11771 : gfc_index_zero_node);
11772 7872 : gfc_conv_descriptor_stride_set (&loop_pre_block, desc,
11773 : gfc_rank_cst[n],
11774 : gfc_index_zero_node);
11775 : }
11776 :
11777 5024 : gfc_conv_descriptor_offset_set (&loop_pre_block, desc,
11778 : gfc_index_zero_node);
11779 :
11780 5024 : tmp = fold_build2_loc (input_location, EQ_EXPR,
11781 : logical_type_node, array1,
11782 5024 : build_int_cst (TREE_TYPE (array1), 0));
11783 5024 : tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
11784 : logical_type_node, tmp, guard);
11785 5024 : tmp = build3_v (COND_EXPR, tmp,
11786 : gfc_finish_block (&loop_pre_block),
11787 : build_empty_stmt (input_location));
11788 5024 : gfc_prepend_expr_to_block (&loop->pre, tmp);
11789 5024 : gfc_prepend_expr_to_block (&loop->pre,
11790 : gfc_finish_block (&unalloc_init_block));
11791 : }
11792 :
11793 6655 : gfc_start_block (&fblock);
11794 :
11795 6655 : if (expr2)
11796 6655 : desc2 = rss->info->data.array.descriptor;
11797 : else
11798 : desc2 = NULL_TREE;
11799 :
11800 : /* Get the old lhs element size for deferred character and class expr1. */
11801 6655 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
11802 : {
11803 663 : if (expr1->ts.u.cl->backend_decl
11804 663 : && VAR_P (expr1->ts.u.cl->backend_decl))
11805 : elemsize1 = expr1->ts.u.cl->backend_decl;
11806 : else
11807 64 : elemsize1 = lss->info->string_length;
11808 663 : tree unit_size = TYPE_SIZE_UNIT (gfc_get_char_type (expr1->ts.kind));
11809 1326 : elemsize1 = fold_build2_loc (input_location, MULT_EXPR,
11810 663 : TREE_TYPE (elemsize1), elemsize1,
11811 663 : fold_convert (TREE_TYPE (elemsize1), unit_size));
11812 :
11813 663 : }
11814 5992 : else if (expr1->ts.type == BT_CLASS)
11815 : {
11816 : /* Unfortunately, the lhs vptr is set too early in many cases.
11817 : Play it safe by using the descriptor element length. */
11818 645 : tmp = gfc_conv_descriptor_elem_len (desc);
11819 645 : elemsize1 = fold_convert (gfc_array_index_type, tmp);
11820 : }
11821 : else
11822 : elemsize1 = NULL_TREE;
11823 1308 : if (elemsize1 != NULL_TREE)
11824 1308 : elemsize1 = gfc_evaluate_now (elemsize1, &fblock);
11825 :
11826 : /* Get the new lhs size in bytes. */
11827 6655 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
11828 : {
11829 663 : if (expr2->ts.deferred)
11830 : {
11831 183 : if (expr2->ts.u.cl->backend_decl
11832 183 : && VAR_P (expr2->ts.u.cl->backend_decl))
11833 : tmp = expr2->ts.u.cl->backend_decl;
11834 : else
11835 0 : tmp = rss->info->string_length;
11836 : }
11837 : else
11838 : {
11839 480 : tmp = expr2->ts.u.cl->backend_decl;
11840 480 : if (!tmp && expr2->expr_type == EXPR_OP
11841 25 : && expr2->value.op.op == INTRINSIC_CONCAT)
11842 : {
11843 25 : tmp = concat_str_length (expr2);
11844 25 : expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
11845 : }
11846 12 : else if (!tmp && expr2->ts.u.cl->length)
11847 : {
11848 12 : gfc_se tmpse;
11849 12 : gfc_init_se (&tmpse, NULL);
11850 12 : gfc_conv_expr_type (&tmpse, expr2->ts.u.cl->length,
11851 : gfc_charlen_type_node);
11852 12 : tmp = tmpse.expr;
11853 12 : expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
11854 : }
11855 480 : tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
11856 : }
11857 :
11858 663 : if (expr1->ts.u.cl->backend_decl
11859 663 : && VAR_P (expr1->ts.u.cl->backend_decl))
11860 599 : gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
11861 : else
11862 64 : gfc_add_modify (&fblock, lss->info->string_length, tmp);
11863 :
11864 663 : if (expr1->ts.kind > 1)
11865 12 : tmp = fold_build2_loc (input_location, MULT_EXPR,
11866 6 : TREE_TYPE (tmp),
11867 6 : tmp, build_int_cst (TREE_TYPE (tmp),
11868 6 : expr1->ts.kind));
11869 : }
11870 5992 : else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
11871 : {
11872 271 : tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts)));
11873 271 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
11874 : fold_convert (gfc_array_index_type, tmp),
11875 271 : expr1->ts.u.cl->backend_decl);
11876 : }
11877 5721 : else if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS)
11878 164 : tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
11879 5557 : else if (expr1->ts.type == BT_CLASS && expr2->ts.type == BT_CLASS)
11880 : {
11881 280 : tmp = expr2->rank ? gfc_get_class_from_expr (desc2) : NULL_TREE;
11882 280 : if (tmp == NULL_TREE && expr2->expr_type == EXPR_VARIABLE)
11883 36 : tmp = class_expr2 = gfc_get_class_from_gfc_expr (expr2);
11884 :
11885 43 : if (tmp != NULL_TREE)
11886 273 : tmp = gfc_class_vtab_size_get (tmp);
11887 : else
11888 7 : tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&CLASS_DATA (expr2)->ts));
11889 : }
11890 : else
11891 5277 : tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
11892 6655 : elemsize2 = fold_convert (gfc_array_index_type, tmp);
11893 6655 : elemsize2 = gfc_evaluate_now (elemsize2, &fblock);
11894 :
11895 : /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
11896 : deallocated if expr is an array of different shape or any of the
11897 : corresponding length type parameter values of variable and expr
11898 : differ." This assures F95 compatibility. */
11899 6655 : jump_label1 = gfc_build_label_decl (NULL_TREE);
11900 6655 : jump_label2 = gfc_build_label_decl (NULL_TREE);
11901 :
11902 : /* Allocate if data is NULL. */
11903 6655 : cond_null = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
11904 6655 : array1, build_int_cst (TREE_TYPE (array1), 0));
11905 6655 : cond_null= gfc_evaluate_now (cond_null, &fblock);
11906 :
11907 6655 : tmp = build3_v (COND_EXPR, cond_null,
11908 : build1_v (GOTO_EXPR, jump_label1),
11909 : build_empty_stmt (input_location));
11910 6655 : gfc_add_expr_to_block (&fblock, tmp);
11911 :
11912 : /* Get arrayspec if expr is a full array. */
11913 6655 : if (expr2 && expr2->expr_type == EXPR_FUNCTION
11914 2814 : && expr2->value.function.isym
11915 2295 : && expr2->value.function.isym->conversion)
11916 : {
11917 : /* For conversion functions, take the arg. */
11918 245 : gfc_expr *arg = expr2->value.function.actual->expr;
11919 245 : as = gfc_get_full_arrayspec_from_expr (arg);
11920 245 : }
11921 : else if (expr2)
11922 6410 : as = gfc_get_full_arrayspec_from_expr (expr2);
11923 : else
11924 : as = NULL;
11925 :
11926 : /* If the lhs shape is not the same as the rhs jump to setting the
11927 : bounds and doing the reallocation....... */
11928 16515 : for (n = 0; n < expr1->rank; n++)
11929 : {
11930 : /* Check the shape. */
11931 9860 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
11932 9860 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
11933 9860 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
11934 : gfc_array_index_type,
11935 : loop->to[n], loop->from[n]);
11936 9860 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
11937 : gfc_array_index_type,
11938 : tmp, lbound);
11939 9860 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
11940 : gfc_array_index_type,
11941 : tmp, ubound);
11942 9860 : cond = fold_build2_loc (input_location, NE_EXPR,
11943 : logical_type_node,
11944 : tmp, gfc_index_zero_node);
11945 9860 : tmp = build3_v (COND_EXPR, cond,
11946 : build1_v (GOTO_EXPR, jump_label1),
11947 : build_empty_stmt (input_location));
11948 9860 : gfc_add_expr_to_block (&fblock, tmp);
11949 : }
11950 :
11951 : /* ...else if the element lengths are not the same also go to
11952 : setting the bounds and doing the reallocation.... */
11953 6655 : if (elemsize1 != NULL_TREE)
11954 : {
11955 1308 : cond = fold_build2_loc (input_location, NE_EXPR,
11956 : logical_type_node,
11957 : elemsize1, elemsize2);
11958 1308 : tmp = build3_v (COND_EXPR, cond,
11959 : build1_v (GOTO_EXPR, jump_label1),
11960 : build_empty_stmt (input_location));
11961 1308 : gfc_add_expr_to_block (&fblock, tmp);
11962 : }
11963 :
11964 : /* ....else jump past the (re)alloc code. */
11965 6655 : tmp = build1_v (GOTO_EXPR, jump_label2);
11966 6655 : gfc_add_expr_to_block (&fblock, tmp);
11967 :
11968 : /* Add the label to start automatic (re)allocation. */
11969 6655 : tmp = build1_v (LABEL_EXPR, jump_label1);
11970 6655 : gfc_add_expr_to_block (&fblock, tmp);
11971 :
11972 : /* Get the rhs size and fix it. */
11973 6655 : size2 = gfc_index_one_node;
11974 16515 : for (n = 0; n < expr2->rank; n++)
11975 : {
11976 9860 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
11977 : gfc_array_index_type,
11978 : loop->to[n], loop->from[n]);
11979 9860 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
11980 : gfc_array_index_type,
11981 : tmp, gfc_index_one_node);
11982 9860 : size2 = fold_build2_loc (input_location, MULT_EXPR,
11983 : gfc_array_index_type,
11984 : tmp, size2);
11985 : }
11986 6655 : size2 = gfc_evaluate_now (size2, &fblock);
11987 :
11988 : /* Deallocation of allocatable components will have to occur on
11989 : reallocation. Fix the old descriptor now. */
11990 6655 : if ((expr1->ts.type == BT_DERIVED)
11991 441 : && expr1->ts.u.derived->attr.alloc_comp)
11992 200 : old_desc = gfc_evaluate_now (desc, &fblock);
11993 : else
11994 : old_desc = NULL_TREE;
11995 :
11996 : /* Now modify the lhs descriptor and the associated scalarizer
11997 : variables. F2003 7.4.1.3: "If variable is or becomes an
11998 : unallocated allocatable variable, then it is allocated with each
11999 : deferred type parameter equal to the corresponding type parameters
12000 : of expr , with the shape of expr , and with each lower bound equal
12001 : to the corresponding element of LBOUND(expr)."
12002 : Reuse size1 to keep a dimension-by-dimension track of the
12003 : stride of the new array. */
12004 6655 : size1 = gfc_index_one_node;
12005 6655 : offset = gfc_index_zero_node;
12006 :
12007 16515 : for (n = 0; n < expr2->rank; n++)
12008 : {
12009 9860 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
12010 : gfc_array_index_type,
12011 : loop->to[n], loop->from[n]);
12012 9860 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
12013 : gfc_array_index_type,
12014 : tmp, gfc_index_one_node);
12015 :
12016 9860 : lbound = gfc_index_one_node;
12017 9860 : ubound = tmp;
12018 :
12019 9860 : if (as)
12020 : {
12021 2108 : lbd = get_std_lbound (expr2, desc2, n,
12022 1054 : as->type == AS_ASSUMED_SIZE);
12023 1054 : ubound = fold_build2_loc (input_location,
12024 : MINUS_EXPR,
12025 : gfc_array_index_type,
12026 : ubound, lbound);
12027 1054 : ubound = fold_build2_loc (input_location,
12028 : PLUS_EXPR,
12029 : gfc_array_index_type,
12030 : ubound, lbd);
12031 1054 : lbound = lbd;
12032 : }
12033 :
12034 9860 : gfc_conv_descriptor_lbound_set (&fblock, desc,
12035 : gfc_rank_cst[n],
12036 : lbound);
12037 9860 : gfc_conv_descriptor_ubound_set (&fblock, desc,
12038 : gfc_rank_cst[n],
12039 : ubound);
12040 9860 : gfc_conv_descriptor_stride_set (&fblock, desc,
12041 : gfc_rank_cst[n],
12042 : size1);
12043 9860 : lbound = gfc_conv_descriptor_lbound_get (desc,
12044 : gfc_rank_cst[n]);
12045 9860 : tmp2 = fold_build2_loc (input_location, MULT_EXPR,
12046 : gfc_array_index_type,
12047 : lbound, size1);
12048 9860 : offset = fold_build2_loc (input_location, MINUS_EXPR,
12049 : gfc_array_index_type,
12050 : offset, tmp2);
12051 9860 : size1 = fold_build2_loc (input_location, MULT_EXPR,
12052 : gfc_array_index_type,
12053 : tmp, size1);
12054 : }
12055 :
12056 : /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
12057 : the array offset is saved and the info.offset is used for a
12058 : running offset. Use the saved_offset instead. */
12059 6655 : tmp = gfc_conv_descriptor_offset (desc);
12060 6655 : gfc_add_modify (&fblock, tmp, offset);
12061 :
12062 : /* Take into account _len of unlimited polymorphic entities, so that span
12063 : for array descriptors and allocation sizes are computed correctly. */
12064 6655 : if (UNLIMITED_POLY (expr2))
12065 : {
12066 92 : tree len = gfc_class_len_get (TREE_OPERAND (desc2, 0));
12067 92 : len = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
12068 : fold_convert (size_type_node, len),
12069 : size_one_node);
12070 92 : elemsize2 = fold_build2_loc (input_location, MULT_EXPR,
12071 : gfc_array_index_type, elemsize2,
12072 : fold_convert (gfc_array_index_type, len));
12073 : }
12074 :
12075 6655 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
12076 6655 : gfc_conv_descriptor_span_set (&fblock, desc, elemsize2);
12077 :
12078 6655 : size2 = fold_build2_loc (input_location, MULT_EXPR,
12079 : gfc_array_index_type,
12080 : elemsize2, size2);
12081 6655 : size2 = fold_convert (size_type_node, size2);
12082 6655 : size2 = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
12083 : size2, size_one_node);
12084 6655 : size2 = gfc_evaluate_now (size2, &fblock);
12085 :
12086 : /* For deferred character length, the 'size' field of the dtype might
12087 : have changed so set the dtype. */
12088 6655 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
12089 6655 : && expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12090 : {
12091 663 : tree type;
12092 663 : tmp = gfc_conv_descriptor_dtype (desc);
12093 663 : if (expr2->ts.u.cl->backend_decl)
12094 663 : type = gfc_typenode_for_spec (&expr2->ts);
12095 : else
12096 0 : type = gfc_typenode_for_spec (&expr1->ts);
12097 :
12098 663 : gfc_add_modify (&fblock, tmp,
12099 : gfc_get_dtype_rank_type (expr1->rank,type));
12100 : }
12101 5992 : else if (expr1->ts.type == BT_CLASS)
12102 : {
12103 645 : tree type;
12104 645 : tmp = gfc_conv_descriptor_dtype (desc);
12105 :
12106 645 : if (expr2->ts.type != BT_CLASS)
12107 365 : type = gfc_typenode_for_spec (&expr2->ts);
12108 : else
12109 280 : type = gfc_get_character_type_len (1, elemsize2);
12110 :
12111 645 : gfc_add_modify (&fblock, tmp,
12112 : gfc_get_dtype_rank_type (expr2->rank,type));
12113 : /* Set the _len field as well... */
12114 645 : if (UNLIMITED_POLY (expr1))
12115 : {
12116 256 : tmp = gfc_class_len_get (TREE_OPERAND (desc, 0));
12117 256 : if (expr2->ts.type == BT_CHARACTER)
12118 49 : gfc_add_modify (&fblock, tmp,
12119 49 : fold_convert (TREE_TYPE (tmp),
12120 : TYPE_SIZE_UNIT (type)));
12121 207 : else if (UNLIMITED_POLY (expr2))
12122 92 : gfc_add_modify (&fblock, tmp,
12123 92 : gfc_class_len_get (TREE_OPERAND (desc2, 0)));
12124 : else
12125 115 : gfc_add_modify (&fblock, tmp,
12126 115 : build_int_cst (TREE_TYPE (tmp), 0));
12127 : }
12128 : /* ...and the vptr. */
12129 645 : tmp = gfc_class_vptr_get (TREE_OPERAND (desc, 0));
12130 645 : if (expr2->ts.type == BT_CLASS && !VAR_P (desc2)
12131 273 : && TREE_CODE (desc2) == COMPONENT_REF)
12132 : {
12133 237 : tmp2 = gfc_get_class_from_expr (desc2);
12134 237 : tmp2 = gfc_class_vptr_get (tmp2);
12135 : }
12136 408 : else if (expr2->ts.type == BT_CLASS && class_expr2 != NULL_TREE)
12137 36 : tmp2 = gfc_class_vptr_get (class_expr2);
12138 : else
12139 : {
12140 372 : tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts));
12141 372 : tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2);
12142 : }
12143 :
12144 645 : gfc_add_modify (&fblock, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
12145 : }
12146 5347 : else if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
12147 : {
12148 39 : gfc_add_modify (&fblock, gfc_conv_descriptor_dtype (desc),
12149 39 : gfc_get_dtype (TREE_TYPE (desc)));
12150 : }
12151 :
12152 : /* Realloc expression. Note that the scalarizer uses desc.data
12153 : in the array reference - (*desc.data)[<element>]. */
12154 6655 : gfc_init_block (&realloc_block);
12155 6655 : gfc_init_se (&caf_se, NULL);
12156 :
12157 6655 : if (coarray)
12158 : {
12159 39 : token = gfc_get_ultimate_alloc_ptr_comps_caf_token (&caf_se, expr1);
12160 39 : if (token == NULL_TREE)
12161 : {
12162 9 : tmp = gfc_get_tree_for_caf_expr (expr1);
12163 9 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
12164 6 : tmp = build_fold_indirect_ref (tmp);
12165 9 : gfc_get_caf_token_offset (&caf_se, &token, NULL, tmp, NULL_TREE,
12166 : expr1);
12167 9 : token = gfc_build_addr_expr (NULL_TREE, token);
12168 : }
12169 :
12170 39 : gfc_add_block_to_block (&realloc_block, &caf_se.pre);
12171 : }
12172 6655 : if ((expr1->ts.type == BT_DERIVED)
12173 441 : && expr1->ts.u.derived->attr.alloc_comp)
12174 : {
12175 200 : tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, old_desc,
12176 : expr1->rank, true);
12177 200 : gfc_add_expr_to_block (&realloc_block, tmp);
12178 : }
12179 :
12180 6655 : if (!coarray)
12181 : {
12182 6616 : tmp = build_call_expr_loc (input_location,
12183 : builtin_decl_explicit (BUILT_IN_REALLOC), 2,
12184 : fold_convert (pvoid_type_node, array1),
12185 : size2);
12186 6616 : if (flag_openmp_allocators)
12187 : {
12188 2 : tree cond, omp_tmp;
12189 2 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
12190 : gfc_conv_descriptor_version (desc),
12191 : build_int_cst (integer_type_node, 1));
12192 2 : omp_tmp = builtin_decl_explicit (BUILT_IN_GOMP_REALLOC);
12193 2 : omp_tmp = build_call_expr_loc (input_location, omp_tmp, 4,
12194 : fold_convert (pvoid_type_node, array1), size2,
12195 : build_zero_cst (ptr_type_node),
12196 : build_zero_cst (ptr_type_node));
12197 2 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond,
12198 : omp_tmp, tmp);
12199 : }
12200 :
12201 6616 : gfc_conv_descriptor_data_set (&realloc_block, desc, tmp);
12202 : }
12203 : else
12204 : {
12205 39 : tmp = build_call_expr_loc (input_location,
12206 : gfor_fndecl_caf_deregister, 5, token,
12207 : build_int_cst (integer_type_node,
12208 : GFC_CAF_COARRAY_DEALLOCATE_ONLY),
12209 : null_pointer_node, null_pointer_node,
12210 : integer_zero_node);
12211 39 : gfc_add_expr_to_block (&realloc_block, tmp);
12212 39 : tmp = build_call_expr_loc (input_location,
12213 : gfor_fndecl_caf_register,
12214 : 7, size2,
12215 : build_int_cst (integer_type_node,
12216 : GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY),
12217 : token, gfc_build_addr_expr (NULL_TREE, desc),
12218 : null_pointer_node, null_pointer_node,
12219 : integer_zero_node);
12220 39 : gfc_add_expr_to_block (&realloc_block, tmp);
12221 : }
12222 :
12223 6655 : if ((expr1->ts.type == BT_DERIVED)
12224 441 : && expr1->ts.u.derived->attr.alloc_comp)
12225 : {
12226 200 : tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc,
12227 : expr1->rank);
12228 200 : gfc_add_expr_to_block (&realloc_block, tmp);
12229 : }
12230 :
12231 6655 : gfc_add_block_to_block (&realloc_block, &caf_se.post);
12232 6655 : realloc_expr = gfc_finish_block (&realloc_block);
12233 :
12234 : /* Malloc expression. */
12235 6655 : gfc_init_block (&alloc_block);
12236 6655 : if (!coarray)
12237 : {
12238 6616 : tmp = build_call_expr_loc (input_location,
12239 : builtin_decl_explicit (BUILT_IN_MALLOC),
12240 : 1, size2);
12241 6616 : gfc_conv_descriptor_data_set (&alloc_block,
12242 : desc, tmp);
12243 : }
12244 : else
12245 : {
12246 39 : tmp = build_call_expr_loc (input_location,
12247 : gfor_fndecl_caf_register,
12248 : 7, size2,
12249 : build_int_cst (integer_type_node,
12250 : GFC_CAF_COARRAY_ALLOC),
12251 : token, gfc_build_addr_expr (NULL_TREE, desc),
12252 : null_pointer_node, null_pointer_node,
12253 : integer_zero_node);
12254 39 : gfc_add_expr_to_block (&alloc_block, tmp);
12255 : }
12256 :
12257 :
12258 : /* We already set the dtype in the case of deferred character
12259 : length arrays and class lvalues. */
12260 6655 : if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
12261 6655 : && ((expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12262 5992 : || coarray))
12263 12608 : && expr1->ts.type != BT_CLASS)
12264 : {
12265 5308 : tmp = gfc_conv_descriptor_dtype (desc);
12266 5308 : gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
12267 : }
12268 :
12269 6655 : if ((expr1->ts.type == BT_DERIVED)
12270 441 : && expr1->ts.u.derived->attr.alloc_comp)
12271 : {
12272 200 : tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc,
12273 : expr1->rank);
12274 200 : gfc_add_expr_to_block (&alloc_block, tmp);
12275 : }
12276 6655 : alloc_expr = gfc_finish_block (&alloc_block);
12277 :
12278 : /* Malloc if not allocated; realloc otherwise. */
12279 6655 : tmp = build3_v (COND_EXPR, cond_null, alloc_expr, realloc_expr);
12280 6655 : gfc_add_expr_to_block (&fblock, tmp);
12281 :
12282 : /* Add the label for same shape lhs and rhs. */
12283 6655 : tmp = build1_v (LABEL_EXPR, jump_label2);
12284 6655 : gfc_add_expr_to_block (&fblock, tmp);
12285 :
12286 6655 : tree realloc_code = gfc_finish_block (&fblock);
12287 :
12288 6655 : stmtblock_t result_block;
12289 6655 : gfc_init_block (&result_block);
12290 6655 : gfc_add_expr_to_block (&result_block, realloc_code);
12291 6655 : update_reallocated_descriptor (&result_block, loop);
12292 :
12293 6655 : return gfc_finish_block (&result_block);
12294 : }
12295 :
12296 :
12297 : /* Initialize class descriptor's TKR information. */
12298 :
12299 : void
12300 2938 : gfc_trans_class_array (gfc_symbol * sym, gfc_wrapped_block * block)
12301 : {
12302 2938 : tree type, etype;
12303 2938 : tree tmp;
12304 2938 : tree descriptor;
12305 2938 : stmtblock_t init;
12306 2938 : int rank;
12307 :
12308 : /* Make sure the frontend gets these right. */
12309 2938 : gcc_assert (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
12310 : && (CLASS_DATA (sym)->attr.class_pointer
12311 : || CLASS_DATA (sym)->attr.allocatable));
12312 :
12313 2938 : gcc_assert (VAR_P (sym->backend_decl)
12314 : || TREE_CODE (sym->backend_decl) == PARM_DECL);
12315 :
12316 2938 : if (sym->attr.dummy)
12317 1436 : return;
12318 :
12319 2938 : descriptor = gfc_class_data_get (sym->backend_decl);
12320 2938 : type = TREE_TYPE (descriptor);
12321 :
12322 2938 : if (type == NULL || !GFC_DESCRIPTOR_TYPE_P (type))
12323 : return;
12324 :
12325 1502 : location_t loc = input_location;
12326 1502 : input_location = gfc_get_location (&sym->declared_at);
12327 1502 : gfc_init_block (&init);
12328 :
12329 1502 : rank = CLASS_DATA (sym)->as ? (CLASS_DATA (sym)->as->rank) : (0);
12330 1502 : gcc_assert (rank>=0);
12331 1502 : tmp = gfc_conv_descriptor_dtype (descriptor);
12332 1502 : etype = gfc_get_element_type (type);
12333 1502 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (tmp), tmp,
12334 : gfc_get_dtype_rank_type (rank, etype));
12335 1502 : gfc_add_expr_to_block (&init, tmp);
12336 :
12337 1502 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
12338 1502 : input_location = loc;
12339 : }
12340 :
12341 :
12342 : /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
12343 : Do likewise, recursively if necessary, with the allocatable components of
12344 : derived types. This function is also called for assumed-rank arrays, which
12345 : are always dummy arguments. */
12346 :
12347 : void
12348 18089 : gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
12349 : {
12350 18089 : tree type;
12351 18089 : tree tmp;
12352 18089 : tree descriptor;
12353 18089 : stmtblock_t init;
12354 18089 : stmtblock_t cleanup;
12355 18089 : int rank;
12356 18089 : bool sym_has_alloc_comp, has_finalizer;
12357 :
12358 36178 : sym_has_alloc_comp = (sym->ts.type == BT_DERIVED
12359 10927 : || sym->ts.type == BT_CLASS)
12360 18089 : && sym->ts.u.derived->attr.alloc_comp;
12361 18089 : has_finalizer = gfc_may_be_finalized (sym->ts);
12362 :
12363 : /* Make sure the frontend gets these right. */
12364 18089 : gcc_assert (sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp
12365 : || has_finalizer
12366 : || (sym->as->type == AS_ASSUMED_RANK && sym->attr.dummy));
12367 :
12368 18089 : location_t loc = input_location;
12369 18089 : input_location = gfc_get_location (&sym->declared_at);
12370 18089 : gfc_init_block (&init);
12371 :
12372 18089 : gcc_assert (VAR_P (sym->backend_decl)
12373 : || TREE_CODE (sym->backend_decl) == PARM_DECL);
12374 :
12375 18089 : if (sym->ts.type == BT_CHARACTER
12376 1390 : && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
12377 : {
12378 812 : if (sym->ts.deferred && !sym->ts.u.cl->length && !sym->attr.dummy)
12379 : {
12380 607 : tree len_expr = sym->ts.u.cl->backend_decl;
12381 607 : tree init_val = build_zero_cst (TREE_TYPE (len_expr));
12382 607 : if (VAR_P (len_expr)
12383 607 : && sym->attr.save
12384 662 : && !DECL_INITIAL (len_expr))
12385 55 : DECL_INITIAL (len_expr) = init_val;
12386 : else
12387 552 : gfc_add_modify (&init, len_expr, init_val);
12388 : }
12389 812 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
12390 812 : gfc_trans_vla_type_sizes (sym, &init);
12391 :
12392 : /* Presence check of optional deferred-length character dummy. */
12393 812 : if (sym->ts.deferred && sym->attr.dummy && sym->attr.optional)
12394 : {
12395 43 : tmp = gfc_finish_block (&init);
12396 43 : tmp = build3_v (COND_EXPR, gfc_conv_expr_present (sym),
12397 : tmp, build_empty_stmt (input_location));
12398 43 : gfc_add_expr_to_block (&init, tmp);
12399 : }
12400 : }
12401 :
12402 : /* Dummy, use associated and result variables don't need anything special. */
12403 18089 : if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result)
12404 : {
12405 882 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
12406 882 : input_location = loc;
12407 1158 : return;
12408 : }
12409 :
12410 17207 : descriptor = sym->backend_decl;
12411 :
12412 : /* Although static, derived types with default initializers and
12413 : allocatable components must not be nulled wholesale; instead they
12414 : are treated component by component. */
12415 17207 : if (TREE_STATIC (descriptor) && !sym_has_alloc_comp && !has_finalizer)
12416 : {
12417 : /* SAVEd variables are not freed on exit. */
12418 276 : gfc_trans_static_array_pointer (sym);
12419 :
12420 276 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
12421 276 : input_location = loc;
12422 276 : return;
12423 : }
12424 :
12425 : /* Get the descriptor type. */
12426 16931 : type = TREE_TYPE (sym->backend_decl);
12427 :
12428 16931 : if ((sym_has_alloc_comp || (has_finalizer && sym->ts.type != BT_CLASS))
12429 5563 : && !(sym->attr.pointer || sym->attr.allocatable))
12430 : {
12431 2892 : if (!sym->attr.save
12432 2495 : && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program))
12433 : {
12434 2495 : if (sym->value == NULL
12435 2495 : || !gfc_has_default_initializer (sym->ts.u.derived))
12436 : {
12437 2063 : rank = sym->as ? sym->as->rank : 0;
12438 2063 : tmp = gfc_nullify_alloc_comp (sym->ts.u.derived,
12439 : descriptor, rank);
12440 2063 : gfc_add_expr_to_block (&init, tmp);
12441 : }
12442 : else
12443 432 : gfc_init_default_dt (sym, &init, false);
12444 : }
12445 : }
12446 14039 : else if (!GFC_DESCRIPTOR_TYPE_P (type))
12447 : {
12448 : /* If the backend_decl is not a descriptor, we must have a pointer
12449 : to one. */
12450 2087 : descriptor = build_fold_indirect_ref_loc (input_location,
12451 : sym->backend_decl);
12452 2087 : type = TREE_TYPE (descriptor);
12453 : }
12454 :
12455 : /* NULLIFY the data pointer for non-saved allocatables, or for non-saved
12456 : pointers when -fcheck=pointer is specified. */
12457 28883 : if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save
12458 28870 : && (sym->attr.allocatable
12459 3281 : || (sym->attr.pointer && (gfc_option.rtcheck & GFC_RTCHECK_POINTER))))
12460 : {
12461 8701 : gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node);
12462 8701 : if (flag_coarray == GFC_FCOARRAY_LIB && sym->attr.codimension)
12463 : {
12464 : /* Declare the variable static so its array descriptor stays present
12465 : after leaving the scope. It may still be accessed through another
12466 : image. This may happen, for example, with the caf_mpi
12467 : implementation. */
12468 161 : TREE_STATIC (descriptor) = 1;
12469 161 : tmp = gfc_conv_descriptor_token (descriptor);
12470 161 : gfc_add_modify (&init, tmp, fold_convert (TREE_TYPE (tmp),
12471 : null_pointer_node));
12472 : }
12473 : }
12474 :
12475 : /* Set initial TKR for pointers and allocatables */
12476 16931 : if (GFC_DESCRIPTOR_TYPE_P (type)
12477 16931 : && (sym->attr.pointer || sym->attr.allocatable))
12478 : {
12479 11952 : tree etype;
12480 :
12481 11952 : gcc_assert (sym->as && sym->as->rank>=0);
12482 11952 : tmp = gfc_conv_descriptor_dtype (descriptor);
12483 11952 : etype = gfc_get_element_type (type);
12484 11952 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
12485 11952 : TREE_TYPE (tmp), tmp,
12486 11952 : gfc_get_dtype_rank_type (sym->as->rank, etype));
12487 11952 : gfc_add_expr_to_block (&init, tmp);
12488 : }
12489 16931 : input_location = loc;
12490 16931 : gfc_init_block (&cleanup);
12491 :
12492 : /* Allocatable arrays need to be freed when they go out of scope.
12493 : The allocatable components of pointers must not be touched. */
12494 16931 : if (!sym->attr.allocatable && has_finalizer && sym->ts.type != BT_CLASS
12495 604 : && !sym->attr.pointer && !sym->attr.artificial && !sym->attr.save
12496 315 : && !sym->ns->proc_name->attr.is_main_program)
12497 : {
12498 276 : gfc_expr *e;
12499 276 : sym->attr.referenced = 1;
12500 276 : e = gfc_lval_expr_from_sym (sym);
12501 276 : gfc_add_finalizer_call (&cleanup, e);
12502 276 : gfc_free_expr (e);
12503 276 : }
12504 16655 : else if ((!sym->attr.allocatable || !has_finalizer)
12505 16531 : && sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
12506 5006 : && !sym->attr.pointer && !sym->attr.save
12507 2496 : && !(sym->attr.artificial && sym->name[0] == '_')
12508 2441 : && !sym->ns->proc_name->attr.is_main_program)
12509 : {
12510 663 : int rank;
12511 663 : rank = sym->as ? sym->as->rank : 0;
12512 663 : tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank,
12513 663 : (sym->attr.codimension
12514 3 : && flag_coarray == GFC_FCOARRAY_LIB)
12515 : ? GFC_STRUCTURE_CAF_MODE_IN_COARRAY
12516 : : 0);
12517 663 : gfc_add_expr_to_block (&cleanup, tmp);
12518 : }
12519 :
12520 16931 : if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension)
12521 8665 : && !sym->attr.save && !sym->attr.result
12522 8658 : && !sym->ns->proc_name->attr.is_main_program)
12523 : {
12524 4544 : gfc_expr *e;
12525 4544 : e = has_finalizer ? gfc_lval_expr_from_sym (sym) : NULL;
12526 9088 : tmp = gfc_deallocate_with_status (sym->backend_decl, NULL_TREE, NULL_TREE,
12527 : NULL_TREE, NULL_TREE, true, e,
12528 4544 : sym->attr.codimension
12529 : ? GFC_CAF_COARRAY_DEREGISTER
12530 : : GFC_CAF_COARRAY_NOCOARRAY,
12531 : NULL_TREE, gfc_finish_block (&cleanup));
12532 4544 : if (e)
12533 45 : gfc_free_expr (e);
12534 4544 : gfc_init_block (&cleanup);
12535 4544 : gfc_add_expr_to_block (&cleanup, tmp);
12536 : }
12537 :
12538 16931 : gfc_add_init_cleanup (block, gfc_finish_block (&init),
12539 : gfc_finish_block (&cleanup));
12540 : }
12541 :
12542 : /************ Expression Walking Functions ******************/
12543 :
12544 : /* Walk a variable reference.
12545 :
12546 : Possible extension - multiple component subscripts.
12547 : x(:,:) = foo%a(:)%b(:)
12548 : Transforms to
12549 : forall (i=..., j=...)
12550 : x(i,j) = foo%a(j)%b(i)
12551 : end forall
12552 : This adds a fair amount of complexity because you need to deal with more
12553 : than one ref. Maybe handle in a similar manner to vector subscripts.
12554 : Maybe not worth the effort. */
12555 :
12556 :
12557 : static gfc_ss *
12558 687429 : gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
12559 : {
12560 687429 : gfc_ref *ref;
12561 :
12562 687429 : gfc_fix_class_refs (expr);
12563 :
12564 803286 : for (ref = expr->ref; ref; ref = ref->next)
12565 446297 : if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
12566 : break;
12567 :
12568 687429 : return gfc_walk_array_ref (ss, expr, ref);
12569 : }
12570 :
12571 : gfc_ss *
12572 687786 : gfc_walk_array_ref (gfc_ss *ss, gfc_expr *expr, gfc_ref *ref, bool array_only)
12573 : {
12574 687786 : gfc_array_ref *ar;
12575 687786 : gfc_ss *newss;
12576 687786 : int n;
12577 :
12578 1027762 : for (; ref; ref = ref->next)
12579 : {
12580 339976 : if (ref->type == REF_SUBSTRING)
12581 : {
12582 1314 : ss = gfc_get_scalar_ss (ss, ref->u.ss.start);
12583 1314 : if (ref->u.ss.end)
12584 1288 : ss = gfc_get_scalar_ss (ss, ref->u.ss.end);
12585 : }
12586 :
12587 : /* We're only interested in array sections from now on. */
12588 339976 : if (ref->type != REF_ARRAY
12589 331207 : || (array_only && ref->u.ar.as && ref->u.ar.as->rank == 0))
12590 8884 : continue;
12591 :
12592 331092 : ar = &ref->u.ar;
12593 :
12594 331092 : switch (ar->type)
12595 : {
12596 326 : case AR_ELEMENT:
12597 699 : for (n = ar->dimen - 1; n >= 0; n--)
12598 373 : ss = gfc_get_scalar_ss (ss, ar->start[n]);
12599 : break;
12600 :
12601 274333 : case AR_FULL:
12602 : /* Assumed shape arrays from interface mapping need this fix. */
12603 274333 : if (!ar->as && expr->symtree->n.sym->as)
12604 : {
12605 6 : ar->as = gfc_get_array_spec();
12606 6 : *ar->as = *expr->symtree->n.sym->as;
12607 : }
12608 274333 : newss = gfc_get_array_ss (ss, expr, ar->as->rank, GFC_SS_SECTION);
12609 274333 : newss->info->data.array.ref = ref;
12610 :
12611 : /* Make sure array is the same as array(:,:), this way
12612 : we don't need to special case all the time. */
12613 274333 : ar->dimen = ar->as->rank;
12614 631494 : for (n = 0; n < ar->dimen; n++)
12615 : {
12616 357161 : ar->dimen_type[n] = DIMEN_RANGE;
12617 :
12618 357161 : gcc_assert (ar->start[n] == NULL);
12619 357161 : gcc_assert (ar->end[n] == NULL);
12620 357161 : gcc_assert (ar->stride[n] == NULL);
12621 : }
12622 : ss = newss;
12623 : break;
12624 :
12625 56433 : case AR_SECTION:
12626 56433 : newss = gfc_get_array_ss (ss, expr, 0, GFC_SS_SECTION);
12627 56433 : newss->info->data.array.ref = ref;
12628 :
12629 : /* We add SS chains for all the subscripts in the section. */
12630 145238 : for (n = 0; n < ar->dimen; n++)
12631 : {
12632 88805 : gfc_ss *indexss;
12633 :
12634 88805 : switch (ar->dimen_type[n])
12635 : {
12636 6792 : case DIMEN_ELEMENT:
12637 : /* Add SS for elemental (scalar) subscripts. */
12638 6792 : gcc_assert (ar->start[n]);
12639 6792 : indexss = gfc_get_scalar_ss (gfc_ss_terminator, ar->start[n]);
12640 6792 : indexss->loop_chain = gfc_ss_terminator;
12641 6792 : newss->info->data.array.subscript[n] = indexss;
12642 6792 : break;
12643 :
12644 80973 : case DIMEN_RANGE:
12645 : /* We don't add anything for sections, just remember this
12646 : dimension for later. */
12647 80973 : newss->dim[newss->dimen] = n;
12648 80973 : newss->dimen++;
12649 80973 : break;
12650 :
12651 1040 : case DIMEN_VECTOR:
12652 : /* Create a GFC_SS_VECTOR index in which we can store
12653 : the vector's descriptor. */
12654 1040 : indexss = gfc_get_array_ss (gfc_ss_terminator, ar->start[n],
12655 : 1, GFC_SS_VECTOR);
12656 1040 : indexss->loop_chain = gfc_ss_terminator;
12657 1040 : newss->info->data.array.subscript[n] = indexss;
12658 1040 : newss->dim[newss->dimen] = n;
12659 1040 : newss->dimen++;
12660 1040 : break;
12661 :
12662 0 : default:
12663 : /* We should know what sort of section it is by now. */
12664 0 : gcc_unreachable ();
12665 : }
12666 : }
12667 : /* We should have at least one non-elemental dimension,
12668 : unless we are creating a descriptor for a (scalar) coarray. */
12669 56433 : gcc_assert (newss->dimen > 0
12670 : || newss->info->data.array.ref->u.ar.as->corank > 0);
12671 : ss = newss;
12672 : break;
12673 :
12674 0 : default:
12675 : /* We should know what sort of section it is by now. */
12676 0 : gcc_unreachable ();
12677 : }
12678 :
12679 : }
12680 687786 : return ss;
12681 : }
12682 :
12683 :
12684 : /* Walk an expression operator. If only one operand of a binary expression is
12685 : scalar, we must also add the scalar term to the SS chain. */
12686 :
12687 : static gfc_ss *
12688 57773 : gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
12689 : {
12690 57773 : gfc_ss *head;
12691 57773 : gfc_ss *head2;
12692 :
12693 57773 : head = gfc_walk_subexpr (ss, expr->value.op.op1);
12694 57773 : if (expr->value.op.op2 == NULL)
12695 : head2 = head;
12696 : else
12697 55133 : head2 = gfc_walk_subexpr (head, expr->value.op.op2);
12698 :
12699 : /* All operands are scalar. Pass back and let the caller deal with it. */
12700 57773 : if (head2 == ss)
12701 : return head2;
12702 :
12703 : /* All operands require scalarization. */
12704 52012 : if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
12705 : return head2;
12706 :
12707 : /* One of the operands needs scalarization, the other is scalar.
12708 : Create a gfc_ss for the scalar expression. */
12709 19430 : if (head == ss)
12710 : {
12711 : /* First operand is scalar. We build the chain in reverse order, so
12712 : add the scalar SS after the second operand. */
12713 : head = head2;
12714 2272 : while (head && head->next != ss)
12715 : head = head->next;
12716 : /* Check we haven't somehow broken the chain. */
12717 2029 : gcc_assert (head);
12718 2029 : head->next = gfc_get_scalar_ss (ss, expr->value.op.op1);
12719 : }
12720 : else /* head2 == head */
12721 : {
12722 17401 : gcc_assert (head2 == head);
12723 : /* Second operand is scalar. */
12724 17401 : head2 = gfc_get_scalar_ss (head2, expr->value.op.op2);
12725 : }
12726 :
12727 : return head2;
12728 : }
12729 :
12730 : static gfc_ss *
12731 36 : gfc_walk_conditional_expr (gfc_ss *ss, gfc_expr *expr)
12732 : {
12733 36 : gfc_ss *head;
12734 :
12735 36 : head = gfc_walk_subexpr (ss, expr->value.conditional.true_expr);
12736 36 : head = gfc_walk_subexpr (head, expr->value.conditional.false_expr);
12737 36 : return head;
12738 : }
12739 :
12740 : /* Reverse a SS chain. */
12741 :
12742 : gfc_ss *
12743 863388 : gfc_reverse_ss (gfc_ss * ss)
12744 : {
12745 863388 : gfc_ss *next;
12746 863388 : gfc_ss *head;
12747 :
12748 863388 : gcc_assert (ss != NULL);
12749 :
12750 : head = gfc_ss_terminator;
12751 1303523 : while (ss != gfc_ss_terminator)
12752 : {
12753 440135 : next = ss->next;
12754 : /* Check we didn't somehow break the chain. */
12755 440135 : gcc_assert (next != NULL);
12756 440135 : ss->next = head;
12757 440135 : head = ss;
12758 440135 : ss = next;
12759 : }
12760 :
12761 863388 : return (head);
12762 : }
12763 :
12764 :
12765 : /* Given an expression referring to a procedure, return the symbol of its
12766 : interface. We can't get the procedure symbol directly as we have to handle
12767 : the case of (deferred) type-bound procedures. */
12768 :
12769 : gfc_symbol *
12770 161 : gfc_get_proc_ifc_for_expr (gfc_expr *procedure_ref)
12771 : {
12772 161 : gfc_symbol *sym;
12773 161 : gfc_ref *ref;
12774 :
12775 161 : if (procedure_ref == NULL)
12776 : return NULL;
12777 :
12778 : /* Normal procedure case. */
12779 161 : if (procedure_ref->expr_type == EXPR_FUNCTION
12780 161 : && procedure_ref->value.function.esym)
12781 : sym = procedure_ref->value.function.esym;
12782 : else
12783 24 : sym = procedure_ref->symtree->n.sym;
12784 :
12785 : /* Typebound procedure case. */
12786 209 : for (ref = procedure_ref->ref; ref; ref = ref->next)
12787 : {
12788 48 : if (ref->type == REF_COMPONENT
12789 48 : && ref->u.c.component->attr.proc_pointer)
12790 24 : sym = ref->u.c.component->ts.interface;
12791 : else
12792 : sym = NULL;
12793 : }
12794 :
12795 : return sym;
12796 : }
12797 :
12798 :
12799 : /* Given an expression referring to an intrinsic function call,
12800 : return the intrinsic symbol. */
12801 :
12802 : gfc_intrinsic_sym *
12803 7964 : gfc_get_intrinsic_for_expr (gfc_expr *call)
12804 : {
12805 7964 : if (call == NULL)
12806 : return NULL;
12807 :
12808 : /* Normal procedure case. */
12809 2366 : if (call->expr_type == EXPR_FUNCTION)
12810 2260 : return call->value.function.isym;
12811 : else
12812 : return NULL;
12813 : }
12814 :
12815 :
12816 : /* Indicates whether an argument to an intrinsic function should be used in
12817 : scalarization. It is usually the case, except for some intrinsics
12818 : requiring the value to be constant, and using the value at compile time only.
12819 : As the value is not used at runtime in those cases, we don’t produce code
12820 : for it, and it should not be visible to the scalarizer.
12821 : FUNCTION is the intrinsic function being called, ACTUAL_ARG is the actual
12822 : argument being examined in that call, and ARG_NUM the index number
12823 : of ACTUAL_ARG in the list of arguments.
12824 : The intrinsic procedure’s dummy argument associated with ACTUAL_ARG is
12825 : identified using the name in ACTUAL_ARG if it is present (that is: if it’s
12826 : a keyword argument), otherwise using ARG_NUM. */
12827 :
12828 : static bool
12829 38054 : arg_evaluated_for_scalarization (gfc_intrinsic_sym *function,
12830 : gfc_dummy_arg *dummy_arg)
12831 : {
12832 38054 : if (function != NULL && dummy_arg != NULL)
12833 : {
12834 12467 : switch (function->id)
12835 : {
12836 241 : case GFC_ISYM_INDEX:
12837 241 : case GFC_ISYM_LEN_TRIM:
12838 241 : case GFC_ISYM_MASKL:
12839 241 : case GFC_ISYM_MASKR:
12840 241 : case GFC_ISYM_SCAN:
12841 241 : case GFC_ISYM_VERIFY:
12842 241 : if (strcmp ("kind", gfc_dummy_arg_get_name (*dummy_arg)) == 0)
12843 : return false;
12844 : /* Fallthrough. */
12845 :
12846 : default:
12847 : break;
12848 : }
12849 : }
12850 :
12851 : return true;
12852 : }
12853 :
12854 :
12855 : /* Walk the arguments of an elemental function.
12856 : PROC_EXPR is used to check whether an argument is permitted to be absent. If
12857 : it is NULL, we don't do the check and the argument is assumed to be present.
12858 : */
12859 :
12860 : gfc_ss *
12861 27035 : gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
12862 : gfc_intrinsic_sym *intrinsic_sym,
12863 : gfc_ss_type type)
12864 : {
12865 27035 : int scalar;
12866 27035 : gfc_ss *head;
12867 27035 : gfc_ss *tail;
12868 27035 : gfc_ss *newss;
12869 :
12870 27035 : head = gfc_ss_terminator;
12871 27035 : tail = NULL;
12872 :
12873 27035 : scalar = 1;
12874 66553 : for (; arg; arg = arg->next)
12875 : {
12876 39518 : gfc_dummy_arg * const dummy_arg = arg->associated_dummy;
12877 41015 : if (!arg->expr
12878 38204 : || arg->expr->expr_type == EXPR_NULL
12879 77572 : || !arg_evaluated_for_scalarization (intrinsic_sym, dummy_arg))
12880 1497 : continue;
12881 :
12882 38021 : newss = gfc_walk_subexpr (head, arg->expr);
12883 38021 : if (newss == head)
12884 : {
12885 : /* Scalar argument. */
12886 18592 : gcc_assert (type == GFC_SS_SCALAR || type == GFC_SS_REFERENCE);
12887 18592 : newss = gfc_get_scalar_ss (head, arg->expr);
12888 18592 : newss->info->type = type;
12889 18592 : if (dummy_arg)
12890 15463 : newss->info->data.scalar.dummy_arg = dummy_arg;
12891 : }
12892 : else
12893 : scalar = 0;
12894 :
12895 34892 : if (dummy_arg != NULL
12896 26426 : && gfc_dummy_arg_is_optional (*dummy_arg)
12897 2538 : && arg->expr->expr_type == EXPR_VARIABLE
12898 36596 : && (gfc_expr_attr (arg->expr).optional
12899 1223 : || gfc_expr_attr (arg->expr).allocatable
12900 37968 : || gfc_expr_attr (arg->expr).pointer))
12901 1005 : newss->info->can_be_null_ref = true;
12902 :
12903 38021 : head = newss;
12904 38021 : if (!tail)
12905 : {
12906 : tail = head;
12907 33747 : while (tail->next != gfc_ss_terminator)
12908 : tail = tail->next;
12909 : }
12910 : }
12911 :
12912 27035 : if (scalar)
12913 : {
12914 : /* If all the arguments are scalar we don't need the argument SS. */
12915 10372 : gfc_free_ss_chain (head);
12916 : /* Pass it back. */
12917 10372 : return ss;
12918 : }
12919 :
12920 : /* Add it onto the existing chain. */
12921 16663 : tail->next = ss;
12922 16663 : return head;
12923 : }
12924 :
12925 :
12926 : /* Walk a function call. Scalar functions are passed back, and taken out of
12927 : scalarization loops. For elemental functions we walk their arguments.
12928 : The result of functions returning arrays is stored in a temporary outside
12929 : the loop, so that the function is only called once. Hence we do not need
12930 : to walk their arguments. */
12931 :
12932 : static gfc_ss *
12933 63638 : gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
12934 : {
12935 63638 : gfc_intrinsic_sym *isym;
12936 63638 : gfc_symbol *sym;
12937 63638 : gfc_component *comp = NULL;
12938 :
12939 63638 : isym = expr->value.function.isym;
12940 :
12941 : /* Handle intrinsic functions separately. */
12942 63638 : if (isym)
12943 55904 : return gfc_walk_intrinsic_function (ss, expr, isym);
12944 :
12945 7734 : sym = expr->value.function.esym;
12946 7734 : if (!sym)
12947 546 : sym = expr->symtree->n.sym;
12948 :
12949 7734 : if (gfc_is_class_array_function (expr))
12950 234 : return gfc_get_array_ss (ss, expr,
12951 234 : CLASS_DATA (expr->value.function.esym->result)->as->rank,
12952 234 : GFC_SS_FUNCTION);
12953 :
12954 : /* A function that returns arrays. */
12955 7500 : comp = gfc_get_proc_ptr_comp (expr);
12956 7102 : if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
12957 7500 : || (comp && comp->attr.dimension))
12958 2680 : return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
12959 :
12960 : /* Walk the parameters of an elemental function. For now we always pass
12961 : by reference. */
12962 4820 : if (sym->attr.elemental || (comp && comp->attr.elemental))
12963 : {
12964 2224 : gfc_ss *old_ss = ss;
12965 :
12966 2224 : ss = gfc_walk_elemental_function_args (old_ss,
12967 : expr->value.function.actual,
12968 : gfc_get_intrinsic_for_expr (expr),
12969 : GFC_SS_REFERENCE);
12970 2224 : if (ss != old_ss
12971 1188 : && (comp
12972 1127 : || sym->attr.proc_pointer
12973 1127 : || sym->attr.if_source != IFSRC_DECL
12974 1005 : || sym->attr.array_outer_dependency))
12975 231 : ss->info->array_outer_dependency = 1;
12976 : }
12977 :
12978 : /* Scalar functions are OK as these are evaluated outside the scalarization
12979 : loop. Pass back and let the caller deal with it. */
12980 : return ss;
12981 : }
12982 :
12983 :
12984 : /* An array temporary is constructed for array constructors. */
12985 :
12986 : static gfc_ss *
12987 50764 : gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
12988 : {
12989 0 : return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_CONSTRUCTOR);
12990 : }
12991 :
12992 :
12993 : /* Walk an expression. Add walked expressions to the head of the SS chain.
12994 : A wholly scalar expression will not be added. */
12995 :
12996 : gfc_ss *
12997 1018609 : gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
12998 : {
12999 1018609 : gfc_ss *head;
13000 :
13001 1018609 : switch (expr->expr_type)
13002 : {
13003 687429 : case EXPR_VARIABLE:
13004 687429 : head = gfc_walk_variable_expr (ss, expr);
13005 687429 : return head;
13006 :
13007 57773 : case EXPR_OP:
13008 57773 : head = gfc_walk_op_expr (ss, expr);
13009 57773 : return head;
13010 :
13011 36 : case EXPR_CONDITIONAL:
13012 36 : head = gfc_walk_conditional_expr (ss, expr);
13013 36 : return head;
13014 :
13015 63638 : case EXPR_FUNCTION:
13016 63638 : head = gfc_walk_function_expr (ss, expr);
13017 63638 : return head;
13018 :
13019 : case EXPR_CONSTANT:
13020 : case EXPR_NULL:
13021 : case EXPR_STRUCTURE:
13022 : /* Pass back and let the caller deal with it. */
13023 : break;
13024 :
13025 50764 : case EXPR_ARRAY:
13026 50764 : head = gfc_walk_array_constructor (ss, expr);
13027 50764 : return head;
13028 :
13029 : case EXPR_SUBSTRING:
13030 : /* Pass back and let the caller deal with it. */
13031 : break;
13032 :
13033 0 : default:
13034 0 : gfc_internal_error ("bad expression type during walk (%d)",
13035 : expr->expr_type);
13036 : }
13037 : return ss;
13038 : }
13039 :
13040 :
13041 : /* Entry point for expression walking.
13042 : A return value equal to the passed chain means this is
13043 : a scalar expression. It is up to the caller to take whatever action is
13044 : necessary to translate these. */
13045 :
13046 : gfc_ss *
13047 860575 : gfc_walk_expr (gfc_expr * expr)
13048 : {
13049 860575 : gfc_ss *res;
13050 :
13051 860575 : res = gfc_walk_subexpr (gfc_ss_terminator, expr);
13052 860575 : return gfc_reverse_ss (res);
13053 : }
|
