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 59787 : gfc_array_dataptr_type (tree desc)
108 : {
109 59787 : 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 175090 : gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
225 : {
226 411329 : for (; ss != gfc_ss_terminator; ss = ss->next)
227 236239 : ss->info->useflags = flags;
228 175090 : }
229 :
230 :
231 : /* Free a gfc_ss chain. */
232 :
233 : void
234 184060 : gfc_free_ss_chain (gfc_ss * ss)
235 : {
236 184060 : gfc_ss *next;
237 :
238 376338 : while (ss != gfc_ss_terminator)
239 : {
240 192278 : gcc_assert (ss != NULL);
241 192278 : next = ss->next;
242 192278 : gfc_free_ss (ss);
243 192278 : ss = next;
244 : }
245 184060 : }
246 :
247 :
248 : static void
249 499087 : free_ss_info (gfc_ss_info *ss_info)
250 : {
251 499087 : int n;
252 :
253 499087 : ss_info->refcount--;
254 499087 : if (ss_info->refcount > 0)
255 : return;
256 :
257 494340 : gcc_assert (ss_info->refcount == 0);
258 :
259 494340 : switch (ss_info->type)
260 : {
261 : case GFC_SS_SECTION:
262 5495680 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
263 5152200 : if (ss_info->data.array.subscript[n])
264 7784 : gfc_free_ss_chain (ss_info->data.array.subscript[n]);
265 : break;
266 :
267 : default:
268 : break;
269 : }
270 :
271 494340 : free (ss_info);
272 : }
273 :
274 :
275 : /* Free a SS. */
276 :
277 : void
278 499087 : gfc_free_ss (gfc_ss * ss)
279 : {
280 499087 : free_ss_info (ss->info);
281 499087 : free (ss);
282 499087 : }
283 :
284 :
285 : /* Creates and initializes an array type gfc_ss struct. */
286 :
287 : gfc_ss *
288 417845 : gfc_get_array_ss (gfc_ss *next, gfc_expr *expr, int dimen, gfc_ss_type type)
289 : {
290 417845 : gfc_ss *ss;
291 417845 : gfc_ss_info *ss_info;
292 417845 : int i;
293 :
294 417845 : ss_info = gfc_get_ss_info ();
295 417845 : ss_info->refcount++;
296 417845 : ss_info->type = type;
297 417845 : ss_info->expr = expr;
298 :
299 417845 : ss = gfc_get_ss ();
300 417845 : ss->info = ss_info;
301 417845 : ss->next = next;
302 417845 : ss->dimen = dimen;
303 879555 : for (i = 0; i < ss->dimen; i++)
304 461710 : ss->dim[i] = i;
305 :
306 417845 : return ss;
307 : }
308 :
309 :
310 : /* Creates and initializes a temporary type gfc_ss struct. */
311 :
312 : gfc_ss *
313 11539 : gfc_get_temp_ss (tree type, tree string_length, int dimen)
314 : {
315 11539 : gfc_ss *ss;
316 11539 : gfc_ss_info *ss_info;
317 11539 : int i;
318 :
319 11539 : ss_info = gfc_get_ss_info ();
320 11539 : ss_info->refcount++;
321 11539 : ss_info->type = GFC_SS_TEMP;
322 11539 : ss_info->string_length = string_length;
323 11539 : ss_info->data.temp.type = type;
324 :
325 11539 : ss = gfc_get_ss ();
326 11539 : ss->info = ss_info;
327 11539 : ss->next = gfc_ss_terminator;
328 11539 : ss->dimen = dimen;
329 25805 : for (i = 0; i < ss->dimen; i++)
330 14266 : ss->dim[i] = i;
331 :
332 11539 : return ss;
333 : }
334 :
335 :
336 : /* Creates and initializes a scalar type gfc_ss struct. */
337 :
338 : gfc_ss *
339 67075 : gfc_get_scalar_ss (gfc_ss *next, gfc_expr *expr)
340 : {
341 67075 : gfc_ss *ss;
342 67075 : gfc_ss_info *ss_info;
343 :
344 67075 : ss_info = gfc_get_ss_info ();
345 67075 : ss_info->refcount++;
346 67075 : ss_info->type = GFC_SS_SCALAR;
347 67075 : ss_info->expr = expr;
348 :
349 67075 : ss = gfc_get_ss ();
350 67075 : ss->info = ss_info;
351 67075 : ss->next = next;
352 :
353 67075 : return ss;
354 : }
355 :
356 :
357 : /* Free all the SS associated with a loop. */
358 :
359 : void
360 185239 : gfc_cleanup_loop (gfc_loopinfo * loop)
361 : {
362 185239 : gfc_loopinfo *loop_next, **ploop;
363 185239 : gfc_ss *ss;
364 185239 : gfc_ss *next;
365 :
366 185239 : ss = loop->ss;
367 491669 : while (ss != gfc_ss_terminator)
368 : {
369 306430 : gcc_assert (ss != NULL);
370 306430 : next = ss->loop_chain;
371 306430 : gfc_free_ss (ss);
372 306430 : ss = next;
373 : }
374 :
375 : /* Remove reference to self in the parent loop. */
376 185239 : 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 188603 : 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 185239 : }
392 :
393 :
394 : static void
395 251927 : set_ss_loop (gfc_ss *ss, gfc_loopinfo *loop)
396 : {
397 251927 : int n;
398 :
399 567488 : for (; ss != gfc_ss_terminator; ss = ss->next)
400 : {
401 315561 : ss->loop = loop;
402 :
403 315561 : if (ss->info->type == GFC_SS_SCALAR
404 : || ss->info->type == GFC_SS_REFERENCE
405 266603 : || ss->info->type == GFC_SS_TEMP)
406 60497 : continue;
407 :
408 4081024 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
409 3825960 : if (ss->info->data.array.subscript[n] != NULL)
410 7513 : set_ss_loop (ss->info->data.array.subscript[n], loop);
411 : }
412 251927 : }
413 :
414 :
415 : /* Associate a SS chain with a loop. */
416 :
417 : void
418 244414 : gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
419 : {
420 244414 : gfc_ss *ss;
421 244414 : gfc_loopinfo *nested_loop;
422 :
423 244414 : if (head == gfc_ss_terminator)
424 : return;
425 :
426 244414 : set_ss_loop (head, loop);
427 :
428 244414 : ss = head;
429 796876 : for (; ss && ss != gfc_ss_terminator; ss = ss->next)
430 : {
431 308048 : 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 308048 : if (ss->next == gfc_ss_terminator)
452 244414 : ss->loop_chain = loop->ss;
453 : else
454 : ss->loop_chain = ss->next;
455 : }
456 244414 : gcc_assert (ss == gfc_ss_terminator);
457 244414 : loop->ss = head;
458 : }
459 :
460 :
461 : /* Returns true if the expression is an array pointer. The tree must be a
462 : descriptor. */
463 :
464 : static bool
465 434649 : is_pointer_array (tree expr)
466 : {
467 434649 : if (expr == NULL_TREE
468 434649 : || !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr))
469 540926 : || GFC_CLASS_TYPE_P (TREE_TYPE (expr)))
470 : return false;
471 :
472 106277 : if (VAR_P (expr)
473 106277 : && GFC_DECL_PTR_ARRAY_P (expr))
474 : return true;
475 :
476 99368 : if (TREE_CODE (expr) == PARM_DECL
477 99368 : && GFC_DECL_PTR_ARRAY_P (expr))
478 : return true;
479 :
480 99368 : if (INDIRECT_REF_P (expr)
481 99368 : && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 0)))
482 : return true;
483 :
484 : /* The field declaration is marked as a pointer array. */
485 96811 : if (TREE_CODE (expr) == COMPONENT_REF
486 16839 : && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 1))
487 100245 : && !GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (expr, 1))))
488 3434 : return true;
489 :
490 : return false;
491 : }
492 :
493 :
494 : /* If the elements of the array are spaced by the span of its descriptor,
495 : return the decl that provides that span, otherwise NULL_TREE. This is
496 : either a descriptor or the local decl of a descriptorless dummy array,
497 : which keeps the descriptor it was built from as the saved one. */
498 :
499 : static tree
500 434649 : span_addressed_array (tree expr)
501 : {
502 434649 : if (is_pointer_array (expr))
503 : return expr;
504 :
505 421749 : if (VAR_P (expr)
506 372289 : && GFC_DECL_PTR_ARRAY_P (expr)
507 2365 : && !GFC_DECL_CLASS (expr)
508 2365 : && GFC_ARRAY_TYPE_P (TREE_TYPE (expr))
509 2365 : && DECL_LANG_SPECIFIC (expr)
510 424114 : && GFC_DECL_SAVED_DESCRIPTOR (expr))
511 2365 : return expr;
512 :
513 : return NULL_TREE;
514 : }
515 :
516 :
517 : /* If the symbol or expression reference a CFI descriptor, return the
518 : pointer to the converted gfc descriptor. If an array reference is
519 : present as the last argument, check that it is the one applied to
520 : the CFI descriptor in the expression. Note that the CFI object is
521 : always the symbol in the expression! */
522 :
523 : static bool
524 376061 : get_CFI_desc (gfc_symbol *sym, gfc_expr *expr,
525 : tree *desc, gfc_array_ref *ar)
526 : {
527 376061 : tree tmp;
528 :
529 376061 : if (!is_CFI_desc (sym, expr))
530 : return false;
531 :
532 4727 : if (expr && ar)
533 : {
534 4061 : if (!(expr->ref && expr->ref->type == REF_ARRAY)
535 4043 : || (&expr->ref->u.ar != ar))
536 : return false;
537 : }
538 :
539 4697 : if (sym == NULL)
540 1108 : tmp = expr->symtree->n.sym->backend_decl;
541 : else
542 3589 : tmp = sym->backend_decl;
543 :
544 4697 : if (tmp && DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp))
545 0 : tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
546 :
547 4697 : *desc = tmp;
548 4697 : return true;
549 : }
550 :
551 :
552 : /* A helper function for gfc_get_array_span that returns the array element size
553 : of a class entity. */
554 : static tree
555 1173 : class_array_element_size (tree decl, bool unlimited)
556 : {
557 : /* Class dummys usually require extraction from the saved descriptor,
558 : which gfc_class_vptr_get does for us if necessary. This, of course,
559 : will be a component of the class object. */
560 1173 : tree vptr = gfc_class_vptr_get (decl);
561 : /* If this is an unlimited polymorphic entity with a character payload,
562 : the element size will be corrected for the string length. */
563 1173 : if (unlimited)
564 1094 : return gfc_resize_class_size_with_len (NULL,
565 547 : TREE_OPERAND (vptr, 0),
566 547 : gfc_vptr_size_get (vptr));
567 : else
568 626 : return gfc_vptr_size_get (vptr);
569 : }
570 :
571 :
572 : /* Return the span of an array. */
573 :
574 : tree
575 59100 : gfc_get_array_span (tree desc, gfc_expr *expr)
576 : {
577 59100 : tree tmp;
578 59100 : gfc_symbol *sym = (expr && expr->expr_type == EXPR_VARIABLE) ?
579 51784 : expr->symtree->n.sym : NULL;
580 :
581 59100 : if (span_addressed_array (desc)
582 59100 : || (get_CFI_desc (NULL, expr, &desc, NULL)
583 1332 : && (POINTER_TYPE_P (TREE_TYPE (desc))
584 666 : ? GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (desc)))
585 0 : : GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))))
586 : /* This will have the span field set. */
587 1294 : tmp = gfc_conv_descriptor_span_get (gfc_get_span_descriptor (desc));
588 57806 : else if (expr->ts.type == BT_ASSUMED)
589 : {
590 127 : if (DECL_LANG_SPECIFIC (desc) && GFC_DECL_SAVED_DESCRIPTOR (desc))
591 127 : desc = GFC_DECL_SAVED_DESCRIPTOR (desc);
592 127 : if (POINTER_TYPE_P (TREE_TYPE (desc)))
593 127 : desc = build_fold_indirect_ref_loc (input_location, desc);
594 127 : tmp = gfc_conv_descriptor_span_get (desc);
595 : }
596 57679 : else if (TREE_CODE (desc) == COMPONENT_REF
597 580 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
598 57808 : && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (desc, 0))))
599 : /* The descriptor is the _data field of a class object. */
600 56 : tmp = class_array_element_size (TREE_OPERAND (desc, 0),
601 56 : UNLIMITED_POLY (expr));
602 57623 : else if (sym && sym->ts.type == BT_CLASS
603 1173 : && expr->ref->type == REF_COMPONENT
604 1173 : && expr->ref->next->type == REF_ARRAY
605 1173 : && expr->ref->next->next == NULL
606 1155 : && CLASS_DATA (sym)->attr.dimension)
607 : /* Having escaped the above, this can only be a class array dummy. */
608 1117 : tmp = class_array_element_size (sym->backend_decl,
609 1117 : UNLIMITED_POLY (sym));
610 : else
611 : {
612 : /* If none of the fancy stuff works, the span is the element
613 : size of the array. Attempt to deal with unbounded character
614 : types if possible. Otherwise, return NULL_TREE. */
615 56506 : tmp = gfc_get_element_type (TREE_TYPE (desc));
616 56506 : if (tmp && TREE_CODE (tmp) == ARRAY_TYPE && TYPE_STRING_FLAG (tmp))
617 : {
618 10993 : gcc_assert (expr->ts.type == BT_CHARACTER);
619 :
620 10993 : tmp = gfc_get_character_len_in_bytes (tmp);
621 :
622 10993 : if (tmp == NULL_TREE || integer_zerop (tmp))
623 : {
624 68 : tree bs;
625 :
626 68 : tmp = gfc_get_expr_charlen (expr);
627 68 : tmp = fold_convert (gfc_array_index_type, tmp);
628 68 : bs = build_int_cst (gfc_array_index_type, expr->ts.kind);
629 68 : tmp = fold_build2_loc (input_location, MULT_EXPR,
630 : gfc_array_index_type, tmp, bs);
631 : }
632 :
633 21918 : tmp = (tmp && !integer_zerop (tmp))
634 21918 : ? (fold_convert (gfc_array_index_type, tmp)) : (NULL_TREE);
635 : }
636 : else
637 45513 : tmp = fold_convert (gfc_array_index_type,
638 : size_in_bytes (tmp));
639 : }
640 59100 : return tmp;
641 : }
642 :
643 :
644 : /* Generate an initializer for a static pointer or allocatable array. */
645 :
646 : void
647 276 : gfc_trans_static_array_pointer (gfc_symbol * sym)
648 : {
649 276 : tree type;
650 :
651 276 : gcc_assert (TREE_STATIC (sym->backend_decl));
652 : /* Just zero the data member. */
653 276 : type = TREE_TYPE (sym->backend_decl);
654 276 : DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
655 276 : }
656 :
657 :
658 : /* If the bounds of SE's loop have not yet been set, see if they can be
659 : determined from array spec AS, which is the array spec of a called
660 : function. MAPPING maps the callee's dummy arguments to the values
661 : that the caller is passing. Add any initialization and finalization
662 : code to SE. */
663 :
664 : void
665 8755 : gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
666 : gfc_se * se, gfc_array_spec * as)
667 : {
668 8755 : int n, dim, total_dim;
669 8755 : gfc_se tmpse;
670 8755 : gfc_ss *ss;
671 8755 : tree lower;
672 8755 : tree upper;
673 8755 : tree tmp;
674 :
675 8755 : total_dim = 0;
676 :
677 8755 : if (!as || as->type != AS_EXPLICIT)
678 7594 : return;
679 :
680 2347 : for (ss = se->ss; ss; ss = ss->parent)
681 : {
682 1186 : total_dim += ss->loop->dimen;
683 2727 : for (n = 0; n < ss->loop->dimen; n++)
684 : {
685 : /* The bound is known, nothing to do. */
686 1541 : if (ss->loop->to[n] != NULL_TREE)
687 485 : continue;
688 :
689 1056 : dim = ss->dim[n];
690 1056 : gcc_assert (dim < as->rank);
691 1056 : gcc_assert (ss->loop->dimen <= as->rank);
692 :
693 : /* Evaluate the lower bound. */
694 1056 : gfc_init_se (&tmpse, NULL);
695 1056 : gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
696 1056 : gfc_add_block_to_block (&se->pre, &tmpse.pre);
697 1056 : gfc_add_block_to_block (&se->post, &tmpse.post);
698 1056 : lower = fold_convert (gfc_array_index_type, tmpse.expr);
699 :
700 : /* ...and the upper bound. */
701 1056 : gfc_init_se (&tmpse, NULL);
702 1056 : gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
703 1056 : gfc_add_block_to_block (&se->pre, &tmpse.pre);
704 1056 : gfc_add_block_to_block (&se->post, &tmpse.post);
705 1056 : upper = fold_convert (gfc_array_index_type, tmpse.expr);
706 :
707 : /* Set the upper bound of the loop to UPPER - LOWER. */
708 1056 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
709 : gfc_array_index_type, upper, lower);
710 1056 : tmp = gfc_evaluate_now (tmp, &se->pre);
711 1056 : ss->loop->to[n] = tmp;
712 : }
713 : }
714 :
715 1161 : gcc_assert (total_dim == as->rank);
716 : }
717 :
718 :
719 : /* Generate code to allocate an array temporary, or create a variable to
720 : hold the data. If size is NULL, zero the descriptor so that the
721 : callee will allocate the array. If DEALLOC is true, also generate code to
722 : free the array afterwards.
723 :
724 : If INITIAL is not NULL, it is packed using internal_pack and the result used
725 : as data instead of allocating a fresh, uninitialized area of memory.
726 :
727 : Initialization code is added to PRE and finalization code to POST.
728 : DYNAMIC is true if the caller may want to extend the array later
729 : using realloc. This prevents us from putting the array on the stack. */
730 :
731 : static void
732 28173 : gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
733 : gfc_array_info * info, tree size, tree nelem,
734 : tree initial, bool dynamic, bool dealloc)
735 : {
736 28173 : tree tmp;
737 28173 : tree desc;
738 28173 : bool onstack;
739 :
740 28173 : desc = info->descriptor;
741 28173 : info->offset = gfc_index_zero_node;
742 28173 : if (size == NULL_TREE || (dynamic && integer_zerop (size)))
743 : {
744 : /* A callee allocated array. */
745 2883 : gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
746 2883 : onstack = false;
747 : }
748 : else
749 : {
750 : /* Allocate the temporary. */
751 50580 : onstack = !dynamic && initial == NULL_TREE
752 25290 : && (flag_stack_arrays
753 24905 : || gfc_can_put_var_on_stack (size));
754 :
755 5224 : if (onstack)
756 : {
757 : /* Make a temporary variable to hold the data. */
758 20066 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (nelem),
759 : nelem, gfc_index_one_node);
760 20066 : tmp = gfc_evaluate_now (tmp, pre);
761 20066 : tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
762 : tmp);
763 20066 : tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
764 : tmp);
765 20066 : tmp = gfc_create_var (tmp, "A");
766 : /* If we're here only because of -fstack-arrays we have to
767 : emit a DECL_EXPR to make the gimplifier emit alloca calls. */
768 20066 : if (!gfc_can_put_var_on_stack (size))
769 17 : gfc_add_expr_to_block (pre,
770 : fold_build1_loc (input_location,
771 17 : DECL_EXPR, TREE_TYPE (tmp),
772 : tmp));
773 20066 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
774 20066 : gfc_conv_descriptor_data_set (pre, desc, tmp);
775 : }
776 : else
777 : {
778 : /* Allocate memory to hold the data or call internal_pack. */
779 5224 : if (initial == NULL_TREE)
780 : {
781 5081 : tmp = gfc_call_malloc (pre, NULL, size);
782 5081 : tmp = gfc_evaluate_now (tmp, pre);
783 : }
784 : else
785 : {
786 143 : tree packed;
787 143 : tree source_data;
788 143 : tree was_packed;
789 143 : stmtblock_t do_copying;
790 :
791 143 : tmp = TREE_TYPE (initial); /* Pointer to descriptor. */
792 143 : gcc_assert (TREE_CODE (tmp) == POINTER_TYPE);
793 143 : tmp = TREE_TYPE (tmp); /* The descriptor itself. */
794 143 : tmp = gfc_get_element_type (tmp);
795 143 : packed = gfc_create_var (build_pointer_type (tmp), "data");
796 :
797 143 : tmp = build_call_expr_loc (input_location,
798 : gfor_fndecl_in_pack, 1, initial);
799 143 : tmp = fold_convert (TREE_TYPE (packed), tmp);
800 143 : gfc_add_modify (pre, packed, tmp);
801 :
802 143 : tmp = build_fold_indirect_ref_loc (input_location,
803 : initial);
804 143 : source_data = gfc_conv_descriptor_data_get (tmp);
805 :
806 : /* internal_pack may return source->data without any allocation
807 : or copying if it is already packed. If that's the case, we
808 : need to allocate and copy manually. */
809 :
810 143 : gfc_start_block (&do_copying);
811 143 : tmp = gfc_call_malloc (&do_copying, NULL, size);
812 143 : tmp = fold_convert (TREE_TYPE (packed), tmp);
813 143 : gfc_add_modify (&do_copying, packed, tmp);
814 143 : tmp = gfc_build_memcpy_call (packed, source_data, size);
815 143 : gfc_add_expr_to_block (&do_copying, tmp);
816 :
817 143 : was_packed = fold_build2_loc (input_location, EQ_EXPR,
818 : logical_type_node, packed,
819 : source_data);
820 143 : tmp = gfc_finish_block (&do_copying);
821 143 : tmp = build3_v (COND_EXPR, was_packed, tmp,
822 : build_empty_stmt (input_location));
823 143 : gfc_add_expr_to_block (pre, tmp);
824 :
825 143 : tmp = fold_convert (pvoid_type_node, packed);
826 : }
827 :
828 5224 : gfc_conv_descriptor_data_set (pre, desc, tmp);
829 : }
830 : }
831 28173 : info->data = gfc_conv_descriptor_data_get (desc);
832 :
833 : /* The offset is zero because we create temporaries with a zero
834 : lower bound. */
835 28173 : gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node);
836 :
837 28173 : if (dealloc && !onstack)
838 : {
839 : /* Free the temporary. */
840 7857 : tmp = gfc_conv_descriptor_data_get (desc);
841 7857 : tmp = gfc_call_free (tmp);
842 7857 : gfc_add_expr_to_block (post, tmp);
843 : }
844 28173 : }
845 :
846 :
847 : /* Get the scalarizer array dimension corresponding to actual array dimension
848 : given by ARRAY_DIM.
849 :
850 : For example, if SS represents the array ref a(1,:,:,1), it is a
851 : bidimensional scalarizer array, and the result would be 0 for ARRAY_DIM=1,
852 : and 1 for ARRAY_DIM=2.
853 : If SS represents transpose(a(:,1,1,:)), it is again a bidimensional
854 : scalarizer array, and the result would be 1 for ARRAY_DIM=0 and 0 for
855 : ARRAY_DIM=3.
856 : If SS represents sum(a(:,:,:,1), dim=1), it is a 2+1-dimensional scalarizer
857 : array. If called on the inner ss, the result would be respectively 0,1,2 for
858 : ARRAY_DIM=0,1,2. If called on the outer ss, the result would be 0,1
859 : for ARRAY_DIM=1,2. */
860 :
861 : static int
862 263757 : get_scalarizer_dim_for_array_dim (gfc_ss *ss, int array_dim)
863 : {
864 263757 : int array_ref_dim;
865 263757 : int n;
866 :
867 263757 : array_ref_dim = 0;
868 :
869 533647 : for (; ss; ss = ss->parent)
870 693625 : for (n = 0; n < ss->dimen; n++)
871 423735 : if (ss->dim[n] < array_dim)
872 77100 : array_ref_dim++;
873 :
874 263757 : return array_ref_dim;
875 : }
876 :
877 :
878 : static gfc_ss *
879 222927 : innermost_ss (gfc_ss *ss)
880 : {
881 411014 : while (ss->nested_ss != NULL)
882 : ss = ss->nested_ss;
883 :
884 402806 : return ss;
885 : }
886 :
887 :
888 :
889 : /* Get the array reference dimension corresponding to the given loop dimension.
890 : It is different from the true array dimension given by the dim array in
891 : the case of a partial array reference (i.e. a(:,:,1,:) for example)
892 : It is different from the loop dimension in the case of a transposed array.
893 : */
894 :
895 : static int
896 222927 : get_array_ref_dim_for_loop_dim (gfc_ss *ss, int loop_dim)
897 : {
898 222927 : return get_scalarizer_dim_for_array_dim (innermost_ss (ss),
899 222927 : ss->dim[loop_dim]);
900 : }
901 :
902 :
903 : /* Use the information in the ss to obtain the required information about
904 : the type and size of an array temporary, when the lhs in an assignment
905 : is a class expression. */
906 :
907 : static tree
908 327 : get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype,
909 : gfc_ss **fcnss)
910 : {
911 327 : gfc_ss *loop_ss = ss->loop->ss;
912 327 : gfc_ss *lhs_ss;
913 327 : gfc_ss *rhs_ss;
914 327 : gfc_ss *fcn_ss = NULL;
915 327 : tree tmp;
916 327 : tree tmp2;
917 327 : tree vptr;
918 327 : tree class_expr = NULL_TREE;
919 327 : tree lhs_class_expr = NULL_TREE;
920 327 : bool unlimited_rhs = false;
921 327 : bool unlimited_lhs = false;
922 327 : bool rhs_function = false;
923 327 : bool unlimited_arg1 = false;
924 327 : gfc_symbol *vtab;
925 327 : tree cntnr = NULL_TREE;
926 :
927 : /* The second element in the loop chain contains the source for the
928 : class temporary created in gfc_trans_create_temp_array. */
929 327 : rhs_ss = loop_ss->loop_chain;
930 :
931 327 : if (rhs_ss != gfc_ss_terminator
932 303 : && rhs_ss->info
933 303 : && rhs_ss->info->expr
934 303 : && rhs_ss->info->expr->ts.type == BT_CLASS
935 182 : && rhs_ss->info->data.array.descriptor)
936 : {
937 170 : if (rhs_ss->info->expr->expr_type != EXPR_VARIABLE)
938 56 : class_expr
939 56 : = gfc_get_class_from_expr (rhs_ss->info->data.array.descriptor);
940 : else
941 114 : class_expr = gfc_get_class_from_gfc_expr (rhs_ss->info->expr);
942 170 : unlimited_rhs = UNLIMITED_POLY (rhs_ss->info->expr);
943 170 : if (rhs_ss->info->expr->expr_type == EXPR_FUNCTION)
944 : rhs_function = true;
945 : }
946 :
947 : /* Usually, ss points to the function. When the function call is an actual
948 : argument, it is instead rhs_ss because the ss chain is shifted by one. */
949 327 : *fcnss = fcn_ss = rhs_function ? rhs_ss : ss;
950 :
951 : /* If this is a transformational function with a class result, the info
952 : class_container field points to the class container of arg1. */
953 327 : if (class_expr != NULL_TREE
954 151 : && fcn_ss->info && fcn_ss->info->expr
955 91 : && fcn_ss->info->expr->expr_type == EXPR_FUNCTION
956 91 : && fcn_ss->info->expr->value.function.isym
957 60 : && fcn_ss->info->expr->value.function.isym->transformational)
958 : {
959 60 : cntnr = ss->info->class_container;
960 60 : unlimited_arg1
961 60 : = UNLIMITED_POLY (fcn_ss->info->expr->value.function.actual->expr);
962 : }
963 :
964 : /* For an assignment the lhs is the next element in the loop chain.
965 : If we have a class rhs, this had better be a class variable
966 : expression! Otherwise, the class container from arg1 can be used
967 : to set the vptr and len fields of the result class container. */
968 327 : lhs_ss = rhs_ss->loop_chain;
969 327 : if (lhs_ss && lhs_ss != gfc_ss_terminator
970 225 : && lhs_ss->info && lhs_ss->info->expr
971 225 : && lhs_ss->info->expr->expr_type ==EXPR_VARIABLE
972 225 : && lhs_ss->info->expr->ts.type == BT_CLASS)
973 : {
974 225 : tmp = lhs_ss->info->data.array.descriptor;
975 225 : unlimited_lhs = UNLIMITED_POLY (rhs_ss->info->expr);
976 : }
977 102 : else if (cntnr != NULL_TREE)
978 : {
979 54 : tmp = gfc_class_vptr_get (class_expr);
980 54 : gfc_add_modify (pre, tmp, fold_convert (TREE_TYPE (tmp),
981 : gfc_class_vptr_get (cntnr)));
982 54 : if (unlimited_rhs)
983 : {
984 6 : tmp = gfc_class_len_get (class_expr);
985 6 : if (unlimited_arg1)
986 6 : gfc_add_modify (pre, tmp, gfc_class_len_get (cntnr));
987 : }
988 : tmp = NULL_TREE;
989 : }
990 : else
991 : tmp = NULL_TREE;
992 :
993 : /* Get the lhs class expression. */
994 231 : if (tmp != NULL_TREE && lhs_ss->loop_chain == gfc_ss_terminator)
995 213 : lhs_class_expr = gfc_get_class_from_expr (tmp);
996 : else
997 : return class_expr;
998 :
999 213 : gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (lhs_class_expr)));
1000 :
1001 : /* Set the lhs vptr and, if necessary, the _len field. */
1002 213 : if (class_expr)
1003 : {
1004 : /* Both lhs and rhs are class expressions. */
1005 79 : tmp = gfc_class_vptr_get (lhs_class_expr);
1006 158 : gfc_add_modify (pre, tmp,
1007 79 : fold_convert (TREE_TYPE (tmp),
1008 : gfc_class_vptr_get (class_expr)));
1009 79 : if (unlimited_lhs)
1010 : {
1011 31 : gcc_assert (unlimited_rhs);
1012 31 : tmp = gfc_class_len_get (lhs_class_expr);
1013 31 : tmp2 = gfc_class_len_get (class_expr);
1014 31 : gfc_add_modify (pre, tmp, tmp2);
1015 : }
1016 : }
1017 134 : else if (rhs_ss->info->data.array.descriptor)
1018 : {
1019 : /* lhs is class and rhs is intrinsic or derived type. */
1020 128 : *eltype = TREE_TYPE (rhs_ss->info->data.array.descriptor);
1021 128 : *eltype = gfc_get_element_type (*eltype);
1022 128 : vtab = gfc_find_vtab (&rhs_ss->info->expr->ts);
1023 128 : vptr = vtab->backend_decl;
1024 128 : if (vptr == NULL_TREE)
1025 24 : vptr = gfc_get_symbol_decl (vtab);
1026 128 : vptr = gfc_build_addr_expr (NULL_TREE, vptr);
1027 128 : tmp = gfc_class_vptr_get (lhs_class_expr);
1028 128 : gfc_add_modify (pre, tmp,
1029 128 : fold_convert (TREE_TYPE (tmp), vptr));
1030 :
1031 128 : if (unlimited_lhs)
1032 : {
1033 0 : tmp = gfc_class_len_get (lhs_class_expr);
1034 0 : if (rhs_ss->info
1035 0 : && rhs_ss->info->expr
1036 0 : && rhs_ss->info->expr->ts.type == BT_CHARACTER)
1037 0 : tmp2 = build_int_cst (TREE_TYPE (tmp),
1038 0 : rhs_ss->info->expr->ts.kind);
1039 : else
1040 0 : tmp2 = build_int_cst (TREE_TYPE (tmp), 0);
1041 0 : gfc_add_modify (pre, tmp, tmp2);
1042 : }
1043 : }
1044 :
1045 : return class_expr;
1046 : }
1047 :
1048 :
1049 :
1050 : /* Generate code to create and initialize the descriptor for a temporary
1051 : array. This is used for both temporaries needed by the scalarizer, and
1052 : functions returning arrays. Adjusts the loop variables to be
1053 : zero-based, and calculates the loop bounds for callee allocated arrays.
1054 : Allocate the array unless it's callee allocated (we have a callee
1055 : allocated array if 'callee_alloc' is true, or if loop->to[n] is
1056 : NULL_TREE for any n). Also fills in the descriptor, data and offset
1057 : fields of info if known. Returns the size of the array, or NULL for a
1058 : callee allocated array.
1059 :
1060 : 'eltype' == NULL signals that the temporary should be a class object.
1061 : The 'initial' expression is used to obtain the size of the dynamic
1062 : type; otherwise the allocation and initialization proceeds as for any
1063 : other expression
1064 :
1065 : PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
1066 : gfc_trans_allocate_array_storage. */
1067 :
1068 : tree
1069 28173 : gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
1070 : tree eltype, tree initial, bool dynamic,
1071 : bool dealloc, bool callee_alloc, locus * where)
1072 : {
1073 28173 : gfc_loopinfo *loop;
1074 28173 : gfc_ss *s;
1075 28173 : gfc_array_info *info;
1076 28173 : tree from[GFC_MAX_DIMENSIONS], to[GFC_MAX_DIMENSIONS];
1077 28173 : tree type;
1078 28173 : tree desc;
1079 28173 : tree tmp;
1080 28173 : tree size;
1081 28173 : tree nelem;
1082 28173 : tree cond;
1083 28173 : tree or_expr;
1084 28173 : tree elemsize;
1085 28173 : tree class_expr = NULL_TREE;
1086 28173 : gfc_ss *fcn_ss = NULL;
1087 28173 : int n, dim, tmp_dim;
1088 28173 : int total_dim = 0;
1089 :
1090 : /* This signals a class array for which we need the size of the
1091 : dynamic type. Generate an eltype and then the class expression. */
1092 28173 : if (eltype == NULL_TREE && initial)
1093 : {
1094 0 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial)));
1095 0 : class_expr = build_fold_indirect_ref_loc (input_location, initial);
1096 : /* Obtain the structure (class) expression. */
1097 0 : class_expr = gfc_get_class_from_expr (class_expr);
1098 0 : gcc_assert (class_expr);
1099 : }
1100 :
1101 : /* Otherwise, some expressions, such as class functions, arising from
1102 : dependency checking in assignments come here with class element type.
1103 : The descriptor can be obtained from the ss->info and then converted
1104 : to the class object. */
1105 28173 : if (class_expr == NULL_TREE && GFC_CLASS_TYPE_P (eltype))
1106 327 : class_expr = get_class_info_from_ss (pre, ss, &eltype, &fcn_ss);
1107 :
1108 : /* If the dynamic type is not available, use the declared type. */
1109 28173 : if (eltype && GFC_CLASS_TYPE_P (eltype))
1110 199 : eltype = gfc_get_element_type (TREE_TYPE (TYPE_FIELDS (eltype)));
1111 :
1112 28173 : if (class_expr == NULL_TREE)
1113 28022 : elemsize = fold_convert (gfc_array_index_type,
1114 : TYPE_SIZE_UNIT (eltype));
1115 : else
1116 : {
1117 : /* Unlimited polymorphic entities are initialised with NULL vptr. They
1118 : can be tested for by checking if the len field is present. If so
1119 : test the vptr before using the vtable size. */
1120 151 : tmp = gfc_class_vptr_get (class_expr);
1121 151 : tmp = fold_build2_loc (input_location, NE_EXPR,
1122 : logical_type_node,
1123 151 : tmp, build_int_cst (TREE_TYPE (tmp), 0));
1124 151 : elemsize = fold_build3_loc (input_location, COND_EXPR,
1125 : gfc_array_index_type,
1126 : tmp,
1127 : gfc_class_vtab_size_get (class_expr),
1128 : gfc_index_zero_node);
1129 151 : elemsize = gfc_evaluate_now (elemsize, pre);
1130 151 : elemsize = gfc_resize_class_size_with_len (pre, class_expr, elemsize);
1131 : /* Casting the data as a character of the dynamic length ensures that
1132 : assignment of elements works when needed. */
1133 151 : eltype = gfc_get_character_type_len (1, elemsize);
1134 : }
1135 :
1136 28173 : memset (from, 0, sizeof (from));
1137 28173 : memset (to, 0, sizeof (to));
1138 :
1139 28173 : info = &ss->info->data.array;
1140 :
1141 28173 : gcc_assert (ss->dimen > 0);
1142 28173 : gcc_assert (ss->loop->dimen == ss->dimen);
1143 :
1144 28173 : if (warn_array_temporaries && where)
1145 207 : gfc_warning (OPT_Warray_temporaries,
1146 : "Creating array temporary at %L", where);
1147 :
1148 : /* Set the lower bound to zero. */
1149 56381 : for (s = ss; s; s = s->parent)
1150 : {
1151 28208 : loop = s->loop;
1152 :
1153 28208 : total_dim += loop->dimen;
1154 65638 : for (n = 0; n < loop->dimen; n++)
1155 : {
1156 37430 : dim = s->dim[n];
1157 :
1158 : /* Callee allocated arrays may not have a known bound yet. */
1159 37430 : if (loop->to[n])
1160 34035 : loop->to[n] = gfc_evaluate_now (
1161 : fold_build2_loc (input_location, MINUS_EXPR,
1162 : gfc_array_index_type,
1163 : loop->to[n], loop->from[n]),
1164 : pre);
1165 37430 : loop->from[n] = gfc_index_zero_node;
1166 :
1167 : /* We have just changed the loop bounds, we must clear the
1168 : corresponding specloop, so that delta calculation is not skipped
1169 : later in gfc_set_delta. */
1170 37430 : loop->specloop[n] = NULL;
1171 :
1172 : /* We are constructing the temporary's descriptor based on the loop
1173 : dimensions. As the dimensions may be accessed in arbitrary order
1174 : (think of transpose) the size taken from the n'th loop may not map
1175 : to the n'th dimension of the array. We need to reconstruct loop
1176 : infos in the right order before using it to set the descriptor
1177 : bounds. */
1178 37430 : tmp_dim = get_scalarizer_dim_for_array_dim (ss, dim);
1179 37430 : from[tmp_dim] = loop->from[n];
1180 37430 : to[tmp_dim] = loop->to[n];
1181 :
1182 37430 : info->delta[dim] = gfc_index_zero_node;
1183 37430 : info->start[dim] = gfc_index_zero_node;
1184 37430 : info->end[dim] = gfc_index_zero_node;
1185 37430 : info->stride[dim] = gfc_index_one_node;
1186 : }
1187 : }
1188 :
1189 : /* Initialize the descriptor. */
1190 28173 : type =
1191 28173 : gfc_get_array_type_bounds (eltype, total_dim, 0, from, to, 1,
1192 : GFC_ARRAY_UNKNOWN, true);
1193 28173 : desc = gfc_create_var (type, "atmp");
1194 28173 : GFC_DECL_PACKED_ARRAY (desc) = 1;
1195 :
1196 : /* Emit a DECL_EXPR for the variable sized array type in
1197 : GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
1198 : sizes works correctly. */
1199 28173 : tree arraytype = TREE_TYPE (GFC_TYPE_ARRAY_DATAPTR_TYPE (type));
1200 28173 : if (! TYPE_NAME (arraytype))
1201 28173 : TYPE_NAME (arraytype) = build_decl (UNKNOWN_LOCATION, TYPE_DECL,
1202 : NULL_TREE, arraytype);
1203 28173 : gfc_add_expr_to_block (pre, build1 (DECL_EXPR,
1204 28173 : arraytype, TYPE_NAME (arraytype)));
1205 :
1206 28173 : if (fcn_ss && fcn_ss->info && fcn_ss->info->class_container)
1207 : {
1208 90 : suppress_warning (desc);
1209 90 : TREE_USED (desc) = 0;
1210 : }
1211 :
1212 28173 : if (class_expr != NULL_TREE
1213 28022 : || (fcn_ss && fcn_ss->info && fcn_ss->info->class_container))
1214 : {
1215 181 : tree class_data;
1216 181 : tree dtype;
1217 181 : gfc_expr *expr1 = fcn_ss ? fcn_ss->info->expr : NULL;
1218 181 : bool rank_changer;
1219 :
1220 : /* Pick out these transformational functions because they change the rank
1221 : or shape of the first argument. This requires that the class type be
1222 : changed, the dtype updated and the correct rank used. */
1223 121 : rank_changer = expr1 && expr1->expr_type == EXPR_FUNCTION
1224 121 : && expr1->value.function.isym
1225 271 : && (expr1->value.function.isym->id == GFC_ISYM_RESHAPE
1226 : || expr1->value.function.isym->id == GFC_ISYM_SPREAD
1227 : || expr1->value.function.isym->id == GFC_ISYM_PACK
1228 : || expr1->value.function.isym->id == GFC_ISYM_UNPACK);
1229 :
1230 : /* Create a class temporary for the result using the lhs class object. */
1231 181 : if (class_expr != NULL_TREE && !rank_changer)
1232 : {
1233 103 : tmp = gfc_create_var (TREE_TYPE (class_expr), "ctmp");
1234 103 : gfc_add_modify (pre, tmp, class_expr);
1235 : }
1236 : else
1237 : {
1238 78 : tree vptr;
1239 78 : class_expr = fcn_ss->info->class_container;
1240 78 : gcc_assert (expr1);
1241 :
1242 : /* Build a new class container using the arg1 class object. The class
1243 : typespec must be rebuilt because the rank might have changed. */
1244 78 : gfc_typespec ts = CLASS_DATA (expr1)->ts;
1245 78 : symbol_attribute attr = CLASS_DATA (expr1)->attr;
1246 78 : gfc_change_class (&ts, &attr, NULL, expr1->rank, 0);
1247 78 : tmp = gfc_create_var (gfc_typenode_for_spec (&ts), "ctmp");
1248 78 : fcn_ss->info->class_container = tmp;
1249 :
1250 : /* Set the vptr and obtain the element size. */
1251 78 : vptr = gfc_class_vptr_get (tmp);
1252 156 : gfc_add_modify (pre, vptr,
1253 78 : fold_convert (TREE_TYPE (vptr),
1254 : gfc_class_vptr_get (class_expr)));
1255 78 : elemsize = gfc_class_vtab_size_get (class_expr);
1256 :
1257 : /* Set the _len field, if necessary. */
1258 78 : if (UNLIMITED_POLY (expr1))
1259 : {
1260 18 : gfc_add_modify (pre, gfc_class_len_get (tmp),
1261 : gfc_class_len_get (class_expr));
1262 18 : elemsize = gfc_resize_class_size_with_len (pre, class_expr,
1263 : elemsize);
1264 : }
1265 :
1266 78 : elemsize = gfc_evaluate_now (elemsize, pre);
1267 : }
1268 :
1269 181 : class_data = gfc_class_data_get (tmp);
1270 :
1271 181 : if (rank_changer)
1272 : {
1273 : /* Take the dtype from the class expression. */
1274 72 : tree class_descr = gfc_class_data_get (class_expr);
1275 72 : dtype = gfc_conv_descriptor_dtype_get (class_descr);
1276 72 : gfc_conv_descriptor_dtype_set (pre, desc, dtype);
1277 :
1278 : /* These transformational functions change the rank. */
1279 72 : gfc_conv_descriptor_rank_set (pre, desc, ss->loop->dimen);
1280 72 : fcn_ss->info->class_container = NULL_TREE;
1281 : }
1282 :
1283 : /* Assign the new descriptor to the _data field. This allows the
1284 : vptr _copy to be used for scalarized assignment since the class
1285 : temporary can be found from the descriptor. */
1286 181 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1287 181 : TREE_TYPE (desc), desc);
1288 181 : gfc_add_modify (pre, class_data, tmp);
1289 :
1290 : /* Point desc to the class _data field. */
1291 181 : desc = class_data;
1292 181 : }
1293 : else
1294 : {
1295 : /* Fill in the array dtype. */
1296 27992 : gfc_conv_descriptor_dtype_set (pre, desc,
1297 27992 : gfc_get_dtype (TREE_TYPE (desc)));
1298 : }
1299 :
1300 28173 : info->descriptor = desc;
1301 28173 : size = gfc_index_one_node;
1302 :
1303 : /*
1304 : Fill in the bounds and stride. This is a packed array, so:
1305 :
1306 : size = 1;
1307 : for (n = 0; n < rank; n++)
1308 : {
1309 : stride[n] = size
1310 : delta = ubound[n] + 1 - lbound[n];
1311 : size = size * delta;
1312 : }
1313 : size = size * sizeof(element);
1314 : */
1315 :
1316 28173 : or_expr = NULL_TREE;
1317 :
1318 : /* If there is at least one null loop->to[n], it is a callee allocated
1319 : array. */
1320 62208 : for (n = 0; n < total_dim; n++)
1321 36082 : if (to[n] == NULL_TREE)
1322 : {
1323 : size = NULL_TREE;
1324 : break;
1325 : }
1326 :
1327 28173 : if (size == NULL_TREE)
1328 4104 : for (s = ss; s; s = s->parent)
1329 5457 : for (n = 0; n < s->loop->dimen; n++)
1330 : {
1331 3400 : dim = get_scalarizer_dim_for_array_dim (ss, s->dim[n]);
1332 :
1333 : /* For a callee allocated array express the loop bounds in terms
1334 : of the descriptor fields. */
1335 3400 : tmp = fold_build2_loc (input_location,
1336 : MINUS_EXPR, gfc_array_index_type,
1337 : gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]),
1338 : gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]));
1339 3400 : s->loop->to[n] = tmp;
1340 : }
1341 : else
1342 : {
1343 60156 : for (n = 0; n < total_dim; n++)
1344 : {
1345 : /* Store the stride and bound components in the descriptor. */
1346 34030 : gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size);
1347 :
1348 34030 : gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
1349 : gfc_index_zero_node);
1350 :
1351 34030 : gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], to[n]);
1352 :
1353 34030 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
1354 : gfc_array_index_type,
1355 : to[n], gfc_index_one_node);
1356 :
1357 : /* Check whether the size for this dimension is negative. */
1358 34030 : cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
1359 : tmp, gfc_index_zero_node);
1360 34030 : cond = gfc_evaluate_now (cond, pre);
1361 :
1362 34030 : if (n == 0)
1363 : or_expr = cond;
1364 : else
1365 7904 : or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1366 : logical_type_node, or_expr, cond);
1367 :
1368 34030 : size = fold_build2_loc (input_location, MULT_EXPR,
1369 : gfc_array_index_type, size, tmp);
1370 34030 : size = gfc_evaluate_now (size, pre);
1371 : }
1372 : }
1373 :
1374 : /* Get the size of the array. */
1375 28173 : if (size && !callee_alloc)
1376 : {
1377 : /* If or_expr is true, then the extent in at least one
1378 : dimension is zero and the size is set to zero. */
1379 25936 : size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
1380 : or_expr, gfc_index_zero_node, size);
1381 :
1382 25936 : nelem = size;
1383 25936 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
1384 : size, elemsize);
1385 : }
1386 : else
1387 : {
1388 : nelem = size;
1389 : size = NULL_TREE;
1390 : }
1391 :
1392 : /* Set the span. */
1393 28173 : tmp = fold_convert (gfc_array_index_type, elemsize);
1394 28173 : gfc_conv_descriptor_span_set (pre, desc, tmp);
1395 :
1396 28173 : gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
1397 : dynamic, dealloc);
1398 :
1399 56381 : while (ss->parent)
1400 : ss = ss->parent;
1401 :
1402 28173 : if (ss->dimen > ss->loop->temp_dim)
1403 24388 : ss->loop->temp_dim = ss->dimen;
1404 :
1405 28173 : return size;
1406 : }
1407 :
1408 :
1409 : /* Return the number of iterations in a loop that starts at START,
1410 : ends at END, and has step STEP. */
1411 :
1412 : static tree
1413 1078 : gfc_get_iteration_count (tree start, tree end, tree step)
1414 : {
1415 1078 : tree tmp;
1416 1078 : tree type;
1417 :
1418 1078 : type = TREE_TYPE (step);
1419 1078 : tmp = fold_build2_loc (input_location, MINUS_EXPR, type, end, start);
1420 1078 : tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, type, tmp, step);
1421 1078 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp,
1422 : build_int_cst (type, 1));
1423 1078 : tmp = fold_build2_loc (input_location, MAX_EXPR, type, tmp,
1424 : build_int_cst (type, 0));
1425 1078 : return fold_convert (gfc_array_index_type, tmp);
1426 : }
1427 :
1428 :
1429 : /* Return true if the bounds of iterator I can only be determined
1430 : at run time. */
1431 :
1432 : static inline bool
1433 2363 : gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
1434 : {
1435 2363 : return (i->start->expr_type != EXPR_CONSTANT
1436 1945 : || i->end->expr_type != EXPR_CONSTANT
1437 2536 : || i->step->expr_type != EXPR_CONSTANT);
1438 : }
1439 :
1440 :
1441 : /* Split the size of constructor element EXPR into the sum of two terms,
1442 : one of which can be determined at compile time and one of which must
1443 : be calculated at run time. Set *SIZE to the former and return true
1444 : if the latter might be nonzero. */
1445 :
1446 : static bool
1447 3290 : gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
1448 : {
1449 3290 : if (expr->expr_type == EXPR_ARRAY)
1450 685 : return gfc_get_array_constructor_size (size, expr->value.constructor);
1451 2605 : else if (expr->rank > 0)
1452 : {
1453 : /* Calculate everything at run time. */
1454 1031 : mpz_set_ui (*size, 0);
1455 1031 : return true;
1456 : }
1457 : else
1458 : {
1459 : /* A single element. */
1460 1574 : mpz_set_ui (*size, 1);
1461 1574 : return false;
1462 : }
1463 : }
1464 :
1465 :
1466 : /* Like gfc_get_array_constructor_element_size, but applied to the whole
1467 : of array constructor C. */
1468 :
1469 : static bool
1470 3030 : gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base)
1471 : {
1472 3030 : gfc_constructor *c;
1473 3030 : gfc_iterator *i;
1474 3030 : mpz_t val;
1475 3030 : mpz_t len;
1476 3030 : bool dynamic;
1477 :
1478 3030 : mpz_set_ui (*size, 0);
1479 3030 : mpz_init (len);
1480 3030 : mpz_init (val);
1481 :
1482 3030 : dynamic = false;
1483 7408 : for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1484 : {
1485 4378 : i = c->iterator;
1486 4378 : if (i && gfc_iterator_has_dynamic_bounds (i))
1487 : dynamic = true;
1488 : else
1489 : {
1490 2739 : dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
1491 2739 : if (i)
1492 : {
1493 : /* Multiply the static part of the element size by the
1494 : number of iterations. */
1495 128 : mpz_sub (val, i->end->value.integer, i->start->value.integer);
1496 128 : mpz_fdiv_q (val, val, i->step->value.integer);
1497 128 : mpz_add_ui (val, val, 1);
1498 128 : if (mpz_sgn (val) > 0)
1499 92 : mpz_mul (len, len, val);
1500 : else
1501 36 : mpz_set_ui (len, 0);
1502 : }
1503 2739 : mpz_add (*size, *size, len);
1504 : }
1505 : }
1506 3030 : mpz_clear (len);
1507 3030 : mpz_clear (val);
1508 3030 : return dynamic;
1509 : }
1510 :
1511 :
1512 : /* Make sure offset is a variable. */
1513 :
1514 : static void
1515 3329 : gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
1516 : tree * offsetvar)
1517 : {
1518 : /* We should have already created the offset variable. We cannot
1519 : create it here because we may be in an inner scope. */
1520 3329 : gcc_assert (*offsetvar != NULL_TREE);
1521 3329 : gfc_add_modify (pblock, *offsetvar, *poffset);
1522 3329 : *poffset = *offsetvar;
1523 3329 : TREE_USED (*offsetvar) = 1;
1524 3329 : }
1525 :
1526 :
1527 : /* Variables needed for bounds-checking. */
1528 : static bool first_len;
1529 : static tree first_len_val;
1530 : static bool typespec_chararray_ctor;
1531 :
1532 : /* Return true if DER has any CLASS allocatable component. Such components
1533 : are initialised by VIEW_CONVERT in structure constructors (a bitwise copy
1534 : of the class descriptor), so their _data pointer may refer to a non-heap
1535 : object and must not be passed to gfc_deallocate_alloc_comp_no_caf. */
1536 :
1537 : static bool
1538 4698 : has_class_alloc_comp (gfc_symbol *der)
1539 : {
1540 12613 : for (gfc_component *c = der->components; c; c = c->next)
1541 7981 : if (c->ts.type == BT_CLASS && !c->attr.class_pointer)
1542 : return true;
1543 : return false;
1544 : }
1545 :
1546 : static void
1547 12772 : gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
1548 : tree offset, gfc_se * se, gfc_expr * expr)
1549 : {
1550 12772 : tree tmp, offset_eval;
1551 :
1552 12772 : gfc_conv_expr (se, expr);
1553 :
1554 : /* Store the value. */
1555 12772 : tmp = build_fold_indirect_ref_loc (input_location,
1556 : gfc_conv_descriptor_data_get (desc));
1557 :
1558 : /* The offset may change, so get its value now and use that to free memory. */
1559 12772 : offset_eval = gfc_evaluate_now (offset, &se->pre);
1560 12772 : tmp = gfc_build_array_ref (tmp, offset_eval, NULL);
1561 :
1562 12772 : if (expr->ts.type == BT_DERIVED
1563 4607 : && (expr->expr_type == EXPR_FUNCTION
1564 4523 : || (expr->expr_type == EXPR_STRUCTURE
1565 3919 : && !has_class_alloc_comp (expr->ts.u.derived)))
1566 16733 : && expr->ts.u.derived->attr.alloc_comp)
1567 800 : gfc_add_expr_to_block (&se->finalblock,
1568 : gfc_deallocate_alloc_comp_no_caf (expr->ts.u.derived,
1569 : tmp, expr->rank,
1570 : true));
1571 :
1572 12772 : if (expr->ts.type == BT_CHARACTER)
1573 : {
1574 2154 : int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
1575 2154 : tree esize;
1576 :
1577 2154 : esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)));
1578 2154 : esize = fold_convert (gfc_charlen_type_node, esize);
1579 4308 : esize = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
1580 2154 : TREE_TYPE (esize), esize,
1581 2154 : build_int_cst (TREE_TYPE (esize),
1582 2154 : gfc_character_kinds[i].bit_size / 8));
1583 :
1584 2154 : gfc_conv_string_parameter (se);
1585 2154 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
1586 : {
1587 : /* The temporary is an array of pointers. */
1588 6 : se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1589 6 : gfc_add_modify (&se->pre, tmp, se->expr);
1590 : }
1591 : else
1592 : {
1593 : /* The temporary is an array of string values. */
1594 2148 : tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp);
1595 : /* We know the temporary and the value will be the same length,
1596 : so can use memcpy. */
1597 2148 : gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind,
1598 : se->string_length, se->expr, expr->ts.kind);
1599 : }
1600 2154 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !typespec_chararray_ctor)
1601 : {
1602 310 : if (first_len)
1603 : {
1604 130 : gfc_add_modify (&se->pre, first_len_val,
1605 130 : fold_convert (TREE_TYPE (first_len_val),
1606 : se->string_length));
1607 130 : first_len = false;
1608 : }
1609 : else
1610 : {
1611 : /* Verify that all constructor elements are of the same
1612 : length. */
1613 180 : tree rhs = fold_convert (TREE_TYPE (first_len_val),
1614 : se->string_length);
1615 180 : tree cond = fold_build2_loc (input_location, NE_EXPR,
1616 : logical_type_node, first_len_val,
1617 : rhs);
1618 180 : gfc_trans_runtime_check
1619 180 : (true, false, cond, &se->pre, &expr->where,
1620 : "Different CHARACTER lengths (%ld/%ld) in array constructor",
1621 : fold_convert (long_integer_type_node, first_len_val),
1622 : fold_convert (long_integer_type_node, se->string_length));
1623 : }
1624 : }
1625 : }
1626 10618 : else if (GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
1627 10618 : && !GFC_CLASS_TYPE_P (gfc_get_element_type (TREE_TYPE (desc))))
1628 : {
1629 : /* Assignment of a CLASS array constructor to a derived type array. */
1630 24 : if (expr->expr_type == EXPR_FUNCTION)
1631 18 : se->expr = gfc_evaluate_now (se->expr, pblock);
1632 24 : se->expr = gfc_class_data_get (se->expr);
1633 24 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
1634 24 : se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1635 24 : gfc_add_modify (&se->pre, tmp, se->expr);
1636 : }
1637 : else
1638 : {
1639 : /* TODO: Should the frontend already have done this conversion? */
1640 10594 : se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1641 10594 : gfc_add_modify (&se->pre, tmp, se->expr);
1642 : }
1643 :
1644 12772 : gfc_add_block_to_block (pblock, &se->pre);
1645 12772 : gfc_add_block_to_block (pblock, &se->post);
1646 12772 : }
1647 :
1648 :
1649 : /* Add the contents of an array to the constructor. DYNAMIC is as for
1650 : gfc_trans_array_constructor_value. */
1651 :
1652 : static void
1653 1141 : gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
1654 : tree type ATTRIBUTE_UNUSED,
1655 : tree desc, gfc_expr * expr,
1656 : tree * poffset, tree * offsetvar,
1657 : bool dynamic)
1658 : {
1659 1141 : gfc_se se;
1660 1141 : gfc_ss *ss;
1661 1141 : gfc_loopinfo loop;
1662 1141 : stmtblock_t body;
1663 1141 : tree tmp;
1664 1141 : tree size;
1665 1141 : int n;
1666 :
1667 : /* We need this to be a variable so we can increment it. */
1668 1141 : gfc_put_offset_into_var (pblock, poffset, offsetvar);
1669 :
1670 1141 : gfc_init_se (&se, NULL);
1671 :
1672 : /* Walk the array expression. */
1673 1141 : ss = gfc_walk_expr (expr);
1674 1141 : gcc_assert (ss != gfc_ss_terminator);
1675 :
1676 : /* Initialize the scalarizer. */
1677 1141 : gfc_init_loopinfo (&loop);
1678 1141 : gfc_add_ss_to_loop (&loop, ss);
1679 :
1680 : /* Initialize the loop. */
1681 1141 : gfc_conv_ss_startstride (&loop);
1682 1141 : gfc_conv_loop_setup (&loop, &expr->where);
1683 :
1684 : /* Make sure the constructed array has room for the new data. */
1685 1141 : if (dynamic)
1686 : {
1687 : /* Set SIZE to the total number of elements in the subarray. */
1688 515 : size = gfc_index_one_node;
1689 1042 : for (n = 0; n < loop.dimen; n++)
1690 : {
1691 527 : tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
1692 : gfc_index_one_node);
1693 527 : size = fold_build2_loc (input_location, MULT_EXPR,
1694 : gfc_array_index_type, size, tmp);
1695 : }
1696 :
1697 : /* Grow the constructed array by SIZE elements. */
1698 515 : gfc_grow_array (&loop.pre, desc, size);
1699 : }
1700 :
1701 : /* Make the loop body. */
1702 1141 : gfc_mark_ss_chain_used (ss, 1);
1703 1141 : gfc_start_scalarized_body (&loop, &body);
1704 1141 : gfc_copy_loopinfo_to_se (&se, &loop);
1705 1141 : se.ss = ss;
1706 :
1707 1141 : gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
1708 1141 : gcc_assert (se.ss == gfc_ss_terminator);
1709 :
1710 : /* Increment the offset. */
1711 1141 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1712 : *poffset, gfc_index_one_node);
1713 1141 : gfc_add_modify (&body, *poffset, tmp);
1714 :
1715 : /* Finish the loop. */
1716 1141 : gfc_trans_scalarizing_loops (&loop, &body);
1717 1141 : gfc_add_block_to_block (&loop.pre, &loop.post);
1718 1141 : tmp = gfc_finish_block (&loop.pre);
1719 1141 : gfc_add_expr_to_block (pblock, tmp);
1720 :
1721 1141 : gfc_cleanup_loop (&loop);
1722 1141 : }
1723 :
1724 :
1725 : /* Return true if every leaf element of an array constructor is a function
1726 : reference returning derived type DER, which has allocatable components.
1727 : Such results are moved (shallow-copied) into the constructor temporary, so
1728 : the temporary owns their allocatable components and they can all be freed
1729 : in a single sweep over the whole temporary. Returns false as soon as an
1730 : element is anything else - notably a variable, whose allocatable components
1731 : are aliased rather than owned by the temporary and must not be freed. */
1732 :
1733 : static bool
1734 521 : gfc_constructor_is_owned_alloc_comp (gfc_constructor_base base,
1735 : gfc_symbol *der)
1736 : {
1737 521 : gfc_constructor *c;
1738 :
1739 521 : if (base == NULL)
1740 : return false;
1741 :
1742 1369 : for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1743 : {
1744 1065 : gfc_expr *e = c->expr;
1745 1065 : if (e->expr_type == EXPR_ARRAY)
1746 : {
1747 54 : if (!gfc_constructor_is_owned_alloc_comp (e->value.constructor, der))
1748 : return false;
1749 : }
1750 1011 : else if (!(e->ts.type == BT_DERIVED
1751 1011 : && (e->expr_type == EXPR_FUNCTION
1752 972 : || (e->expr_type == EXPR_STRUCTURE
1753 779 : && !has_class_alloc_comp (e->ts.u.derived)))
1754 794 : && e->ts.u.derived == der))
1755 : return false;
1756 : }
1757 : return true;
1758 : }
1759 :
1760 :
1761 : /* Assign the values to the elements of an array constructor. DYNAMIC
1762 : is true if descriptor DESC only contains enough data for the static
1763 : size calculated by gfc_get_array_constructor_size. When true, memory
1764 : for the dynamic parts must be allocated using realloc. OWNED_SWEEP is
1765 : true when the caller will free the allocatable components of every
1766 : constructor element in one sweep over the whole temporary; in that case
1767 : the per-element finalization built here is suppressed to avoid a double
1768 : free. */
1769 :
1770 : static void
1771 8361 : gfc_trans_array_constructor_value (stmtblock_t * pblock,
1772 : stmtblock_t * finalblock,
1773 : tree type, tree desc,
1774 : gfc_constructor_base base, tree * poffset,
1775 : tree * offsetvar, bool dynamic,
1776 : bool owned_sweep)
1777 : {
1778 8361 : tree tmp;
1779 8361 : tree start = NULL_TREE;
1780 8361 : tree end = NULL_TREE;
1781 8361 : tree step = NULL_TREE;
1782 8361 : stmtblock_t body;
1783 8361 : gfc_se se;
1784 8361 : mpz_t size;
1785 8361 : gfc_constructor *c;
1786 8361 : gfc_typespec ts;
1787 8361 : int ctr = 0;
1788 :
1789 8361 : tree shadow_loopvar = NULL_TREE;
1790 8361 : gfc_saved_var saved_loopvar;
1791 :
1792 8361 : ts.type = BT_UNKNOWN;
1793 8361 : mpz_init (size);
1794 22749 : for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1795 : {
1796 14388 : ctr++;
1797 : /* If this is an iterator or an array, the offset must be a variable. */
1798 14388 : if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
1799 2188 : gfc_put_offset_into_var (pblock, poffset, offsetvar);
1800 :
1801 : /* Shadowing the iterator avoids changing its value and saves us from
1802 : keeping track of it. Further, it makes sure that there's always a
1803 : backend-decl for the symbol, even if there wasn't one before,
1804 : e.g. in the case of an iterator that appears in a specification
1805 : expression in an interface mapping. */
1806 14388 : if (c->iterator)
1807 : {
1808 1489 : gfc_symbol *sym;
1809 1489 : tree type;
1810 :
1811 : /* Evaluate loop bounds before substituting the loop variable
1812 : in case they depend on it. Such a case is invalid, but it is
1813 : not more expensive to do the right thing here.
1814 : See PR 44354. */
1815 1489 : gfc_init_se (&se, NULL);
1816 1489 : gfc_conv_expr_val (&se, c->iterator->start);
1817 1489 : gfc_add_block_to_block (pblock, &se.pre);
1818 1489 : start = gfc_evaluate_now (se.expr, pblock);
1819 :
1820 1489 : gfc_init_se (&se, NULL);
1821 1489 : gfc_conv_expr_val (&se, c->iterator->end);
1822 1489 : gfc_add_block_to_block (pblock, &se.pre);
1823 1489 : end = gfc_evaluate_now (se.expr, pblock);
1824 :
1825 1489 : gfc_init_se (&se, NULL);
1826 1489 : gfc_conv_expr_val (&se, c->iterator->step);
1827 1489 : gfc_add_block_to_block (pblock, &se.pre);
1828 1489 : step = gfc_evaluate_now (se.expr, pblock);
1829 :
1830 1489 : sym = c->iterator->var->symtree->n.sym;
1831 1489 : type = gfc_typenode_for_spec (&sym->ts);
1832 :
1833 1489 : shadow_loopvar = gfc_create_var (type, "shadow_loopvar");
1834 1489 : gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar);
1835 : }
1836 :
1837 14388 : gfc_start_block (&body);
1838 :
1839 14388 : if (c->expr->expr_type == EXPR_ARRAY)
1840 : {
1841 : /* Array constructors can be nested. */
1842 1511 : gfc_trans_array_constructor_value (&body, finalblock, type,
1843 : desc, c->expr->value.constructor,
1844 : poffset, offsetvar, dynamic,
1845 : owned_sweep);
1846 : }
1847 12877 : else if (c->expr->rank > 0)
1848 : {
1849 1141 : gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
1850 : poffset, offsetvar, dynamic);
1851 : }
1852 : else
1853 : {
1854 : /* This code really upsets the gimplifier so don't bother for now. */
1855 : gfc_constructor *p;
1856 : HOST_WIDE_INT n;
1857 : HOST_WIDE_INT size;
1858 :
1859 : p = c;
1860 : n = 0;
1861 13544 : while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1862 : {
1863 1808 : p = gfc_constructor_next (p);
1864 1808 : n++;
1865 : }
1866 : /* Constructor with few constant elements, or element size not
1867 : known at compile time (e.g. deferred-length character). */
1868 11736 : if (n < 4 || !INTEGER_CST_P (TYPE_SIZE_UNIT (type)))
1869 : {
1870 : /* Scalar values. */
1871 11631 : gfc_init_se (&se, NULL);
1872 11631 : if (IS_PDT (c->expr) && c->expr->expr_type == EXPR_STRUCTURE)
1873 276 : c->expr->must_finalize = 1;
1874 :
1875 11631 : gfc_trans_array_ctor_element (&body, desc, *poffset,
1876 : &se, c->expr);
1877 :
1878 11631 : *poffset = fold_build2_loc (input_location, PLUS_EXPR,
1879 : gfc_array_index_type,
1880 : *poffset, gfc_index_one_node);
1881 : /* Unless the whole temporary is being swept by the caller, add
1882 : the per-element finalization. The sweep is used when every
1883 : element is an owned function result, which is the only way to
1884 : correctly free elements produced inside an implied-do loop. */
1885 11631 : if (finalblock && !owned_sweep)
1886 496 : gfc_add_block_to_block (finalblock, &se.finalblock);
1887 : }
1888 : else
1889 : {
1890 : /* Collect multiple scalar constants into a constructor. */
1891 105 : vec<constructor_elt, va_gc> *v = NULL;
1892 105 : tree init;
1893 105 : tree bound;
1894 105 : tree tmptype;
1895 105 : HOST_WIDE_INT idx = 0;
1896 :
1897 105 : p = c;
1898 : /* Count the number of consecutive scalar constants. */
1899 837 : while (p && !(p->iterator
1900 745 : || p->expr->expr_type != EXPR_CONSTANT))
1901 : {
1902 732 : gfc_init_se (&se, NULL);
1903 732 : gfc_conv_constant (&se, p->expr);
1904 :
1905 732 : if (c->expr->ts.type != BT_CHARACTER)
1906 660 : se.expr = fold_convert (type, se.expr);
1907 : /* For constant character array constructors we build
1908 : an array of pointers. */
1909 72 : else if (POINTER_TYPE_P (type))
1910 0 : se.expr = gfc_build_addr_expr
1911 0 : (gfc_get_pchar_type (p->expr->ts.kind),
1912 : se.expr);
1913 :
1914 732 : CONSTRUCTOR_APPEND_ELT (v,
1915 : build_int_cst (gfc_array_index_type,
1916 : idx++),
1917 : se.expr);
1918 732 : c = p;
1919 732 : p = gfc_constructor_next (p);
1920 : }
1921 :
1922 105 : bound = size_int (n - 1);
1923 : /* Create an array type to hold them. */
1924 105 : tmptype = build_range_type (gfc_array_index_type,
1925 : gfc_index_zero_node, bound);
1926 105 : tmptype = build_array_type (type, tmptype);
1927 :
1928 105 : init = build_constructor (tmptype, v);
1929 105 : TREE_CONSTANT (init) = 1;
1930 105 : TREE_STATIC (init) = 1;
1931 : /* Create a static variable to hold the data. */
1932 105 : tmp = gfc_create_var (tmptype, "data");
1933 105 : TREE_STATIC (tmp) = 1;
1934 105 : TREE_CONSTANT (tmp) = 1;
1935 105 : TREE_READONLY (tmp) = 1;
1936 105 : DECL_INITIAL (tmp) = init;
1937 105 : init = tmp;
1938 :
1939 : /* Use BUILTIN_MEMCPY to assign the values. */
1940 105 : tmp = gfc_conv_descriptor_data_get (desc);
1941 105 : tmp = build_fold_indirect_ref_loc (input_location,
1942 : tmp);
1943 105 : tmp = gfc_build_array_ref (tmp, *poffset, NULL);
1944 105 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1945 105 : init = gfc_build_addr_expr (NULL_TREE, init);
1946 :
1947 105 : size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1948 105 : bound = build_int_cst (size_type_node, n * size);
1949 105 : tmp = build_call_expr_loc (input_location,
1950 : builtin_decl_explicit (BUILT_IN_MEMCPY),
1951 : 3, tmp, init, bound);
1952 105 : gfc_add_expr_to_block (&body, tmp);
1953 :
1954 105 : *poffset = fold_build2_loc (input_location, PLUS_EXPR,
1955 : gfc_array_index_type, *poffset,
1956 105 : build_int_cst (gfc_array_index_type, n));
1957 : }
1958 11736 : if (!INTEGER_CST_P (*poffset))
1959 : {
1960 1791 : gfc_add_modify (&body, *offsetvar, *poffset);
1961 1791 : *poffset = *offsetvar;
1962 : }
1963 :
1964 11736 : if (!c->iterator)
1965 11736 : ts = c->expr->ts;
1966 : }
1967 :
1968 : /* The frontend should already have done any expansions
1969 : at compile-time. */
1970 14388 : if (!c->iterator)
1971 : {
1972 : /* Pass the code as is. */
1973 12899 : tmp = gfc_finish_block (&body);
1974 12899 : gfc_add_expr_to_block (pblock, tmp);
1975 : }
1976 : else
1977 : {
1978 : /* Build the implied do-loop. */
1979 1489 : stmtblock_t implied_do_block;
1980 1489 : tree cond;
1981 1489 : tree exit_label;
1982 1489 : tree loopbody;
1983 1489 : tree tmp2;
1984 :
1985 1489 : loopbody = gfc_finish_block (&body);
1986 :
1987 : /* Create a new block that holds the implied-do loop. A temporary
1988 : loop-variable is used. */
1989 1489 : gfc_start_block(&implied_do_block);
1990 :
1991 : /* Initialize the loop. */
1992 1489 : gfc_add_modify (&implied_do_block, shadow_loopvar, start);
1993 :
1994 : /* If this array expands dynamically, and the number of iterations
1995 : is not constant, we won't have allocated space for the static
1996 : part of C->EXPR's size. Do that now. */
1997 1489 : if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1998 : {
1999 : /* Get the number of iterations. */
2000 551 : tmp = gfc_get_iteration_count (shadow_loopvar, end, step);
2001 :
2002 : /* Get the static part of C->EXPR's size. */
2003 551 : gfc_get_array_constructor_element_size (&size, c->expr);
2004 551 : tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
2005 :
2006 : /* Grow the array by TMP * TMP2 elements. */
2007 551 : tmp = fold_build2_loc (input_location, MULT_EXPR,
2008 : gfc_array_index_type, tmp, tmp2);
2009 551 : gfc_grow_array (&implied_do_block, desc, tmp);
2010 : }
2011 :
2012 : /* Generate the loop body. */
2013 1489 : exit_label = gfc_build_label_decl (NULL_TREE);
2014 1489 : gfc_start_block (&body);
2015 :
2016 : /* Generate the exit condition. Depending on the sign of
2017 : the step variable we have to generate the correct
2018 : comparison. */
2019 1489 : tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2020 1489 : step, build_int_cst (TREE_TYPE (step), 0));
2021 1489 : cond = fold_build3_loc (input_location, COND_EXPR,
2022 : logical_type_node, tmp,
2023 : fold_build2_loc (input_location, GT_EXPR,
2024 : logical_type_node, shadow_loopvar, end),
2025 : fold_build2_loc (input_location, LT_EXPR,
2026 : logical_type_node, shadow_loopvar, end));
2027 1489 : tmp = build1_v (GOTO_EXPR, exit_label);
2028 1489 : TREE_USED (exit_label) = 1;
2029 1489 : tmp = build3_v (COND_EXPR, cond, tmp,
2030 : build_empty_stmt (input_location));
2031 1489 : gfc_add_expr_to_block (&body, tmp);
2032 :
2033 : /* The main loop body. */
2034 1489 : gfc_add_expr_to_block (&body, loopbody);
2035 :
2036 : /* Increase loop variable by step. */
2037 1489 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
2038 1489 : TREE_TYPE (shadow_loopvar), shadow_loopvar,
2039 : step);
2040 1489 : gfc_add_modify (&body, shadow_loopvar, tmp);
2041 :
2042 : /* Finish the loop. */
2043 1489 : tmp = gfc_finish_block (&body);
2044 1489 : tmp = build1_v (LOOP_EXPR, tmp);
2045 1489 : gfc_add_expr_to_block (&implied_do_block, tmp);
2046 :
2047 : /* Add the exit label. */
2048 1489 : tmp = build1_v (LABEL_EXPR, exit_label);
2049 1489 : gfc_add_expr_to_block (&implied_do_block, tmp);
2050 :
2051 : /* Finish the implied-do loop. */
2052 1489 : tmp = gfc_finish_block(&implied_do_block);
2053 1489 : gfc_add_expr_to_block(pblock, tmp);
2054 :
2055 1489 : gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar);
2056 : }
2057 : }
2058 :
2059 : /* F2008 4.5.6.3 para 5: If an executable construct references a structure
2060 : constructor or array constructor, the entity created by the constructor is
2061 : finalized after execution of the innermost executable construct containing
2062 : the reference. This, in fact, was later deleted by the Combined Technical
2063 : Corrigenda 1 TO 4 for fortran 2008 (f08/0011).
2064 :
2065 : Transmit finalization of this constructor through 'finalblock'. */
2066 8361 : if ((gfc_option.allow_std & (GFC_STD_F2008 | GFC_STD_F2003))
2067 8361 : && !(gfc_option.allow_std & GFC_STD_GNU)
2068 70 : && finalblock != NULL
2069 24 : && gfc_may_be_finalized (ts)
2070 18 : && ctr > 0 && desc != NULL_TREE
2071 8379 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
2072 : {
2073 18 : symbol_attribute attr;
2074 18 : gfc_se fse;
2075 18 : locus loc;
2076 18 : gfc_locus_from_location (&loc, input_location);
2077 18 : gfc_warning (0, "The structure constructor at %L has been"
2078 : " finalized. This feature was removed by f08/0011."
2079 : " Use -std=f2018 or -std=gnu to eliminate the"
2080 : " finalization.", &loc);
2081 18 : attr.pointer = attr.allocatable = 0;
2082 18 : gfc_init_se (&fse, NULL);
2083 18 : fse.expr = desc;
2084 18 : gfc_finalize_tree_expr (&fse, ts.u.derived, attr, 1);
2085 18 : gfc_add_block_to_block (finalblock, &fse.pre);
2086 18 : gfc_add_block_to_block (finalblock, &fse.finalblock);
2087 18 : gfc_add_block_to_block (finalblock, &fse.post);
2088 : }
2089 :
2090 8361 : mpz_clear (size);
2091 8361 : }
2092 :
2093 :
2094 : /* The array constructor code can create a string length with an operand
2095 : in the form of a temporary variable. This variable will retain its
2096 : context (current_function_decl). If we store this length tree in a
2097 : gfc_charlen structure which is shared by a variable in another
2098 : context, the resulting gfc_charlen structure with a variable in a
2099 : different context, we could trip the assertion in expand_expr_real_1
2100 : when it sees that a variable has been created in one context and
2101 : referenced in another.
2102 :
2103 : If this might be the case, we create a new gfc_charlen structure and
2104 : link it into the current namespace. */
2105 :
2106 : static void
2107 8455 : store_backend_decl (gfc_charlen **clp, tree len, bool force_new_cl)
2108 : {
2109 8455 : if (force_new_cl)
2110 : {
2111 8427 : gfc_charlen *new_cl = gfc_new_charlen (gfc_current_ns, *clp);
2112 8427 : *clp = new_cl;
2113 : }
2114 8455 : (*clp)->backend_decl = len;
2115 8455 : }
2116 :
2117 : /* A catch-all to obtain the string length for anything that is not
2118 : a substring of non-constant length, a constant, array or variable. */
2119 :
2120 : static void
2121 312 : get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
2122 : {
2123 312 : gfc_se se;
2124 :
2125 : /* Don't bother if we already know the length is a constant. */
2126 312 : if (*len && INTEGER_CST_P (*len))
2127 52 : return;
2128 :
2129 260 : if (!e->ref && e->ts.u.cl && e->ts.u.cl->length
2130 35 : && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
2131 : {
2132 : /* This is easy. */
2133 1 : gfc_conv_const_charlen (e->ts.u.cl);
2134 1 : *len = e->ts.u.cl->backend_decl;
2135 : }
2136 : else
2137 : {
2138 : /* Otherwise, be brutal even if inefficient. */
2139 259 : gfc_init_se (&se, NULL);
2140 :
2141 : /* No function call, in case of side effects. */
2142 259 : se.no_function_call = 1;
2143 259 : if (e->rank == 0)
2144 140 : gfc_conv_expr (&se, e);
2145 : else
2146 119 : gfc_conv_expr_descriptor (&se, e);
2147 :
2148 : /* Fix the value. */
2149 259 : *len = gfc_evaluate_now (se.string_length, &se.pre);
2150 :
2151 259 : gfc_add_block_to_block (block, &se.pre);
2152 259 : gfc_add_block_to_block (block, &se.post);
2153 :
2154 259 : store_backend_decl (&e->ts.u.cl, *len, true);
2155 : }
2156 : }
2157 :
2158 :
2159 : /* Figure out the string length of a variable reference expression.
2160 : Used by get_array_ctor_strlen. */
2161 :
2162 : static void
2163 882 : get_array_ctor_var_strlen (stmtblock_t *block, gfc_expr * expr, tree * len)
2164 : {
2165 882 : gfc_ref *ref;
2166 882 : gfc_typespec *ts;
2167 882 : mpz_t char_len;
2168 882 : gfc_se se;
2169 :
2170 : /* Don't bother if we already know the length is a constant. */
2171 882 : if (*len && INTEGER_CST_P (*len))
2172 551 : return;
2173 :
2174 420 : ts = &expr->symtree->n.sym->ts;
2175 651 : for (ref = expr->ref; ref; ref = ref->next)
2176 : {
2177 320 : switch (ref->type)
2178 : {
2179 186 : case REF_ARRAY:
2180 : /* Array references don't change the string length. */
2181 186 : if (ts->deferred)
2182 112 : get_array_ctor_all_strlen (block, expr, len);
2183 : break;
2184 :
2185 45 : case REF_COMPONENT:
2186 : /* Use the length of the component. */
2187 45 : ts = &ref->u.c.component->ts;
2188 45 : break;
2189 :
2190 89 : case REF_SUBSTRING:
2191 89 : if (ref->u.ss.end == NULL
2192 77 : || ref->u.ss.start->expr_type != EXPR_CONSTANT
2193 58 : || ref->u.ss.end->expr_type != EXPR_CONSTANT)
2194 : {
2195 : /* Note that this might evaluate expr. */
2196 64 : get_array_ctor_all_strlen (block, expr, len);
2197 64 : return;
2198 : }
2199 25 : mpz_init_set_ui (char_len, 1);
2200 25 : mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
2201 25 : mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
2202 25 : *len = gfc_conv_mpz_to_tree_type (char_len, gfc_charlen_type_node);
2203 25 : mpz_clear (char_len);
2204 25 : return;
2205 :
2206 : case REF_INQUIRY:
2207 : break;
2208 :
2209 0 : default:
2210 0 : gcc_unreachable ();
2211 : }
2212 : }
2213 :
2214 : /* A last ditch attempt that is sometimes needed for deferred characters. */
2215 331 : if (!ts->u.cl->backend_decl)
2216 : {
2217 7 : gfc_init_se (&se, NULL);
2218 7 : if (expr->rank)
2219 0 : gfc_conv_expr_descriptor (&se, expr);
2220 : else
2221 7 : gfc_conv_expr (&se, expr);
2222 7 : gcc_assert (se.string_length != NULL_TREE);
2223 7 : gfc_add_block_to_block (block, &se.pre);
2224 7 : ts->u.cl->backend_decl = se.string_length;
2225 : }
2226 :
2227 331 : *len = ts->u.cl->backend_decl;
2228 : }
2229 :
2230 :
2231 : /* Figure out the string length of a character array constructor.
2232 : If len is NULL, don't calculate the length; this happens for recursive calls
2233 : when a sub-array-constructor is an element but not at the first position,
2234 : so when we're not interested in the length.
2235 : Returns TRUE if all elements are character constants. */
2236 :
2237 : bool
2238 8795 : get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len)
2239 : {
2240 8795 : gfc_constructor *c;
2241 8795 : bool is_const;
2242 :
2243 8795 : is_const = true;
2244 :
2245 8795 : if (gfc_constructor_first (base) == NULL)
2246 : {
2247 273 : if (len)
2248 273 : *len = build_int_cstu (gfc_charlen_type_node, 0);
2249 : return is_const;
2250 : }
2251 :
2252 : /* Loop over all constructor elements to find out is_const, but in len we
2253 : want to store the length of the first, not the last, element. We can
2254 : of course exit the loop as soon as is_const is found to be false. */
2255 8522 : for (c = gfc_constructor_first (base);
2256 46731 : c && is_const; c = gfc_constructor_next (c))
2257 : {
2258 38209 : switch (c->expr->expr_type)
2259 : {
2260 37088 : case EXPR_CONSTANT:
2261 37088 : if (len && !(*len && INTEGER_CST_P (*len)))
2262 386 : *len = build_int_cstu (gfc_charlen_type_node,
2263 386 : c->expr->value.character.length);
2264 : break;
2265 :
2266 43 : case EXPR_ARRAY:
2267 43 : if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
2268 38209 : is_const = false;
2269 : break;
2270 :
2271 942 : case EXPR_VARIABLE:
2272 942 : is_const = false;
2273 942 : if (len)
2274 882 : get_array_ctor_var_strlen (block, c->expr, len);
2275 : break;
2276 :
2277 136 : default:
2278 136 : is_const = false;
2279 136 : if (len)
2280 136 : get_array_ctor_all_strlen (block, c->expr, len);
2281 : break;
2282 : }
2283 :
2284 : /* After the first iteration, we don't want the length modified. */
2285 38209 : len = NULL;
2286 : }
2287 :
2288 : return is_const;
2289 : }
2290 :
2291 : /* Check whether the array constructor C consists entirely of constant
2292 : elements, and if so returns the number of those elements, otherwise
2293 : return zero. Note, an empty or NULL array constructor returns zero. */
2294 :
2295 : unsigned HOST_WIDE_INT
2296 60224 : gfc_constant_array_constructor_p (gfc_constructor_base base)
2297 : {
2298 60224 : unsigned HOST_WIDE_INT nelem = 0;
2299 :
2300 60224 : gfc_constructor *c = gfc_constructor_first (base);
2301 545282 : while (c)
2302 : {
2303 431960 : if (c->iterator
2304 430355 : || c->expr->rank > 0
2305 429545 : || c->expr->expr_type != EXPR_CONSTANT)
2306 : return 0;
2307 424834 : c = gfc_constructor_next (c);
2308 424834 : nelem++;
2309 : }
2310 : return nelem;
2311 : }
2312 :
2313 :
2314 : /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
2315 : and the tree type of it's elements, TYPE, return a static constant
2316 : variable that is compile-time initialized. */
2317 :
2318 : tree
2319 42487 : gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
2320 : {
2321 42487 : tree tmptype, init, tmp;
2322 42487 : HOST_WIDE_INT nelem;
2323 42487 : gfc_constructor *c;
2324 42487 : gfc_array_spec as;
2325 42487 : gfc_se se;
2326 42487 : int i;
2327 42487 : vec<constructor_elt, va_gc> *v = NULL;
2328 :
2329 : /* First traverse the constructor list, converting the constants
2330 : to tree to build an initializer. */
2331 42487 : nelem = 0;
2332 42487 : c = gfc_constructor_first (expr->value.constructor);
2333 426170 : while (c)
2334 : {
2335 341196 : gfc_init_se (&se, NULL);
2336 341196 : gfc_conv_constant (&se, c->expr);
2337 341196 : if (c->expr->ts.type != BT_CHARACTER)
2338 305028 : se.expr = fold_convert (type, se.expr);
2339 36168 : else if (POINTER_TYPE_P (type))
2340 36168 : se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
2341 : se.expr);
2342 341196 : CONSTRUCTOR_APPEND_ELT (v, build_int_cst (gfc_array_index_type, nelem),
2343 : se.expr);
2344 341196 : c = gfc_constructor_next (c);
2345 341196 : nelem++;
2346 : }
2347 :
2348 : /* Next determine the tree type for the array. We use the gfortran
2349 : front-end's gfc_get_nodesc_array_type in order to create a suitable
2350 : GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
2351 :
2352 42487 : memset (&as, 0, sizeof (gfc_array_spec));
2353 :
2354 42487 : as.rank = expr->rank;
2355 42487 : as.type = AS_EXPLICIT;
2356 42487 : if (!expr->shape)
2357 : {
2358 4 : as.lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
2359 4 : as.upper[0] = gfc_get_int_expr (gfc_default_integer_kind,
2360 : NULL, nelem - 1);
2361 : }
2362 : else
2363 91675 : for (i = 0; i < expr->rank; i++)
2364 : {
2365 49192 : int tmp = (int) mpz_get_si (expr->shape[i]);
2366 49192 : as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
2367 49192 : as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind,
2368 49192 : NULL, tmp - 1);
2369 : }
2370 :
2371 42487 : tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
2372 :
2373 : /* as is not needed anymore. */
2374 134170 : for (i = 0; i < as.rank + as.corank; i++)
2375 : {
2376 49196 : gfc_free_expr (as.lower[i]);
2377 49196 : gfc_free_expr (as.upper[i]);
2378 : }
2379 :
2380 42487 : init = build_constructor (tmptype, v);
2381 :
2382 42487 : TREE_CONSTANT (init) = 1;
2383 42487 : TREE_STATIC (init) = 1;
2384 :
2385 42487 : tmp = build_decl (input_location, VAR_DECL, create_tmp_var_name ("A"),
2386 : tmptype);
2387 42487 : DECL_ARTIFICIAL (tmp) = 1;
2388 42487 : DECL_IGNORED_P (tmp) = 1;
2389 42487 : TREE_STATIC (tmp) = 1;
2390 42487 : TREE_CONSTANT (tmp) = 1;
2391 42487 : TREE_READONLY (tmp) = 1;
2392 42487 : DECL_INITIAL (tmp) = init;
2393 42487 : pushdecl (tmp);
2394 :
2395 42487 : return tmp;
2396 : }
2397 :
2398 :
2399 : /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
2400 : This mostly initializes the scalarizer state info structure with the
2401 : appropriate values to directly use the array created by the function
2402 : gfc_build_constant_array_constructor. */
2403 :
2404 : static void
2405 36576 : trans_constant_array_constructor (gfc_ss * ss, tree type)
2406 : {
2407 36576 : gfc_array_info *info;
2408 36576 : tree tmp;
2409 36576 : int i;
2410 :
2411 36576 : tmp = gfc_build_constant_array_constructor (ss->info->expr, type);
2412 :
2413 36576 : info = &ss->info->data.array;
2414 :
2415 36576 : info->descriptor = tmp;
2416 36576 : info->data = gfc_build_addr_expr (NULL_TREE, tmp);
2417 36576 : info->offset = gfc_index_zero_node;
2418 :
2419 76989 : for (i = 0; i < ss->dimen; i++)
2420 : {
2421 40413 : info->delta[i] = gfc_index_zero_node;
2422 40413 : info->start[i] = gfc_index_zero_node;
2423 40413 : info->end[i] = gfc_index_zero_node;
2424 40413 : info->stride[i] = gfc_index_one_node;
2425 : }
2426 36576 : }
2427 :
2428 :
2429 : static int
2430 36583 : get_rank (gfc_loopinfo *loop)
2431 : {
2432 36583 : int rank;
2433 :
2434 36583 : rank = 0;
2435 157126 : for (; loop; loop = loop->parent)
2436 78569 : rank += loop->dimen;
2437 :
2438 41974 : return rank;
2439 : }
2440 :
2441 :
2442 : /* Helper routine of gfc_trans_array_constructor to determine if the
2443 : bounds of the loop specified by LOOP are constant and simple enough
2444 : to use with trans_constant_array_constructor. Returns the
2445 : iteration count of the loop if suitable, and NULL_TREE otherwise. */
2446 :
2447 : static tree
2448 36583 : constant_array_constructor_loop_size (gfc_loopinfo * l)
2449 : {
2450 36583 : gfc_loopinfo *loop;
2451 36583 : tree size = gfc_index_one_node;
2452 36583 : tree tmp;
2453 36583 : int i, total_dim;
2454 :
2455 36583 : total_dim = get_rank (l);
2456 :
2457 73166 : for (loop = l; loop; loop = loop->parent)
2458 : {
2459 77015 : for (i = 0; i < loop->dimen; i++)
2460 : {
2461 : /* If the bounds aren't constant, return NULL_TREE. */
2462 40432 : if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
2463 : return NULL_TREE;
2464 40426 : if (!integer_zerop (loop->from[i]))
2465 : {
2466 : /* Only allow nonzero "from" in one-dimensional arrays. */
2467 0 : if (total_dim != 1)
2468 : return NULL_TREE;
2469 0 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2470 : gfc_array_index_type,
2471 : loop->to[i], loop->from[i]);
2472 : }
2473 : else
2474 40426 : tmp = loop->to[i];
2475 40426 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
2476 : gfc_array_index_type, tmp, gfc_index_one_node);
2477 40426 : size = fold_build2_loc (input_location, MULT_EXPR,
2478 : gfc_array_index_type, size, tmp);
2479 : }
2480 : }
2481 :
2482 : return size;
2483 : }
2484 :
2485 :
2486 : static tree *
2487 43426 : get_loop_upper_bound_for_array (gfc_ss *array, int array_dim)
2488 : {
2489 43426 : gfc_ss *ss;
2490 43426 : int n;
2491 :
2492 43426 : gcc_assert (array->nested_ss == NULL);
2493 :
2494 43426 : for (ss = array; ss; ss = ss->parent)
2495 43426 : for (n = 0; n < ss->loop->dimen; n++)
2496 43426 : if (array_dim == get_array_ref_dim_for_loop_dim (ss, n))
2497 43426 : return &(ss->loop->to[n]);
2498 :
2499 0 : gcc_unreachable ();
2500 : }
2501 :
2502 :
2503 : static gfc_loopinfo *
2504 715283 : outermost_loop (gfc_loopinfo * loop)
2505 : {
2506 933124 : while (loop->parent != NULL)
2507 : loop = loop->parent;
2508 :
2509 721971 : return loop;
2510 : }
2511 :
2512 :
2513 : /* Array constructors are handled by constructing a temporary, then using that
2514 : within the scalarization loop. This is not optimal, but seems by far the
2515 : simplest method. */
2516 :
2517 : static void
2518 43426 : trans_array_constructor (gfc_ss * ss, locus * where)
2519 : {
2520 43426 : gfc_constructor_base c;
2521 43426 : tree offset;
2522 43426 : tree offsetvar;
2523 43426 : tree desc;
2524 43426 : tree type;
2525 43426 : tree tmp;
2526 43426 : tree *loop_ubound0;
2527 43426 : bool dynamic;
2528 43426 : bool old_first_len, old_typespec_chararray_ctor;
2529 43426 : tree old_first_len_val;
2530 43426 : gfc_loopinfo *loop, *outer_loop;
2531 43426 : gfc_ss_info *ss_info;
2532 43426 : gfc_expr *expr;
2533 43426 : gfc_ss *s;
2534 43426 : tree neg_len;
2535 43426 : char *msg;
2536 43426 : stmtblock_t finalblock;
2537 43426 : bool finalize_required;
2538 43426 : bool owned_sweep = false;
2539 :
2540 : /* Save the old values for nested checking. */
2541 43426 : old_first_len = first_len;
2542 43426 : old_first_len_val = first_len_val;
2543 43426 : old_typespec_chararray_ctor = typespec_chararray_ctor;
2544 :
2545 43426 : loop = ss->loop;
2546 43426 : outer_loop = outermost_loop (loop);
2547 43426 : ss_info = ss->info;
2548 43426 : expr = ss_info->expr;
2549 :
2550 : /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
2551 : typespec was given for the array constructor. */
2552 86852 : typespec_chararray_ctor = (expr->ts.type == BT_CHARACTER
2553 8196 : && expr->ts.u.cl
2554 51622 : && expr->ts.u.cl->length_from_typespec);
2555 :
2556 43426 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2557 2542 : && expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
2558 : {
2559 1468 : first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
2560 1468 : first_len = true;
2561 : }
2562 :
2563 43426 : gcc_assert (ss->dimen == ss->loop->dimen);
2564 :
2565 43426 : c = expr->value.constructor;
2566 43426 : if (expr->ts.type == BT_CHARACTER)
2567 : {
2568 8196 : bool const_string;
2569 8196 : bool force_new_cl = false;
2570 :
2571 : /* get_array_ctor_strlen walks the elements of the constructor, if a
2572 : typespec was given, we already know the string length and want the one
2573 : specified there. */
2574 8196 : if (typespec_chararray_ctor && expr->ts.u.cl->length
2575 520 : && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
2576 : {
2577 28 : gfc_se length_se;
2578 :
2579 28 : const_string = false;
2580 28 : gfc_init_se (&length_se, NULL);
2581 28 : gfc_conv_expr_type (&length_se, expr->ts.u.cl->length,
2582 : gfc_charlen_type_node);
2583 28 : ss_info->string_length = length_se.expr;
2584 :
2585 : /* Check if the character length is negative. If it is, then
2586 : set LEN = 0. */
2587 28 : neg_len = fold_build2_loc (input_location, LT_EXPR,
2588 : logical_type_node, ss_info->string_length,
2589 28 : build_zero_cst (TREE_TYPE
2590 : (ss_info->string_length)));
2591 : /* Print a warning if bounds checking is enabled. */
2592 28 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2593 : {
2594 18 : msg = xasprintf ("Negative character length treated as LEN = 0");
2595 18 : gfc_trans_runtime_check (false, true, neg_len, &length_se.pre,
2596 : where, msg);
2597 18 : free (msg);
2598 : }
2599 :
2600 28 : ss_info->string_length
2601 28 : = fold_build3_loc (input_location, COND_EXPR,
2602 : gfc_charlen_type_node, neg_len,
2603 : build_zero_cst
2604 28 : (TREE_TYPE (ss_info->string_length)),
2605 : ss_info->string_length);
2606 28 : ss_info->string_length = gfc_evaluate_now (ss_info->string_length,
2607 : &length_se.pre);
2608 28 : gfc_add_block_to_block (&outer_loop->pre, &length_se.pre);
2609 28 : gfc_add_block_to_block (&outer_loop->post, &length_se.post);
2610 28 : }
2611 : else
2612 : {
2613 8168 : const_string = get_array_ctor_strlen (&outer_loop->pre, c,
2614 : &ss_info->string_length);
2615 8168 : force_new_cl = true;
2616 :
2617 : /* Initialize "len" with string length for bounds checking. */
2618 8168 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2619 1486 : && !typespec_chararray_ctor
2620 1468 : && ss_info->string_length)
2621 : {
2622 1468 : gfc_se length_se;
2623 :
2624 1468 : gfc_init_se (&length_se, NULL);
2625 1468 : gfc_add_modify (&length_se.pre, first_len_val,
2626 1468 : fold_convert (TREE_TYPE (first_len_val),
2627 : ss_info->string_length));
2628 1468 : ss_info->string_length = gfc_evaluate_now (ss_info->string_length,
2629 : &length_se.pre);
2630 1468 : gfc_add_block_to_block (&outer_loop->pre, &length_se.pre);
2631 1468 : gfc_add_block_to_block (&outer_loop->post, &length_se.post);
2632 : }
2633 : }
2634 :
2635 : /* Complex character array constructors should have been taken care of
2636 : and not end up here. */
2637 8196 : gcc_assert (ss_info->string_length);
2638 :
2639 8196 : store_backend_decl (&expr->ts.u.cl, ss_info->string_length, force_new_cl);
2640 :
2641 8196 : type = gfc_get_character_type_len (expr->ts.kind, ss_info->string_length);
2642 8196 : if (const_string)
2643 7238 : type = build_pointer_type (type);
2644 : }
2645 : else
2646 35255 : type = gfc_typenode_for_spec (expr->ts.type == BT_CLASS
2647 25 : ? &CLASS_DATA (expr)->ts : &expr->ts);
2648 :
2649 : /* See if the constructor determines the loop bounds. */
2650 43426 : dynamic = false;
2651 :
2652 43426 : loop_ubound0 = get_loop_upper_bound_for_array (ss, 0);
2653 :
2654 85400 : if (expr->shape && get_rank (loop) > 1 && *loop_ubound0 == NULL_TREE)
2655 : {
2656 : /* We have a multidimensional parameter. */
2657 0 : for (s = ss; s; s = s->parent)
2658 : {
2659 : int n;
2660 0 : for (n = 0; n < s->loop->dimen; n++)
2661 : {
2662 0 : s->loop->from[n] = gfc_index_zero_node;
2663 0 : s->loop->to[n] = gfc_conv_mpz_to_tree (expr->shape[s->dim[n]],
2664 : gfc_index_integer_kind);
2665 0 : s->loop->to[n] = fold_build2_loc (input_location, MINUS_EXPR,
2666 : gfc_array_index_type,
2667 0 : s->loop->to[n],
2668 : gfc_index_one_node);
2669 : }
2670 : }
2671 : }
2672 :
2673 43426 : if (*loop_ubound0 == NULL_TREE)
2674 : {
2675 893 : mpz_t size;
2676 :
2677 : /* We should have a 1-dimensional, zero-based loop. */
2678 893 : gcc_assert (loop->parent == NULL && loop->nested == NULL);
2679 893 : gcc_assert (loop->dimen == 1);
2680 893 : gcc_assert (integer_zerop (loop->from[0]));
2681 :
2682 : /* Split the constructor size into a static part and a dynamic part.
2683 : Allocate the static size up-front and record whether the dynamic
2684 : size might be nonzero. */
2685 893 : mpz_init (size);
2686 893 : dynamic = gfc_get_array_constructor_size (&size, c);
2687 893 : mpz_sub_ui (size, size, 1);
2688 893 : loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
2689 893 : mpz_clear (size);
2690 : }
2691 :
2692 : /* Special case constant array constructors. */
2693 893 : if (!dynamic)
2694 : {
2695 42558 : unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
2696 42558 : if (nelem > 0)
2697 : {
2698 36583 : tree size = constant_array_constructor_loop_size (loop);
2699 36577 : if (size && compare_tree_int (size, nelem) == 0
2700 73160 : && TREE_CODE (TYPE_SIZE (type)) == INTEGER_CST)
2701 : {
2702 36576 : trans_constant_array_constructor (ss, type);
2703 36576 : goto finish;
2704 : }
2705 : }
2706 : }
2707 :
2708 6850 : gfc_trans_create_temp_array (&outer_loop->pre, &outer_loop->post, ss, type,
2709 : NULL_TREE, dynamic, true, false, where);
2710 :
2711 6850 : desc = ss_info->data.array.descriptor;
2712 6850 : offset = gfc_index_zero_node;
2713 6850 : offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
2714 6850 : suppress_warning (offsetvar);
2715 6850 : TREE_USED (offsetvar) = 0;
2716 :
2717 6850 : gfc_init_block (&finalblock);
2718 6850 : finalize_required = expr->must_finalize;
2719 6850 : if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
2720 : finalize_required = true;
2721 :
2722 6850 : if (IS_PDT (expr))
2723 : finalize_required = true;
2724 :
2725 : /* If every element of the constructor is a function result with allocatable
2726 : components, those components are owned by the temporary and are freed in a
2727 : single sweep over the whole array below. This is the only way to free the
2728 : elements produced inside an implied-do loop, where a single compile-time
2729 : element stands for many runtime elements. */
2730 13627 : owned_sweep = finalize_required
2731 552 : && expr->ts.type == BT_DERIVED
2732 552 : && expr->ts.u.derived->attr.alloc_comp
2733 7244 : && gfc_constructor_is_owned_alloc_comp (c, expr->ts.u.derived);
2734 :
2735 6850 : gfc_trans_array_constructor_value (&outer_loop->pre,
2736 : finalize_required ? &finalblock : NULL,
2737 : type, desc, c, &offset, &offsetvar,
2738 : dynamic, owned_sweep);
2739 :
2740 6850 : if (owned_sweep)
2741 250 : gfc_add_expr_to_block (&finalblock,
2742 250 : gfc_deallocate_alloc_comp_no_caf (expr->ts.u.derived,
2743 : desc, 1, true));
2744 :
2745 : /* If the array grows dynamically, the upper bound of the loop variable
2746 : is determined by the array's final upper bound. */
2747 6850 : if (dynamic)
2748 : {
2749 868 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2750 : gfc_array_index_type,
2751 : offsetvar, gfc_index_one_node);
2752 868 : tmp = gfc_evaluate_now (tmp, &outer_loop->pre);
2753 868 : if (*loop_ubound0 && VAR_P (*loop_ubound0))
2754 0 : gfc_add_modify (&outer_loop->pre, *loop_ubound0, tmp);
2755 : else
2756 868 : *loop_ubound0 = tmp;
2757 : }
2758 :
2759 6850 : if (TREE_USED (offsetvar))
2760 2188 : pushdecl (offsetvar);
2761 : else
2762 4662 : gcc_assert (INTEGER_CST_P (offset));
2763 :
2764 : #if 0
2765 : /* Disable bound checking for now because it's probably broken. */
2766 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2767 : {
2768 : gcc_unreachable ();
2769 : }
2770 : #endif
2771 :
2772 4662 : finish:
2773 : /* Restore old values of globals. */
2774 43426 : first_len = old_first_len;
2775 43426 : first_len_val = old_first_len_val;
2776 43426 : typespec_chararray_ctor = old_typespec_chararray_ctor;
2777 :
2778 : /* F2008 4.5.6.3 para 5: If an executable construct references a structure
2779 : constructor or array constructor, the entity created by the constructor is
2780 : finalized after execution of the innermost executable construct containing
2781 : the reference. */
2782 43426 : if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
2783 1758 : && finalblock.head != NULL_TREE)
2784 322 : gfc_prepend_expr_to_block (&loop->post, finalblock.head);
2785 43426 : }
2786 :
2787 :
2788 : /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
2789 : called after evaluating all of INFO's vector dimensions. Go through
2790 : each such vector dimension and see if we can now fill in any missing
2791 : loop bounds. */
2792 :
2793 : static void
2794 183287 : set_vector_loop_bounds (gfc_ss * ss)
2795 : {
2796 183287 : gfc_loopinfo *loop, *outer_loop;
2797 183287 : gfc_array_info *info;
2798 183287 : gfc_se se;
2799 183287 : tree tmp;
2800 183287 : tree desc;
2801 183287 : tree zero;
2802 183287 : int n;
2803 183287 : int dim;
2804 :
2805 183287 : outer_loop = outermost_loop (ss->loop);
2806 :
2807 183287 : info = &ss->info->data.array;
2808 :
2809 371210 : for (; ss; ss = ss->parent)
2810 : {
2811 187923 : loop = ss->loop;
2812 :
2813 447270 : for (n = 0; n < loop->dimen; n++)
2814 : {
2815 259347 : dim = ss->dim[n];
2816 259347 : if (info->ref->u.ar.dimen_type[dim] != DIMEN_VECTOR
2817 980 : || loop->to[n] != NULL)
2818 259167 : continue;
2819 :
2820 : /* Loop variable N indexes vector dimension DIM, and we don't
2821 : yet know the upper bound of loop variable N. Set it to the
2822 : difference between the vector's upper and lower bounds. */
2823 180 : gcc_assert (loop->from[n] == gfc_index_zero_node);
2824 180 : gcc_assert (info->subscript[dim]
2825 : && info->subscript[dim]->info->type == GFC_SS_VECTOR);
2826 :
2827 180 : gfc_init_se (&se, NULL);
2828 180 : desc = info->subscript[dim]->info->data.array.descriptor;
2829 180 : zero = gfc_rank_cst[0];
2830 180 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2831 : gfc_array_index_type,
2832 : gfc_conv_descriptor_ubound_get (desc, zero),
2833 : gfc_conv_descriptor_lbound_get (desc, zero));
2834 180 : tmp = gfc_evaluate_now (tmp, &outer_loop->pre);
2835 180 : loop->to[n] = tmp;
2836 : }
2837 : }
2838 183287 : }
2839 :
2840 :
2841 : /* Tells whether a scalar argument to an elemental procedure is saved out
2842 : of a scalarization loop as a value or as a reference. */
2843 :
2844 : bool
2845 45888 : gfc_scalar_elemental_arg_saved_as_reference (gfc_ss_info * ss_info)
2846 : {
2847 45888 : if (ss_info->type != GFC_SS_REFERENCE)
2848 : return false;
2849 :
2850 10294 : if (ss_info->data.scalar.needs_temporary)
2851 : return false;
2852 :
2853 : /* If the actual argument can be absent (in other words, it can
2854 : be a NULL reference), don't try to evaluate it; pass instead
2855 : the reference directly. */
2856 9918 : if (ss_info->can_be_null_ref)
2857 : return true;
2858 :
2859 : /* If the expression is of polymorphic type, it's actual size is not known,
2860 : so we avoid copying it anywhere. */
2861 9242 : if (ss_info->data.scalar.dummy_arg
2862 1402 : && gfc_dummy_arg_get_typespec (*ss_info->data.scalar.dummy_arg).type
2863 : == BT_CLASS
2864 9366 : && ss_info->expr->ts.type == BT_CLASS)
2865 : return true;
2866 :
2867 : /* If the expression is a data reference of aggregate type,
2868 : and the data reference is not used on the left hand side,
2869 : avoid a copy by saving a reference to the content. */
2870 9218 : if (!ss_info->data.scalar.needs_temporary
2871 9218 : && (ss_info->expr->ts.type == BT_DERIVED
2872 8230 : || ss_info->expr->ts.type == BT_CLASS)
2873 10254 : && gfc_expr_is_variable (ss_info->expr))
2874 : return true;
2875 :
2876 : /* Otherwise the expression is evaluated to a temporary variable before the
2877 : scalarization loop. */
2878 : return false;
2879 : }
2880 :
2881 :
2882 : /* Add the pre and post chains for all the scalar expressions in a SS chain
2883 : to loop. This is called after the loop parameters have been calculated,
2884 : but before the actual scalarizing loops. */
2885 :
2886 : static void
2887 192808 : gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
2888 : locus * where)
2889 : {
2890 192808 : gfc_loopinfo *nested_loop, *outer_loop;
2891 192808 : gfc_se se;
2892 192808 : gfc_ss_info *ss_info;
2893 192808 : gfc_array_info *info;
2894 192808 : gfc_expr *expr;
2895 192808 : int n;
2896 :
2897 : /* Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise,
2898 : arguments could get evaluated multiple times. */
2899 192808 : if (ss->is_alloc_lhs)
2900 203 : return;
2901 :
2902 507702 : outer_loop = outermost_loop (loop);
2903 :
2904 : /* TODO: This can generate bad code if there are ordering dependencies,
2905 : e.g., a callee allocated function and an unknown size constructor. */
2906 : gcc_assert (ss != NULL);
2907 :
2908 507702 : for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
2909 : {
2910 315097 : gcc_assert (ss);
2911 :
2912 : /* Cross loop arrays are handled from within the most nested loop. */
2913 315097 : if (ss->nested_ss != NULL)
2914 4740 : continue;
2915 :
2916 310357 : ss_info = ss->info;
2917 310357 : expr = ss_info->expr;
2918 310357 : info = &ss_info->data.array;
2919 :
2920 310357 : switch (ss_info->type)
2921 : {
2922 43748 : case GFC_SS_SCALAR:
2923 : /* Scalar expression. Evaluate this now. This includes elemental
2924 : dimension indices, but not array section bounds. */
2925 43748 : gfc_init_se (&se, NULL);
2926 43748 : gfc_conv_expr (&se, expr);
2927 43748 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
2928 :
2929 43748 : if (expr->ts.type != BT_CHARACTER
2930 43748 : && !gfc_is_alloc_class_scalar_function (expr))
2931 : {
2932 : /* Move the evaluation of scalar expressions outside the
2933 : scalarization loop, except for WHERE assignments. */
2934 39752 : if (subscript)
2935 6495 : se.expr = convert(gfc_array_index_type, se.expr);
2936 39752 : if (!ss_info->where)
2937 39338 : se.expr = gfc_evaluate_now (se.expr, &outer_loop->pre);
2938 39752 : gfc_add_block_to_block (&outer_loop->pre, &se.post);
2939 : }
2940 : else
2941 3996 : gfc_add_block_to_block (&outer_loop->post, &se.post);
2942 :
2943 43748 : ss_info->data.scalar.value = se.expr;
2944 43748 : ss_info->string_length = se.string_length;
2945 43748 : break;
2946 :
2947 5147 : case GFC_SS_REFERENCE:
2948 : /* Scalar argument to elemental procedure. */
2949 5147 : gfc_init_se (&se, NULL);
2950 5147 : if (gfc_scalar_elemental_arg_saved_as_reference (ss_info))
2951 844 : gfc_conv_expr_reference (&se, expr);
2952 : else
2953 : {
2954 : /* Evaluate the argument outside the loop and pass
2955 : a reference to the value. */
2956 4303 : gfc_conv_expr (&se, expr);
2957 : }
2958 :
2959 : /* Ensure that a pointer to the string is stored. */
2960 5147 : if (expr->ts.type == BT_CHARACTER)
2961 174 : gfc_conv_string_parameter (&se);
2962 :
2963 5147 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
2964 5147 : gfc_add_block_to_block (&outer_loop->post, &se.post);
2965 5147 : if (gfc_is_class_scalar_expr (expr))
2966 : /* This is necessary because the dynamic type will always be
2967 : large than the declared type. In consequence, assigning
2968 : the value to a temporary could segfault.
2969 : OOP-TODO: see if this is generally correct or is the value
2970 : has to be written to an allocated temporary, whose address
2971 : is passed via ss_info. */
2972 48 : ss_info->data.scalar.value = se.expr;
2973 : else
2974 5099 : ss_info->data.scalar.value = gfc_evaluate_now (se.expr,
2975 : &outer_loop->pre);
2976 :
2977 5147 : ss_info->string_length = se.string_length;
2978 5147 : break;
2979 :
2980 : case GFC_SS_SECTION:
2981 : /* Add the expressions for scalar and vector subscripts. */
2982 2932592 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2983 2749305 : if (info->subscript[n])
2984 7475 : gfc_add_loop_ss_code (loop, info->subscript[n], true, where);
2985 :
2986 183287 : set_vector_loop_bounds (ss);
2987 183287 : break;
2988 :
2989 980 : case GFC_SS_VECTOR:
2990 : /* Get the vector's descriptor and store it in SS. */
2991 980 : gfc_init_se (&se, NULL);
2992 980 : gfc_conv_expr_descriptor (&se, expr);
2993 980 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
2994 980 : gfc_add_block_to_block (&outer_loop->post, &se.post);
2995 980 : info->descriptor = se.expr;
2996 980 : break;
2997 :
2998 11605 : case GFC_SS_INTRINSIC:
2999 11605 : gfc_add_intrinsic_ss_code (loop, ss);
3000 11605 : break;
3001 :
3002 9588 : case GFC_SS_FUNCTION:
3003 9588 : {
3004 : /* Array function return value. We call the function and save its
3005 : result in a temporary for use inside the loop. */
3006 9588 : gfc_init_se (&se, NULL);
3007 9588 : se.loop = loop;
3008 9588 : se.ss = ss;
3009 9588 : bool class_func = gfc_is_class_array_function (expr);
3010 9588 : if (class_func)
3011 183 : expr->must_finalize = 1;
3012 9588 : gfc_conv_expr (&se, expr);
3013 9588 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3014 9588 : if (class_func
3015 183 : && se.expr
3016 9771 : && GFC_CLASS_TYPE_P (TREE_TYPE (se.expr)))
3017 : {
3018 183 : tree tmp = gfc_class_data_get (se.expr);
3019 183 : info->descriptor = tmp;
3020 183 : info->data = gfc_conv_descriptor_data_get (tmp);
3021 183 : info->offset = gfc_conv_descriptor_offset_get (tmp);
3022 366 : for (gfc_ss *s = ss; s; s = s->parent)
3023 378 : for (int n = 0; n < s->dimen; n++)
3024 : {
3025 195 : int dim = s->dim[n];
3026 195 : tree tree_dim = gfc_rank_cst[dim];
3027 :
3028 195 : tree start;
3029 195 : start = gfc_conv_descriptor_lbound_get (tmp, tree_dim);
3030 195 : start = gfc_evaluate_now (start, &outer_loop->pre);
3031 195 : info->start[dim] = start;
3032 :
3033 195 : tree end;
3034 195 : end = gfc_conv_descriptor_ubound_get (tmp, tree_dim);
3035 195 : end = gfc_evaluate_now (end, &outer_loop->pre);
3036 195 : info->end[dim] = end;
3037 :
3038 195 : tree stride;
3039 195 : stride = gfc_conv_descriptor_stride_get (tmp, tree_dim);
3040 195 : stride = gfc_evaluate_now (stride, &outer_loop->pre);
3041 195 : info->stride[dim] = stride;
3042 : }
3043 : }
3044 9588 : gfc_add_block_to_block (&outer_loop->post, &se.post);
3045 9588 : gfc_add_block_to_block (&outer_loop->post, &se.finalblock);
3046 9588 : ss_info->string_length = se.string_length;
3047 : }
3048 9588 : break;
3049 :
3050 43426 : case GFC_SS_CONSTRUCTOR:
3051 43426 : if (expr->ts.type == BT_CHARACTER
3052 8196 : && ss_info->string_length == NULL
3053 8196 : && expr->ts.u.cl
3054 8196 : && expr->ts.u.cl->length
3055 7852 : && expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
3056 : {
3057 7794 : gfc_init_se (&se, NULL);
3058 7794 : gfc_conv_expr_type (&se, expr->ts.u.cl->length,
3059 : gfc_charlen_type_node);
3060 7794 : ss_info->string_length = se.expr;
3061 7794 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3062 7794 : gfc_add_block_to_block (&outer_loop->post, &se.post);
3063 : }
3064 43426 : trans_array_constructor (ss, where);
3065 43426 : break;
3066 :
3067 : case GFC_SS_TEMP:
3068 : case GFC_SS_COMPONENT:
3069 : /* Do nothing. These are handled elsewhere. */
3070 : break;
3071 :
3072 0 : default:
3073 0 : gcc_unreachable ();
3074 : }
3075 : }
3076 :
3077 192605 : if (!subscript)
3078 188494 : for (nested_loop = loop->nested; nested_loop;
3079 3364 : nested_loop = nested_loop->next)
3080 3364 : gfc_add_loop_ss_code (nested_loop, nested_loop->ss, subscript, where);
3081 : }
3082 :
3083 :
3084 : /* Given an array descriptor expression DESCR and its data pointer DATA, decide
3085 : whether to either save the data pointer to a variable and use the variable or
3086 : use the data pointer expression directly without any intermediary variable.
3087 : */
3088 :
3089 : static bool
3090 130676 : save_descriptor_data (tree descr, tree data)
3091 : {
3092 130676 : return !(DECL_P (data)
3093 119284 : || (TREE_CODE (data) == ADDR_EXPR
3094 70315 : && DECL_P (TREE_OPERAND (data, 0)))
3095 52106 : || (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (descr))
3096 48535 : && TREE_CODE (descr) == COMPONENT_REF
3097 11429 : && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (descr, 0)))));
3098 : }
3099 :
3100 :
3101 : /* Type of the DATA argument passed to walk_tree by substitute_subexpr_in_expr
3102 : and used by maybe_substitute_expr. */
3103 :
3104 : typedef struct
3105 : {
3106 : tree target, repl;
3107 : }
3108 : substitute_t;
3109 :
3110 :
3111 : /* Check if the expression in *TP is equal to the substitution target provided
3112 : in DATA->TARGET and replace it with DATA->REPL in that case. This is a
3113 : callback function for use with walk_tree. */
3114 :
3115 : static tree
3116 21939 : maybe_substitute_expr (tree *tp, int *walk_subtree, void *data)
3117 : {
3118 21939 : substitute_t *subst = (substitute_t *) data;
3119 21939 : if (*tp == subst->target)
3120 : {
3121 4204 : *tp = subst->repl;
3122 4204 : *walk_subtree = 0;
3123 : }
3124 :
3125 21939 : return NULL_TREE;
3126 : }
3127 :
3128 :
3129 : /* Substitute in EXPR any occurrence of TARGET with REPLACEMENT. */
3130 :
3131 : static void
3132 3897 : substitute_subexpr_in_expr (tree target, tree replacement, tree expr)
3133 : {
3134 3897 : substitute_t subst;
3135 3897 : subst.target = target;
3136 3897 : subst.repl = replacement;
3137 :
3138 3897 : walk_tree (&expr, maybe_substitute_expr, &subst, nullptr);
3139 3897 : }
3140 :
3141 :
3142 : /* Save REF to a fresh variable in all of REPLACEMENT_ROOTS, appending extra
3143 : code to CODE. Before returning, add REF to REPLACEMENT_ROOTS and clear
3144 : REF. */
3145 :
3146 : static void
3147 3725 : save_ref (tree &code, tree &ref, vec<tree> &replacement_roots)
3148 : {
3149 3725 : stmtblock_t tmp_block;
3150 3725 : gfc_init_block (&tmp_block);
3151 3725 : tree var = gfc_evaluate_now (ref, &tmp_block);
3152 3725 : gfc_add_expr_to_block (&tmp_block, code);
3153 3725 : code = gfc_finish_block (&tmp_block);
3154 :
3155 3725 : unsigned i;
3156 3725 : tree repl_root;
3157 7622 : FOR_EACH_VEC_ELT (replacement_roots, i, repl_root)
3158 3897 : substitute_subexpr_in_expr (ref, var, repl_root);
3159 :
3160 3725 : replacement_roots.safe_push (ref);
3161 3725 : ref = NULL_TREE;
3162 3725 : }
3163 :
3164 :
3165 : /* If REF isn't shared with code in PREVIOUS_CODE, replace it with a fresh
3166 : variable in all of REPLACEMENT_ROOTS, appending extra code to CODE. */
3167 :
3168 : static void
3169 3797 : maybe_save_ref (tree &code, tree &ref, vec<tree> &replacement_roots,
3170 : stmtblock_t *previous_code)
3171 : {
3172 3797 : if (find_tree (previous_code->head, ref))
3173 : return;
3174 :
3175 3725 : save_ref (code, ref, replacement_roots);
3176 : }
3177 :
3178 :
3179 : /* Save the descriptor reference VALUE to storage pointed by DESC_PTR. Before
3180 : that, try to create fresh variables to factor subexpressions of VALUE, if
3181 : those subexpressions aren't shared with code in PRELIMINARY_CODE. Add any
3182 : necessary additional code (initialization of variables typically) to BLOCK.
3183 :
3184 : The candidate references to factoring are dereferenced pointers because they
3185 : are cheap to copy and array descriptors because they are often the base of
3186 : multiple subreferences. */
3187 :
3188 : static void
3189 329314 : set_factored_descriptor_value (tree *desc_ptr, tree value, stmtblock_t *block,
3190 : stmtblock_t *preliminary_code)
3191 : {
3192 : /* As the reference is processed from outer to inner, variable definitions
3193 : will be generated in reversed order, so can't be put directly in BLOCK.
3194 : We use temporary blocks instead, which we save in ACCUMULATED_CODE, and
3195 : only append to BLOCK at the end. */
3196 329314 : tree accumulated_code = NULL_TREE;
3197 :
3198 : /* The current candidate to factoring. */
3199 329314 : tree saveable_ref = NULL_TREE;
3200 :
3201 : /* The root expressions in which we look for subexpressions to replace with
3202 : variables. */
3203 329314 : auto_vec<tree> replacement_roots;
3204 329314 : replacement_roots.safe_push (value);
3205 :
3206 329314 : tree data_ref = value;
3207 329314 : tree next_ref = NULL_TREE;
3208 :
3209 : /* If the candidate reference is not followed by a subreference, it can't be
3210 : saved to a variable as it may be reallocatable, and we have to keep the
3211 : parent reference to be able to store the new pointer value in case of
3212 : reallocation. */
3213 329314 : bool maybe_reallocatable = true;
3214 :
3215 549834 : while (true)
3216 : {
3217 439574 : if (!maybe_reallocatable
3218 439574 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (data_ref)))
3219 2434 : saveable_ref = data_ref;
3220 :
3221 439574 : if (TREE_CODE (data_ref) == INDIRECT_REF)
3222 : {
3223 59516 : next_ref = TREE_OPERAND (data_ref, 0);
3224 :
3225 59516 : if (!maybe_reallocatable)
3226 : {
3227 15059 : if (saveable_ref != NULL_TREE && saveable_ref != data_ref)
3228 : {
3229 : /* A reference worth saving has been seen, and now the pointer
3230 : to the current reference is also worth saving. If the
3231 : previous reference to save wasn't the current one, do save
3232 : it now. Otherwise drop it as we prefer saving the
3233 : pointer. */
3234 1887 : maybe_save_ref (accumulated_code, saveable_ref,
3235 : replacement_roots, preliminary_code);
3236 : }
3237 :
3238 : /* Don't evaluate the pointer to a variable yet; do it only if the
3239 : variable would be significantly more simple than the reference
3240 : it replaces. That is if the reference contains anything
3241 : different from NOPs, COMPONENTs and DECLs. */
3242 15059 : saveable_ref = next_ref;
3243 : }
3244 : }
3245 380058 : else if (TREE_CODE (data_ref) == COMPONENT_REF)
3246 : {
3247 41631 : maybe_reallocatable = false;
3248 41631 : next_ref = TREE_OPERAND (data_ref, 0);
3249 : }
3250 338427 : else if (TREE_CODE (data_ref) == NOP_EXPR)
3251 3701 : next_ref = TREE_OPERAND (data_ref, 0);
3252 : else
3253 : {
3254 334726 : if (DECL_P (data_ref))
3255 : break;
3256 :
3257 7036 : if (TREE_CODE (data_ref) == ARRAY_REF)
3258 : {
3259 5412 : maybe_reallocatable = false;
3260 5412 : next_ref = TREE_OPERAND (data_ref, 0);
3261 : }
3262 :
3263 7036 : if (saveable_ref != NULL_TREE)
3264 : /* We have seen a reference worth saving. Do it now. */
3265 1910 : maybe_save_ref (accumulated_code, saveable_ref, replacement_roots,
3266 : preliminary_code);
3267 :
3268 7036 : if (TREE_CODE (data_ref) != ARRAY_REF)
3269 : break;
3270 : }
3271 :
3272 110260 : data_ref = next_ref;
3273 : }
3274 :
3275 329314 : *desc_ptr = value;
3276 329314 : gfc_add_expr_to_block (block, accumulated_code);
3277 329314 : }
3278 :
3279 :
3280 : /* Translate expressions for the descriptor and data pointer of a SS. */
3281 : /*GCC ARRAYS*/
3282 :
3283 : static void
3284 329314 : gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
3285 : {
3286 329314 : gfc_se se;
3287 329314 : gfc_ss_info *ss_info;
3288 329314 : gfc_array_info *info;
3289 329314 : tree tmp;
3290 :
3291 329314 : ss_info = ss->info;
3292 329314 : info = &ss_info->data.array;
3293 :
3294 : /* Get the descriptor for the array to be scalarized. */
3295 329314 : gcc_assert (ss_info->expr->expr_type == EXPR_VARIABLE);
3296 329314 : gfc_init_se (&se, NULL);
3297 329314 : se.descriptor_only = 1;
3298 329314 : gfc_conv_expr_lhs (&se, ss_info->expr);
3299 329314 : stmtblock_t tmp_block;
3300 329314 : gfc_init_block (&tmp_block);
3301 329314 : set_factored_descriptor_value (&info->descriptor, se.expr, &tmp_block,
3302 : &se.pre);
3303 329314 : gfc_add_block_to_block (block, &se.pre);
3304 329314 : gfc_add_block_to_block (block, &tmp_block);
3305 329314 : ss_info->string_length = se.string_length;
3306 329314 : ss_info->class_container = se.class_container;
3307 :
3308 329314 : if (base)
3309 : {
3310 123960 : if (ss_info->expr->ts.type == BT_CHARACTER && !ss_info->expr->ts.deferred
3311 22778 : && ss_info->expr->ts.u.cl->length == NULL)
3312 : {
3313 : /* Emit a DECL_EXPR for the variable sized array type in
3314 : GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
3315 : sizes works correctly. */
3316 1097 : tree arraytype = TREE_TYPE (
3317 : GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (info->descriptor)));
3318 1097 : if (! TYPE_NAME (arraytype))
3319 899 : TYPE_NAME (arraytype) = build_decl (UNKNOWN_LOCATION, TYPE_DECL,
3320 : NULL_TREE, arraytype);
3321 1097 : gfc_add_expr_to_block (block, build1 (DECL_EXPR, arraytype,
3322 1097 : TYPE_NAME (arraytype)));
3323 : }
3324 : /* Also the data pointer. */
3325 123960 : tmp = gfc_conv_array_data (se.expr);
3326 : /* If this is a variable or address or a class array, use it directly.
3327 : Otherwise we must evaluate it now to avoid breaking dependency
3328 : analysis by pulling the expressions for elemental array indices
3329 : inside the loop. */
3330 123960 : if (save_descriptor_data (se.expr, tmp) && !ss->is_alloc_lhs)
3331 36608 : tmp = gfc_evaluate_now (tmp, block);
3332 123960 : info->data = tmp;
3333 :
3334 123960 : tmp = gfc_conv_array_offset (se.expr);
3335 123960 : if (!ss->is_alloc_lhs)
3336 117447 : tmp = gfc_evaluate_now (tmp, block);
3337 123960 : info->offset = tmp;
3338 :
3339 : /* Make absolutely sure that the saved_offset is indeed saved
3340 : so that the variable is still accessible after the loops
3341 : are translated. */
3342 123960 : info->saved_offset = info->offset;
3343 : }
3344 329314 : }
3345 :
3346 :
3347 : /* Initialize a gfc_loopinfo structure. */
3348 :
3349 : void
3350 192278 : gfc_init_loopinfo (gfc_loopinfo * loop)
3351 : {
3352 192278 : int n;
3353 :
3354 192278 : memset (loop, 0, sizeof (gfc_loopinfo));
3355 192278 : gfc_init_block (&loop->pre);
3356 192278 : gfc_init_block (&loop->post);
3357 :
3358 : /* Initially scalarize in order and default to no loop reversal. */
3359 3268726 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
3360 : {
3361 2884170 : loop->order[n] = n;
3362 2884170 : loop->reverse[n] = GFC_INHIBIT_REVERSE;
3363 : }
3364 :
3365 192278 : loop->ss = gfc_ss_terminator;
3366 192278 : }
3367 :
3368 :
3369 : /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
3370 : chain. */
3371 :
3372 : void
3373 191985 : gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
3374 : {
3375 191985 : se->loop = loop;
3376 191985 : }
3377 :
3378 :
3379 : /* Return an expression for the data pointer of an array. */
3380 :
3381 : tree
3382 338227 : gfc_conv_array_data (tree descriptor)
3383 : {
3384 338227 : tree type;
3385 :
3386 338227 : type = TREE_TYPE (descriptor);
3387 338227 : if (GFC_ARRAY_TYPE_P (type))
3388 : {
3389 237258 : if (TREE_CODE (type) == POINTER_TYPE)
3390 : return descriptor;
3391 : else
3392 : {
3393 : /* Descriptorless arrays. */
3394 176832 : return gfc_build_addr_expr (NULL_TREE, descriptor);
3395 : }
3396 : }
3397 : else
3398 100969 : return gfc_conv_descriptor_data_get (descriptor);
3399 : }
3400 :
3401 :
3402 : /* Return an expression for the base offset of an array. */
3403 :
3404 : tree
3405 251516 : gfc_conv_array_offset (tree descriptor)
3406 : {
3407 251516 : tree type;
3408 :
3409 251516 : type = TREE_TYPE (descriptor);
3410 251516 : if (GFC_ARRAY_TYPE_P (type))
3411 179557 : return GFC_TYPE_ARRAY_OFFSET (type);
3412 : else
3413 71959 : return gfc_conv_descriptor_offset_get (descriptor);
3414 : }
3415 :
3416 :
3417 : /* Get an expression for the array stride. */
3418 :
3419 : tree
3420 500588 : gfc_conv_array_stride (tree descriptor, int dim)
3421 : {
3422 500588 : tree tmp;
3423 500588 : tree type;
3424 :
3425 500588 : type = TREE_TYPE (descriptor);
3426 :
3427 : /* For descriptorless arrays use the array size. */
3428 500588 : tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
3429 500588 : if (tmp != NULL_TREE)
3430 : return tmp;
3431 :
3432 114792 : tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]);
3433 114792 : return tmp;
3434 : }
3435 :
3436 :
3437 : /* Like gfc_conv_array_stride, but for the lower bound. */
3438 :
3439 : tree
3440 321121 : gfc_conv_array_lbound (tree descriptor, int dim)
3441 : {
3442 321121 : tree tmp;
3443 321121 : tree type;
3444 :
3445 321121 : type = TREE_TYPE (descriptor);
3446 :
3447 321121 : tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
3448 321121 : if (tmp != NULL_TREE)
3449 : return tmp;
3450 :
3451 18685 : tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]);
3452 18685 : return tmp;
3453 : }
3454 :
3455 :
3456 : /* Like gfc_conv_array_stride, but for the upper bound. */
3457 :
3458 : tree
3459 208053 : gfc_conv_array_ubound (tree descriptor, int dim)
3460 : {
3461 208053 : tree tmp;
3462 208053 : tree type;
3463 :
3464 208053 : type = TREE_TYPE (descriptor);
3465 :
3466 208053 : tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
3467 208053 : if (tmp != NULL_TREE)
3468 : return tmp;
3469 :
3470 : /* This should only ever happen when passing an assumed shape array
3471 : as an actual parameter. The value will never be used. */
3472 8081 : if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
3473 554 : return gfc_index_zero_node;
3474 :
3475 7527 : tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]);
3476 7527 : return tmp;
3477 : }
3478 :
3479 :
3480 : /* Generate abridged name of a part-ref for use in bounds-check message.
3481 : Cases:
3482 : (1) for an ordinary array variable x return "x"
3483 : (2) for z a DT scalar and array component x (at level 1) return "z%%x"
3484 : (3) for z a DT scalar and array component x (at level > 1) or
3485 : for z a DT array and array x (at any number of levels): "z...%%x"
3486 : */
3487 :
3488 : static char *
3489 36604 : abridged_ref_name (gfc_expr * expr, gfc_array_ref * ar)
3490 : {
3491 36604 : gfc_ref *ref;
3492 36604 : gfc_symbol *sym;
3493 36604 : char *ref_name = NULL;
3494 36604 : const char *comp_name = NULL;
3495 36604 : int len_sym, last_len = 0, level = 0;
3496 36604 : bool sym_is_array;
3497 :
3498 36604 : gcc_assert (expr->expr_type == EXPR_VARIABLE && expr->ref != NULL);
3499 :
3500 36604 : sym = expr->symtree->n.sym;
3501 72821 : sym_is_array = (sym->ts.type != BT_CLASS
3502 36604 : ? sym->as != NULL
3503 387 : : IS_CLASS_ARRAY (sym));
3504 36604 : len_sym = strlen (sym->name);
3505 :
3506 : /* Scan ref chain to get name of the array component (when ar != NULL) or
3507 : array section, determine depth and remember its component name. */
3508 52135 : for (ref = expr->ref; ref; ref = ref->next)
3509 : {
3510 38053 : if (ref->type == REF_COMPONENT
3511 1048 : && strcmp (ref->u.c.component->name, "_data") != 0)
3512 : {
3513 918 : level++;
3514 918 : comp_name = ref->u.c.component->name;
3515 918 : continue;
3516 : }
3517 :
3518 37135 : if (ref->type != REF_ARRAY)
3519 150 : continue;
3520 :
3521 36985 : if (ar)
3522 : {
3523 15971 : if (&ref->u.ar == ar)
3524 : break;
3525 : }
3526 21014 : else if (ref->u.ar.type == AR_SECTION)
3527 : break;
3528 : }
3529 :
3530 36604 : if (level > 0)
3531 800 : last_len = strlen (comp_name);
3532 :
3533 : /* Provide a buffer sufficiently large to hold "x...%%z". */
3534 36604 : ref_name = XNEWVEC (char, len_sym + last_len + 6);
3535 36604 : strcpy (ref_name, sym->name);
3536 :
3537 36604 : if (level == 1 && !sym_is_array)
3538 : {
3539 442 : strcat (ref_name, "%%");
3540 442 : strcat (ref_name, comp_name);
3541 : }
3542 36162 : else if (level > 0)
3543 : {
3544 358 : strcat (ref_name, "...%%");
3545 358 : strcat (ref_name, comp_name);
3546 : }
3547 :
3548 36604 : return ref_name;
3549 : }
3550 :
3551 :
3552 : /* Generate code to perform an array index bound check. */
3553 :
3554 : static tree
3555 5726 : trans_array_bound_check (stmtblock_t *block, gfc_ss *ss, tree index, int n,
3556 : locus * where, bool check_upper,
3557 : const char *compname = NULL)
3558 : {
3559 5726 : tree fault;
3560 5726 : tree tmp_lo, tmp_up;
3561 5726 : tree descriptor;
3562 5726 : char *msg;
3563 5726 : char *ref_name = NULL;
3564 5726 : const char * name = NULL;
3565 5726 : gfc_expr *expr;
3566 :
3567 5726 : if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
3568 : return index;
3569 :
3570 252 : descriptor = ss->info->data.array.descriptor;
3571 :
3572 252 : index = gfc_evaluate_now (index, block);
3573 :
3574 : /* We find a name for the error message. */
3575 252 : name = ss->info->expr->symtree->n.sym->name;
3576 252 : gcc_assert (name != NULL);
3577 :
3578 : /* When we have a component ref, get name of the array section.
3579 : Note that there can only be one part ref. */
3580 252 : expr = ss->info->expr;
3581 252 : if (expr->ref && !compname)
3582 160 : name = ref_name = abridged_ref_name (expr, NULL);
3583 :
3584 252 : if (VAR_P (descriptor))
3585 162 : name = IDENTIFIER_POINTER (DECL_NAME (descriptor));
3586 :
3587 : /* Use given (array component) name. */
3588 252 : if (compname)
3589 92 : name = compname;
3590 :
3591 : /* If upper bound is present, include both bounds in the error message. */
3592 252 : if (check_upper)
3593 : {
3594 225 : tmp_lo = gfc_conv_array_lbound (descriptor, n);
3595 225 : tmp_up = gfc_conv_array_ubound (descriptor, n);
3596 :
3597 225 : if (name)
3598 225 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3599 : "outside of expected range (%%ld:%%ld)", n+1, name);
3600 : else
3601 0 : msg = xasprintf ("Index '%%ld' of dimension %d "
3602 : "outside of expected range (%%ld:%%ld)", n+1);
3603 :
3604 225 : fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3605 : index, tmp_lo);
3606 225 : gfc_trans_runtime_check (true, false, fault, block, where, msg,
3607 : fold_convert (long_integer_type_node, index),
3608 : fold_convert (long_integer_type_node, tmp_lo),
3609 : fold_convert (long_integer_type_node, tmp_up));
3610 225 : fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3611 : index, tmp_up);
3612 225 : gfc_trans_runtime_check (true, false, fault, block, where, msg,
3613 : fold_convert (long_integer_type_node, index),
3614 : fold_convert (long_integer_type_node, tmp_lo),
3615 : fold_convert (long_integer_type_node, tmp_up));
3616 225 : free (msg);
3617 : }
3618 : else
3619 : {
3620 27 : tmp_lo = gfc_conv_array_lbound (descriptor, n);
3621 :
3622 27 : if (name)
3623 27 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3624 : "below lower bound of %%ld", n+1, name);
3625 : else
3626 0 : msg = xasprintf ("Index '%%ld' of dimension %d "
3627 : "below lower bound of %%ld", n+1);
3628 :
3629 27 : fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3630 : index, tmp_lo);
3631 27 : gfc_trans_runtime_check (true, false, fault, block, where, msg,
3632 : fold_convert (long_integer_type_node, index),
3633 : fold_convert (long_integer_type_node, tmp_lo));
3634 27 : free (msg);
3635 : }
3636 :
3637 252 : free (ref_name);
3638 252 : return index;
3639 : }
3640 :
3641 :
3642 : /* Helper functions to detect impure functions in an expression. */
3643 :
3644 : static const char *impure_name = NULL;
3645 : static bool
3646 108 : expr_contains_impure_fcn (gfc_expr *e, gfc_symbol* sym ATTRIBUTE_UNUSED,
3647 : int* g ATTRIBUTE_UNUSED)
3648 : {
3649 108 : if (e && e->expr_type == EXPR_FUNCTION
3650 6 : && !gfc_pure_function (e, &impure_name)
3651 111 : && !gfc_implicit_pure_function (e))
3652 3 : return true;
3653 :
3654 : return false;
3655 : }
3656 :
3657 : static bool
3658 92 : gfc_expr_contains_impure_fcn (gfc_expr *e)
3659 : {
3660 92 : impure_name = NULL;
3661 92 : return gfc_traverse_expr (e, NULL, &expr_contains_impure_fcn, 0);
3662 : }
3663 :
3664 :
3665 : /* Generate code for bounds checking for elemental dimensions. */
3666 :
3667 : static void
3668 6688 : array_bound_check_elemental (stmtblock_t *block, gfc_ss * ss, gfc_expr * expr)
3669 : {
3670 6688 : gfc_array_ref *ar;
3671 6688 : gfc_ref *ref;
3672 6688 : char *var_name = NULL;
3673 6688 : int dim;
3674 :
3675 6688 : if (expr->expr_type == EXPR_VARIABLE)
3676 : {
3677 12533 : for (ref = expr->ref; ref; ref = ref->next)
3678 : {
3679 6303 : if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
3680 : {
3681 3953 : ar = &ref->u.ar;
3682 3953 : var_name = abridged_ref_name (expr, ar);
3683 12111 : for (dim = 0; dim < ar->dimen; dim++)
3684 : {
3685 4205 : if (ar->dimen_type[dim] == DIMEN_ELEMENT)
3686 : {
3687 92 : if (gfc_expr_contains_impure_fcn (ar->start[dim]))
3688 3 : gfc_warning_now (0, "Bounds checking of the elemental "
3689 : "index at %L will cause two calls to "
3690 : "%qs, which is not declared to be "
3691 : "PURE or is not implicitly pure.",
3692 3 : &ar->start[dim]->where, impure_name);
3693 92 : gfc_se indexse;
3694 92 : gfc_init_se (&indexse, NULL);
3695 92 : gfc_conv_expr_type (&indexse, ar->start[dim],
3696 : gfc_array_index_type);
3697 92 : gfc_add_block_to_block (block, &indexse.pre);
3698 92 : trans_array_bound_check (block, ss, indexse.expr, dim,
3699 : &ar->where,
3700 92 : ar->as->type != AS_ASSUMED_SIZE
3701 0 : || dim < ar->dimen - 1,
3702 : var_name);
3703 : }
3704 : }
3705 3953 : free (var_name);
3706 : }
3707 : }
3708 : }
3709 6688 : }
3710 :
3711 :
3712 : /* Return the offset for an index. Performs bound checking for elemental
3713 : dimensions. Single element references are processed separately.
3714 : DIM is the array dimension, I is the loop dimension. */
3715 :
3716 : static tree
3717 255252 : conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i,
3718 : gfc_array_ref * ar, tree stride)
3719 : {
3720 255252 : gfc_array_info *info;
3721 255252 : tree index;
3722 255252 : tree desc;
3723 255252 : tree data;
3724 :
3725 255252 : info = &ss->info->data.array;
3726 :
3727 : /* Get the index into the array for this dimension. */
3728 255252 : if (ar)
3729 : {
3730 181421 : gcc_assert (ar->type != AR_ELEMENT);
3731 181421 : switch (ar->dimen_type[dim])
3732 : {
3733 0 : case DIMEN_THIS_IMAGE:
3734 0 : gcc_unreachable ();
3735 4657 : break;
3736 4657 : case DIMEN_ELEMENT:
3737 : /* Elemental dimension. */
3738 4657 : gcc_assert (info->subscript[dim]
3739 : && info->subscript[dim]->info->type == GFC_SS_SCALAR);
3740 : /* We've already translated this value outside the loop. */
3741 4657 : index = info->subscript[dim]->info->data.scalar.value;
3742 :
3743 9390 : index = trans_array_bound_check (&se->pre, ss, index, dim, &ar->where,
3744 4657 : ar->as->type != AS_ASSUMED_SIZE
3745 76 : || dim < ar->dimen - 1);
3746 4657 : break;
3747 :
3748 977 : case DIMEN_VECTOR:
3749 977 : gcc_assert (info && se->loop);
3750 977 : gcc_assert (info->subscript[dim]
3751 : && info->subscript[dim]->info->type == GFC_SS_VECTOR);
3752 977 : desc = info->subscript[dim]->info->data.array.descriptor;
3753 :
3754 : /* Get a zero-based index into the vector. */
3755 977 : index = fold_build2_loc (input_location, MINUS_EXPR,
3756 : gfc_array_index_type,
3757 : se->loop->loopvar[i], se->loop->from[i]);
3758 :
3759 : /* Multiply the index by the stride. */
3760 977 : index = fold_build2_loc (input_location, MULT_EXPR,
3761 : gfc_array_index_type,
3762 : index, gfc_conv_array_stride (desc, 0));
3763 :
3764 : /* Read the vector to get an index into info->descriptor. */
3765 977 : data = build_fold_indirect_ref_loc (input_location,
3766 : gfc_conv_array_data (desc));
3767 977 : index = gfc_build_array_ref (data, index, NULL);
3768 977 : index = gfc_evaluate_now (index, &se->pre);
3769 977 : index = fold_convert (gfc_array_index_type, index);
3770 :
3771 : /* Do any bounds checking on the final info->descriptor index. */
3772 1960 : index = trans_array_bound_check (&se->pre, ss, index, dim, &ar->where,
3773 977 : ar->as->type != AS_ASSUMED_SIZE
3774 6 : || dim < ar->dimen - 1);
3775 977 : break;
3776 :
3777 175787 : case DIMEN_RANGE:
3778 : /* Scalarized dimension. */
3779 175787 : gcc_assert (info && se->loop);
3780 :
3781 : /* Multiply the loop variable by the stride and delta. */
3782 175787 : index = se->loop->loopvar[i];
3783 175787 : if (!integer_onep (info->stride[dim]))
3784 6978 : index = fold_build2_loc (input_location, MULT_EXPR,
3785 : gfc_array_index_type, index,
3786 : info->stride[dim]);
3787 175787 : if (!integer_zerop (info->delta[dim]))
3788 67808 : index = fold_build2_loc (input_location, PLUS_EXPR,
3789 : gfc_array_index_type, index,
3790 : info->delta[dim]);
3791 : break;
3792 :
3793 0 : default:
3794 0 : gcc_unreachable ();
3795 : }
3796 : }
3797 : else
3798 : {
3799 : /* Temporary array or derived type component. */
3800 73831 : gcc_assert (se->loop);
3801 73831 : index = se->loop->loopvar[se->loop->order[i]];
3802 :
3803 : /* Pointer functions can have stride[0] different from unity.
3804 : Use the stride returned by the function call and stored in
3805 : the descriptor for the temporary. */
3806 73831 : if (se->ss && se->ss->info->type == GFC_SS_FUNCTION
3807 8050 : && se->ss->info->expr
3808 8050 : && se->ss->info->expr->symtree
3809 8050 : && se->ss->info->expr->symtree->n.sym->result
3810 7610 : && se->ss->info->expr->symtree->n.sym->result->attr.pointer)
3811 144 : stride = gfc_conv_descriptor_stride_get (info->descriptor,
3812 : gfc_rank_cst[dim]);
3813 :
3814 73831 : if (info->delta[dim] && !integer_zerop (info->delta[dim]))
3815 804 : index = fold_build2_loc (input_location, PLUS_EXPR,
3816 : gfc_array_index_type, index, info->delta[dim]);
3817 : }
3818 :
3819 : /* Multiply by the stride. */
3820 255252 : if (stride != NULL && !integer_onep (stride))
3821 77979 : index = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
3822 : index, stride);
3823 :
3824 255252 : return index;
3825 : }
3826 :
3827 :
3828 : /* Build a scalarized array reference using the vptr 'size'. */
3829 :
3830 : static bool
3831 195651 : build_class_array_ref (gfc_se *se, tree base, tree index)
3832 : {
3833 195651 : tree size;
3834 195651 : tree decl = NULL_TREE;
3835 195651 : tree tmp;
3836 195651 : gfc_expr *expr = se->ss->info->expr;
3837 195651 : gfc_expr *class_expr;
3838 195651 : gfc_typespec *ts;
3839 195651 : gfc_symbol *sym;
3840 :
3841 195651 : tmp = !VAR_P (base) ? gfc_get_class_from_expr (base) : NULL_TREE;
3842 :
3843 91767 : if (tmp != NULL_TREE)
3844 : decl = tmp;
3845 : else
3846 : {
3847 : /* The base expression does not contain a class component, either
3848 : because it is a temporary array or array descriptor. Class
3849 : array functions are correctly resolved above. */
3850 192212 : if (!expr
3851 192212 : || (expr->ts.type != BT_CLASS
3852 178234 : && !gfc_is_class_array_ref (expr, NULL)))
3853 : return false;
3854 :
3855 : /* Obtain the expression for the class entity or component that is
3856 : followed by an array reference, which is not an element, so that
3857 : the span of the array can be obtained. */
3858 477 : class_expr = gfc_find_and_cut_at_last_class_ref (expr, false, &ts);
3859 :
3860 477 : if (!ts)
3861 : return false;
3862 :
3863 452 : sym = (!class_expr && expr) ? expr->symtree->n.sym : NULL;
3864 0 : if (sym && sym->attr.function
3865 0 : && sym == sym->result
3866 0 : && sym->backend_decl == current_function_decl)
3867 : /* The temporary is the data field of the class data component
3868 : of the current function. */
3869 0 : decl = gfc_get_fake_result_decl (sym, 0);
3870 452 : else if (sym)
3871 : {
3872 0 : if (decl == NULL_TREE)
3873 0 : decl = expr->symtree->n.sym->backend_decl;
3874 : /* For class arrays the tree containing the class is stored in
3875 : GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl.
3876 : For all others it's sym's backend_decl directly. */
3877 0 : if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl))
3878 0 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
3879 : }
3880 : else
3881 452 : decl = gfc_get_class_from_gfc_expr (class_expr);
3882 :
3883 452 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
3884 0 : decl = build_fold_indirect_ref_loc (input_location, decl);
3885 :
3886 452 : if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl)))
3887 : return false;
3888 : }
3889 :
3890 3891 : se->class_vptr = gfc_evaluate_now (gfc_class_vptr_get (decl), &se->pre);
3891 :
3892 3891 : size = gfc_class_vtab_size_get (decl);
3893 : /* For unlimited polymorphic entities then _len component needs to be
3894 : multiplied with the size. */
3895 3891 : size = gfc_resize_class_size_with_len (&se->pre, decl, size);
3896 3891 : size = fold_convert (TREE_TYPE (index), size);
3897 :
3898 : /* Return the element in the se expression. */
3899 3891 : se->expr = gfc_build_spanned_array_ref (base, index, size);
3900 3891 : return true;
3901 : }
3902 :
3903 :
3904 : /* Indicates that the tree EXPR is a reference to an array that can’t
3905 : have any negative stride. */
3906 :
3907 : static bool
3908 316727 : non_negative_strides_array_p (tree expr)
3909 : {
3910 330472 : if (expr == NULL_TREE)
3911 : return false;
3912 :
3913 330472 : tree type = TREE_TYPE (expr);
3914 330472 : if (POINTER_TYPE_P (type))
3915 74391 : type = TREE_TYPE (type);
3916 :
3917 330472 : if (TYPE_LANG_SPECIFIC (type))
3918 : {
3919 330472 : gfc_array_kind array_kind = GFC_TYPE_ARRAY_AKIND (type);
3920 :
3921 330472 : if (array_kind == GFC_ARRAY_ALLOCATABLE
3922 330472 : || array_kind == GFC_ARRAY_ASSUMED_SHAPE_CONT)
3923 : return true;
3924 : }
3925 :
3926 : /* An array with descriptor can have negative strides.
3927 : We try to be conservative and return false by default here
3928 : if we don’t recognize a contiguous array instead of
3929 : returning false if we can identify a non-contiguous one. */
3930 273003 : if (!GFC_ARRAY_TYPE_P (type))
3931 : return false;
3932 :
3933 : /* If the array was originally a dummy with a descriptor, strides can be
3934 : negative. */
3935 238415 : if (DECL_P (expr)
3936 229374 : && DECL_LANG_SPECIFIC (expr)
3937 48388 : && GFC_DECL_SAVED_DESCRIPTOR (expr)
3938 252179 : && GFC_DECL_SAVED_DESCRIPTOR (expr) != expr)
3939 13745 : return non_negative_strides_array_p (GFC_DECL_SAVED_DESCRIPTOR (expr));
3940 :
3941 : return true;
3942 : }
3943 :
3944 :
3945 : /* Build a scalarized reference to an array. */
3946 :
3947 : static void
3948 195651 : gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar,
3949 : bool tmp_array = false)
3950 : {
3951 195651 : gfc_array_info *info;
3952 195651 : tree decl = NULL_TREE;
3953 195651 : tree index;
3954 195651 : tree base;
3955 195651 : gfc_ss *ss;
3956 195651 : gfc_expr *expr;
3957 195651 : int n;
3958 :
3959 195651 : ss = se->ss;
3960 195651 : expr = ss->info->expr;
3961 195651 : info = &ss->info->data.array;
3962 195651 : if (ar)
3963 133942 : n = se->loop->order[0];
3964 : else
3965 : n = 0;
3966 :
3967 195651 : index = conv_array_index_offset (se, ss, ss->dim[n], n, ar, info->stride0);
3968 : /* Add the offset for this dimension to the stored offset for all other
3969 : dimensions. */
3970 195651 : if (info->offset && !integer_zerop (info->offset))
3971 143612 : index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3972 : index, info->offset);
3973 :
3974 195651 : base = build_fold_indirect_ref_loc (input_location, info->data);
3975 :
3976 : /* Use the vptr 'size' field to access the element of a class array. */
3977 195651 : if (build_class_array_ref (se, base, index))
3978 3891 : return;
3979 :
3980 191760 : if (get_CFI_desc (NULL, expr, &decl, ar))
3981 442 : decl = build_fold_indirect_ref_loc (input_location, decl);
3982 :
3983 : /* A pointer array component can be detected from its field decl. Fix
3984 : the descriptor, mark the resulting variable decl and pass it to
3985 : gfc_build_array_ref. */
3986 191760 : if (span_addressed_array (info->descriptor)
3987 191760 : || (expr && expr->ts.deferred && info->descriptor
3988 2806 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info->descriptor))))
3989 : {
3990 9884 : if (TREE_CODE (info->descriptor) == COMPONENT_REF)
3991 1588 : decl = info->descriptor;
3992 8296 : else if (INDIRECT_REF_P (info->descriptor))
3993 1485 : decl = TREE_OPERAND (info->descriptor, 0);
3994 :
3995 9884 : if (decl == NULL_TREE)
3996 6811 : decl = info->descriptor;
3997 : }
3998 :
3999 191760 : bool non_negative_stride = tmp_array
4000 191760 : || non_negative_strides_array_p (info->descriptor);
4001 191760 : se->expr = gfc_build_array_ref (base, index, decl,
4002 : non_negative_stride);
4003 : }
4004 :
4005 :
4006 : /* Translate access of temporary array. */
4007 :
4008 : void
4009 61709 : gfc_conv_tmp_array_ref (gfc_se * se)
4010 : {
4011 61709 : se->string_length = se->ss->info->string_length;
4012 61709 : gfc_conv_scalarized_array_ref (se, NULL, true);
4013 61709 : gfc_advance_se_ss_chain (se);
4014 61709 : }
4015 :
4016 : /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
4017 :
4018 : static void
4019 280387 : add_to_offset (tree *cst_offset, tree *offset, tree t)
4020 : {
4021 280387 : if (TREE_CODE (t) == INTEGER_CST)
4022 141180 : *cst_offset = int_const_binop (PLUS_EXPR, *cst_offset, t);
4023 : else
4024 : {
4025 139207 : if (!integer_zerop (*offset))
4026 48700 : *offset = fold_build2_loc (input_location, PLUS_EXPR,
4027 : gfc_array_index_type, *offset, t);
4028 : else
4029 90507 : *offset = t;
4030 : }
4031 280387 : }
4032 :
4033 :
4034 : static tree
4035 186282 : build_array_ref (tree desc, tree offset, tree decl, tree vptr)
4036 : {
4037 186282 : tree tmp;
4038 186282 : tree type;
4039 186282 : tree cdesc;
4040 :
4041 : /* For class arrays the class declaration is stored in the saved
4042 : descriptor. */
4043 186282 : if (INDIRECT_REF_P (desc)
4044 7374 : && DECL_LANG_SPECIFIC (TREE_OPERAND (desc, 0))
4045 188628 : && GFC_DECL_SAVED_DESCRIPTOR (TREE_OPERAND (desc, 0)))
4046 911 : cdesc = gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (
4047 : TREE_OPERAND (desc, 0)));
4048 : else
4049 : cdesc = desc;
4050 :
4051 : /* Class container types do not always have the GFC_CLASS_TYPE_P
4052 : but the canonical type does. */
4053 186282 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdesc))
4054 186282 : && TREE_CODE (cdesc) == COMPONENT_REF)
4055 : {
4056 11500 : type = TREE_TYPE (TREE_OPERAND (cdesc, 0));
4057 11500 : if (TYPE_CANONICAL (type)
4058 11500 : && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type)))
4059 : {
4060 3601 : vptr = gfc_class_vptr_get (TREE_OPERAND (cdesc, 0));
4061 : /* Pass the class container as decl so that gfc_build_array_ref can
4062 : correct the element size for an unlimited polymorphic character
4063 : payload (the _len field), which the vptr size alone omits. Only do
4064 : this for a genuine array element reference; a scalar coarray has
4065 : nothing to span-correct and gfc_build_array_ref asserts decl is null
4066 : for it. */
4067 3601 : if (decl == NULL_TREE
4068 3601 : && GFC_TYPE_ARRAY_RANK (TREE_TYPE (cdesc)) > 0)
4069 3477 : decl = TREE_OPERAND (cdesc, 0);
4070 : }
4071 : }
4072 :
4073 186282 : tmp = gfc_conv_array_data (desc);
4074 186282 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
4075 186282 : tmp = gfc_build_array_ref (tmp, offset, decl,
4076 : non_negative_strides_array_p (desc),
4077 : vptr);
4078 186282 : return tmp;
4079 : }
4080 :
4081 :
4082 : /* Build an array reference. se->expr already holds the array descriptor.
4083 : This should be either a variable, indirect variable reference or component
4084 : reference. For arrays which do not have a descriptor, se->expr will be
4085 : the data pointer.
4086 : a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
4087 :
4088 : void
4089 264975 : gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
4090 : locus * where)
4091 : {
4092 264975 : int n;
4093 264975 : tree offset, cst_offset;
4094 264975 : tree tmp;
4095 264975 : tree stride;
4096 264975 : tree decl = NULL_TREE;
4097 264975 : gfc_se indexse;
4098 264975 : gfc_se tmpse;
4099 264975 : gfc_symbol * sym = expr->symtree->n.sym;
4100 264975 : char *var_name = NULL;
4101 :
4102 264975 : if (ar->stat)
4103 : {
4104 3 : gfc_se statse;
4105 :
4106 3 : gfc_init_se (&statse, NULL);
4107 3 : gfc_conv_expr_lhs (&statse, ar->stat);
4108 3 : gfc_add_block_to_block (&se->pre, &statse.pre);
4109 3 : gfc_add_modify (&se->pre, statse.expr, integer_zero_node);
4110 : }
4111 264975 : if (ar->dimen == 0)
4112 : {
4113 4538 : gcc_assert (ar->codimen || sym->attr.select_rank_temporary
4114 : || (ar->as && ar->as->corank));
4115 :
4116 4538 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
4117 993 : se->expr = build_fold_indirect_ref (gfc_conv_array_data (se->expr));
4118 : else
4119 : {
4120 3545 : if (GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr))
4121 3545 : && TREE_CODE (TREE_TYPE (se->expr)) == POINTER_TYPE)
4122 2598 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
4123 :
4124 : /* Use the actual tree type and not the wrapped coarray. */
4125 3545 : if (!se->want_pointer)
4126 2576 : se->expr = fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se->expr)),
4127 : se->expr);
4128 : }
4129 :
4130 138480 : return;
4131 : }
4132 :
4133 : /* Handle scalarized references separately. */
4134 260437 : if (ar->type != AR_ELEMENT)
4135 : {
4136 133942 : gfc_conv_scalarized_array_ref (se, ar);
4137 133942 : gfc_advance_se_ss_chain (se);
4138 133942 : return;
4139 : }
4140 :
4141 126495 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
4142 11849 : var_name = abridged_ref_name (expr, ar);
4143 :
4144 126495 : decl = se->expr;
4145 126495 : if (UNLIMITED_POLY(sym)
4146 104 : && IS_CLASS_ARRAY (sym)
4147 103 : && sym->attr.dummy
4148 60 : && ar->as->type != AS_DEFERRED)
4149 48 : decl = sym->backend_decl;
4150 :
4151 126495 : cst_offset = offset = gfc_index_zero_node;
4152 126495 : add_to_offset (&cst_offset, &offset, gfc_conv_array_offset (decl));
4153 :
4154 : /* Calculate the offsets from all the dimensions. Make sure to associate
4155 : the final offset so that we form a chain of loop invariant summands. */
4156 280387 : for (n = ar->dimen - 1; n >= 0; n--)
4157 : {
4158 : /* Calculate the index for this dimension. */
4159 153892 : gfc_init_se (&indexse, se);
4160 153892 : gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
4161 153892 : gfc_add_block_to_block (&se->pre, &indexse.pre);
4162 :
4163 153892 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && ! expr->no_bounds_check)
4164 : {
4165 : /* Check array bounds. */
4166 15389 : tree cond;
4167 15389 : char *msg;
4168 :
4169 : /* Evaluate the indexse.expr only once. */
4170 15389 : indexse.expr = save_expr (indexse.expr);
4171 :
4172 : /* Lower bound. */
4173 15389 : tmp = gfc_conv_array_lbound (decl, n);
4174 15389 : if (sym->attr.temporary)
4175 : {
4176 18 : gfc_init_se (&tmpse, se);
4177 18 : gfc_conv_expr_type (&tmpse, ar->as->lower[n],
4178 : gfc_array_index_type);
4179 18 : gfc_add_block_to_block (&se->pre, &tmpse.pre);
4180 18 : tmp = tmpse.expr;
4181 : }
4182 :
4183 15389 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
4184 : indexse.expr, tmp);
4185 15389 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4186 : "below lower bound of %%ld", n+1, var_name);
4187 15389 : gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
4188 : fold_convert (long_integer_type_node,
4189 : indexse.expr),
4190 : fold_convert (long_integer_type_node, tmp));
4191 15389 : free (msg);
4192 :
4193 : /* Upper bound, but not for the last dimension of assumed-size
4194 : arrays. */
4195 15389 : if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE)
4196 : {
4197 13656 : tmp = gfc_conv_array_ubound (decl, n);
4198 13656 : if (sym->attr.temporary)
4199 : {
4200 18 : gfc_init_se (&tmpse, se);
4201 18 : gfc_conv_expr_type (&tmpse, ar->as->upper[n],
4202 : gfc_array_index_type);
4203 18 : gfc_add_block_to_block (&se->pre, &tmpse.pre);
4204 18 : tmp = tmpse.expr;
4205 : }
4206 :
4207 13656 : cond = fold_build2_loc (input_location, GT_EXPR,
4208 : logical_type_node, indexse.expr, tmp);
4209 13656 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4210 : "above upper bound of %%ld", n+1, var_name);
4211 13656 : gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
4212 : fold_convert (long_integer_type_node,
4213 : indexse.expr),
4214 : fold_convert (long_integer_type_node, tmp));
4215 13656 : free (msg);
4216 : }
4217 : }
4218 :
4219 : /* Multiply the index by the stride. */
4220 153892 : stride = gfc_conv_array_stride (decl, n);
4221 153892 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4222 : indexse.expr, stride);
4223 :
4224 : /* And add it to the total. */
4225 153892 : add_to_offset (&cst_offset, &offset, tmp);
4226 : }
4227 :
4228 126495 : if (!integer_zerop (cst_offset))
4229 67222 : offset = fold_build2_loc (input_location, PLUS_EXPR,
4230 : gfc_array_index_type, offset, cst_offset);
4231 :
4232 : /* A pointer array component can be detected from its field decl. Fix
4233 : the descriptor, mark the resulting variable decl and pass it to
4234 : build_array_ref. */
4235 126495 : decl = NULL_TREE;
4236 126495 : if (get_CFI_desc (sym, expr, &decl, ar))
4237 3589 : decl = build_fold_indirect_ref_loc (input_location, decl);
4238 125436 : if (!expr->ts.deferred && !sym->attr.codimension
4239 249706 : && span_addressed_array (se->expr))
4240 : {
4241 5407 : if (INDIRECT_REF_P (se->expr))
4242 990 : decl = TREE_OPERAND (se->expr, 0);
4243 : else
4244 4417 : decl = se->expr;
4245 : }
4246 121088 : else if (expr->ts.deferred
4247 120029 : || (sym->ts.type == BT_CHARACTER
4248 15347 : && sym->attr.select_type_temporary))
4249 : {
4250 2769 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
4251 : {
4252 2613 : decl = se->expr;
4253 2613 : if (INDIRECT_REF_P (decl))
4254 20 : decl = TREE_OPERAND (decl, 0);
4255 : }
4256 : else
4257 156 : decl = sym->backend_decl;
4258 : }
4259 118319 : else if (sym->ts.type == BT_CLASS)
4260 : {
4261 2315 : if (UNLIMITED_POLY (sym))
4262 : {
4263 104 : gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr);
4264 104 : gfc_init_se (&tmpse, NULL);
4265 104 : gfc_conv_expr (&tmpse, class_expr);
4266 104 : if (!se->class_vptr)
4267 104 : se->class_vptr = gfc_class_vptr_get (tmpse.expr);
4268 104 : gfc_free_expr (class_expr);
4269 104 : decl = tmpse.expr;
4270 104 : }
4271 : else
4272 2211 : decl = NULL_TREE;
4273 : }
4274 :
4275 126495 : free (var_name);
4276 126495 : se->expr = build_array_ref (se->expr, offset, decl, se->class_vptr);
4277 : }
4278 :
4279 :
4280 : /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
4281 : LOOP_DIM dimension (if any) to array's offset. */
4282 :
4283 : static void
4284 59601 : add_array_offset (stmtblock_t *pblock, gfc_loopinfo *loop, gfc_ss *ss,
4285 : gfc_array_ref *ar, int array_dim, int loop_dim)
4286 : {
4287 59601 : gfc_se se;
4288 59601 : gfc_array_info *info;
4289 59601 : tree stride, index;
4290 :
4291 59601 : info = &ss->info->data.array;
4292 :
4293 59601 : gfc_init_se (&se, NULL);
4294 59601 : se.loop = loop;
4295 59601 : se.expr = info->descriptor;
4296 59601 : stride = gfc_conv_array_stride (info->descriptor, array_dim);
4297 59601 : index = conv_array_index_offset (&se, ss, array_dim, loop_dim, ar, stride);
4298 59601 : gfc_add_block_to_block (pblock, &se.pre);
4299 :
4300 59601 : info->offset = fold_build2_loc (input_location, PLUS_EXPR,
4301 : gfc_array_index_type,
4302 : info->offset, index);
4303 59601 : info->offset = gfc_evaluate_now (info->offset, pblock);
4304 59601 : }
4305 :
4306 :
4307 : /* Generate the code to be executed immediately before entering a
4308 : scalarization loop. */
4309 :
4310 : static void
4311 147665 : gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
4312 : stmtblock_t * pblock)
4313 : {
4314 147665 : tree stride;
4315 147665 : gfc_ss_info *ss_info;
4316 147665 : gfc_array_info *info;
4317 147665 : gfc_ss_type ss_type;
4318 147665 : gfc_ss *ss, *pss;
4319 147665 : gfc_loopinfo *ploop;
4320 147665 : gfc_array_ref *ar;
4321 :
4322 : /* This code will be executed before entering the scalarization loop
4323 : for this dimension. */
4324 450072 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4325 : {
4326 302407 : ss_info = ss->info;
4327 :
4328 302407 : if ((ss_info->useflags & flag) == 0)
4329 1476 : continue;
4330 :
4331 300931 : ss_type = ss_info->type;
4332 367039 : if (ss_type != GFC_SS_SECTION
4333 : && ss_type != GFC_SS_FUNCTION
4334 300931 : && ss_type != GFC_SS_CONSTRUCTOR
4335 300931 : && ss_type != GFC_SS_COMPONENT)
4336 66108 : continue;
4337 :
4338 234823 : info = &ss_info->data.array;
4339 :
4340 234823 : gcc_assert (dim < ss->dimen);
4341 234823 : gcc_assert (ss->dimen == loop->dimen);
4342 :
4343 234823 : if (info->ref)
4344 165613 : ar = &info->ref->u.ar;
4345 : else
4346 : ar = NULL;
4347 :
4348 234823 : if (dim == loop->dimen - 1 && loop->parent != NULL)
4349 : {
4350 : /* If we are in the outermost dimension of this loop, the previous
4351 : dimension shall be in the parent loop. */
4352 4687 : gcc_assert (ss->parent != NULL);
4353 :
4354 4687 : pss = ss->parent;
4355 4687 : ploop = loop->parent;
4356 :
4357 : /* ss and ss->parent are about the same array. */
4358 4687 : gcc_assert (ss_info == pss->info);
4359 : }
4360 : else
4361 : {
4362 : ploop = loop;
4363 : pss = ss;
4364 : }
4365 :
4366 234823 : if (dim == loop->dimen - 1 && loop->parent == NULL)
4367 : {
4368 179879 : gcc_assert (0 == ploop->order[0]);
4369 :
4370 359758 : stride = gfc_conv_array_stride (info->descriptor,
4371 179879 : innermost_ss (ss)->dim[0]);
4372 :
4373 : /* Calculate the stride of the innermost loop. Hopefully this will
4374 : allow the backend optimizers to do their stuff more effectively.
4375 : */
4376 179879 : info->stride0 = gfc_evaluate_now (stride, pblock);
4377 :
4378 : /* For the outermost loop calculate the offset due to any
4379 : elemental dimensions. It will have been initialized with the
4380 : base offset of the array. */
4381 179879 : if (info->ref)
4382 : {
4383 290687 : for (int i = 0; i < ar->dimen; i++)
4384 : {
4385 167896 : if (ar->dimen_type[i] != DIMEN_ELEMENT)
4386 163239 : continue;
4387 :
4388 4657 : add_array_offset (pblock, loop, ss, ar, i, /* unused */ -1);
4389 : }
4390 : }
4391 : }
4392 : else
4393 : {
4394 54944 : int i;
4395 :
4396 54944 : if (dim == loop->dimen - 1)
4397 : i = 0;
4398 : else
4399 50257 : i = dim + 1;
4400 :
4401 : /* For the time being, there is no loop reordering. */
4402 54944 : gcc_assert (i == ploop->order[i]);
4403 54944 : i = ploop->order[i];
4404 :
4405 : /* Add the offset for the previous loop dimension. */
4406 54944 : add_array_offset (pblock, ploop, ss, ar, pss->dim[i], i);
4407 : }
4408 :
4409 : /* Remember this offset for the second loop. */
4410 234823 : if (dim == loop->temp_dim - 1 && loop->parent == NULL)
4411 54861 : info->saved_offset = info->offset;
4412 : }
4413 147665 : }
4414 :
4415 :
4416 : /* Start a scalarized expression. Creates a scope and declares loop
4417 : variables. */
4418 :
4419 : void
4420 117235 : gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
4421 : {
4422 117235 : int dim;
4423 117235 : int n;
4424 117235 : int flags;
4425 :
4426 117235 : gcc_assert (!loop->array_parameter);
4427 :
4428 263320 : for (dim = loop->dimen - 1; dim >= 0; dim--)
4429 : {
4430 146085 : n = loop->order[dim];
4431 :
4432 146085 : gfc_start_block (&loop->code[n]);
4433 :
4434 : /* Create the loop variable. */
4435 146085 : loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
4436 :
4437 146085 : if (dim < loop->temp_dim)
4438 : flags = 3;
4439 : else
4440 99950 : flags = 1;
4441 : /* Calculate values that will be constant within this loop. */
4442 146085 : gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
4443 : }
4444 117235 : gfc_start_block (pbody);
4445 117235 : }
4446 :
4447 :
4448 : /* Generates the actual loop code for a scalarization loop. */
4449 :
4450 : static void
4451 162232 : gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
4452 : stmtblock_t * pbody)
4453 : {
4454 162232 : stmtblock_t block;
4455 162232 : tree cond;
4456 162232 : tree tmp;
4457 162232 : tree loopbody;
4458 162232 : tree exit_label;
4459 162232 : tree stmt;
4460 162232 : tree init;
4461 162232 : tree incr;
4462 :
4463 162232 : if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS
4464 : | OMPWS_SCALARIZER_BODY))
4465 : == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS)
4466 108 : && n == loop->dimen - 1)
4467 : {
4468 : /* We create an OMP_FOR construct for the outermost scalarized loop. */
4469 80 : init = make_tree_vec (1);
4470 80 : cond = make_tree_vec (1);
4471 80 : incr = make_tree_vec (1);
4472 :
4473 : /* Cycle statement is implemented with a goto. Exit statement must not
4474 : be present for this loop. */
4475 80 : exit_label = gfc_build_label_decl (NULL_TREE);
4476 80 : TREE_USED (exit_label) = 1;
4477 :
4478 : /* Label for cycle statements (if needed). */
4479 80 : tmp = build1_v (LABEL_EXPR, exit_label);
4480 80 : gfc_add_expr_to_block (pbody, tmp);
4481 :
4482 80 : stmt = make_node (OMP_FOR);
4483 :
4484 80 : TREE_TYPE (stmt) = void_type_node;
4485 80 : OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody);
4486 :
4487 80 : OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location,
4488 : OMP_CLAUSE_SCHEDULE);
4489 80 : OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt))
4490 80 : = OMP_CLAUSE_SCHEDULE_STATIC;
4491 80 : if (ompws_flags & OMPWS_NOWAIT)
4492 33 : OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt))
4493 66 : = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT);
4494 :
4495 : /* Initialize the loopvar. */
4496 80 : TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n],
4497 : loop->from[n]);
4498 80 : OMP_FOR_INIT (stmt) = init;
4499 : /* The exit condition. */
4500 80 : TREE_VEC_ELT (cond, 0) = build2_loc (input_location, LE_EXPR,
4501 : logical_type_node,
4502 : loop->loopvar[n], loop->to[n]);
4503 80 : SET_EXPR_LOCATION (TREE_VEC_ELT (cond, 0), input_location);
4504 80 : OMP_FOR_COND (stmt) = cond;
4505 : /* Increment the loopvar. */
4506 80 : tmp = build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4507 : loop->loopvar[n], gfc_index_one_node);
4508 80 : TREE_VEC_ELT (incr, 0) = fold_build2_loc (input_location, MODIFY_EXPR,
4509 : void_type_node, loop->loopvar[n], tmp);
4510 80 : OMP_FOR_INCR (stmt) = incr;
4511 :
4512 80 : ompws_flags &= ~OMPWS_CURR_SINGLEUNIT;
4513 80 : gfc_add_expr_to_block (&loop->code[n], stmt);
4514 : }
4515 : else
4516 : {
4517 324304 : bool reverse_loop = (loop->reverse[n] == GFC_REVERSE_SET)
4518 162152 : && (loop->temp_ss == NULL);
4519 :
4520 162152 : loopbody = gfc_finish_block (pbody);
4521 :
4522 162152 : if (reverse_loop)
4523 204 : std::swap (loop->from[n], loop->to[n]);
4524 :
4525 : /* Initialize the loopvar. */
4526 162152 : if (loop->loopvar[n] != loop->from[n])
4527 161331 : gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
4528 :
4529 162152 : exit_label = gfc_build_label_decl (NULL_TREE);
4530 :
4531 : /* Generate the loop body. */
4532 162152 : gfc_init_block (&block);
4533 :
4534 : /* The exit condition. */
4535 324100 : cond = fold_build2_loc (input_location, reverse_loop ? LT_EXPR : GT_EXPR,
4536 : logical_type_node, loop->loopvar[n], loop->to[n]);
4537 162152 : tmp = build1_v (GOTO_EXPR, exit_label);
4538 162152 : TREE_USED (exit_label) = 1;
4539 162152 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
4540 162152 : gfc_add_expr_to_block (&block, tmp);
4541 :
4542 : /* The main body. */
4543 162152 : gfc_add_expr_to_block (&block, loopbody);
4544 :
4545 : /* Increment the loopvar. */
4546 324100 : tmp = fold_build2_loc (input_location,
4547 : reverse_loop ? MINUS_EXPR : PLUS_EXPR,
4548 : gfc_array_index_type, loop->loopvar[n],
4549 : gfc_index_one_node);
4550 :
4551 162152 : gfc_add_modify (&block, loop->loopvar[n], tmp);
4552 :
4553 : /* Build the loop. */
4554 162152 : tmp = gfc_finish_block (&block);
4555 162152 : tmp = build1_v (LOOP_EXPR, tmp);
4556 162152 : gfc_add_expr_to_block (&loop->code[n], tmp);
4557 :
4558 : /* Add the exit label. */
4559 162152 : tmp = build1_v (LABEL_EXPR, exit_label);
4560 162152 : gfc_add_expr_to_block (&loop->code[n], tmp);
4561 : }
4562 :
4563 162232 : }
4564 :
4565 :
4566 : /* Finishes and generates the loops for a scalarized expression. */
4567 :
4568 : void
4569 123594 : gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
4570 : {
4571 123594 : int dim;
4572 123594 : int n;
4573 123594 : gfc_ss *ss;
4574 123594 : stmtblock_t *pblock;
4575 123594 : tree tmp;
4576 :
4577 123594 : pblock = body;
4578 : /* Generate the loops. */
4579 276029 : for (dim = 0; dim < loop->dimen; dim++)
4580 : {
4581 152435 : n = loop->order[dim];
4582 152435 : gfc_trans_scalarized_loop_end (loop, n, pblock);
4583 152435 : loop->loopvar[n] = NULL_TREE;
4584 152435 : pblock = &loop->code[n];
4585 : }
4586 :
4587 123594 : tmp = gfc_finish_block (pblock);
4588 123594 : gfc_add_expr_to_block (&loop->pre, tmp);
4589 :
4590 : /* Clear all the used flags. */
4591 361442 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4592 237848 : if (ss->parent == NULL)
4593 233098 : ss->info->useflags = 0;
4594 123594 : }
4595 :
4596 :
4597 : /* Finish the main body of a scalarized expression, and start the secondary
4598 : copying body. */
4599 :
4600 : void
4601 8217 : gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
4602 : {
4603 8217 : int dim;
4604 8217 : int n;
4605 8217 : stmtblock_t *pblock;
4606 8217 : gfc_ss *ss;
4607 :
4608 8217 : pblock = body;
4609 : /* We finish as many loops as are used by the temporary. */
4610 9797 : for (dim = 0; dim < loop->temp_dim - 1; dim++)
4611 : {
4612 1580 : n = loop->order[dim];
4613 1580 : gfc_trans_scalarized_loop_end (loop, n, pblock);
4614 1580 : loop->loopvar[n] = NULL_TREE;
4615 1580 : pblock = &loop->code[n];
4616 : }
4617 :
4618 : /* We don't want to finish the outermost loop entirely. */
4619 8217 : n = loop->order[loop->temp_dim - 1];
4620 8217 : gfc_trans_scalarized_loop_end (loop, n, pblock);
4621 :
4622 : /* Restore the initial offsets. */
4623 23555 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4624 : {
4625 15338 : gfc_ss_type ss_type;
4626 15338 : gfc_ss_info *ss_info;
4627 :
4628 15338 : ss_info = ss->info;
4629 :
4630 15338 : if ((ss_info->useflags & 2) == 0)
4631 4546 : continue;
4632 :
4633 10792 : ss_type = ss_info->type;
4634 10946 : if (ss_type != GFC_SS_SECTION
4635 : && ss_type != GFC_SS_FUNCTION
4636 10792 : && ss_type != GFC_SS_CONSTRUCTOR
4637 10792 : && ss_type != GFC_SS_COMPONENT)
4638 154 : continue;
4639 :
4640 10638 : ss_info->data.array.offset = ss_info->data.array.saved_offset;
4641 : }
4642 :
4643 : /* Restart all the inner loops we just finished. */
4644 9797 : for (dim = loop->temp_dim - 2; dim >= 0; dim--)
4645 : {
4646 1580 : n = loop->order[dim];
4647 :
4648 1580 : gfc_start_block (&loop->code[n]);
4649 :
4650 1580 : loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
4651 :
4652 1580 : gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
4653 : }
4654 :
4655 : /* Start a block for the secondary copying code. */
4656 8217 : gfc_start_block (body);
4657 8217 : }
4658 :
4659 :
4660 : /* Precalculate (either lower or upper) bound of an array section.
4661 : BLOCK: Block in which the (pre)calculation code will go.
4662 : BOUNDS[DIM]: Where the bound value will be stored once evaluated.
4663 : VALUES[DIM]: Specified bound (NULL <=> unspecified).
4664 : DESC: Array descriptor from which the bound will be picked if unspecified
4665 : (either lower or upper bound according to LBOUND). */
4666 :
4667 : static void
4668 519668 : evaluate_bound (stmtblock_t *block, tree *bounds, gfc_expr ** values,
4669 : tree desc, int dim, bool lbound, bool deferred, bool save_value)
4670 : {
4671 519668 : gfc_se se;
4672 519668 : gfc_expr * input_val = values[dim];
4673 519668 : tree *output = &bounds[dim];
4674 :
4675 519668 : if (input_val)
4676 : {
4677 : /* Specified section bound. */
4678 47996 : gfc_init_se (&se, NULL);
4679 47996 : gfc_conv_expr_type (&se, input_val, gfc_array_index_type);
4680 47996 : gfc_add_block_to_block (block, &se.pre);
4681 47996 : *output = se.expr;
4682 : }
4683 471672 : else if (deferred && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
4684 : {
4685 : /* The gfc_conv_array_lbound () routine returns a constant zero for
4686 : deferred length arrays, which in the scalarizer wreaks havoc, when
4687 : copying to a (newly allocated) one-based array.
4688 : Keep returning the actual result in sync for both bounds. */
4689 192362 : *output = lbound ? gfc_conv_descriptor_lbound_get (desc,
4690 : gfc_rank_cst[dim]):
4691 64234 : gfc_conv_descriptor_ubound_get (desc,
4692 : gfc_rank_cst[dim]);
4693 : }
4694 : else
4695 : {
4696 : /* No specific bound specified so use the bound of the array. */
4697 511905 : *output = lbound ? gfc_conv_array_lbound (desc, dim) :
4698 168361 : gfc_conv_array_ubound (desc, dim);
4699 : }
4700 519668 : if (save_value)
4701 500430 : *output = gfc_evaluate_now (*output, block);
4702 519668 : }
4703 :
4704 :
4705 : /* Calculate the lower bound of an array section. */
4706 :
4707 : static void
4708 260467 : gfc_conv_section_startstride (stmtblock_t * block, gfc_ss * ss, int dim)
4709 : {
4710 260467 : gfc_expr *stride = NULL;
4711 260467 : tree desc;
4712 260467 : gfc_se se;
4713 260467 : gfc_array_info *info;
4714 260467 : gfc_array_ref *ar;
4715 :
4716 260467 : gcc_assert (ss->info->type == GFC_SS_SECTION);
4717 :
4718 260467 : info = &ss->info->data.array;
4719 260467 : ar = &info->ref->u.ar;
4720 :
4721 260467 : if (ar->dimen_type[dim] == DIMEN_VECTOR)
4722 : {
4723 : /* We use a zero-based index to access the vector. */
4724 980 : info->start[dim] = gfc_index_zero_node;
4725 980 : info->end[dim] = NULL;
4726 980 : info->stride[dim] = gfc_index_one_node;
4727 980 : return;
4728 : }
4729 :
4730 259487 : gcc_assert (ar->dimen_type[dim] == DIMEN_RANGE
4731 : || ar->dimen_type[dim] == DIMEN_THIS_IMAGE);
4732 259487 : desc = info->descriptor;
4733 259487 : stride = ar->stride[dim];
4734 259487 : bool save_value = !ss->is_alloc_lhs;
4735 :
4736 : /* Calculate the start of the range. For vector subscripts this will
4737 : be the range of the vector. */
4738 259487 : evaluate_bound (block, info->start, ar->start, desc, dim, true,
4739 259487 : ar->as->type == AS_DEFERRED, save_value);
4740 :
4741 : /* Similarly calculate the end. Although this is not used in the
4742 : scalarizer, it is needed when checking bounds and where the end
4743 : is an expression with side-effects. */
4744 259487 : evaluate_bound (block, info->end, ar->end, desc, dim, false,
4745 259487 : ar->as->type == AS_DEFERRED, save_value);
4746 :
4747 :
4748 : /* Calculate the stride. */
4749 259487 : if (stride == NULL)
4750 246647 : info->stride[dim] = gfc_index_one_node;
4751 : else
4752 : {
4753 12840 : gfc_init_se (&se, NULL);
4754 12840 : gfc_conv_expr_type (&se, stride, gfc_array_index_type);
4755 12840 : gfc_add_block_to_block (block, &se.pre);
4756 12840 : tree value = se.expr;
4757 12840 : if (save_value)
4758 12840 : info->stride[dim] = gfc_evaluate_now (value, block);
4759 : else
4760 0 : info->stride[dim] = value;
4761 : }
4762 : }
4763 :
4764 :
4765 : /* Generate in INNER the bounds checking code along the dimension DIM for
4766 : the array associated with SS_INFO. */
4767 :
4768 : static void
4769 24078 : add_check_section_in_array_bounds (stmtblock_t *inner, gfc_ss_info *ss_info,
4770 : int dim)
4771 : {
4772 24078 : gfc_expr *expr = ss_info->expr;
4773 24078 : locus *expr_loc = &expr->where;
4774 24078 : const char *expr_name = expr->symtree->name;
4775 :
4776 24078 : gfc_array_info *info = &ss_info->data.array;
4777 :
4778 24078 : bool check_upper;
4779 24078 : if (dim == info->ref->u.ar.dimen - 1
4780 20451 : && info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
4781 : check_upper = false;
4782 : else
4783 23782 : check_upper = true;
4784 :
4785 : /* Zero stride is not allowed. */
4786 24078 : tree tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
4787 : info->stride[dim], gfc_index_zero_node);
4788 24078 : char * msg = xasprintf ("Zero stride is not allowed, for dimension %d "
4789 : "of array '%s'", dim + 1, expr_name);
4790 24078 : gfc_trans_runtime_check (true, false, tmp, inner, expr_loc, msg);
4791 24078 : free (msg);
4792 :
4793 24078 : tree desc = info->descriptor;
4794 :
4795 : /* This is the run-time equivalent of resolve.cc's
4796 : check_dimension. The logical is more readable there
4797 : than it is here, with all the trees. */
4798 24078 : tree lbound = gfc_conv_array_lbound (desc, dim);
4799 24078 : tree end = info->end[dim];
4800 24078 : tree ubound = check_upper ? gfc_conv_array_ubound (desc, dim) : NULL_TREE;
4801 :
4802 : /* non_zerosized is true when the selected range is not
4803 : empty. */
4804 24078 : tree stride_pos = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
4805 : info->stride[dim], gfc_index_zero_node);
4806 24078 : tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
4807 : info->start[dim], end);
4808 24078 : stride_pos = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4809 : logical_type_node, stride_pos, tmp);
4810 :
4811 24078 : tree stride_neg = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
4812 : info->stride[dim], gfc_index_zero_node);
4813 24078 : tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
4814 : info->start[dim], end);
4815 24078 : stride_neg = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4816 : logical_type_node, stride_neg, tmp);
4817 24078 : tree non_zerosized = fold_build2_loc (input_location, TRUTH_OR_EXPR,
4818 : logical_type_node, stride_pos,
4819 : stride_neg);
4820 :
4821 : /* Check the start of the range against the lower and upper
4822 : bounds of the array, if the range is not empty.
4823 : If upper bound is present, include both bounds in the
4824 : error message. */
4825 24078 : if (check_upper)
4826 : {
4827 23782 : tmp = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
4828 : info->start[dim], lbound);
4829 23782 : tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
4830 : non_zerosized, tmp);
4831 23782 : tree tmp2 = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
4832 : info->start[dim], ubound);
4833 23782 : tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
4834 : non_zerosized, tmp2);
4835 23782 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' outside of "
4836 : "expected range (%%ld:%%ld)", dim + 1, expr_name);
4837 23782 : 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 : fold_convert (long_integer_type_node, ubound));
4841 23782 : gfc_trans_runtime_check (true, false, tmp2, inner, expr_loc, msg,
4842 : fold_convert (long_integer_type_node, info->start[dim]),
4843 : fold_convert (long_integer_type_node, lbound),
4844 : fold_convert (long_integer_type_node, ubound));
4845 23782 : free (msg);
4846 : }
4847 : else
4848 : {
4849 296 : tmp = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
4850 : info->start[dim], lbound);
4851 296 : tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
4852 : non_zerosized, tmp);
4853 296 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' below "
4854 : "lower bound of %%ld", dim + 1, expr_name);
4855 296 : gfc_trans_runtime_check (true, false, tmp, inner, expr_loc, msg,
4856 : fold_convert (long_integer_type_node, info->start[dim]),
4857 : fold_convert (long_integer_type_node, lbound));
4858 296 : free (msg);
4859 : }
4860 :
4861 : /* Compute the last element of the range, which is not
4862 : necessarily "end" (think 0:5:3, which doesn't contain 5)
4863 : and check it against both lower and upper bounds. */
4864 :
4865 24078 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4866 : end, info->start[dim]);
4867 24078 : tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR, gfc_array_index_type,
4868 : tmp, info->stride[dim]);
4869 24078 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4870 : end, tmp);
4871 24078 : tree tmp2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
4872 : tmp, lbound);
4873 24078 : tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
4874 : non_zerosized, tmp2);
4875 24078 : if (check_upper)
4876 : {
4877 23782 : tree tmp3 = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
4878 : tmp, ubound);
4879 23782 : tmp3 = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
4880 : non_zerosized, tmp3);
4881 23782 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' outside of "
4882 : "expected range (%%ld:%%ld)", dim + 1, expr_name);
4883 23782 : gfc_trans_runtime_check (true, false, tmp2, inner, expr_loc, msg,
4884 : fold_convert (long_integer_type_node, tmp),
4885 : fold_convert (long_integer_type_node, ubound),
4886 : fold_convert (long_integer_type_node, lbound));
4887 23782 : gfc_trans_runtime_check (true, false, tmp3, inner, expr_loc, msg,
4888 : fold_convert (long_integer_type_node, tmp),
4889 : fold_convert (long_integer_type_node, ubound),
4890 : fold_convert (long_integer_type_node, lbound));
4891 23782 : free (msg);
4892 : }
4893 : else
4894 : {
4895 296 : msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' below "
4896 : "lower bound of %%ld", dim + 1, expr_name);
4897 296 : gfc_trans_runtime_check (true, false, tmp2, inner, expr_loc, msg,
4898 : fold_convert (long_integer_type_node, tmp),
4899 : fold_convert (long_integer_type_node, lbound));
4900 296 : free (msg);
4901 : }
4902 24078 : }
4903 :
4904 :
4905 : /* Tells whether we need to generate bounds checking code for the array
4906 : associated with SS. */
4907 :
4908 : bool
4909 25045 : bounds_check_needed (gfc_ss *ss)
4910 : {
4911 : /* Catch allocatable lhs in f2003. */
4912 25045 : if (flag_realloc_lhs && ss->no_bounds_check)
4913 : return false;
4914 :
4915 24768 : gfc_ss_info *ss_info = ss->info;
4916 24768 : if (ss_info->type == GFC_SS_SECTION)
4917 : return true;
4918 :
4919 4126 : if (!(ss_info->type == GFC_SS_INTRINSIC
4920 227 : && ss_info->expr
4921 227 : && ss_info->expr->expr_type == EXPR_FUNCTION))
4922 : return false;
4923 :
4924 227 : gfc_intrinsic_sym *isym = ss_info->expr->value.function.isym;
4925 227 : if (!(isym
4926 227 : && (isym->id == GFC_ISYM_MAXLOC
4927 203 : || isym->id == GFC_ISYM_MINLOC)))
4928 : return false;
4929 :
4930 34 : return gfc_inline_intrinsic_function_p (ss_info->expr);
4931 : }
4932 :
4933 :
4934 : /* Calculates the range start and stride for a SS chain. Also gets the
4935 : descriptor and data pointer. The range of vector subscripts is the size
4936 : of the vector. Array bounds are also checked. */
4937 :
4938 : void
4939 185333 : gfc_conv_ss_startstride (gfc_loopinfo * loop)
4940 : {
4941 185333 : int n;
4942 185333 : tree tmp;
4943 185333 : gfc_ss *ss;
4944 :
4945 185333 : gfc_loopinfo * const outer_loop = outermost_loop (loop);
4946 :
4947 185333 : loop->dimen = 0;
4948 : /* Determine the rank of the loop. */
4949 205686 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4950 : {
4951 205686 : switch (ss->info->type)
4952 : {
4953 173987 : case GFC_SS_SECTION:
4954 173987 : case GFC_SS_CONSTRUCTOR:
4955 173987 : case GFC_SS_FUNCTION:
4956 173987 : case GFC_SS_COMPONENT:
4957 173987 : loop->dimen = ss->dimen;
4958 173987 : goto done;
4959 :
4960 : /* As usual, lbound and ubound are exceptions!. */
4961 11346 : case GFC_SS_INTRINSIC:
4962 11346 : switch (ss->info->expr->value.function.isym->id)
4963 : {
4964 11346 : case GFC_ISYM_LBOUND:
4965 11346 : case GFC_ISYM_UBOUND:
4966 11346 : case GFC_ISYM_COSHAPE:
4967 11346 : case GFC_ISYM_LCOBOUND:
4968 11346 : case GFC_ISYM_UCOBOUND:
4969 11346 : case GFC_ISYM_MAXLOC:
4970 11346 : case GFC_ISYM_MINLOC:
4971 11346 : case GFC_ISYM_SHAPE:
4972 11346 : case GFC_ISYM_THIS_IMAGE:
4973 11346 : loop->dimen = ss->dimen;
4974 11346 : goto done;
4975 :
4976 : default:
4977 : break;
4978 : }
4979 :
4980 20353 : default:
4981 20353 : break;
4982 : }
4983 : }
4984 :
4985 : /* We should have determined the rank of the expression by now. If
4986 : not, that's bad news. */
4987 0 : gcc_unreachable ();
4988 :
4989 185333 : done:
4990 : /* Loop over all the SS in the chain. */
4991 481822 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4992 : {
4993 296489 : gfc_ss_info *ss_info;
4994 296489 : gfc_array_info *info;
4995 296489 : gfc_expr *expr;
4996 :
4997 296489 : ss_info = ss->info;
4998 296489 : expr = ss_info->expr;
4999 296489 : info = &ss_info->data.array;
5000 :
5001 296489 : if (expr && expr->shape && !info->shape)
5002 171837 : info->shape = expr->shape;
5003 :
5004 296489 : switch (ss_info->type)
5005 : {
5006 188126 : case GFC_SS_SECTION:
5007 : /* Get the descriptor for the array. If it is a cross loops array,
5008 : we got the descriptor already in the outermost loop. */
5009 188126 : if (ss->parent == NULL)
5010 183490 : gfc_conv_ss_descriptor (&outer_loop->pre, ss,
5011 183490 : !loop->array_parameter);
5012 :
5013 447775 : for (n = 0; n < ss->dimen; n++)
5014 259649 : gfc_conv_section_startstride (&outer_loop->pre, ss, ss->dim[n]);
5015 : break;
5016 :
5017 11605 : case GFC_SS_INTRINSIC:
5018 11605 : switch (expr->value.function.isym->id)
5019 : {
5020 3281 : case GFC_ISYM_MINLOC:
5021 3281 : case GFC_ISYM_MAXLOC:
5022 3281 : {
5023 3281 : gfc_se se;
5024 3281 : gfc_init_se (&se, nullptr);
5025 3281 : se.loop = loop;
5026 3281 : se.ss = ss;
5027 3281 : gfc_conv_intrinsic_function (&se, expr);
5028 3281 : gfc_add_block_to_block (&outer_loop->pre, &se.pre);
5029 3281 : gfc_add_block_to_block (&outer_loop->post, &se.post);
5030 :
5031 3281 : info->descriptor = se.expr;
5032 :
5033 3281 : info->data = gfc_conv_array_data (info->descriptor);
5034 3281 : info->data = gfc_evaluate_now (info->data, &outer_loop->pre);
5035 :
5036 3281 : gfc_expr *array = expr->value.function.actual->expr;
5037 3281 : tree rank = build_int_cst (gfc_array_index_type, array->rank);
5038 :
5039 3281 : tree tmp = fold_build2_loc (input_location, MINUS_EXPR,
5040 : gfc_array_index_type, rank,
5041 : gfc_index_one_node);
5042 :
5043 3281 : info->end[0] = gfc_evaluate_now (tmp, &outer_loop->pre);
5044 3281 : info->start[0] = gfc_index_zero_node;
5045 3281 : info->stride[0] = gfc_index_one_node;
5046 3281 : info->offset = gfc_index_zero_node;
5047 3281 : continue;
5048 3281 : }
5049 :
5050 : /* Fall through to supply start and stride. */
5051 3004 : case GFC_ISYM_LBOUND:
5052 3004 : case GFC_ISYM_UBOUND:
5053 : /* This is the variant without DIM=... */
5054 3004 : gcc_assert (expr->value.function.actual->next->expr == NULL);
5055 : /* Fall through. */
5056 :
5057 8016 : case GFC_ISYM_SHAPE:
5058 8016 : {
5059 8016 : gfc_expr *arg;
5060 :
5061 8016 : arg = expr->value.function.actual->expr;
5062 8016 : if (arg->rank == -1)
5063 : {
5064 1175 : gfc_se se;
5065 1175 : tree rank, tmp;
5066 :
5067 : /* The rank (hence the return value's shape) is unknown,
5068 : we have to retrieve it. */
5069 1175 : gfc_init_se (&se, NULL);
5070 1175 : se.descriptor_only = 1;
5071 1175 : gfc_conv_expr (&se, arg);
5072 : /* This is a bare variable, so there is no preliminary
5073 : or cleanup code unless -std=f202y and bounds checking
5074 : is on. */
5075 1175 : if (!((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
5076 0 : && (gfc_option.allow_std & GFC_STD_F202Y)))
5077 1175 : gcc_assert (se.pre.head == NULL_TREE
5078 : && se.post.head == NULL_TREE);
5079 1175 : rank = gfc_conv_descriptor_rank_get (se.expr);
5080 1175 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
5081 : gfc_array_index_type,
5082 : fold_convert (gfc_array_index_type,
5083 : rank),
5084 : gfc_index_one_node);
5085 1175 : info->end[0] = gfc_evaluate_now (tmp, &outer_loop->pre);
5086 1175 : info->start[0] = gfc_index_zero_node;
5087 1175 : info->stride[0] = gfc_index_one_node;
5088 1175 : continue;
5089 1175 : }
5090 : /* Otherwise fall through GFC_SS_FUNCTION. */
5091 : gcc_fallthrough ();
5092 : }
5093 : case GFC_ISYM_COSHAPE:
5094 : case GFC_ISYM_LCOBOUND:
5095 : case GFC_ISYM_UCOBOUND:
5096 : case GFC_ISYM_THIS_IMAGE:
5097 : break;
5098 :
5099 0 : default:
5100 0 : continue;
5101 0 : }
5102 :
5103 : /* FALLTHRU */
5104 : case GFC_SS_CONSTRUCTOR:
5105 : case GFC_SS_FUNCTION:
5106 131186 : for (n = 0; n < ss->dimen; n++)
5107 : {
5108 70779 : int dim = ss->dim[n];
5109 :
5110 70779 : info->start[dim] = gfc_index_zero_node;
5111 70779 : if (ss_info->type != GFC_SS_FUNCTION)
5112 56298 : info->end[dim] = gfc_index_zero_node;
5113 70779 : info->stride[dim] = gfc_index_one_node;
5114 : }
5115 : break;
5116 :
5117 : default:
5118 : break;
5119 : }
5120 : }
5121 :
5122 : /* The rest is just runtime bounds checking. */
5123 185333 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
5124 : {
5125 16945 : stmtblock_t block;
5126 16945 : tree size[GFC_MAX_DIMENSIONS];
5127 16945 : tree tmp3;
5128 16945 : gfc_array_info *info;
5129 16945 : char *msg;
5130 16945 : int dim;
5131 :
5132 16945 : gfc_start_block (&block);
5133 :
5134 54257 : for (n = 0; n < loop->dimen; n++)
5135 20367 : size[n] = NULL_TREE;
5136 :
5137 : /* If there is a constructor involved, derive size[] from its shape. */
5138 39164 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5139 : {
5140 24699 : gfc_ss_info *ss_info;
5141 :
5142 24699 : ss_info = ss->info;
5143 24699 : info = &ss_info->data.array;
5144 :
5145 24699 : if (ss_info->type == GFC_SS_CONSTRUCTOR && info->shape)
5146 : {
5147 5224 : for (n = 0; n < loop->dimen; n++)
5148 : {
5149 2744 : if (size[n] == NULL)
5150 : {
5151 2744 : gcc_assert (info->shape[n]);
5152 2744 : size[n] = gfc_conv_mpz_to_tree (info->shape[n],
5153 : gfc_index_integer_kind);
5154 : }
5155 : }
5156 : break;
5157 : }
5158 : }
5159 :
5160 41990 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5161 : {
5162 25045 : stmtblock_t inner;
5163 25045 : gfc_ss_info *ss_info;
5164 25045 : gfc_expr *expr;
5165 25045 : locus *expr_loc;
5166 25045 : const char *expr_name;
5167 25045 : char *ref_name = NULL;
5168 :
5169 25045 : if (!bounds_check_needed (ss))
5170 4369 : continue;
5171 :
5172 20676 : ss_info = ss->info;
5173 20676 : expr = ss_info->expr;
5174 20676 : expr_loc = &expr->where;
5175 20676 : if (expr->ref)
5176 20642 : expr_name = ref_name = abridged_ref_name (expr, NULL);
5177 : else
5178 34 : expr_name = expr->symtree->name;
5179 :
5180 20676 : gfc_start_block (&inner);
5181 :
5182 : /* TODO: range checking for mapped dimensions. */
5183 20676 : info = &ss_info->data.array;
5184 :
5185 : /* This code only checks ranges. Elemental and vector
5186 : dimensions are checked later. */
5187 65478 : for (n = 0; n < loop->dimen; n++)
5188 : {
5189 24126 : dim = ss->dim[n];
5190 24126 : if (ss_info->type == GFC_SS_SECTION)
5191 : {
5192 24092 : if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
5193 14 : continue;
5194 :
5195 24078 : add_check_section_in_array_bounds (&inner, ss_info, dim);
5196 : }
5197 :
5198 : /* Check the section sizes match. */
5199 24112 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
5200 : gfc_array_index_type, info->end[dim],
5201 : info->start[dim]);
5202 24112 : tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
5203 : gfc_array_index_type, tmp,
5204 : info->stride[dim]);
5205 24112 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
5206 : gfc_array_index_type,
5207 : gfc_index_one_node, tmp);
5208 24112 : tmp = fold_build2_loc (input_location, MAX_EXPR,
5209 : gfc_array_index_type, tmp,
5210 : build_int_cst (gfc_array_index_type, 0));
5211 : /* We remember the size of the first section, and check all the
5212 : others against this. */
5213 24112 : if (size[n])
5214 : {
5215 7193 : tmp3 = fold_build2_loc (input_location, NE_EXPR,
5216 : logical_type_node, tmp, size[n]);
5217 7193 : if (ss_info->type == GFC_SS_INTRINSIC)
5218 0 : msg = xasprintf ("Extent mismatch for dimension %d of the "
5219 : "result of intrinsic '%s' (%%ld/%%ld)",
5220 : dim + 1, expr_name);
5221 : else
5222 7193 : msg = xasprintf ("Array bound mismatch for dimension %d "
5223 : "of array '%s' (%%ld/%%ld)",
5224 : dim + 1, expr_name);
5225 :
5226 7193 : gfc_trans_runtime_check (true, false, tmp3, &inner,
5227 : expr_loc, msg,
5228 : fold_convert (long_integer_type_node, tmp),
5229 : fold_convert (long_integer_type_node, size[n]));
5230 :
5231 7193 : free (msg);
5232 : }
5233 : else
5234 16919 : size[n] = gfc_evaluate_now (tmp, &inner);
5235 : }
5236 :
5237 20676 : tmp = gfc_finish_block (&inner);
5238 :
5239 : /* For optional arguments, only check bounds if the argument is
5240 : present. */
5241 20676 : if ((expr->symtree->n.sym->attr.optional
5242 20368 : || expr->symtree->n.sym->attr.not_always_present)
5243 308 : && expr->symtree->n.sym->attr.dummy)
5244 307 : tmp = build3_v (COND_EXPR,
5245 : gfc_conv_expr_present (expr->symtree->n.sym),
5246 : tmp, build_empty_stmt (input_location));
5247 :
5248 20676 : gfc_add_expr_to_block (&block, tmp);
5249 :
5250 20676 : free (ref_name);
5251 : }
5252 :
5253 16945 : tmp = gfc_finish_block (&block);
5254 16945 : gfc_add_expr_to_block (&outer_loop->pre, tmp);
5255 : }
5256 :
5257 188697 : for (loop = loop->nested; loop; loop = loop->next)
5258 3364 : gfc_conv_ss_startstride (loop);
5259 185333 : }
5260 :
5261 : /* Return true if both symbols could refer to the same data object. Does
5262 : not take account of aliasing due to equivalence statements. */
5263 :
5264 : static bool
5265 13972 : symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym, bool lsym_pointer,
5266 : bool lsym_target, bool rsym_pointer, bool rsym_target)
5267 : {
5268 : /* Aliasing isn't possible if the symbols have different base types,
5269 : except for complex types where an inquiry reference (%RE, %IM) could
5270 : alias with a real type with the same kind parameter. */
5271 13972 : if (!gfc_compare_types (&lsym->ts, &rsym->ts)
5272 13972 : && !(((lsym->ts.type == BT_COMPLEX && rsym->ts.type == BT_REAL)
5273 5019 : || (lsym->ts.type == BT_REAL && rsym->ts.type == BT_COMPLEX))
5274 76 : && lsym->ts.kind == rsym->ts.kind))
5275 : return false;
5276 :
5277 : /* Pointers can point to other pointers and target objects. */
5278 :
5279 8966 : if ((lsym_pointer && (rsym_pointer || rsym_target))
5280 8757 : || (rsym_pointer && (lsym_pointer || lsym_target)))
5281 : return true;
5282 :
5283 : /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
5284 : and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
5285 : checked above. */
5286 8843 : if (lsym_target && rsym_target
5287 14 : && ((lsym->attr.dummy && !lsym->attr.contiguous
5288 0 : && (!lsym->attr.dimension || lsym->as->type == AS_ASSUMED_SHAPE))
5289 14 : || (rsym->attr.dummy && !rsym->attr.contiguous
5290 6 : && (!rsym->attr.dimension
5291 6 : || rsym->as->type == AS_ASSUMED_SHAPE))))
5292 6 : return true;
5293 :
5294 : return false;
5295 : }
5296 :
5297 :
5298 : /* Return true if the two SS could be aliased, i.e. both point to the same data
5299 : object. */
5300 : /* TODO: resolve aliases based on frontend expressions. */
5301 :
5302 : static int
5303 11674 : gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
5304 : {
5305 11674 : gfc_ref *lref;
5306 11674 : gfc_ref *rref;
5307 11674 : gfc_expr *lexpr, *rexpr;
5308 11674 : gfc_symbol *lsym;
5309 11674 : gfc_symbol *rsym;
5310 11674 : bool lsym_pointer, lsym_target, rsym_pointer, rsym_target;
5311 :
5312 11674 : lexpr = lss->info->expr;
5313 11674 : rexpr = rss->info->expr;
5314 :
5315 11674 : lsym = lexpr->symtree->n.sym;
5316 11674 : rsym = rexpr->symtree->n.sym;
5317 :
5318 11674 : lsym_pointer = lsym->attr.pointer;
5319 11674 : lsym_target = lsym->attr.target;
5320 11674 : rsym_pointer = rsym->attr.pointer;
5321 11674 : rsym_target = rsym->attr.target;
5322 :
5323 11674 : if (symbols_could_alias (lsym, rsym, lsym_pointer, lsym_target,
5324 : rsym_pointer, rsym_target))
5325 : return 1;
5326 :
5327 11583 : if (rsym->ts.type != BT_DERIVED && rsym->ts.type != BT_CLASS
5328 10166 : && lsym->ts.type != BT_DERIVED && lsym->ts.type != BT_CLASS)
5329 : return 0;
5330 :
5331 : /* For derived types we must check all the component types. We can ignore
5332 : array references as these will have the same base type as the previous
5333 : component ref. */
5334 2914 : for (lref = lexpr->ref; lref != lss->info->data.array.ref; lref = lref->next)
5335 : {
5336 1067 : if (lref->type != REF_COMPONENT)
5337 107 : continue;
5338 :
5339 960 : lsym_pointer = lsym_pointer || lref->u.c.sym->attr.pointer;
5340 960 : lsym_target = lsym_target || lref->u.c.sym->attr.target;
5341 :
5342 960 : if (symbols_could_alias (lref->u.c.sym, rsym, lsym_pointer, lsym_target,
5343 : rsym_pointer, rsym_target))
5344 : return 1;
5345 :
5346 960 : if ((lsym_pointer && (rsym_pointer || rsym_target))
5347 945 : || (rsym_pointer && (lsym_pointer || lsym_target)))
5348 : {
5349 6 : if (gfc_compare_types (&lref->u.c.component->ts,
5350 : &rsym->ts))
5351 : return 1;
5352 : }
5353 :
5354 1450 : for (rref = rexpr->ref; rref != rss->info->data.array.ref;
5355 496 : rref = rref->next)
5356 : {
5357 497 : if (rref->type != REF_COMPONENT)
5358 36 : continue;
5359 :
5360 461 : rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
5361 461 : rsym_target = lsym_target || rref->u.c.sym->attr.target;
5362 :
5363 461 : if (symbols_could_alias (lref->u.c.sym, rref->u.c.sym,
5364 : lsym_pointer, lsym_target,
5365 : rsym_pointer, rsym_target))
5366 : return 1;
5367 :
5368 460 : if ((lsym_pointer && (rsym_pointer || rsym_target))
5369 456 : || (rsym_pointer && (lsym_pointer || lsym_target)))
5370 : {
5371 0 : if (gfc_compare_types (&lref->u.c.component->ts,
5372 0 : &rref->u.c.sym->ts))
5373 : return 1;
5374 0 : if (gfc_compare_types (&lref->u.c.sym->ts,
5375 0 : &rref->u.c.component->ts))
5376 : return 1;
5377 0 : if (gfc_compare_types (&lref->u.c.component->ts,
5378 0 : &rref->u.c.component->ts))
5379 : return 1;
5380 : }
5381 : }
5382 : }
5383 :
5384 1847 : lsym_pointer = lsym->attr.pointer;
5385 1847 : lsym_target = lsym->attr.target;
5386 :
5387 2718 : for (rref = rexpr->ref; rref != rss->info->data.array.ref; rref = rref->next)
5388 : {
5389 1024 : if (rref->type != REF_COMPONENT)
5390 : break;
5391 :
5392 877 : rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
5393 877 : rsym_target = lsym_target || rref->u.c.sym->attr.target;
5394 :
5395 877 : if (symbols_could_alias (rref->u.c.sym, lsym,
5396 : lsym_pointer, lsym_target,
5397 : rsym_pointer, rsym_target))
5398 : return 1;
5399 :
5400 877 : if ((lsym_pointer && (rsym_pointer || rsym_target))
5401 859 : || (rsym_pointer && (lsym_pointer || lsym_target)))
5402 : {
5403 6 : if (gfc_compare_types (&lsym->ts, &rref->u.c.component->ts))
5404 : return 1;
5405 : }
5406 : }
5407 :
5408 : return 0;
5409 : }
5410 :
5411 :
5412 : /* Resolve array data dependencies. Creates a temporary if required. */
5413 : /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
5414 : dependency.cc. */
5415 :
5416 : void
5417 38599 : gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
5418 : gfc_ss * rss)
5419 : {
5420 38599 : gfc_ss *ss;
5421 38599 : gfc_ref *lref;
5422 38599 : gfc_ref *rref;
5423 38599 : gfc_ss_info *ss_info;
5424 38599 : gfc_expr *dest_expr;
5425 38599 : gfc_expr *ss_expr;
5426 38599 : int nDepend = 0;
5427 38599 : int i, j;
5428 :
5429 38599 : loop->temp_ss = NULL;
5430 38599 : dest_expr = dest->info->expr;
5431 :
5432 83094 : for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
5433 : {
5434 45688 : ss_info = ss->info;
5435 45688 : ss_expr = ss_info->expr;
5436 :
5437 45688 : if (ss_info->array_outer_dependency)
5438 : {
5439 : nDepend = 1;
5440 : break;
5441 : }
5442 :
5443 45571 : if (ss_info->type != GFC_SS_SECTION)
5444 : {
5445 31108 : if (flag_realloc_lhs
5446 30056 : && dest_expr != ss_expr
5447 30056 : && gfc_is_reallocatable_lhs (dest_expr)
5448 38290 : && ss_expr->rank)
5449 3470 : nDepend = gfc_check_dependency (dest_expr, ss_expr, true);
5450 :
5451 : /* Check for cases like c(:)(1:2) = c(2)(2:3) */
5452 31108 : if (!nDepend && dest_expr->rank > 0
5453 30578 : && dest_expr->ts.type == BT_CHARACTER
5454 4778 : && ss_expr->expr_type == EXPR_VARIABLE)
5455 :
5456 165 : nDepend = gfc_check_dependency (dest_expr, ss_expr, false);
5457 :
5458 31108 : if (ss_info->type == GFC_SS_REFERENCE
5459 31108 : && gfc_check_dependency (dest_expr, ss_expr, false))
5460 188 : ss_info->data.scalar.needs_temporary = 1;
5461 :
5462 31108 : if (nDepend)
5463 : break;
5464 : else
5465 30566 : continue;
5466 : }
5467 :
5468 14463 : if (dest_expr->symtree->n.sym != ss_expr->symtree->n.sym)
5469 : {
5470 11674 : if (gfc_could_be_alias (dest, ss)
5471 11674 : || gfc_are_equivalenced_arrays (dest_expr, ss_expr))
5472 : {
5473 : nDepend = 1;
5474 : break;
5475 : }
5476 : }
5477 : else
5478 : {
5479 2789 : lref = dest_expr->ref;
5480 2789 : rref = ss_expr->ref;
5481 :
5482 2789 : nDepend = gfc_dep_resolver (lref, rref, &loop->reverse[0]);
5483 :
5484 2789 : if (nDepend == 1)
5485 : break;
5486 :
5487 5566 : for (i = 0; i < dest->dimen; i++)
5488 7558 : for (j = 0; j < ss->dimen; j++)
5489 4492 : if (i != j
5490 1363 : && dest->dim[i] == ss->dim[j])
5491 : {
5492 : /* If we don't access array elements in the same order,
5493 : there is a dependency. */
5494 63 : nDepend = 1;
5495 63 : goto temporary;
5496 : }
5497 : #if 0
5498 : /* TODO : loop shifting. */
5499 : if (nDepend == 1)
5500 : {
5501 : /* Mark the dimensions for LOOP SHIFTING */
5502 : for (n = 0; n < loop->dimen; n++)
5503 : {
5504 : int dim = dest->data.info.dim[n];
5505 :
5506 : if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
5507 : depends[n] = 2;
5508 : else if (! gfc_is_same_range (&lref->u.ar,
5509 : &rref->u.ar, dim, 0))
5510 : depends[n] = 1;
5511 : }
5512 :
5513 : /* Put all the dimensions with dependencies in the
5514 : innermost loops. */
5515 : dim = 0;
5516 : for (n = 0; n < loop->dimen; n++)
5517 : {
5518 : gcc_assert (loop->order[n] == n);
5519 : if (depends[n])
5520 : loop->order[dim++] = n;
5521 : }
5522 : for (n = 0; n < loop->dimen; n++)
5523 : {
5524 : if (! depends[n])
5525 : loop->order[dim++] = n;
5526 : }
5527 :
5528 : gcc_assert (dim == loop->dimen);
5529 : break;
5530 : }
5531 : #endif
5532 : }
5533 : }
5534 :
5535 831 : temporary:
5536 :
5537 38599 : if (nDepend == 1)
5538 : {
5539 1193 : tree base_type = gfc_typenode_for_spec (&dest_expr->ts);
5540 1193 : if (GFC_ARRAY_TYPE_P (base_type)
5541 1193 : || GFC_DESCRIPTOR_TYPE_P (base_type))
5542 0 : base_type = gfc_get_element_type (base_type);
5543 1193 : loop->temp_ss = gfc_get_temp_ss (base_type, dest->info->string_length,
5544 : loop->dimen);
5545 1193 : gfc_add_ss_to_loop (loop, loop->temp_ss);
5546 : }
5547 : else
5548 37406 : loop->temp_ss = NULL;
5549 38599 : }
5550 :
5551 :
5552 : /* Browse through each array's information from the scalarizer and set the loop
5553 : bounds according to the "best" one (per dimension), i.e. the one which
5554 : provides the most information (constant bounds, shape, etc.). */
5555 :
5556 : static void
5557 185333 : set_loop_bounds (gfc_loopinfo *loop)
5558 : {
5559 185333 : int n, dim, spec_dim;
5560 185333 : gfc_array_info *info;
5561 185333 : gfc_array_info *specinfo;
5562 185333 : gfc_ss *ss;
5563 185333 : tree tmp;
5564 185333 : gfc_ss **loopspec;
5565 185333 : bool dynamic[GFC_MAX_DIMENSIONS];
5566 185333 : mpz_t *cshape;
5567 185333 : mpz_t i;
5568 185333 : bool nonoptional_arr;
5569 :
5570 185333 : gfc_loopinfo * const outer_loop = outermost_loop (loop);
5571 :
5572 185333 : loopspec = loop->specloop;
5573 :
5574 185333 : mpz_init (i);
5575 621725 : for (n = 0; n < loop->dimen; n++)
5576 : {
5577 251059 : loopspec[n] = NULL;
5578 251059 : dynamic[n] = false;
5579 :
5580 : /* If there are both optional and nonoptional array arguments, scalarize
5581 : over the nonoptional; otherwise, it does not matter as then all
5582 : (optional) arrays have to be present per F2008, 125.2.12p3(6). */
5583 :
5584 251059 : nonoptional_arr = false;
5585 :
5586 292775 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5587 292755 : if (ss->info->type != GFC_SS_SCALAR && ss->info->type != GFC_SS_TEMP
5588 257630 : && ss->info->type != GFC_SS_REFERENCE && !ss->info->can_be_null_ref)
5589 : {
5590 : nonoptional_arr = true;
5591 : break;
5592 : }
5593 :
5594 : /* We use one SS term, and use that to determine the bounds of the
5595 : loop for this dimension. We try to pick the simplest term. */
5596 657355 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5597 : {
5598 406296 : gfc_ss_type ss_type;
5599 :
5600 406296 : ss_type = ss->info->type;
5601 476891 : if (ss_type == GFC_SS_SCALAR
5602 406296 : || ss_type == GFC_SS_TEMP
5603 344971 : || ss_type == GFC_SS_REFERENCE
5604 335978 : || (ss->info->can_be_null_ref && nonoptional_arr))
5605 70595 : continue;
5606 :
5607 335701 : info = &ss->info->data.array;
5608 335701 : dim = ss->dim[n];
5609 :
5610 335701 : if (loopspec[n] != NULL)
5611 : {
5612 84642 : specinfo = &loopspec[n]->info->data.array;
5613 84642 : spec_dim = loopspec[n]->dim[n];
5614 : }
5615 : else
5616 : {
5617 : /* Silence uninitialized warnings. */
5618 : specinfo = NULL;
5619 : spec_dim = 0;
5620 : }
5621 :
5622 335701 : if (info->shape)
5623 : {
5624 : /* The frontend has worked out the size for us. */
5625 226654 : if (!loopspec[n]
5626 59855 : || !specinfo->shape
5627 273608 : || !integer_zerop (specinfo->start[spec_dim]))
5628 : /* Prefer zero-based descriptors if possible. */
5629 209558 : loopspec[n] = ss;
5630 226654 : continue;
5631 : }
5632 :
5633 109047 : if (ss_type == GFC_SS_CONSTRUCTOR)
5634 : {
5635 1452 : gfc_constructor_base base;
5636 : /* An unknown size constructor will always be rank one.
5637 : Higher rank constructors will either have known shape,
5638 : or still be wrapped in a call to reshape. */
5639 1452 : gcc_assert (loop->dimen == 1);
5640 :
5641 : /* Always prefer to use the constructor bounds if the size
5642 : can be determined at compile time. Prefer not to otherwise,
5643 : since the general case involves realloc, and it's better to
5644 : avoid that overhead if possible. */
5645 1452 : base = ss->info->expr->value.constructor;
5646 1452 : dynamic[n] = gfc_get_array_constructor_size (&i, base);
5647 1452 : if (!dynamic[n] || !loopspec[n])
5648 1229 : loopspec[n] = ss;
5649 1452 : continue;
5650 1452 : }
5651 :
5652 : /* Avoid using an allocatable lhs in an assignment, since
5653 : there might be a reallocation coming. */
5654 107595 : if (loopspec[n] && ss->is_alloc_lhs)
5655 9619 : continue;
5656 :
5657 97976 : if (!loopspec[n])
5658 83031 : loopspec[n] = ss;
5659 : /* Criteria for choosing a loop specifier (most important first):
5660 : doesn't need realloc
5661 : stride of one
5662 : known stride
5663 : known lower bound
5664 : known upper bound
5665 : */
5666 14945 : else if (loopspec[n]->info->type == GFC_SS_CONSTRUCTOR && dynamic[n])
5667 235 : loopspec[n] = ss;
5668 14710 : else if (integer_onep (info->stride[dim])
5669 14710 : && !integer_onep (specinfo->stride[spec_dim]))
5670 120 : loopspec[n] = ss;
5671 14590 : else if (INTEGER_CST_P (info->stride[dim])
5672 14366 : && !INTEGER_CST_P (specinfo->stride[spec_dim]))
5673 0 : loopspec[n] = ss;
5674 14590 : else if (INTEGER_CST_P (info->start[dim])
5675 4481 : && !INTEGER_CST_P (specinfo->start[spec_dim])
5676 856 : && integer_onep (info->stride[dim])
5677 428 : == integer_onep (specinfo->stride[spec_dim])
5678 14590 : && INTEGER_CST_P (info->stride[dim])
5679 401 : == INTEGER_CST_P (specinfo->stride[spec_dim]))
5680 401 : loopspec[n] = ss;
5681 : /* We don't work out the upper bound.
5682 : else if (INTEGER_CST_P (info->finish[n])
5683 : && ! INTEGER_CST_P (specinfo->finish[n]))
5684 : loopspec[n] = ss; */
5685 : }
5686 :
5687 : /* We should have found the scalarization loop specifier. If not,
5688 : that's bad news. */
5689 251059 : gcc_assert (loopspec[n]);
5690 :
5691 251059 : info = &loopspec[n]->info->data.array;
5692 251059 : dim = loopspec[n]->dim[n];
5693 :
5694 : /* Set the extents of this range. */
5695 251059 : cshape = info->shape;
5696 251059 : if (cshape && INTEGER_CST_P (info->start[dim])
5697 179501 : && INTEGER_CST_P (info->stride[dim]))
5698 : {
5699 179501 : loop->from[n] = info->start[dim];
5700 179501 : mpz_set (i, cshape[get_array_ref_dim_for_loop_dim (loopspec[n], n)]);
5701 179501 : mpz_sub_ui (i, i, 1);
5702 : /* To = from + (size - 1) * stride. */
5703 179501 : tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
5704 179501 : if (!integer_onep (info->stride[dim]))
5705 8743 : tmp = fold_build2_loc (input_location, MULT_EXPR,
5706 : gfc_array_index_type, tmp,
5707 : info->stride[dim]);
5708 179501 : loop->to[n] = fold_build2_loc (input_location, PLUS_EXPR,
5709 : gfc_array_index_type,
5710 : loop->from[n], tmp);
5711 : }
5712 : else
5713 : {
5714 71558 : loop->from[n] = info->start[dim];
5715 71558 : switch (loopspec[n]->info->type)
5716 : {
5717 893 : case GFC_SS_CONSTRUCTOR:
5718 : /* The upper bound is calculated when we expand the
5719 : constructor. */
5720 893 : gcc_assert (loop->to[n] == NULL_TREE);
5721 : break;
5722 :
5723 65015 : case GFC_SS_SECTION:
5724 : /* Use the end expression if it exists and is not constant,
5725 : so that it is only evaluated once. */
5726 65015 : loop->to[n] = info->end[dim];
5727 65015 : break;
5728 :
5729 4871 : case GFC_SS_FUNCTION:
5730 : /* The loop bound will be set when we generate the call. */
5731 4871 : gcc_assert (loop->to[n] == NULL_TREE);
5732 : break;
5733 :
5734 767 : case GFC_SS_INTRINSIC:
5735 767 : {
5736 767 : gfc_expr *expr = loopspec[n]->info->expr;
5737 :
5738 : /* The {l,u}bound of an assumed rank. */
5739 767 : if (expr->value.function.isym->id == GFC_ISYM_SHAPE)
5740 255 : gcc_assert (expr->value.function.actual->expr->rank == -1);
5741 : else
5742 512 : gcc_assert ((expr->value.function.isym->id == GFC_ISYM_LBOUND
5743 : || expr->value.function.isym->id == GFC_ISYM_UBOUND)
5744 : && expr->value.function.actual->next->expr == NULL
5745 : && expr->value.function.actual->expr->rank == -1);
5746 :
5747 767 : loop->to[n] = info->end[dim];
5748 767 : break;
5749 : }
5750 :
5751 12 : case GFC_SS_COMPONENT:
5752 12 : {
5753 12 : if (info->end[dim] != NULL_TREE)
5754 : {
5755 12 : loop->to[n] = info->end[dim];
5756 12 : break;
5757 : }
5758 : else
5759 0 : gcc_unreachable ();
5760 : }
5761 :
5762 0 : default:
5763 0 : gcc_unreachable ();
5764 : }
5765 : }
5766 :
5767 : /* Transform everything so we have a simple incrementing variable. */
5768 251059 : if (integer_onep (info->stride[dim]))
5769 240177 : info->delta[dim] = gfc_index_zero_node;
5770 : else
5771 : {
5772 : /* Set the delta for this section. */
5773 10882 : info->delta[dim] = gfc_evaluate_now (loop->from[n], &outer_loop->pre);
5774 : /* Number of iterations is (end - start + step) / step.
5775 : with start = 0, this simplifies to
5776 : last = end / step;
5777 : for (i = 0; i<=last; i++){...}; */
5778 10882 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
5779 : gfc_array_index_type, loop->to[n],
5780 : loop->from[n]);
5781 10882 : tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
5782 : gfc_array_index_type, tmp, info->stride[dim]);
5783 10882 : tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
5784 : tmp, build_int_cst (gfc_array_index_type, -1));
5785 10882 : loop->to[n] = gfc_evaluate_now (tmp, &outer_loop->pre);
5786 : /* Make the loop variable start at 0. */
5787 10882 : loop->from[n] = gfc_index_zero_node;
5788 : }
5789 : }
5790 185333 : mpz_clear (i);
5791 :
5792 188697 : for (loop = loop->nested; loop; loop = loop->next)
5793 3364 : set_loop_bounds (loop);
5794 185333 : }
5795 :
5796 :
5797 : /* Last attempt to set the loop bounds, in case they depend on an allocatable
5798 : function result. */
5799 :
5800 : static void
5801 185333 : late_set_loop_bounds (gfc_loopinfo *loop)
5802 : {
5803 185333 : int n, dim;
5804 185333 : gfc_array_info *info;
5805 185333 : gfc_ss **loopspec;
5806 :
5807 185333 : loopspec = loop->specloop;
5808 :
5809 436392 : for (n = 0; n < loop->dimen; n++)
5810 : {
5811 : /* Set the extents of this range. */
5812 251059 : if (loop->from[n] == NULL_TREE
5813 251059 : || loop->to[n] == NULL_TREE)
5814 : {
5815 : /* We should have found the scalarization loop specifier. If not,
5816 : that's bad news. */
5817 455 : gcc_assert (loopspec[n]);
5818 :
5819 455 : info = &loopspec[n]->info->data.array;
5820 455 : dim = loopspec[n]->dim[n];
5821 :
5822 455 : if (loopspec[n]->info->type == GFC_SS_FUNCTION
5823 455 : && info->start[dim]
5824 455 : && info->end[dim])
5825 : {
5826 153 : loop->from[n] = info->start[dim];
5827 153 : loop->to[n] = info->end[dim];
5828 : }
5829 : }
5830 : }
5831 :
5832 188697 : for (loop = loop->nested; loop; loop = loop->next)
5833 3364 : late_set_loop_bounds (loop);
5834 185333 : }
5835 :
5836 :
5837 : /* Initialize the scalarization loop. Creates the loop variables. Determines
5838 : the range of the loop variables. Creates a temporary if required.
5839 : Also generates code for scalar expressions which have been
5840 : moved outside the loop. */
5841 :
5842 : void
5843 181969 : gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
5844 : {
5845 181969 : gfc_ss *tmp_ss;
5846 181969 : tree tmp;
5847 :
5848 181969 : set_loop_bounds (loop);
5849 :
5850 : /* Add all the scalar code that can be taken out of the loops.
5851 : This may include calculating the loop bounds, so do it before
5852 : allocating the temporary. */
5853 181969 : gfc_add_loop_ss_code (loop, loop->ss, false, where);
5854 :
5855 181969 : late_set_loop_bounds (loop);
5856 :
5857 181969 : tmp_ss = loop->temp_ss;
5858 : /* If we want a temporary then create it. */
5859 181969 : if (tmp_ss != NULL)
5860 : {
5861 11539 : gfc_ss_info *tmp_ss_info;
5862 :
5863 11539 : tmp_ss_info = tmp_ss->info;
5864 11539 : gcc_assert (tmp_ss_info->type == GFC_SS_TEMP);
5865 11539 : gcc_assert (loop->parent == NULL);
5866 :
5867 : /* Make absolutely sure that this is a complete type. */
5868 11539 : if (tmp_ss_info->string_length)
5869 2773 : tmp_ss_info->data.temp.type
5870 2773 : = gfc_get_character_type_len_for_eltype
5871 2773 : (TREE_TYPE (tmp_ss_info->data.temp.type),
5872 : tmp_ss_info->string_length);
5873 :
5874 11539 : tmp = tmp_ss_info->data.temp.type;
5875 11539 : memset (&tmp_ss_info->data.array, 0, sizeof (gfc_array_info));
5876 11539 : tmp_ss_info->type = GFC_SS_SECTION;
5877 :
5878 11539 : gcc_assert (tmp_ss->dimen != 0);
5879 :
5880 11539 : gfc_trans_create_temp_array (&loop->pre, &loop->post, tmp_ss, tmp,
5881 : NULL_TREE, false, true, false, where);
5882 : }
5883 :
5884 : /* For array parameters we don't have loop variables, so don't calculate the
5885 : translations. */
5886 181969 : if (!loop->array_parameter)
5887 114073 : gfc_set_delta (loop);
5888 181969 : }
5889 :
5890 :
5891 : /* Calculates how to transform from loop variables to array indices for each
5892 : array: once loop bounds are chosen, sets the difference (DELTA field) between
5893 : loop bounds and array reference bounds, for each array info. */
5894 :
5895 : void
5896 117904 : gfc_set_delta (gfc_loopinfo *loop)
5897 : {
5898 117904 : gfc_ss *ss, **loopspec;
5899 117904 : gfc_array_info *info;
5900 117904 : tree tmp;
5901 117904 : int n, dim;
5902 :
5903 117904 : gfc_loopinfo * const outer_loop = outermost_loop (loop);
5904 :
5905 117904 : loopspec = loop->specloop;
5906 :
5907 : /* Calculate the translation from loop variables to array indices. */
5908 357344 : for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5909 : {
5910 239440 : gfc_ss_type ss_type;
5911 :
5912 239440 : ss_type = ss->info->type;
5913 61370 : if (!(ss_type == GFC_SS_SECTION
5914 239440 : || ss_type == GFC_SS_COMPONENT
5915 97486 : || ss_type == GFC_SS_CONSTRUCTOR
5916 : || (ss_type == GFC_SS_FUNCTION
5917 8286 : && gfc_is_class_array_function (ss->info->expr))))
5918 61218 : continue;
5919 :
5920 178222 : info = &ss->info->data.array;
5921 :
5922 400703 : for (n = 0; n < ss->dimen; n++)
5923 : {
5924 : /* If we are specifying the range the delta is already set. */
5925 222481 : if (loopspec[n] != ss)
5926 : {
5927 115955 : dim = ss->dim[n];
5928 :
5929 : /* Calculate the offset relative to the loop variable.
5930 : First multiply by the stride. */
5931 115955 : tmp = loop->from[n];
5932 115955 : if (!integer_onep (info->stride[dim]))
5933 3126 : tmp = fold_build2_loc (input_location, MULT_EXPR,
5934 : gfc_array_index_type,
5935 : tmp, info->stride[dim]);
5936 :
5937 : /* Then subtract this from our starting value. */
5938 115955 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
5939 : gfc_array_index_type,
5940 : info->start[dim], tmp);
5941 :
5942 115955 : if (ss->is_alloc_lhs)
5943 9619 : info->delta[dim] = tmp;
5944 : else
5945 106336 : info->delta[dim] = gfc_evaluate_now (tmp, &outer_loop->pre);
5946 : }
5947 : }
5948 : }
5949 :
5950 121356 : for (loop = loop->nested; loop; loop = loop->next)
5951 3452 : gfc_set_delta (loop);
5952 117904 : }
5953 :
5954 :
5955 : /* Calculate the size of a given array dimension from the bounds. This
5956 : is simply (ubound - lbound + 1) if this expression is positive
5957 : or 0 if it is negative (pick either one if it is zero). Optionally
5958 : (if or_expr is present) OR the (expression != 0) condition to it. */
5959 :
5960 : tree
5961 23333 : gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr)
5962 : {
5963 23333 : tree res;
5964 23333 : tree cond;
5965 :
5966 : /* Calculate (ubound - lbound + 1). */
5967 23333 : res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5968 : ubound, lbound);
5969 23333 : res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res,
5970 : gfc_index_one_node);
5971 :
5972 : /* Check whether the size for this dimension is negative. */
5973 23333 : cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, res,
5974 : gfc_index_zero_node);
5975 23333 : res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
5976 : gfc_index_zero_node, res);
5977 :
5978 : /* Build OR expression. */
5979 23333 : if (or_expr)
5980 17942 : *or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
5981 : logical_type_node, *or_expr, cond);
5982 :
5983 23333 : return res;
5984 : }
5985 :
5986 :
5987 : /* Fills in an array descriptor, and returns the size of the array.
5988 : The size will be a simple_val, ie a variable or a constant. Also
5989 : calculates the offset of the base. The pointer argument overflow,
5990 : which should be of integer type, will increase in value if overflow
5991 : occurs during the size calculation. Returns the size of the array.
5992 : {
5993 : stride = 1;
5994 : offset = 0;
5995 : for (n = 0; n < rank; n++)
5996 : {
5997 : a.lbound[n] = specified_lower_bound;
5998 : offset = offset + a.lbond[n] * stride;
5999 : size = 1 - lbound;
6000 : a.ubound[n] = specified_upper_bound;
6001 : a.stride[n] = stride;
6002 : size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
6003 : overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
6004 : stride = stride * size;
6005 : }
6006 : for (n = rank; n < rank+corank; n++)
6007 : (Set lcobound/ucobound as above.)
6008 : element_size = sizeof (array element);
6009 : if (!rank)
6010 : return element_size
6011 : stride = (size_t) stride;
6012 : overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
6013 : stride = stride * element_size;
6014 : return (stride);
6015 : } */
6016 : /*GCC ARRAYS*/
6017 :
6018 : static tree
6019 12300 : gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
6020 : gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
6021 : stmtblock_t * descriptor_block, tree * overflow,
6022 : tree expr3_elem_size, gfc_expr *expr3, tree expr3_desc,
6023 : bool e3_has_nodescriptor, gfc_expr *expr,
6024 : tree *element_size, bool explicit_ts)
6025 : {
6026 12300 : tree type;
6027 12300 : tree tmp;
6028 12300 : tree size;
6029 12300 : tree offset;
6030 12300 : tree stride;
6031 12300 : tree or_expr;
6032 12300 : tree thencase;
6033 12300 : tree elsecase;
6034 12300 : tree cond;
6035 12300 : tree var;
6036 12300 : stmtblock_t thenblock;
6037 12300 : stmtblock_t elseblock;
6038 12300 : gfc_expr *ubound;
6039 12300 : gfc_se se;
6040 12300 : int n;
6041 :
6042 12300 : if (expr->ts.type == BT_CLASS
6043 1704 : && expr3_desc != NULL_TREE
6044 12662 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr3_desc)))
6045 362 : type = TREE_TYPE (expr3_desc);
6046 : else
6047 11938 : type = TREE_TYPE (descriptor);
6048 :
6049 :
6050 12300 : stride = gfc_index_one_node;
6051 12300 : offset = gfc_index_zero_node;
6052 :
6053 : /* Set the dtype before the alloc, because registration of coarrays needs
6054 : it initialized. */
6055 12300 : if (expr->ts.type == BT_CHARACTER
6056 1079 : && expr->ts.deferred
6057 545 : && VAR_P (expr->ts.u.cl->backend_decl))
6058 : {
6059 366 : type = gfc_typenode_for_spec (&expr->ts);
6060 366 : gfc_conv_descriptor_dtype_set (pblock, descriptor,
6061 : gfc_get_dtype_rank_type (rank, type));
6062 : }
6063 11934 : else if (expr->ts.type == BT_CHARACTER
6064 713 : && expr->ts.deferred
6065 179 : && TREE_CODE (descriptor) == COMPONENT_REF)
6066 : {
6067 : /* Deferred character components have their string length tucked away
6068 : in a hidden field of the derived type. Obtain that and use it to
6069 : set the dtype. The charlen backend decl is zero because the field
6070 : type is zero length. */
6071 161 : gfc_ref *ref;
6072 161 : tmp = NULL_TREE;
6073 161 : for (ref = expr->ref; ref; ref = ref->next)
6074 161 : if (ref->type == REF_COMPONENT
6075 161 : && gfc_deferred_strlen (ref->u.c.component, &tmp))
6076 : break;
6077 161 : gcc_assert (tmp != NULL_TREE);
6078 161 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
6079 161 : TREE_OPERAND (descriptor, 0), tmp, NULL_TREE);
6080 161 : tmp = fold_convert (gfc_charlen_type_node, tmp);
6081 161 : type = gfc_get_character_type_len (expr->ts.kind, tmp);
6082 161 : gfc_conv_descriptor_dtype_set (pblock, descriptor,
6083 : gfc_get_dtype_rank_type (rank, type));
6084 161 : }
6085 11773 : else if (expr3_desc && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr3_desc)))
6086 952 : gfc_conv_descriptor_dtype_set (pblock, descriptor,
6087 : gfc_conv_descriptor_dtype_get (expr3_desc));
6088 10821 : else if (expr->ts.type == BT_CLASS && !explicit_ts
6089 1342 : && expr3 && expr3->ts.type != BT_CLASS
6090 355 : && expr3_elem_size != NULL_TREE && expr3_desc == NULL_TREE)
6091 : {
6092 355 : gfc_conv_descriptor_dtype_set (pblock, descriptor, gfc_get_dtype (type));
6093 355 : gfc_conv_descriptor_elem_len_set (pblock, descriptor, expr3_elem_size);
6094 : }
6095 : else
6096 10466 : gfc_conv_descriptor_dtype_set (pblock, descriptor, gfc_get_dtype (type));
6097 :
6098 12300 : or_expr = logical_false_node;
6099 :
6100 30242 : for (n = 0; n < rank; n++)
6101 : {
6102 17942 : tree conv_lbound;
6103 17942 : tree conv_ubound;
6104 :
6105 : /* We have 3 possibilities for determining the size of the array:
6106 : lower == NULL => lbound = 1, ubound = upper[n]
6107 : upper[n] = NULL => lbound = 1, ubound = lower[n]
6108 : upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
6109 17942 : ubound = upper[n];
6110 :
6111 : /* Set lower bound. */
6112 17942 : gfc_init_se (&se, NULL);
6113 17942 : if (expr3_desc != NULL_TREE)
6114 : {
6115 1495 : if (e3_has_nodescriptor)
6116 : /* The lbound of nondescriptor arrays like array constructors,
6117 : nonallocatable/nonpointer function results/variables,
6118 : start at zero, but when allocating it, the standard expects
6119 : the array to start at one. */
6120 967 : se.expr = gfc_index_one_node;
6121 : else
6122 528 : se.expr = gfc_conv_descriptor_lbound_get (expr3_desc,
6123 : gfc_rank_cst[n]);
6124 : }
6125 16447 : else if (lower == NULL)
6126 13260 : se.expr = gfc_index_one_node;
6127 : else
6128 : {
6129 3187 : gcc_assert (lower[n]);
6130 3187 : if (ubound)
6131 : {
6132 2457 : gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
6133 2457 : gfc_add_block_to_block (pblock, &se.pre);
6134 : }
6135 : else
6136 : {
6137 730 : se.expr = gfc_index_one_node;
6138 730 : ubound = lower[n];
6139 : }
6140 : }
6141 17942 : gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
6142 : gfc_rank_cst[n], se.expr);
6143 17942 : conv_lbound = se.expr;
6144 :
6145 : /* Work out the offset for this component. */
6146 17942 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6147 : se.expr, stride);
6148 17942 : offset = fold_build2_loc (input_location, MINUS_EXPR,
6149 : gfc_array_index_type, offset, tmp);
6150 :
6151 : /* Set upper bound. */
6152 17942 : gfc_init_se (&se, NULL);
6153 17942 : if (expr3_desc != NULL_TREE)
6154 : {
6155 1495 : if (e3_has_nodescriptor)
6156 : {
6157 : /* The lbound of nondescriptor arrays like array constructors,
6158 : nonallocatable/nonpointer function results/variables,
6159 : start at zero, but when allocating it, the standard expects
6160 : the array to start at one. Therefore fix the upper bound to be
6161 : (desc.ubound - desc.lbound) + 1. */
6162 967 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
6163 : gfc_array_index_type,
6164 : gfc_conv_descriptor_ubound_get (
6165 : expr3_desc, gfc_rank_cst[n]),
6166 : gfc_conv_descriptor_lbound_get (
6167 : expr3_desc, gfc_rank_cst[n]));
6168 967 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
6169 : gfc_array_index_type, tmp,
6170 : gfc_index_one_node);
6171 967 : se.expr = gfc_evaluate_now (tmp, pblock);
6172 : }
6173 : else
6174 528 : se.expr = gfc_conv_descriptor_ubound_get (expr3_desc,
6175 : gfc_rank_cst[n]);
6176 : }
6177 : else
6178 : {
6179 16447 : gcc_assert (ubound);
6180 16447 : gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
6181 16447 : gfc_add_block_to_block (pblock, &se.pre);
6182 16447 : if (ubound->expr_type == EXPR_FUNCTION)
6183 781 : se.expr = gfc_evaluate_now (se.expr, pblock);
6184 : }
6185 17942 : gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
6186 : gfc_rank_cst[n], se.expr);
6187 17942 : conv_ubound = se.expr;
6188 :
6189 : /* Store the stride. */
6190 17942 : gfc_conv_descriptor_stride_set (descriptor_block, descriptor,
6191 : gfc_rank_cst[n], stride);
6192 :
6193 : /* Calculate size and check whether extent is negative. */
6194 17942 : size = gfc_conv_array_extent_dim (conv_lbound, conv_ubound, &or_expr);
6195 17942 : size = gfc_evaluate_now (size, pblock);
6196 :
6197 : /* Check whether multiplying the stride by the number of
6198 : elements in this dimension would overflow. We must also check
6199 : whether the current dimension has zero size in order to avoid
6200 : division by zero.
6201 : */
6202 17942 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
6203 : gfc_array_index_type,
6204 17942 : fold_convert (gfc_array_index_type,
6205 : TYPE_MAX_VALUE (gfc_array_index_type)),
6206 : size);
6207 17942 : cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
6208 : logical_type_node, tmp, stride),
6209 : PRED_FORTRAN_OVERFLOW);
6210 17942 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
6211 : integer_one_node, integer_zero_node);
6212 17942 : cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
6213 : logical_type_node, size,
6214 : gfc_index_zero_node),
6215 : PRED_FORTRAN_SIZE_ZERO);
6216 17942 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
6217 : integer_zero_node, tmp);
6218 17942 : tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
6219 : *overflow, tmp);
6220 17942 : *overflow = gfc_evaluate_now (tmp, pblock);
6221 :
6222 : /* Multiply the stride by the number of elements in this dimension. */
6223 17942 : stride = fold_build2_loc (input_location, MULT_EXPR,
6224 : gfc_array_index_type, stride, size);
6225 17942 : stride = gfc_evaluate_now (stride, pblock);
6226 : }
6227 :
6228 12969 : for (n = rank; n < rank + corank; n++)
6229 : {
6230 669 : ubound = upper[n];
6231 :
6232 : /* Set lower bound. */
6233 669 : gfc_init_se (&se, NULL);
6234 669 : if (lower == NULL || lower[n] == NULL)
6235 : {
6236 400 : gcc_assert (n == rank + corank - 1);
6237 400 : se.expr = gfc_index_one_node;
6238 : }
6239 : else
6240 : {
6241 269 : if (ubound || n == rank + corank - 1)
6242 : {
6243 175 : gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
6244 175 : gfc_add_block_to_block (pblock, &se.pre);
6245 : }
6246 : else
6247 : {
6248 94 : se.expr = gfc_index_one_node;
6249 94 : ubound = lower[n];
6250 : }
6251 : }
6252 669 : gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
6253 : gfc_rank_cst[n], se.expr);
6254 :
6255 669 : if (n < rank + corank - 1)
6256 : {
6257 178 : gfc_init_se (&se, NULL);
6258 178 : gcc_assert (ubound);
6259 178 : gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
6260 178 : gfc_add_block_to_block (pblock, &se.pre);
6261 178 : gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
6262 : gfc_rank_cst[n], se.expr);
6263 : }
6264 : }
6265 :
6266 : /* The stride is the number of elements in the array, so multiply by the
6267 : size of an element to get the total size. Obviously, if there is a
6268 : SOURCE expression (expr3) we must use its element size. */
6269 12300 : if (expr3_elem_size != NULL_TREE)
6270 3103 : tmp = expr3_elem_size;
6271 9197 : else if (expr3 != NULL)
6272 : {
6273 0 : if (expr3->ts.type == BT_CLASS)
6274 : {
6275 0 : gfc_se se_sz;
6276 0 : gfc_expr *sz = gfc_copy_expr (expr3);
6277 0 : gfc_add_vptr_component (sz);
6278 0 : gfc_add_size_component (sz);
6279 0 : gfc_init_se (&se_sz, NULL);
6280 0 : gfc_conv_expr (&se_sz, sz);
6281 0 : gfc_free_expr (sz);
6282 0 : tmp = se_sz.expr;
6283 : }
6284 : else
6285 : {
6286 0 : tmp = gfc_typenode_for_spec (&expr3->ts);
6287 0 : tmp = TYPE_SIZE_UNIT (tmp);
6288 : }
6289 : }
6290 : else
6291 9197 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
6292 :
6293 : /* Convert to size_t. */
6294 12300 : *element_size = fold_convert (size_type_node, tmp);
6295 :
6296 12300 : if (rank == 0)
6297 : return *element_size;
6298 :
6299 12073 : stride = fold_convert (size_type_node, stride);
6300 :
6301 : /* First check for overflow. Since an array of type character can
6302 : have zero element_size, we must check for that before
6303 : dividing. */
6304 12073 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
6305 : size_type_node,
6306 12073 : TYPE_MAX_VALUE (size_type_node), *element_size);
6307 12073 : cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
6308 : logical_type_node, tmp, stride),
6309 : PRED_FORTRAN_OVERFLOW);
6310 12073 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
6311 : integer_one_node, integer_zero_node);
6312 12073 : cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
6313 : logical_type_node, *element_size,
6314 : build_int_cst (size_type_node, 0)),
6315 : PRED_FORTRAN_SIZE_ZERO);
6316 12073 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
6317 : integer_zero_node, tmp);
6318 12073 : tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
6319 : *overflow, tmp);
6320 12073 : *overflow = gfc_evaluate_now (tmp, pblock);
6321 :
6322 12073 : size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
6323 : stride, *element_size);
6324 :
6325 12073 : if (poffset != NULL)
6326 : {
6327 12073 : offset = gfc_evaluate_now (offset, pblock);
6328 12073 : *poffset = offset;
6329 : }
6330 :
6331 12073 : if (integer_zerop (or_expr))
6332 : return size;
6333 3661 : if (integer_onep (or_expr))
6334 605 : return build_int_cst (size_type_node, 0);
6335 :
6336 3056 : var = gfc_create_var (TREE_TYPE (size), "size");
6337 3056 : gfc_start_block (&thenblock);
6338 3056 : gfc_add_modify (&thenblock, var, build_int_cst (size_type_node, 0));
6339 3056 : thencase = gfc_finish_block (&thenblock);
6340 :
6341 3056 : gfc_start_block (&elseblock);
6342 3056 : gfc_add_modify (&elseblock, var, size);
6343 3056 : elsecase = gfc_finish_block (&elseblock);
6344 :
6345 3056 : tmp = gfc_evaluate_now (or_expr, pblock);
6346 3056 : tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
6347 3056 : gfc_add_expr_to_block (pblock, tmp);
6348 :
6349 3056 : return var;
6350 : }
6351 :
6352 :
6353 : /* Retrieve the last ref from the chain. This routine is specific to
6354 : gfc_array_allocate ()'s needs. */
6355 :
6356 : bool
6357 18791 : retrieve_last_ref (gfc_ref **ref_in, gfc_ref **prev_ref_in)
6358 : {
6359 18791 : gfc_ref *ref, *prev_ref;
6360 :
6361 18791 : ref = *ref_in;
6362 : /* Prevent warnings for uninitialized variables. */
6363 18791 : prev_ref = *prev_ref_in;
6364 26085 : while (ref && ref->next != NULL)
6365 : {
6366 7294 : gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
6367 : || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
6368 7294 : prev_ref = ref;
6369 7294 : ref = ref->next;
6370 : }
6371 :
6372 18791 : if (ref == NULL || ref->type != REF_ARRAY)
6373 : return false;
6374 :
6375 13537 : *ref_in = ref;
6376 13537 : *prev_ref_in = prev_ref;
6377 13537 : return true;
6378 : }
6379 :
6380 : /* Initializes the descriptor and generates a call to _gfor_allocate. Does
6381 : the work for an ALLOCATE statement. */
6382 : /*GCC ARRAYS*/
6383 :
6384 : bool
6385 17554 : gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
6386 : tree errlen, tree label_finish, tree expr3_elem_size,
6387 : gfc_expr *expr3, tree e3_arr_desc, bool e3_has_nodescriptor,
6388 : gfc_omp_namelist *omp_alloc, bool explicit_ts)
6389 : {
6390 17554 : tree tmp;
6391 17554 : tree pointer;
6392 17554 : tree offset = NULL_TREE;
6393 17554 : tree token = NULL_TREE;
6394 17554 : tree size;
6395 17554 : tree msg;
6396 17554 : tree error = NULL_TREE;
6397 17554 : tree overflow; /* Boolean storing whether size calculation overflows. */
6398 17554 : tree var_overflow = NULL_TREE;
6399 17554 : tree cond;
6400 17554 : tree set_descriptor;
6401 17554 : tree not_prev_allocated = NULL_TREE;
6402 17554 : tree element_size = NULL_TREE;
6403 17554 : stmtblock_t set_descriptor_block;
6404 17554 : stmtblock_t elseblock;
6405 17554 : gfc_expr **lower;
6406 17554 : gfc_expr **upper;
6407 17554 : gfc_ref *ref, *prev_ref = NULL, *coref;
6408 17554 : bool allocatable, coarray, dimension, alloc_w_e3_arr_spec = false,
6409 : non_ulimate_coarray_ptr_comp;
6410 17554 : tree omp_cond = NULL_TREE, omp_alt_alloc = NULL_TREE;
6411 :
6412 17554 : ref = expr->ref;
6413 :
6414 : /* Find the last reference in the chain. */
6415 17554 : if (!retrieve_last_ref (&ref, &prev_ref))
6416 : return false;
6417 :
6418 : /* Take the allocatable and coarray properties solely from the expr-ref's
6419 : attributes and not from source=-expression. */
6420 12300 : if (!prev_ref)
6421 : {
6422 8361 : allocatable = expr->symtree->n.sym->attr.allocatable;
6423 8361 : dimension = expr->symtree->n.sym->attr.dimension;
6424 8361 : non_ulimate_coarray_ptr_comp = false;
6425 : }
6426 : else
6427 : {
6428 3939 : allocatable = prev_ref->u.c.component->attr.allocatable;
6429 : /* Pointer components in coarrayed derived types must be treated
6430 : specially in that they are registered without a check if the are
6431 : already associated. This does not hold for ultimate coarray
6432 : pointers. */
6433 7878 : non_ulimate_coarray_ptr_comp = (prev_ref->u.c.component->attr.pointer
6434 3939 : && !prev_ref->u.c.component->attr.codimension);
6435 3939 : dimension = prev_ref->u.c.component->attr.dimension;
6436 : }
6437 :
6438 : /* For allocatable/pointer arrays in derived types, one of the refs has to be
6439 : a coarray. In this case it does not matter whether we are on this_image
6440 : or not. */
6441 12300 : coarray = false;
6442 29503 : for (coref = expr->ref; coref; coref = coref->next)
6443 17869 : if (coref->type == REF_ARRAY && coref->u.ar.codimen > 0)
6444 : {
6445 : coarray = true;
6446 : break;
6447 : }
6448 :
6449 12300 : if (!dimension)
6450 227 : gcc_assert (coarray);
6451 :
6452 12300 : if (ref->u.ar.type == AR_FULL && expr3 != NULL)
6453 : {
6454 1237 : gfc_ref *old_ref = ref;
6455 : /* F08:C633: Array shape from expr3. */
6456 1237 : ref = expr3->ref;
6457 :
6458 : /* Find the last reference in the chain. */
6459 1237 : if (!retrieve_last_ref (&ref, &prev_ref))
6460 : {
6461 0 : if (expr3->expr_type == EXPR_FUNCTION
6462 0 : && gfc_expr_attr (expr3).dimension)
6463 0 : ref = old_ref;
6464 : else
6465 0 : return false;
6466 : }
6467 : alloc_w_e3_arr_spec = true;
6468 : }
6469 :
6470 : /* Figure out the size of the array. */
6471 12300 : switch (ref->u.ar.type)
6472 : {
6473 9387 : case AR_ELEMENT:
6474 9387 : if (!coarray)
6475 : {
6476 8773 : lower = NULL;
6477 8773 : upper = ref->u.ar.start;
6478 8773 : break;
6479 : }
6480 : /* Fall through. */
6481 :
6482 2321 : case AR_SECTION:
6483 2321 : lower = ref->u.ar.start;
6484 2321 : upper = ref->u.ar.end;
6485 2321 : break;
6486 :
6487 1206 : case AR_FULL:
6488 1206 : gcc_assert (ref->u.ar.as->type == AS_EXPLICIT
6489 : || alloc_w_e3_arr_spec);
6490 :
6491 1206 : lower = ref->u.ar.as->lower;
6492 1206 : upper = ref->u.ar.as->upper;
6493 1206 : break;
6494 :
6495 0 : default:
6496 0 : gcc_unreachable ();
6497 12300 : break;
6498 : }
6499 :
6500 12300 : overflow = integer_zero_node;
6501 :
6502 12300 : if (expr->ts.type == BT_CHARACTER
6503 1079 : && TREE_CODE (se->string_length) == COMPONENT_REF
6504 161 : && expr->ts.u.cl->backend_decl != se->string_length
6505 161 : && VAR_P (expr->ts.u.cl->backend_decl))
6506 0 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
6507 0 : fold_convert (TREE_TYPE (expr->ts.u.cl->backend_decl),
6508 : se->string_length));
6509 :
6510 12300 : gfc_init_block (&set_descriptor_block);
6511 : /* Take the corank only from the actual ref and not from the coref. The
6512 : later will mislead the generation of the array dimensions for allocatable/
6513 : pointer components in derived types. */
6514 24029 : size = gfc_array_init_size (se->expr, alloc_w_e3_arr_spec ? expr->rank
6515 11063 : : ref->u.ar.as->rank,
6516 666 : coarray ? ref->u.ar.as->corank : 0,
6517 : &offset, lower, upper,
6518 : &se->pre, &set_descriptor_block, &overflow,
6519 : expr3_elem_size, expr3, e3_arr_desc,
6520 : e3_has_nodescriptor, expr, &element_size,
6521 : explicit_ts);
6522 :
6523 12300 : if (dimension)
6524 : {
6525 12073 : var_overflow = gfc_create_var (integer_type_node, "overflow");
6526 12073 : gfc_add_modify (&se->pre, var_overflow, overflow);
6527 :
6528 12073 : if (status == NULL_TREE)
6529 : {
6530 : /* Generate the block of code handling overflow. */
6531 11851 : msg = gfc_build_addr_expr (pchar_type_node,
6532 : gfc_build_localized_cstring_const
6533 : ("Integer overflow when calculating the amount of "
6534 : "memory to allocate"));
6535 11851 : error = build_call_expr_loc (input_location,
6536 : gfor_fndecl_runtime_error, 1, msg);
6537 : }
6538 : else
6539 : {
6540 222 : tree status_type = TREE_TYPE (status);
6541 222 : stmtblock_t set_status_block;
6542 :
6543 222 : gfc_start_block (&set_status_block);
6544 222 : gfc_add_modify (&set_status_block, status,
6545 : build_int_cst (status_type, LIBERROR_ALLOCATION));
6546 222 : error = gfc_finish_block (&set_status_block);
6547 : }
6548 : }
6549 :
6550 : /* Allocate memory to store the data. */
6551 12300 : if (POINTER_TYPE_P (TREE_TYPE (se->expr)))
6552 0 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
6553 :
6554 12300 : if (coarray && flag_coarray == GFC_FCOARRAY_LIB)
6555 : {
6556 425 : pointer = non_ulimate_coarray_ptr_comp ? se->expr
6557 353 : : gfc_conv_descriptor_data_get (se->expr);
6558 425 : token = gfc_conv_descriptor_token (se->expr);
6559 425 : token = gfc_build_addr_expr (NULL_TREE, token);
6560 : }
6561 : else
6562 : {
6563 11875 : pointer = gfc_conv_descriptor_data_get (se->expr);
6564 11875 : if (omp_alloc)
6565 33 : omp_cond = boolean_true_node;
6566 : }
6567 12300 : STRIP_NOPS (pointer);
6568 :
6569 12300 : if (allocatable)
6570 : {
6571 10098 : not_prev_allocated = gfc_create_var (logical_type_node,
6572 : "not_prev_allocated");
6573 10098 : tmp = fold_build2_loc (input_location, EQ_EXPR,
6574 : logical_type_node, pointer,
6575 10098 : build_int_cst (TREE_TYPE (pointer), 0));
6576 :
6577 10098 : gfc_add_modify (&se->pre, not_prev_allocated, tmp);
6578 : }
6579 :
6580 12300 : gfc_start_block (&elseblock);
6581 :
6582 12300 : tree succ_add_expr = NULL_TREE;
6583 12300 : if (omp_cond)
6584 : {
6585 33 : tree align, alloc, sz;
6586 33 : gfc_se se2;
6587 33 : if (omp_alloc->u2.allocator)
6588 : {
6589 10 : gfc_init_se (&se2, NULL);
6590 10 : gfc_conv_expr (&se2, omp_alloc->u2.allocator);
6591 10 : gfc_add_block_to_block (&elseblock, &se2.pre);
6592 10 : alloc = gfc_evaluate_now (se2.expr, &elseblock);
6593 10 : gfc_add_block_to_block (&elseblock, &se2.post);
6594 : }
6595 : else
6596 23 : alloc = build_zero_cst (ptr_type_node);
6597 33 : tmp = TREE_TYPE (TREE_TYPE (pointer));
6598 33 : if (tmp == void_type_node)
6599 33 : tmp = gfc_typenode_for_spec (&expr->ts, 0);
6600 33 : if (omp_alloc->u.align)
6601 : {
6602 17 : gfc_init_se (&se2, NULL);
6603 17 : gfc_conv_expr (&se2, omp_alloc->u.align);
6604 17 : gcc_assert (CONSTANT_CLASS_P (se2.expr)
6605 : && se2.pre.head == NULL
6606 : && se2.post.head == NULL);
6607 17 : align = build_int_cst (size_type_node,
6608 17 : MAX (tree_to_uhwi (se2.expr),
6609 : TYPE_ALIGN_UNIT (tmp)));
6610 : }
6611 : else
6612 16 : align = build_int_cst (size_type_node, TYPE_ALIGN_UNIT (tmp));
6613 33 : sz = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
6614 : fold_convert (size_type_node, size),
6615 : build_int_cst (size_type_node, 1));
6616 33 : omp_alt_alloc = builtin_decl_explicit (BUILT_IN_GOMP_ALLOC);
6617 33 : DECL_ATTRIBUTES (omp_alt_alloc)
6618 33 : = tree_cons (get_identifier ("omp allocator"),
6619 : build_tree_list (NULL_TREE, alloc),
6620 33 : DECL_ATTRIBUTES (omp_alt_alloc));
6621 33 : omp_alt_alloc = build_call_expr (omp_alt_alloc, 3, align, sz, alloc);
6622 33 : stmtblock_t tmp_block;
6623 33 : gfc_init_block (&tmp_block);
6624 33 : gfc_conv_descriptor_version_set (&tmp_block, se->expr, integer_one_node);
6625 33 : succ_add_expr = gfc_finish_block (&tmp_block);
6626 : }
6627 :
6628 : /* The allocatable variant takes the old pointer as first argument. */
6629 12300 : if (allocatable)
6630 10689 : gfc_allocate_allocatable (&elseblock, pointer, size, token,
6631 : status, errmsg, errlen, label_finish, expr,
6632 591 : coref != NULL ? coref->u.ar.as->corank : 0,
6633 : omp_cond, omp_alt_alloc, succ_add_expr);
6634 2202 : else if (non_ulimate_coarray_ptr_comp && token)
6635 : /* The token is set only for GFC_FCOARRAY_LIB mode. */
6636 72 : gfc_allocate_using_caf_lib (&elseblock, pointer, size, token, status,
6637 : errmsg, errlen,
6638 : GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY);
6639 : else
6640 2130 : gfc_allocate_using_malloc (&elseblock, pointer, size, status,
6641 : omp_cond, omp_alt_alloc, succ_add_expr);
6642 :
6643 12300 : if (dimension)
6644 : {
6645 12073 : cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
6646 : logical_type_node, var_overflow, integer_zero_node),
6647 : PRED_FORTRAN_OVERFLOW);
6648 12073 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6649 : error, gfc_finish_block (&elseblock));
6650 : }
6651 : else
6652 227 : tmp = gfc_finish_block (&elseblock);
6653 :
6654 12300 : gfc_add_expr_to_block (&se->pre, tmp);
6655 :
6656 : /* Update the array descriptor with the offset and the span. */
6657 12300 : if (dimension)
6658 : {
6659 12073 : gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
6660 12073 : tmp = fold_convert (gfc_array_index_type, element_size);
6661 12073 : gfc_conv_descriptor_span_set (&set_descriptor_block, se->expr, tmp);
6662 : }
6663 :
6664 12300 : set_descriptor = gfc_finish_block (&set_descriptor_block);
6665 12300 : if (status != NULL_TREE)
6666 : {
6667 238 : cond = fold_build2_loc (input_location, EQ_EXPR,
6668 : logical_type_node, status,
6669 238 : build_int_cst (TREE_TYPE (status), 0));
6670 :
6671 238 : if (not_prev_allocated != NULL_TREE)
6672 222 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
6673 : logical_type_node, cond, not_prev_allocated);
6674 :
6675 238 : gfc_add_expr_to_block (&se->pre,
6676 : fold_build3_loc (input_location, COND_EXPR, void_type_node,
6677 : cond,
6678 : set_descriptor,
6679 : build_empty_stmt (input_location)));
6680 : }
6681 : else
6682 12062 : gfc_add_expr_to_block (&se->pre, set_descriptor);
6683 :
6684 : return true;
6685 : }
6686 :
6687 :
6688 : /* Create an array constructor from an initialization expression.
6689 : We assume the frontend already did any expansions and conversions. */
6690 :
6691 : tree
6692 7778 : gfc_conv_array_initializer (tree type, gfc_expr * expr)
6693 : {
6694 7778 : gfc_constructor *c;
6695 7778 : tree tmp;
6696 7778 : gfc_se se;
6697 7778 : tree index, range;
6698 7778 : vec<constructor_elt, va_gc> *v = NULL;
6699 :
6700 7778 : if (expr->expr_type == EXPR_VARIABLE
6701 1 : && expr->symtree->n.sym->attr.flavor == FL_PARAMETER
6702 1 : && expr->symtree->n.sym->value
6703 1 : && !expr->ref)
6704 7778 : expr = expr->symtree->n.sym->value;
6705 :
6706 : /* After parameter substitution the expression should be a constant, array
6707 : constructor, structure constructor, or NULL. Anything else is invalid
6708 : and must not ICE later in lowering. */
6709 7778 : if (expr->expr_type != EXPR_CONSTANT
6710 7384 : && expr->expr_type != EXPR_STRUCTURE
6711 6618 : && expr->expr_type != EXPR_ARRAY
6712 4 : && expr->expr_type != EXPR_NULL)
6713 : {
6714 4 : gfc_error ("Array initializer at %L does not reduce to a constant "
6715 : "expression", &expr->where);
6716 4 : return build_constructor (type, NULL);
6717 : }
6718 :
6719 7774 : switch (expr->expr_type)
6720 : {
6721 1160 : case EXPR_CONSTANT:
6722 1160 : case EXPR_STRUCTURE:
6723 : /* A single scalar or derived type value. Create an array with all
6724 : elements equal to that value. */
6725 1160 : gfc_init_se (&se, NULL);
6726 :
6727 1160 : if (expr->expr_type == EXPR_CONSTANT)
6728 394 : gfc_conv_constant (&se, expr);
6729 : else
6730 766 : gfc_conv_structure (&se, expr, 1);
6731 :
6732 2320 : if (tree_int_cst_lt (TYPE_MAX_VALUE (TYPE_DOMAIN (type)),
6733 1160 : TYPE_MIN_VALUE (TYPE_DOMAIN (type))))
6734 : break;
6735 2296 : else if (tree_int_cst_equal (TYPE_MIN_VALUE (TYPE_DOMAIN (type)),
6736 1148 : TYPE_MAX_VALUE (TYPE_DOMAIN (type))))
6737 167 : range = TYPE_MIN_VALUE (TYPE_DOMAIN (type));
6738 : else
6739 1962 : range = build2 (RANGE_EXPR, gfc_array_index_type,
6740 981 : TYPE_MIN_VALUE (TYPE_DOMAIN (type)),
6741 981 : TYPE_MAX_VALUE (TYPE_DOMAIN (type)));
6742 1148 : CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
6743 1148 : break;
6744 :
6745 6614 : case EXPR_ARRAY:
6746 : /* Create a vector of all the elements. */
6747 6614 : for (c = gfc_constructor_first (expr->value.constructor);
6748 164761 : c && c->expr; c = gfc_constructor_next (c))
6749 : {
6750 158147 : if (c->iterator)
6751 : {
6752 : /* Problems occur when we get something like
6753 : integer :: a(lots) = (/(i, i=1, lots)/) */
6754 0 : gfc_fatal_error ("The number of elements in the array "
6755 : "constructor at %L requires an increase of "
6756 : "the allowed %d upper limit. See "
6757 : "%<-fmax-array-constructor%> option",
6758 : &expr->where, flag_max_array_constructor);
6759 : return NULL_TREE;
6760 : }
6761 158147 : index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
6762 :
6763 158147 : if (mpz_cmp_si (c->repeat, 1) > 0)
6764 : {
6765 127 : tree tmp1, tmp2;
6766 127 : mpz_t maxval;
6767 :
6768 127 : mpz_init (maxval);
6769 127 : mpz_add (maxval, c->offset, c->repeat);
6770 127 : mpz_sub_ui (maxval, maxval, 1);
6771 127 : tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
6772 127 : if (mpz_cmp_si (c->offset, 0) != 0)
6773 : {
6774 27 : mpz_add_ui (maxval, c->offset, 1);
6775 27 : tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
6776 : }
6777 : else
6778 100 : tmp1 = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
6779 :
6780 127 : range = fold_build2 (RANGE_EXPR, gfc_array_index_type, tmp1, tmp2);
6781 127 : mpz_clear (maxval);
6782 : }
6783 : else
6784 : range = NULL;
6785 :
6786 158147 : gfc_init_se (&se, NULL);
6787 158147 : switch (c->expr->expr_type)
6788 : {
6789 156664 : case EXPR_CONSTANT:
6790 156664 : gfc_conv_constant (&se, c->expr);
6791 :
6792 : /* See gfortran.dg/charlen_15.f90 for instance. */
6793 156664 : if (TREE_CODE (se.expr) == STRING_CST
6794 5260 : && TREE_CODE (type) == ARRAY_TYPE)
6795 : {
6796 : tree atype = type;
6797 10520 : while (TREE_CODE (TREE_TYPE (atype)) == ARRAY_TYPE)
6798 5260 : atype = TREE_TYPE (atype);
6799 5260 : gcc_checking_assert (TREE_CODE (TREE_TYPE (atype))
6800 : == INTEGER_TYPE);
6801 5260 : gcc_checking_assert (TREE_TYPE (TREE_TYPE (se.expr))
6802 : == TREE_TYPE (atype));
6803 5260 : if (tree_to_uhwi (TYPE_SIZE_UNIT (TREE_TYPE (se.expr)))
6804 5260 : > tree_to_uhwi (TYPE_SIZE_UNIT (atype)))
6805 : {
6806 0 : unsigned HOST_WIDE_INT size
6807 0 : = tree_to_uhwi (TYPE_SIZE_UNIT (atype));
6808 0 : const char *p = TREE_STRING_POINTER (se.expr);
6809 :
6810 0 : se.expr = build_string (size, p);
6811 : }
6812 5260 : TREE_TYPE (se.expr) = atype;
6813 : }
6814 : break;
6815 :
6816 1483 : case EXPR_STRUCTURE:
6817 1483 : gfc_conv_structure (&se, c->expr, 1);
6818 1483 : break;
6819 :
6820 0 : default:
6821 : /* Catch those occasional beasts that do not simplify
6822 : for one reason or another, assuming that if they are
6823 : standard defying the frontend will catch them. */
6824 0 : gfc_conv_expr (&se, c->expr);
6825 0 : break;
6826 : }
6827 :
6828 158147 : if (range == NULL_TREE)
6829 158020 : CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
6830 : else
6831 : {
6832 127 : if (!integer_zerop (index))
6833 27 : CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
6834 158274 : CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
6835 : }
6836 : }
6837 : break;
6838 :
6839 0 : case EXPR_NULL:
6840 0 : return gfc_build_null_descriptor (type);
6841 :
6842 : default:
6843 : gcc_unreachable ();
6844 : }
6845 :
6846 : /* Create a constructor from the list of elements. */
6847 7774 : tmp = build_constructor (type, v);
6848 7774 : TREE_CONSTANT (tmp) = 1;
6849 7774 : return tmp;
6850 : }
6851 :
6852 :
6853 : /* Generate code to evaluate non-constant coarray cobounds. */
6854 :
6855 : void
6856 21405 : gfc_trans_array_cobounds (tree type, stmtblock_t * pblock,
6857 : const gfc_symbol *sym)
6858 : {
6859 21405 : int dim;
6860 21405 : tree ubound;
6861 21405 : tree lbound;
6862 21405 : gfc_se se;
6863 21405 : gfc_array_spec *as;
6864 :
6865 21405 : as = IS_CLASS_COARRAY_OR_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
6866 :
6867 22382 : for (dim = as->rank; dim < as->rank + as->corank; dim++)
6868 : {
6869 : /* Evaluate non-constant array bound expressions.
6870 : F2008 4.5.6.3 para 6: If a specification expression in a scoping unit
6871 : references a function, the result is finalized before execution of the
6872 : executable constructs in the scoping unit.
6873 : Adding the finalblocks enables this. */
6874 977 : lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
6875 977 : if (as->lower[dim] && !INTEGER_CST_P (lbound))
6876 : {
6877 114 : gfc_init_se (&se, NULL);
6878 114 : gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
6879 114 : gfc_add_block_to_block (pblock, &se.pre);
6880 114 : gfc_add_block_to_block (pblock, &se.finalblock);
6881 114 : gfc_add_modify (pblock, lbound, se.expr);
6882 : }
6883 977 : ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
6884 977 : if (as->upper[dim] && !INTEGER_CST_P (ubound))
6885 : {
6886 60 : gfc_init_se (&se, NULL);
6887 60 : gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
6888 60 : gfc_add_block_to_block (pblock, &se.pre);
6889 60 : gfc_add_block_to_block (pblock, &se.finalblock);
6890 60 : gfc_add_modify (pblock, ubound, se.expr);
6891 : }
6892 : }
6893 21405 : }
6894 :
6895 :
6896 : /* Generate code to evaluate non-constant array bounds. Sets *poffset and
6897 : returns the size (in elements) of the array. */
6898 :
6899 : tree
6900 13887 : gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
6901 : stmtblock_t * pblock)
6902 : {
6903 13887 : gfc_array_spec *as;
6904 13887 : tree size;
6905 13887 : tree stride;
6906 13887 : tree offset;
6907 13887 : tree ubound;
6908 13887 : tree lbound;
6909 13887 : tree tmp;
6910 13887 : gfc_se se;
6911 :
6912 13887 : int dim;
6913 :
6914 13887 : as = IS_CLASS_COARRAY_OR_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
6915 :
6916 13887 : size = gfc_index_one_node;
6917 13887 : offset = gfc_index_zero_node;
6918 13887 : stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
6919 13887 : if (stride && VAR_P (stride))
6920 124 : gfc_add_modify (pblock, stride, gfc_index_one_node);
6921 31035 : for (dim = 0; dim < as->rank; dim++)
6922 : {
6923 : /* Evaluate non-constant array bound expressions.
6924 : F2008 4.5.6.3 para 6: If a specification expression in a scoping unit
6925 : references a function, the result is finalized before execution of the
6926 : executable constructs in the scoping unit.
6927 : Adding the finalblocks enables this. */
6928 17148 : lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
6929 17148 : if (as->lower[dim] && !INTEGER_CST_P (lbound))
6930 : {
6931 475 : gfc_init_se (&se, NULL);
6932 475 : gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
6933 475 : gfc_add_block_to_block (pblock, &se.pre);
6934 475 : gfc_add_block_to_block (pblock, &se.finalblock);
6935 475 : gfc_add_modify (pblock, lbound, se.expr);
6936 : }
6937 17148 : ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
6938 17148 : if (as->upper[dim] && !INTEGER_CST_P (ubound))
6939 : {
6940 10587 : gfc_init_se (&se, NULL);
6941 10587 : gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
6942 10587 : gfc_add_block_to_block (pblock, &se.pre);
6943 10587 : gfc_add_block_to_block (pblock, &se.finalblock);
6944 10587 : gfc_add_modify (pblock, ubound, se.expr);
6945 : }
6946 : /* The offset of this dimension. offset = offset - lbound * stride. */
6947 17148 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6948 : lbound, size);
6949 17148 : offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6950 : offset, tmp);
6951 :
6952 : /* The size of this dimension, and the stride of the next. */
6953 17148 : if (dim + 1 < as->rank)
6954 3460 : stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
6955 : else
6956 13688 : stride = GFC_TYPE_ARRAY_SIZE (type);
6957 :
6958 17148 : if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
6959 : {
6960 : /* Calculate stride = size * (ubound + 1 - lbound). */
6961 10777 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
6962 : gfc_array_index_type,
6963 : gfc_index_one_node, lbound);
6964 10777 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
6965 : gfc_array_index_type, ubound, tmp);
6966 10777 : tmp = fold_build2_loc (input_location, MULT_EXPR,
6967 : gfc_array_index_type, size, tmp);
6968 10777 : if (stride)
6969 10777 : gfc_add_modify (pblock, stride, tmp);
6970 : else
6971 0 : stride = gfc_evaluate_now (tmp, pblock);
6972 :
6973 : /* Make sure that negative size arrays are translated
6974 : to being zero size. */
6975 10777 : tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
6976 : stride, gfc_index_zero_node);
6977 10777 : tmp = fold_build3_loc (input_location, COND_EXPR,
6978 : gfc_array_index_type, tmp,
6979 : stride, gfc_index_zero_node);
6980 10777 : gfc_add_modify (pblock, stride, tmp);
6981 : }
6982 :
6983 17148 : size = stride;
6984 : }
6985 :
6986 13887 : gfc_trans_array_cobounds (type, pblock, sym);
6987 13887 : gfc_trans_vla_type_sizes (sym, pblock);
6988 :
6989 13887 : *poffset = offset;
6990 13887 : return size;
6991 : }
6992 :
6993 :
6994 : /* Generate code to initialize/allocate an array variable. */
6995 :
6996 : void
6997 32042 : gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
6998 : gfc_wrapped_block * block)
6999 : {
7000 32042 : stmtblock_t init;
7001 32042 : tree type;
7002 32042 : tree tmp = NULL_TREE;
7003 32042 : tree size;
7004 32042 : tree offset;
7005 32042 : tree space;
7006 32042 : tree inittree;
7007 32042 : bool onstack;
7008 32042 : bool back;
7009 :
7010 32042 : gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
7011 :
7012 : /* Do nothing for USEd variables. */
7013 32042 : if (sym->attr.use_assoc)
7014 25955 : return;
7015 :
7016 31999 : type = TREE_TYPE (decl);
7017 31999 : gcc_assert (GFC_ARRAY_TYPE_P (type));
7018 31999 : onstack = TREE_CODE (type) != POINTER_TYPE;
7019 :
7020 : /* In the case of non-dummy symbols with dependencies on an old-fashioned
7021 : function result (ie. proc_name = proc_name->result), gfc_add_init_cleanup
7022 : must be called with the last, optional argument false so that the alloc-
7023 : ation occurs after the processing of the result. */
7024 31999 : back = sym->fn_result_dep;
7025 :
7026 31999 : gfc_init_block (&init);
7027 :
7028 : /* Evaluate character string length. */
7029 31999 : if (sym->ts.type == BT_CHARACTER
7030 3074 : && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
7031 : {
7032 43 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7033 :
7034 43 : gfc_trans_vla_type_sizes (sym, &init);
7035 :
7036 : /* Emit a DECL_EXPR for this variable, which will cause the
7037 : gimplifier to allocate storage, and all that good stuff. */
7038 43 : tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
7039 43 : gfc_add_expr_to_block (&init, tmp);
7040 43 : if (sym->attr.omp_allocate)
7041 : {
7042 : /* Save location of size calculation to ensure GOMP_alloc is placed
7043 : after it. */
7044 0 : tree omp_alloc = lookup_attribute ("omp allocate",
7045 0 : DECL_ATTRIBUTES (decl));
7046 0 : TREE_CHAIN (TREE_CHAIN (TREE_VALUE (omp_alloc)))
7047 0 : = build_tree_list (NULL_TREE, tsi_stmt (tsi_last (init.head)));
7048 : }
7049 : }
7050 :
7051 31797 : if (onstack)
7052 : {
7053 25772 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE,
7054 : back);
7055 25772 : return;
7056 : }
7057 :
7058 6227 : type = TREE_TYPE (type);
7059 :
7060 6227 : gcc_assert (!sym->attr.use_assoc);
7061 6227 : gcc_assert (!sym->module);
7062 :
7063 6227 : if (sym->ts.type == BT_CHARACTER
7064 202 : && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
7065 94 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7066 :
7067 6227 : size = gfc_trans_array_bounds (type, sym, &offset, &init);
7068 :
7069 : /* Don't actually allocate space for Cray Pointees. */
7070 6227 : if (sym->attr.cray_pointee)
7071 : {
7072 140 : if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
7073 49 : gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
7074 :
7075 140 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
7076 140 : return;
7077 : }
7078 6087 : if (sym->attr.omp_allocate)
7079 : {
7080 : /* The size is the number of elements in the array, so multiply by the
7081 : size of an element to get the total size. */
7082 7 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
7083 7 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7084 : size, fold_convert (gfc_array_index_type, tmp));
7085 7 : size = gfc_evaluate_now (size, &init);
7086 :
7087 7 : tree omp_alloc = lookup_attribute ("omp allocate",
7088 7 : DECL_ATTRIBUTES (decl));
7089 7 : TREE_CHAIN (TREE_CHAIN (TREE_VALUE (omp_alloc)))
7090 7 : = build_tree_list (size, NULL_TREE);
7091 7 : space = NULL_TREE;
7092 : }
7093 6080 : else if (flag_stack_arrays)
7094 : {
7095 17 : gcc_assert (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE);
7096 17 : space = build_decl (gfc_get_location (&sym->declared_at),
7097 : VAR_DECL, create_tmp_var_name ("A"),
7098 17 : TREE_TYPE (TREE_TYPE (decl)));
7099 17 : gfc_trans_vla_type_sizes (sym, &init);
7100 : }
7101 : else
7102 : {
7103 : /* The size is the number of elements in the array, so multiply by the
7104 : size of an element to get the total size. */
7105 6063 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
7106 6063 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7107 : size, fold_convert (gfc_array_index_type, tmp));
7108 :
7109 : /* Allocate memory to hold the data. */
7110 6063 : tmp = gfc_call_malloc (&init, TREE_TYPE (decl), size);
7111 6063 : gfc_add_modify (&init, decl, tmp);
7112 :
7113 : /* Free the temporary. */
7114 6063 : tmp = gfc_call_free (decl);
7115 6063 : space = NULL_TREE;
7116 : }
7117 :
7118 : /* Set offset of the array. */
7119 6087 : if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
7120 387 : gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
7121 :
7122 : /* Automatic arrays should not have initializers. */
7123 6087 : gcc_assert (!sym->value);
7124 :
7125 6087 : inittree = gfc_finish_block (&init);
7126 :
7127 6087 : if (space)
7128 : {
7129 17 : tree addr;
7130 17 : pushdecl (space);
7131 :
7132 : /* Don't create new scope, emit the DECL_EXPR in exactly the scope
7133 : where also space is located. */
7134 17 : gfc_init_block (&init);
7135 17 : tmp = fold_build1_loc (input_location, DECL_EXPR,
7136 17 : TREE_TYPE (space), space);
7137 17 : gfc_add_expr_to_block (&init, tmp);
7138 17 : addr = fold_build1_loc (gfc_get_location (&sym->declared_at),
7139 17 : ADDR_EXPR, TREE_TYPE (decl), space);
7140 17 : gfc_add_modify (&init, decl, addr);
7141 17 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE,
7142 : back);
7143 17 : tmp = NULL_TREE;
7144 : }
7145 6087 : gfc_add_init_cleanup (block, inittree, tmp, back);
7146 : }
7147 :
7148 :
7149 : /* Generate entry and exit code for g77 calling convention arrays. */
7150 :
7151 : void
7152 7406 : gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block)
7153 : {
7154 7406 : tree parm;
7155 7406 : tree type;
7156 7406 : tree offset;
7157 7406 : tree tmp;
7158 7406 : tree stmt;
7159 7406 : stmtblock_t init;
7160 :
7161 7406 : location_t loc = input_location;
7162 7406 : input_location = gfc_get_location (&sym->declared_at);
7163 :
7164 : /* Descriptor type. */
7165 7406 : parm = sym->backend_decl;
7166 7406 : type = TREE_TYPE (parm);
7167 7406 : gcc_assert (GFC_ARRAY_TYPE_P (type));
7168 :
7169 7406 : gfc_start_block (&init);
7170 :
7171 7406 : if (sym->ts.type == BT_CHARACTER
7172 722 : && VAR_P (sym->ts.u.cl->backend_decl))
7173 79 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7174 :
7175 : /* Evaluate the bounds of the array. */
7176 7406 : gfc_trans_array_bounds (type, sym, &offset, &init);
7177 :
7178 : /* Set the offset. */
7179 7406 : if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
7180 1214 : gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
7181 :
7182 : /* Set the pointer itself if we aren't using the parameter directly. */
7183 7406 : if (TREE_CODE (parm) != PARM_DECL)
7184 : {
7185 612 : tmp = GFC_DECL_SAVED_DESCRIPTOR (parm);
7186 612 : if (sym->ts.type == BT_CLASS)
7187 : {
7188 243 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
7189 243 : tmp = gfc_class_data_get (tmp);
7190 243 : tmp = gfc_conv_descriptor_data_get (tmp);
7191 : }
7192 612 : tmp = convert (TREE_TYPE (parm), tmp);
7193 612 : gfc_add_modify (&init, parm, tmp);
7194 : }
7195 7406 : stmt = gfc_finish_block (&init);
7196 :
7197 7406 : input_location = loc;
7198 :
7199 : /* Add the initialization code to the start of the function. */
7200 :
7201 7406 : if ((sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.optional)
7202 7406 : || sym->attr.optional
7203 6924 : || sym->attr.not_always_present)
7204 : {
7205 542 : tree nullify;
7206 542 : if (TREE_CODE (parm) != PARM_DECL)
7207 105 : nullify = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
7208 : parm, null_pointer_node);
7209 : else
7210 437 : nullify = build_empty_stmt (input_location);
7211 542 : tmp = gfc_conv_expr_present (sym, true);
7212 542 : stmt = build3_v (COND_EXPR, tmp, stmt, nullify);
7213 : }
7214 :
7215 7406 : gfc_add_init_cleanup (block, stmt, NULL_TREE);
7216 7406 : }
7217 :
7218 :
7219 : /* Modify the descriptor of an array parameter so that it has the
7220 : correct lower bound. Also move the upper bound accordingly.
7221 : If the array is not packed, it will be copied into a temporary.
7222 : For each dimension we set the new lower and upper bounds. Then we copy the
7223 : stride and calculate the offset for this dimension. We also work out
7224 : what the stride of a packed array would be, and see it the two match.
7225 : If the array need repacking, we set the stride to the values we just
7226 : calculated, recalculate the offset and copy the array data.
7227 : Code is also added to copy the data back at the end of the function.
7228 : */
7229 :
7230 : void
7231 13185 : gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
7232 : gfc_wrapped_block * block)
7233 : {
7234 13185 : tree size;
7235 13185 : tree type;
7236 13185 : tree offset;
7237 13185 : stmtblock_t init;
7238 13185 : tree stmtInit, stmtCleanup;
7239 13185 : tree lbound;
7240 13185 : tree ubound;
7241 13185 : tree dubound;
7242 13185 : tree dlbound;
7243 13185 : tree dumdesc;
7244 13185 : tree tmp;
7245 13185 : tree stride, stride2;
7246 13185 : tree stmt_packed;
7247 13185 : tree stmt_unpacked;
7248 13185 : tree partial;
7249 13185 : gfc_se se;
7250 13185 : int n;
7251 13185 : int checkparm;
7252 13185 : int no_repack;
7253 13185 : bool optional_arg;
7254 13185 : gfc_array_spec *as;
7255 13185 : bool is_classarray = IS_CLASS_COARRAY_OR_ARRAY (sym);
7256 :
7257 : /* Do nothing for pointer and allocatable arrays. */
7258 13185 : if ((sym->ts.type != BT_CLASS && sym->attr.pointer)
7259 13088 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer)
7260 13088 : || sym->attr.allocatable
7261 12982 : || (is_classarray && CLASS_DATA (sym)->attr.allocatable))
7262 6070 : return;
7263 :
7264 880 : if ((!is_classarray
7265 880 : || (is_classarray && CLASS_DATA (sym)->as->type == AS_EXPLICIT))
7266 12286 : && sym->attr.dummy && !sym->attr.elemental && gfc_is_nodesc_array (sym))
7267 : {
7268 5867 : gfc_trans_g77_array (sym, block);
7269 5867 : return;
7270 : }
7271 :
7272 7115 : location_t loc = input_location;
7273 7115 : input_location = gfc_get_location (&sym->declared_at);
7274 :
7275 : /* Descriptor type. */
7276 7115 : type = TREE_TYPE (tmpdesc);
7277 7115 : gcc_assert (GFC_ARRAY_TYPE_P (type));
7278 7115 : dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
7279 7115 : if (is_classarray)
7280 : /* For a class array the dummy array descriptor is in the _class
7281 : component. */
7282 715 : dumdesc = gfc_class_data_get (dumdesc);
7283 : else
7284 6400 : dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc);
7285 7115 : as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
7286 7115 : gfc_start_block (&init);
7287 :
7288 7115 : if (sym->ts.type == BT_CHARACTER
7289 792 : && VAR_P (sym->ts.u.cl->backend_decl))
7290 87 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7291 :
7292 : /* TODO: Fix the exclusion of class arrays from extent checking. */
7293 1084 : checkparm = (as->type == AS_EXPLICIT && !is_classarray
7294 8180 : && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
7295 :
7296 7115 : no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
7297 7114 : || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
7298 :
7299 7115 : if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
7300 : {
7301 : /* For non-constant shape arrays we only check if the first dimension
7302 : is contiguous. Repacking higher dimensions wouldn't gain us
7303 : anything as we still don't know the array stride. */
7304 1 : partial = gfc_create_var (logical_type_node, "partial");
7305 1 : TREE_USED (partial) = 1;
7306 1 : tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
7307 1 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, tmp,
7308 : gfc_index_one_node);
7309 1 : gfc_add_modify (&init, partial, tmp);
7310 : }
7311 : else
7312 : partial = NULL_TREE;
7313 :
7314 : /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
7315 : here, however I think it does the right thing. */
7316 7115 : if (no_repack)
7317 : {
7318 : /* Set the first stride. */
7319 7113 : stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
7320 7113 : stride = gfc_evaluate_now (stride, &init);
7321 :
7322 7113 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7323 : stride, gfc_index_zero_node);
7324 7113 : tmp = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
7325 : tmp, gfc_index_one_node, stride);
7326 7113 : stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
7327 7113 : gfc_add_modify (&init, stride, tmp);
7328 :
7329 : /* Allow the user to disable array repacking. */
7330 7113 : stmt_unpacked = NULL_TREE;
7331 : }
7332 : else
7333 : {
7334 2 : gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
7335 : /* A library call to repack the array if necessary. */
7336 2 : tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
7337 2 : stmt_unpacked = build_call_expr_loc (input_location,
7338 : gfor_fndecl_in_pack, 1, tmp);
7339 :
7340 2 : stride = gfc_index_one_node;
7341 :
7342 2 : if (warn_array_temporaries)
7343 : {
7344 1 : locus where;
7345 1 : gfc_locus_from_location (&where, loc);
7346 1 : gfc_warning (OPT_Warray_temporaries,
7347 : "Creating array temporary at %L", &where);
7348 : }
7349 : }
7350 :
7351 : /* This is for the case where the array data is used directly without
7352 : calling the repack function. */
7353 7115 : if (no_repack || partial != NULL_TREE)
7354 7114 : stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
7355 : else
7356 : stmt_packed = NULL_TREE;
7357 :
7358 : /* Assign the data pointer. */
7359 7115 : if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
7360 : {
7361 : /* Don't repack unknown shape arrays when the first stride is 1. */
7362 1 : tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (stmt_packed),
7363 : partial, stmt_packed, stmt_unpacked);
7364 : }
7365 : else
7366 7114 : tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
7367 7115 : gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp));
7368 :
7369 7115 : offset = gfc_index_zero_node;
7370 7115 : size = gfc_index_one_node;
7371 :
7372 : /* Evaluate the bounds of the array. */
7373 16624 : for (n = 0; n < as->rank; n++)
7374 : {
7375 9509 : if (checkparm || !as->upper[n])
7376 : {
7377 : /* Get the bounds of the actual parameter. */
7378 8190 : dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]);
7379 8190 : dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]);
7380 : }
7381 : else
7382 : {
7383 : dubound = NULL_TREE;
7384 : dlbound = NULL_TREE;
7385 : }
7386 :
7387 9509 : lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
7388 9509 : if (!INTEGER_CST_P (lbound))
7389 : {
7390 46 : gfc_init_se (&se, NULL);
7391 46 : gfc_conv_expr_type (&se, as->lower[n],
7392 : gfc_array_index_type);
7393 46 : gfc_add_block_to_block (&init, &se.pre);
7394 46 : gfc_add_modify (&init, lbound, se.expr);
7395 : }
7396 :
7397 9509 : ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
7398 : /* Set the desired upper bound. */
7399 9509 : if (as->upper[n])
7400 : {
7401 : /* We know what we want the upper bound to be. */
7402 1377 : if (!INTEGER_CST_P (ubound))
7403 : {
7404 639 : gfc_init_se (&se, NULL);
7405 639 : gfc_conv_expr_type (&se, as->upper[n],
7406 : gfc_array_index_type);
7407 639 : gfc_add_block_to_block (&init, &se.pre);
7408 639 : gfc_add_modify (&init, ubound, se.expr);
7409 : }
7410 :
7411 : /* Check the sizes match. */
7412 1377 : if (checkparm)
7413 : {
7414 : /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
7415 58 : char * msg;
7416 58 : tree temp;
7417 58 : locus where;
7418 :
7419 58 : gfc_locus_from_location (&where, loc);
7420 58 : temp = fold_build2_loc (input_location, MINUS_EXPR,
7421 : gfc_array_index_type, ubound, lbound);
7422 58 : temp = fold_build2_loc (input_location, PLUS_EXPR,
7423 : gfc_array_index_type,
7424 : gfc_index_one_node, temp);
7425 58 : stride2 = fold_build2_loc (input_location, MINUS_EXPR,
7426 : gfc_array_index_type, dubound,
7427 : dlbound);
7428 58 : stride2 = fold_build2_loc (input_location, PLUS_EXPR,
7429 : gfc_array_index_type,
7430 : gfc_index_one_node, stride2);
7431 58 : tmp = fold_build2_loc (input_location, NE_EXPR,
7432 : gfc_array_index_type, temp, stride2);
7433 58 : msg = xasprintf ("Dimension %d of array '%s' has extent "
7434 : "%%ld instead of %%ld", n+1, sym->name);
7435 :
7436 58 : gfc_trans_runtime_check (true, false, tmp, &init, &where, msg,
7437 : fold_convert (long_integer_type_node, temp),
7438 : fold_convert (long_integer_type_node, stride2));
7439 :
7440 58 : free (msg);
7441 : }
7442 : }
7443 : else
7444 : {
7445 : /* For assumed shape arrays move the upper bound by the same amount
7446 : as the lower bound. */
7447 8132 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
7448 : gfc_array_index_type, dubound, dlbound);
7449 8132 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
7450 : gfc_array_index_type, tmp, lbound);
7451 8132 : gfc_add_modify (&init, ubound, tmp);
7452 : }
7453 : /* The offset of this dimension. offset = offset - lbound * stride. */
7454 9509 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7455 : lbound, stride);
7456 9509 : offset = fold_build2_loc (input_location, MINUS_EXPR,
7457 : gfc_array_index_type, offset, tmp);
7458 :
7459 : /* The size of this dimension, and the stride of the next. */
7460 9509 : if (n + 1 < as->rank)
7461 : {
7462 2394 : stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
7463 :
7464 2394 : if (no_repack || partial != NULL_TREE)
7465 2393 : stmt_unpacked =
7466 2393 : gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]);
7467 :
7468 : /* Figure out the stride if not a known constant. */
7469 2394 : if (!INTEGER_CST_P (stride))
7470 : {
7471 2393 : if (no_repack)
7472 : stmt_packed = NULL_TREE;
7473 : else
7474 : {
7475 : /* Calculate stride = size * (ubound + 1 - lbound). */
7476 0 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
7477 : gfc_array_index_type,
7478 : gfc_index_one_node, lbound);
7479 0 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
7480 : gfc_array_index_type, ubound, tmp);
7481 0 : size = fold_build2_loc (input_location, MULT_EXPR,
7482 : gfc_array_index_type, size, tmp);
7483 0 : stmt_packed = size;
7484 : }
7485 :
7486 : /* Assign the stride. */
7487 2393 : if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
7488 0 : tmp = fold_build3_loc (input_location, COND_EXPR,
7489 : gfc_array_index_type, partial,
7490 : stmt_unpacked, stmt_packed);
7491 : else
7492 2393 : tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
7493 2393 : gfc_add_modify (&init, stride, tmp);
7494 : }
7495 : }
7496 : else
7497 : {
7498 7115 : stride = GFC_TYPE_ARRAY_SIZE (type);
7499 :
7500 7115 : if (stride && !INTEGER_CST_P (stride))
7501 : {
7502 : /* Calculate size = stride * (ubound + 1 - lbound). */
7503 7114 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
7504 : gfc_array_index_type,
7505 : gfc_index_one_node, lbound);
7506 7114 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
7507 : gfc_array_index_type,
7508 : ubound, tmp);
7509 21342 : tmp = fold_build2_loc (input_location, MULT_EXPR,
7510 : gfc_array_index_type,
7511 7114 : GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
7512 7114 : gfc_add_modify (&init, stride, tmp);
7513 : }
7514 : }
7515 : }
7516 :
7517 7115 : gfc_trans_array_cobounds (type, &init, sym);
7518 :
7519 : /* Set the offset. */
7520 7115 : if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
7521 7113 : gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
7522 :
7523 7115 : gfc_trans_vla_type_sizes (sym, &init);
7524 :
7525 7115 : stmtInit = gfc_finish_block (&init);
7526 :
7527 : /* Only do the entry/initialization code if the arg is present. */
7528 7115 : dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
7529 7115 : optional_arg = (sym->attr.optional
7530 7115 : || (sym->ns->proc_name->attr.entry_master
7531 79 : && sym->attr.dummy));
7532 : if (optional_arg)
7533 : {
7534 723 : tree zero_init = fold_convert (TREE_TYPE (tmpdesc), null_pointer_node);
7535 723 : zero_init = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
7536 : tmpdesc, zero_init);
7537 723 : tmp = gfc_conv_expr_present (sym, true);
7538 723 : stmtInit = build3_v (COND_EXPR, tmp, stmtInit, zero_init);
7539 : }
7540 :
7541 : /* Cleanup code. */
7542 7115 : if (no_repack)
7543 : stmtCleanup = NULL_TREE;
7544 : else
7545 : {
7546 2 : stmtblock_t cleanup;
7547 2 : gfc_start_block (&cleanup);
7548 :
7549 2 : if (sym->attr.intent != INTENT_IN)
7550 : {
7551 : /* Copy the data back. */
7552 2 : tmp = build_call_expr_loc (input_location,
7553 : gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
7554 2 : gfc_add_expr_to_block (&cleanup, tmp);
7555 : }
7556 :
7557 : /* Free the temporary. */
7558 2 : tmp = gfc_call_free (tmpdesc);
7559 2 : gfc_add_expr_to_block (&cleanup, tmp);
7560 :
7561 2 : stmtCleanup = gfc_finish_block (&cleanup);
7562 :
7563 : /* Only do the cleanup if the array was repacked. */
7564 2 : if (is_classarray)
7565 : /* For a class array the dummy array descriptor is in the _class
7566 : component. */
7567 1 : tmp = gfc_class_data_get (dumdesc);
7568 : else
7569 1 : tmp = build_fold_indirect_ref_loc (input_location, dumdesc);
7570 2 : tmp = gfc_conv_descriptor_data_get (tmp);
7571 2 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
7572 : tmp, tmpdesc);
7573 2 : stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
7574 : build_empty_stmt (input_location));
7575 :
7576 2 : if (optional_arg)
7577 : {
7578 0 : tmp = gfc_conv_expr_present (sym);
7579 0 : stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
7580 : build_empty_stmt (input_location));
7581 : }
7582 : }
7583 :
7584 : /* We don't need to free any memory allocated by internal_pack as it will
7585 : be freed at the end of the function by pop_context. */
7586 7115 : gfc_add_init_cleanup (block, stmtInit, stmtCleanup);
7587 :
7588 7115 : input_location = loc;
7589 : }
7590 :
7591 :
7592 : /* Calculate the overall offset, including subreferences. */
7593 : void
7594 60712 : gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
7595 : bool subref, gfc_expr *expr)
7596 : {
7597 60712 : tree tmp;
7598 60712 : tree field;
7599 60712 : tree stride;
7600 60712 : tree index;
7601 60712 : gfc_ref *ref;
7602 60712 : gfc_se start;
7603 60712 : int n;
7604 :
7605 : /* If offset is NULL and this is not a subreferenced array, there is
7606 : nothing to do. */
7607 60712 : if (offset == NULL_TREE)
7608 : {
7609 1060 : if (subref)
7610 135 : offset = gfc_index_zero_node;
7611 : else
7612 925 : return;
7613 : }
7614 :
7615 : /* An array whose elements are spaced by the span needs pointer arithmetic
7616 : to reference an element. */
7617 59787 : tmp = build_array_ref (desc, offset, span_addressed_array (desc), NULL);
7618 :
7619 : /* A spanned character element is referenced by a pointer. */
7620 59787 : if (POINTER_TYPE_P (TREE_TYPE (tmp)) && span_addressed_array (desc))
7621 102 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
7622 :
7623 : /* Offset the data pointer for pointer assignments from arrays with
7624 : subreferences; e.g. my_integer => my_type(:)%integer_component. */
7625 59787 : if (subref)
7626 : {
7627 : /* Go past the array reference. */
7628 1088 : for (ref = expr->ref; ref; ref = ref->next)
7629 1088 : if (ref->type == REF_ARRAY &&
7630 995 : ref->u.ar.type != AR_ELEMENT)
7631 : {
7632 971 : ref = ref->next;
7633 971 : break;
7634 : }
7635 :
7636 : /* Calculate the offset for each subsequent subreference. */
7637 1724 : for (; ref; ref = ref->next)
7638 : {
7639 753 : switch (ref->type)
7640 : {
7641 355 : case REF_COMPONENT:
7642 355 : field = ref->u.c.component->backend_decl;
7643 355 : gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
7644 710 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
7645 355 : TREE_TYPE (field),
7646 : tmp, field, NULL_TREE);
7647 355 : break;
7648 :
7649 314 : case REF_SUBSTRING:
7650 314 : gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
7651 314 : gfc_init_se (&start, NULL);
7652 314 : gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
7653 314 : gfc_add_block_to_block (block, &start.pre);
7654 314 : tmp = gfc_build_array_ref (tmp, start.expr, NULL);
7655 314 : break;
7656 :
7657 24 : case REF_ARRAY:
7658 24 : gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
7659 : && ref->u.ar.type == AR_ELEMENT);
7660 :
7661 : /* TODO - Add bounds checking. */
7662 24 : stride = gfc_index_one_node;
7663 24 : index = gfc_index_zero_node;
7664 55 : for (n = 0; n < ref->u.ar.dimen; n++)
7665 : {
7666 31 : tree itmp;
7667 31 : tree jtmp;
7668 :
7669 : /* Update the index. */
7670 31 : gfc_init_se (&start, NULL);
7671 31 : gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
7672 31 : itmp = gfc_evaluate_now (start.expr, block);
7673 31 : gfc_init_se (&start, NULL);
7674 31 : gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
7675 31 : jtmp = gfc_evaluate_now (start.expr, block);
7676 31 : itmp = fold_build2_loc (input_location, MINUS_EXPR,
7677 : gfc_array_index_type, itmp, jtmp);
7678 31 : itmp = fold_build2_loc (input_location, MULT_EXPR,
7679 : gfc_array_index_type, itmp, stride);
7680 31 : index = fold_build2_loc (input_location, PLUS_EXPR,
7681 : gfc_array_index_type, itmp, index);
7682 31 : index = gfc_evaluate_now (index, block);
7683 :
7684 : /* Update the stride. */
7685 31 : gfc_init_se (&start, NULL);
7686 31 : gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
7687 31 : itmp = fold_build2_loc (input_location, MINUS_EXPR,
7688 : gfc_array_index_type, start.expr,
7689 : jtmp);
7690 31 : itmp = fold_build2_loc (input_location, PLUS_EXPR,
7691 : gfc_array_index_type,
7692 : gfc_index_one_node, itmp);
7693 31 : stride = fold_build2_loc (input_location, MULT_EXPR,
7694 : gfc_array_index_type, stride, itmp);
7695 31 : stride = gfc_evaluate_now (stride, block);
7696 : }
7697 :
7698 : /* Apply the index to obtain the array element. */
7699 24 : tmp = gfc_build_array_ref (tmp, index, NULL);
7700 24 : break;
7701 :
7702 60 : case REF_INQUIRY:
7703 60 : switch (ref->u.i)
7704 : {
7705 54 : case INQUIRY_RE:
7706 108 : tmp = fold_build1_loc (input_location, REALPART_EXPR,
7707 54 : TREE_TYPE (TREE_TYPE (tmp)), tmp);
7708 54 : break;
7709 :
7710 6 : case INQUIRY_IM:
7711 12 : tmp = fold_build1_loc (input_location, IMAGPART_EXPR,
7712 6 : TREE_TYPE (TREE_TYPE (tmp)), tmp);
7713 6 : break;
7714 :
7715 : default:
7716 : break;
7717 : }
7718 : break;
7719 :
7720 0 : default:
7721 0 : gcc_unreachable ();
7722 753 : break;
7723 : }
7724 : }
7725 : }
7726 :
7727 : /* Set the target data pointer. */
7728 59787 : offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
7729 :
7730 : /* Check for optional dummy argument being present. Arguments of BIND(C)
7731 : procedures are excepted here since they are handled differently. */
7732 59787 : if (expr->expr_type == EXPR_VARIABLE
7733 52458 : && expr->symtree->n.sym->attr.dummy
7734 6468 : && expr->symtree->n.sym->attr.optional
7735 60779 : && !is_CFI_desc (NULL, expr))
7736 1624 : offset = build3_loc (input_location, COND_EXPR, TREE_TYPE (offset),
7737 812 : gfc_conv_expr_present (expr->symtree->n.sym), offset,
7738 812 : fold_convert (TREE_TYPE (offset), gfc_index_zero_node));
7739 :
7740 59787 : gfc_conv_descriptor_data_set (block, parm, offset);
7741 : }
7742 :
7743 :
7744 : /* gfc_conv_expr_descriptor needs the string length an expression
7745 : so that the size of the temporary can be obtained. This is done
7746 : by adding up the string lengths of all the elements in the
7747 : expression. Function with non-constant expressions have their
7748 : string lengths mapped onto the actual arguments using the
7749 : interface mapping machinery in trans-expr.cc. */
7750 : static void
7751 1584 : get_array_charlen (gfc_expr *expr, gfc_se *se)
7752 : {
7753 1584 : gfc_interface_mapping mapping;
7754 1584 : gfc_formal_arglist *formal;
7755 1584 : gfc_actual_arglist *arg;
7756 1584 : gfc_se tse;
7757 1584 : gfc_expr *e;
7758 :
7759 1584 : if (expr->ts.u.cl->length
7760 1584 : && gfc_is_constant_expr (expr->ts.u.cl->length))
7761 : {
7762 1237 : if (!expr->ts.u.cl->backend_decl)
7763 471 : gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
7764 1369 : return;
7765 : }
7766 :
7767 347 : switch (expr->expr_type)
7768 : {
7769 130 : case EXPR_ARRAY:
7770 :
7771 : /* This is somewhat brutal. The expression for the first
7772 : element of the array is evaluated and assigned to a
7773 : new string length for the original expression. */
7774 130 : e = gfc_constructor_first (expr->value.constructor)->expr;
7775 :
7776 130 : gfc_init_se (&tse, NULL);
7777 :
7778 : /* Avoid evaluating trailing array references since all we need is
7779 : the string length. */
7780 130 : if (e->rank)
7781 38 : tse.descriptor_only = 1;
7782 130 : if (e->rank && e->expr_type != EXPR_VARIABLE)
7783 1 : gfc_conv_expr_descriptor (&tse, e);
7784 : else
7785 129 : gfc_conv_expr (&tse, e);
7786 :
7787 130 : gfc_add_block_to_block (&se->pre, &tse.pre);
7788 130 : gfc_add_block_to_block (&se->post, &tse.post);
7789 :
7790 130 : if (!expr->ts.u.cl->backend_decl || !VAR_P (expr->ts.u.cl->backend_decl))
7791 : {
7792 87 : expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
7793 87 : expr->ts.u.cl->backend_decl =
7794 87 : gfc_create_var (gfc_charlen_type_node, "sln");
7795 : }
7796 :
7797 130 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
7798 : tse.string_length);
7799 :
7800 : /* Make sure that deferred length components point to the hidden
7801 : string_length component. */
7802 130 : if (TREE_CODE (tse.expr) == COMPONENT_REF
7803 25 : && TREE_CODE (tse.string_length) == COMPONENT_REF
7804 149 : && TREE_OPERAND (tse.expr, 0) == TREE_OPERAND (tse.string_length, 0))
7805 19 : e->ts.u.cl->backend_decl = expr->ts.u.cl->backend_decl;
7806 :
7807 : return;
7808 :
7809 91 : case EXPR_OP:
7810 91 : get_array_charlen (expr->value.op.op1, se);
7811 :
7812 : /* For parentheses the expression ts.u.cl should be identical. */
7813 91 : if (expr->value.op.op == INTRINSIC_PARENTHESES)
7814 : {
7815 2 : if (expr->value.op.op1->ts.u.cl != expr->ts.u.cl)
7816 2 : expr->ts.u.cl->backend_decl
7817 2 : = expr->value.op.op1->ts.u.cl->backend_decl;
7818 : return;
7819 : }
7820 :
7821 178 : expr->ts.u.cl->backend_decl =
7822 89 : gfc_create_var (gfc_charlen_type_node, "sln");
7823 :
7824 89 : if (expr->value.op.op2)
7825 : {
7826 89 : get_array_charlen (expr->value.op.op2, se);
7827 :
7828 89 : gcc_assert (expr->value.op.op == INTRINSIC_CONCAT);
7829 :
7830 : /* Add the string lengths and assign them to the expression
7831 : string length backend declaration. */
7832 89 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
7833 : fold_build2_loc (input_location, PLUS_EXPR,
7834 : gfc_charlen_type_node,
7835 89 : expr->value.op.op1->ts.u.cl->backend_decl,
7836 89 : expr->value.op.op2->ts.u.cl->backend_decl));
7837 : }
7838 : else
7839 0 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
7840 0 : expr->value.op.op1->ts.u.cl->backend_decl);
7841 : break;
7842 :
7843 44 : case EXPR_FUNCTION:
7844 44 : if (expr->value.function.esym == NULL
7845 37 : || expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
7846 : {
7847 7 : gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
7848 7 : break;
7849 : }
7850 :
7851 : /* Map expressions involving the dummy arguments onto the actual
7852 : argument expressions. */
7853 37 : gfc_init_interface_mapping (&mapping);
7854 37 : formal = gfc_sym_get_dummy_args (expr->symtree->n.sym);
7855 37 : arg = expr->value.function.actual;
7856 :
7857 : /* Set se = NULL in the calls to the interface mapping, to suppress any
7858 : backend stuff. */
7859 113 : for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
7860 : {
7861 38 : if (!arg->expr)
7862 0 : continue;
7863 38 : if (formal->sym)
7864 38 : gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
7865 : }
7866 :
7867 37 : gfc_init_se (&tse, NULL);
7868 :
7869 : /* Build the expression for the character length and convert it. */
7870 37 : gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length);
7871 :
7872 37 : gfc_add_block_to_block (&se->pre, &tse.pre);
7873 37 : gfc_add_block_to_block (&se->post, &tse.post);
7874 37 : tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
7875 74 : tse.expr = fold_build2_loc (input_location, MAX_EXPR,
7876 37 : TREE_TYPE (tse.expr), tse.expr,
7877 37 : build_zero_cst (TREE_TYPE (tse.expr)));
7878 37 : expr->ts.u.cl->backend_decl = tse.expr;
7879 37 : gfc_free_interface_mapping (&mapping);
7880 37 : break;
7881 :
7882 82 : default:
7883 82 : gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
7884 82 : break;
7885 : }
7886 : }
7887 :
7888 :
7889 : /* Helper function to check dimensions. */
7890 : static bool
7891 0 : transposed_dims (gfc_ss *ss)
7892 : {
7893 0 : int n;
7894 :
7895 177827 : for (n = 0; n < ss->dimen; n++)
7896 89367 : if (ss->dim[n] != n)
7897 : return true;
7898 : return false;
7899 : }
7900 :
7901 :
7902 : /* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
7903 : AR_FULL, suitable for the scalarizer. */
7904 :
7905 : static gfc_ss *
7906 1510 : walk_coarray (gfc_expr *e)
7907 : {
7908 1510 : gfc_ss *ss;
7909 :
7910 1510 : ss = gfc_walk_expr (e);
7911 :
7912 : /* Fix scalar coarray. */
7913 1510 : if (ss == gfc_ss_terminator)
7914 : {
7915 357 : gfc_ref *ref;
7916 :
7917 357 : ref = e->ref;
7918 508 : while (ref)
7919 : {
7920 508 : if (ref->type == REF_ARRAY
7921 357 : && ref->u.ar.codimen > 0)
7922 : break;
7923 :
7924 151 : ref = ref->next;
7925 : }
7926 :
7927 357 : gcc_assert (ref != NULL);
7928 357 : if (ref->u.ar.type == AR_ELEMENT)
7929 339 : ref->u.ar.type = AR_SECTION;
7930 357 : ss = gfc_reverse_ss (gfc_walk_array_ref (ss, e, ref, false));
7931 : }
7932 :
7933 1510 : return ss;
7934 : }
7935 :
7936 : gfc_array_spec *
7937 2177 : get_coarray_as (const gfc_expr *e)
7938 : {
7939 2177 : gfc_array_spec *as;
7940 2177 : gfc_symbol *sym = e->symtree->n.sym;
7941 2177 : gfc_component *comp;
7942 :
7943 2177 : if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.codimension)
7944 595 : as = CLASS_DATA (sym)->as;
7945 1582 : else if (sym->attr.codimension)
7946 1522 : as = sym->as;
7947 : else
7948 : as = nullptr;
7949 :
7950 5069 : for (gfc_ref *ref = e->ref; ref; ref = ref->next)
7951 : {
7952 2892 : switch (ref->type)
7953 : {
7954 715 : case REF_COMPONENT:
7955 715 : comp = ref->u.c.component;
7956 715 : if (comp->ts.type == BT_CLASS && CLASS_DATA (comp)->attr.codimension)
7957 18 : as = CLASS_DATA (comp)->as;
7958 697 : else if (comp->ts.type != BT_CLASS && comp->attr.codimension)
7959 655 : as = comp->as;
7960 : break;
7961 :
7962 : case REF_ARRAY:
7963 : case REF_SUBSTRING:
7964 : case REF_INQUIRY:
7965 : break;
7966 : }
7967 : }
7968 :
7969 2177 : return as;
7970 : }
7971 :
7972 : bool
7973 145539 : is_explicit_coarray (gfc_expr *expr)
7974 : {
7975 145539 : if (!gfc_is_coarray (expr))
7976 : return false;
7977 :
7978 2177 : gfc_array_spec *cas = get_coarray_as (expr);
7979 2177 : return cas && cas->cotype == AS_EXPLICIT;
7980 : }
7981 :
7982 : /* Convert an array for passing as an actual argument. Expressions and
7983 : vector subscripts are evaluated and stored in a temporary, which is then
7984 : passed. For whole arrays the descriptor is passed. For array sections
7985 : a modified copy of the descriptor is passed, but using the original data.
7986 :
7987 : This function is also used for array pointer assignments, and there
7988 : are three cases:
7989 :
7990 : - se->want_pointer && !se->direct_byref
7991 : EXPR is an actual argument. On exit, se->expr contains a
7992 : pointer to the array descriptor.
7993 :
7994 : - !se->want_pointer && !se->direct_byref
7995 : EXPR is an actual argument to an intrinsic function or the
7996 : left-hand side of a pointer assignment. On exit, se->expr
7997 : contains the descriptor for EXPR.
7998 :
7999 : - !se->want_pointer && se->direct_byref
8000 : EXPR is the right-hand side of a pointer assignment and
8001 : se->expr is the descriptor for the previously-evaluated
8002 : left-hand side. The function creates an assignment from
8003 : EXPR to se->expr.
8004 :
8005 :
8006 : The se->force_tmp flag disables the non-copying descriptor optimization
8007 : that is used for transpose. It may be used in cases where there is an
8008 : alias between the transpose argument and another argument in the same
8009 : function call. */
8010 :
8011 : void
8012 162088 : gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
8013 : {
8014 162088 : gfc_ss *ss;
8015 162088 : gfc_ss_type ss_type;
8016 162088 : gfc_ss_info *ss_info;
8017 162088 : gfc_loopinfo loop;
8018 162088 : gfc_array_info *info;
8019 162088 : int need_tmp;
8020 162088 : int n;
8021 162088 : tree tmp;
8022 162088 : tree desc;
8023 162088 : stmtblock_t block;
8024 162088 : tree start;
8025 162088 : int full;
8026 162088 : bool subref_array_target = false;
8027 162088 : bool deferred_array_component = false;
8028 162088 : bool substr = false;
8029 162088 : gfc_expr *arg, *ss_expr;
8030 :
8031 162088 : if (se->want_coarray || expr->rank == 0)
8032 1510 : ss = walk_coarray (expr);
8033 : else
8034 160578 : ss = gfc_walk_expr (expr);
8035 :
8036 162088 : gcc_assert (ss != NULL);
8037 162088 : gcc_assert (ss != gfc_ss_terminator);
8038 :
8039 162088 : ss_info = ss->info;
8040 162088 : ss_type = ss_info->type;
8041 162088 : ss_expr = ss_info->expr;
8042 :
8043 : /* Special case: TRANSPOSE which needs no temporary. */
8044 167499 : while (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym
8045 167265 : && (arg = gfc_get_noncopying_intrinsic_argument (expr)) != NULL)
8046 : {
8047 : /* This is a call to transpose which has already been handled by the
8048 : scalarizer, so that we just need to get its argument's descriptor. */
8049 444 : gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
8050 444 : expr = expr->value.function.actual->expr;
8051 : }
8052 :
8053 162088 : if (!se->direct_byref)
8054 311559 : se->unlimited_polymorphic = UNLIMITED_POLY (expr);
8055 :
8056 : /* Special case things we know we can pass easily. */
8057 162088 : switch (expr->expr_type)
8058 : {
8059 145824 : case EXPR_VARIABLE:
8060 : /* If we have a linear array section, we can pass it directly.
8061 : Otherwise we need to copy it into a temporary. */
8062 :
8063 145824 : gcc_assert (ss_type == GFC_SS_SECTION);
8064 145824 : gcc_assert (ss_expr == expr);
8065 145824 : info = &ss_info->data.array;
8066 :
8067 : /* Get the descriptor for the array. */
8068 145824 : gfc_conv_ss_descriptor (&se->pre, ss, 0);
8069 145824 : desc = info->descriptor;
8070 :
8071 : /* The charlen backend decl for deferred character components cannot
8072 : be used because it is fixed at zero. Instead, the hidden string
8073 : length component is used. */
8074 145824 : if (expr->ts.type == BT_CHARACTER
8075 20221 : && expr->ts.deferred
8076 2806 : && TREE_CODE (desc) == COMPONENT_REF)
8077 145824 : deferred_array_component = true;
8078 :
8079 145824 : substr = info->ref && info->ref->next
8080 146700 : && info->ref->next->type == REF_SUBSTRING;
8081 :
8082 145824 : subref_array_target = (is_subref_array (expr)
8083 145824 : && (se->direct_byref
8084 3603 : || se->force_no_tmp
8085 3121 : || expr->ts.type == BT_CHARACTER));
8086 145824 : need_tmp = (gfc_ref_needs_temporary_p (expr->ref)
8087 145824 : && !subref_array_target);
8088 :
8089 145824 : if (se->force_tmp)
8090 : need_tmp = 1;
8091 145641 : else if (se->force_no_tmp)
8092 : need_tmp = 0;
8093 :
8094 139167 : if (need_tmp)
8095 : full = 0;
8096 145539 : else if (is_explicit_coarray (expr))
8097 : full = 0;
8098 144719 : else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
8099 : {
8100 : /* Create a new descriptor if the array doesn't have one. */
8101 : full = 0;
8102 : }
8103 94655 : else if (info->ref->u.ar.type == AR_FULL || se->descriptor_only)
8104 : full = 1;
8105 8059 : else if (se->direct_byref)
8106 : full = 0;
8107 7696 : else if (info->ref->u.ar.dimen == 0 && !info->ref->next)
8108 : full = 1;
8109 7555 : else if (info->ref->u.ar.type == AR_SECTION && se->want_pointer)
8110 : full = 0;
8111 : else
8112 3651 : full = gfc_full_array_ref_p (info->ref, NULL);
8113 :
8114 : /* A subobject of the array elements is described by a new descriptor,
8115 : whose element type is that of the subobject and whose span is the
8116 : element size of the array. */
8117 145824 : if (subref_array_target && !se->direct_byref
8118 1185 : && info->ref && info->ref->next)
8119 : full = 0;
8120 :
8121 232612 : if (full && !transposed_dims (ss))
8122 : {
8123 86957 : if (se->direct_byref && !se->byref_noassign)
8124 : {
8125 1060 : struct lang_type *lhs_ls
8126 1060 : = TYPE_LANG_SPECIFIC (TREE_TYPE (se->expr)),
8127 1060 : *rhs_ls = TYPE_LANG_SPECIFIC (TREE_TYPE (desc));
8128 : /* When only the array_kind differs, do a view_convert. */
8129 1462 : tmp = lhs_ls && rhs_ls && lhs_ls->rank == rhs_ls->rank
8130 1060 : && lhs_ls->akind != rhs_ls->akind
8131 1462 : ? build1 (VIEW_CONVERT_EXPR, TREE_TYPE (se->expr), desc)
8132 : : desc;
8133 : /* Copy the descriptor for pointer assignments. */
8134 1060 : gfc_add_modify (&se->pre, se->expr, tmp);
8135 :
8136 : /* Add any offsets from subreferences. */
8137 1060 : gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
8138 : subref_array_target, expr);
8139 :
8140 : /* ....and set the span field. */
8141 1060 : if (ss_info->expr->ts.type == BT_CHARACTER)
8142 141 : tmp = gfc_conv_descriptor_span_get (desc);
8143 : else
8144 919 : tmp = gfc_get_array_span (desc, expr);
8145 1060 : gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp);
8146 1060 : }
8147 85897 : else if (se->want_pointer)
8148 : {
8149 : /* We pass full arrays directly. This means that pointers and
8150 : allocatable arrays should also work. */
8151 14051 : se->expr = gfc_build_addr_expr (NULL_TREE, desc);
8152 : }
8153 : else
8154 : {
8155 71846 : se->expr = desc;
8156 : }
8157 :
8158 86957 : if (expr->ts.type == BT_CHARACTER && !deferred_array_component)
8159 8384 : se->string_length = gfc_get_expr_charlen (expr);
8160 : /* The ss_info string length is returned set to the value of the
8161 : hidden string length component. */
8162 78310 : else if (deferred_array_component)
8163 263 : se->string_length = ss_info->string_length;
8164 :
8165 86957 : se->class_container = ss_info->class_container;
8166 :
8167 86957 : gfc_free_ss_chain (ss);
8168 174040 : return;
8169 : }
8170 : break;
8171 :
8172 4967 : case EXPR_FUNCTION:
8173 : /* A transformational function return value will be a temporary
8174 : array descriptor. We still need to go through the scalarizer
8175 : to create the descriptor. Elemental functions are handled as
8176 : arbitrary expressions, i.e. copy to a temporary. */
8177 :
8178 4967 : if (se->direct_byref)
8179 : {
8180 126 : gcc_assert (ss_type == GFC_SS_FUNCTION && ss_expr == expr);
8181 :
8182 : /* For pointer assignments pass the descriptor directly. */
8183 126 : if (se->ss == NULL)
8184 126 : se->ss = ss;
8185 : else
8186 0 : gcc_assert (se->ss == ss);
8187 :
8188 126 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
8189 126 : gfc_conv_expr (se, expr);
8190 :
8191 126 : gfc_free_ss_chain (ss);
8192 126 : return;
8193 : }
8194 :
8195 4841 : if (ss_expr != expr || ss_type != GFC_SS_FUNCTION)
8196 : {
8197 3325 : if (ss_expr != expr)
8198 : /* Elemental function. */
8199 2576 : gcc_assert ((expr->value.function.esym != NULL
8200 : && expr->value.function.esym->attr.elemental)
8201 : || (expr->value.function.isym != NULL
8202 : && expr->value.function.isym->elemental)
8203 : || (gfc_expr_attr (expr).proc_pointer
8204 : && gfc_expr_attr (expr).elemental)
8205 : || gfc_inline_intrinsic_function_p (expr));
8206 :
8207 3325 : need_tmp = 1;
8208 3325 : if (expr->ts.type == BT_CHARACTER
8209 35 : && expr->ts.u.cl->length
8210 29 : && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
8211 13 : get_array_charlen (expr, se);
8212 :
8213 : info = NULL;
8214 : }
8215 : else
8216 : {
8217 : /* Transformational function. */
8218 1516 : info = &ss_info->data.array;
8219 1516 : need_tmp = 0;
8220 : }
8221 : break;
8222 :
8223 10539 : case EXPR_ARRAY:
8224 : /* Constant array constructors don't need a temporary. */
8225 10539 : if (ss_type == GFC_SS_CONSTRUCTOR
8226 10539 : && expr->ts.type != BT_CHARACTER
8227 19819 : && gfc_constant_array_constructor_p (expr->value.constructor))
8228 : {
8229 7316 : need_tmp = 0;
8230 7316 : info = &ss_info->data.array;
8231 : }
8232 : else
8233 : {
8234 : need_tmp = 1;
8235 : info = NULL;
8236 : }
8237 : break;
8238 :
8239 : default:
8240 : /* Something complicated. Copy it into a temporary. */
8241 : need_tmp = 1;
8242 : info = NULL;
8243 : break;
8244 : }
8245 :
8246 : /* If we are creating a temporary, we don't need to bother about aliases
8247 : anymore. */
8248 67712 : if (need_tmp)
8249 7591 : se->force_tmp = 0;
8250 :
8251 75005 : gfc_init_loopinfo (&loop);
8252 :
8253 : /* Associate the SS with the loop. */
8254 75005 : gfc_add_ss_to_loop (&loop, ss);
8255 :
8256 : /* Tell the scalarizer not to bother creating loop variables, etc. */
8257 75005 : if (!need_tmp)
8258 67414 : loop.array_parameter = 1;
8259 : else
8260 : /* The right-hand side of a pointer assignment mustn't use a temporary. */
8261 7591 : gcc_assert (!se->direct_byref);
8262 :
8263 : /* Do we need bounds checking or not? */
8264 75005 : ss->no_bounds_check = expr->no_bounds_check;
8265 :
8266 : /* Setup the scalarizing loops and bounds. */
8267 75005 : gfc_conv_ss_startstride (&loop);
8268 :
8269 : /* Add bounds-checking for elemental dimensions. */
8270 75005 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !expr->no_bounds_check)
8271 6688 : array_bound_check_elemental (&outermost_loop (&loop)->pre, ss, expr);
8272 :
8273 75005 : if (need_tmp)
8274 : {
8275 7591 : if (expr->ts.type == BT_CHARACTER
8276 1499 : && (!expr->ts.u.cl->backend_decl || expr->expr_type == EXPR_ARRAY))
8277 1391 : get_array_charlen (expr, se);
8278 :
8279 : /* Tell the scalarizer to make a temporary. */
8280 7591 : loop.temp_ss = gfc_get_temp_ss (gfc_typenode_for_spec (&expr->ts),
8281 7591 : ((expr->ts.type == BT_CHARACTER)
8282 1499 : ? expr->ts.u.cl->backend_decl
8283 : : NULL),
8284 : loop.dimen);
8285 :
8286 7591 : se->string_length = loop.temp_ss->info->string_length;
8287 7591 : gcc_assert (loop.temp_ss->dimen == loop.dimen);
8288 7591 : gfc_add_ss_to_loop (&loop, loop.temp_ss);
8289 : }
8290 :
8291 75005 : gfc_conv_loop_setup (&loop, & expr->where);
8292 :
8293 75005 : if (need_tmp)
8294 : {
8295 : /* Copy into a temporary and pass that. We don't need to copy the data
8296 : back because expressions and vector subscripts must be INTENT_IN. */
8297 : /* TODO: Optimize passing function return values. */
8298 7591 : gfc_se lse;
8299 7591 : gfc_se rse;
8300 7591 : bool deep_copy;
8301 :
8302 : /* Start the copying loops. */
8303 7591 : gfc_mark_ss_chain_used (loop.temp_ss, 1);
8304 7591 : gfc_mark_ss_chain_used (ss, 1);
8305 7591 : gfc_start_scalarized_body (&loop, &block);
8306 :
8307 : /* Copy each data element. */
8308 7591 : gfc_init_se (&lse, NULL);
8309 7591 : gfc_copy_loopinfo_to_se (&lse, &loop);
8310 7591 : gfc_init_se (&rse, NULL);
8311 7591 : gfc_copy_loopinfo_to_se (&rse, &loop);
8312 :
8313 7591 : lse.ss = loop.temp_ss;
8314 7591 : rse.ss = ss;
8315 :
8316 7591 : gfc_conv_tmp_array_ref (&lse);
8317 7591 : if (expr->ts.type == BT_CHARACTER)
8318 : {
8319 1499 : gfc_conv_expr (&rse, expr);
8320 1499 : if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
8321 1177 : rse.expr = build_fold_indirect_ref_loc (input_location,
8322 : rse.expr);
8323 : }
8324 : else
8325 6092 : gfc_conv_expr_val (&rse, expr);
8326 :
8327 7591 : gfc_add_block_to_block (&block, &rse.pre);
8328 7591 : gfc_add_block_to_block (&block, &lse.pre);
8329 :
8330 7591 : lse.string_length = rse.string_length;
8331 :
8332 15182 : deep_copy = !se->data_not_needed
8333 7591 : && (expr->expr_type == EXPR_VARIABLE
8334 7053 : || expr->expr_type == EXPR_ARRAY);
8335 7591 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts,
8336 : deep_copy, false);
8337 7591 : gfc_add_expr_to_block (&block, tmp);
8338 :
8339 : /* Finish the copying loops. */
8340 7591 : gfc_trans_scalarizing_loops (&loop, &block);
8341 :
8342 7591 : desc = loop.temp_ss->info->data.array.descriptor;
8343 : }
8344 68930 : else if (expr->expr_type == EXPR_FUNCTION && !transposed_dims (ss))
8345 : {
8346 1503 : desc = info->descriptor;
8347 1503 : se->string_length = ss_info->string_length;
8348 : }
8349 : else
8350 : {
8351 : /* We pass sections without copying to a temporary. Make a new
8352 : descriptor and point it at the section we want. The loop variable
8353 : limits will be the limits of the section.
8354 : A function may decide to repack the array to speed up access, but
8355 : we're not bothered about that here. */
8356 65911 : int dim, ndim, codim;
8357 65911 : tree parm;
8358 65911 : tree parmtype;
8359 65911 : tree dtype;
8360 65911 : tree stride;
8361 65911 : tree from;
8362 65911 : tree to;
8363 65911 : tree base;
8364 65911 : tree offset;
8365 :
8366 65911 : ndim = info->ref ? info->ref->u.ar.dimen : ss->dimen;
8367 :
8368 65911 : if (se->want_coarray)
8369 : {
8370 694 : gfc_array_ref *ar = &info->ref->u.ar;
8371 :
8372 694 : codim = expr->corank;
8373 1512 : for (n = 0; n < codim - 1; n++)
8374 : {
8375 : /* Make sure we are not lost somehow. */
8376 818 : gcc_assert (ar->dimen_type[n + ndim] == DIMEN_THIS_IMAGE);
8377 :
8378 : /* Make sure the call to gfc_conv_section_startstride won't
8379 : generate unnecessary code to calculate stride. */
8380 818 : gcc_assert (ar->stride[n + ndim] == NULL);
8381 :
8382 818 : gfc_conv_section_startstride (&loop.pre, ss, n + ndim);
8383 818 : loop.from[n + loop.dimen] = info->start[n + ndim];
8384 818 : loop.to[n + loop.dimen] = info->end[n + ndim];
8385 : }
8386 :
8387 694 : gcc_assert (n == codim - 1);
8388 694 : evaluate_bound (&loop.pre, info->start, ar->start,
8389 : info->descriptor, n + ndim, true,
8390 694 : ar->as->type == AS_DEFERRED, true);
8391 694 : loop.from[n + loop.dimen] = info->start[n + ndim];
8392 : }
8393 : else
8394 : codim = 0;
8395 :
8396 : /* Set the string_length for a character array. */
8397 65911 : if (expr->ts.type == BT_CHARACTER)
8398 : {
8399 11530 : if (deferred_array_component && !substr)
8400 37 : se->string_length = ss_info->string_length;
8401 : else
8402 11493 : se->string_length = gfc_get_expr_charlen (expr);
8403 :
8404 11530 : if (VAR_P (se->string_length)
8405 984 : && expr->ts.u.cl->backend_decl == se->string_length)
8406 978 : tmp = ss_info->string_length;
8407 : else
8408 : tmp = se->string_length;
8409 :
8410 11530 : if (expr->ts.deferred && expr->ts.u.cl->backend_decl
8411 205 : && VAR_P (expr->ts.u.cl->backend_decl))
8412 150 : gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, tmp);
8413 : else
8414 11380 : expr->ts.u.cl->backend_decl = tmp;
8415 : }
8416 :
8417 : /* If we have an array section, are assigning or passing an array
8418 : section argument make sure that the lower bound is 1. References
8419 : to the full array should otherwise keep the original bounds. */
8420 65911 : if (!info->ref || info->ref->u.ar.type != AR_FULL)
8421 84373 : for (dim = 0; dim < loop.dimen; dim++)
8422 51267 : if (!integer_onep (loop.from[dim]))
8423 : {
8424 27735 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
8425 : gfc_array_index_type, gfc_index_one_node,
8426 : loop.from[dim]);
8427 27735 : loop.to[dim] = fold_build2_loc (input_location, PLUS_EXPR,
8428 : gfc_array_index_type,
8429 : loop.to[dim], tmp);
8430 27735 : loop.from[dim] = gfc_index_one_node;
8431 : }
8432 :
8433 65911 : desc = info->descriptor;
8434 65911 : if (se->direct_byref && !se->byref_noassign)
8435 : {
8436 : /* For pointer assignments we fill in the destination. */
8437 2682 : parm = se->expr;
8438 2682 : parmtype = TREE_TYPE (parm);
8439 : }
8440 : else
8441 : {
8442 : /* Otherwise make a new one. The element type is that of the
8443 : subobject for a subreference of the array. */
8444 63229 : if (expr->ts.type == BT_CHARACTER
8445 52363 : || (subref_array_target && !se->direct_byref))
8446 10950 : parmtype = gfc_typenode_for_spec (&expr->ts);
8447 : else
8448 52279 : parmtype = gfc_get_element_type (TREE_TYPE (desc));
8449 :
8450 63229 : parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, codim,
8451 : loop.from, loop.to, 0,
8452 : GFC_ARRAY_UNKNOWN, false);
8453 63229 : parm = gfc_create_var (parmtype, "parm");
8454 :
8455 : /* When expression is a class object, then add the class' handle to
8456 : the parm_decl. */
8457 63229 : if (expr->ts.type == BT_CLASS && expr->expr_type == EXPR_VARIABLE)
8458 : {
8459 1256 : gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr);
8460 1256 : gfc_se classse;
8461 :
8462 : /* class_expr can be NULL, when no _class ref is in expr.
8463 : We must not fix this here with a gfc_fix_class_ref (). */
8464 1256 : if (class_expr)
8465 : {
8466 1246 : gfc_init_se (&classse, NULL);
8467 1246 : gfc_conv_expr (&classse, class_expr);
8468 1246 : gfc_free_expr (class_expr);
8469 :
8470 1246 : gcc_assert (classse.pre.head == NULL_TREE
8471 : && classse.post.head == NULL_TREE);
8472 1246 : gfc_allocate_lang_decl (parm);
8473 1246 : GFC_DECL_SAVED_DESCRIPTOR (parm) = classse.expr;
8474 : }
8475 : }
8476 : }
8477 :
8478 65911 : if (expr->ts.type == BT_CHARACTER
8479 65911 : && VAR_P (TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (parm)))))
8480 : {
8481 0 : tree elem_len = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (parm)));
8482 0 : gfc_add_modify (&loop.pre, elem_len,
8483 0 : fold_convert (TREE_TYPE (elem_len),
8484 : gfc_get_array_span (desc, expr)));
8485 : }
8486 :
8487 : /* Set the span field. */
8488 65911 : tmp = NULL_TREE;
8489 65911 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
8490 7730 : tmp = gfc_conv_descriptor_span_get (desc);
8491 : else
8492 58181 : tmp = gfc_get_array_span (desc, expr);
8493 65911 : if (tmp)
8494 65843 : gfc_conv_descriptor_span_set (&loop.pre, parm, tmp);
8495 :
8496 : /* The following can be somewhat confusing. We have two
8497 : descriptors, a new one and the original array.
8498 : {parm, parmtype, dim} refer to the new one.
8499 : {desc, type, n, loop} refer to the original, which maybe
8500 : a descriptorless array.
8501 : The bounds of the scalarization are the bounds of the section.
8502 : We don't have to worry about numeric overflows when calculating
8503 : the offsets because all elements are within the array data. */
8504 :
8505 : /* Set the dtype. */
8506 65911 : if (se->unlimited_polymorphic)
8507 679 : dtype = gfc_get_dtype (TREE_TYPE (desc), &loop.dimen);
8508 65232 : else if (expr->ts.type == BT_ASSUMED)
8509 : {
8510 127 : tree tmp2 = desc;
8511 127 : if (DECL_LANG_SPECIFIC (tmp2) && GFC_DECL_SAVED_DESCRIPTOR (tmp2))
8512 127 : tmp2 = GFC_DECL_SAVED_DESCRIPTOR (tmp2);
8513 127 : if (POINTER_TYPE_P (TREE_TYPE (tmp2)))
8514 127 : tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
8515 127 : dtype = gfc_conv_descriptor_dtype_get (tmp2);
8516 : }
8517 : else
8518 65105 : dtype = gfc_get_dtype (parmtype);
8519 65911 : gfc_conv_descriptor_dtype_set (&loop.pre, parm, dtype);
8520 :
8521 : /* The 1st element in the section. */
8522 65911 : base = gfc_index_zero_node;
8523 65911 : if (expr->ts.type == BT_CHARACTER && expr->rank == 0 && codim)
8524 6 : base = gfc_index_one_node;
8525 :
8526 : /* The offset from the 1st element in the section. */
8527 65911 : offset = gfc_index_zero_node;
8528 :
8529 169019 : for (n = 0; n < ndim; n++)
8530 : {
8531 103108 : stride = gfc_conv_array_stride (desc, n);
8532 :
8533 : /* Work out the 1st element in the section. */
8534 103108 : if (info->ref
8535 95334 : && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
8536 : {
8537 1267 : gcc_assert (info->subscript[n]
8538 : && info->subscript[n]->info->type == GFC_SS_SCALAR);
8539 1267 : start = info->subscript[n]->info->data.scalar.value;
8540 : }
8541 : else
8542 : {
8543 : /* Evaluate and remember the start of the section. */
8544 101841 : start = info->start[n];
8545 101841 : stride = gfc_evaluate_now (stride, &loop.pre);
8546 : }
8547 :
8548 103108 : tmp = gfc_conv_array_lbound (desc, n);
8549 103108 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
8550 : start, tmp);
8551 103108 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
8552 : tmp, stride);
8553 103108 : base = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
8554 : base, tmp);
8555 :
8556 103108 : if (info->ref
8557 95334 : && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
8558 : {
8559 : /* For elemental dimensions, we only need the 1st
8560 : element in the section. */
8561 1267 : continue;
8562 : }
8563 :
8564 : /* Vector subscripts need copying and are handled elsewhere. */
8565 101841 : if (info->ref)
8566 94067 : gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
8567 :
8568 : /* look for the corresponding scalarizer dimension: dim. */
8569 152661 : for (dim = 0; dim < ndim; dim++)
8570 152661 : if (ss->dim[dim] == n)
8571 : break;
8572 :
8573 : /* loop exited early: the DIM being looked for has been found. */
8574 101841 : gcc_assert (dim < ndim);
8575 :
8576 : /* Set the new lower bound. */
8577 101841 : from = loop.from[dim];
8578 101841 : to = loop.to[dim];
8579 :
8580 101841 : gfc_conv_descriptor_lbound_set (&loop.pre, parm,
8581 : gfc_rank_cst[dim], from);
8582 :
8583 : /* Set the new upper bound. */
8584 101841 : gfc_conv_descriptor_ubound_set (&loop.pre, parm,
8585 : gfc_rank_cst[dim], to);
8586 :
8587 : /* Multiply the stride by the section stride to get the
8588 : total stride. */
8589 101841 : stride = fold_build2_loc (input_location, MULT_EXPR,
8590 : gfc_array_index_type,
8591 : stride, info->stride[n]);
8592 :
8593 101841 : tmp = fold_build2_loc (input_location, MULT_EXPR,
8594 101841 : TREE_TYPE (offset), stride, from);
8595 101841 : offset = fold_build2_loc (input_location, MINUS_EXPR,
8596 101841 : TREE_TYPE (offset), offset, tmp);
8597 :
8598 : /* Store the new stride. */
8599 101841 : gfc_conv_descriptor_stride_set (&loop.pre, parm,
8600 : gfc_rank_cst[dim], stride);
8601 : }
8602 :
8603 : /* For deferred-length character we need to take the dynamic length
8604 : into account for the dataptr offset. */
8605 65911 : if (expr->ts.type == BT_CHARACTER
8606 11530 : && expr->ts.deferred
8607 211 : && expr->ts.u.cl->backend_decl
8608 211 : && VAR_P (expr->ts.u.cl->backend_decl))
8609 : {
8610 150 : tree base_type = TREE_TYPE (base);
8611 150 : base = fold_build2_loc (input_location, MULT_EXPR, base_type, base,
8612 : fold_convert (base_type,
8613 : expr->ts.u.cl->backend_decl));
8614 : }
8615 :
8616 67423 : for (n = loop.dimen; n < loop.dimen + codim; n++)
8617 : {
8618 1512 : from = loop.from[n];
8619 1512 : to = loop.to[n];
8620 1512 : gfc_conv_descriptor_lbound_set (&loop.pre, parm,
8621 : gfc_rank_cst[n], from);
8622 1512 : if (n < loop.dimen + codim - 1)
8623 818 : gfc_conv_descriptor_ubound_set (&loop.pre, parm,
8624 : gfc_rank_cst[n], to);
8625 : }
8626 :
8627 65911 : if (se->data_not_needed)
8628 6259 : gfc_conv_descriptor_data_set (&loop.pre, parm,
8629 : gfc_index_zero_node);
8630 : else
8631 : /* Point the data pointer at the 1st element in the section. */
8632 59652 : gfc_get_dataptr_offset (&loop.pre, parm, desc, base,
8633 : subref_array_target, expr);
8634 :
8635 65911 : gfc_conv_descriptor_offset_set (&loop.pre, parm, offset);
8636 :
8637 65911 : if (flag_coarray == GFC_FCOARRAY_LIB && expr->corank)
8638 : {
8639 404 : tmp = INDIRECT_REF_P (desc) ? TREE_OPERAND (desc, 0) : desc;
8640 404 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
8641 : {
8642 24 : tmp = gfc_conv_descriptor_token (tmp);
8643 : }
8644 380 : else if (DECL_P (tmp) && DECL_LANG_SPECIFIC (tmp)
8645 460 : && GFC_DECL_TOKEN (tmp) != NULL_TREE)
8646 64 : tmp = GFC_DECL_TOKEN (tmp);
8647 : else
8648 : {
8649 316 : tmp = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (tmp));
8650 : }
8651 :
8652 404 : gfc_conv_descriptor_token_set (&loop.pre, parm, tmp);
8653 : }
8654 : desc = parm;
8655 : }
8656 :
8657 : /* For class arrays add the class tree into the saved descriptor to
8658 : enable getting of _vptr and the like. */
8659 75005 : if (expr->expr_type == EXPR_VARIABLE && VAR_P (desc)
8660 57951 : && IS_CLASS_ARRAY (expr->symtree->n.sym))
8661 : {
8662 1216 : gfc_allocate_lang_decl (desc);
8663 1216 : GFC_DECL_SAVED_DESCRIPTOR (desc) =
8664 1216 : DECL_LANG_SPECIFIC (expr->symtree->n.sym->backend_decl) ?
8665 1130 : GFC_DECL_SAVED_DESCRIPTOR (expr->symtree->n.sym->backend_decl)
8666 : : expr->symtree->n.sym->backend_decl;
8667 : }
8668 73789 : else if (expr->expr_type == EXPR_ARRAY && VAR_P (desc)
8669 10539 : && IS_CLASS_ARRAY (expr))
8670 : {
8671 12 : tree vtype;
8672 12 : gfc_allocate_lang_decl (desc);
8673 12 : tmp = gfc_create_var (expr->ts.u.derived->backend_decl, "class");
8674 12 : GFC_DECL_SAVED_DESCRIPTOR (desc) = tmp;
8675 12 : vtype = gfc_class_vptr_get (tmp);
8676 12 : gfc_add_modify (&se->pre, vtype,
8677 12 : gfc_build_addr_expr (TREE_TYPE (vtype),
8678 12 : gfc_find_vtab (&expr->ts)->backend_decl));
8679 : }
8680 75005 : if (!se->direct_byref || se->byref_noassign)
8681 : {
8682 : /* Get a pointer to the new descriptor. */
8683 72323 : if (se->want_pointer)
8684 40543 : se->expr = gfc_build_addr_expr (NULL_TREE, desc);
8685 : else
8686 31780 : se->expr = desc;
8687 : }
8688 :
8689 75005 : gfc_add_block_to_block (&se->pre, &loop.pre);
8690 75005 : gfc_add_block_to_block (&se->post, &loop.post);
8691 :
8692 : /* Cleanup the scalarizer. */
8693 75005 : gfc_cleanup_loop (&loop);
8694 : }
8695 :
8696 :
8697 : /* Calculate the array size (number of elements); if dim != NULL_TREE,
8698 : return size for that dim (dim=0..rank-1; only for GFC_DESCRIPTOR_TYPE_P).
8699 : If !expr && descriptor array, the rank is taken from the descriptor. */
8700 : tree
8701 15690 : gfc_tree_array_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree dim)
8702 : {
8703 15690 : if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
8704 : {
8705 40 : gcc_assert (dim == NULL_TREE);
8706 40 : return GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
8707 : }
8708 15650 : tree size, tmp, rank = NULL_TREE, cond = NULL_TREE;
8709 15650 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
8710 15650 : enum gfc_array_kind akind = GFC_TYPE_ARRAY_AKIND (TREE_TYPE (desc));
8711 15650 : if (expr == NULL || expr->rank < 0)
8712 3641 : rank = gfc_conv_descriptor_rank_get (desc);
8713 : else
8714 12009 : rank = gfc_rank_cst[expr->rank];
8715 :
8716 15650 : if (dim || (expr && expr->rank == 1))
8717 : {
8718 4681 : if (dim)
8719 9301 : dim = fold_convert_loc (input_location, gfc_array_dim_rank_type, dim);
8720 : else
8721 4681 : dim = gfc_rank_cst[0];
8722 13982 : tree ubound = gfc_conv_descriptor_ubound_get (desc, dim);
8723 13982 : tree lbound = gfc_conv_descriptor_lbound_get (desc, dim);
8724 :
8725 13982 : size = fold_build2_loc (input_location, MINUS_EXPR,
8726 : gfc_array_index_type, ubound, lbound);
8727 13982 : size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
8728 : size, gfc_index_one_node);
8729 : /* if (!allocatable && !pointer && assumed rank)
8730 : size = (idx == rank && ubound[rank-1] == -1 ? -1 : size;
8731 : else
8732 : size = max (0, size); */
8733 13982 : size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
8734 : size, gfc_index_zero_node);
8735 13982 : if (akind == GFC_ARRAY_ASSUMED_RANK_CONT
8736 13982 : || akind == GFC_ARRAY_ASSUMED_RANK)
8737 : {
8738 2942 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
8739 : gfc_array_dim_rank_type, rank,
8740 : gfc_rank_cst[1]);
8741 2942 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
8742 : dim, tmp);
8743 2942 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
8744 : gfc_conv_descriptor_ubound_get (desc, dim),
8745 : build_int_cst (gfc_array_index_type, -1));
8746 2942 : cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
8747 : cond, tmp);
8748 2942 : tmp = build_int_cst (gfc_array_index_type, -1);
8749 2942 : size = build3_loc (input_location, COND_EXPR, gfc_array_index_type,
8750 : cond, tmp, size);
8751 : }
8752 : return size;
8753 : }
8754 :
8755 : /* size = 1. */
8756 1668 : size = gfc_create_var (gfc_array_index_type, "size");
8757 1668 : gfc_add_modify (block, size, build_int_cst (TREE_TYPE (size), 1));
8758 1668 : tree extent = gfc_create_var (gfc_array_index_type, "extent");
8759 :
8760 1668 : stmtblock_t cond_block, loop_body;
8761 1668 : gfc_init_block (&cond_block);
8762 1668 : gfc_init_block (&loop_body);
8763 :
8764 : /* Loop: for (i = 0; i < rank; ++i). */
8765 1668 : tree idx = gfc_create_var (gfc_array_dim_rank_type, "idx");
8766 : /* Loop body. */
8767 : /* #if (assumed-rank + !allocatable && !pointer)
8768 : if (idx + 1 == rank && dim[idx].ubound == -1)
8769 : extent = -1;
8770 : else
8771 : #endif
8772 : extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1
8773 : if (extent < 0)
8774 : extent = 0
8775 : size *= extent. */
8776 1668 : cond = NULL_TREE;
8777 1668 : if (akind == GFC_ARRAY_ASSUMED_RANK_CONT || akind == GFC_ARRAY_ASSUMED_RANK)
8778 : {
8779 471 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
8780 : gfc_array_dim_rank_type, idx, gfc_rank_cst[1]);
8781 471 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
8782 : tmp, rank);
8783 471 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
8784 : gfc_conv_descriptor_ubound_get (desc, idx),
8785 : build_int_cst (gfc_array_index_type, -1));
8786 471 : cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
8787 : cond, tmp);
8788 : }
8789 1668 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8790 : gfc_conv_descriptor_ubound_get (desc, idx),
8791 : gfc_conv_descriptor_lbound_get (desc, idx));
8792 1668 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
8793 : tmp, gfc_index_one_node);
8794 1668 : gfc_add_modify (&cond_block, extent, tmp);
8795 1668 : tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
8796 : extent, gfc_index_zero_node);
8797 1668 : tmp = build3_v (COND_EXPR, tmp,
8798 : fold_build2_loc (input_location, MODIFY_EXPR,
8799 : gfc_array_index_type,
8800 : extent, gfc_index_zero_node),
8801 : build_empty_stmt (input_location));
8802 1668 : gfc_add_expr_to_block (&cond_block, tmp);
8803 1668 : tmp = gfc_finish_block (&cond_block);
8804 1668 : if (cond)
8805 471 : tmp = build3_v (COND_EXPR, cond,
8806 : fold_build2_loc (input_location, MODIFY_EXPR,
8807 : gfc_array_index_type, extent,
8808 : build_int_cst (gfc_array_index_type, -1)),
8809 : tmp);
8810 1668 : gfc_add_expr_to_block (&loop_body, tmp);
8811 : /* size *= extent. */
8812 1668 : gfc_add_modify (&loop_body, size,
8813 : fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
8814 : size, extent));
8815 : /* Generate loop. */
8816 3336 : gfc_simple_for_loop (block, idx, build_int_cst (TREE_TYPE (idx), 0), rank, LT_EXPR,
8817 1668 : build_int_cst (TREE_TYPE (idx), 1),
8818 : gfc_finish_block (&loop_body));
8819 1668 : return size;
8820 : }
8821 :
8822 : /* Helper function for gfc_conv_array_parameter if array size needs to be
8823 : computed. */
8824 :
8825 : static void
8826 142 : array_parameter_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree *size)
8827 : {
8828 142 : tree elem;
8829 142 : *size = gfc_tree_array_size (block, desc, expr, NULL);
8830 142 : elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
8831 142 : *size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
8832 : *size, fold_convert (gfc_array_index_type, elem));
8833 142 : }
8834 :
8835 : /* Helper function - return true if the argument is a pointer. */
8836 :
8837 : static bool
8838 711 : is_pointer (gfc_expr *e)
8839 : {
8840 711 : gfc_symbol *sym;
8841 :
8842 711 : if (e->expr_type != EXPR_VARIABLE || e->symtree == NULL)
8843 : return false;
8844 :
8845 711 : sym = e->symtree->n.sym;
8846 711 : if (sym == NULL)
8847 : return false;
8848 :
8849 711 : return sym->attr.pointer || sym->attr.proc_pointer;
8850 : }
8851 :
8852 : /* Assumed-rank actual argument: the caller only allocates storage for dtype
8853 : rank dimensions. Copying GFC_MAX_DIMENSIONS dim entries would read past the
8854 : physical end of the descriptor. Copy the header fields explicitly and use a
8855 : runtime-sized memcpy for the dim[] entries. */
8856 : void
8857 78 : gfc_resize_assumed_rank_dim_field (gfc_se *se, stmtblock_t *block, tree desc)
8858 : {
8859 78 : tree rank, dim_field, dim_size, copy_size, dst_ptr, src_ptr;
8860 :
8861 78 : gfc_conv_descriptor_data_set (block, desc,
8862 : gfc_conv_descriptor_data_get (se->expr));
8863 78 : gfc_conv_descriptor_offset_set (block, desc,
8864 : gfc_conv_descriptor_offset_get (se->expr));
8865 78 : gfc_conv_descriptor_dtype_set (block, desc,
8866 : gfc_conv_descriptor_dtype_get (se->expr));
8867 78 : rank = fold_convert (size_type_node, gfc_conv_descriptor_rank_get (se->expr));
8868 78 : dim_field = gfc_get_descriptor_dimension (se->expr);
8869 78 : dim_size = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (dim_field)));
8870 78 : copy_size = fold_build2_loc (input_location, MULT_EXPR,
8871 : size_type_node, rank, dim_size);
8872 78 : dst_ptr = gfc_build_addr_expr (pvoid_type_node,
8873 : gfc_get_descriptor_dimension (desc));
8874 78 : src_ptr = gfc_build_addr_expr (pvoid_type_node, dim_field);
8875 78 : gfc_add_expr_to_block (block, build_call_expr_loc (input_location,
8876 : builtin_decl_explicit (BUILT_IN_MEMCPY),
8877 : 3, dst_ptr, src_ptr, copy_size));
8878 78 : }
8879 :
8880 : /* Convert an array for passing as an actual parameter. */
8881 :
8882 : void
8883 66567 : gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr, bool g77,
8884 : const gfc_symbol *fsym, const char *proc_name,
8885 : tree *size, tree *lbshift, tree *packed)
8886 : {
8887 66567 : tree ptr;
8888 66567 : tree desc;
8889 66567 : tree tmp = NULL_TREE;
8890 66567 : tree stmt;
8891 66567 : tree parent = DECL_CONTEXT (current_function_decl);
8892 66567 : tree ctree;
8893 66567 : tree pack_attr = NULL_TREE; /* Set when packing class arrays. */
8894 66567 : bool full_array_var;
8895 66567 : bool this_array_result;
8896 66567 : bool contiguous;
8897 66567 : bool no_pack;
8898 66567 : bool array_constructor;
8899 66567 : bool good_allocatable;
8900 66567 : bool ultimate_ptr_comp;
8901 66567 : bool ultimate_alloc_comp;
8902 66567 : bool readonly;
8903 66567 : gfc_symbol *sym;
8904 66567 : stmtblock_t block;
8905 66567 : gfc_ref *ref;
8906 :
8907 66567 : ultimate_ptr_comp = false;
8908 66567 : ultimate_alloc_comp = false;
8909 :
8910 67396 : for (ref = expr->ref; ref; ref = ref->next)
8911 : {
8912 55786 : if (ref->next == NULL)
8913 : break;
8914 :
8915 829 : if (ref->type == REF_COMPONENT)
8916 : {
8917 697 : ultimate_ptr_comp = ref->u.c.component->attr.pointer;
8918 697 : ultimate_alloc_comp = ref->u.c.component->attr.allocatable;
8919 : }
8920 : }
8921 :
8922 66567 : full_array_var = false;
8923 66567 : contiguous = false;
8924 :
8925 66567 : if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp)
8926 54868 : full_array_var = gfc_full_array_ref_p (ref, &contiguous);
8927 :
8928 54868 : sym = full_array_var ? expr->symtree->n.sym : NULL;
8929 :
8930 : /* The symbol should have an array specification. */
8931 63553 : gcc_assert (!sym || sym->as || ref->u.ar.as);
8932 :
8933 66567 : if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
8934 : {
8935 708 : if (expr->ts.u.cl->length_from_typespec && expr->ts.u.cl->length)
8936 : {
8937 : /* The constructor has an explicit character type-spec length
8938 : so convert it directly. */
8939 126 : gfc_se cse;
8940 126 : gfc_init_se (&cse, NULL);
8941 126 : gfc_conv_expr_type (&cse, expr->ts.u.cl->length,
8942 : gfc_charlen_type_node);
8943 126 : gfc_add_block_to_block (&se->pre, &cse.pre);
8944 126 : tmp = cse.expr;
8945 126 : }
8946 : else
8947 582 : get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
8948 :
8949 708 : expr->ts.u.cl->backend_decl = tmp;
8950 708 : se->string_length = tmp;
8951 : }
8952 :
8953 : /* Is this the result of the enclosing procedure? */
8954 66567 : this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
8955 58 : if (this_array_result
8956 58 : && (sym->backend_decl != current_function_decl)
8957 0 : && (sym->backend_decl != parent))
8958 66567 : this_array_result = false;
8959 :
8960 : /* Passing an optional dummy argument as actual to an optional dummy? */
8961 66567 : bool pass_optional;
8962 66567 : pass_optional = fsym && fsym->attr.optional && sym && sym->attr.optional;
8963 :
8964 : /* Passing address of the array if it is not pointer or assumed-shape. */
8965 66567 : if (full_array_var && g77 && !this_array_result
8966 16233 : && sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
8967 : {
8968 12578 : tmp = gfc_get_symbol_decl (sym);
8969 :
8970 12578 : if (sym->ts.type == BT_CHARACTER)
8971 2809 : se->string_length = sym->ts.u.cl->backend_decl;
8972 :
8973 12578 : if (!sym->attr.pointer
8974 12087 : && sym->as
8975 12087 : && sym->as->type != AS_ASSUMED_SHAPE
8976 11849 : && sym->as->type != AS_DEFERRED
8977 10353 : && sym->as->type != AS_ASSUMED_RANK
8978 10277 : && !sym->attr.allocatable)
8979 : {
8980 : /* Some variables are declared directly, others are declared as
8981 : pointers and allocated on the heap. */
8982 9771 : if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
8983 2518 : se->expr = tmp;
8984 : else
8985 7253 : se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
8986 9771 : if (size)
8987 40 : array_parameter_size (&se->pre, tmp, expr, size);
8988 17136 : return;
8989 : }
8990 :
8991 2807 : if (sym->attr.allocatable)
8992 : {
8993 1882 : if (sym->attr.dummy || sym->attr.result)
8994 : {
8995 1176 : gfc_conv_expr_descriptor (se, expr);
8996 1176 : tmp = se->expr;
8997 : }
8998 1882 : if (size)
8999 14 : array_parameter_size (&se->pre, tmp, expr, size);
9000 1882 : se->expr = gfc_conv_array_data (tmp);
9001 1882 : if (pass_optional)
9002 : {
9003 18 : tree cond = gfc_conv_expr_present (sym);
9004 36 : se->expr = build3_loc (input_location, COND_EXPR,
9005 18 : TREE_TYPE (se->expr), cond, se->expr,
9006 18 : fold_convert (TREE_TYPE (se->expr),
9007 : null_pointer_node));
9008 : }
9009 : return;
9010 : }
9011 : }
9012 :
9013 : /* A convenient reduction in scope. */
9014 54914 : contiguous = g77 && !this_array_result && contiguous;
9015 :
9016 : /* There is no need to pack and unpack the array, if it is contiguous
9017 : and not a deferred- or assumed-shape array, or if it is simply
9018 : contiguous. */
9019 54914 : no_pack = false;
9020 : // clang-format off
9021 54914 : if (sym)
9022 : {
9023 40288 : symbol_attribute *attr = &(IS_CLASS_ARRAY (sym)
9024 : ? CLASS_DATA (sym)->attr : sym->attr);
9025 40288 : gfc_array_spec *as = IS_CLASS_ARRAY (sym)
9026 40288 : ? CLASS_DATA (sym)->as : sym->as;
9027 40288 : no_pack = (as
9028 39998 : && !attr->pointer
9029 36732 : && as->type != AS_DEFERRED
9030 27027 : && as->type != AS_ASSUMED_RANK
9031 64095 : && as->type != AS_ASSUMED_SHAPE);
9032 : }
9033 54914 : if (ref && ref->u.ar.as)
9034 43254 : no_pack = no_pack
9035 43254 : || (ref->u.ar.as->type != AS_DEFERRED
9036 : && ref->u.ar.as->type != AS_ASSUMED_RANK
9037 : && ref->u.ar.as->type != AS_ASSUMED_SHAPE);
9038 109828 : no_pack = contiguous
9039 54914 : && (no_pack || gfc_is_simply_contiguous (expr, false, true));
9040 : // clang-format on
9041 :
9042 : /* If we have an EXPR_OP or a function returning an explicit-shaped
9043 : or allocatable array, an array temporary will be generated which
9044 : does not need to be packed / unpacked if passed to an
9045 : explicit-shape dummy array. */
9046 :
9047 54914 : if (g77)
9048 : {
9049 6526 : if (expr->expr_type == EXPR_OP)
9050 : no_pack = 1;
9051 6449 : else if (expr->expr_type == EXPR_FUNCTION && expr->value.function.esym)
9052 : {
9053 41 : gfc_symbol *result = expr->value.function.esym->result;
9054 41 : if (result->attr.dimension
9055 41 : && (result->as->type == AS_EXPLICIT
9056 14 : || result->attr.allocatable
9057 7 : || result->attr.contiguous))
9058 54914 : no_pack = 1;
9059 : }
9060 : }
9061 :
9062 : /* Array constructors are always contiguous and do not need packing. */
9063 54914 : array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY;
9064 :
9065 : /* Same is true of contiguous sections from allocatable variables. */
9066 109828 : good_allocatable = contiguous
9067 4717 : && expr->symtree
9068 59631 : && expr->symtree->n.sym->attr.allocatable;
9069 :
9070 : /* Or ultimate allocatable components. */
9071 54914 : ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
9072 :
9073 54914 : if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp)
9074 : {
9075 5101 : gfc_conv_expr_descriptor (se, expr);
9076 : /* Deallocate the allocatable components of structures that are
9077 : not variable. */
9078 5101 : if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
9079 3558 : && expr->ts.u.derived->attr.alloc_comp
9080 2137 : && expr->expr_type != EXPR_VARIABLE)
9081 : {
9082 2 : tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, se->expr, expr->rank);
9083 :
9084 : /* The components shall be deallocated before their containing entity. */
9085 2 : gfc_prepend_expr_to_block (&se->post, tmp);
9086 : }
9087 5101 : if (expr->ts.type == BT_CHARACTER && expr->expr_type != EXPR_FUNCTION)
9088 309 : se->string_length = expr->ts.u.cl->backend_decl;
9089 5101 : if (size)
9090 58 : array_parameter_size (&se->pre, se->expr, expr, size);
9091 5101 : se->expr = gfc_conv_array_data (se->expr);
9092 5101 : return;
9093 : }
9094 :
9095 49813 : if (fsym && fsym->ts.type == BT_CLASS)
9096 : {
9097 1260 : gcc_assert (se->expr);
9098 : ctree = se->expr;
9099 : }
9100 : else
9101 : ctree = NULL_TREE;
9102 :
9103 49813 : if (this_array_result)
9104 : {
9105 : /* Result of the enclosing function. */
9106 58 : gfc_conv_expr_descriptor (se, expr);
9107 58 : if (size)
9108 0 : array_parameter_size (&se->pre, se->expr, expr, size);
9109 58 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
9110 :
9111 18 : if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
9112 76 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
9113 18 : se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location,
9114 : se->expr));
9115 :
9116 : return;
9117 : }
9118 : else
9119 : {
9120 : /* Every other type of array. */
9121 49755 : se->want_pointer = (ctree) ? 0 : 1;
9122 49755 : se->want_coarray = expr->corank;
9123 49755 : gfc_conv_expr_descriptor (se, expr);
9124 :
9125 49755 : if (size)
9126 30 : array_parameter_size (&se->pre,
9127 : build_fold_indirect_ref_loc (input_location,
9128 : se->expr),
9129 : expr, size);
9130 49755 : if (ctree)
9131 : {
9132 1260 : stmtblock_t block;
9133 :
9134 1260 : gfc_init_block (&block);
9135 1260 : if (lbshift && *lbshift)
9136 : {
9137 : /* Apply a shift of the lbound when supplied. */
9138 98 : for (int dim = 0; dim < expr->rank; ++dim)
9139 49 : gfc_conv_shift_descriptor_lbound (&block, se->expr, dim,
9140 : *lbshift);
9141 : }
9142 1260 : tmp = gfc_class_data_get (ctree);
9143 1260 : if (expr->rank > 1 && CLASS_DATA (fsym)->as->rank != expr->rank
9144 84 : && CLASS_DATA (fsym)->as->type == AS_EXPLICIT && !no_pack)
9145 : {
9146 36 : tree arr = gfc_create_var (TREE_TYPE (tmp), "parm");
9147 36 : gfc_conv_descriptor_data_set (&block, arr,
9148 : gfc_conv_descriptor_data_get (
9149 : se->expr));
9150 36 : gfc_conv_descriptor_lbound_set (&block, arr, gfc_index_zero_node,
9151 : gfc_index_zero_node);
9152 36 : gfc_conv_descriptor_ubound_set (
9153 : &block, arr, gfc_index_zero_node,
9154 : gfc_conv_descriptor_size (se->expr, expr->rank));
9155 36 : gfc_conv_descriptor_stride_set (
9156 : &block, arr, gfc_index_zero_node,
9157 : gfc_conv_descriptor_stride_get (se->expr, gfc_index_zero_node));
9158 36 : tree dtype_val = gfc_conv_descriptor_dtype_get (se->expr);
9159 36 : gfc_conv_descriptor_dtype_set (&block, arr, dtype_val);
9160 36 : gfc_conv_descriptor_rank_set (&block, arr, 1);
9161 36 : gfc_conv_descriptor_span_set (&block, arr,
9162 : gfc_conv_descriptor_span_get (arr));
9163 36 : gfc_conv_descriptor_offset_set (&block, arr, gfc_index_zero_node);
9164 36 : se->expr = arr;
9165 : }
9166 1260 : if (expr->rank == -1)
9167 78 : gfc_resize_assumed_rank_dim_field (se, &block, tmp);
9168 1182 : else if (CLASS_DATA (fsym)->as->rank == -1)
9169 397 : gfc_class_array_data_assign (&block, tmp, se->expr, false);
9170 : else
9171 785 : gfc_class_array_data_assign (&block, tmp, se->expr, true);
9172 :
9173 : /* Handle optional. */
9174 1260 : if (fsym && fsym->attr.optional && sym && sym->attr.optional)
9175 348 : tmp = build3_v (COND_EXPR, gfc_conv_expr_present (sym),
9176 : gfc_finish_block (&block),
9177 : build_empty_stmt (input_location));
9178 : else
9179 912 : tmp = gfc_finish_block (&block);
9180 :
9181 1260 : gfc_add_expr_to_block (&se->pre, tmp);
9182 : }
9183 48495 : else if (pass_optional && full_array_var && sym->as && sym->as->rank != 0)
9184 : {
9185 : /* Perform calculation of bounds and strides of optional array dummy
9186 : only if the argument is present. */
9187 219 : tmp = build3_v (COND_EXPR, gfc_conv_expr_present (sym),
9188 : gfc_finish_block (&se->pre),
9189 : build_empty_stmt (input_location));
9190 219 : gfc_add_expr_to_block (&se->pre, tmp);
9191 : }
9192 : }
9193 :
9194 : /* Deallocate the allocatable components of structures that are
9195 : not variable, for descriptorless arguments.
9196 : Arguments with a descriptor are handled in gfc_conv_procedure_call. */
9197 49755 : if (g77 && (expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
9198 78 : && expr->ts.u.derived->attr.alloc_comp
9199 18 : && expr->expr_type != EXPR_VARIABLE)
9200 : {
9201 0 : tmp = build_fold_indirect_ref_loc (input_location, se->expr);
9202 0 : tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank);
9203 :
9204 : /* The components shall be deallocated before their containing entity. */
9205 0 : gfc_prepend_expr_to_block (&se->post, tmp);
9206 : }
9207 :
9208 48348 : if (g77 || (fsym && fsym->attr.contiguous
9209 1579 : && !gfc_is_simply_contiguous (expr, false, true)))
9210 : {
9211 1581 : tree origptr = NULL_TREE, packedptr = NULL_TREE;
9212 :
9213 1581 : desc = se->expr;
9214 :
9215 : /* For contiguous arrays, save the original value of the descriptor. */
9216 1581 : if (!g77 && !ctree)
9217 : {
9218 78 : origptr = gfc_create_var (pvoid_type_node, "origptr");
9219 78 : tmp = build_fold_indirect_ref_loc (input_location, desc);
9220 78 : tmp = gfc_conv_array_data (tmp);
9221 156 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
9222 78 : TREE_TYPE (origptr), origptr,
9223 78 : fold_convert (TREE_TYPE (origptr), tmp));
9224 78 : gfc_add_expr_to_block (&se->pre, tmp);
9225 : }
9226 :
9227 : /* Repack the array. */
9228 1581 : if (warn_array_temporaries)
9229 : {
9230 28 : if (fsym)
9231 18 : gfc_warning (OPT_Warray_temporaries,
9232 : "Creating array temporary at %L for argument %qs",
9233 18 : &expr->where, fsym->name);
9234 : else
9235 10 : gfc_warning (OPT_Warray_temporaries,
9236 : "Creating array temporary at %L", &expr->where);
9237 : }
9238 :
9239 : /* When optimizing, we can use gfc_conv_subref_array_arg for
9240 : making the packing and unpacking operation visible to the
9241 : optimizers. */
9242 :
9243 1407 : if (g77 && flag_inline_arg_packing && expr->expr_type == EXPR_VARIABLE
9244 711 : && !is_pointer (expr) && ! gfc_has_dimen_vector_ref (expr)
9245 341 : && !(expr->symtree->n.sym->as
9246 323 : && expr->symtree->n.sym->as->type == AS_ASSUMED_RANK)
9247 1922 : && (fsym == NULL || fsym->ts.type != BT_ASSUMED))
9248 : {
9249 324 : gfc_conv_subref_array_arg (se, expr, g77,
9250 148 : fsym ? fsym->attr.intent : INTENT_INOUT,
9251 : false, fsym, proc_name, sym, true);
9252 324 : return;
9253 : }
9254 :
9255 1257 : if (ctree)
9256 : {
9257 96 : packedptr
9258 96 : = gfc_build_addr_expr (NULL_TREE, gfc_create_var (TREE_TYPE (ctree),
9259 : "packed"));
9260 96 : if (fsym)
9261 : {
9262 96 : int pack_mask = 0;
9263 :
9264 : /* Set bit 0 to the mask, when this is an unlimited_poly
9265 : class. */
9266 96 : if (CLASS_DATA (fsym)->ts.u.derived->attr.unlimited_polymorphic)
9267 36 : pack_mask = 1 << 0;
9268 96 : pack_attr = build_int_cst (integer_type_node, pack_mask);
9269 : }
9270 : else
9271 0 : pack_attr = integer_zero_node;
9272 :
9273 96 : gfc_add_expr_to_block (
9274 : &se->pre,
9275 : build_call_expr_loc (input_location, gfor_fndecl_in_pack_class, 4,
9276 : packedptr,
9277 : gfc_build_addr_expr (NULL_TREE, ctree),
9278 96 : size_in_bytes (TREE_TYPE (ctree)), pack_attr));
9279 96 : ptr = gfc_conv_array_data (gfc_class_data_get (packedptr));
9280 96 : se->expr = packedptr;
9281 96 : if (packed)
9282 96 : *packed = packedptr;
9283 : }
9284 : else
9285 : {
9286 1161 : ptr = build_call_expr_loc (input_location, gfor_fndecl_in_pack, 1,
9287 : desc);
9288 :
9289 1161 : if (fsym && fsym->attr.optional && sym && sym->attr.optional)
9290 : {
9291 11 : tmp = gfc_conv_expr_present (sym);
9292 22 : ptr = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
9293 11 : tmp, fold_convert (TREE_TYPE (se->expr), ptr),
9294 11 : fold_convert (TREE_TYPE (se->expr),
9295 : null_pointer_node));
9296 : }
9297 :
9298 1161 : ptr = gfc_evaluate_now (ptr, &se->pre);
9299 : }
9300 :
9301 : /* Use the packed data for the actual argument, except for contiguous arrays,
9302 : where the descriptor's data component is set. */
9303 1257 : if (g77)
9304 1083 : se->expr = ptr;
9305 : else
9306 : {
9307 174 : tmp = build_fold_indirect_ref_loc (input_location, desc);
9308 :
9309 174 : if (!ctree)
9310 : {
9311 : /* The original descriptor may have transposed dims so we
9312 : can't reuse it directly; we have to create a new one. */
9313 78 : tree old_field;
9314 78 : tree old_desc = tmp;
9315 78 : tree new_desc = gfc_create_var (TREE_TYPE (old_desc), "arg_desc");
9316 :
9317 78 : old_field = gfc_conv_descriptor_dtype_get (old_desc);
9318 78 : gfc_conv_descriptor_dtype_set (&se->pre, new_desc, old_field);
9319 :
9320 78 : if (expr->rank == -1)
9321 : {
9322 12 : tree idx = gfc_create_var (gfc_array_dim_rank_type, "idx");
9323 12 : tree stride = gfc_create_var (gfc_array_index_type, "stride");
9324 12 : stmtblock_t loop_body;
9325 :
9326 12 : gfc_conv_descriptor_offset_set (&se->pre, new_desc,
9327 : gfc_index_zero_node);
9328 12 : gfc_conv_descriptor_span_set (&se->pre, new_desc,
9329 : gfc_conv_descriptor_span_get
9330 : (old_desc));
9331 12 : gfc_add_modify (&se->pre, stride, gfc_index_one_node);
9332 :
9333 12 : gfc_init_block (&loop_body);
9334 :
9335 12 : old_field = gfc_conv_descriptor_lbound_get (old_desc, idx);
9336 12 : gfc_conv_descriptor_lbound_set (&loop_body, new_desc, idx,
9337 : old_field);
9338 :
9339 12 : old_field = gfc_conv_descriptor_ubound_get (old_desc, idx);
9340 12 : gfc_conv_descriptor_ubound_set (&loop_body, new_desc, idx,
9341 : old_field);
9342 :
9343 12 : gfc_conv_descriptor_stride_set (&loop_body, new_desc, idx,
9344 : stride);
9345 :
9346 12 : tree offset = fold_build2_loc (input_location, MULT_EXPR,
9347 : gfc_array_index_type, stride,
9348 : gfc_conv_descriptor_lbound_get
9349 : (new_desc, idx));
9350 12 : offset = fold_build2_loc (input_location, MINUS_EXPR,
9351 : gfc_array_index_type,
9352 : gfc_conv_descriptor_offset_get
9353 : (new_desc), offset);
9354 12 : gfc_conv_descriptor_offset_set (&loop_body, new_desc, offset);
9355 :
9356 12 : tree extent = gfc_conv_array_extent_dim
9357 12 : (gfc_conv_descriptor_lbound_get (new_desc, idx),
9358 : gfc_conv_descriptor_ubound_get (new_desc, idx),
9359 : NULL);
9360 12 : extent = fold_build2_loc (input_location, MULT_EXPR,
9361 : gfc_array_index_type, stride,
9362 : extent);
9363 12 : gfc_add_modify (&loop_body, stride, extent);
9364 :
9365 36 : gfc_simple_for_loop (&se->pre, idx,
9366 12 : build_int_cst (TREE_TYPE (idx), 0),
9367 : gfc_conv_descriptor_rank_get (old_desc),
9368 : LT_EXPR,
9369 12 : build_int_cst (TREE_TYPE (idx), 1),
9370 : gfc_finish_block (&loop_body));
9371 : }
9372 : else
9373 : {
9374 66 : tree offset = gfc_index_zero_node;
9375 :
9376 66 : tree stride = gfc_index_one_node;
9377 :
9378 90 : for (int i = 0; i < expr->rank; i++)
9379 : {
9380 90 : tree dim = gfc_rank_cst[i];
9381 :
9382 90 : tree lbound = gfc_conv_descriptor_lbound_get (old_desc,
9383 : dim);
9384 90 : lbound = gfc_evaluate_now (lbound, &se->pre);
9385 90 : gfc_conv_descriptor_lbound_set (&se->pre, new_desc, dim,
9386 : lbound);
9387 :
9388 90 : tree ubound = gfc_conv_descriptor_ubound_get (old_desc,
9389 : dim);
9390 90 : ubound = gfc_evaluate_now (ubound, &se->pre);
9391 90 : gfc_conv_descriptor_ubound_set (&se->pre, new_desc, dim,
9392 : ubound);
9393 :
9394 90 : gfc_conv_descriptor_stride_set (&se->pre, new_desc, dim,
9395 : stride);
9396 :
9397 90 : tree tmp = fold_build2_loc (input_location, MULT_EXPR,
9398 : gfc_array_index_type,
9399 : stride, lbound);
9400 90 : offset = fold_build2_loc (input_location, MINUS_EXPR,
9401 : gfc_array_index_type,
9402 : offset, tmp);
9403 90 : offset = gfc_evaluate_now (offset, &se->pre);
9404 :
9405 : /* Now calculate the stride for next dimension, unless the
9406 : current dimension is the last one. */
9407 90 : if (i == expr->rank - 1)
9408 : break;
9409 :
9410 24 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
9411 : gfc_array_index_type,
9412 : lbound, gfc_index_one_node);
9413 24 : tree extent = fold_build2_loc (input_location, MINUS_EXPR,
9414 : gfc_array_index_type,
9415 : ubound, tmp);
9416 24 : stride = fold_build2_loc (input_location, MULT_EXPR,
9417 : gfc_array_index_type,
9418 : stride, extent);
9419 24 : stride = gfc_evaluate_now (stride, &se->pre);
9420 : }
9421 :
9422 66 : gfc_conv_descriptor_offset_set (&se->pre, new_desc, offset);
9423 : }
9424 :
9425 78 : if (flag_coarray == GFC_FCOARRAY_LIB
9426 0 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (old_desc))
9427 78 : && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (old_desc))
9428 : == GFC_ARRAY_ALLOCATABLE)
9429 : {
9430 0 : old_field = gfc_conv_descriptor_token (old_desc);
9431 0 : gfc_conv_descriptor_token_set (&se->pre, new_desc,
9432 : old_field);
9433 : }
9434 :
9435 78 : gfc_conv_descriptor_data_set (&se->pre, new_desc, ptr);
9436 78 : se->expr = gfc_build_addr_expr (NULL_TREE, new_desc);
9437 : }
9438 : }
9439 :
9440 1257 : if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
9441 : {
9442 8 : char * msg;
9443 :
9444 8 : if (fsym && proc_name)
9445 8 : msg = xasprintf ("An array temporary was created for argument "
9446 8 : "'%s' of procedure '%s'", fsym->name, proc_name);
9447 : else
9448 0 : msg = xasprintf ("An array temporary was created");
9449 :
9450 8 : tmp = build_fold_indirect_ref_loc (input_location,
9451 : desc);
9452 8 : tmp = gfc_conv_array_data (tmp);
9453 8 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9454 8 : fold_convert (TREE_TYPE (tmp), ptr), tmp);
9455 :
9456 8 : if (pass_optional)
9457 6 : tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
9458 : logical_type_node,
9459 : gfc_conv_expr_present (sym), tmp);
9460 :
9461 8 : gfc_trans_runtime_check (false, true, tmp, &se->pre,
9462 : &expr->where, msg);
9463 8 : free (msg);
9464 : }
9465 :
9466 1257 : gfc_start_block (&block);
9467 :
9468 : /* Copy the data back. If input expr is read-only, e.g. a PARAMETER
9469 : array, copying back modified values is undefined behavior. */
9470 2514 : readonly = (expr->expr_type == EXPR_VARIABLE
9471 846 : && expr->symtree
9472 2103 : && expr->symtree->n.sym->attr.flavor == FL_PARAMETER);
9473 :
9474 1257 : if ((fsym == NULL || fsym->attr.intent != INTENT_IN) && !readonly)
9475 : {
9476 1106 : if (ctree)
9477 : {
9478 66 : tmp = gfc_build_addr_expr (NULL_TREE, ctree);
9479 66 : tmp = build_call_expr_loc (input_location,
9480 : gfor_fndecl_in_unpack_class, 4, tmp,
9481 : packedptr,
9482 66 : size_in_bytes (TREE_TYPE (ctree)),
9483 : pack_attr);
9484 : }
9485 : else
9486 1040 : tmp = build_call_expr_loc (input_location, gfor_fndecl_in_unpack, 2,
9487 : desc, ptr);
9488 1106 : gfc_add_expr_to_block (&block, tmp);
9489 : }
9490 151 : else if (ctree && fsym->attr.intent == INTENT_IN)
9491 : {
9492 : /* Need to free the memory for class arrays, that got packed. */
9493 30 : gfc_add_expr_to_block (&block, gfc_call_free (ptr));
9494 : }
9495 :
9496 : /* Free the temporary. */
9497 1136 : if (!ctree)
9498 1161 : gfc_add_expr_to_block (&block, gfc_call_free (ptr));
9499 :
9500 1257 : stmt = gfc_finish_block (&block);
9501 :
9502 1257 : gfc_init_block (&block);
9503 : /* Only if it was repacked. This code needs to be executed before the
9504 : loop cleanup code. */
9505 1257 : tmp = (ctree) ? desc : build_fold_indirect_ref_loc (input_location, desc);
9506 1257 : tmp = gfc_conv_array_data (tmp);
9507 1257 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9508 1257 : fold_convert (TREE_TYPE (tmp), ptr), tmp);
9509 :
9510 1257 : if (pass_optional)
9511 11 : tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
9512 : logical_type_node,
9513 : gfc_conv_expr_present (sym), tmp);
9514 :
9515 1257 : tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
9516 :
9517 1257 : gfc_add_expr_to_block (&block, tmp);
9518 1257 : gfc_add_block_to_block (&block, &se->post);
9519 :
9520 1257 : gfc_init_block (&se->post);
9521 :
9522 : /* Reset the descriptor pointer. */
9523 1257 : if (!g77 && !ctree)
9524 : {
9525 78 : tmp = build_fold_indirect_ref_loc (input_location, desc);
9526 78 : gfc_conv_descriptor_data_set (&se->post, tmp, origptr);
9527 : }
9528 :
9529 1257 : gfc_add_block_to_block (&se->post, &block);
9530 : }
9531 : }
9532 :
9533 :
9534 : /* This helper function calculates the size in words of a full array. */
9535 :
9536 : tree
9537 21440 : gfc_full_array_size (stmtblock_t *block, tree decl, int rank)
9538 : {
9539 21440 : tree idx;
9540 21440 : tree nelems;
9541 21440 : tree tmp;
9542 21440 : if (rank < 0)
9543 0 : idx = gfc_conv_descriptor_rank_get (decl);
9544 : else
9545 21440 : idx = gfc_rank_cst[rank - 1];
9546 21440 : nelems = gfc_conv_descriptor_ubound_get (decl, idx);
9547 21440 : tmp = gfc_conv_descriptor_lbound_get (decl, idx);
9548 21440 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
9549 : nelems, tmp);
9550 21440 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
9551 : tmp, gfc_index_one_node);
9552 21440 : tmp = gfc_evaluate_now (tmp, block);
9553 :
9554 21440 : nelems = gfc_conv_descriptor_stride_get (decl, idx);
9555 21440 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9556 : nelems, tmp);
9557 21440 : return gfc_evaluate_now (tmp, block);
9558 : }
9559 :
9560 :
9561 : /* Allocate dest to the same size as src, and copy src -> dest.
9562 : If no_malloc is set, only the copy is done. */
9563 :
9564 : static tree
9565 10376 : duplicate_allocatable (tree dest, tree src, tree type, int rank,
9566 : bool no_malloc, bool no_memcpy, tree str_sz,
9567 : tree add_when_allocated)
9568 : {
9569 10376 : tree tmp;
9570 10376 : tree eltype;
9571 10376 : tree size;
9572 10376 : tree nelems;
9573 10376 : tree null_cond;
9574 10376 : tree null_data;
9575 10376 : stmtblock_t block;
9576 :
9577 : /* If the source is null, set the destination to null. Then,
9578 : allocate memory to the destination. */
9579 10376 : gfc_init_block (&block);
9580 :
9581 10376 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
9582 : {
9583 2501 : gfc_add_modify (&block, dest, fold_convert (type, null_pointer_node));
9584 2501 : null_data = gfc_finish_block (&block);
9585 :
9586 2501 : gfc_init_block (&block);
9587 2501 : eltype = TREE_TYPE (type);
9588 2501 : if (str_sz != NULL_TREE)
9589 : size = str_sz;
9590 : else
9591 2133 : size = TYPE_SIZE_UNIT (eltype);
9592 :
9593 2501 : if (!no_malloc)
9594 : {
9595 2501 : tmp = gfc_call_malloc (&block, type, size);
9596 2501 : gfc_add_modify (&block, dest, fold_convert (type, tmp));
9597 : }
9598 :
9599 2501 : if (!no_memcpy)
9600 : {
9601 1718 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
9602 1718 : tmp = build_call_expr_loc (input_location, tmp, 3, dest, src,
9603 : fold_convert (size_type_node, size));
9604 1718 : gfc_add_expr_to_block (&block, tmp);
9605 : }
9606 : }
9607 : else
9608 : {
9609 7875 : gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
9610 7875 : null_data = gfc_finish_block (&block);
9611 :
9612 7875 : gfc_init_block (&block);
9613 7875 : if (rank)
9614 7860 : nelems = gfc_full_array_size (&block, src, rank);
9615 : else
9616 15 : nelems = gfc_index_one_node;
9617 :
9618 : /* If type is not the array type, then it is the element type. */
9619 7875 : if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type))
9620 7845 : eltype = gfc_get_element_type (type);
9621 : else
9622 : eltype = type;
9623 :
9624 7875 : if (str_sz != NULL_TREE)
9625 43 : tmp = fold_convert (gfc_array_index_type, str_sz);
9626 : else
9627 7832 : tmp = fold_convert (gfc_array_index_type,
9628 : TYPE_SIZE_UNIT (eltype));
9629 :
9630 7875 : tmp = gfc_evaluate_now (tmp, &block);
9631 7875 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9632 : nelems, tmp);
9633 7875 : if (!no_malloc)
9634 : {
9635 7807 : tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src));
9636 7807 : tmp = gfc_call_malloc (&block, tmp, size);
9637 7807 : gfc_conv_descriptor_data_set (&block, dest, tmp);
9638 : }
9639 :
9640 : /* We know the temporary and the value will be the same length,
9641 : so can use memcpy. */
9642 7875 : if (!no_memcpy)
9643 : {
9644 6514 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
9645 6514 : tmp = build_call_expr_loc (input_location, tmp, 3,
9646 : gfc_conv_descriptor_data_get (dest),
9647 : gfc_conv_descriptor_data_get (src),
9648 : fold_convert (size_type_node, size));
9649 6514 : gfc_add_expr_to_block (&block, tmp);
9650 : }
9651 : }
9652 :
9653 10376 : gfc_add_expr_to_block (&block, add_when_allocated);
9654 10376 : tmp = gfc_finish_block (&block);
9655 :
9656 : /* Null the destination if the source is null; otherwise do
9657 : the allocate and copy. */
9658 10376 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src)))
9659 : null_cond = src;
9660 : else
9661 7875 : null_cond = gfc_conv_descriptor_data_get (src);
9662 :
9663 10376 : null_cond = convert (pvoid_type_node, null_cond);
9664 10376 : null_cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9665 : null_cond, null_pointer_node);
9666 10376 : return build3_v (COND_EXPR, null_cond, tmp, null_data);
9667 : }
9668 :
9669 :
9670 : /* Allocate dest to the same size as src, and copy data src -> dest. */
9671 :
9672 : tree
9673 7577 : gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank,
9674 : tree add_when_allocated)
9675 : {
9676 7577 : return duplicate_allocatable (dest, src, type, rank, false, false,
9677 7577 : NULL_TREE, add_when_allocated);
9678 : }
9679 :
9680 :
9681 : /* Copy data src -> dest. */
9682 :
9683 : tree
9684 68 : gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
9685 : {
9686 68 : return duplicate_allocatable (dest, src, type, rank, true, false,
9687 68 : NULL_TREE, NULL_TREE);
9688 : }
9689 :
9690 : /* Allocate dest to the same size as src, but don't copy anything. */
9691 :
9692 : tree
9693 2144 : gfc_duplicate_allocatable_nocopy (tree dest, tree src, tree type, int rank)
9694 : {
9695 2144 : return duplicate_allocatable (dest, src, type, rank, false, true,
9696 2144 : NULL_TREE, NULL_TREE);
9697 : }
9698 :
9699 : static tree
9700 62 : duplicate_allocatable_coarray (tree dest, tree dest_tok, tree src, tree type,
9701 : int rank, tree add_when_allocated)
9702 : {
9703 62 : tree tmp;
9704 62 : tree size;
9705 62 : tree nelems;
9706 62 : tree null_cond;
9707 62 : tree null_data;
9708 62 : stmtblock_t block, globalblock;
9709 :
9710 : /* If the source is null, set the destination to null. Then,
9711 : allocate memory to the destination. */
9712 62 : gfc_init_block (&block);
9713 62 : gfc_init_block (&globalblock);
9714 :
9715 62 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
9716 : {
9717 18 : gfc_se se;
9718 18 : symbol_attribute attr;
9719 18 : tree dummy_desc;
9720 :
9721 18 : gfc_init_se (&se, NULL);
9722 18 : gfc_clear_attr (&attr);
9723 18 : attr.allocatable = 1;
9724 18 : dummy_desc = gfc_conv_scalar_to_descriptor (&se, dest, attr);
9725 18 : gfc_add_block_to_block (&globalblock, &se.pre);
9726 18 : size = TYPE_SIZE_UNIT (TREE_TYPE (type));
9727 :
9728 18 : gfc_add_modify (&block, dest, fold_convert (type, null_pointer_node));
9729 18 : gfc_allocate_using_caf_lib (&block, dummy_desc, size,
9730 : gfc_build_addr_expr (NULL_TREE, dest_tok),
9731 : NULL_TREE, NULL_TREE, NULL_TREE,
9732 : GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
9733 18 : gfc_add_modify (&block, dest, gfc_conv_descriptor_data_get (dummy_desc));
9734 18 : null_data = gfc_finish_block (&block);
9735 :
9736 18 : gfc_init_block (&block);
9737 :
9738 18 : gfc_allocate_using_caf_lib (&block, dummy_desc,
9739 : fold_convert (size_type_node, size),
9740 : gfc_build_addr_expr (NULL_TREE, dest_tok),
9741 : NULL_TREE, NULL_TREE, NULL_TREE,
9742 : GFC_CAF_COARRAY_ALLOC);
9743 18 : gfc_add_modify (&block, dest, gfc_conv_descriptor_data_get (dummy_desc));
9744 :
9745 18 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
9746 18 : tmp = build_call_expr_loc (input_location, tmp, 3, dest, src,
9747 : fold_convert (size_type_node, size));
9748 18 : gfc_add_expr_to_block (&block, tmp);
9749 : }
9750 : else
9751 : {
9752 : /* Set the rank or uninitialized memory access may be reported. */
9753 44 : gfc_conv_descriptor_rank_set (&globalblock, dest, rank);
9754 :
9755 44 : if (rank)
9756 44 : nelems = gfc_full_array_size (&globalblock, src, rank);
9757 : else
9758 0 : nelems = integer_one_node;
9759 :
9760 44 : tmp = fold_convert (size_type_node,
9761 : TYPE_SIZE_UNIT (gfc_get_element_type (type)));
9762 44 : size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
9763 : fold_convert (size_type_node, nelems), tmp);
9764 :
9765 44 : gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
9766 44 : gfc_allocate_using_caf_lib (&block, dest, fold_convert (size_type_node,
9767 : size),
9768 : gfc_build_addr_expr (NULL_TREE, dest_tok),
9769 : NULL_TREE, NULL_TREE, NULL_TREE,
9770 : GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
9771 44 : null_data = gfc_finish_block (&block);
9772 :
9773 44 : gfc_init_block (&block);
9774 44 : gfc_allocate_using_caf_lib (&block, dest,
9775 : fold_convert (size_type_node, size),
9776 : gfc_build_addr_expr (NULL_TREE, dest_tok),
9777 : NULL_TREE, NULL_TREE, NULL_TREE,
9778 : GFC_CAF_COARRAY_ALLOC);
9779 :
9780 44 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
9781 44 : tmp = build_call_expr_loc (input_location, tmp, 3,
9782 : gfc_conv_descriptor_data_get (dest),
9783 : gfc_conv_descriptor_data_get (src),
9784 : fold_convert (size_type_node, size));
9785 44 : gfc_add_expr_to_block (&block, tmp);
9786 : }
9787 62 : gfc_add_expr_to_block (&block, add_when_allocated);
9788 62 : tmp = gfc_finish_block (&block);
9789 :
9790 : /* Null the destination if the source is null; otherwise do
9791 : the register and copy. */
9792 62 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src)))
9793 : null_cond = src;
9794 : else
9795 44 : null_cond = gfc_conv_descriptor_data_get (src);
9796 :
9797 62 : null_cond = convert (pvoid_type_node, null_cond);
9798 62 : null_cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9799 : null_cond, null_pointer_node);
9800 62 : gfc_add_expr_to_block (&globalblock, build3_v (COND_EXPR, null_cond, tmp,
9801 : null_data));
9802 62 : return gfc_finish_block (&globalblock);
9803 : }
9804 :
9805 :
9806 : /* Helper function to abstract whether coarray processing is enabled. */
9807 :
9808 : static bool
9809 4221 : caf_enabled (int caf_mode)
9810 : {
9811 4221 : return (caf_mode & GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY)
9812 4221 : == GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY;
9813 : }
9814 :
9815 :
9816 : /* Helper function to abstract whether coarray processing is enabled
9817 : and we are in a derived type coarray. */
9818 :
9819 : static bool
9820 13378 : caf_in_coarray (int caf_mode)
9821 : {
9822 13378 : static const int pat = GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
9823 : | GFC_STRUCTURE_CAF_MODE_IN_COARRAY;
9824 13378 : return (caf_mode & pat) == pat;
9825 : }
9826 :
9827 :
9828 : /* Helper function to abstract whether coarray is to deallocate only. */
9829 :
9830 : bool
9831 392 : gfc_caf_is_dealloc_only (int caf_mode)
9832 : {
9833 392 : return (caf_mode & GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY)
9834 392 : == GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY;
9835 : }
9836 :
9837 :
9838 : /* Recursively traverse an object of derived type, generating code to
9839 : deallocate, nullify or copy allocatable components. This is the work horse
9840 : function for the functions named in this enum. */
9841 :
9842 : enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP,
9843 : COPY_ALLOC_COMP, COPY_ONLY_ALLOC_COMP, REASSIGN_CAF_COMP,
9844 : ALLOCATE_PDT_COMP, DEALLOCATE_PDT_COMP, CHECK_PDT_DUMMY,
9845 : BCAST_ALLOC_COMP};
9846 :
9847 : static gfc_actual_arglist *pdt_param_list;
9848 : static bool generating_copy_helper;
9849 : static hash_set<gfc_symbol *> seen_derived_types;
9850 :
9851 : /* Forward declaration of structure_alloc_comps for wrapper generator. */
9852 : static tree structure_alloc_comps (gfc_symbol *, tree, tree, int, int, int,
9853 : gfc_co_subroutines_args *, bool);
9854 :
9855 : /* Generate a wrapper function that performs element-wise deep copy for
9856 : recursive allocatable array components. This wrapper is passed as a
9857 : function pointer to the runtime helper _gfortran_cfi_deep_copy_array,
9858 : allowing recursion to happen at runtime instead of compile time. */
9859 :
9860 : static tree
9861 475 : get_copy_helper_function_type (void)
9862 : {
9863 475 : static tree fn_type = NULL_TREE;
9864 475 : if (fn_type == NULL_TREE)
9865 93 : fn_type = build_function_type_list (void_type_node,
9866 : pvoid_type_node,
9867 : pvoid_type_node,
9868 : NULL_TREE);
9869 475 : return fn_type;
9870 : }
9871 :
9872 : static tree
9873 1670 : get_copy_helper_pointer_type (void)
9874 : {
9875 1670 : static tree ptr_type = NULL_TREE;
9876 1670 : if (ptr_type == NULL_TREE)
9877 93 : ptr_type = build_pointer_type (get_copy_helper_function_type ());
9878 1670 : return ptr_type;
9879 : }
9880 :
9881 : static tree
9882 382 : generate_element_copy_wrapper (gfc_symbol *der_type, tree comp_type,
9883 : int purpose, int caf_mode)
9884 : {
9885 382 : tree fndecl, fntype, result_decl;
9886 382 : tree dest_parm, src_parm, dest_typed, src_typed;
9887 382 : tree der_type_ptr;
9888 382 : stmtblock_t block;
9889 382 : tree decls;
9890 382 : tree body;
9891 :
9892 382 : fntype = get_copy_helper_function_type ();
9893 :
9894 382 : fndecl = build_decl (input_location, FUNCTION_DECL,
9895 : create_tmp_var_name ("copy_element"),
9896 : fntype);
9897 :
9898 382 : TREE_STATIC (fndecl) = 1;
9899 382 : TREE_USED (fndecl) = 1;
9900 382 : DECL_ARTIFICIAL (fndecl) = 1;
9901 382 : DECL_IGNORED_P (fndecl) = 0;
9902 382 : TREE_PUBLIC (fndecl) = 0;
9903 382 : DECL_UNINLINABLE (fndecl) = 1;
9904 382 : DECL_EXTERNAL (fndecl) = 0;
9905 382 : DECL_CONTEXT (fndecl) = NULL_TREE;
9906 382 : DECL_INITIAL (fndecl) = make_node (BLOCK);
9907 382 : BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
9908 :
9909 382 : result_decl = build_decl (input_location, RESULT_DECL, NULL_TREE,
9910 : void_type_node);
9911 382 : DECL_ARTIFICIAL (result_decl) = 1;
9912 382 : DECL_IGNORED_P (result_decl) = 1;
9913 382 : DECL_CONTEXT (result_decl) = fndecl;
9914 382 : DECL_RESULT (fndecl) = result_decl;
9915 :
9916 382 : dest_parm = build_decl (input_location, PARM_DECL,
9917 : get_identifier ("dest"), pvoid_type_node);
9918 382 : src_parm = build_decl (input_location, PARM_DECL,
9919 : get_identifier ("src"), pvoid_type_node);
9920 :
9921 382 : DECL_ARTIFICIAL (dest_parm) = 1;
9922 382 : DECL_ARTIFICIAL (src_parm) = 1;
9923 382 : DECL_ARG_TYPE (dest_parm) = pvoid_type_node;
9924 382 : DECL_ARG_TYPE (src_parm) = pvoid_type_node;
9925 382 : DECL_CONTEXT (dest_parm) = fndecl;
9926 382 : DECL_CONTEXT (src_parm) = fndecl;
9927 :
9928 382 : DECL_ARGUMENTS (fndecl) = dest_parm;
9929 382 : TREE_CHAIN (dest_parm) = src_parm;
9930 :
9931 382 : push_struct_function (fndecl);
9932 382 : cfun->function_end_locus = input_location;
9933 :
9934 382 : pushlevel ();
9935 382 : gfc_init_block (&block);
9936 :
9937 382 : bool saved_generating = generating_copy_helper;
9938 382 : generating_copy_helper = true;
9939 :
9940 : /* When generating a wrapper, we need a fresh type tracking state to
9941 : avoid inheriting the parent context's seen_derived_types, which would
9942 : cause infinite recursion when the wrapper tries to handle the same
9943 : recursive type. Save elements, clear the set, generate wrapper, then
9944 : restore elements. */
9945 382 : vec<gfc_symbol *> saved_symbols = vNULL;
9946 382 : for (hash_set<gfc_symbol *>::iterator it = seen_derived_types.begin ();
9947 918 : it != seen_derived_types.end (); ++it)
9948 536 : saved_symbols.safe_push (*it);
9949 382 : seen_derived_types.empty ();
9950 :
9951 382 : der_type_ptr = build_pointer_type (comp_type);
9952 382 : dest_typed = fold_convert (der_type_ptr, dest_parm);
9953 382 : src_typed = fold_convert (der_type_ptr, src_parm);
9954 :
9955 382 : dest_typed = build_fold_indirect_ref (dest_typed);
9956 382 : src_typed = build_fold_indirect_ref (src_typed);
9957 :
9958 382 : body = structure_alloc_comps (der_type, src_typed, dest_typed,
9959 : 0, purpose, caf_mode, NULL, false);
9960 382 : gfc_add_expr_to_block (&block, body);
9961 :
9962 : /* Restore saved symbols. */
9963 382 : seen_derived_types.empty ();
9964 918 : for (unsigned i = 0; i < saved_symbols.length (); i++)
9965 536 : seen_derived_types.add (saved_symbols[i]);
9966 382 : saved_symbols.release ();
9967 382 : generating_copy_helper = saved_generating;
9968 :
9969 382 : body = gfc_finish_block (&block);
9970 382 : decls = getdecls ();
9971 :
9972 382 : poplevel (1, 1);
9973 :
9974 764 : DECL_SAVED_TREE (fndecl)
9975 382 : = fold_build3_loc (DECL_SOURCE_LOCATION (fndecl), BIND_EXPR,
9976 382 : void_type_node, decls, body, DECL_INITIAL (fndecl));
9977 :
9978 382 : pop_cfun ();
9979 :
9980 : /* Use finalize_function with no_collect=true to skip the ggc_collect
9981 : call that add_new_function would trigger. This function is called
9982 : during tree lowering of structure_alloc_comps where caller stack
9983 : frames hold locally-computed tree nodes (COMPONENT_REFs etc.) that
9984 : are not yet attached to any GC root. A collection at this point
9985 : would free those nodes and cause segfaults. PR124235. */
9986 382 : cgraph_node::finalize_function (fndecl, true);
9987 :
9988 382 : return build1 (ADDR_EXPR, get_copy_helper_pointer_type (), fndecl);
9989 : }
9990 :
9991 : static tree
9992 26366 : structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
9993 : int rank, int purpose, int caf_mode,
9994 : gfc_co_subroutines_args *args,
9995 : bool no_finalization = false)
9996 : {
9997 26366 : gfc_component *c;
9998 26366 : gfc_loopinfo loop;
9999 26366 : stmtblock_t fnblock;
10000 26366 : stmtblock_t loopbody;
10001 26366 : stmtblock_t tmpblock;
10002 26366 : tree decl_type;
10003 26366 : tree tmp;
10004 26366 : tree comp;
10005 26366 : tree dcmp;
10006 26366 : tree nelems;
10007 26366 : tree index;
10008 26366 : tree var;
10009 26366 : tree cdecl;
10010 26366 : tree ctype;
10011 26366 : tree vref, dref;
10012 26366 : tree null_cond = NULL_TREE;
10013 26366 : tree add_when_allocated;
10014 26366 : tree dealloc_fndecl;
10015 26366 : tree caf_token;
10016 26366 : gfc_symbol *vtab;
10017 26366 : int caf_dereg_mode;
10018 26366 : symbol_attribute *attr;
10019 26366 : bool deallocate_called;
10020 :
10021 26366 : gfc_init_block (&fnblock);
10022 :
10023 26366 : decl_type = TREE_TYPE (decl);
10024 :
10025 26366 : if ((POINTER_TYPE_P (decl_type))
10026 : || (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == 0))
10027 : {
10028 1637 : decl = build_fold_indirect_ref_loc (input_location, decl);
10029 : /* Deref dest in sync with decl, but only when it is not NULL. */
10030 1637 : if (dest)
10031 124 : dest = build_fold_indirect_ref_loc (input_location, dest);
10032 :
10033 : /* Update the decl_type because it got dereferenced. */
10034 1637 : decl_type = TREE_TYPE (decl);
10035 : }
10036 :
10037 : /* If this is an array of derived types with allocatable components
10038 : build a loop and recursively call this function. */
10039 26366 : if (TREE_CODE (decl_type) == ARRAY_TYPE
10040 26366 : || (GFC_DESCRIPTOR_TYPE_P (decl_type) && rank != 0))
10041 : {
10042 4715 : tmp = gfc_conv_array_data (decl);
10043 4715 : var = build_fold_indirect_ref_loc (input_location, tmp);
10044 :
10045 : /* Get the number of elements - 1 and set the counter. */
10046 4715 : if (GFC_DESCRIPTOR_TYPE_P (decl_type))
10047 : {
10048 : /* Use the descriptor for an allocatable array. Since this
10049 : is a full array reference, we only need the descriptor
10050 : information from dimension = rank. */
10051 3439 : tmp = gfc_full_array_size (&fnblock, decl, rank);
10052 3439 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
10053 : gfc_array_index_type, tmp,
10054 : gfc_index_one_node);
10055 :
10056 3439 : null_cond = gfc_conv_descriptor_data_get (decl);
10057 3439 : null_cond = fold_build2_loc (input_location, NE_EXPR,
10058 : logical_type_node, null_cond,
10059 3439 : build_int_cst (TREE_TYPE (null_cond), 0));
10060 : }
10061 : else
10062 : {
10063 : /* Otherwise use the TYPE_DOMAIN information. */
10064 1276 : tmp = array_type_nelts_minus_one (decl_type);
10065 1276 : tmp = fold_convert (gfc_array_index_type, tmp);
10066 : }
10067 :
10068 : /* Remember that this is, in fact, the no. of elements - 1. */
10069 4715 : nelems = gfc_evaluate_now (tmp, &fnblock);
10070 4715 : index = gfc_create_var (gfc_array_index_type, "S");
10071 :
10072 : /* Build the body of the loop. */
10073 4715 : gfc_init_block (&loopbody);
10074 :
10075 4715 : vref = gfc_build_array_ref (var, index, NULL);
10076 :
10077 4715 : if (purpose == COPY_ALLOC_COMP || purpose == COPY_ONLY_ALLOC_COMP)
10078 : {
10079 999 : tmp = build_fold_indirect_ref_loc (input_location,
10080 : gfc_conv_array_data (dest));
10081 999 : dref = gfc_build_array_ref (tmp, index, NULL);
10082 999 : tmp = structure_alloc_comps (der_type, vref, dref, rank,
10083 : COPY_ALLOC_COMP, caf_mode, args,
10084 : no_finalization);
10085 : }
10086 : else
10087 3716 : tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose,
10088 : caf_mode, args, no_finalization);
10089 :
10090 4715 : gfc_add_expr_to_block (&loopbody, tmp);
10091 :
10092 : /* Build the loop and return. */
10093 4715 : gfc_init_loopinfo (&loop);
10094 4715 : loop.dimen = 1;
10095 4715 : loop.from[0] = gfc_index_zero_node;
10096 4715 : loop.loopvar[0] = index;
10097 4715 : loop.to[0] = nelems;
10098 4715 : gfc_trans_scalarizing_loops (&loop, &loopbody);
10099 4715 : gfc_add_block_to_block (&fnblock, &loop.pre);
10100 :
10101 4715 : tmp = gfc_finish_block (&fnblock);
10102 : /* When copying allocateable components, the above implements the
10103 : deep copy. Nevertheless is a deep copy only allowed, when the current
10104 : component is allocated, for which code will be generated in
10105 : gfc_duplicate_allocatable (), where the deep copy code is just added
10106 : into the if's body, by adding tmp (the deep copy code) as last
10107 : argument to gfc_duplicate_allocatable (). */
10108 4715 : if (purpose == COPY_ALLOC_COMP && caf_mode == 0
10109 4715 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
10110 746 : tmp = gfc_duplicate_allocatable (dest, decl, decl_type, rank,
10111 : tmp);
10112 3969 : else if (null_cond != NULL_TREE)
10113 2693 : tmp = build3_v (COND_EXPR, null_cond, tmp,
10114 : build_empty_stmt (input_location));
10115 :
10116 4715 : return tmp;
10117 : }
10118 :
10119 21651 : if (purpose == DEALLOCATE_ALLOC_COMP && der_type->attr.pdt_type)
10120 : {
10121 833 : tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
10122 : DEALLOCATE_PDT_COMP, 0, args,
10123 : no_finalization);
10124 833 : gfc_add_expr_to_block (&fnblock, tmp);
10125 : }
10126 20818 : else if (purpose == ALLOCATE_PDT_COMP && der_type->attr.alloc_comp)
10127 : {
10128 125 : tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
10129 : NULLIFY_ALLOC_COMP, 0, args,
10130 : no_finalization);
10131 125 : gfc_add_expr_to_block (&fnblock, tmp);
10132 : }
10133 :
10134 : /* Still having a descriptor array of rank == 0 here, indicates an
10135 : allocatable coarrays. Dereference it correctly. */
10136 21651 : if (GFC_DESCRIPTOR_TYPE_P (decl_type))
10137 : {
10138 5 : decl = build_fold_indirect_ref (gfc_conv_array_data (decl));
10139 : }
10140 : /* Otherwise, act on the components or recursively call self to
10141 : act on a chain of components. */
10142 21651 : seen_derived_types.add (der_type);
10143 62521 : for (c = der_type->components; c; c = c->next)
10144 : {
10145 40870 : bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED
10146 40870 : || c->ts.type == BT_CLASS)
10147 40870 : && c->ts.u.derived->attr.alloc_comp;
10148 40870 : bool same_type
10149 : = (c->ts.type == BT_DERIVED
10150 10139 : && seen_derived_types.contains (c->ts.u.derived))
10151 47987 : || (c->ts.type == BT_CLASS
10152 2374 : && seen_derived_types.contains (CLASS_DATA (c)->ts.u.derived));
10153 40870 : bool inside_wrapper = generating_copy_helper;
10154 :
10155 40870 : bool is_pdt_type = IS_PDT (c);
10156 :
10157 40870 : cdecl = c->backend_decl;
10158 40870 : ctype = TREE_TYPE (cdecl);
10159 :
10160 40870 : switch (purpose)
10161 : {
10162 :
10163 3 : case BCAST_ALLOC_COMP:
10164 :
10165 3 : tree ubound;
10166 3 : tree cdesc;
10167 3 : stmtblock_t derived_type_block;
10168 :
10169 3 : gfc_init_block (&tmpblock);
10170 :
10171 3 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10172 : decl, cdecl, NULL_TREE);
10173 :
10174 : /* Shortcut to get the attributes of the component. */
10175 3 : if (c->ts.type == BT_CLASS)
10176 : {
10177 0 : attr = &CLASS_DATA (c)->attr;
10178 0 : if (attr->class_pointer)
10179 0 : continue;
10180 : }
10181 : else
10182 : {
10183 3 : attr = &c->attr;
10184 3 : if (attr->pointer)
10185 0 : continue;
10186 : }
10187 :
10188 : /* Do not broadcast a caf_token. These are local to the image. */
10189 3 : if (attr->caf_token)
10190 1 : continue;
10191 :
10192 2 : add_when_allocated = NULL_TREE;
10193 2 : if (cmp_has_alloc_comps
10194 0 : && !c->attr.pointer && !c->attr.proc_pointer)
10195 : {
10196 0 : if (c->ts.type == BT_CLASS)
10197 : {
10198 0 : rank = CLASS_DATA (c)->as ? CLASS_DATA (c)->as->rank : 0;
10199 0 : add_when_allocated
10200 0 : = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
10201 : comp, NULL_TREE, rank, purpose,
10202 : caf_mode, args, no_finalization);
10203 : }
10204 : else
10205 : {
10206 0 : rank = c->as ? c->as->rank : 0;
10207 0 : add_when_allocated = structure_alloc_comps (c->ts.u.derived,
10208 : comp, NULL_TREE,
10209 : rank, purpose,
10210 : caf_mode, args,
10211 : no_finalization);
10212 : }
10213 : }
10214 :
10215 2 : gfc_init_block (&derived_type_block);
10216 2 : if (add_when_allocated)
10217 0 : gfc_add_expr_to_block (&derived_type_block, add_when_allocated);
10218 2 : tmp = gfc_finish_block (&derived_type_block);
10219 2 : gfc_add_expr_to_block (&tmpblock, tmp);
10220 :
10221 : /* Convert the component into a rank 1 descriptor type. */
10222 2 : if (attr->dimension)
10223 : {
10224 0 : tmp = gfc_get_element_type (TREE_TYPE (comp));
10225 0 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
10226 0 : ubound = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (comp));
10227 : else
10228 0 : ubound = gfc_full_array_size (&tmpblock, comp,
10229 0 : c->ts.type == BT_CLASS
10230 0 : ? CLASS_DATA (c)->as->rank
10231 0 : : c->as->rank);
10232 : }
10233 : else
10234 : {
10235 2 : tmp = TREE_TYPE (comp);
10236 2 : ubound = build_int_cst (gfc_array_index_type, 1);
10237 : }
10238 :
10239 : /* Treat strings like arrays. Or the other way around, do not
10240 : * generate an additional array layer for scalar components. */
10241 2 : if (attr->dimension || c->ts.type == BT_CHARACTER)
10242 : {
10243 0 : cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node,
10244 : &ubound, 1,
10245 : GFC_ARRAY_ALLOCATABLE, false);
10246 :
10247 0 : cdesc = gfc_create_var (cdesc, "cdesc");
10248 0 : DECL_ARTIFICIAL (cdesc) = 1;
10249 :
10250 0 : gfc_conv_descriptor_dtype_set (&tmpblock, cdesc,
10251 : gfc_get_dtype_rank_type (1, tmp));
10252 0 : gfc_conv_descriptor_lbound_set (&tmpblock, cdesc,
10253 : gfc_index_zero_node,
10254 : gfc_index_one_node);
10255 0 : gfc_conv_descriptor_stride_set (&tmpblock, cdesc,
10256 : gfc_index_zero_node,
10257 : gfc_index_one_node);
10258 0 : gfc_conv_descriptor_ubound_set (&tmpblock, cdesc,
10259 : gfc_index_zero_node, ubound);
10260 : }
10261 : else
10262 : /* Prevent warning. */
10263 : cdesc = NULL_TREE;
10264 :
10265 2 : if (attr->dimension)
10266 : {
10267 0 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
10268 0 : comp = gfc_conv_descriptor_data_get (comp);
10269 : else
10270 0 : comp = gfc_build_addr_expr (NULL_TREE, comp);
10271 : }
10272 : else
10273 : {
10274 2 : gfc_se se;
10275 :
10276 2 : gfc_init_se (&se, NULL);
10277 :
10278 2 : comp = gfc_conv_scalar_to_descriptor (&se, comp,
10279 2 : c->ts.type == BT_CLASS
10280 2 : ? CLASS_DATA (c)->attr
10281 : : c->attr);
10282 2 : if (c->ts.type == BT_CHARACTER)
10283 0 : comp = gfc_build_addr_expr (NULL_TREE, comp);
10284 2 : gfc_add_block_to_block (&tmpblock, &se.pre);
10285 : }
10286 :
10287 2 : if (attr->dimension || c->ts.type == BT_CHARACTER)
10288 0 : gfc_conv_descriptor_data_set (&tmpblock, cdesc, comp);
10289 : else
10290 2 : cdesc = comp;
10291 :
10292 2 : tree fndecl;
10293 :
10294 2 : fndecl = build_call_expr_loc (input_location,
10295 : gfor_fndecl_co_broadcast, 5,
10296 : gfc_build_addr_expr (pvoid_type_node,cdesc),
10297 : args->image_index,
10298 : null_pointer_node, null_pointer_node,
10299 : null_pointer_node);
10300 :
10301 2 : gfc_add_expr_to_block (&tmpblock, fndecl);
10302 2 : gfc_add_block_to_block (&fnblock, &tmpblock);
10303 :
10304 33288 : break;
10305 :
10306 16067 : case DEALLOCATE_ALLOC_COMP:
10307 :
10308 16067 : gfc_init_block (&tmpblock);
10309 :
10310 16067 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10311 : decl, cdecl, NULL_TREE);
10312 :
10313 : /* Shortcut to get the attributes of the component. */
10314 16067 : if (c->ts.type == BT_CLASS)
10315 : {
10316 1070 : attr = &CLASS_DATA (c)->attr;
10317 1070 : if (attr->class_pointer || c->attr.proc_pointer)
10318 18 : continue;
10319 : }
10320 : else
10321 : {
10322 14997 : attr = &c->attr;
10323 14997 : if (attr->pointer || attr->proc_pointer)
10324 143 : continue;
10325 : }
10326 :
10327 15906 : if (!no_finalization && ((c->ts.type == BT_DERIVED && !c->attr.pointer)
10328 9235 : || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer)))
10329 : /* Call the finalizer, which will free the memory and nullify the
10330 : pointer of an array. */
10331 4146 : deallocate_called = gfc_add_comp_finalizer_call (&tmpblock, comp, c,
10332 : caf_enabled (caf_mode))
10333 4146 : && attr->dimension;
10334 : else
10335 : deallocate_called = false;
10336 :
10337 : /* Add the _class ref for classes. */
10338 15906 : if (c->ts.type == BT_CLASS && attr->allocatable)
10339 1052 : comp = gfc_class_data_get (comp);
10340 :
10341 15906 : add_when_allocated = NULL_TREE;
10342 15906 : if (cmp_has_alloc_comps
10343 3603 : && !c->attr.pointer && !c->attr.proc_pointer
10344 : && !same_type
10345 3603 : && !deallocate_called)
10346 : {
10347 : /* Add checked deallocation of the components. This code is
10348 : obviously added because the finalizer is not trusted to free
10349 : all memory. */
10350 2161 : if (c->ts.type == BT_CLASS)
10351 : {
10352 242 : rank = CLASS_DATA (c)->as ? CLASS_DATA (c)->as->rank : 0;
10353 242 : add_when_allocated
10354 242 : = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
10355 : comp, NULL_TREE, rank, purpose,
10356 : caf_mode, args, no_finalization);
10357 : }
10358 : else
10359 : {
10360 1919 : rank = c->as ? c->as->rank : 0;
10361 1919 : add_when_allocated = structure_alloc_comps (c->ts.u.derived,
10362 : comp, NULL_TREE,
10363 : rank, purpose,
10364 : caf_mode, args,
10365 : no_finalization);
10366 : }
10367 : }
10368 :
10369 10188 : if (attr->allocatable && !same_type
10370 24927 : && (!attr->codimension || caf_enabled (caf_mode)))
10371 : {
10372 : /* Handle all types of components besides components of the
10373 : same_type as the current one, because those would create an
10374 : endless loop. */
10375 51 : caf_dereg_mode = (caf_in_coarray (caf_mode)
10376 58 : && (attr->dimension || c->caf_token))
10377 8957 : || attr->codimension
10378 9092 : ? (gfc_caf_is_dealloc_only (caf_mode)
10379 : ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
10380 : : GFC_CAF_COARRAY_DEREGISTER)
10381 : : GFC_CAF_COARRAY_NOCOARRAY;
10382 :
10383 9014 : caf_token = NULL_TREE;
10384 : /* Coarray components are handled directly by
10385 : deallocate_with_status. */
10386 9014 : if (!attr->codimension
10387 8993 : && caf_dereg_mode != GFC_CAF_COARRAY_NOCOARRAY)
10388 : {
10389 57 : if (c->caf_token)
10390 19 : caf_token
10391 19 : = fold_build3_loc (input_location, COMPONENT_REF,
10392 19 : TREE_TYPE (gfc_comp_caf_token (c)),
10393 : decl, gfc_comp_caf_token (c),
10394 : NULL_TREE);
10395 38 : else if (attr->dimension && !attr->proc_pointer)
10396 38 : caf_token = gfc_conv_descriptor_token (comp);
10397 : }
10398 :
10399 9014 : tmp = gfc_deallocate_with_status (comp, NULL_TREE, NULL_TREE,
10400 : NULL_TREE, NULL_TREE, true,
10401 : NULL, caf_dereg_mode, NULL_TREE,
10402 : add_when_allocated, caf_token);
10403 :
10404 9014 : gfc_add_expr_to_block (&tmpblock, tmp);
10405 : }
10406 6892 : else if (attr->allocatable && !attr->codimension
10407 1167 : && !deallocate_called)
10408 : {
10409 : /* Case of recursive allocatable derived types. */
10410 1167 : tree is_allocated;
10411 1167 : tree ubound;
10412 1167 : tree cdesc;
10413 1167 : stmtblock_t dealloc_block;
10414 :
10415 1167 : gfc_init_block (&dealloc_block);
10416 1167 : if (add_when_allocated)
10417 0 : gfc_add_expr_to_block (&dealloc_block, add_when_allocated);
10418 :
10419 : /* Convert the component into a rank 1 descriptor type. */
10420 1167 : if (attr->dimension)
10421 : {
10422 417 : tmp = gfc_get_element_type (TREE_TYPE (comp));
10423 417 : ubound = gfc_full_array_size (&dealloc_block, comp,
10424 417 : c->ts.type == BT_CLASS
10425 0 : ? CLASS_DATA (c)->as->rank
10426 417 : : c->as->rank);
10427 : }
10428 : else
10429 : {
10430 750 : tmp = TREE_TYPE (comp);
10431 750 : ubound = build_int_cst (gfc_array_index_type, 1);
10432 : }
10433 :
10434 1167 : cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node,
10435 : &ubound, 1,
10436 : GFC_ARRAY_ALLOCATABLE, false);
10437 :
10438 1167 : cdesc = gfc_create_var (cdesc, "cdesc");
10439 1167 : DECL_ARTIFICIAL (cdesc) = 1;
10440 :
10441 1167 : gfc_conv_descriptor_dtype_set (&dealloc_block, cdesc,
10442 : gfc_get_dtype_rank_type (1, tmp));
10443 1167 : gfc_conv_descriptor_lbound_set (&dealloc_block, cdesc,
10444 : gfc_index_zero_node,
10445 : gfc_index_one_node);
10446 1167 : gfc_conv_descriptor_stride_set (&dealloc_block, cdesc,
10447 : gfc_index_zero_node,
10448 : gfc_index_one_node);
10449 1167 : gfc_conv_descriptor_ubound_set (&dealloc_block, cdesc,
10450 : gfc_index_zero_node, ubound);
10451 :
10452 1167 : if (attr->dimension)
10453 417 : comp = gfc_conv_descriptor_data_get (comp);
10454 :
10455 1167 : gfc_conv_descriptor_data_set (&dealloc_block, cdesc, comp);
10456 :
10457 : /* Now call the deallocator. */
10458 1167 : vtab = gfc_find_vtab (&c->ts);
10459 1167 : if (vtab->backend_decl == NULL)
10460 47 : gfc_get_symbol_decl (vtab);
10461 1167 : tmp = gfc_build_addr_expr (NULL_TREE, vtab->backend_decl);
10462 1167 : dealloc_fndecl = gfc_vptr_deallocate_get (tmp);
10463 1167 : dealloc_fndecl = build_fold_indirect_ref_loc (input_location,
10464 : dealloc_fndecl);
10465 1167 : tmp = build_int_cst (TREE_TYPE (comp), 0);
10466 1167 : is_allocated = fold_build2_loc (input_location, NE_EXPR,
10467 : logical_type_node, tmp,
10468 : comp);
10469 1167 : cdesc = gfc_build_addr_expr (NULL_TREE, cdesc);
10470 :
10471 1167 : tmp = build_call_expr_loc (input_location,
10472 : dealloc_fndecl, 1,
10473 : cdesc);
10474 1167 : gfc_add_expr_to_block (&dealloc_block, tmp);
10475 :
10476 1167 : tmp = gfc_finish_block (&dealloc_block);
10477 :
10478 1167 : tmp = fold_build3_loc (input_location, COND_EXPR,
10479 : void_type_node, is_allocated, tmp,
10480 : build_empty_stmt (input_location));
10481 :
10482 1167 : gfc_add_expr_to_block (&tmpblock, tmp);
10483 1167 : }
10484 5725 : else if (add_when_allocated)
10485 1147 : gfc_add_expr_to_block (&tmpblock, add_when_allocated);
10486 :
10487 1052 : if (c->ts.type == BT_CLASS && attr->allocatable
10488 16958 : && (!attr->codimension || !caf_enabled (caf_mode)))
10489 : {
10490 : /* Finally, reset the vptr to the declared type vtable and, if
10491 : necessary reset the _len field.
10492 :
10493 : First recover the reference to the component and obtain
10494 : the vptr. */
10495 1037 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10496 : decl, cdecl, NULL_TREE);
10497 1037 : tmp = gfc_class_vptr_get (comp);
10498 :
10499 1037 : if (UNLIMITED_POLY (c))
10500 : {
10501 : /* Both vptr and _len field should be nulled. */
10502 231 : gfc_add_modify (&tmpblock, tmp,
10503 231 : build_int_cst (TREE_TYPE (tmp), 0));
10504 231 : tmp = gfc_class_len_get (comp);
10505 231 : gfc_add_modify (&tmpblock, tmp,
10506 231 : build_int_cst (TREE_TYPE (tmp), 0));
10507 : }
10508 : else
10509 : {
10510 : /* Build the vtable address and set the vptr with it. */
10511 806 : gfc_reset_vptr (&tmpblock, nullptr, tmp, c->ts.u.derived);
10512 : }
10513 : }
10514 :
10515 : /* Now add the deallocation of this component. */
10516 15906 : gfc_add_block_to_block (&fnblock, &tmpblock);
10517 15906 : break;
10518 :
10519 6167 : case NULLIFY_ALLOC_COMP:
10520 : /* Nullify
10521 : - allocatable components (regular or in class)
10522 : - components that have allocatable components
10523 : - pointer components when in a coarray.
10524 : Skip everything else especially proc_pointers, which may come
10525 : coupled with the regular pointer attribute. */
10526 8285 : if (c->attr.proc_pointer
10527 6167 : || !(c->attr.allocatable || (c->ts.type == BT_CLASS
10528 494 : && CLASS_DATA (c)->attr.allocatable)
10529 2739 : || (cmp_has_alloc_comps
10530 538 : && ((c->ts.type == BT_DERIVED && !c->attr.pointer)
10531 18 : || (c->ts.type == BT_CLASS
10532 12 : && !CLASS_DATA (c)->attr.class_pointer)))
10533 2219 : || (caf_in_coarray (caf_mode) && c->attr.pointer)))
10534 2118 : continue;
10535 :
10536 : /* Process class components first, because they always have the
10537 : pointer-attribute set which would be caught wrong else. */
10538 4049 : if (c->ts.type == BT_CLASS
10539 481 : && (CLASS_DATA (c)->attr.allocatable
10540 0 : || CLASS_DATA (c)->attr.class_pointer))
10541 : {
10542 481 : tree class_ref;
10543 :
10544 : /* Allocatable CLASS components. */
10545 481 : class_ref = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10546 : decl, cdecl, NULL_TREE);
10547 :
10548 481 : comp = gfc_class_data_get (class_ref);
10549 481 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
10550 269 : gfc_conv_descriptor_data_set (&fnblock, comp,
10551 : null_pointer_node);
10552 : else
10553 : {
10554 212 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
10555 : void_type_node, comp,
10556 212 : build_int_cst (TREE_TYPE (comp), 0));
10557 212 : gfc_add_expr_to_block (&fnblock, tmp);
10558 : }
10559 :
10560 : /* The dynamic type of a disassociated pointer or unallocated
10561 : allocatable variable is its declared type. An unlimited
10562 : polymorphic entity has no declared type. */
10563 481 : gfc_reset_vptr (&fnblock, nullptr, class_ref, c->ts.u.derived);
10564 :
10565 481 : cmp_has_alloc_comps = false;
10566 481 : }
10567 : /* Coarrays need the component to be nulled before the api-call
10568 : is made. */
10569 3568 : else if (c->attr.pointer || c->attr.allocatable)
10570 : {
10571 3048 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10572 : decl, cdecl, NULL_TREE);
10573 3048 : if (c->attr.dimension || c->attr.codimension)
10574 2175 : gfc_conv_descriptor_data_set (&fnblock, comp,
10575 : null_pointer_node);
10576 : else
10577 873 : gfc_add_modify (&fnblock, comp,
10578 873 : build_int_cst (TREE_TYPE (comp), 0));
10579 3048 : if (gfc_deferred_strlen (c, &comp))
10580 : {
10581 317 : comp = fold_build3_loc (input_location, COMPONENT_REF,
10582 317 : TREE_TYPE (comp),
10583 : decl, comp, NULL_TREE);
10584 634 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
10585 317 : TREE_TYPE (comp), comp,
10586 317 : build_int_cst (TREE_TYPE (comp), 0));
10587 317 : gfc_add_expr_to_block (&fnblock, tmp);
10588 : }
10589 : cmp_has_alloc_comps = false;
10590 : }
10591 :
10592 4049 : if (flag_coarray == GFC_FCOARRAY_LIB && caf_in_coarray (caf_mode))
10593 : {
10594 : /* Register a component of a derived type coarray with the
10595 : coarray library. Do not register ultimate component
10596 : coarrays here. They are treated like regular coarrays and
10597 : are either allocated on all images or on none. */
10598 132 : tree token;
10599 :
10600 132 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10601 : decl, cdecl, NULL_TREE);
10602 132 : if (c->attr.dimension)
10603 : {
10604 : /* Set the dtype, because caf_register needs it. */
10605 104 : tree dtype_val = gfc_get_dtype (TREE_TYPE (comp));
10606 104 : gfc_conv_descriptor_dtype_set (&fnblock, comp, dtype_val);
10607 104 : tmp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10608 : decl, cdecl, NULL_TREE);
10609 104 : token = gfc_conv_descriptor_token (tmp);
10610 : }
10611 : else
10612 : {
10613 28 : gfc_se se;
10614 :
10615 28 : gfc_init_se (&se, NULL);
10616 56 : token = fold_build3_loc (input_location, COMPONENT_REF,
10617 : pvoid_type_node, decl,
10618 28 : gfc_comp_caf_token (c), NULL_TREE);
10619 28 : comp = gfc_conv_scalar_to_descriptor (&se, comp,
10620 28 : c->ts.type == BT_CLASS
10621 28 : ? CLASS_DATA (c)->attr
10622 : : c->attr);
10623 28 : gfc_add_block_to_block (&fnblock, &se.pre);
10624 : }
10625 :
10626 132 : gfc_allocate_using_caf_lib (&fnblock, comp, size_zero_node,
10627 : gfc_build_addr_expr (NULL_TREE,
10628 : token),
10629 : NULL_TREE, NULL_TREE, NULL_TREE,
10630 : GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
10631 : }
10632 :
10633 4049 : if (cmp_has_alloc_comps)
10634 : {
10635 520 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10636 : decl, cdecl, NULL_TREE);
10637 520 : rank = c->as ? c->as->rank : 0;
10638 520 : tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
10639 : rank, purpose, caf_mode, args,
10640 : no_finalization);
10641 520 : gfc_add_expr_to_block (&fnblock, tmp);
10642 : }
10643 : break;
10644 :
10645 30 : case REASSIGN_CAF_COMP:
10646 30 : if (caf_enabled (caf_mode)
10647 30 : && (c->attr.codimension
10648 23 : || (c->ts.type == BT_CLASS
10649 2 : && (CLASS_DATA (c)->attr.coarray_comp
10650 2 : || caf_in_coarray (caf_mode)))
10651 21 : || (c->ts.type == BT_DERIVED
10652 7 : && (c->ts.u.derived->attr.coarray_comp
10653 6 : || caf_in_coarray (caf_mode))))
10654 46 : && !same_type)
10655 : {
10656 14 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10657 : decl, cdecl, NULL_TREE);
10658 14 : dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10659 : dest, cdecl, NULL_TREE);
10660 :
10661 14 : if (c->attr.codimension)
10662 : {
10663 7 : if (c->ts.type == BT_CLASS)
10664 : {
10665 0 : comp = gfc_class_data_get (comp);
10666 0 : dcmp = gfc_class_data_get (dcmp);
10667 : }
10668 7 : gfc_conv_descriptor_data_set (&fnblock, dcmp,
10669 : gfc_conv_descriptor_data_get (comp));
10670 : }
10671 : else
10672 : {
10673 7 : tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
10674 : rank, purpose, caf_mode
10675 : | GFC_STRUCTURE_CAF_MODE_IN_COARRAY,
10676 : args, no_finalization);
10677 7 : gfc_add_expr_to_block (&fnblock, tmp);
10678 : }
10679 : }
10680 : break;
10681 :
10682 12720 : case COPY_ALLOC_COMP:
10683 12720 : if (c->attr.pointer || c->attr.proc_pointer)
10684 153 : continue;
10685 :
10686 : /* We need source and destination components. */
10687 12567 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl,
10688 : cdecl, NULL_TREE);
10689 12567 : dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, dest,
10690 : cdecl, NULL_TREE);
10691 12567 : dcmp = fold_convert (TREE_TYPE (comp), dcmp);
10692 :
10693 12567 : if (IS_PDT (c) && !c->attr.allocatable)
10694 : {
10695 117 : tmp = gfc_copy_alloc_comp (c->ts.u.derived, comp, dcmp,
10696 : 0, 0);
10697 117 : gfc_add_expr_to_block (&fnblock, tmp);
10698 117 : continue;
10699 : }
10700 :
10701 12450 : if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
10702 : {
10703 780 : tree ftn_tree;
10704 780 : tree size;
10705 780 : tree dst_data;
10706 780 : tree src_data;
10707 780 : tree null_data;
10708 :
10709 780 : dst_data = gfc_class_data_get (dcmp);
10710 780 : src_data = gfc_class_data_get (comp);
10711 780 : size = fold_convert (size_type_node,
10712 : gfc_class_vtab_size_get (comp));
10713 :
10714 780 : if (CLASS_DATA (c)->attr.dimension)
10715 : {
10716 752 : nelems = gfc_conv_descriptor_size (src_data,
10717 376 : CLASS_DATA (c)->as->rank);
10718 376 : size = fold_build2_loc (input_location, MULT_EXPR,
10719 : size_type_node, size,
10720 : fold_convert (size_type_node,
10721 : nelems));
10722 : }
10723 : else
10724 404 : nelems = build_int_cst (size_type_node, 1);
10725 :
10726 780 : if (CLASS_DATA (c)->attr.dimension
10727 404 : || CLASS_DATA (c)->attr.codimension)
10728 : {
10729 384 : src_data = gfc_conv_descriptor_data_get (src_data);
10730 384 : dst_data = gfc_conv_descriptor_data_get (dst_data);
10731 : }
10732 :
10733 780 : gfc_init_block (&tmpblock);
10734 :
10735 780 : gfc_add_modify (&tmpblock, gfc_class_vptr_get (dcmp),
10736 : gfc_class_vptr_get (comp));
10737 :
10738 : /* Copy the unlimited '_len' field. If it is greater than zero
10739 : (ie. a character(_len)), multiply it by size and use this
10740 : for the malloc call. */
10741 780 : if (UNLIMITED_POLY (c))
10742 : {
10743 158 : gfc_add_modify (&tmpblock, gfc_class_len_get (dcmp),
10744 : gfc_class_len_get (comp));
10745 158 : size = gfc_resize_class_size_with_len (&tmpblock, comp, size);
10746 : }
10747 :
10748 : /* Coarray component have to have the same allocation status and
10749 : shape/type-parameter/effective-type on the LHS and RHS of an
10750 : intrinsic assignment. Hence, we did not deallocated them - and
10751 : do not allocate them here. */
10752 780 : if (!CLASS_DATA (c)->attr.codimension)
10753 : {
10754 765 : ftn_tree = builtin_decl_explicit (BUILT_IN_MALLOC);
10755 765 : tmp = build_call_expr_loc (input_location, ftn_tree, 1, size);
10756 765 : gfc_add_modify (&tmpblock, dst_data,
10757 765 : fold_convert (TREE_TYPE (dst_data), tmp));
10758 : }
10759 :
10760 1545 : tmp = gfc_copy_class_to_class (comp, dcmp, nelems,
10761 780 : UNLIMITED_POLY (c));
10762 780 : gfc_add_expr_to_block (&tmpblock, tmp);
10763 780 : tmp = gfc_finish_block (&tmpblock);
10764 :
10765 780 : gfc_init_block (&tmpblock);
10766 780 : gfc_add_modify (&tmpblock, dst_data,
10767 780 : fold_convert (TREE_TYPE (dst_data),
10768 : null_pointer_node));
10769 780 : null_data = gfc_finish_block (&tmpblock);
10770 :
10771 780 : null_cond = fold_build2_loc (input_location, NE_EXPR,
10772 : logical_type_node, src_data,
10773 : null_pointer_node);
10774 :
10775 780 : gfc_add_expr_to_block (&fnblock, build3_v (COND_EXPR, null_cond,
10776 : tmp, null_data));
10777 780 : continue;
10778 780 : }
10779 :
10780 : /* To implement guarded deep copy, i.e., deep copy only allocatable
10781 : components that are really allocated, the deep copy code has to
10782 : be generated first and then added to the if-block in
10783 : gfc_duplicate_allocatable (). */
10784 11670 : if (cmp_has_alloc_comps && !c->attr.proc_pointer && !same_type)
10785 : {
10786 1820 : rank = c->as ? c->as->rank : 0;
10787 1820 : tmp = fold_convert (TREE_TYPE (dcmp), comp);
10788 1820 : gfc_add_modify (&fnblock, dcmp, tmp);
10789 1820 : add_when_allocated = structure_alloc_comps (c->ts.u.derived,
10790 : comp, dcmp,
10791 : rank, purpose,
10792 : caf_mode, args,
10793 : no_finalization);
10794 : }
10795 : else
10796 : add_when_allocated = NULL_TREE;
10797 :
10798 11670 : if (gfc_deferred_strlen (c, &tmp))
10799 : {
10800 411 : tree len, size;
10801 411 : len = tmp;
10802 411 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
10803 411 : TREE_TYPE (len),
10804 : decl, len, NULL_TREE);
10805 411 : len = fold_build3_loc (input_location, COMPONENT_REF,
10806 411 : TREE_TYPE (len),
10807 : dest, len, NULL_TREE);
10808 411 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
10809 411 : TREE_TYPE (len), len, tmp);
10810 411 : gfc_add_expr_to_block (&fnblock, tmp);
10811 411 : size = size_of_string_in_bytes (c->ts.kind, len);
10812 : /* This component cannot have allocatable components,
10813 : therefore add_when_allocated of duplicate_allocatable ()
10814 : is always NULL. */
10815 411 : rank = c->as ? c->as->rank : 0;
10816 411 : tmp = duplicate_allocatable (dcmp, comp, ctype, rank,
10817 : false, false, size, NULL_TREE);
10818 411 : gfc_add_expr_to_block (&fnblock, tmp);
10819 : }
10820 11259 : else if (c->attr.pdt_array
10821 176 : && !c->attr.allocatable && !c->attr.pointer)
10822 : {
10823 176 : tmp = duplicate_allocatable (dcmp, comp, ctype,
10824 176 : c->as ? c->as->rank : 0,
10825 : false, false, NULL_TREE, NULL_TREE);
10826 176 : gfc_add_expr_to_block (&fnblock, tmp);
10827 : }
10828 : /* Special case: recursive allocatable array components require
10829 : runtime helpers to avoid compile-time infinite recursion. Generate
10830 : a call to _gfortran_cfi_deep_copy_array with an element copy
10831 : wrapper. When inside a wrapper, reuse current_function_decl. */
10832 6736 : else if (c->attr.allocatable && cmp_has_alloc_comps && same_type
10833 1288 : && purpose == COPY_ALLOC_COMP && !c->attr.proc_pointer
10834 1288 : && !c->attr.codimension && !caf_in_coarray (caf_mode)
10835 12371 : && c->ts.type == BT_DERIVED && c->ts.u.derived != NULL)
10836 : {
10837 1288 : tree copy_wrapper, call, dest_addr, src_addr, elem_type;
10838 1288 : tree helper_ptr_type;
10839 1288 : tree alloc_expr;
10840 1288 : int comp_rank;
10841 :
10842 : /* Get the element type from ctype (already the component
10843 : type). For arrays we need the element type, not the array
10844 : type. */
10845 1288 : elem_type = ctype;
10846 1288 : if (GFC_DESCRIPTOR_TYPE_P (ctype))
10847 930 : elem_type = gfc_get_element_type (ctype);
10848 358 : else if (TREE_CODE (ctype) == ARRAY_TYPE)
10849 0 : elem_type = TREE_TYPE (ctype);
10850 358 : else if (!c->as)
10851 358 : elem_type = TREE_TYPE (TREE_TYPE (comp));
10852 :
10853 1288 : helper_ptr_type = get_copy_helper_pointer_type ();
10854 :
10855 1288 : comp_rank = c->as ? c->as->rank : 0;
10856 1288 : alloc_expr = gfc_duplicate_allocatable_nocopy (dcmp, comp, ctype,
10857 : comp_rank);
10858 1288 : gfc_add_expr_to_block (&fnblock, alloc_expr);
10859 :
10860 : /* Generate or reuse the element copy helper. Inside an
10861 : existing helper we can reuse the current function to
10862 : prevent recursive generation. */
10863 1288 : if (inside_wrapper)
10864 906 : copy_wrapper
10865 906 : = gfc_build_addr_expr (NULL_TREE, current_function_decl);
10866 : else
10867 382 : copy_wrapper
10868 382 : = generate_element_copy_wrapper (c->ts.u.derived, elem_type,
10869 : purpose, caf_mode);
10870 1288 : copy_wrapper = fold_convert (helper_ptr_type, copy_wrapper);
10871 :
10872 1288 : if (c->as)
10873 : {
10874 : /* Build addresses of descriptors. */
10875 930 : dest_addr = gfc_build_addr_expr (pvoid_type_node, dcmp);
10876 930 : src_addr = gfc_build_addr_expr (pvoid_type_node, comp);
10877 : }
10878 : else
10879 : {
10880 : /* For scalars, create separate descriptors for source and
10881 : dest, then pass their addresses. */
10882 358 : gfc_se se;
10883 358 : gfc_init_se (&se, NULL);
10884 358 : tmp = gfc_conv_scalar_to_descriptor (&se, dcmp, c->attr);
10885 358 : dest_addr = gfc_build_addr_expr (pvoid_type_node, tmp);
10886 358 : tmp = gfc_conv_scalar_to_descriptor (&se, comp, c->attr);
10887 358 : src_addr = gfc_build_addr_expr (pvoid_type_node, tmp);
10888 358 : gfc_add_block_to_block (&fnblock, &se.pre);
10889 : }
10890 :
10891 : /* Build call: _gfortran_cfi_deep_copy_array (&dcmp, &comp, wrapper). */
10892 1288 : call = build_call_expr_loc (input_location,
10893 : gfor_fndecl_cfi_deep_copy_array, 3,
10894 : dest_addr, src_addr,
10895 : copy_wrapper);
10896 :
10897 1288 : gfc_add_expr_to_block (&fnblock, call);
10898 : }
10899 : /* For allocatable arrays with nested allocatable components,
10900 : add_when_allocated already includes gfc_duplicate_allocatable
10901 : (from the recursive structure_alloc_comps call at line 10290-10293),
10902 : so we must not call it again here. PR121628 added an
10903 : add_when_allocated != NULL clause that was redundant for scalars
10904 : (already handled by !c->as) and wrong for arrays (double alloc). */
10905 5448 : else if (c->attr.allocatable && !c->attr.proc_pointer
10906 15243 : && (!cmp_has_alloc_comps
10907 705 : || !c->as
10908 591 : || c->attr.codimension
10909 588 : || caf_in_coarray (caf_mode)))
10910 : {
10911 4866 : rank = c->as ? c->as->rank : 0;
10912 4866 : if (c->attr.codimension)
10913 20 : tmp = gfc_copy_allocatable_data (dcmp, comp, ctype, rank);
10914 4846 : else if (flag_coarray == GFC_FCOARRAY_LIB
10915 4846 : && caf_in_coarray (caf_mode))
10916 : {
10917 62 : tree dst_tok;
10918 62 : if (c->as)
10919 44 : dst_tok = gfc_conv_descriptor_token (dcmp);
10920 : else
10921 : {
10922 18 : dst_tok
10923 18 : = fold_build3_loc (input_location, COMPONENT_REF,
10924 : pvoid_type_node, dest,
10925 18 : gfc_comp_caf_token (c), NULL_TREE);
10926 : }
10927 62 : tmp
10928 62 : = duplicate_allocatable_coarray (dcmp, dst_tok, comp, ctype,
10929 : rank, add_when_allocated);
10930 : }
10931 : else
10932 4784 : tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank,
10933 : add_when_allocated);
10934 4866 : gfc_add_expr_to_block (&fnblock, tmp);
10935 : }
10936 : else
10937 4929 : if (cmp_has_alloc_comps || is_pdt_type)
10938 1853 : gfc_add_expr_to_block (&fnblock, add_when_allocated);
10939 :
10940 : break;
10941 :
10942 1954 : case ALLOCATE_PDT_COMP:
10943 :
10944 1954 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10945 : decl, cdecl, NULL_TREE);
10946 :
10947 : /* Set the PDT KIND and LEN fields. */
10948 1954 : if (c->attr.pdt_kind || c->attr.pdt_len)
10949 : {
10950 895 : gfc_se tse;
10951 895 : gfc_expr *c_expr = NULL;
10952 895 : gfc_actual_arglist *param = pdt_param_list;
10953 895 : gfc_init_se (&tse, NULL);
10954 3219 : for (; param; param = param->next)
10955 1429 : if (param->name && !strcmp (c->name, param->name))
10956 883 : c_expr = param->expr;
10957 :
10958 895 : if (!c_expr)
10959 30 : c_expr = c->initializer;
10960 :
10961 30 : if (c_expr)
10962 : {
10963 877 : gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp));
10964 877 : gfc_add_block_to_block (&fnblock, &tse.pre);
10965 877 : gfc_add_modify (&fnblock, comp, tse.expr);
10966 877 : gfc_add_block_to_block (&fnblock, &tse.post);
10967 : }
10968 895 : }
10969 1059 : else if (c->initializer && !c->attr.pdt_string && !c->attr.pdt_array
10970 145 : && !c->as && !IS_PDT (c)) /* Take care of arrays. */
10971 : {
10972 49 : gfc_se tse;
10973 49 : gfc_expr *c_expr;
10974 49 : gfc_init_se (&tse, NULL);
10975 49 : c_expr = c->initializer;
10976 49 : gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp));
10977 49 : gfc_add_block_to_block (&fnblock, &tse.pre);
10978 49 : gfc_add_modify (&fnblock, comp, tse.expr);
10979 49 : gfc_add_block_to_block (&fnblock, &tse.post);
10980 : }
10981 :
10982 1954 : if (c->attr.pdt_string)
10983 : {
10984 90 : gfc_se tse;
10985 90 : gfc_init_se (&tse, NULL);
10986 90 : tree strlen = NULL_TREE;
10987 90 : gfc_expr *e = gfc_copy_expr (c->ts.u.cl->length);
10988 : /* Convert the parameterized string length to its value. The
10989 : string length is stored in a hidden field in the same way as
10990 : deferred string lengths. */
10991 90 : gfc_insert_parameter_exprs (e, pdt_param_list);
10992 90 : if (gfc_deferred_strlen (c, &strlen) && strlen != NULL_TREE)
10993 : {
10994 90 : gfc_conv_expr_type (&tse, e,
10995 90 : TREE_TYPE (strlen));
10996 90 : strlen = fold_build3_loc (input_location, COMPONENT_REF,
10997 90 : TREE_TYPE (strlen),
10998 : decl, strlen, NULL_TREE);
10999 90 : gfc_add_block_to_block (&fnblock, &tse.pre);
11000 90 : gfc_add_modify (&fnblock, strlen, tse.expr);
11001 90 : gfc_add_block_to_block (&fnblock, &tse.post);
11002 90 : c->ts.u.cl->backend_decl = strlen;
11003 : }
11004 90 : gfc_free_expr (e);
11005 :
11006 : /* Scalar parameterized strings can be allocated now. */
11007 90 : if (!c->as)
11008 : {
11009 90 : tmp = fold_convert (gfc_array_index_type, strlen);
11010 90 : tmp = size_of_string_in_bytes (c->ts.kind, tmp);
11011 90 : tmp = gfc_evaluate_now (tmp, &fnblock);
11012 90 : tmp = gfc_call_malloc (&fnblock, TREE_TYPE (comp), tmp);
11013 90 : gfc_add_modify (&fnblock, comp, tmp);
11014 : }
11015 : }
11016 :
11017 : /* Allocate parameterized arrays of parameterized derived types. */
11018 1954 : if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT)
11019 1673 : && !(IS_PDT (c) || IS_CLASS_PDT (c)))
11020 1487 : continue;
11021 :
11022 467 : if (c->ts.type == BT_CLASS)
11023 0 : comp = gfc_class_data_get (comp);
11024 :
11025 467 : if (c->attr.pdt_array)
11026 : {
11027 281 : gfc_se tse;
11028 281 : int i;
11029 281 : tree size = gfc_index_one_node;
11030 281 : tree offset = gfc_index_zero_node;
11031 281 : tree lower, upper;
11032 281 : gfc_expr *e;
11033 :
11034 : /* This chunk takes the expressions for 'lower' and 'upper'
11035 : in the arrayspec and substitutes in the expressions for
11036 : the parameters from 'pdt_param_list'. The descriptor
11037 : fields can then be filled from the values so obtained. */
11038 281 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)));
11039 664 : for (i = 0; i < c->as->rank; i++)
11040 : {
11041 383 : gfc_init_se (&tse, NULL);
11042 383 : e = gfc_copy_expr (c->as->lower[i]);
11043 383 : gfc_insert_parameter_exprs (e, pdt_param_list);
11044 383 : gfc_conv_expr_type (&tse, e, gfc_array_index_type);
11045 383 : gfc_free_expr (e);
11046 383 : lower = tse.expr;
11047 383 : gfc_add_block_to_block (&fnblock, &tse.pre);
11048 383 : gfc_conv_descriptor_lbound_set (&fnblock, comp,
11049 : gfc_rank_cst[i],
11050 : lower);
11051 383 : gfc_add_block_to_block (&fnblock, &tse.post);
11052 383 : e = gfc_copy_expr (c->as->upper[i]);
11053 383 : gfc_insert_parameter_exprs (e, pdt_param_list);
11054 383 : gfc_conv_expr_type (&tse, e, gfc_array_index_type);
11055 383 : gfc_free_expr (e);
11056 383 : upper = tse.expr;
11057 383 : gfc_add_block_to_block (&fnblock, &tse.pre);
11058 383 : gfc_conv_descriptor_ubound_set (&fnblock, comp,
11059 : gfc_rank_cst[i],
11060 : upper);
11061 383 : gfc_add_block_to_block (&fnblock, &tse.post);
11062 383 : gfc_conv_descriptor_stride_set (&fnblock, comp,
11063 : gfc_rank_cst[i],
11064 : size);
11065 383 : size = gfc_evaluate_now (size, &fnblock);
11066 383 : offset = fold_build2_loc (input_location,
11067 : MINUS_EXPR,
11068 : gfc_array_index_type,
11069 : offset, size);
11070 383 : offset = gfc_evaluate_now (offset, &fnblock);
11071 383 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
11072 : gfc_array_index_type,
11073 : upper, lower);
11074 383 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
11075 : gfc_array_index_type,
11076 : tmp, gfc_index_one_node);
11077 383 : size = fold_build2_loc (input_location, MULT_EXPR,
11078 : gfc_array_index_type, size, tmp);
11079 : }
11080 281 : gfc_conv_descriptor_offset_set (&fnblock, comp, offset);
11081 281 : if (c->ts.type == BT_CLASS)
11082 : {
11083 0 : tmp = gfc_get_vptr_from_expr (comp);
11084 0 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
11085 0 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
11086 0 : tmp = gfc_vptr_size_get (tmp);
11087 : }
11088 : else
11089 281 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (ctype));
11090 281 : tmp = fold_convert (gfc_array_index_type, tmp);
11091 281 : size = fold_build2_loc (input_location, MULT_EXPR,
11092 : gfc_array_index_type, size, tmp);
11093 281 : size = gfc_evaluate_now (size, &fnblock);
11094 281 : tmp = gfc_call_malloc (&fnblock, NULL, size);
11095 281 : gfc_conv_descriptor_data_set (&fnblock, comp, tmp);
11096 281 : gfc_conv_descriptor_dtype_set (&fnblock, comp,
11097 : gfc_get_dtype (ctype));
11098 :
11099 281 : if (c->initializer && c->initializer->rank)
11100 : {
11101 0 : gfc_init_se (&tse, NULL);
11102 0 : e = gfc_copy_expr (c->initializer);
11103 0 : gfc_insert_parameter_exprs (e, pdt_param_list);
11104 0 : gfc_conv_expr_descriptor (&tse, e);
11105 0 : gfc_add_block_to_block (&fnblock, &tse.pre);
11106 0 : gfc_free_expr (e);
11107 0 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
11108 0 : tmp = build_call_expr_loc (input_location, tmp, 3,
11109 : gfc_conv_descriptor_data_get (comp),
11110 : gfc_conv_descriptor_data_get (tse.expr),
11111 : fold_convert (size_type_node, size));
11112 0 : gfc_add_expr_to_block (&fnblock, tmp);
11113 0 : gfc_add_block_to_block (&fnblock, &tse.post);
11114 : }
11115 : }
11116 :
11117 : /* Recurse in to PDT components. */
11118 467 : if ((IS_PDT (c) || IS_CLASS_PDT (c))
11119 200 : && !(c->attr.pointer || c->attr.allocatable))
11120 : {
11121 104 : gfc_actual_arglist *tail = c->param_list;
11122 :
11123 262 : for (; tail; tail = tail->next)
11124 158 : if (tail->expr)
11125 134 : gfc_insert_parameter_exprs (tail->expr, pdt_param_list);
11126 :
11127 104 : tmp = gfc_allocate_pdt_comp (c->ts.u.derived, comp,
11128 104 : c->as ? c->as->rank : 0,
11129 104 : c->param_list);
11130 104 : gfc_add_expr_to_block (&fnblock, tmp);
11131 : }
11132 :
11133 : break;
11134 :
11135 3593 : case DEALLOCATE_PDT_COMP:
11136 : /* Deallocate array or parameterized string length components
11137 : of parameterized derived types. */
11138 3593 : if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT)
11139 3051 : && !c->attr.pdt_string
11140 2943 : && !(IS_PDT (c) || IS_CLASS_PDT (c)))
11141 2479 : continue;
11142 :
11143 1114 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
11144 : decl, cdecl, NULL_TREE);
11145 1114 : if (c->ts.type == BT_CLASS)
11146 0 : comp = gfc_class_data_get (comp);
11147 :
11148 : /* Recurse in to PDT components. */
11149 1114 : if ((IS_PDT (c) || IS_CLASS_PDT (c))
11150 502 : && (!c->attr.pointer && !c->attr.allocatable))
11151 : {
11152 335 : tmp = gfc_deallocate_pdt_comp (c->ts.u.derived, comp,
11153 335 : c->as ? c->as->rank : 0);
11154 335 : gfc_add_expr_to_block (&fnblock, tmp);
11155 : }
11156 :
11157 1114 : if (c->attr.pdt_array || c->attr.pdt_string)
11158 : {
11159 650 : tmp = comp;
11160 650 : if (c->attr.pdt_array)
11161 542 : tmp = gfc_conv_descriptor_data_get (comp);
11162 650 : null_cond = fold_build2_loc (input_location, NE_EXPR,
11163 : logical_type_node, tmp,
11164 650 : build_int_cst (TREE_TYPE (tmp), 0));
11165 650 : if (flag_openmp_allocators)
11166 : {
11167 0 : tree cd, t;
11168 0 : if (c->attr.pdt_array)
11169 : {
11170 0 : tree version_val = gfc_conv_descriptor_version_get (comp);
11171 0 : cd = fold_build2_loc (input_location, EQ_EXPR,
11172 : boolean_type_node, version_val,
11173 : integer_one_node);
11174 : }
11175 : else
11176 0 : cd = gfc_omp_call_is_alloc (tmp);
11177 0 : t = builtin_decl_explicit (BUILT_IN_GOMP_FREE);
11178 0 : t = build_call_expr_loc (input_location, t, 1, tmp);
11179 :
11180 0 : stmtblock_t tblock;
11181 0 : gfc_init_block (&tblock);
11182 0 : gfc_add_expr_to_block (&tblock, t);
11183 0 : if (c->attr.pdt_array)
11184 0 : gfc_conv_descriptor_version_set (&tblock, comp,
11185 : integer_zero_node);
11186 0 : tmp = build3_loc (input_location, COND_EXPR, void_type_node,
11187 : cd, gfc_finish_block (&tblock),
11188 : gfc_call_free (tmp));
11189 : }
11190 : else
11191 650 : tmp = gfc_call_free (tmp);
11192 650 : tmp = build3_v (COND_EXPR, null_cond, tmp,
11193 : build_empty_stmt (input_location));
11194 650 : gfc_add_expr_to_block (&fnblock, tmp);
11195 :
11196 650 : if (c->attr.pdt_array)
11197 542 : gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
11198 : else
11199 : {
11200 108 : tmp = fold_convert (TREE_TYPE (comp), null_pointer_node);
11201 108 : gfc_add_modify (&fnblock, comp, tmp);
11202 : }
11203 : }
11204 :
11205 : break;
11206 :
11207 336 : case CHECK_PDT_DUMMY:
11208 :
11209 336 : comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
11210 : decl, cdecl, NULL_TREE);
11211 336 : if (c->ts.type == BT_CLASS)
11212 0 : comp = gfc_class_data_get (comp);
11213 :
11214 : /* Recurse in to PDT components. */
11215 336 : if (((c->ts.type == BT_DERIVED
11216 14 : && !c->attr.allocatable && !c->attr.pointer)
11217 324 : || (c->ts.type == BT_CLASS
11218 0 : && !CLASS_DATA (c)->attr.allocatable
11219 0 : && !CLASS_DATA (c)->attr.pointer))
11220 12 : && c->ts.u.derived && c->ts.u.derived->attr.pdt_type)
11221 : {
11222 12 : tmp = gfc_check_pdt_dummy (c->ts.u.derived, comp,
11223 12 : c->as ? c->as->rank : 0,
11224 : pdt_param_list);
11225 12 : gfc_add_expr_to_block (&fnblock, tmp);
11226 : }
11227 :
11228 336 : if (!c->attr.pdt_len)
11229 288 : continue;
11230 : else
11231 : {
11232 48 : gfc_se tse;
11233 48 : gfc_expr *c_expr = NULL;
11234 48 : gfc_actual_arglist *param = pdt_param_list;
11235 :
11236 48 : gfc_init_se (&tse, NULL);
11237 186 : for (; param; param = param->next)
11238 90 : if (!strcmp (c->name, param->name)
11239 48 : && param->spec_type == SPEC_EXPLICIT)
11240 30 : c_expr = param->expr;
11241 :
11242 48 : if (c_expr)
11243 : {
11244 30 : tree error, cond, cname;
11245 30 : gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp));
11246 30 : cond = fold_build2_loc (input_location, NE_EXPR,
11247 : logical_type_node,
11248 : comp, tse.expr);
11249 30 : cname = gfc_build_cstring_const (c->name);
11250 30 : cname = gfc_build_addr_expr (pchar_type_node, cname);
11251 30 : error = gfc_trans_runtime_error (true, NULL,
11252 : "The value of the PDT LEN "
11253 : "parameter '%s' does not "
11254 : "agree with that in the "
11255 : "dummy declaration",
11256 : cname);
11257 30 : tmp = fold_build3_loc (input_location, COND_EXPR,
11258 : void_type_node, cond, error,
11259 : build_empty_stmt (input_location));
11260 30 : gfc_add_expr_to_block (&fnblock, tmp);
11261 : }
11262 : }
11263 48 : break;
11264 :
11265 0 : default:
11266 0 : gcc_unreachable ();
11267 7584 : break;
11268 : }
11269 : }
11270 21651 : seen_derived_types.remove (der_type);
11271 :
11272 21651 : return gfc_finish_block (&fnblock);
11273 : }
11274 :
11275 : /* Recursively traverse an object of derived type, generating code to
11276 : nullify allocatable components. */
11277 :
11278 : tree
11279 3138 : gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
11280 : int caf_mode)
11281 : {
11282 3138 : return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11283 : NULLIFY_ALLOC_COMP,
11284 : GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode,
11285 3138 : NULL);
11286 : }
11287 :
11288 :
11289 : /* Recursively traverse an object of derived type, generating code to
11290 : deallocate allocatable components. */
11291 :
11292 : tree
11293 3146 : gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
11294 : int caf_mode, bool no_finalization)
11295 : {
11296 3146 : return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11297 : DEALLOCATE_ALLOC_COMP,
11298 : GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode,
11299 3146 : NULL, no_finalization);
11300 : }
11301 :
11302 : tree
11303 1 : gfc_bcast_alloc_comp (gfc_symbol *derived, gfc_expr *expr, int rank,
11304 : tree image_index, tree stat, tree errmsg,
11305 : tree errmsg_len)
11306 : {
11307 1 : tree tmp, array;
11308 1 : gfc_se argse;
11309 1 : stmtblock_t block, post_block;
11310 1 : gfc_co_subroutines_args args;
11311 :
11312 1 : args.image_index = image_index;
11313 1 : args.stat = stat;
11314 1 : args.errmsg = errmsg;
11315 1 : args.errmsg_len = errmsg_len;
11316 :
11317 1 : if (rank == 0)
11318 : {
11319 1 : gfc_start_block (&block);
11320 1 : gfc_init_block (&post_block);
11321 1 : gfc_init_se (&argse, NULL);
11322 1 : gfc_conv_expr (&argse, expr);
11323 1 : gfc_add_block_to_block (&block, &argse.pre);
11324 1 : gfc_add_block_to_block (&post_block, &argse.post);
11325 1 : array = argse.expr;
11326 : }
11327 : else
11328 : {
11329 0 : gfc_init_se (&argse, NULL);
11330 0 : argse.want_pointer = 1;
11331 0 : gfc_conv_expr_descriptor (&argse, expr);
11332 0 : array = argse.expr;
11333 : }
11334 :
11335 1 : tmp = structure_alloc_comps (derived, array, NULL_TREE, rank,
11336 : BCAST_ALLOC_COMP,
11337 : GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY,
11338 : &args);
11339 1 : return tmp;
11340 : }
11341 :
11342 : /* Recursively traverse an object of derived type, generating code to
11343 : deallocate allocatable components. But do not deallocate coarrays.
11344 : To be used for intrinsic assignment, which may not change the allocation
11345 : status of coarrays. */
11346 :
11347 : tree
11348 3509 : gfc_deallocate_alloc_comp_no_caf (gfc_symbol * der_type, tree decl, int rank,
11349 : bool no_finalization)
11350 : {
11351 3509 : return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11352 : DEALLOCATE_ALLOC_COMP, 0, NULL,
11353 3509 : no_finalization);
11354 : }
11355 :
11356 :
11357 : tree
11358 5 : gfc_reassign_alloc_comp_caf (gfc_symbol *der_type, tree decl, tree dest)
11359 : {
11360 5 : return structure_alloc_comps (der_type, decl, dest, 0, REASSIGN_CAF_COMP,
11361 : GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY,
11362 5 : NULL);
11363 : }
11364 :
11365 :
11366 : /* Recursively traverse an object of derived type, generating code to
11367 : copy it and its allocatable components. */
11368 :
11369 : tree
11370 4592 : gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank,
11371 : int caf_mode)
11372 : {
11373 4592 : return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP,
11374 4592 : caf_mode, NULL);
11375 : }
11376 :
11377 :
11378 : /* Recursively traverse an object of derived type, generating code to
11379 : copy it and its allocatable components, while suppressing any
11380 : finalization that might occur. This is used in the finalization of
11381 : function results. */
11382 :
11383 : tree
11384 38 : gfc_copy_alloc_comp_no_fini (gfc_symbol * der_type, tree decl, tree dest,
11385 : int rank, int caf_mode)
11386 : {
11387 38 : return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP,
11388 38 : caf_mode, NULL, true);
11389 : }
11390 :
11391 :
11392 : /* Recursively traverse an object of derived type, generating code to
11393 : copy only its allocatable components. */
11394 :
11395 : tree
11396 0 : gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
11397 : {
11398 0 : return structure_alloc_comps (der_type, decl, dest, rank,
11399 0 : COPY_ONLY_ALLOC_COMP, 0, NULL);
11400 : }
11401 :
11402 :
11403 : /* Recursively traverse an object of parameterized derived type, generating
11404 : code to allocate parameterized components. */
11405 :
11406 : tree
11407 711 : gfc_allocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank,
11408 : gfc_actual_arglist *param_list)
11409 : {
11410 711 : tree res;
11411 711 : gfc_actual_arglist *old_param_list = pdt_param_list;
11412 711 : pdt_param_list = param_list;
11413 711 : res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11414 : ALLOCATE_PDT_COMP, 0, NULL);
11415 711 : pdt_param_list = old_param_list;
11416 711 : return res;
11417 : }
11418 :
11419 : /* Recursively traverse an object of parameterized derived type, generating
11420 : code to deallocate parameterized components. */
11421 :
11422 : tree
11423 1316 : gfc_deallocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank)
11424 : {
11425 : /* A type without parameterized components causes gimplifier problems. */
11426 1316 : if (!has_parameterized_comps (der_type))
11427 : return NULL_TREE;
11428 :
11429 583 : return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11430 583 : DEALLOCATE_PDT_COMP, 0, NULL);
11431 : }
11432 :
11433 :
11434 : /* Recursively traverse a dummy of parameterized derived type to check the
11435 : values of LEN parameters. */
11436 :
11437 : tree
11438 80 : gfc_check_pdt_dummy (gfc_symbol * der_type, tree decl, int rank,
11439 : gfc_actual_arglist *param_list)
11440 : {
11441 80 : tree res;
11442 80 : gfc_actual_arglist *old_param_list = pdt_param_list;
11443 80 : pdt_param_list = param_list;
11444 80 : res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
11445 : CHECK_PDT_DUMMY, 0, NULL);
11446 80 : pdt_param_list = old_param_list;
11447 80 : return res;
11448 : }
11449 :
11450 :
11451 : /* Returns the value of LBOUND for an expression. This could be broken out
11452 : from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
11453 : called by gfc_alloc_allocatable_for_assignment. */
11454 : static tree
11455 1084 : get_std_lbound (gfc_expr *expr, tree desc, int dim, bool assumed_size)
11456 : {
11457 1084 : tree lbound;
11458 1084 : tree ubound;
11459 1084 : tree stride;
11460 1084 : tree cond, cond1, cond3, cond4;
11461 1084 : tree tmp;
11462 1084 : gfc_ref *ref;
11463 :
11464 1084 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
11465 : {
11466 508 : tmp = gfc_rank_cst[dim];
11467 508 : lbound = gfc_conv_descriptor_lbound_get (desc, tmp);
11468 508 : ubound = gfc_conv_descriptor_ubound_get (desc, tmp);
11469 508 : stride = gfc_conv_descriptor_stride_get (desc, tmp);
11470 508 : cond1 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
11471 : ubound, lbound);
11472 508 : cond3 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
11473 : stride, gfc_index_zero_node);
11474 508 : cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
11475 : logical_type_node, cond3, cond1);
11476 508 : cond4 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
11477 : stride, gfc_index_zero_node);
11478 508 : if (assumed_size)
11479 0 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
11480 : tmp, build_int_cst (gfc_array_index_type,
11481 0 : expr->rank - 1));
11482 : else
11483 508 : cond = logical_false_node;
11484 :
11485 508 : cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
11486 : logical_type_node, cond3, cond4);
11487 508 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
11488 : logical_type_node, cond, cond1);
11489 :
11490 508 : return fold_build3_loc (input_location, COND_EXPR,
11491 : gfc_array_index_type, cond,
11492 508 : lbound, gfc_index_one_node);
11493 : }
11494 :
11495 576 : if (expr->expr_type == EXPR_FUNCTION)
11496 : {
11497 : /* A conversion function, so use the argument. */
11498 7 : gcc_assert (expr->value.function.isym
11499 : && expr->value.function.isym->conversion);
11500 7 : expr = expr->value.function.actual->expr;
11501 : }
11502 :
11503 576 : if (expr->expr_type == EXPR_VARIABLE)
11504 : {
11505 576 : tmp = TREE_TYPE (expr->symtree->n.sym->backend_decl);
11506 1496 : for (ref = expr->ref; ref; ref = ref->next)
11507 : {
11508 920 : if (ref->type == REF_COMPONENT
11509 295 : && ref->u.c.component->as
11510 246 : && ref->next
11511 246 : && ref->next->u.ar.type == AR_FULL)
11512 204 : tmp = TREE_TYPE (ref->u.c.component->backend_decl);
11513 : }
11514 576 : return GFC_TYPE_ARRAY_LBOUND(tmp, dim);
11515 : }
11516 :
11517 0 : return gfc_index_one_node;
11518 : }
11519 :
11520 :
11521 : /* Returns true if an expression represents an lhs that can be reallocated
11522 : on assignment. */
11523 :
11524 : bool
11525 638412 : gfc_is_reallocatable_lhs (gfc_expr *expr)
11526 : {
11527 638412 : gfc_ref * ref;
11528 638412 : gfc_symbol *sym;
11529 :
11530 638412 : if (!flag_realloc_lhs)
11531 : return false;
11532 :
11533 637912 : if (!expr->ref)
11534 : return false;
11535 :
11536 214728 : sym = expr->symtree->n.sym;
11537 :
11538 214728 : if (sym->attr.associate_var && !expr->ref)
11539 : return false;
11540 :
11541 : /* An allocatable class variable with no reference. */
11542 214728 : if (sym->ts.type == BT_CLASS
11543 6721 : && (!sym->attr.associate_var || sym->attr.select_rank_temporary)
11544 6561 : && CLASS_DATA (sym)->attr.allocatable
11545 : && expr->ref
11546 4023 : && ((expr->ref->type == REF_ARRAY && expr->ref->u.ar.type == AR_FULL
11547 703 : && expr->ref->next == NULL)
11548 3393 : || (expr->ref->type == REF_COMPONENT
11549 3052 : && strcmp (expr->ref->u.c.component->name, "_data") == 0
11550 2171 : && (expr->ref->next == NULL
11551 2171 : || (expr->ref->next->type == REF_ARRAY
11552 2171 : && expr->ref->next->u.ar.type == AR_FULL
11553 1749 : && expr->ref->next->next == NULL)))))
11554 : return true;
11555 :
11556 : /* An allocatable variable. */
11557 212489 : if (sym->attr.allocatable
11558 46632 : && (!sym->attr.associate_var || sym->attr.select_rank_temporary)
11559 : && expr->ref
11560 46632 : && expr->ref->type == REF_ARRAY
11561 45137 : && expr->ref->u.ar.type == AR_FULL)
11562 : return true;
11563 :
11564 : /* All that can be left are allocatable components. */
11565 184605 : if (sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
11566 : return false;
11567 :
11568 : /* Find a component ref followed by an array reference. */
11569 90587 : for (ref = expr->ref; ref; ref = ref->next)
11570 63460 : if (ref->next
11571 36333 : && ref->type == REF_COMPONENT
11572 20794 : && ref->next->type == REF_ARRAY
11573 17083 : && !ref->next->next)
11574 : break;
11575 :
11576 39953 : if (!ref)
11577 : return false;
11578 :
11579 : /* Return true if valid reallocatable lhs. */
11580 12826 : if (ref->u.c.component->attr.allocatable
11581 6426 : && ref->next->u.ar.type == AR_FULL)
11582 4812 : return true;
11583 :
11584 : return false;
11585 : }
11586 :
11587 :
11588 : static tree
11589 56 : concat_str_length (gfc_expr* expr)
11590 : {
11591 56 : tree type;
11592 56 : tree len1;
11593 56 : tree len2;
11594 56 : gfc_se se;
11595 :
11596 56 : type = gfc_typenode_for_spec (&expr->value.op.op1->ts);
11597 56 : len1 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
11598 56 : if (len1 == NULL_TREE)
11599 : {
11600 56 : if (expr->value.op.op1->expr_type == EXPR_OP)
11601 31 : len1 = concat_str_length (expr->value.op.op1);
11602 25 : else if (expr->value.op.op1->expr_type == EXPR_CONSTANT)
11603 25 : len1 = build_int_cst (gfc_charlen_type_node,
11604 25 : expr->value.op.op1->value.character.length);
11605 0 : else if (expr->value.op.op1->ts.u.cl->length)
11606 : {
11607 0 : gfc_init_se (&se, NULL);
11608 0 : gfc_conv_expr (&se, expr->value.op.op1->ts.u.cl->length);
11609 0 : len1 = se.expr;
11610 : }
11611 : else
11612 : {
11613 : /* Last resort! */
11614 0 : gfc_init_se (&se, NULL);
11615 0 : se.want_pointer = 1;
11616 0 : se.descriptor_only = 1;
11617 0 : gfc_conv_expr (&se, expr->value.op.op1);
11618 0 : len1 = se.string_length;
11619 : }
11620 : }
11621 :
11622 56 : type = gfc_typenode_for_spec (&expr->value.op.op2->ts);
11623 56 : len2 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
11624 56 : if (len2 == NULL_TREE)
11625 : {
11626 31 : if (expr->value.op.op2->expr_type == EXPR_OP)
11627 0 : len2 = concat_str_length (expr->value.op.op2);
11628 31 : else if (expr->value.op.op2->expr_type == EXPR_CONSTANT)
11629 25 : len2 = build_int_cst (gfc_charlen_type_node,
11630 25 : expr->value.op.op2->value.character.length);
11631 6 : else if (expr->value.op.op2->ts.u.cl->length)
11632 : {
11633 6 : gfc_init_se (&se, NULL);
11634 6 : gfc_conv_expr (&se, expr->value.op.op2->ts.u.cl->length);
11635 6 : len2 = se.expr;
11636 : }
11637 : else
11638 : {
11639 : /* Last resort! */
11640 0 : gfc_init_se (&se, NULL);
11641 0 : se.want_pointer = 1;
11642 0 : se.descriptor_only = 1;
11643 0 : gfc_conv_expr (&se, expr->value.op.op2);
11644 0 : len2 = se.string_length;
11645 : }
11646 : }
11647 :
11648 56 : gcc_assert(len1 && len2);
11649 56 : len1 = fold_convert (gfc_charlen_type_node, len1);
11650 56 : len2 = fold_convert (gfc_charlen_type_node, len2);
11651 :
11652 56 : return fold_build2_loc (input_location, PLUS_EXPR,
11653 56 : gfc_charlen_type_node, len1, len2);
11654 : }
11655 :
11656 :
11657 : /* Among the scalarization chain of LOOP, find the element associated with an
11658 : allocatable array on the lhs of an assignment and evaluate its fields
11659 : (bounds, offset, etc) to new variables, putting the new code in BLOCK. This
11660 : function is to be called after putting the reallocation code in BLOCK and
11661 : before the beginning of the scalarization loop body.
11662 :
11663 : The fields to be saved are expected to hold on entry to the function
11664 : expressions referencing the array descriptor. Especially the expressions
11665 : shouldn't be already temporary variable references as the value saved before
11666 : reallocation would be incorrect after reallocation.
11667 : At the end of the function, the expressions have been replaced with variable
11668 : references. */
11669 :
11670 : static void
11671 6716 : update_reallocated_descriptor (stmtblock_t *block, gfc_loopinfo *loop)
11672 : {
11673 23416 : for (gfc_ss *s = loop->ss; s != gfc_ss_terminator; s = s->loop_chain)
11674 : {
11675 16700 : if (!s->is_alloc_lhs)
11676 9984 : continue;
11677 :
11678 6716 : gcc_assert (s->info->type == GFC_SS_SECTION);
11679 6716 : gfc_array_info *info = &s->info->data.array;
11680 :
11681 : #define SAVE_VALUE(value) \
11682 : do \
11683 : { \
11684 : value = gfc_evaluate_now (value, block); \
11685 : } \
11686 : while (0)
11687 :
11688 6716 : if (save_descriptor_data (info->descriptor, info->data))
11689 5876 : SAVE_VALUE (info->data);
11690 6716 : SAVE_VALUE (info->offset);
11691 6716 : info->saved_offset = info->offset;
11692 16637 : for (int i = 0; i < s->dimen; i++)
11693 : {
11694 9921 : int dim = s->dim[i];
11695 9921 : SAVE_VALUE (info->start[dim]);
11696 9921 : SAVE_VALUE (info->end[dim]);
11697 9921 : SAVE_VALUE (info->stride[dim]);
11698 9921 : SAVE_VALUE (info->delta[dim]);
11699 : }
11700 :
11701 : #undef SAVE_VALUE
11702 : }
11703 6716 : }
11704 :
11705 :
11706 : /* Allocate the lhs of an assignment to an allocatable array, otherwise
11707 : reallocate it. */
11708 :
11709 : tree
11710 6716 : gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
11711 : gfc_expr *expr1,
11712 : gfc_expr *expr2)
11713 : {
11714 6716 : stmtblock_t realloc_block;
11715 6716 : stmtblock_t alloc_block;
11716 6716 : stmtblock_t fblock;
11717 6716 : stmtblock_t loop_pre_block;
11718 6716 : gfc_ref *ref;
11719 6716 : gfc_ss *rss;
11720 6716 : gfc_ss *lss;
11721 6716 : gfc_array_info *linfo;
11722 6716 : tree realloc_expr;
11723 6716 : tree alloc_expr;
11724 6716 : tree size1;
11725 6716 : tree size2;
11726 6716 : tree elemsize1;
11727 6716 : tree elemsize2;
11728 6716 : tree array1;
11729 6716 : tree cond_null;
11730 6716 : tree cond;
11731 6716 : tree tmp;
11732 6716 : tree tmp2;
11733 6716 : tree lbound;
11734 6716 : tree ubound;
11735 6716 : tree desc;
11736 6716 : tree old_desc;
11737 6716 : tree desc2;
11738 6716 : tree offset;
11739 6716 : tree jump_label1;
11740 6716 : tree jump_label2;
11741 6716 : tree lbd;
11742 6716 : tree class_expr2 = NULL_TREE;
11743 6716 : int n;
11744 6716 : gfc_array_spec * as;
11745 6716 : bool coarray = (flag_coarray == GFC_FCOARRAY_LIB
11746 6716 : && gfc_caf_attr (expr1, true).codimension);
11747 6716 : tree token;
11748 6716 : gfc_se caf_se;
11749 :
11750 : /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
11751 : Find the lhs expression in the loop chain and set expr1 and
11752 : expr2 accordingly. */
11753 6716 : if (expr1->expr_type == EXPR_FUNCTION && expr2 == NULL)
11754 : {
11755 203 : expr2 = expr1;
11756 : /* Find the ss for the lhs. */
11757 203 : lss = loop->ss;
11758 406 : for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
11759 406 : if (lss->info->expr && lss->info->expr->expr_type == EXPR_VARIABLE)
11760 : break;
11761 203 : if (lss == gfc_ss_terminator)
11762 : return NULL_TREE;
11763 203 : expr1 = lss->info->expr;
11764 : }
11765 :
11766 : /* Bail out if this is not a valid allocate on assignment. */
11767 6716 : if (!gfc_is_reallocatable_lhs (expr1)
11768 6716 : || (expr2 && !expr2->rank))
11769 : return NULL_TREE;
11770 :
11771 : /* Find the ss for the lhs. */
11772 6716 : lss = loop->ss;
11773 16700 : for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
11774 16700 : if (lss->info->expr == expr1)
11775 : break;
11776 :
11777 6716 : if (lss == gfc_ss_terminator)
11778 : return NULL_TREE;
11779 :
11780 6716 : linfo = &lss->info->data.array;
11781 :
11782 : /* Find an ss for the rhs. For operator expressions, we see the
11783 : ss's for the operands. Any one of these will do. */
11784 6716 : rss = loop->ss;
11785 7320 : for (; rss && rss != gfc_ss_terminator; rss = rss->loop_chain)
11786 7320 : if (rss->info->expr != expr1 && rss != loop->temp_ss)
11787 : break;
11788 :
11789 6716 : if (expr2 && rss == gfc_ss_terminator)
11790 : return NULL_TREE;
11791 :
11792 : /* Ensure that the string length from the current scope is used. */
11793 6716 : if (expr2->ts.type == BT_CHARACTER
11794 983 : && expr2->expr_type == EXPR_FUNCTION
11795 130 : && !expr2->value.function.isym)
11796 21 : expr2->ts.u.cl->backend_decl = rss->info->string_length;
11797 :
11798 : /* Since the lhs is allocatable, this must be a descriptor type.
11799 : Get the data and array size. */
11800 6716 : desc = linfo->descriptor;
11801 6716 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
11802 6716 : array1 = gfc_conv_descriptor_data_get (desc);
11803 :
11804 : /* If the data is null, set the descriptor bounds and offset. This suppresses
11805 : the maybe used uninitialized warning. Note that the always false variable
11806 : prevents this block from ever being executed, and makes sure that the
11807 : optimizers are able to remove it. Component references are not subject to
11808 : the warnings, so we don't uselessly complicate the generated code for them.
11809 : */
11810 11948 : for (ref = expr1->ref; ref; ref = ref->next)
11811 6923 : if (ref->type == REF_COMPONENT)
11812 : break;
11813 :
11814 6716 : if (!ref)
11815 : {
11816 5025 : stmtblock_t unalloc_init_block;
11817 5025 : gfc_init_block (&unalloc_init_block);
11818 5025 : tree guard = gfc_create_var (logical_type_node, "unallocated_init_guard");
11819 5025 : gfc_add_modify (&unalloc_init_block, guard, logical_false_node);
11820 :
11821 5025 : gfc_start_block (&loop_pre_block);
11822 17923 : for (n = 0; n < expr1->rank; n++)
11823 : {
11824 7873 : gfc_conv_descriptor_lbound_set (&loop_pre_block, desc,
11825 : gfc_rank_cst[n],
11826 : gfc_index_one_node);
11827 7873 : gfc_conv_descriptor_ubound_set (&loop_pre_block, desc,
11828 : gfc_rank_cst[n],
11829 : gfc_index_zero_node);
11830 7873 : gfc_conv_descriptor_stride_set (&loop_pre_block, desc,
11831 : gfc_rank_cst[n],
11832 : gfc_index_zero_node);
11833 : }
11834 :
11835 5025 : gfc_conv_descriptor_offset_set (&loop_pre_block, desc,
11836 : gfc_index_zero_node);
11837 :
11838 5025 : tmp = fold_build2_loc (input_location, EQ_EXPR,
11839 : logical_type_node, array1,
11840 5025 : build_int_cst (TREE_TYPE (array1), 0));
11841 5025 : tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
11842 : logical_type_node, tmp, guard);
11843 5025 : tmp = build3_v (COND_EXPR, tmp,
11844 : gfc_finish_block (&loop_pre_block),
11845 : build_empty_stmt (input_location));
11846 5025 : gfc_prepend_expr_to_block (&loop->pre, tmp);
11847 5025 : gfc_prepend_expr_to_block (&loop->pre,
11848 : gfc_finish_block (&unalloc_init_block));
11849 : }
11850 :
11851 6716 : gfc_start_block (&fblock);
11852 :
11853 6716 : if (expr2)
11854 6716 : desc2 = rss->info->data.array.descriptor;
11855 : else
11856 : desc2 = NULL_TREE;
11857 :
11858 : /* Get the old lhs element size for deferred character and class expr1. */
11859 6716 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
11860 : {
11861 663 : if (expr1->ts.u.cl->backend_decl
11862 663 : && VAR_P (expr1->ts.u.cl->backend_decl))
11863 : elemsize1 = expr1->ts.u.cl->backend_decl;
11864 : else
11865 64 : elemsize1 = lss->info->string_length;
11866 663 : tree unit_size = TYPE_SIZE_UNIT (gfc_get_char_type (expr1->ts.kind));
11867 1326 : elemsize1 = fold_build2_loc (input_location, MULT_EXPR,
11868 663 : TREE_TYPE (elemsize1), elemsize1,
11869 663 : fold_convert (TREE_TYPE (elemsize1), unit_size));
11870 :
11871 663 : }
11872 6053 : else if (expr1->ts.type == BT_CLASS)
11873 : {
11874 : /* Unfortunately, the lhs vptr is set too early in many cases.
11875 : Play it safe by using the descriptor element length. */
11876 669 : tmp = gfc_conv_descriptor_elem_len_get (desc);
11877 669 : elemsize1 = fold_convert (gfc_array_index_type, tmp);
11878 : }
11879 : else
11880 : elemsize1 = NULL_TREE;
11881 1332 : if (elemsize1 != NULL_TREE)
11882 1332 : elemsize1 = gfc_evaluate_now (elemsize1, &fblock);
11883 :
11884 : /* Get the new lhs size in bytes. */
11885 6716 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
11886 : {
11887 663 : if (expr2->ts.deferred)
11888 : {
11889 183 : if (expr2->ts.u.cl->backend_decl
11890 183 : && VAR_P (expr2->ts.u.cl->backend_decl))
11891 : tmp = expr2->ts.u.cl->backend_decl;
11892 : else
11893 0 : tmp = rss->info->string_length;
11894 : }
11895 : else
11896 : {
11897 480 : tmp = expr2->ts.u.cl->backend_decl;
11898 480 : if (!tmp && expr2->expr_type == EXPR_OP
11899 25 : && expr2->value.op.op == INTRINSIC_CONCAT)
11900 : {
11901 25 : tmp = concat_str_length (expr2);
11902 25 : expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
11903 : }
11904 12 : else if (!tmp && expr2->ts.u.cl->length)
11905 : {
11906 12 : gfc_se tmpse;
11907 12 : gfc_init_se (&tmpse, NULL);
11908 12 : gfc_conv_expr_type (&tmpse, expr2->ts.u.cl->length,
11909 : gfc_charlen_type_node);
11910 12 : tmp = tmpse.expr;
11911 12 : expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
11912 : }
11913 480 : tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
11914 : }
11915 :
11916 663 : if (expr1->ts.u.cl->backend_decl
11917 663 : && VAR_P (expr1->ts.u.cl->backend_decl))
11918 599 : gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
11919 : else
11920 64 : gfc_add_modify (&fblock, lss->info->string_length, tmp);
11921 :
11922 663 : if (expr1->ts.kind > 1)
11923 12 : tmp = fold_build2_loc (input_location, MULT_EXPR,
11924 6 : TREE_TYPE (tmp),
11925 6 : tmp, build_int_cst (TREE_TYPE (tmp),
11926 6 : expr1->ts.kind));
11927 : }
11928 6053 : else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
11929 : {
11930 271 : tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts)));
11931 271 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
11932 : fold_convert (gfc_array_index_type, tmp),
11933 271 : expr1->ts.u.cl->backend_decl);
11934 : }
11935 5782 : else if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS)
11936 164 : tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
11937 5618 : else if (expr1->ts.type == BT_CLASS && expr2->ts.type == BT_CLASS)
11938 : {
11939 298 : tmp = expr2->rank ? gfc_get_class_from_expr (desc2) : NULL_TREE;
11940 298 : if (tmp == NULL_TREE && expr2->expr_type == EXPR_VARIABLE)
11941 54 : tmp = class_expr2 = gfc_get_class_from_gfc_expr (expr2);
11942 :
11943 61 : if (tmp != NULL_TREE)
11944 291 : tmp = gfc_class_vtab_size_get (tmp);
11945 : else
11946 7 : tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&CLASS_DATA (expr2)->ts));
11947 : }
11948 : else
11949 5320 : tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
11950 6716 : elemsize2 = fold_convert (gfc_array_index_type, tmp);
11951 6716 : elemsize2 = gfc_evaluate_now (elemsize2, &fblock);
11952 :
11953 : /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
11954 : deallocated if expr is an array of different shape or any of the
11955 : corresponding length type parameter values of variable and expr
11956 : differ." This assures F95 compatibility. */
11957 6716 : jump_label1 = gfc_build_label_decl (NULL_TREE);
11958 6716 : jump_label2 = gfc_build_label_decl (NULL_TREE);
11959 :
11960 : /* Allocate if data is NULL. */
11961 6716 : cond_null = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
11962 6716 : array1, build_int_cst (TREE_TYPE (array1), 0));
11963 6716 : cond_null= gfc_evaluate_now (cond_null, &fblock);
11964 :
11965 6716 : tmp = build3_v (COND_EXPR, cond_null,
11966 : build1_v (GOTO_EXPR, jump_label1),
11967 : build_empty_stmt (input_location));
11968 6716 : gfc_add_expr_to_block (&fblock, tmp);
11969 :
11970 : /* Get arrayspec if expr is a full array. */
11971 6716 : if (expr2 && expr2->expr_type == EXPR_FUNCTION
11972 2814 : && expr2->value.function.isym
11973 2295 : && expr2->value.function.isym->conversion)
11974 : {
11975 : /* For conversion functions, take the arg. */
11976 245 : gfc_expr *arg = expr2->value.function.actual->expr;
11977 245 : as = gfc_get_full_arrayspec_from_expr (arg);
11978 245 : }
11979 : else if (expr2)
11980 6471 : as = gfc_get_full_arrayspec_from_expr (expr2);
11981 : else
11982 : as = NULL;
11983 :
11984 : /* If the lhs shape is not the same as the rhs jump to setting the
11985 : bounds and doing the reallocation....... */
11986 16637 : for (n = 0; n < expr1->rank; n++)
11987 : {
11988 : /* Check the shape. */
11989 9921 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
11990 9921 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
11991 9921 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
11992 : gfc_array_index_type,
11993 : loop->to[n], loop->from[n]);
11994 9921 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
11995 : gfc_array_index_type,
11996 : tmp, lbound);
11997 9921 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
11998 : gfc_array_index_type,
11999 : tmp, ubound);
12000 9921 : cond = fold_build2_loc (input_location, NE_EXPR,
12001 : logical_type_node,
12002 : tmp, gfc_index_zero_node);
12003 9921 : tmp = build3_v (COND_EXPR, cond,
12004 : build1_v (GOTO_EXPR, jump_label1),
12005 : build_empty_stmt (input_location));
12006 9921 : gfc_add_expr_to_block (&fblock, tmp);
12007 : }
12008 :
12009 : /* ...else if the element lengths are not the same also go to
12010 : setting the bounds and doing the reallocation.... */
12011 6716 : if (elemsize1 != NULL_TREE)
12012 : {
12013 1332 : cond = fold_build2_loc (input_location, NE_EXPR,
12014 : logical_type_node,
12015 : elemsize1, elemsize2);
12016 1332 : tmp = build3_v (COND_EXPR, cond,
12017 : build1_v (GOTO_EXPR, jump_label1),
12018 : build_empty_stmt (input_location));
12019 1332 : gfc_add_expr_to_block (&fblock, tmp);
12020 : }
12021 :
12022 : /* ....else jump past the (re)alloc code. */
12023 6716 : tmp = build1_v (GOTO_EXPR, jump_label2);
12024 6716 : gfc_add_expr_to_block (&fblock, tmp);
12025 :
12026 : /* Add the label to start automatic (re)allocation. */
12027 6716 : tmp = build1_v (LABEL_EXPR, jump_label1);
12028 6716 : gfc_add_expr_to_block (&fblock, tmp);
12029 :
12030 : /* Get the rhs size and fix it. */
12031 6716 : size2 = gfc_index_one_node;
12032 16637 : for (n = 0; n < expr2->rank; n++)
12033 : {
12034 9921 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
12035 : gfc_array_index_type,
12036 : loop->to[n], loop->from[n]);
12037 9921 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
12038 : gfc_array_index_type,
12039 : tmp, gfc_index_one_node);
12040 9921 : size2 = fold_build2_loc (input_location, MULT_EXPR,
12041 : gfc_array_index_type,
12042 : tmp, size2);
12043 : }
12044 6716 : size2 = gfc_evaluate_now (size2, &fblock);
12045 :
12046 : /* Deallocation of allocatable components will have to occur on
12047 : reallocation. Fix the old descriptor now. */
12048 6716 : if ((expr1->ts.type == BT_DERIVED)
12049 441 : && expr1->ts.u.derived->attr.alloc_comp)
12050 200 : old_desc = gfc_evaluate_now (desc, &fblock);
12051 : else
12052 : old_desc = NULL_TREE;
12053 :
12054 : /* Now modify the lhs descriptor and the associated scalarizer
12055 : variables. F2003 7.4.1.3: "If variable is or becomes an
12056 : unallocated allocatable variable, then it is allocated with each
12057 : deferred type parameter equal to the corresponding type parameters
12058 : of expr , with the shape of expr , and with each lower bound equal
12059 : to the corresponding element of LBOUND(expr)."
12060 : Reuse size1 to keep a dimension-by-dimension track of the
12061 : stride of the new array. */
12062 6716 : size1 = gfc_index_one_node;
12063 6716 : offset = gfc_index_zero_node;
12064 :
12065 16637 : for (n = 0; n < expr2->rank; n++)
12066 : {
12067 9921 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
12068 : gfc_array_index_type,
12069 : loop->to[n], loop->from[n]);
12070 9921 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
12071 : gfc_array_index_type,
12072 : tmp, gfc_index_one_node);
12073 :
12074 9921 : lbound = gfc_index_one_node;
12075 9921 : ubound = tmp;
12076 :
12077 9921 : if (as)
12078 : {
12079 2168 : lbd = get_std_lbound (expr2, desc2, n,
12080 1084 : as->type == AS_ASSUMED_SIZE);
12081 1084 : ubound = fold_build2_loc (input_location,
12082 : MINUS_EXPR,
12083 : gfc_array_index_type,
12084 : ubound, lbound);
12085 1084 : ubound = fold_build2_loc (input_location,
12086 : PLUS_EXPR,
12087 : gfc_array_index_type,
12088 : ubound, lbd);
12089 1084 : lbound = lbd;
12090 : }
12091 :
12092 9921 : gfc_conv_descriptor_lbound_set (&fblock, desc,
12093 : gfc_rank_cst[n],
12094 : lbound);
12095 9921 : gfc_conv_descriptor_ubound_set (&fblock, desc,
12096 : gfc_rank_cst[n],
12097 : ubound);
12098 9921 : gfc_conv_descriptor_stride_set (&fblock, desc,
12099 : gfc_rank_cst[n],
12100 : size1);
12101 9921 : lbound = gfc_conv_descriptor_lbound_get (desc,
12102 : gfc_rank_cst[n]);
12103 9921 : tmp2 = fold_build2_loc (input_location, MULT_EXPR,
12104 : gfc_array_index_type,
12105 : lbound, size1);
12106 9921 : offset = fold_build2_loc (input_location, MINUS_EXPR,
12107 : gfc_array_index_type,
12108 : offset, tmp2);
12109 9921 : size1 = fold_build2_loc (input_location, MULT_EXPR,
12110 : gfc_array_index_type,
12111 : tmp, size1);
12112 : }
12113 :
12114 : /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
12115 : the array offset is saved and the info.offset is used for a
12116 : running offset. Use the saved_offset instead. */
12117 6716 : gfc_conv_descriptor_offset_set (&fblock, desc, offset);
12118 :
12119 : /* Take into account _len of unlimited polymorphic entities, so that span
12120 : for array descriptors and allocation sizes are computed correctly. */
12121 6716 : if (UNLIMITED_POLY (expr2))
12122 : {
12123 110 : tree len = gfc_class_len_get (TREE_OPERAND (desc2, 0));
12124 110 : len = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
12125 : fold_convert (size_type_node, len),
12126 : size_one_node);
12127 110 : elemsize2 = fold_build2_loc (input_location, MULT_EXPR,
12128 : gfc_array_index_type, elemsize2,
12129 : fold_convert (gfc_array_index_type, len));
12130 : }
12131 :
12132 6716 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
12133 6716 : gfc_conv_descriptor_span_set (&fblock, desc, elemsize2);
12134 :
12135 6716 : size2 = fold_build2_loc (input_location, MULT_EXPR,
12136 : gfc_array_index_type,
12137 : elemsize2, size2);
12138 6716 : size2 = fold_convert (size_type_node, size2);
12139 6716 : size2 = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
12140 : size2, size_one_node);
12141 6716 : size2 = gfc_evaluate_now (size2, &fblock);
12142 :
12143 : /* For deferred character length, the 'size' field of the dtype might
12144 : have changed so set the dtype. */
12145 6716 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
12146 6716 : && expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12147 : {
12148 663 : tree type;
12149 663 : if (expr2->ts.u.cl->backend_decl)
12150 663 : type = gfc_typenode_for_spec (&expr2->ts);
12151 : else
12152 0 : type = gfc_typenode_for_spec (&expr1->ts);
12153 :
12154 663 : gfc_conv_descriptor_dtype_set (&fblock, desc,
12155 : gfc_get_dtype_rank_type (expr1->rank,
12156 : type));
12157 : }
12158 6053 : else if (expr1->ts.type == BT_CLASS)
12159 : {
12160 669 : tree type;
12161 :
12162 669 : if (expr2->ts.type != BT_CLASS)
12163 371 : type = gfc_typenode_for_spec (&expr2->ts);
12164 : else
12165 298 : type = gfc_get_character_type_len (1, elemsize2);
12166 :
12167 669 : gfc_conv_descriptor_dtype_set (&fblock, desc,
12168 : gfc_get_dtype_rank_type (expr2->rank,
12169 : type));
12170 :
12171 : /* Set the _len field as well... */
12172 669 : if (UNLIMITED_POLY (expr1))
12173 : {
12174 274 : tmp = gfc_class_len_get (TREE_OPERAND (desc, 0));
12175 274 : if (expr2->ts.type == BT_CHARACTER)
12176 49 : gfc_add_modify (&fblock, tmp,
12177 49 : fold_convert (TREE_TYPE (tmp),
12178 : TYPE_SIZE_UNIT (type)));
12179 225 : else if (UNLIMITED_POLY (expr2))
12180 110 : gfc_add_modify (&fblock, tmp,
12181 110 : gfc_class_len_get (TREE_OPERAND (desc2, 0)));
12182 : else
12183 115 : gfc_add_modify (&fblock, tmp,
12184 115 : build_int_cst (TREE_TYPE (tmp), 0));
12185 : }
12186 : /* ...and the vptr. */
12187 669 : tmp = gfc_class_vptr_get (TREE_OPERAND (desc, 0));
12188 669 : if (expr2->ts.type == BT_CLASS && !VAR_P (desc2)
12189 291 : && TREE_CODE (desc2) == COMPONENT_REF)
12190 : {
12191 237 : tmp2 = gfc_get_class_from_expr (desc2);
12192 237 : tmp2 = gfc_class_vptr_get (tmp2);
12193 : }
12194 432 : else if (expr2->ts.type == BT_CLASS && class_expr2 != NULL_TREE)
12195 54 : tmp2 = gfc_class_vptr_get (class_expr2);
12196 : else
12197 : {
12198 378 : tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts));
12199 378 : tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2);
12200 : }
12201 :
12202 669 : gfc_add_modify (&fblock, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
12203 : }
12204 5384 : else if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
12205 39 : gfc_conv_descriptor_dtype_set (&fblock, desc,
12206 39 : gfc_get_dtype (TREE_TYPE (desc)));
12207 :
12208 : /* Realloc expression. Note that the scalarizer uses desc.data
12209 : in the array reference - (*desc.data)[<element>]. */
12210 6716 : gfc_init_block (&realloc_block);
12211 6716 : gfc_init_se (&caf_se, NULL);
12212 :
12213 6716 : if (coarray)
12214 : {
12215 39 : token = gfc_get_ultimate_alloc_ptr_comps_caf_token (&caf_se, expr1);
12216 39 : if (token == NULL_TREE)
12217 : {
12218 9 : tmp = gfc_get_tree_for_caf_expr (expr1);
12219 9 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
12220 6 : tmp = build_fold_indirect_ref (tmp);
12221 9 : gfc_get_caf_token_offset (&caf_se, &token, NULL, tmp, NULL_TREE,
12222 : expr1);
12223 9 : token = gfc_build_addr_expr (NULL_TREE, token);
12224 : }
12225 :
12226 39 : gfc_add_block_to_block (&realloc_block, &caf_se.pre);
12227 : }
12228 6716 : if ((expr1->ts.type == BT_DERIVED)
12229 441 : && expr1->ts.u.derived->attr.alloc_comp)
12230 : {
12231 200 : tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, old_desc,
12232 : expr1->rank, true);
12233 200 : gfc_add_expr_to_block (&realloc_block, tmp);
12234 : }
12235 :
12236 6716 : if (!coarray)
12237 : {
12238 6677 : tmp = build_call_expr_loc (input_location,
12239 : builtin_decl_explicit (BUILT_IN_REALLOC), 2,
12240 : fold_convert (pvoid_type_node, array1),
12241 : size2);
12242 6677 : if (flag_openmp_allocators)
12243 : {
12244 2 : tree cond, omp_tmp;
12245 2 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
12246 : gfc_conv_descriptor_version_get (desc),
12247 : integer_one_node);
12248 2 : omp_tmp = builtin_decl_explicit (BUILT_IN_GOMP_REALLOC);
12249 2 : omp_tmp = build_call_expr_loc (input_location, omp_tmp, 4,
12250 : fold_convert (pvoid_type_node, array1), size2,
12251 : build_zero_cst (ptr_type_node),
12252 : build_zero_cst (ptr_type_node));
12253 2 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond,
12254 : omp_tmp, tmp);
12255 : }
12256 :
12257 6677 : gfc_conv_descriptor_data_set (&realloc_block, desc, tmp);
12258 : }
12259 : else
12260 : {
12261 39 : tmp = build_call_expr_loc (input_location,
12262 : gfor_fndecl_caf_deregister, 5, token,
12263 : build_int_cst (integer_type_node,
12264 : GFC_CAF_COARRAY_DEALLOCATE_ONLY),
12265 : null_pointer_node, null_pointer_node,
12266 : integer_zero_node);
12267 39 : gfc_add_expr_to_block (&realloc_block, tmp);
12268 39 : tmp = build_call_expr_loc (input_location,
12269 : gfor_fndecl_caf_register,
12270 : 7, size2,
12271 : build_int_cst (integer_type_node,
12272 : GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY),
12273 : token, gfc_build_addr_expr (NULL_TREE, desc),
12274 : null_pointer_node, null_pointer_node,
12275 : integer_zero_node);
12276 39 : gfc_add_expr_to_block (&realloc_block, tmp);
12277 : }
12278 :
12279 6716 : if ((expr1->ts.type == BT_DERIVED)
12280 441 : && expr1->ts.u.derived->attr.alloc_comp)
12281 : {
12282 200 : tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc,
12283 : expr1->rank);
12284 200 : gfc_add_expr_to_block (&realloc_block, tmp);
12285 : }
12286 :
12287 6716 : gfc_add_block_to_block (&realloc_block, &caf_se.post);
12288 6716 : realloc_expr = gfc_finish_block (&realloc_block);
12289 :
12290 : /* Malloc expression. */
12291 6716 : gfc_init_block (&alloc_block);
12292 6716 : if (!coarray)
12293 : {
12294 6677 : tmp = build_call_expr_loc (input_location,
12295 : builtin_decl_explicit (BUILT_IN_MALLOC),
12296 : 1, size2);
12297 6677 : gfc_conv_descriptor_data_set (&alloc_block,
12298 : desc, tmp);
12299 : }
12300 : else
12301 : {
12302 39 : tmp = build_call_expr_loc (input_location,
12303 : gfor_fndecl_caf_register,
12304 : 7, size2,
12305 : build_int_cst (integer_type_node,
12306 : GFC_CAF_COARRAY_ALLOC),
12307 : token, gfc_build_addr_expr (NULL_TREE, desc),
12308 : null_pointer_node, null_pointer_node,
12309 : integer_zero_node);
12310 39 : gfc_add_expr_to_block (&alloc_block, tmp);
12311 : }
12312 :
12313 :
12314 : /* We already set the dtype in the case of deferred character
12315 : length arrays and class lvalues. */
12316 6716 : if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
12317 6716 : && ((expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12318 6053 : || coarray))
12319 12730 : && expr1->ts.type != BT_CLASS)
12320 5345 : gfc_conv_descriptor_dtype_set (&alloc_block, desc,
12321 5345 : gfc_get_dtype (TREE_TYPE (desc)));
12322 :
12323 6716 : if ((expr1->ts.type == BT_DERIVED)
12324 441 : && expr1->ts.u.derived->attr.alloc_comp)
12325 : {
12326 200 : tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc,
12327 : expr1->rank);
12328 200 : gfc_add_expr_to_block (&alloc_block, tmp);
12329 : }
12330 6716 : alloc_expr = gfc_finish_block (&alloc_block);
12331 :
12332 : /* Malloc if not allocated; realloc otherwise. */
12333 6716 : tmp = build3_v (COND_EXPR, cond_null, alloc_expr, realloc_expr);
12334 6716 : gfc_add_expr_to_block (&fblock, tmp);
12335 :
12336 : /* Add the label for same shape lhs and rhs. */
12337 6716 : tmp = build1_v (LABEL_EXPR, jump_label2);
12338 6716 : gfc_add_expr_to_block (&fblock, tmp);
12339 :
12340 6716 : tree realloc_code = gfc_finish_block (&fblock);
12341 :
12342 6716 : stmtblock_t result_block;
12343 6716 : gfc_init_block (&result_block);
12344 6716 : gfc_add_expr_to_block (&result_block, realloc_code);
12345 6716 : update_reallocated_descriptor (&result_block, loop);
12346 :
12347 6716 : return gfc_finish_block (&result_block);
12348 : }
12349 :
12350 :
12351 : /* Initialize class descriptor's TKR information. */
12352 :
12353 : void
12354 3046 : gfc_trans_class_array (gfc_symbol * sym, gfc_wrapped_block * block)
12355 : {
12356 3046 : tree type, etype;
12357 3046 : tree descriptor;
12358 3046 : stmtblock_t init;
12359 3046 : int rank;
12360 :
12361 : /* Make sure the frontend gets these right. */
12362 3046 : gcc_assert (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
12363 : && (CLASS_DATA (sym)->attr.class_pointer
12364 : || CLASS_DATA (sym)->attr.allocatable));
12365 :
12366 3046 : gcc_assert (VAR_P (sym->backend_decl)
12367 : || TREE_CODE (sym->backend_decl) == PARM_DECL);
12368 :
12369 3046 : if (sym->attr.dummy)
12370 1496 : return;
12371 :
12372 3046 : descriptor = gfc_class_data_get (sym->backend_decl);
12373 3046 : type = TREE_TYPE (descriptor);
12374 :
12375 3046 : if (type == NULL || !GFC_DESCRIPTOR_TYPE_P (type))
12376 : return;
12377 :
12378 1550 : location_t loc = input_location;
12379 1550 : input_location = gfc_get_location (&sym->declared_at);
12380 1550 : gfc_init_block (&init);
12381 :
12382 1550 : rank = CLASS_DATA (sym)->as ? (CLASS_DATA (sym)->as->rank) : (0);
12383 1550 : gcc_assert (rank>=0);
12384 1550 : etype = gfc_get_element_type (type);
12385 1550 : gfc_conv_descriptor_dtype_set (&init, descriptor,
12386 : gfc_get_dtype_rank_type (rank, etype));
12387 :
12388 1550 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
12389 1550 : input_location = loc;
12390 : }
12391 :
12392 :
12393 : /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
12394 : Do likewise, recursively if necessary, with the allocatable components of
12395 : derived types. This function is also called for assumed-rank arrays, which
12396 : are always dummy arguments. */
12397 :
12398 : void
12399 18217 : gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
12400 : {
12401 18217 : tree type;
12402 18217 : tree tmp;
12403 18217 : tree descriptor;
12404 18217 : stmtblock_t init;
12405 18217 : stmtblock_t cleanup;
12406 18217 : int rank;
12407 18217 : bool sym_has_alloc_comp, has_finalizer;
12408 :
12409 36434 : sym_has_alloc_comp = (sym->ts.type == BT_DERIVED
12410 10964 : || sym->ts.type == BT_CLASS)
12411 18217 : && sym->ts.u.derived->attr.alloc_comp;
12412 18217 : has_finalizer = gfc_may_be_finalized (sym->ts);
12413 :
12414 : /* Make sure the frontend gets these right. */
12415 18217 : gcc_assert (sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp
12416 : || has_finalizer
12417 : || (sym->as->type == AS_ASSUMED_RANK && sym->attr.dummy));
12418 :
12419 18217 : location_t loc = input_location;
12420 18217 : input_location = gfc_get_location (&sym->declared_at);
12421 18217 : gfc_init_block (&init);
12422 :
12423 18217 : gcc_assert (VAR_P (sym->backend_decl)
12424 : || TREE_CODE (sym->backend_decl) == PARM_DECL);
12425 :
12426 18217 : if (sym->ts.type == BT_CHARACTER
12427 1390 : && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
12428 : {
12429 812 : if (sym->ts.deferred && !sym->ts.u.cl->length && !sym->attr.dummy)
12430 : {
12431 607 : tree len_expr = sym->ts.u.cl->backend_decl;
12432 607 : tree init_val = build_zero_cst (TREE_TYPE (len_expr));
12433 607 : if (VAR_P (len_expr)
12434 607 : && sym->attr.save
12435 662 : && !DECL_INITIAL (len_expr))
12436 55 : DECL_INITIAL (len_expr) = init_val;
12437 : else
12438 552 : gfc_add_modify (&init, len_expr, init_val);
12439 : }
12440 812 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
12441 812 : gfc_trans_vla_type_sizes (sym, &init);
12442 :
12443 : /* Presence check of optional deferred-length character dummy. */
12444 812 : if (sym->ts.deferred && sym->attr.dummy && sym->attr.optional)
12445 : {
12446 43 : tmp = gfc_finish_block (&init);
12447 43 : tmp = build3_v (COND_EXPR, gfc_conv_expr_present (sym),
12448 : tmp, build_empty_stmt (input_location));
12449 43 : gfc_add_expr_to_block (&init, tmp);
12450 : }
12451 : }
12452 :
12453 : /* Dummy, use associated and result variables don't need anything special. */
12454 18217 : if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result)
12455 : {
12456 882 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
12457 882 : input_location = loc;
12458 1158 : return;
12459 : }
12460 :
12461 17335 : descriptor = sym->backend_decl;
12462 :
12463 : /* Although static, derived types with default initializers and
12464 : allocatable components must not be nulled wholesale; instead they
12465 : are treated component by component. */
12466 17335 : if (TREE_STATIC (descriptor) && !sym_has_alloc_comp && !has_finalizer)
12467 : {
12468 : /* SAVEd variables are not freed on exit. */
12469 276 : gfc_trans_static_array_pointer (sym);
12470 :
12471 276 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
12472 276 : input_location = loc;
12473 276 : return;
12474 : }
12475 :
12476 : /* Get the descriptor type. */
12477 17059 : type = TREE_TYPE (sym->backend_decl);
12478 :
12479 17059 : if ((sym_has_alloc_comp || (has_finalizer && sym->ts.type != BT_CLASS))
12480 5654 : && !(sym->attr.pointer || sym->attr.allocatable))
12481 : {
12482 2928 : if (!sym->attr.save
12483 2525 : && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program))
12484 : {
12485 2525 : if (sym->value == NULL
12486 2525 : || !gfc_has_default_initializer (sym->ts.u.derived))
12487 : {
12488 2087 : rank = sym->as ? sym->as->rank : 0;
12489 2087 : tmp = gfc_nullify_alloc_comp (sym->ts.u.derived,
12490 : descriptor, rank);
12491 2087 : gfc_add_expr_to_block (&init, tmp);
12492 : }
12493 : else
12494 438 : gfc_init_default_dt (sym, &init, false);
12495 : }
12496 : }
12497 14131 : else if (!GFC_DESCRIPTOR_TYPE_P (type))
12498 : {
12499 : /* If the backend_decl is not a descriptor, we must have a pointer
12500 : to one. */
12501 2141 : descriptor = build_fold_indirect_ref_loc (input_location,
12502 : sym->backend_decl);
12503 2141 : type = TREE_TYPE (descriptor);
12504 : }
12505 :
12506 : /* NULLIFY the data pointer for non-saved allocatables, or for non-saved
12507 : pointers when -fcheck=pointer is specified. */
12508 29049 : if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save
12509 29036 : && (sym->attr.allocatable
12510 3285 : || (sym->attr.pointer && (gfc_option.rtcheck & GFC_RTCHECK_POINTER))))
12511 : {
12512 8735 : gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node);
12513 8735 : if (flag_coarray == GFC_FCOARRAY_LIB && sym->attr.codimension)
12514 : {
12515 : /* Declare the variable static so its array descriptor stays present
12516 : after leaving the scope. It may still be accessed through another
12517 : image. This may happen, for example, with the caf_mpi
12518 : implementation. */
12519 169 : TREE_STATIC (descriptor) = 1;
12520 169 : gfc_conv_descriptor_token_set (&init, descriptor, null_pointer_node);
12521 : }
12522 : }
12523 :
12524 : /* Set initial TKR for pointers and allocatables */
12525 17059 : if (GFC_DESCRIPTOR_TYPE_P (type)
12526 17059 : && (sym->attr.pointer || sym->attr.allocatable))
12527 : {
12528 11990 : tree etype;
12529 :
12530 11990 : gcc_assert (sym->as && sym->as->rank>=0);
12531 11990 : etype = gfc_get_element_type (type);
12532 11990 : gfc_conv_descriptor_dtype_set (&init, descriptor,
12533 11990 : gfc_get_dtype_rank_type (sym->as->rank,
12534 : etype));
12535 : }
12536 17059 : input_location = loc;
12537 17059 : gfc_init_block (&cleanup);
12538 :
12539 : /* Allocatable arrays need to be freed when they go out of scope.
12540 : The allocatable components of pointers must not be touched. */
12541 17059 : if (!sym->attr.allocatable && has_finalizer && sym->ts.type != BT_CLASS
12542 604 : && !sym->attr.pointer && !sym->attr.artificial && !sym->attr.save
12543 315 : && !sym->ns->proc_name->attr.is_main_program)
12544 : {
12545 276 : gfc_expr *e;
12546 276 : sym->attr.referenced = 1;
12547 276 : e = gfc_lval_expr_from_sym (sym);
12548 276 : gfc_add_finalizer_call (&cleanup, e);
12549 276 : gfc_free_expr (e);
12550 276 : }
12551 16783 : else if ((!sym->attr.allocatable || !has_finalizer)
12552 16659 : && sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
12553 5097 : && !sym->attr.pointer && !sym->attr.save
12554 2527 : && !(sym->attr.artificial && sym->name[0] == '_')
12555 2472 : && !sym->ns->proc_name->attr.is_main_program)
12556 : {
12557 682 : int rank;
12558 682 : rank = sym->as ? sym->as->rank : 0;
12559 682 : tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank,
12560 682 : (sym->attr.codimension
12561 3 : && flag_coarray == GFC_FCOARRAY_LIB)
12562 : ? GFC_STRUCTURE_CAF_MODE_IN_COARRAY
12563 : : 0);
12564 682 : gfc_add_expr_to_block (&cleanup, tmp);
12565 : }
12566 :
12567 17059 : if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension)
12568 8699 : && !sym->attr.save && !sym->attr.result
12569 8692 : && !sym->ns->proc_name->attr.is_main_program)
12570 : {
12571 4554 : gfc_expr *e;
12572 4554 : e = has_finalizer ? gfc_lval_expr_from_sym (sym) : NULL;
12573 9108 : tmp = gfc_deallocate_with_status (sym->backend_decl, NULL_TREE, NULL_TREE,
12574 : NULL_TREE, NULL_TREE, true, e,
12575 4554 : sym->attr.codimension
12576 : ? GFC_CAF_COARRAY_DEREGISTER
12577 : : GFC_CAF_COARRAY_NOCOARRAY,
12578 : NULL_TREE, gfc_finish_block (&cleanup));
12579 4554 : if (e)
12580 45 : gfc_free_expr (e);
12581 4554 : gfc_init_block (&cleanup);
12582 4554 : gfc_add_expr_to_block (&cleanup, tmp);
12583 : }
12584 :
12585 17059 : gfc_add_init_cleanup (block, gfc_finish_block (&init),
12586 : gfc_finish_block (&cleanup));
12587 : }
12588 :
12589 : /************ Expression Walking Functions ******************/
12590 :
12591 : /* Walk a variable reference.
12592 :
12593 : Possible extension - multiple component subscripts.
12594 : x(:,:) = foo%a(:)%b(:)
12595 : Transforms to
12596 : forall (i=..., j=...)
12597 : x(i,j) = foo%a(j)%b(i)
12598 : end forall
12599 : This adds a fair amount of complexity because you need to deal with more
12600 : than one ref. Maybe handle in a similar manner to vector subscripts.
12601 : Maybe not worth the effort. */
12602 :
12603 :
12604 : static gfc_ss *
12605 692618 : gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
12606 : {
12607 692618 : gfc_ref *ref;
12608 :
12609 692618 : gfc_fix_class_refs (expr);
12610 :
12611 810348 : for (ref = expr->ref; ref; ref = ref->next)
12612 450731 : if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
12613 : break;
12614 :
12615 692618 : return gfc_walk_array_ref (ss, expr, ref);
12616 : }
12617 :
12618 : gfc_ss *
12619 692975 : gfc_walk_array_ref (gfc_ss *ss, gfc_expr *expr, gfc_ref *ref, bool array_only)
12620 : {
12621 692975 : gfc_array_ref *ar;
12622 692975 : gfc_ss *newss;
12623 692975 : int n;
12624 :
12625 1035812 : for (; ref; ref = ref->next)
12626 : {
12627 342837 : if (ref->type == REF_SUBSTRING)
12628 : {
12629 1308 : ss = gfc_get_scalar_ss (ss, ref->u.ss.start);
12630 1308 : if (ref->u.ss.end)
12631 1282 : ss = gfc_get_scalar_ss (ss, ref->u.ss.end);
12632 : }
12633 :
12634 : /* We're only interested in array sections from now on. */
12635 342837 : if (ref->type != REF_ARRAY
12636 333768 : || (array_only && ref->u.ar.as && ref->u.ar.as->rank == 0))
12637 9184 : continue;
12638 :
12639 333653 : ar = &ref->u.ar;
12640 :
12641 333653 : switch (ar->type)
12642 : {
12643 326 : case AR_ELEMENT:
12644 699 : for (n = ar->dimen - 1; n >= 0; n--)
12645 373 : ss = gfc_get_scalar_ss (ss, ar->start[n]);
12646 : break;
12647 :
12648 276769 : case AR_FULL:
12649 : /* Assumed shape arrays from interface mapping need this fix. */
12650 276769 : if (!ar->as && expr->symtree->n.sym->as)
12651 : {
12652 6 : ar->as = gfc_get_array_spec();
12653 6 : *ar->as = *expr->symtree->n.sym->as;
12654 : }
12655 276769 : newss = gfc_get_array_ss (ss, expr, ar->as->rank, GFC_SS_SECTION);
12656 276769 : newss->info->data.array.ref = ref;
12657 :
12658 : /* Make sure array is the same as array(:,:), this way
12659 : we don't need to special case all the time. */
12660 276769 : ar->dimen = ar->as->rank;
12661 635912 : for (n = 0; n < ar->dimen; n++)
12662 : {
12663 359143 : ar->dimen_type[n] = DIMEN_RANGE;
12664 :
12665 359143 : gcc_assert (ar->start[n] == NULL);
12666 359143 : gcc_assert (ar->end[n] == NULL);
12667 359143 : gcc_assert (ar->stride[n] == NULL);
12668 : }
12669 : ss = newss;
12670 : break;
12671 :
12672 56558 : case AR_SECTION:
12673 56558 : newss = gfc_get_array_ss (ss, expr, 0, GFC_SS_SECTION);
12674 56558 : newss->info->data.array.ref = ref;
12675 :
12676 : /* We add SS chains for all the subscripts in the section. */
12677 145557 : for (n = 0; n < ar->dimen; n++)
12678 : {
12679 88999 : gfc_ss *indexss;
12680 :
12681 88999 : switch (ar->dimen_type[n])
12682 : {
12683 6821 : case DIMEN_ELEMENT:
12684 : /* Add SS for elemental (scalar) subscripts. */
12685 6821 : gcc_assert (ar->start[n]);
12686 6821 : indexss = gfc_get_scalar_ss (gfc_ss_terminator, ar->start[n]);
12687 6821 : indexss->loop_chain = gfc_ss_terminator;
12688 6821 : newss->info->data.array.subscript[n] = indexss;
12689 6821 : break;
12690 :
12691 81138 : case DIMEN_RANGE:
12692 : /* We don't add anything for sections, just remember this
12693 : dimension for later. */
12694 81138 : newss->dim[newss->dimen] = n;
12695 81138 : newss->dimen++;
12696 81138 : break;
12697 :
12698 1040 : case DIMEN_VECTOR:
12699 : /* Create a GFC_SS_VECTOR index in which we can store
12700 : the vector's descriptor. */
12701 1040 : indexss = gfc_get_array_ss (gfc_ss_terminator, ar->start[n],
12702 : 1, GFC_SS_VECTOR);
12703 1040 : indexss->loop_chain = gfc_ss_terminator;
12704 1040 : newss->info->data.array.subscript[n] = indexss;
12705 1040 : newss->dim[newss->dimen] = n;
12706 1040 : newss->dimen++;
12707 1040 : break;
12708 :
12709 0 : default:
12710 : /* We should know what sort of section it is by now. */
12711 0 : gcc_unreachable ();
12712 : }
12713 : }
12714 : /* We should have at least one non-elemental dimension,
12715 : unless we are creating a descriptor for a (scalar) coarray. */
12716 56558 : gcc_assert (newss->dimen > 0
12717 : || newss->info->data.array.ref->u.ar.as->corank > 0);
12718 : ss = newss;
12719 : break;
12720 :
12721 0 : default:
12722 : /* We should know what sort of section it is by now. */
12723 0 : gcc_unreachable ();
12724 : }
12725 :
12726 : }
12727 692975 : return ss;
12728 : }
12729 :
12730 :
12731 : /* Walk an expression operator. If only one operand of a binary expression is
12732 : scalar, we must also add the scalar term to the SS chain. */
12733 :
12734 : static gfc_ss *
12735 58112 : gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
12736 : {
12737 58112 : gfc_ss *head;
12738 58112 : gfc_ss *head2;
12739 :
12740 58112 : head = gfc_walk_subexpr (ss, expr->value.op.op1);
12741 58112 : if (expr->value.op.op2 == NULL)
12742 : head2 = head;
12743 : else
12744 55434 : head2 = gfc_walk_subexpr (head, expr->value.op.op2);
12745 :
12746 : /* All operands are scalar. Pass back and let the caller deal with it. */
12747 58112 : if (head2 == ss)
12748 : return head2;
12749 :
12750 : /* All operands require scalarization. */
12751 52334 : if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
12752 : return head2;
12753 :
12754 : /* One of the operands needs scalarization, the other is scalar.
12755 : Create a gfc_ss for the scalar expression. */
12756 19450 : if (head == ss)
12757 : {
12758 : /* First operand is scalar. We build the chain in reverse order, so
12759 : add the scalar SS after the second operand. */
12760 : head = head2;
12761 2280 : while (head && head->next != ss)
12762 : head = head->next;
12763 : /* Check we haven't somehow broken the chain. */
12764 2037 : gcc_assert (head);
12765 2037 : head->next = gfc_get_scalar_ss (ss, expr->value.op.op1);
12766 : }
12767 : else /* head2 == head */
12768 : {
12769 17413 : gcc_assert (head2 == head);
12770 : /* Second operand is scalar. */
12771 17413 : head2 = gfc_get_scalar_ss (head2, expr->value.op.op2);
12772 : }
12773 :
12774 : return head2;
12775 : }
12776 :
12777 : static gfc_ss *
12778 36 : gfc_walk_conditional_expr (gfc_ss *ss, gfc_expr *expr)
12779 : {
12780 36 : gfc_ss *head;
12781 :
12782 36 : head = gfc_walk_subexpr (ss, expr->value.conditional.true_expr);
12783 36 : head = gfc_walk_subexpr (head, expr->value.conditional.false_expr);
12784 36 : return head;
12785 : }
12786 :
12787 : /* Reverse a SS chain. */
12788 :
12789 : gfc_ss *
12790 869297 : gfc_reverse_ss (gfc_ss * ss)
12791 : {
12792 869297 : gfc_ss *next;
12793 869297 : gfc_ss *head;
12794 :
12795 869297 : gcc_assert (ss != NULL);
12796 :
12797 : head = gfc_ss_terminator;
12798 1312441 : while (ss != gfc_ss_terminator)
12799 : {
12800 443144 : next = ss->next;
12801 : /* Check we didn't somehow break the chain. */
12802 443144 : gcc_assert (next != NULL);
12803 443144 : ss->next = head;
12804 443144 : head = ss;
12805 443144 : ss = next;
12806 : }
12807 :
12808 869297 : return (head);
12809 : }
12810 :
12811 :
12812 : /* Given an expression referring to a procedure, return the symbol of its
12813 : interface. We can't get the procedure symbol directly as we have to handle
12814 : the case of (deferred) type-bound procedures. */
12815 :
12816 : gfc_symbol *
12817 161 : gfc_get_proc_ifc_for_expr (gfc_expr *procedure_ref)
12818 : {
12819 161 : gfc_symbol *sym;
12820 161 : gfc_ref *ref;
12821 :
12822 161 : if (procedure_ref == NULL)
12823 : return NULL;
12824 :
12825 : /* Normal procedure case. */
12826 161 : if (procedure_ref->expr_type == EXPR_FUNCTION
12827 161 : && procedure_ref->value.function.esym)
12828 : sym = procedure_ref->value.function.esym;
12829 : else
12830 24 : sym = procedure_ref->symtree->n.sym;
12831 :
12832 : /* Typebound procedure case. */
12833 209 : for (ref = procedure_ref->ref; ref; ref = ref->next)
12834 : {
12835 48 : if (ref->type == REF_COMPONENT
12836 48 : && ref->u.c.component->attr.proc_pointer)
12837 24 : sym = ref->u.c.component->ts.interface;
12838 : else
12839 : sym = NULL;
12840 : }
12841 :
12842 : return sym;
12843 : }
12844 :
12845 :
12846 : /* Given an expression referring to an intrinsic function call,
12847 : return the intrinsic symbol. */
12848 :
12849 : gfc_intrinsic_sym *
12850 7964 : gfc_get_intrinsic_for_expr (gfc_expr *call)
12851 : {
12852 7964 : if (call == NULL)
12853 : return NULL;
12854 :
12855 : /* Normal procedure case. */
12856 2366 : if (call->expr_type == EXPR_FUNCTION)
12857 2260 : return call->value.function.isym;
12858 : else
12859 : return NULL;
12860 : }
12861 :
12862 :
12863 : /* Indicates whether an argument to an intrinsic function should be used in
12864 : scalarization. It is usually the case, except for some intrinsics
12865 : requiring the value to be constant, and using the value at compile time only.
12866 : As the value is not used at runtime in those cases, we don’t produce code
12867 : for it, and it should not be visible to the scalarizer.
12868 : FUNCTION is the intrinsic function being called, ACTUAL_ARG is the actual
12869 : argument being examined in that call, and ARG_NUM the index number
12870 : of ACTUAL_ARG in the list of arguments.
12871 : The intrinsic procedure’s dummy argument associated with ACTUAL_ARG is
12872 : identified using the name in ACTUAL_ARG if it is present (that is: if it’s
12873 : a keyword argument), otherwise using ARG_NUM. */
12874 :
12875 : static bool
12876 38069 : arg_evaluated_for_scalarization (gfc_intrinsic_sym *function,
12877 : gfc_dummy_arg *dummy_arg)
12878 : {
12879 38069 : if (function != NULL && dummy_arg != NULL)
12880 : {
12881 12473 : switch (function->id)
12882 : {
12883 241 : case GFC_ISYM_INDEX:
12884 241 : case GFC_ISYM_LEN_TRIM:
12885 241 : case GFC_ISYM_MASKL:
12886 241 : case GFC_ISYM_MASKR:
12887 241 : case GFC_ISYM_SCAN:
12888 241 : case GFC_ISYM_VERIFY:
12889 241 : if (strcmp ("kind", gfc_dummy_arg_get_name (*dummy_arg)) == 0)
12890 33 : return false;
12891 : /* Fallthrough. */
12892 :
12893 : default:
12894 : break;
12895 : }
12896 : }
12897 :
12898 : return true;
12899 : }
12900 :
12901 :
12902 : /* Walk the arguments of an elemental function.
12903 : PROC_EXPR is used to check whether an argument is permitted to be absent. If
12904 : it is NULL, we don't do the check and the argument is assumed to be present.
12905 : */
12906 :
12907 : gfc_ss *
12908 27050 : gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
12909 : gfc_intrinsic_sym *intrinsic_sym,
12910 : gfc_ss_type type)
12911 : {
12912 27050 : int scalar;
12913 27050 : gfc_ss *head;
12914 27050 : gfc_ss *tail;
12915 27050 : gfc_ss *newss;
12916 :
12917 27050 : head = gfc_ss_terminator;
12918 27050 : tail = NULL;
12919 :
12920 27050 : scalar = 1;
12921 66583 : for (; arg; arg = arg->next)
12922 : {
12923 39533 : gfc_dummy_arg * const dummy_arg = arg->associated_dummy;
12924 41030 : if (!arg->expr
12925 38219 : || arg->expr->expr_type == EXPR_NULL
12926 77602 : || !arg_evaluated_for_scalarization (intrinsic_sym, dummy_arg))
12927 1497 : continue;
12928 :
12929 38036 : newss = gfc_walk_subexpr (head, arg->expr);
12930 38036 : if (newss == head)
12931 : {
12932 : /* Scalar argument. */
12933 18595 : gcc_assert (type == GFC_SS_SCALAR || type == GFC_SS_REFERENCE);
12934 18595 : newss = gfc_get_scalar_ss (head, arg->expr);
12935 18595 : newss->info->type = type;
12936 18595 : if (dummy_arg)
12937 15463 : newss->info->data.scalar.dummy_arg = dummy_arg;
12938 : }
12939 : else
12940 : scalar = 0;
12941 :
12942 34904 : if (dummy_arg != NULL
12943 26432 : && gfc_dummy_arg_is_optional (*dummy_arg)
12944 2538 : && arg->expr->expr_type == EXPR_VARIABLE
12945 36608 : && (gfc_expr_attr (arg->expr).optional
12946 1223 : || gfc_expr_attr (arg->expr).allocatable
12947 38036 : || gfc_expr_attr (arg->expr).pointer))
12948 1005 : newss->info->can_be_null_ref = true;
12949 :
12950 38036 : head = newss;
12951 38036 : if (!tail)
12952 : {
12953 : tail = head;
12954 33768 : while (tail->next != gfc_ss_terminator)
12955 : tail = tail->next;
12956 : }
12957 : }
12958 :
12959 27050 : if (scalar)
12960 : {
12961 : /* If all the arguments are scalar we don't need the argument SS. */
12962 10375 : gfc_free_ss_chain (head);
12963 : /* Pass it back. */
12964 10375 : return ss;
12965 : }
12966 :
12967 : /* Add it onto the existing chain. */
12968 16675 : tail->next = ss;
12969 16675 : return head;
12970 : }
12971 :
12972 :
12973 : /* Walk a function call. Scalar functions are passed back, and taken out of
12974 : scalarization loops. For elemental functions we walk their arguments.
12975 : The result of functions returning arrays is stored in a temporary outside
12976 : the loop, so that the function is only called once. Hence we do not need
12977 : to walk their arguments. */
12978 :
12979 : static gfc_ss *
12980 63689 : gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
12981 : {
12982 63689 : gfc_intrinsic_sym *isym;
12983 63689 : gfc_symbol *sym;
12984 63689 : gfc_component *comp = NULL;
12985 :
12986 63689 : isym = expr->value.function.isym;
12987 :
12988 : /* Handle intrinsic functions separately. */
12989 63689 : if (isym)
12990 55955 : return gfc_walk_intrinsic_function (ss, expr, isym);
12991 :
12992 7734 : sym = expr->value.function.esym;
12993 7734 : if (!sym)
12994 546 : sym = expr->symtree->n.sym;
12995 :
12996 7734 : if (gfc_is_class_array_function (expr))
12997 234 : return gfc_get_array_ss (ss, expr,
12998 234 : CLASS_DATA (expr->value.function.esym->result)->as->rank,
12999 234 : GFC_SS_FUNCTION);
13000 :
13001 : /* A function that returns arrays. */
13002 7500 : comp = gfc_get_proc_ptr_comp (expr);
13003 7102 : if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
13004 7500 : || (comp && comp->attr.dimension))
13005 2680 : return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
13006 :
13007 : /* Walk the parameters of an elemental function. For now we always pass
13008 : by reference. */
13009 4820 : if (sym->attr.elemental || (comp && comp->attr.elemental))
13010 : {
13011 2224 : gfc_ss *old_ss = ss;
13012 :
13013 2224 : ss = gfc_walk_elemental_function_args (old_ss,
13014 : expr->value.function.actual,
13015 : gfc_get_intrinsic_for_expr (expr),
13016 : GFC_SS_REFERENCE);
13017 2224 : if (ss != old_ss
13018 1188 : && (comp
13019 1127 : || sym->attr.proc_pointer
13020 1127 : || sym->attr.if_source != IFSRC_DECL
13021 1005 : || sym->attr.array_outer_dependency))
13022 231 : ss->info->array_outer_dependency = 1;
13023 : }
13024 :
13025 : /* Scalar functions are OK as these are evaluated outside the scalarization
13026 : loop. Pass back and let the caller deal with it. */
13027 : return ss;
13028 : }
13029 :
13030 :
13031 : /* An array temporary is constructed for array constructors. */
13032 :
13033 : static gfc_ss *
13034 51168 : gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
13035 : {
13036 0 : return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_CONSTRUCTOR);
13037 : }
13038 :
13039 :
13040 : /* Walk an expression. Add walked expressions to the head of the SS chain.
13041 : A wholly scalar expression will not be added. */
13042 :
13043 : gfc_ss *
13044 1025167 : gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
13045 : {
13046 1025167 : gfc_ss *head;
13047 :
13048 1025167 : switch (expr->expr_type)
13049 : {
13050 692618 : case EXPR_VARIABLE:
13051 692618 : head = gfc_walk_variable_expr (ss, expr);
13052 692618 : return head;
13053 :
13054 58112 : case EXPR_OP:
13055 58112 : head = gfc_walk_op_expr (ss, expr);
13056 58112 : return head;
13057 :
13058 36 : case EXPR_CONDITIONAL:
13059 36 : head = gfc_walk_conditional_expr (ss, expr);
13060 36 : return head;
13061 :
13062 63689 : case EXPR_FUNCTION:
13063 63689 : head = gfc_walk_function_expr (ss, expr);
13064 63689 : return head;
13065 :
13066 : case EXPR_CONSTANT:
13067 : case EXPR_NULL:
13068 : case EXPR_STRUCTURE:
13069 : /* Pass back and let the caller deal with it. */
13070 : break;
13071 :
13072 51168 : case EXPR_ARRAY:
13073 51168 : head = gfc_walk_array_constructor (ss, expr);
13074 51168 : return head;
13075 :
13076 : case EXPR_SUBSTRING:
13077 : /* Pass back and let the caller deal with it. */
13078 : break;
13079 :
13080 0 : default:
13081 0 : gfc_internal_error ("bad expression type during walk (%d)",
13082 : expr->expr_type);
13083 : }
13084 : return ss;
13085 : }
13086 :
13087 :
13088 : /* Entry point for expression walking.
13089 : A return value equal to the passed chain means this is
13090 : a scalar expression. It is up to the caller to take whatever action is
13091 : necessary to translate these. */
13092 :
13093 : gfc_ss *
13094 866484 : gfc_walk_expr (gfc_expr * expr)
13095 : {
13096 866484 : gfc_ss *res;
13097 :
13098 866484 : res = gfc_walk_subexpr (gfc_ss_terminator, expr);
13099 866484 : return gfc_reverse_ss (res);
13100 : }
|
