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 59623 : gfc_array_dataptr_type (tree desc)
108 : {
109 59623 : 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 173922 : gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
225 : {
226 408745 : for (; ss != gfc_ss_terminator; ss = ss->next)
227 234823 : ss->info->useflags = flags;
228 173922 : }
229 :
230 :
231 : /* Free a gfc_ss chain. */
232 :
233 : void
234 182786 : gfc_free_ss_chain (gfc_ss * ss)
235 : {
236 182786 : gfc_ss *next;
237 :
238 373790 : while (ss != gfc_ss_terminator)
239 : {
240 191004 : gcc_assert (ss != NULL);
241 191004 : next = ss->next;
242 191004 : gfc_free_ss (ss);
243 191004 : ss = next;
244 : }
245 182786 : }
246 :
247 :
248 : static void
249 496246 : free_ss_info (gfc_ss_info *ss_info)
250 : {
251 496246 : int n;
252 :
253 496246 : ss_info->refcount--;
254 496246 : if (ss_info->refcount > 0)
255 : return;
256 :
257 491499 : gcc_assert (ss_info->refcount == 0);
258 :
259 491499 : switch (ss_info->type)
260 : {
261 : case GFC_SS_SECTION:
262 5457472 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
263 5116380 : if (ss_info->data.array.subscript[n])
264 7768 : gfc_free_ss_chain (ss_info->data.array.subscript[n]);
265 : break;
266 :
267 : default:
268 : break;
269 : }
270 :
271 491499 : free (ss_info);
272 : }
273 :
274 :
275 : /* Free a SS. */
276 :
277 : void
278 496246 : gfc_free_ss (gfc_ss * ss)
279 : {
280 496246 : free_ss_info (ss->info);
281 496246 : free (ss);
282 496246 : }
283 :
284 :
285 : /* Creates and initializes an array type gfc_ss struct. */
286 :
287 : gfc_ss *
288 415175 : gfc_get_array_ss (gfc_ss *next, gfc_expr *expr, int dimen, gfc_ss_type type)
289 : {
290 415175 : gfc_ss *ss;
291 415175 : gfc_ss_info *ss_info;
292 415175 : int i;
293 :
294 415175 : ss_info = gfc_get_ss_info ();
295 415175 : ss_info->refcount++;
296 415175 : ss_info->type = type;
297 415175 : ss_info->expr = expr;
298 :
299 415175 : ss = gfc_get_ss ();
300 415175 : ss->info = ss_info;
301 415175 : ss->next = next;
302 415175 : ss->dimen = dimen;
303 874793 : for (i = 0; i < ss->dimen; i++)
304 459618 : ss->dim[i] = i;
305 :
306 415175 : 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 67005 : gfc_get_scalar_ss (gfc_ss *next, gfc_expr *expr)
340 : {
341 67005 : gfc_ss *ss;
342 67005 : gfc_ss_info *ss_info;
343 :
344 67005 : ss_info = gfc_get_ss_info ();
345 67005 : ss_info->refcount++;
346 67005 : ss_info->type = GFC_SS_SCALAR;
347 67005 : ss_info->expr = expr;
348 :
349 67005 : ss = gfc_get_ss ();
350 67005 : ss->info = ss_info;
351 67005 : ss->next = next;
352 :
353 67005 : return ss;
354 : }
355 :
356 :
357 : /* Free all the SS associated with a loop. */
358 :
359 : void
360 184241 : gfc_cleanup_loop (gfc_loopinfo * loop)
361 : {
362 184241 : gfc_loopinfo *loop_next, **ploop;
363 184241 : gfc_ss *ss;
364 184241 : gfc_ss *next;
365 :
366 184241 : ss = loop->ss;
367 489104 : while (ss != gfc_ss_terminator)
368 : {
369 304863 : gcc_assert (ss != NULL);
370 304863 : next = ss->loop_chain;
371 304863 : gfc_free_ss (ss);
372 304863 : ss = next;
373 : }
374 :
375 : /* Remove reference to self in the parent loop. */
376 184241 : 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 187605 : 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 184241 : }
392 :
393 :
394 : static void
395 250594 : set_ss_loop (gfc_ss *ss, gfc_loopinfo *loop)
396 : {
397 250594 : int n;
398 :
399 564574 : for (; ss != gfc_ss_terminator; ss = ss->next)
400 : {
401 313980 : ss->loop = loop;
402 :
403 313980 : if (ss->info->type == GFC_SS_SCALAR
404 : || ss->info->type == GFC_SS_REFERENCE
405 265087 : || ss->info->type == GFC_SS_TEMP)
406 60277 : continue;
407 :
408 4059248 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
409 3805545 : if (ss->info->data.array.subscript[n] != NULL)
410 7499 : set_ss_loop (ss->info->data.array.subscript[n], loop);
411 : }
412 250594 : }
413 :
414 :
415 : /* Associate a SS chain with a loop. */
416 :
417 : void
418 243095 : gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
419 : {
420 243095 : gfc_ss *ss;
421 243095 : gfc_loopinfo *nested_loop;
422 :
423 243095 : if (head == gfc_ss_terminator)
424 : return;
425 :
426 243095 : set_ss_loop (head, loop);
427 :
428 243095 : ss = head;
429 792671 : for (; ss && ss != gfc_ss_terminator; ss = ss->next)
430 : {
431 306481 : 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 306481 : if (ss->next == gfc_ss_terminator)
452 243095 : ss->loop_chain = loop->ss;
453 : else
454 63386 : ss->loop_chain = ss->next;
455 : }
456 243095 : gcc_assert (ss == gfc_ss_terminator);
457 243095 : loop->ss = head;
458 : }
459 :
460 :
461 : /* Returns true if the expression is an array pointer. */
462 :
463 : static bool
464 371495 : is_pointer_array (tree expr)
465 : {
466 371495 : if (expr == NULL_TREE
467 371495 : || !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr))
468 469329 : || GFC_CLASS_TYPE_P (TREE_TYPE (expr)))
469 : return false;
470 :
471 97834 : if (VAR_P (expr)
472 97834 : && GFC_DECL_PTR_ARRAY_P (expr))
473 : return true;
474 :
475 91423 : if (TREE_CODE (expr) == PARM_DECL
476 91423 : && GFC_DECL_PTR_ARRAY_P (expr))
477 : return true;
478 :
479 91423 : if (INDIRECT_REF_P (expr)
480 91423 : && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 0)))
481 : return true;
482 :
483 : /* The field declaration is marked as an pointer array. */
484 88994 : if (TREE_CODE (expr) == COMPONENT_REF
485 15901 : && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 1))
486 92167 : && !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 374221 : get_CFI_desc (gfc_symbol *sym, gfc_expr *expr,
501 : tree *desc, gfc_array_ref *ar)
502 : {
503 374221 : tree tmp;
504 :
505 374221 : 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 58832 : gfc_get_array_span (tree desc, gfc_expr *expr)
552 : {
553 58832 : tree tmp;
554 58832 : gfc_symbol *sym = (expr && expr->expr_type == EXPR_VARIABLE) ?
555 51552 : expr->symtree->n.sym : NULL;
556 :
557 58832 : if (is_pointer_array (desc)
558 58832 : || (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 58274 : 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 58147 : else if (TREE_CODE (desc) == COMPONENT_REF
578 562 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
579 58276 : && 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 58091 : 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 57004 : tmp = gfc_get_element_type (TREE_TYPE (desc));
597 57004 : if (tmp && TREE_CODE (tmp) == ARRAY_TYPE && TYPE_STRING_FLAG (tmp))
598 : {
599 11077 : gcc_assert (expr->ts.type == BT_CHARACTER);
600 :
601 11077 : tmp = gfc_get_character_len_in_bytes (tmp);
602 :
603 11077 : if (tmp == NULL_TREE || integer_zerop (tmp))
604 : {
605 68 : tree bs;
606 :
607 68 : tmp = gfc_get_expr_charlen (expr);
608 68 : tmp = fold_convert (gfc_array_index_type, tmp);
609 68 : bs = build_int_cst (gfc_array_index_type, expr->ts.kind);
610 68 : tmp = fold_build2_loc (input_location, MULT_EXPR,
611 : gfc_array_index_type, tmp, bs);
612 : }
613 :
614 22086 : tmp = (tmp && !integer_zerop (tmp))
615 22086 : ? (fold_convert (gfc_array_index_type, tmp)) : (NULL_TREE);
616 : }
617 : else
618 45927 : tmp = fold_convert (gfc_array_index_type,
619 : size_in_bytes (tmp));
620 : }
621 58832 : 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 27960 : 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 27960 : tree tmp;
718 27960 : tree desc;
719 27960 : bool onstack;
720 :
721 27960 : desc = info->descriptor;
722 27960 : info->offset = gfc_index_zero_node;
723 27960 : 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 50154 : onstack = !dynamic && initial == NULL_TREE
733 25077 : && (flag_stack_arrays
734 24692 : || gfc_can_put_var_on_stack (size));
735 :
736 25077 : if (onstack)
737 : {
738 : /* Make a temporary variable to hold the data. */
739 19991 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (nelem),
740 : nelem, gfc_index_one_node);
741 19991 : tmp = gfc_evaluate_now (tmp, pre);
742 19991 : tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
743 : tmp);
744 19991 : tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
745 : tmp);
746 19991 : 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 19991 : 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 19991 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
755 19991 : gfc_conv_descriptor_data_set (pre, desc, tmp);
756 : }
757 : else
758 : {
759 : /* Allocate memory to hold the data or call internal_pack. */
760 5086 : if (initial == NULL_TREE)
761 : {
762 4943 : tmp = gfc_call_malloc (pre, NULL, size);
763 4943 : 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 5086 : gfc_conv_descriptor_data_set (pre, desc, tmp);
810 : }
811 : }
812 27960 : 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 27960 : gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node);
817 :
818 27960 : if (dealloc && !onstack)
819 : {
820 : /* Free the temporary. */
821 7719 : tmp = gfc_conv_descriptor_data_get (desc);
822 7719 : tmp = gfc_call_free (tmp);
823 7719 : gfc_add_expr_to_block (post, tmp);
824 : }
825 27960 : }
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 262725 : get_scalarizer_dim_for_array_dim (gfc_ss *ss, int array_dim)
844 : {
845 262725 : int array_ref_dim;
846 262725 : int n;
847 :
848 262725 : array_ref_dim = 0;
849 :
850 531583 : for (; ss; ss = ss->parent)
851 691505 : for (n = 0; n < ss->dimen; n++)
852 422647 : if (ss->dim[n] < array_dim)
853 77075 : array_ref_dim++;
854 :
855 262725 : return array_ref_dim;
856 : }
857 :
858 :
859 : static gfc_ss *
860 222120 : innermost_ss (gfc_ss *ss)
861 : {
862 408990 : while (ss->nested_ss != NULL)
863 : ss = ss->nested_ss;
864 :
865 400782 : 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 222120 : get_array_ref_dim_for_loop_dim (gfc_ss *ss, int loop_dim)
878 : {
879 222120 : return get_scalarizer_dim_for_array_dim (innermost_ss (ss),
880 222120 : 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 27960 : 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 27960 : gfc_loopinfo *loop;
1055 27960 : gfc_ss *s;
1056 27960 : gfc_array_info *info;
1057 27960 : tree from[GFC_MAX_DIMENSIONS], to[GFC_MAX_DIMENSIONS];
1058 27960 : tree type;
1059 27960 : tree desc;
1060 27960 : tree tmp;
1061 27960 : tree size;
1062 27960 : tree nelem;
1063 27960 : tree cond;
1064 27960 : tree or_expr;
1065 27960 : tree elemsize;
1066 27960 : tree class_expr = NULL_TREE;
1067 27960 : gfc_ss *fcn_ss = NULL;
1068 27960 : int n, dim, tmp_dim;
1069 27960 : 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 27960 : 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 27960 : 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 27960 : if (eltype && GFC_CLASS_TYPE_P (eltype))
1091 199 : eltype = gfc_get_element_type (TREE_TYPE (TYPE_FIELDS (eltype)));
1092 :
1093 27960 : if (class_expr == NULL_TREE)
1094 27809 : 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 27960 : memset (from, 0, sizeof (from));
1118 27960 : memset (to, 0, sizeof (to));
1119 :
1120 27960 : info = &ss->info->data.array;
1121 :
1122 27960 : gcc_assert (ss->dimen > 0);
1123 27960 : gcc_assert (ss->loop->dimen == ss->dimen);
1124 :
1125 27960 : 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 55955 : for (s = ss; s; s = s->parent)
1131 : {
1132 27995 : loop = s->loop;
1133 :
1134 27995 : total_dim += loop->dimen;
1135 65200 : for (n = 0; n < loop->dimen; n++)
1136 : {
1137 37205 : dim = s->dim[n];
1138 :
1139 : /* Callee allocated arrays may not have a known bound yet. */
1140 37205 : if (loop->to[n])
1141 33810 : 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 37205 : 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 37205 : 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 37205 : tmp_dim = get_scalarizer_dim_for_array_dim (ss, dim);
1160 37205 : from[tmp_dim] = loop->from[n];
1161 37205 : to[tmp_dim] = loop->to[n];
1162 :
1163 37205 : info->delta[dim] = gfc_index_zero_node;
1164 37205 : info->start[dim] = gfc_index_zero_node;
1165 37205 : info->end[dim] = gfc_index_zero_node;
1166 37205 : info->stride[dim] = gfc_index_one_node;
1167 : }
1168 : }
1169 :
1170 : /* Initialize the descriptor. */
1171 27960 : type =
1172 27960 : gfc_get_array_type_bounds (eltype, total_dim, 0, from, to, 1,
1173 : GFC_ARRAY_UNKNOWN, true);
1174 27960 : desc = gfc_create_var (type, "atmp");
1175 27960 : 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 27960 : tree arraytype = TREE_TYPE (GFC_TYPE_ARRAY_DATAPTR_TYPE (type));
1181 27960 : if (! TYPE_NAME (arraytype))
1182 27960 : TYPE_NAME (arraytype) = build_decl (UNKNOWN_LOCATION, TYPE_DECL,
1183 : NULL_TREE, arraytype);
1184 27960 : gfc_add_expr_to_block (pre, build1 (DECL_EXPR,
1185 27960 : arraytype, TYPE_NAME (arraytype)));
1186 :
1187 27960 : 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 27960 : if (class_expr != NULL_TREE
1194 27809 : || (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 : tree class_descr = gfc_class_data_get (class_expr);
1256 72 : dtype = gfc_conv_descriptor_dtype_get (class_descr);
1257 72 : gfc_conv_descriptor_dtype_set (pre, desc, dtype);
1258 :
1259 : /* These transformational functions change the rank. */
1260 72 : gfc_conv_descriptor_rank_set (pre, desc, ss->loop->dimen);
1261 72 : fcn_ss->info->class_container = NULL_TREE;
1262 : }
1263 :
1264 : /* Assign the new descriptor to the _data field. This allows the
1265 : vptr _copy to be used for scalarized assignment since the class
1266 : temporary can be found from the descriptor. */
1267 181 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1268 181 : TREE_TYPE (desc), desc);
1269 181 : gfc_add_modify (pre, class_data, tmp);
1270 :
1271 : /* Point desc to the class _data field. */
1272 181 : desc = class_data;
1273 181 : }
1274 : else
1275 : {
1276 : /* Fill in the array dtype. */
1277 27779 : gfc_conv_descriptor_dtype_set (pre, desc,
1278 27779 : gfc_get_dtype (TREE_TYPE (desc)));
1279 : }
1280 :
1281 27960 : info->descriptor = desc;
1282 27960 : size = gfc_index_one_node;
1283 :
1284 : /*
1285 : Fill in the bounds and stride. This is a packed array, so:
1286 :
1287 : size = 1;
1288 : for (n = 0; n < rank; n++)
1289 : {
1290 : stride[n] = size
1291 : delta = ubound[n] + 1 - lbound[n];
1292 : size = size * delta;
1293 : }
1294 : size = size * sizeof(element);
1295 : */
1296 :
1297 27960 : or_expr = NULL_TREE;
1298 :
1299 : /* If there is at least one null loop->to[n], it is a callee allocated
1300 : array. */
1301 61770 : for (n = 0; n < total_dim; n++)
1302 35857 : if (to[n] == NULL_TREE)
1303 : {
1304 : size = NULL_TREE;
1305 : break;
1306 : }
1307 :
1308 27960 : if (size == NULL_TREE)
1309 4104 : for (s = ss; s; s = s->parent)
1310 5457 : for (n = 0; n < s->loop->dimen; n++)
1311 : {
1312 3400 : dim = get_scalarizer_dim_for_array_dim (ss, s->dim[n]);
1313 :
1314 : /* For a callee allocated array express the loop bounds in terms
1315 : of the descriptor fields. */
1316 3400 : tmp = fold_build2_loc (input_location,
1317 : MINUS_EXPR, gfc_array_index_type,
1318 : gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]),
1319 : gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]));
1320 3400 : s->loop->to[n] = tmp;
1321 : }
1322 : else
1323 : {
1324 59718 : for (n = 0; n < total_dim; n++)
1325 : {
1326 : /* Store the stride and bound components in the descriptor. */
1327 33805 : gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size);
1328 :
1329 33805 : gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
1330 : gfc_index_zero_node);
1331 :
1332 33805 : gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], to[n]);
1333 :
1334 33805 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
1335 : gfc_array_index_type,
1336 : to[n], gfc_index_one_node);
1337 :
1338 : /* Check whether the size for this dimension is negative. */
1339 33805 : cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
1340 : tmp, gfc_index_zero_node);
1341 33805 : cond = gfc_evaluate_now (cond, pre);
1342 :
1343 33805 : if (n == 0)
1344 : or_expr = cond;
1345 : else
1346 7892 : or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1347 : logical_type_node, or_expr, cond);
1348 :
1349 33805 : size = fold_build2_loc (input_location, MULT_EXPR,
1350 : gfc_array_index_type, size, tmp);
1351 33805 : size = gfc_evaluate_now (size, pre);
1352 : }
1353 : }
1354 :
1355 : /* Get the size of the array. */
1356 27960 : if (size && !callee_alloc)
1357 : {
1358 : /* If or_expr is true, then the extent in at least one
1359 : dimension is zero and the size is set to zero. */
1360 25723 : size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
1361 : or_expr, gfc_index_zero_node, size);
1362 :
1363 25723 : nelem = size;
1364 25723 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
1365 : size, elemsize);
1366 : }
1367 : else
1368 : {
1369 : nelem = size;
1370 : size = NULL_TREE;
1371 : }
1372 :
1373 : /* Set the span. */
1374 27960 : tmp = fold_convert (gfc_array_index_type, elemsize);
1375 27960 : gfc_conv_descriptor_span_set (pre, desc, tmp);
1376 :
1377 27960 : gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
1378 : dynamic, dealloc);
1379 :
1380 55955 : while (ss->parent)
1381 : ss = ss->parent;
1382 :
1383 27960 : if (ss->dimen > ss->loop->temp_dim)
1384 24175 : ss->loop->temp_dim = ss->dimen;
1385 :
1386 27960 : return size;
1387 : }
1388 :
1389 :
1390 : /* Return the number of iterations in a loop that starts at START,
1391 : ends at END, and has step STEP. */
1392 :
1393 : static tree
1394 1078 : gfc_get_iteration_count (tree start, tree end, tree step)
1395 : {
1396 1078 : tree tmp;
1397 1078 : tree type;
1398 :
1399 1078 : type = TREE_TYPE (step);
1400 1078 : tmp = fold_build2_loc (input_location, MINUS_EXPR, type, end, start);
1401 1078 : tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, type, tmp, step);
1402 1078 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp,
1403 : build_int_cst (type, 1));
1404 1078 : tmp = fold_build2_loc (input_location, MAX_EXPR, type, tmp,
1405 : build_int_cst (type, 0));
1406 1078 : return fold_convert (gfc_array_index_type, tmp);
1407 : }
1408 :
1409 :
1410 : /* Return true if the bounds of iterator I can only be determined
1411 : at run time. */
1412 :
1413 : static inline bool
1414 2363 : gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
1415 : {
1416 2363 : return (i->start->expr_type != EXPR_CONSTANT
1417 1945 : || i->end->expr_type != EXPR_CONSTANT
1418 2536 : || i->step->expr_type != EXPR_CONSTANT);
1419 : }
1420 :
1421 :
1422 : /* Split the size of constructor element EXPR into the sum of two terms,
1423 : one of which can be determined at compile time and one of which must
1424 : be calculated at run time. Set *SIZE to the former and return true
1425 : if the latter might be nonzero. */
1426 :
1427 : static bool
1428 3290 : gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
1429 : {
1430 3290 : if (expr->expr_type == EXPR_ARRAY)
1431 685 : return gfc_get_array_constructor_size (size, expr->value.constructor);
1432 2605 : else if (expr->rank > 0)
1433 : {
1434 : /* Calculate everything at run time. */
1435 1031 : mpz_set_ui (*size, 0);
1436 1031 : return true;
1437 : }
1438 : else
1439 : {
1440 : /* A single element. */
1441 1574 : mpz_set_ui (*size, 1);
1442 1574 : return false;
1443 : }
1444 : }
1445 :
1446 :
1447 : /* Like gfc_get_array_constructor_element_size, but applied to the whole
1448 : of array constructor C. */
1449 :
1450 : static bool
1451 3030 : gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base)
1452 : {
1453 3030 : gfc_constructor *c;
1454 3030 : gfc_iterator *i;
1455 3030 : mpz_t val;
1456 3030 : mpz_t len;
1457 3030 : bool dynamic;
1458 :
1459 3030 : mpz_set_ui (*size, 0);
1460 3030 : mpz_init (len);
1461 3030 : mpz_init (val);
1462 :
1463 3030 : dynamic = false;
1464 7408 : for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1465 : {
1466 4378 : i = c->iterator;
1467 4378 : if (i && gfc_iterator_has_dynamic_bounds (i))
1468 : dynamic = true;
1469 : else
1470 : {
1471 2739 : dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
1472 2739 : if (i)
1473 : {
1474 : /* Multiply the static part of the element size by the
1475 : number of iterations. */
1476 128 : mpz_sub (val, i->end->value.integer, i->start->value.integer);
1477 128 : mpz_fdiv_q (val, val, i->step->value.integer);
1478 128 : mpz_add_ui (val, val, 1);
1479 128 : if (mpz_sgn (val) > 0)
1480 92 : mpz_mul (len, len, val);
1481 : else
1482 36 : mpz_set_ui (len, 0);
1483 : }
1484 2739 : mpz_add (*size, *size, len);
1485 : }
1486 : }
1487 3030 : mpz_clear (len);
1488 3030 : mpz_clear (val);
1489 3030 : return dynamic;
1490 : }
1491 :
1492 :
1493 : /* Make sure offset is a variable. */
1494 :
1495 : static void
1496 3321 : gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
1497 : tree * offsetvar)
1498 : {
1499 : /* We should have already created the offset variable. We cannot
1500 : create it here because we may be in an inner scope. */
1501 3321 : gcc_assert (*offsetvar != NULL_TREE);
1502 3321 : gfc_add_modify (pblock, *offsetvar, *poffset);
1503 3321 : *poffset = *offsetvar;
1504 3321 : TREE_USED (*offsetvar) = 1;
1505 3321 : }
1506 :
1507 :
1508 : /* Variables needed for bounds-checking. */
1509 : static bool first_len;
1510 : static tree first_len_val;
1511 : static bool typespec_chararray_ctor;
1512 :
1513 : /* Return true if DER has any CLASS allocatable component. Such components
1514 : are initialised by VIEW_CONVERT in structure constructors (a bitwise copy
1515 : of the class descriptor), so their _data pointer may refer to a non-heap
1516 : object and must not be passed to gfc_deallocate_alloc_comp_no_caf. */
1517 :
1518 : static bool
1519 4493 : has_class_alloc_comp (gfc_symbol *der)
1520 : {
1521 11998 : for (gfc_component *c = der->components; c; c = c->next)
1522 7571 : if (c->ts.type == BT_CLASS && !c->attr.class_pointer)
1523 : return true;
1524 : return false;
1525 : }
1526 :
1527 : static void
1528 12541 : gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
1529 : tree offset, gfc_se * se, gfc_expr * expr)
1530 : {
1531 12541 : tree tmp, offset_eval;
1532 :
1533 12541 : gfc_conv_expr (se, expr);
1534 :
1535 : /* Store the value. */
1536 12541 : tmp = build_fold_indirect_ref_loc (input_location,
1537 : gfc_conv_descriptor_data_get (desc));
1538 :
1539 : /* The offset may change, so get its value now and use that to free memory. */
1540 12541 : offset_eval = gfc_evaluate_now (offset, &se->pre);
1541 12541 : tmp = gfc_build_array_ref (tmp, offset_eval, NULL);
1542 :
1543 12541 : if (expr->ts.type == BT_DERIVED
1544 4402 : && (expr->expr_type == EXPR_FUNCTION
1545 4318 : || (expr->expr_type == EXPR_STRUCTURE
1546 3714 : && !has_class_alloc_comp (expr->ts.u.derived)))
1547 16297 : && expr->ts.u.derived->attr.alloc_comp)
1548 800 : gfc_add_expr_to_block (&se->finalblock,
1549 : gfc_deallocate_alloc_comp_no_caf (expr->ts.u.derived,
1550 : tmp, expr->rank,
1551 : true));
1552 :
1553 12541 : if (expr->ts.type == BT_CHARACTER)
1554 : {
1555 2152 : int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
1556 2152 : tree esize;
1557 :
1558 2152 : esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)));
1559 2152 : esize = fold_convert (gfc_charlen_type_node, esize);
1560 4304 : esize = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
1561 2152 : TREE_TYPE (esize), esize,
1562 2152 : build_int_cst (TREE_TYPE (esize),
1563 2152 : gfc_character_kinds[i].bit_size / 8));
1564 :
1565 2152 : gfc_conv_string_parameter (se);
1566 2152 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
1567 : {
1568 : /* The temporary is an array of pointers. */
1569 6 : se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1570 6 : gfc_add_modify (&se->pre, tmp, se->expr);
1571 : }
1572 : else
1573 : {
1574 : /* The temporary is an array of string values. */
1575 2146 : tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp);
1576 : /* We know the temporary and the value will be the same length,
1577 : so can use memcpy. */
1578 2146 : gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind,
1579 : se->string_length, se->expr, expr->ts.kind);
1580 : }
1581 2152 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !typespec_chararray_ctor)
1582 : {
1583 310 : if (first_len)
1584 : {
1585 130 : gfc_add_modify (&se->pre, first_len_val,
1586 130 : fold_convert (TREE_TYPE (first_len_val),
1587 : se->string_length));
1588 130 : first_len = false;
1589 : }
1590 : else
1591 : {
1592 : /* Verify that all constructor elements are of the same
1593 : length. */
1594 180 : tree rhs = fold_convert (TREE_TYPE (first_len_val),
1595 : se->string_length);
1596 180 : tree cond = fold_build2_loc (input_location, NE_EXPR,
1597 : logical_type_node, first_len_val,
1598 : rhs);
1599 180 : gfc_trans_runtime_check
1600 180 : (true, false, cond, &se->pre, &expr->where,
1601 : "Different CHARACTER lengths (%ld/%ld) in array constructor",
1602 : fold_convert (long_integer_type_node, first_len_val),
1603 : fold_convert (long_integer_type_node, se->string_length));
1604 : }
1605 : }
1606 : }
1607 10389 : else if (GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
1608 10389 : && !GFC_CLASS_TYPE_P (gfc_get_element_type (TREE_TYPE (desc))))
1609 : {
1610 : /* Assignment of a CLASS array constructor to a derived type array. */
1611 24 : if (expr->expr_type == EXPR_FUNCTION)
1612 18 : se->expr = gfc_evaluate_now (se->expr, pblock);
1613 24 : se->expr = gfc_class_data_get (se->expr);
1614 24 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
1615 24 : se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1616 24 : gfc_add_modify (&se->pre, tmp, se->expr);
1617 : }
1618 : else
1619 : {
1620 : /* TODO: Should the frontend already have done this conversion? */
1621 10365 : se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1622 10365 : gfc_add_modify (&se->pre, tmp, se->expr);
1623 : }
1624 :
1625 12541 : gfc_add_block_to_block (pblock, &se->pre);
1626 12541 : gfc_add_block_to_block (pblock, &se->post);
1627 12541 : }
1628 :
1629 :
1630 : /* Add the contents of an array to the constructor. DYNAMIC is as for
1631 : gfc_trans_array_constructor_value. */
1632 :
1633 : static void
1634 1141 : gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
1635 : tree type ATTRIBUTE_UNUSED,
1636 : tree desc, gfc_expr * expr,
1637 : tree * poffset, tree * offsetvar,
1638 : bool dynamic)
1639 : {
1640 1141 : gfc_se se;
1641 1141 : gfc_ss *ss;
1642 1141 : gfc_loopinfo loop;
1643 1141 : stmtblock_t body;
1644 1141 : tree tmp;
1645 1141 : tree size;
1646 1141 : int n;
1647 :
1648 : /* We need this to be a variable so we can increment it. */
1649 1141 : gfc_put_offset_into_var (pblock, poffset, offsetvar);
1650 :
1651 1141 : gfc_init_se (&se, NULL);
1652 :
1653 : /* Walk the array expression. */
1654 1141 : ss = gfc_walk_expr (expr);
1655 1141 : gcc_assert (ss != gfc_ss_terminator);
1656 :
1657 : /* Initialize the scalarizer. */
1658 1141 : gfc_init_loopinfo (&loop);
1659 1141 : gfc_add_ss_to_loop (&loop, ss);
1660 :
1661 : /* Initialize the loop. */
1662 1141 : gfc_conv_ss_startstride (&loop);
1663 1141 : gfc_conv_loop_setup (&loop, &expr->where);
1664 :
1665 : /* Make sure the constructed array has room for the new data. */
1666 1141 : if (dynamic)
1667 : {
1668 : /* Set SIZE to the total number of elements in the subarray. */
1669 515 : size = gfc_index_one_node;
1670 1042 : for (n = 0; n < loop.dimen; n++)
1671 : {
1672 527 : tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
1673 : gfc_index_one_node);
1674 527 : size = fold_build2_loc (input_location, MULT_EXPR,
1675 : gfc_array_index_type, size, tmp);
1676 : }
1677 :
1678 : /* Grow the constructed array by SIZE elements. */
1679 515 : gfc_grow_array (&loop.pre, desc, size);
1680 : }
1681 :
1682 : /* Make the loop body. */
1683 1141 : gfc_mark_ss_chain_used (ss, 1);
1684 1141 : gfc_start_scalarized_body (&loop, &body);
1685 1141 : gfc_copy_loopinfo_to_se (&se, &loop);
1686 1141 : se.ss = ss;
1687 :
1688 1141 : gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
1689 1141 : gcc_assert (se.ss == gfc_ss_terminator);
1690 :
1691 : /* Increment the offset. */
1692 1141 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1693 : *poffset, gfc_index_one_node);
1694 1141 : gfc_add_modify (&body, *poffset, tmp);
1695 :
1696 : /* Finish the loop. */
1697 1141 : gfc_trans_scalarizing_loops (&loop, &body);
1698 1141 : gfc_add_block_to_block (&loop.pre, &loop.post);
1699 1141 : tmp = gfc_finish_block (&loop.pre);
1700 1141 : gfc_add_expr_to_block (pblock, tmp);
1701 :
1702 1141 : gfc_cleanup_loop (&loop);
1703 1141 : }
1704 :
1705 :
1706 : /* Return true if every leaf element of an array constructor is a function
1707 : reference returning derived type DER, which has allocatable components.
1708 : Such results are moved (shallow-copied) into the constructor temporary, so
1709 : the temporary owns their allocatable components and they can all be freed
1710 : in a single sweep over the whole temporary. Returns false as soon as an
1711 : element is anything else - notably a variable, whose allocatable components
1712 : are aliased rather than owned by the temporary and must not be freed. */
1713 :
1714 : static bool
1715 521 : gfc_constructor_is_owned_alloc_comp (gfc_constructor_base base,
1716 : gfc_symbol *der)
1717 : {
1718 521 : gfc_constructor *c;
1719 :
1720 521 : if (base == NULL)
1721 : return false;
1722 :
1723 1369 : for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1724 : {
1725 1065 : gfc_expr *e = c->expr;
1726 1065 : if (e->expr_type == EXPR_ARRAY)
1727 : {
1728 54 : if (!gfc_constructor_is_owned_alloc_comp (e->value.constructor, der))
1729 : return false;
1730 : }
1731 1011 : else if (!(e->ts.type == BT_DERIVED
1732 1011 : && (e->expr_type == EXPR_FUNCTION
1733 972 : || (e->expr_type == EXPR_STRUCTURE
1734 779 : && !has_class_alloc_comp (e->ts.u.derived)))
1735 794 : && e->ts.u.derived == der))
1736 : return false;
1737 : }
1738 : return true;
1739 : }
1740 :
1741 :
1742 : /* Assign the values to the elements of an array constructor. DYNAMIC
1743 : is true if descriptor DESC only contains enough data for the static
1744 : size calculated by gfc_get_array_constructor_size. When true, memory
1745 : for the dynamic parts must be allocated using realloc. OWNED_SWEEP is
1746 : true when the caller will free the allocatable components of every
1747 : constructor element in one sweep over the whole temporary; in that case
1748 : the per-element finalization built here is suppressed to avoid a double
1749 : free. */
1750 :
1751 : static void
1752 8313 : gfc_trans_array_constructor_value (stmtblock_t * pblock,
1753 : stmtblock_t * finalblock,
1754 : tree type, tree desc,
1755 : gfc_constructor_base base, tree * poffset,
1756 : tree * offsetvar, bool dynamic,
1757 : bool owned_sweep)
1758 : {
1759 8313 : tree tmp;
1760 8313 : tree start = NULL_TREE;
1761 8313 : tree end = NULL_TREE;
1762 8313 : tree step = NULL_TREE;
1763 8313 : stmtblock_t body;
1764 8313 : gfc_se se;
1765 8313 : mpz_t size;
1766 8313 : gfc_constructor *c;
1767 8313 : gfc_typespec ts;
1768 8313 : int ctr = 0;
1769 :
1770 8313 : tree shadow_loopvar = NULL_TREE;
1771 8313 : gfc_saved_var saved_loopvar;
1772 :
1773 8313 : ts.type = BT_UNKNOWN;
1774 8313 : mpz_init (size);
1775 22462 : for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1776 : {
1777 14149 : ctr++;
1778 : /* If this is an iterator or an array, the offset must be a variable. */
1779 14149 : if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
1780 2180 : gfc_put_offset_into_var (pblock, poffset, offsetvar);
1781 :
1782 : /* Shadowing the iterator avoids changing its value and saves us from
1783 : keeping track of it. Further, it makes sure that there's always a
1784 : backend-decl for the symbol, even if there wasn't one before,
1785 : e.g. in the case of an iterator that appears in a specification
1786 : expression in an interface mapping. */
1787 14149 : if (c->iterator)
1788 : {
1789 1481 : gfc_symbol *sym;
1790 1481 : tree type;
1791 :
1792 : /* Evaluate loop bounds before substituting the loop variable
1793 : in case they depend on it. Such a case is invalid, but it is
1794 : not more expensive to do the right thing here.
1795 : See PR 44354. */
1796 1481 : gfc_init_se (&se, NULL);
1797 1481 : gfc_conv_expr_val (&se, c->iterator->start);
1798 1481 : gfc_add_block_to_block (pblock, &se.pre);
1799 1481 : start = gfc_evaluate_now (se.expr, pblock);
1800 :
1801 1481 : gfc_init_se (&se, NULL);
1802 1481 : gfc_conv_expr_val (&se, c->iterator->end);
1803 1481 : gfc_add_block_to_block (pblock, &se.pre);
1804 1481 : end = gfc_evaluate_now (se.expr, pblock);
1805 :
1806 1481 : gfc_init_se (&se, NULL);
1807 1481 : gfc_conv_expr_val (&se, c->iterator->step);
1808 1481 : gfc_add_block_to_block (pblock, &se.pre);
1809 1481 : step = gfc_evaluate_now (se.expr, pblock);
1810 :
1811 1481 : sym = c->iterator->var->symtree->n.sym;
1812 1481 : type = gfc_typenode_for_spec (&sym->ts);
1813 :
1814 1481 : shadow_loopvar = gfc_create_var (type, "shadow_loopvar");
1815 1481 : gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar);
1816 : }
1817 :
1818 14149 : gfc_start_block (&body);
1819 :
1820 14149 : if (c->expr->expr_type == EXPR_ARRAY)
1821 : {
1822 : /* Array constructors can be nested. */
1823 1503 : gfc_trans_array_constructor_value (&body, finalblock, type,
1824 : desc, c->expr->value.constructor,
1825 : poffset, offsetvar, dynamic,
1826 : owned_sweep);
1827 : }
1828 12646 : else if (c->expr->rank > 0)
1829 : {
1830 1141 : gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
1831 : poffset, offsetvar, dynamic);
1832 : }
1833 : else
1834 : {
1835 : /* This code really upsets the gimplifier so don't bother for now. */
1836 : gfc_constructor *p;
1837 : HOST_WIDE_INT n;
1838 : HOST_WIDE_INT size;
1839 :
1840 : p = c;
1841 : n = 0;
1842 13310 : while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1843 : {
1844 1805 : p = gfc_constructor_next (p);
1845 1805 : n++;
1846 : }
1847 : /* Constructor with few constant elements, or element size not
1848 : known at compile time (e.g. deferred-length character). */
1849 11505 : if (n < 4 || !INTEGER_CST_P (TYPE_SIZE_UNIT (type)))
1850 : {
1851 : /* Scalar values. */
1852 11400 : gfc_init_se (&se, NULL);
1853 11400 : if (IS_PDT (c->expr) && c->expr->expr_type == EXPR_STRUCTURE)
1854 276 : c->expr->must_finalize = 1;
1855 :
1856 11400 : gfc_trans_array_ctor_element (&body, desc, *poffset,
1857 : &se, c->expr);
1858 :
1859 11400 : *poffset = fold_build2_loc (input_location, PLUS_EXPR,
1860 : gfc_array_index_type,
1861 : *poffset, gfc_index_one_node);
1862 : /* Unless the whole temporary is being swept by the caller, add
1863 : the per-element finalization. The sweep is used when every
1864 : element is an owned function result, which is the only way to
1865 : correctly free elements produced inside an implied-do loop. */
1866 11400 : if (finalblock && !owned_sweep)
1867 496 : gfc_add_block_to_block (finalblock, &se.finalblock);
1868 : }
1869 : else
1870 : {
1871 : /* Collect multiple scalar constants into a constructor. */
1872 105 : vec<constructor_elt, va_gc> *v = NULL;
1873 105 : tree init;
1874 105 : tree bound;
1875 105 : tree tmptype;
1876 105 : HOST_WIDE_INT idx = 0;
1877 :
1878 105 : p = c;
1879 : /* Count the number of consecutive scalar constants. */
1880 837 : while (p && !(p->iterator
1881 745 : || p->expr->expr_type != EXPR_CONSTANT))
1882 : {
1883 732 : gfc_init_se (&se, NULL);
1884 732 : gfc_conv_constant (&se, p->expr);
1885 :
1886 732 : if (c->expr->ts.type != BT_CHARACTER)
1887 660 : se.expr = fold_convert (type, se.expr);
1888 : /* For constant character array constructors we build
1889 : an array of pointers. */
1890 72 : else if (POINTER_TYPE_P (type))
1891 0 : se.expr = gfc_build_addr_expr
1892 0 : (gfc_get_pchar_type (p->expr->ts.kind),
1893 : se.expr);
1894 :
1895 732 : CONSTRUCTOR_APPEND_ELT (v,
1896 : build_int_cst (gfc_array_index_type,
1897 : idx++),
1898 : se.expr);
1899 732 : c = p;
1900 732 : p = gfc_constructor_next (p);
1901 : }
1902 :
1903 105 : bound = size_int (n - 1);
1904 : /* Create an array type to hold them. */
1905 105 : tmptype = build_range_type (gfc_array_index_type,
1906 : gfc_index_zero_node, bound);
1907 105 : tmptype = build_array_type (type, tmptype);
1908 :
1909 105 : init = build_constructor (tmptype, v);
1910 105 : TREE_CONSTANT (init) = 1;
1911 105 : TREE_STATIC (init) = 1;
1912 : /* Create a static variable to hold the data. */
1913 105 : tmp = gfc_create_var (tmptype, "data");
1914 105 : TREE_STATIC (tmp) = 1;
1915 105 : TREE_CONSTANT (tmp) = 1;
1916 105 : TREE_READONLY (tmp) = 1;
1917 105 : DECL_INITIAL (tmp) = init;
1918 105 : init = tmp;
1919 :
1920 : /* Use BUILTIN_MEMCPY to assign the values. */
1921 105 : tmp = gfc_conv_descriptor_data_get (desc);
1922 105 : tmp = build_fold_indirect_ref_loc (input_location,
1923 : tmp);
1924 105 : tmp = gfc_build_array_ref (tmp, *poffset, NULL);
1925 105 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1926 105 : init = gfc_build_addr_expr (NULL_TREE, init);
1927 :
1928 105 : size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1929 105 : bound = build_int_cst (size_type_node, n * size);
1930 105 : tmp = build_call_expr_loc (input_location,
1931 : builtin_decl_explicit (BUILT_IN_MEMCPY),
1932 : 3, tmp, init, bound);
1933 105 : gfc_add_expr_to_block (&body, tmp);
1934 :
1935 105 : *poffset = fold_build2_loc (input_location, PLUS_EXPR,
1936 : gfc_array_index_type, *poffset,
1937 105 : build_int_cst (gfc_array_index_type, n));
1938 : }
1939 11505 : if (!INTEGER_CST_P (*poffset))
1940 : {
1941 1783 : gfc_add_modify (&body, *offsetvar, *poffset);
1942 1783 : *poffset = *offsetvar;
1943 : }
1944 :
1945 11505 : if (!c->iterator)
1946 11505 : ts = c->expr->ts;
1947 : }
1948 :
1949 : /* The frontend should already have done any expansions
1950 : at compile-time. */
1951 14149 : if (!c->iterator)
1952 : {
1953 : /* Pass the code as is. */
1954 12668 : tmp = gfc_finish_block (&body);
1955 12668 : gfc_add_expr_to_block (pblock, tmp);
1956 : }
1957 : else
1958 : {
1959 : /* Build the implied do-loop. */
1960 1481 : stmtblock_t implied_do_block;
1961 1481 : tree cond;
1962 1481 : tree exit_label;
1963 1481 : tree loopbody;
1964 1481 : tree tmp2;
1965 :
1966 1481 : loopbody = gfc_finish_block (&body);
1967 :
1968 : /* Create a new block that holds the implied-do loop. A temporary
1969 : loop-variable is used. */
1970 1481 : gfc_start_block(&implied_do_block);
1971 :
1972 : /* Initialize the loop. */
1973 1481 : gfc_add_modify (&implied_do_block, shadow_loopvar, start);
1974 :
1975 : /* If this array expands dynamically, and the number of iterations
1976 : is not constant, we won't have allocated space for the static
1977 : part of C->EXPR's size. Do that now. */
1978 1481 : if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1979 : {
1980 : /* Get the number of iterations. */
1981 551 : tmp = gfc_get_iteration_count (shadow_loopvar, end, step);
1982 :
1983 : /* Get the static part of C->EXPR's size. */
1984 551 : gfc_get_array_constructor_element_size (&size, c->expr);
1985 551 : tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1986 :
1987 : /* Grow the array by TMP * TMP2 elements. */
1988 551 : tmp = fold_build2_loc (input_location, MULT_EXPR,
1989 : gfc_array_index_type, tmp, tmp2);
1990 551 : gfc_grow_array (&implied_do_block, desc, tmp);
1991 : }
1992 :
1993 : /* Generate the loop body. */
1994 1481 : exit_label = gfc_build_label_decl (NULL_TREE);
1995 1481 : gfc_start_block (&body);
1996 :
1997 : /* Generate the exit condition. Depending on the sign of
1998 : the step variable we have to generate the correct
1999 : comparison. */
2000 1481 : tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2001 1481 : step, build_int_cst (TREE_TYPE (step), 0));
2002 1481 : cond = fold_build3_loc (input_location, COND_EXPR,
2003 : logical_type_node, tmp,
2004 : fold_build2_loc (input_location, GT_EXPR,
2005 : logical_type_node, shadow_loopvar, end),
2006 : fold_build2_loc (input_location, LT_EXPR,
2007 : logical_type_node, shadow_loopvar, end));
2008 1481 : tmp = build1_v (GOTO_EXPR, exit_label);
2009 1481 : TREE_USED (exit_label) = 1;
2010 1481 : tmp = build3_v (COND_EXPR, cond, tmp,
2011 : build_empty_stmt (input_location));
2012 1481 : gfc_add_expr_to_block (&body, tmp);
2013 :
2014 : /* The main loop body. */
2015 1481 : gfc_add_expr_to_block (&body, loopbody);
2016 :
2017 : /* Increase loop variable by step. */
2018 1481 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
2019 1481 : TREE_TYPE (shadow_loopvar), shadow_loopvar,
2020 : step);
2021 1481 : gfc_add_modify (&body, shadow_loopvar, tmp);
2022 :
2023 : /* Finish the loop. */
2024 1481 : tmp = gfc_finish_block (&body);
2025 1481 : tmp = build1_v (LOOP_EXPR, tmp);
2026 1481 : gfc_add_expr_to_block (&implied_do_block, tmp);
2027 :
2028 : /* Add the exit label. */
2029 1481 : tmp = build1_v (LABEL_EXPR, exit_label);
2030 1481 : gfc_add_expr_to_block (&implied_do_block, tmp);
2031 :
2032 : /* Finish the implied-do loop. */
2033 1481 : tmp = gfc_finish_block(&implied_do_block);
2034 1481 : gfc_add_expr_to_block(pblock, tmp);
2035 :
2036 1481 : gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar);
2037 : }
2038 : }
2039 :
2040 : /* F2008 4.5.6.3 para 5: If an executable construct references a structure
2041 : constructor or array constructor, the entity created by the constructor is
2042 : finalized after execution of the innermost executable construct containing
2043 : the reference. This, in fact, was later deleted by the Combined Technical
2044 : Corrigenda 1 TO 4 for fortran 2008 (f08/0011).
2045 :
2046 : Transmit finalization of this constructor through 'finalblock'. */
2047 8313 : if ((gfc_option.allow_std & (GFC_STD_F2008 | GFC_STD_F2003))
2048 8313 : && !(gfc_option.allow_std & GFC_STD_GNU)
2049 70 : && finalblock != NULL
2050 24 : && gfc_may_be_finalized (ts)
2051 18 : && ctr > 0 && desc != NULL_TREE
2052 8331 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
2053 : {
2054 18 : symbol_attribute attr;
2055 18 : gfc_se fse;
2056 18 : locus loc;
2057 18 : gfc_locus_from_location (&loc, input_location);
2058 18 : gfc_warning (0, "The structure constructor at %L has been"
2059 : " finalized. This feature was removed by f08/0011."
2060 : " Use -std=f2018 or -std=gnu to eliminate the"
2061 : " finalization.", &loc);
2062 18 : attr.pointer = attr.allocatable = 0;
2063 18 : gfc_init_se (&fse, NULL);
2064 18 : fse.expr = desc;
2065 18 : gfc_finalize_tree_expr (&fse, ts.u.derived, attr, 1);
2066 18 : gfc_add_block_to_block (finalblock, &fse.pre);
2067 18 : gfc_add_block_to_block (finalblock, &fse.finalblock);
2068 18 : gfc_add_block_to_block (finalblock, &fse.post);
2069 : }
2070 :
2071 8313 : mpz_clear (size);
2072 8313 : }
2073 :
2074 :
2075 : /* The array constructor code can create a string length with an operand
2076 : in the form of a temporary variable. This variable will retain its
2077 : context (current_function_decl). If we store this length tree in a
2078 : gfc_charlen structure which is shared by a variable in another
2079 : context, the resulting gfc_charlen structure with a variable in a
2080 : different context, we could trip the assertion in expand_expr_real_1
2081 : when it sees that a variable has been created in one context and
2082 : referenced in another.
2083 :
2084 : If this might be the case, we create a new gfc_charlen structure and
2085 : link it into the current namespace. */
2086 :
2087 : static void
2088 8453 : store_backend_decl (gfc_charlen **clp, tree len, bool force_new_cl)
2089 : {
2090 8453 : if (force_new_cl)
2091 : {
2092 8426 : gfc_charlen *new_cl = gfc_new_charlen (gfc_current_ns, *clp);
2093 8426 : *clp = new_cl;
2094 : }
2095 8453 : (*clp)->backend_decl = len;
2096 8453 : }
2097 :
2098 : /* A catch-all to obtain the string length for anything that is not
2099 : a substring of non-constant length, a constant, array or variable. */
2100 :
2101 : static void
2102 312 : get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
2103 : {
2104 312 : gfc_se se;
2105 :
2106 : /* Don't bother if we already know the length is a constant. */
2107 312 : if (*len && INTEGER_CST_P (*len))
2108 52 : return;
2109 :
2110 260 : if (!e->ref && e->ts.u.cl && e->ts.u.cl->length
2111 35 : && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
2112 : {
2113 : /* This is easy. */
2114 1 : gfc_conv_const_charlen (e->ts.u.cl);
2115 1 : *len = e->ts.u.cl->backend_decl;
2116 : }
2117 : else
2118 : {
2119 : /* Otherwise, be brutal even if inefficient. */
2120 259 : gfc_init_se (&se, NULL);
2121 :
2122 : /* No function call, in case of side effects. */
2123 259 : se.no_function_call = 1;
2124 259 : if (e->rank == 0)
2125 140 : gfc_conv_expr (&se, e);
2126 : else
2127 119 : gfc_conv_expr_descriptor (&se, e);
2128 :
2129 : /* Fix the value. */
2130 259 : *len = gfc_evaluate_now (se.string_length, &se.pre);
2131 :
2132 259 : gfc_add_block_to_block (block, &se.pre);
2133 259 : gfc_add_block_to_block (block, &se.post);
2134 :
2135 259 : store_backend_decl (&e->ts.u.cl, *len, true);
2136 : }
2137 : }
2138 :
2139 :
2140 : /* Figure out the string length of a variable reference expression.
2141 : Used by get_array_ctor_strlen. */
2142 :
2143 : static void
2144 882 : get_array_ctor_var_strlen (stmtblock_t *block, gfc_expr * expr, tree * len)
2145 : {
2146 882 : gfc_ref *ref;
2147 882 : gfc_typespec *ts;
2148 882 : mpz_t char_len;
2149 882 : gfc_se se;
2150 :
2151 : /* Don't bother if we already know the length is a constant. */
2152 882 : if (*len && INTEGER_CST_P (*len))
2153 551 : return;
2154 :
2155 420 : ts = &expr->symtree->n.sym->ts;
2156 651 : for (ref = expr->ref; ref; ref = ref->next)
2157 : {
2158 320 : switch (ref->type)
2159 : {
2160 186 : case REF_ARRAY:
2161 : /* Array references don't change the string length. */
2162 186 : if (ts->deferred)
2163 112 : get_array_ctor_all_strlen (block, expr, len);
2164 : break;
2165 :
2166 45 : case REF_COMPONENT:
2167 : /* Use the length of the component. */
2168 45 : ts = &ref->u.c.component->ts;
2169 45 : break;
2170 :
2171 89 : case REF_SUBSTRING:
2172 89 : if (ref->u.ss.end == NULL
2173 77 : || ref->u.ss.start->expr_type != EXPR_CONSTANT
2174 58 : || ref->u.ss.end->expr_type != EXPR_CONSTANT)
2175 : {
2176 : /* Note that this might evaluate expr. */
2177 64 : get_array_ctor_all_strlen (block, expr, len);
2178 64 : return;
2179 : }
2180 25 : mpz_init_set_ui (char_len, 1);
2181 25 : mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
2182 25 : mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
2183 25 : *len = gfc_conv_mpz_to_tree_type (char_len, gfc_charlen_type_node);
2184 25 : mpz_clear (char_len);
2185 25 : return;
2186 :
2187 : case REF_INQUIRY:
2188 : break;
2189 :
2190 0 : default:
2191 0 : gcc_unreachable ();
2192 : }
2193 : }
2194 :
2195 : /* A last ditch attempt that is sometimes needed for deferred characters. */
2196 331 : if (!ts->u.cl->backend_decl)
2197 : {
2198 7 : gfc_init_se (&se, NULL);
2199 7 : if (expr->rank)
2200 0 : gfc_conv_expr_descriptor (&se, expr);
2201 : else
2202 7 : gfc_conv_expr (&se, expr);
2203 7 : gcc_assert (se.string_length != NULL_TREE);
2204 7 : gfc_add_block_to_block (block, &se.pre);
2205 7 : ts->u.cl->backend_decl = se.string_length;
2206 : }
2207 :
2208 331 : *len = ts->u.cl->backend_decl;
2209 : }
2210 :
2211 :
2212 : /* Figure out the string length of a character array constructor.
2213 : If len is NULL, don't calculate the length; this happens for recursive calls
2214 : when a sub-array-constructor is an element but not at the first position,
2215 : so when we're not interested in the length.
2216 : Returns TRUE if all elements are character constants. */
2217 :
2218 : bool
2219 8794 : get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len)
2220 : {
2221 8794 : gfc_constructor *c;
2222 8794 : bool is_const;
2223 :
2224 8794 : is_const = true;
2225 :
2226 8794 : if (gfc_constructor_first (base) == NULL)
2227 : {
2228 273 : if (len)
2229 273 : *len = build_int_cstu (gfc_charlen_type_node, 0);
2230 273 : return is_const;
2231 : }
2232 :
2233 : /* Loop over all constructor elements to find out is_const, but in len we
2234 : want to store the length of the first, not the last, element. We can
2235 : of course exit the loop as soon as is_const is found to be false. */
2236 8521 : for (c = gfc_constructor_first (base);
2237 46728 : c && is_const; c = gfc_constructor_next (c))
2238 : {
2239 38207 : switch (c->expr->expr_type)
2240 : {
2241 37086 : case EXPR_CONSTANT:
2242 37086 : if (len && !(*len && INTEGER_CST_P (*len)))
2243 386 : *len = build_int_cstu (gfc_charlen_type_node,
2244 386 : c->expr->value.character.length);
2245 : break;
2246 :
2247 43 : case EXPR_ARRAY:
2248 43 : if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
2249 1109 : is_const = false;
2250 : break;
2251 :
2252 942 : case EXPR_VARIABLE:
2253 942 : is_const = false;
2254 942 : if (len)
2255 882 : get_array_ctor_var_strlen (block, c->expr, len);
2256 : break;
2257 :
2258 136 : default:
2259 136 : is_const = false;
2260 136 : if (len)
2261 136 : get_array_ctor_all_strlen (block, c->expr, len);
2262 : break;
2263 : }
2264 :
2265 : /* After the first iteration, we don't want the length modified. */
2266 38207 : len = NULL;
2267 : }
2268 :
2269 : return is_const;
2270 : }
2271 :
2272 : /* Check whether the array constructor C consists entirely of constant
2273 : elements, and if so returns the number of those elements, otherwise
2274 : return zero. Note, an empty or NULL array constructor returns zero. */
2275 :
2276 : unsigned HOST_WIDE_INT
2277 59820 : gfc_constant_array_constructor_p (gfc_constructor_base base)
2278 : {
2279 59820 : unsigned HOST_WIDE_INT nelem = 0;
2280 :
2281 59820 : gfc_constructor *c = gfc_constructor_first (base);
2282 543342 : while (c)
2283 : {
2284 430762 : if (c->iterator
2285 429167 : || c->expr->rank > 0
2286 428357 : || c->expr->expr_type != EXPR_CONSTANT)
2287 : return 0;
2288 423702 : c = gfc_constructor_next (c);
2289 423702 : nelem++;
2290 : }
2291 : return nelem;
2292 : }
2293 :
2294 :
2295 : /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
2296 : and the tree type of it's elements, TYPE, return a static constant
2297 : variable that is compile-time initialized. */
2298 :
2299 : tree
2300 42186 : gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
2301 : {
2302 42186 : tree tmptype, init, tmp;
2303 42186 : HOST_WIDE_INT nelem;
2304 42186 : gfc_constructor *c;
2305 42186 : gfc_array_spec as;
2306 42186 : gfc_se se;
2307 42186 : int i;
2308 42186 : vec<constructor_elt, va_gc> *v = NULL;
2309 :
2310 : /* First traverse the constructor list, converting the constants
2311 : to tree to build an initializer. */
2312 42186 : nelem = 0;
2313 42186 : c = gfc_constructor_first (expr->value.constructor);
2314 424552 : while (c)
2315 : {
2316 340180 : gfc_init_se (&se, NULL);
2317 340180 : gfc_conv_constant (&se, c->expr);
2318 340180 : if (c->expr->ts.type != BT_CHARACTER)
2319 304014 : se.expr = fold_convert (type, se.expr);
2320 36166 : else if (POINTER_TYPE_P (type))
2321 36166 : se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
2322 : se.expr);
2323 340180 : CONSTRUCTOR_APPEND_ELT (v, build_int_cst (gfc_array_index_type, nelem),
2324 : se.expr);
2325 340180 : c = gfc_constructor_next (c);
2326 340180 : nelem++;
2327 : }
2328 :
2329 : /* Next determine the tree type for the array. We use the gfortran
2330 : front-end's gfc_get_nodesc_array_type in order to create a suitable
2331 : GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
2332 :
2333 42186 : memset (&as, 0, sizeof (gfc_array_spec));
2334 :
2335 42186 : as.rank = expr->rank;
2336 42186 : as.type = AS_EXPLICIT;
2337 42186 : if (!expr->shape)
2338 : {
2339 4 : as.lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
2340 4 : as.upper[0] = gfc_get_int_expr (gfc_default_integer_kind,
2341 : NULL, nelem - 1);
2342 : }
2343 : else
2344 91067 : for (i = 0; i < expr->rank; i++)
2345 : {
2346 48885 : int tmp = (int) mpz_get_si (expr->shape[i]);
2347 48885 : as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
2348 48885 : as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind,
2349 48885 : NULL, tmp - 1);
2350 : }
2351 :
2352 42186 : tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
2353 :
2354 : /* as is not needed anymore. */
2355 133261 : for (i = 0; i < as.rank + as.corank; i++)
2356 : {
2357 48889 : gfc_free_expr (as.lower[i]);
2358 48889 : gfc_free_expr (as.upper[i]);
2359 : }
2360 :
2361 42186 : init = build_constructor (tmptype, v);
2362 :
2363 42186 : TREE_CONSTANT (init) = 1;
2364 42186 : TREE_STATIC (init) = 1;
2365 :
2366 42186 : tmp = build_decl (input_location, VAR_DECL, create_tmp_var_name ("A"),
2367 : tmptype);
2368 42186 : DECL_ARTIFICIAL (tmp) = 1;
2369 42186 : DECL_IGNORED_P (tmp) = 1;
2370 42186 : TREE_STATIC (tmp) = 1;
2371 42186 : TREE_CONSTANT (tmp) = 1;
2372 42186 : TREE_READONLY (tmp) = 1;
2373 42186 : DECL_INITIAL (tmp) = init;
2374 42186 : pushdecl (tmp);
2375 :
2376 42186 : return tmp;
2377 : }
2378 :
2379 :
2380 : /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
2381 : This mostly initializes the scalarizer state info structure with the
2382 : appropriate values to directly use the array created by the function
2383 : gfc_build_constant_array_constructor. */
2384 :
2385 : static void
2386 36281 : trans_constant_array_constructor (gfc_ss * ss, tree type)
2387 : {
2388 36281 : gfc_array_info *info;
2389 36281 : tree tmp;
2390 36281 : int i;
2391 :
2392 36281 : tmp = gfc_build_constant_array_constructor (ss->info->expr, type);
2393 :
2394 36281 : info = &ss->info->data.array;
2395 :
2396 36281 : info->descriptor = tmp;
2397 36281 : info->data = gfc_build_addr_expr (NULL_TREE, tmp);
2398 36281 : info->offset = gfc_index_zero_node;
2399 :
2400 76393 : for (i = 0; i < ss->dimen; i++)
2401 : {
2402 40112 : info->delta[i] = gfc_index_zero_node;
2403 40112 : info->start[i] = gfc_index_zero_node;
2404 40112 : info->end[i] = gfc_index_zero_node;
2405 40112 : info->stride[i] = gfc_index_one_node;
2406 : }
2407 36281 : }
2408 :
2409 :
2410 : static int
2411 36287 : get_rank (gfc_loopinfo *loop)
2412 : {
2413 36287 : int rank;
2414 :
2415 36287 : rank = 0;
2416 155864 : for (; loop; loop = loop->parent)
2417 77938 : rank += loop->dimen;
2418 :
2419 41639 : return rank;
2420 : }
2421 :
2422 :
2423 : /* Helper routine of gfc_trans_array_constructor to determine if the
2424 : bounds of the loop specified by LOOP are constant and simple enough
2425 : to use with trans_constant_array_constructor. Returns the
2426 : iteration count of the loop if suitable, and NULL_TREE otherwise. */
2427 :
2428 : static tree
2429 36287 : constant_array_constructor_loop_size (gfc_loopinfo * l)
2430 : {
2431 36287 : gfc_loopinfo *loop;
2432 36287 : tree size = gfc_index_one_node;
2433 36287 : tree tmp;
2434 36287 : int i, total_dim;
2435 :
2436 36287 : total_dim = get_rank (l);
2437 :
2438 72574 : for (loop = l; loop; loop = loop->parent)
2439 : {
2440 76417 : for (i = 0; i < loop->dimen; i++)
2441 : {
2442 : /* If the bounds aren't constant, return NULL_TREE. */
2443 40130 : if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
2444 : return NULL_TREE;
2445 40124 : if (!integer_zerop (loop->from[i]))
2446 : {
2447 : /* Only allow nonzero "from" in one-dimensional arrays. */
2448 0 : if (total_dim != 1)
2449 : return NULL_TREE;
2450 0 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2451 : gfc_array_index_type,
2452 : loop->to[i], loop->from[i]);
2453 : }
2454 : else
2455 40124 : tmp = loop->to[i];
2456 40124 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
2457 : gfc_array_index_type, tmp, gfc_index_one_node);
2458 40124 : size = fold_build2_loc (input_location, MULT_EXPR,
2459 : gfc_array_index_type, size, tmp);
2460 : }
2461 : }
2462 :
2463 : return size;
2464 : }
2465 :
2466 :
2467 : static tree *
2468 43091 : get_loop_upper_bound_for_array (gfc_ss *array, int array_dim)
2469 : {
2470 43091 : gfc_ss *ss;
2471 43091 : int n;
2472 :
2473 43091 : gcc_assert (array->nested_ss == NULL);
2474 :
2475 43091 : for (ss = array; ss; ss = ss->parent)
2476 43091 : for (n = 0; n < ss->loop->dimen; n++)
2477 43091 : if (array_dim == get_array_ref_dim_for_loop_dim (ss, n))
2478 43091 : return &(ss->loop->to[n]);
2479 :
2480 0 : gcc_unreachable ();
2481 : }
2482 :
2483 :
2484 : static gfc_loopinfo *
2485 711281 : outermost_loop (gfc_loopinfo * loop)
2486 : {
2487 928122 : while (loop->parent != NULL)
2488 : loop = loop->parent;
2489 :
2490 717969 : return loop;
2491 : }
2492 :
2493 :
2494 : /* Array constructors are handled by constructing a temporary, then using that
2495 : within the scalarization loop. This is not optimal, but seems by far the
2496 : simplest method. */
2497 :
2498 : static void
2499 43091 : trans_array_constructor (gfc_ss * ss, locus * where)
2500 : {
2501 43091 : gfc_constructor_base c;
2502 43091 : tree offset;
2503 43091 : tree offsetvar;
2504 43091 : tree desc;
2505 43091 : tree type;
2506 43091 : tree tmp;
2507 43091 : tree *loop_ubound0;
2508 43091 : bool dynamic;
2509 43091 : bool old_first_len, old_typespec_chararray_ctor;
2510 43091 : tree old_first_len_val;
2511 43091 : gfc_loopinfo *loop, *outer_loop;
2512 43091 : gfc_ss_info *ss_info;
2513 43091 : gfc_expr *expr;
2514 43091 : gfc_ss *s;
2515 43091 : tree neg_len;
2516 43091 : char *msg;
2517 43091 : stmtblock_t finalblock;
2518 43091 : bool finalize_required;
2519 43091 : bool owned_sweep = false;
2520 :
2521 : /* Save the old values for nested checking. */
2522 43091 : old_first_len = first_len;
2523 43091 : old_first_len_val = first_len_val;
2524 43091 : old_typespec_chararray_ctor = typespec_chararray_ctor;
2525 :
2526 43091 : loop = ss->loop;
2527 43091 : outer_loop = outermost_loop (loop);
2528 43091 : ss_info = ss->info;
2529 43091 : expr = ss_info->expr;
2530 :
2531 : /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
2532 : typespec was given for the array constructor. */
2533 86182 : typespec_chararray_ctor = (expr->ts.type == BT_CHARACTER
2534 8194 : && expr->ts.u.cl
2535 51285 : && expr->ts.u.cl->length_from_typespec);
2536 :
2537 43091 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2538 2542 : && expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
2539 : {
2540 1468 : first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
2541 1468 : first_len = true;
2542 : }
2543 :
2544 43091 : gcc_assert (ss->dimen == ss->loop->dimen);
2545 :
2546 43091 : c = expr->value.constructor;
2547 43091 : if (expr->ts.type == BT_CHARACTER)
2548 : {
2549 8194 : bool const_string;
2550 8194 : bool force_new_cl = false;
2551 :
2552 : /* get_array_ctor_strlen walks the elements of the constructor, if a
2553 : typespec was given, we already know the string length and want the one
2554 : specified there. */
2555 8194 : if (typespec_chararray_ctor && expr->ts.u.cl->length
2556 518 : && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
2557 : {
2558 27 : gfc_se length_se;
2559 :
2560 27 : const_string = false;
2561 27 : gfc_init_se (&length_se, NULL);
2562 27 : gfc_conv_expr_type (&length_se, expr->ts.u.cl->length,
2563 : gfc_charlen_type_node);
2564 27 : ss_info->string_length = length_se.expr;
2565 :
2566 : /* Check if the character length is negative. If it is, then
2567 : set LEN = 0. */
2568 27 : neg_len = fold_build2_loc (input_location, LT_EXPR,
2569 : logical_type_node, ss_info->string_length,
2570 27 : build_zero_cst (TREE_TYPE
2571 : (ss_info->string_length)));
2572 : /* Print a warning if bounds checking is enabled. */
2573 27 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2574 : {
2575 18 : msg = xasprintf ("Negative character length treated as LEN = 0");
2576 18 : gfc_trans_runtime_check (false, true, neg_len, &length_se.pre,
2577 : where, msg);
2578 18 : free (msg);
2579 : }
2580 :
2581 27 : ss_info->string_length
2582 27 : = fold_build3_loc (input_location, COND_EXPR,
2583 : gfc_charlen_type_node, neg_len,
2584 : build_zero_cst
2585 27 : (TREE_TYPE (ss_info->string_length)),
2586 : ss_info->string_length);
2587 27 : ss_info->string_length = gfc_evaluate_now (ss_info->string_length,
2588 : &length_se.pre);
2589 27 : gfc_add_block_to_block (&outer_loop->pre, &length_se.pre);
2590 27 : gfc_add_block_to_block (&outer_loop->post, &length_se.post);
2591 27 : }
2592 : else
2593 : {
2594 8167 : const_string = get_array_ctor_strlen (&outer_loop->pre, c,
2595 : &ss_info->string_length);
2596 8167 : force_new_cl = true;
2597 :
2598 : /* Initialize "len" with string length for bounds checking. */
2599 8167 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2600 1486 : && !typespec_chararray_ctor
2601 1468 : && ss_info->string_length)
2602 : {
2603 1468 : gfc_se length_se;
2604 :
2605 1468 : gfc_init_se (&length_se, NULL);
2606 1468 : gfc_add_modify (&length_se.pre, first_len_val,
2607 1468 : fold_convert (TREE_TYPE (first_len_val),
2608 : ss_info->string_length));
2609 1468 : ss_info->string_length = gfc_evaluate_now (ss_info->string_length,
2610 : &length_se.pre);
2611 1468 : gfc_add_block_to_block (&outer_loop->pre, &length_se.pre);
2612 1468 : gfc_add_block_to_block (&outer_loop->post, &length_se.post);
2613 : }
2614 : }
2615 :
2616 : /* Complex character array constructors should have been taken care of
2617 : and not end up here. */
2618 8194 : gcc_assert (ss_info->string_length);
2619 :
2620 8194 : store_backend_decl (&expr->ts.u.cl, ss_info->string_length, force_new_cl);
2621 :
2622 8194 : type = gfc_get_character_type_len (expr->ts.kind, ss_info->string_length);
2623 8194 : if (const_string)
2624 7237 : type = build_pointer_type (type);
2625 : }
2626 : else
2627 34922 : type = gfc_typenode_for_spec (expr->ts.type == BT_CLASS
2628 25 : ? &CLASS_DATA (expr)->ts : &expr->ts);
2629 :
2630 : /* See if the constructor determines the loop bounds. */
2631 43091 : dynamic = false;
2632 :
2633 43091 : loop_ubound0 = get_loop_upper_bound_for_array (ss, 0);
2634 :
2635 84730 : if (expr->shape && get_rank (loop) > 1 && *loop_ubound0 == NULL_TREE)
2636 : {
2637 : /* We have a multidimensional parameter. */
2638 0 : for (s = ss; s; s = s->parent)
2639 : {
2640 : int n;
2641 0 : for (n = 0; n < s->loop->dimen; n++)
2642 : {
2643 0 : s->loop->from[n] = gfc_index_zero_node;
2644 0 : s->loop->to[n] = gfc_conv_mpz_to_tree (expr->shape[s->dim[n]],
2645 : gfc_index_integer_kind);
2646 0 : s->loop->to[n] = fold_build2_loc (input_location, MINUS_EXPR,
2647 : gfc_array_index_type,
2648 0 : s->loop->to[n],
2649 : gfc_index_one_node);
2650 : }
2651 : }
2652 : }
2653 :
2654 43091 : if (*loop_ubound0 == NULL_TREE)
2655 : {
2656 893 : mpz_t size;
2657 :
2658 : /* We should have a 1-dimensional, zero-based loop. */
2659 893 : gcc_assert (loop->parent == NULL && loop->nested == NULL);
2660 893 : gcc_assert (loop->dimen == 1);
2661 893 : gcc_assert (integer_zerop (loop->from[0]));
2662 :
2663 : /* Split the constructor size into a static part and a dynamic part.
2664 : Allocate the static size up-front and record whether the dynamic
2665 : size might be nonzero. */
2666 893 : mpz_init (size);
2667 893 : dynamic = gfc_get_array_constructor_size (&size, c);
2668 893 : mpz_sub_ui (size, size, 1);
2669 893 : loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
2670 893 : mpz_clear (size);
2671 : }
2672 :
2673 : /* Special case constant array constructors. */
2674 893 : if (!dynamic)
2675 : {
2676 42223 : unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
2677 42223 : if (nelem > 0)
2678 : {
2679 36287 : tree size = constant_array_constructor_loop_size (loop);
2680 36287 : if (size && compare_tree_int (size, nelem) == 0)
2681 : {
2682 36281 : trans_constant_array_constructor (ss, type);
2683 36281 : goto finish;
2684 : }
2685 : }
2686 : }
2687 :
2688 6810 : gfc_trans_create_temp_array (&outer_loop->pre, &outer_loop->post, ss, type,
2689 : NULL_TREE, dynamic, true, false, where);
2690 :
2691 6810 : desc = ss_info->data.array.descriptor;
2692 6810 : offset = gfc_index_zero_node;
2693 6810 : offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
2694 6810 : suppress_warning (offsetvar);
2695 6810 : TREE_USED (offsetvar) = 0;
2696 :
2697 6810 : gfc_init_block (&finalblock);
2698 6810 : finalize_required = expr->must_finalize;
2699 6810 : if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
2700 : finalize_required = true;
2701 :
2702 6810 : if (IS_PDT (expr))
2703 : finalize_required = true;
2704 :
2705 : /* If every element of the constructor is a function result with allocatable
2706 : components, those components are owned by the temporary and are freed in a
2707 : single sweep over the whole array below. This is the only way to free the
2708 : elements produced inside an implied-do loop, where a single compile-time
2709 : element stands for many runtime elements. */
2710 14099 : owned_sweep = finalize_required
2711 552 : && expr->ts.type == BT_DERIVED
2712 552 : && expr->ts.u.derived->attr.alloc_comp
2713 7204 : && gfc_constructor_is_owned_alloc_comp (c, expr->ts.u.derived);
2714 :
2715 6810 : gfc_trans_array_constructor_value (&outer_loop->pre,
2716 : finalize_required ? &finalblock : NULL,
2717 : type, desc, c, &offset, &offsetvar,
2718 : dynamic, owned_sweep);
2719 :
2720 6810 : if (owned_sweep)
2721 250 : gfc_add_expr_to_block (&finalblock,
2722 250 : gfc_deallocate_alloc_comp_no_caf (expr->ts.u.derived,
2723 : desc, 1, true));
2724 :
2725 : /* If the array grows dynamically, the upper bound of the loop variable
2726 : is determined by the array's final upper bound. */
2727 6810 : if (dynamic)
2728 : {
2729 868 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2730 : gfc_array_index_type,
2731 : offsetvar, gfc_index_one_node);
2732 868 : tmp = gfc_evaluate_now (tmp, &outer_loop->pre);
2733 868 : if (*loop_ubound0 && VAR_P (*loop_ubound0))
2734 0 : gfc_add_modify (&outer_loop->pre, *loop_ubound0, tmp);
2735 : else
2736 868 : *loop_ubound0 = tmp;
2737 : }
2738 :
2739 6810 : if (TREE_USED (offsetvar))
2740 2180 : pushdecl (offsetvar);
2741 : else
2742 4630 : gcc_assert (INTEGER_CST_P (offset));
2743 :
2744 : #if 0
2745 : /* Disable bound checking for now because it's probably broken. */
2746 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2747 : {
2748 : gcc_unreachable ();
2749 : }
2750 : #endif
2751 :
2752 4630 : finish:
2753 : /* Restore old values of globals. */
2754 43091 : first_len = old_first_len;
2755 43091 : first_len_val = old_first_len_val;
2756 43091 : typespec_chararray_ctor = old_typespec_chararray_ctor;
2757 :
2758 : /* F2008 4.5.6.3 para 5: If an executable construct references a structure
2759 : constructor or array constructor, the entity created by the constructor is
2760 : finalized after execution of the innermost executable construct containing
2761 : the reference. */
2762 43091 : if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
2763 1731 : && finalblock.head != NULL_TREE)
2764 322 : gfc_prepend_expr_to_block (&loop->post, finalblock.head);
2765 43091 : }
2766 :
2767 :
2768 : /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
2769 : called after evaluating all of INFO's vector dimensions. Go through
2770 : each such vector dimension and see if we can now fill in any missing
2771 : loop bounds. */
2772 :
2773 : static void
2774 182303 : set_vector_loop_bounds (gfc_ss * ss)
2775 : {
2776 182303 : gfc_loopinfo *loop, *outer_loop;
2777 182303 : gfc_array_info *info;
2778 182303 : gfc_se se;
2779 182303 : tree tmp;
2780 182303 : tree desc;
2781 182303 : tree zero;
2782 182303 : int n;
2783 182303 : int dim;
2784 :
2785 182303 : outer_loop = outermost_loop (ss->loop);
2786 :
2787 182303 : info = &ss->info->data.array;
2788 :
2789 369242 : for (; ss; ss = ss->parent)
2790 : {
2791 186939 : loop = ss->loop;
2792 :
2793 445241 : for (n = 0; n < loop->dimen; n++)
2794 : {
2795 258302 : dim = ss->dim[n];
2796 258302 : if (info->ref->u.ar.dimen_type[dim] != DIMEN_VECTOR
2797 980 : || loop->to[n] != NULL)
2798 258122 : continue;
2799 :
2800 : /* Loop variable N indexes vector dimension DIM, and we don't
2801 : yet know the upper bound of loop variable N. Set it to the
2802 : difference between the vector's upper and lower bounds. */
2803 180 : gcc_assert (loop->from[n] == gfc_index_zero_node);
2804 180 : gcc_assert (info->subscript[dim]
2805 : && info->subscript[dim]->info->type == GFC_SS_VECTOR);
2806 :
2807 180 : gfc_init_se (&se, NULL);
2808 180 : desc = info->subscript[dim]->info->data.array.descriptor;
2809 180 : zero = gfc_rank_cst[0];
2810 180 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2811 : gfc_array_index_type,
2812 : gfc_conv_descriptor_ubound_get (desc, zero),
2813 : gfc_conv_descriptor_lbound_get (desc, zero));
2814 180 : tmp = gfc_evaluate_now (tmp, &outer_loop->pre);
2815 180 : loop->to[n] = tmp;
2816 : }
2817 : }
2818 182303 : }
2819 :
2820 :
2821 : /* Tells whether a scalar argument to an elemental procedure is saved out
2822 : of a scalarization loop as a value or as a reference. */
2823 :
2824 : bool
2825 45837 : gfc_scalar_elemental_arg_saved_as_reference (gfc_ss_info * ss_info)
2826 : {
2827 45837 : if (ss_info->type != GFC_SS_REFERENCE)
2828 : return false;
2829 :
2830 10294 : if (ss_info->data.scalar.needs_temporary)
2831 : return false;
2832 :
2833 : /* If the actual argument can be absent (in other words, it can
2834 : be a NULL reference), don't try to evaluate it; pass instead
2835 : the reference directly. */
2836 9918 : if (ss_info->can_be_null_ref)
2837 : return true;
2838 :
2839 : /* If the expression is of polymorphic type, it's actual size is not known,
2840 : so we avoid copying it anywhere. */
2841 9242 : if (ss_info->data.scalar.dummy_arg
2842 1402 : && gfc_dummy_arg_get_typespec (*ss_info->data.scalar.dummy_arg).type
2843 : == BT_CLASS
2844 9366 : && ss_info->expr->ts.type == BT_CLASS)
2845 : return true;
2846 :
2847 : /* If the expression is a data reference of aggregate type,
2848 : and the data reference is not used on the left hand side,
2849 : avoid a copy by saving a reference to the content. */
2850 9218 : if (!ss_info->data.scalar.needs_temporary
2851 9218 : && (ss_info->expr->ts.type == BT_DERIVED
2852 8230 : || ss_info->expr->ts.type == BT_CLASS)
2853 10254 : && gfc_expr_is_variable (ss_info->expr))
2854 : return true;
2855 :
2856 : /* Otherwise the expression is evaluated to a temporary variable before the
2857 : scalarization loop. */
2858 : return false;
2859 : }
2860 :
2861 :
2862 : /* Add the pre and post chains for all the scalar expressions in a SS chain
2863 : to loop. This is called after the loop parameters have been calculated,
2864 : but before the actual scalarizing loops. */
2865 :
2866 : static void
2867 191808 : gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
2868 : locus * where)
2869 : {
2870 191808 : gfc_loopinfo *nested_loop, *outer_loop;
2871 191808 : gfc_se se;
2872 191808 : gfc_ss_info *ss_info;
2873 191808 : gfc_array_info *info;
2874 191808 : gfc_expr *expr;
2875 191808 : int n;
2876 :
2877 : /* Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise,
2878 : arguments could get evaluated multiple times. */
2879 191808 : if (ss->is_alloc_lhs)
2880 203 : return;
2881 :
2882 505121 : outer_loop = outermost_loop (loop);
2883 :
2884 : /* TODO: This can generate bad code if there are ordering dependencies,
2885 : e.g., a callee allocated function and an unknown size constructor. */
2886 : gcc_assert (ss != NULL);
2887 :
2888 505121 : for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
2889 : {
2890 313516 : gcc_assert (ss);
2891 :
2892 : /* Cross loop arrays are handled from within the most nested loop. */
2893 313516 : if (ss->nested_ss != NULL)
2894 4740 : continue;
2895 :
2896 308776 : ss_info = ss->info;
2897 308776 : expr = ss_info->expr;
2898 308776 : info = &ss_info->data.array;
2899 :
2900 308776 : switch (ss_info->type)
2901 : {
2902 43683 : case GFC_SS_SCALAR:
2903 : /* Scalar expression. Evaluate this now. This includes elemental
2904 : dimension indices, but not array section bounds. */
2905 43683 : gfc_init_se (&se, NULL);
2906 43683 : gfc_conv_expr (&se, expr);
2907 43683 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
2908 :
2909 43683 : if (expr->ts.type != BT_CHARACTER
2910 43683 : && !gfc_is_alloc_class_scalar_function (expr))
2911 : {
2912 : /* Move the evaluation of scalar expressions outside the
2913 : scalarization loop, except for WHERE assignments. */
2914 39689 : if (subscript)
2915 6481 : se.expr = convert(gfc_array_index_type, se.expr);
2916 39689 : if (!ss_info->where)
2917 39275 : se.expr = gfc_evaluate_now (se.expr, &outer_loop->pre);
2918 39689 : gfc_add_block_to_block (&outer_loop->pre, &se.post);
2919 : }
2920 : else
2921 3994 : gfc_add_block_to_block (&outer_loop->post, &se.post);
2922 :
2923 43683 : ss_info->data.scalar.value = se.expr;
2924 43683 : ss_info->string_length = se.string_length;
2925 43683 : break;
2926 :
2927 5147 : case GFC_SS_REFERENCE:
2928 : /* Scalar argument to elemental procedure. */
2929 5147 : gfc_init_se (&se, NULL);
2930 5147 : if (gfc_scalar_elemental_arg_saved_as_reference (ss_info))
2931 844 : gfc_conv_expr_reference (&se, expr);
2932 : else
2933 : {
2934 : /* Evaluate the argument outside the loop and pass
2935 : a reference to the value. */
2936 4303 : gfc_conv_expr (&se, expr);
2937 : }
2938 :
2939 : /* Ensure that a pointer to the string is stored. */
2940 5147 : if (expr->ts.type == BT_CHARACTER)
2941 174 : gfc_conv_string_parameter (&se);
2942 :
2943 5147 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
2944 5147 : gfc_add_block_to_block (&outer_loop->post, &se.post);
2945 5147 : if (gfc_is_class_scalar_expr (expr))
2946 : /* This is necessary because the dynamic type will always be
2947 : large than the declared type. In consequence, assigning
2948 : the value to a temporary could segfault.
2949 : OOP-TODO: see if this is generally correct or is the value
2950 : has to be written to an allocated temporary, whose address
2951 : is passed via ss_info. */
2952 48 : ss_info->data.scalar.value = se.expr;
2953 : else
2954 5099 : ss_info->data.scalar.value = gfc_evaluate_now (se.expr,
2955 : &outer_loop->pre);
2956 :
2957 5147 : ss_info->string_length = se.string_length;
2958 5147 : break;
2959 :
2960 : case GFC_SS_SECTION:
2961 : /* Add the expressions for scalar and vector subscripts. */
2962 2916848 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2963 2734545 : if (info->subscript[n])
2964 7461 : gfc_add_loop_ss_code (loop, info->subscript[n], true, where);
2965 :
2966 182303 : set_vector_loop_bounds (ss);
2967 182303 : break;
2968 :
2969 980 : case GFC_SS_VECTOR:
2970 : /* Get the vector's descriptor and store it in SS. */
2971 980 : gfc_init_se (&se, NULL);
2972 980 : gfc_conv_expr_descriptor (&se, expr);
2973 980 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
2974 980 : gfc_add_block_to_block (&outer_loop->post, &se.post);
2975 980 : info->descriptor = se.expr;
2976 980 : break;
2977 :
2978 11581 : case GFC_SS_INTRINSIC:
2979 11581 : gfc_add_intrinsic_ss_code (loop, ss);
2980 11581 : break;
2981 :
2982 9570 : case GFC_SS_FUNCTION:
2983 9570 : {
2984 : /* Array function return value. We call the function and save its
2985 : result in a temporary for use inside the loop. */
2986 9570 : gfc_init_se (&se, NULL);
2987 9570 : se.loop = loop;
2988 9570 : se.ss = ss;
2989 9570 : bool class_func = gfc_is_class_array_function (expr);
2990 9570 : if (class_func)
2991 183 : expr->must_finalize = 1;
2992 9570 : gfc_conv_expr (&se, expr);
2993 9570 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
2994 9570 : if (class_func
2995 183 : && se.expr
2996 9753 : && GFC_CLASS_TYPE_P (TREE_TYPE (se.expr)))
2997 : {
2998 183 : tree tmp = gfc_class_data_get (se.expr);
2999 183 : info->descriptor = tmp;
3000 183 : info->data = gfc_conv_descriptor_data_get (tmp);
3001 183 : info->offset = gfc_conv_descriptor_offset_get (tmp);
3002 366 : for (gfc_ss *s = ss; s; s = s->parent)
3003 378 : for (int n = 0; n < s->dimen; n++)
3004 : {
3005 195 : int dim = s->dim[n];
3006 195 : tree tree_dim = gfc_rank_cst[dim];
3007 :
3008 195 : tree start;
3009 195 : start = gfc_conv_descriptor_lbound_get (tmp, tree_dim);
3010 195 : start = gfc_evaluate_now (start, &outer_loop->pre);
3011 195 : info->start[dim] = start;
3012 :
3013 195 : tree end;
3014 195 : end = gfc_conv_descriptor_ubound_get (tmp, tree_dim);
3015 195 : end = gfc_evaluate_now (end, &outer_loop->pre);
3016 195 : info->end[dim] = end;
3017 :
3018 195 : tree stride;
3019 195 : stride = gfc_conv_descriptor_stride_get (tmp, tree_dim);
3020 195 : stride = gfc_evaluate_now (stride, &outer_loop->pre);
3021 195 : info->stride[dim] = stride;
3022 : }
3023 : }
3024 9570 : gfc_add_block_to_block (&outer_loop->post, &se.post);
3025 9570 : gfc_add_block_to_block (&outer_loop->post, &se.finalblock);
3026 9570 : ss_info->string_length = se.string_length;
3027 : }
3028 9570 : break;
3029 :
3030 43091 : case GFC_SS_CONSTRUCTOR:
3031 43091 : if (expr->ts.type == BT_CHARACTER
3032 8194 : && ss_info->string_length == NULL
3033 8194 : && expr->ts.u.cl
3034 8194 : && expr->ts.u.cl->length
3035 7850 : && expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
3036 : {
3037 7793 : gfc_init_se (&se, NULL);
3038 7793 : gfc_conv_expr_type (&se, expr->ts.u.cl->length,
3039 : gfc_charlen_type_node);
3040 7793 : ss_info->string_length = se.expr;
3041 7793 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3042 7793 : gfc_add_block_to_block (&outer_loop->post, &se.post);
3043 : }
3044 43091 : trans_array_constructor (ss, where);
3045 43091 : break;
3046 :
3047 : case GFC_SS_TEMP:
3048 : case GFC_SS_COMPONENT:
3049 : /* Do nothing. These are handled elsewhere. */
3050 : break;
3051 :
3052 0 : default:
3053 0 : gcc_unreachable ();
3054 : }
3055 : }
3056 :
3057 191605 : if (!subscript)
3058 187508 : for (nested_loop = loop->nested; nested_loop;
3059 3364 : nested_loop = nested_loop->next)
3060 3364 : gfc_add_loop_ss_code (nested_loop, nested_loop->ss, subscript, where);
3061 : }
3062 :
3063 :
3064 : /* Given an array descriptor expression DESCR and its data pointer DATA, decide
3065 : whether to either save the data pointer to a variable and use the variable or
3066 : use the data pointer expression directly without any intermediary variable.
3067 : */
3068 :
3069 : static bool
3070 129871 : save_descriptor_data (tree descr, tree data)
3071 : {
3072 129871 : return !(DECL_P (data)
3073 118781 : || (TREE_CODE (data) == ADDR_EXPR
3074 70161 : && DECL_P (TREE_OPERAND (data, 0)))
3075 51727 : || (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (descr))
3076 48228 : && TREE_CODE (descr) == COMPONENT_REF
3077 11189 : && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (descr, 0)))));
3078 : }
3079 :
3080 :
3081 : /* Type of the DATA argument passed to walk_tree by substitute_subexpr_in_expr
3082 : and used by maybe_substitute_expr. */
3083 :
3084 : typedef struct
3085 : {
3086 : tree target, repl;
3087 : }
3088 : substitute_t;
3089 :
3090 :
3091 : /* Check if the expression in *TP is equal to the substitution target provided
3092 : in DATA->TARGET and replace it with DATA->REPL in that case. This is a
3093 : callback function for use with walk_tree. */
3094 :
3095 : static tree
3096 21411 : maybe_substitute_expr (tree *tp, int *walk_subtree, void *data)
3097 : {
3098 21411 : substitute_t *subst = (substitute_t *) data;
3099 21411 : if (*tp == subst->target)
3100 : {
3101 4102 : *tp = subst->repl;
3102 4102 : *walk_subtree = 0;
3103 : }
3104 :
3105 21411 : return NULL_TREE;
3106 : }
3107 :
3108 :
3109 : /* Substitute in EXPR any occurrence of TARGET with REPLACEMENT. */
3110 :
3111 : static void
3112 3795 : substitute_subexpr_in_expr (tree target, tree replacement, tree expr)
3113 : {
3114 3795 : substitute_t subst;
3115 3795 : subst.target = target;
3116 3795 : subst.repl = replacement;
3117 :
3118 3795 : walk_tree (&expr, maybe_substitute_expr, &subst, nullptr);
3119 3795 : }
3120 :
3121 :
3122 : /* Save REF to a fresh variable in all of REPLACEMENT_ROOTS, appending extra
3123 : code to CODE. Before returning, add REF to REPLACEMENT_ROOTS and clear
3124 : REF. */
3125 :
3126 : static void
3127 3623 : save_ref (tree &code, tree &ref, vec<tree> &replacement_roots)
3128 : {
3129 3623 : stmtblock_t tmp_block;
3130 3623 : gfc_init_block (&tmp_block);
3131 3623 : tree var = gfc_evaluate_now (ref, &tmp_block);
3132 3623 : gfc_add_expr_to_block (&tmp_block, code);
3133 3623 : code = gfc_finish_block (&tmp_block);
3134 :
3135 3623 : unsigned i;
3136 3623 : tree repl_root;
3137 7418 : FOR_EACH_VEC_ELT (replacement_roots, i, repl_root)
3138 3795 : substitute_subexpr_in_expr (ref, var, repl_root);
3139 :
3140 3623 : replacement_roots.safe_push (ref);
3141 3623 : ref = NULL_TREE;
3142 3623 : }
3143 :
3144 :
3145 : /* If REF isn't shared with code in PREVIOUS_CODE, replace it with a fresh
3146 : variable in all of REPLACEMENT_ROOTS, appending extra code to CODE. */
3147 :
3148 : static void
3149 3695 : maybe_save_ref (tree &code, tree &ref, vec<tree> &replacement_roots,
3150 : stmtblock_t *previous_code)
3151 : {
3152 3695 : if (find_tree (previous_code->head, ref))
3153 : return;
3154 :
3155 3623 : save_ref (code, ref, replacement_roots);
3156 : }
3157 :
3158 :
3159 : /* Save the descriptor reference VALUE to storage pointed by DESC_PTR. Before
3160 : that, try to create fresh variables to factor subexpressions of VALUE, if
3161 : those subexpressions aren't shared with code in PRELIMINARY_CODE. Add any
3162 : necessary additional code (initialization of variables typically) to BLOCK.
3163 :
3164 : The candidate references to factoring are dereferenced pointers because they
3165 : are cheap to copy and array descriptors because they are often the base of
3166 : multiple subreferences. */
3167 :
3168 : static void
3169 327155 : set_factored_descriptor_value (tree *desc_ptr, tree value, stmtblock_t *block,
3170 : stmtblock_t *preliminary_code)
3171 : {
3172 : /* As the reference is processed from outer to inner, variable definitions
3173 : will be generated in reversed order, so can't be put directly in BLOCK.
3174 : We use temporary blocks instead, which we save in ACCUMULATED_CODE, and
3175 : only append to BLOCK at the end. */
3176 327155 : tree accumulated_code = NULL_TREE;
3177 :
3178 : /* The current candidate to factoring. */
3179 327155 : tree saveable_ref = NULL_TREE;
3180 :
3181 : /* The root expressions in which we look for subexpressions to replace with
3182 : variables. */
3183 327155 : auto_vec<tree> replacement_roots;
3184 327155 : replacement_roots.safe_push (value);
3185 :
3186 327155 : tree data_ref = value;
3187 327155 : tree next_ref = NULL_TREE;
3188 :
3189 : /* If the candidate reference is not followed by a subreference, it can't be
3190 : saved to a variable as it may be reallocatable, and we have to keep the
3191 : parent reference to be able to store the new pointer value in case of
3192 : reallocation. */
3193 327155 : bool maybe_reallocatable = true;
3194 :
3195 435665 : while (true)
3196 : {
3197 435665 : if (!maybe_reallocatable
3198 435665 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (data_ref)))
3199 2434 : saveable_ref = data_ref;
3200 :
3201 435665 : if (TREE_CODE (data_ref) == INDIRECT_REF)
3202 : {
3203 58564 : next_ref = TREE_OPERAND (data_ref, 0);
3204 :
3205 58564 : if (!maybe_reallocatable)
3206 : {
3207 14765 : if (saveable_ref != NULL_TREE && saveable_ref != data_ref)
3208 : {
3209 : /* A reference worth saving has been seen, and now the pointer
3210 : to the current reference is also worth saving. If the
3211 : previous reference to save wasn't the current one, do save
3212 : it now. Otherwise drop it as we prefer saving the
3213 : pointer. */
3214 1827 : maybe_save_ref (accumulated_code, saveable_ref,
3215 : replacement_roots, preliminary_code);
3216 : }
3217 :
3218 : /* Don't evaluate the pointer to a variable yet; do it only if the
3219 : variable would be significantly more simple than the reference
3220 : it replaces. That is if the reference contains anything
3221 : different from NOPs, COMPONENTs and DECLs. */
3222 14765 : saveable_ref = next_ref;
3223 : }
3224 : }
3225 377101 : else if (TREE_CODE (data_ref) == COMPONENT_REF)
3226 : {
3227 40839 : maybe_reallocatable = false;
3228 40839 : next_ref = TREE_OPERAND (data_ref, 0);
3229 : }
3230 336262 : else if (TREE_CODE (data_ref) == NOP_EXPR)
3231 3695 : next_ref = TREE_OPERAND (data_ref, 0);
3232 : else
3233 : {
3234 332567 : if (DECL_P (data_ref))
3235 : break;
3236 :
3237 6994 : if (TREE_CODE (data_ref) == ARRAY_REF)
3238 : {
3239 5412 : maybe_reallocatable = false;
3240 5412 : next_ref = TREE_OPERAND (data_ref, 0);
3241 : }
3242 :
3243 6994 : if (saveable_ref != NULL_TREE)
3244 : /* We have seen a reference worth saving. Do it now. */
3245 1868 : maybe_save_ref (accumulated_code, saveable_ref, replacement_roots,
3246 : preliminary_code);
3247 :
3248 6994 : if (TREE_CODE (data_ref) != ARRAY_REF)
3249 : break;
3250 : }
3251 :
3252 : data_ref = next_ref;
3253 : }
3254 :
3255 327155 : *desc_ptr = value;
3256 327155 : gfc_add_expr_to_block (block, accumulated_code);
3257 327155 : }
3258 :
3259 :
3260 : /* Translate expressions for the descriptor and data pointer of a SS. */
3261 : /*GCC ARRAYS*/
3262 :
3263 : static void
3264 327155 : gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
3265 : {
3266 327155 : gfc_se se;
3267 327155 : gfc_ss_info *ss_info;
3268 327155 : gfc_array_info *info;
3269 327155 : tree tmp;
3270 :
3271 327155 : ss_info = ss->info;
3272 327155 : info = &ss_info->data.array;
3273 :
3274 : /* Get the descriptor for the array to be scalarized. */
3275 327155 : gcc_assert (ss_info->expr->expr_type == EXPR_VARIABLE);
3276 327155 : gfc_init_se (&se, NULL);
3277 327155 : se.descriptor_only = 1;
3278 327155 : gfc_conv_expr_lhs (&se, ss_info->expr);
3279 327155 : stmtblock_t tmp_block;
3280 327155 : gfc_init_block (&tmp_block);
3281 327155 : set_factored_descriptor_value (&info->descriptor, se.expr, &tmp_block,
3282 : &se.pre);
3283 327155 : gfc_add_block_to_block (block, &se.pre);
3284 327155 : gfc_add_block_to_block (block, &tmp_block);
3285 327155 : ss_info->string_length = se.string_length;
3286 327155 : ss_info->class_container = se.class_container;
3287 :
3288 327155 : if (base)
3289 : {
3290 123215 : if (ss_info->expr->ts.type == BT_CHARACTER && !ss_info->expr->ts.deferred
3291 22778 : && ss_info->expr->ts.u.cl->length == NULL)
3292 : {
3293 : /* Emit a DECL_EXPR for the variable sized array type in
3294 : GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
3295 : sizes works correctly. */
3296 1097 : tree arraytype = TREE_TYPE (
3297 : GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (info->descriptor)));
3298 1097 : if (! TYPE_NAME (arraytype))
3299 899 : TYPE_NAME (arraytype) = build_decl (UNKNOWN_LOCATION, TYPE_DECL,
3300 : NULL_TREE, arraytype);
3301 1097 : gfc_add_expr_to_block (block, build1 (DECL_EXPR, arraytype,
3302 1097 : TYPE_NAME (arraytype)));
3303 : }
3304 : /* Also the data pointer. */
3305 123215 : tmp = gfc_conv_array_data (se.expr);
3306 : /* If this is a variable or address or a class array, use it directly.
3307 : Otherwise we must evaluate it now to avoid breaking dependency
3308 : analysis by pulling the expressions for elemental array indices
3309 : inside the loop. */
3310 123215 : if (save_descriptor_data (se.expr, tmp) && !ss->is_alloc_lhs)
3311 36415 : tmp = gfc_evaluate_now (tmp, block);
3312 123215 : info->data = tmp;
3313 :
3314 123215 : tmp = gfc_conv_array_offset (se.expr);
3315 123215 : if (!ss->is_alloc_lhs)
3316 116762 : tmp = gfc_evaluate_now (tmp, block);
3317 123215 : info->offset = tmp;
3318 :
3319 : /* Make absolutely sure that the saved_offset is indeed saved
3320 : so that the variable is still accessible after the loops
3321 : are translated. */
3322 123215 : info->saved_offset = info->offset;
3323 : }
3324 327155 : }
3325 :
3326 :
3327 : /* Initialize a gfc_loopinfo structure. */
3328 :
3329 : void
3330 191250 : gfc_init_loopinfo (gfc_loopinfo * loop)
3331 : {
3332 191250 : int n;
3333 :
3334 191250 : memset (loop, 0, sizeof (gfc_loopinfo));
3335 191250 : gfc_init_block (&loop->pre);
3336 191250 : gfc_init_block (&loop->post);
3337 :
3338 : /* Initially scalarize in order and default to no loop reversal. */
3339 3251250 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
3340 : {
3341 2868750 : loop->order[n] = n;
3342 2868750 : loop->reverse[n] = GFC_INHIBIT_REVERSE;
3343 : }
3344 :
3345 191250 : loop->ss = gfc_ss_terminator;
3346 191250 : }
3347 :
3348 :
3349 : /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
3350 : chain. */
3351 :
3352 : void
3353 190817 : gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
3354 : {
3355 190817 : se->loop = loop;
3356 190817 : }
3357 :
3358 :
3359 : /* Return an expression for the data pointer of an array. */
3360 :
3361 : tree
3362 335997 : gfc_conv_array_data (tree descriptor)
3363 : {
3364 335997 : tree type;
3365 :
3366 335997 : type = TREE_TYPE (descriptor);
3367 335997 : if (GFC_ARRAY_TYPE_P (type))
3368 : {
3369 235647 : if (TREE_CODE (type) == POINTER_TYPE)
3370 : return descriptor;
3371 : else
3372 : {
3373 : /* Descriptorless arrays. */
3374 176400 : return gfc_build_addr_expr (NULL_TREE, descriptor);
3375 : }
3376 : }
3377 : else
3378 100350 : return gfc_conv_descriptor_data_get (descriptor);
3379 : }
3380 :
3381 :
3382 : /* Return an expression for the base offset of an array. */
3383 :
3384 : tree
3385 249548 : gfc_conv_array_offset (tree descriptor)
3386 : {
3387 249548 : tree type;
3388 :
3389 249548 : type = TREE_TYPE (descriptor);
3390 249548 : if (GFC_ARRAY_TYPE_P (type))
3391 178101 : return GFC_TYPE_ARRAY_OFFSET (type);
3392 : else
3393 71447 : return gfc_conv_descriptor_offset_get (descriptor);
3394 : }
3395 :
3396 :
3397 : /* Get an expression for the array stride. */
3398 :
3399 : tree
3400 497168 : gfc_conv_array_stride (tree descriptor, int dim)
3401 : {
3402 497168 : tree tmp;
3403 497168 : tree type;
3404 :
3405 497168 : type = TREE_TYPE (descriptor);
3406 :
3407 : /* For descriptorless arrays use the array size. */
3408 497168 : tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
3409 497168 : if (tmp != NULL_TREE)
3410 : return tmp;
3411 :
3412 113873 : tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]);
3413 113873 : return tmp;
3414 : }
3415 :
3416 :
3417 : /* Like gfc_conv_array_stride, but for the lower bound. */
3418 :
3419 : tree
3420 320119 : gfc_conv_array_lbound (tree descriptor, int dim)
3421 : {
3422 320119 : tree tmp;
3423 320119 : tree type;
3424 :
3425 320119 : type = TREE_TYPE (descriptor);
3426 :
3427 320119 : tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
3428 320119 : if (tmp != NULL_TREE)
3429 : return tmp;
3430 :
3431 18657 : tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]);
3432 18657 : return tmp;
3433 : }
3434 :
3435 :
3436 : /* Like gfc_conv_array_stride, but for the upper bound. */
3437 :
3438 : tree
3439 207323 : gfc_conv_array_ubound (tree descriptor, int dim)
3440 : {
3441 207323 : tree tmp;
3442 207323 : tree type;
3443 :
3444 207323 : type = TREE_TYPE (descriptor);
3445 :
3446 207323 : tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
3447 207323 : if (tmp != NULL_TREE)
3448 : return tmp;
3449 :
3450 : /* This should only ever happen when passing an assumed shape array
3451 : as an actual parameter. The value will never be used. */
3452 8081 : if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
3453 554 : return gfc_index_zero_node;
3454 :
3455 7527 : tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]);
3456 7527 : return tmp;
3457 : }
3458 :
3459 :
3460 : /* Generate abridged name of a part-ref for use in bounds-check message.
3461 : Cases:
3462 : (1) for an ordinary array variable x return "x"
3463 : (2) for z a DT scalar and array component x (at level 1) return "z%%x"
3464 : (3) for z a DT scalar and array component x (at level > 1) or
3465 : for z a DT array and array x (at any number of levels): "z...%%x"
3466 : */
3467 :
3468 : static char *
3469 36604 : abridged_ref_name (gfc_expr * expr, gfc_array_ref * ar)
3470 : {
3471 36604 : gfc_ref *ref;
3472 36604 : gfc_symbol *sym;
3473 36604 : char *ref_name = NULL;
3474 36604 : const char *comp_name = NULL;
3475 36604 : int len_sym, last_len = 0, level = 0;
3476 36604 : bool sym_is_array;
3477 :
3478 36604 : gcc_assert (expr->expr_type == EXPR_VARIABLE && expr->ref != NULL);
3479 :
3480 36604 : sym = expr->symtree->n.sym;
3481 72821 : sym_is_array = (sym->ts.type != BT_CLASS
3482 36604 : ? sym->as != NULL
3483 387 : : IS_CLASS_ARRAY (sym));
3484 36604 : len_sym = strlen (sym->name);
3485 :
3486 : /* Scan ref chain to get name of the array component (when ar != NULL) or
3487 : array section, determine depth and remember its component name. */
3488 52135 : for (ref = expr->ref; ref; ref = ref->next)
3489 : {
3490 38053 : if (ref->type == REF_COMPONENT
3491 1048 : && strcmp (ref->u.c.component->name, "_data") != 0)
3492 : {
3493 918 : level++;
3494 918 : comp_name = ref->u.c.component->name;
3495 918 : continue;
3496 : }
3497 :
3498 37135 : if (ref->type != REF_ARRAY)
3499 150 : continue;
3500 :
3501 36985 : if (ar)
3502 : {
3503 15971 : if (&ref->u.ar == ar)
3504 : break;
3505 : }
3506 21014 : else if (ref->u.ar.type == AR_SECTION)
3507 : break;
3508 : }
3509 :
3510 36604 : if (level > 0)
3511 800 : last_len = strlen (comp_name);
3512 :
3513 : /* Provide a buffer sufficiently large to hold "x...%%z". */
3514 36604 : ref_name = XNEWVEC (char, len_sym + last_len + 6);
3515 36604 : strcpy (ref_name, sym->name);
3516 :
3517 36604 : if (level == 1 && !sym_is_array)
3518 : {
3519 442 : strcat (ref_name, "%%");
3520 442 : strcat (ref_name, comp_name);
3521 : }
3522 36162 : else if (level > 0)
3523 : {
3524 358 : strcat (ref_name, "...%%");
3525 358 : strcat (ref_name, comp_name);
3526 : }
3527 :
3528 36604 : return ref_name;
3529 : }
3530 :
3531 :
3532 : /* Generate code to perform an array index bound check. */
3533 :
3534 : static tree
3535 5714 : trans_array_bound_check (stmtblock_t *block, gfc_ss *ss, tree index, int n,
3536 : locus * where, bool check_upper,
3537 : const char *compname = NULL)
3538 : {
3539 5714 : tree fault;
3540 5714 : tree tmp_lo, tmp_up;
3541 5714 : tree descriptor;
3542 5714 : char *msg;
3543 5714 : char *ref_name = NULL;
3544 5714 : const char * name = NULL;
3545 5714 : gfc_expr *expr;
3546 :
3547 5714 : if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
3548 : return index;
3549 :
3550 252 : descriptor = ss->info->data.array.descriptor;
3551 :
3552 252 : index = gfc_evaluate_now (index, block);
3553 :
3554 : /* We find a name for the error message. */
3555 252 : name = ss->info->expr->symtree->n.sym->name;
3556 252 : gcc_assert (name != NULL);
3557 :
3558 : /* When we have a component ref, get name of the array section.
3559 : Note that there can only be one part ref. */
3560 252 : expr = ss->info->expr;
3561 252 : if (expr->ref && !compname)
3562 160 : name = ref_name = abridged_ref_name (expr, NULL);
3563 :
3564 252 : if (VAR_P (descriptor))
3565 162 : name = IDENTIFIER_POINTER (DECL_NAME (descriptor));
3566 :
3567 : /* Use given (array component) name. */
3568 252 : if (compname)
3569 92 : name = compname;
3570 :
3571 : /* If upper bound is present, include both bounds in the error message. */
3572 252 : if (check_upper)
3573 : {
3574 225 : tmp_lo = gfc_conv_array_lbound (descriptor, n);
3575 225 : tmp_up = gfc_conv_array_ubound (descriptor, n);
3576 :
3577 225 : if (name)
3578 225 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3579 : "outside of expected range (%%ld:%%ld)", n+1, name);
3580 : else
3581 0 : msg = xasprintf ("Index '%%ld' of dimension %d "
3582 : "outside of expected range (%%ld:%%ld)", n+1);
3583 :
3584 225 : fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3585 : index, tmp_lo);
3586 225 : gfc_trans_runtime_check (true, false, fault, block, where, msg,
3587 : fold_convert (long_integer_type_node, index),
3588 : fold_convert (long_integer_type_node, tmp_lo),
3589 : fold_convert (long_integer_type_node, tmp_up));
3590 225 : fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3591 : index, tmp_up);
3592 225 : gfc_trans_runtime_check (true, false, fault, block, where, msg,
3593 : fold_convert (long_integer_type_node, index),
3594 : fold_convert (long_integer_type_node, tmp_lo),
3595 : fold_convert (long_integer_type_node, tmp_up));
3596 225 : free (msg);
3597 : }
3598 : else
3599 : {
3600 27 : tmp_lo = gfc_conv_array_lbound (descriptor, n);
3601 :
3602 27 : if (name)
3603 27 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3604 : "below lower bound of %%ld", n+1, name);
3605 : else
3606 0 : msg = xasprintf ("Index '%%ld' of dimension %d "
3607 : "below lower bound of %%ld", n+1);
3608 :
3609 27 : fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3610 : index, tmp_lo);
3611 27 : gfc_trans_runtime_check (true, false, fault, block, where, msg,
3612 : fold_convert (long_integer_type_node, index),
3613 : fold_convert (long_integer_type_node, tmp_lo));
3614 27 : free (msg);
3615 : }
3616 :
3617 252 : free (ref_name);
3618 252 : return index;
3619 : }
3620 :
3621 :
3622 : /* Helper functions to detect impure functions in an expression. */
3623 :
3624 : static const char *impure_name = NULL;
3625 : static bool
3626 108 : expr_contains_impure_fcn (gfc_expr *e, gfc_symbol* sym ATTRIBUTE_UNUSED,
3627 : int* g ATTRIBUTE_UNUSED)
3628 : {
3629 108 : if (e && e->expr_type == EXPR_FUNCTION
3630 6 : && !gfc_pure_function (e, &impure_name)
3631 111 : && !gfc_implicit_pure_function (e))
3632 : return true;
3633 :
3634 : return false;
3635 : }
3636 :
3637 : static bool
3638 92 : gfc_expr_contains_impure_fcn (gfc_expr *e)
3639 : {
3640 92 : impure_name = NULL;
3641 92 : return gfc_traverse_expr (e, NULL, &expr_contains_impure_fcn, 0);
3642 : }
3643 :
3644 :
3645 : /* Generate code for bounds checking for elemental dimensions. */
3646 :
3647 : static void
3648 6688 : array_bound_check_elemental (stmtblock_t *block, gfc_ss * ss, gfc_expr * expr)
3649 : {
3650 6688 : gfc_array_ref *ar;
3651 6688 : gfc_ref *ref;
3652 6688 : char *var_name = NULL;
3653 6688 : int dim;
3654 :
3655 6688 : if (expr->expr_type == EXPR_VARIABLE)
3656 : {
3657 12533 : for (ref = expr->ref; ref; ref = ref->next)
3658 : {
3659 6303 : if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
3660 : {
3661 3953 : ar = &ref->u.ar;
3662 3953 : var_name = abridged_ref_name (expr, ar);
3663 8158 : for (dim = 0; dim < ar->dimen; dim++)
3664 : {
3665 4205 : if (ar->dimen_type[dim] == DIMEN_ELEMENT)
3666 : {
3667 92 : if (gfc_expr_contains_impure_fcn (ar->start[dim]))
3668 3 : gfc_warning_now (0, "Bounds checking of the elemental "
3669 : "index at %L will cause two calls to "
3670 : "%qs, which is not declared to be "
3671 : "PURE or is not implicitly pure.",
3672 3 : &ar->start[dim]->where, impure_name);
3673 92 : gfc_se indexse;
3674 92 : gfc_init_se (&indexse, NULL);
3675 92 : gfc_conv_expr_type (&indexse, ar->start[dim],
3676 : gfc_array_index_type);
3677 92 : gfc_add_block_to_block (block, &indexse.pre);
3678 92 : trans_array_bound_check (block, ss, indexse.expr, dim,
3679 : &ar->where,
3680 92 : ar->as->type != AS_ASSUMED_SIZE
3681 92 : || dim < ar->dimen - 1,
3682 : var_name);
3683 : }
3684 : }
3685 3953 : free (var_name);
3686 : }
3687 : }
3688 : }
3689 6688 : }
3690 :
3691 :
3692 : /* Return the offset for an index. Performs bound checking for elemental
3693 : dimensions. Single element references are processed separately.
3694 : DIM is the array dimension, I is the loop dimension. */
3695 :
3696 : static tree
3697 253963 : conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i,
3698 : gfc_array_ref * ar, tree stride)
3699 : {
3700 253963 : gfc_array_info *info;
3701 253963 : tree index;
3702 253963 : tree desc;
3703 253963 : tree data;
3704 :
3705 253963 : info = &ss->info->data.array;
3706 :
3707 : /* Get the index into the array for this dimension. */
3708 253963 : if (ar)
3709 : {
3710 180622 : gcc_assert (ar->type != AR_ELEMENT);
3711 180622 : switch (ar->dimen_type[dim])
3712 : {
3713 0 : case DIMEN_THIS_IMAGE:
3714 0 : gcc_unreachable ();
3715 4645 : break;
3716 4645 : case DIMEN_ELEMENT:
3717 : /* Elemental dimension. */
3718 4645 : gcc_assert (info->subscript[dim]
3719 : && info->subscript[dim]->info->type == GFC_SS_SCALAR);
3720 : /* We've already translated this value outside the loop. */
3721 4645 : index = info->subscript[dim]->info->data.scalar.value;
3722 :
3723 9290 : index = trans_array_bound_check (&se->pre, ss, index, dim, &ar->where,
3724 4645 : ar->as->type != AS_ASSUMED_SIZE
3725 4645 : || dim < ar->dimen - 1);
3726 4645 : break;
3727 :
3728 977 : case DIMEN_VECTOR:
3729 977 : gcc_assert (info && se->loop);
3730 977 : gcc_assert (info->subscript[dim]
3731 : && info->subscript[dim]->info->type == GFC_SS_VECTOR);
3732 977 : desc = info->subscript[dim]->info->data.array.descriptor;
3733 :
3734 : /* Get a zero-based index into the vector. */
3735 977 : index = fold_build2_loc (input_location, MINUS_EXPR,
3736 : gfc_array_index_type,
3737 : se->loop->loopvar[i], se->loop->from[i]);
3738 :
3739 : /* Multiply the index by the stride. */
3740 977 : index = fold_build2_loc (input_location, MULT_EXPR,
3741 : gfc_array_index_type,
3742 : index, gfc_conv_array_stride (desc, 0));
3743 :
3744 : /* Read the vector to get an index into info->descriptor. */
3745 977 : data = build_fold_indirect_ref_loc (input_location,
3746 : gfc_conv_array_data (desc));
3747 977 : index = gfc_build_array_ref (data, index, NULL);
3748 977 : index = gfc_evaluate_now (index, &se->pre);
3749 977 : index = fold_convert (gfc_array_index_type, index);
3750 :
3751 : /* Do any bounds checking on the final info->descriptor index. */
3752 1954 : index = trans_array_bound_check (&se->pre, ss, index, dim, &ar->where,
3753 977 : ar->as->type != AS_ASSUMED_SIZE
3754 977 : || dim < ar->dimen - 1);
3755 977 : break;
3756 :
3757 175000 : case DIMEN_RANGE:
3758 : /* Scalarized dimension. */
3759 175000 : gcc_assert (info && se->loop);
3760 :
3761 : /* Multiply the loop variable by the stride and delta. */
3762 175000 : index = se->loop->loopvar[i];
3763 175000 : if (!integer_onep (info->stride[dim]))
3764 6954 : index = fold_build2_loc (input_location, MULT_EXPR,
3765 : gfc_array_index_type, index,
3766 : info->stride[dim]);
3767 175000 : if (!integer_zerop (info->delta[dim]))
3768 67320 : index = fold_build2_loc (input_location, PLUS_EXPR,
3769 : gfc_array_index_type, index,
3770 : info->delta[dim]);
3771 : break;
3772 :
3773 0 : default:
3774 0 : gcc_unreachable ();
3775 : }
3776 : }
3777 : else
3778 : {
3779 : /* Temporary array or derived type component. */
3780 73341 : gcc_assert (se->loop);
3781 73341 : index = se->loop->loopvar[se->loop->order[i]];
3782 :
3783 : /* Pointer functions can have stride[0] different from unity.
3784 : Use the stride returned by the function call and stored in
3785 : the descriptor for the temporary. */
3786 73341 : if (se->ss && se->ss->info->type == GFC_SS_FUNCTION
3787 8032 : && se->ss->info->expr
3788 8032 : && se->ss->info->expr->symtree
3789 8032 : && se->ss->info->expr->symtree->n.sym->result
3790 7592 : && se->ss->info->expr->symtree->n.sym->result->attr.pointer)
3791 144 : stride = gfc_conv_descriptor_stride_get (info->descriptor,
3792 : gfc_rank_cst[dim]);
3793 :
3794 73341 : if (info->delta[dim] && !integer_zerop (info->delta[dim]))
3795 804 : index = fold_build2_loc (input_location, PLUS_EXPR,
3796 : gfc_array_index_type, index, info->delta[dim]);
3797 : }
3798 :
3799 : /* Multiply by the stride. */
3800 253963 : if (stride != NULL && !integer_onep (stride))
3801 77520 : index = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
3802 : index, stride);
3803 :
3804 253963 : return index;
3805 : }
3806 :
3807 :
3808 : /* Build a scalarized array reference using the vptr 'size'. */
3809 :
3810 : static bool
3811 194434 : build_class_array_ref (gfc_se *se, tree base, tree index)
3812 : {
3813 194434 : tree size;
3814 194434 : tree decl = NULL_TREE;
3815 194434 : tree tmp;
3816 194434 : gfc_expr *expr = se->ss->info->expr;
3817 194434 : gfc_expr *class_expr;
3818 194434 : gfc_typespec *ts;
3819 194434 : gfc_symbol *sym;
3820 :
3821 194434 : tmp = !VAR_P (base) ? gfc_get_class_from_expr (base) : NULL_TREE;
3822 :
3823 90933 : if (tmp != NULL_TREE)
3824 : decl = tmp;
3825 : else
3826 : {
3827 : /* The base expression does not contain a class component, either
3828 : because it is a temporary array or array descriptor. Class
3829 : array functions are correctly resolved above. */
3830 191085 : if (!expr
3831 191085 : || (expr->ts.type != BT_CLASS
3832 177298 : && !gfc_is_class_array_ref (expr, NULL)))
3833 190650 : return false;
3834 :
3835 : /* Obtain the expression for the class entity or component that is
3836 : followed by an array reference, which is not an element, so that
3837 : the span of the array can be obtained. */
3838 435 : class_expr = gfc_find_and_cut_at_last_class_ref (expr, false, &ts);
3839 :
3840 435 : if (!ts)
3841 : return false;
3842 :
3843 410 : sym = (!class_expr && expr) ? expr->symtree->n.sym : NULL;
3844 0 : if (sym && sym->attr.function
3845 0 : && sym == sym->result
3846 0 : && sym->backend_decl == current_function_decl)
3847 : /* The temporary is the data field of the class data component
3848 : of the current function. */
3849 0 : decl = gfc_get_fake_result_decl (sym, 0);
3850 410 : else if (sym)
3851 : {
3852 0 : if (decl == NULL_TREE)
3853 0 : decl = expr->symtree->n.sym->backend_decl;
3854 : /* For class arrays the tree containing the class is stored in
3855 : GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl.
3856 : For all others it's sym's backend_decl directly. */
3857 0 : if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl))
3858 0 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
3859 : }
3860 : else
3861 410 : decl = gfc_get_class_from_gfc_expr (class_expr);
3862 :
3863 410 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
3864 0 : decl = build_fold_indirect_ref_loc (input_location, decl);
3865 :
3866 410 : if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl)))
3867 : return false;
3868 : }
3869 :
3870 3759 : se->class_vptr = gfc_evaluate_now (gfc_class_vptr_get (decl), &se->pre);
3871 :
3872 3759 : size = gfc_class_vtab_size_get (decl);
3873 : /* For unlimited polymorphic entities then _len component needs to be
3874 : multiplied with the size. */
3875 3759 : size = gfc_resize_class_size_with_len (&se->pre, decl, size);
3876 3759 : size = fold_convert (TREE_TYPE (index), size);
3877 :
3878 : /* Return the element in the se expression. */
3879 3759 : se->expr = gfc_build_spanned_array_ref (base, index, size);
3880 3759 : return true;
3881 : }
3882 :
3883 :
3884 : /* Indicates that the tree EXPR is a reference to an array that can’t
3885 : have any negative stride. */
3886 :
3887 : static bool
3888 314727 : non_negative_strides_array_p (tree expr)
3889 : {
3890 328060 : if (expr == NULL_TREE)
3891 : return false;
3892 :
3893 328060 : tree type = TREE_TYPE (expr);
3894 328060 : if (POINTER_TYPE_P (type))
3895 72800 : type = TREE_TYPE (type);
3896 :
3897 328060 : if (TYPE_LANG_SPECIFIC (type))
3898 : {
3899 328060 : gfc_array_kind array_kind = GFC_TYPE_ARRAY_AKIND (type);
3900 :
3901 328060 : if (array_kind == GFC_ARRAY_ALLOCATABLE
3902 328060 : || array_kind == GFC_ARRAY_ASSUMED_SHAPE_CONT)
3903 : return true;
3904 : }
3905 :
3906 : /* An array with descriptor can have negative strides.
3907 : We try to be conservative and return false by default here
3908 : if we don’t recognize a contiguous array instead of
3909 : returning false if we can identify a non-contiguous one. */
3910 270941 : if (!GFC_ARRAY_TYPE_P (type))
3911 : return false;
3912 :
3913 : /* If the array was originally a dummy with a descriptor, strides can be
3914 : negative. */
3915 236846 : if (DECL_P (expr)
3916 227877 : && DECL_LANG_SPECIFIC (expr)
3917 47976 : && GFC_DECL_SAVED_DESCRIPTOR (expr)
3918 250198 : && GFC_DECL_SAVED_DESCRIPTOR (expr) != expr)
3919 13333 : return non_negative_strides_array_p (GFC_DECL_SAVED_DESCRIPTOR (expr));
3920 :
3921 : return true;
3922 : }
3923 :
3924 :
3925 : /* Build a scalarized reference to an array. */
3926 :
3927 : static void
3928 194434 : gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar,
3929 : bool tmp_array = false)
3930 : {
3931 194434 : gfc_array_info *info;
3932 194434 : tree decl = NULL_TREE;
3933 194434 : tree index;
3934 194434 : tree base;
3935 194434 : gfc_ss *ss;
3936 194434 : gfc_expr *expr;
3937 194434 : int n;
3938 :
3939 194434 : ss = se->ss;
3940 194434 : expr = ss->info->expr;
3941 194434 : info = &ss->info->data.array;
3942 194434 : if (ar)
3943 133197 : n = se->loop->order[0];
3944 : else
3945 : n = 0;
3946 :
3947 194434 : index = conv_array_index_offset (se, ss, ss->dim[n], n, ar, info->stride0);
3948 : /* Add the offset for this dimension to the stored offset for all other
3949 : dimensions. */
3950 194434 : if (info->offset && !integer_zerop (info->offset))
3951 142849 : index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3952 : index, info->offset);
3953 :
3954 194434 : base = build_fold_indirect_ref_loc (input_location, info->data);
3955 :
3956 : /* Use the vptr 'size' field to access the element of a class array. */
3957 194434 : if (build_class_array_ref (se, base, index))
3958 3759 : return;
3959 :
3960 190675 : if (get_CFI_desc (NULL, expr, &decl, ar))
3961 442 : decl = build_fold_indirect_ref_loc (input_location, decl);
3962 :
3963 : /* A pointer array component can be detected from its field decl. Fix
3964 : the descriptor, mark the resulting variable decl and pass it to
3965 : gfc_build_array_ref. */
3966 190675 : if (is_pointer_array (info->descriptor)
3967 190675 : || (expr && expr->ts.deferred && info->descriptor
3968 2913 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info->descriptor))))
3969 : {
3970 9143 : if (TREE_CODE (info->descriptor) == COMPONENT_REF)
3971 1588 : decl = info->descriptor;
3972 7555 : else if (INDIRECT_REF_P (info->descriptor))
3973 1485 : decl = TREE_OPERAND (info->descriptor, 0);
3974 :
3975 9143 : if (decl == NULL_TREE)
3976 6070 : decl = info->descriptor;
3977 : }
3978 :
3979 190675 : bool non_negative_stride = tmp_array
3980 190675 : || non_negative_strides_array_p (info->descriptor);
3981 190675 : se->expr = gfc_build_array_ref (base, index, decl,
3982 : non_negative_stride);
3983 : }
3984 :
3985 :
3986 : /* Translate access of temporary array. */
3987 :
3988 : void
3989 61237 : gfc_conv_tmp_array_ref (gfc_se * se)
3990 : {
3991 61237 : se->string_length = se->ss->info->string_length;
3992 61237 : gfc_conv_scalarized_array_ref (se, NULL, true);
3993 61237 : gfc_advance_se_ss_chain (se);
3994 61237 : }
3995 :
3996 : /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
3997 :
3998 : static void
3999 277329 : add_to_offset (tree *cst_offset, tree *offset, tree t)
4000 : {
4001 277329 : if (TREE_CODE (t) == INTEGER_CST)
4002 140148 : *cst_offset = int_const_binop (PLUS_EXPR, *cst_offset, t);
4003 : else
4004 : {
4005 137181 : if (!integer_zerop (*offset))
4006 47781 : *offset = fold_build2_loc (input_location, PLUS_EXPR,
4007 : gfc_array_index_type, *offset, t);
4008 : else
4009 89400 : *offset = t;
4010 : }
4011 277329 : }
4012 :
4013 :
4014 : static tree
4015 184895 : build_array_ref (tree desc, tree offset, tree decl, tree vptr)
4016 : {
4017 184895 : tree tmp;
4018 184895 : tree type;
4019 184895 : tree cdesc;
4020 :
4021 : /* For class arrays the class declaration is stored in the saved
4022 : descriptor. */
4023 184895 : if (INDIRECT_REF_P (desc)
4024 7336 : && DECL_LANG_SPECIFIC (TREE_OPERAND (desc, 0))
4025 187211 : && GFC_DECL_SAVED_DESCRIPTOR (TREE_OPERAND (desc, 0)))
4026 881 : cdesc = gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (
4027 : TREE_OPERAND (desc, 0)));
4028 : else
4029 : cdesc = desc;
4030 :
4031 : /* Class container types do not always have the GFC_CLASS_TYPE_P
4032 : but the canonical type does. */
4033 184895 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdesc))
4034 184895 : && TREE_CODE (cdesc) == COMPONENT_REF)
4035 : {
4036 11380 : type = TREE_TYPE (TREE_OPERAND (cdesc, 0));
4037 11380 : if (TYPE_CANONICAL (type)
4038 11380 : && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type)))
4039 : {
4040 3481 : vptr = gfc_class_vptr_get (TREE_OPERAND (cdesc, 0));
4041 : /* Pass the class container as decl so that gfc_build_array_ref can
4042 : correct the element size for an unlimited polymorphic character
4043 : payload (the _len field), which the vptr size alone omits. Only do
4044 : this for a genuine array element reference; a scalar coarray has
4045 : nothing to span-correct and gfc_build_array_ref asserts decl is null
4046 : for it. */
4047 3481 : if (decl == NULL_TREE
4048 3481 : && GFC_TYPE_ARRAY_RANK (TREE_TYPE (cdesc)) > 0)
4049 3357 : decl = TREE_OPERAND (cdesc, 0);
4050 : }
4051 : }
4052 :
4053 184895 : tmp = gfc_conv_array_data (desc);
4054 184895 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
4055 184895 : tmp = gfc_build_array_ref (tmp, offset, decl,
4056 184895 : non_negative_strides_array_p (desc),
4057 : vptr);
4058 184895 : return tmp;
4059 : }
4060 :
4061 :
4062 : /* Build an array reference. se->expr already holds the array descriptor.
4063 : This should be either a variable, indirect variable reference or component
4064 : reference. For arrays which do not have a descriptor, se->expr will be
4065 : the data pointer.
4066 : a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
4067 :
4068 : void
4069 263007 : gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
4070 : locus * where)
4071 : {
4072 263007 : int n;
4073 263007 : tree offset, cst_offset;
4074 263007 : tree tmp;
4075 263007 : tree stride;
4076 263007 : tree decl = NULL_TREE;
4077 263007 : gfc_se indexse;
4078 263007 : gfc_se tmpse;
4079 263007 : gfc_symbol * sym = expr->symtree->n.sym;
4080 263007 : char *var_name = NULL;
4081 :
4082 263007 : if (ar->stat)
4083 : {
4084 3 : gfc_se statse;
4085 :
4086 3 : gfc_init_se (&statse, NULL);
4087 3 : gfc_conv_expr_lhs (&statse, ar->stat);
4088 3 : gfc_add_block_to_block (&se->pre, &statse.pre);
4089 3 : gfc_add_modify (&se->pre, statse.expr, integer_zero_node);
4090 : }
4091 263007 : if (ar->dimen == 0)
4092 : {
4093 4538 : gcc_assert (ar->codimen || sym->attr.select_rank_temporary
4094 : || (ar->as && ar->as->corank));
4095 :
4096 4538 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
4097 993 : se->expr = build_fold_indirect_ref (gfc_conv_array_data (se->expr));
4098 : else
4099 : {
4100 3545 : if (GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr))
4101 3545 : && TREE_CODE (TREE_TYPE (se->expr)) == POINTER_TYPE)
4102 2598 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
4103 :
4104 : /* Use the actual tree type and not the wrapped coarray. */
4105 3545 : if (!se->want_pointer)
4106 2576 : se->expr = fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se->expr)),
4107 : se->expr);
4108 : }
4109 :
4110 137735 : return;
4111 : }
4112 :
4113 : /* Handle scalarized references separately. */
4114 258469 : if (ar->type != AR_ELEMENT)
4115 : {
4116 133197 : gfc_conv_scalarized_array_ref (se, ar);
4117 133197 : gfc_advance_se_ss_chain (se);
4118 133197 : return;
4119 : }
4120 :
4121 125272 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
4122 11849 : var_name = abridged_ref_name (expr, ar);
4123 :
4124 125272 : decl = se->expr;
4125 125272 : if (UNLIMITED_POLY(sym)
4126 104 : && IS_CLASS_ARRAY (sym)
4127 103 : && sym->attr.dummy
4128 60 : && ar->as->type != AS_DEFERRED)
4129 48 : decl = sym->backend_decl;
4130 :
4131 125272 : cst_offset = offset = gfc_index_zero_node;
4132 125272 : add_to_offset (&cst_offset, &offset, gfc_conv_array_offset (decl));
4133 :
4134 : /* Calculate the offsets from all the dimensions. Make sure to associate
4135 : the final offset so that we form a chain of loop invariant summands. */
4136 277329 : for (n = ar->dimen - 1; n >= 0; n--)
4137 : {
4138 : /* Calculate the index for this dimension. */
4139 152057 : gfc_init_se (&indexse, se);
4140 152057 : gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
4141 152057 : gfc_add_block_to_block (&se->pre, &indexse.pre);
4142 :
4143 152057 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && ! expr->no_bounds_check)
4144 : {
4145 : /* Check array bounds. */
4146 15389 : tree cond;
4147 15389 : char *msg;
4148 :
4149 : /* Evaluate the indexse.expr only once. */
4150 15389 : indexse.expr = save_expr (indexse.expr);
4151 :
4152 : /* Lower bound. */
4153 15389 : tmp = gfc_conv_array_lbound (decl, n);
4154 15389 : if (sym->attr.temporary)
4155 : {
4156 18 : gfc_init_se (&tmpse, se);
4157 18 : gfc_conv_expr_type (&tmpse, ar->as->lower[n],
4158 : gfc_array_index_type);
4159 18 : gfc_add_block_to_block (&se->pre, &tmpse.pre);
4160 18 : tmp = tmpse.expr;
4161 : }
4162 :
4163 15389 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
4164 : indexse.expr, tmp);
4165 15389 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4166 : "below lower bound of %%ld", n+1, var_name);
4167 15389 : gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
4168 : fold_convert (long_integer_type_node,
4169 : indexse.expr),
4170 : fold_convert (long_integer_type_node, tmp));
4171 15389 : free (msg);
4172 :
4173 : /* Upper bound, but not for the last dimension of assumed-size
4174 : arrays. */
4175 15389 : if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE)
4176 : {
4177 13656 : tmp = gfc_conv_array_ubound (decl, n);
4178 13656 : if (sym->attr.temporary)
4179 : {
4180 18 : gfc_init_se (&tmpse, se);
4181 18 : gfc_conv_expr_type (&tmpse, ar->as->upper[n],
4182 : gfc_array_index_type);
4183 18 : gfc_add_block_to_block (&se->pre, &tmpse.pre);
4184 18 : tmp = tmpse.expr;
4185 : }
4186 :
4187 13656 : cond = fold_build2_loc (input_location, GT_EXPR,
4188 : logical_type_node, indexse.expr, tmp);
4189 13656 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4190 : "above upper bound of %%ld", n+1, var_name);
4191 13656 : gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
4192 : fold_convert (long_integer_type_node,
4193 : indexse.expr),
4194 : fold_convert (long_integer_type_node, tmp));
4195 13656 : free (msg);
4196 : }
4197 : }
4198 :
4199 : /* Multiply the index by the stride. */
4200 152057 : stride = gfc_conv_array_stride (decl, n);
4201 152057 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4202 : indexse.expr, stride);
4203 :
4204 : /* And add it to the total. */
4205 152057 : add_to_offset (&cst_offset, &offset, tmp);
4206 : }
4207 :
4208 125272 : if (!integer_zerop (cst_offset))
4209 66842 : offset = fold_build2_loc (input_location, PLUS_EXPR,
4210 : gfc_array_index_type, offset, cst_offset);
4211 :
4212 : /* A pointer array component can be detected from its field decl. Fix
4213 : the descriptor, mark the resulting variable decl and pass it to
4214 : build_array_ref. */
4215 125272 : decl = NULL_TREE;
4216 125272 : if (get_CFI_desc (sym, expr, &decl, ar))
4217 3589 : decl = build_fold_indirect_ref_loc (input_location, decl);
4218 124213 : if (!expr->ts.deferred && !sym->attr.codimension
4219 247260 : && is_pointer_array (se->expr))
4220 : {
4221 5129 : if (TREE_CODE (se->expr) == COMPONENT_REF)
4222 1672 : decl = se->expr;
4223 3457 : else if (INDIRECT_REF_P (se->expr))
4224 984 : decl = TREE_OPERAND (se->expr, 0);
4225 : else
4226 2473 : decl = se->expr;
4227 : }
4228 120143 : else if (expr->ts.deferred
4229 119084 : || (sym->ts.type == BT_CHARACTER
4230 15347 : && sym->attr.select_type_temporary))
4231 : {
4232 2769 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
4233 : {
4234 2613 : decl = se->expr;
4235 2613 : if (INDIRECT_REF_P (decl))
4236 20 : decl = TREE_OPERAND (decl, 0);
4237 : }
4238 : else
4239 156 : decl = sym->backend_decl;
4240 : }
4241 117374 : else if (sym->ts.type == BT_CLASS)
4242 : {
4243 2237 : if (UNLIMITED_POLY (sym))
4244 : {
4245 104 : gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr);
4246 104 : gfc_init_se (&tmpse, NULL);
4247 104 : gfc_conv_expr (&tmpse, class_expr);
4248 104 : if (!se->class_vptr)
4249 104 : se->class_vptr = gfc_class_vptr_get (tmpse.expr);
4250 104 : gfc_free_expr (class_expr);
4251 104 : decl = tmpse.expr;
4252 104 : }
4253 : else
4254 2133 : decl = NULL_TREE;
4255 : }
4256 :
4257 125272 : free (var_name);
4258 125272 : se->expr = build_array_ref (se->expr, offset, decl, se->class_vptr);
4259 : }
4260 :
4261 :
4262 : /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
4263 : LOOP_DIM dimension (if any) to array's offset. */
4264 :
4265 : static void
4266 59529 : add_array_offset (stmtblock_t *pblock, gfc_loopinfo *loop, gfc_ss *ss,
4267 : gfc_array_ref *ar, int array_dim, int loop_dim)
4268 : {
4269 59529 : gfc_se se;
4270 59529 : gfc_array_info *info;
4271 59529 : tree stride, index;
4272 :
4273 59529 : info = &ss->info->data.array;
4274 :
4275 59529 : gfc_init_se (&se, NULL);
4276 59529 : se.loop = loop;
4277 59529 : se.expr = info->descriptor;
4278 59529 : stride = gfc_conv_array_stride (info->descriptor, array_dim);
4279 59529 : index = conv_array_index_offset (&se, ss, array_dim, loop_dim, ar, stride);
4280 59529 : gfc_add_block_to_block (pblock, &se.pre);
4281 :
4282 59529 : info->offset = fold_build2_loc (input_location, PLUS_EXPR,
4283 : gfc_array_index_type,
4284 : info->offset, index);
4285 59529 : info->offset = gfc_evaluate_now (info->offset, pblock);
4286 59529 : }
4287 :
4288 :
4289 : /* Generate the code to be executed immediately before entering a
4290 : scalarization loop. */
4291 :
4292 : static void
4293 146906 : gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
4294 : stmtblock_t * pblock)
4295 : {
4296 146906 : tree stride;
4297 146906 : gfc_ss_info *ss_info;
4298 146906 : gfc_array_info *info;
4299 146906 : gfc_ss_type ss_type;
4300 146906 : gfc_ss *ss, *pss;
4301 146906 : gfc_loopinfo *ploop;
4302 146906 : gfc_array_ref *ar;
4303 :
4304 : /* This code will be executed before entering the scalarization loop
4305 : for this dimension. */
4306 447931 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4307 : {
4308 301025 : ss_info = ss->info;
4309 :
4310 301025 : if ((ss_info->useflags & flag) == 0)
4311 1476 : continue;
4312 :
4313 299549 : ss_type = ss_info->type;
4314 365552 : if (ss_type != GFC_SS_SECTION
4315 : && ss_type != GFC_SS_FUNCTION
4316 299549 : && ss_type != GFC_SS_CONSTRUCTOR
4317 299549 : && ss_type != GFC_SS_COMPONENT)
4318 66003 : continue;
4319 :
4320 233546 : info = &ss_info->data.array;
4321 :
4322 233546 : gcc_assert (dim < ss->dimen);
4323 233546 : gcc_assert (ss->dimen == loop->dimen);
4324 :
4325 233546 : if (info->ref)
4326 164826 : ar = &info->ref->u.ar;
4327 : else
4328 : ar = NULL;
4329 :
4330 233546 : if (dim == loop->dimen - 1 && loop->parent != NULL)
4331 : {
4332 : /* If we are in the outermost dimension of this loop, the previous
4333 : dimension shall be in the parent loop. */
4334 4687 : gcc_assert (ss->parent != NULL);
4335 :
4336 4687 : pss = ss->parent;
4337 4687 : ploop = loop->parent;
4338 :
4339 : /* ss and ss->parent are about the same array. */
4340 4687 : gcc_assert (ss_info == pss->info);
4341 : }
4342 : else
4343 : {
4344 : ploop = loop;
4345 : pss = ss;
4346 : }
4347 :
4348 233546 : if (dim == loop->dimen - 1 && loop->parent == NULL)
4349 : {
4350 178662 : gcc_assert (0 == ploop->order[0]);
4351 :
4352 357324 : stride = gfc_conv_array_stride (info->descriptor,
4353 178662 : innermost_ss (ss)->dim[0]);
4354 :
4355 : /* Calculate the stride of the innermost loop. Hopefully this will
4356 : allow the backend optimizers to do their stuff more effectively.
4357 : */
4358 178662 : info->stride0 = gfc_evaluate_now (stride, pblock);
4359 :
4360 : /* For the outermost loop calculate the offset due to any
4361 : elemental dimensions. It will have been initialized with the
4362 : base offset of the array. */
4363 178662 : if (info->ref)
4364 : {
4365 289143 : for (int i = 0; i < ar->dimen; i++)
4366 : {
4367 167097 : if (ar->dimen_type[i] != DIMEN_ELEMENT)
4368 162452 : continue;
4369 :
4370 4645 : add_array_offset (pblock, loop, ss, ar, i, /* unused */ -1);
4371 : }
4372 : }
4373 : }
4374 : else
4375 : {
4376 54884 : int i;
4377 :
4378 54884 : if (dim == loop->dimen - 1)
4379 : i = 0;
4380 : else
4381 50197 : i = dim + 1;
4382 :
4383 : /* For the time being, there is no loop reordering. */
4384 54884 : gcc_assert (i == ploop->order[i]);
4385 54884 : i = ploop->order[i];
4386 :
4387 : /* Add the offset for the previous loop dimension. */
4388 54884 : add_array_offset (pblock, ploop, ss, ar, pss->dim[i], i);
4389 : }
4390 :
4391 : /* Remember this offset for the second loop. */
4392 233546 : if (dim == loop->temp_dim - 1 && loop->parent == NULL)
4393 54436 : info->saved_offset = info->offset;
4394 : }
4395 146906 : }
4396 :
4397 :
4398 : /* Start a scalarized expression. Creates a scope and declares loop
4399 : variables. */
4400 :
4401 : void
4402 116524 : gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
4403 : {
4404 116524 : int dim;
4405 116524 : int n;
4406 116524 : int flags;
4407 :
4408 116524 : gcc_assert (!loop->array_parameter);
4409 :
4410 261850 : for (dim = loop->dimen - 1; dim >= 0; dim--)
4411 : {
4412 145326 : n = loop->order[dim];
4413 :
4414 145326 : gfc_start_block (&loop->code[n]);
4415 :
4416 : /* Create the loop variable. */
4417 145326 : loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
4418 :
4419 145326 : if (dim < loop->temp_dim)
4420 : flags = 3;
4421 : else
4422 99416 : flags = 1;
4423 : /* Calculate values that will be constant within this loop. */
4424 145326 : gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
4425 : }
4426 116524 : gfc_start_block (pbody);
4427 116524 : }
4428 :
4429 :
4430 : /* Generates the actual loop code for a scalarization loop. */
4431 :
4432 : static void
4433 161431 : gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
4434 : stmtblock_t * pbody)
4435 : {
4436 161431 : stmtblock_t block;
4437 161431 : tree cond;
4438 161431 : tree tmp;
4439 161431 : tree loopbody;
4440 161431 : tree exit_label;
4441 161431 : tree stmt;
4442 161431 : tree init;
4443 161431 : tree incr;
4444 :
4445 161431 : if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS
4446 : | OMPWS_SCALARIZER_BODY))
4447 : == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS)
4448 108 : && n == loop->dimen - 1)
4449 : {
4450 : /* We create an OMP_FOR construct for the outermost scalarized loop. */
4451 80 : init = make_tree_vec (1);
4452 80 : cond = make_tree_vec (1);
4453 80 : incr = make_tree_vec (1);
4454 :
4455 : /* Cycle statement is implemented with a goto. Exit statement must not
4456 : be present for this loop. */
4457 80 : exit_label = gfc_build_label_decl (NULL_TREE);
4458 80 : TREE_USED (exit_label) = 1;
4459 :
4460 : /* Label for cycle statements (if needed). */
4461 80 : tmp = build1_v (LABEL_EXPR, exit_label);
4462 80 : gfc_add_expr_to_block (pbody, tmp);
4463 :
4464 80 : stmt = make_node (OMP_FOR);
4465 :
4466 80 : TREE_TYPE (stmt) = void_type_node;
4467 80 : OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody);
4468 :
4469 80 : OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location,
4470 : OMP_CLAUSE_SCHEDULE);
4471 80 : OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt))
4472 80 : = OMP_CLAUSE_SCHEDULE_STATIC;
4473 80 : if (ompws_flags & OMPWS_NOWAIT)
4474 33 : OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt))
4475 66 : = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT);
4476 :
4477 : /* Initialize the loopvar. */
4478 80 : TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n],
4479 : loop->from[n]);
4480 80 : OMP_FOR_INIT (stmt) = init;
4481 : /* The exit condition. */
4482 80 : TREE_VEC_ELT (cond, 0) = build2_loc (input_location, LE_EXPR,
4483 : logical_type_node,
4484 : loop->loopvar[n], loop->to[n]);
4485 80 : SET_EXPR_LOCATION (TREE_VEC_ELT (cond, 0), input_location);
4486 80 : OMP_FOR_COND (stmt) = cond;
4487 : /* Increment the loopvar. */
4488 80 : tmp = build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4489 : loop->loopvar[n], gfc_index_one_node);
4490 80 : TREE_VEC_ELT (incr, 0) = fold_build2_loc (input_location, MODIFY_EXPR,
4491 : void_type_node, loop->loopvar[n], tmp);
4492 80 : OMP_FOR_INCR (stmt) = incr;
4493 :
4494 80 : ompws_flags &= ~OMPWS_CURR_SINGLEUNIT;
4495 80 : gfc_add_expr_to_block (&loop->code[n], stmt);
4496 : }
4497 : else
4498 : {
4499 322702 : bool reverse_loop = (loop->reverse[n] == GFC_REVERSE_SET)
4500 161351 : && (loop->temp_ss == NULL);
4501 :
4502 161351 : loopbody = gfc_finish_block (pbody);
4503 :
4504 161351 : if (reverse_loop)
4505 204 : std::swap (loop->from[n], loop->to[n]);
4506 :
4507 : /* Initialize the loopvar. */
4508 161351 : if (loop->loopvar[n] != loop->from[n])
4509 160530 : gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
4510 :
4511 161351 : exit_label = gfc_build_label_decl (NULL_TREE);
4512 :
4513 : /* Generate the loop body. */
4514 161351 : gfc_init_block (&block);
4515 :
4516 : /* The exit condition. */
4517 322498 : cond = fold_build2_loc (input_location, reverse_loop ? LT_EXPR : GT_EXPR,
4518 : logical_type_node, loop->loopvar[n], loop->to[n]);
4519 161351 : tmp = build1_v (GOTO_EXPR, exit_label);
4520 161351 : TREE_USED (exit_label) = 1;
4521 161351 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
4522 161351 : gfc_add_expr_to_block (&block, tmp);
4523 :
4524 : /* The main body. */
4525 161351 : gfc_add_expr_to_block (&block, loopbody);
4526 :
4527 : /* Increment the loopvar. */
4528 322498 : tmp = fold_build2_loc (input_location,
4529 : reverse_loop ? MINUS_EXPR : PLUS_EXPR,
4530 : gfc_array_index_type, loop->loopvar[n],
4531 : gfc_index_one_node);
4532 :
4533 161351 : gfc_add_modify (&block, loop->loopvar[n], tmp);
4534 :
4535 : /* Build the loop. */
4536 161351 : tmp = gfc_finish_block (&block);
4537 161351 : tmp = build1_v (LOOP_EXPR, tmp);
4538 161351 : gfc_add_expr_to_block (&loop->code[n], tmp);
4539 :
4540 : /* Add the exit label. */
4541 161351 : tmp = build1_v (LABEL_EXPR, exit_label);
4542 161351 : gfc_add_expr_to_block (&loop->code[n], tmp);
4543 : }
4544 :
4545 161431 : }
4546 :
4547 :
4548 : /* Finishes and generates the loops for a scalarized expression. */
4549 :
4550 : void
4551 122841 : gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
4552 : {
4553 122841 : int dim;
4554 122841 : int n;
4555 122841 : gfc_ss *ss;
4556 122841 : stmtblock_t *pblock;
4557 122841 : tree tmp;
4558 :
4559 122841 : pblock = body;
4560 : /* Generate the loops. */
4561 274475 : for (dim = 0; dim < loop->dimen; dim++)
4562 : {
4563 151634 : n = loop->order[dim];
4564 151634 : gfc_trans_scalarized_loop_end (loop, n, pblock);
4565 151634 : loop->loopvar[n] = NULL_TREE;
4566 151634 : pblock = &loop->code[n];
4567 : }
4568 :
4569 122841 : tmp = gfc_finish_block (pblock);
4570 122841 : gfc_add_expr_to_block (&loop->pre, tmp);
4571 :
4572 : /* Clear all the used flags. */
4573 359397 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4574 236556 : if (ss->parent == NULL)
4575 231806 : ss->info->useflags = 0;
4576 122841 : }
4577 :
4578 :
4579 : /* Finish the main body of a scalarized expression, and start the secondary
4580 : copying body. */
4581 :
4582 : void
4583 8217 : gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
4584 : {
4585 8217 : int dim;
4586 8217 : int n;
4587 8217 : stmtblock_t *pblock;
4588 8217 : gfc_ss *ss;
4589 :
4590 8217 : pblock = body;
4591 : /* We finish as many loops as are used by the temporary. */
4592 9797 : for (dim = 0; dim < loop->temp_dim - 1; dim++)
4593 : {
4594 1580 : n = loop->order[dim];
4595 1580 : gfc_trans_scalarized_loop_end (loop, n, pblock);
4596 1580 : loop->loopvar[n] = NULL_TREE;
4597 1580 : pblock = &loop->code[n];
4598 : }
4599 :
4600 : /* We don't want to finish the outermost loop entirely. */
4601 8217 : n = loop->order[loop->temp_dim - 1];
4602 8217 : gfc_trans_scalarized_loop_end (loop, n, pblock);
4603 :
4604 : /* Restore the initial offsets. */
4605 23555 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4606 : {
4607 15338 : gfc_ss_type ss_type;
4608 15338 : gfc_ss_info *ss_info;
4609 :
4610 15338 : ss_info = ss->info;
4611 :
4612 15338 : if ((ss_info->useflags & 2) == 0)
4613 4546 : continue;
4614 :
4615 10792 : ss_type = ss_info->type;
4616 10946 : if (ss_type != GFC_SS_SECTION
4617 : && ss_type != GFC_SS_FUNCTION
4618 10792 : && ss_type != GFC_SS_CONSTRUCTOR
4619 10792 : && ss_type != GFC_SS_COMPONENT)
4620 154 : continue;
4621 :
4622 10638 : ss_info->data.array.offset = ss_info->data.array.saved_offset;
4623 : }
4624 :
4625 : /* Restart all the inner loops we just finished. */
4626 9797 : for (dim = loop->temp_dim - 2; dim >= 0; dim--)
4627 : {
4628 1580 : n = loop->order[dim];
4629 :
4630 1580 : gfc_start_block (&loop->code[n]);
4631 :
4632 1580 : loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
4633 :
4634 1580 : gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
4635 : }
4636 :
4637 : /* Start a block for the secondary copying code. */
4638 8217 : gfc_start_block (body);
4639 8217 : }
4640 :
4641 :
4642 : /* Precalculate (either lower or upper) bound of an array section.
4643 : BLOCK: Block in which the (pre)calculation code will go.
4644 : BOUNDS[DIM]: Where the bound value will be stored once evaluated.
4645 : VALUES[DIM]: Specified bound (NULL <=> unspecified).
4646 : DESC: Array descriptor from which the bound will be picked if unspecified
4647 : (either lower or upper bound according to LBOUND). */
4648 :
4649 : static void
4650 517578 : evaluate_bound (stmtblock_t *block, tree *bounds, gfc_expr ** values,
4651 : tree desc, int dim, bool lbound, bool deferred, bool save_value)
4652 : {
4653 517578 : gfc_se se;
4654 517578 : gfc_expr * input_val = values[dim];
4655 517578 : tree *output = &bounds[dim];
4656 :
4657 517578 : if (input_val)
4658 : {
4659 : /* Specified section bound. */
4660 47936 : gfc_init_se (&se, NULL);
4661 47936 : gfc_conv_expr_type (&se, input_val, gfc_array_index_type);
4662 47936 : gfc_add_block_to_block (block, &se.pre);
4663 47936 : *output = se.expr;
4664 : }
4665 469642 : else if (deferred && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
4666 : {
4667 : /* The gfc_conv_array_lbound () routine returns a constant zero for
4668 : deferred length arrays, which in the scalarizer wreaks havoc, when
4669 : copying to a (newly allocated) one-based array.
4670 : Keep returning the actual result in sync for both bounds. */
4671 191471 : *output = lbound ? gfc_conv_descriptor_lbound_get (desc,
4672 : gfc_rank_cst[dim]):
4673 63937 : gfc_conv_descriptor_ubound_get (desc,
4674 : gfc_rank_cst[dim]);
4675 : }
4676 : else
4677 : {
4678 : /* No specific bound specified so use the bound of the array. */
4679 509739 : *output = lbound ? gfc_conv_array_lbound (desc, dim) :
4680 167631 : gfc_conv_array_ubound (desc, dim);
4681 : }
4682 517578 : if (save_value)
4683 498460 : *output = gfc_evaluate_now (*output, block);
4684 517578 : }
4685 :
4686 :
4687 : /* Calculate the lower bound of an array section. */
4688 :
4689 : static void
4690 259422 : gfc_conv_section_startstride (stmtblock_t * block, gfc_ss * ss, int dim)
4691 : {
4692 259422 : gfc_expr *stride = NULL;
4693 259422 : tree desc;
4694 259422 : gfc_se se;
4695 259422 : gfc_array_info *info;
4696 259422 : gfc_array_ref *ar;
4697 :
4698 259422 : gcc_assert (ss->info->type == GFC_SS_SECTION);
4699 :
4700 259422 : info = &ss->info->data.array;
4701 259422 : ar = &info->ref->u.ar;
4702 :
4703 259422 : if (ar->dimen_type[dim] == DIMEN_VECTOR)
4704 : {
4705 : /* We use a zero-based index to access the vector. */
4706 980 : info->start[dim] = gfc_index_zero_node;
4707 980 : info->end[dim] = NULL;
4708 980 : info->stride[dim] = gfc_index_one_node;
4709 980 : return;
4710 : }
4711 :
4712 258442 : gcc_assert (ar->dimen_type[dim] == DIMEN_RANGE
4713 : || ar->dimen_type[dim] == DIMEN_THIS_IMAGE);
4714 258442 : desc = info->descriptor;
4715 258442 : stride = ar->stride[dim];
4716 258442 : bool save_value = !ss->is_alloc_lhs;
4717 :
4718 : /* Calculate the start of the range. For vector subscripts this will
4719 : be the range of the vector. */
4720 258442 : evaluate_bound (block, info->start, ar->start, desc, dim, true,
4721 258442 : ar->as->type == AS_DEFERRED, save_value);
4722 :
4723 : /* Similarly calculate the end. Although this is not used in the
4724 : scalarizer, it is needed when checking bounds and where the end
4725 : is an expression with side-effects. */
4726 258442 : evaluate_bound (block, info->end, ar->end, desc, dim, false,
4727 258442 : ar->as->type == AS_DEFERRED, save_value);
4728 :
4729 :
4730 : /* Calculate the stride. */
4731 258442 : if (stride == NULL)
4732 245638 : info->stride[dim] = gfc_index_one_node;
4733 : else
4734 : {
4735 12804 : gfc_init_se (&se, NULL);
4736 12804 : gfc_conv_expr_type (&se, stride, gfc_array_index_type);
4737 12804 : gfc_add_block_to_block (block, &se.pre);
4738 12804 : tree value = se.expr;
4739 12804 : if (save_value)
4740 12804 : info->stride[dim] = gfc_evaluate_now (value, block);
4741 : else
4742 0 : info->stride[dim] = value;
4743 : }
4744 : }
4745 :
4746 :
4747 : /* Generate in INNER the bounds checking code along the dimension DIM for
4748 : the array associated with SS_INFO. */
4749 :
4750 : static void
4751 24078 : add_check_section_in_array_bounds (stmtblock_t *inner, gfc_ss_info *ss_info,
4752 : int dim)
4753 : {
4754 24078 : gfc_expr *expr = ss_info->expr;
4755 24078 : locus *expr_loc = &expr->where;
4756 24078 : const char *expr_name = expr->symtree->name;
4757 :
4758 24078 : gfc_array_info *info = &ss_info->data.array;
4759 :
4760 24078 : bool check_upper;
4761 24078 : if (dim == info->ref->u.ar.dimen - 1
4762 20451 : && info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
4763 : check_upper = false;
4764 : else
4765 23782 : check_upper = true;
4766 :
4767 : /* Zero stride is not allowed. */
4768 24078 : tree tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
4769 : info->stride[dim], gfc_index_zero_node);
4770 24078 : char * msg = xasprintf ("Zero stride is not allowed, for dimension %d "
4771 : "of array '%s'", dim + 1, expr_name);
4772 24078 : gfc_trans_runtime_check (true, false, tmp, inner, expr_loc, msg);
4773 24078 : free (msg);
4774 :
4775 24078 : tree desc = info->descriptor;
4776 :
4777 : /* This is the run-time equivalent of resolve.cc's
4778 : check_dimension. The logical is more readable there
4779 : than it is here, with all the trees. */
4780 24078 : tree lbound = gfc_conv_array_lbound (desc, dim);
4781 24078 : tree end = info->end[dim];
4782 24078 : tree ubound = check_upper ? gfc_conv_array_ubound (desc, dim) : NULL_TREE;
4783 :
4784 : /* non_zerosized is true when the selected range is not
4785 : empty. */
4786 24078 : tree stride_pos = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
4787 : info->stride[dim], gfc_index_zero_node);
4788 24078 : tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
4789 : info->start[dim], end);
4790 24078 : stride_pos = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4791 : logical_type_node, stride_pos, tmp);
4792 :
4793 24078 : tree stride_neg = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
4794 : info->stride[dim], gfc_index_zero_node);
4795 24078 : tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
4796 : info->start[dim], end);
4797 24078 : stride_neg = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4798 : logical_type_node, stride_neg, tmp);
4799 24078 : tree non_zerosized = fold_build2_loc (input_location, TRUTH_OR_EXPR,
4800 : logical_type_node, stride_pos,
4801 : stride_neg);
4802 :
4803 : /* Check the start of the range against the lower and upper
4804 : bounds of the array, if the range is not empty.
4805 : If upper bound is present, include both bounds in the
4806 : error message. */
4807 24078 : if (check_upper)
4808 : {
4809 23782 : tmp = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
4810 : info->start[dim], lbound);
4811 23782 : tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
4812 : non_zerosized, tmp);
4813 23782 : tree tmp2 = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
4814 : info->start[dim], ubound);
4815 23782 : tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
4816 : non_zerosized, tmp2);
4817 23782 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' outside of "
4818 : "expected range (%%ld:%%ld)", dim + 1, expr_name);
4819 23782 : gfc_trans_runtime_check (true, false, tmp, inner, expr_loc, msg,
4820 : fold_convert (long_integer_type_node, info->start[dim]),
4821 : fold_convert (long_integer_type_node, lbound),
4822 : fold_convert (long_integer_type_node, ubound));
4823 23782 : gfc_trans_runtime_check (true, false, tmp2, inner, expr_loc, msg,
4824 : fold_convert (long_integer_type_node, info->start[dim]),
4825 : fold_convert (long_integer_type_node, lbound),
4826 : fold_convert (long_integer_type_node, ubound));
4827 23782 : free (msg);
4828 : }
4829 : else
4830 : {
4831 296 : tmp = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
4832 : info->start[dim], lbound);
4833 296 : tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
4834 : non_zerosized, tmp);
4835 296 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' below "
4836 : "lower bound of %%ld", dim + 1, expr_name);
4837 296 : gfc_trans_runtime_check (true, false, tmp, inner, expr_loc, msg,
4838 : fold_convert (long_integer_type_node, info->start[dim]),
4839 : fold_convert (long_integer_type_node, lbound));
4840 296 : free (msg);
4841 : }
4842 :
4843 : /* Compute the last element of the range, which is not
4844 : necessarily "end" (think 0:5:3, which doesn't contain 5)
4845 : and check it against both lower and upper bounds. */
4846 :
4847 24078 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4848 : end, info->start[dim]);
4849 24078 : tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR, gfc_array_index_type,
4850 : tmp, info->stride[dim]);
4851 24078 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4852 : end, tmp);
4853 24078 : tree tmp2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
4854 : tmp, lbound);
4855 24078 : tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
4856 : non_zerosized, tmp2);
4857 24078 : if (check_upper)
4858 : {
4859 23782 : tree tmp3 = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
4860 : tmp, ubound);
4861 23782 : tmp3 = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
4862 : non_zerosized, tmp3);
4863 23782 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' outside of "
4864 : "expected range (%%ld:%%ld)", dim + 1, expr_name);
4865 23782 : gfc_trans_runtime_check (true, false, tmp2, inner, expr_loc, msg,
4866 : fold_convert (long_integer_type_node, tmp),
4867 : fold_convert (long_integer_type_node, ubound),
4868 : fold_convert (long_integer_type_node, lbound));
4869 23782 : gfc_trans_runtime_check (true, false, tmp3, inner, expr_loc, msg,
4870 : fold_convert (long_integer_type_node, tmp),
4871 : fold_convert (long_integer_type_node, ubound),
4872 : fold_convert (long_integer_type_node, lbound));
4873 23782 : free (msg);
4874 : }
4875 : else
4876 : {
4877 296 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' below "
4878 : "lower bound of %%ld", dim + 1, expr_name);
4879 296 : gfc_trans_runtime_check (true, false, tmp2, inner, expr_loc, msg,
4880 : fold_convert (long_integer_type_node, tmp),
4881 : fold_convert (long_integer_type_node, lbound));
4882 296 : free (msg);
4883 : }
4884 24078 : }
4885 :
4886 :
4887 : /* Tells whether we need to generate bounds checking code for the array
4888 : associated with SS. */
4889 :
4890 : bool
4891 25045 : bounds_check_needed (gfc_ss *ss)
4892 : {
4893 : /* Catch allocatable lhs in f2003. */
4894 25045 : if (flag_realloc_lhs && ss->no_bounds_check)
4895 : return false;
4896 :
4897 24768 : gfc_ss_info *ss_info = ss->info;
4898 24768 : if (ss_info->type == GFC_SS_SECTION)
4899 : return true;
4900 :
4901 4126 : if (!(ss_info->type == GFC_SS_INTRINSIC
4902 227 : && ss_info->expr
4903 227 : && ss_info->expr->expr_type == EXPR_FUNCTION))
4904 : return false;
4905 :
4906 227 : gfc_intrinsic_sym *isym = ss_info->expr->value.function.isym;
4907 227 : if (!(isym
4908 227 : && (isym->id == GFC_ISYM_MAXLOC
4909 203 : || isym->id == GFC_ISYM_MINLOC)))
4910 : return false;
4911 :
4912 34 : return gfc_inline_intrinsic_function_p (ss_info->expr);
4913 : }
4914 :
4915 :
4916 : /* Calculates the range start and stride for a SS chain. Also gets the
4917 : descriptor and data pointer. The range of vector subscripts is the size
4918 : of the vector. Array bounds are also checked. */
4919 :
4920 : void
4921 184347 : gfc_conv_ss_startstride (gfc_loopinfo * loop)
4922 : {
4923 184347 : int n;
4924 184347 : tree tmp;
4925 184347 : gfc_ss *ss;
4926 :
4927 184347 : gfc_loopinfo * const outer_loop = outermost_loop (loop);
4928 :
4929 184347 : loop->dimen = 0;
4930 : /* Determine the rank of the loop. */
4931 204655 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4932 : {
4933 204655 : switch (ss->info->type)
4934 : {
4935 173025 : case GFC_SS_SECTION:
4936 173025 : case GFC_SS_CONSTRUCTOR:
4937 173025 : case GFC_SS_FUNCTION:
4938 173025 : case GFC_SS_COMPONENT:
4939 173025 : loop->dimen = ss->dimen;
4940 173025 : goto done;
4941 :
4942 : /* As usual, lbound and ubound are exceptions!. */
4943 11322 : case GFC_SS_INTRINSIC:
4944 11322 : switch (ss->info->expr->value.function.isym->id)
4945 : {
4946 11322 : case GFC_ISYM_LBOUND:
4947 11322 : case GFC_ISYM_UBOUND:
4948 11322 : case GFC_ISYM_COSHAPE:
4949 11322 : case GFC_ISYM_LCOBOUND:
4950 11322 : case GFC_ISYM_UCOBOUND:
4951 11322 : case GFC_ISYM_MAXLOC:
4952 11322 : case GFC_ISYM_MINLOC:
4953 11322 : case GFC_ISYM_SHAPE:
4954 11322 : case GFC_ISYM_THIS_IMAGE:
4955 11322 : loop->dimen = ss->dimen;
4956 11322 : goto done;
4957 :
4958 : default:
4959 : break;
4960 : }
4961 :
4962 20308 : default:
4963 20308 : break;
4964 : }
4965 : }
4966 :
4967 : /* We should have determined the rank of the expression by now. If
4968 : not, that's bad news. */
4969 0 : gcc_unreachable ();
4970 :
4971 : done:
4972 : /* Loop over all the SS in the chain. */
4973 479424 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4974 : {
4975 295077 : gfc_ss_info *ss_info;
4976 295077 : gfc_array_info *info;
4977 295077 : gfc_expr *expr;
4978 :
4979 295077 : ss_info = ss->info;
4980 295077 : expr = ss_info->expr;
4981 295077 : info = &ss_info->data.array;
4982 :
4983 295077 : if (expr && expr->shape && !info->shape)
4984 171249 : info->shape = expr->shape;
4985 :
4986 295077 : switch (ss_info->type)
4987 : {
4988 187142 : case GFC_SS_SECTION:
4989 : /* Get the descriptor for the array. If it is a cross loops array,
4990 : we got the descriptor already in the outermost loop. */
4991 187142 : if (ss->parent == NULL)
4992 182506 : gfc_conv_ss_descriptor (&outer_loop->pre, ss,
4993 182506 : !loop->array_parameter);
4994 :
4995 445746 : for (n = 0; n < ss->dimen; n++)
4996 258604 : gfc_conv_section_startstride (&outer_loop->pre, ss, ss->dim[n]);
4997 : break;
4998 :
4999 11581 : case GFC_SS_INTRINSIC:
5000 11581 : switch (expr->value.function.isym->id)
5001 : {
5002 3281 : case GFC_ISYM_MINLOC:
5003 3281 : case GFC_ISYM_MAXLOC:
5004 3281 : {
5005 3281 : gfc_se se;
5006 3281 : gfc_init_se (&se, nullptr);
5007 3281 : se.loop = loop;
5008 3281 : se.ss = ss;
5009 3281 : gfc_conv_intrinsic_function (&se, expr);
5010 3281 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
5011 3281 : gfc_add_block_to_block (&outer_loop->post, &se.post);
5012 :
5013 3281 : info->descriptor = se.expr;
5014 :
5015 3281 : info->data = gfc_conv_array_data (info->descriptor);
5016 3281 : info->data = gfc_evaluate_now (info->data, &outer_loop->pre);
5017 :
5018 3281 : gfc_expr *array = expr->value.function.actual->expr;
5019 3281 : tree rank = build_int_cst (gfc_array_index_type, array->rank);
5020 :
5021 3281 : tree tmp = fold_build2_loc (input_location, MINUS_EXPR,
5022 : gfc_array_index_type, rank,
5023 : gfc_index_one_node);
5024 :
5025 3281 : info->end[0] = gfc_evaluate_now (tmp, &outer_loop->pre);
5026 3281 : info->start[0] = gfc_index_zero_node;
5027 3281 : info->stride[0] = gfc_index_one_node;
5028 3281 : info->offset = gfc_index_zero_node;
5029 3281 : continue;
5030 3281 : }
5031 :
5032 : /* Fall through to supply start and stride. */
5033 3004 : case GFC_ISYM_LBOUND:
5034 3004 : case GFC_ISYM_UBOUND:
5035 : /* This is the variant without DIM=... */
5036 3004 : gcc_assert (expr->value.function.actual->next->expr == NULL);
5037 : /* Fall through. */
5038 :
5039 7992 : case GFC_ISYM_SHAPE:
5040 7992 : {
5041 7992 : gfc_expr *arg;
5042 :
5043 7992 : arg = expr->value.function.actual->expr;
5044 7992 : if (arg->rank == -1)
5045 : {
5046 1175 : gfc_se se;
5047 1175 : tree rank, tmp;
5048 :
5049 : /* The rank (hence the return value's shape) is unknown,
5050 : we have to retrieve it. */
5051 1175 : gfc_init_se (&se, NULL);
5052 1175 : se.descriptor_only = 1;
5053 1175 : gfc_conv_expr (&se, arg);
5054 : /* This is a bare variable, so there is no preliminary
5055 : or cleanup code unless -std=f202y and bounds checking
5056 : is on. */
5057 1175 : if (!((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
5058 0 : && (gfc_option.allow_std & GFC_STD_F202Y)))
5059 1175 : gcc_assert (se.pre.head == NULL_TREE
5060 : && se.post.head == NULL_TREE);
5061 1175 : rank = gfc_conv_descriptor_rank_get (se.expr);
5062 1175 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
5063 : gfc_array_index_type,
5064 : fold_convert (gfc_array_index_type,
5065 : rank),
5066 : gfc_index_one_node);
5067 1175 : info->end[0] = gfc_evaluate_now (tmp, &outer_loop->pre);
5068 1175 : info->start[0] = gfc_index_zero_node;
5069 1175 : info->stride[0] = gfc_index_one_node;
5070 1175 : continue;
5071 1175 : }
5072 : /* Otherwise fall through GFC_SS_FUNCTION. */
5073 : gcc_fallthrough ();
5074 : }
5075 : case GFC_ISYM_COSHAPE:
5076 : case GFC_ISYM_LCOBOUND:
5077 : case GFC_ISYM_UCOBOUND:
5078 : case GFC_ISYM_THIS_IMAGE:
5079 : break;
5080 :
5081 0 : default:
5082 0 : continue;
5083 0 : }
5084 :
5085 : /* FALLTHRU */
5086 : case GFC_SS_CONSTRUCTOR:
5087 : case GFC_SS_FUNCTION:
5088 130420 : for (n = 0; n < ss->dimen; n++)
5089 : {
5090 70390 : int dim = ss->dim[n];
5091 :
5092 70390 : info->start[dim] = gfc_index_zero_node;
5093 70390 : if (ss_info->type != GFC_SS_FUNCTION)
5094 55933 : info->end[dim] = gfc_index_zero_node;
5095 70390 : info->stride[dim] = gfc_index_one_node;
5096 : }
5097 : break;
5098 :
5099 : default:
5100 : break;
5101 : }
5102 : }
5103 :
5104 : /* The rest is just runtime bounds checking. */
5105 184347 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
5106 : {
5107 16945 : stmtblock_t block;
5108 16945 : tree size[GFC_MAX_DIMENSIONS];
5109 16945 : tree tmp3;
5110 16945 : gfc_array_info *info;
5111 16945 : char *msg;
5112 16945 : int dim;
5113 :
5114 16945 : gfc_start_block (&block);
5115 :
5116 54257 : for (n = 0; n < loop->dimen; n++)
5117 20367 : size[n] = NULL_TREE;
5118 :
5119 : /* If there is a constructor involved, derive size[] from its shape. */
5120 39164 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5121 : {
5122 24699 : gfc_ss_info *ss_info;
5123 :
5124 24699 : ss_info = ss->info;
5125 24699 : info = &ss_info->data.array;
5126 :
5127 24699 : if (ss_info->type == GFC_SS_CONSTRUCTOR && info->shape)
5128 : {
5129 5224 : for (n = 0; n < loop->dimen; n++)
5130 : {
5131 2744 : if (size[n] == NULL)
5132 : {
5133 2744 : gcc_assert (info->shape[n]);
5134 2744 : size[n] = gfc_conv_mpz_to_tree (info->shape[n],
5135 : gfc_index_integer_kind);
5136 : }
5137 : }
5138 : break;
5139 : }
5140 : }
5141 :
5142 41990 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5143 : {
5144 25045 : stmtblock_t inner;
5145 25045 : gfc_ss_info *ss_info;
5146 25045 : gfc_expr *expr;
5147 25045 : locus *expr_loc;
5148 25045 : const char *expr_name;
5149 25045 : char *ref_name = NULL;
5150 :
5151 25045 : if (!bounds_check_needed (ss))
5152 4369 : continue;
5153 :
5154 20676 : ss_info = ss->info;
5155 20676 : expr = ss_info->expr;
5156 20676 : expr_loc = &expr->where;
5157 20676 : if (expr->ref)
5158 20642 : expr_name = ref_name = abridged_ref_name (expr, NULL);
5159 : else
5160 34 : expr_name = expr->symtree->name;
5161 :
5162 20676 : gfc_start_block (&inner);
5163 :
5164 : /* TODO: range checking for mapped dimensions. */
5165 20676 : info = &ss_info->data.array;
5166 :
5167 : /* This code only checks ranges. Elemental and vector
5168 : dimensions are checked later. */
5169 65478 : for (n = 0; n < loop->dimen; n++)
5170 : {
5171 24126 : dim = ss->dim[n];
5172 24126 : if (ss_info->type == GFC_SS_SECTION)
5173 : {
5174 24092 : if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
5175 14 : continue;
5176 :
5177 24078 : add_check_section_in_array_bounds (&inner, ss_info, dim);
5178 : }
5179 :
5180 : /* Check the section sizes match. */
5181 24112 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
5182 : gfc_array_index_type, info->end[dim],
5183 : info->start[dim]);
5184 24112 : tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
5185 : gfc_array_index_type, tmp,
5186 : info->stride[dim]);
5187 24112 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
5188 : gfc_array_index_type,
5189 : gfc_index_one_node, tmp);
5190 24112 : tmp = fold_build2_loc (input_location, MAX_EXPR,
5191 : gfc_array_index_type, tmp,
5192 : build_int_cst (gfc_array_index_type, 0));
5193 : /* We remember the size of the first section, and check all the
5194 : others against this. */
5195 24112 : if (size[n])
5196 : {
5197 7193 : tmp3 = fold_build2_loc (input_location, NE_EXPR,
5198 : logical_type_node, tmp, size[n]);
5199 7193 : if (ss_info->type == GFC_SS_INTRINSIC)
5200 0 : msg = xasprintf ("Extent mismatch for dimension %d of the "
5201 : "result of intrinsic '%s' (%%ld/%%ld)",
5202 : dim + 1, expr_name);
5203 : else
5204 7193 : msg = xasprintf ("Array bound mismatch for dimension %d "
5205 : "of array '%s' (%%ld/%%ld)",
5206 : dim + 1, expr_name);
5207 :
5208 7193 : gfc_trans_runtime_check (true, false, tmp3, &inner,
5209 : expr_loc, msg,
5210 : fold_convert (long_integer_type_node, tmp),
5211 : fold_convert (long_integer_type_node, size[n]));
5212 :
5213 7193 : free (msg);
5214 : }
5215 : else
5216 16919 : size[n] = gfc_evaluate_now (tmp, &inner);
5217 : }
5218 :
5219 20676 : tmp = gfc_finish_block (&inner);
5220 :
5221 : /* For optional arguments, only check bounds if the argument is
5222 : present. */
5223 20676 : if ((expr->symtree->n.sym->attr.optional
5224 20368 : || expr->symtree->n.sym->attr.not_always_present)
5225 308 : && expr->symtree->n.sym->attr.dummy)
5226 307 : tmp = build3_v (COND_EXPR,
5227 : gfc_conv_expr_present (expr->symtree->n.sym),
5228 : tmp, build_empty_stmt (input_location));
5229 :
5230 20676 : gfc_add_expr_to_block (&block, tmp);
5231 :
5232 20676 : free (ref_name);
5233 : }
5234 :
5235 16945 : tmp = gfc_finish_block (&block);
5236 16945 : gfc_add_expr_to_block (&outer_loop->pre, tmp);
5237 : }
5238 :
5239 187711 : for (loop = loop->nested; loop; loop = loop->next)
5240 3364 : gfc_conv_ss_startstride (loop);
5241 184347 : }
5242 :
5243 : /* Return true if both symbols could refer to the same data object. Does
5244 : not take account of aliasing due to equivalence statements. */
5245 :
5246 : static bool
5247 13828 : symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym, bool lsym_pointer,
5248 : bool lsym_target, bool rsym_pointer, bool rsym_target)
5249 : {
5250 : /* Aliasing isn't possible if the symbols have different base types,
5251 : except for complex types where an inquiry reference (%RE, %IM) could
5252 : alias with a real type with the same kind parameter. */
5253 13828 : if (!gfc_compare_types (&lsym->ts, &rsym->ts)
5254 13828 : && !(((lsym->ts.type == BT_COMPLEX && rsym->ts.type == BT_REAL)
5255 4929 : || (lsym->ts.type == BT_REAL && rsym->ts.type == BT_COMPLEX))
5256 76 : && lsym->ts.kind == rsym->ts.kind))
5257 : return false;
5258 :
5259 : /* Pointers can point to other pointers and target objects. */
5260 :
5261 8912 : if ((lsym_pointer && (rsym_pointer || rsym_target))
5262 8703 : || (rsym_pointer && (lsym_pointer || lsym_target)))
5263 : return true;
5264 :
5265 : /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
5266 : and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
5267 : checked above. */
5268 8789 : if (lsym_target && rsym_target
5269 14 : && ((lsym->attr.dummy && !lsym->attr.contiguous
5270 0 : && (!lsym->attr.dimension || lsym->as->type == AS_ASSUMED_SHAPE))
5271 14 : || (rsym->attr.dummy && !rsym->attr.contiguous
5272 6 : && (!rsym->attr.dimension
5273 6 : || rsym->as->type == AS_ASSUMED_SHAPE))))
5274 6 : return true;
5275 :
5276 : return false;
5277 : }
5278 :
5279 :
5280 : /* Return true if the two SS could be aliased, i.e. both point to the same data
5281 : object. */
5282 : /* TODO: resolve aliases based on frontend expressions. */
5283 :
5284 : static int
5285 11638 : gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
5286 : {
5287 11638 : gfc_ref *lref;
5288 11638 : gfc_ref *rref;
5289 11638 : gfc_expr *lexpr, *rexpr;
5290 11638 : gfc_symbol *lsym;
5291 11638 : gfc_symbol *rsym;
5292 11638 : bool lsym_pointer, lsym_target, rsym_pointer, rsym_target;
5293 :
5294 11638 : lexpr = lss->info->expr;
5295 11638 : rexpr = rss->info->expr;
5296 :
5297 11638 : lsym = lexpr->symtree->n.sym;
5298 11638 : rsym = rexpr->symtree->n.sym;
5299 :
5300 11638 : lsym_pointer = lsym->attr.pointer;
5301 11638 : lsym_target = lsym->attr.target;
5302 11638 : rsym_pointer = rsym->attr.pointer;
5303 11638 : rsym_target = rsym->attr.target;
5304 :
5305 11638 : if (symbols_could_alias (lsym, rsym, lsym_pointer, lsym_target,
5306 : rsym_pointer, rsym_target))
5307 : return 1;
5308 :
5309 11547 : if (rsym->ts.type != BT_DERIVED && rsym->ts.type != BT_CLASS
5310 10160 : && lsym->ts.type != BT_DERIVED && lsym->ts.type != BT_CLASS)
5311 : return 0;
5312 :
5313 : /* For derived types we must check all the component types. We can ignore
5314 : array references as these will have the same base type as the previous
5315 : component ref. */
5316 2830 : for (lref = lexpr->ref; lref != lss->info->data.array.ref; lref = lref->next)
5317 : {
5318 1019 : if (lref->type != REF_COMPONENT)
5319 107 : continue;
5320 :
5321 912 : lsym_pointer = lsym_pointer || lref->u.c.sym->attr.pointer;
5322 912 : lsym_target = lsym_target || lref->u.c.sym->attr.target;
5323 :
5324 912 : if (symbols_could_alias (lref->u.c.sym, rsym, lsym_pointer, lsym_target,
5325 : rsym_pointer, rsym_target))
5326 : return 1;
5327 :
5328 912 : if ((lsym_pointer && (rsym_pointer || rsym_target))
5329 897 : || (rsym_pointer && (lsym_pointer || lsym_target)))
5330 : {
5331 6 : if (gfc_compare_types (&lref->u.c.component->ts,
5332 : &rsym->ts))
5333 : return 1;
5334 : }
5335 :
5336 1366 : for (rref = rexpr->ref; rref != rss->info->data.array.ref;
5337 460 : rref = rref->next)
5338 : {
5339 461 : if (rref->type != REF_COMPONENT)
5340 36 : continue;
5341 :
5342 425 : rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
5343 425 : rsym_target = lsym_target || rref->u.c.sym->attr.target;
5344 :
5345 425 : if (symbols_could_alias (lref->u.c.sym, rref->u.c.sym,
5346 : lsym_pointer, lsym_target,
5347 : rsym_pointer, rsym_target))
5348 : return 1;
5349 :
5350 424 : if ((lsym_pointer && (rsym_pointer || rsym_target))
5351 420 : || (rsym_pointer && (lsym_pointer || lsym_target)))
5352 : {
5353 0 : if (gfc_compare_types (&lref->u.c.component->ts,
5354 0 : &rref->u.c.sym->ts))
5355 : return 1;
5356 0 : if (gfc_compare_types (&lref->u.c.sym->ts,
5357 0 : &rref->u.c.component->ts))
5358 : return 1;
5359 0 : if (gfc_compare_types (&lref->u.c.component->ts,
5360 0 : &rref->u.c.component->ts))
5361 : return 1;
5362 : }
5363 : }
5364 : }
5365 :
5366 1811 : lsym_pointer = lsym->attr.pointer;
5367 1811 : lsym_target = lsym->attr.target;
5368 :
5369 2658 : for (rref = rexpr->ref; rref != rss->info->data.array.ref; rref = rref->next)
5370 : {
5371 1000 : if (rref->type != REF_COMPONENT)
5372 : break;
5373 :
5374 853 : rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
5375 853 : rsym_target = lsym_target || rref->u.c.sym->attr.target;
5376 :
5377 853 : if (symbols_could_alias (rref->u.c.sym, lsym,
5378 : lsym_pointer, lsym_target,
5379 : rsym_pointer, rsym_target))
5380 : return 1;
5381 :
5382 853 : if ((lsym_pointer && (rsym_pointer || rsym_target))
5383 835 : || (rsym_pointer && (lsym_pointer || lsym_target)))
5384 : {
5385 6 : if (gfc_compare_types (&lsym->ts, &rref->u.c.component->ts))
5386 : return 1;
5387 : }
5388 : }
5389 :
5390 : return 0;
5391 : }
5392 :
5393 :
5394 : /* Resolve array data dependencies. Creates a temporary if required. */
5395 : /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
5396 : dependency.cc. */
5397 :
5398 : void
5399 38439 : gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
5400 : gfc_ss * rss)
5401 : {
5402 38439 : gfc_ss *ss;
5403 38439 : gfc_ref *lref;
5404 38439 : gfc_ref *rref;
5405 38439 : gfc_ss_info *ss_info;
5406 38439 : gfc_expr *dest_expr;
5407 38439 : gfc_expr *ss_expr;
5408 38439 : int nDepend = 0;
5409 38439 : int i, j;
5410 :
5411 38439 : loop->temp_ss = NULL;
5412 38439 : dest_expr = dest->info->expr;
5413 :
5414 82774 : for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
5415 : {
5416 45528 : ss_info = ss->info;
5417 45528 : ss_expr = ss_info->expr;
5418 :
5419 45528 : if (ss_info->array_outer_dependency)
5420 : {
5421 : nDepend = 1;
5422 : break;
5423 : }
5424 :
5425 45411 : if (ss_info->type != GFC_SS_SECTION)
5426 : {
5427 30990 : if (flag_realloc_lhs
5428 29938 : && dest_expr != ss_expr
5429 29938 : && gfc_is_reallocatable_lhs (dest_expr)
5430 38142 : && ss_expr->rank)
5431 3440 : nDepend = gfc_check_dependency (dest_expr, ss_expr, true);
5432 :
5433 : /* Check for cases like c(:)(1:2) = c(2)(2:3) */
5434 30990 : if (!nDepend && dest_expr->rank > 0
5435 30460 : && dest_expr->ts.type == BT_CHARACTER
5436 4778 : && ss_expr->expr_type == EXPR_VARIABLE)
5437 :
5438 165 : nDepend = gfc_check_dependency (dest_expr, ss_expr, false);
5439 :
5440 30990 : if (ss_info->type == GFC_SS_REFERENCE
5441 30990 : && gfc_check_dependency (dest_expr, ss_expr, false))
5442 188 : ss_info->data.scalar.needs_temporary = 1;
5443 :
5444 30990 : if (nDepend)
5445 : break;
5446 : else
5447 30448 : continue;
5448 : }
5449 :
5450 14421 : if (dest_expr->symtree->n.sym != ss_expr->symtree->n.sym)
5451 : {
5452 11638 : if (gfc_could_be_alias (dest, ss)
5453 11638 : || gfc_are_equivalenced_arrays (dest_expr, ss_expr))
5454 : {
5455 : nDepend = 1;
5456 : break;
5457 : }
5458 : }
5459 : else
5460 : {
5461 2783 : lref = dest_expr->ref;
5462 2783 : rref = ss_expr->ref;
5463 :
5464 2783 : nDepend = gfc_dep_resolver (lref, rref, &loop->reverse[0]);
5465 :
5466 2783 : if (nDepend == 1)
5467 : break;
5468 :
5469 5554 : for (i = 0; i < dest->dimen; i++)
5470 7546 : for (j = 0; j < ss->dimen; j++)
5471 4486 : if (i != j
5472 1363 : && dest->dim[i] == ss->dim[j])
5473 : {
5474 : /* If we don't access array elements in the same order,
5475 : there is a dependency. */
5476 63 : nDepend = 1;
5477 63 : goto temporary;
5478 : }
5479 : #if 0
5480 : /* TODO : loop shifting. */
5481 : if (nDepend == 1)
5482 : {
5483 : /* Mark the dimensions for LOOP SHIFTING */
5484 : for (n = 0; n < loop->dimen; n++)
5485 : {
5486 : int dim = dest->data.info.dim[n];
5487 :
5488 : if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
5489 : depends[n] = 2;
5490 : else if (! gfc_is_same_range (&lref->u.ar,
5491 : &rref->u.ar, dim, 0))
5492 : depends[n] = 1;
5493 : }
5494 :
5495 : /* Put all the dimensions with dependencies in the
5496 : innermost loops. */
5497 : dim = 0;
5498 : for (n = 0; n < loop->dimen; n++)
5499 : {
5500 : gcc_assert (loop->order[n] == n);
5501 : if (depends[n])
5502 : loop->order[dim++] = n;
5503 : }
5504 : for (n = 0; n < loop->dimen; n++)
5505 : {
5506 : if (! depends[n])
5507 : loop->order[dim++] = n;
5508 : }
5509 :
5510 : gcc_assert (dim == loop->dimen);
5511 : break;
5512 : }
5513 : #endif
5514 : }
5515 : }
5516 :
5517 831 : temporary:
5518 :
5519 38439 : if (nDepend == 1)
5520 : {
5521 1193 : tree base_type = gfc_typenode_for_spec (&dest_expr->ts);
5522 1193 : if (GFC_ARRAY_TYPE_P (base_type)
5523 1193 : || GFC_DESCRIPTOR_TYPE_P (base_type))
5524 0 : base_type = gfc_get_element_type (base_type);
5525 1193 : loop->temp_ss = gfc_get_temp_ss (base_type, dest->info->string_length,
5526 : loop->dimen);
5527 1193 : gfc_add_ss_to_loop (loop, loop->temp_ss);
5528 : }
5529 : else
5530 37246 : loop->temp_ss = NULL;
5531 38439 : }
5532 :
5533 :
5534 : /* Browse through each array's information from the scalarizer and set the loop
5535 : bounds according to the "best" one (per dimension), i.e. the one which
5536 : provides the most information (constant bounds, shape, etc.). */
5537 :
5538 : static void
5539 184347 : set_loop_bounds (gfc_loopinfo *loop)
5540 : {
5541 184347 : int n, dim, spec_dim;
5542 184347 : gfc_array_info *info;
5543 184347 : gfc_array_info *specinfo;
5544 184347 : gfc_ss *ss;
5545 184347 : tree tmp;
5546 184347 : gfc_ss **loopspec;
5547 184347 : bool dynamic[GFC_MAX_DIMENSIONS];
5548 184347 : mpz_t *cshape;
5549 184347 : mpz_t i;
5550 184347 : bool nonoptional_arr;
5551 :
5552 184347 : gfc_loopinfo * const outer_loop = outermost_loop (loop);
5553 :
5554 184347 : loopspec = loop->specloop;
5555 :
5556 184347 : mpz_init (i);
5557 434353 : for (n = 0; n < loop->dimen; n++)
5558 : {
5559 250006 : loopspec[n] = NULL;
5560 250006 : dynamic[n] = false;
5561 :
5562 : /* If there are both optional and nonoptional array arguments, scalarize
5563 : over the nonoptional; otherwise, it does not matter as then all
5564 : (optional) arrays have to be present per F2008, 125.2.12p3(6). */
5565 :
5566 250006 : nonoptional_arr = false;
5567 :
5568 291486 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5569 291466 : if (ss->info->type != GFC_SS_SCALAR && ss->info->type != GFC_SS_TEMP
5570 256577 : && ss->info->type != GFC_SS_REFERENCE && !ss->info->can_be_null_ref)
5571 : {
5572 : nonoptional_arr = true;
5573 : break;
5574 : }
5575 :
5576 : /* We use one SS term, and use that to determine the bounds of the
5577 : loop for this dimension. We try to pick the simplest term. */
5578 654626 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5579 : {
5580 404620 : gfc_ss_type ss_type;
5581 :
5582 404620 : ss_type = ss->info->type;
5583 474973 : if (ss_type == GFC_SS_SCALAR
5584 404620 : || ss_type == GFC_SS_TEMP
5585 343537 : || ss_type == GFC_SS_REFERENCE
5586 334544 : || (ss->info->can_be_null_ref && nonoptional_arr))
5587 70353 : continue;
5588 :
5589 334267 : info = &ss->info->data.array;
5590 334267 : dim = ss->dim[n];
5591 :
5592 334267 : if (loopspec[n] != NULL)
5593 : {
5594 84261 : specinfo = &loopspec[n]->info->data.array;
5595 84261 : spec_dim = loopspec[n]->dim[n];
5596 : }
5597 : else
5598 : {
5599 : /* Silence uninitialized warnings. */
5600 : specinfo = NULL;
5601 : spec_dim = 0;
5602 : }
5603 :
5604 334267 : if (info->shape)
5605 : {
5606 : /* The frontend has worked out the size for us. */
5607 226047 : if (!loopspec[n]
5608 59564 : || !specinfo->shape
5609 272866 : || !integer_zerop (specinfo->start[spec_dim]))
5610 : /* Prefer zero-based descriptors if possible. */
5611 209032 : loopspec[n] = ss;
5612 226047 : continue;
5613 : }
5614 :
5615 108220 : if (ss_type == GFC_SS_CONSTRUCTOR)
5616 : {
5617 1452 : gfc_constructor_base base;
5618 : /* An unknown size constructor will always be rank one.
5619 : Higher rank constructors will either have known shape,
5620 : or still be wrapped in a call to reshape. */
5621 1452 : gcc_assert (loop->dimen == 1);
5622 :
5623 : /* Always prefer to use the constructor bounds if the size
5624 : can be determined at compile time. Prefer not to otherwise,
5625 : since the general case involves realloc, and it's better to
5626 : avoid that overhead if possible. */
5627 1452 : base = ss->info->expr->value.constructor;
5628 1452 : dynamic[n] = gfc_get_array_constructor_size (&i, base);
5629 1452 : if (!dynamic[n] || !loopspec[n])
5630 1229 : loopspec[n] = ss;
5631 1452 : continue;
5632 1452 : }
5633 :
5634 : /* Avoid using an allocatable lhs in an assignment, since
5635 : there might be a reallocation coming. */
5636 106768 : if (loopspec[n] && ss->is_alloc_lhs)
5637 9559 : continue;
5638 :
5639 97209 : if (!loopspec[n])
5640 82294 : loopspec[n] = ss;
5641 : /* Criteria for choosing a loop specifier (most important first):
5642 : doesn't need realloc
5643 : stride of one
5644 : known stride
5645 : known lower bound
5646 : known upper bound
5647 : */
5648 14915 : else if (loopspec[n]->info->type == GFC_SS_CONSTRUCTOR && dynamic[n])
5649 235 : loopspec[n] = ss;
5650 14680 : else if (integer_onep (info->stride[dim])
5651 14680 : && !integer_onep (specinfo->stride[spec_dim]))
5652 120 : loopspec[n] = ss;
5653 14560 : else if (INTEGER_CST_P (info->stride[dim])
5654 14336 : && !INTEGER_CST_P (specinfo->stride[spec_dim]))
5655 0 : loopspec[n] = ss;
5656 14560 : else if (INTEGER_CST_P (info->start[dim])
5657 4475 : && !INTEGER_CST_P (specinfo->start[spec_dim])
5658 856 : && integer_onep (info->stride[dim])
5659 428 : == integer_onep (specinfo->stride[spec_dim])
5660 14560 : && INTEGER_CST_P (info->stride[dim])
5661 401 : == INTEGER_CST_P (specinfo->stride[spec_dim]))
5662 401 : loopspec[n] = ss;
5663 : /* We don't work out the upper bound.
5664 : else if (INTEGER_CST_P (info->finish[n])
5665 : && ! INTEGER_CST_P (specinfo->finish[n]))
5666 : loopspec[n] = ss; */
5667 : }
5668 :
5669 : /* We should have found the scalarization loop specifier. If not,
5670 : that's bad news. */
5671 250006 : gcc_assert (loopspec[n]);
5672 :
5673 250006 : info = &loopspec[n]->info->data.array;
5674 250006 : dim = loopspec[n]->dim[n];
5675 :
5676 : /* Set the extents of this range. */
5677 250006 : cshape = info->shape;
5678 250006 : if (cshape && INTEGER_CST_P (info->start[dim])
5679 179029 : && INTEGER_CST_P (info->stride[dim]))
5680 : {
5681 179029 : loop->from[n] = info->start[dim];
5682 179029 : mpz_set (i, cshape[get_array_ref_dim_for_loop_dim (loopspec[n], n)]);
5683 179029 : mpz_sub_ui (i, i, 1);
5684 : /* To = from + (size - 1) * stride. */
5685 179029 : tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
5686 179029 : if (!integer_onep (info->stride[dim]))
5687 8737 : tmp = fold_build2_loc (input_location, MULT_EXPR,
5688 : gfc_array_index_type, tmp,
5689 : info->stride[dim]);
5690 179029 : loop->to[n] = fold_build2_loc (input_location, PLUS_EXPR,
5691 : gfc_array_index_type,
5692 : loop->from[n], tmp);
5693 : }
5694 : else
5695 : {
5696 70977 : loop->from[n] = info->start[dim];
5697 70977 : switch (loopspec[n]->info->type)
5698 : {
5699 893 : case GFC_SS_CONSTRUCTOR:
5700 : /* The upper bound is calculated when we expand the
5701 : constructor. */
5702 893 : gcc_assert (loop->to[n] == NULL_TREE);
5703 : break;
5704 :
5705 64434 : case GFC_SS_SECTION:
5706 : /* Use the end expression if it exists and is not constant,
5707 : so that it is only evaluated once. */
5708 64434 : loop->to[n] = info->end[dim];
5709 64434 : break;
5710 :
5711 4871 : case GFC_SS_FUNCTION:
5712 : /* The loop bound will be set when we generate the call. */
5713 4871 : gcc_assert (loop->to[n] == NULL_TREE);
5714 : break;
5715 :
5716 767 : case GFC_SS_INTRINSIC:
5717 767 : {
5718 767 : gfc_expr *expr = loopspec[n]->info->expr;
5719 :
5720 : /* The {l,u}bound of an assumed rank. */
5721 767 : if (expr->value.function.isym->id == GFC_ISYM_SHAPE)
5722 255 : gcc_assert (expr->value.function.actual->expr->rank == -1);
5723 : else
5724 512 : gcc_assert ((expr->value.function.isym->id == GFC_ISYM_LBOUND
5725 : || expr->value.function.isym->id == GFC_ISYM_UBOUND)
5726 : && expr->value.function.actual->next->expr == NULL
5727 : && expr->value.function.actual->expr->rank == -1);
5728 :
5729 767 : loop->to[n] = info->end[dim];
5730 767 : break;
5731 : }
5732 :
5733 12 : case GFC_SS_COMPONENT:
5734 12 : {
5735 12 : if (info->end[dim] != NULL_TREE)
5736 : {
5737 12 : loop->to[n] = info->end[dim];
5738 12 : break;
5739 : }
5740 : else
5741 0 : gcc_unreachable ();
5742 : }
5743 :
5744 0 : default:
5745 0 : gcc_unreachable ();
5746 : }
5747 : }
5748 :
5749 : /* Transform everything so we have a simple incrementing variable. */
5750 250006 : if (integer_onep (info->stride[dim]))
5751 239148 : info->delta[dim] = gfc_index_zero_node;
5752 : else
5753 : {
5754 : /* Set the delta for this section. */
5755 10858 : info->delta[dim] = gfc_evaluate_now (loop->from[n], &outer_loop->pre);
5756 : /* Number of iterations is (end - start + step) / step.
5757 : with start = 0, this simplifies to
5758 : last = end / step;
5759 : for (i = 0; i<=last; i++){...}; */
5760 10858 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
5761 : gfc_array_index_type, loop->to[n],
5762 : loop->from[n]);
5763 10858 : tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
5764 : gfc_array_index_type, tmp, info->stride[dim]);
5765 10858 : tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
5766 : tmp, build_int_cst (gfc_array_index_type, -1));
5767 10858 : loop->to[n] = gfc_evaluate_now (tmp, &outer_loop->pre);
5768 : /* Make the loop variable start at 0. */
5769 10858 : loop->from[n] = gfc_index_zero_node;
5770 : }
5771 : }
5772 184347 : mpz_clear (i);
5773 :
5774 187711 : for (loop = loop->nested; loop; loop = loop->next)
5775 3364 : set_loop_bounds (loop);
5776 184347 : }
5777 :
5778 :
5779 : /* Last attempt to set the loop bounds, in case they depend on an allocatable
5780 : function result. */
5781 :
5782 : static void
5783 184347 : late_set_loop_bounds (gfc_loopinfo *loop)
5784 : {
5785 184347 : int n, dim;
5786 184347 : gfc_array_info *info;
5787 184347 : gfc_ss **loopspec;
5788 :
5789 184347 : loopspec = loop->specloop;
5790 :
5791 434353 : for (n = 0; n < loop->dimen; n++)
5792 : {
5793 : /* Set the extents of this range. */
5794 250006 : if (loop->from[n] == NULL_TREE
5795 250006 : || loop->to[n] == NULL_TREE)
5796 : {
5797 : /* We should have found the scalarization loop specifier. If not,
5798 : that's bad news. */
5799 455 : gcc_assert (loopspec[n]);
5800 :
5801 455 : info = &loopspec[n]->info->data.array;
5802 455 : dim = loopspec[n]->dim[n];
5803 :
5804 455 : if (loopspec[n]->info->type == GFC_SS_FUNCTION
5805 455 : && info->start[dim]
5806 455 : && info->end[dim])
5807 : {
5808 153 : loop->from[n] = info->start[dim];
5809 153 : loop->to[n] = info->end[dim];
5810 : }
5811 : }
5812 : }
5813 :
5814 187711 : for (loop = loop->nested; loop; loop = loop->next)
5815 3364 : late_set_loop_bounds (loop);
5816 184347 : }
5817 :
5818 :
5819 : /* Initialize the scalarization loop. Creates the loop variables. Determines
5820 : the range of the loop variables. Creates a temporary if required.
5821 : Also generates code for scalar expressions which have been
5822 : moved outside the loop. */
5823 :
5824 : void
5825 180983 : gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
5826 : {
5827 180983 : gfc_ss *tmp_ss;
5828 180983 : tree tmp;
5829 :
5830 180983 : set_loop_bounds (loop);
5831 :
5832 : /* Add all the scalar code that can be taken out of the loops.
5833 : This may include calculating the loop bounds, so do it before
5834 : allocating the temporary. */
5835 180983 : gfc_add_loop_ss_code (loop, loop->ss, false, where);
5836 :
5837 180983 : late_set_loop_bounds (loop);
5838 :
5839 180983 : tmp_ss = loop->temp_ss;
5840 : /* If we want a temporary then create it. */
5841 180983 : if (tmp_ss != NULL)
5842 : {
5843 11384 : gfc_ss_info *tmp_ss_info;
5844 :
5845 11384 : tmp_ss_info = tmp_ss->info;
5846 11384 : gcc_assert (tmp_ss_info->type == GFC_SS_TEMP);
5847 11384 : gcc_assert (loop->parent == NULL);
5848 :
5849 : /* Make absolutely sure that this is a complete type. */
5850 11384 : if (tmp_ss_info->string_length)
5851 2772 : tmp_ss_info->data.temp.type
5852 2772 : = gfc_get_character_type_len_for_eltype
5853 2772 : (TREE_TYPE (tmp_ss_info->data.temp.type),
5854 : tmp_ss_info->string_length);
5855 :
5856 11384 : tmp = tmp_ss_info->data.temp.type;
5857 11384 : memset (&tmp_ss_info->data.array, 0, sizeof (gfc_array_info));
5858 11384 : tmp_ss_info->type = GFC_SS_SECTION;
5859 :
5860 11384 : gcc_assert (tmp_ss->dimen != 0);
5861 :
5862 11384 : gfc_trans_create_temp_array (&loop->pre, &loop->post, tmp_ss, tmp,
5863 : NULL_TREE, false, true, false, where);
5864 : }
5865 :
5866 : /* For array parameters we don't have loop variables, so don't calculate the
5867 : translations. */
5868 180983 : if (!loop->array_parameter)
5869 113362 : gfc_set_delta (loop);
5870 180983 : }
5871 :
5872 :
5873 : /* Calculates how to transform from loop variables to array indices for each
5874 : array: once loop bounds are chosen, sets the difference (DELTA field) between
5875 : loop bounds and array reference bounds, for each array info. */
5876 :
5877 : void
5878 117193 : gfc_set_delta (gfc_loopinfo *loop)
5879 : {
5880 117193 : gfc_ss *ss, **loopspec;
5881 117193 : gfc_array_info *info;
5882 117193 : tree tmp;
5883 117193 : int n, dim;
5884 :
5885 117193 : gfc_loopinfo * const outer_loop = outermost_loop (loop);
5886 :
5887 117193 : loopspec = loop->specloop;
5888 :
5889 : /* Calculate the translation from loop variables to array indices. */
5890 355341 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5891 : {
5892 238148 : gfc_ss_type ss_type;
5893 :
5894 238148 : ss_type = ss->info->type;
5895 61277 : if (!(ss_type == GFC_SS_SECTION
5896 238148 : || ss_type == GFC_SS_COMPONENT
5897 97094 : || ss_type == GFC_SS_CONSTRUCTOR
5898 : || (ss_type == GFC_SS_FUNCTION
5899 8268 : && gfc_is_class_array_function (ss->info->expr))))
5900 61125 : continue;
5901 :
5902 177023 : info = &ss->info->data.array;
5903 :
5904 398251 : for (n = 0; n < ss->dimen; n++)
5905 : {
5906 : /* If we are specifying the range the delta is already set. */
5907 221228 : if (loopspec[n] != ss)
5908 : {
5909 115212 : dim = ss->dim[n];
5910 :
5911 : /* Calculate the offset relative to the loop variable.
5912 : First multiply by the stride. */
5913 115212 : tmp = loop->from[n];
5914 115212 : if (!integer_onep (info->stride[dim]))
5915 3108 : tmp = fold_build2_loc (input_location, MULT_EXPR,
5916 : gfc_array_index_type,
5917 : tmp, info->stride[dim]);
5918 :
5919 : /* Then subtract this from our starting value. */
5920 115212 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
5921 : gfc_array_index_type,
5922 : info->start[dim], tmp);
5923 :
5924 115212 : if (ss->is_alloc_lhs)
5925 9559 : info->delta[dim] = tmp;
5926 : else
5927 105653 : info->delta[dim] = gfc_evaluate_now (tmp, &outer_loop->pre);
5928 : }
5929 : }
5930 : }
5931 :
5932 120645 : for (loop = loop->nested; loop; loop = loop->next)
5933 3452 : gfc_set_delta (loop);
5934 117193 : }
5935 :
5936 :
5937 : /* Calculate the size of a given array dimension from the bounds. This
5938 : is simply (ubound - lbound + 1) if this expression is positive
5939 : or 0 if it is negative (pick either one if it is zero). Optionally
5940 : (if or_expr is present) OR the (expression != 0) condition to it. */
5941 :
5942 : tree
5943 23216 : gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr)
5944 : {
5945 23216 : tree res;
5946 23216 : tree cond;
5947 :
5948 : /* Calculate (ubound - lbound + 1). */
5949 23216 : res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5950 : ubound, lbound);
5951 23216 : res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res,
5952 : gfc_index_one_node);
5953 :
5954 : /* Check whether the size for this dimension is negative. */
5955 23216 : cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, res,
5956 : gfc_index_zero_node);
5957 23216 : res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
5958 : gfc_index_zero_node, res);
5959 :
5960 : /* Build OR expression. */
5961 23216 : if (or_expr)
5962 17844 : *or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
5963 : logical_type_node, *or_expr, cond);
5964 :
5965 23216 : return res;
5966 : }
5967 :
5968 :
5969 : /* Fills in an array descriptor, and returns the size of the array.
5970 : The size will be a simple_val, ie a variable or a constant. Also
5971 : calculates the offset of the base. The pointer argument overflow,
5972 : which should be of integer type, will increase in value if overflow
5973 : occurs during the size calculation. Returns the size of the array.
5974 : {
5975 : stride = 1;
5976 : offset = 0;
5977 : for (n = 0; n < rank; n++)
5978 : {
5979 : a.lbound[n] = specified_lower_bound;
5980 : offset = offset + a.lbond[n] * stride;
5981 : size = 1 - lbound;
5982 : a.ubound[n] = specified_upper_bound;
5983 : a.stride[n] = stride;
5984 : size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
5985 : overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
5986 : stride = stride * size;
5987 : }
5988 : for (n = rank; n < rank+corank; n++)
5989 : (Set lcobound/ucobound as above.)
5990 : element_size = sizeof (array element);
5991 : if (!rank)
5992 : return element_size
5993 : stride = (size_t) stride;
5994 : overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
5995 : stride = stride * element_size;
5996 : return (stride);
5997 : } */
5998 : /*GCC ARRAYS*/
5999 :
6000 : static tree
6001 12226 : gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
6002 : gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
6003 : stmtblock_t * descriptor_block, tree * overflow,
6004 : tree expr3_elem_size, gfc_expr *expr3, tree expr3_desc,
6005 : bool e3_has_nodescriptor, gfc_expr *expr,
6006 : tree *element_size, bool explicit_ts)
6007 : {
6008 12226 : tree type;
6009 12226 : tree tmp;
6010 12226 : tree size;
6011 12226 : tree offset;
6012 12226 : tree stride;
6013 12226 : tree or_expr;
6014 12226 : tree thencase;
6015 12226 : tree elsecase;
6016 12226 : tree cond;
6017 12226 : tree var;
6018 12226 : stmtblock_t thenblock;
6019 12226 : stmtblock_t elseblock;
6020 12226 : gfc_expr *ubound;
6021 12226 : gfc_se se;
6022 12226 : int n;
6023 :
6024 12226 : type = TREE_TYPE (descriptor);
6025 :
6026 12226 : stride = gfc_index_one_node;
6027 12226 : offset = gfc_index_zero_node;
6028 :
6029 : /* Set the dtype before the alloc, because registration of coarrays needs
6030 : it initialized. */
6031 12226 : if (expr->ts.type == BT_CHARACTER
6032 1079 : && expr->ts.deferred
6033 545 : && VAR_P (expr->ts.u.cl->backend_decl))
6034 : {
6035 366 : type = gfc_typenode_for_spec (&expr->ts);
6036 366 : gfc_conv_descriptor_dtype_set (pblock, descriptor,
6037 : gfc_get_dtype_rank_type (rank, type));
6038 : }
6039 11860 : else if (expr->ts.type == BT_CHARACTER
6040 713 : && expr->ts.deferred
6041 179 : && TREE_CODE (descriptor) == COMPONENT_REF)
6042 : {
6043 : /* Deferred character components have their string length tucked away
6044 : in a hidden field of the derived type. Obtain that and use it to
6045 : set the dtype. The charlen backend decl is zero because the field
6046 : type is zero length. */
6047 161 : gfc_ref *ref;
6048 161 : tmp = NULL_TREE;
6049 161 : for (ref = expr->ref; ref; ref = ref->next)
6050 161 : if (ref->type == REF_COMPONENT
6051 161 : && gfc_deferred_strlen (ref->u.c.component, &tmp))
6052 : break;
6053 161 : gcc_assert (tmp != NULL_TREE);
6054 161 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
6055 161 : TREE_OPERAND (descriptor, 0), tmp, NULL_TREE);
6056 161 : tmp = fold_convert (gfc_charlen_type_node, tmp);
6057 161 : type = gfc_get_character_type_len (expr->ts.kind, tmp);
6058 161 : gfc_conv_descriptor_dtype_set (pblock, descriptor,
6059 : gfc_get_dtype_rank_type (rank, type));
6060 161 : }
6061 11699 : else if (expr3_desc && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr3_desc)))
6062 934 : gfc_conv_descriptor_dtype_set (pblock, descriptor,
6063 : gfc_conv_descriptor_dtype_get (expr3_desc));
6064 10765 : else if (expr->ts.type == BT_CLASS && !explicit_ts
6065 1306 : && expr3 && expr3->ts.type != BT_CLASS
6066 355 : && expr3_elem_size != NULL_TREE && expr3_desc == NULL_TREE)
6067 : {
6068 355 : gfc_conv_descriptor_dtype_set (pblock, descriptor, gfc_get_dtype (type));
6069 355 : gfc_conv_descriptor_elem_len_set (pblock, descriptor, expr3_elem_size);
6070 : }
6071 : else
6072 10410 : gfc_conv_descriptor_dtype_set (pblock, descriptor, gfc_get_dtype (type));
6073 :
6074 12226 : or_expr = logical_false_node;
6075 :
6076 30070 : for (n = 0; n < rank; n++)
6077 : {
6078 17844 : tree conv_lbound;
6079 17844 : tree conv_ubound;
6080 :
6081 : /* We have 3 possibilities for determining the size of the array:
6082 : lower == NULL => lbound = 1, ubound = upper[n]
6083 : upper[n] = NULL => lbound = 1, ubound = lower[n]
6084 : upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
6085 17844 : ubound = upper[n];
6086 :
6087 : /* Set lower bound. */
6088 17844 : gfc_init_se (&se, NULL);
6089 17844 : if (expr3_desc != NULL_TREE)
6090 : {
6091 1477 : if (e3_has_nodescriptor)
6092 : /* The lbound of nondescriptor arrays like array constructors,
6093 : nonallocatable/nonpointer function results/variables,
6094 : start at zero, but when allocating it, the standard expects
6095 : the array to start at one. */
6096 967 : se.expr = gfc_index_one_node;
6097 : else
6098 510 : se.expr = gfc_conv_descriptor_lbound_get (expr3_desc,
6099 : gfc_rank_cst[n]);
6100 : }
6101 16367 : else if (lower == NULL)
6102 13180 : se.expr = gfc_index_one_node;
6103 : else
6104 : {
6105 3187 : gcc_assert (lower[n]);
6106 3187 : if (ubound)
6107 : {
6108 2457 : gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
6109 2457 : gfc_add_block_to_block (pblock, &se.pre);
6110 : }
6111 : else
6112 : {
6113 730 : se.expr = gfc_index_one_node;
6114 730 : ubound = lower[n];
6115 : }
6116 : }
6117 17844 : gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
6118 : gfc_rank_cst[n], se.expr);
6119 17844 : conv_lbound = se.expr;
6120 :
6121 : /* Work out the offset for this component. */
6122 17844 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6123 : se.expr, stride);
6124 17844 : offset = fold_build2_loc (input_location, MINUS_EXPR,
6125 : gfc_array_index_type, offset, tmp);
6126 :
6127 : /* Set upper bound. */
6128 17844 : gfc_init_se (&se, NULL);
6129 17844 : if (expr3_desc != NULL_TREE)
6130 : {
6131 1477 : if (e3_has_nodescriptor)
6132 : {
6133 : /* The lbound of nondescriptor arrays like array constructors,
6134 : nonallocatable/nonpointer function results/variables,
6135 : start at zero, but when allocating it, the standard expects
6136 : the array to start at one. Therefore fix the upper bound to be
6137 : (desc.ubound - desc.lbound) + 1. */
6138 967 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
6139 : gfc_array_index_type,
6140 : gfc_conv_descriptor_ubound_get (
6141 : expr3_desc, gfc_rank_cst[n]),
6142 : gfc_conv_descriptor_lbound_get (
6143 : expr3_desc, gfc_rank_cst[n]));
6144 967 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
6145 : gfc_array_index_type, tmp,
6146 : gfc_index_one_node);
6147 967 : se.expr = gfc_evaluate_now (tmp, pblock);
6148 : }
6149 : else
6150 510 : se.expr = gfc_conv_descriptor_ubound_get (expr3_desc,
6151 : gfc_rank_cst[n]);
6152 : }
6153 : else
6154 : {
6155 16367 : gcc_assert (ubound);
6156 16367 : gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
6157 16367 : gfc_add_block_to_block (pblock, &se.pre);
6158 16367 : if (ubound->expr_type == EXPR_FUNCTION)
6159 779 : se.expr = gfc_evaluate_now (se.expr, pblock);
6160 : }
6161 17844 : gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
6162 : gfc_rank_cst[n], se.expr);
6163 17844 : conv_ubound = se.expr;
6164 :
6165 : /* Store the stride. */
6166 17844 : gfc_conv_descriptor_stride_set (descriptor_block, descriptor,
6167 : gfc_rank_cst[n], stride);
6168 :
6169 : /* Calculate size and check whether extent is negative. */
6170 17844 : size = gfc_conv_array_extent_dim (conv_lbound, conv_ubound, &or_expr);
6171 17844 : size = gfc_evaluate_now (size, pblock);
6172 :
6173 : /* Check whether multiplying the stride by the number of
6174 : elements in this dimension would overflow. We must also check
6175 : whether the current dimension has zero size in order to avoid
6176 : division by zero.
6177 : */
6178 17844 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
6179 : gfc_array_index_type,
6180 17844 : fold_convert (gfc_array_index_type,
6181 : TYPE_MAX_VALUE (gfc_array_index_type)),
6182 : size);
6183 17844 : cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
6184 : logical_type_node, tmp, stride),
6185 : PRED_FORTRAN_OVERFLOW);
6186 17844 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
6187 : integer_one_node, integer_zero_node);
6188 17844 : cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
6189 : logical_type_node, size,
6190 : gfc_index_zero_node),
6191 : PRED_FORTRAN_SIZE_ZERO);
6192 17844 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
6193 : integer_zero_node, tmp);
6194 17844 : tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
6195 : *overflow, tmp);
6196 17844 : *overflow = gfc_evaluate_now (tmp, pblock);
6197 :
6198 : /* Multiply the stride by the number of elements in this dimension. */
6199 17844 : stride = fold_build2_loc (input_location, MULT_EXPR,
6200 : gfc_array_index_type, stride, size);
6201 17844 : stride = gfc_evaluate_now (stride, pblock);
6202 : }
6203 :
6204 12895 : for (n = rank; n < rank + corank; n++)
6205 : {
6206 669 : ubound = upper[n];
6207 :
6208 : /* Set lower bound. */
6209 669 : gfc_init_se (&se, NULL);
6210 669 : if (lower == NULL || lower[n] == NULL)
6211 : {
6212 400 : gcc_assert (n == rank + corank - 1);
6213 400 : se.expr = gfc_index_one_node;
6214 : }
6215 : else
6216 : {
6217 269 : if (ubound || n == rank + corank - 1)
6218 : {
6219 175 : gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
6220 175 : gfc_add_block_to_block (pblock, &se.pre);
6221 : }
6222 : else
6223 : {
6224 94 : se.expr = gfc_index_one_node;
6225 94 : ubound = lower[n];
6226 : }
6227 : }
6228 669 : gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
6229 : gfc_rank_cst[n], se.expr);
6230 :
6231 669 : if (n < rank + corank - 1)
6232 : {
6233 178 : gfc_init_se (&se, NULL);
6234 178 : gcc_assert (ubound);
6235 178 : gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
6236 178 : gfc_add_block_to_block (pblock, &se.pre);
6237 178 : gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
6238 : gfc_rank_cst[n], se.expr);
6239 : }
6240 : }
6241 :
6242 : /* The stride is the number of elements in the array, so multiply by the
6243 : size of an element to get the total size. Obviously, if there is a
6244 : SOURCE expression (expr3) we must use its element size. */
6245 12226 : if (expr3_elem_size != NULL_TREE)
6246 3049 : tmp = expr3_elem_size;
6247 9177 : else if (expr3 != NULL)
6248 : {
6249 0 : if (expr3->ts.type == BT_CLASS)
6250 : {
6251 0 : gfc_se se_sz;
6252 0 : gfc_expr *sz = gfc_copy_expr (expr3);
6253 0 : gfc_add_vptr_component (sz);
6254 0 : gfc_add_size_component (sz);
6255 0 : gfc_init_se (&se_sz, NULL);
6256 0 : gfc_conv_expr (&se_sz, sz);
6257 0 : gfc_free_expr (sz);
6258 0 : tmp = se_sz.expr;
6259 : }
6260 : else
6261 : {
6262 0 : tmp = gfc_typenode_for_spec (&expr3->ts);
6263 0 : tmp = TYPE_SIZE_UNIT (tmp);
6264 : }
6265 : }
6266 : else
6267 9177 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
6268 :
6269 : /* Convert to size_t. */
6270 12226 : *element_size = fold_convert (size_type_node, tmp);
6271 :
6272 12226 : if (rank == 0)
6273 : return *element_size;
6274 :
6275 11999 : stride = fold_convert (size_type_node, stride);
6276 :
6277 : /* First check for overflow. Since an array of type character can
6278 : have zero element_size, we must check for that before
6279 : dividing. */
6280 11999 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
6281 : size_type_node,
6282 11999 : TYPE_MAX_VALUE (size_type_node), *element_size);
6283 11999 : cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
6284 : logical_type_node, tmp, stride),
6285 : PRED_FORTRAN_OVERFLOW);
6286 11999 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
6287 : integer_one_node, integer_zero_node);
6288 11999 : cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
6289 : logical_type_node, *element_size,
6290 : build_int_cst (size_type_node, 0)),
6291 : PRED_FORTRAN_SIZE_ZERO);
6292 11999 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
6293 : integer_zero_node, tmp);
6294 11999 : tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
6295 : *overflow, tmp);
6296 11999 : *overflow = gfc_evaluate_now (tmp, pblock);
6297 :
6298 11999 : size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
6299 : stride, *element_size);
6300 :
6301 11999 : if (poffset != NULL)
6302 : {
6303 11999 : offset = gfc_evaluate_now (offset, pblock);
6304 11999 : *poffset = offset;
6305 : }
6306 :
6307 11999 : if (integer_zerop (or_expr))
6308 : return size;
6309 3635 : if (integer_onep (or_expr))
6310 599 : return build_int_cst (size_type_node, 0);
6311 :
6312 3036 : var = gfc_create_var (TREE_TYPE (size), "size");
6313 3036 : gfc_start_block (&thenblock);
6314 3036 : gfc_add_modify (&thenblock, var, build_int_cst (size_type_node, 0));
6315 3036 : thencase = gfc_finish_block (&thenblock);
6316 :
6317 3036 : gfc_start_block (&elseblock);
6318 3036 : gfc_add_modify (&elseblock, var, size);
6319 3036 : elsecase = gfc_finish_block (&elseblock);
6320 :
6321 3036 : tmp = gfc_evaluate_now (or_expr, pblock);
6322 3036 : tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
6323 3036 : gfc_add_expr_to_block (pblock, tmp);
6324 :
6325 3036 : return var;
6326 : }
6327 :
6328 :
6329 : /* Retrieve the last ref from the chain. This routine is specific to
6330 : gfc_array_allocate ()'s needs. */
6331 :
6332 : bool
6333 18633 : retrieve_last_ref (gfc_ref **ref_in, gfc_ref **prev_ref_in)
6334 : {
6335 18633 : gfc_ref *ref, *prev_ref;
6336 :
6337 18633 : ref = *ref_in;
6338 : /* Prevent warnings for uninitialized variables. */
6339 18633 : prev_ref = *prev_ref_in;
6340 25843 : while (ref && ref->next != NULL)
6341 : {
6342 7210 : gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
6343 : || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
6344 : prev_ref = ref;
6345 : ref = ref->next;
6346 : }
6347 :
6348 18633 : if (ref == NULL || ref->type != REF_ARRAY)
6349 : return false;
6350 :
6351 13445 : *ref_in = ref;
6352 13445 : *prev_ref_in = prev_ref;
6353 13445 : return true;
6354 : }
6355 :
6356 : /* Initializes the descriptor and generates a call to _gfor_allocate. Does
6357 : the work for an ALLOCATE statement. */
6358 : /*GCC ARRAYS*/
6359 :
6360 : bool
6361 17414 : gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
6362 : tree errlen, tree label_finish, tree expr3_elem_size,
6363 : gfc_expr *expr3, tree e3_arr_desc, bool e3_has_nodescriptor,
6364 : gfc_omp_namelist *omp_alloc, bool explicit_ts)
6365 : {
6366 17414 : tree tmp;
6367 17414 : tree pointer;
6368 17414 : tree offset = NULL_TREE;
6369 17414 : tree token = NULL_TREE;
6370 17414 : tree size;
6371 17414 : tree msg;
6372 17414 : tree error = NULL_TREE;
6373 17414 : tree overflow; /* Boolean storing whether size calculation overflows. */
6374 17414 : tree var_overflow = NULL_TREE;
6375 17414 : tree cond;
6376 17414 : tree set_descriptor;
6377 17414 : tree not_prev_allocated = NULL_TREE;
6378 17414 : tree element_size = NULL_TREE;
6379 17414 : stmtblock_t set_descriptor_block;
6380 17414 : stmtblock_t elseblock;
6381 17414 : gfc_expr **lower;
6382 17414 : gfc_expr **upper;
6383 17414 : gfc_ref *ref, *prev_ref = NULL, *coref;
6384 17414 : bool allocatable, coarray, dimension, alloc_w_e3_arr_spec = false,
6385 : non_ulimate_coarray_ptr_comp;
6386 17414 : tree omp_cond = NULL_TREE, omp_alt_alloc = NULL_TREE;
6387 :
6388 17414 : ref = expr->ref;
6389 :
6390 : /* Find the last reference in the chain. */
6391 17414 : if (!retrieve_last_ref (&ref, &prev_ref))
6392 : return false;
6393 :
6394 : /* Take the allocatable and coarray properties solely from the expr-ref's
6395 : attributes and not from source=-expression. */
6396 12226 : if (!prev_ref)
6397 : {
6398 8341 : allocatable = expr->symtree->n.sym->attr.allocatable;
6399 8341 : dimension = expr->symtree->n.sym->attr.dimension;
6400 8341 : non_ulimate_coarray_ptr_comp = false;
6401 : }
6402 : else
6403 : {
6404 3885 : allocatable = prev_ref->u.c.component->attr.allocatable;
6405 : /* Pointer components in coarrayed derived types must be treated
6406 : specially in that they are registered without a check if the are
6407 : already associated. This does not hold for ultimate coarray
6408 : pointers. */
6409 7770 : non_ulimate_coarray_ptr_comp = (prev_ref->u.c.component->attr.pointer
6410 3885 : && !prev_ref->u.c.component->attr.codimension);
6411 3885 : dimension = prev_ref->u.c.component->attr.dimension;
6412 : }
6413 :
6414 : /* For allocatable/pointer arrays in derived types, one of the refs has to be
6415 : a coarray. In this case it does not matter whether we are on this_image
6416 : or not. */
6417 12226 : coarray = false;
6418 29289 : for (coref = expr->ref; coref; coref = coref->next)
6419 17729 : if (coref->type == REF_ARRAY && coref->u.ar.codimen > 0)
6420 : {
6421 : coarray = true;
6422 : break;
6423 : }
6424 :
6425 12226 : if (!dimension)
6426 227 : gcc_assert (coarray);
6427 :
6428 12226 : if (ref->u.ar.type == AR_FULL && expr3 != NULL)
6429 : {
6430 1219 : gfc_ref *old_ref = ref;
6431 : /* F08:C633: Array shape from expr3. */
6432 1219 : ref = expr3->ref;
6433 :
6434 : /* Find the last reference in the chain. */
6435 1219 : if (!retrieve_last_ref (&ref, &prev_ref))
6436 : {
6437 0 : if (expr3->expr_type == EXPR_FUNCTION
6438 0 : && gfc_expr_attr (expr3).dimension)
6439 0 : ref = old_ref;
6440 : else
6441 0 : return false;
6442 : }
6443 : alloc_w_e3_arr_spec = true;
6444 : }
6445 :
6446 : /* Figure out the size of the array. */
6447 12226 : switch (ref->u.ar.type)
6448 : {
6449 9331 : case AR_ELEMENT:
6450 9331 : if (!coarray)
6451 : {
6452 8717 : lower = NULL;
6453 8717 : upper = ref->u.ar.start;
6454 8717 : break;
6455 : }
6456 : /* Fall through. */
6457 :
6458 2321 : case AR_SECTION:
6459 2321 : lower = ref->u.ar.start;
6460 2321 : upper = ref->u.ar.end;
6461 2321 : break;
6462 :
6463 1188 : case AR_FULL:
6464 1188 : gcc_assert (ref->u.ar.as->type == AS_EXPLICIT
6465 : || alloc_w_e3_arr_spec);
6466 :
6467 1188 : lower = ref->u.ar.as->lower;
6468 1188 : upper = ref->u.ar.as->upper;
6469 1188 : break;
6470 :
6471 0 : default:
6472 0 : gcc_unreachable ();
6473 12226 : break;
6474 : }
6475 :
6476 12226 : overflow = integer_zero_node;
6477 :
6478 12226 : if (expr->ts.type == BT_CHARACTER
6479 1079 : && TREE_CODE (se->string_length) == COMPONENT_REF
6480 161 : && expr->ts.u.cl->backend_decl != se->string_length
6481 161 : && VAR_P (expr->ts.u.cl->backend_decl))
6482 0 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
6483 0 : fold_convert (TREE_TYPE (expr->ts.u.cl->backend_decl),
6484 : se->string_length));
6485 :
6486 12226 : gfc_init_block (&set_descriptor_block);
6487 : /* Take the corank only from the actual ref and not from the coref. The
6488 : later will mislead the generation of the array dimensions for allocatable/
6489 : pointer components in derived types. */
6490 23899 : size = gfc_array_init_size (se->expr, alloc_w_e3_arr_spec ? expr->rank
6491 11007 : : ref->u.ar.as->rank,
6492 666 : coarray ? ref->u.ar.as->corank : 0,
6493 : &offset, lower, upper,
6494 : &se->pre, &set_descriptor_block, &overflow,
6495 : expr3_elem_size, expr3, e3_arr_desc,
6496 : e3_has_nodescriptor, expr, &element_size,
6497 : explicit_ts);
6498 :
6499 12226 : if (dimension)
6500 : {
6501 11999 : var_overflow = gfc_create_var (integer_type_node, "overflow");
6502 11999 : gfc_add_modify (&se->pre, var_overflow, overflow);
6503 :
6504 11999 : if (status == NULL_TREE)
6505 : {
6506 : /* Generate the block of code handling overflow. */
6507 11777 : msg = gfc_build_addr_expr (pchar_type_node,
6508 : gfc_build_localized_cstring_const
6509 : ("Integer overflow when calculating the amount of "
6510 : "memory to allocate"));
6511 11777 : error = build_call_expr_loc (input_location,
6512 : gfor_fndecl_runtime_error, 1, msg);
6513 : }
6514 : else
6515 : {
6516 222 : tree status_type = TREE_TYPE (status);
6517 222 : stmtblock_t set_status_block;
6518 :
6519 222 : gfc_start_block (&set_status_block);
6520 222 : gfc_add_modify (&set_status_block, status,
6521 : build_int_cst (status_type, LIBERROR_ALLOCATION));
6522 222 : error = gfc_finish_block (&set_status_block);
6523 : }
6524 : }
6525 :
6526 : /* Allocate memory to store the data. */
6527 12226 : if (POINTER_TYPE_P (TREE_TYPE (se->expr)))
6528 0 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
6529 :
6530 12226 : if (coarray && flag_coarray == GFC_FCOARRAY_LIB)
6531 : {
6532 425 : pointer = non_ulimate_coarray_ptr_comp ? se->expr
6533 353 : : gfc_conv_descriptor_data_get (se->expr);
6534 425 : token = gfc_conv_descriptor_token (se->expr);
6535 425 : token = gfc_build_addr_expr (NULL_TREE, token);
6536 : }
6537 : else
6538 : {
6539 11801 : pointer = gfc_conv_descriptor_data_get (se->expr);
6540 11801 : if (omp_alloc)
6541 33 : omp_cond = boolean_true_node;
6542 : }
6543 12226 : STRIP_NOPS (pointer);
6544 :
6545 12226 : if (allocatable)
6546 : {
6547 10030 : not_prev_allocated = gfc_create_var (logical_type_node,
6548 : "not_prev_allocated");
6549 10030 : tmp = fold_build2_loc (input_location, EQ_EXPR,
6550 : logical_type_node, pointer,
6551 10030 : build_int_cst (TREE_TYPE (pointer), 0));
6552 :
6553 10030 : gfc_add_modify (&se->pre, not_prev_allocated, tmp);
6554 : }
6555 :
6556 12226 : gfc_start_block (&elseblock);
6557 :
6558 12226 : tree succ_add_expr = NULL_TREE;
6559 12226 : if (omp_cond)
6560 : {
6561 33 : tree align, alloc, sz;
6562 33 : gfc_se se2;
6563 33 : if (omp_alloc->u2.allocator)
6564 : {
6565 10 : gfc_init_se (&se2, NULL);
6566 10 : gfc_conv_expr (&se2, omp_alloc->u2.allocator);
6567 10 : gfc_add_block_to_block (&elseblock, &se2.pre);
6568 10 : alloc = gfc_evaluate_now (se2.expr, &elseblock);
6569 10 : gfc_add_block_to_block (&elseblock, &se2.post);
6570 : }
6571 : else
6572 23 : alloc = build_zero_cst (ptr_type_node);
6573 33 : tmp = TREE_TYPE (TREE_TYPE (pointer));
6574 33 : if (tmp == void_type_node)
6575 33 : tmp = gfc_typenode_for_spec (&expr->ts, 0);
6576 33 : if (omp_alloc->u.align)
6577 : {
6578 17 : gfc_init_se (&se2, NULL);
6579 17 : gfc_conv_expr (&se2, omp_alloc->u.align);
6580 17 : gcc_assert (CONSTANT_CLASS_P (se2.expr)
6581 : && se2.pre.head == NULL
6582 : && se2.post.head == NULL);
6583 17 : align = build_int_cst (size_type_node,
6584 17 : MAX (tree_to_uhwi (se2.expr),
6585 : TYPE_ALIGN_UNIT (tmp)));
6586 : }
6587 : else
6588 16 : align = build_int_cst (size_type_node, TYPE_ALIGN_UNIT (tmp));
6589 33 : sz = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
6590 : fold_convert (size_type_node, size),
6591 : build_int_cst (size_type_node, 1));
6592 33 : omp_alt_alloc = builtin_decl_explicit (BUILT_IN_GOMP_ALLOC);
6593 33 : DECL_ATTRIBUTES (omp_alt_alloc)
6594 33 : = tree_cons (get_identifier ("omp allocator"),
6595 : build_tree_list (NULL_TREE, alloc),
6596 33 : DECL_ATTRIBUTES (omp_alt_alloc));
6597 33 : omp_alt_alloc = build_call_expr (omp_alt_alloc, 3, align, sz, alloc);
6598 33 : stmtblock_t tmp_block;
6599 33 : gfc_init_block (&tmp_block);
6600 33 : gfc_conv_descriptor_version_set (&tmp_block, se->expr, integer_one_node);
6601 33 : succ_add_expr = gfc_finish_block (&tmp_block);
6602 : }
6603 :
6604 : /* The allocatable variant takes the old pointer as first argument. */
6605 12226 : if (allocatable)
6606 10621 : gfc_allocate_allocatable (&elseblock, pointer, size, token,
6607 : status, errmsg, errlen, label_finish, expr,
6608 591 : coref != NULL ? coref->u.ar.as->corank : 0,
6609 : omp_cond, omp_alt_alloc, succ_add_expr);
6610 2196 : else if (non_ulimate_coarray_ptr_comp && token)
6611 : /* The token is set only for GFC_FCOARRAY_LIB mode. */
6612 72 : gfc_allocate_using_caf_lib (&elseblock, pointer, size, token, status,
6613 : errmsg, errlen,
6614 : GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY);
6615 : else
6616 2124 : gfc_allocate_using_malloc (&elseblock, pointer, size, status,
6617 : omp_cond, omp_alt_alloc, succ_add_expr);
6618 :
6619 12226 : if (dimension)
6620 : {
6621 11999 : cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
6622 : logical_type_node, var_overflow, integer_zero_node),
6623 : PRED_FORTRAN_OVERFLOW);
6624 11999 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6625 : error, gfc_finish_block (&elseblock));
6626 : }
6627 : else
6628 227 : tmp = gfc_finish_block (&elseblock);
6629 :
6630 12226 : gfc_add_expr_to_block (&se->pre, tmp);
6631 :
6632 : /* Update the array descriptor with the offset and the span. */
6633 12226 : if (dimension)
6634 : {
6635 11999 : gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
6636 11999 : tmp = fold_convert (gfc_array_index_type, element_size);
6637 11999 : gfc_conv_descriptor_span_set (&set_descriptor_block, se->expr, tmp);
6638 : }
6639 :
6640 12226 : set_descriptor = gfc_finish_block (&set_descriptor_block);
6641 12226 : if (status != NULL_TREE)
6642 : {
6643 238 : cond = fold_build2_loc (input_location, EQ_EXPR,
6644 : logical_type_node, status,
6645 238 : build_int_cst (TREE_TYPE (status), 0));
6646 :
6647 238 : if (not_prev_allocated != NULL_TREE)
6648 222 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
6649 : logical_type_node, cond, not_prev_allocated);
6650 :
6651 238 : gfc_add_expr_to_block (&se->pre,
6652 : fold_build3_loc (input_location, COND_EXPR, void_type_node,
6653 : cond,
6654 : set_descriptor,
6655 : build_empty_stmt (input_location)));
6656 : }
6657 : else
6658 11988 : gfc_add_expr_to_block (&se->pre, set_descriptor);
6659 :
6660 : return true;
6661 : }
6662 :
6663 :
6664 : /* Create an array constructor from an initialization expression.
6665 : We assume the frontend already did any expansions and conversions. */
6666 :
6667 : tree
6668 7772 : gfc_conv_array_initializer (tree type, gfc_expr * expr)
6669 : {
6670 7772 : gfc_constructor *c;
6671 7772 : tree tmp;
6672 7772 : gfc_se se;
6673 7772 : tree index, range;
6674 7772 : vec<constructor_elt, va_gc> *v = NULL;
6675 :
6676 7772 : if (expr->expr_type == EXPR_VARIABLE
6677 1 : && expr->symtree->n.sym->attr.flavor == FL_PARAMETER
6678 1 : && expr->symtree->n.sym->value
6679 1 : && !expr->ref)
6680 7772 : expr = expr->symtree->n.sym->value;
6681 :
6682 : /* After parameter substitution the expression should be a constant, array
6683 : constructor, structure constructor, or NULL. Anything else is invalid
6684 : and must not ICE later in lowering. */
6685 7772 : if (expr->expr_type != EXPR_CONSTANT
6686 7378 : && expr->expr_type != EXPR_STRUCTURE
6687 6612 : && expr->expr_type != EXPR_ARRAY
6688 4 : && expr->expr_type != EXPR_NULL)
6689 : {
6690 4 : gfc_error ("Array initializer at %L does not reduce to a constant "
6691 : "expression", &expr->where);
6692 4 : return build_constructor (type, NULL);
6693 : }
6694 :
6695 7768 : switch (expr->expr_type)
6696 : {
6697 1160 : case EXPR_CONSTANT:
6698 1160 : case EXPR_STRUCTURE:
6699 : /* A single scalar or derived type value. Create an array with all
6700 : elements equal to that value. */
6701 1160 : gfc_init_se (&se, NULL);
6702 :
6703 1160 : if (expr->expr_type == EXPR_CONSTANT)
6704 394 : gfc_conv_constant (&se, expr);
6705 : else
6706 766 : gfc_conv_structure (&se, expr, 1);
6707 :
6708 2320 : if (tree_int_cst_lt (TYPE_MAX_VALUE (TYPE_DOMAIN (type)),
6709 1160 : TYPE_MIN_VALUE (TYPE_DOMAIN (type))))
6710 : break;
6711 2296 : else if (tree_int_cst_equal (TYPE_MIN_VALUE (TYPE_DOMAIN (type)),
6712 1148 : TYPE_MAX_VALUE (TYPE_DOMAIN (type))))
6713 167 : range = TYPE_MIN_VALUE (TYPE_DOMAIN (type));
6714 : else
6715 1962 : range = build2 (RANGE_EXPR, gfc_array_index_type,
6716 981 : TYPE_MIN_VALUE (TYPE_DOMAIN (type)),
6717 981 : TYPE_MAX_VALUE (TYPE_DOMAIN (type)));
6718 1148 : CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
6719 1148 : break;
6720 :
6721 6608 : case EXPR_ARRAY:
6722 : /* Create a vector of all the elements. */
6723 6608 : for (c = gfc_constructor_first (expr->value.constructor);
6724 164743 : c && c->expr; c = gfc_constructor_next (c))
6725 : {
6726 158135 : if (c->iterator)
6727 : {
6728 : /* Problems occur when we get something like
6729 : integer :: a(lots) = (/(i, i=1, lots)/) */
6730 0 : gfc_fatal_error ("The number of elements in the array "
6731 : "constructor at %L requires an increase of "
6732 : "the allowed %d upper limit. See "
6733 : "%<-fmax-array-constructor%> option",
6734 : &expr->where, flag_max_array_constructor);
6735 : return NULL_TREE;
6736 : }
6737 158135 : index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
6738 :
6739 158135 : if (mpz_cmp_si (c->repeat, 1) > 0)
6740 : {
6741 127 : tree tmp1, tmp2;
6742 127 : mpz_t maxval;
6743 :
6744 127 : mpz_init (maxval);
6745 127 : mpz_add (maxval, c->offset, c->repeat);
6746 127 : mpz_sub_ui (maxval, maxval, 1);
6747 127 : tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
6748 127 : if (mpz_cmp_si (c->offset, 0) != 0)
6749 : {
6750 27 : mpz_add_ui (maxval, c->offset, 1);
6751 27 : tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
6752 : }
6753 : else
6754 100 : tmp1 = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
6755 :
6756 127 : range = fold_build2 (RANGE_EXPR, gfc_array_index_type, tmp1, tmp2);
6757 127 : mpz_clear (maxval);
6758 : }
6759 : else
6760 : range = NULL;
6761 :
6762 158135 : gfc_init_se (&se, NULL);
6763 158135 : switch (c->expr->expr_type)
6764 : {
6765 156652 : case EXPR_CONSTANT:
6766 156652 : gfc_conv_constant (&se, c->expr);
6767 :
6768 : /* See gfortran.dg/charlen_15.f90 for instance. */
6769 156652 : if (TREE_CODE (se.expr) == STRING_CST
6770 5260 : && TREE_CODE (type) == ARRAY_TYPE)
6771 : {
6772 : tree atype = type;
6773 10520 : while (TREE_CODE (TREE_TYPE (atype)) == ARRAY_TYPE)
6774 5260 : atype = TREE_TYPE (atype);
6775 5260 : gcc_checking_assert (TREE_CODE (TREE_TYPE (atype))
6776 : == INTEGER_TYPE);
6777 5260 : gcc_checking_assert (TREE_TYPE (TREE_TYPE (se.expr))
6778 : == TREE_TYPE (atype));
6779 5260 : if (tree_to_uhwi (TYPE_SIZE_UNIT (TREE_TYPE (se.expr)))
6780 5260 : > tree_to_uhwi (TYPE_SIZE_UNIT (atype)))
6781 : {
6782 0 : unsigned HOST_WIDE_INT size
6783 0 : = tree_to_uhwi (TYPE_SIZE_UNIT (atype));
6784 0 : const char *p = TREE_STRING_POINTER (se.expr);
6785 :
6786 0 : se.expr = build_string (size, p);
6787 : }
6788 5260 : TREE_TYPE (se.expr) = atype;
6789 : }
6790 : break;
6791 :
6792 1483 : case EXPR_STRUCTURE:
6793 1483 : gfc_conv_structure (&se, c->expr, 1);
6794 1483 : break;
6795 :
6796 0 : default:
6797 : /* Catch those occasional beasts that do not simplify
6798 : for one reason or another, assuming that if they are
6799 : standard defying the frontend will catch them. */
6800 0 : gfc_conv_expr (&se, c->expr);
6801 0 : break;
6802 : }
6803 :
6804 158135 : if (range == NULL_TREE)
6805 158008 : CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
6806 : else
6807 : {
6808 127 : if (!integer_zerop (index))
6809 27 : CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
6810 158262 : CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
6811 : }
6812 : }
6813 : break;
6814 :
6815 0 : case EXPR_NULL:
6816 0 : return gfc_build_null_descriptor (type);
6817 :
6818 0 : default:
6819 0 : gcc_unreachable ();
6820 : }
6821 :
6822 : /* Create a constructor from the list of elements. */
6823 7768 : tmp = build_constructor (type, v);
6824 7768 : TREE_CONSTANT (tmp) = 1;
6825 7768 : return tmp;
6826 : }
6827 :
6828 :
6829 : /* Generate code to evaluate non-constant coarray cobounds. */
6830 :
6831 : void
6832 21115 : gfc_trans_array_cobounds (tree type, stmtblock_t * pblock,
6833 : const gfc_symbol *sym)
6834 : {
6835 21115 : int dim;
6836 21115 : tree ubound;
6837 21115 : tree lbound;
6838 21115 : gfc_se se;
6839 21115 : gfc_array_spec *as;
6840 :
6841 21115 : as = IS_CLASS_COARRAY_OR_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
6842 :
6843 22092 : for (dim = as->rank; dim < as->rank + as->corank; dim++)
6844 : {
6845 : /* Evaluate non-constant array bound expressions.
6846 : F2008 4.5.6.3 para 6: If a specification expression in a scoping unit
6847 : references a function, the result is finalized before execution of the
6848 : executable constructs in the scoping unit.
6849 : Adding the finalblocks enables this. */
6850 977 : lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
6851 977 : if (as->lower[dim] && !INTEGER_CST_P (lbound))
6852 : {
6853 114 : gfc_init_se (&se, NULL);
6854 114 : gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
6855 114 : gfc_add_block_to_block (pblock, &se.pre);
6856 114 : gfc_add_block_to_block (pblock, &se.finalblock);
6857 114 : gfc_add_modify (pblock, lbound, se.expr);
6858 : }
6859 977 : ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
6860 977 : if (as->upper[dim] && !INTEGER_CST_P (ubound))
6861 : {
6862 60 : gfc_init_se (&se, NULL);
6863 60 : gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
6864 60 : gfc_add_block_to_block (pblock, &se.pre);
6865 60 : gfc_add_block_to_block (pblock, &se.finalblock);
6866 60 : gfc_add_modify (pblock, ubound, se.expr);
6867 : }
6868 : }
6869 21115 : }
6870 :
6871 :
6872 : /* Generate code to evaluate non-constant array bounds. Sets *poffset and
6873 : returns the size (in elements) of the array. */
6874 :
6875 : tree
6876 13740 : gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
6877 : stmtblock_t * pblock)
6878 : {
6879 13740 : gfc_array_spec *as;
6880 13740 : tree size;
6881 13740 : tree stride;
6882 13740 : tree offset;
6883 13740 : tree ubound;
6884 13740 : tree lbound;
6885 13740 : tree tmp;
6886 13740 : gfc_se se;
6887 :
6888 13740 : int dim;
6889 :
6890 13740 : as = IS_CLASS_COARRAY_OR_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
6891 :
6892 13740 : size = gfc_index_one_node;
6893 13740 : offset = gfc_index_zero_node;
6894 13740 : stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
6895 13740 : if (stride && VAR_P (stride))
6896 124 : gfc_add_modify (pblock, stride, gfc_index_one_node);
6897 30737 : for (dim = 0; dim < as->rank; dim++)
6898 : {
6899 : /* Evaluate non-constant array bound expressions.
6900 : F2008 4.5.6.3 para 6: If a specification expression in a scoping unit
6901 : references a function, the result is finalized before execution of the
6902 : executable constructs in the scoping unit.
6903 : Adding the finalblocks enables this. */
6904 16997 : lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
6905 16997 : if (as->lower[dim] && !INTEGER_CST_P (lbound))
6906 : {
6907 475 : gfc_init_se (&se, NULL);
6908 475 : gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
6909 475 : gfc_add_block_to_block (pblock, &se.pre);
6910 475 : gfc_add_block_to_block (pblock, &se.finalblock);
6911 475 : gfc_add_modify (pblock, lbound, se.expr);
6912 : }
6913 16997 : ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
6914 16997 : if (as->upper[dim] && !INTEGER_CST_P (ubound))
6915 : {
6916 10448 : gfc_init_se (&se, NULL);
6917 10448 : gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
6918 10448 : gfc_add_block_to_block (pblock, &se.pre);
6919 10448 : gfc_add_block_to_block (pblock, &se.finalblock);
6920 10448 : gfc_add_modify (pblock, ubound, se.expr);
6921 : }
6922 : /* The offset of this dimension. offset = offset - lbound * stride. */
6923 16997 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6924 : lbound, size);
6925 16997 : offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6926 : offset, tmp);
6927 :
6928 : /* The size of this dimension, and the stride of the next. */
6929 16997 : if (dim + 1 < as->rank)
6930 3456 : stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
6931 : else
6932 13541 : stride = GFC_TYPE_ARRAY_SIZE (type);
6933 :
6934 16997 : if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
6935 : {
6936 : /* Calculate stride = size * (ubound + 1 - lbound). */
6937 10638 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
6938 : gfc_array_index_type,
6939 : gfc_index_one_node, lbound);
6940 10638 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
6941 : gfc_array_index_type, ubound, tmp);
6942 10638 : tmp = fold_build2_loc (input_location, MULT_EXPR,
6943 : gfc_array_index_type, size, tmp);
6944 10638 : if (stride)
6945 10638 : gfc_add_modify (pblock, stride, tmp);
6946 : else
6947 0 : stride = gfc_evaluate_now (tmp, pblock);
6948 :
6949 : /* Make sure that negative size arrays are translated
6950 : to being zero size. */
6951 10638 : tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
6952 : stride, gfc_index_zero_node);
6953 10638 : tmp = fold_build3_loc (input_location, COND_EXPR,
6954 : gfc_array_index_type, tmp,
6955 : stride, gfc_index_zero_node);
6956 10638 : gfc_add_modify (pblock, stride, tmp);
6957 : }
6958 :
6959 : size = stride;
6960 : }
6961 :
6962 13740 : gfc_trans_array_cobounds (type, pblock, sym);
6963 13740 : gfc_trans_vla_type_sizes (sym, pblock);
6964 :
6965 13740 : *poffset = offset;
6966 13740 : return size;
6967 : }
6968 :
6969 :
6970 : /* Generate code to initialize/allocate an array variable. */
6971 :
6972 : void
6973 31840 : gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
6974 : gfc_wrapped_block * block)
6975 : {
6976 31840 : stmtblock_t init;
6977 31840 : tree type;
6978 31840 : tree tmp = NULL_TREE;
6979 31840 : tree size;
6980 31840 : tree offset;
6981 31840 : tree space;
6982 31840 : tree inittree;
6983 31840 : bool onstack;
6984 31840 : bool back;
6985 :
6986 31840 : gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
6987 :
6988 : /* Do nothing for USEd variables. */
6989 31840 : if (sym->attr.use_assoc)
6990 25888 : return;
6991 :
6992 31797 : type = TREE_TYPE (decl);
6993 31797 : gcc_assert (GFC_ARRAY_TYPE_P (type));
6994 31797 : onstack = TREE_CODE (type) != POINTER_TYPE;
6995 :
6996 : /* In the case of non-dummy symbols with dependencies on an old-fashioned
6997 : function result (ie. proc_name = proc_name->result), gfc_add_init_cleanup
6998 : must be called with the last, optional argument false so that the alloc-
6999 : ation occurs after the processing of the result. */
7000 31797 : back = sym->fn_result_dep;
7001 :
7002 31797 : gfc_init_block (&init);
7003 :
7004 : /* Evaluate character string length. */
7005 31797 : if (sym->ts.type == BT_CHARACTER
7006 3074 : && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
7007 : {
7008 43 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7009 :
7010 43 : gfc_trans_vla_type_sizes (sym, &init);
7011 :
7012 : /* Emit a DECL_EXPR for this variable, which will cause the
7013 : gimplifier to allocate storage, and all that good stuff. */
7014 43 : tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
7015 43 : gfc_add_expr_to_block (&init, tmp);
7016 43 : if (sym->attr.omp_allocate)
7017 : {
7018 : /* Save location of size calculation to ensure GOMP_alloc is placed
7019 : after it. */
7020 0 : tree omp_alloc = lookup_attribute ("omp allocate",
7021 0 : DECL_ATTRIBUTES (decl));
7022 0 : TREE_CHAIN (TREE_CHAIN (TREE_VALUE (omp_alloc)))
7023 0 : = build_tree_list (NULL_TREE, tsi_stmt (tsi_last (init.head)));
7024 : }
7025 : }
7026 :
7027 31595 : if (onstack)
7028 : {
7029 25705 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE,
7030 : back);
7031 25705 : return;
7032 : }
7033 :
7034 6092 : type = TREE_TYPE (type);
7035 :
7036 6092 : gcc_assert (!sym->attr.use_assoc);
7037 6092 : gcc_assert (!sym->module);
7038 :
7039 6092 : if (sym->ts.type == BT_CHARACTER
7040 202 : && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
7041 94 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7042 :
7043 6092 : size = gfc_trans_array_bounds (type, sym, &offset, &init);
7044 :
7045 : /* Don't actually allocate space for Cray Pointees. */
7046 6092 : if (sym->attr.cray_pointee)
7047 : {
7048 140 : if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
7049 49 : gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
7050 :
7051 140 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
7052 140 : return;
7053 : }
7054 5952 : if (sym->attr.omp_allocate)
7055 : {
7056 : /* The size is the number of elements in the array, so multiply by the
7057 : size of an element to get the total size. */
7058 7 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
7059 7 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7060 : size, fold_convert (gfc_array_index_type, tmp));
7061 7 : size = gfc_evaluate_now (size, &init);
7062 :
7063 7 : tree omp_alloc = lookup_attribute ("omp allocate",
7064 7 : DECL_ATTRIBUTES (decl));
7065 7 : TREE_CHAIN (TREE_CHAIN (TREE_VALUE (omp_alloc)))
7066 7 : = build_tree_list (size, NULL_TREE);
7067 7 : space = NULL_TREE;
7068 : }
7069 5945 : else if (flag_stack_arrays)
7070 : {
7071 14 : gcc_assert (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE);
7072 14 : space = build_decl (gfc_get_location (&sym->declared_at),
7073 : VAR_DECL, create_tmp_var_name ("A"),
7074 14 : TREE_TYPE (TREE_TYPE (decl)));
7075 14 : gfc_trans_vla_type_sizes (sym, &init);
7076 : }
7077 : else
7078 : {
7079 : /* The size is the number of elements in the array, so multiply by the
7080 : size of an element to get the total size. */
7081 5931 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
7082 5931 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7083 : size, fold_convert (gfc_array_index_type, tmp));
7084 :
7085 : /* Allocate memory to hold the data. */
7086 5931 : tmp = gfc_call_malloc (&init, TREE_TYPE (decl), size);
7087 5931 : gfc_add_modify (&init, decl, tmp);
7088 :
7089 : /* Free the temporary. */
7090 5931 : tmp = gfc_call_free (decl);
7091 5931 : space = NULL_TREE;
7092 : }
7093 :
7094 : /* Set offset of the array. */
7095 5952 : if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
7096 384 : gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
7097 :
7098 : /* Automatic arrays should not have initializers. */
7099 5952 : gcc_assert (!sym->value);
7100 :
7101 5952 : inittree = gfc_finish_block (&init);
7102 :
7103 5952 : if (space)
7104 : {
7105 14 : tree addr;
7106 14 : pushdecl (space);
7107 :
7108 : /* Don't create new scope, emit the DECL_EXPR in exactly the scope
7109 : where also space is located. */
7110 14 : gfc_init_block (&init);
7111 14 : tmp = fold_build1_loc (input_location, DECL_EXPR,
7112 14 : TREE_TYPE (space), space);
7113 14 : gfc_add_expr_to_block (&init, tmp);
7114 14 : addr = fold_build1_loc (gfc_get_location (&sym->declared_at),
7115 14 : ADDR_EXPR, TREE_TYPE (decl), space);
7116 14 : gfc_add_modify (&init, decl, addr);
7117 14 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE,
7118 : back);
7119 14 : tmp = NULL_TREE;
7120 : }
7121 5952 : gfc_add_init_cleanup (block, inittree, tmp, back);
7122 : }
7123 :
7124 :
7125 : /* Generate entry and exit code for g77 calling convention arrays. */
7126 :
7127 : void
7128 7394 : gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block)
7129 : {
7130 7394 : tree parm;
7131 7394 : tree type;
7132 7394 : tree offset;
7133 7394 : tree tmp;
7134 7394 : tree stmt;
7135 7394 : stmtblock_t init;
7136 :
7137 7394 : location_t loc = input_location;
7138 7394 : input_location = gfc_get_location (&sym->declared_at);
7139 :
7140 : /* Descriptor type. */
7141 7394 : parm = sym->backend_decl;
7142 7394 : type = TREE_TYPE (parm);
7143 7394 : gcc_assert (GFC_ARRAY_TYPE_P (type));
7144 :
7145 7394 : gfc_start_block (&init);
7146 :
7147 7394 : if (sym->ts.type == BT_CHARACTER
7148 722 : && VAR_P (sym->ts.u.cl->backend_decl))
7149 79 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7150 :
7151 : /* Evaluate the bounds of the array. */
7152 7394 : gfc_trans_array_bounds (type, sym, &offset, &init);
7153 :
7154 : /* Set the offset. */
7155 7394 : if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
7156 1214 : gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
7157 :
7158 : /* Set the pointer itself if we aren't using the parameter directly. */
7159 7394 : if (TREE_CODE (parm) != PARM_DECL)
7160 : {
7161 612 : tmp = GFC_DECL_SAVED_DESCRIPTOR (parm);
7162 612 : if (sym->ts.type == BT_CLASS)
7163 : {
7164 243 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
7165 243 : tmp = gfc_class_data_get (tmp);
7166 243 : tmp = gfc_conv_descriptor_data_get (tmp);
7167 : }
7168 612 : tmp = convert (TREE_TYPE (parm), tmp);
7169 612 : gfc_add_modify (&init, parm, tmp);
7170 : }
7171 7394 : stmt = gfc_finish_block (&init);
7172 :
7173 7394 : input_location = loc;
7174 :
7175 : /* Add the initialization code to the start of the function. */
7176 :
7177 7394 : if ((sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.optional)
7178 7394 : || sym->attr.optional
7179 6912 : || sym->attr.not_always_present)
7180 : {
7181 542 : tree nullify;
7182 542 : if (TREE_CODE (parm) != PARM_DECL)
7183 105 : nullify = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
7184 : parm, null_pointer_node);
7185 : else
7186 437 : nullify = build_empty_stmt (input_location);
7187 542 : tmp = gfc_conv_expr_present (sym, true);
7188 542 : stmt = build3_v (COND_EXPR, tmp, stmt, nullify);
7189 : }
7190 :
7191 7394 : gfc_add_init_cleanup (block, stmt, NULL_TREE);
7192 7394 : }
7193 :
7194 :
7195 : /* Modify the descriptor of an array parameter so that it has the
7196 : correct lower bound. Also move the upper bound accordingly.
7197 : If the array is not packed, it will be copied into a temporary.
7198 : For each dimension we set the new lower and upper bounds. Then we copy the
7199 : stride and calculate the offset for this dimension. We also work out
7200 : what the stride of a packed array would be, and see it the two match.
7201 : If the array need repacking, we set the stride to the values we just
7202 : calculated, recalculate the offset and copy the array data.
7203 : Code is also added to copy the data back at the end of the function.
7204 : */
7205 :
7206 : void
7207 13036 : gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
7208 : gfc_wrapped_block * block)
7209 : {
7210 13036 : tree size;
7211 13036 : tree type;
7212 13036 : tree offset;
7213 13036 : stmtblock_t init;
7214 13036 : tree stmtInit, stmtCleanup;
7215 13036 : tree lbound;
7216 13036 : tree ubound;
7217 13036 : tree dubound;
7218 13036 : tree dlbound;
7219 13036 : tree dumdesc;
7220 13036 : tree tmp;
7221 13036 : tree stride, stride2;
7222 13036 : tree stmt_packed;
7223 13036 : tree stmt_unpacked;
7224 13036 : tree partial;
7225 13036 : gfc_se se;
7226 13036 : int n;
7227 13036 : int checkparm;
7228 13036 : int no_repack;
7229 13036 : bool optional_arg;
7230 13036 : gfc_array_spec *as;
7231 13036 : bool is_classarray = IS_CLASS_COARRAY_OR_ARRAY (sym);
7232 :
7233 : /* Do nothing for pointer and allocatable arrays. */
7234 13036 : if ((sym->ts.type != BT_CLASS && sym->attr.pointer)
7235 12939 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer)
7236 12939 : || sym->attr.allocatable
7237 12833 : || (is_classarray && CLASS_DATA (sym)->attr.allocatable))
7238 6064 : return;
7239 :
7240 826 : if ((!is_classarray
7241 826 : || (is_classarray && CLASS_DATA (sym)->as->type == AS_EXPLICIT))
7242 12191 : && sym->attr.dummy && !sym->attr.elemental && gfc_is_nodesc_array (sym))
7243 : {
7244 5861 : gfc_trans_g77_array (sym, block);
7245 5861 : return;
7246 : }
7247 :
7248 6972 : location_t loc = input_location;
7249 6972 : input_location = gfc_get_location (&sym->declared_at);
7250 :
7251 : /* Descriptor type. */
7252 6972 : type = TREE_TYPE (tmpdesc);
7253 6972 : gcc_assert (GFC_ARRAY_TYPE_P (type));
7254 6972 : dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
7255 6972 : if (is_classarray)
7256 : /* For a class array the dummy array descriptor is in the _class
7257 : component. */
7258 661 : dumdesc = gfc_class_data_get (dumdesc);
7259 : else
7260 6311 : dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc);
7261 6972 : as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
7262 6972 : gfc_start_block (&init);
7263 :
7264 6972 : if (sym->ts.type == BT_CHARACTER
7265 786 : && VAR_P (sym->ts.u.cl->backend_decl))
7266 87 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7267 :
7268 : /* TODO: Fix the exclusion of class arrays from extent checking. */
7269 1084 : checkparm = (as->type == AS_EXPLICIT && !is_classarray
7270 8037 : && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
7271 :
7272 6972 : no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
7273 6971 : || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
7274 :
7275 6972 : if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
7276 : {
7277 : /* For non-constant shape arrays we only check if the first dimension
7278 : is contiguous. Repacking higher dimensions wouldn't gain us
7279 : anything as we still don't know the array stride. */
7280 1 : partial = gfc_create_var (logical_type_node, "partial");
7281 1 : TREE_USED (partial) = 1;
7282 1 : tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
7283 1 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, tmp,
7284 : gfc_index_one_node);
7285 1 : gfc_add_modify (&init, partial, tmp);
7286 : }
7287 : else
7288 : partial = NULL_TREE;
7289 :
7290 : /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
7291 : here, however I think it does the right thing. */
7292 6972 : if (no_repack)
7293 : {
7294 : /* Set the first stride. */
7295 6970 : stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
7296 6970 : stride = gfc_evaluate_now (stride, &init);
7297 :
7298 6970 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7299 : stride, gfc_index_zero_node);
7300 6970 : tmp = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
7301 : tmp, gfc_index_one_node, stride);
7302 6970 : stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
7303 6970 : gfc_add_modify (&init, stride, tmp);
7304 :
7305 : /* Allow the user to disable array repacking. */
7306 6970 : stmt_unpacked = NULL_TREE;
7307 : }
7308 : else
7309 : {
7310 2 : gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
7311 : /* A library call to repack the array if necessary. */
7312 2 : tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
7313 2 : stmt_unpacked = build_call_expr_loc (input_location,
7314 : gfor_fndecl_in_pack, 1, tmp);
7315 :
7316 2 : stride = gfc_index_one_node;
7317 :
7318 2 : if (warn_array_temporaries)
7319 : {
7320 1 : locus where;
7321 1 : gfc_locus_from_location (&where, loc);
7322 1 : gfc_warning (OPT_Warray_temporaries,
7323 : "Creating array temporary at %L", &where);
7324 : }
7325 : }
7326 :
7327 : /* This is for the case where the array data is used directly without
7328 : calling the repack function. */
7329 6972 : if (no_repack || partial != NULL_TREE)
7330 6971 : stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
7331 : else
7332 : stmt_packed = NULL_TREE;
7333 :
7334 : /* Assign the data pointer. */
7335 6972 : if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
7336 : {
7337 : /* Don't repack unknown shape arrays when the first stride is 1. */
7338 1 : tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (stmt_packed),
7339 : partial, stmt_packed, stmt_unpacked);
7340 : }
7341 : else
7342 6971 : tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
7343 6972 : gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp));
7344 :
7345 6972 : offset = gfc_index_zero_node;
7346 6972 : size = gfc_index_one_node;
7347 :
7348 : /* Evaluate the bounds of the array. */
7349 16318 : for (n = 0; n < as->rank; n++)
7350 : {
7351 9346 : if (checkparm || !as->upper[n])
7352 : {
7353 : /* Get the bounds of the actual parameter. */
7354 8027 : dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]);
7355 8027 : dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]);
7356 : }
7357 : else
7358 : {
7359 : dubound = NULL_TREE;
7360 : dlbound = NULL_TREE;
7361 : }
7362 :
7363 9346 : lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
7364 9346 : if (!INTEGER_CST_P (lbound))
7365 : {
7366 46 : gfc_init_se (&se, NULL);
7367 46 : gfc_conv_expr_type (&se, as->lower[n],
7368 : gfc_array_index_type);
7369 46 : gfc_add_block_to_block (&init, &se.pre);
7370 46 : gfc_add_modify (&init, lbound, se.expr);
7371 : }
7372 :
7373 9346 : ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
7374 : /* Set the desired upper bound. */
7375 9346 : if (as->upper[n])
7376 : {
7377 : /* We know what we want the upper bound to be. */
7378 1377 : if (!INTEGER_CST_P (ubound))
7379 : {
7380 639 : gfc_init_se (&se, NULL);
7381 639 : gfc_conv_expr_type (&se, as->upper[n],
7382 : gfc_array_index_type);
7383 639 : gfc_add_block_to_block (&init, &se.pre);
7384 639 : gfc_add_modify (&init, ubound, se.expr);
7385 : }
7386 :
7387 : /* Check the sizes match. */
7388 1377 : if (checkparm)
7389 : {
7390 : /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
7391 58 : char * msg;
7392 58 : tree temp;
7393 58 : locus where;
7394 :
7395 58 : gfc_locus_from_location (&where, loc);
7396 58 : temp = fold_build2_loc (input_location, MINUS_EXPR,
7397 : gfc_array_index_type, ubound, lbound);
7398 58 : temp = fold_build2_loc (input_location, PLUS_EXPR,
7399 : gfc_array_index_type,
7400 : gfc_index_one_node, temp);
7401 58 : stride2 = fold_build2_loc (input_location, MINUS_EXPR,
7402 : gfc_array_index_type, dubound,
7403 : dlbound);
7404 58 : stride2 = fold_build2_loc (input_location, PLUS_EXPR,
7405 : gfc_array_index_type,
7406 : gfc_index_one_node, stride2);
7407 58 : tmp = fold_build2_loc (input_location, NE_EXPR,
7408 : gfc_array_index_type, temp, stride2);
7409 58 : msg = xasprintf ("Dimension %d of array '%s' has extent "
7410 : "%%ld instead of %%ld", n+1, sym->name);
7411 :
7412 58 : gfc_trans_runtime_check (true, false, tmp, &init, &where, msg,
7413 : fold_convert (long_integer_type_node, temp),
7414 : fold_convert (long_integer_type_node, stride2));
7415 :
7416 58 : free (msg);
7417 : }
7418 : }
7419 : else
7420 : {
7421 : /* For assumed shape arrays move the upper bound by the same amount
7422 : as the lower bound. */
7423 7969 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
7424 : gfc_array_index_type, dubound, dlbound);
7425 7969 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
7426 : gfc_array_index_type, tmp, lbound);
7427 7969 : gfc_add_modify (&init, ubound, tmp);
7428 : }
7429 : /* The offset of this dimension. offset = offset - lbound * stride. */
7430 9346 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7431 : lbound, stride);
7432 9346 : offset = fold_build2_loc (input_location, MINUS_EXPR,
7433 : gfc_array_index_type, offset, tmp);
7434 :
7435 : /* The size of this dimension, and the stride of the next. */
7436 9346 : if (n + 1 < as->rank)
7437 : {
7438 2374 : stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
7439 :
7440 2374 : if (no_repack || partial != NULL_TREE)
7441 2373 : stmt_unpacked =
7442 2373 : gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]);
7443 :
7444 : /* Figure out the stride if not a known constant. */
7445 2374 : if (!INTEGER_CST_P (stride))
7446 : {
7447 2373 : if (no_repack)
7448 : stmt_packed = NULL_TREE;
7449 : else
7450 : {
7451 : /* Calculate stride = size * (ubound + 1 - lbound). */
7452 0 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
7453 : gfc_array_index_type,
7454 : gfc_index_one_node, lbound);
7455 0 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
7456 : gfc_array_index_type, ubound, tmp);
7457 0 : size = fold_build2_loc (input_location, MULT_EXPR,
7458 : gfc_array_index_type, size, tmp);
7459 0 : stmt_packed = size;
7460 : }
7461 :
7462 : /* Assign the stride. */
7463 2373 : if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
7464 0 : tmp = fold_build3_loc (input_location, COND_EXPR,
7465 : gfc_array_index_type, partial,
7466 : stmt_unpacked, stmt_packed);
7467 : else
7468 2373 : tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
7469 2373 : gfc_add_modify (&init, stride, tmp);
7470 : }
7471 : }
7472 : else
7473 : {
7474 6972 : stride = GFC_TYPE_ARRAY_SIZE (type);
7475 :
7476 6972 : if (stride && !INTEGER_CST_P (stride))
7477 : {
7478 : /* Calculate size = stride * (ubound + 1 - lbound). */
7479 6971 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
7480 : gfc_array_index_type,
7481 : gfc_index_one_node, lbound);
7482 6971 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
7483 : gfc_array_index_type,
7484 : ubound, tmp);
7485 20913 : tmp = fold_build2_loc (input_location, MULT_EXPR,
7486 : gfc_array_index_type,
7487 6971 : GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
7488 6971 : gfc_add_modify (&init, stride, tmp);
7489 : }
7490 : }
7491 : }
7492 :
7493 6972 : gfc_trans_array_cobounds (type, &init, sym);
7494 :
7495 : /* Set the offset. */
7496 6972 : if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
7497 6970 : gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
7498 :
7499 6972 : gfc_trans_vla_type_sizes (sym, &init);
7500 :
7501 6972 : stmtInit = gfc_finish_block (&init);
7502 :
7503 : /* Only do the entry/initialization code if the arg is present. */
7504 6972 : dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
7505 6972 : optional_arg = (sym->attr.optional
7506 6972 : || (sym->ns->proc_name->attr.entry_master
7507 79 : && sym->attr.dummy));
7508 : if (optional_arg)
7509 : {
7510 717 : tree zero_init = fold_convert (TREE_TYPE (tmpdesc), null_pointer_node);
7511 717 : zero_init = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
7512 : tmpdesc, zero_init);
7513 717 : tmp = gfc_conv_expr_present (sym, true);
7514 717 : stmtInit = build3_v (COND_EXPR, tmp, stmtInit, zero_init);
7515 : }
7516 :
7517 : /* Cleanup code. */
7518 6972 : if (no_repack)
7519 : stmtCleanup = NULL_TREE;
7520 : else
7521 : {
7522 2 : stmtblock_t cleanup;
7523 2 : gfc_start_block (&cleanup);
7524 :
7525 2 : if (sym->attr.intent != INTENT_IN)
7526 : {
7527 : /* Copy the data back. */
7528 2 : tmp = build_call_expr_loc (input_location,
7529 : gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
7530 2 : gfc_add_expr_to_block (&cleanup, tmp);
7531 : }
7532 :
7533 : /* Free the temporary. */
7534 2 : tmp = gfc_call_free (tmpdesc);
7535 2 : gfc_add_expr_to_block (&cleanup, tmp);
7536 :
7537 2 : stmtCleanup = gfc_finish_block (&cleanup);
7538 :
7539 : /* Only do the cleanup if the array was repacked. */
7540 2 : if (is_classarray)
7541 : /* For a class array the dummy array descriptor is in the _class
7542 : component. */
7543 1 : tmp = gfc_class_data_get (dumdesc);
7544 : else
7545 1 : tmp = build_fold_indirect_ref_loc (input_location, dumdesc);
7546 2 : tmp = gfc_conv_descriptor_data_get (tmp);
7547 2 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
7548 : tmp, tmpdesc);
7549 2 : stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
7550 : build_empty_stmt (input_location));
7551 :
7552 2 : if (optional_arg)
7553 : {
7554 0 : tmp = gfc_conv_expr_present (sym);
7555 0 : stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
7556 : build_empty_stmt (input_location));
7557 : }
7558 : }
7559 :
7560 : /* We don't need to free any memory allocated by internal_pack as it will
7561 : be freed at the end of the function by pop_context. */
7562 6972 : gfc_add_init_cleanup (block, stmtInit, stmtCleanup);
7563 :
7564 6972 : input_location = loc;
7565 : }
7566 :
7567 :
7568 : /* Calculate the overall offset, including subreferences. */
7569 : void
7570 60550 : gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
7571 : bool subref, gfc_expr *expr)
7572 : {
7573 60550 : tree tmp;
7574 60550 : tree field;
7575 60550 : tree stride;
7576 60550 : tree index;
7577 60550 : gfc_ref *ref;
7578 60550 : gfc_se start;
7579 60550 : int n;
7580 :
7581 : /* If offset is NULL and this is not a subreferenced array, there is
7582 : nothing to do. */
7583 60550 : if (offset == NULL_TREE)
7584 : {
7585 1066 : if (subref)
7586 139 : offset = gfc_index_zero_node;
7587 : else
7588 927 : return;
7589 : }
7590 :
7591 59623 : tmp = build_array_ref (desc, offset, NULL, NULL);
7592 :
7593 : /* Offset the data pointer for pointer assignments from arrays with
7594 : subreferences; e.g. my_integer => my_type(:)%integer_component. */
7595 59623 : if (subref)
7596 : {
7597 : /* Go past the array reference. */
7598 838 : for (ref = expr->ref; ref; ref = ref->next)
7599 838 : if (ref->type == REF_ARRAY &&
7600 751 : ref->u.ar.type != AR_ELEMENT)
7601 : {
7602 727 : ref = ref->next;
7603 727 : break;
7604 : }
7605 :
7606 : /* Calculate the offset for each subsequent subreference. */
7607 1426 : for (; ref; ref = ref->next)
7608 : {
7609 699 : switch (ref->type)
7610 : {
7611 301 : case REF_COMPONENT:
7612 301 : field = ref->u.c.component->backend_decl;
7613 301 : gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
7614 602 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
7615 301 : TREE_TYPE (field),
7616 : tmp, field, NULL_TREE);
7617 301 : break;
7618 :
7619 314 : case REF_SUBSTRING:
7620 314 : gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
7621 314 : gfc_init_se (&start, NULL);
7622 314 : gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
7623 314 : gfc_add_block_to_block (block, &start.pre);
7624 314 : tmp = gfc_build_array_ref (tmp, start.expr, NULL);
7625 314 : break;
7626 :
7627 24 : case REF_ARRAY:
7628 24 : gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
7629 : && ref->u.ar.type == AR_ELEMENT);
7630 :
7631 : /* TODO - Add bounds checking. */
7632 24 : stride = gfc_index_one_node;
7633 24 : index = gfc_index_zero_node;
7634 55 : for (n = 0; n < ref->u.ar.dimen; n++)
7635 : {
7636 31 : tree itmp;
7637 31 : tree jtmp;
7638 :
7639 : /* Update the index. */
7640 31 : gfc_init_se (&start, NULL);
7641 31 : gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
7642 31 : itmp = gfc_evaluate_now (start.expr, block);
7643 31 : gfc_init_se (&start, NULL);
7644 31 : gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
7645 31 : jtmp = gfc_evaluate_now (start.expr, block);
7646 31 : itmp = fold_build2_loc (input_location, MINUS_EXPR,
7647 : gfc_array_index_type, itmp, jtmp);
7648 31 : itmp = fold_build2_loc (input_location, MULT_EXPR,
7649 : gfc_array_index_type, itmp, stride);
7650 31 : index = fold_build2_loc (input_location, PLUS_EXPR,
7651 : gfc_array_index_type, itmp, index);
7652 31 : index = gfc_evaluate_now (index, block);
7653 :
7654 : /* Update the stride. */
7655 31 : gfc_init_se (&start, NULL);
7656 31 : gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
7657 31 : itmp = fold_build2_loc (input_location, MINUS_EXPR,
7658 : gfc_array_index_type, start.expr,
7659 : jtmp);
7660 31 : itmp = fold_build2_loc (input_location, PLUS_EXPR,
7661 : gfc_array_index_type,
7662 : gfc_index_one_node, itmp);
7663 31 : stride = fold_build2_loc (input_location, MULT_EXPR,
7664 : gfc_array_index_type, stride, itmp);
7665 31 : stride = gfc_evaluate_now (stride, block);
7666 : }
7667 :
7668 : /* Apply the index to obtain the array element. */
7669 24 : tmp = gfc_build_array_ref (tmp, index, NULL);
7670 24 : break;
7671 :
7672 60 : case REF_INQUIRY:
7673 60 : switch (ref->u.i)
7674 : {
7675 54 : case INQUIRY_RE:
7676 108 : tmp = fold_build1_loc (input_location, REALPART_EXPR,
7677 54 : TREE_TYPE (TREE_TYPE (tmp)), tmp);
7678 54 : break;
7679 :
7680 6 : case INQUIRY_IM:
7681 12 : tmp = fold_build1_loc (input_location, IMAGPART_EXPR,
7682 6 : TREE_TYPE (TREE_TYPE (tmp)), tmp);
7683 6 : break;
7684 :
7685 : default:
7686 : break;
7687 : }
7688 : break;
7689 :
7690 0 : default:
7691 0 : gcc_unreachable ();
7692 699 : break;
7693 : }
7694 : }
7695 : }
7696 :
7697 : /* Set the target data pointer. */
7698 59623 : offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
7699 :
7700 : /* Check for optional dummy argument being present. Arguments of BIND(C)
7701 : procedures are excepted here since they are handled differently. */
7702 59623 : if (expr->expr_type == EXPR_VARIABLE
7703 52330 : && expr->symtree->n.sym->attr.dummy
7704 6392 : && expr->symtree->n.sym->attr.optional
7705 60615 : && !is_CFI_desc (NULL, expr))
7706 1624 : offset = build3_loc (input_location, COND_EXPR, TREE_TYPE (offset),
7707 812 : gfc_conv_expr_present (expr->symtree->n.sym), offset,
7708 812 : fold_convert (TREE_TYPE (offset), gfc_index_zero_node));
7709 :
7710 59623 : gfc_conv_descriptor_data_set (block, parm, offset);
7711 : }
7712 :
7713 :
7714 : /* gfc_conv_expr_descriptor needs the string length an expression
7715 : so that the size of the temporary can be obtained. This is done
7716 : by adding up the string lengths of all the elements in the
7717 : expression. Function with non-constant expressions have their
7718 : string lengths mapped onto the actual arguments using the
7719 : interface mapping machinery in trans-expr.cc. */
7720 : static void
7721 1584 : get_array_charlen (gfc_expr *expr, gfc_se *se)
7722 : {
7723 1584 : gfc_interface_mapping mapping;
7724 1584 : gfc_formal_arglist *formal;
7725 1584 : gfc_actual_arglist *arg;
7726 1584 : gfc_se tse;
7727 1584 : gfc_expr *e;
7728 :
7729 1584 : if (expr->ts.u.cl->length
7730 1584 : && gfc_is_constant_expr (expr->ts.u.cl->length))
7731 : {
7732 1237 : if (!expr->ts.u.cl->backend_decl)
7733 471 : gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
7734 1369 : return;
7735 : }
7736 :
7737 347 : switch (expr->expr_type)
7738 : {
7739 130 : case EXPR_ARRAY:
7740 :
7741 : /* This is somewhat brutal. The expression for the first
7742 : element of the array is evaluated and assigned to a
7743 : new string length for the original expression. */
7744 130 : e = gfc_constructor_first (expr->value.constructor)->expr;
7745 :
7746 130 : gfc_init_se (&tse, NULL);
7747 :
7748 : /* Avoid evaluating trailing array references since all we need is
7749 : the string length. */
7750 130 : if (e->rank)
7751 38 : tse.descriptor_only = 1;
7752 130 : if (e->rank && e->expr_type != EXPR_VARIABLE)
7753 1 : gfc_conv_expr_descriptor (&tse, e);
7754 : else
7755 129 : gfc_conv_expr (&tse, e);
7756 :
7757 130 : gfc_add_block_to_block (&se->pre, &tse.pre);
7758 130 : gfc_add_block_to_block (&se->post, &tse.post);
7759 :
7760 130 : if (!expr->ts.u.cl->backend_decl || !VAR_P (expr->ts.u.cl->backend_decl))
7761 : {
7762 87 : expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
7763 87 : expr->ts.u.cl->backend_decl =
7764 87 : gfc_create_var (gfc_charlen_type_node, "sln");
7765 : }
7766 :
7767 130 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
7768 : tse.string_length);
7769 :
7770 : /* Make sure that deferred length components point to the hidden
7771 : string_length component. */
7772 130 : if (TREE_CODE (tse.expr) == COMPONENT_REF
7773 25 : && TREE_CODE (tse.string_length) == COMPONENT_REF
7774 149 : && TREE_OPERAND (tse.expr, 0) == TREE_OPERAND (tse.string_length, 0))
7775 19 : e->ts.u.cl->backend_decl = expr->ts.u.cl->backend_decl;
7776 :
7777 : return;
7778 :
7779 91 : case EXPR_OP:
7780 91 : get_array_charlen (expr->value.op.op1, se);
7781 :
7782 : /* For parentheses the expression ts.u.cl should be identical. */
7783 91 : if (expr->value.op.op == INTRINSIC_PARENTHESES)
7784 : {
7785 2 : if (expr->value.op.op1->ts.u.cl != expr->ts.u.cl)
7786 2 : expr->ts.u.cl->backend_decl
7787 2 : = expr->value.op.op1->ts.u.cl->backend_decl;
7788 2 : return;
7789 : }
7790 :
7791 178 : expr->ts.u.cl->backend_decl =
7792 89 : gfc_create_var (gfc_charlen_type_node, "sln");
7793 :
7794 89 : if (expr->value.op.op2)
7795 : {
7796 89 : get_array_charlen (expr->value.op.op2, se);
7797 :
7798 89 : gcc_assert (expr->value.op.op == INTRINSIC_CONCAT);
7799 :
7800 : /* Add the string lengths and assign them to the expression
7801 : string length backend declaration. */
7802 89 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
7803 : fold_build2_loc (input_location, PLUS_EXPR,
7804 : gfc_charlen_type_node,
7805 89 : expr->value.op.op1->ts.u.cl->backend_decl,
7806 89 : expr->value.op.op2->ts.u.cl->backend_decl));
7807 : }
7808 : else
7809 0 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
7810 0 : expr->value.op.op1->ts.u.cl->backend_decl);
7811 : break;
7812 :
7813 44 : case EXPR_FUNCTION:
7814 44 : if (expr->value.function.esym == NULL
7815 37 : || expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
7816 : {
7817 7 : gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
7818 7 : break;
7819 : }
7820 :
7821 : /* Map expressions involving the dummy arguments onto the actual
7822 : argument expressions. */
7823 37 : gfc_init_interface_mapping (&mapping);
7824 37 : formal = gfc_sym_get_dummy_args (expr->symtree->n.sym);
7825 37 : arg = expr->value.function.actual;
7826 :
7827 : /* Set se = NULL in the calls to the interface mapping, to suppress any
7828 : backend stuff. */
7829 113 : for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
7830 : {
7831 38 : if (!arg->expr)
7832 0 : continue;
7833 38 : if (formal->sym)
7834 38 : gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
7835 : }
7836 :
7837 37 : gfc_init_se (&tse, NULL);
7838 :
7839 : /* Build the expression for the character length and convert it. */
7840 37 : gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length);
7841 :
7842 37 : gfc_add_block_to_block (&se->pre, &tse.pre);
7843 37 : gfc_add_block_to_block (&se->post, &tse.post);
7844 37 : tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
7845 74 : tse.expr = fold_build2_loc (input_location, MAX_EXPR,
7846 37 : TREE_TYPE (tse.expr), tse.expr,
7847 37 : build_zero_cst (TREE_TYPE (tse.expr)));
7848 37 : expr->ts.u.cl->backend_decl = tse.expr;
7849 37 : gfc_free_interface_mapping (&mapping);
7850 37 : break;
7851 :
7852 82 : default:
7853 82 : gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
7854 82 : break;
7855 : }
7856 : }
7857 :
7858 :
7859 : /* Helper function to check dimensions. */
7860 : static bool
7861 0 : transposed_dims (gfc_ss *ss)
7862 : {
7863 0 : int n;
7864 :
7865 176462 : for (n = 0; n < ss->dimen; n++)
7866 88938 : if (ss->dim[n] != n)
7867 : return true;
7868 : return false;
7869 : }
7870 :
7871 :
7872 : /* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
7873 : AR_FULL, suitable for the scalarizer. */
7874 :
7875 : static gfc_ss *
7876 1510 : walk_coarray (gfc_expr *e)
7877 : {
7878 1510 : gfc_ss *ss;
7879 :
7880 1510 : ss = gfc_walk_expr (e);
7881 :
7882 : /* Fix scalar coarray. */
7883 1510 : if (ss == gfc_ss_terminator)
7884 : {
7885 357 : gfc_ref *ref;
7886 :
7887 357 : ref = e->ref;
7888 508 : while (ref)
7889 : {
7890 508 : if (ref->type == REF_ARRAY
7891 357 : && ref->u.ar.codimen > 0)
7892 : break;
7893 :
7894 151 : ref = ref->next;
7895 : }
7896 :
7897 357 : gcc_assert (ref != NULL);
7898 357 : if (ref->u.ar.type == AR_ELEMENT)
7899 339 : ref->u.ar.type = AR_SECTION;
7900 357 : ss = gfc_reverse_ss (gfc_walk_array_ref (ss, e, ref, false));
7901 : }
7902 :
7903 1510 : return ss;
7904 : }
7905 :
7906 : gfc_array_spec *
7907 2177 : get_coarray_as (const gfc_expr *e)
7908 : {
7909 2177 : gfc_array_spec *as;
7910 2177 : gfc_symbol *sym = e->symtree->n.sym;
7911 2177 : gfc_component *comp;
7912 :
7913 2177 : if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.codimension)
7914 595 : as = CLASS_DATA (sym)->as;
7915 1582 : else if (sym->attr.codimension)
7916 1522 : as = sym->as;
7917 : else
7918 : as = nullptr;
7919 :
7920 5069 : for (gfc_ref *ref = e->ref; ref; ref = ref->next)
7921 : {
7922 2892 : switch (ref->type)
7923 : {
7924 715 : case REF_COMPONENT:
7925 715 : comp = ref->u.c.component;
7926 715 : if (comp->ts.type == BT_CLASS && CLASS_DATA (comp)->attr.codimension)
7927 18 : as = CLASS_DATA (comp)->as;
7928 697 : else if (comp->ts.type != BT_CLASS && comp->attr.codimension)
7929 655 : as = comp->as;
7930 : break;
7931 :
7932 : case REF_ARRAY:
7933 : case REF_SUBSTRING:
7934 : case REF_INQUIRY:
7935 : break;
7936 : }
7937 : }
7938 :
7939 2177 : return as;
7940 : }
7941 :
7942 : bool
7943 144364 : is_explicit_coarray (gfc_expr *expr)
7944 : {
7945 144364 : if (!gfc_is_coarray (expr))
7946 : return false;
7947 :
7948 2177 : gfc_array_spec *cas = get_coarray_as (expr);
7949 2177 : return cas && cas->cotype == AS_EXPLICIT;
7950 : }
7951 :
7952 : /* Convert an array for passing as an actual argument. Expressions and
7953 : vector subscripts are evaluated and stored in a temporary, which is then
7954 : passed. For whole arrays the descriptor is passed. For array sections
7955 : a modified copy of the descriptor is passed, but using the original data.
7956 :
7957 : This function is also used for array pointer assignments, and there
7958 : are three cases:
7959 :
7960 : - se->want_pointer && !se->direct_byref
7961 : EXPR is an actual argument. On exit, se->expr contains a
7962 : pointer to the array descriptor.
7963 :
7964 : - !se->want_pointer && !se->direct_byref
7965 : EXPR is an actual argument to an intrinsic function or the
7966 : left-hand side of a pointer assignment. On exit, se->expr
7967 : contains the descriptor for EXPR.
7968 :
7969 : - !se->want_pointer && se->direct_byref
7970 : EXPR is the right-hand side of a pointer assignment and
7971 : se->expr is the descriptor for the previously-evaluated
7972 : left-hand side. The function creates an assignment from
7973 : EXPR to se->expr.
7974 :
7975 :
7976 : The se->force_tmp flag disables the non-copying descriptor optimization
7977 : that is used for transpose. It may be used in cases where there is an
7978 : alias between the transpose argument and another argument in the same
7979 : function call. */
7980 :
7981 : void
7982 160846 : gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
7983 : {
7984 160846 : gfc_ss *ss;
7985 160846 : gfc_ss_type ss_type;
7986 160846 : gfc_ss_info *ss_info;
7987 160846 : gfc_loopinfo loop;
7988 160846 : gfc_array_info *info;
7989 160846 : int need_tmp;
7990 160846 : int n;
7991 160846 : tree tmp;
7992 160846 : tree desc;
7993 160846 : stmtblock_t block;
7994 160846 : tree start;
7995 160846 : int full;
7996 160846 : bool subref_array_target = false;
7997 160846 : bool deferred_array_component = false;
7998 160846 : bool substr = false;
7999 160846 : gfc_expr *arg, *ss_expr;
8000 :
8001 160846 : if (se->want_coarray || expr->rank == 0)
8002 1510 : ss = walk_coarray (expr);
8003 : else
8004 159336 : ss = gfc_walk_expr (expr);
8005 :
8006 160846 : gcc_assert (ss != NULL);
8007 160846 : gcc_assert (ss != gfc_ss_terminator);
8008 :
8009 160846 : ss_info = ss->info;
8010 160846 : ss_type = ss_info->type;
8011 160846 : ss_expr = ss_info->expr;
8012 :
8013 : /* Special case: TRANSPOSE which needs no temporary. */
8014 166263 : while (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym
8015 166035 : && (arg = gfc_get_noncopying_intrinsic_argument (expr)) != NULL)
8016 : {
8017 : /* This is a call to transpose which has already been handled by the
8018 : scalarizer, so that we just need to get its argument's descriptor. */
8019 450 : gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
8020 450 : expr = expr->value.function.actual->expr;
8021 : }
8022 :
8023 160846 : if (!se->direct_byref)
8024 309249 : se->unlimited_polymorphic = UNLIMITED_POLY (expr);
8025 :
8026 : /* Special case things we know we can pass easily. */
8027 160846 : switch (expr->expr_type)
8028 : {
8029 144649 : case EXPR_VARIABLE:
8030 : /* If we have a linear array section, we can pass it directly.
8031 : Otherwise we need to copy it into a temporary. */
8032 :
8033 144649 : gcc_assert (ss_type == GFC_SS_SECTION);
8034 144649 : gcc_assert (ss_expr == expr);
8035 144649 : info = &ss_info->data.array;
8036 :
8037 : /* Get the descriptor for the array. */
8038 144649 : gfc_conv_ss_descriptor (&se->pre, ss, 0);
8039 144649 : desc = info->descriptor;
8040 :
8041 : /* The charlen backend decl for deferred character components cannot
8042 : be used because it is fixed at zero. Instead, the hidden string
8043 : length component is used. */
8044 144649 : if (expr->ts.type == BT_CHARACTER
8045 20216 : && expr->ts.deferred
8046 2807 : && TREE_CODE (desc) == COMPONENT_REF)
8047 144649 : deferred_array_component = true;
8048 :
8049 144649 : substr = info->ref && info->ref->next
8050 145471 : && info->ref->next->type == REF_SUBSTRING;
8051 :
8052 144649 : subref_array_target = (is_subref_array (expr)
8053 144649 : && (se->direct_byref
8054 2590 : || expr->ts.type == BT_CHARACTER));
8055 144649 : need_tmp = (gfc_ref_needs_temporary_p (expr->ref)
8056 144649 : && !subref_array_target);
8057 :
8058 144649 : if (se->force_tmp)
8059 : need_tmp = 1;
8060 144466 : else if (se->force_no_tmp)
8061 : need_tmp = 0;
8062 :
8063 138329 : if (need_tmp)
8064 : full = 0;
8065 144364 : else if (is_explicit_coarray (expr))
8066 : full = 0;
8067 143544 : else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
8068 : {
8069 : /* Create a new descriptor if the array doesn't have one. */
8070 : full = 0;
8071 : }
8072 93706 : else if (info->ref->u.ar.type == AR_FULL || se->descriptor_only)
8073 : full = 1;
8074 8051 : else if (se->direct_byref)
8075 : full = 0;
8076 7688 : else if (info->ref->u.ar.dimen == 0 && !info->ref->next)
8077 : full = 1;
8078 7547 : else if (info->ref->u.ar.type == AR_SECTION && se->want_pointer)
8079 : full = 0;
8080 : else
8081 3649 : full = gfc_full_array_ref_p (info->ref, NULL);
8082 :
8083 175523 : if (full && !transposed_dims (ss))
8084 : {
8085 86021 : if (se->direct_byref && !se->byref_noassign)
8086 : {
8087 1054 : struct lang_type *lhs_ls
8088 1054 : = TYPE_LANG_SPECIFIC (TREE_TYPE (se->expr)),
8089 1054 : *rhs_ls = TYPE_LANG_SPECIFIC (TREE_TYPE (desc));
8090 : /* When only the array_kind differs, do a view_convert. */
8091 1450 : tmp = lhs_ls && rhs_ls && lhs_ls->rank == rhs_ls->rank
8092 1054 : && lhs_ls->akind != rhs_ls->akind
8093 1450 : ? build1 (VIEW_CONVERT_EXPR, TREE_TYPE (se->expr), desc)
8094 : : desc;
8095 : /* Copy the descriptor for pointer assignments. */
8096 1054 : gfc_add_modify (&se->pre, se->expr, tmp);
8097 :
8098 : /* Add any offsets from subreferences. */
8099 1054 : gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
8100 : subref_array_target, expr);
8101 :
8102 : /* ....and set the span field. */
8103 1054 : if (ss_info->expr->ts.type == BT_CHARACTER)
8104 141 : tmp = gfc_conv_descriptor_span_get (desc);
8105 : else
8106 913 : tmp = gfc_get_array_span (desc, expr);
8107 1054 : gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp);
8108 1054 : }
8109 84967 : else if (se->want_pointer)
8110 : {
8111 : /* We pass full arrays directly. This means that pointers and
8112 : allocatable arrays should also work. */
8113 13941 : se->expr = gfc_build_addr_expr (NULL_TREE, desc);
8114 : }
8115 : else
8116 : {
8117 71026 : se->expr = desc;
8118 : }
8119 :
8120 86021 : if (expr->ts.type == BT_CHARACTER && !deferred_array_component)
8121 8385 : se->string_length = gfc_get_expr_charlen (expr);
8122 : /* The ss_info string length is returned set to the value of the
8123 : hidden string length component. */
8124 77373 : else if (deferred_array_component)
8125 263 : se->string_length = ss_info->string_length;
8126 :
8127 86021 : se->class_container = ss_info->class_container;
8128 :
8129 86021 : gfc_free_ss_chain (ss);
8130 172168 : return;
8131 : }
8132 : break;
8133 :
8134 4967 : case EXPR_FUNCTION:
8135 : /* A transformational function return value will be a temporary
8136 : array descriptor. We still need to go through the scalarizer
8137 : to create the descriptor. Elemental functions are handled as
8138 : arbitrary expressions, i.e. copy to a temporary. */
8139 :
8140 4967 : if (se->direct_byref)
8141 : {
8142 126 : gcc_assert (ss_type == GFC_SS_FUNCTION && ss_expr == expr);
8143 :
8144 : /* For pointer assignments pass the descriptor directly. */
8145 126 : if (se->ss == NULL)
8146 126 : se->ss = ss;
8147 : else
8148 0 : gcc_assert (se->ss == ss);
8149 :
8150 126 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
8151 126 : gfc_conv_expr (se, expr);
8152 :
8153 126 : gfc_free_ss_chain (ss);
8154 126 : return;
8155 : }
8156 :
8157 4841 : if (ss_expr != expr || ss_type != GFC_SS_FUNCTION)
8158 : {
8159 3325 : if (ss_expr != expr)
8160 : /* Elemental function. */
8161 2576 : gcc_assert ((expr->value.function.esym != NULL
8162 : && expr->value.function.esym->attr.elemental)
8163 : || (expr->value.function.isym != NULL
8164 : && expr->value.function.isym->elemental)
8165 : || (gfc_expr_attr (expr).proc_pointer
8166 : && gfc_expr_attr (expr).elemental)
8167 : || gfc_inline_intrinsic_function_p (expr));
8168 :
8169 3325 : need_tmp = 1;
8170 3325 : if (expr->ts.type == BT_CHARACTER
8171 35 : && expr->ts.u.cl->length
8172 29 : && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
8173 13 : get_array_charlen (expr, se);
8174 :
8175 : info = NULL;
8176 : }
8177 : else
8178 : {
8179 : /* Transformational function. */
8180 1516 : info = &ss_info->data.array;
8181 1516 : need_tmp = 0;
8182 : }
8183 : break;
8184 :
8185 10503 : case EXPR_ARRAY:
8186 : /* Constant array constructors don't need a temporary. */
8187 10503 : if (ss_type == GFC_SS_CONSTRUCTOR
8188 10503 : && expr->ts.type != BT_CHARACTER
8189 19747 : && gfc_constant_array_constructor_p (expr->value.constructor))
8190 : {
8191 7280 : need_tmp = 0;
8192 7280 : info = &ss_info->data.array;
8193 : }
8194 : else
8195 : {
8196 : need_tmp = 1;
8197 : info = NULL;
8198 : }
8199 : break;
8200 :
8201 : default:
8202 : /* Something complicated. Copy it into a temporary. */
8203 : need_tmp = 1;
8204 : info = NULL;
8205 : break;
8206 : }
8207 :
8208 : /* If we are creating a temporary, we don't need to bother about aliases
8209 : anymore. */
8210 67424 : if (need_tmp)
8211 7560 : se->force_tmp = 0;
8212 :
8213 74699 : gfc_init_loopinfo (&loop);
8214 :
8215 : /* Associate the SS with the loop. */
8216 74699 : gfc_add_ss_to_loop (&loop, ss);
8217 :
8218 : /* Tell the scalarizer not to bother creating loop variables, etc. */
8219 74699 : if (!need_tmp)
8220 67139 : loop.array_parameter = 1;
8221 : else
8222 : /* The right-hand side of a pointer assignment mustn't use a temporary. */
8223 7560 : gcc_assert (!se->direct_byref);
8224 :
8225 : /* Do we need bounds checking or not? */
8226 74699 : ss->no_bounds_check = expr->no_bounds_check;
8227 :
8228 : /* Setup the scalarizing loops and bounds. */
8229 74699 : gfc_conv_ss_startstride (&loop);
8230 :
8231 : /* Add bounds-checking for elemental dimensions. */
8232 74699 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !expr->no_bounds_check)
8233 6688 : array_bound_check_elemental (&outermost_loop (&loop)->pre, ss, expr);
8234 :
8235 74699 : if (need_tmp)
8236 : {
8237 7560 : if (expr->ts.type == BT_CHARACTER
8238 1498 : && (!expr->ts.u.cl->backend_decl || expr->expr_type == EXPR_ARRAY))
8239 1391 : get_array_charlen (expr, se);
8240 :
8241 : /* Tell the scalarizer to make a temporary. */
8242 7560 : loop.temp_ss = gfc_get_temp_ss (gfc_typenode_for_spec (&expr->ts),
8243 7560 : ((expr->ts.type == BT_CHARACTER)
8244 1498 : ? expr->ts.u.cl->backend_decl
8245 : : NULL),
8246 : loop.dimen);
8247 :
8248 7560 : se->string_length = loop.temp_ss->info->string_length;
8249 7560 : gcc_assert (loop.temp_ss->dimen == loop.dimen);
8250 7560 : gfc_add_ss_to_loop (&loop, loop.temp_ss);
8251 : }
8252 :
8253 74699 : gfc_conv_loop_setup (&loop, & expr->where);
8254 :
8255 74699 : if (need_tmp)
8256 : {
8257 : /* Copy into a temporary and pass that. We don't need to copy the data
8258 : back because expressions and vector subscripts must be INTENT_IN. */
8259 : /* TODO: Optimize passing function return values. */
8260 7560 : gfc_se lse;
8261 7560 : gfc_se rse;
8262 7560 : bool deep_copy;
8263 :
8264 : /* Start the copying loops. */
8265 7560 : gfc_mark_ss_chain_used (loop.temp_ss, 1);
8266 7560 : gfc_mark_ss_chain_used (ss, 1);
8267 7560 : gfc_start_scalarized_body (&loop, &block);
8268 :
8269 : /* Copy each data element. */
8270 7560 : gfc_init_se (&lse, NULL);
8271 7560 : gfc_copy_loopinfo_to_se (&lse, &loop);
8272 7560 : gfc_init_se (&rse, NULL);
8273 7560 : gfc_copy_loopinfo_to_se (&rse, &loop);
8274 :
8275 7560 : lse.ss = loop.temp_ss;
8276 7560 : rse.ss = ss;
8277 :
8278 7560 : gfc_conv_tmp_array_ref (&lse);
8279 7560 : if (expr->ts.type == BT_CHARACTER)
8280 : {
8281 1498 : gfc_conv_expr (&rse, expr);
8282 1498 : if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
8283 1176 : rse.expr = build_fold_indirect_ref_loc (input_location,
8284 : rse.expr);
8285 : }
8286 : else
8287 6062 : gfc_conv_expr_val (&rse, expr);
8288 :
8289 7560 : gfc_add_block_to_block (&block, &rse.pre);
8290 7560 : gfc_add_block_to_block (&block, &lse.pre);
8291 :
8292 7560 : lse.string_length = rse.string_length;
8293 :
8294 15120 : deep_copy = !se->data_not_needed
8295 7560 : && (expr->expr_type == EXPR_VARIABLE
8296 7022 : || expr->expr_type == EXPR_ARRAY);
8297 7560 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts,
8298 : deep_copy, false);
8299 7560 : gfc_add_expr_to_block (&block, tmp);
8300 :
8301 : /* Finish the copying loops. */
8302 7560 : gfc_trans_scalarizing_loops (&loop, &block);
8303 :
8304 7560 : desc = loop.temp_ss->info->data.array.descriptor;
8305 : }
8306 68655 : else if (expr->expr_type == EXPR_FUNCTION && !transposed_dims (ss))
8307 : {
8308 1503 : desc = info->descriptor;
8309 1503 : se->string_length = ss_info->string_length;
8310 : }
8311 : else
8312 : {
8313 : /* We pass sections without copying to a temporary. Make a new
8314 : descriptor and point it at the section we want. The loop variable
8315 : limits will be the limits of the section.
8316 : A function may decide to repack the array to speed up access, but
8317 : we're not bothered about that here. */
8318 65636 : int dim, ndim, codim;
8319 65636 : tree parm;
8320 65636 : tree parmtype;
8321 65636 : tree dtype;
8322 65636 : tree stride;
8323 65636 : tree from;
8324 65636 : tree to;
8325 65636 : tree base;
8326 65636 : tree offset;
8327 :
8328 65636 : ndim = info->ref ? info->ref->u.ar.dimen : ss->dimen;
8329 :
8330 65636 : if (se->want_coarray)
8331 : {
8332 694 : gfc_array_ref *ar = &info->ref->u.ar;
8333 :
8334 694 : codim = expr->corank;
8335 1512 : for (n = 0; n < codim - 1; n++)
8336 : {
8337 : /* Make sure we are not lost somehow. */
8338 818 : gcc_assert (ar->dimen_type[n + ndim] == DIMEN_THIS_IMAGE);
8339 :
8340 : /* Make sure the call to gfc_conv_section_startstride won't
8341 : generate unnecessary code to calculate stride. */
8342 818 : gcc_assert (ar->stride[n + ndim] == NULL);
8343 :
8344 818 : gfc_conv_section_startstride (&loop.pre, ss, n + ndim);
8345 818 : loop.from[n + loop.dimen] = info->start[n + ndim];
8346 818 : loop.to[n + loop.dimen] = info->end[n + ndim];
8347 : }
8348 :
8349 694 : gcc_assert (n == codim - 1);
8350 694 : evaluate_bound (&loop.pre, info->start, ar->start,
8351 : info->descriptor, n + ndim, true,
8352 694 : ar->as->type == AS_DEFERRED, true);
8353 694 : loop.from[n + loop.dimen] = info->start[n + ndim];
8354 : }
8355 : else
8356 : codim = 0;
8357 :
8358 : /* Set the string_length for a character array. */
8359 65636 : if (expr->ts.type == BT_CHARACTER)
8360 : {
8361 11524 : if (deferred_array_component && !substr)
8362 37 : se->string_length = ss_info->string_length;
8363 : else
8364 11487 : se->string_length = gfc_get_expr_charlen (expr);
8365 :
8366 11524 : if (VAR_P (se->string_length)
8367 984 : && expr->ts.u.cl->backend_decl == se->string_length)
8368 978 : tmp = ss_info->string_length;
8369 : else
8370 : tmp = se->string_length;
8371 :
8372 11524 : if (expr->ts.deferred && expr->ts.u.cl->backend_decl
8373 205 : && VAR_P (expr->ts.u.cl->backend_decl))
8374 150 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, tmp);
8375 : else
8376 11374 : expr->ts.u.cl->backend_decl = tmp;
8377 : }
8378 :
8379 : /* If we have an array section, are assigning or passing an array
8380 : section argument make sure that the lower bound is 1. References
8381 : to the full array should otherwise keep the original bounds. */
8382 65636 : if (!info->ref || info->ref->u.ar.type != AR_FULL)
8383 84241 : for (dim = 0; dim < loop.dimen; dim++)
8384 51197 : if (!integer_onep (loop.from[dim]))
8385 : {
8386 27671 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
8387 : gfc_array_index_type, gfc_index_one_node,
8388 : loop.from[dim]);
8389 27671 : loop.to[dim] = fold_build2_loc (input_location, PLUS_EXPR,
8390 : gfc_array_index_type,
8391 : loop.to[dim], tmp);
8392 27671 : loop.from[dim] = gfc_index_one_node;
8393 : }
8394 :
8395 65636 : desc = info->descriptor;
8396 65636 : if (se->direct_byref && !se->byref_noassign)
8397 : {
8398 : /* For pointer assignments we fill in the destination. */
8399 2670 : parm = se->expr;
8400 2670 : parmtype = TREE_TYPE (parm);
8401 : }
8402 : else
8403 : {
8404 : /* Otherwise make a new one. */
8405 62966 : if (expr->ts.type == BT_CHARACTER)
8406 10860 : parmtype = gfc_typenode_for_spec (&expr->ts);
8407 : else
8408 52106 : parmtype = gfc_get_element_type (TREE_TYPE (desc));
8409 :
8410 62966 : parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, codim,
8411 : loop.from, loop.to, 0,
8412 : GFC_ARRAY_UNKNOWN, false);
8413 62966 : parm = gfc_create_var (parmtype, "parm");
8414 :
8415 : /* When expression is a class object, then add the class' handle to
8416 : the parm_decl. */
8417 62966 : if (expr->ts.type == BT_CLASS && expr->expr_type == EXPR_VARIABLE)
8418 : {
8419 1220 : gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr);
8420 1220 : gfc_se classse;
8421 :
8422 : /* class_expr can be NULL, when no _class ref is in expr.
8423 : We must not fix this here with a gfc_fix_class_ref (). */
8424 1220 : if (class_expr)
8425 : {
8426 1210 : gfc_init_se (&classse, NULL);
8427 1210 : gfc_conv_expr (&classse, class_expr);
8428 1210 : gfc_free_expr (class_expr);
8429 :
8430 1210 : gcc_assert (classse.pre.head == NULL_TREE
8431 : && classse.post.head == NULL_TREE);
8432 1210 : gfc_allocate_lang_decl (parm);
8433 1210 : GFC_DECL_SAVED_DESCRIPTOR (parm) = classse.expr;
8434 : }
8435 : }
8436 : }
8437 :
8438 65636 : if (expr->ts.type == BT_CHARACTER
8439 65636 : && VAR_P (TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (parm)))))
8440 : {
8441 0 : tree elem_len = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (parm)));
8442 0 : gfc_add_modify (&loop.pre, elem_len,
8443 0 : fold_convert (TREE_TYPE (elem_len),
8444 : gfc_get_array_span (desc, expr)));
8445 : }
8446 :
8447 : /* Set the span field. */
8448 65636 : tmp = NULL_TREE;
8449 65636 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
8450 7717 : tmp = gfc_conv_descriptor_span_get (desc);
8451 : else
8452 57919 : tmp = gfc_get_array_span (desc, expr);
8453 65636 : if (tmp)
8454 65568 : gfc_conv_descriptor_span_set (&loop.pre, parm, tmp);
8455 :
8456 : /* The following can be somewhat confusing. We have two
8457 : descriptors, a new one and the original array.
8458 : {parm, parmtype, dim} refer to the new one.
8459 : {desc, type, n, loop} refer to the original, which maybe
8460 : a descriptorless array.
8461 : The bounds of the scalarization are the bounds of the section.
8462 : We don't have to worry about numeric overflows when calculating
8463 : the offsets because all elements are within the array data. */
8464 :
8465 : /* Set the dtype. */
8466 65636 : if (se->unlimited_polymorphic)
8467 649 : dtype = gfc_get_dtype (TREE_TYPE (desc), &loop.dimen);
8468 64987 : else if (expr->ts.type == BT_ASSUMED)
8469 : {
8470 127 : tree tmp2 = desc;
8471 127 : if (DECL_LANG_SPECIFIC (tmp2) && GFC_DECL_SAVED_DESCRIPTOR (tmp2))
8472 127 : tmp2 = GFC_DECL_SAVED_DESCRIPTOR (tmp2);
8473 127 : if (POINTER_TYPE_P (TREE_TYPE (tmp2)))
8474 127 : tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
8475 127 : dtype = gfc_conv_descriptor_dtype_get (tmp2);
8476 : }
8477 : else
8478 64860 : dtype = gfc_get_dtype (parmtype);
8479 65636 : gfc_conv_descriptor_dtype_set (&loop.pre, parm, dtype);
8480 :
8481 : /* The 1st element in the section. */
8482 65636 : base = gfc_index_zero_node;
8483 65636 : if (expr->ts.type == BT_CHARACTER && expr->rank == 0 && codim)
8484 6 : base = gfc_index_one_node;
8485 :
8486 : /* The offset from the 1st element in the section. */
8487 : offset = gfc_index_zero_node;
8488 :
8489 168448 : for (n = 0; n < ndim; n++)
8490 : {
8491 102812 : stride = gfc_conv_array_stride (desc, n);
8492 :
8493 : /* Work out the 1st element in the section. */
8494 102812 : if (info->ref
8495 95074 : && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
8496 : {
8497 1265 : gcc_assert (info->subscript[n]
8498 : && info->subscript[n]->info->type == GFC_SS_SCALAR);
8499 1265 : start = info->subscript[n]->info->data.scalar.value;
8500 : }
8501 : else
8502 : {
8503 : /* Evaluate and remember the start of the section. */
8504 101547 : start = info->start[n];
8505 101547 : stride = gfc_evaluate_now (stride, &loop.pre);
8506 : }
8507 :
8508 102812 : tmp = gfc_conv_array_lbound (desc, n);
8509 102812 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
8510 : start, tmp);
8511 102812 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
8512 : tmp, stride);
8513 102812 : base = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
8514 : base, tmp);
8515 :
8516 102812 : if (info->ref
8517 95074 : && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
8518 : {
8519 : /* For elemental dimensions, we only need the 1st
8520 : element in the section. */
8521 1265 : continue;
8522 : }
8523 :
8524 : /* Vector subscripts need copying and are handled elsewhere. */
8525 101547 : if (info->ref)
8526 93809 : gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
8527 :
8528 : /* look for the corresponding scalarizer dimension: dim. */
8529 152348 : for (dim = 0; dim < ndim; dim++)
8530 152348 : if (ss->dim[dim] == n)
8531 : break;
8532 :
8533 : /* loop exited early: the DIM being looked for has been found. */
8534 101547 : gcc_assert (dim < ndim);
8535 :
8536 : /* Set the new lower bound. */
8537 101547 : from = loop.from[dim];
8538 101547 : to = loop.to[dim];
8539 :
8540 101547 : gfc_conv_descriptor_lbound_set (&loop.pre, parm,
8541 : gfc_rank_cst[dim], from);
8542 :
8543 : /* Set the new upper bound. */
8544 101547 : gfc_conv_descriptor_ubound_set (&loop.pre, parm,
8545 : gfc_rank_cst[dim], to);
8546 :
8547 : /* Multiply the stride by the section stride to get the
8548 : total stride. */
8549 101547 : stride = fold_build2_loc (input_location, MULT_EXPR,
8550 : gfc_array_index_type,
8551 : stride, info->stride[n]);
8552 :
8553 101547 : tmp = fold_build2_loc (input_location, MULT_EXPR,
8554 101547 : TREE_TYPE (offset), stride, from);
8555 101547 : offset = fold_build2_loc (input_location, MINUS_EXPR,
8556 101547 : TREE_TYPE (offset), offset, tmp);
8557 :
8558 : /* Store the new stride. */
8559 101547 : gfc_conv_descriptor_stride_set (&loop.pre, parm,
8560 : gfc_rank_cst[dim], stride);
8561 : }
8562 :
8563 : /* For deferred-length character we need to take the dynamic length
8564 : into account for the dataptr offset. */
8565 65636 : if (expr->ts.type == BT_CHARACTER
8566 11524 : && expr->ts.deferred
8567 211 : && expr->ts.u.cl->backend_decl
8568 211 : && VAR_P (expr->ts.u.cl->backend_decl))
8569 : {
8570 150 : tree base_type = TREE_TYPE (base);
8571 150 : base = fold_build2_loc (input_location, MULT_EXPR, base_type, base,
8572 : fold_convert (base_type,
8573 : expr->ts.u.cl->backend_decl));
8574 : }
8575 :
8576 67148 : for (n = loop.dimen; n < loop.dimen + codim; n++)
8577 : {
8578 1512 : from = loop.from[n];
8579 1512 : to = loop.to[n];
8580 1512 : gfc_conv_descriptor_lbound_set (&loop.pre, parm,
8581 : gfc_rank_cst[n], from);
8582 1512 : if (n < loop.dimen + codim - 1)
8583 818 : gfc_conv_descriptor_ubound_set (&loop.pre, parm,
8584 : gfc_rank_cst[n], to);
8585 : }
8586 :
8587 65636 : if (se->data_not_needed)
8588 6152 : gfc_conv_descriptor_data_set (&loop.pre, parm,
8589 : gfc_index_zero_node);
8590 : else
8591 : /* Point the data pointer at the 1st element in the section. */
8592 59484 : gfc_get_dataptr_offset (&loop.pre, parm, desc, base,
8593 : subref_array_target, expr);
8594 :
8595 65636 : gfc_conv_descriptor_offset_set (&loop.pre, parm, offset);
8596 :
8597 65636 : if (flag_coarray == GFC_FCOARRAY_LIB && expr->corank)
8598 : {
8599 404 : tmp = INDIRECT_REF_P (desc) ? TREE_OPERAND (desc, 0) : desc;
8600 404 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
8601 : {
8602 24 : tmp = gfc_conv_descriptor_token (tmp);
8603 : }
8604 380 : else if (DECL_P (tmp) && DECL_LANG_SPECIFIC (tmp)
8605 460 : && GFC_DECL_TOKEN (tmp) != NULL_TREE)
8606 64 : tmp = GFC_DECL_TOKEN (tmp);
8607 : else
8608 : {
8609 316 : tmp = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (tmp));
8610 : }
8611 :
8612 404 : gfc_conv_descriptor_token_set (&loop.pre, parm, tmp);
8613 : }
8614 : desc = parm;
8615 : }
8616 :
8617 : /* For class arrays add the class tree into the saved descriptor to
8618 : enable getting of _vptr and the like. */
8619 74699 : if (expr->expr_type == EXPR_VARIABLE && VAR_P (desc)
8620 57712 : && IS_CLASS_ARRAY (expr->symtree->n.sym))
8621 : {
8622 1174 : gfc_allocate_lang_decl (desc);
8623 1174 : GFC_DECL_SAVED_DESCRIPTOR (desc) =
8624 1174 : DECL_LANG_SPECIFIC (expr->symtree->n.sym->backend_decl) ?
8625 1088 : GFC_DECL_SAVED_DESCRIPTOR (expr->symtree->n.sym->backend_decl)
8626 : : expr->symtree->n.sym->backend_decl;
8627 : }
8628 73525 : else if (expr->expr_type == EXPR_ARRAY && VAR_P (desc)
8629 10503 : && IS_CLASS_ARRAY (expr))
8630 : {
8631 12 : tree vtype;
8632 12 : gfc_allocate_lang_decl (desc);
8633 12 : tmp = gfc_create_var (expr->ts.u.derived->backend_decl, "class");
8634 12 : GFC_DECL_SAVED_DESCRIPTOR (desc) = tmp;
8635 12 : vtype = gfc_class_vptr_get (tmp);
8636 12 : gfc_add_modify (&se->pre, vtype,
8637 12 : gfc_build_addr_expr (TREE_TYPE (vtype),
8638 12 : gfc_find_vtab (&expr->ts)->backend_decl));
8639 : }
8640 74699 : if (!se->direct_byref || se->byref_noassign)
8641 : {
8642 : /* Get a pointer to the new descriptor. */
8643 72029 : if (se->want_pointer)
8644 40555 : se->expr = gfc_build_addr_expr (NULL_TREE, desc);
8645 : else
8646 31474 : se->expr = desc;
8647 : }
8648 :
8649 74699 : gfc_add_block_to_block (&se->pre, &loop.pre);
8650 74699 : gfc_add_block_to_block (&se->post, &loop.post);
8651 :
8652 : /* Cleanup the scalarizer. */
8653 74699 : gfc_cleanup_loop (&loop);
8654 : }
8655 :
8656 :
8657 : /* Calculate the array size (number of elements); if dim != NULL_TREE,
8658 : return size for that dim (dim=0..rank-1; only for GFC_DESCRIPTOR_TYPE_P).
8659 : If !expr && descriptor array, the rank is taken from the descriptor. */
8660 : tree
8661 15594 : gfc_tree_array_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree dim)
8662 : {
8663 15594 : if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
8664 : {
8665 40 : gcc_assert (dim == NULL_TREE);
8666 40 : return GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
8667 : }
8668 15554 : tree size, tmp, rank = NULL_TREE, cond = NULL_TREE;
8669 15554 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
8670 15554 : enum gfc_array_kind akind = GFC_TYPE_ARRAY_AKIND (TREE_TYPE (desc));
8671 15554 : if (expr == NULL || expr->rank < 0)
8672 3575 : rank = gfc_conv_descriptor_rank_get (desc);
8673 : else
8674 11979 : rank = gfc_rank_cst[expr->rank];
8675 :
8676 15554 : if (dim || (expr && expr->rank == 1))
8677 : {
8678 4669 : if (dim)
8679 9217 : dim = fold_convert_loc (input_location, gfc_array_dim_rank_type, dim);
8680 : else
8681 4669 : dim = gfc_rank_cst[0];
8682 13886 : tree ubound = gfc_conv_descriptor_ubound_get (desc, dim);
8683 13886 : tree lbound = gfc_conv_descriptor_lbound_get (desc, dim);
8684 :
8685 13886 : size = fold_build2_loc (input_location, MINUS_EXPR,
8686 : gfc_array_index_type, ubound, lbound);
8687 13886 : size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
8688 : size, gfc_index_one_node);
8689 : /* if (!allocatable && !pointer && assumed rank)
8690 : size = (idx == rank && ubound[rank-1] == -1 ? -1 : size;
8691 : else
8692 : size = max (0, size); */
8693 13886 : size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
8694 : size, gfc_index_zero_node);
8695 13886 : if (akind == GFC_ARRAY_ASSUMED_RANK_CONT
8696 13886 : || akind == GFC_ARRAY_ASSUMED_RANK)
8697 : {
8698 2876 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
8699 : gfc_array_dim_rank_type, rank,
8700 : gfc_rank_cst[1]);
8701 2876 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
8702 : dim, tmp);
8703 2876 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
8704 : gfc_conv_descriptor_ubound_get (desc, dim),
8705 : build_int_cst (gfc_array_index_type, -1));
8706 2876 : cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
8707 : cond, tmp);
8708 2876 : tmp = build_int_cst (gfc_array_index_type, -1);
8709 2876 : size = build3_loc (input_location, COND_EXPR, gfc_array_index_type,
8710 : cond, tmp, size);
8711 : }
8712 13886 : return size;
8713 : }
8714 :
8715 : /* size = 1. */
8716 1668 : size = gfc_create_var (gfc_array_index_type, "size");
8717 1668 : gfc_add_modify (block, size, build_int_cst (TREE_TYPE (size), 1));
8718 1668 : tree extent = gfc_create_var (gfc_array_index_type, "extent");
8719 :
8720 1668 : stmtblock_t cond_block, loop_body;
8721 1668 : gfc_init_block (&cond_block);
8722 1668 : gfc_init_block (&loop_body);
8723 :
8724 : /* Loop: for (i = 0; i < rank; ++i). */
8725 1668 : tree idx = gfc_create_var (gfc_array_dim_rank_type, "idx");
8726 : /* Loop body. */
8727 : /* #if (assumed-rank + !allocatable && !pointer)
8728 : if (idx + 1 == rank && dim[idx].ubound == -1)
8729 : extent = -1;
8730 : else
8731 : #endif
8732 : extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1
8733 : if (extent < 0)
8734 : extent = 0
8735 : size *= extent. */
8736 1668 : cond = NULL_TREE;
8737 1668 : if (akind == GFC_ARRAY_ASSUMED_RANK_CONT || akind == GFC_ARRAY_ASSUMED_RANK)
8738 : {
8739 471 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
8740 : gfc_array_dim_rank_type, idx, gfc_rank_cst[1]);
8741 471 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
8742 : tmp, rank);
8743 471 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
8744 : gfc_conv_descriptor_ubound_get (desc, idx),
8745 : build_int_cst (gfc_array_index_type, -1));
8746 471 : cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
8747 : cond, tmp);
8748 : }
8749 1668 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8750 : gfc_conv_descriptor_ubound_get (desc, idx),
8751 : gfc_conv_descriptor_lbound_get (desc, idx));
8752 1668 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
8753 : tmp, gfc_index_one_node);
8754 1668 : gfc_add_modify (&cond_block, extent, tmp);
8755 1668 : tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
8756 : extent, gfc_index_zero_node);
8757 1668 : tmp = build3_v (COND_EXPR, tmp,
8758 : fold_build2_loc (input_location, MODIFY_EXPR,
8759 : gfc_array_index_type,
8760 : extent, gfc_index_zero_node),
8761 : build_empty_stmt (input_location));
8762 1668 : gfc_add_expr_to_block (&cond_block, tmp);
8763 1668 : tmp = gfc_finish_block (&cond_block);
8764 1668 : if (cond)
8765 471 : tmp = build3_v (COND_EXPR, cond,
8766 : fold_build2_loc (input_location, MODIFY_EXPR,
8767 : gfc_array_index_type, extent,
8768 : build_int_cst (gfc_array_index_type, -1)),
8769 : tmp);
8770 1668 : gfc_add_expr_to_block (&loop_body, tmp);
8771 : /* size *= extent. */
8772 1668 : gfc_add_modify (&loop_body, size,
8773 : fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
8774 : size, extent));
8775 : /* Generate loop. */
8776 3336 : gfc_simple_for_loop (block, idx, build_int_cst (TREE_TYPE (idx), 0), rank, LT_EXPR,
8777 1668 : build_int_cst (TREE_TYPE (idx), 1),
8778 : gfc_finish_block (&loop_body));
8779 1668 : return size;
8780 : }
8781 :
8782 : /* Helper function for gfc_conv_array_parameter if array size needs to be
8783 : computed. */
8784 :
8785 : static void
8786 142 : array_parameter_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree *size)
8787 : {
8788 142 : tree elem;
8789 142 : *size = gfc_tree_array_size (block, desc, expr, NULL);
8790 142 : elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
8791 142 : *size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
8792 : *size, fold_convert (gfc_array_index_type, elem));
8793 142 : }
8794 :
8795 : /* Helper function - return true if the argument is a pointer. */
8796 :
8797 : static bool
8798 712 : is_pointer (gfc_expr *e)
8799 : {
8800 712 : gfc_symbol *sym;
8801 :
8802 712 : if (e->expr_type != EXPR_VARIABLE || e->symtree == NULL)
8803 : return false;
8804 :
8805 712 : sym = e->symtree->n.sym;
8806 712 : if (sym == NULL)
8807 : return false;
8808 :
8809 712 : return sym->attr.pointer || sym->attr.proc_pointer;
8810 : }
8811 :
8812 : /* Assumed-rank actual argument: the caller only allocates storage for dtype
8813 : rank dimensions. Copying GFC_MAX_DIMENSIONS dim entries would read past the
8814 : physical end of the descriptor. Copy the header fields explicitly and use a
8815 : runtime-sized memcpy for the dim[] entries. */
8816 : void
8817 78 : gfc_resize_assumed_rank_dim_field (gfc_se *se, stmtblock_t *block, tree desc)
8818 : {
8819 78 : tree rank, dim_field, dim_size, copy_size, dst_ptr, src_ptr;
8820 :
8821 78 : gfc_conv_descriptor_data_set (block, desc,
8822 : gfc_conv_descriptor_data_get (se->expr));
8823 78 : gfc_conv_descriptor_offset_set (block, desc,
8824 : gfc_conv_descriptor_offset_get (se->expr));
8825 78 : gfc_conv_descriptor_dtype_set (block, desc,
8826 : gfc_conv_descriptor_dtype_get (se->expr));
8827 78 : rank = fold_convert (size_type_node, gfc_conv_descriptor_rank_get (se->expr));
8828 78 : dim_field = gfc_get_descriptor_dimension (se->expr);
8829 78 : dim_size = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (dim_field)));
8830 78 : copy_size = fold_build2_loc (input_location, MULT_EXPR,
8831 : size_type_node, rank, dim_size);
8832 78 : dst_ptr = gfc_build_addr_expr (pvoid_type_node,
8833 : gfc_get_descriptor_dimension (desc));
8834 78 : src_ptr = gfc_build_addr_expr (pvoid_type_node, dim_field);
8835 78 : gfc_add_expr_to_block (block, build_call_expr_loc (input_location,
8836 : builtin_decl_explicit (BUILT_IN_MEMCPY),
8837 : 3, dst_ptr, src_ptr, copy_size));
8838 78 : }
8839 :
8840 : /* Convert an array for passing as an actual parameter. */
8841 :
8842 : void
8843 66482 : gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr, bool g77,
8844 : const gfc_symbol *fsym, const char *proc_name,
8845 : tree *size, tree *lbshift, tree *packed)
8846 : {
8847 66482 : tree ptr;
8848 66482 : tree desc;
8849 66482 : tree tmp = NULL_TREE;
8850 66482 : tree stmt;
8851 66482 : tree parent = DECL_CONTEXT (current_function_decl);
8852 66482 : tree ctree;
8853 66482 : tree pack_attr = NULL_TREE; /* Set when packing class arrays. */
8854 66482 : bool full_array_var;
8855 66482 : bool this_array_result;
8856 66482 : bool contiguous;
8857 66482 : bool no_pack;
8858 66482 : bool array_constructor;
8859 66482 : bool good_allocatable;
8860 66482 : bool ultimate_ptr_comp;
8861 66482 : bool ultimate_alloc_comp;
8862 66482 : bool readonly;
8863 66482 : gfc_symbol *sym;
8864 66482 : stmtblock_t block;
8865 66482 : gfc_ref *ref;
8866 :
8867 66482 : ultimate_ptr_comp = false;
8868 66482 : ultimate_alloc_comp = false;
8869 :
8870 67227 : for (ref = expr->ref; ref; ref = ref->next)
8871 : {
8872 55623 : if (ref->next == NULL)
8873 : break;
8874 :
8875 745 : if (ref->type == REF_COMPONENT)
8876 : {
8877 661 : ultimate_ptr_comp = ref->u.c.component->attr.pointer;
8878 661 : ultimate_alloc_comp = ref->u.c.component->attr.allocatable;
8879 : }
8880 : }
8881 :
8882 66482 : full_array_var = false;
8883 66482 : contiguous = false;
8884 :
8885 66482 : if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp)
8886 54795 : full_array_var = gfc_full_array_ref_p (ref, &contiguous);
8887 :
8888 54795 : sym = full_array_var ? expr->symtree->n.sym : NULL;
8889 :
8890 : /* The symbol should have an array specification. */
8891 63524 : gcc_assert (!sym || sym->as || ref->u.ar.as);
8892 :
8893 66482 : if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
8894 : {
8895 708 : if (expr->ts.u.cl->length_from_typespec && expr->ts.u.cl->length)
8896 : {
8897 : /* The constructor has an explicit character type-spec length
8898 : so convert it directly. */
8899 126 : gfc_se cse;
8900 126 : gfc_init_se (&cse, NULL);
8901 126 : gfc_conv_expr_type (&cse, expr->ts.u.cl->length,
8902 : gfc_charlen_type_node);
8903 126 : gfc_add_block_to_block (&se->pre, &cse.pre);
8904 126 : tmp = cse.expr;
8905 126 : }
8906 : else
8907 582 : get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
8908 :
8909 708 : expr->ts.u.cl->backend_decl = tmp;
8910 708 : se->string_length = tmp;
8911 : }
8912 :
8913 : /* Is this the result of the enclosing procedure? */
8914 66482 : this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
8915 58 : if (this_array_result
8916 58 : && (sym->backend_decl != current_function_decl)
8917 0 : && (sym->backend_decl != parent))
8918 66482 : this_array_result = false;
8919 :
8920 : /* Passing an optional dummy argument as actual to an optional dummy? */
8921 66482 : bool pass_optional;
8922 66482 : pass_optional = fsym && fsym->attr.optional && sym && sym->attr.optional;
8923 :
8924 : /* Passing address of the array if it is not pointer or assumed-shape. */
8925 66482 : if (full_array_var && g77 && !this_array_result
8926 16168 : && sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
8927 : {
8928 12585 : tmp = gfc_get_symbol_decl (sym);
8929 :
8930 12585 : if (sym->ts.type == BT_CHARACTER)
8931 2809 : se->string_length = sym->ts.u.cl->backend_decl;
8932 :
8933 12585 : if (!sym->attr.pointer
8934 12094 : && sym->as
8935 12094 : && sym->as->type != AS_ASSUMED_SHAPE
8936 11849 : && sym->as->type != AS_DEFERRED
8937 10353 : && sym->as->type != AS_ASSUMED_RANK
8938 10277 : && !sym->attr.allocatable)
8939 : {
8940 : /* Some variables are declared directly, others are declared as
8941 : pointers and allocated on the heap. */
8942 9771 : if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
8943 2518 : se->expr = tmp;
8944 : else
8945 7253 : se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
8946 9771 : if (size)
8947 40 : array_parameter_size (&se->pre, tmp, expr, size);
8948 17065 : return;
8949 : }
8950 :
8951 2814 : if (sym->attr.allocatable)
8952 : {
8953 1882 : if (sym->attr.dummy || sym->attr.result)
8954 : {
8955 1176 : gfc_conv_expr_descriptor (se, expr);
8956 1176 : tmp = se->expr;
8957 : }
8958 1882 : if (size)
8959 14 : array_parameter_size (&se->pre, tmp, expr, size);
8960 1882 : se->expr = gfc_conv_array_data (tmp);
8961 1882 : if (pass_optional)
8962 : {
8963 18 : tree cond = gfc_conv_expr_present (sym);
8964 36 : se->expr = build3_loc (input_location, COND_EXPR,
8965 18 : TREE_TYPE (se->expr), cond, se->expr,
8966 18 : fold_convert (TREE_TYPE (se->expr),
8967 : null_pointer_node));
8968 : }
8969 1882 : return;
8970 : }
8971 : }
8972 :
8973 : /* A convenient reduction in scope. */
8974 54829 : contiguous = g77 && !this_array_result && contiguous;
8975 :
8976 : /* There is no need to pack and unpack the array, if it is contiguous
8977 : and not a deferred- or assumed-shape array, or if it is simply
8978 : contiguous. */
8979 54829 : no_pack = false;
8980 : // clang-format off
8981 54829 : if (sym)
8982 : {
8983 40265 : symbol_attribute *attr = &(IS_CLASS_ARRAY (sym)
8984 : ? CLASS_DATA (sym)->attr : sym->attr);
8985 40265 : gfc_array_spec *as = IS_CLASS_ARRAY (sym)
8986 40265 : ? CLASS_DATA (sym)->as : sym->as;
8987 40265 : no_pack = (as
8988 39975 : && !attr->pointer
8989 36715 : && as->type != AS_DEFERRED
8990 27033 : && as->type != AS_ASSUMED_RANK
8991 64144 : && as->type != AS_ASSUMED_SHAPE);
8992 : }
8993 54829 : if (ref && ref->u.ar.as)
8994 43223 : no_pack = no_pack
8995 43223 : || (ref->u.ar.as->type != AS_DEFERRED
8996 : && ref->u.ar.as->type != AS_ASSUMED_RANK
8997 : && ref->u.ar.as->type != AS_ASSUMED_SHAPE);
8998 109658 : no_pack = contiguous
8999 54829 : && (no_pack || gfc_is_simply_contiguous (expr, false, true));
9000 : // clang-format on
9001 :
9002 : /* If we have an EXPR_OP or a function returning an explicit-shaped
9003 : or allocatable array, an array temporary will be generated which
9004 : does not need to be packed / unpacked if passed to an
9005 : explicit-shape dummy array. */
9006 :
9007 54829 : if (g77)
9008 : {
9009 6459 : if (expr->expr_type == EXPR_OP)
9010 : no_pack = 1;
9011 6382 : else if (expr->expr_type == EXPR_FUNCTION && expr->value.function.esym)
9012 : {
9013 41 : gfc_symbol *result = expr->value.function.esym->result;
9014 41 : if (result->attr.dimension
9015 41 : && (result->as->type == AS_EXPLICIT
9016 14 : || result->attr.allocatable
9017 7 : || result->attr.contiguous))
9018 54829 : no_pack = 1;
9019 : }
9020 : }
9021 :
9022 : /* Array constructors are always contiguous and do not need packing. */
9023 54829 : array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY;
9024 :
9025 : /* Same is true of contiguous sections from allocatable variables. */
9026 109658 : good_allocatable = contiguous
9027 4650 : && expr->symtree
9028 59479 : && expr->symtree->n.sym->attr.allocatable;
9029 :
9030 : /* Or ultimate allocatable components. */
9031 54829 : ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
9032 :
9033 54829 : if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp)
9034 : {
9035 5033 : gfc_conv_expr_descriptor (se, expr);
9036 : /* Deallocate the allocatable components of structures that are
9037 : not variable. */
9038 5033 : if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
9039 3492 : && expr->ts.u.derived->attr.alloc_comp
9040 2083 : && expr->expr_type != EXPR_VARIABLE)
9041 : {
9042 2 : tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, se->expr, expr->rank);
9043 :
9044 : /* The components shall be deallocated before their containing entity. */
9045 2 : gfc_prepend_expr_to_block (&se->post, tmp);
9046 : }
9047 5033 : if (expr->ts.type == BT_CHARACTER && expr->expr_type != EXPR_FUNCTION)
9048 309 : se->string_length = expr->ts.u.cl->backend_decl;
9049 5033 : if (size)
9050 58 : array_parameter_size (&se->pre, se->expr, expr, size);
9051 5033 : se->expr = gfc_conv_array_data (se->expr);
9052 5033 : return;
9053 : }
9054 :
9055 49796 : if (fsym && fsym->ts.type == BT_CLASS)
9056 : {
9057 1254 : gcc_assert (se->expr);
9058 : ctree = se->expr;
9059 : }
9060 : else
9061 : ctree = NULL_TREE;
9062 :
9063 49796 : if (this_array_result)
9064 : {
9065 : /* Result of the enclosing function. */
9066 58 : gfc_conv_expr_descriptor (se, expr);
9067 58 : if (size)
9068 0 : array_parameter_size (&se->pre, se->expr, expr, size);
9069 58 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
9070 :
9071 18 : if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
9072 76 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
9073 18 : se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location,
9074 : se->expr));
9075 :
9076 58 : return;
9077 : }
9078 : else
9079 : {
9080 : /* Every other type of array. */
9081 49738 : se->want_pointer = (ctree) ? 0 : 1;
9082 49738 : se->want_coarray = expr->corank;
9083 49738 : gfc_conv_expr_descriptor (se, expr);
9084 :
9085 49738 : if (size)
9086 30 : array_parameter_size (&se->pre,
9087 : build_fold_indirect_ref_loc (input_location,
9088 : se->expr),
9089 : expr, size);
9090 49738 : if (ctree)
9091 : {
9092 1254 : stmtblock_t block;
9093 :
9094 1254 : gfc_init_block (&block);
9095 1254 : if (lbshift && *lbshift)
9096 : {
9097 : /* Apply a shift of the lbound when supplied. */
9098 98 : for (int dim = 0; dim < expr->rank; ++dim)
9099 49 : gfc_conv_shift_descriptor_lbound (&block, se->expr, dim,
9100 : *lbshift);
9101 : }
9102 1254 : tmp = gfc_class_data_get (ctree);
9103 1254 : if (expr->rank > 1 && CLASS_DATA (fsym)->as->rank != expr->rank
9104 84 : && CLASS_DATA (fsym)->as->type == AS_EXPLICIT && !no_pack)
9105 : {
9106 36 : tree arr = gfc_create_var (TREE_TYPE (tmp), "parm");
9107 36 : gfc_conv_descriptor_data_set (&block, arr,
9108 : gfc_conv_descriptor_data_get (
9109 : se->expr));
9110 36 : gfc_conv_descriptor_lbound_set (&block, arr, gfc_index_zero_node,
9111 : gfc_index_zero_node);
9112 36 : gfc_conv_descriptor_ubound_set (
9113 : &block, arr, gfc_index_zero_node,
9114 : gfc_conv_descriptor_size (se->expr, expr->rank));
9115 36 : gfc_conv_descriptor_stride_set (
9116 : &block, arr, gfc_index_zero_node,
9117 : gfc_conv_descriptor_stride_get (se->expr, gfc_index_zero_node));
9118 36 : tree dtype_val = gfc_conv_descriptor_dtype_get (se->expr);
9119 36 : gfc_conv_descriptor_dtype_set (&block, arr, dtype_val);
9120 36 : gfc_conv_descriptor_rank_set (&block, arr, 1);
9121 36 : gfc_conv_descriptor_span_set (&block, arr,
9122 : gfc_conv_descriptor_span_get (arr));
9123 36 : gfc_conv_descriptor_offset_set (&block, arr, gfc_index_zero_node);
9124 36 : se->expr = arr;
9125 : }
9126 1254 : if (expr->rank == -1)
9127 78 : gfc_resize_assumed_rank_dim_field (se, &block, tmp);
9128 1176 : else if (CLASS_DATA (fsym)->as->rank == -1)
9129 397 : gfc_class_array_data_assign (&block, tmp, se->expr, false);
9130 : else
9131 779 : gfc_class_array_data_assign (&block, tmp, se->expr, true);
9132 :
9133 : /* Handle optional. */
9134 1254 : if (fsym && fsym->attr.optional && sym && sym->attr.optional)
9135 348 : tmp = build3_v (COND_EXPR, gfc_conv_expr_present (sym),
9136 : gfc_finish_block (&block),
9137 : build_empty_stmt (input_location));
9138 : else
9139 906 : tmp = gfc_finish_block (&block);
9140 :
9141 1254 : gfc_add_expr_to_block (&se->pre, tmp);
9142 : }
9143 48484 : else if (pass_optional && full_array_var && sym->as && sym->as->rank != 0)
9144 : {
9145 : /* Perform calculation of bounds and strides of optional array dummy
9146 : only if the argument is present. */
9147 219 : tmp = build3_v (COND_EXPR, gfc_conv_expr_present (sym),
9148 : gfc_finish_block (&se->pre),
9149 : build_empty_stmt (input_location));
9150 219 : gfc_add_expr_to_block (&se->pre, tmp);
9151 : }
9152 : }
9153 :
9154 : /* Deallocate the allocatable components of structures that are
9155 : not variable, for descriptorless arguments.
9156 : Arguments with a descriptor are handled in gfc_conv_procedure_call. */
9157 49738 : if (g77 && (expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
9158 72 : && expr->ts.u.derived->attr.alloc_comp
9159 18 : && expr->expr_type != EXPR_VARIABLE)
9160 : {
9161 0 : tmp = build_fold_indirect_ref_loc (input_location, se->expr);
9162 0 : tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank);
9163 :
9164 : /* The components shall be deallocated before their containing entity. */
9165 0 : gfc_prepend_expr_to_block (&se->post, tmp);
9166 : }
9167 :
9168 48330 : if (g77 || (fsym && fsym->attr.contiguous
9169 1585 : && !gfc_is_simply_contiguous (expr, false, true)))
9170 : {
9171 1588 : tree origptr = NULL_TREE, packedptr = NULL_TREE;
9172 :
9173 1588 : desc = se->expr;
9174 :
9175 : /* For contiguous arrays, save the original value of the descriptor. */
9176 1588 : if (!g77 && !ctree)
9177 : {
9178 84 : origptr = gfc_create_var (pvoid_type_node, "origptr");
9179 84 : tmp = build_fold_indirect_ref_loc (input_location, desc);
9180 84 : tmp = gfc_conv_array_data (tmp);
9181 168 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
9182 84 : TREE_TYPE (origptr), origptr,
9183 84 : fold_convert (TREE_TYPE (origptr), tmp));
9184 84 : gfc_add_expr_to_block (&se->pre, tmp);
9185 : }
9186 :
9187 : /* Repack the array. */
9188 1588 : if (warn_array_temporaries)
9189 : {
9190 28 : if (fsym)
9191 18 : gfc_warning (OPT_Warray_temporaries,
9192 : "Creating array temporary at %L for argument %qs",
9193 18 : &expr->where, fsym->name);
9194 : else
9195 10 : gfc_warning (OPT_Warray_temporaries,
9196 : "Creating array temporary at %L", &expr->where);
9197 : }
9198 :
9199 : /* When optimizing, we can use gfc_conv_subref_array_arg for
9200 : making the packing and unpacking operation visible to the
9201 : optimizers. */
9202 :
9203 1408 : if (g77 && flag_inline_arg_packing && expr->expr_type == EXPR_VARIABLE
9204 712 : && !is_pointer (expr) && ! gfc_has_dimen_vector_ref (expr)
9205 342 : && !(expr->symtree->n.sym->as
9206 324 : && expr->symtree->n.sym->as->type == AS_ASSUMED_RANK)
9207 1930 : && (fsym == NULL || fsym->ts.type != BT_ASSUMED))
9208 : {
9209 321 : gfc_conv_subref_array_arg (se, expr, g77,
9210 145 : fsym ? fsym->attr.intent : INTENT_INOUT,
9211 : false, fsym, proc_name, sym, true);
9212 321 : return;
9213 : }
9214 :
9215 1267 : if (ctree)
9216 : {
9217 96 : packedptr
9218 96 : = gfc_build_addr_expr (NULL_TREE, gfc_create_var (TREE_TYPE (ctree),
9219 : "packed"));
9220 96 : if (fsym)
9221 : {
9222 96 : int pack_mask = 0;
9223 :
9224 : /* Set bit 0 to the mask, when this is an unlimited_poly
9225 : class. */
9226 96 : if (CLASS_DATA (fsym)->ts.u.derived->attr.unlimited_polymorphic)
9227 36 : pack_mask = 1 << 0;
9228 96 : pack_attr = build_int_cst (integer_type_node, pack_mask);
9229 : }
9230 : else
9231 0 : pack_attr = integer_zero_node;
9232 :
9233 96 : gfc_add_expr_to_block (
9234 : &se->pre,
9235 : build_call_expr_loc (input_location, gfor_fndecl_in_pack_class, 4,
9236 : packedptr,
9237 : gfc_build_addr_expr (NULL_TREE, ctree),
9238 96 : size_in_bytes (TREE_TYPE (ctree)), pack_attr));
9239 96 : ptr = gfc_conv_array_data (gfc_class_data_get (packedptr));
9240 96 : se->expr = packedptr;
9241 96 : if (packed)
9242 96 : *packed = packedptr;
9243 : }
9244 : else
9245 : {
9246 1171 : ptr = build_call_expr_loc (input_location, gfor_fndecl_in_pack, 1,
9247 : desc);
9248 :
9249 1171 : if (fsym && fsym->attr.optional && sym && sym->attr.optional)
9250 : {
9251 11 : tmp = gfc_conv_expr_present (sym);
9252 22 : ptr = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
9253 11 : tmp, fold_convert (TREE_TYPE (se->expr), ptr),
9254 11 : fold_convert (TREE_TYPE (se->expr),
9255 : null_pointer_node));
9256 : }
9257 :
9258 1171 : ptr = gfc_evaluate_now (ptr, &se->pre);
9259 : }
9260 :
9261 : /* Use the packed data for the actual argument, except for contiguous arrays,
9262 : where the descriptor's data component is set. */
9263 1267 : if (g77)
9264 1087 : se->expr = ptr;
9265 : else
9266 : {
9267 180 : tmp = build_fold_indirect_ref_loc (input_location, desc);
9268 :
9269 180 : if (!ctree)
9270 : {
9271 : /* The original descriptor may have transposed dims so we
9272 : can't reuse it directly; we have to create a new one. */
9273 84 : tree old_field;
9274 84 : tree old_desc = tmp;
9275 84 : tree new_desc = gfc_create_var (TREE_TYPE (old_desc), "arg_desc");
9276 :
9277 84 : old_field = gfc_conv_descriptor_dtype_get (old_desc);
9278 84 : gfc_conv_descriptor_dtype_set (&se->pre, new_desc, 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_get (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 : gfc_conv_descriptor_token_set (&se->pre, new_desc,
9392 : 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 21108 : gfc_full_array_size (stmtblock_t *block, tree decl, int rank)
9498 : {
9499 21108 : tree idx;
9500 21108 : tree nelems;
9501 21108 : tree tmp;
9502 21108 : if (rank < 0)
9503 0 : idx = gfc_conv_descriptor_rank_get (decl);
9504 : else
9505 21108 : idx = gfc_rank_cst[rank - 1];
9506 21108 : nelems = gfc_conv_descriptor_ubound_get (decl, idx);
9507 21108 : tmp = gfc_conv_descriptor_lbound_get (decl, idx);
9508 21108 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
9509 : nelems, tmp);
9510 21108 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
9511 : tmp, gfc_index_one_node);
9512 21108 : tmp = gfc_evaluate_now (tmp, block);
9513 :
9514 21108 : nelems = gfc_conv_descriptor_stride_get (decl, idx);
9515 21108 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9516 : nelems, tmp);
9517 21108 : 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 9930 : 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 9930 : tree tmp;
9530 9930 : tree eltype;
9531 9930 : tree size;
9532 9930 : tree nelems;
9533 9930 : tree null_cond;
9534 9930 : tree null_data;
9535 9930 : stmtblock_t block;
9536 :
9537 : /* If the source is null, set the destination to null. Then,
9538 : allocate memory to the destination. */
9539 9930 : gfc_init_block (&block);
9540 :
9541 9930 : 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 7694 : gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
9570 7694 : null_data = gfc_finish_block (&block);
9571 :
9572 7694 : gfc_init_block (&block);
9573 7694 : if (rank)
9574 7679 : 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 7694 : if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type))
9580 7664 : eltype = gfc_get_element_type (type);
9581 : else
9582 : eltype = type;
9583 :
9584 7694 : if (str_sz != NULL_TREE)
9585 43 : tmp = fold_convert (gfc_array_index_type, str_sz);
9586 : else
9587 7651 : tmp = fold_convert (gfc_array_index_type,
9588 : TYPE_SIZE_UNIT (eltype));
9589 :
9590 7694 : tmp = gfc_evaluate_now (tmp, &block);
9591 7694 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9592 : nelems, tmp);
9593 7694 : if (!no_malloc)
9594 : {
9595 7626 : tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src));
9596 7626 : tmp = gfc_call_malloc (&block, tmp, size);
9597 7626 : 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 7694 : if (!no_memcpy)
9603 : {
9604 6333 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
9605 6333 : 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 6333 : gfc_add_expr_to_block (&block, tmp);
9610 : }
9611 : }
9612 :
9613 9930 : gfc_add_expr_to_block (&block, add_when_allocated);
9614 9930 : tmp = gfc_finish_block (&block);
9615 :
9616 : /* Null the destination if the source is null; otherwise do
9617 : the allocate and copy. */
9618 9930 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src)))
9619 : null_cond = src;
9620 : else
9621 7694 : null_cond = gfc_conv_descriptor_data_get (src);
9622 :
9623 9930 : null_cond = convert (pvoid_type_node, null_cond);
9624 9930 : null_cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9625 : null_cond, null_pointer_node);
9626 9930 : 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 7490 : gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank,
9634 : tree add_when_allocated)
9635 : {
9636 7490 : return duplicate_allocatable (dest, src, type, rank, false, false,
9637 7490 : 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 : gfc_conv_descriptor_rank_set (&globalblock, dest, rank);
9714 :
9715 44 : if (rank)
9716 44 : nelems = gfc_full_array_size (&globalblock, src, rank);
9717 : else
9718 0 : nelems = integer_one_node;
9719 :
9720 44 : tmp = fold_convert (size_type_node,
9721 : TYPE_SIZE_UNIT (gfc_get_element_type (type)));
9722 44 : size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
9723 : fold_convert (size_type_node, nelems), tmp);
9724 :
9725 44 : gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
9726 44 : gfc_allocate_using_caf_lib (&block, dest, fold_convert (size_type_node,
9727 : size),
9728 : gfc_build_addr_expr (NULL_TREE, dest_tok),
9729 : NULL_TREE, NULL_TREE, NULL_TREE,
9730 : GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
9731 44 : null_data = gfc_finish_block (&block);
9732 :
9733 44 : gfc_init_block (&block);
9734 44 : gfc_allocate_using_caf_lib (&block, dest,
9735 : fold_convert (size_type_node, size),
9736 : gfc_build_addr_expr (NULL_TREE, dest_tok),
9737 : NULL_TREE, NULL_TREE, NULL_TREE,
9738 : GFC_CAF_COARRAY_ALLOC);
9739 :
9740 44 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
9741 44 : tmp = build_call_expr_loc (input_location, tmp, 3,
9742 : gfc_conv_descriptor_data_get (dest),
9743 : gfc_conv_descriptor_data_get (src),
9744 : fold_convert (size_type_node, size));
9745 44 : gfc_add_expr_to_block (&block, tmp);
9746 : }
9747 62 : gfc_add_expr_to_block (&block, add_when_allocated);
9748 62 : tmp = gfc_finish_block (&block);
9749 :
9750 : /* Null the destination if the source is null; otherwise do
9751 : the register and copy. */
9752 62 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src)))
9753 : null_cond = src;
9754 : else
9755 44 : null_cond = gfc_conv_descriptor_data_get (src);
9756 :
9757 62 : null_cond = convert (pvoid_type_node, null_cond);
9758 62 : null_cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9759 : null_cond, null_pointer_node);
9760 62 : gfc_add_expr_to_block (&globalblock, build3_v (COND_EXPR, null_cond, tmp,
9761 : null_data));
9762 62 : return gfc_finish_block (&globalblock);
9763 : }
9764 :
9765 :
9766 : /* Helper function to abstract whether coarray processing is enabled. */
9767 :
9768 : static bool
9769 75 : caf_enabled (int caf_mode)
9770 : {
9771 75 : return (caf_mode & GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY)
9772 75 : == GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY;
9773 : }
9774 :
9775 :
9776 : /* Helper function to abstract whether coarray processing is enabled
9777 : and we are in a derived type coarray. */
9778 :
9779 : static bool
9780 12774 : caf_in_coarray (int caf_mode)
9781 : {
9782 12774 : static const int pat = GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
9783 : | GFC_STRUCTURE_CAF_MODE_IN_COARRAY;
9784 12774 : return (caf_mode & pat) == pat;
9785 : }
9786 :
9787 :
9788 : /* Helper function to abstract whether coarray is to deallocate only. */
9789 :
9790 : bool
9791 392 : gfc_caf_is_dealloc_only (int caf_mode)
9792 : {
9793 392 : return (caf_mode & GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY)
9794 392 : == GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY;
9795 : }
9796 :
9797 :
9798 : /* Recursively traverse an object of derived type, generating code to
9799 : deallocate, nullify or copy allocatable components. This is the work horse
9800 : function for the functions named in this enum. */
9801 :
9802 : enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP,
9803 : COPY_ALLOC_COMP, COPY_ONLY_ALLOC_COMP, REASSIGN_CAF_COMP,
9804 : ALLOCATE_PDT_COMP, DEALLOCATE_PDT_COMP, CHECK_PDT_DUMMY,
9805 : BCAST_ALLOC_COMP};
9806 :
9807 : static gfc_actual_arglist *pdt_param_list;
9808 : static bool generating_copy_helper;
9809 : static hash_set<gfc_symbol *> seen_derived_types;
9810 :
9811 : /* Forward declaration of structure_alloc_comps for wrapper generator. */
9812 : static tree structure_alloc_comps (gfc_symbol *, tree, tree, int, int, int,
9813 : gfc_co_subroutines_args *, bool);
9814 :
9815 : /* Generate a wrapper function that performs element-wise deep copy for
9816 : recursive allocatable array components. This wrapper is passed as a
9817 : function pointer to the runtime helper _gfortran_cfi_deep_copy_array,
9818 : allowing recursion to happen at runtime instead of compile time. */
9819 :
9820 : static tree
9821 256 : get_copy_helper_function_type (void)
9822 : {
9823 256 : static tree fn_type = NULL_TREE;
9824 256 : if (fn_type == NULL_TREE)
9825 29 : fn_type = build_function_type_list (void_type_node,
9826 : pvoid_type_node,
9827 : pvoid_type_node,
9828 : NULL_TREE);
9829 256 : return fn_type;
9830 : }
9831 :
9832 : static tree
9833 1157 : get_copy_helper_pointer_type (void)
9834 : {
9835 1157 : static tree ptr_type = NULL_TREE;
9836 1157 : if (ptr_type == NULL_TREE)
9837 29 : ptr_type = build_pointer_type (get_copy_helper_function_type ());
9838 1157 : return ptr_type;
9839 : }
9840 :
9841 : static tree
9842 227 : generate_element_copy_wrapper (gfc_symbol *der_type, tree comp_type,
9843 : int purpose, int caf_mode)
9844 : {
9845 227 : tree fndecl, fntype, result_decl;
9846 227 : tree dest_parm, src_parm, dest_typed, src_typed;
9847 227 : tree der_type_ptr;
9848 227 : stmtblock_t block;
9849 227 : tree decls;
9850 227 : tree body;
9851 :
9852 227 : fntype = get_copy_helper_function_type ();
9853 :
9854 227 : fndecl = build_decl (input_location, FUNCTION_DECL,
9855 : create_tmp_var_name ("copy_element"),
9856 : fntype);
9857 :
9858 227 : TREE_STATIC (fndecl) = 1;
9859 227 : TREE_USED (fndecl) = 1;
9860 227 : DECL_ARTIFICIAL (fndecl) = 1;
9861 227 : DECL_IGNORED_P (fndecl) = 0;
9862 227 : TREE_PUBLIC (fndecl) = 0;
9863 227 : DECL_UNINLINABLE (fndecl) = 1;
9864 227 : DECL_EXTERNAL (fndecl) = 0;
9865 227 : DECL_CONTEXT (fndecl) = NULL_TREE;
9866 227 : DECL_INITIAL (fndecl) = make_node (BLOCK);
9867 227 : BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
9868 :
9869 227 : result_decl = build_decl (input_location, RESULT_DECL, NULL_TREE,
9870 : void_type_node);
9871 227 : DECL_ARTIFICIAL (result_decl) = 1;
9872 227 : DECL_IGNORED_P (result_decl) = 1;
9873 227 : DECL_CONTEXT (result_decl) = fndecl;
9874 227 : DECL_RESULT (fndecl) = result_decl;
9875 :
9876 227 : dest_parm = build_decl (input_location, PARM_DECL,
9877 : get_identifier ("dest"), pvoid_type_node);
9878 227 : src_parm = build_decl (input_location, PARM_DECL,
9879 : get_identifier ("src"), pvoid_type_node);
9880 :
9881 227 : DECL_ARTIFICIAL (dest_parm) = 1;
9882 227 : DECL_ARTIFICIAL (src_parm) = 1;
9883 227 : DECL_ARG_TYPE (dest_parm) = pvoid_type_node;
9884 227 : DECL_ARG_TYPE (src_parm) = pvoid_type_node;
9885 227 : DECL_CONTEXT (dest_parm) = fndecl;
9886 227 : DECL_CONTEXT (src_parm) = fndecl;
9887 :
9888 227 : DECL_ARGUMENTS (fndecl) = dest_parm;
9889 227 : TREE_CHAIN (dest_parm) = src_parm;
9890 :
9891 227 : push_struct_function (fndecl);
9892 227 : cfun->function_end_locus = input_location;
9893 :
9894 227 : pushlevel ();
9895 227 : gfc_init_block (&block);
9896 :
9897 227 : bool saved_generating = generating_copy_helper;
9898 227 : generating_copy_helper = true;
9899 :
9900 : /* When generating a wrapper, we need a fresh type tracking state to
9901 : avoid inheriting the parent context's seen_derived_types, which would
9902 : cause infinite recursion when the wrapper tries to handle the same
9903 : recursive type. Save elements, clear the set, generate wrapper, then
9904 : restore elements. */
9905 227 : vec<gfc_symbol *> saved_symbols = vNULL;
9906 227 : for (hash_set<gfc_symbol *>::iterator it = seen_derived_types.begin ();
9907 973 : it != seen_derived_types.end (); ++it)
9908 373 : saved_symbols.safe_push (*it);
9909 227 : seen_derived_types.empty ();
9910 :
9911 227 : der_type_ptr = build_pointer_type (comp_type);
9912 227 : dest_typed = fold_convert (der_type_ptr, dest_parm);
9913 227 : src_typed = fold_convert (der_type_ptr, src_parm);
9914 :
9915 227 : dest_typed = build_fold_indirect_ref (dest_typed);
9916 227 : src_typed = build_fold_indirect_ref (src_typed);
9917 :
9918 227 : body = structure_alloc_comps (der_type, src_typed, dest_typed,
9919 : 0, purpose, caf_mode, NULL, false);
9920 227 : gfc_add_expr_to_block (&block, body);
9921 :
9922 : /* Restore saved symbols. */
9923 227 : seen_derived_types.empty ();
9924 600 : for (unsigned i = 0; i < saved_symbols.length (); i++)
9925 373 : seen_derived_types.add (saved_symbols[i]);
9926 227 : saved_symbols.release ();
9927 227 : generating_copy_helper = saved_generating;
9928 :
9929 227 : body = gfc_finish_block (&block);
9930 227 : decls = getdecls ();
9931 :
9932 227 : poplevel (1, 1);
9933 :
9934 454 : DECL_SAVED_TREE (fndecl)
9935 227 : = fold_build3_loc (DECL_SOURCE_LOCATION (fndecl), BIND_EXPR,
9936 227 : void_type_node, decls, body, DECL_INITIAL (fndecl));
9937 :
9938 227 : pop_cfun ();
9939 :
9940 : /* Use finalize_function with no_collect=true to skip the ggc_collect
9941 : call that add_new_function would trigger. This function is called
9942 : during tree lowering of structure_alloc_comps where caller stack
9943 : frames hold locally-computed tree nodes (COMPONENT_REFs etc.) that
9944 : are not yet attached to any GC root. A collection at this point
9945 : would free those nodes and cause segfaults. PR124235. */
9946 227 : cgraph_node::finalize_function (fndecl, true);
9947 :
9948 227 : return build1 (ADDR_EXPR, get_copy_helper_pointer_type (), fndecl);
9949 : }
9950 :
9951 : static tree
9952 25615 : structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
9953 : int rank, int purpose, int caf_mode,
9954 : gfc_co_subroutines_args *args,
9955 : bool no_finalization = false)
9956 : {
9957 25615 : gfc_component *c;
9958 25615 : gfc_loopinfo loop;
9959 25615 : stmtblock_t fnblock;
9960 25615 : stmtblock_t loopbody;
9961 25615 : stmtblock_t tmpblock;
9962 25615 : tree decl_type;
9963 25615 : tree tmp;
9964 25615 : tree comp;
9965 25615 : tree dcmp;
9966 25615 : tree nelems;
9967 25615 : tree index;
9968 25615 : tree var;
9969 25615 : tree cdecl;
9970 25615 : tree ctype;
9971 25615 : tree vref, dref;
9972 25615 : tree null_cond = NULL_TREE;
9973 25615 : tree add_when_allocated;
9974 25615 : tree dealloc_fndecl;
9975 25615 : tree caf_token;
9976 25615 : gfc_symbol *vtab;
9977 25615 : int caf_dereg_mode;
9978 25615 : symbol_attribute *attr;
9979 25615 : bool deallocate_called;
9980 :
9981 25615 : gfc_init_block (&fnblock);
9982 :
9983 25615 : decl_type = TREE_TYPE (decl);
9984 :
9985 25615 : if ((POINTER_TYPE_P (decl_type))
9986 : || (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == 0))
9987 : {
9988 1569 : decl = build_fold_indirect_ref_loc (input_location, decl);
9989 : /* Deref dest in sync with decl, but only when it is not NULL. */
9990 1569 : if (dest)
9991 110 : dest = build_fold_indirect_ref_loc (input_location, dest);
9992 :
9993 : /* Update the decl_type because it got dereferenced. */
9994 1569 : decl_type = TREE_TYPE (decl);
9995 : }
9996 :
9997 : /* If this is an array of derived types with allocatable components
9998 : build a loop and recursively call this function. */
9999 25615 : if (TREE_CODE (decl_type) == ARRAY_TYPE
10000 25615 : || (GFC_DESCRIPTOR_TYPE_P (decl_type) && rank != 0))
10001 : {
10002 4697 : tmp = gfc_conv_array_data (decl);
10003 4697 : var = build_fold_indirect_ref_loc (input_location, tmp);
10004 :
10005 : /* Get the number of elements - 1 and set the counter. */
10006 4697 : if (GFC_DESCRIPTOR_TYPE_P (decl_type))
10007 : {
10008 : /* Use the descriptor for an allocatable array. Since this
10009 : is a full array reference, we only need the descriptor
10010 : information from dimension = rank. */
10011 3421 : tmp = gfc_full_array_size (&fnblock, decl, rank);
10012 3421 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
10013 : gfc_array_index_type, tmp,
10014 : gfc_index_one_node);
10015 :
10016 3421 : null_cond = gfc_conv_descriptor_data_get (decl);
10017 3421 : null_cond = fold_build2_loc (input_location, NE_EXPR,
10018 : logical_type_node, null_cond,
10019 3421 : build_int_cst (TREE_TYPE (null_cond), 0));
10020 : }
10021 : else
10022 : {
10023 : /* Otherwise use the TYPE_DOMAIN information. */
10024 1276 : tmp = array_type_nelts_minus_one (decl_type);
10025 1276 : tmp = fold_convert (gfc_array_index_type, tmp);
10026 : }
10027 :
10028 : /* Remember that this is, in fact, the no. of elements - 1. */
10029 4697 : nelems = gfc_evaluate_now (tmp, &fnblock);
10030 4697 : index = gfc_create_var (gfc_array_index_type, "S");
10031 :
10032 : /* Build the body of the loop. */
10033 4697 : gfc_init_block (&loopbody);
10034 :
10035 4697 : vref = gfc_build_array_ref (var, index, NULL);
10036 :
10037 4697 : if (purpose == COPY_ALLOC_COMP || purpose == COPY_ONLY_ALLOC_COMP)
10038 : {
10039 993 : tmp = build_fold_indirect_ref_loc (input_location,
10040 : gfc_conv_array_data (dest));
10041 993 : dref = gfc_build_array_ref (tmp, index, NULL);
10042 993 : tmp = structure_alloc_comps (der_type, vref, dref, rank,
10043 : COPY_ALLOC_COMP, caf_mode, args,
10044 : no_finalization);
10045 : }
10046 : else
10047 3704 : tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose,
10048 : caf_mode, args, no_finalization);
10049 :
10050 4697 : gfc_add_expr_to_block (&loopbody, tmp);
10051 :
10052 : /* Build the loop and return. */
10053 4697 : gfc_init_loopinfo (&loop);
10054 4697 : loop.dimen = 1;
10055 4697 : loop.from[0] = gfc_index_zero_node;
10056 4697 : loop.loopvar[0] = index;
10057 4697 : loop.to[0] = nelems;
10058 4697 : gfc_trans_scalarizing_loops (&loop, &loopbody);
10059 4697 : gfc_add_block_to_block (&fnblock, &loop.pre);
10060 :
10061 4697 : tmp = gfc_finish_block (&fnblock);
10062 : /* When copying allocateable components, the above implements the
10063 : deep copy. Nevertheless is a deep copy only allowed, when the current
10064 : component is allocated, for which code will be generated in
10065 : gfc_duplicate_allocatable (), where the deep copy code is just added
10066 : into the if's body, by adding tmp (the deep copy code) as last
10067 : argument to gfc_duplicate_allocatable (). */
10068 4697 : if (purpose == COPY_ALLOC_COMP && caf_mode == 0
10069 4697 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
10070 740 : tmp = gfc_duplicate_allocatable (dest, decl, decl_type, rank,
10071 : tmp);
10072 3957 : else if (null_cond != NULL_TREE)
10073 2681 : tmp = build3_v (COND_EXPR, null_cond, tmp,
10074 : build_empty_stmt (input_location));
10075 :
10076 4697 : return tmp;
10077 : }
10078 :
10079 20918 : if (purpose == DEALLOCATE_ALLOC_COMP && der_type->attr.pdt_type)
10080 : {
10081 833 : tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
10082 : DEALLOCATE_PDT_COMP, 0, args,
10083 : no_finalization);
10084 833 : gfc_add_expr_to_block (&fnblock, tmp);
10085 : }
10086 20085 : else if (purpose == ALLOCATE_PDT_COMP && der_type->attr.alloc_comp)
10087 : {
10088 125 : tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
10089 : NULLIFY_ALLOC_COMP, 0, args,
10090 : no_finalization);
10091 125 : gfc_add_expr_to_block (&fnblock, tmp);
10092 : }
10093 :
10094 : /* Still having a descriptor array of rank == 0 here, indicates an
10095 : allocatable coarrays. Dereference it correctly. */
10096 20918 : if (GFC_DESCRIPTOR_TYPE_P (decl_type))
10097 : {
10098 5 : decl = build_fold_indirect_ref (gfc_conv_array_data (decl));
10099 : }
10100 : /* Otherwise, act on the components or recursively call self to
10101 : act on a chain of components. */
10102 20918 : seen_derived_types.add (der_type);
10103 60415 : for (c = der_type->components; c; c = c->next)
10104 : {
10105 39497 : bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED
10106 39497 : || c->ts.type == BT_CLASS)
10107 39497 : && c->ts.u.derived->attr.alloc_comp;
10108 39497 : bool same_type
10109 : = (c->ts.type == BT_DERIVED
10110 9358 : && seen_derived_types.contains (c->ts.u.derived))
10111 46204 : || (c->ts.type == BT_CLASS
10112 2278 : && seen_derived_types.contains (CLASS_DATA (c)->ts.u.derived));
10113 39497 : bool inside_wrapper = generating_copy_helper;
10114 :
10115 39497 : bool is_pdt_type = IS_PDT (c);
10116 :
10117 39497 : cdecl = c->backend_decl;
10118 39497 : ctype = TREE_TYPE (cdecl);
10119 :
10120 39497 : switch (purpose)
10121 : {
10122 :
10123 3 : case BCAST_ALLOC_COMP:
10124 :
10125 3 : tree ubound;
10126 3 : tree cdesc;
10127 3 : stmtblock_t derived_type_block;
10128 :
10129 3 : gfc_init_block (&tmpblock);
10130 :
10131 3 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10132 : decl, cdecl, NULL_TREE);
10133 :
10134 : /* Shortcut to get the attributes of the component. */
10135 3 : if (c->ts.type == BT_CLASS)
10136 : {
10137 0 : attr = &CLASS_DATA (c)->attr;
10138 0 : if (attr->class_pointer)
10139 0 : continue;
10140 : }
10141 : else
10142 : {
10143 3 : attr = &c->attr;
10144 3 : if (attr->pointer)
10145 0 : continue;
10146 : }
10147 :
10148 : /* Do not broadcast a caf_token. These are local to the image. */
10149 3 : if (attr->caf_token)
10150 1 : continue;
10151 :
10152 2 : add_when_allocated = NULL_TREE;
10153 2 : if (cmp_has_alloc_comps
10154 0 : && !c->attr.pointer && !c->attr.proc_pointer)
10155 : {
10156 0 : if (c->ts.type == BT_CLASS)
10157 : {
10158 0 : rank = CLASS_DATA (c)->as ? CLASS_DATA (c)->as->rank : 0;
10159 0 : add_when_allocated
10160 0 : = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
10161 : comp, NULL_TREE, rank, purpose,
10162 : caf_mode, args, no_finalization);
10163 : }
10164 : else
10165 : {
10166 0 : rank = c->as ? c->as->rank : 0;
10167 0 : add_when_allocated = structure_alloc_comps (c->ts.u.derived,
10168 : comp, NULL_TREE,
10169 : rank, purpose,
10170 : caf_mode, args,
10171 : no_finalization);
10172 : }
10173 : }
10174 :
10175 2 : gfc_init_block (&derived_type_block);
10176 2 : if (add_when_allocated)
10177 0 : gfc_add_expr_to_block (&derived_type_block, add_when_allocated);
10178 2 : tmp = gfc_finish_block (&derived_type_block);
10179 2 : gfc_add_expr_to_block (&tmpblock, tmp);
10180 :
10181 : /* Convert the component into a rank 1 descriptor type. */
10182 2 : if (attr->dimension)
10183 : {
10184 0 : tmp = gfc_get_element_type (TREE_TYPE (comp));
10185 0 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
10186 0 : ubound = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (comp));
10187 : else
10188 0 : ubound = gfc_full_array_size (&tmpblock, comp,
10189 0 : c->ts.type == BT_CLASS
10190 0 : ? CLASS_DATA (c)->as->rank
10191 0 : : c->as->rank);
10192 : }
10193 : else
10194 : {
10195 2 : tmp = TREE_TYPE (comp);
10196 2 : ubound = build_int_cst (gfc_array_index_type, 1);
10197 : }
10198 :
10199 : /* Treat strings like arrays. Or the other way around, do not
10200 : * generate an additional array layer for scalar components. */
10201 2 : if (attr->dimension || c->ts.type == BT_CHARACTER)
10202 : {
10203 0 : cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node,
10204 : &ubound, 1,
10205 : GFC_ARRAY_ALLOCATABLE, false);
10206 :
10207 0 : cdesc = gfc_create_var (cdesc, "cdesc");
10208 0 : DECL_ARTIFICIAL (cdesc) = 1;
10209 :
10210 0 : gfc_conv_descriptor_dtype_set (&tmpblock, cdesc,
10211 : gfc_get_dtype_rank_type (1, tmp));
10212 0 : gfc_conv_descriptor_lbound_set (&tmpblock, cdesc,
10213 : gfc_index_zero_node,
10214 : gfc_index_one_node);
10215 0 : gfc_conv_descriptor_stride_set (&tmpblock, cdesc,
10216 : gfc_index_zero_node,
10217 : gfc_index_one_node);
10218 0 : gfc_conv_descriptor_ubound_set (&tmpblock, cdesc,
10219 : gfc_index_zero_node, ubound);
10220 : }
10221 : else
10222 : /* Prevent warning. */
10223 : cdesc = NULL_TREE;
10224 :
10225 2 : if (attr->dimension)
10226 : {
10227 0 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
10228 0 : comp = gfc_conv_descriptor_data_get (comp);
10229 : else
10230 0 : comp = gfc_build_addr_expr (NULL_TREE, comp);
10231 : }
10232 : else
10233 : {
10234 2 : gfc_se se;
10235 :
10236 2 : gfc_init_se (&se, NULL);
10237 :
10238 2 : comp = gfc_conv_scalar_to_descriptor (&se, comp,
10239 2 : c->ts.type == BT_CLASS
10240 2 : ? CLASS_DATA (c)->attr
10241 : : c->attr);
10242 2 : if (c->ts.type == BT_CHARACTER)
10243 0 : comp = gfc_build_addr_expr (NULL_TREE, comp);
10244 2 : gfc_add_block_to_block (&tmpblock, &se.pre);
10245 : }
10246 :
10247 2 : if (attr->dimension || c->ts.type == BT_CHARACTER)
10248 0 : gfc_conv_descriptor_data_set (&tmpblock, cdesc, comp);
10249 : else
10250 2 : cdesc = comp;
10251 :
10252 2 : tree fndecl;
10253 :
10254 2 : fndecl = build_call_expr_loc (input_location,
10255 : gfor_fndecl_co_broadcast, 5,
10256 : gfc_build_addr_expr (pvoid_type_node,cdesc),
10257 : args->image_index,
10258 : null_pointer_node, null_pointer_node,
10259 : null_pointer_node);
10260 :
10261 2 : gfc_add_expr_to_block (&tmpblock, fndecl);
10262 2 : gfc_add_block_to_block (&fnblock, &tmpblock);
10263 :
10264 31951 : break;
10265 :
10266 15479 : case DEALLOCATE_ALLOC_COMP:
10267 :
10268 15479 : gfc_init_block (&tmpblock);
10269 :
10270 15479 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10271 : decl, cdecl, NULL_TREE);
10272 :
10273 : /* Shortcut to get the attributes of the component. */
10274 15479 : if (c->ts.type == BT_CLASS)
10275 : {
10276 1022 : attr = &CLASS_DATA (c)->attr;
10277 1022 : if (attr->class_pointer || c->attr.proc_pointer)
10278 18 : continue;
10279 : }
10280 : else
10281 : {
10282 14457 : attr = &c->attr;
10283 14457 : if (attr->pointer || attr->proc_pointer)
10284 143 : continue;
10285 : }
10286 :
10287 15318 : if (!no_finalization && ((c->ts.type == BT_DERIVED && !c->attr.pointer)
10288 9001 : || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer)))
10289 : /* Call the finalizer, which will free the memory and nullify the
10290 : pointer of an array. */
10291 3744 : deallocate_called = gfc_add_comp_finalizer_call (&tmpblock, comp, c,
10292 3744 : caf_enabled (caf_mode))
10293 3744 : && attr->dimension;
10294 : else
10295 : deallocate_called = false;
10296 :
10297 : /* Add the _class ref for classes. */
10298 15318 : if (c->ts.type == BT_CLASS && attr->allocatable)
10299 1004 : comp = gfc_class_data_get (comp);
10300 :
10301 15318 : add_when_allocated = NULL_TREE;
10302 15318 : if (cmp_has_alloc_comps
10303 3285 : && !c->attr.pointer && !c->attr.proc_pointer
10304 : && !same_type
10305 3285 : && !deallocate_called)
10306 : {
10307 : /* Add checked deallocation of the components. This code is
10308 : obviously added because the finalizer is not trusted to free
10309 : all memory. */
10310 1987 : if (c->ts.type == BT_CLASS)
10311 : {
10312 242 : rank = CLASS_DATA (c)->as ? CLASS_DATA (c)->as->rank : 0;
10313 242 : add_when_allocated
10314 242 : = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
10315 : comp, NULL_TREE, rank, purpose,
10316 : caf_mode, args, no_finalization);
10317 : }
10318 : else
10319 : {
10320 1745 : rank = c->as ? c->as->rank : 0;
10321 1745 : add_when_allocated = structure_alloc_comps (c->ts.u.derived,
10322 : comp, NULL_TREE,
10323 : rank, purpose,
10324 : caf_mode, args,
10325 : no_finalization);
10326 : }
10327 : }
10328 :
10329 9804 : if (attr->allocatable && !same_type
10330 24099 : && (!attr->codimension || caf_enabled (caf_mode)))
10331 : {
10332 : /* Handle all types of components besides components of the
10333 : same_type as the current one, because those would create an
10334 : endless loop. */
10335 51 : caf_dereg_mode = (caf_in_coarray (caf_mode)
10336 58 : && (attr->dimension || c->caf_token))
10337 8717 : || attr->codimension
10338 8852 : ? (gfc_caf_is_dealloc_only (caf_mode)
10339 : ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
10340 : : GFC_CAF_COARRAY_DEREGISTER)
10341 : : GFC_CAF_COARRAY_NOCOARRAY;
10342 :
10343 8774 : caf_token = NULL_TREE;
10344 : /* Coarray components are handled directly by
10345 : deallocate_with_status. */
10346 8774 : if (!attr->codimension
10347 8753 : && caf_dereg_mode != GFC_CAF_COARRAY_NOCOARRAY)
10348 : {
10349 57 : if (c->caf_token)
10350 19 : caf_token
10351 19 : = fold_build3_loc (input_location, COMPONENT_REF,
10352 19 : TREE_TYPE (gfc_comp_caf_token (c)),
10353 : decl, gfc_comp_caf_token (c),
10354 : NULL_TREE);
10355 38 : else if (attr->dimension && !attr->proc_pointer)
10356 38 : caf_token = gfc_conv_descriptor_token (comp);
10357 : }
10358 :
10359 8774 : tmp = gfc_deallocate_with_status (comp, NULL_TREE, NULL_TREE,
10360 : NULL_TREE, NULL_TREE, true,
10361 : NULL, caf_dereg_mode, NULL_TREE,
10362 : add_when_allocated, caf_token);
10363 :
10364 8774 : gfc_add_expr_to_block (&tmpblock, tmp);
10365 : }
10366 6544 : else if (attr->allocatable && !attr->codimension
10367 1023 : && !deallocate_called)
10368 : {
10369 : /* Case of recursive allocatable derived types. */
10370 1023 : tree is_allocated;
10371 1023 : tree ubound;
10372 1023 : tree cdesc;
10373 1023 : stmtblock_t dealloc_block;
10374 :
10375 1023 : gfc_init_block (&dealloc_block);
10376 1023 : if (add_when_allocated)
10377 0 : gfc_add_expr_to_block (&dealloc_block, add_when_allocated);
10378 :
10379 : /* Convert the component into a rank 1 descriptor type. */
10380 1023 : if (attr->dimension)
10381 : {
10382 417 : tmp = gfc_get_element_type (TREE_TYPE (comp));
10383 417 : ubound = gfc_full_array_size (&dealloc_block, comp,
10384 417 : c->ts.type == BT_CLASS
10385 0 : ? CLASS_DATA (c)->as->rank
10386 417 : : c->as->rank);
10387 : }
10388 : else
10389 : {
10390 606 : tmp = TREE_TYPE (comp);
10391 606 : ubound = build_int_cst (gfc_array_index_type, 1);
10392 : }
10393 :
10394 1023 : cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node,
10395 : &ubound, 1,
10396 : GFC_ARRAY_ALLOCATABLE, false);
10397 :
10398 1023 : cdesc = gfc_create_var (cdesc, "cdesc");
10399 1023 : DECL_ARTIFICIAL (cdesc) = 1;
10400 :
10401 1023 : gfc_conv_descriptor_dtype_set (&dealloc_block, cdesc,
10402 : gfc_get_dtype_rank_type (1, tmp));
10403 1023 : gfc_conv_descriptor_lbound_set (&dealloc_block, cdesc,
10404 : gfc_index_zero_node,
10405 : gfc_index_one_node);
10406 1023 : gfc_conv_descriptor_stride_set (&dealloc_block, cdesc,
10407 : gfc_index_zero_node,
10408 : gfc_index_one_node);
10409 1023 : gfc_conv_descriptor_ubound_set (&dealloc_block, cdesc,
10410 : gfc_index_zero_node, ubound);
10411 :
10412 1023 : if (attr->dimension)
10413 417 : comp = gfc_conv_descriptor_data_get (comp);
10414 :
10415 1023 : gfc_conv_descriptor_data_set (&dealloc_block, cdesc, comp);
10416 :
10417 : /* Now call the deallocator. */
10418 1023 : vtab = gfc_find_vtab (&c->ts);
10419 1023 : if (vtab->backend_decl == NULL)
10420 47 : gfc_get_symbol_decl (vtab);
10421 1023 : tmp = gfc_build_addr_expr (NULL_TREE, vtab->backend_decl);
10422 1023 : dealloc_fndecl = gfc_vptr_deallocate_get (tmp);
10423 1023 : dealloc_fndecl = build_fold_indirect_ref_loc (input_location,
10424 : dealloc_fndecl);
10425 1023 : tmp = build_int_cst (TREE_TYPE (comp), 0);
10426 1023 : is_allocated = fold_build2_loc (input_location, NE_EXPR,
10427 : logical_type_node, tmp,
10428 : comp);
10429 1023 : cdesc = gfc_build_addr_expr (NULL_TREE, cdesc);
10430 :
10431 1023 : tmp = build_call_expr_loc (input_location,
10432 : dealloc_fndecl, 1,
10433 : cdesc);
10434 1023 : gfc_add_expr_to_block (&dealloc_block, tmp);
10435 :
10436 1023 : tmp = gfc_finish_block (&dealloc_block);
10437 :
10438 1023 : tmp = fold_build3_loc (input_location, COND_EXPR,
10439 : void_type_node, is_allocated, tmp,
10440 : build_empty_stmt (input_location));
10441 :
10442 1023 : gfc_add_expr_to_block (&tmpblock, tmp);
10443 1023 : }
10444 5521 : else if (add_when_allocated)
10445 991 : gfc_add_expr_to_block (&tmpblock, add_when_allocated);
10446 :
10447 1004 : if (c->ts.type == BT_CLASS && attr->allocatable
10448 16322 : && (!attr->codimension || !caf_enabled (caf_mode)))
10449 : {
10450 : /* Finally, reset the vptr to the declared type vtable and, if
10451 : necessary reset the _len field.
10452 :
10453 : First recover the reference to the component and obtain
10454 : the vptr. */
10455 989 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10456 : decl, cdecl, NULL_TREE);
10457 989 : tmp = gfc_class_vptr_get (comp);
10458 :
10459 989 : if (UNLIMITED_POLY (c))
10460 : {
10461 : /* Both vptr and _len field should be nulled. */
10462 219 : gfc_add_modify (&tmpblock, tmp,
10463 219 : build_int_cst (TREE_TYPE (tmp), 0));
10464 219 : tmp = gfc_class_len_get (comp);
10465 219 : gfc_add_modify (&tmpblock, tmp,
10466 219 : build_int_cst (TREE_TYPE (tmp), 0));
10467 : }
10468 : else
10469 : {
10470 : /* Build the vtable address and set the vptr with it. */
10471 770 : gfc_reset_vptr (&tmpblock, nullptr, tmp, c->ts.u.derived);
10472 : }
10473 : }
10474 :
10475 : /* Now add the deallocation of this component. */
10476 15318 : gfc_add_block_to_block (&fnblock, &tmpblock);
10477 15318 : break;
10478 :
10479 6155 : case NULLIFY_ALLOC_COMP:
10480 : /* Nullify
10481 : - allocatable components (regular or in class)
10482 : - components that have allocatable components
10483 : - pointer components when in a coarray.
10484 : Skip everything else especially proc_pointers, which may come
10485 : coupled with the regular pointer attribute. */
10486 8273 : if (c->attr.proc_pointer
10487 6155 : || !(c->attr.allocatable || (c->ts.type == BT_CLASS
10488 482 : && CLASS_DATA (c)->attr.allocatable)
10489 2739 : || (cmp_has_alloc_comps
10490 538 : && ((c->ts.type == BT_DERIVED && !c->attr.pointer)
10491 18 : || (c->ts.type == BT_CLASS
10492 12 : && !CLASS_DATA (c)->attr.class_pointer)))
10493 2219 : || (caf_in_coarray (caf_mode) && c->attr.pointer)))
10494 2118 : continue;
10495 :
10496 : /* Process class components first, because they always have the
10497 : pointer-attribute set which would be caught wrong else. */
10498 4037 : if (c->ts.type == BT_CLASS
10499 469 : && (CLASS_DATA (c)->attr.allocatable
10500 0 : || CLASS_DATA (c)->attr.class_pointer))
10501 : {
10502 469 : tree class_ref;
10503 :
10504 : /* Allocatable CLASS components. */
10505 469 : class_ref = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10506 : decl, cdecl, NULL_TREE);
10507 :
10508 469 : comp = gfc_class_data_get (class_ref);
10509 469 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
10510 257 : gfc_conv_descriptor_data_set (&fnblock, comp,
10511 : null_pointer_node);
10512 : else
10513 : {
10514 212 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
10515 : void_type_node, comp,
10516 212 : build_int_cst (TREE_TYPE (comp), 0));
10517 212 : gfc_add_expr_to_block (&fnblock, tmp);
10518 : }
10519 :
10520 : /* The dynamic type of a disassociated pointer or unallocated
10521 : allocatable variable is its declared type. An unlimited
10522 : polymorphic entity has no declared type. */
10523 469 : gfc_reset_vptr (&fnblock, nullptr, class_ref, c->ts.u.derived);
10524 :
10525 469 : cmp_has_alloc_comps = false;
10526 469 : }
10527 : /* Coarrays need the component to be nulled before the api-call
10528 : is made. */
10529 3568 : else if (c->attr.pointer || c->attr.allocatable)
10530 : {
10531 3048 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10532 : decl, cdecl, NULL_TREE);
10533 3048 : if (c->attr.dimension || c->attr.codimension)
10534 2175 : gfc_conv_descriptor_data_set (&fnblock, comp,
10535 : null_pointer_node);
10536 : else
10537 873 : gfc_add_modify (&fnblock, comp,
10538 873 : build_int_cst (TREE_TYPE (comp), 0));
10539 3048 : if (gfc_deferred_strlen (c, &comp))
10540 : {
10541 317 : comp = fold_build3_loc (input_location, COMPONENT_REF,
10542 317 : TREE_TYPE (comp),
10543 : decl, comp, NULL_TREE);
10544 634 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
10545 317 : TREE_TYPE (comp), comp,
10546 317 : build_int_cst (TREE_TYPE (comp), 0));
10547 317 : gfc_add_expr_to_block (&fnblock, tmp);
10548 : }
10549 : cmp_has_alloc_comps = false;
10550 : }
10551 :
10552 4037 : if (flag_coarray == GFC_FCOARRAY_LIB && caf_in_coarray (caf_mode))
10553 : {
10554 : /* Register a component of a derived type coarray with the
10555 : coarray library. Do not register ultimate component
10556 : coarrays here. They are treated like regular coarrays and
10557 : are either allocated on all images or on none. */
10558 132 : tree token;
10559 :
10560 132 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10561 : decl, cdecl, NULL_TREE);
10562 132 : if (c->attr.dimension)
10563 : {
10564 : /* Set the dtype, because caf_register needs it. */
10565 104 : tree dtype_val = gfc_get_dtype (TREE_TYPE (comp));
10566 104 : gfc_conv_descriptor_dtype_set (&fnblock, comp, dtype_val);
10567 104 : tmp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10568 : decl, cdecl, NULL_TREE);
10569 104 : token = gfc_conv_descriptor_token (tmp);
10570 : }
10571 : else
10572 : {
10573 28 : gfc_se se;
10574 :
10575 28 : gfc_init_se (&se, NULL);
10576 56 : token = fold_build3_loc (input_location, COMPONENT_REF,
10577 : pvoid_type_node, decl,
10578 28 : gfc_comp_caf_token (c), NULL_TREE);
10579 28 : comp = gfc_conv_scalar_to_descriptor (&se, comp,
10580 28 : c->ts.type == BT_CLASS
10581 28 : ? CLASS_DATA (c)->attr
10582 : : c->attr);
10583 28 : gfc_add_block_to_block (&fnblock, &se.pre);
10584 : }
10585 :
10586 132 : gfc_allocate_using_caf_lib (&fnblock, comp, size_zero_node,
10587 : gfc_build_addr_expr (NULL_TREE,
10588 : token),
10589 : NULL_TREE, NULL_TREE, NULL_TREE,
10590 : GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
10591 : }
10592 :
10593 4037 : if (cmp_has_alloc_comps)
10594 : {
10595 520 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10596 : decl, cdecl, NULL_TREE);
10597 520 : rank = c->as ? c->as->rank : 0;
10598 520 : tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
10599 : rank, purpose, caf_mode, args,
10600 : no_finalization);
10601 520 : gfc_add_expr_to_block (&fnblock, tmp);
10602 : }
10603 : break;
10604 :
10605 30 : case REASSIGN_CAF_COMP:
10606 30 : if (caf_enabled (caf_mode)
10607 30 : && (c->attr.codimension
10608 23 : || (c->ts.type == BT_CLASS
10609 2 : && (CLASS_DATA (c)->attr.coarray_comp
10610 2 : || caf_in_coarray (caf_mode)))
10611 21 : || (c->ts.type == BT_DERIVED
10612 7 : && (c->ts.u.derived->attr.coarray_comp
10613 6 : || caf_in_coarray (caf_mode))))
10614 46 : && !same_type)
10615 : {
10616 14 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10617 : decl, cdecl, NULL_TREE);
10618 14 : dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10619 : dest, cdecl, NULL_TREE);
10620 :
10621 14 : if (c->attr.codimension)
10622 : {
10623 7 : if (c->ts.type == BT_CLASS)
10624 : {
10625 0 : comp = gfc_class_data_get (comp);
10626 0 : dcmp = gfc_class_data_get (dcmp);
10627 : }
10628 7 : gfc_conv_descriptor_data_set (&fnblock, dcmp,
10629 : gfc_conv_descriptor_data_get (comp));
10630 : }
10631 : else
10632 : {
10633 7 : tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
10634 : rank, purpose, caf_mode
10635 : | GFC_STRUCTURE_CAF_MODE_IN_COARRAY,
10636 : args, no_finalization);
10637 7 : gfc_add_expr_to_block (&fnblock, tmp);
10638 : }
10639 : }
10640 : break;
10641 :
10642 11947 : case COPY_ALLOC_COMP:
10643 11947 : if (c->attr.pointer || c->attr.proc_pointer)
10644 153 : continue;
10645 :
10646 : /* We need source and destination components. */
10647 11794 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl,
10648 : cdecl, NULL_TREE);
10649 11794 : dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, dest,
10650 : cdecl, NULL_TREE);
10651 11794 : dcmp = fold_convert (TREE_TYPE (comp), dcmp);
10652 :
10653 11794 : if (IS_PDT (c) && !c->attr.allocatable)
10654 : {
10655 117 : tmp = gfc_copy_alloc_comp (c->ts.u.derived, comp, dcmp,
10656 : 0, 0);
10657 117 : gfc_add_expr_to_block (&fnblock, tmp);
10658 117 : continue;
10659 : }
10660 :
10661 11677 : if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
10662 : {
10663 744 : tree ftn_tree;
10664 744 : tree size;
10665 744 : tree dst_data;
10666 744 : tree src_data;
10667 744 : tree null_data;
10668 :
10669 744 : dst_data = gfc_class_data_get (dcmp);
10670 744 : src_data = gfc_class_data_get (comp);
10671 744 : size = fold_convert (size_type_node,
10672 : gfc_class_vtab_size_get (comp));
10673 :
10674 744 : if (CLASS_DATA (c)->attr.dimension)
10675 : {
10676 728 : nelems = gfc_conv_descriptor_size (src_data,
10677 364 : CLASS_DATA (c)->as->rank);
10678 364 : size = fold_build2_loc (input_location, MULT_EXPR,
10679 : size_type_node, size,
10680 : fold_convert (size_type_node,
10681 : nelems));
10682 : }
10683 : else
10684 380 : nelems = build_int_cst (size_type_node, 1);
10685 :
10686 744 : if (CLASS_DATA (c)->attr.dimension
10687 380 : || CLASS_DATA (c)->attr.codimension)
10688 : {
10689 372 : src_data = gfc_conv_descriptor_data_get (src_data);
10690 372 : dst_data = gfc_conv_descriptor_data_get (dst_data);
10691 : }
10692 :
10693 744 : gfc_init_block (&tmpblock);
10694 :
10695 744 : gfc_add_modify (&tmpblock, gfc_class_vptr_get (dcmp),
10696 : gfc_class_vptr_get (comp));
10697 :
10698 : /* Copy the unlimited '_len' field. If it is greater than zero
10699 : (ie. a character(_len)), multiply it by size and use this
10700 : for the malloc call. */
10701 744 : if (UNLIMITED_POLY (c))
10702 : {
10703 146 : gfc_add_modify (&tmpblock, gfc_class_len_get (dcmp),
10704 : gfc_class_len_get (comp));
10705 146 : size = gfc_resize_class_size_with_len (&tmpblock, comp, size);
10706 : }
10707 :
10708 : /* Coarray component have to have the same allocation status and
10709 : shape/type-parameter/effective-type on the LHS and RHS of an
10710 : intrinsic assignment. Hence, we did not deallocated them - and
10711 : do not allocate them here. */
10712 744 : if (!CLASS_DATA (c)->attr.codimension)
10713 : {
10714 729 : ftn_tree = builtin_decl_explicit (BUILT_IN_MALLOC);
10715 729 : tmp = build_call_expr_loc (input_location, ftn_tree, 1, size);
10716 729 : gfc_add_modify (&tmpblock, dst_data,
10717 729 : fold_convert (TREE_TYPE (dst_data), tmp));
10718 : }
10719 :
10720 1473 : tmp = gfc_copy_class_to_class (comp, dcmp, nelems,
10721 744 : UNLIMITED_POLY (c));
10722 744 : gfc_add_expr_to_block (&tmpblock, tmp);
10723 744 : tmp = gfc_finish_block (&tmpblock);
10724 :
10725 744 : gfc_init_block (&tmpblock);
10726 744 : gfc_add_modify (&tmpblock, dst_data,
10727 744 : fold_convert (TREE_TYPE (dst_data),
10728 : null_pointer_node));
10729 744 : null_data = gfc_finish_block (&tmpblock);
10730 :
10731 744 : null_cond = fold_build2_loc (input_location, NE_EXPR,
10732 : logical_type_node, src_data,
10733 : null_pointer_node);
10734 :
10735 744 : gfc_add_expr_to_block (&fnblock, build3_v (COND_EXPR, null_cond,
10736 : tmp, null_data));
10737 744 : continue;
10738 744 : }
10739 :
10740 : /* To implement guarded deep copy, i.e., deep copy only allocatable
10741 : components that are really allocated, the deep copy code has to
10742 : be generated first and then added to the if-block in
10743 : gfc_duplicate_allocatable (). */
10744 10933 : if (cmp_has_alloc_comps && !c->attr.proc_pointer && !same_type)
10745 : {
10746 1680 : rank = c->as ? c->as->rank : 0;
10747 1680 : tmp = fold_convert (TREE_TYPE (dcmp), comp);
10748 1680 : gfc_add_modify (&fnblock, dcmp, tmp);
10749 1680 : add_when_allocated = structure_alloc_comps (c->ts.u.derived,
10750 : comp, dcmp,
10751 : rank, purpose,
10752 : caf_mode, args,
10753 : no_finalization);
10754 : }
10755 : else
10756 : add_when_allocated = NULL_TREE;
10757 :
10758 10933 : if (gfc_deferred_strlen (c, &tmp))
10759 : {
10760 411 : tree len, size;
10761 411 : len = tmp;
10762 411 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
10763 411 : TREE_TYPE (len),
10764 : decl, len, NULL_TREE);
10765 411 : len = fold_build3_loc (input_location, COMPONENT_REF,
10766 411 : TREE_TYPE (len),
10767 : dest, len, NULL_TREE);
10768 411 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
10769 411 : TREE_TYPE (len), len, tmp);
10770 411 : gfc_add_expr_to_block (&fnblock, tmp);
10771 411 : size = size_of_string_in_bytes (c->ts.kind, len);
10772 : /* This component cannot have allocatable components,
10773 : therefore add_when_allocated of duplicate_allocatable ()
10774 : is always NULL. */
10775 411 : rank = c->as ? c->as->rank : 0;
10776 411 : tmp = duplicate_allocatable (dcmp, comp, ctype, rank,
10777 : false, false, size, NULL_TREE);
10778 411 : gfc_add_expr_to_block (&fnblock, tmp);
10779 : }
10780 10522 : else if (c->attr.pdt_array
10781 175 : && !c->attr.allocatable && !c->attr.pointer)
10782 : {
10783 175 : tmp = duplicate_allocatable (dcmp, comp, ctype,
10784 175 : c->as ? c->as->rank : 0,
10785 : false, false, NULL_TREE, NULL_TREE);
10786 175 : gfc_add_expr_to_block (&fnblock, tmp);
10787 : }
10788 : /* Special case: recursive allocatable array components require
10789 : runtime helpers to avoid compile-time infinite recursion. Generate
10790 : a call to _gfortran_cfi_deep_copy_array with an element copy
10791 : wrapper. When inside a wrapper, reuse current_function_decl. */
10792 6291 : else if (c->attr.allocatable && c->as && cmp_has_alloc_comps && same_type
10793 930 : && purpose == COPY_ALLOC_COMP && !c->attr.proc_pointer
10794 930 : && !c->attr.codimension && !caf_in_coarray (caf_mode)
10795 11277 : && c->ts.type == BT_DERIVED && c->ts.u.derived != NULL)
10796 : {
10797 930 : tree copy_wrapper, call, dest_addr, src_addr, elem_type;
10798 930 : tree helper_ptr_type;
10799 930 : tree alloc_expr;
10800 930 : int comp_rank;
10801 :
10802 : /* Get the element type from ctype (already the component
10803 : type). For arrays we need the element type, not the array
10804 : type. */
10805 930 : elem_type = ctype;
10806 930 : if (GFC_DESCRIPTOR_TYPE_P (ctype))
10807 930 : elem_type = gfc_get_element_type (ctype);
10808 0 : else if (TREE_CODE (ctype) == ARRAY_TYPE)
10809 0 : elem_type = TREE_TYPE (ctype);
10810 :
10811 930 : helper_ptr_type = get_copy_helper_pointer_type ();
10812 :
10813 930 : comp_rank = c->as ? c->as->rank : 0;
10814 930 : alloc_expr = gfc_duplicate_allocatable_nocopy (dcmp, comp, ctype,
10815 : comp_rank);
10816 930 : gfc_add_expr_to_block (&fnblock, alloc_expr);
10817 :
10818 : /* Generate or reuse the element copy helper. Inside an
10819 : existing helper we can reuse the current function to
10820 : prevent recursive generation. */
10821 930 : if (inside_wrapper)
10822 703 : copy_wrapper
10823 703 : = gfc_build_addr_expr (NULL_TREE, current_function_decl);
10824 : else
10825 227 : copy_wrapper
10826 227 : = generate_element_copy_wrapper (c->ts.u.derived, elem_type,
10827 : purpose, caf_mode);
10828 930 : copy_wrapper = fold_convert (helper_ptr_type, copy_wrapper);
10829 :
10830 : /* Build addresses of descriptors. */
10831 930 : dest_addr = gfc_build_addr_expr (pvoid_type_node, dcmp);
10832 930 : src_addr = gfc_build_addr_expr (pvoid_type_node, comp);
10833 :
10834 : /* Build call: _gfortran_cfi_deep_copy_array (&dcmp, &comp,
10835 : wrapper). */
10836 930 : call = build_call_expr_loc (input_location,
10837 : gfor_fndecl_cfi_deep_copy_array, 3,
10838 : dest_addr, src_addr,
10839 : copy_wrapper);
10840 930 : gfc_add_expr_to_block (&fnblock, call);
10841 : }
10842 : /* For allocatable arrays with nested allocatable components,
10843 : add_when_allocated already includes gfc_duplicate_allocatable
10844 : (from the recursive structure_alloc_comps call at line 10290-10293),
10845 : so we must not call it again here. PR121628 added an
10846 : add_when_allocated != NULL clause that was redundant for scalars
10847 : (already handled by !c->as) and wrong for arrays (double alloc). */
10848 5361 : else if (c->attr.allocatable && !c->attr.proc_pointer
10849 14778 : && (!cmp_has_alloc_comps
10850 810 : || !c->as
10851 585 : || c->attr.codimension
10852 582 : || caf_in_coarray (caf_mode)))
10853 : {
10854 4785 : rank = c->as ? c->as->rank : 0;
10855 4785 : if (c->attr.codimension)
10856 20 : tmp = gfc_copy_allocatable_data (dcmp, comp, ctype, rank);
10857 4765 : else if (flag_coarray == GFC_FCOARRAY_LIB
10858 4765 : && caf_in_coarray (caf_mode))
10859 : {
10860 62 : tree dst_tok;
10861 62 : if (c->as)
10862 44 : dst_tok = gfc_conv_descriptor_token (dcmp);
10863 : else
10864 : {
10865 18 : dst_tok
10866 18 : = fold_build3_loc (input_location, COMPONENT_REF,
10867 : pvoid_type_node, dest,
10868 18 : gfc_comp_caf_token (c), NULL_TREE);
10869 : }
10870 62 : tmp
10871 62 : = duplicate_allocatable_coarray (dcmp, dst_tok, comp, ctype,
10872 : rank, add_when_allocated);
10873 : }
10874 : else
10875 4703 : tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank,
10876 : add_when_allocated);
10877 4785 : gfc_add_expr_to_block (&fnblock, tmp);
10878 : }
10879 : else
10880 4632 : if (cmp_has_alloc_comps || is_pdt_type)
10881 1721 : gfc_add_expr_to_block (&fnblock, add_when_allocated);
10882 :
10883 : break;
10884 :
10885 1954 : case ALLOCATE_PDT_COMP:
10886 :
10887 1954 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10888 : decl, cdecl, NULL_TREE);
10889 :
10890 : /* Set the PDT KIND and LEN fields. */
10891 1954 : if (c->attr.pdt_kind || c->attr.pdt_len)
10892 : {
10893 895 : gfc_se tse;
10894 895 : gfc_expr *c_expr = NULL;
10895 895 : gfc_actual_arglist *param = pdt_param_list;
10896 895 : gfc_init_se (&tse, NULL);
10897 3219 : for (; param; param = param->next)
10898 1429 : if (param->name && !strcmp (c->name, param->name))
10899 883 : c_expr = param->expr;
10900 :
10901 895 : if (!c_expr)
10902 30 : c_expr = c->initializer;
10903 :
10904 30 : if (c_expr)
10905 : {
10906 877 : gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp));
10907 877 : gfc_add_block_to_block (&fnblock, &tse.pre);
10908 877 : gfc_add_modify (&fnblock, comp, tse.expr);
10909 877 : gfc_add_block_to_block (&fnblock, &tse.post);
10910 : }
10911 895 : }
10912 1059 : else if (c->initializer && !c->attr.pdt_string && !c->attr.pdt_array
10913 145 : && !c->as && !IS_PDT (c)) /* Take care of arrays. */
10914 : {
10915 49 : gfc_se tse;
10916 49 : gfc_expr *c_expr;
10917 49 : gfc_init_se (&tse, NULL);
10918 49 : c_expr = c->initializer;
10919 49 : gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp));
10920 49 : gfc_add_block_to_block (&fnblock, &tse.pre);
10921 49 : gfc_add_modify (&fnblock, comp, tse.expr);
10922 49 : gfc_add_block_to_block (&fnblock, &tse.post);
10923 : }
10924 :
10925 1954 : if (c->attr.pdt_string)
10926 : {
10927 90 : gfc_se tse;
10928 90 : gfc_init_se (&tse, NULL);
10929 90 : tree strlen = NULL_TREE;
10930 90 : gfc_expr *e = gfc_copy_expr (c->ts.u.cl->length);
10931 : /* Convert the parameterized string length to its value. The
10932 : string length is stored in a hidden field in the same way as
10933 : deferred string lengths. */
10934 90 : gfc_insert_parameter_exprs (e, pdt_param_list);
10935 90 : if (gfc_deferred_strlen (c, &strlen) && strlen != NULL_TREE)
10936 : {
10937 90 : gfc_conv_expr_type (&tse, e,
10938 90 : TREE_TYPE (strlen));
10939 90 : strlen = fold_build3_loc (input_location, COMPONENT_REF,
10940 90 : TREE_TYPE (strlen),
10941 : decl, strlen, NULL_TREE);
10942 90 : gfc_add_block_to_block (&fnblock, &tse.pre);
10943 90 : gfc_add_modify (&fnblock, strlen, tse.expr);
10944 90 : gfc_add_block_to_block (&fnblock, &tse.post);
10945 90 : c->ts.u.cl->backend_decl = strlen;
10946 : }
10947 90 : gfc_free_expr (e);
10948 :
10949 : /* Scalar parameterized strings can be allocated now. */
10950 90 : if (!c->as)
10951 : {
10952 90 : tmp = fold_convert (gfc_array_index_type, strlen);
10953 90 : tmp = size_of_string_in_bytes (c->ts.kind, tmp);
10954 90 : tmp = gfc_evaluate_now (tmp, &fnblock);
10955 90 : tmp = gfc_call_malloc (&fnblock, TREE_TYPE (comp), tmp);
10956 90 : gfc_add_modify (&fnblock, comp, tmp);
10957 : }
10958 : }
10959 :
10960 : /* Allocate parameterized arrays of parameterized derived types. */
10961 1954 : if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT)
10962 1673 : && !(IS_PDT (c) || IS_CLASS_PDT (c)))
10963 1487 : continue;
10964 :
10965 467 : if (c->ts.type == BT_CLASS)
10966 0 : comp = gfc_class_data_get (comp);
10967 :
10968 467 : if (c->attr.pdt_array)
10969 : {
10970 281 : gfc_se tse;
10971 281 : int i;
10972 281 : tree size = gfc_index_one_node;
10973 281 : tree offset = gfc_index_zero_node;
10974 281 : tree lower, upper;
10975 281 : gfc_expr *e;
10976 :
10977 : /* This chunk takes the expressions for 'lower' and 'upper'
10978 : in the arrayspec and substitutes in the expressions for
10979 : the parameters from 'pdt_param_list'. The descriptor
10980 : fields can then be filled from the values so obtained. */
10981 281 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)));
10982 664 : for (i = 0; i < c->as->rank; i++)
10983 : {
10984 383 : gfc_init_se (&tse, NULL);
10985 383 : e = gfc_copy_expr (c->as->lower[i]);
10986 383 : gfc_insert_parameter_exprs (e, pdt_param_list);
10987 383 : gfc_conv_expr_type (&tse, e, gfc_array_index_type);
10988 383 : gfc_free_expr (e);
10989 383 : lower = tse.expr;
10990 383 : gfc_add_block_to_block (&fnblock, &tse.pre);
10991 383 : gfc_conv_descriptor_lbound_set (&fnblock, comp,
10992 : gfc_rank_cst[i],
10993 : lower);
10994 383 : gfc_add_block_to_block (&fnblock, &tse.post);
10995 383 : e = gfc_copy_expr (c->as->upper[i]);
10996 383 : gfc_insert_parameter_exprs (e, pdt_param_list);
10997 383 : gfc_conv_expr_type (&tse, e, gfc_array_index_type);
10998 383 : gfc_free_expr (e);
10999 383 : upper = tse.expr;
11000 383 : gfc_add_block_to_block (&fnblock, &tse.pre);
11001 383 : gfc_conv_descriptor_ubound_set (&fnblock, comp,
11002 : gfc_rank_cst[i],
11003 : upper);
11004 383 : gfc_add_block_to_block (&fnblock, &tse.post);
11005 383 : gfc_conv_descriptor_stride_set (&fnblock, comp,
11006 : gfc_rank_cst[i],
11007 : size);
11008 383 : size = gfc_evaluate_now (size, &fnblock);
11009 383 : offset = fold_build2_loc (input_location,
11010 : MINUS_EXPR,
11011 : gfc_array_index_type,
11012 : offset, size);
11013 383 : offset = gfc_evaluate_now (offset, &fnblock);
11014 383 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
11015 : gfc_array_index_type,
11016 : upper, lower);
11017 383 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
11018 : gfc_array_index_type,
11019 : tmp, gfc_index_one_node);
11020 383 : size = fold_build2_loc (input_location, MULT_EXPR,
11021 : gfc_array_index_type, size, tmp);
11022 : }
11023 281 : gfc_conv_descriptor_offset_set (&fnblock, comp, offset);
11024 281 : if (c->ts.type == BT_CLASS)
11025 : {
11026 0 : tmp = gfc_get_vptr_from_expr (comp);
11027 0 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
11028 0 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
11029 0 : tmp = gfc_vptr_size_get (tmp);
11030 : }
11031 : else
11032 281 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (ctype));
11033 281 : tmp = fold_convert (gfc_array_index_type, tmp);
11034 281 : size = fold_build2_loc (input_location, MULT_EXPR,
11035 : gfc_array_index_type, size, tmp);
11036 281 : size = gfc_evaluate_now (size, &fnblock);
11037 281 : tmp = gfc_call_malloc (&fnblock, NULL, size);
11038 281 : gfc_conv_descriptor_data_set (&fnblock, comp, tmp);
11039 281 : gfc_conv_descriptor_dtype_set (&fnblock, comp,
11040 : gfc_get_dtype (ctype));
11041 :
11042 281 : if (c->initializer && c->initializer->rank)
11043 : {
11044 0 : gfc_init_se (&tse, NULL);
11045 0 : e = gfc_copy_expr (c->initializer);
11046 0 : gfc_insert_parameter_exprs (e, pdt_param_list);
11047 0 : gfc_conv_expr_descriptor (&tse, e);
11048 0 : gfc_add_block_to_block (&fnblock, &tse.pre);
11049 0 : gfc_free_expr (e);
11050 0 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
11051 0 : tmp = build_call_expr_loc (input_location, tmp, 3,
11052 : gfc_conv_descriptor_data_get (comp),
11053 : gfc_conv_descriptor_data_get (tse.expr),
11054 : fold_convert (size_type_node, size));
11055 0 : gfc_add_expr_to_block (&fnblock, tmp);
11056 0 : gfc_add_block_to_block (&fnblock, &tse.post);
11057 : }
11058 : }
11059 :
11060 : /* Recurse in to PDT components. */
11061 467 : if ((IS_PDT (c) || IS_CLASS_PDT (c))
11062 200 : && !(c->attr.pointer || c->attr.allocatable))
11063 : {
11064 104 : gfc_actual_arglist *tail = c->param_list;
11065 :
11066 262 : for (; tail; tail = tail->next)
11067 158 : if (tail->expr)
11068 134 : gfc_insert_parameter_exprs (tail->expr, pdt_param_list);
11069 :
11070 104 : tmp = gfc_allocate_pdt_comp (c->ts.u.derived, comp,
11071 104 : c->as ? c->as->rank : 0,
11072 104 : c->param_list);
11073 104 : gfc_add_expr_to_block (&fnblock, tmp);
11074 : }
11075 :
11076 : break;
11077 :
11078 3593 : case DEALLOCATE_PDT_COMP:
11079 : /* Deallocate array or parameterized string length components
11080 : of parameterized derived types. */
11081 3593 : if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT)
11082 3051 : && !c->attr.pdt_string
11083 2943 : && !(IS_PDT (c) || IS_CLASS_PDT (c)))
11084 2479 : continue;
11085 :
11086 1114 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
11087 : decl, cdecl, NULL_TREE);
11088 1114 : if (c->ts.type == BT_CLASS)
11089 0 : comp = gfc_class_data_get (comp);
11090 :
11091 : /* Recurse in to PDT components. */
11092 1114 : if ((IS_PDT (c) || IS_CLASS_PDT (c))
11093 502 : && (!c->attr.pointer && !c->attr.allocatable))
11094 : {
11095 335 : tmp = gfc_deallocate_pdt_comp (c->ts.u.derived, comp,
11096 335 : c->as ? c->as->rank : 0);
11097 335 : gfc_add_expr_to_block (&fnblock, tmp);
11098 : }
11099 :
11100 1114 : if (c->attr.pdt_array || c->attr.pdt_string)
11101 : {
11102 650 : tmp = comp;
11103 650 : if (c->attr.pdt_array)
11104 542 : tmp = gfc_conv_descriptor_data_get (comp);
11105 650 : null_cond = fold_build2_loc (input_location, NE_EXPR,
11106 : logical_type_node, tmp,
11107 650 : build_int_cst (TREE_TYPE (tmp), 0));
11108 650 : if (flag_openmp_allocators)
11109 : {
11110 0 : tree cd, t;
11111 0 : if (c->attr.pdt_array)
11112 : {
11113 0 : tree version_val = gfc_conv_descriptor_version_get (comp);
11114 0 : cd = fold_build2_loc (input_location, EQ_EXPR,
11115 : boolean_type_node, version_val,
11116 : integer_one_node);
11117 : }
11118 : else
11119 0 : cd = gfc_omp_call_is_alloc (tmp);
11120 0 : t = builtin_decl_explicit (BUILT_IN_GOMP_FREE);
11121 0 : t = build_call_expr_loc (input_location, t, 1, tmp);
11122 :
11123 0 : stmtblock_t tblock;
11124 0 : gfc_init_block (&tblock);
11125 0 : gfc_add_expr_to_block (&tblock, t);
11126 0 : if (c->attr.pdt_array)
11127 0 : gfc_conv_descriptor_version_set (&tblock, comp,
11128 : integer_zero_node);
11129 0 : tmp = build3_loc (input_location, COND_EXPR, void_type_node,
11130 : cd, gfc_finish_block (&tblock),
11131 : gfc_call_free (tmp));
11132 : }
11133 : else
11134 650 : tmp = gfc_call_free (tmp);
11135 650 : tmp = build3_v (COND_EXPR, null_cond, tmp,
11136 : build_empty_stmt (input_location));
11137 650 : gfc_add_expr_to_block (&fnblock, tmp);
11138 :
11139 650 : if (c->attr.pdt_array)
11140 542 : gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
11141 : else
11142 : {
11143 108 : tmp = fold_convert (TREE_TYPE (comp), null_pointer_node);
11144 108 : gfc_add_modify (&fnblock, comp, tmp);
11145 : }
11146 : }
11147 :
11148 : break;
11149 :
11150 336 : case CHECK_PDT_DUMMY:
11151 :
11152 336 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
11153 : decl, cdecl, NULL_TREE);
11154 336 : if (c->ts.type == BT_CLASS)
11155 0 : comp = gfc_class_data_get (comp);
11156 :
11157 : /* Recurse in to PDT components. */
11158 336 : if (((c->ts.type == BT_DERIVED
11159 14 : && !c->attr.allocatable && !c->attr.pointer)
11160 324 : || (c->ts.type == BT_CLASS
11161 0 : && !CLASS_DATA (c)->attr.allocatable
11162 0 : && !CLASS_DATA (c)->attr.pointer))
11163 12 : && c->ts.u.derived && c->ts.u.derived->attr.pdt_type)
11164 : {
11165 12 : tmp = gfc_check_pdt_dummy (c->ts.u.derived, comp,
11166 12 : c->as ? c->as->rank : 0,
11167 : pdt_param_list);
11168 12 : gfc_add_expr_to_block (&fnblock, tmp);
11169 : }
11170 :
11171 336 : if (!c->attr.pdt_len)
11172 288 : continue;
11173 : else
11174 : {
11175 48 : gfc_se tse;
11176 48 : gfc_expr *c_expr = NULL;
11177 48 : gfc_actual_arglist *param = pdt_param_list;
11178 :
11179 48 : gfc_init_se (&tse, NULL);
11180 186 : for (; param; param = param->next)
11181 90 : if (!strcmp (c->name, param->name)
11182 48 : && param->spec_type == SPEC_EXPLICIT)
11183 30 : c_expr = param->expr;
11184 :
11185 48 : if (c_expr)
11186 : {
11187 30 : tree error, cond, cname;
11188 30 : gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp));
11189 30 : cond = fold_build2_loc (input_location, NE_EXPR,
11190 : logical_type_node,
11191 : comp, tse.expr);
11192 30 : cname = gfc_build_cstring_const (c->name);
11193 30 : cname = gfc_build_addr_expr (pchar_type_node, cname);
11194 30 : error = gfc_trans_runtime_error (true, NULL,
11195 : "The value of the PDT LEN "
11196 : "parameter '%s' does not "
11197 : "agree with that in the "
11198 : "dummy declaration",
11199 : cname);
11200 30 : tmp = fold_build3_loc (input_location, COND_EXPR,
11201 : void_type_node, cond, error,
11202 : build_empty_stmt (input_location));
11203 30 : gfc_add_expr_to_block (&fnblock, tmp);
11204 : }
11205 : }
11206 48 : break;
11207 :
11208 0 : default:
11209 0 : gcc_unreachable ();
11210 7548 : break;
11211 : }
11212 : }
11213 20918 : seen_derived_types.remove (der_type);
11214 :
11215 20918 : return gfc_finish_block (&fnblock);
11216 : }
11217 :
11218 : /* Recursively traverse an object of derived type, generating code to
11219 : nullify allocatable components. */
11220 :
11221 : tree
11222 3126 : gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
11223 : int caf_mode)
11224 : {
11225 3126 : return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11226 : NULLIFY_ALLOC_COMP,
11227 : GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode,
11228 3126 : NULL);
11229 : }
11230 :
11231 :
11232 : /* Recursively traverse an object of derived type, generating code to
11233 : deallocate allocatable components. */
11234 :
11235 : tree
11236 3008 : gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
11237 : int caf_mode, bool no_finalization)
11238 : {
11239 3008 : return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11240 : DEALLOCATE_ALLOC_COMP,
11241 : GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode,
11242 3008 : NULL, no_finalization);
11243 : }
11244 :
11245 : tree
11246 1 : gfc_bcast_alloc_comp (gfc_symbol *derived, gfc_expr *expr, int rank,
11247 : tree image_index, tree stat, tree errmsg,
11248 : tree errmsg_len)
11249 : {
11250 1 : tree tmp, array;
11251 1 : gfc_se argse;
11252 1 : stmtblock_t block, post_block;
11253 1 : gfc_co_subroutines_args args;
11254 :
11255 1 : args.image_index = image_index;
11256 1 : args.stat = stat;
11257 1 : args.errmsg = errmsg;
11258 1 : args.errmsg_len = errmsg_len;
11259 :
11260 1 : if (rank == 0)
11261 : {
11262 1 : gfc_start_block (&block);
11263 1 : gfc_init_block (&post_block);
11264 1 : gfc_init_se (&argse, NULL);
11265 1 : gfc_conv_expr (&argse, expr);
11266 1 : gfc_add_block_to_block (&block, &argse.pre);
11267 1 : gfc_add_block_to_block (&post_block, &argse.post);
11268 1 : array = argse.expr;
11269 : }
11270 : else
11271 : {
11272 0 : gfc_init_se (&argse, NULL);
11273 0 : argse.want_pointer = 1;
11274 0 : gfc_conv_expr_descriptor (&argse, expr);
11275 0 : array = argse.expr;
11276 : }
11277 :
11278 1 : tmp = structure_alloc_comps (derived, array, NULL_TREE, rank,
11279 : BCAST_ALLOC_COMP,
11280 : GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY,
11281 : &args);
11282 1 : return tmp;
11283 : }
11284 :
11285 : /* Recursively traverse an object of derived type, generating code to
11286 : deallocate allocatable components. But do not deallocate coarrays.
11287 : To be used for intrinsic assignment, which may not change the allocation
11288 : status of coarrays. */
11289 :
11290 : tree
11291 3497 : gfc_deallocate_alloc_comp_no_caf (gfc_symbol * der_type, tree decl, int rank,
11292 : bool no_finalization)
11293 : {
11294 3497 : return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11295 : DEALLOCATE_ALLOC_COMP, 0, NULL,
11296 3497 : no_finalization);
11297 : }
11298 :
11299 :
11300 : tree
11301 5 : gfc_reassign_alloc_comp_caf (gfc_symbol *der_type, tree decl, tree dest)
11302 : {
11303 5 : return structure_alloc_comps (der_type, decl, dest, 0, REASSIGN_CAF_COMP,
11304 : GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY,
11305 5 : NULL);
11306 : }
11307 :
11308 :
11309 : /* Recursively traverse an object of derived type, generating code to
11310 : copy it and its allocatable components. */
11311 :
11312 : tree
11313 4490 : gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank,
11314 : int caf_mode)
11315 : {
11316 4490 : return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP,
11317 4490 : caf_mode, NULL);
11318 : }
11319 :
11320 :
11321 : /* Recursively traverse an object of derived type, generating code to
11322 : copy it and its allocatable components, while suppressing any
11323 : finalization that might occur. This is used in the finalization of
11324 : function results. */
11325 :
11326 : tree
11327 38 : gfc_copy_alloc_comp_no_fini (gfc_symbol * der_type, tree decl, tree dest,
11328 : int rank, int caf_mode)
11329 : {
11330 38 : return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP,
11331 38 : caf_mode, NULL, true);
11332 : }
11333 :
11334 :
11335 : /* Recursively traverse an object of derived type, generating code to
11336 : copy only its allocatable components. */
11337 :
11338 : tree
11339 0 : gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
11340 : {
11341 0 : return structure_alloc_comps (der_type, decl, dest, rank,
11342 0 : COPY_ONLY_ALLOC_COMP, 0, NULL);
11343 : }
11344 :
11345 :
11346 : /* Recursively traverse an object of parameterized derived type, generating
11347 : code to allocate parameterized components. */
11348 :
11349 : tree
11350 711 : gfc_allocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank,
11351 : gfc_actual_arglist *param_list)
11352 : {
11353 711 : tree res;
11354 711 : gfc_actual_arglist *old_param_list = pdt_param_list;
11355 711 : pdt_param_list = param_list;
11356 711 : res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11357 : ALLOCATE_PDT_COMP, 0, NULL);
11358 711 : pdt_param_list = old_param_list;
11359 711 : return res;
11360 : }
11361 :
11362 : /* Recursively traverse an object of parameterized derived type, generating
11363 : code to deallocate parameterized components. */
11364 :
11365 : tree
11366 1316 : gfc_deallocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank)
11367 : {
11368 : /* A type without parameterized components causes gimplifier problems. */
11369 1316 : if (!has_parameterized_comps (der_type))
11370 : return NULL_TREE;
11371 :
11372 583 : return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11373 583 : DEALLOCATE_PDT_COMP, 0, NULL);
11374 : }
11375 :
11376 :
11377 : /* Recursively traverse a dummy of parameterized derived type to check the
11378 : values of LEN parameters. */
11379 :
11380 : tree
11381 80 : gfc_check_pdt_dummy (gfc_symbol * der_type, tree decl, int rank,
11382 : gfc_actual_arglist *param_list)
11383 : {
11384 80 : tree res;
11385 80 : gfc_actual_arglist *old_param_list = pdt_param_list;
11386 80 : pdt_param_list = param_list;
11387 80 : res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11388 : CHECK_PDT_DUMMY, 0, NULL);
11389 80 : pdt_param_list = old_param_list;
11390 80 : return res;
11391 : }
11392 :
11393 :
11394 : /* Returns the value of LBOUND for an expression. This could be broken out
11395 : from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
11396 : called by gfc_alloc_allocatable_for_assignment. */
11397 : static tree
11398 1054 : get_std_lbound (gfc_expr *expr, tree desc, int dim, bool assumed_size)
11399 : {
11400 1054 : tree lbound;
11401 1054 : tree ubound;
11402 1054 : tree stride;
11403 1054 : tree cond, cond1, cond3, cond4;
11404 1054 : tree tmp;
11405 1054 : gfc_ref *ref;
11406 :
11407 1054 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
11408 : {
11409 508 : tmp = gfc_rank_cst[dim];
11410 508 : lbound = gfc_conv_descriptor_lbound_get (desc, tmp);
11411 508 : ubound = gfc_conv_descriptor_ubound_get (desc, tmp);
11412 508 : stride = gfc_conv_descriptor_stride_get (desc, tmp);
11413 508 : cond1 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
11414 : ubound, lbound);
11415 508 : cond3 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
11416 : stride, gfc_index_zero_node);
11417 508 : cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
11418 : logical_type_node, cond3, cond1);
11419 508 : cond4 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
11420 : stride, gfc_index_zero_node);
11421 508 : if (assumed_size)
11422 0 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
11423 : tmp, build_int_cst (gfc_array_index_type,
11424 0 : expr->rank - 1));
11425 : else
11426 508 : cond = logical_false_node;
11427 :
11428 508 : cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
11429 : logical_type_node, cond3, cond4);
11430 508 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
11431 : logical_type_node, cond, cond1);
11432 :
11433 508 : return fold_build3_loc (input_location, COND_EXPR,
11434 : gfc_array_index_type, cond,
11435 508 : lbound, gfc_index_one_node);
11436 : }
11437 :
11438 546 : if (expr->expr_type == EXPR_FUNCTION)
11439 : {
11440 : /* A conversion function, so use the argument. */
11441 7 : gcc_assert (expr->value.function.isym
11442 : && expr->value.function.isym->conversion);
11443 7 : expr = expr->value.function.actual->expr;
11444 : }
11445 :
11446 546 : if (expr->expr_type == EXPR_VARIABLE)
11447 : {
11448 546 : tmp = TREE_TYPE (expr->symtree->n.sym->backend_decl);
11449 1418 : for (ref = expr->ref; ref; ref = ref->next)
11450 : {
11451 872 : if (ref->type == REF_COMPONENT
11452 277 : && ref->u.c.component->as
11453 228 : && ref->next
11454 228 : && ref->next->u.ar.type == AR_FULL)
11455 186 : tmp = TREE_TYPE (ref->u.c.component->backend_decl);
11456 : }
11457 546 : return GFC_TYPE_ARRAY_LBOUND(tmp, dim);
11458 : }
11459 :
11460 0 : return gfc_index_one_node;
11461 : }
11462 :
11463 :
11464 : /* Returns true if an expression represents an lhs that can be reallocated
11465 : on assignment. */
11466 :
11467 : bool
11468 636450 : gfc_is_reallocatable_lhs (gfc_expr *expr)
11469 : {
11470 636450 : gfc_ref * ref;
11471 636450 : gfc_symbol *sym;
11472 :
11473 636450 : if (!flag_realloc_lhs)
11474 : return false;
11475 :
11476 635950 : if (!expr->ref)
11477 : return false;
11478 :
11479 213576 : sym = expr->symtree->n.sym;
11480 :
11481 213576 : if (sym->attr.associate_var && !expr->ref)
11482 : return false;
11483 :
11484 : /* An allocatable class variable with no reference. */
11485 213576 : if (sym->ts.type == BT_CLASS
11486 6258 : && (!sym->attr.associate_var || sym->attr.select_rank_temporary)
11487 6098 : && CLASS_DATA (sym)->attr.allocatable
11488 : && expr->ref
11489 3650 : && ((expr->ref->type == REF_ARRAY && expr->ref->u.ar.type == AR_FULL
11490 690 : && expr->ref->next == NULL)
11491 3033 : || (expr->ref->type == REF_COMPONENT
11492 2776 : && strcmp (expr->ref->u.c.component->name, "_data") == 0
11493 2039 : && (expr->ref->next == NULL
11494 2039 : || (expr->ref->next->type == REF_ARRAY
11495 2039 : && expr->ref->next->u.ar.type == AR_FULL
11496 1725 : && expr->ref->next->next == NULL)))))
11497 : return true;
11498 :
11499 : /* An allocatable variable. */
11500 211374 : if (sym->attr.allocatable
11501 46595 : && (!sym->attr.associate_var || sym->attr.select_rank_temporary)
11502 : && expr->ref
11503 46595 : && expr->ref->type == REF_ARRAY
11504 45118 : && expr->ref->u.ar.type == AR_FULL)
11505 : return true;
11506 :
11507 : /* All that can be left are allocatable components. */
11508 183502 : if (sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
11509 : return false;
11510 :
11511 : /* Find a component ref followed by an array reference. */
11512 88815 : for (ref = expr->ref; ref; ref = ref->next)
11513 62172 : if (ref->next
11514 35529 : && ref->type == REF_COMPONENT
11515 20320 : && ref->next->type == REF_ARRAY
11516 16753 : && !ref->next->next)
11517 : break;
11518 :
11519 39289 : if (!ref)
11520 : return false;
11521 :
11522 : /* Return true if valid reallocatable lhs. */
11523 12646 : if (ref->u.c.component->attr.allocatable
11524 6264 : && ref->next->u.ar.type == AR_FULL)
11525 4650 : return true;
11526 :
11527 : return false;
11528 : }
11529 :
11530 :
11531 : static tree
11532 56 : concat_str_length (gfc_expr* expr)
11533 : {
11534 56 : tree type;
11535 56 : tree len1;
11536 56 : tree len2;
11537 56 : gfc_se se;
11538 :
11539 56 : type = gfc_typenode_for_spec (&expr->value.op.op1->ts);
11540 56 : len1 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
11541 56 : if (len1 == NULL_TREE)
11542 : {
11543 56 : if (expr->value.op.op1->expr_type == EXPR_OP)
11544 31 : len1 = concat_str_length (expr->value.op.op1);
11545 25 : else if (expr->value.op.op1->expr_type == EXPR_CONSTANT)
11546 25 : len1 = build_int_cst (gfc_charlen_type_node,
11547 25 : expr->value.op.op1->value.character.length);
11548 0 : else if (expr->value.op.op1->ts.u.cl->length)
11549 : {
11550 0 : gfc_init_se (&se, NULL);
11551 0 : gfc_conv_expr (&se, expr->value.op.op1->ts.u.cl->length);
11552 0 : len1 = se.expr;
11553 : }
11554 : else
11555 : {
11556 : /* Last resort! */
11557 0 : gfc_init_se (&se, NULL);
11558 0 : se.want_pointer = 1;
11559 0 : se.descriptor_only = 1;
11560 0 : gfc_conv_expr (&se, expr->value.op.op1);
11561 0 : len1 = se.string_length;
11562 : }
11563 : }
11564 :
11565 56 : type = gfc_typenode_for_spec (&expr->value.op.op2->ts);
11566 56 : len2 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
11567 56 : if (len2 == NULL_TREE)
11568 : {
11569 31 : if (expr->value.op.op2->expr_type == EXPR_OP)
11570 0 : len2 = concat_str_length (expr->value.op.op2);
11571 31 : else if (expr->value.op.op2->expr_type == EXPR_CONSTANT)
11572 25 : len2 = build_int_cst (gfc_charlen_type_node,
11573 25 : expr->value.op.op2->value.character.length);
11574 6 : else if (expr->value.op.op2->ts.u.cl->length)
11575 : {
11576 6 : gfc_init_se (&se, NULL);
11577 6 : gfc_conv_expr (&se, expr->value.op.op2->ts.u.cl->length);
11578 6 : len2 = se.expr;
11579 : }
11580 : else
11581 : {
11582 : /* Last resort! */
11583 0 : gfc_init_se (&se, NULL);
11584 0 : se.want_pointer = 1;
11585 0 : se.descriptor_only = 1;
11586 0 : gfc_conv_expr (&se, expr->value.op.op2);
11587 0 : len2 = se.string_length;
11588 : }
11589 : }
11590 :
11591 56 : gcc_assert(len1 && len2);
11592 56 : len1 = fold_convert (gfc_charlen_type_node, len1);
11593 56 : len2 = fold_convert (gfc_charlen_type_node, len2);
11594 :
11595 56 : return fold_build2_loc (input_location, PLUS_EXPR,
11596 56 : gfc_charlen_type_node, len1, len2);
11597 : }
11598 :
11599 :
11600 : /* Among the scalarization chain of LOOP, find the element associated with an
11601 : allocatable array on the lhs of an assignment and evaluate its fields
11602 : (bounds, offset, etc) to new variables, putting the new code in BLOCK. This
11603 : function is to be called after putting the reallocation code in BLOCK and
11604 : before the beginning of the scalarization loop body.
11605 :
11606 : The fields to be saved are expected to hold on entry to the function
11607 : expressions referencing the array descriptor. Especially the expressions
11608 : shouldn't be already temporary variable references as the value saved before
11609 : reallocation would be incorrect after reallocation.
11610 : At the end of the function, the expressions have been replaced with variable
11611 : references. */
11612 :
11613 : static void
11614 6656 : update_reallocated_descriptor (stmtblock_t *block, gfc_loopinfo *loop)
11615 : {
11616 23236 : for (gfc_ss *s = loop->ss; s != gfc_ss_terminator; s = s->loop_chain)
11617 : {
11618 16580 : if (!s->is_alloc_lhs)
11619 9924 : continue;
11620 :
11621 6656 : gcc_assert (s->info->type == GFC_SS_SECTION);
11622 6656 : gfc_array_info *info = &s->info->data.array;
11623 :
11624 : #define SAVE_VALUE(value) \
11625 : do \
11626 : { \
11627 : value = gfc_evaluate_now (value, block); \
11628 : } \
11629 : while (0)
11630 :
11631 6656 : if (save_descriptor_data (info->descriptor, info->data))
11632 5840 : SAVE_VALUE (info->data);
11633 6656 : SAVE_VALUE (info->offset);
11634 6656 : info->saved_offset = info->offset;
11635 16517 : for (int i = 0; i < s->dimen; i++)
11636 : {
11637 9861 : int dim = s->dim[i];
11638 9861 : SAVE_VALUE (info->start[dim]);
11639 9861 : SAVE_VALUE (info->end[dim]);
11640 9861 : SAVE_VALUE (info->stride[dim]);
11641 9861 : SAVE_VALUE (info->delta[dim]);
11642 : }
11643 :
11644 : #undef SAVE_VALUE
11645 : }
11646 6656 : }
11647 :
11648 :
11649 : /* Allocate the lhs of an assignment to an allocatable array, otherwise
11650 : reallocate it. */
11651 :
11652 : tree
11653 6656 : gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
11654 : gfc_expr *expr1,
11655 : gfc_expr *expr2)
11656 : {
11657 6656 : stmtblock_t realloc_block;
11658 6656 : stmtblock_t alloc_block;
11659 6656 : stmtblock_t fblock;
11660 6656 : stmtblock_t loop_pre_block;
11661 6656 : gfc_ref *ref;
11662 6656 : gfc_ss *rss;
11663 6656 : gfc_ss *lss;
11664 6656 : gfc_array_info *linfo;
11665 6656 : tree realloc_expr;
11666 6656 : tree alloc_expr;
11667 6656 : tree size1;
11668 6656 : tree size2;
11669 6656 : tree elemsize1;
11670 6656 : tree elemsize2;
11671 6656 : tree array1;
11672 6656 : tree cond_null;
11673 6656 : tree cond;
11674 6656 : tree tmp;
11675 6656 : tree tmp2;
11676 6656 : tree lbound;
11677 6656 : tree ubound;
11678 6656 : tree desc;
11679 6656 : tree old_desc;
11680 6656 : tree desc2;
11681 6656 : tree offset;
11682 6656 : tree jump_label1;
11683 6656 : tree jump_label2;
11684 6656 : tree lbd;
11685 6656 : tree class_expr2 = NULL_TREE;
11686 6656 : int n;
11687 6656 : gfc_array_spec * as;
11688 6656 : bool coarray = (flag_coarray == GFC_FCOARRAY_LIB
11689 6656 : && gfc_caf_attr (expr1, true).codimension);
11690 6656 : tree token;
11691 6656 : gfc_se caf_se;
11692 :
11693 : /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
11694 : Find the lhs expression in the loop chain and set expr1 and
11695 : expr2 accordingly. */
11696 6656 : if (expr1->expr_type == EXPR_FUNCTION && expr2 == NULL)
11697 : {
11698 203 : expr2 = expr1;
11699 : /* Find the ss for the lhs. */
11700 203 : lss = loop->ss;
11701 406 : for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
11702 406 : if (lss->info->expr && lss->info->expr->expr_type == EXPR_VARIABLE)
11703 : break;
11704 203 : if (lss == gfc_ss_terminator)
11705 : return NULL_TREE;
11706 203 : expr1 = lss->info->expr;
11707 : }
11708 :
11709 : /* Bail out if this is not a valid allocate on assignment. */
11710 6656 : if (!gfc_is_reallocatable_lhs (expr1)
11711 6656 : || (expr2 && !expr2->rank))
11712 : return NULL_TREE;
11713 :
11714 : /* Find the ss for the lhs. */
11715 6656 : lss = loop->ss;
11716 16580 : for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
11717 16580 : if (lss->info->expr == expr1)
11718 : break;
11719 :
11720 6656 : if (lss == gfc_ss_terminator)
11721 : return NULL_TREE;
11722 :
11723 6656 : linfo = &lss->info->data.array;
11724 :
11725 : /* Find an ss for the rhs. For operator expressions, we see the
11726 : ss's for the operands. Any one of these will do. */
11727 6656 : rss = loop->ss;
11728 7260 : for (; rss && rss != gfc_ss_terminator; rss = rss->loop_chain)
11729 7260 : if (rss->info->expr != expr1 && rss != loop->temp_ss)
11730 : break;
11731 :
11732 6656 : if (expr2 && rss == gfc_ss_terminator)
11733 : return NULL_TREE;
11734 :
11735 : /* Ensure that the string length from the current scope is used. */
11736 6656 : if (expr2->ts.type == BT_CHARACTER
11737 983 : && expr2->expr_type == EXPR_FUNCTION
11738 130 : && !expr2->value.function.isym)
11739 21 : expr2->ts.u.cl->backend_decl = rss->info->string_length;
11740 :
11741 : /* Since the lhs is allocatable, this must be a descriptor type.
11742 : Get the data and array size. */
11743 6656 : desc = linfo->descriptor;
11744 6656 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
11745 6656 : array1 = gfc_conv_descriptor_data_get (desc);
11746 :
11747 : /* If the data is null, set the descriptor bounds and offset. This suppresses
11748 : the maybe used uninitialized warning. Note that the always false variable
11749 : prevents this block from ever being executed, and makes sure that the
11750 : optimizers are able to remove it. Component references are not subject to
11751 : the warnings, so we don't uselessly complicate the generated code for them.
11752 : */
11753 11888 : for (ref = expr1->ref; ref; ref = ref->next)
11754 6863 : if (ref->type == REF_COMPONENT)
11755 : break;
11756 :
11757 6656 : if (!ref)
11758 : {
11759 5025 : stmtblock_t unalloc_init_block;
11760 5025 : gfc_init_block (&unalloc_init_block);
11761 5025 : tree guard = gfc_create_var (logical_type_node, "unallocated_init_guard");
11762 5025 : gfc_add_modify (&unalloc_init_block, guard, logical_false_node);
11763 :
11764 5025 : gfc_start_block (&loop_pre_block);
11765 17923 : for (n = 0; n < expr1->rank; n++)
11766 : {
11767 7873 : gfc_conv_descriptor_lbound_set (&loop_pre_block, desc,
11768 : gfc_rank_cst[n],
11769 : gfc_index_one_node);
11770 7873 : gfc_conv_descriptor_ubound_set (&loop_pre_block, desc,
11771 : gfc_rank_cst[n],
11772 : gfc_index_zero_node);
11773 7873 : gfc_conv_descriptor_stride_set (&loop_pre_block, desc,
11774 : gfc_rank_cst[n],
11775 : gfc_index_zero_node);
11776 : }
11777 :
11778 5025 : gfc_conv_descriptor_offset_set (&loop_pre_block, desc,
11779 : gfc_index_zero_node);
11780 :
11781 5025 : tmp = fold_build2_loc (input_location, EQ_EXPR,
11782 : logical_type_node, array1,
11783 5025 : build_int_cst (TREE_TYPE (array1), 0));
11784 5025 : tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
11785 : logical_type_node, tmp, guard);
11786 5025 : tmp = build3_v (COND_EXPR, tmp,
11787 : gfc_finish_block (&loop_pre_block),
11788 : build_empty_stmt (input_location));
11789 5025 : gfc_prepend_expr_to_block (&loop->pre, tmp);
11790 5025 : gfc_prepend_expr_to_block (&loop->pre,
11791 : gfc_finish_block (&unalloc_init_block));
11792 : }
11793 :
11794 6656 : gfc_start_block (&fblock);
11795 :
11796 6656 : if (expr2)
11797 6656 : desc2 = rss->info->data.array.descriptor;
11798 : else
11799 : desc2 = NULL_TREE;
11800 :
11801 : /* Get the old lhs element size for deferred character and class expr1. */
11802 6656 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
11803 : {
11804 663 : if (expr1->ts.u.cl->backend_decl
11805 663 : && VAR_P (expr1->ts.u.cl->backend_decl))
11806 : elemsize1 = expr1->ts.u.cl->backend_decl;
11807 : else
11808 64 : elemsize1 = lss->info->string_length;
11809 663 : tree unit_size = TYPE_SIZE_UNIT (gfc_get_char_type (expr1->ts.kind));
11810 1326 : elemsize1 = fold_build2_loc (input_location, MULT_EXPR,
11811 663 : TREE_TYPE (elemsize1), elemsize1,
11812 663 : fold_convert (TREE_TYPE (elemsize1), unit_size));
11813 :
11814 663 : }
11815 5993 : else if (expr1->ts.type == BT_CLASS)
11816 : {
11817 : /* Unfortunately, the lhs vptr is set too early in many cases.
11818 : Play it safe by using the descriptor element length. */
11819 645 : tmp = gfc_conv_descriptor_elem_len_get (desc);
11820 645 : elemsize1 = fold_convert (gfc_array_index_type, tmp);
11821 : }
11822 : else
11823 : elemsize1 = NULL_TREE;
11824 1308 : if (elemsize1 != NULL_TREE)
11825 1308 : elemsize1 = gfc_evaluate_now (elemsize1, &fblock);
11826 :
11827 : /* Get the new lhs size in bytes. */
11828 6656 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
11829 : {
11830 663 : if (expr2->ts.deferred)
11831 : {
11832 183 : if (expr2->ts.u.cl->backend_decl
11833 183 : && VAR_P (expr2->ts.u.cl->backend_decl))
11834 : tmp = expr2->ts.u.cl->backend_decl;
11835 : else
11836 0 : tmp = rss->info->string_length;
11837 : }
11838 : else
11839 : {
11840 480 : tmp = expr2->ts.u.cl->backend_decl;
11841 480 : if (!tmp && expr2->expr_type == EXPR_OP
11842 25 : && expr2->value.op.op == INTRINSIC_CONCAT)
11843 : {
11844 25 : tmp = concat_str_length (expr2);
11845 25 : expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
11846 : }
11847 12 : else if (!tmp && expr2->ts.u.cl->length)
11848 : {
11849 12 : gfc_se tmpse;
11850 12 : gfc_init_se (&tmpse, NULL);
11851 12 : gfc_conv_expr_type (&tmpse, expr2->ts.u.cl->length,
11852 : gfc_charlen_type_node);
11853 12 : tmp = tmpse.expr;
11854 12 : expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
11855 : }
11856 480 : tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
11857 : }
11858 :
11859 663 : if (expr1->ts.u.cl->backend_decl
11860 663 : && VAR_P (expr1->ts.u.cl->backend_decl))
11861 599 : gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
11862 : else
11863 64 : gfc_add_modify (&fblock, lss->info->string_length, tmp);
11864 :
11865 663 : if (expr1->ts.kind > 1)
11866 12 : tmp = fold_build2_loc (input_location, MULT_EXPR,
11867 6 : TREE_TYPE (tmp),
11868 6 : tmp, build_int_cst (TREE_TYPE (tmp),
11869 6 : expr1->ts.kind));
11870 : }
11871 5993 : else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
11872 : {
11873 271 : tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts)));
11874 271 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
11875 : fold_convert (gfc_array_index_type, tmp),
11876 271 : expr1->ts.u.cl->backend_decl);
11877 : }
11878 5722 : else if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS)
11879 164 : tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
11880 5558 : else if (expr1->ts.type == BT_CLASS && expr2->ts.type == BT_CLASS)
11881 : {
11882 280 : tmp = expr2->rank ? gfc_get_class_from_expr (desc2) : NULL_TREE;
11883 280 : if (tmp == NULL_TREE && expr2->expr_type == EXPR_VARIABLE)
11884 36 : tmp = class_expr2 = gfc_get_class_from_gfc_expr (expr2);
11885 :
11886 43 : if (tmp != NULL_TREE)
11887 273 : tmp = gfc_class_vtab_size_get (tmp);
11888 : else
11889 7 : tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&CLASS_DATA (expr2)->ts));
11890 : }
11891 : else
11892 5278 : tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
11893 6656 : elemsize2 = fold_convert (gfc_array_index_type, tmp);
11894 6656 : elemsize2 = gfc_evaluate_now (elemsize2, &fblock);
11895 :
11896 : /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
11897 : deallocated if expr is an array of different shape or any of the
11898 : corresponding length type parameter values of variable and expr
11899 : differ." This assures F95 compatibility. */
11900 6656 : jump_label1 = gfc_build_label_decl (NULL_TREE);
11901 6656 : jump_label2 = gfc_build_label_decl (NULL_TREE);
11902 :
11903 : /* Allocate if data is NULL. */
11904 6656 : cond_null = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
11905 6656 : array1, build_int_cst (TREE_TYPE (array1), 0));
11906 6656 : cond_null= gfc_evaluate_now (cond_null, &fblock);
11907 :
11908 6656 : tmp = build3_v (COND_EXPR, cond_null,
11909 : build1_v (GOTO_EXPR, jump_label1),
11910 : build_empty_stmt (input_location));
11911 6656 : gfc_add_expr_to_block (&fblock, tmp);
11912 :
11913 : /* Get arrayspec if expr is a full array. */
11914 6656 : if (expr2 && expr2->expr_type == EXPR_FUNCTION
11915 2814 : && expr2->value.function.isym
11916 2295 : && expr2->value.function.isym->conversion)
11917 : {
11918 : /* For conversion functions, take the arg. */
11919 245 : gfc_expr *arg = expr2->value.function.actual->expr;
11920 245 : as = gfc_get_full_arrayspec_from_expr (arg);
11921 245 : }
11922 : else if (expr2)
11923 6411 : as = gfc_get_full_arrayspec_from_expr (expr2);
11924 : else
11925 : as = NULL;
11926 :
11927 : /* If the lhs shape is not the same as the rhs jump to setting the
11928 : bounds and doing the reallocation....... */
11929 16517 : for (n = 0; n < expr1->rank; n++)
11930 : {
11931 : /* Check the shape. */
11932 9861 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
11933 9861 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
11934 9861 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
11935 : gfc_array_index_type,
11936 : loop->to[n], loop->from[n]);
11937 9861 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
11938 : gfc_array_index_type,
11939 : tmp, lbound);
11940 9861 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
11941 : gfc_array_index_type,
11942 : tmp, ubound);
11943 9861 : cond = fold_build2_loc (input_location, NE_EXPR,
11944 : logical_type_node,
11945 : tmp, gfc_index_zero_node);
11946 9861 : tmp = build3_v (COND_EXPR, cond,
11947 : build1_v (GOTO_EXPR, jump_label1),
11948 : build_empty_stmt (input_location));
11949 9861 : gfc_add_expr_to_block (&fblock, tmp);
11950 : }
11951 :
11952 : /* ...else if the element lengths are not the same also go to
11953 : setting the bounds and doing the reallocation.... */
11954 6656 : if (elemsize1 != NULL_TREE)
11955 : {
11956 1308 : cond = fold_build2_loc (input_location, NE_EXPR,
11957 : logical_type_node,
11958 : elemsize1, elemsize2);
11959 1308 : tmp = build3_v (COND_EXPR, cond,
11960 : build1_v (GOTO_EXPR, jump_label1),
11961 : build_empty_stmt (input_location));
11962 1308 : gfc_add_expr_to_block (&fblock, tmp);
11963 : }
11964 :
11965 : /* ....else jump past the (re)alloc code. */
11966 6656 : tmp = build1_v (GOTO_EXPR, jump_label2);
11967 6656 : gfc_add_expr_to_block (&fblock, tmp);
11968 :
11969 : /* Add the label to start automatic (re)allocation. */
11970 6656 : tmp = build1_v (LABEL_EXPR, jump_label1);
11971 6656 : gfc_add_expr_to_block (&fblock, tmp);
11972 :
11973 : /* Get the rhs size and fix it. */
11974 6656 : size2 = gfc_index_one_node;
11975 16517 : for (n = 0; n < expr2->rank; n++)
11976 : {
11977 9861 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
11978 : gfc_array_index_type,
11979 : loop->to[n], loop->from[n]);
11980 9861 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
11981 : gfc_array_index_type,
11982 : tmp, gfc_index_one_node);
11983 9861 : size2 = fold_build2_loc (input_location, MULT_EXPR,
11984 : gfc_array_index_type,
11985 : tmp, size2);
11986 : }
11987 6656 : size2 = gfc_evaluate_now (size2, &fblock);
11988 :
11989 : /* Deallocation of allocatable components will have to occur on
11990 : reallocation. Fix the old descriptor now. */
11991 6656 : if ((expr1->ts.type == BT_DERIVED)
11992 441 : && expr1->ts.u.derived->attr.alloc_comp)
11993 200 : old_desc = gfc_evaluate_now (desc, &fblock);
11994 : else
11995 : old_desc = NULL_TREE;
11996 :
11997 : /* Now modify the lhs descriptor and the associated scalarizer
11998 : variables. F2003 7.4.1.3: "If variable is or becomes an
11999 : unallocated allocatable variable, then it is allocated with each
12000 : deferred type parameter equal to the corresponding type parameters
12001 : of expr , with the shape of expr , and with each lower bound equal
12002 : to the corresponding element of LBOUND(expr)."
12003 : Reuse size1 to keep a dimension-by-dimension track of the
12004 : stride of the new array. */
12005 6656 : size1 = gfc_index_one_node;
12006 6656 : offset = gfc_index_zero_node;
12007 :
12008 16517 : for (n = 0; n < expr2->rank; n++)
12009 : {
12010 9861 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
12011 : gfc_array_index_type,
12012 : loop->to[n], loop->from[n]);
12013 9861 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
12014 : gfc_array_index_type,
12015 : tmp, gfc_index_one_node);
12016 :
12017 9861 : lbound = gfc_index_one_node;
12018 9861 : ubound = tmp;
12019 :
12020 9861 : if (as)
12021 : {
12022 2108 : lbd = get_std_lbound (expr2, desc2, n,
12023 1054 : as->type == AS_ASSUMED_SIZE);
12024 1054 : ubound = fold_build2_loc (input_location,
12025 : MINUS_EXPR,
12026 : gfc_array_index_type,
12027 : ubound, lbound);
12028 1054 : ubound = fold_build2_loc (input_location,
12029 : PLUS_EXPR,
12030 : gfc_array_index_type,
12031 : ubound, lbd);
12032 1054 : lbound = lbd;
12033 : }
12034 :
12035 9861 : gfc_conv_descriptor_lbound_set (&fblock, desc,
12036 : gfc_rank_cst[n],
12037 : lbound);
12038 9861 : gfc_conv_descriptor_ubound_set (&fblock, desc,
12039 : gfc_rank_cst[n],
12040 : ubound);
12041 9861 : gfc_conv_descriptor_stride_set (&fblock, desc,
12042 : gfc_rank_cst[n],
12043 : size1);
12044 9861 : lbound = gfc_conv_descriptor_lbound_get (desc,
12045 : gfc_rank_cst[n]);
12046 9861 : tmp2 = fold_build2_loc (input_location, MULT_EXPR,
12047 : gfc_array_index_type,
12048 : lbound, size1);
12049 9861 : offset = fold_build2_loc (input_location, MINUS_EXPR,
12050 : gfc_array_index_type,
12051 : offset, tmp2);
12052 9861 : size1 = fold_build2_loc (input_location, MULT_EXPR,
12053 : gfc_array_index_type,
12054 : tmp, size1);
12055 : }
12056 :
12057 : /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
12058 : the array offset is saved and the info.offset is used for a
12059 : running offset. Use the saved_offset instead. */
12060 6656 : gfc_conv_descriptor_offset_set (&fblock, desc, 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 6656 : 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 6656 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
12076 6656 : gfc_conv_descriptor_span_set (&fblock, desc, elemsize2);
12077 :
12078 6656 : size2 = fold_build2_loc (input_location, MULT_EXPR,
12079 : gfc_array_index_type,
12080 : elemsize2, size2);
12081 6656 : size2 = fold_convert (size_type_node, size2);
12082 6656 : size2 = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
12083 : size2, size_one_node);
12084 6656 : 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 6656 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
12089 6656 : && expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12090 : {
12091 663 : tree type;
12092 663 : if (expr2->ts.u.cl->backend_decl)
12093 663 : type = gfc_typenode_for_spec (&expr2->ts);
12094 : else
12095 0 : type = gfc_typenode_for_spec (&expr1->ts);
12096 :
12097 663 : gfc_conv_descriptor_dtype_set (&fblock, desc,
12098 : gfc_get_dtype_rank_type (expr1->rank,
12099 : type));
12100 : }
12101 5993 : else if (expr1->ts.type == BT_CLASS)
12102 : {
12103 645 : tree type;
12104 :
12105 645 : if (expr2->ts.type != BT_CLASS)
12106 365 : type = gfc_typenode_for_spec (&expr2->ts);
12107 : else
12108 280 : type = gfc_get_character_type_len (1, elemsize2);
12109 :
12110 645 : gfc_conv_descriptor_dtype_set (&fblock, desc,
12111 : gfc_get_dtype_rank_type (expr2->rank,
12112 : type));
12113 :
12114 : /* Set the _len field as well... */
12115 645 : if (UNLIMITED_POLY (expr1))
12116 : {
12117 256 : tmp = gfc_class_len_get (TREE_OPERAND (desc, 0));
12118 256 : if (expr2->ts.type == BT_CHARACTER)
12119 49 : gfc_add_modify (&fblock, tmp,
12120 49 : fold_convert (TREE_TYPE (tmp),
12121 : TYPE_SIZE_UNIT (type)));
12122 207 : else if (UNLIMITED_POLY (expr2))
12123 92 : gfc_add_modify (&fblock, tmp,
12124 92 : gfc_class_len_get (TREE_OPERAND (desc2, 0)));
12125 : else
12126 115 : gfc_add_modify (&fblock, tmp,
12127 115 : build_int_cst (TREE_TYPE (tmp), 0));
12128 : }
12129 : /* ...and the vptr. */
12130 645 : tmp = gfc_class_vptr_get (TREE_OPERAND (desc, 0));
12131 645 : if (expr2->ts.type == BT_CLASS && !VAR_P (desc2)
12132 273 : && TREE_CODE (desc2) == COMPONENT_REF)
12133 : {
12134 237 : tmp2 = gfc_get_class_from_expr (desc2);
12135 237 : tmp2 = gfc_class_vptr_get (tmp2);
12136 : }
12137 408 : else if (expr2->ts.type == BT_CLASS && class_expr2 != NULL_TREE)
12138 36 : tmp2 = gfc_class_vptr_get (class_expr2);
12139 : else
12140 : {
12141 372 : tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts));
12142 372 : tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2);
12143 : }
12144 :
12145 645 : gfc_add_modify (&fblock, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
12146 : }
12147 5348 : else if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
12148 39 : gfc_conv_descriptor_dtype_set (&fblock, desc,
12149 39 : gfc_get_dtype (TREE_TYPE (desc)));
12150 :
12151 : /* Realloc expression. Note that the scalarizer uses desc.data
12152 : in the array reference - (*desc.data)[<element>]. */
12153 6656 : gfc_init_block (&realloc_block);
12154 6656 : gfc_init_se (&caf_se, NULL);
12155 :
12156 6656 : if (coarray)
12157 : {
12158 39 : token = gfc_get_ultimate_alloc_ptr_comps_caf_token (&caf_se, expr1);
12159 39 : if (token == NULL_TREE)
12160 : {
12161 9 : tmp = gfc_get_tree_for_caf_expr (expr1);
12162 9 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
12163 6 : tmp = build_fold_indirect_ref (tmp);
12164 9 : gfc_get_caf_token_offset (&caf_se, &token, NULL, tmp, NULL_TREE,
12165 : expr1);
12166 9 : token = gfc_build_addr_expr (NULL_TREE, token);
12167 : }
12168 :
12169 39 : gfc_add_block_to_block (&realloc_block, &caf_se.pre);
12170 : }
12171 6656 : if ((expr1->ts.type == BT_DERIVED)
12172 441 : && expr1->ts.u.derived->attr.alloc_comp)
12173 : {
12174 200 : tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, old_desc,
12175 : expr1->rank, true);
12176 200 : gfc_add_expr_to_block (&realloc_block, tmp);
12177 : }
12178 :
12179 6656 : if (!coarray)
12180 : {
12181 6617 : tmp = build_call_expr_loc (input_location,
12182 : builtin_decl_explicit (BUILT_IN_REALLOC), 2,
12183 : fold_convert (pvoid_type_node, array1),
12184 : size2);
12185 6617 : if (flag_openmp_allocators)
12186 : {
12187 2 : tree cond, omp_tmp;
12188 2 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
12189 : gfc_conv_descriptor_version_get (desc),
12190 : integer_one_node);
12191 2 : omp_tmp = builtin_decl_explicit (BUILT_IN_GOMP_REALLOC);
12192 2 : omp_tmp = build_call_expr_loc (input_location, omp_tmp, 4,
12193 : fold_convert (pvoid_type_node, array1), size2,
12194 : build_zero_cst (ptr_type_node),
12195 : build_zero_cst (ptr_type_node));
12196 2 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond,
12197 : omp_tmp, tmp);
12198 : }
12199 :
12200 6617 : gfc_conv_descriptor_data_set (&realloc_block, desc, tmp);
12201 : }
12202 : else
12203 : {
12204 39 : tmp = build_call_expr_loc (input_location,
12205 : gfor_fndecl_caf_deregister, 5, token,
12206 : build_int_cst (integer_type_node,
12207 : GFC_CAF_COARRAY_DEALLOCATE_ONLY),
12208 : null_pointer_node, null_pointer_node,
12209 : integer_zero_node);
12210 39 : gfc_add_expr_to_block (&realloc_block, tmp);
12211 39 : tmp = build_call_expr_loc (input_location,
12212 : gfor_fndecl_caf_register,
12213 : 7, size2,
12214 : build_int_cst (integer_type_node,
12215 : GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY),
12216 : token, gfc_build_addr_expr (NULL_TREE, desc),
12217 : null_pointer_node, null_pointer_node,
12218 : integer_zero_node);
12219 39 : gfc_add_expr_to_block (&realloc_block, tmp);
12220 : }
12221 :
12222 6656 : if ((expr1->ts.type == BT_DERIVED)
12223 441 : && expr1->ts.u.derived->attr.alloc_comp)
12224 : {
12225 200 : tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc,
12226 : expr1->rank);
12227 200 : gfc_add_expr_to_block (&realloc_block, tmp);
12228 : }
12229 :
12230 6656 : gfc_add_block_to_block (&realloc_block, &caf_se.post);
12231 6656 : realloc_expr = gfc_finish_block (&realloc_block);
12232 :
12233 : /* Malloc expression. */
12234 6656 : gfc_init_block (&alloc_block);
12235 6656 : if (!coarray)
12236 : {
12237 6617 : tmp = build_call_expr_loc (input_location,
12238 : builtin_decl_explicit (BUILT_IN_MALLOC),
12239 : 1, size2);
12240 6617 : gfc_conv_descriptor_data_set (&alloc_block,
12241 : desc, tmp);
12242 : }
12243 : else
12244 : {
12245 39 : tmp = build_call_expr_loc (input_location,
12246 : gfor_fndecl_caf_register,
12247 : 7, size2,
12248 : build_int_cst (integer_type_node,
12249 : GFC_CAF_COARRAY_ALLOC),
12250 : token, gfc_build_addr_expr (NULL_TREE, desc),
12251 : null_pointer_node, null_pointer_node,
12252 : integer_zero_node);
12253 39 : gfc_add_expr_to_block (&alloc_block, tmp);
12254 : }
12255 :
12256 :
12257 : /* We already set the dtype in the case of deferred character
12258 : length arrays and class lvalues. */
12259 6656 : if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
12260 6656 : && ((expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12261 5993 : || coarray))
12262 12610 : && expr1->ts.type != BT_CLASS)
12263 5309 : gfc_conv_descriptor_dtype_set (&alloc_block, desc,
12264 5309 : gfc_get_dtype (TREE_TYPE (desc)));
12265 :
12266 6656 : if ((expr1->ts.type == BT_DERIVED)
12267 441 : && expr1->ts.u.derived->attr.alloc_comp)
12268 : {
12269 200 : tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc,
12270 : expr1->rank);
12271 200 : gfc_add_expr_to_block (&alloc_block, tmp);
12272 : }
12273 6656 : alloc_expr = gfc_finish_block (&alloc_block);
12274 :
12275 : /* Malloc if not allocated; realloc otherwise. */
12276 6656 : tmp = build3_v (COND_EXPR, cond_null, alloc_expr, realloc_expr);
12277 6656 : gfc_add_expr_to_block (&fblock, tmp);
12278 :
12279 : /* Add the label for same shape lhs and rhs. */
12280 6656 : tmp = build1_v (LABEL_EXPR, jump_label2);
12281 6656 : gfc_add_expr_to_block (&fblock, tmp);
12282 :
12283 6656 : tree realloc_code = gfc_finish_block (&fblock);
12284 :
12285 6656 : stmtblock_t result_block;
12286 6656 : gfc_init_block (&result_block);
12287 6656 : gfc_add_expr_to_block (&result_block, realloc_code);
12288 6656 : update_reallocated_descriptor (&result_block, loop);
12289 :
12290 6656 : return gfc_finish_block (&result_block);
12291 : }
12292 :
12293 :
12294 : /* Initialize class descriptor's TKR information. */
12295 :
12296 : void
12297 2938 : gfc_trans_class_array (gfc_symbol * sym, gfc_wrapped_block * block)
12298 : {
12299 2938 : tree type, etype;
12300 2938 : tree descriptor;
12301 2938 : stmtblock_t init;
12302 2938 : int rank;
12303 :
12304 : /* Make sure the frontend gets these right. */
12305 2938 : gcc_assert (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
12306 : && (CLASS_DATA (sym)->attr.class_pointer
12307 : || CLASS_DATA (sym)->attr.allocatable));
12308 :
12309 2938 : gcc_assert (VAR_P (sym->backend_decl)
12310 : || TREE_CODE (sym->backend_decl) == PARM_DECL);
12311 :
12312 2938 : if (sym->attr.dummy)
12313 1436 : return;
12314 :
12315 2938 : descriptor = gfc_class_data_get (sym->backend_decl);
12316 2938 : type = TREE_TYPE (descriptor);
12317 :
12318 2938 : if (type == NULL || !GFC_DESCRIPTOR_TYPE_P (type))
12319 : return;
12320 :
12321 1502 : location_t loc = input_location;
12322 1502 : input_location = gfc_get_location (&sym->declared_at);
12323 1502 : gfc_init_block (&init);
12324 :
12325 1502 : rank = CLASS_DATA (sym)->as ? (CLASS_DATA (sym)->as->rank) : (0);
12326 1502 : gcc_assert (rank>=0);
12327 1502 : etype = gfc_get_element_type (type);
12328 1502 : gfc_conv_descriptor_dtype_set (&init, descriptor,
12329 : gfc_get_dtype_rank_type (rank, etype));
12330 :
12331 1502 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
12332 1502 : input_location = loc;
12333 : }
12334 :
12335 :
12336 : /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
12337 : Do likewise, recursively if necessary, with the allocatable components of
12338 : derived types. This function is also called for assumed-rank arrays, which
12339 : are always dummy arguments. */
12340 :
12341 : void
12342 18123 : gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
12343 : {
12344 18123 : tree type;
12345 18123 : tree tmp;
12346 18123 : tree descriptor;
12347 18123 : stmtblock_t init;
12348 18123 : stmtblock_t cleanup;
12349 18123 : int rank;
12350 18123 : bool sym_has_alloc_comp, has_finalizer;
12351 :
12352 36246 : sym_has_alloc_comp = (sym->ts.type == BT_DERIVED
12353 10948 : || sym->ts.type == BT_CLASS)
12354 18123 : && sym->ts.u.derived->attr.alloc_comp;
12355 18123 : has_finalizer = gfc_may_be_finalized (sym->ts);
12356 :
12357 : /* Make sure the frontend gets these right. */
12358 18123 : gcc_assert (sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp
12359 : || has_finalizer
12360 : || (sym->as->type == AS_ASSUMED_RANK && sym->attr.dummy));
12361 :
12362 18123 : location_t loc = input_location;
12363 18123 : input_location = gfc_get_location (&sym->declared_at);
12364 18123 : gfc_init_block (&init);
12365 :
12366 18123 : gcc_assert (VAR_P (sym->backend_decl)
12367 : || TREE_CODE (sym->backend_decl) == PARM_DECL);
12368 :
12369 18123 : if (sym->ts.type == BT_CHARACTER
12370 1390 : && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
12371 : {
12372 812 : if (sym->ts.deferred && !sym->ts.u.cl->length && !sym->attr.dummy)
12373 : {
12374 607 : tree len_expr = sym->ts.u.cl->backend_decl;
12375 607 : tree init_val = build_zero_cst (TREE_TYPE (len_expr));
12376 607 : if (VAR_P (len_expr)
12377 607 : && sym->attr.save
12378 662 : && !DECL_INITIAL (len_expr))
12379 55 : DECL_INITIAL (len_expr) = init_val;
12380 : else
12381 552 : gfc_add_modify (&init, len_expr, init_val);
12382 : }
12383 812 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
12384 812 : gfc_trans_vla_type_sizes (sym, &init);
12385 :
12386 : /* Presence check of optional deferred-length character dummy. */
12387 812 : if (sym->ts.deferred && sym->attr.dummy && sym->attr.optional)
12388 : {
12389 43 : tmp = gfc_finish_block (&init);
12390 43 : tmp = build3_v (COND_EXPR, gfc_conv_expr_present (sym),
12391 : tmp, build_empty_stmt (input_location));
12392 43 : gfc_add_expr_to_block (&init, tmp);
12393 : }
12394 : }
12395 :
12396 : /* Dummy, use associated and result variables don't need anything special. */
12397 18123 : if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result)
12398 : {
12399 882 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
12400 882 : input_location = loc;
12401 1158 : return;
12402 : }
12403 :
12404 17241 : descriptor = sym->backend_decl;
12405 :
12406 : /* Although static, derived types with default initializers and
12407 : allocatable components must not be nulled wholesale; instead they
12408 : are treated component by component. */
12409 17241 : if (TREE_STATIC (descriptor) && !sym_has_alloc_comp && !has_finalizer)
12410 : {
12411 : /* SAVEd variables are not freed on exit. */
12412 276 : gfc_trans_static_array_pointer (sym);
12413 :
12414 276 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
12415 276 : input_location = loc;
12416 276 : return;
12417 : }
12418 :
12419 : /* Get the descriptor type. */
12420 16965 : type = TREE_TYPE (sym->backend_decl);
12421 :
12422 16965 : if ((sym_has_alloc_comp || (has_finalizer && sym->ts.type != BT_CLASS))
12423 5576 : && !(sym->attr.pointer || sym->attr.allocatable))
12424 : {
12425 2904 : if (!sym->attr.save
12426 2507 : && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program))
12427 : {
12428 2507 : if (sym->value == NULL
12429 2507 : || !gfc_has_default_initializer (sym->ts.u.derived))
12430 : {
12431 2075 : rank = sym->as ? sym->as->rank : 0;
12432 2075 : tmp = gfc_nullify_alloc_comp (sym->ts.u.derived,
12433 : descriptor, rank);
12434 2075 : gfc_add_expr_to_block (&init, tmp);
12435 : }
12436 : else
12437 432 : gfc_init_default_dt (sym, &init, false);
12438 : }
12439 : }
12440 14061 : else if (!GFC_DESCRIPTOR_TYPE_P (type))
12441 : {
12442 : /* If the backend_decl is not a descriptor, we must have a pointer
12443 : to one. */
12444 2087 : descriptor = build_fold_indirect_ref_loc (input_location,
12445 : sym->backend_decl);
12446 2087 : type = TREE_TYPE (descriptor);
12447 : }
12448 :
12449 : /* NULLIFY the data pointer for non-saved allocatables, or for non-saved
12450 : pointers when -fcheck=pointer is specified. */
12451 28939 : if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save
12452 28926 : && (sym->attr.allocatable
12453 3282 : || (sym->attr.pointer && (gfc_option.rtcheck & GFC_RTCHECK_POINTER))))
12454 : {
12455 8722 : gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node);
12456 8722 : if (flag_coarray == GFC_FCOARRAY_LIB && sym->attr.codimension)
12457 : {
12458 : /* Declare the variable static so its array descriptor stays present
12459 : after leaving the scope. It may still be accessed through another
12460 : image. This may happen, for example, with the caf_mpi
12461 : implementation. */
12462 169 : TREE_STATIC (descriptor) = 1;
12463 169 : gfc_conv_descriptor_token_set (&init, descriptor, null_pointer_node);
12464 : }
12465 : }
12466 :
12467 : /* Set initial TKR for pointers and allocatables */
12468 16965 : if (GFC_DESCRIPTOR_TYPE_P (type)
12469 16965 : && (sym->attr.pointer || sym->attr.allocatable))
12470 : {
12471 11974 : tree etype;
12472 :
12473 11974 : gcc_assert (sym->as && sym->as->rank>=0);
12474 11974 : etype = gfc_get_element_type (type);
12475 11974 : gfc_conv_descriptor_dtype_set (&init, descriptor,
12476 11974 : gfc_get_dtype_rank_type (sym->as->rank,
12477 : etype));
12478 : }
12479 16965 : input_location = loc;
12480 16965 : gfc_init_block (&cleanup);
12481 :
12482 : /* Allocatable arrays need to be freed when they go out of scope.
12483 : The allocatable components of pointers must not be touched. */
12484 16965 : if (!sym->attr.allocatable && has_finalizer && sym->ts.type != BT_CLASS
12485 604 : && !sym->attr.pointer && !sym->attr.artificial && !sym->attr.save
12486 315 : && !sym->ns->proc_name->attr.is_main_program)
12487 : {
12488 276 : gfc_expr *e;
12489 276 : sym->attr.referenced = 1;
12490 276 : e = gfc_lval_expr_from_sym (sym);
12491 276 : gfc_add_finalizer_call (&cleanup, e);
12492 276 : gfc_free_expr (e);
12493 276 : }
12494 16689 : else if ((!sym->attr.allocatable || !has_finalizer)
12495 16565 : && sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
12496 5019 : && !sym->attr.pointer && !sym->attr.save
12497 2509 : && !(sym->attr.artificial && sym->name[0] == '_')
12498 2454 : && !sym->ns->proc_name->attr.is_main_program)
12499 : {
12500 664 : int rank;
12501 664 : rank = sym->as ? sym->as->rank : 0;
12502 664 : tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank,
12503 664 : (sym->attr.codimension
12504 3 : && flag_coarray == GFC_FCOARRAY_LIB)
12505 : ? GFC_STRUCTURE_CAF_MODE_IN_COARRAY
12506 : : 0);
12507 664 : gfc_add_expr_to_block (&cleanup, tmp);
12508 : }
12509 :
12510 16965 : if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension)
12511 8686 : && !sym->attr.save && !sym->attr.result
12512 8679 : && !sym->ns->proc_name->attr.is_main_program)
12513 : {
12514 4547 : gfc_expr *e;
12515 4547 : e = has_finalizer ? gfc_lval_expr_from_sym (sym) : NULL;
12516 9094 : tmp = gfc_deallocate_with_status (sym->backend_decl, NULL_TREE, NULL_TREE,
12517 : NULL_TREE, NULL_TREE, true, e,
12518 4547 : sym->attr.codimension
12519 : ? GFC_CAF_COARRAY_DEREGISTER
12520 : : GFC_CAF_COARRAY_NOCOARRAY,
12521 : NULL_TREE, gfc_finish_block (&cleanup));
12522 4547 : if (e)
12523 45 : gfc_free_expr (e);
12524 4547 : gfc_init_block (&cleanup);
12525 4547 : gfc_add_expr_to_block (&cleanup, tmp);
12526 : }
12527 :
12528 16965 : gfc_add_init_cleanup (block, gfc_finish_block (&init),
12529 : gfc_finish_block (&cleanup));
12530 : }
12531 :
12532 : /************ Expression Walking Functions ******************/
12533 :
12534 : /* Walk a variable reference.
12535 :
12536 : Possible extension - multiple component subscripts.
12537 : x(:,:) = foo%a(:)%b(:)
12538 : Transforms to
12539 : forall (i=..., j=...)
12540 : x(i,j) = foo%a(j)%b(i)
12541 : end forall
12542 : This adds a fair amount of complexity because you need to deal with more
12543 : than one ref. Maybe handle in a similar manner to vector subscripts.
12544 : Maybe not worth the effort. */
12545 :
12546 :
12547 : static gfc_ss *
12548 688905 : gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
12549 : {
12550 688905 : gfc_ref *ref;
12551 :
12552 688905 : gfc_fix_class_refs (expr);
12553 :
12554 804978 : for (ref = expr->ref; ref; ref = ref->next)
12555 446811 : if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
12556 : break;
12557 :
12558 688905 : return gfc_walk_array_ref (ss, expr, ref);
12559 : }
12560 :
12561 : gfc_ss *
12562 689262 : gfc_walk_array_ref (gfc_ss *ss, gfc_expr *expr, gfc_ref *ref, bool array_only)
12563 : {
12564 689262 : gfc_array_ref *ar;
12565 689262 : gfc_ss *newss;
12566 689262 : int n;
12567 :
12568 1029530 : for (; ref; ref = ref->next)
12569 : {
12570 340268 : if (ref->type == REF_SUBSTRING)
12571 : {
12572 1308 : ss = gfc_get_scalar_ss (ss, ref->u.ss.start);
12573 1308 : if (ref->u.ss.end)
12574 1282 : ss = gfc_get_scalar_ss (ss, ref->u.ss.end);
12575 : }
12576 :
12577 : /* We're only interested in array sections from now on. */
12578 340268 : if (ref->type != REF_ARRAY
12579 331505 : || (array_only && ref->u.ar.as && ref->u.ar.as->rank == 0))
12580 8878 : continue;
12581 :
12582 331390 : ar = &ref->u.ar;
12583 :
12584 331390 : switch (ar->type)
12585 : {
12586 326 : case AR_ELEMENT:
12587 699 : for (n = ar->dimen - 1; n >= 0; n--)
12588 373 : ss = gfc_get_scalar_ss (ss, ar->start[n]);
12589 : break;
12590 :
12591 274630 : case AR_FULL:
12592 : /* Assumed shape arrays from interface mapping need this fix. */
12593 274630 : if (!ar->as && expr->symtree->n.sym->as)
12594 : {
12595 6 : ar->as = gfc_get_array_spec();
12596 6 : *ar->as = *expr->symtree->n.sym->as;
12597 : }
12598 274630 : newss = gfc_get_array_ss (ss, expr, ar->as->rank, GFC_SS_SECTION);
12599 274630 : newss->info->data.array.ref = ref;
12600 :
12601 : /* Make sure array is the same as array(:,:), this way
12602 : we don't need to special case all the time. */
12603 274630 : ar->dimen = ar->as->rank;
12604 632100 : for (n = 0; n < ar->dimen; n++)
12605 : {
12606 357470 : ar->dimen_type[n] = DIMEN_RANGE;
12607 :
12608 357470 : gcc_assert (ar->start[n] == NULL);
12609 357470 : gcc_assert (ar->end[n] == NULL);
12610 357470 : gcc_assert (ar->stride[n] == NULL);
12611 : }
12612 : ss = newss;
12613 : break;
12614 :
12615 56434 : case AR_SECTION:
12616 56434 : newss = gfc_get_array_ss (ss, expr, 0, GFC_SS_SECTION);
12617 56434 : newss->info->data.array.ref = ref;
12618 :
12619 : /* We add SS chains for all the subscripts in the section. */
12620 145253 : for (n = 0; n < ar->dimen; n++)
12621 : {
12622 88819 : gfc_ss *indexss;
12623 :
12624 88819 : switch (ar->dimen_type[n])
12625 : {
12626 6805 : case DIMEN_ELEMENT:
12627 : /* Add SS for elemental (scalar) subscripts. */
12628 6805 : gcc_assert (ar->start[n]);
12629 6805 : indexss = gfc_get_scalar_ss (gfc_ss_terminator, ar->start[n]);
12630 6805 : indexss->loop_chain = gfc_ss_terminator;
12631 6805 : newss->info->data.array.subscript[n] = indexss;
12632 6805 : break;
12633 :
12634 80974 : case DIMEN_RANGE:
12635 : /* We don't add anything for sections, just remember this
12636 : dimension for later. */
12637 80974 : newss->dim[newss->dimen] = n;
12638 80974 : newss->dimen++;
12639 80974 : break;
12640 :
12641 1040 : case DIMEN_VECTOR:
12642 : /* Create a GFC_SS_VECTOR index in which we can store
12643 : the vector's descriptor. */
12644 1040 : indexss = gfc_get_array_ss (gfc_ss_terminator, ar->start[n],
12645 : 1, GFC_SS_VECTOR);
12646 1040 : indexss->loop_chain = gfc_ss_terminator;
12647 1040 : newss->info->data.array.subscript[n] = indexss;
12648 1040 : newss->dim[newss->dimen] = n;
12649 1040 : newss->dimen++;
12650 1040 : break;
12651 :
12652 0 : default:
12653 : /* We should know what sort of section it is by now. */
12654 0 : gcc_unreachable ();
12655 : }
12656 : }
12657 : /* We should have at least one non-elemental dimension,
12658 : unless we are creating a descriptor for a (scalar) coarray. */
12659 56434 : gcc_assert (newss->dimen > 0
12660 : || newss->info->data.array.ref->u.ar.as->corank > 0);
12661 : ss = newss;
12662 : break;
12663 :
12664 0 : default:
12665 : /* We should know what sort of section it is by now. */
12666 0 : gcc_unreachable ();
12667 : }
12668 :
12669 : }
12670 689262 : return ss;
12671 : }
12672 :
12673 :
12674 : /* Walk an expression operator. If only one operand of a binary expression is
12675 : scalar, we must also add the scalar term to the SS chain. */
12676 :
12677 : static gfc_ss *
12678 57816 : gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
12679 : {
12680 57816 : gfc_ss *head;
12681 57816 : gfc_ss *head2;
12682 :
12683 57816 : head = gfc_walk_subexpr (ss, expr->value.op.op1);
12684 57816 : if (expr->value.op.op2 == NULL)
12685 : head2 = head;
12686 : else
12687 55176 : head2 = gfc_walk_subexpr (head, expr->value.op.op2);
12688 :
12689 : /* All operands are scalar. Pass back and let the caller deal with it. */
12690 57816 : if (head2 == ss)
12691 : return head2;
12692 :
12693 : /* All operands require scalarization. */
12694 52049 : if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
12695 : return head2;
12696 :
12697 : /* One of the operands needs scalarization, the other is scalar.
12698 : Create a gfc_ss for the scalar expression. */
12699 19442 : if (head == ss)
12700 : {
12701 : /* First operand is scalar. We build the chain in reverse order, so
12702 : add the scalar SS after the second operand. */
12703 : head = head2;
12704 2278 : while (head && head->next != ss)
12705 : head = head->next;
12706 : /* Check we haven't somehow broken the chain. */
12707 2035 : gcc_assert (head);
12708 2035 : head->next = gfc_get_scalar_ss (ss, expr->value.op.op1);
12709 : }
12710 : else /* head2 == head */
12711 : {
12712 17407 : gcc_assert (head2 == head);
12713 : /* Second operand is scalar. */
12714 17407 : head2 = gfc_get_scalar_ss (head2, expr->value.op.op2);
12715 : }
12716 :
12717 : return head2;
12718 : }
12719 :
12720 : static gfc_ss *
12721 36 : gfc_walk_conditional_expr (gfc_ss *ss, gfc_expr *expr)
12722 : {
12723 36 : gfc_ss *head;
12724 :
12725 36 : head = gfc_walk_subexpr (ss, expr->value.conditional.true_expr);
12726 36 : head = gfc_walk_subexpr (head, expr->value.conditional.false_expr);
12727 36 : return head;
12728 : }
12729 :
12730 : /* Reverse a SS chain. */
12731 :
12732 : gfc_ss *
12733 865330 : gfc_reverse_ss (gfc_ss * ss)
12734 : {
12735 865330 : gfc_ss *next;
12736 865330 : gfc_ss *head;
12737 :
12738 865330 : gcc_assert (ss != NULL);
12739 :
12740 : head = gfc_ss_terminator;
12741 1305796 : while (ss != gfc_ss_terminator)
12742 : {
12743 440466 : next = ss->next;
12744 : /* Check we didn't somehow break the chain. */
12745 440466 : gcc_assert (next != NULL);
12746 440466 : ss->next = head;
12747 440466 : head = ss;
12748 440466 : ss = next;
12749 : }
12750 :
12751 865330 : return (head);
12752 : }
12753 :
12754 :
12755 : /* Given an expression referring to a procedure, return the symbol of its
12756 : interface. We can't get the procedure symbol directly as we have to handle
12757 : the case of (deferred) type-bound procedures. */
12758 :
12759 : gfc_symbol *
12760 161 : gfc_get_proc_ifc_for_expr (gfc_expr *procedure_ref)
12761 : {
12762 161 : gfc_symbol *sym;
12763 161 : gfc_ref *ref;
12764 :
12765 161 : if (procedure_ref == NULL)
12766 : return NULL;
12767 :
12768 : /* Normal procedure case. */
12769 161 : if (procedure_ref->expr_type == EXPR_FUNCTION
12770 161 : && procedure_ref->value.function.esym)
12771 : sym = procedure_ref->value.function.esym;
12772 : else
12773 24 : sym = procedure_ref->symtree->n.sym;
12774 :
12775 : /* Typebound procedure case. */
12776 209 : for (ref = procedure_ref->ref; ref; ref = ref->next)
12777 : {
12778 48 : if (ref->type == REF_COMPONENT
12779 48 : && ref->u.c.component->attr.proc_pointer)
12780 24 : sym = ref->u.c.component->ts.interface;
12781 : else
12782 : sym = NULL;
12783 : }
12784 :
12785 : return sym;
12786 : }
12787 :
12788 :
12789 : /* Given an expression referring to an intrinsic function call,
12790 : return the intrinsic symbol. */
12791 :
12792 : gfc_intrinsic_sym *
12793 7964 : gfc_get_intrinsic_for_expr (gfc_expr *call)
12794 : {
12795 7964 : if (call == NULL)
12796 : return NULL;
12797 :
12798 : /* Normal procedure case. */
12799 2366 : if (call->expr_type == EXPR_FUNCTION)
12800 2260 : return call->value.function.isym;
12801 : else
12802 : return NULL;
12803 : }
12804 :
12805 :
12806 : /* Indicates whether an argument to an intrinsic function should be used in
12807 : scalarization. It is usually the case, except for some intrinsics
12808 : requiring the value to be constant, and using the value at compile time only.
12809 : As the value is not used at runtime in those cases, we don’t produce code
12810 : for it, and it should not be visible to the scalarizer.
12811 : FUNCTION is the intrinsic function being called, ACTUAL_ARG is the actual
12812 : argument being examined in that call, and ARG_NUM the index number
12813 : of ACTUAL_ARG in the list of arguments.
12814 : The intrinsic procedure’s dummy argument associated with ACTUAL_ARG is
12815 : identified using the name in ACTUAL_ARG if it is present (that is: if it’s
12816 : a keyword argument), otherwise using ARG_NUM. */
12817 :
12818 : static bool
12819 38054 : arg_evaluated_for_scalarization (gfc_intrinsic_sym *function,
12820 : gfc_dummy_arg *dummy_arg)
12821 : {
12822 38054 : if (function != NULL && dummy_arg != NULL)
12823 : {
12824 12467 : switch (function->id)
12825 : {
12826 241 : case GFC_ISYM_INDEX:
12827 241 : case GFC_ISYM_LEN_TRIM:
12828 241 : case GFC_ISYM_MASKL:
12829 241 : case GFC_ISYM_MASKR:
12830 241 : case GFC_ISYM_SCAN:
12831 241 : case GFC_ISYM_VERIFY:
12832 241 : if (strcmp ("kind", gfc_dummy_arg_get_name (*dummy_arg)) == 0)
12833 : return false;
12834 : /* Fallthrough. */
12835 :
12836 : default:
12837 : break;
12838 : }
12839 : }
12840 :
12841 : return true;
12842 : }
12843 :
12844 :
12845 : /* Walk the arguments of an elemental function.
12846 : PROC_EXPR is used to check whether an argument is permitted to be absent. If
12847 : it is NULL, we don't do the check and the argument is assumed to be present.
12848 : */
12849 :
12850 : gfc_ss *
12851 27035 : gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
12852 : gfc_intrinsic_sym *intrinsic_sym,
12853 : gfc_ss_type type)
12854 : {
12855 27035 : int scalar;
12856 27035 : gfc_ss *head;
12857 27035 : gfc_ss *tail;
12858 27035 : gfc_ss *newss;
12859 :
12860 27035 : head = gfc_ss_terminator;
12861 27035 : tail = NULL;
12862 :
12863 27035 : scalar = 1;
12864 66553 : for (; arg; arg = arg->next)
12865 : {
12866 39518 : gfc_dummy_arg * const dummy_arg = arg->associated_dummy;
12867 41015 : if (!arg->expr
12868 38204 : || arg->expr->expr_type == EXPR_NULL
12869 77572 : || !arg_evaluated_for_scalarization (intrinsic_sym, dummy_arg))
12870 1497 : continue;
12871 :
12872 38021 : newss = gfc_walk_subexpr (head, arg->expr);
12873 38021 : if (newss == head)
12874 : {
12875 : /* Scalar argument. */
12876 18592 : gcc_assert (type == GFC_SS_SCALAR || type == GFC_SS_REFERENCE);
12877 18592 : newss = gfc_get_scalar_ss (head, arg->expr);
12878 18592 : newss->info->type = type;
12879 18592 : if (dummy_arg)
12880 15463 : newss->info->data.scalar.dummy_arg = dummy_arg;
12881 : }
12882 : else
12883 : scalar = 0;
12884 :
12885 34892 : if (dummy_arg != NULL
12886 26426 : && gfc_dummy_arg_is_optional (*dummy_arg)
12887 2538 : && arg->expr->expr_type == EXPR_VARIABLE
12888 36596 : && (gfc_expr_attr (arg->expr).optional
12889 1223 : || gfc_expr_attr (arg->expr).allocatable
12890 37968 : || gfc_expr_attr (arg->expr).pointer))
12891 1005 : newss->info->can_be_null_ref = true;
12892 :
12893 38021 : head = newss;
12894 38021 : if (!tail)
12895 : {
12896 : tail = head;
12897 33747 : while (tail->next != gfc_ss_terminator)
12898 : tail = tail->next;
12899 : }
12900 : }
12901 :
12902 27035 : if (scalar)
12903 : {
12904 : /* If all the arguments are scalar we don't need the argument SS. */
12905 10372 : gfc_free_ss_chain (head);
12906 : /* Pass it back. */
12907 10372 : return ss;
12908 : }
12909 :
12910 : /* Add it onto the existing chain. */
12911 16663 : tail->next = ss;
12912 16663 : return head;
12913 : }
12914 :
12915 :
12916 : /* Walk a function call. Scalar functions are passed back, and taken out of
12917 : scalarization loops. For elemental functions we walk their arguments.
12918 : The result of functions returning arrays is stored in a temporary outside
12919 : the loop, so that the function is only called once. Hence we do not need
12920 : to walk their arguments. */
12921 :
12922 : static gfc_ss *
12923 63644 : gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
12924 : {
12925 63644 : gfc_intrinsic_sym *isym;
12926 63644 : gfc_symbol *sym;
12927 63644 : gfc_component *comp = NULL;
12928 :
12929 63644 : isym = expr->value.function.isym;
12930 :
12931 : /* Handle intrinsic functions separately. */
12932 63644 : if (isym)
12933 55910 : return gfc_walk_intrinsic_function (ss, expr, isym);
12934 :
12935 7734 : sym = expr->value.function.esym;
12936 7734 : if (!sym)
12937 546 : sym = expr->symtree->n.sym;
12938 :
12939 7734 : if (gfc_is_class_array_function (expr))
12940 234 : return gfc_get_array_ss (ss, expr,
12941 234 : CLASS_DATA (expr->value.function.esym->result)->as->rank,
12942 234 : GFC_SS_FUNCTION);
12943 :
12944 : /* A function that returns arrays. */
12945 7500 : comp = gfc_get_proc_ptr_comp (expr);
12946 7102 : if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
12947 7500 : || (comp && comp->attr.dimension))
12948 2680 : return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
12949 :
12950 : /* Walk the parameters of an elemental function. For now we always pass
12951 : by reference. */
12952 4820 : if (sym->attr.elemental || (comp && comp->attr.elemental))
12953 : {
12954 2224 : gfc_ss *old_ss = ss;
12955 :
12956 2224 : ss = gfc_walk_elemental_function_args (old_ss,
12957 : expr->value.function.actual,
12958 : gfc_get_intrinsic_for_expr (expr),
12959 : GFC_SS_REFERENCE);
12960 2224 : if (ss != old_ss
12961 1188 : && (comp
12962 1127 : || sym->attr.proc_pointer
12963 1127 : || sym->attr.if_source != IFSRC_DECL
12964 1005 : || sym->attr.array_outer_dependency))
12965 231 : ss->info->array_outer_dependency = 1;
12966 : }
12967 :
12968 : /* Scalar functions are OK as these are evaluated outside the scalarization
12969 : loop. Pass back and let the caller deal with it. */
12970 : return ss;
12971 : }
12972 :
12973 :
12974 : /* An array temporary is constructed for array constructors. */
12975 :
12976 : static gfc_ss *
12977 50797 : gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
12978 : {
12979 0 : return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_CONSTRUCTOR);
12980 : }
12981 :
12982 :
12983 : /* Walk an expression. Add walked expressions to the head of the SS chain.
12984 : A wholly scalar expression will not be added. */
12985 :
12986 : gfc_ss *
12987 1020643 : gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
12988 : {
12989 1020643 : gfc_ss *head;
12990 :
12991 1020643 : switch (expr->expr_type)
12992 : {
12993 688905 : case EXPR_VARIABLE:
12994 688905 : head = gfc_walk_variable_expr (ss, expr);
12995 688905 : return head;
12996 :
12997 57816 : case EXPR_OP:
12998 57816 : head = gfc_walk_op_expr (ss, expr);
12999 57816 : return head;
13000 :
13001 36 : case EXPR_CONDITIONAL:
13002 36 : head = gfc_walk_conditional_expr (ss, expr);
13003 36 : return head;
13004 :
13005 63644 : case EXPR_FUNCTION:
13006 63644 : head = gfc_walk_function_expr (ss, expr);
13007 63644 : return head;
13008 :
13009 : case EXPR_CONSTANT:
13010 : case EXPR_NULL:
13011 : case EXPR_STRUCTURE:
13012 : /* Pass back and let the caller deal with it. */
13013 : break;
13014 :
13015 50797 : case EXPR_ARRAY:
13016 50797 : head = gfc_walk_array_constructor (ss, expr);
13017 50797 : return head;
13018 :
13019 : case EXPR_SUBSTRING:
13020 : /* Pass back and let the caller deal with it. */
13021 : break;
13022 :
13023 0 : default:
13024 0 : gfc_internal_error ("bad expression type during walk (%d)",
13025 : expr->expr_type);
13026 : }
13027 : return ss;
13028 : }
13029 :
13030 :
13031 : /* Entry point for expression walking.
13032 : A return value equal to the passed chain means this is
13033 : a scalar expression. It is up to the caller to take whatever action is
13034 : necessary to translate these. */
13035 :
13036 : gfc_ss *
13037 862517 : gfc_walk_expr (gfc_expr * expr)
13038 : {
13039 862517 : gfc_ss *res;
13040 :
13041 862517 : res = gfc_walk_subexpr (gfc_ss_terminator, expr);
13042 862517 : return gfc_reverse_ss (res);
13043 : }
|
