1 /* Array translation routines
2 Copyright (C) 2002-2019 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.c-- 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 "trans.h"
86 #include "fold-const.h"
87 #include "constructor.h"
88 #include "trans-types.h"
89 #include "trans-array.h"
90 #include "trans-const.h"
91 #include "dependency.h"
92
93 static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor_base);
94
95 /* The contents of this structure aren't actually used, just the address. */
96 static gfc_ss gfc_ss_terminator_var;
97 gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var;
98
99
100 static tree
gfc_array_dataptr_type(tree desc)101 gfc_array_dataptr_type (tree desc)
102 {
103 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
104 }
105
106
107 /* Build expressions to access the members of an array descriptor.
108 It's surprisingly easy to mess up here, so never access
109 an array descriptor by "brute force", always use these
110 functions. This also avoids problems if we change the format
111 of an array descriptor.
112
113 To understand these magic numbers, look at the comments
114 before gfc_build_array_type() in trans-types.c.
115
116 The code within these defines should be the only code which knows the format
117 of an array descriptor.
118
119 Any code just needing to read obtain the bounds of an array should use
120 gfc_conv_array_* rather than the following functions as these will return
121 know constant values, and work with arrays which do not have descriptors.
122
123 Don't forget to #undef these! */
124
125 #define DATA_FIELD 0
126 #define OFFSET_FIELD 1
127 #define DTYPE_FIELD 2
128 #define SPAN_FIELD 3
129 #define DIMENSION_FIELD 4
130 #define CAF_TOKEN_FIELD 5
131
132 #define STRIDE_SUBFIELD 0
133 #define LBOUND_SUBFIELD 1
134 #define UBOUND_SUBFIELD 2
135
136 /* This provides READ-ONLY access to the data field. The field itself
137 doesn't have the proper type. */
138
139 tree
gfc_conv_descriptor_data_get(tree desc)140 gfc_conv_descriptor_data_get (tree desc)
141 {
142 tree field, type, t;
143
144 type = TREE_TYPE (desc);
145 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
146
147 field = TYPE_FIELDS (type);
148 gcc_assert (DATA_FIELD == 0);
149
150 t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc,
151 field, NULL_TREE);
152 t = fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), t);
153
154 return t;
155 }
156
157 /* This provides WRITE access to the data field.
158
159 TUPLES_P is true if we are generating tuples.
160
161 This function gets called through the following macros:
162 gfc_conv_descriptor_data_set
163 gfc_conv_descriptor_data_set. */
164
165 void
gfc_conv_descriptor_data_set(stmtblock_t * block,tree desc,tree value)166 gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
167 {
168 tree field, type, t;
169
170 type = TREE_TYPE (desc);
171 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
172
173 field = TYPE_FIELDS (type);
174 gcc_assert (DATA_FIELD == 0);
175
176 t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc,
177 field, NULL_TREE);
178 gfc_add_modify (block, t, fold_convert (TREE_TYPE (field), value));
179 }
180
181
182 /* This provides address access to the data field. This should only be
183 used by array allocation, passing this on to the runtime. */
184
185 tree
gfc_conv_descriptor_data_addr(tree desc)186 gfc_conv_descriptor_data_addr (tree desc)
187 {
188 tree field, type, t;
189
190 type = TREE_TYPE (desc);
191 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
192
193 field = TYPE_FIELDS (type);
194 gcc_assert (DATA_FIELD == 0);
195
196 t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc,
197 field, NULL_TREE);
198 return gfc_build_addr_expr (NULL_TREE, t);
199 }
200
201 static tree
gfc_conv_descriptor_offset(tree desc)202 gfc_conv_descriptor_offset (tree desc)
203 {
204 tree type;
205 tree field;
206
207 type = TREE_TYPE (desc);
208 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
209
210 field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD);
211 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
212
213 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
214 desc, field, NULL_TREE);
215 }
216
217 tree
gfc_conv_descriptor_offset_get(tree desc)218 gfc_conv_descriptor_offset_get (tree desc)
219 {
220 return gfc_conv_descriptor_offset (desc);
221 }
222
223 void
gfc_conv_descriptor_offset_set(stmtblock_t * block,tree desc,tree value)224 gfc_conv_descriptor_offset_set (stmtblock_t *block, tree desc,
225 tree value)
226 {
227 tree t = gfc_conv_descriptor_offset (desc);
228 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
229 }
230
231
232 tree
gfc_conv_descriptor_dtype(tree desc)233 gfc_conv_descriptor_dtype (tree desc)
234 {
235 tree field;
236 tree type;
237
238 type = TREE_TYPE (desc);
239 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
240
241 field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
242 gcc_assert (field != NULL_TREE
243 && TREE_TYPE (field) == get_dtype_type_node ());
244
245 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
246 desc, field, NULL_TREE);
247 }
248
249 static tree
gfc_conv_descriptor_span(tree desc)250 gfc_conv_descriptor_span (tree desc)
251 {
252 tree type;
253 tree field;
254
255 type = TREE_TYPE (desc);
256 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
257
258 field = gfc_advance_chain (TYPE_FIELDS (type), SPAN_FIELD);
259 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
260
261 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
262 desc, field, NULL_TREE);
263 }
264
265 tree
gfc_conv_descriptor_span_get(tree desc)266 gfc_conv_descriptor_span_get (tree desc)
267 {
268 return gfc_conv_descriptor_span (desc);
269 }
270
271 void
gfc_conv_descriptor_span_set(stmtblock_t * block,tree desc,tree value)272 gfc_conv_descriptor_span_set (stmtblock_t *block, tree desc,
273 tree value)
274 {
275 tree t = gfc_conv_descriptor_span (desc);
276 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
277 }
278
279
280 tree
gfc_conv_descriptor_rank(tree desc)281 gfc_conv_descriptor_rank (tree desc)
282 {
283 tree tmp;
284 tree dtype;
285
286 dtype = gfc_conv_descriptor_dtype (desc);
287 tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), GFC_DTYPE_RANK);
288 gcc_assert (tmp != NULL_TREE
289 && TREE_TYPE (tmp) == signed_char_type_node);
290 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
291 dtype, tmp, NULL_TREE);
292 }
293
294
295 /* Return the element length from the descriptor dtype field. */
296
297 tree
gfc_conv_descriptor_elem_len(tree desc)298 gfc_conv_descriptor_elem_len (tree desc)
299 {
300 tree tmp;
301 tree dtype;
302
303 dtype = gfc_conv_descriptor_dtype (desc);
304 tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)),
305 GFC_DTYPE_ELEM_LEN);
306 gcc_assert (tmp != NULL_TREE
307 && TREE_TYPE (tmp) == size_type_node);
308 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
309 dtype, tmp, NULL_TREE);
310 }
311
312
313 tree
gfc_conv_descriptor_attribute(tree desc)314 gfc_conv_descriptor_attribute (tree desc)
315 {
316 tree tmp;
317 tree dtype;
318
319 dtype = gfc_conv_descriptor_dtype (desc);
320 tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)),
321 GFC_DTYPE_ATTRIBUTE);
322 gcc_assert (tmp!= NULL_TREE
323 && TREE_TYPE (tmp) == short_integer_type_node);
324 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
325 dtype, tmp, NULL_TREE);
326 }
327
328
329 tree
gfc_get_descriptor_dimension(tree desc)330 gfc_get_descriptor_dimension (tree desc)
331 {
332 tree type, field;
333
334 type = TREE_TYPE (desc);
335 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
336
337 field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
338 gcc_assert (field != NULL_TREE
339 && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
340 && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
341
342 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
343 desc, field, NULL_TREE);
344 }
345
346
347 static tree
gfc_conv_descriptor_dimension(tree desc,tree dim)348 gfc_conv_descriptor_dimension (tree desc, tree dim)
349 {
350 tree tmp;
351
352 tmp = gfc_get_descriptor_dimension (desc);
353
354 return gfc_build_array_ref (tmp, dim, NULL);
355 }
356
357
358 tree
gfc_conv_descriptor_token(tree desc)359 gfc_conv_descriptor_token (tree desc)
360 {
361 tree type;
362 tree field;
363
364 type = TREE_TYPE (desc);
365 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
366 gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
367 field = gfc_advance_chain (TYPE_FIELDS (type), CAF_TOKEN_FIELD);
368
369 /* Should be a restricted pointer - except in the finalization wrapper. */
370 gcc_assert (field != NULL_TREE
371 && (TREE_TYPE (field) == prvoid_type_node
372 || TREE_TYPE (field) == pvoid_type_node));
373
374 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
375 desc, field, NULL_TREE);
376 }
377
378
379 static tree
gfc_conv_descriptor_stride(tree desc,tree dim)380 gfc_conv_descriptor_stride (tree desc, tree dim)
381 {
382 tree tmp;
383 tree field;
384
385 tmp = gfc_conv_descriptor_dimension (desc, dim);
386 field = TYPE_FIELDS (TREE_TYPE (tmp));
387 field = gfc_advance_chain (field, STRIDE_SUBFIELD);
388 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
389
390 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
391 tmp, field, NULL_TREE);
392 return tmp;
393 }
394
395 tree
gfc_conv_descriptor_stride_get(tree desc,tree dim)396 gfc_conv_descriptor_stride_get (tree desc, tree dim)
397 {
398 tree type = TREE_TYPE (desc);
399 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
400 if (integer_zerop (dim)
401 && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
402 ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT
403 ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT
404 ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
405 return gfc_index_one_node;
406
407 return gfc_conv_descriptor_stride (desc, dim);
408 }
409
410 void
gfc_conv_descriptor_stride_set(stmtblock_t * block,tree desc,tree dim,tree value)411 gfc_conv_descriptor_stride_set (stmtblock_t *block, tree desc,
412 tree dim, tree value)
413 {
414 tree t = gfc_conv_descriptor_stride (desc, dim);
415 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
416 }
417
418 static tree
gfc_conv_descriptor_lbound(tree desc,tree dim)419 gfc_conv_descriptor_lbound (tree desc, tree dim)
420 {
421 tree tmp;
422 tree field;
423
424 tmp = gfc_conv_descriptor_dimension (desc, dim);
425 field = TYPE_FIELDS (TREE_TYPE (tmp));
426 field = gfc_advance_chain (field, LBOUND_SUBFIELD);
427 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
428
429 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
430 tmp, field, NULL_TREE);
431 return tmp;
432 }
433
434 tree
gfc_conv_descriptor_lbound_get(tree desc,tree dim)435 gfc_conv_descriptor_lbound_get (tree desc, tree dim)
436 {
437 return gfc_conv_descriptor_lbound (desc, dim);
438 }
439
440 void
gfc_conv_descriptor_lbound_set(stmtblock_t * block,tree desc,tree dim,tree value)441 gfc_conv_descriptor_lbound_set (stmtblock_t *block, tree desc,
442 tree dim, tree value)
443 {
444 tree t = gfc_conv_descriptor_lbound (desc, dim);
445 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
446 }
447
448 static tree
gfc_conv_descriptor_ubound(tree desc,tree dim)449 gfc_conv_descriptor_ubound (tree desc, tree dim)
450 {
451 tree tmp;
452 tree field;
453
454 tmp = gfc_conv_descriptor_dimension (desc, dim);
455 field = TYPE_FIELDS (TREE_TYPE (tmp));
456 field = gfc_advance_chain (field, UBOUND_SUBFIELD);
457 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
458
459 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
460 tmp, field, NULL_TREE);
461 return tmp;
462 }
463
464 tree
gfc_conv_descriptor_ubound_get(tree desc,tree dim)465 gfc_conv_descriptor_ubound_get (tree desc, tree dim)
466 {
467 return gfc_conv_descriptor_ubound (desc, dim);
468 }
469
470 void
gfc_conv_descriptor_ubound_set(stmtblock_t * block,tree desc,tree dim,tree value)471 gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree desc,
472 tree dim, tree value)
473 {
474 tree t = gfc_conv_descriptor_ubound (desc, dim);
475 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
476 }
477
478 /* Build a null array descriptor constructor. */
479
480 tree
gfc_build_null_descriptor(tree type)481 gfc_build_null_descriptor (tree type)
482 {
483 tree field;
484 tree tmp;
485
486 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
487 gcc_assert (DATA_FIELD == 0);
488 field = TYPE_FIELDS (type);
489
490 /* Set a NULL data pointer. */
491 tmp = build_constructor_single (type, field, null_pointer_node);
492 TREE_CONSTANT (tmp) = 1;
493 /* All other fields are ignored. */
494
495 return tmp;
496 }
497
498
499 /* Modify a descriptor such that the lbound of a given dimension is the value
500 specified. This also updates ubound and offset accordingly. */
501
502 void
gfc_conv_shift_descriptor_lbound(stmtblock_t * block,tree desc,int dim,tree new_lbound)503 gfc_conv_shift_descriptor_lbound (stmtblock_t* block, tree desc,
504 int dim, tree new_lbound)
505 {
506 tree offs, ubound, lbound, stride;
507 tree diff, offs_diff;
508
509 new_lbound = fold_convert (gfc_array_index_type, new_lbound);
510
511 offs = gfc_conv_descriptor_offset_get (desc);
512 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
513 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
514 stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]);
515
516 /* Get difference (new - old) by which to shift stuff. */
517 diff = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
518 new_lbound, lbound);
519
520 /* Shift ubound and offset accordingly. This has to be done before
521 updating the lbound, as they depend on the lbound expression! */
522 ubound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
523 ubound, diff);
524 gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[dim], ubound);
525 offs_diff = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
526 diff, stride);
527 offs = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
528 offs, offs_diff);
529 gfc_conv_descriptor_offset_set (block, desc, offs);
530
531 /* Finally set lbound to value we want. */
532 gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[dim], new_lbound);
533 }
534
535
536 /* Obtain offsets for trans-types.c(gfc_get_array_descr_info). */
537
538 void
gfc_get_descriptor_offsets_for_info(const_tree desc_type,tree * data_off,tree * dtype_off,tree * dim_off,tree * dim_size,tree * stride_suboff,tree * lower_suboff,tree * upper_suboff)539 gfc_get_descriptor_offsets_for_info (const_tree desc_type, tree *data_off,
540 tree *dtype_off, tree *dim_off,
541 tree *dim_size, tree *stride_suboff,
542 tree *lower_suboff, tree *upper_suboff)
543 {
544 tree field;
545 tree type;
546
547 type = TYPE_MAIN_VARIANT (desc_type);
548 field = gfc_advance_chain (TYPE_FIELDS (type), DATA_FIELD);
549 *data_off = byte_position (field);
550 field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
551 *dtype_off = byte_position (field);
552 field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
553 *dim_off = byte_position (field);
554 type = TREE_TYPE (TREE_TYPE (field));
555 *dim_size = TYPE_SIZE_UNIT (type);
556 field = gfc_advance_chain (TYPE_FIELDS (type), STRIDE_SUBFIELD);
557 *stride_suboff = byte_position (field);
558 field = gfc_advance_chain (TYPE_FIELDS (type), LBOUND_SUBFIELD);
559 *lower_suboff = byte_position (field);
560 field = gfc_advance_chain (TYPE_FIELDS (type), UBOUND_SUBFIELD);
561 *upper_suboff = byte_position (field);
562 }
563
564
565 /* Cleanup those #defines. */
566
567 #undef DATA_FIELD
568 #undef OFFSET_FIELD
569 #undef DTYPE_FIELD
570 #undef SPAN_FIELD
571 #undef DIMENSION_FIELD
572 #undef CAF_TOKEN_FIELD
573 #undef STRIDE_SUBFIELD
574 #undef LBOUND_SUBFIELD
575 #undef UBOUND_SUBFIELD
576
577
578 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
579 flags & 1 = Main loop body.
580 flags & 2 = temp copy loop. */
581
582 void
gfc_mark_ss_chain_used(gfc_ss * ss,unsigned flags)583 gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
584 {
585 for (; ss != gfc_ss_terminator; ss = ss->next)
586 ss->info->useflags = flags;
587 }
588
589
590 /* Free a gfc_ss chain. */
591
592 void
gfc_free_ss_chain(gfc_ss * ss)593 gfc_free_ss_chain (gfc_ss * ss)
594 {
595 gfc_ss *next;
596
597 while (ss != gfc_ss_terminator)
598 {
599 gcc_assert (ss != NULL);
600 next = ss->next;
601 gfc_free_ss (ss);
602 ss = next;
603 }
604 }
605
606
607 static void
free_ss_info(gfc_ss_info * ss_info)608 free_ss_info (gfc_ss_info *ss_info)
609 {
610 int n;
611
612 ss_info->refcount--;
613 if (ss_info->refcount > 0)
614 return;
615
616 gcc_assert (ss_info->refcount == 0);
617
618 switch (ss_info->type)
619 {
620 case GFC_SS_SECTION:
621 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
622 if (ss_info->data.array.subscript[n])
623 gfc_free_ss_chain (ss_info->data.array.subscript[n]);
624 break;
625
626 default:
627 break;
628 }
629
630 free (ss_info);
631 }
632
633
634 /* Free a SS. */
635
636 void
gfc_free_ss(gfc_ss * ss)637 gfc_free_ss (gfc_ss * ss)
638 {
639 free_ss_info (ss->info);
640 free (ss);
641 }
642
643
644 /* Creates and initializes an array type gfc_ss struct. */
645
646 gfc_ss *
gfc_get_array_ss(gfc_ss * next,gfc_expr * expr,int dimen,gfc_ss_type type)647 gfc_get_array_ss (gfc_ss *next, gfc_expr *expr, int dimen, gfc_ss_type type)
648 {
649 gfc_ss *ss;
650 gfc_ss_info *ss_info;
651 int i;
652
653 ss_info = gfc_get_ss_info ();
654 ss_info->refcount++;
655 ss_info->type = type;
656 ss_info->expr = expr;
657
658 ss = gfc_get_ss ();
659 ss->info = ss_info;
660 ss->next = next;
661 ss->dimen = dimen;
662 for (i = 0; i < ss->dimen; i++)
663 ss->dim[i] = i;
664
665 return ss;
666 }
667
668
669 /* Creates and initializes a temporary type gfc_ss struct. */
670
671 gfc_ss *
gfc_get_temp_ss(tree type,tree string_length,int dimen)672 gfc_get_temp_ss (tree type, tree string_length, int dimen)
673 {
674 gfc_ss *ss;
675 gfc_ss_info *ss_info;
676 int i;
677
678 ss_info = gfc_get_ss_info ();
679 ss_info->refcount++;
680 ss_info->type = GFC_SS_TEMP;
681 ss_info->string_length = string_length;
682 ss_info->data.temp.type = type;
683
684 ss = gfc_get_ss ();
685 ss->info = ss_info;
686 ss->next = gfc_ss_terminator;
687 ss->dimen = dimen;
688 for (i = 0; i < ss->dimen; i++)
689 ss->dim[i] = i;
690
691 return ss;
692 }
693
694
695 /* Creates and initializes a scalar type gfc_ss struct. */
696
697 gfc_ss *
gfc_get_scalar_ss(gfc_ss * next,gfc_expr * expr)698 gfc_get_scalar_ss (gfc_ss *next, gfc_expr *expr)
699 {
700 gfc_ss *ss;
701 gfc_ss_info *ss_info;
702
703 ss_info = gfc_get_ss_info ();
704 ss_info->refcount++;
705 ss_info->type = GFC_SS_SCALAR;
706 ss_info->expr = expr;
707
708 ss = gfc_get_ss ();
709 ss->info = ss_info;
710 ss->next = next;
711
712 return ss;
713 }
714
715
716 /* Free all the SS associated with a loop. */
717
718 void
gfc_cleanup_loop(gfc_loopinfo * loop)719 gfc_cleanup_loop (gfc_loopinfo * loop)
720 {
721 gfc_loopinfo *loop_next, **ploop;
722 gfc_ss *ss;
723 gfc_ss *next;
724
725 ss = loop->ss;
726 while (ss != gfc_ss_terminator)
727 {
728 gcc_assert (ss != NULL);
729 next = ss->loop_chain;
730 gfc_free_ss (ss);
731 ss = next;
732 }
733
734 /* Remove reference to self in the parent loop. */
735 if (loop->parent)
736 for (ploop = &loop->parent->nested; *ploop; ploop = &(*ploop)->next)
737 if (*ploop == loop)
738 {
739 *ploop = loop->next;
740 break;
741 }
742
743 /* Free non-freed nested loops. */
744 for (loop = loop->nested; loop; loop = loop_next)
745 {
746 loop_next = loop->next;
747 gfc_cleanup_loop (loop);
748 free (loop);
749 }
750 }
751
752
753 static void
set_ss_loop(gfc_ss * ss,gfc_loopinfo * loop)754 set_ss_loop (gfc_ss *ss, gfc_loopinfo *loop)
755 {
756 int n;
757
758 for (; ss != gfc_ss_terminator; ss = ss->next)
759 {
760 ss->loop = loop;
761
762 if (ss->info->type == GFC_SS_SCALAR
763 || ss->info->type == GFC_SS_REFERENCE
764 || ss->info->type == GFC_SS_TEMP)
765 continue;
766
767 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
768 if (ss->info->data.array.subscript[n] != NULL)
769 set_ss_loop (ss->info->data.array.subscript[n], loop);
770 }
771 }
772
773
774 /* Associate a SS chain with a loop. */
775
776 void
gfc_add_ss_to_loop(gfc_loopinfo * loop,gfc_ss * head)777 gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
778 {
779 gfc_ss *ss;
780 gfc_loopinfo *nested_loop;
781
782 if (head == gfc_ss_terminator)
783 return;
784
785 set_ss_loop (head, loop);
786
787 ss = head;
788 for (; ss && ss != gfc_ss_terminator; ss = ss->next)
789 {
790 if (ss->nested_ss)
791 {
792 nested_loop = ss->nested_ss->loop;
793
794 /* More than one ss can belong to the same loop. Hence, we add the
795 loop to the chain only if it is different from the previously
796 added one, to avoid duplicate nested loops. */
797 if (nested_loop != loop->nested)
798 {
799 gcc_assert (nested_loop->parent == NULL);
800 nested_loop->parent = loop;
801
802 gcc_assert (nested_loop->next == NULL);
803 nested_loop->next = loop->nested;
804 loop->nested = nested_loop;
805 }
806 else
807 gcc_assert (nested_loop->parent == loop);
808 }
809
810 if (ss->next == gfc_ss_terminator)
811 ss->loop_chain = loop->ss;
812 else
813 ss->loop_chain = ss->next;
814 }
815 gcc_assert (ss == gfc_ss_terminator);
816 loop->ss = head;
817 }
818
819
820 /* Returns true if the expression is an array pointer. */
821
822 static bool
is_pointer_array(tree expr)823 is_pointer_array (tree expr)
824 {
825 if (expr == NULL_TREE
826 || !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr))
827 || GFC_CLASS_TYPE_P (TREE_TYPE (expr)))
828 return false;
829
830 if (TREE_CODE (expr) == VAR_DECL
831 && GFC_DECL_PTR_ARRAY_P (expr))
832 return true;
833
834 if (TREE_CODE (expr) == PARM_DECL
835 && GFC_DECL_PTR_ARRAY_P (expr))
836 return true;
837
838 if (TREE_CODE (expr) == INDIRECT_REF
839 && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 0)))
840 return true;
841
842 /* The field declaration is marked as an pointer array. */
843 if (TREE_CODE (expr) == COMPONENT_REF
844 && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 1))
845 && !GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (expr, 1))))
846 return true;
847
848 return false;
849 }
850
851
852 /* If the symbol or expression reference a CFI descriptor, return the
853 pointer to the converted gfc descriptor. If an array reference is
854 present as the last argument, check that it is the one applied to
855 the CFI descriptor in the expression. Note that the CFI object is
856 always the symbol in the expression! */
857
858 static bool
get_CFI_desc(gfc_symbol * sym,gfc_expr * expr,tree * desc,gfc_array_ref * ar)859 get_CFI_desc (gfc_symbol *sym, gfc_expr *expr,
860 tree *desc, gfc_array_ref *ar)
861 {
862 tree tmp;
863
864 if (!is_CFI_desc (sym, expr))
865 return false;
866
867 if (expr && ar)
868 {
869 if (!(expr->ref && expr->ref->type == REF_ARRAY)
870 || (&expr->ref->u.ar != ar))
871 return false;
872 }
873
874 if (sym == NULL)
875 tmp = expr->symtree->n.sym->backend_decl;
876 else
877 tmp = sym->backend_decl;
878
879 if (tmp && DECL_LANG_SPECIFIC (tmp))
880 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
881
882 *desc = tmp;
883 return true;
884 }
885
886
887 /* Return the span of an array. */
888
889 tree
gfc_get_array_span(tree desc,gfc_expr * expr)890 gfc_get_array_span (tree desc, gfc_expr *expr)
891 {
892 tree tmp;
893
894 if (is_pointer_array (desc) || get_CFI_desc (NULL, expr, &desc, NULL))
895 {
896 if (POINTER_TYPE_P (TREE_TYPE (desc)))
897 desc = build_fold_indirect_ref_loc (input_location, desc);
898
899 /* This will have the span field set. */
900 tmp = gfc_conv_descriptor_span_get (desc);
901 }
902 else if (TREE_CODE (desc) == COMPONENT_REF
903 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
904 && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (desc, 0))))
905 {
906 /* The descriptor is a class _data field and so use the vtable
907 size for the receiving span field. */
908 tmp = gfc_get_vptr_from_expr (desc);
909 tmp = gfc_vptr_size_get (tmp);
910 }
911 else if (expr && expr->expr_type == EXPR_VARIABLE
912 && expr->symtree->n.sym->ts.type == BT_CLASS
913 && expr->ref->type == REF_COMPONENT
914 && expr->ref->next->type == REF_ARRAY
915 && expr->ref->next->next == NULL
916 && CLASS_DATA (expr->symtree->n.sym)->attr.dimension)
917 {
918 /* Dummys come in sometimes with the descriptor detached from
919 the class field or declaration. */
920 tmp = gfc_class_vptr_get (expr->symtree->n.sym->backend_decl);
921 tmp = gfc_vptr_size_get (tmp);
922 }
923 else
924 {
925 /* If none of the fancy stuff works, the span is the element
926 size of the array. Attempt to deal with unbounded character
927 types if possible. Otherwise, return NULL_TREE. */
928 tmp = gfc_get_element_type (TREE_TYPE (desc));
929 if (tmp && TREE_CODE (tmp) == ARRAY_TYPE
930 && (TYPE_MAX_VALUE (TYPE_DOMAIN (tmp)) == NULL_TREE
931 || integer_zerop (TYPE_MAX_VALUE (TYPE_DOMAIN (tmp)))))
932 {
933 if (expr->expr_type == EXPR_VARIABLE
934 && expr->ts.type == BT_CHARACTER)
935 tmp = fold_convert (gfc_array_index_type,
936 gfc_get_expr_charlen (expr));
937 else
938 tmp = NULL_TREE;
939 }
940 else
941 tmp = fold_convert (gfc_array_index_type,
942 size_in_bytes (tmp));
943 }
944 return tmp;
945 }
946
947
948 /* Generate an initializer for a static pointer or allocatable array. */
949
950 void
gfc_trans_static_array_pointer(gfc_symbol * sym)951 gfc_trans_static_array_pointer (gfc_symbol * sym)
952 {
953 tree type;
954
955 gcc_assert (TREE_STATIC (sym->backend_decl));
956 /* Just zero the data member. */
957 type = TREE_TYPE (sym->backend_decl);
958 DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
959 }
960
961
962 /* If the bounds of SE's loop have not yet been set, see if they can be
963 determined from array spec AS, which is the array spec of a called
964 function. MAPPING maps the callee's dummy arguments to the values
965 that the caller is passing. Add any initialization and finalization
966 code to SE. */
967
968 void
gfc_set_loop_bounds_from_array_spec(gfc_interface_mapping * mapping,gfc_se * se,gfc_array_spec * as)969 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
970 gfc_se * se, gfc_array_spec * as)
971 {
972 int n, dim, total_dim;
973 gfc_se tmpse;
974 gfc_ss *ss;
975 tree lower;
976 tree upper;
977 tree tmp;
978
979 total_dim = 0;
980
981 if (!as || as->type != AS_EXPLICIT)
982 return;
983
984 for (ss = se->ss; ss; ss = ss->parent)
985 {
986 total_dim += ss->loop->dimen;
987 for (n = 0; n < ss->loop->dimen; n++)
988 {
989 /* The bound is known, nothing to do. */
990 if (ss->loop->to[n] != NULL_TREE)
991 continue;
992
993 dim = ss->dim[n];
994 gcc_assert (dim < as->rank);
995 gcc_assert (ss->loop->dimen <= as->rank);
996
997 /* Evaluate the lower bound. */
998 gfc_init_se (&tmpse, NULL);
999 gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
1000 gfc_add_block_to_block (&se->pre, &tmpse.pre);
1001 gfc_add_block_to_block (&se->post, &tmpse.post);
1002 lower = fold_convert (gfc_array_index_type, tmpse.expr);
1003
1004 /* ...and the upper bound. */
1005 gfc_init_se (&tmpse, NULL);
1006 gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
1007 gfc_add_block_to_block (&se->pre, &tmpse.pre);
1008 gfc_add_block_to_block (&se->post, &tmpse.post);
1009 upper = fold_convert (gfc_array_index_type, tmpse.expr);
1010
1011 /* Set the upper bound of the loop to UPPER - LOWER. */
1012 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1013 gfc_array_index_type, upper, lower);
1014 tmp = gfc_evaluate_now (tmp, &se->pre);
1015 ss->loop->to[n] = tmp;
1016 }
1017 }
1018
1019 gcc_assert (total_dim == as->rank);
1020 }
1021
1022
1023 /* Generate code to allocate an array temporary, or create a variable to
1024 hold the data. If size is NULL, zero the descriptor so that the
1025 callee will allocate the array. If DEALLOC is true, also generate code to
1026 free the array afterwards.
1027
1028 If INITIAL is not NULL, it is packed using internal_pack and the result used
1029 as data instead of allocating a fresh, unitialized area of memory.
1030
1031 Initialization code is added to PRE and finalization code to POST.
1032 DYNAMIC is true if the caller may want to extend the array later
1033 using realloc. This prevents us from putting the array on the stack. */
1034
1035 static void
gfc_trans_allocate_array_storage(stmtblock_t * pre,stmtblock_t * post,gfc_array_info * info,tree size,tree nelem,tree initial,bool dynamic,bool dealloc)1036 gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
1037 gfc_array_info * info, tree size, tree nelem,
1038 tree initial, bool dynamic, bool dealloc)
1039 {
1040 tree tmp;
1041 tree desc;
1042 bool onstack;
1043
1044 desc = info->descriptor;
1045 info->offset = gfc_index_zero_node;
1046 if (size == NULL_TREE || integer_zerop (size))
1047 {
1048 /* A callee allocated array. */
1049 gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
1050 onstack = FALSE;
1051 }
1052 else
1053 {
1054 /* Allocate the temporary. */
1055 onstack = !dynamic && initial == NULL_TREE
1056 && (flag_stack_arrays
1057 || gfc_can_put_var_on_stack (size));
1058
1059 if (onstack)
1060 {
1061 /* Make a temporary variable to hold the data. */
1062 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (nelem),
1063 nelem, gfc_index_one_node);
1064 tmp = gfc_evaluate_now (tmp, pre);
1065 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
1066 tmp);
1067 tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
1068 tmp);
1069 tmp = gfc_create_var (tmp, "A");
1070 /* If we're here only because of -fstack-arrays we have to
1071 emit a DECL_EXPR to make the gimplifier emit alloca calls. */
1072 if (!gfc_can_put_var_on_stack (size))
1073 gfc_add_expr_to_block (pre,
1074 fold_build1_loc (input_location,
1075 DECL_EXPR, TREE_TYPE (tmp),
1076 tmp));
1077 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1078 gfc_conv_descriptor_data_set (pre, desc, tmp);
1079 }
1080 else
1081 {
1082 /* Allocate memory to hold the data or call internal_pack. */
1083 if (initial == NULL_TREE)
1084 {
1085 tmp = gfc_call_malloc (pre, NULL, size);
1086 tmp = gfc_evaluate_now (tmp, pre);
1087 }
1088 else
1089 {
1090 tree packed;
1091 tree source_data;
1092 tree was_packed;
1093 stmtblock_t do_copying;
1094
1095 tmp = TREE_TYPE (initial); /* Pointer to descriptor. */
1096 gcc_assert (TREE_CODE (tmp) == POINTER_TYPE);
1097 tmp = TREE_TYPE (tmp); /* The descriptor itself. */
1098 tmp = gfc_get_element_type (tmp);
1099 gcc_assert (tmp == gfc_get_element_type (TREE_TYPE (desc)));
1100 packed = gfc_create_var (build_pointer_type (tmp), "data");
1101
1102 tmp = build_call_expr_loc (input_location,
1103 gfor_fndecl_in_pack, 1, initial);
1104 tmp = fold_convert (TREE_TYPE (packed), tmp);
1105 gfc_add_modify (pre, packed, tmp);
1106
1107 tmp = build_fold_indirect_ref_loc (input_location,
1108 initial);
1109 source_data = gfc_conv_descriptor_data_get (tmp);
1110
1111 /* internal_pack may return source->data without any allocation
1112 or copying if it is already packed. If that's the case, we
1113 need to allocate and copy manually. */
1114
1115 gfc_start_block (&do_copying);
1116 tmp = gfc_call_malloc (&do_copying, NULL, size);
1117 tmp = fold_convert (TREE_TYPE (packed), tmp);
1118 gfc_add_modify (&do_copying, packed, tmp);
1119 tmp = gfc_build_memcpy_call (packed, source_data, size);
1120 gfc_add_expr_to_block (&do_copying, tmp);
1121
1122 was_packed = fold_build2_loc (input_location, EQ_EXPR,
1123 logical_type_node, packed,
1124 source_data);
1125 tmp = gfc_finish_block (&do_copying);
1126 tmp = build3_v (COND_EXPR, was_packed, tmp,
1127 build_empty_stmt (input_location));
1128 gfc_add_expr_to_block (pre, tmp);
1129
1130 tmp = fold_convert (pvoid_type_node, packed);
1131 }
1132
1133 gfc_conv_descriptor_data_set (pre, desc, tmp);
1134 }
1135 }
1136 info->data = gfc_conv_descriptor_data_get (desc);
1137
1138 /* The offset is zero because we create temporaries with a zero
1139 lower bound. */
1140 gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node);
1141
1142 if (dealloc && !onstack)
1143 {
1144 /* Free the temporary. */
1145 tmp = gfc_conv_descriptor_data_get (desc);
1146 tmp = gfc_call_free (tmp);
1147 gfc_add_expr_to_block (post, tmp);
1148 }
1149 }
1150
1151
1152 /* Get the scalarizer array dimension corresponding to actual array dimension
1153 given by ARRAY_DIM.
1154
1155 For example, if SS represents the array ref a(1,:,:,1), it is a
1156 bidimensional scalarizer array, and the result would be 0 for ARRAY_DIM=1,
1157 and 1 for ARRAY_DIM=2.
1158 If SS represents transpose(a(:,1,1,:)), it is again a bidimensional
1159 scalarizer array, and the result would be 1 for ARRAY_DIM=0 and 0 for
1160 ARRAY_DIM=3.
1161 If SS represents sum(a(:,:,:,1), dim=1), it is a 2+1-dimensional scalarizer
1162 array. If called on the inner ss, the result would be respectively 0,1,2 for
1163 ARRAY_DIM=0,1,2. If called on the outer ss, the result would be 0,1
1164 for ARRAY_DIM=1,2. */
1165
1166 static int
get_scalarizer_dim_for_array_dim(gfc_ss * ss,int array_dim)1167 get_scalarizer_dim_for_array_dim (gfc_ss *ss, int array_dim)
1168 {
1169 int array_ref_dim;
1170 int n;
1171
1172 array_ref_dim = 0;
1173
1174 for (; ss; ss = ss->parent)
1175 for (n = 0; n < ss->dimen; n++)
1176 if (ss->dim[n] < array_dim)
1177 array_ref_dim++;
1178
1179 return array_ref_dim;
1180 }
1181
1182
1183 static gfc_ss *
innermost_ss(gfc_ss * ss)1184 innermost_ss (gfc_ss *ss)
1185 {
1186 while (ss->nested_ss != NULL)
1187 ss = ss->nested_ss;
1188
1189 return ss;
1190 }
1191
1192
1193
1194 /* Get the array reference dimension corresponding to the given loop dimension.
1195 It is different from the true array dimension given by the dim array in
1196 the case of a partial array reference (i.e. a(:,:,1,:) for example)
1197 It is different from the loop dimension in the case of a transposed array.
1198 */
1199
1200 static int
get_array_ref_dim_for_loop_dim(gfc_ss * ss,int loop_dim)1201 get_array_ref_dim_for_loop_dim (gfc_ss *ss, int loop_dim)
1202 {
1203 return get_scalarizer_dim_for_array_dim (innermost_ss (ss),
1204 ss->dim[loop_dim]);
1205 }
1206
1207
1208 /* Generate code to create and initialize the descriptor for a temporary
1209 array. This is used for both temporaries needed by the scalarizer, and
1210 functions returning arrays. Adjusts the loop variables to be
1211 zero-based, and calculates the loop bounds for callee allocated arrays.
1212 Allocate the array unless it's callee allocated (we have a callee
1213 allocated array if 'callee_alloc' is true, or if loop->to[n] is
1214 NULL_TREE for any n). Also fills in the descriptor, data and offset
1215 fields of info if known. Returns the size of the array, or NULL for a
1216 callee allocated array.
1217
1218 'eltype' == NULL signals that the temporary should be a class object.
1219 The 'initial' expression is used to obtain the size of the dynamic
1220 type; otherwise the allocation and initialization proceeds as for any
1221 other expression
1222
1223 PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
1224 gfc_trans_allocate_array_storage. */
1225
1226 tree
gfc_trans_create_temp_array(stmtblock_t * pre,stmtblock_t * post,gfc_ss * ss,tree eltype,tree initial,bool dynamic,bool dealloc,bool callee_alloc,locus * where)1227 gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
1228 tree eltype, tree initial, bool dynamic,
1229 bool dealloc, bool callee_alloc, locus * where)
1230 {
1231 gfc_loopinfo *loop;
1232 gfc_ss *s;
1233 gfc_array_info *info;
1234 tree from[GFC_MAX_DIMENSIONS], to[GFC_MAX_DIMENSIONS];
1235 tree type;
1236 tree desc;
1237 tree tmp;
1238 tree size;
1239 tree nelem;
1240 tree cond;
1241 tree or_expr;
1242 tree class_expr = NULL_TREE;
1243 int n, dim, tmp_dim;
1244 int total_dim = 0;
1245
1246 /* This signals a class array for which we need the size of the
1247 dynamic type. Generate an eltype and then the class expression. */
1248 if (eltype == NULL_TREE && initial)
1249 {
1250 gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial)));
1251 class_expr = build_fold_indirect_ref_loc (input_location, initial);
1252 eltype = TREE_TYPE (class_expr);
1253 eltype = gfc_get_element_type (eltype);
1254 /* Obtain the structure (class) expression. */
1255 class_expr = TREE_OPERAND (class_expr, 0);
1256 gcc_assert (class_expr);
1257 }
1258
1259 memset (from, 0, sizeof (from));
1260 memset (to, 0, sizeof (to));
1261
1262 info = &ss->info->data.array;
1263
1264 gcc_assert (ss->dimen > 0);
1265 gcc_assert (ss->loop->dimen == ss->dimen);
1266
1267 if (warn_array_temporaries && where)
1268 gfc_warning (OPT_Warray_temporaries,
1269 "Creating array temporary at %L", where);
1270
1271 /* Set the lower bound to zero. */
1272 for (s = ss; s; s = s->parent)
1273 {
1274 loop = s->loop;
1275
1276 total_dim += loop->dimen;
1277 for (n = 0; n < loop->dimen; n++)
1278 {
1279 dim = s->dim[n];
1280
1281 /* Callee allocated arrays may not have a known bound yet. */
1282 if (loop->to[n])
1283 loop->to[n] = gfc_evaluate_now (
1284 fold_build2_loc (input_location, MINUS_EXPR,
1285 gfc_array_index_type,
1286 loop->to[n], loop->from[n]),
1287 pre);
1288 loop->from[n] = gfc_index_zero_node;
1289
1290 /* We have just changed the loop bounds, we must clear the
1291 corresponding specloop, so that delta calculation is not skipped
1292 later in gfc_set_delta. */
1293 loop->specloop[n] = NULL;
1294
1295 /* We are constructing the temporary's descriptor based on the loop
1296 dimensions. As the dimensions may be accessed in arbitrary order
1297 (think of transpose) the size taken from the n'th loop may not map
1298 to the n'th dimension of the array. We need to reconstruct loop
1299 infos in the right order before using it to set the descriptor
1300 bounds. */
1301 tmp_dim = get_scalarizer_dim_for_array_dim (ss, dim);
1302 from[tmp_dim] = loop->from[n];
1303 to[tmp_dim] = loop->to[n];
1304
1305 info->delta[dim] = gfc_index_zero_node;
1306 info->start[dim] = gfc_index_zero_node;
1307 info->end[dim] = gfc_index_zero_node;
1308 info->stride[dim] = gfc_index_one_node;
1309 }
1310 }
1311
1312 /* Initialize the descriptor. */
1313 type =
1314 gfc_get_array_type_bounds (eltype, total_dim, 0, from, to, 1,
1315 GFC_ARRAY_UNKNOWN, true);
1316 desc = gfc_create_var (type, "atmp");
1317 GFC_DECL_PACKED_ARRAY (desc) = 1;
1318
1319 info->descriptor = desc;
1320 size = gfc_index_one_node;
1321
1322 /* Emit a DECL_EXPR for the variable sized array type in
1323 GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
1324 sizes works correctly. */
1325 tree arraytype = TREE_TYPE (GFC_TYPE_ARRAY_DATAPTR_TYPE (type));
1326 if (! TYPE_NAME (arraytype))
1327 TYPE_NAME (arraytype) = build_decl (UNKNOWN_LOCATION, TYPE_DECL,
1328 NULL_TREE, arraytype);
1329 gfc_add_expr_to_block (pre, build1 (DECL_EXPR,
1330 arraytype, TYPE_NAME (arraytype)));
1331
1332 /* Fill in the array dtype. */
1333 tmp = gfc_conv_descriptor_dtype (desc);
1334 gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
1335
1336 /* Also set the span for derived types, since they can be used in
1337 component references to arrays of this type. */
1338 if (TREE_CODE (eltype) == RECORD_TYPE)
1339 {
1340 tmp = TYPE_SIZE_UNIT (eltype);
1341 tmp = fold_convert (gfc_array_index_type, tmp);
1342 gfc_conv_descriptor_span_set (pre, desc, tmp);
1343 }
1344
1345 /*
1346 Fill in the bounds and stride. This is a packed array, so:
1347
1348 size = 1;
1349 for (n = 0; n < rank; n++)
1350 {
1351 stride[n] = size
1352 delta = ubound[n] + 1 - lbound[n];
1353 size = size * delta;
1354 }
1355 size = size * sizeof(element);
1356 */
1357
1358 or_expr = NULL_TREE;
1359
1360 /* If there is at least one null loop->to[n], it is a callee allocated
1361 array. */
1362 for (n = 0; n < total_dim; n++)
1363 if (to[n] == NULL_TREE)
1364 {
1365 size = NULL_TREE;
1366 break;
1367 }
1368
1369 if (size == NULL_TREE)
1370 for (s = ss; s; s = s->parent)
1371 for (n = 0; n < s->loop->dimen; n++)
1372 {
1373 dim = get_scalarizer_dim_for_array_dim (ss, s->dim[n]);
1374
1375 /* For a callee allocated array express the loop bounds in terms
1376 of the descriptor fields. */
1377 tmp = fold_build2_loc (input_location,
1378 MINUS_EXPR, gfc_array_index_type,
1379 gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]),
1380 gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]));
1381 s->loop->to[n] = tmp;
1382 }
1383 else
1384 {
1385 for (n = 0; n < total_dim; n++)
1386 {
1387 /* Store the stride and bound components in the descriptor. */
1388 gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size);
1389
1390 gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
1391 gfc_index_zero_node);
1392
1393 gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], to[n]);
1394
1395 tmp = fold_build2_loc (input_location, PLUS_EXPR,
1396 gfc_array_index_type,
1397 to[n], gfc_index_one_node);
1398
1399 /* Check whether the size for this dimension is negative. */
1400 cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
1401 tmp, gfc_index_zero_node);
1402 cond = gfc_evaluate_now (cond, pre);
1403
1404 if (n == 0)
1405 or_expr = cond;
1406 else
1407 or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1408 logical_type_node, or_expr, cond);
1409
1410 size = fold_build2_loc (input_location, MULT_EXPR,
1411 gfc_array_index_type, size, tmp);
1412 size = gfc_evaluate_now (size, pre);
1413 }
1414 }
1415
1416 /* Get the size of the array. */
1417 if (size && !callee_alloc)
1418 {
1419 tree elemsize;
1420 /* If or_expr is true, then the extent in at least one
1421 dimension is zero and the size is set to zero. */
1422 size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
1423 or_expr, gfc_index_zero_node, size);
1424
1425 nelem = size;
1426 if (class_expr == NULL_TREE)
1427 elemsize = fold_convert (gfc_array_index_type,
1428 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
1429 else
1430 elemsize = gfc_class_vtab_size_get (class_expr);
1431
1432 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
1433 size, elemsize);
1434 }
1435 else
1436 {
1437 nelem = size;
1438 size = NULL_TREE;
1439 }
1440
1441 gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
1442 dynamic, dealloc);
1443
1444 while (ss->parent)
1445 ss = ss->parent;
1446
1447 if (ss->dimen > ss->loop->temp_dim)
1448 ss->loop->temp_dim = ss->dimen;
1449
1450 return size;
1451 }
1452
1453
1454 /* Return the number of iterations in a loop that starts at START,
1455 ends at END, and has step STEP. */
1456
1457 static tree
gfc_get_iteration_count(tree start,tree end,tree step)1458 gfc_get_iteration_count (tree start, tree end, tree step)
1459 {
1460 tree tmp;
1461 tree type;
1462
1463 type = TREE_TYPE (step);
1464 tmp = fold_build2_loc (input_location, MINUS_EXPR, type, end, start);
1465 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, type, tmp, step);
1466 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp,
1467 build_int_cst (type, 1));
1468 tmp = fold_build2_loc (input_location, MAX_EXPR, type, tmp,
1469 build_int_cst (type, 0));
1470 return fold_convert (gfc_array_index_type, tmp);
1471 }
1472
1473
1474 /* Extend the data in array DESC by EXTRA elements. */
1475
1476 static void
gfc_grow_array(stmtblock_t * pblock,tree desc,tree extra)1477 gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
1478 {
1479 tree arg0, arg1;
1480 tree tmp;
1481 tree size;
1482 tree ubound;
1483
1484 if (integer_zerop (extra))
1485 return;
1486
1487 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
1488
1489 /* Add EXTRA to the upper bound. */
1490 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1491 ubound, extra);
1492 gfc_conv_descriptor_ubound_set (pblock, desc, gfc_rank_cst[0], tmp);
1493
1494 /* Get the value of the current data pointer. */
1495 arg0 = gfc_conv_descriptor_data_get (desc);
1496
1497 /* Calculate the new array size. */
1498 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
1499 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1500 ubound, gfc_index_one_node);
1501 arg1 = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
1502 fold_convert (size_type_node, tmp),
1503 fold_convert (size_type_node, size));
1504
1505 /* Call the realloc() function. */
1506 tmp = gfc_call_realloc (pblock, arg0, arg1);
1507 gfc_conv_descriptor_data_set (pblock, desc, tmp);
1508 }
1509
1510
1511 /* Return true if the bounds of iterator I can only be determined
1512 at run time. */
1513
1514 static inline bool
gfc_iterator_has_dynamic_bounds(gfc_iterator * i)1515 gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
1516 {
1517 return (i->start->expr_type != EXPR_CONSTANT
1518 || i->end->expr_type != EXPR_CONSTANT
1519 || i->step->expr_type != EXPR_CONSTANT);
1520 }
1521
1522
1523 /* Split the size of constructor element EXPR into the sum of two terms,
1524 one of which can be determined at compile time and one of which must
1525 be calculated at run time. Set *SIZE to the former and return true
1526 if the latter might be nonzero. */
1527
1528 static bool
gfc_get_array_constructor_element_size(mpz_t * size,gfc_expr * expr)1529 gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
1530 {
1531 if (expr->expr_type == EXPR_ARRAY)
1532 return gfc_get_array_constructor_size (size, expr->value.constructor);
1533 else if (expr->rank > 0)
1534 {
1535 /* Calculate everything at run time. */
1536 mpz_set_ui (*size, 0);
1537 return true;
1538 }
1539 else
1540 {
1541 /* A single element. */
1542 mpz_set_ui (*size, 1);
1543 return false;
1544 }
1545 }
1546
1547
1548 /* Like gfc_get_array_constructor_element_size, but applied to the whole
1549 of array constructor C. */
1550
1551 static bool
gfc_get_array_constructor_size(mpz_t * size,gfc_constructor_base base)1552 gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base)
1553 {
1554 gfc_constructor *c;
1555 gfc_iterator *i;
1556 mpz_t val;
1557 mpz_t len;
1558 bool dynamic;
1559
1560 mpz_set_ui (*size, 0);
1561 mpz_init (len);
1562 mpz_init (val);
1563
1564 dynamic = false;
1565 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1566 {
1567 i = c->iterator;
1568 if (i && gfc_iterator_has_dynamic_bounds (i))
1569 dynamic = true;
1570 else
1571 {
1572 dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
1573 if (i)
1574 {
1575 /* Multiply the static part of the element size by the
1576 number of iterations. */
1577 mpz_sub (val, i->end->value.integer, i->start->value.integer);
1578 mpz_fdiv_q (val, val, i->step->value.integer);
1579 mpz_add_ui (val, val, 1);
1580 if (mpz_sgn (val) > 0)
1581 mpz_mul (len, len, val);
1582 else
1583 mpz_set_ui (len, 0);
1584 }
1585 mpz_add (*size, *size, len);
1586 }
1587 }
1588 mpz_clear (len);
1589 mpz_clear (val);
1590 return dynamic;
1591 }
1592
1593
1594 /* Make sure offset is a variable. */
1595
1596 static void
gfc_put_offset_into_var(stmtblock_t * pblock,tree * poffset,tree * offsetvar)1597 gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
1598 tree * offsetvar)
1599 {
1600 /* We should have already created the offset variable. We cannot
1601 create it here because we may be in an inner scope. */
1602 gcc_assert (*offsetvar != NULL_TREE);
1603 gfc_add_modify (pblock, *offsetvar, *poffset);
1604 *poffset = *offsetvar;
1605 TREE_USED (*offsetvar) = 1;
1606 }
1607
1608
1609 /* Variables needed for bounds-checking. */
1610 static bool first_len;
1611 static tree first_len_val;
1612 static bool typespec_chararray_ctor;
1613
1614 static void
gfc_trans_array_ctor_element(stmtblock_t * pblock,tree desc,tree offset,gfc_se * se,gfc_expr * expr)1615 gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
1616 tree offset, gfc_se * se, gfc_expr * expr)
1617 {
1618 tree tmp;
1619
1620 gfc_conv_expr (se, expr);
1621
1622 /* Store the value. */
1623 tmp = build_fold_indirect_ref_loc (input_location,
1624 gfc_conv_descriptor_data_get (desc));
1625 tmp = gfc_build_array_ref (tmp, offset, NULL);
1626
1627 if (expr->ts.type == BT_CHARACTER)
1628 {
1629 int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
1630 tree esize;
1631
1632 esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)));
1633 esize = fold_convert (gfc_charlen_type_node, esize);
1634 esize = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
1635 TREE_TYPE (esize), esize,
1636 build_int_cst (TREE_TYPE (esize),
1637 gfc_character_kinds[i].bit_size / 8));
1638
1639 gfc_conv_string_parameter (se);
1640 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
1641 {
1642 /* The temporary is an array of pointers. */
1643 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1644 gfc_add_modify (&se->pre, tmp, se->expr);
1645 }
1646 else
1647 {
1648 /* The temporary is an array of string values. */
1649 tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp);
1650 /* We know the temporary and the value will be the same length,
1651 so can use memcpy. */
1652 gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind,
1653 se->string_length, se->expr, expr->ts.kind);
1654 }
1655 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !typespec_chararray_ctor)
1656 {
1657 if (first_len)
1658 {
1659 gfc_add_modify (&se->pre, first_len_val,
1660 fold_convert (TREE_TYPE (first_len_val),
1661 se->string_length));
1662 first_len = false;
1663 }
1664 else
1665 {
1666 /* Verify that all constructor elements are of the same
1667 length. */
1668 tree rhs = fold_convert (TREE_TYPE (first_len_val),
1669 se->string_length);
1670 tree cond = fold_build2_loc (input_location, NE_EXPR,
1671 logical_type_node, first_len_val,
1672 rhs);
1673 gfc_trans_runtime_check
1674 (true, false, cond, &se->pre, &expr->where,
1675 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1676 fold_convert (long_integer_type_node, first_len_val),
1677 fold_convert (long_integer_type_node, se->string_length));
1678 }
1679 }
1680 }
1681 else if (GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
1682 && !GFC_CLASS_TYPE_P (gfc_get_element_type (TREE_TYPE (desc))))
1683 {
1684 /* Assignment of a CLASS array constructor to a derived type array. */
1685 if (expr->expr_type == EXPR_FUNCTION)
1686 se->expr = gfc_evaluate_now (se->expr, pblock);
1687 se->expr = gfc_class_data_get (se->expr);
1688 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
1689 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1690 gfc_add_modify (&se->pre, tmp, se->expr);
1691 }
1692 else
1693 {
1694 /* TODO: Should the frontend already have done this conversion? */
1695 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1696 gfc_add_modify (&se->pre, tmp, se->expr);
1697 }
1698
1699 gfc_add_block_to_block (pblock, &se->pre);
1700 gfc_add_block_to_block (pblock, &se->post);
1701 }
1702
1703
1704 /* Add the contents of an array to the constructor. DYNAMIC is as for
1705 gfc_trans_array_constructor_value. */
1706
1707 static void
gfc_trans_array_constructor_subarray(stmtblock_t * pblock,tree type ATTRIBUTE_UNUSED,tree desc,gfc_expr * expr,tree * poffset,tree * offsetvar,bool dynamic)1708 gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
1709 tree type ATTRIBUTE_UNUSED,
1710 tree desc, gfc_expr * expr,
1711 tree * poffset, tree * offsetvar,
1712 bool dynamic)
1713 {
1714 gfc_se se;
1715 gfc_ss *ss;
1716 gfc_loopinfo loop;
1717 stmtblock_t body;
1718 tree tmp;
1719 tree size;
1720 int n;
1721
1722 /* We need this to be a variable so we can increment it. */
1723 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1724
1725 gfc_init_se (&se, NULL);
1726
1727 /* Walk the array expression. */
1728 ss = gfc_walk_expr (expr);
1729 gcc_assert (ss != gfc_ss_terminator);
1730
1731 /* Initialize the scalarizer. */
1732 gfc_init_loopinfo (&loop);
1733 gfc_add_ss_to_loop (&loop, ss);
1734
1735 /* Initialize the loop. */
1736 gfc_conv_ss_startstride (&loop);
1737 gfc_conv_loop_setup (&loop, &expr->where);
1738
1739 /* Make sure the constructed array has room for the new data. */
1740 if (dynamic)
1741 {
1742 /* Set SIZE to the total number of elements in the subarray. */
1743 size = gfc_index_one_node;
1744 for (n = 0; n < loop.dimen; n++)
1745 {
1746 tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
1747 gfc_index_one_node);
1748 size = fold_build2_loc (input_location, MULT_EXPR,
1749 gfc_array_index_type, size, tmp);
1750 }
1751
1752 /* Grow the constructed array by SIZE elements. */
1753 gfc_grow_array (&loop.pre, desc, size);
1754 }
1755
1756 /* Make the loop body. */
1757 gfc_mark_ss_chain_used (ss, 1);
1758 gfc_start_scalarized_body (&loop, &body);
1759 gfc_copy_loopinfo_to_se (&se, &loop);
1760 se.ss = ss;
1761
1762 gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
1763 gcc_assert (se.ss == gfc_ss_terminator);
1764
1765 /* Increment the offset. */
1766 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1767 *poffset, gfc_index_one_node);
1768 gfc_add_modify (&body, *poffset, tmp);
1769
1770 /* Finish the loop. */
1771 gfc_trans_scalarizing_loops (&loop, &body);
1772 gfc_add_block_to_block (&loop.pre, &loop.post);
1773 tmp = gfc_finish_block (&loop.pre);
1774 gfc_add_expr_to_block (pblock, tmp);
1775
1776 gfc_cleanup_loop (&loop);
1777 }
1778
1779
1780 /* Assign the values to the elements of an array constructor. DYNAMIC
1781 is true if descriptor DESC only contains enough data for the static
1782 size calculated by gfc_get_array_constructor_size. When true, memory
1783 for the dynamic parts must be allocated using realloc. */
1784
1785 static void
gfc_trans_array_constructor_value(stmtblock_t * pblock,tree type,tree desc,gfc_constructor_base base,tree * poffset,tree * offsetvar,bool dynamic)1786 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
1787 tree desc, gfc_constructor_base base,
1788 tree * poffset, tree * offsetvar,
1789 bool dynamic)
1790 {
1791 tree tmp;
1792 tree start = NULL_TREE;
1793 tree end = NULL_TREE;
1794 tree step = NULL_TREE;
1795 stmtblock_t body;
1796 gfc_se se;
1797 mpz_t size;
1798 gfc_constructor *c;
1799
1800 tree shadow_loopvar = NULL_TREE;
1801 gfc_saved_var saved_loopvar;
1802
1803 mpz_init (size);
1804 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1805 {
1806 /* If this is an iterator or an array, the offset must be a variable. */
1807 if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
1808 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1809
1810 /* Shadowing the iterator avoids changing its value and saves us from
1811 keeping track of it. Further, it makes sure that there's always a
1812 backend-decl for the symbol, even if there wasn't one before,
1813 e.g. in the case of an iterator that appears in a specification
1814 expression in an interface mapping. */
1815 if (c->iterator)
1816 {
1817 gfc_symbol *sym;
1818 tree type;
1819
1820 /* Evaluate loop bounds before substituting the loop variable
1821 in case they depend on it. Such a case is invalid, but it is
1822 not more expensive to do the right thing here.
1823 See PR 44354. */
1824 gfc_init_se (&se, NULL);
1825 gfc_conv_expr_val (&se, c->iterator->start);
1826 gfc_add_block_to_block (pblock, &se.pre);
1827 start = gfc_evaluate_now (se.expr, pblock);
1828
1829 gfc_init_se (&se, NULL);
1830 gfc_conv_expr_val (&se, c->iterator->end);
1831 gfc_add_block_to_block (pblock, &se.pre);
1832 end = gfc_evaluate_now (se.expr, pblock);
1833
1834 gfc_init_se (&se, NULL);
1835 gfc_conv_expr_val (&se, c->iterator->step);
1836 gfc_add_block_to_block (pblock, &se.pre);
1837 step = gfc_evaluate_now (se.expr, pblock);
1838
1839 sym = c->iterator->var->symtree->n.sym;
1840 type = gfc_typenode_for_spec (&sym->ts);
1841
1842 shadow_loopvar = gfc_create_var (type, "shadow_loopvar");
1843 gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar);
1844 }
1845
1846 gfc_start_block (&body);
1847
1848 if (c->expr->expr_type == EXPR_ARRAY)
1849 {
1850 /* Array constructors can be nested. */
1851 gfc_trans_array_constructor_value (&body, type, desc,
1852 c->expr->value.constructor,
1853 poffset, offsetvar, dynamic);
1854 }
1855 else if (c->expr->rank > 0)
1856 {
1857 gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
1858 poffset, offsetvar, dynamic);
1859 }
1860 else
1861 {
1862 /* This code really upsets the gimplifier so don't bother for now. */
1863 gfc_constructor *p;
1864 HOST_WIDE_INT n;
1865 HOST_WIDE_INT size;
1866
1867 p = c;
1868 n = 0;
1869 while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1870 {
1871 p = gfc_constructor_next (p);
1872 n++;
1873 }
1874 if (n < 4)
1875 {
1876 /* Scalar values. */
1877 gfc_init_se (&se, NULL);
1878 gfc_trans_array_ctor_element (&body, desc, *poffset,
1879 &se, c->expr);
1880
1881 *poffset = fold_build2_loc (input_location, PLUS_EXPR,
1882 gfc_array_index_type,
1883 *poffset, gfc_index_one_node);
1884 }
1885 else
1886 {
1887 /* Collect multiple scalar constants into a constructor. */
1888 vec<constructor_elt, va_gc> *v = NULL;
1889 tree init;
1890 tree bound;
1891 tree tmptype;
1892 HOST_WIDE_INT idx = 0;
1893
1894 p = c;
1895 /* Count the number of consecutive scalar constants. */
1896 while (p && !(p->iterator
1897 || p->expr->expr_type != EXPR_CONSTANT))
1898 {
1899 gfc_init_se (&se, NULL);
1900 gfc_conv_constant (&se, p->expr);
1901
1902 if (c->expr->ts.type != BT_CHARACTER)
1903 se.expr = fold_convert (type, se.expr);
1904 /* For constant character array constructors we build
1905 an array of pointers. */
1906 else if (POINTER_TYPE_P (type))
1907 se.expr = gfc_build_addr_expr
1908 (gfc_get_pchar_type (p->expr->ts.kind),
1909 se.expr);
1910
1911 CONSTRUCTOR_APPEND_ELT (v,
1912 build_int_cst (gfc_array_index_type,
1913 idx++),
1914 se.expr);
1915 c = p;
1916 p = gfc_constructor_next (p);
1917 }
1918
1919 bound = size_int (n - 1);
1920 /* Create an array type to hold them. */
1921 tmptype = build_range_type (gfc_array_index_type,
1922 gfc_index_zero_node, bound);
1923 tmptype = build_array_type (type, tmptype);
1924
1925 init = build_constructor (tmptype, v);
1926 TREE_CONSTANT (init) = 1;
1927 TREE_STATIC (init) = 1;
1928 /* Create a static variable to hold the data. */
1929 tmp = gfc_create_var (tmptype, "data");
1930 TREE_STATIC (tmp) = 1;
1931 TREE_CONSTANT (tmp) = 1;
1932 TREE_READONLY (tmp) = 1;
1933 DECL_INITIAL (tmp) = init;
1934 init = tmp;
1935
1936 /* Use BUILTIN_MEMCPY to assign the values. */
1937 tmp = gfc_conv_descriptor_data_get (desc);
1938 tmp = build_fold_indirect_ref_loc (input_location,
1939 tmp);
1940 tmp = gfc_build_array_ref (tmp, *poffset, NULL);
1941 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1942 init = gfc_build_addr_expr (NULL_TREE, init);
1943
1944 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1945 bound = build_int_cst (size_type_node, n * size);
1946 tmp = build_call_expr_loc (input_location,
1947 builtin_decl_explicit (BUILT_IN_MEMCPY),
1948 3, tmp, init, bound);
1949 gfc_add_expr_to_block (&body, tmp);
1950
1951 *poffset = fold_build2_loc (input_location, PLUS_EXPR,
1952 gfc_array_index_type, *poffset,
1953 build_int_cst (gfc_array_index_type, n));
1954 }
1955 if (!INTEGER_CST_P (*poffset))
1956 {
1957 gfc_add_modify (&body, *offsetvar, *poffset);
1958 *poffset = *offsetvar;
1959 }
1960 }
1961
1962 /* The frontend should already have done any expansions
1963 at compile-time. */
1964 if (!c->iterator)
1965 {
1966 /* Pass the code as is. */
1967 tmp = gfc_finish_block (&body);
1968 gfc_add_expr_to_block (pblock, tmp);
1969 }
1970 else
1971 {
1972 /* Build the implied do-loop. */
1973 stmtblock_t implied_do_block;
1974 tree cond;
1975 tree exit_label;
1976 tree loopbody;
1977 tree tmp2;
1978
1979 loopbody = gfc_finish_block (&body);
1980
1981 /* Create a new block that holds the implied-do loop. A temporary
1982 loop-variable is used. */
1983 gfc_start_block(&implied_do_block);
1984
1985 /* Initialize the loop. */
1986 gfc_add_modify (&implied_do_block, shadow_loopvar, start);
1987
1988 /* If this array expands dynamically, and the number of iterations
1989 is not constant, we won't have allocated space for the static
1990 part of C->EXPR's size. Do that now. */
1991 if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1992 {
1993 /* Get the number of iterations. */
1994 tmp = gfc_get_iteration_count (shadow_loopvar, end, step);
1995
1996 /* Get the static part of C->EXPR's size. */
1997 gfc_get_array_constructor_element_size (&size, c->expr);
1998 tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1999
2000 /* Grow the array by TMP * TMP2 elements. */
2001 tmp = fold_build2_loc (input_location, MULT_EXPR,
2002 gfc_array_index_type, tmp, tmp2);
2003 gfc_grow_array (&implied_do_block, desc, tmp);
2004 }
2005
2006 /* Generate the loop body. */
2007 exit_label = gfc_build_label_decl (NULL_TREE);
2008 gfc_start_block (&body);
2009
2010 /* Generate the exit condition. Depending on the sign of
2011 the step variable we have to generate the correct
2012 comparison. */
2013 tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2014 step, build_int_cst (TREE_TYPE (step), 0));
2015 cond = fold_build3_loc (input_location, COND_EXPR,
2016 logical_type_node, tmp,
2017 fold_build2_loc (input_location, GT_EXPR,
2018 logical_type_node, shadow_loopvar, end),
2019 fold_build2_loc (input_location, LT_EXPR,
2020 logical_type_node, shadow_loopvar, end));
2021 tmp = build1_v (GOTO_EXPR, exit_label);
2022 TREE_USED (exit_label) = 1;
2023 tmp = build3_v (COND_EXPR, cond, tmp,
2024 build_empty_stmt (input_location));
2025 gfc_add_expr_to_block (&body, tmp);
2026
2027 /* The main loop body. */
2028 gfc_add_expr_to_block (&body, loopbody);
2029
2030 /* Increase loop variable by step. */
2031 tmp = fold_build2_loc (input_location, PLUS_EXPR,
2032 TREE_TYPE (shadow_loopvar), shadow_loopvar,
2033 step);
2034 gfc_add_modify (&body, shadow_loopvar, tmp);
2035
2036 /* Finish the loop. */
2037 tmp = gfc_finish_block (&body);
2038 tmp = build1_v (LOOP_EXPR, tmp);
2039 gfc_add_expr_to_block (&implied_do_block, tmp);
2040
2041 /* Add the exit label. */
2042 tmp = build1_v (LABEL_EXPR, exit_label);
2043 gfc_add_expr_to_block (&implied_do_block, tmp);
2044
2045 /* Finish the implied-do loop. */
2046 tmp = gfc_finish_block(&implied_do_block);
2047 gfc_add_expr_to_block(pblock, tmp);
2048
2049 gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar);
2050 }
2051 }
2052 mpz_clear (size);
2053 }
2054
2055
2056 /* The array constructor code can create a string length with an operand
2057 in the form of a temporary variable. This variable will retain its
2058 context (current_function_decl). If we store this length tree in a
2059 gfc_charlen structure which is shared by a variable in another
2060 context, the resulting gfc_charlen structure with a variable in a
2061 different context, we could trip the assertion in expand_expr_real_1
2062 when it sees that a variable has been created in one context and
2063 referenced in another.
2064
2065 If this might be the case, we create a new gfc_charlen structure and
2066 link it into the current namespace. */
2067
2068 static void
store_backend_decl(gfc_charlen ** clp,tree len,bool force_new_cl)2069 store_backend_decl (gfc_charlen **clp, tree len, bool force_new_cl)
2070 {
2071 if (force_new_cl)
2072 {
2073 gfc_charlen *new_cl = gfc_new_charlen (gfc_current_ns, *clp);
2074 *clp = new_cl;
2075 }
2076 (*clp)->backend_decl = len;
2077 }
2078
2079 /* A catch-all to obtain the string length for anything that is not
2080 a substring of non-constant length, a constant, array or variable. */
2081
2082 static void
get_array_ctor_all_strlen(stmtblock_t * block,gfc_expr * e,tree * len)2083 get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
2084 {
2085 gfc_se se;
2086
2087 /* Don't bother if we already know the length is a constant. */
2088 if (*len && INTEGER_CST_P (*len))
2089 return;
2090
2091 if (!e->ref && e->ts.u.cl && e->ts.u.cl->length
2092 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
2093 {
2094 /* This is easy. */
2095 gfc_conv_const_charlen (e->ts.u.cl);
2096 *len = e->ts.u.cl->backend_decl;
2097 }
2098 else
2099 {
2100 /* Otherwise, be brutal even if inefficient. */
2101 gfc_init_se (&se, NULL);
2102
2103 /* No function call, in case of side effects. */
2104 se.no_function_call = 1;
2105 if (e->rank == 0)
2106 gfc_conv_expr (&se, e);
2107 else
2108 gfc_conv_expr_descriptor (&se, e);
2109
2110 /* Fix the value. */
2111 *len = gfc_evaluate_now (se.string_length, &se.pre);
2112
2113 gfc_add_block_to_block (block, &se.pre);
2114 gfc_add_block_to_block (block, &se.post);
2115
2116 store_backend_decl (&e->ts.u.cl, *len, true);
2117 }
2118 }
2119
2120
2121 /* Figure out the string length of a variable reference expression.
2122 Used by get_array_ctor_strlen. */
2123
2124 static void
get_array_ctor_var_strlen(stmtblock_t * block,gfc_expr * expr,tree * len)2125 get_array_ctor_var_strlen (stmtblock_t *block, gfc_expr * expr, tree * len)
2126 {
2127 gfc_ref *ref;
2128 gfc_typespec *ts;
2129 mpz_t char_len;
2130
2131 /* Don't bother if we already know the length is a constant. */
2132 if (*len && INTEGER_CST_P (*len))
2133 return;
2134
2135 ts = &expr->symtree->n.sym->ts;
2136 for (ref = expr->ref; ref; ref = ref->next)
2137 {
2138 switch (ref->type)
2139 {
2140 case REF_ARRAY:
2141 /* Array references don't change the string length. */
2142 if (ts->deferred)
2143 get_array_ctor_all_strlen (block, expr, len);
2144 break;
2145
2146 case REF_COMPONENT:
2147 /* Use the length of the component. */
2148 ts = &ref->u.c.component->ts;
2149 break;
2150
2151 case REF_SUBSTRING:
2152 if (ref->u.ss.end == NULL
2153 || ref->u.ss.start->expr_type != EXPR_CONSTANT
2154 || ref->u.ss.end->expr_type != EXPR_CONSTANT)
2155 {
2156 /* Note that this might evaluate expr. */
2157 get_array_ctor_all_strlen (block, expr, len);
2158 return;
2159 }
2160 mpz_init_set_ui (char_len, 1);
2161 mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
2162 mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
2163 *len = gfc_conv_mpz_to_tree_type (char_len, gfc_charlen_type_node);
2164 mpz_clear (char_len);
2165 return;
2166
2167 case REF_INQUIRY:
2168 break;
2169
2170 default:
2171 gcc_unreachable ();
2172 }
2173 }
2174
2175 *len = ts->u.cl->backend_decl;
2176 }
2177
2178
2179 /* Figure out the string length of a character array constructor.
2180 If len is NULL, don't calculate the length; this happens for recursive calls
2181 when a sub-array-constructor is an element but not at the first position,
2182 so when we're not interested in the length.
2183 Returns TRUE if all elements are character constants. */
2184
2185 bool
get_array_ctor_strlen(stmtblock_t * block,gfc_constructor_base base,tree * len)2186 get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len)
2187 {
2188 gfc_constructor *c;
2189 bool is_const;
2190
2191 is_const = TRUE;
2192
2193 if (gfc_constructor_first (base) == NULL)
2194 {
2195 if (len)
2196 *len = build_int_cstu (gfc_charlen_type_node, 0);
2197 return is_const;
2198 }
2199
2200 /* Loop over all constructor elements to find out is_const, but in len we
2201 want to store the length of the first, not the last, element. We can
2202 of course exit the loop as soon as is_const is found to be false. */
2203 for (c = gfc_constructor_first (base);
2204 c && is_const; c = gfc_constructor_next (c))
2205 {
2206 switch (c->expr->expr_type)
2207 {
2208 case EXPR_CONSTANT:
2209 if (len && !(*len && INTEGER_CST_P (*len)))
2210 *len = build_int_cstu (gfc_charlen_type_node,
2211 c->expr->value.character.length);
2212 break;
2213
2214 case EXPR_ARRAY:
2215 if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
2216 is_const = false;
2217 break;
2218
2219 case EXPR_VARIABLE:
2220 is_const = false;
2221 if (len)
2222 get_array_ctor_var_strlen (block, c->expr, len);
2223 break;
2224
2225 default:
2226 is_const = false;
2227 if (len)
2228 get_array_ctor_all_strlen (block, c->expr, len);
2229 break;
2230 }
2231
2232 /* After the first iteration, we don't want the length modified. */
2233 len = NULL;
2234 }
2235
2236 return is_const;
2237 }
2238
2239 /* Check whether the array constructor C consists entirely of constant
2240 elements, and if so returns the number of those elements, otherwise
2241 return zero. Note, an empty or NULL array constructor returns zero. */
2242
2243 unsigned HOST_WIDE_INT
gfc_constant_array_constructor_p(gfc_constructor_base base)2244 gfc_constant_array_constructor_p (gfc_constructor_base base)
2245 {
2246 unsigned HOST_WIDE_INT nelem = 0;
2247
2248 gfc_constructor *c = gfc_constructor_first (base);
2249 while (c)
2250 {
2251 if (c->iterator
2252 || c->expr->rank > 0
2253 || c->expr->expr_type != EXPR_CONSTANT)
2254 return 0;
2255 c = gfc_constructor_next (c);
2256 nelem++;
2257 }
2258 return nelem;
2259 }
2260
2261
2262 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
2263 and the tree type of it's elements, TYPE, return a static constant
2264 variable that is compile-time initialized. */
2265
2266 tree
gfc_build_constant_array_constructor(gfc_expr * expr,tree type)2267 gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
2268 {
2269 tree tmptype, init, tmp;
2270 HOST_WIDE_INT nelem;
2271 gfc_constructor *c;
2272 gfc_array_spec as;
2273 gfc_se se;
2274 int i;
2275 vec<constructor_elt, va_gc> *v = NULL;
2276
2277 /* First traverse the constructor list, converting the constants
2278 to tree to build an initializer. */
2279 nelem = 0;
2280 c = gfc_constructor_first (expr->value.constructor);
2281 while (c)
2282 {
2283 gfc_init_se (&se, NULL);
2284 gfc_conv_constant (&se, c->expr);
2285 if (c->expr->ts.type != BT_CHARACTER)
2286 se.expr = fold_convert (type, se.expr);
2287 else if (POINTER_TYPE_P (type))
2288 se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
2289 se.expr);
2290 CONSTRUCTOR_APPEND_ELT (v, build_int_cst (gfc_array_index_type, nelem),
2291 se.expr);
2292 c = gfc_constructor_next (c);
2293 nelem++;
2294 }
2295
2296 /* Next determine the tree type for the array. We use the gfortran
2297 front-end's gfc_get_nodesc_array_type in order to create a suitable
2298 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
2299
2300 memset (&as, 0, sizeof (gfc_array_spec));
2301
2302 as.rank = expr->rank;
2303 as.type = AS_EXPLICIT;
2304 if (!expr->shape)
2305 {
2306 as.lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
2307 as.upper[0] = gfc_get_int_expr (gfc_default_integer_kind,
2308 NULL, nelem - 1);
2309 }
2310 else
2311 for (i = 0; i < expr->rank; i++)
2312 {
2313 int tmp = (int) mpz_get_si (expr->shape[i]);
2314 as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
2315 as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind,
2316 NULL, tmp - 1);
2317 }
2318
2319 tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
2320
2321 /* as is not needed anymore. */
2322 for (i = 0; i < as.rank + as.corank; i++)
2323 {
2324 gfc_free_expr (as.lower[i]);
2325 gfc_free_expr (as.upper[i]);
2326 }
2327
2328 init = build_constructor (tmptype, v);
2329
2330 TREE_CONSTANT (init) = 1;
2331 TREE_STATIC (init) = 1;
2332
2333 tmp = build_decl (input_location, VAR_DECL, create_tmp_var_name ("A"),
2334 tmptype);
2335 DECL_ARTIFICIAL (tmp) = 1;
2336 DECL_IGNORED_P (tmp) = 1;
2337 TREE_STATIC (tmp) = 1;
2338 TREE_CONSTANT (tmp) = 1;
2339 TREE_READONLY (tmp) = 1;
2340 DECL_INITIAL (tmp) = init;
2341 pushdecl (tmp);
2342
2343 return tmp;
2344 }
2345
2346
2347 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
2348 This mostly initializes the scalarizer state info structure with the
2349 appropriate values to directly use the array created by the function
2350 gfc_build_constant_array_constructor. */
2351
2352 static void
trans_constant_array_constructor(gfc_ss * ss,tree type)2353 trans_constant_array_constructor (gfc_ss * ss, tree type)
2354 {
2355 gfc_array_info *info;
2356 tree tmp;
2357 int i;
2358
2359 tmp = gfc_build_constant_array_constructor (ss->info->expr, type);
2360
2361 info = &ss->info->data.array;
2362
2363 info->descriptor = tmp;
2364 info->data = gfc_build_addr_expr (NULL_TREE, tmp);
2365 info->offset = gfc_index_zero_node;
2366
2367 for (i = 0; i < ss->dimen; i++)
2368 {
2369 info->delta[i] = gfc_index_zero_node;
2370 info->start[i] = gfc_index_zero_node;
2371 info->end[i] = gfc_index_zero_node;
2372 info->stride[i] = gfc_index_one_node;
2373 }
2374 }
2375
2376
2377 static int
get_rank(gfc_loopinfo * loop)2378 get_rank (gfc_loopinfo *loop)
2379 {
2380 int rank;
2381
2382 rank = 0;
2383 for (; loop; loop = loop->parent)
2384 rank += loop->dimen;
2385
2386 return rank;
2387 }
2388
2389
2390 /* Helper routine of gfc_trans_array_constructor to determine if the
2391 bounds of the loop specified by LOOP are constant and simple enough
2392 to use with trans_constant_array_constructor. Returns the
2393 iteration count of the loop if suitable, and NULL_TREE otherwise. */
2394
2395 static tree
constant_array_constructor_loop_size(gfc_loopinfo * l)2396 constant_array_constructor_loop_size (gfc_loopinfo * l)
2397 {
2398 gfc_loopinfo *loop;
2399 tree size = gfc_index_one_node;
2400 tree tmp;
2401 int i, total_dim;
2402
2403 total_dim = get_rank (l);
2404
2405 for (loop = l; loop; loop = loop->parent)
2406 {
2407 for (i = 0; i < loop->dimen; i++)
2408 {
2409 /* If the bounds aren't constant, return NULL_TREE. */
2410 if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
2411 return NULL_TREE;
2412 if (!integer_zerop (loop->from[i]))
2413 {
2414 /* Only allow nonzero "from" in one-dimensional arrays. */
2415 if (total_dim != 1)
2416 return NULL_TREE;
2417 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2418 gfc_array_index_type,
2419 loop->to[i], loop->from[i]);
2420 }
2421 else
2422 tmp = loop->to[i];
2423 tmp = fold_build2_loc (input_location, PLUS_EXPR,
2424 gfc_array_index_type, tmp, gfc_index_one_node);
2425 size = fold_build2_loc (input_location, MULT_EXPR,
2426 gfc_array_index_type, size, tmp);
2427 }
2428 }
2429
2430 return size;
2431 }
2432
2433
2434 static tree *
get_loop_upper_bound_for_array(gfc_ss * array,int array_dim)2435 get_loop_upper_bound_for_array (gfc_ss *array, int array_dim)
2436 {
2437 gfc_ss *ss;
2438 int n;
2439
2440 gcc_assert (array->nested_ss == NULL);
2441
2442 for (ss = array; ss; ss = ss->parent)
2443 for (n = 0; n < ss->loop->dimen; n++)
2444 if (array_dim == get_array_ref_dim_for_loop_dim (ss, n))
2445 return &(ss->loop->to[n]);
2446
2447 gcc_unreachable ();
2448 }
2449
2450
2451 static gfc_loopinfo *
outermost_loop(gfc_loopinfo * loop)2452 outermost_loop (gfc_loopinfo * loop)
2453 {
2454 while (loop->parent != NULL)
2455 loop = loop->parent;
2456
2457 return loop;
2458 }
2459
2460
2461 /* Array constructors are handled by constructing a temporary, then using that
2462 within the scalarization loop. This is not optimal, but seems by far the
2463 simplest method. */
2464
2465 static void
trans_array_constructor(gfc_ss * ss,locus * where)2466 trans_array_constructor (gfc_ss * ss, locus * where)
2467 {
2468 gfc_constructor_base c;
2469 tree offset;
2470 tree offsetvar;
2471 tree desc;
2472 tree type;
2473 tree tmp;
2474 tree *loop_ubound0;
2475 bool dynamic;
2476 bool old_first_len, old_typespec_chararray_ctor;
2477 tree old_first_len_val;
2478 gfc_loopinfo *loop, *outer_loop;
2479 gfc_ss_info *ss_info;
2480 gfc_expr *expr;
2481 gfc_ss *s;
2482 tree neg_len;
2483 char *msg;
2484
2485 /* Save the old values for nested checking. */
2486 old_first_len = first_len;
2487 old_first_len_val = first_len_val;
2488 old_typespec_chararray_ctor = typespec_chararray_ctor;
2489
2490 loop = ss->loop;
2491 outer_loop = outermost_loop (loop);
2492 ss_info = ss->info;
2493 expr = ss_info->expr;
2494
2495 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
2496 typespec was given for the array constructor. */
2497 typespec_chararray_ctor = (expr->ts.type == BT_CHARACTER
2498 && expr->ts.u.cl
2499 && expr->ts.u.cl->length_from_typespec);
2500
2501 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2502 && expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
2503 {
2504 first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
2505 first_len = true;
2506 }
2507
2508 gcc_assert (ss->dimen == ss->loop->dimen);
2509
2510 c = expr->value.constructor;
2511 if (expr->ts.type == BT_CHARACTER)
2512 {
2513 bool const_string;
2514 bool force_new_cl = false;
2515
2516 /* get_array_ctor_strlen walks the elements of the constructor, if a
2517 typespec was given, we already know the string length and want the one
2518 specified there. */
2519 if (typespec_chararray_ctor && expr->ts.u.cl->length
2520 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
2521 {
2522 gfc_se length_se;
2523
2524 const_string = false;
2525 gfc_init_se (&length_se, NULL);
2526 gfc_conv_expr_type (&length_se, expr->ts.u.cl->length,
2527 gfc_charlen_type_node);
2528 ss_info->string_length = length_se.expr;
2529
2530 /* Check if the character length is negative. If it is, then
2531 set LEN = 0. */
2532 neg_len = fold_build2_loc (input_location, LT_EXPR,
2533 logical_type_node, ss_info->string_length,
2534 build_zero_cst (TREE_TYPE
2535 (ss_info->string_length)));
2536 /* Print a warning if bounds checking is enabled. */
2537 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2538 {
2539 msg = xasprintf ("Negative character length treated as LEN = 0");
2540 gfc_trans_runtime_check (false, true, neg_len, &length_se.pre,
2541 where, msg);
2542 free (msg);
2543 }
2544
2545 ss_info->string_length
2546 = fold_build3_loc (input_location, COND_EXPR,
2547 gfc_charlen_type_node, neg_len,
2548 build_zero_cst
2549 (TREE_TYPE (ss_info->string_length)),
2550 ss_info->string_length);
2551 ss_info->string_length = gfc_evaluate_now (ss_info->string_length,
2552 &length_se.pre);
2553 gfc_add_block_to_block (&outer_loop->pre, &length_se.pre);
2554 gfc_add_block_to_block (&outer_loop->post, &length_se.post);
2555 }
2556 else
2557 {
2558 const_string = get_array_ctor_strlen (&outer_loop->pre, c,
2559 &ss_info->string_length);
2560 force_new_cl = true;
2561 }
2562
2563 /* Complex character array constructors should have been taken care of
2564 and not end up here. */
2565 gcc_assert (ss_info->string_length);
2566
2567 store_backend_decl (&expr->ts.u.cl, ss_info->string_length, force_new_cl);
2568
2569 type = gfc_get_character_type_len (expr->ts.kind, ss_info->string_length);
2570 if (const_string)
2571 type = build_pointer_type (type);
2572 }
2573 else
2574 type = gfc_typenode_for_spec (expr->ts.type == BT_CLASS
2575 ? &CLASS_DATA (expr)->ts : &expr->ts);
2576
2577 /* See if the constructor determines the loop bounds. */
2578 dynamic = false;
2579
2580 loop_ubound0 = get_loop_upper_bound_for_array (ss, 0);
2581
2582 if (expr->shape && get_rank (loop) > 1 && *loop_ubound0 == NULL_TREE)
2583 {
2584 /* We have a multidimensional parameter. */
2585 for (s = ss; s; s = s->parent)
2586 {
2587 int n;
2588 for (n = 0; n < s->loop->dimen; n++)
2589 {
2590 s->loop->from[n] = gfc_index_zero_node;
2591 s->loop->to[n] = gfc_conv_mpz_to_tree (expr->shape[s->dim[n]],
2592 gfc_index_integer_kind);
2593 s->loop->to[n] = fold_build2_loc (input_location, MINUS_EXPR,
2594 gfc_array_index_type,
2595 s->loop->to[n],
2596 gfc_index_one_node);
2597 }
2598 }
2599 }
2600
2601 if (*loop_ubound0 == NULL_TREE)
2602 {
2603 mpz_t size;
2604
2605 /* We should have a 1-dimensional, zero-based loop. */
2606 gcc_assert (loop->parent == NULL && loop->nested == NULL);
2607 gcc_assert (loop->dimen == 1);
2608 gcc_assert (integer_zerop (loop->from[0]));
2609
2610 /* Split the constructor size into a static part and a dynamic part.
2611 Allocate the static size up-front and record whether the dynamic
2612 size might be nonzero. */
2613 mpz_init (size);
2614 dynamic = gfc_get_array_constructor_size (&size, c);
2615 mpz_sub_ui (size, size, 1);
2616 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
2617 mpz_clear (size);
2618 }
2619
2620 /* Special case constant array constructors. */
2621 if (!dynamic)
2622 {
2623 unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
2624 if (nelem > 0)
2625 {
2626 tree size = constant_array_constructor_loop_size (loop);
2627 if (size && compare_tree_int (size, nelem) == 0)
2628 {
2629 trans_constant_array_constructor (ss, type);
2630 goto finish;
2631 }
2632 }
2633 }
2634
2635 gfc_trans_create_temp_array (&outer_loop->pre, &outer_loop->post, ss, type,
2636 NULL_TREE, dynamic, true, false, where);
2637
2638 desc = ss_info->data.array.descriptor;
2639 offset = gfc_index_zero_node;
2640 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
2641 TREE_NO_WARNING (offsetvar) = 1;
2642 TREE_USED (offsetvar) = 0;
2643 gfc_trans_array_constructor_value (&outer_loop->pre, type, desc, c,
2644 &offset, &offsetvar, dynamic);
2645
2646 /* If the array grows dynamically, the upper bound of the loop variable
2647 is determined by the array's final upper bound. */
2648 if (dynamic)
2649 {
2650 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2651 gfc_array_index_type,
2652 offsetvar, gfc_index_one_node);
2653 tmp = gfc_evaluate_now (tmp, &outer_loop->pre);
2654 gfc_conv_descriptor_ubound_set (&loop->pre, desc, gfc_rank_cst[0], tmp);
2655 if (*loop_ubound0 && VAR_P (*loop_ubound0))
2656 gfc_add_modify (&outer_loop->pre, *loop_ubound0, tmp);
2657 else
2658 *loop_ubound0 = tmp;
2659 }
2660
2661 if (TREE_USED (offsetvar))
2662 pushdecl (offsetvar);
2663 else
2664 gcc_assert (INTEGER_CST_P (offset));
2665
2666 #if 0
2667 /* Disable bound checking for now because it's probably broken. */
2668 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2669 {
2670 gcc_unreachable ();
2671 }
2672 #endif
2673
2674 finish:
2675 /* Restore old values of globals. */
2676 first_len = old_first_len;
2677 first_len_val = old_first_len_val;
2678 typespec_chararray_ctor = old_typespec_chararray_ctor;
2679 }
2680
2681
2682 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
2683 called after evaluating all of INFO's vector dimensions. Go through
2684 each such vector dimension and see if we can now fill in any missing
2685 loop bounds. */
2686
2687 static void
set_vector_loop_bounds(gfc_ss * ss)2688 set_vector_loop_bounds (gfc_ss * ss)
2689 {
2690 gfc_loopinfo *loop, *outer_loop;
2691 gfc_array_info *info;
2692 gfc_se se;
2693 tree tmp;
2694 tree desc;
2695 tree zero;
2696 int n;
2697 int dim;
2698
2699 outer_loop = outermost_loop (ss->loop);
2700
2701 info = &ss->info->data.array;
2702
2703 for (; ss; ss = ss->parent)
2704 {
2705 loop = ss->loop;
2706
2707 for (n = 0; n < loop->dimen; n++)
2708 {
2709 dim = ss->dim[n];
2710 if (info->ref->u.ar.dimen_type[dim] != DIMEN_VECTOR
2711 || loop->to[n] != NULL)
2712 continue;
2713
2714 /* Loop variable N indexes vector dimension DIM, and we don't
2715 yet know the upper bound of loop variable N. Set it to the
2716 difference between the vector's upper and lower bounds. */
2717 gcc_assert (loop->from[n] == gfc_index_zero_node);
2718 gcc_assert (info->subscript[dim]
2719 && info->subscript[dim]->info->type == GFC_SS_VECTOR);
2720
2721 gfc_init_se (&se, NULL);
2722 desc = info->subscript[dim]->info->data.array.descriptor;
2723 zero = gfc_rank_cst[0];
2724 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2725 gfc_array_index_type,
2726 gfc_conv_descriptor_ubound_get (desc, zero),
2727 gfc_conv_descriptor_lbound_get (desc, zero));
2728 tmp = gfc_evaluate_now (tmp, &outer_loop->pre);
2729 loop->to[n] = tmp;
2730 }
2731 }
2732 }
2733
2734
2735 /* Tells whether a scalar argument to an elemental procedure is saved out
2736 of a scalarization loop as a value or as a reference. */
2737
2738 bool
gfc_scalar_elemental_arg_saved_as_reference(gfc_ss_info * ss_info)2739 gfc_scalar_elemental_arg_saved_as_reference (gfc_ss_info * ss_info)
2740 {
2741 if (ss_info->type != GFC_SS_REFERENCE)
2742 return false;
2743
2744 if (ss_info->data.scalar.needs_temporary)
2745 return false;
2746
2747 /* If the actual argument can be absent (in other words, it can
2748 be a NULL reference), don't try to evaluate it; pass instead
2749 the reference directly. */
2750 if (ss_info->can_be_null_ref)
2751 return true;
2752
2753 /* If the expression is of polymorphic type, it's actual size is not known,
2754 so we avoid copying it anywhere. */
2755 if (ss_info->data.scalar.dummy_arg
2756 && ss_info->data.scalar.dummy_arg->ts.type == BT_CLASS
2757 && ss_info->expr->ts.type == BT_CLASS)
2758 return true;
2759
2760 /* If the expression is a data reference of aggregate type,
2761 and the data reference is not used on the left hand side,
2762 avoid a copy by saving a reference to the content. */
2763 if (!ss_info->data.scalar.needs_temporary
2764 && (ss_info->expr->ts.type == BT_DERIVED
2765 || ss_info->expr->ts.type == BT_CLASS)
2766 && gfc_expr_is_variable (ss_info->expr))
2767 return true;
2768
2769 /* Otherwise the expression is evaluated to a temporary variable before the
2770 scalarization loop. */
2771 return false;
2772 }
2773
2774
2775 /* Add the pre and post chains for all the scalar expressions in a SS chain
2776 to loop. This is called after the loop parameters have been calculated,
2777 but before the actual scalarizing loops. */
2778
2779 static void
gfc_add_loop_ss_code(gfc_loopinfo * loop,gfc_ss * ss,bool subscript,locus * where)2780 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
2781 locus * where)
2782 {
2783 gfc_loopinfo *nested_loop, *outer_loop;
2784 gfc_se se;
2785 gfc_ss_info *ss_info;
2786 gfc_array_info *info;
2787 gfc_expr *expr;
2788 int n;
2789
2790 /* Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise,
2791 arguments could get evaluated multiple times. */
2792 if (ss->is_alloc_lhs)
2793 return;
2794
2795 outer_loop = outermost_loop (loop);
2796
2797 /* TODO: This can generate bad code if there are ordering dependencies,
2798 e.g., a callee allocated function and an unknown size constructor. */
2799 gcc_assert (ss != NULL);
2800
2801 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
2802 {
2803 gcc_assert (ss);
2804
2805 /* Cross loop arrays are handled from within the most nested loop. */
2806 if (ss->nested_ss != NULL)
2807 continue;
2808
2809 ss_info = ss->info;
2810 expr = ss_info->expr;
2811 info = &ss_info->data.array;
2812
2813 switch (ss_info->type)
2814 {
2815 case GFC_SS_SCALAR:
2816 /* Scalar expression. Evaluate this now. This includes elemental
2817 dimension indices, but not array section bounds. */
2818 gfc_init_se (&se, NULL);
2819 gfc_conv_expr (&se, expr);
2820 gfc_add_block_to_block (&outer_loop->pre, &se.pre);
2821
2822 if (expr->ts.type != BT_CHARACTER
2823 && !gfc_is_alloc_class_scalar_function (expr))
2824 {
2825 /* Move the evaluation of scalar expressions outside the
2826 scalarization loop, except for WHERE assignments. */
2827 if (subscript)
2828 se.expr = convert(gfc_array_index_type, se.expr);
2829 if (!ss_info->where)
2830 se.expr = gfc_evaluate_now (se.expr, &outer_loop->pre);
2831 gfc_add_block_to_block (&outer_loop->pre, &se.post);
2832 }
2833 else
2834 gfc_add_block_to_block (&outer_loop->post, &se.post);
2835
2836 ss_info->data.scalar.value = se.expr;
2837 ss_info->string_length = se.string_length;
2838 break;
2839
2840 case GFC_SS_REFERENCE:
2841 /* Scalar argument to elemental procedure. */
2842 gfc_init_se (&se, NULL);
2843 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info))
2844 gfc_conv_expr_reference (&se, expr);
2845 else
2846 {
2847 /* Evaluate the argument outside the loop and pass
2848 a reference to the value. */
2849 gfc_conv_expr (&se, expr);
2850 }
2851
2852 /* Ensure that a pointer to the string is stored. */
2853 if (expr->ts.type == BT_CHARACTER)
2854 gfc_conv_string_parameter (&se);
2855
2856 gfc_add_block_to_block (&outer_loop->pre, &se.pre);
2857 gfc_add_block_to_block (&outer_loop->post, &se.post);
2858 if (gfc_is_class_scalar_expr (expr))
2859 /* This is necessary because the dynamic type will always be
2860 large than the declared type. In consequence, assigning
2861 the value to a temporary could segfault.
2862 OOP-TODO: see if this is generally correct or is the value
2863 has to be written to an allocated temporary, whose address
2864 is passed via ss_info. */
2865 ss_info->data.scalar.value = se.expr;
2866 else
2867 ss_info->data.scalar.value = gfc_evaluate_now (se.expr,
2868 &outer_loop->pre);
2869
2870 ss_info->string_length = se.string_length;
2871 break;
2872
2873 case GFC_SS_SECTION:
2874 /* Add the expressions for scalar and vector subscripts. */
2875 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2876 if (info->subscript[n])
2877 gfc_add_loop_ss_code (loop, info->subscript[n], true, where);
2878
2879 set_vector_loop_bounds (ss);
2880 break;
2881
2882 case GFC_SS_VECTOR:
2883 /* Get the vector's descriptor and store it in SS. */
2884 gfc_init_se (&se, NULL);
2885 gfc_conv_expr_descriptor (&se, expr);
2886 gfc_add_block_to_block (&outer_loop->pre, &se.pre);
2887 gfc_add_block_to_block (&outer_loop->post, &se.post);
2888 info->descriptor = se.expr;
2889 break;
2890
2891 case GFC_SS_INTRINSIC:
2892 gfc_add_intrinsic_ss_code (loop, ss);
2893 break;
2894
2895 case GFC_SS_FUNCTION:
2896 /* Array function return value. We call the function and save its
2897 result in a temporary for use inside the loop. */
2898 gfc_init_se (&se, NULL);
2899 se.loop = loop;
2900 se.ss = ss;
2901 if (gfc_is_class_array_function (expr))
2902 expr->must_finalize = 1;
2903 gfc_conv_expr (&se, expr);
2904 gfc_add_block_to_block (&outer_loop->pre, &se.pre);
2905 gfc_add_block_to_block (&outer_loop->post, &se.post);
2906 ss_info->string_length = se.string_length;
2907 break;
2908
2909 case GFC_SS_CONSTRUCTOR:
2910 if (expr->ts.type == BT_CHARACTER
2911 && ss_info->string_length == NULL
2912 && expr->ts.u.cl
2913 && expr->ts.u.cl->length
2914 && expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
2915 {
2916 gfc_init_se (&se, NULL);
2917 gfc_conv_expr_type (&se, expr->ts.u.cl->length,
2918 gfc_charlen_type_node);
2919 ss_info->string_length = se.expr;
2920 gfc_add_block_to_block (&outer_loop->pre, &se.pre);
2921 gfc_add_block_to_block (&outer_loop->post, &se.post);
2922 }
2923 trans_array_constructor (ss, where);
2924 break;
2925
2926 case GFC_SS_TEMP:
2927 case GFC_SS_COMPONENT:
2928 /* Do nothing. These are handled elsewhere. */
2929 break;
2930
2931 default:
2932 gcc_unreachable ();
2933 }
2934 }
2935
2936 if (!subscript)
2937 for (nested_loop = loop->nested; nested_loop;
2938 nested_loop = nested_loop->next)
2939 gfc_add_loop_ss_code (nested_loop, nested_loop->ss, subscript, where);
2940 }
2941
2942
2943 /* Translate expressions for the descriptor and data pointer of a SS. */
2944 /*GCC ARRAYS*/
2945
2946 static void
gfc_conv_ss_descriptor(stmtblock_t * block,gfc_ss * ss,int base)2947 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
2948 {
2949 gfc_se se;
2950 gfc_ss_info *ss_info;
2951 gfc_array_info *info;
2952 tree tmp;
2953
2954 ss_info = ss->info;
2955 info = &ss_info->data.array;
2956
2957 /* Get the descriptor for the array to be scalarized. */
2958 gcc_assert (ss_info->expr->expr_type == EXPR_VARIABLE);
2959 gfc_init_se (&se, NULL);
2960 se.descriptor_only = 1;
2961 gfc_conv_expr_lhs (&se, ss_info->expr);
2962 gfc_add_block_to_block (block, &se.pre);
2963 info->descriptor = se.expr;
2964 ss_info->string_length = se.string_length;
2965
2966 if (base)
2967 {
2968 if (ss_info->expr->ts.type == BT_CHARACTER && !ss_info->expr->ts.deferred
2969 && ss_info->expr->ts.u.cl->length == NULL)
2970 {
2971 /* Emit a DECL_EXPR for the variable sized array type in
2972 GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
2973 sizes works correctly. */
2974 tree arraytype = TREE_TYPE (
2975 GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (info->descriptor)));
2976 if (! TYPE_NAME (arraytype))
2977 TYPE_NAME (arraytype) = build_decl (UNKNOWN_LOCATION, TYPE_DECL,
2978 NULL_TREE, arraytype);
2979 gfc_add_expr_to_block (block, build1 (DECL_EXPR, arraytype,
2980 TYPE_NAME (arraytype)));
2981 }
2982 /* Also the data pointer. */
2983 tmp = gfc_conv_array_data (se.expr);
2984 /* If this is a variable or address of a variable we use it directly.
2985 Otherwise we must evaluate it now to avoid breaking dependency
2986 analysis by pulling the expressions for elemental array indices
2987 inside the loop. */
2988 if (!(DECL_P (tmp)
2989 || (TREE_CODE (tmp) == ADDR_EXPR
2990 && DECL_P (TREE_OPERAND (tmp, 0)))))
2991 tmp = gfc_evaluate_now (tmp, block);
2992 info->data = tmp;
2993
2994 tmp = gfc_conv_array_offset (se.expr);
2995 info->offset = gfc_evaluate_now (tmp, block);
2996
2997 /* Make absolutely sure that the saved_offset is indeed saved
2998 so that the variable is still accessible after the loops
2999 are translated. */
3000 info->saved_offset = info->offset;
3001 }
3002 }
3003
3004
3005 /* Initialize a gfc_loopinfo structure. */
3006
3007 void
gfc_init_loopinfo(gfc_loopinfo * loop)3008 gfc_init_loopinfo (gfc_loopinfo * loop)
3009 {
3010 int n;
3011
3012 memset (loop, 0, sizeof (gfc_loopinfo));
3013 gfc_init_block (&loop->pre);
3014 gfc_init_block (&loop->post);
3015
3016 /* Initially scalarize in order and default to no loop reversal. */
3017 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
3018 {
3019 loop->order[n] = n;
3020 loop->reverse[n] = GFC_INHIBIT_REVERSE;
3021 }
3022
3023 loop->ss = gfc_ss_terminator;
3024 }
3025
3026
3027 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
3028 chain. */
3029
3030 void
gfc_copy_loopinfo_to_se(gfc_se * se,gfc_loopinfo * loop)3031 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
3032 {
3033 se->loop = loop;
3034 }
3035
3036
3037 /* Return an expression for the data pointer of an array. */
3038
3039 tree
gfc_conv_array_data(tree descriptor)3040 gfc_conv_array_data (tree descriptor)
3041 {
3042 tree type;
3043
3044 type = TREE_TYPE (descriptor);
3045 if (GFC_ARRAY_TYPE_P (type))
3046 {
3047 if (TREE_CODE (type) == POINTER_TYPE)
3048 return descriptor;
3049 else
3050 {
3051 /* Descriptorless arrays. */
3052 return gfc_build_addr_expr (NULL_TREE, descriptor);
3053 }
3054 }
3055 else
3056 return gfc_conv_descriptor_data_get (descriptor);
3057 }
3058
3059
3060 /* Return an expression for the base offset of an array. */
3061
3062 tree
gfc_conv_array_offset(tree descriptor)3063 gfc_conv_array_offset (tree descriptor)
3064 {
3065 tree type;
3066
3067 type = TREE_TYPE (descriptor);
3068 if (GFC_ARRAY_TYPE_P (type))
3069 return GFC_TYPE_ARRAY_OFFSET (type);
3070 else
3071 return gfc_conv_descriptor_offset_get (descriptor);
3072 }
3073
3074
3075 /* Get an expression for the array stride. */
3076
3077 tree
gfc_conv_array_stride(tree descriptor,int dim)3078 gfc_conv_array_stride (tree descriptor, int dim)
3079 {
3080 tree tmp;
3081 tree type;
3082
3083 type = TREE_TYPE (descriptor);
3084
3085 /* For descriptorless arrays use the array size. */
3086 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
3087 if (tmp != NULL_TREE)
3088 return tmp;
3089
3090 tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]);
3091 return tmp;
3092 }
3093
3094
3095 /* Like gfc_conv_array_stride, but for the lower bound. */
3096
3097 tree
gfc_conv_array_lbound(tree descriptor,int dim)3098 gfc_conv_array_lbound (tree descriptor, int dim)
3099 {
3100 tree tmp;
3101 tree type;
3102
3103 type = TREE_TYPE (descriptor);
3104
3105 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
3106 if (tmp != NULL_TREE)
3107 return tmp;
3108
3109 tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]);
3110 return tmp;
3111 }
3112
3113
3114 /* Like gfc_conv_array_stride, but for the upper bound. */
3115
3116 tree
gfc_conv_array_ubound(tree descriptor,int dim)3117 gfc_conv_array_ubound (tree descriptor, int dim)
3118 {
3119 tree tmp;
3120 tree type;
3121
3122 type = TREE_TYPE (descriptor);
3123
3124 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
3125 if (tmp != NULL_TREE)
3126 return tmp;
3127
3128 /* This should only ever happen when passing an assumed shape array
3129 as an actual parameter. The value will never be used. */
3130 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
3131 return gfc_index_zero_node;
3132
3133 tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]);
3134 return tmp;
3135 }
3136
3137
3138 /* Generate code to perform an array index bound check. */
3139
3140 static tree
trans_array_bound_check(gfc_se * se,gfc_ss * ss,tree index,int n,locus * where,bool check_upper)3141 trans_array_bound_check (gfc_se * se, gfc_ss *ss, tree index, int n,
3142 locus * where, bool check_upper)
3143 {
3144 tree fault;
3145 tree tmp_lo, tmp_up;
3146 tree descriptor;
3147 char *msg;
3148 const char * name = NULL;
3149
3150 if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
3151 return index;
3152
3153 descriptor = ss->info->data.array.descriptor;
3154
3155 index = gfc_evaluate_now (index, &se->pre);
3156
3157 /* We find a name for the error message. */
3158 name = ss->info->expr->symtree->n.sym->name;
3159 gcc_assert (name != NULL);
3160
3161 if (VAR_P (descriptor))
3162 name = IDENTIFIER_POINTER (DECL_NAME (descriptor));
3163
3164 /* If upper bound is present, include both bounds in the error message. */
3165 if (check_upper)
3166 {
3167 tmp_lo = gfc_conv_array_lbound (descriptor, n);
3168 tmp_up = gfc_conv_array_ubound (descriptor, n);
3169
3170 if (name)
3171 msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3172 "outside of expected range (%%ld:%%ld)", n+1, name);
3173 else
3174 msg = xasprintf ("Index '%%ld' of dimension %d "
3175 "outside of expected range (%%ld:%%ld)", n+1);
3176
3177 fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3178 index, tmp_lo);
3179 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
3180 fold_convert (long_integer_type_node, index),
3181 fold_convert (long_integer_type_node, tmp_lo),
3182 fold_convert (long_integer_type_node, tmp_up));
3183 fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3184 index, tmp_up);
3185 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
3186 fold_convert (long_integer_type_node, index),
3187 fold_convert (long_integer_type_node, tmp_lo),
3188 fold_convert (long_integer_type_node, tmp_up));
3189 free (msg);
3190 }
3191 else
3192 {
3193 tmp_lo = gfc_conv_array_lbound (descriptor, n);
3194
3195 if (name)
3196 msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3197 "below lower bound of %%ld", n+1, name);
3198 else
3199 msg = xasprintf ("Index '%%ld' of dimension %d "
3200 "below lower bound of %%ld", n+1);
3201
3202 fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3203 index, tmp_lo);
3204 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
3205 fold_convert (long_integer_type_node, index),
3206 fold_convert (long_integer_type_node, tmp_lo));
3207 free (msg);
3208 }
3209
3210 return index;
3211 }
3212
3213
3214 /* Return the offset for an index. Performs bound checking for elemental
3215 dimensions. Single element references are processed separately.
3216 DIM is the array dimension, I is the loop dimension. */
3217
3218 static tree
conv_array_index_offset(gfc_se * se,gfc_ss * ss,int dim,int i,gfc_array_ref * ar,tree stride)3219 conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i,
3220 gfc_array_ref * ar, tree stride)
3221 {
3222 gfc_array_info *info;
3223 tree index;
3224 tree desc;
3225 tree data;
3226
3227 info = &ss->info->data.array;
3228
3229 /* Get the index into the array for this dimension. */
3230 if (ar)
3231 {
3232 gcc_assert (ar->type != AR_ELEMENT);
3233 switch (ar->dimen_type[dim])
3234 {
3235 case DIMEN_THIS_IMAGE:
3236 gcc_unreachable ();
3237 break;
3238 case DIMEN_ELEMENT:
3239 /* Elemental dimension. */
3240 gcc_assert (info->subscript[dim]
3241 && info->subscript[dim]->info->type == GFC_SS_SCALAR);
3242 /* We've already translated this value outside the loop. */
3243 index = info->subscript[dim]->info->data.scalar.value;
3244
3245 index = trans_array_bound_check (se, ss, index, dim, &ar->where,
3246 ar->as->type != AS_ASSUMED_SIZE
3247 || dim < ar->dimen - 1);
3248 break;
3249
3250 case DIMEN_VECTOR:
3251 gcc_assert (info && se->loop);
3252 gcc_assert (info->subscript[dim]
3253 && info->subscript[dim]->info->type == GFC_SS_VECTOR);
3254 desc = info->subscript[dim]->info->data.array.descriptor;
3255
3256 /* Get a zero-based index into the vector. */
3257 index = fold_build2_loc (input_location, MINUS_EXPR,
3258 gfc_array_index_type,
3259 se->loop->loopvar[i], se->loop->from[i]);
3260
3261 /* Multiply the index by the stride. */
3262 index = fold_build2_loc (input_location, MULT_EXPR,
3263 gfc_array_index_type,
3264 index, gfc_conv_array_stride (desc, 0));
3265
3266 /* Read the vector to get an index into info->descriptor. */
3267 data = build_fold_indirect_ref_loc (input_location,
3268 gfc_conv_array_data (desc));
3269 index = gfc_build_array_ref (data, index, NULL);
3270 index = gfc_evaluate_now (index, &se->pre);
3271 index = fold_convert (gfc_array_index_type, index);
3272
3273 /* Do any bounds checking on the final info->descriptor index. */
3274 index = trans_array_bound_check (se, ss, index, dim, &ar->where,
3275 ar->as->type != AS_ASSUMED_SIZE
3276 || dim < ar->dimen - 1);
3277 break;
3278
3279 case DIMEN_RANGE:
3280 /* Scalarized dimension. */
3281 gcc_assert (info && se->loop);
3282
3283 /* Multiply the loop variable by the stride and delta. */
3284 index = se->loop->loopvar[i];
3285 if (!integer_onep (info->stride[dim]))
3286 index = fold_build2_loc (input_location, MULT_EXPR,
3287 gfc_array_index_type, index,
3288 info->stride[dim]);
3289 if (!integer_zerop (info->delta[dim]))
3290 index = fold_build2_loc (input_location, PLUS_EXPR,
3291 gfc_array_index_type, index,
3292 info->delta[dim]);
3293 break;
3294
3295 default:
3296 gcc_unreachable ();
3297 }
3298 }
3299 else
3300 {
3301 /* Temporary array or derived type component. */
3302 gcc_assert (se->loop);
3303 index = se->loop->loopvar[se->loop->order[i]];
3304
3305 /* Pointer functions can have stride[0] different from unity.
3306 Use the stride returned by the function call and stored in
3307 the descriptor for the temporary. */
3308 if (se->ss && se->ss->info->type == GFC_SS_FUNCTION
3309 && se->ss->info->expr
3310 && se->ss->info->expr->symtree
3311 && se->ss->info->expr->symtree->n.sym->result
3312 && se->ss->info->expr->symtree->n.sym->result->attr.pointer)
3313 stride = gfc_conv_descriptor_stride_get (info->descriptor,
3314 gfc_rank_cst[dim]);
3315
3316 if (info->delta[dim] && !integer_zerop (info->delta[dim]))
3317 index = fold_build2_loc (input_location, PLUS_EXPR,
3318 gfc_array_index_type, index, info->delta[dim]);
3319 }
3320
3321 /* Multiply by the stride. */
3322 if (stride != NULL && !integer_onep (stride))
3323 index = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
3324 index, stride);
3325
3326 return index;
3327 }
3328
3329
3330 /* Build a scalarized array reference using the vptr 'size'. */
3331
3332 static bool
build_class_array_ref(gfc_se * se,tree base,tree index)3333 build_class_array_ref (gfc_se *se, tree base, tree index)
3334 {
3335 tree type;
3336 tree size;
3337 tree offset;
3338 tree decl = NULL_TREE;
3339 tree tmp;
3340 gfc_expr *expr = se->ss->info->expr;
3341 gfc_ref *ref;
3342 gfc_ref *class_ref = NULL;
3343 gfc_typespec *ts;
3344
3345 if (se->expr && DECL_P (se->expr) && DECL_LANG_SPECIFIC (se->expr)
3346 && GFC_DECL_SAVED_DESCRIPTOR (se->expr)
3347 && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (se->expr))))
3348 decl = se->expr;
3349 else
3350 {
3351 if (expr == NULL
3352 || (expr->ts.type != BT_CLASS
3353 && !gfc_is_class_array_function (expr)
3354 && !gfc_is_class_array_ref (expr, NULL)))
3355 return false;
3356
3357 if (expr->symtree && expr->symtree->n.sym->ts.type == BT_CLASS)
3358 ts = &expr->symtree->n.sym->ts;
3359 else
3360 ts = NULL;
3361
3362 for (ref = expr->ref; ref; ref = ref->next)
3363 {
3364 if (ref->type == REF_COMPONENT
3365 && ref->u.c.component->ts.type == BT_CLASS
3366 && ref->next && ref->next->type == REF_COMPONENT
3367 && strcmp (ref->next->u.c.component->name, "_data") == 0
3368 && ref->next->next
3369 && ref->next->next->type == REF_ARRAY
3370 && ref->next->next->u.ar.type != AR_ELEMENT)
3371 {
3372 ts = &ref->u.c.component->ts;
3373 class_ref = ref;
3374 break;
3375 }
3376 }
3377
3378 if (ts == NULL)
3379 return false;
3380 }
3381
3382 if (class_ref == NULL && expr && expr->symtree->n.sym->attr.function
3383 && expr->symtree->n.sym == expr->symtree->n.sym->result
3384 && expr->symtree->n.sym->backend_decl == current_function_decl)
3385 {
3386 decl = gfc_get_fake_result_decl (expr->symtree->n.sym, 0);
3387 }
3388 else if (expr && gfc_is_class_array_function (expr))
3389 {
3390 size = NULL_TREE;
3391 decl = NULL_TREE;
3392 for (tmp = base; tmp; tmp = TREE_OPERAND (tmp, 0))
3393 {
3394 tree type;
3395 type = TREE_TYPE (tmp);
3396 while (type)
3397 {
3398 if (GFC_CLASS_TYPE_P (type))
3399 decl = tmp;
3400 if (type != TYPE_CANONICAL (type))
3401 type = TYPE_CANONICAL (type);
3402 else
3403 type = NULL_TREE;
3404 }
3405 if (VAR_P (tmp))
3406 break;
3407 }
3408
3409 if (decl == NULL_TREE)
3410 return false;
3411
3412 se->class_vptr = gfc_evaluate_now (gfc_class_vptr_get (decl), &se->pre);
3413 }
3414 else if (class_ref == NULL)
3415 {
3416 if (decl == NULL_TREE)
3417 decl = expr->symtree->n.sym->backend_decl;
3418 /* For class arrays the tree containing the class is stored in
3419 GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl.
3420 For all others it's sym's backend_decl directly. */
3421 if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl))
3422 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
3423 }
3424 else
3425 {
3426 /* Remove everything after the last class reference, convert the
3427 expression and then recover its tailend once more. */
3428 gfc_se tmpse;
3429 ref = class_ref->next;
3430 class_ref->next = NULL;
3431 gfc_init_se (&tmpse, NULL);
3432 gfc_conv_expr (&tmpse, expr);
3433 gfc_add_block_to_block (&se->pre, &tmpse.pre);
3434 decl = tmpse.expr;
3435 class_ref->next = ref;
3436 }
3437
3438 if (POINTER_TYPE_P (TREE_TYPE (decl)))
3439 decl = build_fold_indirect_ref_loc (input_location, decl);
3440
3441 if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl)))
3442 return false;
3443
3444 size = gfc_class_vtab_size_get (decl);
3445
3446 /* For unlimited polymorphic entities then _len component needs to be
3447 multiplied with the size. If no _len component is present, then
3448 gfc_class_len_or_zero_get () return a zero_node. */
3449 tmp = gfc_class_len_or_zero_get (decl);
3450 if (!integer_zerop (tmp))
3451 size = fold_build2 (MULT_EXPR, TREE_TYPE (index),
3452 fold_convert (TREE_TYPE (index), size),
3453 fold_build2 (MAX_EXPR, TREE_TYPE (index),
3454 fold_convert (TREE_TYPE (index), tmp),
3455 fold_convert (TREE_TYPE (index),
3456 integer_one_node)));
3457 else
3458 size = fold_convert (TREE_TYPE (index), size);
3459
3460 /* Build the address of the element. */
3461 type = TREE_TYPE (TREE_TYPE (base));
3462 offset = fold_build2_loc (input_location, MULT_EXPR,
3463 gfc_array_index_type,
3464 index, size);
3465 tmp = gfc_build_addr_expr (pvoid_type_node, base);
3466 tmp = fold_build_pointer_plus_loc (input_location, tmp, offset);
3467 tmp = fold_convert (build_pointer_type (type), tmp);
3468
3469 /* Return the element in the se expression. */
3470 se->expr = build_fold_indirect_ref_loc (input_location, tmp);
3471 return true;
3472 }
3473
3474
3475 /* Build a scalarized reference to an array. */
3476
3477 static void
gfc_conv_scalarized_array_ref(gfc_se * se,gfc_array_ref * ar)3478 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
3479 {
3480 gfc_array_info *info;
3481 tree decl = NULL_TREE;
3482 tree index;
3483 tree base;
3484 gfc_ss *ss;
3485 gfc_expr *expr;
3486 int n;
3487
3488 ss = se->ss;
3489 expr = ss->info->expr;
3490 info = &ss->info->data.array;
3491 if (ar)
3492 n = se->loop->order[0];
3493 else
3494 n = 0;
3495
3496 index = conv_array_index_offset (se, ss, ss->dim[n], n, ar, info->stride0);
3497 /* Add the offset for this dimension to the stored offset for all other
3498 dimensions. */
3499 if (info->offset && !integer_zerop (info->offset))
3500 index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3501 index, info->offset);
3502
3503 base = build_fold_indirect_ref_loc (input_location, info->data);
3504
3505 /* Use the vptr 'size' field to access the element of a class array. */
3506 if (build_class_array_ref (se, base, index))
3507 return;
3508
3509 if (get_CFI_desc (NULL, expr, &decl, ar))
3510 {
3511 decl = build_fold_indirect_ref_loc (input_location, decl);
3512 goto done;
3513 }
3514
3515 if (expr && ((is_subref_array (expr)
3516 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info->descriptor)))
3517 || (expr->ts.deferred && (expr->expr_type == EXPR_VARIABLE
3518 || expr->expr_type == EXPR_FUNCTION))))
3519 decl = expr->symtree->n.sym->backend_decl;
3520
3521 if (decl && GFC_DECL_PTR_ARRAY_P (decl))
3522 goto done;
3523
3524 /* A pointer array component can be detected from its field decl. Fix
3525 the descriptor, mark the resulting variable decl and pass it to
3526 gfc_build_array_ref. */
3527 if (is_pointer_array (info->descriptor)
3528 || (expr && expr->ts.deferred && info->descriptor
3529 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info->descriptor))))
3530 {
3531 if (TREE_CODE (info->descriptor) == COMPONENT_REF)
3532 decl = info->descriptor;
3533 else if (TREE_CODE (info->descriptor) == INDIRECT_REF)
3534 decl = TREE_OPERAND (info->descriptor, 0);
3535
3536 if (decl == NULL_TREE)
3537 decl = info->descriptor;
3538 }
3539
3540 done:
3541 se->expr = gfc_build_array_ref (base, index, decl);
3542 }
3543
3544
3545 /* Translate access of temporary array. */
3546
3547 void
gfc_conv_tmp_array_ref(gfc_se * se)3548 gfc_conv_tmp_array_ref (gfc_se * se)
3549 {
3550 se->string_length = se->ss->info->string_length;
3551 gfc_conv_scalarized_array_ref (se, NULL);
3552 gfc_advance_se_ss_chain (se);
3553 }
3554
3555 /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
3556
3557 static void
add_to_offset(tree * cst_offset,tree * offset,tree t)3558 add_to_offset (tree *cst_offset, tree *offset, tree t)
3559 {
3560 if (TREE_CODE (t) == INTEGER_CST)
3561 *cst_offset = int_const_binop (PLUS_EXPR, *cst_offset, t);
3562 else
3563 {
3564 if (!integer_zerop (*offset))
3565 *offset = fold_build2_loc (input_location, PLUS_EXPR,
3566 gfc_array_index_type, *offset, t);
3567 else
3568 *offset = t;
3569 }
3570 }
3571
3572
3573 static tree
build_array_ref(tree desc,tree offset,tree decl,tree vptr)3574 build_array_ref (tree desc, tree offset, tree decl, tree vptr)
3575 {
3576 tree tmp;
3577 tree type;
3578 tree cdesc;
3579
3580 /* For class arrays the class declaration is stored in the saved
3581 descriptor. */
3582 if (INDIRECT_REF_P (desc)
3583 && DECL_LANG_SPECIFIC (TREE_OPERAND (desc, 0))
3584 && GFC_DECL_SAVED_DESCRIPTOR (TREE_OPERAND (desc, 0)))
3585 cdesc = gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (
3586 TREE_OPERAND (desc, 0)));
3587 else
3588 cdesc = desc;
3589
3590 /* Class container types do not always have the GFC_CLASS_TYPE_P
3591 but the canonical type does. */
3592 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdesc))
3593 && TREE_CODE (cdesc) == COMPONENT_REF)
3594 {
3595 type = TREE_TYPE (TREE_OPERAND (cdesc, 0));
3596 if (TYPE_CANONICAL (type)
3597 && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type)))
3598 vptr = gfc_class_vptr_get (TREE_OPERAND (cdesc, 0));
3599 }
3600
3601 tmp = gfc_conv_array_data (desc);
3602 tmp = build_fold_indirect_ref_loc (input_location, tmp);
3603 tmp = gfc_build_array_ref (tmp, offset, decl, vptr);
3604 return tmp;
3605 }
3606
3607
3608 /* Build an array reference. se->expr already holds the array descriptor.
3609 This should be either a variable, indirect variable reference or component
3610 reference. For arrays which do not have a descriptor, se->expr will be
3611 the data pointer.
3612 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
3613
3614 void
gfc_conv_array_ref(gfc_se * se,gfc_array_ref * ar,gfc_expr * expr,locus * where)3615 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
3616 locus * where)
3617 {
3618 int n;
3619 tree offset, cst_offset;
3620 tree tmp;
3621 tree stride;
3622 tree decl = NULL_TREE;
3623 gfc_se indexse;
3624 gfc_se tmpse;
3625 gfc_symbol * sym = expr->symtree->n.sym;
3626 char *var_name = NULL;
3627
3628 if (ar->dimen == 0)
3629 {
3630 gcc_assert (ar->codimen);
3631
3632 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
3633 se->expr = build_fold_indirect_ref (gfc_conv_array_data (se->expr));
3634 else
3635 {
3636 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr))
3637 && TREE_CODE (TREE_TYPE (se->expr)) == POINTER_TYPE)
3638 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
3639
3640 /* Use the actual tree type and not the wrapped coarray. */
3641 if (!se->want_pointer)
3642 se->expr = fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se->expr)),
3643 se->expr);
3644 }
3645
3646 return;
3647 }
3648
3649 /* Handle scalarized references separately. */
3650 if (ar->type != AR_ELEMENT)
3651 {
3652 gfc_conv_scalarized_array_ref (se, ar);
3653 gfc_advance_se_ss_chain (se);
3654 return;
3655 }
3656
3657 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3658 {
3659 size_t len;
3660 gfc_ref *ref;
3661
3662 len = strlen (sym->name) + 1;
3663 for (ref = expr->ref; ref; ref = ref->next)
3664 {
3665 if (ref->type == REF_ARRAY && &ref->u.ar == ar)
3666 break;
3667 if (ref->type == REF_COMPONENT)
3668 len += 2 + strlen (ref->u.c.component->name);
3669 }
3670
3671 var_name = XALLOCAVEC (char, len);
3672 strcpy (var_name, sym->name);
3673
3674 for (ref = expr->ref; ref; ref = ref->next)
3675 {
3676 if (ref->type == REF_ARRAY && &ref->u.ar == ar)
3677 break;
3678 if (ref->type == REF_COMPONENT)
3679 {
3680 strcat (var_name, "%%");
3681 strcat (var_name, ref->u.c.component->name);
3682 }
3683 }
3684 }
3685
3686 cst_offset = offset = gfc_index_zero_node;
3687 add_to_offset (&cst_offset, &offset, gfc_conv_array_offset (se->expr));
3688
3689 /* Calculate the offsets from all the dimensions. Make sure to associate
3690 the final offset so that we form a chain of loop invariant summands. */
3691 for (n = ar->dimen - 1; n >= 0; n--)
3692 {
3693 /* Calculate the index for this dimension. */
3694 gfc_init_se (&indexse, se);
3695 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
3696 gfc_add_block_to_block (&se->pre, &indexse.pre);
3697
3698 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && ! expr->no_bounds_check)
3699 {
3700 /* Check array bounds. */
3701 tree cond;
3702 char *msg;
3703
3704 /* Evaluate the indexse.expr only once. */
3705 indexse.expr = save_expr (indexse.expr);
3706
3707 /* Lower bound. */
3708 tmp = gfc_conv_array_lbound (se->expr, n);
3709 if (sym->attr.temporary)
3710 {
3711 gfc_init_se (&tmpse, se);
3712 gfc_conv_expr_type (&tmpse, ar->as->lower[n],
3713 gfc_array_index_type);
3714 gfc_add_block_to_block (&se->pre, &tmpse.pre);
3715 tmp = tmpse.expr;
3716 }
3717
3718 cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3719 indexse.expr, tmp);
3720 msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3721 "below lower bound of %%ld", n+1, var_name);
3722 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
3723 fold_convert (long_integer_type_node,
3724 indexse.expr),
3725 fold_convert (long_integer_type_node, tmp));
3726 free (msg);
3727
3728 /* Upper bound, but not for the last dimension of assumed-size
3729 arrays. */
3730 if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE)
3731 {
3732 tmp = gfc_conv_array_ubound (se->expr, n);
3733 if (sym->attr.temporary)
3734 {
3735 gfc_init_se (&tmpse, se);
3736 gfc_conv_expr_type (&tmpse, ar->as->upper[n],
3737 gfc_array_index_type);
3738 gfc_add_block_to_block (&se->pre, &tmpse.pre);
3739 tmp = tmpse.expr;
3740 }
3741
3742 cond = fold_build2_loc (input_location, GT_EXPR,
3743 logical_type_node, indexse.expr, tmp);
3744 msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3745 "above upper bound of %%ld", n+1, var_name);
3746 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
3747 fold_convert (long_integer_type_node,
3748 indexse.expr),
3749 fold_convert (long_integer_type_node, tmp));
3750 free (msg);
3751 }
3752 }
3753
3754 /* Multiply the index by the stride. */
3755 stride = gfc_conv_array_stride (se->expr, n);
3756 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
3757 indexse.expr, stride);
3758
3759 /* And add it to the total. */
3760 add_to_offset (&cst_offset, &offset, tmp);
3761 }
3762
3763 if (!integer_zerop (cst_offset))
3764 offset = fold_build2_loc (input_location, PLUS_EXPR,
3765 gfc_array_index_type, offset, cst_offset);
3766
3767 /* A pointer array component can be detected from its field decl. Fix
3768 the descriptor, mark the resulting variable decl and pass it to
3769 build_array_ref. */
3770 if (get_CFI_desc (sym, expr, &decl, ar))
3771 decl = build_fold_indirect_ref_loc (input_location, decl);
3772 if (!expr->ts.deferred && !sym->attr.codimension
3773 && is_pointer_array (se->expr))
3774 {
3775 if (TREE_CODE (se->expr) == COMPONENT_REF)
3776 decl = se->expr;
3777 else if (TREE_CODE (se->expr) == INDIRECT_REF)
3778 decl = TREE_OPERAND (se->expr, 0);
3779 else
3780 decl = se->expr;
3781 }
3782 else if (expr->ts.deferred
3783 || (sym->ts.type == BT_CHARACTER
3784 && sym->attr.select_type_temporary))
3785 {
3786 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
3787 {
3788 decl = se->expr;
3789 if (TREE_CODE (decl) == INDIRECT_REF)
3790 decl = TREE_OPERAND (decl, 0);
3791 }
3792 else
3793 decl = sym->backend_decl;
3794 }
3795 else if (sym->ts.type == BT_CLASS)
3796 decl = NULL_TREE;
3797
3798 se->expr = build_array_ref (se->expr, offset, decl, se->class_vptr);
3799 }
3800
3801
3802 /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
3803 LOOP_DIM dimension (if any) to array's offset. */
3804
3805 static void
add_array_offset(stmtblock_t * pblock,gfc_loopinfo * loop,gfc_ss * ss,gfc_array_ref * ar,int array_dim,int loop_dim)3806 add_array_offset (stmtblock_t *pblock, gfc_loopinfo *loop, gfc_ss *ss,
3807 gfc_array_ref *ar, int array_dim, int loop_dim)
3808 {
3809 gfc_se se;
3810 gfc_array_info *info;
3811 tree stride, index;
3812
3813 info = &ss->info->data.array;
3814
3815 gfc_init_se (&se, NULL);
3816 se.loop = loop;
3817 se.expr = info->descriptor;
3818 stride = gfc_conv_array_stride (info->descriptor, array_dim);
3819 index = conv_array_index_offset (&se, ss, array_dim, loop_dim, ar, stride);
3820 gfc_add_block_to_block (pblock, &se.pre);
3821
3822 info->offset = fold_build2_loc (input_location, PLUS_EXPR,
3823 gfc_array_index_type,
3824 info->offset, index);
3825 info->offset = gfc_evaluate_now (info->offset, pblock);
3826 }
3827
3828
3829 /* Generate the code to be executed immediately before entering a
3830 scalarization loop. */
3831
3832 static void
gfc_trans_preloop_setup(gfc_loopinfo * loop,int dim,int flag,stmtblock_t * pblock)3833 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
3834 stmtblock_t * pblock)
3835 {
3836 tree stride;
3837 gfc_ss_info *ss_info;
3838 gfc_array_info *info;
3839 gfc_ss_type ss_type;
3840 gfc_ss *ss, *pss;
3841 gfc_loopinfo *ploop;
3842 gfc_array_ref *ar;
3843 int i;
3844
3845 /* This code will be executed before entering the scalarization loop
3846 for this dimension. */
3847 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3848 {
3849 ss_info = ss->info;
3850
3851 if ((ss_info->useflags & flag) == 0)
3852 continue;
3853
3854 ss_type = ss_info->type;
3855 if (ss_type != GFC_SS_SECTION
3856 && ss_type != GFC_SS_FUNCTION
3857 && ss_type != GFC_SS_CONSTRUCTOR
3858 && ss_type != GFC_SS_COMPONENT)
3859 continue;
3860
3861 info = &ss_info->data.array;
3862
3863 gcc_assert (dim < ss->dimen);
3864 gcc_assert (ss->dimen == loop->dimen);
3865
3866 if (info->ref)
3867 ar = &info->ref->u.ar;
3868 else
3869 ar = NULL;
3870
3871 if (dim == loop->dimen - 1 && loop->parent != NULL)
3872 {
3873 /* If we are in the outermost dimension of this loop, the previous
3874 dimension shall be in the parent loop. */
3875 gcc_assert (ss->parent != NULL);
3876
3877 pss = ss->parent;
3878 ploop = loop->parent;
3879
3880 /* ss and ss->parent are about the same array. */
3881 gcc_assert (ss_info == pss->info);
3882 }
3883 else
3884 {
3885 ploop = loop;
3886 pss = ss;
3887 }
3888
3889 if (dim == loop->dimen - 1)
3890 i = 0;
3891 else
3892 i = dim + 1;
3893
3894 /* For the time being, there is no loop reordering. */
3895 gcc_assert (i == ploop->order[i]);
3896 i = ploop->order[i];
3897
3898 if (dim == loop->dimen - 1 && loop->parent == NULL)
3899 {
3900 stride = gfc_conv_array_stride (info->descriptor,
3901 innermost_ss (ss)->dim[i]);
3902
3903 /* Calculate the stride of the innermost loop. Hopefully this will
3904 allow the backend optimizers to do their stuff more effectively.
3905 */
3906 info->stride0 = gfc_evaluate_now (stride, pblock);
3907
3908 /* For the outermost loop calculate the offset due to any
3909 elemental dimensions. It will have been initialized with the
3910 base offset of the array. */
3911 if (info->ref)
3912 {
3913 for (i = 0; i < ar->dimen; i++)
3914 {
3915 if (ar->dimen_type[i] != DIMEN_ELEMENT)
3916 continue;
3917
3918 add_array_offset (pblock, loop, ss, ar, i, /* unused */ -1);
3919 }
3920 }
3921 }
3922 else
3923 /* Add the offset for the previous loop dimension. */
3924 add_array_offset (pblock, ploop, ss, ar, pss->dim[i], i);
3925
3926 /* Remember this offset for the second loop. */
3927 if (dim == loop->temp_dim - 1 && loop->parent == NULL)
3928 info->saved_offset = info->offset;
3929 }
3930 }
3931
3932
3933 /* Start a scalarized expression. Creates a scope and declares loop
3934 variables. */
3935
3936 void
gfc_start_scalarized_body(gfc_loopinfo * loop,stmtblock_t * pbody)3937 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
3938 {
3939 int dim;
3940 int n;
3941 int flags;
3942
3943 gcc_assert (!loop->array_parameter);
3944
3945 for (dim = loop->dimen - 1; dim >= 0; dim--)
3946 {
3947 n = loop->order[dim];
3948
3949 gfc_start_block (&loop->code[n]);
3950
3951 /* Create the loop variable. */
3952 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
3953
3954 if (dim < loop->temp_dim)
3955 flags = 3;
3956 else
3957 flags = 1;
3958 /* Calculate values that will be constant within this loop. */
3959 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
3960 }
3961 gfc_start_block (pbody);
3962 }
3963
3964
3965 /* Generates the actual loop code for a scalarization loop. */
3966
3967 void
gfc_trans_scalarized_loop_end(gfc_loopinfo * loop,int n,stmtblock_t * pbody)3968 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
3969 stmtblock_t * pbody)
3970 {
3971 stmtblock_t block;
3972 tree cond;
3973 tree tmp;
3974 tree loopbody;
3975 tree exit_label;
3976 tree stmt;
3977 tree init;
3978 tree incr;
3979
3980 if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS
3981 | OMPWS_SCALARIZER_BODY))
3982 == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS)
3983 && n == loop->dimen - 1)
3984 {
3985 /* We create an OMP_FOR construct for the outermost scalarized loop. */
3986 init = make_tree_vec (1);
3987 cond = make_tree_vec (1);
3988 incr = make_tree_vec (1);
3989
3990 /* Cycle statement is implemented with a goto. Exit statement must not
3991 be present for this loop. */
3992 exit_label = gfc_build_label_decl (NULL_TREE);
3993 TREE_USED (exit_label) = 1;
3994
3995 /* Label for cycle statements (if needed). */
3996 tmp = build1_v (LABEL_EXPR, exit_label);
3997 gfc_add_expr_to_block (pbody, tmp);
3998
3999 stmt = make_node (OMP_FOR);
4000
4001 TREE_TYPE (stmt) = void_type_node;
4002 OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody);
4003
4004 OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location,
4005 OMP_CLAUSE_SCHEDULE);
4006 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt))
4007 = OMP_CLAUSE_SCHEDULE_STATIC;
4008 if (ompws_flags & OMPWS_NOWAIT)
4009 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt))
4010 = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT);
4011
4012 /* Initialize the loopvar. */
4013 TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n],
4014 loop->from[n]);
4015 OMP_FOR_INIT (stmt) = init;
4016 /* The exit condition. */
4017 TREE_VEC_ELT (cond, 0) = build2_loc (input_location, LE_EXPR,
4018 logical_type_node,
4019 loop->loopvar[n], loop->to[n]);
4020 SET_EXPR_LOCATION (TREE_VEC_ELT (cond, 0), input_location);
4021 OMP_FOR_COND (stmt) = cond;
4022 /* Increment the loopvar. */
4023 tmp = build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4024 loop->loopvar[n], gfc_index_one_node);
4025 TREE_VEC_ELT (incr, 0) = fold_build2_loc (input_location, MODIFY_EXPR,
4026 void_type_node, loop->loopvar[n], tmp);
4027 OMP_FOR_INCR (stmt) = incr;
4028
4029 ompws_flags &= ~OMPWS_CURR_SINGLEUNIT;
4030 gfc_add_expr_to_block (&loop->code[n], stmt);
4031 }
4032 else
4033 {
4034 bool reverse_loop = (loop->reverse[n] == GFC_REVERSE_SET)
4035 && (loop->temp_ss == NULL);
4036
4037 loopbody = gfc_finish_block (pbody);
4038
4039 if (reverse_loop)
4040 std::swap (loop->from[n], loop->to[n]);
4041
4042 /* Initialize the loopvar. */
4043 if (loop->loopvar[n] != loop->from[n])
4044 gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
4045
4046 exit_label = gfc_build_label_decl (NULL_TREE);
4047
4048 /* Generate the loop body. */
4049 gfc_init_block (&block);
4050
4051 /* The exit condition. */
4052 cond = fold_build2_loc (input_location, reverse_loop ? LT_EXPR : GT_EXPR,
4053 logical_type_node, loop->loopvar[n], loop->to[n]);
4054 tmp = build1_v (GOTO_EXPR, exit_label);
4055 TREE_USED (exit_label) = 1;
4056 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
4057 gfc_add_expr_to_block (&block, tmp);
4058
4059 /* The main body. */
4060 gfc_add_expr_to_block (&block, loopbody);
4061
4062 /* Increment the loopvar. */
4063 tmp = fold_build2_loc (input_location,
4064 reverse_loop ? MINUS_EXPR : PLUS_EXPR,
4065 gfc_array_index_type, loop->loopvar[n],
4066 gfc_index_one_node);
4067
4068 gfc_add_modify (&block, loop->loopvar[n], tmp);
4069
4070 /* Build the loop. */
4071 tmp = gfc_finish_block (&block);
4072 tmp = build1_v (LOOP_EXPR, tmp);
4073 gfc_add_expr_to_block (&loop->code[n], tmp);
4074
4075 /* Add the exit label. */
4076 tmp = build1_v (LABEL_EXPR, exit_label);
4077 gfc_add_expr_to_block (&loop->code[n], tmp);
4078 }
4079
4080 }
4081
4082
4083 /* Finishes and generates the loops for a scalarized expression. */
4084
4085 void
gfc_trans_scalarizing_loops(gfc_loopinfo * loop,stmtblock_t * body)4086 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
4087 {
4088 int dim;
4089 int n;
4090 gfc_ss *ss;
4091 stmtblock_t *pblock;
4092 tree tmp;
4093
4094 pblock = body;
4095 /* Generate the loops. */
4096 for (dim = 0; dim < loop->dimen; dim++)
4097 {
4098 n = loop->order[dim];
4099 gfc_trans_scalarized_loop_end (loop, n, pblock);
4100 loop->loopvar[n] = NULL_TREE;
4101 pblock = &loop->code[n];
4102 }
4103
4104 tmp = gfc_finish_block (pblock);
4105 gfc_add_expr_to_block (&loop->pre, tmp);
4106
4107 /* Clear all the used flags. */
4108 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4109 if (ss->parent == NULL)
4110 ss->info->useflags = 0;
4111 }
4112
4113
4114 /* Finish the main body of a scalarized expression, and start the secondary
4115 copying body. */
4116
4117 void
gfc_trans_scalarized_loop_boundary(gfc_loopinfo * loop,stmtblock_t * body)4118 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
4119 {
4120 int dim;
4121 int n;
4122 stmtblock_t *pblock;
4123 gfc_ss *ss;
4124
4125 pblock = body;
4126 /* We finish as many loops as are used by the temporary. */
4127 for (dim = 0; dim < loop->temp_dim - 1; dim++)
4128 {
4129 n = loop->order[dim];
4130 gfc_trans_scalarized_loop_end (loop, n, pblock);
4131 loop->loopvar[n] = NULL_TREE;
4132 pblock = &loop->code[n];
4133 }
4134
4135 /* We don't want to finish the outermost loop entirely. */
4136 n = loop->order[loop->temp_dim - 1];
4137 gfc_trans_scalarized_loop_end (loop, n, pblock);
4138
4139 /* Restore the initial offsets. */
4140 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4141 {
4142 gfc_ss_type ss_type;
4143 gfc_ss_info *ss_info;
4144
4145 ss_info = ss->info;
4146
4147 if ((ss_info->useflags & 2) == 0)
4148 continue;
4149
4150 ss_type = ss_info->type;
4151 if (ss_type != GFC_SS_SECTION
4152 && ss_type != GFC_SS_FUNCTION
4153 && ss_type != GFC_SS_CONSTRUCTOR
4154 && ss_type != GFC_SS_COMPONENT)
4155 continue;
4156
4157 ss_info->data.array.offset = ss_info->data.array.saved_offset;
4158 }
4159
4160 /* Restart all the inner loops we just finished. */
4161 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
4162 {
4163 n = loop->order[dim];
4164
4165 gfc_start_block (&loop->code[n]);
4166
4167 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
4168
4169 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
4170 }
4171
4172 /* Start a block for the secondary copying code. */
4173 gfc_start_block (body);
4174 }
4175
4176
4177 /* Precalculate (either lower or upper) bound of an array section.
4178 BLOCK: Block in which the (pre)calculation code will go.
4179 BOUNDS[DIM]: Where the bound value will be stored once evaluated.
4180 VALUES[DIM]: Specified bound (NULL <=> unspecified).
4181 DESC: Array descriptor from which the bound will be picked if unspecified
4182 (either lower or upper bound according to LBOUND). */
4183
4184 static void
evaluate_bound(stmtblock_t * block,tree * bounds,gfc_expr ** values,tree desc,int dim,bool lbound,bool deferred)4185 evaluate_bound (stmtblock_t *block, tree *bounds, gfc_expr ** values,
4186 tree desc, int dim, bool lbound, bool deferred)
4187 {
4188 gfc_se se;
4189 gfc_expr * input_val = values[dim];
4190 tree *output = &bounds[dim];
4191
4192
4193 if (input_val)
4194 {
4195 /* Specified section bound. */
4196 gfc_init_se (&se, NULL);
4197 gfc_conv_expr_type (&se, input_val, gfc_array_index_type);
4198 gfc_add_block_to_block (block, &se.pre);
4199 *output = se.expr;
4200 }
4201 else if (deferred && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
4202 {
4203 /* The gfc_conv_array_lbound () routine returns a constant zero for
4204 deferred length arrays, which in the scalarizer wreaks havoc, when
4205 copying to a (newly allocated) one-based array.
4206 Keep returning the actual result in sync for both bounds. */
4207 *output = lbound ? gfc_conv_descriptor_lbound_get (desc,
4208 gfc_rank_cst[dim]):
4209 gfc_conv_descriptor_ubound_get (desc,
4210 gfc_rank_cst[dim]);
4211 }
4212 else
4213 {
4214 /* No specific bound specified so use the bound of the array. */
4215 *output = lbound ? gfc_conv_array_lbound (desc, dim) :
4216 gfc_conv_array_ubound (desc, dim);
4217 }
4218 *output = gfc_evaluate_now (*output, block);
4219 }
4220
4221
4222 /* Calculate the lower bound of an array section. */
4223
4224 static void
gfc_conv_section_startstride(stmtblock_t * block,gfc_ss * ss,int dim)4225 gfc_conv_section_startstride (stmtblock_t * block, gfc_ss * ss, int dim)
4226 {
4227 gfc_expr *stride = NULL;
4228 tree desc;
4229 gfc_se se;
4230 gfc_array_info *info;
4231 gfc_array_ref *ar;
4232
4233 gcc_assert (ss->info->type == GFC_SS_SECTION);
4234
4235 info = &ss->info->data.array;
4236 ar = &info->ref->u.ar;
4237
4238 if (ar->dimen_type[dim] == DIMEN_VECTOR)
4239 {
4240 /* We use a zero-based index to access the vector. */
4241 info->start[dim] = gfc_index_zero_node;
4242 info->end[dim] = NULL;
4243 info->stride[dim] = gfc_index_one_node;
4244 return;
4245 }
4246
4247 gcc_assert (ar->dimen_type[dim] == DIMEN_RANGE
4248 || ar->dimen_type[dim] == DIMEN_THIS_IMAGE);
4249 desc = info->descriptor;
4250 stride = ar->stride[dim];
4251
4252
4253 /* Calculate the start of the range. For vector subscripts this will
4254 be the range of the vector. */
4255 evaluate_bound (block, info->start, ar->start, desc, dim, true,
4256 ar->as->type == AS_DEFERRED);
4257
4258 /* Similarly calculate the end. Although this is not used in the
4259 scalarizer, it is needed when checking bounds and where the end
4260 is an expression with side-effects. */
4261 evaluate_bound (block, info->end, ar->end, desc, dim, false,
4262 ar->as->type == AS_DEFERRED);
4263
4264
4265 /* Calculate the stride. */
4266 if (stride == NULL)
4267 info->stride[dim] = gfc_index_one_node;
4268 else
4269 {
4270 gfc_init_se (&se, NULL);
4271 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
4272 gfc_add_block_to_block (block, &se.pre);
4273 info->stride[dim] = gfc_evaluate_now (se.expr, block);
4274 }
4275 }
4276
4277
4278 /* Calculates the range start and stride for a SS chain. Also gets the
4279 descriptor and data pointer. The range of vector subscripts is the size
4280 of the vector. Array bounds are also checked. */
4281
4282 void
gfc_conv_ss_startstride(gfc_loopinfo * loop)4283 gfc_conv_ss_startstride (gfc_loopinfo * loop)
4284 {
4285 int n;
4286 tree tmp;
4287 gfc_ss *ss;
4288 tree desc;
4289
4290 gfc_loopinfo * const outer_loop = outermost_loop (loop);
4291
4292 loop->dimen = 0;
4293 /* Determine the rank of the loop. */
4294 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4295 {
4296 switch (ss->info->type)
4297 {
4298 case GFC_SS_SECTION:
4299 case GFC_SS_CONSTRUCTOR:
4300 case GFC_SS_FUNCTION:
4301 case GFC_SS_COMPONENT:
4302 loop->dimen = ss->dimen;
4303 goto done;
4304
4305 /* As usual, lbound and ubound are exceptions!. */
4306 case GFC_SS_INTRINSIC:
4307 switch (ss->info->expr->value.function.isym->id)
4308 {
4309 case GFC_ISYM_LBOUND:
4310 case GFC_ISYM_UBOUND:
4311 case GFC_ISYM_LCOBOUND:
4312 case GFC_ISYM_UCOBOUND:
4313 case GFC_ISYM_THIS_IMAGE:
4314 loop->dimen = ss->dimen;
4315 goto done;
4316
4317 default:
4318 break;
4319 }
4320
4321 default:
4322 break;
4323 }
4324 }
4325
4326 /* We should have determined the rank of the expression by now. If
4327 not, that's bad news. */
4328 gcc_unreachable ();
4329
4330 done:
4331 /* Loop over all the SS in the chain. */
4332 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4333 {
4334 gfc_ss_info *ss_info;
4335 gfc_array_info *info;
4336 gfc_expr *expr;
4337
4338 ss_info = ss->info;
4339 expr = ss_info->expr;
4340 info = &ss_info->data.array;
4341
4342 if (expr && expr->shape && !info->shape)
4343 info->shape = expr->shape;
4344
4345 switch (ss_info->type)
4346 {
4347 case GFC_SS_SECTION:
4348 /* Get the descriptor for the array. If it is a cross loops array,
4349 we got the descriptor already in the outermost loop. */
4350 if (ss->parent == NULL)
4351 gfc_conv_ss_descriptor (&outer_loop->pre, ss,
4352 !loop->array_parameter);
4353
4354 for (n = 0; n < ss->dimen; n++)
4355 gfc_conv_section_startstride (&outer_loop->pre, ss, ss->dim[n]);
4356 break;
4357
4358 case GFC_SS_INTRINSIC:
4359 switch (expr->value.function.isym->id)
4360 {
4361 /* Fall through to supply start and stride. */
4362 case GFC_ISYM_LBOUND:
4363 case GFC_ISYM_UBOUND:
4364 {
4365 gfc_expr *arg;
4366
4367 /* This is the variant without DIM=... */
4368 gcc_assert (expr->value.function.actual->next->expr == NULL);
4369
4370 arg = expr->value.function.actual->expr;
4371 if (arg->rank == -1)
4372 {
4373 gfc_se se;
4374 tree rank, tmp;
4375
4376 /* The rank (hence the return value's shape) is unknown,
4377 we have to retrieve it. */
4378 gfc_init_se (&se, NULL);
4379 se.descriptor_only = 1;
4380 gfc_conv_expr (&se, arg);
4381 /* This is a bare variable, so there is no preliminary
4382 or cleanup code. */
4383 gcc_assert (se.pre.head == NULL_TREE
4384 && se.post.head == NULL_TREE);
4385 rank = gfc_conv_descriptor_rank (se.expr);
4386 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4387 gfc_array_index_type,
4388 fold_convert (gfc_array_index_type,
4389 rank),
4390 gfc_index_one_node);
4391 info->end[0] = gfc_evaluate_now (tmp, &outer_loop->pre);
4392 info->start[0] = gfc_index_zero_node;
4393 info->stride[0] = gfc_index_one_node;
4394 continue;
4395 }
4396 /* Otherwise fall through GFC_SS_FUNCTION. */
4397 gcc_fallthrough ();
4398 }
4399 case GFC_ISYM_LCOBOUND:
4400 case GFC_ISYM_UCOBOUND:
4401 case GFC_ISYM_THIS_IMAGE:
4402 break;
4403
4404 default:
4405 continue;
4406 }
4407
4408 /* FALLTHRU */
4409 case GFC_SS_CONSTRUCTOR:
4410 case GFC_SS_FUNCTION:
4411 for (n = 0; n < ss->dimen; n++)
4412 {
4413 int dim = ss->dim[n];
4414
4415 info->start[dim] = gfc_index_zero_node;
4416 info->end[dim] = gfc_index_zero_node;
4417 info->stride[dim] = gfc_index_one_node;
4418 }
4419 break;
4420
4421 default:
4422 break;
4423 }
4424 }
4425
4426 /* The rest is just runtime bounds checking. */
4427 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
4428 {
4429 stmtblock_t block;
4430 tree lbound, ubound;
4431 tree end;
4432 tree size[GFC_MAX_DIMENSIONS];
4433 tree stride_pos, stride_neg, non_zerosized, tmp2, tmp3;
4434 gfc_array_info *info;
4435 char *msg;
4436 int dim;
4437
4438 gfc_start_block (&block);
4439
4440 for (n = 0; n < loop->dimen; n++)
4441 size[n] = NULL_TREE;
4442
4443 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4444 {
4445 stmtblock_t inner;
4446 gfc_ss_info *ss_info;
4447 gfc_expr *expr;
4448 locus *expr_loc;
4449 const char *expr_name;
4450
4451 ss_info = ss->info;
4452 if (ss_info->type != GFC_SS_SECTION)
4453 continue;
4454
4455 /* Catch allocatable lhs in f2003. */
4456 if (flag_realloc_lhs && ss->no_bounds_check)
4457 continue;
4458
4459 expr = ss_info->expr;
4460 expr_loc = &expr->where;
4461 expr_name = expr->symtree->name;
4462
4463 gfc_start_block (&inner);
4464
4465 /* TODO: range checking for mapped dimensions. */
4466 info = &ss_info->data.array;
4467
4468 /* This code only checks ranges. Elemental and vector
4469 dimensions are checked later. */
4470 for (n = 0; n < loop->dimen; n++)
4471 {
4472 bool check_upper;
4473
4474 dim = ss->dim[n];
4475 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
4476 continue;
4477
4478 if (dim == info->ref->u.ar.dimen - 1
4479 && info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
4480 check_upper = false;
4481 else
4482 check_upper = true;
4483
4484 /* Zero stride is not allowed. */
4485 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
4486 info->stride[dim], gfc_index_zero_node);
4487 msg = xasprintf ("Zero stride is not allowed, for dimension %d "
4488 "of array '%s'", dim + 1, expr_name);
4489 gfc_trans_runtime_check (true, false, tmp, &inner,
4490 expr_loc, msg);
4491 free (msg);
4492
4493 desc = info->descriptor;
4494
4495 /* This is the run-time equivalent of resolve.c's
4496 check_dimension(). The logical is more readable there
4497 than it is here, with all the trees. */
4498 lbound = gfc_conv_array_lbound (desc, dim);
4499 end = info->end[dim];
4500 if (check_upper)
4501 ubound = gfc_conv_array_ubound (desc, dim);
4502 else
4503 ubound = NULL;
4504
4505 /* non_zerosized is true when the selected range is not
4506 empty. */
4507 stride_pos = fold_build2_loc (input_location, GT_EXPR,
4508 logical_type_node, info->stride[dim],
4509 gfc_index_zero_node);
4510 tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
4511 info->start[dim], end);
4512 stride_pos = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4513 logical_type_node, stride_pos, tmp);
4514
4515 stride_neg = fold_build2_loc (input_location, LT_EXPR,
4516 logical_type_node,
4517 info->stride[dim], gfc_index_zero_node);
4518 tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
4519 info->start[dim], end);
4520 stride_neg = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4521 logical_type_node,
4522 stride_neg, tmp);
4523 non_zerosized = fold_build2_loc (input_location, TRUTH_OR_EXPR,
4524 logical_type_node,
4525 stride_pos, stride_neg);
4526
4527 /* Check the start of the range against the lower and upper
4528 bounds of the array, if the range is not empty.
4529 If upper bound is present, include both bounds in the
4530 error message. */
4531 if (check_upper)
4532 {
4533 tmp = fold_build2_loc (input_location, LT_EXPR,
4534 logical_type_node,
4535 info->start[dim], lbound);
4536 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4537 logical_type_node,
4538 non_zerosized, tmp);
4539 tmp2 = fold_build2_loc (input_location, GT_EXPR,
4540 logical_type_node,
4541 info->start[dim], ubound);
4542 tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4543 logical_type_node,
4544 non_zerosized, tmp2);
4545 msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4546 "outside of expected range (%%ld:%%ld)",
4547 dim + 1, expr_name);
4548 gfc_trans_runtime_check (true, false, tmp, &inner,
4549 expr_loc, msg,
4550 fold_convert (long_integer_type_node, info->start[dim]),
4551 fold_convert (long_integer_type_node, lbound),
4552 fold_convert (long_integer_type_node, ubound));
4553 gfc_trans_runtime_check (true, false, tmp2, &inner,
4554 expr_loc, msg,
4555 fold_convert (long_integer_type_node, info->start[dim]),
4556 fold_convert (long_integer_type_node, lbound),
4557 fold_convert (long_integer_type_node, ubound));
4558 free (msg);
4559 }
4560 else
4561 {
4562 tmp = fold_build2_loc (input_location, LT_EXPR,
4563 logical_type_node,
4564 info->start[dim], lbound);
4565 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4566 logical_type_node, non_zerosized, tmp);
4567 msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4568 "below lower bound of %%ld",
4569 dim + 1, expr_name);
4570 gfc_trans_runtime_check (true, false, tmp, &inner,
4571 expr_loc, msg,
4572 fold_convert (long_integer_type_node, info->start[dim]),
4573 fold_convert (long_integer_type_node, lbound));
4574 free (msg);
4575 }
4576
4577 /* Compute the last element of the range, which is not
4578 necessarily "end" (think 0:5:3, which doesn't contain 5)
4579 and check it against both lower and upper bounds. */
4580
4581 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4582 gfc_array_index_type, end,
4583 info->start[dim]);
4584 tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
4585 gfc_array_index_type, tmp,
4586 info->stride[dim]);
4587 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4588 gfc_array_index_type, end, tmp);
4589 tmp2 = fold_build2_loc (input_location, LT_EXPR,
4590 logical_type_node, tmp, lbound);
4591 tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4592 logical_type_node, non_zerosized, tmp2);
4593 if (check_upper)
4594 {
4595 tmp3 = fold_build2_loc (input_location, GT_EXPR,
4596 logical_type_node, tmp, ubound);
4597 tmp3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4598 logical_type_node, non_zerosized, tmp3);
4599 msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4600 "outside of expected range (%%ld:%%ld)",
4601 dim + 1, expr_name);
4602 gfc_trans_runtime_check (true, false, tmp2, &inner,
4603 expr_loc, msg,
4604 fold_convert (long_integer_type_node, tmp),
4605 fold_convert (long_integer_type_node, ubound),
4606 fold_convert (long_integer_type_node, lbound));
4607 gfc_trans_runtime_check (true, false, tmp3, &inner,
4608 expr_loc, msg,
4609 fold_convert (long_integer_type_node, tmp),
4610 fold_convert (long_integer_type_node, ubound),
4611 fold_convert (long_integer_type_node, lbound));
4612 free (msg);
4613 }
4614 else
4615 {
4616 msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4617 "below lower bound of %%ld",
4618 dim + 1, expr_name);
4619 gfc_trans_runtime_check (true, false, tmp2, &inner,
4620 expr_loc, msg,
4621 fold_convert (long_integer_type_node, tmp),
4622 fold_convert (long_integer_type_node, lbound));
4623 free (msg);
4624 }
4625
4626 /* Check the section sizes match. */
4627 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4628 gfc_array_index_type, end,
4629 info->start[dim]);
4630 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
4631 gfc_array_index_type, tmp,
4632 info->stride[dim]);
4633 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4634 gfc_array_index_type,
4635 gfc_index_one_node, tmp);
4636 tmp = fold_build2_loc (input_location, MAX_EXPR,
4637 gfc_array_index_type, tmp,
4638 build_int_cst (gfc_array_index_type, 0));
4639 /* We remember the size of the first section, and check all the
4640 others against this. */
4641 if (size[n])
4642 {
4643 tmp3 = fold_build2_loc (input_location, NE_EXPR,
4644 logical_type_node, tmp, size[n]);
4645 msg = xasprintf ("Array bound mismatch for dimension %d "
4646 "of array '%s' (%%ld/%%ld)",
4647 dim + 1, expr_name);
4648
4649 gfc_trans_runtime_check (true, false, tmp3, &inner,
4650 expr_loc, msg,
4651 fold_convert (long_integer_type_node, tmp),
4652 fold_convert (long_integer_type_node, size[n]));
4653
4654 free (msg);
4655 }
4656 else
4657 size[n] = gfc_evaluate_now (tmp, &inner);
4658 }
4659
4660 tmp = gfc_finish_block (&inner);
4661
4662 /* For optional arguments, only check bounds if the argument is
4663 present. */
4664 if (expr->symtree->n.sym->attr.optional
4665 || expr->symtree->n.sym->attr.not_always_present)
4666 tmp = build3_v (COND_EXPR,
4667 gfc_conv_expr_present (expr->symtree->n.sym),
4668 tmp, build_empty_stmt (input_location));
4669
4670 gfc_add_expr_to_block (&block, tmp);
4671
4672 }
4673
4674 tmp = gfc_finish_block (&block);
4675 gfc_add_expr_to_block (&outer_loop->pre, tmp);
4676 }
4677
4678 for (loop = loop->nested; loop; loop = loop->next)
4679 gfc_conv_ss_startstride (loop);
4680 }
4681
4682 /* Return true if both symbols could refer to the same data object. Does
4683 not take account of aliasing due to equivalence statements. */
4684
4685 static int
symbols_could_alias(gfc_symbol * lsym,gfc_symbol * rsym,bool lsym_pointer,bool lsym_target,bool rsym_pointer,bool rsym_target)4686 symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym, bool lsym_pointer,
4687 bool lsym_target, bool rsym_pointer, bool rsym_target)
4688 {
4689 /* Aliasing isn't possible if the symbols have different base types. */
4690 if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
4691 return 0;
4692
4693 /* Pointers can point to other pointers and target objects. */
4694
4695 if ((lsym_pointer && (rsym_pointer || rsym_target))
4696 || (rsym_pointer && (lsym_pointer || lsym_target)))
4697 return 1;
4698
4699 /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
4700 and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
4701 checked above. */
4702 if (lsym_target && rsym_target
4703 && ((lsym->attr.dummy && !lsym->attr.contiguous
4704 && (!lsym->attr.dimension || lsym->as->type == AS_ASSUMED_SHAPE))
4705 || (rsym->attr.dummy && !rsym->attr.contiguous
4706 && (!rsym->attr.dimension
4707 || rsym->as->type == AS_ASSUMED_SHAPE))))
4708 return 1;
4709
4710 return 0;
4711 }
4712
4713
4714 /* Return true if the two SS could be aliased, i.e. both point to the same data
4715 object. */
4716 /* TODO: resolve aliases based on frontend expressions. */
4717
4718 static int
gfc_could_be_alias(gfc_ss * lss,gfc_ss * rss)4719 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
4720 {
4721 gfc_ref *lref;
4722 gfc_ref *rref;
4723 gfc_expr *lexpr, *rexpr;
4724 gfc_symbol *lsym;
4725 gfc_symbol *rsym;
4726 bool lsym_pointer, lsym_target, rsym_pointer, rsym_target;
4727
4728 lexpr = lss->info->expr;
4729 rexpr = rss->info->expr;
4730
4731 lsym = lexpr->symtree->n.sym;
4732 rsym = rexpr->symtree->n.sym;
4733
4734 lsym_pointer = lsym->attr.pointer;
4735 lsym_target = lsym->attr.target;
4736 rsym_pointer = rsym->attr.pointer;
4737 rsym_target = rsym->attr.target;
4738
4739 if (symbols_could_alias (lsym, rsym, lsym_pointer, lsym_target,
4740 rsym_pointer, rsym_target))
4741 return 1;
4742
4743 if (rsym->ts.type != BT_DERIVED && rsym->ts.type != BT_CLASS
4744 && lsym->ts.type != BT_DERIVED && lsym->ts.type != BT_CLASS)
4745 return 0;
4746
4747 /* For derived types we must check all the component types. We can ignore
4748 array references as these will have the same base type as the previous
4749 component ref. */
4750 for (lref = lexpr->ref; lref != lss->info->data.array.ref; lref = lref->next)
4751 {
4752 if (lref->type != REF_COMPONENT)
4753 continue;
4754
4755 lsym_pointer = lsym_pointer || lref->u.c.sym->attr.pointer;
4756 lsym_target = lsym_target || lref->u.c.sym->attr.target;
4757
4758 if (symbols_could_alias (lref->u.c.sym, rsym, lsym_pointer, lsym_target,
4759 rsym_pointer, rsym_target))
4760 return 1;
4761
4762 if ((lsym_pointer && (rsym_pointer || rsym_target))
4763 || (rsym_pointer && (lsym_pointer || lsym_target)))
4764 {
4765 if (gfc_compare_types (&lref->u.c.component->ts,
4766 &rsym->ts))
4767 return 1;
4768 }
4769
4770 for (rref = rexpr->ref; rref != rss->info->data.array.ref;
4771 rref = rref->next)
4772 {
4773 if (rref->type != REF_COMPONENT)
4774 continue;
4775
4776 rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
4777 rsym_target = lsym_target || rref->u.c.sym->attr.target;
4778
4779 if (symbols_could_alias (lref->u.c.sym, rref->u.c.sym,
4780 lsym_pointer, lsym_target,
4781 rsym_pointer, rsym_target))
4782 return 1;
4783
4784 if ((lsym_pointer && (rsym_pointer || rsym_target))
4785 || (rsym_pointer && (lsym_pointer || lsym_target)))
4786 {
4787 if (gfc_compare_types (&lref->u.c.component->ts,
4788 &rref->u.c.sym->ts))
4789 return 1;
4790 if (gfc_compare_types (&lref->u.c.sym->ts,
4791 &rref->u.c.component->ts))
4792 return 1;
4793 if (gfc_compare_types (&lref->u.c.component->ts,
4794 &rref->u.c.component->ts))
4795 return 1;
4796 }
4797 }
4798 }
4799
4800 lsym_pointer = lsym->attr.pointer;
4801 lsym_target = lsym->attr.target;
4802 lsym_pointer = lsym->attr.pointer;
4803 lsym_target = lsym->attr.target;
4804
4805 for (rref = rexpr->ref; rref != rss->info->data.array.ref; rref = rref->next)
4806 {
4807 if (rref->type != REF_COMPONENT)
4808 break;
4809
4810 rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
4811 rsym_target = lsym_target || rref->u.c.sym->attr.target;
4812
4813 if (symbols_could_alias (rref->u.c.sym, lsym,
4814 lsym_pointer, lsym_target,
4815 rsym_pointer, rsym_target))
4816 return 1;
4817
4818 if ((lsym_pointer && (rsym_pointer || rsym_target))
4819 || (rsym_pointer && (lsym_pointer || lsym_target)))
4820 {
4821 if (gfc_compare_types (&lsym->ts, &rref->u.c.component->ts))
4822 return 1;
4823 }
4824 }
4825
4826 return 0;
4827 }
4828
4829
4830 /* Resolve array data dependencies. Creates a temporary if required. */
4831 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
4832 dependency.c. */
4833
4834 void
gfc_conv_resolve_dependencies(gfc_loopinfo * loop,gfc_ss * dest,gfc_ss * rss)4835 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
4836 gfc_ss * rss)
4837 {
4838 gfc_ss *ss;
4839 gfc_ref *lref;
4840 gfc_ref *rref;
4841 gfc_ss_info *ss_info;
4842 gfc_expr *dest_expr;
4843 gfc_expr *ss_expr;
4844 int nDepend = 0;
4845 int i, j;
4846
4847 loop->temp_ss = NULL;
4848 dest_expr = dest->info->expr;
4849
4850 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
4851 {
4852 ss_info = ss->info;
4853 ss_expr = ss_info->expr;
4854
4855 if (ss_info->array_outer_dependency)
4856 {
4857 nDepend = 1;
4858 break;
4859 }
4860
4861 if (ss_info->type != GFC_SS_SECTION)
4862 {
4863 if (flag_realloc_lhs
4864 && dest_expr != ss_expr
4865 && gfc_is_reallocatable_lhs (dest_expr)
4866 && ss_expr->rank)
4867 nDepend = gfc_check_dependency (dest_expr, ss_expr, true);
4868
4869 /* Check for cases like c(:)(1:2) = c(2)(2:3) */
4870 if (!nDepend && dest_expr->rank > 0
4871 && dest_expr->ts.type == BT_CHARACTER
4872 && ss_expr->expr_type == EXPR_VARIABLE)
4873
4874 nDepend = gfc_check_dependency (dest_expr, ss_expr, false);
4875
4876 if (ss_info->type == GFC_SS_REFERENCE
4877 && gfc_check_dependency (dest_expr, ss_expr, false))
4878 ss_info->data.scalar.needs_temporary = 1;
4879
4880 if (nDepend)
4881 break;
4882 else
4883 continue;
4884 }
4885
4886 if (dest_expr->symtree->n.sym != ss_expr->symtree->n.sym)
4887 {
4888 if (gfc_could_be_alias (dest, ss)
4889 || gfc_are_equivalenced_arrays (dest_expr, ss_expr))
4890 {
4891 nDepend = 1;
4892 break;
4893 }
4894 }
4895 else
4896 {
4897 lref = dest_expr->ref;
4898 rref = ss_expr->ref;
4899
4900 nDepend = gfc_dep_resolver (lref, rref, &loop->reverse[0]);
4901
4902 if (nDepend == 1)
4903 break;
4904
4905 for (i = 0; i < dest->dimen; i++)
4906 for (j = 0; j < ss->dimen; j++)
4907 if (i != j
4908 && dest->dim[i] == ss->dim[j])
4909 {
4910 /* If we don't access array elements in the same order,
4911 there is a dependency. */
4912 nDepend = 1;
4913 goto temporary;
4914 }
4915 #if 0
4916 /* TODO : loop shifting. */
4917 if (nDepend == 1)
4918 {
4919 /* Mark the dimensions for LOOP SHIFTING */
4920 for (n = 0; n < loop->dimen; n++)
4921 {
4922 int dim = dest->data.info.dim[n];
4923
4924 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
4925 depends[n] = 2;
4926 else if (! gfc_is_same_range (&lref->u.ar,
4927 &rref->u.ar, dim, 0))
4928 depends[n] = 1;
4929 }
4930
4931 /* Put all the dimensions with dependencies in the
4932 innermost loops. */
4933 dim = 0;
4934 for (n = 0; n < loop->dimen; n++)
4935 {
4936 gcc_assert (loop->order[n] == n);
4937 if (depends[n])
4938 loop->order[dim++] = n;
4939 }
4940 for (n = 0; n < loop->dimen; n++)
4941 {
4942 if (! depends[n])
4943 loop->order[dim++] = n;
4944 }
4945
4946 gcc_assert (dim == loop->dimen);
4947 break;
4948 }
4949 #endif
4950 }
4951 }
4952
4953 temporary:
4954
4955 if (nDepend == 1)
4956 {
4957 tree base_type = gfc_typenode_for_spec (&dest_expr->ts);
4958 if (GFC_ARRAY_TYPE_P (base_type)
4959 || GFC_DESCRIPTOR_TYPE_P (base_type))
4960 base_type = gfc_get_element_type (base_type);
4961 loop->temp_ss = gfc_get_temp_ss (base_type, dest->info->string_length,
4962 loop->dimen);
4963 gfc_add_ss_to_loop (loop, loop->temp_ss);
4964 }
4965 else
4966 loop->temp_ss = NULL;
4967 }
4968
4969
4970 /* Browse through each array's information from the scalarizer and set the loop
4971 bounds according to the "best" one (per dimension), i.e. the one which
4972 provides the most information (constant bounds, shape, etc.). */
4973
4974 static void
set_loop_bounds(gfc_loopinfo * loop)4975 set_loop_bounds (gfc_loopinfo *loop)
4976 {
4977 int n, dim, spec_dim;
4978 gfc_array_info *info;
4979 gfc_array_info *specinfo;
4980 gfc_ss *ss;
4981 tree tmp;
4982 gfc_ss **loopspec;
4983 bool dynamic[GFC_MAX_DIMENSIONS];
4984 mpz_t *cshape;
4985 mpz_t i;
4986 bool nonoptional_arr;
4987
4988 gfc_loopinfo * const outer_loop = outermost_loop (loop);
4989
4990 loopspec = loop->specloop;
4991
4992 mpz_init (i);
4993 for (n = 0; n < loop->dimen; n++)
4994 {
4995 loopspec[n] = NULL;
4996 dynamic[n] = false;
4997
4998 /* If there are both optional and nonoptional array arguments, scalarize
4999 over the nonoptional; otherwise, it does not matter as then all
5000 (optional) arrays have to be present per F2008, 125.2.12p3(6). */
5001
5002 nonoptional_arr = false;
5003
5004 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5005 if (ss->info->type != GFC_SS_SCALAR && ss->info->type != GFC_SS_TEMP
5006 && ss->info->type != GFC_SS_REFERENCE && !ss->info->can_be_null_ref)
5007 {
5008 nonoptional_arr = true;
5009 break;
5010 }
5011
5012 /* We use one SS term, and use that to determine the bounds of the
5013 loop for this dimension. We try to pick the simplest term. */
5014 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5015 {
5016 gfc_ss_type ss_type;
5017
5018 ss_type = ss->info->type;
5019 if (ss_type == GFC_SS_SCALAR
5020 || ss_type == GFC_SS_TEMP
5021 || ss_type == GFC_SS_REFERENCE
5022 || (ss->info->can_be_null_ref && nonoptional_arr))
5023 continue;
5024
5025 info = &ss->info->data.array;
5026 dim = ss->dim[n];
5027
5028 if (loopspec[n] != NULL)
5029 {
5030 specinfo = &loopspec[n]->info->data.array;
5031 spec_dim = loopspec[n]->dim[n];
5032 }
5033 else
5034 {
5035 /* Silence uninitialized warnings. */
5036 specinfo = NULL;
5037 spec_dim = 0;
5038 }
5039
5040 if (info->shape)
5041 {
5042 gcc_assert (info->shape[dim]);
5043 /* The frontend has worked out the size for us. */
5044 if (!loopspec[n]
5045 || !specinfo->shape
5046 || !integer_zerop (specinfo->start[spec_dim]))
5047 /* Prefer zero-based descriptors if possible. */
5048 loopspec[n] = ss;
5049 continue;
5050 }
5051
5052 if (ss_type == GFC_SS_CONSTRUCTOR)
5053 {
5054 gfc_constructor_base base;
5055 /* An unknown size constructor will always be rank one.
5056 Higher rank constructors will either have known shape,
5057 or still be wrapped in a call to reshape. */
5058 gcc_assert (loop->dimen == 1);
5059
5060 /* Always prefer to use the constructor bounds if the size
5061 can be determined at compile time. Prefer not to otherwise,
5062 since the general case involves realloc, and it's better to
5063 avoid that overhead if possible. */
5064 base = ss->info->expr->value.constructor;
5065 dynamic[n] = gfc_get_array_constructor_size (&i, base);
5066 if (!dynamic[n] || !loopspec[n])
5067 loopspec[n] = ss;
5068 continue;
5069 }
5070
5071 /* Avoid using an allocatable lhs in an assignment, since
5072 there might be a reallocation coming. */
5073 if (loopspec[n] && ss->is_alloc_lhs)
5074 continue;
5075
5076 if (!loopspec[n])
5077 loopspec[n] = ss;
5078 /* Criteria for choosing a loop specifier (most important first):
5079 doesn't need realloc
5080 stride of one
5081 known stride
5082 known lower bound
5083 known upper bound
5084 */
5085 else if (loopspec[n]->info->type == GFC_SS_CONSTRUCTOR && dynamic[n])
5086 loopspec[n] = ss;
5087 else if (integer_onep (info->stride[dim])
5088 && !integer_onep (specinfo->stride[spec_dim]))
5089 loopspec[n] = ss;
5090 else if (INTEGER_CST_P (info->stride[dim])
5091 && !INTEGER_CST_P (specinfo->stride[spec_dim]))
5092 loopspec[n] = ss;
5093 else if (INTEGER_CST_P (info->start[dim])
5094 && !INTEGER_CST_P (specinfo->start[spec_dim])
5095 && integer_onep (info->stride[dim])
5096 == integer_onep (specinfo->stride[spec_dim])
5097 && INTEGER_CST_P (info->stride[dim])
5098 == INTEGER_CST_P (specinfo->stride[spec_dim]))
5099 loopspec[n] = ss;
5100 /* We don't work out the upper bound.
5101 else if (INTEGER_CST_P (info->finish[n])
5102 && ! INTEGER_CST_P (specinfo->finish[n]))
5103 loopspec[n] = ss; */
5104 }
5105
5106 /* We should have found the scalarization loop specifier. If not,
5107 that's bad news. */
5108 gcc_assert (loopspec[n]);
5109
5110 info = &loopspec[n]->info->data.array;
5111 dim = loopspec[n]->dim[n];
5112
5113 /* Set the extents of this range. */
5114 cshape = info->shape;
5115 if (cshape && INTEGER_CST_P (info->start[dim])
5116 && INTEGER_CST_P (info->stride[dim]))
5117 {
5118 loop->from[n] = info->start[dim];
5119 mpz_set (i, cshape[get_array_ref_dim_for_loop_dim (loopspec[n], n)]);
5120 mpz_sub_ui (i, i, 1);
5121 /* To = from + (size - 1) * stride. */
5122 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
5123 if (!integer_onep (info->stride[dim]))
5124 tmp = fold_build2_loc (input_location, MULT_EXPR,
5125 gfc_array_index_type, tmp,
5126 info->stride[dim]);
5127 loop->to[n] = fold_build2_loc (input_location, PLUS_EXPR,
5128 gfc_array_index_type,
5129 loop->from[n], tmp);
5130 }
5131 else
5132 {
5133 loop->from[n] = info->start[dim];
5134 switch (loopspec[n]->info->type)
5135 {
5136 case GFC_SS_CONSTRUCTOR:
5137 /* The upper bound is calculated when we expand the
5138 constructor. */
5139 gcc_assert (loop->to[n] == NULL_TREE);
5140 break;
5141
5142 case GFC_SS_SECTION:
5143 /* Use the end expression if it exists and is not constant,
5144 so that it is only evaluated once. */
5145 loop->to[n] = info->end[dim];
5146 break;
5147
5148 case GFC_SS_FUNCTION:
5149 /* The loop bound will be set when we generate the call. */
5150 gcc_assert (loop->to[n] == NULL_TREE);
5151 break;
5152
5153 case GFC_SS_INTRINSIC:
5154 {
5155 gfc_expr *expr = loopspec[n]->info->expr;
5156
5157 /* The {l,u}bound of an assumed rank. */
5158 gcc_assert ((expr->value.function.isym->id == GFC_ISYM_LBOUND
5159 || expr->value.function.isym->id == GFC_ISYM_UBOUND)
5160 && expr->value.function.actual->next->expr == NULL
5161 && expr->value.function.actual->expr->rank == -1);
5162
5163 loop->to[n] = info->end[dim];
5164 break;
5165 }
5166
5167 case GFC_SS_COMPONENT:
5168 {
5169 if (info->end[dim] != NULL_TREE)
5170 {
5171 loop->to[n] = info->end[dim];
5172 break;
5173 }
5174 else
5175 gcc_unreachable ();
5176 }
5177
5178 default:
5179 gcc_unreachable ();
5180 }
5181 }
5182
5183 /* Transform everything so we have a simple incrementing variable. */
5184 if (integer_onep (info->stride[dim]))
5185 info->delta[dim] = gfc_index_zero_node;
5186 else
5187 {
5188 /* Set the delta for this section. */
5189 info->delta[dim] = gfc_evaluate_now (loop->from[n], &outer_loop->pre);
5190 /* Number of iterations is (end - start + step) / step.
5191 with start = 0, this simplifies to
5192 last = end / step;
5193 for (i = 0; i<=last; i++){...}; */
5194 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5195 gfc_array_index_type, loop->to[n],
5196 loop->from[n]);
5197 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
5198 gfc_array_index_type, tmp, info->stride[dim]);
5199 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
5200 tmp, build_int_cst (gfc_array_index_type, -1));
5201 loop->to[n] = gfc_evaluate_now (tmp, &outer_loop->pre);
5202 /* Make the loop variable start at 0. */
5203 loop->from[n] = gfc_index_zero_node;
5204 }
5205 }
5206 mpz_clear (i);
5207
5208 for (loop = loop->nested; loop; loop = loop->next)
5209 set_loop_bounds (loop);
5210 }
5211
5212
5213 /* Initialize the scalarization loop. Creates the loop variables. Determines
5214 the range of the loop variables. Creates a temporary if required.
5215 Also generates code for scalar expressions which have been
5216 moved outside the loop. */
5217
5218 void
gfc_conv_loop_setup(gfc_loopinfo * loop,locus * where)5219 gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
5220 {
5221 gfc_ss *tmp_ss;
5222 tree tmp;
5223
5224 set_loop_bounds (loop);
5225
5226 /* Add all the scalar code that can be taken out of the loops.
5227 This may include calculating the loop bounds, so do it before
5228 allocating the temporary. */
5229 gfc_add_loop_ss_code (loop, loop->ss, false, where);
5230
5231 tmp_ss = loop->temp_ss;
5232 /* If we want a temporary then create it. */
5233 if (tmp_ss != NULL)
5234 {
5235 gfc_ss_info *tmp_ss_info;
5236
5237 tmp_ss_info = tmp_ss->info;
5238 gcc_assert (tmp_ss_info->type == GFC_SS_TEMP);
5239 gcc_assert (loop->parent == NULL);
5240
5241 /* Make absolutely sure that this is a complete type. */
5242 if (tmp_ss_info->string_length)
5243 tmp_ss_info->data.temp.type
5244 = gfc_get_character_type_len_for_eltype
5245 (TREE_TYPE (tmp_ss_info->data.temp.type),
5246 tmp_ss_info->string_length);
5247
5248 tmp = tmp_ss_info->data.temp.type;
5249 memset (&tmp_ss_info->data.array, 0, sizeof (gfc_array_info));
5250 tmp_ss_info->type = GFC_SS_SECTION;
5251
5252 gcc_assert (tmp_ss->dimen != 0);
5253
5254 gfc_trans_create_temp_array (&loop->pre, &loop->post, tmp_ss, tmp,
5255 NULL_TREE, false, true, false, where);
5256 }
5257
5258 /* For array parameters we don't have loop variables, so don't calculate the
5259 translations. */
5260 if (!loop->array_parameter)
5261 gfc_set_delta (loop);
5262 }
5263
5264
5265 /* Calculates how to transform from loop variables to array indices for each
5266 array: once loop bounds are chosen, sets the difference (DELTA field) between
5267 loop bounds and array reference bounds, for each array info. */
5268
5269 void
gfc_set_delta(gfc_loopinfo * loop)5270 gfc_set_delta (gfc_loopinfo *loop)
5271 {
5272 gfc_ss *ss, **loopspec;
5273 gfc_array_info *info;
5274 tree tmp;
5275 int n, dim;
5276
5277 gfc_loopinfo * const outer_loop = outermost_loop (loop);
5278
5279 loopspec = loop->specloop;
5280
5281 /* Calculate the translation from loop variables to array indices. */
5282 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5283 {
5284 gfc_ss_type ss_type;
5285
5286 ss_type = ss->info->type;
5287 if (ss_type != GFC_SS_SECTION
5288 && ss_type != GFC_SS_COMPONENT
5289 && ss_type != GFC_SS_CONSTRUCTOR)
5290 continue;
5291
5292 info = &ss->info->data.array;
5293
5294 for (n = 0; n < ss->dimen; n++)
5295 {
5296 /* If we are specifying the range the delta is already set. */
5297 if (loopspec[n] != ss)
5298 {
5299 dim = ss->dim[n];
5300
5301 /* Calculate the offset relative to the loop variable.
5302 First multiply by the stride. */
5303 tmp = loop->from[n];
5304 if (!integer_onep (info->stride[dim]))
5305 tmp = fold_build2_loc (input_location, MULT_EXPR,
5306 gfc_array_index_type,
5307 tmp, info->stride[dim]);
5308
5309 /* Then subtract this from our starting value. */
5310 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5311 gfc_array_index_type,
5312 info->start[dim], tmp);
5313
5314 info->delta[dim] = gfc_evaluate_now (tmp, &outer_loop->pre);
5315 }
5316 }
5317 }
5318
5319 for (loop = loop->nested; loop; loop = loop->next)
5320 gfc_set_delta (loop);
5321 }
5322
5323
5324 /* Calculate the size of a given array dimension from the bounds. This
5325 is simply (ubound - lbound + 1) if this expression is positive
5326 or 0 if it is negative (pick either one if it is zero). Optionally
5327 (if or_expr is present) OR the (expression != 0) condition to it. */
5328
5329 tree
gfc_conv_array_extent_dim(tree lbound,tree ubound,tree * or_expr)5330 gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr)
5331 {
5332 tree res;
5333 tree cond;
5334
5335 /* Calculate (ubound - lbound + 1). */
5336 res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5337 ubound, lbound);
5338 res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res,
5339 gfc_index_one_node);
5340
5341 /* Check whether the size for this dimension is negative. */
5342 cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, res,
5343 gfc_index_zero_node);
5344 res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
5345 gfc_index_zero_node, res);
5346
5347 /* Build OR expression. */
5348 if (or_expr)
5349 *or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
5350 logical_type_node, *or_expr, cond);
5351
5352 return res;
5353 }
5354
5355
5356 /* For an array descriptor, get the total number of elements. This is just
5357 the product of the extents along from_dim to to_dim. */
5358
5359 static tree
gfc_conv_descriptor_size_1(tree desc,int from_dim,int to_dim)5360 gfc_conv_descriptor_size_1 (tree desc, int from_dim, int to_dim)
5361 {
5362 tree res;
5363 int dim;
5364
5365 res = gfc_index_one_node;
5366
5367 for (dim = from_dim; dim < to_dim; ++dim)
5368 {
5369 tree lbound;
5370 tree ubound;
5371 tree extent;
5372
5373 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
5374 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
5375
5376 extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
5377 res = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5378 res, extent);
5379 }
5380
5381 return res;
5382 }
5383
5384
5385 /* Full size of an array. */
5386
5387 tree
gfc_conv_descriptor_size(tree desc,int rank)5388 gfc_conv_descriptor_size (tree desc, int rank)
5389 {
5390 return gfc_conv_descriptor_size_1 (desc, 0, rank);
5391 }
5392
5393
5394 /* Size of a coarray for all dimensions but the last. */
5395
5396 tree
gfc_conv_descriptor_cosize(tree desc,int rank,int corank)5397 gfc_conv_descriptor_cosize (tree desc, int rank, int corank)
5398 {
5399 return gfc_conv_descriptor_size_1 (desc, rank, rank + corank - 1);
5400 }
5401
5402
5403 /* Fills in an array descriptor, and returns the size of the array.
5404 The size will be a simple_val, ie a variable or a constant. Also
5405 calculates the offset of the base. The pointer argument overflow,
5406 which should be of integer type, will increase in value if overflow
5407 occurs during the size calculation. Returns the size of the array.
5408 {
5409 stride = 1;
5410 offset = 0;
5411 for (n = 0; n < rank; n++)
5412 {
5413 a.lbound[n] = specified_lower_bound;
5414 offset = offset + a.lbond[n] * stride;
5415 size = 1 - lbound;
5416 a.ubound[n] = specified_upper_bound;
5417 a.stride[n] = stride;
5418 size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
5419 overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
5420 stride = stride * size;
5421 }
5422 for (n = rank; n < rank+corank; n++)
5423 (Set lcobound/ucobound as above.)
5424 element_size = sizeof (array element);
5425 if (!rank)
5426 return element_size
5427 stride = (size_t) stride;
5428 overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
5429 stride = stride * element_size;
5430 return (stride);
5431 } */
5432 /*GCC ARRAYS*/
5433
5434 static tree
gfc_array_init_size(tree descriptor,int rank,int corank,tree * poffset,gfc_expr ** lower,gfc_expr ** upper,stmtblock_t * pblock,stmtblock_t * descriptor_block,tree * overflow,tree expr3_elem_size,tree * nelems,gfc_expr * expr3,tree expr3_desc,bool e3_has_nodescriptor,gfc_expr * expr,tree * element_size)5435 gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
5436 gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
5437 stmtblock_t * descriptor_block, tree * overflow,
5438 tree expr3_elem_size, tree *nelems, gfc_expr *expr3,
5439 tree expr3_desc, bool e3_has_nodescriptor, gfc_expr *expr,
5440 tree *element_size)
5441 {
5442 tree type;
5443 tree tmp;
5444 tree size;
5445 tree offset;
5446 tree stride;
5447 tree or_expr;
5448 tree thencase;
5449 tree elsecase;
5450 tree cond;
5451 tree var;
5452 stmtblock_t thenblock;
5453 stmtblock_t elseblock;
5454 gfc_expr *ubound;
5455 gfc_se se;
5456 int n;
5457
5458 type = TREE_TYPE (descriptor);
5459
5460 stride = gfc_index_one_node;
5461 offset = gfc_index_zero_node;
5462
5463 /* Set the dtype before the alloc, because registration of coarrays needs
5464 it initialized. */
5465 if (expr->ts.type == BT_CHARACTER
5466 && expr->ts.deferred
5467 && VAR_P (expr->ts.u.cl->backend_decl))
5468 {
5469 type = gfc_typenode_for_spec (&expr->ts);
5470 tmp = gfc_conv_descriptor_dtype (descriptor);
5471 gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type));
5472 }
5473 else if (expr->ts.type == BT_CHARACTER
5474 && expr->ts.deferred
5475 && TREE_CODE (descriptor) == COMPONENT_REF)
5476 {
5477 /* Deferred character components have their string length tucked away
5478 in a hidden field of the derived type. Obtain that and use it to
5479 set the dtype. The charlen backend decl is zero because the field
5480 type is zero length. */
5481 gfc_ref *ref;
5482 tmp = NULL_TREE;
5483 for (ref = expr->ref; ref; ref = ref->next)
5484 if (ref->type == REF_COMPONENT
5485 && gfc_deferred_strlen (ref->u.c.component, &tmp))
5486 break;
5487 gcc_assert (tmp != NULL_TREE);
5488 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
5489 TREE_OPERAND (descriptor, 0), tmp, NULL_TREE);
5490 tmp = fold_convert (gfc_charlen_type_node, tmp);
5491 type = gfc_get_character_type_len (expr->ts.kind, tmp);
5492 tmp = gfc_conv_descriptor_dtype (descriptor);
5493 gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type));
5494 }
5495 else
5496 {
5497 tmp = gfc_conv_descriptor_dtype (descriptor);
5498 gfc_add_modify (pblock, tmp, gfc_get_dtype (type));
5499 }
5500
5501 or_expr = logical_false_node;
5502
5503 for (n = 0; n < rank; n++)
5504 {
5505 tree conv_lbound;
5506 tree conv_ubound;
5507
5508 /* We have 3 possibilities for determining the size of the array:
5509 lower == NULL => lbound = 1, ubound = upper[n]
5510 upper[n] = NULL => lbound = 1, ubound = lower[n]
5511 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
5512 ubound = upper[n];
5513
5514 /* Set lower bound. */
5515 gfc_init_se (&se, NULL);
5516 if (expr3_desc != NULL_TREE)
5517 {
5518 if (e3_has_nodescriptor)
5519 /* The lbound of nondescriptor arrays like array constructors,
5520 nonallocatable/nonpointer function results/variables,
5521 start at zero, but when allocating it, the standard expects
5522 the array to start at one. */
5523 se.expr = gfc_index_one_node;
5524 else
5525 se.expr = gfc_conv_descriptor_lbound_get (expr3_desc,
5526 gfc_rank_cst[n]);
5527 }
5528 else if (lower == NULL)
5529 se.expr = gfc_index_one_node;
5530 else
5531 {
5532 gcc_assert (lower[n]);
5533 if (ubound)
5534 {
5535 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
5536 gfc_add_block_to_block (pblock, &se.pre);
5537 }
5538 else
5539 {
5540 se.expr = gfc_index_one_node;
5541 ubound = lower[n];
5542 }
5543 }
5544 gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
5545 gfc_rank_cst[n], se.expr);
5546 conv_lbound = se.expr;
5547
5548 /* Work out the offset for this component. */
5549 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5550 se.expr, stride);
5551 offset = fold_build2_loc (input_location, MINUS_EXPR,
5552 gfc_array_index_type, offset, tmp);
5553
5554 /* Set upper bound. */
5555 gfc_init_se (&se, NULL);
5556 if (expr3_desc != NULL_TREE)
5557 {
5558 if (e3_has_nodescriptor)
5559 {
5560 /* The lbound of nondescriptor arrays like array constructors,
5561 nonallocatable/nonpointer function results/variables,
5562 start at zero, but when allocating it, the standard expects
5563 the array to start at one. Therefore fix the upper bound to be
5564 (desc.ubound - desc.lbound) + 1. */
5565 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5566 gfc_array_index_type,
5567 gfc_conv_descriptor_ubound_get (
5568 expr3_desc, gfc_rank_cst[n]),
5569 gfc_conv_descriptor_lbound_get (
5570 expr3_desc, gfc_rank_cst[n]));
5571 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5572 gfc_array_index_type, tmp,
5573 gfc_index_one_node);
5574 se.expr = gfc_evaluate_now (tmp, pblock);
5575 }
5576 else
5577 se.expr = gfc_conv_descriptor_ubound_get (expr3_desc,
5578 gfc_rank_cst[n]);
5579 }
5580 else
5581 {
5582 gcc_assert (ubound);
5583 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
5584 gfc_add_block_to_block (pblock, &se.pre);
5585 if (ubound->expr_type == EXPR_FUNCTION)
5586 se.expr = gfc_evaluate_now (se.expr, pblock);
5587 }
5588 gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
5589 gfc_rank_cst[n], se.expr);
5590 conv_ubound = se.expr;
5591
5592 /* Store the stride. */
5593 gfc_conv_descriptor_stride_set (descriptor_block, descriptor,
5594 gfc_rank_cst[n], stride);
5595
5596 /* Calculate size and check whether extent is negative. */
5597 size = gfc_conv_array_extent_dim (conv_lbound, conv_ubound, &or_expr);
5598 size = gfc_evaluate_now (size, pblock);
5599
5600 /* Check whether multiplying the stride by the number of
5601 elements in this dimension would overflow. We must also check
5602 whether the current dimension has zero size in order to avoid
5603 division by zero.
5604 */
5605 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
5606 gfc_array_index_type,
5607 fold_convert (gfc_array_index_type,
5608 TYPE_MAX_VALUE (gfc_array_index_type)),
5609 size);
5610 cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
5611 logical_type_node, tmp, stride),
5612 PRED_FORTRAN_OVERFLOW);
5613 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
5614 integer_one_node, integer_zero_node);
5615 cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
5616 logical_type_node, size,
5617 gfc_index_zero_node),
5618 PRED_FORTRAN_SIZE_ZERO);
5619 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
5620 integer_zero_node, tmp);
5621 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
5622 *overflow, tmp);
5623 *overflow = gfc_evaluate_now (tmp, pblock);
5624
5625 /* Multiply the stride by the number of elements in this dimension. */
5626 stride = fold_build2_loc (input_location, MULT_EXPR,
5627 gfc_array_index_type, stride, size);
5628 stride = gfc_evaluate_now (stride, pblock);
5629 }
5630
5631 for (n = rank; n < rank + corank; n++)
5632 {
5633 ubound = upper[n];
5634
5635 /* Set lower bound. */
5636 gfc_init_se (&se, NULL);
5637 if (lower == NULL || lower[n] == NULL)
5638 {
5639 gcc_assert (n == rank + corank - 1);
5640 se.expr = gfc_index_one_node;
5641 }
5642 else
5643 {
5644 if (ubound || n == rank + corank - 1)
5645 {
5646 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
5647 gfc_add_block_to_block (pblock, &se.pre);
5648 }
5649 else
5650 {
5651 se.expr = gfc_index_one_node;
5652 ubound = lower[n];
5653 }
5654 }
5655 gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
5656 gfc_rank_cst[n], se.expr);
5657
5658 if (n < rank + corank - 1)
5659 {
5660 gfc_init_se (&se, NULL);
5661 gcc_assert (ubound);
5662 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
5663 gfc_add_block_to_block (pblock, &se.pre);
5664 gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
5665 gfc_rank_cst[n], se.expr);
5666 }
5667 }
5668
5669 /* The stride is the number of elements in the array, so multiply by the
5670 size of an element to get the total size. Obviously, if there is a
5671 SOURCE expression (expr3) we must use its element size. */
5672 if (expr3_elem_size != NULL_TREE)
5673 tmp = expr3_elem_size;
5674 else if (expr3 != NULL)
5675 {
5676 if (expr3->ts.type == BT_CLASS)
5677 {
5678 gfc_se se_sz;
5679 gfc_expr *sz = gfc_copy_expr (expr3);
5680 gfc_add_vptr_component (sz);
5681 gfc_add_size_component (sz);
5682 gfc_init_se (&se_sz, NULL);
5683 gfc_conv_expr (&se_sz, sz);
5684 gfc_free_expr (sz);
5685 tmp = se_sz.expr;
5686 }
5687 else
5688 {
5689 tmp = gfc_typenode_for_spec (&expr3->ts);
5690 tmp = TYPE_SIZE_UNIT (tmp);
5691 }
5692 }
5693 else
5694 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
5695
5696 /* Convert to size_t. */
5697 *element_size = fold_convert (size_type_node, tmp);
5698
5699 if (rank == 0)
5700 return *element_size;
5701
5702 *nelems = gfc_evaluate_now (stride, pblock);
5703 stride = fold_convert (size_type_node, stride);
5704
5705 /* First check for overflow. Since an array of type character can
5706 have zero element_size, we must check for that before
5707 dividing. */
5708 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
5709 size_type_node,
5710 TYPE_MAX_VALUE (size_type_node), *element_size);
5711 cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
5712 logical_type_node, tmp, stride),
5713 PRED_FORTRAN_OVERFLOW);
5714 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
5715 integer_one_node, integer_zero_node);
5716 cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
5717 logical_type_node, *element_size,
5718 build_int_cst (size_type_node, 0)),
5719 PRED_FORTRAN_SIZE_ZERO);
5720 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
5721 integer_zero_node, tmp);
5722 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
5723 *overflow, tmp);
5724 *overflow = gfc_evaluate_now (tmp, pblock);
5725
5726 size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
5727 stride, *element_size);
5728
5729 if (poffset != NULL)
5730 {
5731 offset = gfc_evaluate_now (offset, pblock);
5732 *poffset = offset;
5733 }
5734
5735 if (integer_zerop (or_expr))
5736 return size;
5737 if (integer_onep (or_expr))
5738 return build_int_cst (size_type_node, 0);
5739
5740 var = gfc_create_var (TREE_TYPE (size), "size");
5741 gfc_start_block (&thenblock);
5742 gfc_add_modify (&thenblock, var, build_int_cst (size_type_node, 0));
5743 thencase = gfc_finish_block (&thenblock);
5744
5745 gfc_start_block (&elseblock);
5746 gfc_add_modify (&elseblock, var, size);
5747 elsecase = gfc_finish_block (&elseblock);
5748
5749 tmp = gfc_evaluate_now (or_expr, pblock);
5750 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
5751 gfc_add_expr_to_block (pblock, tmp);
5752
5753 return var;
5754 }
5755
5756
5757 /* Retrieve the last ref from the chain. This routine is specific to
5758 gfc_array_allocate ()'s needs. */
5759
5760 bool
retrieve_last_ref(gfc_ref ** ref_in,gfc_ref ** prev_ref_in)5761 retrieve_last_ref (gfc_ref **ref_in, gfc_ref **prev_ref_in)
5762 {
5763 gfc_ref *ref, *prev_ref;
5764
5765 ref = *ref_in;
5766 /* Prevent warnings for uninitialized variables. */
5767 prev_ref = *prev_ref_in;
5768 while (ref && ref->next != NULL)
5769 {
5770 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
5771 || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
5772 prev_ref = ref;
5773 ref = ref->next;
5774 }
5775
5776 if (ref == NULL || ref->type != REF_ARRAY)
5777 return false;
5778
5779 *ref_in = ref;
5780 *prev_ref_in = prev_ref;
5781 return true;
5782 }
5783
5784 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
5785 the work for an ALLOCATE statement. */
5786 /*GCC ARRAYS*/
5787
5788 bool
gfc_array_allocate(gfc_se * se,gfc_expr * expr,tree status,tree errmsg,tree errlen,tree label_finish,tree expr3_elem_size,tree * nelems,gfc_expr * expr3,tree e3_arr_desc,bool e3_has_nodescriptor)5789 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
5790 tree errlen, tree label_finish, tree expr3_elem_size,
5791 tree *nelems, gfc_expr *expr3, tree e3_arr_desc,
5792 bool e3_has_nodescriptor)
5793 {
5794 tree tmp;
5795 tree pointer;
5796 tree offset = NULL_TREE;
5797 tree token = NULL_TREE;
5798 tree size;
5799 tree msg;
5800 tree error = NULL_TREE;
5801 tree overflow; /* Boolean storing whether size calculation overflows. */
5802 tree var_overflow = NULL_TREE;
5803 tree cond;
5804 tree set_descriptor;
5805 tree not_prev_allocated = NULL_TREE;
5806 tree element_size = NULL_TREE;
5807 stmtblock_t set_descriptor_block;
5808 stmtblock_t elseblock;
5809 gfc_expr **lower;
5810 gfc_expr **upper;
5811 gfc_ref *ref, *prev_ref = NULL, *coref;
5812 bool allocatable, coarray, dimension, alloc_w_e3_arr_spec = false,
5813 non_ulimate_coarray_ptr_comp;
5814
5815 ref = expr->ref;
5816
5817 /* Find the last reference in the chain. */
5818 if (!retrieve_last_ref (&ref, &prev_ref))
5819 return false;
5820
5821 /* Take the allocatable and coarray properties solely from the expr-ref's
5822 attributes and not from source=-expression. */
5823 if (!prev_ref)
5824 {
5825 allocatable = expr->symtree->n.sym->attr.allocatable;
5826 dimension = expr->symtree->n.sym->attr.dimension;
5827 non_ulimate_coarray_ptr_comp = false;
5828 }
5829 else
5830 {
5831 allocatable = prev_ref->u.c.component->attr.allocatable;
5832 /* Pointer components in coarrayed derived types must be treated
5833 specially in that they are registered without a check if the are
5834 already associated. This does not hold for ultimate coarray
5835 pointers. */
5836 non_ulimate_coarray_ptr_comp = (prev_ref->u.c.component->attr.pointer
5837 && !prev_ref->u.c.component->attr.codimension);
5838 dimension = prev_ref->u.c.component->attr.dimension;
5839 }
5840
5841 /* For allocatable/pointer arrays in derived types, one of the refs has to be
5842 a coarray. In this case it does not matter whether we are on this_image
5843 or not. */
5844 coarray = false;
5845 for (coref = expr->ref; coref; coref = coref->next)
5846 if (coref->type == REF_ARRAY && coref->u.ar.codimen > 0)
5847 {
5848 coarray = true;
5849 break;
5850 }
5851
5852 if (!dimension)
5853 gcc_assert (coarray);
5854
5855 if (ref->u.ar.type == AR_FULL && expr3 != NULL)
5856 {
5857 gfc_ref *old_ref = ref;
5858 /* F08:C633: Array shape from expr3. */
5859 ref = expr3->ref;
5860
5861 /* Find the last reference in the chain. */
5862 if (!retrieve_last_ref (&ref, &prev_ref))
5863 {
5864 if (expr3->expr_type == EXPR_FUNCTION
5865 && gfc_expr_attr (expr3).dimension)
5866 ref = old_ref;
5867 else
5868 return false;
5869 }
5870 alloc_w_e3_arr_spec = true;
5871 }
5872
5873 /* Figure out the size of the array. */
5874 switch (ref->u.ar.type)
5875 {
5876 case AR_ELEMENT:
5877 if (!coarray)
5878 {
5879 lower = NULL;
5880 upper = ref->u.ar.start;
5881 break;
5882 }
5883 /* Fall through. */
5884
5885 case AR_SECTION:
5886 lower = ref->u.ar.start;
5887 upper = ref->u.ar.end;
5888 break;
5889
5890 case AR_FULL:
5891 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT
5892 || alloc_w_e3_arr_spec);
5893
5894 lower = ref->u.ar.as->lower;
5895 upper = ref->u.ar.as->upper;
5896 break;
5897
5898 default:
5899 gcc_unreachable ();
5900 break;
5901 }
5902
5903 overflow = integer_zero_node;
5904
5905 if (expr->ts.type == BT_CHARACTER
5906 && TREE_CODE (se->string_length) == COMPONENT_REF
5907 && expr->ts.u.cl->backend_decl != se->string_length
5908 && VAR_P (expr->ts.u.cl->backend_decl))
5909 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
5910 fold_convert (TREE_TYPE (expr->ts.u.cl->backend_decl),
5911 se->string_length));
5912
5913 gfc_init_block (&set_descriptor_block);
5914 /* Take the corank only from the actual ref and not from the coref. The
5915 later will mislead the generation of the array dimensions for allocatable/
5916 pointer components in derived types. */
5917 size = gfc_array_init_size (se->expr, alloc_w_e3_arr_spec ? expr->rank
5918 : ref->u.ar.as->rank,
5919 coarray ? ref->u.ar.as->corank : 0,
5920 &offset, lower, upper,
5921 &se->pre, &set_descriptor_block, &overflow,
5922 expr3_elem_size, nelems, expr3, e3_arr_desc,
5923 e3_has_nodescriptor, expr, &element_size);
5924
5925 if (dimension)
5926 {
5927 var_overflow = gfc_create_var (integer_type_node, "overflow");
5928 gfc_add_modify (&se->pre, var_overflow, overflow);
5929
5930 if (status == NULL_TREE)
5931 {
5932 /* Generate the block of code handling overflow. */
5933 msg = gfc_build_addr_expr (pchar_type_node,
5934 gfc_build_localized_cstring_const
5935 ("Integer overflow when calculating the amount of "
5936 "memory to allocate"));
5937 error = build_call_expr_loc (input_location,
5938 gfor_fndecl_runtime_error, 1, msg);
5939 }
5940 else
5941 {
5942 tree status_type = TREE_TYPE (status);
5943 stmtblock_t set_status_block;
5944
5945 gfc_start_block (&set_status_block);
5946 gfc_add_modify (&set_status_block, status,
5947 build_int_cst (status_type, LIBERROR_ALLOCATION));
5948 error = gfc_finish_block (&set_status_block);
5949 }
5950 }
5951
5952 /* Allocate memory to store the data. */
5953 if (POINTER_TYPE_P (TREE_TYPE (se->expr)))
5954 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
5955
5956 if (coarray && flag_coarray == GFC_FCOARRAY_LIB)
5957 {
5958 pointer = non_ulimate_coarray_ptr_comp ? se->expr
5959 : gfc_conv_descriptor_data_get (se->expr);
5960 token = gfc_conv_descriptor_token (se->expr);
5961 token = gfc_build_addr_expr (NULL_TREE, token);
5962 }
5963 else
5964 pointer = gfc_conv_descriptor_data_get (se->expr);
5965 STRIP_NOPS (pointer);
5966
5967 if (allocatable)
5968 {
5969 not_prev_allocated = gfc_create_var (logical_type_node,
5970 "not_prev_allocated");
5971 tmp = fold_build2_loc (input_location, EQ_EXPR,
5972 logical_type_node, pointer,
5973 build_int_cst (TREE_TYPE (pointer), 0));
5974
5975 gfc_add_modify (&se->pre, not_prev_allocated, tmp);
5976 }
5977
5978 gfc_start_block (&elseblock);
5979
5980 /* The allocatable variant takes the old pointer as first argument. */
5981 if (allocatable)
5982 gfc_allocate_allocatable (&elseblock, pointer, size, token,
5983 status, errmsg, errlen, label_finish, expr,
5984 coref != NULL ? coref->u.ar.as->corank : 0);
5985 else if (non_ulimate_coarray_ptr_comp && token)
5986 /* The token is set only for GFC_FCOARRAY_LIB mode. */
5987 gfc_allocate_using_caf_lib (&elseblock, pointer, size, token, status,
5988 errmsg, errlen,
5989 GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY);
5990 else
5991 gfc_allocate_using_malloc (&elseblock, pointer, size, status);
5992
5993 if (dimension)
5994 {
5995 cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
5996 logical_type_node, var_overflow, integer_zero_node),
5997 PRED_FORTRAN_OVERFLOW);
5998 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
5999 error, gfc_finish_block (&elseblock));
6000 }
6001 else
6002 tmp = gfc_finish_block (&elseblock);
6003
6004 gfc_add_expr_to_block (&se->pre, tmp);
6005
6006 /* Update the array descriptor with the offset and the span. */
6007 if (dimension)
6008 {
6009 gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
6010 tmp = fold_convert (gfc_array_index_type, element_size);
6011 gfc_conv_descriptor_span_set (&set_descriptor_block, se->expr, tmp);
6012 }
6013
6014 set_descriptor = gfc_finish_block (&set_descriptor_block);
6015 if (status != NULL_TREE)
6016 {
6017 cond = fold_build2_loc (input_location, EQ_EXPR,
6018 logical_type_node, status,
6019 build_int_cst (TREE_TYPE (status), 0));
6020
6021 if (not_prev_allocated != NULL_TREE)
6022 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
6023 logical_type_node, cond, not_prev_allocated);
6024
6025 gfc_add_expr_to_block (&se->pre,
6026 fold_build3_loc (input_location, COND_EXPR, void_type_node,
6027 cond,
6028 set_descriptor,
6029 build_empty_stmt (input_location)));
6030 }
6031 else
6032 gfc_add_expr_to_block (&se->pre, set_descriptor);
6033
6034 return true;
6035 }
6036
6037
6038 /* Create an array constructor from an initialization expression.
6039 We assume the frontend already did any expansions and conversions. */
6040
6041 tree
gfc_conv_array_initializer(tree type,gfc_expr * expr)6042 gfc_conv_array_initializer (tree type, gfc_expr * expr)
6043 {
6044 gfc_constructor *c;
6045 tree tmp;
6046 gfc_se se;
6047 tree index, range;
6048 vec<constructor_elt, va_gc> *v = NULL;
6049
6050 if (expr->expr_type == EXPR_VARIABLE
6051 && expr->symtree->n.sym->attr.flavor == FL_PARAMETER
6052 && expr->symtree->n.sym->value)
6053 expr = expr->symtree->n.sym->value;
6054
6055 switch (expr->expr_type)
6056 {
6057 case EXPR_CONSTANT:
6058 case EXPR_STRUCTURE:
6059 /* A single scalar or derived type value. Create an array with all
6060 elements equal to that value. */
6061 gfc_init_se (&se, NULL);
6062
6063 if (expr->expr_type == EXPR_CONSTANT)
6064 gfc_conv_constant (&se, expr);
6065 else
6066 gfc_conv_structure (&se, expr, 1);
6067
6068 CONSTRUCTOR_APPEND_ELT (v, build2 (RANGE_EXPR, gfc_array_index_type,
6069 TYPE_MIN_VALUE (TYPE_DOMAIN (type)),
6070 TYPE_MAX_VALUE (TYPE_DOMAIN (type))),
6071 se.expr);
6072 break;
6073
6074 case EXPR_ARRAY:
6075 /* Create a vector of all the elements. */
6076 for (c = gfc_constructor_first (expr->value.constructor);
6077 c; c = gfc_constructor_next (c))
6078 {
6079 if (c->iterator)
6080 {
6081 /* Problems occur when we get something like
6082 integer :: a(lots) = (/(i, i=1, lots)/) */
6083 gfc_fatal_error ("The number of elements in the array "
6084 "constructor at %L requires an increase of "
6085 "the allowed %d upper limit. See "
6086 "%<-fmax-array-constructor%> option",
6087 &expr->where, flag_max_array_constructor);
6088 return NULL_TREE;
6089 }
6090 if (mpz_cmp_si (c->offset, 0) != 0)
6091 index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
6092 else
6093 index = NULL_TREE;
6094
6095 if (mpz_cmp_si (c->repeat, 1) > 0)
6096 {
6097 tree tmp1, tmp2;
6098 mpz_t maxval;
6099
6100 mpz_init (maxval);
6101 mpz_add (maxval, c->offset, c->repeat);
6102 mpz_sub_ui (maxval, maxval, 1);
6103 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
6104 if (mpz_cmp_si (c->offset, 0) != 0)
6105 {
6106 mpz_add_ui (maxval, c->offset, 1);
6107 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
6108 }
6109 else
6110 tmp1 = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
6111
6112 range = fold_build2 (RANGE_EXPR, gfc_array_index_type, tmp1, tmp2);
6113 mpz_clear (maxval);
6114 }
6115 else
6116 range = NULL;
6117
6118 gfc_init_se (&se, NULL);
6119 switch (c->expr->expr_type)
6120 {
6121 case EXPR_CONSTANT:
6122 gfc_conv_constant (&se, c->expr);
6123
6124 /* See gfortran.dg/charlen_15.f90 for instance. */
6125 if (TREE_CODE (se.expr) == STRING_CST
6126 && TREE_CODE (type) == ARRAY_TYPE)
6127 {
6128 tree atype = type;
6129 while (TREE_CODE (TREE_TYPE (atype)) == ARRAY_TYPE)
6130 atype = TREE_TYPE (atype);
6131 if (TREE_CODE (TREE_TYPE (atype)) == INTEGER_TYPE
6132 && tree_to_uhwi (TYPE_SIZE_UNIT (TREE_TYPE (se.expr)))
6133 > tree_to_uhwi (TYPE_SIZE_UNIT (atype)))
6134 {
6135 unsigned HOST_WIDE_INT size
6136 = tree_to_uhwi (TYPE_SIZE_UNIT (atype));
6137 const char *p = TREE_STRING_POINTER (se.expr);
6138
6139 se.expr = build_string (size, p);
6140 TREE_TYPE (se.expr) = atype;
6141 }
6142 }
6143 break;
6144
6145 case EXPR_STRUCTURE:
6146 gfc_conv_structure (&se, c->expr, 1);
6147 break;
6148
6149 default:
6150 /* Catch those occasional beasts that do not simplify
6151 for one reason or another, assuming that if they are
6152 standard defying the frontend will catch them. */
6153 gfc_conv_expr (&se, c->expr);
6154 break;
6155 }
6156
6157 if (range == NULL_TREE)
6158 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
6159 else
6160 {
6161 if (index != NULL_TREE)
6162 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
6163 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
6164 }
6165 }
6166 break;
6167
6168 case EXPR_NULL:
6169 return gfc_build_null_descriptor (type);
6170
6171 default:
6172 gcc_unreachable ();
6173 }
6174
6175 /* Create a constructor from the list of elements. */
6176 tmp = build_constructor (type, v);
6177 TREE_CONSTANT (tmp) = 1;
6178 return tmp;
6179 }
6180
6181
6182 /* Generate code to evaluate non-constant coarray cobounds. */
6183
6184 void
gfc_trans_array_cobounds(tree type,stmtblock_t * pblock,const gfc_symbol * sym)6185 gfc_trans_array_cobounds (tree type, stmtblock_t * pblock,
6186 const gfc_symbol *sym)
6187 {
6188 int dim;
6189 tree ubound;
6190 tree lbound;
6191 gfc_se se;
6192 gfc_array_spec *as;
6193
6194 as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
6195
6196 for (dim = as->rank; dim < as->rank + as->corank; dim++)
6197 {
6198 /* Evaluate non-constant array bound expressions. */
6199 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
6200 if (as->lower[dim] && !INTEGER_CST_P (lbound))
6201 {
6202 gfc_init_se (&se, NULL);
6203 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
6204 gfc_add_block_to_block (pblock, &se.pre);
6205 gfc_add_modify (pblock, lbound, se.expr);
6206 }
6207 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
6208 if (as->upper[dim] && !INTEGER_CST_P (ubound))
6209 {
6210 gfc_init_se (&se, NULL);
6211 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
6212 gfc_add_block_to_block (pblock, &se.pre);
6213 gfc_add_modify (pblock, ubound, se.expr);
6214 }
6215 }
6216 }
6217
6218
6219 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
6220 returns the size (in elements) of the array. */
6221
6222 static tree
gfc_trans_array_bounds(tree type,gfc_symbol * sym,tree * poffset,stmtblock_t * pblock)6223 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
6224 stmtblock_t * pblock)
6225 {
6226 gfc_array_spec *as;
6227 tree size;
6228 tree stride;
6229 tree offset;
6230 tree ubound;
6231 tree lbound;
6232 tree tmp;
6233 gfc_se se;
6234
6235 int dim;
6236
6237 as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
6238
6239 size = gfc_index_one_node;
6240 offset = gfc_index_zero_node;
6241 for (dim = 0; dim < as->rank; dim++)
6242 {
6243 /* Evaluate non-constant array bound expressions. */
6244 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
6245 if (as->lower[dim] && !INTEGER_CST_P (lbound))
6246 {
6247 gfc_init_se (&se, NULL);
6248 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
6249 gfc_add_block_to_block (pblock, &se.pre);
6250 gfc_add_modify (pblock, lbound, se.expr);
6251 }
6252 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
6253 if (as->upper[dim] && !INTEGER_CST_P (ubound))
6254 {
6255 gfc_init_se (&se, NULL);
6256 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
6257 gfc_add_block_to_block (pblock, &se.pre);
6258 gfc_add_modify (pblock, ubound, se.expr);
6259 }
6260 /* The offset of this dimension. offset = offset - lbound * stride. */
6261 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6262 lbound, size);
6263 offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6264 offset, tmp);
6265
6266 /* The size of this dimension, and the stride of the next. */
6267 if (dim + 1 < as->rank)
6268 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
6269 else
6270 stride = GFC_TYPE_ARRAY_SIZE (type);
6271
6272 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
6273 {
6274 /* Calculate stride = size * (ubound + 1 - lbound). */
6275 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6276 gfc_array_index_type,
6277 gfc_index_one_node, lbound);
6278 tmp = fold_build2_loc (input_location, PLUS_EXPR,
6279 gfc_array_index_type, ubound, tmp);
6280 tmp = fold_build2_loc (input_location, MULT_EXPR,
6281 gfc_array_index_type, size, tmp);
6282 if (stride)
6283 gfc_add_modify (pblock, stride, tmp);
6284 else
6285 stride = gfc_evaluate_now (tmp, pblock);
6286
6287 /* Make sure that negative size arrays are translated
6288 to being zero size. */
6289 tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
6290 stride, gfc_index_zero_node);
6291 tmp = fold_build3_loc (input_location, COND_EXPR,
6292 gfc_array_index_type, tmp,
6293 stride, gfc_index_zero_node);
6294 gfc_add_modify (pblock, stride, tmp);
6295 }
6296
6297 size = stride;
6298 }
6299
6300 gfc_trans_array_cobounds (type, pblock, sym);
6301 gfc_trans_vla_type_sizes (sym, pblock);
6302
6303 *poffset = offset;
6304 return size;
6305 }
6306
6307
6308 /* Generate code to initialize/allocate an array variable. */
6309
6310 void
gfc_trans_auto_array_allocation(tree decl,gfc_symbol * sym,gfc_wrapped_block * block)6311 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
6312 gfc_wrapped_block * block)
6313 {
6314 stmtblock_t init;
6315 tree type;
6316 tree tmp = NULL_TREE;
6317 tree size;
6318 tree offset;
6319 tree space;
6320 tree inittree;
6321 bool onstack;
6322
6323 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
6324
6325 /* Do nothing for USEd variables. */
6326 if (sym->attr.use_assoc)
6327 return;
6328
6329 type = TREE_TYPE (decl);
6330 gcc_assert (GFC_ARRAY_TYPE_P (type));
6331 onstack = TREE_CODE (type) != POINTER_TYPE;
6332
6333 gfc_init_block (&init);
6334
6335 /* Evaluate character string length. */
6336 if (sym->ts.type == BT_CHARACTER
6337 && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
6338 {
6339 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
6340
6341 gfc_trans_vla_type_sizes (sym, &init);
6342
6343 /* Emit a DECL_EXPR for this variable, which will cause the
6344 gimplifier to allocate storage, and all that good stuff. */
6345 tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
6346 gfc_add_expr_to_block (&init, tmp);
6347 }
6348
6349 if (onstack)
6350 {
6351 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
6352 return;
6353 }
6354
6355 type = TREE_TYPE (type);
6356
6357 gcc_assert (!sym->attr.use_assoc);
6358 gcc_assert (!TREE_STATIC (decl));
6359 gcc_assert (!sym->module);
6360
6361 if (sym->ts.type == BT_CHARACTER
6362 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
6363 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
6364
6365 size = gfc_trans_array_bounds (type, sym, &offset, &init);
6366
6367 /* Don't actually allocate space for Cray Pointees. */
6368 if (sym->attr.cray_pointee)
6369 {
6370 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
6371 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
6372
6373 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
6374 return;
6375 }
6376
6377 if (flag_stack_arrays)
6378 {
6379 gcc_assert (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE);
6380 space = build_decl (sym->declared_at.lb->location,
6381 VAR_DECL, create_tmp_var_name ("A"),
6382 TREE_TYPE (TREE_TYPE (decl)));
6383 gfc_trans_vla_type_sizes (sym, &init);
6384 }
6385 else
6386 {
6387 /* The size is the number of elements in the array, so multiply by the
6388 size of an element to get the total size. */
6389 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
6390 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6391 size, fold_convert (gfc_array_index_type, tmp));
6392
6393 /* Allocate memory to hold the data. */
6394 tmp = gfc_call_malloc (&init, TREE_TYPE (decl), size);
6395 gfc_add_modify (&init, decl, tmp);
6396
6397 /* Free the temporary. */
6398 tmp = gfc_call_free (decl);
6399 space = NULL_TREE;
6400 }
6401
6402 /* Set offset of the array. */
6403 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
6404 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
6405
6406 /* Automatic arrays should not have initializers. */
6407 gcc_assert (!sym->value);
6408
6409 inittree = gfc_finish_block (&init);
6410
6411 if (space)
6412 {
6413 tree addr;
6414 pushdecl (space);
6415
6416 /* Don't create new scope, emit the DECL_EXPR in exactly the scope
6417 where also space is located. */
6418 gfc_init_block (&init);
6419 tmp = fold_build1_loc (input_location, DECL_EXPR,
6420 TREE_TYPE (space), space);
6421 gfc_add_expr_to_block (&init, tmp);
6422 addr = fold_build1_loc (sym->declared_at.lb->location,
6423 ADDR_EXPR, TREE_TYPE (decl), space);
6424 gfc_add_modify (&init, decl, addr);
6425 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
6426 tmp = NULL_TREE;
6427 }
6428 gfc_add_init_cleanup (block, inittree, tmp);
6429 }
6430
6431
6432 /* Generate entry and exit code for g77 calling convention arrays. */
6433
6434 void
gfc_trans_g77_array(gfc_symbol * sym,gfc_wrapped_block * block)6435 gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block)
6436 {
6437 tree parm;
6438 tree type;
6439 locus loc;
6440 tree offset;
6441 tree tmp;
6442 tree stmt;
6443 stmtblock_t init;
6444
6445 gfc_save_backend_locus (&loc);
6446 gfc_set_backend_locus (&sym->declared_at);
6447
6448 /* Descriptor type. */
6449 parm = sym->backend_decl;
6450 type = TREE_TYPE (parm);
6451 gcc_assert (GFC_ARRAY_TYPE_P (type));
6452
6453 gfc_start_block (&init);
6454
6455 if (sym->ts.type == BT_CHARACTER
6456 && VAR_P (sym->ts.u.cl->backend_decl))
6457 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
6458
6459 /* Evaluate the bounds of the array. */
6460 gfc_trans_array_bounds (type, sym, &offset, &init);
6461
6462 /* Set the offset. */
6463 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
6464 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
6465
6466 /* Set the pointer itself if we aren't using the parameter directly. */
6467 if (TREE_CODE (parm) != PARM_DECL)
6468 {
6469 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
6470 gfc_add_modify (&init, parm, tmp);
6471 }
6472 stmt = gfc_finish_block (&init);
6473
6474 gfc_restore_backend_locus (&loc);
6475
6476 /* Add the initialization code to the start of the function. */
6477
6478 if (sym->attr.optional || sym->attr.not_always_present)
6479 {
6480 tmp = gfc_conv_expr_present (sym);
6481 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
6482 }
6483
6484 gfc_add_init_cleanup (block, stmt, NULL_TREE);
6485 }
6486
6487
6488 /* Modify the descriptor of an array parameter so that it has the
6489 correct lower bound. Also move the upper bound accordingly.
6490 If the array is not packed, it will be copied into a temporary.
6491 For each dimension we set the new lower and upper bounds. Then we copy the
6492 stride and calculate the offset for this dimension. We also work out
6493 what the stride of a packed array would be, and see it the two match.
6494 If the array need repacking, we set the stride to the values we just
6495 calculated, recalculate the offset and copy the array data.
6496 Code is also added to copy the data back at the end of the function.
6497 */
6498
6499 void
gfc_trans_dummy_array_bias(gfc_symbol * sym,tree tmpdesc,gfc_wrapped_block * block)6500 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
6501 gfc_wrapped_block * block)
6502 {
6503 tree size;
6504 tree type;
6505 tree offset;
6506 locus loc;
6507 stmtblock_t init;
6508 tree stmtInit, stmtCleanup;
6509 tree lbound;
6510 tree ubound;
6511 tree dubound;
6512 tree dlbound;
6513 tree dumdesc;
6514 tree tmp;
6515 tree stride, stride2;
6516 tree stmt_packed;
6517 tree stmt_unpacked;
6518 tree partial;
6519 gfc_se se;
6520 int n;
6521 int checkparm;
6522 int no_repack;
6523 bool optional_arg;
6524 gfc_array_spec *as;
6525 bool is_classarray = IS_CLASS_ARRAY (sym);
6526
6527 /* Do nothing for pointer and allocatable arrays. */
6528 if ((sym->ts.type != BT_CLASS && sym->attr.pointer)
6529 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer)
6530 || sym->attr.allocatable
6531 || (is_classarray && CLASS_DATA (sym)->attr.allocatable))
6532 return;
6533
6534 if (!is_classarray && sym->attr.dummy && gfc_is_nodesc_array (sym))
6535 {
6536 gfc_trans_g77_array (sym, block);
6537 return;
6538 }
6539
6540 loc.nextc = NULL;
6541 gfc_save_backend_locus (&loc);
6542 /* loc.nextc is not set by save_backend_locus but the location routines
6543 depend on it. */
6544 if (loc.nextc == NULL)
6545 loc.nextc = loc.lb->line;
6546 gfc_set_backend_locus (&sym->declared_at);
6547
6548 /* Descriptor type. */
6549 type = TREE_TYPE (tmpdesc);
6550 gcc_assert (GFC_ARRAY_TYPE_P (type));
6551 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
6552 if (is_classarray)
6553 /* For a class array the dummy array descriptor is in the _class
6554 component. */
6555 dumdesc = gfc_class_data_get (dumdesc);
6556 else
6557 dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc);
6558 as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
6559 gfc_start_block (&init);
6560
6561 if (sym->ts.type == BT_CHARACTER
6562 && VAR_P (sym->ts.u.cl->backend_decl))
6563 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
6564
6565 checkparm = (as->type == AS_EXPLICIT
6566 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
6567
6568 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
6569 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
6570
6571 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
6572 {
6573 /* For non-constant shape arrays we only check if the first dimension
6574 is contiguous. Repacking higher dimensions wouldn't gain us
6575 anything as we still don't know the array stride. */
6576 partial = gfc_create_var (logical_type_node, "partial");
6577 TREE_USED (partial) = 1;
6578 tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
6579 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, tmp,
6580 gfc_index_one_node);
6581 gfc_add_modify (&init, partial, tmp);
6582 }
6583 else
6584 partial = NULL_TREE;
6585
6586 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
6587 here, however I think it does the right thing. */
6588 if (no_repack)
6589 {
6590 /* Set the first stride. */
6591 stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
6592 stride = gfc_evaluate_now (stride, &init);
6593
6594 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
6595 stride, gfc_index_zero_node);
6596 tmp = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
6597 tmp, gfc_index_one_node, stride);
6598 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
6599 gfc_add_modify (&init, stride, tmp);
6600
6601 /* Allow the user to disable array repacking. */
6602 stmt_unpacked = NULL_TREE;
6603 }
6604 else
6605 {
6606 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
6607 /* A library call to repack the array if necessary. */
6608 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
6609 stmt_unpacked = build_call_expr_loc (input_location,
6610 gfor_fndecl_in_pack, 1, tmp);
6611
6612 stride = gfc_index_one_node;
6613
6614 if (warn_array_temporaries)
6615 gfc_warning (OPT_Warray_temporaries,
6616 "Creating array temporary at %L", &loc);
6617 }
6618
6619 /* This is for the case where the array data is used directly without
6620 calling the repack function. */
6621 if (no_repack || partial != NULL_TREE)
6622 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
6623 else
6624 stmt_packed = NULL_TREE;
6625
6626 /* Assign the data pointer. */
6627 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
6628 {
6629 /* Don't repack unknown shape arrays when the first stride is 1. */
6630 tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (stmt_packed),
6631 partial, stmt_packed, stmt_unpacked);
6632 }
6633 else
6634 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
6635 gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp));
6636
6637 offset = gfc_index_zero_node;
6638 size = gfc_index_one_node;
6639
6640 /* Evaluate the bounds of the array. */
6641 for (n = 0; n < as->rank; n++)
6642 {
6643 if (checkparm || !as->upper[n])
6644 {
6645 /* Get the bounds of the actual parameter. */
6646 dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]);
6647 dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]);
6648 }
6649 else
6650 {
6651 dubound = NULL_TREE;
6652 dlbound = NULL_TREE;
6653 }
6654
6655 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
6656 if (!INTEGER_CST_P (lbound))
6657 {
6658 gfc_init_se (&se, NULL);
6659 gfc_conv_expr_type (&se, as->lower[n],
6660 gfc_array_index_type);
6661 gfc_add_block_to_block (&init, &se.pre);
6662 gfc_add_modify (&init, lbound, se.expr);
6663 }
6664
6665 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
6666 /* Set the desired upper bound. */
6667 if (as->upper[n])
6668 {
6669 /* We know what we want the upper bound to be. */
6670 if (!INTEGER_CST_P (ubound))
6671 {
6672 gfc_init_se (&se, NULL);
6673 gfc_conv_expr_type (&se, as->upper[n],
6674 gfc_array_index_type);
6675 gfc_add_block_to_block (&init, &se.pre);
6676 gfc_add_modify (&init, ubound, se.expr);
6677 }
6678
6679 /* Check the sizes match. */
6680 if (checkparm)
6681 {
6682 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
6683 char * msg;
6684 tree temp;
6685
6686 temp = fold_build2_loc (input_location, MINUS_EXPR,
6687 gfc_array_index_type, ubound, lbound);
6688 temp = fold_build2_loc (input_location, PLUS_EXPR,
6689 gfc_array_index_type,
6690 gfc_index_one_node, temp);
6691 stride2 = fold_build2_loc (input_location, MINUS_EXPR,
6692 gfc_array_index_type, dubound,
6693 dlbound);
6694 stride2 = fold_build2_loc (input_location, PLUS_EXPR,
6695 gfc_array_index_type,
6696 gfc_index_one_node, stride2);
6697 tmp = fold_build2_loc (input_location, NE_EXPR,
6698 gfc_array_index_type, temp, stride2);
6699 msg = xasprintf ("Dimension %d of array '%s' has extent "
6700 "%%ld instead of %%ld", n+1, sym->name);
6701
6702 gfc_trans_runtime_check (true, false, tmp, &init, &loc, msg,
6703 fold_convert (long_integer_type_node, temp),
6704 fold_convert (long_integer_type_node, stride2));
6705
6706 free (msg);
6707 }
6708 }
6709 else
6710 {
6711 /* For assumed shape arrays move the upper bound by the same amount
6712 as the lower bound. */
6713 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6714 gfc_array_index_type, dubound, dlbound);
6715 tmp = fold_build2_loc (input_location, PLUS_EXPR,
6716 gfc_array_index_type, tmp, lbound);
6717 gfc_add_modify (&init, ubound, tmp);
6718 }
6719 /* The offset of this dimension. offset = offset - lbound * stride. */
6720 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6721 lbound, stride);
6722 offset = fold_build2_loc (input_location, MINUS_EXPR,
6723 gfc_array_index_type, offset, tmp);
6724
6725 /* The size of this dimension, and the stride of the next. */
6726 if (n + 1 < as->rank)
6727 {
6728 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
6729
6730 if (no_repack || partial != NULL_TREE)
6731 stmt_unpacked =
6732 gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]);
6733
6734 /* Figure out the stride if not a known constant. */
6735 if (!INTEGER_CST_P (stride))
6736 {
6737 if (no_repack)
6738 stmt_packed = NULL_TREE;
6739 else
6740 {
6741 /* Calculate stride = size * (ubound + 1 - lbound). */
6742 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6743 gfc_array_index_type,
6744 gfc_index_one_node, lbound);
6745 tmp = fold_build2_loc (input_location, PLUS_EXPR,
6746 gfc_array_index_type, ubound, tmp);
6747 size = fold_build2_loc (input_location, MULT_EXPR,
6748 gfc_array_index_type, size, tmp);
6749 stmt_packed = size;
6750 }
6751
6752 /* Assign the stride. */
6753 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
6754 tmp = fold_build3_loc (input_location, COND_EXPR,
6755 gfc_array_index_type, partial,
6756 stmt_unpacked, stmt_packed);
6757 else
6758 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
6759 gfc_add_modify (&init, stride, tmp);
6760 }
6761 }
6762 else
6763 {
6764 stride = GFC_TYPE_ARRAY_SIZE (type);
6765
6766 if (stride && !INTEGER_CST_P (stride))
6767 {
6768 /* Calculate size = stride * (ubound + 1 - lbound). */
6769 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6770 gfc_array_index_type,
6771 gfc_index_one_node, lbound);
6772 tmp = fold_build2_loc (input_location, PLUS_EXPR,
6773 gfc_array_index_type,
6774 ubound, tmp);
6775 tmp = fold_build2_loc (input_location, MULT_EXPR,
6776 gfc_array_index_type,
6777 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
6778 gfc_add_modify (&init, stride, tmp);
6779 }
6780 }
6781 }
6782
6783 gfc_trans_array_cobounds (type, &init, sym);
6784
6785 /* Set the offset. */
6786 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
6787 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
6788
6789 gfc_trans_vla_type_sizes (sym, &init);
6790
6791 stmtInit = gfc_finish_block (&init);
6792
6793 /* Only do the entry/initialization code if the arg is present. */
6794 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
6795 optional_arg = (sym->attr.optional
6796 || (sym->ns->proc_name->attr.entry_master
6797 && sym->attr.dummy));
6798 if (optional_arg)
6799 {
6800 tmp = gfc_conv_expr_present (sym);
6801 stmtInit = build3_v (COND_EXPR, tmp, stmtInit,
6802 build_empty_stmt (input_location));
6803 }
6804
6805 /* Cleanup code. */
6806 if (no_repack)
6807 stmtCleanup = NULL_TREE;
6808 else
6809 {
6810 stmtblock_t cleanup;
6811 gfc_start_block (&cleanup);
6812
6813 if (sym->attr.intent != INTENT_IN)
6814 {
6815 /* Copy the data back. */
6816 tmp = build_call_expr_loc (input_location,
6817 gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
6818 gfc_add_expr_to_block (&cleanup, tmp);
6819 }
6820
6821 /* Free the temporary. */
6822 tmp = gfc_call_free (tmpdesc);
6823 gfc_add_expr_to_block (&cleanup, tmp);
6824
6825 stmtCleanup = gfc_finish_block (&cleanup);
6826
6827 /* Only do the cleanup if the array was repacked. */
6828 if (is_classarray)
6829 /* For a class array the dummy array descriptor is in the _class
6830 component. */
6831 tmp = gfc_class_data_get (dumdesc);
6832 else
6833 tmp = build_fold_indirect_ref_loc (input_location, dumdesc);
6834 tmp = gfc_conv_descriptor_data_get (tmp);
6835 tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
6836 tmp, tmpdesc);
6837 stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
6838 build_empty_stmt (input_location));
6839
6840 if (optional_arg)
6841 {
6842 tmp = gfc_conv_expr_present (sym);
6843 stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
6844 build_empty_stmt (input_location));
6845 }
6846 }
6847
6848 /* We don't need to free any memory allocated by internal_pack as it will
6849 be freed at the end of the function by pop_context. */
6850 gfc_add_init_cleanup (block, stmtInit, stmtCleanup);
6851
6852 gfc_restore_backend_locus (&loc);
6853 }
6854
6855
6856 /* Calculate the overall offset, including subreferences. */
6857 void
gfc_get_dataptr_offset(stmtblock_t * block,tree parm,tree desc,tree offset,bool subref,gfc_expr * expr)6858 gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
6859 bool subref, gfc_expr *expr)
6860 {
6861 tree tmp;
6862 tree field;
6863 tree stride;
6864 tree index;
6865 gfc_ref *ref;
6866 gfc_se start;
6867 int n;
6868
6869 /* If offset is NULL and this is not a subreferenced array, there is
6870 nothing to do. */
6871 if (offset == NULL_TREE)
6872 {
6873 if (subref)
6874 offset = gfc_index_zero_node;
6875 else
6876 return;
6877 }
6878
6879 tmp = build_array_ref (desc, offset, NULL, NULL);
6880
6881 /* Offset the data pointer for pointer assignments from arrays with
6882 subreferences; e.g. my_integer => my_type(:)%integer_component. */
6883 if (subref)
6884 {
6885 /* Go past the array reference. */
6886 for (ref = expr->ref; ref; ref = ref->next)
6887 if (ref->type == REF_ARRAY &&
6888 ref->u.ar.type != AR_ELEMENT)
6889 {
6890 ref = ref->next;
6891 break;
6892 }
6893
6894 /* Calculate the offset for each subsequent subreference. */
6895 for (; ref; ref = ref->next)
6896 {
6897 switch (ref->type)
6898 {
6899 case REF_COMPONENT:
6900 field = ref->u.c.component->backend_decl;
6901 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
6902 tmp = fold_build3_loc (input_location, COMPONENT_REF,
6903 TREE_TYPE (field),
6904 tmp, field, NULL_TREE);
6905 break;
6906
6907 case REF_SUBSTRING:
6908 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
6909 gfc_init_se (&start, NULL);
6910 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
6911 gfc_add_block_to_block (block, &start.pre);
6912 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
6913 break;
6914
6915 case REF_ARRAY:
6916 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
6917 && ref->u.ar.type == AR_ELEMENT);
6918
6919 /* TODO - Add bounds checking. */
6920 stride = gfc_index_one_node;
6921 index = gfc_index_zero_node;
6922 for (n = 0; n < ref->u.ar.dimen; n++)
6923 {
6924 tree itmp;
6925 tree jtmp;
6926
6927 /* Update the index. */
6928 gfc_init_se (&start, NULL);
6929 gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
6930 itmp = gfc_evaluate_now (start.expr, block);
6931 gfc_init_se (&start, NULL);
6932 gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
6933 jtmp = gfc_evaluate_now (start.expr, block);
6934 itmp = fold_build2_loc (input_location, MINUS_EXPR,
6935 gfc_array_index_type, itmp, jtmp);
6936 itmp = fold_build2_loc (input_location, MULT_EXPR,
6937 gfc_array_index_type, itmp, stride);
6938 index = fold_build2_loc (input_location, PLUS_EXPR,
6939 gfc_array_index_type, itmp, index);
6940 index = gfc_evaluate_now (index, block);
6941
6942 /* Update the stride. */
6943 gfc_init_se (&start, NULL);
6944 gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
6945 itmp = fold_build2_loc (input_location, MINUS_EXPR,
6946 gfc_array_index_type, start.expr,
6947 jtmp);
6948 itmp = fold_build2_loc (input_location, PLUS_EXPR,
6949 gfc_array_index_type,
6950 gfc_index_one_node, itmp);
6951 stride = fold_build2_loc (input_location, MULT_EXPR,
6952 gfc_array_index_type, stride, itmp);
6953 stride = gfc_evaluate_now (stride, block);
6954 }
6955
6956 /* Apply the index to obtain the array element. */
6957 tmp = gfc_build_array_ref (tmp, index, NULL);
6958 break;
6959
6960 default:
6961 gcc_unreachable ();
6962 break;
6963 }
6964 }
6965 }
6966
6967 /* Set the target data pointer. */
6968 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
6969 gfc_conv_descriptor_data_set (block, parm, offset);
6970 }
6971
6972
6973 /* gfc_conv_expr_descriptor needs the string length an expression
6974 so that the size of the temporary can be obtained. This is done
6975 by adding up the string lengths of all the elements in the
6976 expression. Function with non-constant expressions have their
6977 string lengths mapped onto the actual arguments using the
6978 interface mapping machinery in trans-expr.c. */
6979 static void
get_array_charlen(gfc_expr * expr,gfc_se * se)6980 get_array_charlen (gfc_expr *expr, gfc_se *se)
6981 {
6982 gfc_interface_mapping mapping;
6983 gfc_formal_arglist *formal;
6984 gfc_actual_arglist *arg;
6985 gfc_se tse;
6986 gfc_expr *e;
6987
6988 if (expr->ts.u.cl->length
6989 && gfc_is_constant_expr (expr->ts.u.cl->length))
6990 {
6991 if (!expr->ts.u.cl->backend_decl)
6992 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
6993 return;
6994 }
6995
6996 switch (expr->expr_type)
6997 {
6998 case EXPR_ARRAY:
6999
7000 /* This is somewhat brutal. The expression for the first
7001 element of the array is evaluated and assigned to a
7002 new string length for the original expression. */
7003 e = gfc_constructor_first (expr->value.constructor)->expr;
7004
7005 gfc_init_se (&tse, NULL);
7006 if (e->rank)
7007 gfc_conv_expr_descriptor (&tse, e);
7008 else
7009 gfc_conv_expr (&tse, e);
7010
7011 gfc_add_block_to_block (&se->pre, &tse.pre);
7012 gfc_add_block_to_block (&se->post, &tse.post);
7013
7014 if (!expr->ts.u.cl->backend_decl || !VAR_P (expr->ts.u.cl->backend_decl))
7015 {
7016 expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
7017 expr->ts.u.cl->backend_decl =
7018 gfc_create_var (gfc_charlen_type_node, "sln");
7019 }
7020
7021 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
7022 tse.string_length);
7023
7024 return;
7025
7026 case EXPR_OP:
7027 get_array_charlen (expr->value.op.op1, se);
7028
7029 /* For parentheses the expression ts.u.cl is identical. */
7030 if (expr->value.op.op == INTRINSIC_PARENTHESES)
7031 return;
7032
7033 expr->ts.u.cl->backend_decl =
7034 gfc_create_var (gfc_charlen_type_node, "sln");
7035
7036 if (expr->value.op.op2)
7037 {
7038 get_array_charlen (expr->value.op.op2, se);
7039
7040 gcc_assert (expr->value.op.op == INTRINSIC_CONCAT);
7041
7042 /* Add the string lengths and assign them to the expression
7043 string length backend declaration. */
7044 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
7045 fold_build2_loc (input_location, PLUS_EXPR,
7046 gfc_charlen_type_node,
7047 expr->value.op.op1->ts.u.cl->backend_decl,
7048 expr->value.op.op2->ts.u.cl->backend_decl));
7049 }
7050 else
7051 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
7052 expr->value.op.op1->ts.u.cl->backend_decl);
7053 break;
7054
7055 case EXPR_FUNCTION:
7056 if (expr->value.function.esym == NULL
7057 || expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
7058 {
7059 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
7060 break;
7061 }
7062
7063 /* Map expressions involving the dummy arguments onto the actual
7064 argument expressions. */
7065 gfc_init_interface_mapping (&mapping);
7066 formal = gfc_sym_get_dummy_args (expr->symtree->n.sym);
7067 arg = expr->value.function.actual;
7068
7069 /* Set se = NULL in the calls to the interface mapping, to suppress any
7070 backend stuff. */
7071 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
7072 {
7073 if (!arg->expr)
7074 continue;
7075 if (formal->sym)
7076 gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
7077 }
7078
7079 gfc_init_se (&tse, NULL);
7080
7081 /* Build the expression for the character length and convert it. */
7082 gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length);
7083
7084 gfc_add_block_to_block (&se->pre, &tse.pre);
7085 gfc_add_block_to_block (&se->post, &tse.post);
7086 tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
7087 tse.expr = fold_build2_loc (input_location, MAX_EXPR,
7088 TREE_TYPE (tse.expr), tse.expr,
7089 build_zero_cst (TREE_TYPE (tse.expr)));
7090 expr->ts.u.cl->backend_decl = tse.expr;
7091 gfc_free_interface_mapping (&mapping);
7092 break;
7093
7094 default:
7095 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
7096 break;
7097 }
7098 }
7099
7100
7101 /* Helper function to check dimensions. */
7102 static bool
transposed_dims(gfc_ss * ss)7103 transposed_dims (gfc_ss *ss)
7104 {
7105 int n;
7106
7107 for (n = 0; n < ss->dimen; n++)
7108 if (ss->dim[n] != n)
7109 return true;
7110 return false;
7111 }
7112
7113
7114 /* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
7115 AR_FULL, suitable for the scalarizer. */
7116
7117 static gfc_ss *
walk_coarray(gfc_expr * e)7118 walk_coarray (gfc_expr *e)
7119 {
7120 gfc_ss *ss;
7121
7122 gcc_assert (gfc_get_corank (e) > 0);
7123
7124 ss = gfc_walk_expr (e);
7125
7126 /* Fix scalar coarray. */
7127 if (ss == gfc_ss_terminator)
7128 {
7129 gfc_ref *ref;
7130
7131 ref = e->ref;
7132 while (ref)
7133 {
7134 if (ref->type == REF_ARRAY
7135 && ref->u.ar.codimen > 0)
7136 break;
7137
7138 ref = ref->next;
7139 }
7140
7141 gcc_assert (ref != NULL);
7142 if (ref->u.ar.type == AR_ELEMENT)
7143 ref->u.ar.type = AR_SECTION;
7144 ss = gfc_reverse_ss (gfc_walk_array_ref (ss, e, ref));
7145 }
7146
7147 return ss;
7148 }
7149
7150
7151 /* Convert an array for passing as an actual argument. Expressions and
7152 vector subscripts are evaluated and stored in a temporary, which is then
7153 passed. For whole arrays the descriptor is passed. For array sections
7154 a modified copy of the descriptor is passed, but using the original data.
7155
7156 This function is also used for array pointer assignments, and there
7157 are three cases:
7158
7159 - se->want_pointer && !se->direct_byref
7160 EXPR is an actual argument. On exit, se->expr contains a
7161 pointer to the array descriptor.
7162
7163 - !se->want_pointer && !se->direct_byref
7164 EXPR is an actual argument to an intrinsic function or the
7165 left-hand side of a pointer assignment. On exit, se->expr
7166 contains the descriptor for EXPR.
7167
7168 - !se->want_pointer && se->direct_byref
7169 EXPR is the right-hand side of a pointer assignment and
7170 se->expr is the descriptor for the previously-evaluated
7171 left-hand side. The function creates an assignment from
7172 EXPR to se->expr.
7173
7174
7175 The se->force_tmp flag disables the non-copying descriptor optimization
7176 that is used for transpose. It may be used in cases where there is an
7177 alias between the transpose argument and another argument in the same
7178 function call. */
7179
7180 void
gfc_conv_expr_descriptor(gfc_se * se,gfc_expr * expr)7181 gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
7182 {
7183 gfc_ss *ss;
7184 gfc_ss_type ss_type;
7185 gfc_ss_info *ss_info;
7186 gfc_loopinfo loop;
7187 gfc_array_info *info;
7188 int need_tmp;
7189 int n;
7190 tree tmp;
7191 tree desc;
7192 stmtblock_t block;
7193 tree start;
7194 tree offset;
7195 int full;
7196 bool subref_array_target = false;
7197 bool deferred_array_component = false;
7198 gfc_expr *arg, *ss_expr;
7199
7200 if (se->want_coarray)
7201 ss = walk_coarray (expr);
7202 else
7203 ss = gfc_walk_expr (expr);
7204
7205 gcc_assert (ss != NULL);
7206 gcc_assert (ss != gfc_ss_terminator);
7207
7208 ss_info = ss->info;
7209 ss_type = ss_info->type;
7210 ss_expr = ss_info->expr;
7211
7212 /* Special case: TRANSPOSE which needs no temporary. */
7213 while (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym
7214 && (arg = gfc_get_noncopying_intrinsic_argument (expr)) != NULL)
7215 {
7216 /* This is a call to transpose which has already been handled by the
7217 scalarizer, so that we just need to get its argument's descriptor. */
7218 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
7219 expr = expr->value.function.actual->expr;
7220 }
7221
7222 /* Special case things we know we can pass easily. */
7223 switch (expr->expr_type)
7224 {
7225 case EXPR_VARIABLE:
7226 /* If we have a linear array section, we can pass it directly.
7227 Otherwise we need to copy it into a temporary. */
7228
7229 gcc_assert (ss_type == GFC_SS_SECTION);
7230 gcc_assert (ss_expr == expr);
7231 info = &ss_info->data.array;
7232
7233 /* Get the descriptor for the array. */
7234 gfc_conv_ss_descriptor (&se->pre, ss, 0);
7235 desc = info->descriptor;
7236
7237 /* The charlen backend decl for deferred character components cannot
7238 be used because it is fixed at zero. Instead, the hidden string
7239 length component is used. */
7240 if (expr->ts.type == BT_CHARACTER
7241 && expr->ts.deferred
7242 && TREE_CODE (desc) == COMPONENT_REF)
7243 deferred_array_component = true;
7244
7245 subref_array_target = se->direct_byref && is_subref_array (expr);
7246 need_tmp = gfc_ref_needs_temporary_p (expr->ref)
7247 && !subref_array_target;
7248
7249 if (se->force_tmp)
7250 need_tmp = 1;
7251
7252 if (need_tmp)
7253 full = 0;
7254 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
7255 {
7256 /* Create a new descriptor if the array doesn't have one. */
7257 full = 0;
7258 }
7259 else if (info->ref->u.ar.type == AR_FULL || se->descriptor_only)
7260 full = 1;
7261 else if (se->direct_byref)
7262 full = 0;
7263 else
7264 full = gfc_full_array_ref_p (info->ref, NULL);
7265
7266 if (full && !transposed_dims (ss))
7267 {
7268 if (se->direct_byref && !se->byref_noassign)
7269 {
7270 /* Copy the descriptor for pointer assignments. */
7271 gfc_add_modify (&se->pre, se->expr, desc);
7272
7273 /* Add any offsets from subreferences. */
7274 gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
7275 subref_array_target, expr);
7276
7277 /* ....and set the span field. */
7278 tmp = gfc_get_array_span (desc, expr);
7279 if (tmp != NULL_TREE && !integer_zerop (tmp))
7280 gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp);
7281 }
7282 else if (se->want_pointer)
7283 {
7284 /* We pass full arrays directly. This means that pointers and
7285 allocatable arrays should also work. */
7286 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
7287 }
7288 else
7289 {
7290 se->expr = desc;
7291 }
7292
7293 if (expr->ts.type == BT_CHARACTER && !deferred_array_component)
7294 se->string_length = gfc_get_expr_charlen (expr);
7295 /* The ss_info string length is returned set to the value of the
7296 hidden string length component. */
7297 else if (deferred_array_component)
7298 se->string_length = ss_info->string_length;
7299
7300 gfc_free_ss_chain (ss);
7301 return;
7302 }
7303 break;
7304
7305 case EXPR_FUNCTION:
7306 /* A transformational function return value will be a temporary
7307 array descriptor. We still need to go through the scalarizer
7308 to create the descriptor. Elemental functions are handled as
7309 arbitrary expressions, i.e. copy to a temporary. */
7310
7311 if (se->direct_byref)
7312 {
7313 gcc_assert (ss_type == GFC_SS_FUNCTION && ss_expr == expr);
7314
7315 /* For pointer assignments pass the descriptor directly. */
7316 if (se->ss == NULL)
7317 se->ss = ss;
7318 else
7319 gcc_assert (se->ss == ss);
7320
7321 if (!is_pointer_array (se->expr))
7322 {
7323 tmp = gfc_get_element_type (TREE_TYPE (se->expr));
7324 tmp = fold_convert (gfc_array_index_type,
7325 size_in_bytes (tmp));
7326 gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp);
7327 }
7328
7329 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
7330 gfc_conv_expr (se, expr);
7331
7332 gfc_free_ss_chain (ss);
7333 return;
7334 }
7335
7336 if (ss_expr != expr || ss_type != GFC_SS_FUNCTION)
7337 {
7338 if (ss_expr != expr)
7339 /* Elemental function. */
7340 gcc_assert ((expr->value.function.esym != NULL
7341 && expr->value.function.esym->attr.elemental)
7342 || (expr->value.function.isym != NULL
7343 && expr->value.function.isym->elemental)
7344 || gfc_inline_intrinsic_function_p (expr));
7345 else
7346 gcc_assert (ss_type == GFC_SS_INTRINSIC);
7347
7348 need_tmp = 1;
7349 if (expr->ts.type == BT_CHARACTER
7350 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
7351 get_array_charlen (expr, se);
7352
7353 info = NULL;
7354 }
7355 else
7356 {
7357 /* Transformational function. */
7358 info = &ss_info->data.array;
7359 need_tmp = 0;
7360 }
7361 break;
7362
7363 case EXPR_ARRAY:
7364 /* Constant array constructors don't need a temporary. */
7365 if (ss_type == GFC_SS_CONSTRUCTOR
7366 && expr->ts.type != BT_CHARACTER
7367 && gfc_constant_array_constructor_p (expr->value.constructor))
7368 {
7369 need_tmp = 0;
7370 info = &ss_info->data.array;
7371 }
7372 else
7373 {
7374 need_tmp = 1;
7375 info = NULL;
7376 }
7377 break;
7378
7379 default:
7380 /* Something complicated. Copy it into a temporary. */
7381 need_tmp = 1;
7382 info = NULL;
7383 break;
7384 }
7385
7386 /* If we are creating a temporary, we don't need to bother about aliases
7387 anymore. */
7388 if (need_tmp)
7389 se->force_tmp = 0;
7390
7391 gfc_init_loopinfo (&loop);
7392
7393 /* Associate the SS with the loop. */
7394 gfc_add_ss_to_loop (&loop, ss);
7395
7396 /* Tell the scalarizer not to bother creating loop variables, etc. */
7397 if (!need_tmp)
7398 loop.array_parameter = 1;
7399 else
7400 /* The right-hand side of a pointer assignment mustn't use a temporary. */
7401 gcc_assert (!se->direct_byref);
7402
7403 /* Do we need bounds checking or not? */
7404 ss->no_bounds_check = expr->no_bounds_check;
7405
7406 /* Setup the scalarizing loops and bounds. */
7407 gfc_conv_ss_startstride (&loop);
7408
7409 if (need_tmp)
7410 {
7411 if (expr->ts.type == BT_CHARACTER
7412 && (!expr->ts.u.cl->backend_decl || expr->expr_type == EXPR_ARRAY))
7413 get_array_charlen (expr, se);
7414
7415 /* Tell the scalarizer to make a temporary. */
7416 loop.temp_ss = gfc_get_temp_ss (gfc_typenode_for_spec (&expr->ts),
7417 ((expr->ts.type == BT_CHARACTER)
7418 ? expr->ts.u.cl->backend_decl
7419 : NULL),
7420 loop.dimen);
7421
7422 se->string_length = loop.temp_ss->info->string_length;
7423 gcc_assert (loop.temp_ss->dimen == loop.dimen);
7424 gfc_add_ss_to_loop (&loop, loop.temp_ss);
7425 }
7426
7427 gfc_conv_loop_setup (&loop, & expr->where);
7428
7429 if (need_tmp)
7430 {
7431 /* Copy into a temporary and pass that. We don't need to copy the data
7432 back because expressions and vector subscripts must be INTENT_IN. */
7433 /* TODO: Optimize passing function return values. */
7434 gfc_se lse;
7435 gfc_se rse;
7436 bool deep_copy;
7437
7438 /* Start the copying loops. */
7439 gfc_mark_ss_chain_used (loop.temp_ss, 1);
7440 gfc_mark_ss_chain_used (ss, 1);
7441 gfc_start_scalarized_body (&loop, &block);
7442
7443 /* Copy each data element. */
7444 gfc_init_se (&lse, NULL);
7445 gfc_copy_loopinfo_to_se (&lse, &loop);
7446 gfc_init_se (&rse, NULL);
7447 gfc_copy_loopinfo_to_se (&rse, &loop);
7448
7449 lse.ss = loop.temp_ss;
7450 rse.ss = ss;
7451
7452 gfc_conv_scalarized_array_ref (&lse, NULL);
7453 if (expr->ts.type == BT_CHARACTER)
7454 {
7455 gfc_conv_expr (&rse, expr);
7456 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
7457 rse.expr = build_fold_indirect_ref_loc (input_location,
7458 rse.expr);
7459 }
7460 else
7461 gfc_conv_expr_val (&rse, expr);
7462
7463 gfc_add_block_to_block (&block, &rse.pre);
7464 gfc_add_block_to_block (&block, &lse.pre);
7465
7466 lse.string_length = rse.string_length;
7467
7468 deep_copy = !se->data_not_needed
7469 && (expr->expr_type == EXPR_VARIABLE
7470 || expr->expr_type == EXPR_ARRAY);
7471 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts,
7472 deep_copy, false);
7473 gfc_add_expr_to_block (&block, tmp);
7474
7475 /* Finish the copying loops. */
7476 gfc_trans_scalarizing_loops (&loop, &block);
7477
7478 desc = loop.temp_ss->info->data.array.descriptor;
7479 }
7480 else if (expr->expr_type == EXPR_FUNCTION && !transposed_dims (ss))
7481 {
7482 desc = info->descriptor;
7483 se->string_length = ss_info->string_length;
7484 }
7485 else
7486 {
7487 /* We pass sections without copying to a temporary. Make a new
7488 descriptor and point it at the section we want. The loop variable
7489 limits will be the limits of the section.
7490 A function may decide to repack the array to speed up access, but
7491 we're not bothered about that here. */
7492 int dim, ndim, codim;
7493 tree parm;
7494 tree parmtype;
7495 tree stride;
7496 tree from;
7497 tree to;
7498 tree base;
7499 bool onebased = false, rank_remap;
7500
7501 ndim = info->ref ? info->ref->u.ar.dimen : ss->dimen;
7502 rank_remap = ss->dimen < ndim;
7503
7504 if (se->want_coarray)
7505 {
7506 gfc_array_ref *ar = &info->ref->u.ar;
7507
7508 codim = gfc_get_corank (expr);
7509 for (n = 0; n < codim - 1; n++)
7510 {
7511 /* Make sure we are not lost somehow. */
7512 gcc_assert (ar->dimen_type[n + ndim] == DIMEN_THIS_IMAGE);
7513
7514 /* Make sure the call to gfc_conv_section_startstride won't
7515 generate unnecessary code to calculate stride. */
7516 gcc_assert (ar->stride[n + ndim] == NULL);
7517
7518 gfc_conv_section_startstride (&loop.pre, ss, n + ndim);
7519 loop.from[n + loop.dimen] = info->start[n + ndim];
7520 loop.to[n + loop.dimen] = info->end[n + ndim];
7521 }
7522
7523 gcc_assert (n == codim - 1);
7524 evaluate_bound (&loop.pre, info->start, ar->start,
7525 info->descriptor, n + ndim, true,
7526 ar->as->type == AS_DEFERRED);
7527 loop.from[n + loop.dimen] = info->start[n + ndim];
7528 }
7529 else
7530 codim = 0;
7531
7532 /* Set the string_length for a character array. */
7533 if (expr->ts.type == BT_CHARACTER)
7534 {
7535 se->string_length = gfc_get_expr_charlen (expr);
7536 if (VAR_P (se->string_length)
7537 && expr->ts.u.cl->backend_decl == se->string_length)
7538 tmp = ss_info->string_length;
7539 else
7540 tmp = se->string_length;
7541
7542 if (expr->ts.deferred)
7543 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, tmp);
7544 }
7545
7546 /* If we have an array section or are assigning make sure that
7547 the lower bound is 1. References to the full
7548 array should otherwise keep the original bounds. */
7549 if ((!info->ref || info->ref->u.ar.type != AR_FULL) && !se->want_pointer)
7550 for (dim = 0; dim < loop.dimen; dim++)
7551 if (!integer_onep (loop.from[dim]))
7552 {
7553 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7554 gfc_array_index_type, gfc_index_one_node,
7555 loop.from[dim]);
7556 loop.to[dim] = fold_build2_loc (input_location, PLUS_EXPR,
7557 gfc_array_index_type,
7558 loop.to[dim], tmp);
7559 loop.from[dim] = gfc_index_one_node;
7560 }
7561
7562 desc = info->descriptor;
7563 if (se->direct_byref && !se->byref_noassign)
7564 {
7565 /* For pointer assignments we fill in the destination. */
7566 parm = se->expr;
7567 parmtype = TREE_TYPE (parm);
7568 }
7569 else
7570 {
7571 /* Otherwise make a new one. */
7572 if (expr->ts.type == BT_CHARACTER && expr->ts.deferred)
7573 parmtype = gfc_typenode_for_spec (&expr->ts);
7574 else
7575 parmtype = gfc_get_element_type (TREE_TYPE (desc));
7576
7577 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, codim,
7578 loop.from, loop.to, 0,
7579 GFC_ARRAY_UNKNOWN, false);
7580 parm = gfc_create_var (parmtype, "parm");
7581
7582 /* When expression is a class object, then add the class' handle to
7583 the parm_decl. */
7584 if (expr->ts.type == BT_CLASS && expr->expr_type == EXPR_VARIABLE)
7585 {
7586 gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr);
7587 gfc_se classse;
7588
7589 /* class_expr can be NULL, when no _class ref is in expr.
7590 We must not fix this here with a gfc_fix_class_ref (). */
7591 if (class_expr)
7592 {
7593 gfc_init_se (&classse, NULL);
7594 gfc_conv_expr (&classse, class_expr);
7595 gfc_free_expr (class_expr);
7596
7597 gcc_assert (classse.pre.head == NULL_TREE
7598 && classse.post.head == NULL_TREE);
7599 gfc_allocate_lang_decl (parm);
7600 GFC_DECL_SAVED_DESCRIPTOR (parm) = classse.expr;
7601 }
7602 }
7603 }
7604
7605 /* Set the span field. */
7606 if (expr->ts.type == BT_CHARACTER && ss_info->string_length)
7607 tmp = ss_info->string_length;
7608 else
7609 tmp = gfc_get_array_span (desc, expr);
7610 if (tmp != NULL_TREE)
7611 gfc_conv_descriptor_span_set (&loop.pre, parm, tmp);
7612
7613 offset = gfc_index_zero_node;
7614
7615 /* The following can be somewhat confusing. We have two
7616 descriptors, a new one and the original array.
7617 {parm, parmtype, dim} refer to the new one.
7618 {desc, type, n, loop} refer to the original, which maybe
7619 a descriptorless array.
7620 The bounds of the scalarization are the bounds of the section.
7621 We don't have to worry about numeric overflows when calculating
7622 the offsets because all elements are within the array data. */
7623
7624 /* Set the dtype. */
7625 tmp = gfc_conv_descriptor_dtype (parm);
7626 gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
7627
7628 /* Set offset for assignments to pointer only to zero if it is not
7629 the full array. */
7630 if ((se->direct_byref || se->use_offset)
7631 && ((info->ref && info->ref->u.ar.type != AR_FULL)
7632 || (expr->expr_type == EXPR_ARRAY && se->use_offset)))
7633 base = gfc_index_zero_node;
7634 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
7635 base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
7636 else
7637 base = NULL_TREE;
7638
7639 for (n = 0; n < ndim; n++)
7640 {
7641 stride = gfc_conv_array_stride (desc, n);
7642
7643 /* Work out the offset. */
7644 if (info->ref
7645 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
7646 {
7647 gcc_assert (info->subscript[n]
7648 && info->subscript[n]->info->type == GFC_SS_SCALAR);
7649 start = info->subscript[n]->info->data.scalar.value;
7650 }
7651 else
7652 {
7653 /* Evaluate and remember the start of the section. */
7654 start = info->start[n];
7655 stride = gfc_evaluate_now (stride, &loop.pre);
7656 }
7657
7658 tmp = gfc_conv_array_lbound (desc, n);
7659 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
7660 start, tmp);
7661 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
7662 tmp, stride);
7663 offset = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
7664 offset, tmp);
7665
7666 if (info->ref
7667 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
7668 {
7669 /* For elemental dimensions, we only need the offset. */
7670 continue;
7671 }
7672
7673 /* Vector subscripts need copying and are handled elsewhere. */
7674 if (info->ref)
7675 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
7676
7677 /* look for the corresponding scalarizer dimension: dim. */
7678 for (dim = 0; dim < ndim; dim++)
7679 if (ss->dim[dim] == n)
7680 break;
7681
7682 /* loop exited early: the DIM being looked for has been found. */
7683 gcc_assert (dim < ndim);
7684
7685 /* Set the new lower bound. */
7686 from = loop.from[dim];
7687 to = loop.to[dim];
7688
7689 onebased = integer_onep (from);
7690 gfc_conv_descriptor_lbound_set (&loop.pre, parm,
7691 gfc_rank_cst[dim], from);
7692
7693 /* Set the new upper bound. */
7694 gfc_conv_descriptor_ubound_set (&loop.pre, parm,
7695 gfc_rank_cst[dim], to);
7696
7697 /* Multiply the stride by the section stride to get the
7698 total stride. */
7699 stride = fold_build2_loc (input_location, MULT_EXPR,
7700 gfc_array_index_type,
7701 stride, info->stride[n]);
7702
7703 if ((se->direct_byref || se->use_offset)
7704 && ((info->ref && info->ref->u.ar.type != AR_FULL)
7705 || (expr->expr_type == EXPR_ARRAY && se->use_offset)))
7706 {
7707 base = fold_build2_loc (input_location, MINUS_EXPR,
7708 TREE_TYPE (base), base, stride);
7709 }
7710 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)) || se->use_offset)
7711 {
7712 bool toonebased;
7713 tmp = gfc_conv_array_lbound (desc, n);
7714 toonebased = integer_onep (tmp);
7715 // lb(arr) - from (- start + 1)
7716 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7717 TREE_TYPE (base), tmp, from);
7718 if (onebased && toonebased)
7719 {
7720 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7721 TREE_TYPE (base), tmp, start);
7722 tmp = fold_build2_loc (input_location, PLUS_EXPR,
7723 TREE_TYPE (base), tmp,
7724 gfc_index_one_node);
7725 }
7726 tmp = fold_build2_loc (input_location, MULT_EXPR,
7727 TREE_TYPE (base), tmp,
7728 gfc_conv_array_stride (desc, n));
7729 base = fold_build2_loc (input_location, PLUS_EXPR,
7730 TREE_TYPE (base), tmp, base);
7731 }
7732
7733 /* Store the new stride. */
7734 gfc_conv_descriptor_stride_set (&loop.pre, parm,
7735 gfc_rank_cst[dim], stride);
7736 }
7737
7738 for (n = loop.dimen; n < loop.dimen + codim; n++)
7739 {
7740 from = loop.from[n];
7741 to = loop.to[n];
7742 gfc_conv_descriptor_lbound_set (&loop.pre, parm,
7743 gfc_rank_cst[n], from);
7744 if (n < loop.dimen + codim - 1)
7745 gfc_conv_descriptor_ubound_set (&loop.pre, parm,
7746 gfc_rank_cst[n], to);
7747 }
7748
7749 if (se->data_not_needed)
7750 gfc_conv_descriptor_data_set (&loop.pre, parm,
7751 gfc_index_zero_node);
7752 else
7753 /* Point the data pointer at the 1st element in the section. */
7754 gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
7755 subref_array_target, expr);
7756
7757 /* Force the offset to be -1, when the lower bound of the highest
7758 dimension is one and the symbol is present and is not a
7759 pointer/allocatable or associated. */
7760 if (((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
7761 && !se->data_not_needed)
7762 || (se->use_offset && base != NULL_TREE))
7763 {
7764 /* Set the offset depending on base. */
7765 tmp = rank_remap && !se->direct_byref ?
7766 fold_build2_loc (input_location, PLUS_EXPR,
7767 gfc_array_index_type, base,
7768 offset)
7769 : base;
7770 gfc_conv_descriptor_offset_set (&loop.pre, parm, tmp);
7771 }
7772 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
7773 && !se->data_not_needed
7774 && (!rank_remap || se->use_offset))
7775 {
7776 gfc_conv_descriptor_offset_set (&loop.pre, parm,
7777 gfc_conv_descriptor_offset_get (desc));
7778 }
7779 else if (onebased && (!rank_remap || se->use_offset)
7780 && expr->symtree
7781 && !(expr->symtree->n.sym && expr->symtree->n.sym->ts.type == BT_CLASS
7782 && !CLASS_DATA (expr->symtree->n.sym)->attr.class_pointer)
7783 && !expr->symtree->n.sym->attr.allocatable
7784 && !expr->symtree->n.sym->attr.pointer
7785 && !expr->symtree->n.sym->attr.host_assoc
7786 && !expr->symtree->n.sym->attr.use_assoc)
7787 {
7788 /* Set the offset to -1. */
7789 mpz_t minus_one;
7790 mpz_init_set_si (minus_one, -1);
7791 tmp = gfc_conv_mpz_to_tree (minus_one, gfc_index_integer_kind);
7792 gfc_conv_descriptor_offset_set (&loop.pre, parm, tmp);
7793 }
7794 else
7795 {
7796 /* Only the callee knows what the correct offset it, so just set
7797 it to zero here. */
7798 gfc_conv_descriptor_offset_set (&loop.pre, parm, gfc_index_zero_node);
7799 }
7800 desc = parm;
7801 }
7802
7803 /* For class arrays add the class tree into the saved descriptor to
7804 enable getting of _vptr and the like. */
7805 if (expr->expr_type == EXPR_VARIABLE && VAR_P (desc)
7806 && IS_CLASS_ARRAY (expr->symtree->n.sym))
7807 {
7808 gfc_allocate_lang_decl (desc);
7809 GFC_DECL_SAVED_DESCRIPTOR (desc) =
7810 DECL_LANG_SPECIFIC (expr->symtree->n.sym->backend_decl) ?
7811 GFC_DECL_SAVED_DESCRIPTOR (expr->symtree->n.sym->backend_decl)
7812 : expr->symtree->n.sym->backend_decl;
7813 }
7814 else if (expr->expr_type == EXPR_ARRAY && VAR_P (desc)
7815 && IS_CLASS_ARRAY (expr))
7816 {
7817 tree vtype;
7818 gfc_allocate_lang_decl (desc);
7819 tmp = gfc_create_var (expr->ts.u.derived->backend_decl, "class");
7820 GFC_DECL_SAVED_DESCRIPTOR (desc) = tmp;
7821 vtype = gfc_class_vptr_get (tmp);
7822 gfc_add_modify (&se->pre, vtype,
7823 gfc_build_addr_expr (TREE_TYPE (vtype),
7824 gfc_find_vtab (&expr->ts)->backend_decl));
7825 }
7826 if (!se->direct_byref || se->byref_noassign)
7827 {
7828 /* Get a pointer to the new descriptor. */
7829 if (se->want_pointer)
7830 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
7831 else
7832 se->expr = desc;
7833 }
7834
7835 gfc_add_block_to_block (&se->pre, &loop.pre);
7836 gfc_add_block_to_block (&se->post, &loop.post);
7837
7838 /* Cleanup the scalarizer. */
7839 gfc_cleanup_loop (&loop);
7840 }
7841
7842 /* Helper function for gfc_conv_array_parameter if array size needs to be
7843 computed. */
7844
7845 static void
array_parameter_size(tree desc,gfc_expr * expr,tree * size)7846 array_parameter_size (tree desc, gfc_expr *expr, tree *size)
7847 {
7848 tree elem;
7849 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
7850 *size = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
7851 else if (expr->rank > 1)
7852 *size = build_call_expr_loc (input_location,
7853 gfor_fndecl_size0, 1,
7854 gfc_build_addr_expr (NULL, desc));
7855 else
7856 {
7857 tree ubound = gfc_conv_descriptor_ubound_get (desc, gfc_index_zero_node);
7858 tree lbound = gfc_conv_descriptor_lbound_get (desc, gfc_index_zero_node);
7859
7860 *size = fold_build2_loc (input_location, MINUS_EXPR,
7861 gfc_array_index_type, ubound, lbound);
7862 *size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
7863 *size, gfc_index_one_node);
7864 *size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
7865 *size, gfc_index_zero_node);
7866 }
7867 elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
7868 *size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7869 *size, fold_convert (gfc_array_index_type, elem));
7870 }
7871
7872 /* Convert an array for passing as an actual parameter. */
7873
7874 void
gfc_conv_array_parameter(gfc_se * se,gfc_expr * expr,bool g77,const gfc_symbol * fsym,const char * proc_name,tree * size)7875 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
7876 const gfc_symbol *fsym, const char *proc_name,
7877 tree *size)
7878 {
7879 tree ptr;
7880 tree desc;
7881 tree tmp = NULL_TREE;
7882 tree stmt;
7883 tree parent = DECL_CONTEXT (current_function_decl);
7884 bool full_array_var;
7885 bool this_array_result;
7886 bool contiguous;
7887 bool no_pack;
7888 bool array_constructor;
7889 bool good_allocatable;
7890 bool ultimate_ptr_comp;
7891 bool ultimate_alloc_comp;
7892 gfc_symbol *sym;
7893 stmtblock_t block;
7894 gfc_ref *ref;
7895
7896 ultimate_ptr_comp = false;
7897 ultimate_alloc_comp = false;
7898
7899 for (ref = expr->ref; ref; ref = ref->next)
7900 {
7901 if (ref->next == NULL)
7902 break;
7903
7904 if (ref->type == REF_COMPONENT)
7905 {
7906 ultimate_ptr_comp = ref->u.c.component->attr.pointer;
7907 ultimate_alloc_comp = ref->u.c.component->attr.allocatable;
7908 }
7909 }
7910
7911 full_array_var = false;
7912 contiguous = false;
7913
7914 if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp)
7915 full_array_var = gfc_full_array_ref_p (ref, &contiguous);
7916
7917 sym = full_array_var ? expr->symtree->n.sym : NULL;
7918
7919 /* The symbol should have an array specification. */
7920 gcc_assert (!sym || sym->as || ref->u.ar.as);
7921
7922 if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
7923 {
7924 get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
7925 expr->ts.u.cl->backend_decl = tmp;
7926 se->string_length = tmp;
7927 }
7928
7929 /* Is this the result of the enclosing procedure? */
7930 this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
7931 if (this_array_result
7932 && (sym->backend_decl != current_function_decl)
7933 && (sym->backend_decl != parent))
7934 this_array_result = false;
7935
7936 /* Passing address of the array if it is not pointer or assumed-shape. */
7937 if (full_array_var && g77 && !this_array_result
7938 && sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
7939 {
7940 tmp = gfc_get_symbol_decl (sym);
7941
7942 if (sym->ts.type == BT_CHARACTER)
7943 se->string_length = sym->ts.u.cl->backend_decl;
7944
7945 if (!sym->attr.pointer
7946 && sym->as
7947 && sym->as->type != AS_ASSUMED_SHAPE
7948 && sym->as->type != AS_DEFERRED
7949 && sym->as->type != AS_ASSUMED_RANK
7950 && !sym->attr.allocatable)
7951 {
7952 /* Some variables are declared directly, others are declared as
7953 pointers and allocated on the heap. */
7954 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
7955 se->expr = tmp;
7956 else
7957 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
7958 if (size)
7959 array_parameter_size (tmp, expr, size);
7960 return;
7961 }
7962
7963 if (sym->attr.allocatable)
7964 {
7965 if (sym->attr.dummy || sym->attr.result)
7966 {
7967 gfc_conv_expr_descriptor (se, expr);
7968 tmp = se->expr;
7969 }
7970 if (size)
7971 array_parameter_size (tmp, expr, size);
7972 se->expr = gfc_conv_array_data (tmp);
7973 return;
7974 }
7975 }
7976
7977 /* A convenient reduction in scope. */
7978 contiguous = g77 && !this_array_result && contiguous;
7979
7980 /* There is no need to pack and unpack the array, if it is contiguous
7981 and not a deferred- or assumed-shape array, or if it is simply
7982 contiguous. */
7983 no_pack = ((sym && sym->as
7984 && !sym->attr.pointer
7985 && sym->as->type != AS_DEFERRED
7986 && sym->as->type != AS_ASSUMED_RANK
7987 && sym->as->type != AS_ASSUMED_SHAPE)
7988 ||
7989 (ref && ref->u.ar.as
7990 && ref->u.ar.as->type != AS_DEFERRED
7991 && ref->u.ar.as->type != AS_ASSUMED_RANK
7992 && ref->u.ar.as->type != AS_ASSUMED_SHAPE)
7993 ||
7994 gfc_is_simply_contiguous (expr, false, true));
7995
7996 no_pack = contiguous && no_pack;
7997
7998 /* If we have an EXPR_OP or a function returning an explicit-shaped
7999 or allocatable array, an array temporary will be generated which
8000 does not need to be packed / unpacked if passed to an
8001 explicit-shape dummy array. */
8002
8003 if (g77)
8004 {
8005 if (expr->expr_type == EXPR_OP)
8006 no_pack = 1;
8007 else if (expr->expr_type == EXPR_FUNCTION && expr->value.function.esym)
8008 {
8009 gfc_symbol *result = expr->value.function.esym->result;
8010 if (result->attr.dimension
8011 && (result->as->type == AS_EXPLICIT
8012 || result->attr.allocatable
8013 || result->attr.contiguous))
8014 no_pack = 1;
8015 }
8016 }
8017
8018 /* Array constructors are always contiguous and do not need packing. */
8019 array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY;
8020
8021 /* Same is true of contiguous sections from allocatable variables. */
8022 good_allocatable = contiguous
8023 && expr->symtree
8024 && expr->symtree->n.sym->attr.allocatable;
8025
8026 /* Or ultimate allocatable components. */
8027 ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
8028
8029 if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp)
8030 {
8031 gfc_conv_expr_descriptor (se, expr);
8032 /* Deallocate the allocatable components of structures that are
8033 not variable. */
8034 if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
8035 && expr->ts.u.derived->attr.alloc_comp
8036 && expr->expr_type != EXPR_VARIABLE)
8037 {
8038 tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, se->expr, expr->rank);
8039
8040 /* The components shall be deallocated before their containing entity. */
8041 gfc_prepend_expr_to_block (&se->post, tmp);
8042 }
8043 if (expr->ts.type == BT_CHARACTER)
8044 se->string_length = expr->ts.u.cl->backend_decl;
8045 if (size)
8046 array_parameter_size (se->expr, expr, size);
8047 se->expr = gfc_conv_array_data (se->expr);
8048 return;
8049 }
8050
8051 if (this_array_result)
8052 {
8053 /* Result of the enclosing function. */
8054 gfc_conv_expr_descriptor (se, expr);
8055 if (size)
8056 array_parameter_size (se->expr, expr, size);
8057 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
8058
8059 if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
8060 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
8061 se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location,
8062 se->expr));
8063
8064 return;
8065 }
8066 else
8067 {
8068 /* Every other type of array. */
8069 se->want_pointer = 1;
8070 gfc_conv_expr_descriptor (se, expr);
8071
8072 if (size)
8073 array_parameter_size (build_fold_indirect_ref_loc (input_location,
8074 se->expr),
8075 expr, size);
8076 }
8077
8078 /* Deallocate the allocatable components of structures that are
8079 not variable, for descriptorless arguments.
8080 Arguments with a descriptor are handled in gfc_conv_procedure_call. */
8081 if (g77 && (expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
8082 && expr->ts.u.derived->attr.alloc_comp
8083 && expr->expr_type != EXPR_VARIABLE)
8084 {
8085 tmp = build_fold_indirect_ref_loc (input_location, se->expr);
8086 tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank);
8087
8088 /* The components shall be deallocated before their containing entity. */
8089 gfc_prepend_expr_to_block (&se->post, tmp);
8090 }
8091
8092 if (g77 || (fsym && fsym->attr.contiguous
8093 && !gfc_is_simply_contiguous (expr, false, true)))
8094 {
8095 tree origptr = NULL_TREE;
8096
8097 desc = se->expr;
8098
8099 /* For contiguous arrays, save the original value of the descriptor. */
8100 if (!g77)
8101 {
8102 origptr = gfc_create_var (pvoid_type_node, "origptr");
8103 tmp = build_fold_indirect_ref_loc (input_location, desc);
8104 tmp = gfc_conv_array_data (tmp);
8105 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
8106 TREE_TYPE (origptr), origptr,
8107 fold_convert (TREE_TYPE (origptr), tmp));
8108 gfc_add_expr_to_block (&se->pre, tmp);
8109 }
8110
8111 /* Repack the array. */
8112 if (warn_array_temporaries)
8113 {
8114 if (fsym)
8115 gfc_warning (OPT_Warray_temporaries,
8116 "Creating array temporary at %L for argument %qs",
8117 &expr->where, fsym->name);
8118 else
8119 gfc_warning (OPT_Warray_temporaries,
8120 "Creating array temporary at %L", &expr->where);
8121 }
8122
8123 ptr = build_call_expr_loc (input_location,
8124 gfor_fndecl_in_pack, 1, desc);
8125
8126 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
8127 {
8128 tmp = gfc_conv_expr_present (sym);
8129 ptr = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
8130 tmp, fold_convert (TREE_TYPE (se->expr), ptr),
8131 fold_convert (TREE_TYPE (se->expr), null_pointer_node));
8132 }
8133
8134 ptr = gfc_evaluate_now (ptr, &se->pre);
8135
8136 /* Use the packed data for the actual argument, except for contiguous arrays,
8137 where the descriptor's data component is set. */
8138 if (g77)
8139 se->expr = ptr;
8140 else
8141 {
8142 tmp = build_fold_indirect_ref_loc (input_location, desc);
8143
8144 gfc_ss * ss = gfc_walk_expr (expr);
8145 if (!transposed_dims (ss))
8146 gfc_conv_descriptor_data_set (&se->pre, tmp, ptr);
8147 else
8148 {
8149 tree old_field, new_field;
8150
8151 /* The original descriptor has transposed dims so we can't reuse
8152 it directly; we have to create a new one. */
8153 tree old_desc = tmp;
8154 tree new_desc = gfc_create_var (TREE_TYPE (old_desc), "arg_desc");
8155
8156 old_field = gfc_conv_descriptor_dtype (old_desc);
8157 new_field = gfc_conv_descriptor_dtype (new_desc);
8158 gfc_add_modify (&se->pre, new_field, old_field);
8159
8160 old_field = gfc_conv_descriptor_offset (old_desc);
8161 new_field = gfc_conv_descriptor_offset (new_desc);
8162 gfc_add_modify (&se->pre, new_field, old_field);
8163
8164 for (int i = 0; i < expr->rank; i++)
8165 {
8166 old_field = gfc_conv_descriptor_dimension (old_desc,
8167 gfc_rank_cst[get_array_ref_dim_for_loop_dim (ss, i)]);
8168 new_field = gfc_conv_descriptor_dimension (new_desc,
8169 gfc_rank_cst[i]);
8170 gfc_add_modify (&se->pre, new_field, old_field);
8171 }
8172
8173 if (flag_coarray == GFC_FCOARRAY_LIB
8174 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (old_desc))
8175 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (old_desc))
8176 == GFC_ARRAY_ALLOCATABLE)
8177 {
8178 old_field = gfc_conv_descriptor_token (old_desc);
8179 new_field = gfc_conv_descriptor_token (new_desc);
8180 gfc_add_modify (&se->pre, new_field, old_field);
8181 }
8182
8183 gfc_conv_descriptor_data_set (&se->pre, new_desc, ptr);
8184 se->expr = gfc_build_addr_expr (NULL_TREE, new_desc);
8185 }
8186 gfc_free_ss (ss);
8187 }
8188
8189 if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
8190 {
8191 char * msg;
8192
8193 if (fsym && proc_name)
8194 msg = xasprintf ("An array temporary was created for argument "
8195 "'%s' of procedure '%s'", fsym->name, proc_name);
8196 else
8197 msg = xasprintf ("An array temporary was created");
8198
8199 tmp = build_fold_indirect_ref_loc (input_location,
8200 desc);
8201 tmp = gfc_conv_array_data (tmp);
8202 tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
8203 fold_convert (TREE_TYPE (tmp), ptr), tmp);
8204
8205 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
8206 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
8207 logical_type_node,
8208 gfc_conv_expr_present (sym), tmp);
8209
8210 gfc_trans_runtime_check (false, true, tmp, &se->pre,
8211 &expr->where, msg);
8212 free (msg);
8213 }
8214
8215 gfc_start_block (&block);
8216
8217 /* Copy the data back. */
8218 if (fsym == NULL || fsym->attr.intent != INTENT_IN)
8219 {
8220 tmp = build_call_expr_loc (input_location,
8221 gfor_fndecl_in_unpack, 2, desc, ptr);
8222 gfc_add_expr_to_block (&block, tmp);
8223 }
8224
8225 /* Free the temporary. */
8226 tmp = gfc_call_free (ptr);
8227 gfc_add_expr_to_block (&block, tmp);
8228
8229 stmt = gfc_finish_block (&block);
8230
8231 gfc_init_block (&block);
8232 /* Only if it was repacked. This code needs to be executed before the
8233 loop cleanup code. */
8234 tmp = build_fold_indirect_ref_loc (input_location,
8235 desc);
8236 tmp = gfc_conv_array_data (tmp);
8237 tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
8238 fold_convert (TREE_TYPE (tmp), ptr), tmp);
8239
8240 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
8241 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
8242 logical_type_node,
8243 gfc_conv_expr_present (sym), tmp);
8244
8245 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
8246
8247 gfc_add_expr_to_block (&block, tmp);
8248 gfc_add_block_to_block (&block, &se->post);
8249
8250 gfc_init_block (&se->post);
8251
8252 /* Reset the descriptor pointer. */
8253 if (!g77)
8254 {
8255 tmp = build_fold_indirect_ref_loc (input_location, desc);
8256 gfc_conv_descriptor_data_set (&se->post, tmp, origptr);
8257 }
8258
8259 gfc_add_block_to_block (&se->post, &block);
8260 }
8261 }
8262
8263
8264 /* This helper function calculates the size in words of a full array. */
8265
8266 tree
gfc_full_array_size(stmtblock_t * block,tree decl,int rank)8267 gfc_full_array_size (stmtblock_t *block, tree decl, int rank)
8268 {
8269 tree idx;
8270 tree nelems;
8271 tree tmp;
8272 idx = gfc_rank_cst[rank - 1];
8273 nelems = gfc_conv_descriptor_ubound_get (decl, idx);
8274 tmp = gfc_conv_descriptor_lbound_get (decl, idx);
8275 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8276 nelems, tmp);
8277 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
8278 tmp, gfc_index_one_node);
8279 tmp = gfc_evaluate_now (tmp, block);
8280
8281 nelems = gfc_conv_descriptor_stride_get (decl, idx);
8282 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
8283 nelems, tmp);
8284 return gfc_evaluate_now (tmp, block);
8285 }
8286
8287
8288 /* Allocate dest to the same size as src, and copy src -> dest.
8289 If no_malloc is set, only the copy is done. */
8290
8291 static tree
duplicate_allocatable(tree dest,tree src,tree type,int rank,bool no_malloc,bool no_memcpy,tree str_sz,tree add_when_allocated)8292 duplicate_allocatable (tree dest, tree src, tree type, int rank,
8293 bool no_malloc, bool no_memcpy, tree str_sz,
8294 tree add_when_allocated)
8295 {
8296 tree tmp;
8297 tree size;
8298 tree nelems;
8299 tree null_cond;
8300 tree null_data;
8301 stmtblock_t block;
8302
8303 /* If the source is null, set the destination to null. Then,
8304 allocate memory to the destination. */
8305 gfc_init_block (&block);
8306
8307 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
8308 {
8309 gfc_add_modify (&block, dest, fold_convert (type, null_pointer_node));
8310 null_data = gfc_finish_block (&block);
8311
8312 gfc_init_block (&block);
8313 if (str_sz != NULL_TREE)
8314 size = str_sz;
8315 else
8316 size = TYPE_SIZE_UNIT (TREE_TYPE (type));
8317
8318 if (!no_malloc)
8319 {
8320 tmp = gfc_call_malloc (&block, type, size);
8321 gfc_add_modify (&block, dest, fold_convert (type, tmp));
8322 }
8323
8324 if (!no_memcpy)
8325 {
8326 tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
8327 tmp = build_call_expr_loc (input_location, tmp, 3, dest, src,
8328 fold_convert (size_type_node, size));
8329 gfc_add_expr_to_block (&block, tmp);
8330 }
8331 }
8332 else
8333 {
8334 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
8335 null_data = gfc_finish_block (&block);
8336
8337 gfc_init_block (&block);
8338 if (rank)
8339 nelems = gfc_full_array_size (&block, src, rank);
8340 else
8341 nelems = gfc_index_one_node;
8342
8343 if (str_sz != NULL_TREE)
8344 tmp = fold_convert (gfc_array_index_type, str_sz);
8345 else
8346 tmp = fold_convert (gfc_array_index_type,
8347 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
8348 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
8349 nelems, tmp);
8350 if (!no_malloc)
8351 {
8352 tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src));
8353 tmp = gfc_call_malloc (&block, tmp, size);
8354 gfc_conv_descriptor_data_set (&block, dest, tmp);
8355 }
8356
8357 /* We know the temporary and the value will be the same length,
8358 so can use memcpy. */
8359 if (!no_memcpy)
8360 {
8361 tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
8362 tmp = build_call_expr_loc (input_location, tmp, 3,
8363 gfc_conv_descriptor_data_get (dest),
8364 gfc_conv_descriptor_data_get (src),
8365 fold_convert (size_type_node, size));
8366 gfc_add_expr_to_block (&block, tmp);
8367 }
8368 }
8369
8370 gfc_add_expr_to_block (&block, add_when_allocated);
8371 tmp = gfc_finish_block (&block);
8372
8373 /* Null the destination if the source is null; otherwise do
8374 the allocate and copy. */
8375 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src)))
8376 null_cond = src;
8377 else
8378 null_cond = gfc_conv_descriptor_data_get (src);
8379
8380 null_cond = convert (pvoid_type_node, null_cond);
8381 null_cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
8382 null_cond, null_pointer_node);
8383 return build3_v (COND_EXPR, null_cond, tmp, null_data);
8384 }
8385
8386
8387 /* Allocate dest to the same size as src, and copy data src -> dest. */
8388
8389 tree
gfc_duplicate_allocatable(tree dest,tree src,tree type,int rank,tree add_when_allocated)8390 gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank,
8391 tree add_when_allocated)
8392 {
8393 return duplicate_allocatable (dest, src, type, rank, false, false,
8394 NULL_TREE, add_when_allocated);
8395 }
8396
8397
8398 /* Copy data src -> dest. */
8399
8400 tree
gfc_copy_allocatable_data(tree dest,tree src,tree type,int rank)8401 gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
8402 {
8403 return duplicate_allocatable (dest, src, type, rank, true, false,
8404 NULL_TREE, NULL_TREE);
8405 }
8406
8407 /* Allocate dest to the same size as src, but don't copy anything. */
8408
8409 tree
gfc_duplicate_allocatable_nocopy(tree dest,tree src,tree type,int rank)8410 gfc_duplicate_allocatable_nocopy (tree dest, tree src, tree type, int rank)
8411 {
8412 return duplicate_allocatable (dest, src, type, rank, false, true,
8413 NULL_TREE, NULL_TREE);
8414 }
8415
8416
8417 static tree
duplicate_allocatable_coarray(tree dest,tree dest_tok,tree src,tree type,int rank)8418 duplicate_allocatable_coarray (tree dest, tree dest_tok, tree src,
8419 tree type, int rank)
8420 {
8421 tree tmp;
8422 tree size;
8423 tree nelems;
8424 tree null_cond;
8425 tree null_data;
8426 stmtblock_t block, globalblock;
8427
8428 /* If the source is null, set the destination to null. Then,
8429 allocate memory to the destination. */
8430 gfc_init_block (&block);
8431 gfc_init_block (&globalblock);
8432
8433 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
8434 {
8435 gfc_se se;
8436 symbol_attribute attr;
8437 tree dummy_desc;
8438
8439 gfc_init_se (&se, NULL);
8440 gfc_clear_attr (&attr);
8441 attr.allocatable = 1;
8442 dummy_desc = gfc_conv_scalar_to_descriptor (&se, dest, attr);
8443 gfc_add_block_to_block (&globalblock, &se.pre);
8444 size = TYPE_SIZE_UNIT (TREE_TYPE (type));
8445
8446 gfc_add_modify (&block, dest, fold_convert (type, null_pointer_node));
8447 gfc_allocate_using_caf_lib (&block, dummy_desc, size,
8448 gfc_build_addr_expr (NULL_TREE, dest_tok),
8449 NULL_TREE, NULL_TREE, NULL_TREE,
8450 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
8451 null_data = gfc_finish_block (&block);
8452
8453 gfc_init_block (&block);
8454
8455 gfc_allocate_using_caf_lib (&block, dummy_desc,
8456 fold_convert (size_type_node, size),
8457 gfc_build_addr_expr (NULL_TREE, dest_tok),
8458 NULL_TREE, NULL_TREE, NULL_TREE,
8459 GFC_CAF_COARRAY_ALLOC);
8460
8461 tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
8462 tmp = build_call_expr_loc (input_location, tmp, 3, dest, src,
8463 fold_convert (size_type_node, size));
8464 gfc_add_expr_to_block (&block, tmp);
8465 }
8466 else
8467 {
8468 /* Set the rank or unitialized memory access may be reported. */
8469 tmp = gfc_conv_descriptor_rank (dest);
8470 gfc_add_modify (&globalblock, tmp, build_int_cst (TREE_TYPE (tmp), rank));
8471
8472 if (rank)
8473 nelems = gfc_full_array_size (&block, src, rank);
8474 else
8475 nelems = integer_one_node;
8476
8477 tmp = fold_convert (size_type_node,
8478 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
8479 size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
8480 fold_convert (size_type_node, nelems), tmp);
8481
8482 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
8483 gfc_allocate_using_caf_lib (&block, dest, fold_convert (size_type_node,
8484 size),
8485 gfc_build_addr_expr (NULL_TREE, dest_tok),
8486 NULL_TREE, NULL_TREE, NULL_TREE,
8487 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
8488 null_data = gfc_finish_block (&block);
8489
8490 gfc_init_block (&block);
8491 gfc_allocate_using_caf_lib (&block, dest,
8492 fold_convert (size_type_node, size),
8493 gfc_build_addr_expr (NULL_TREE, dest_tok),
8494 NULL_TREE, NULL_TREE, NULL_TREE,
8495 GFC_CAF_COARRAY_ALLOC);
8496
8497 tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
8498 tmp = build_call_expr_loc (input_location, tmp, 3,
8499 gfc_conv_descriptor_data_get (dest),
8500 gfc_conv_descriptor_data_get (src),
8501 fold_convert (size_type_node, size));
8502 gfc_add_expr_to_block (&block, tmp);
8503 }
8504
8505 tmp = gfc_finish_block (&block);
8506
8507 /* Null the destination if the source is null; otherwise do
8508 the register and copy. */
8509 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src)))
8510 null_cond = src;
8511 else
8512 null_cond = gfc_conv_descriptor_data_get (src);
8513
8514 null_cond = convert (pvoid_type_node, null_cond);
8515 null_cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
8516 null_cond, null_pointer_node);
8517 gfc_add_expr_to_block (&globalblock, build3_v (COND_EXPR, null_cond, tmp,
8518 null_data));
8519 return gfc_finish_block (&globalblock);
8520 }
8521
8522
8523 /* Helper function to abstract whether coarray processing is enabled. */
8524
8525 static bool
caf_enabled(int caf_mode)8526 caf_enabled (int caf_mode)
8527 {
8528 return (caf_mode & GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY)
8529 == GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY;
8530 }
8531
8532
8533 /* Helper function to abstract whether coarray processing is enabled
8534 and we are in a derived type coarray. */
8535
8536 static bool
caf_in_coarray(int caf_mode)8537 caf_in_coarray (int caf_mode)
8538 {
8539 static const int pat = GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
8540 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY;
8541 return (caf_mode & pat) == pat;
8542 }
8543
8544
8545 /* Helper function to abstract whether coarray is to deallocate only. */
8546
8547 bool
gfc_caf_is_dealloc_only(int caf_mode)8548 gfc_caf_is_dealloc_only (int caf_mode)
8549 {
8550 return (caf_mode & GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY)
8551 == GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY;
8552 }
8553
8554
8555 /* Recursively traverse an object of derived type, generating code to
8556 deallocate, nullify or copy allocatable components. This is the work horse
8557 function for the functions named in this enum. */
8558
8559 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP,
8560 COPY_ALLOC_COMP, COPY_ONLY_ALLOC_COMP, REASSIGN_CAF_COMP,
8561 ALLOCATE_PDT_COMP, DEALLOCATE_PDT_COMP, CHECK_PDT_DUMMY};
8562
8563 static gfc_actual_arglist *pdt_param_list;
8564
8565 static tree
structure_alloc_comps(gfc_symbol * der_type,tree decl,tree dest,int rank,int purpose,int caf_mode)8566 structure_alloc_comps (gfc_symbol * der_type, tree decl,
8567 tree dest, int rank, int purpose, int caf_mode)
8568 {
8569 gfc_component *c;
8570 gfc_loopinfo loop;
8571 stmtblock_t fnblock;
8572 stmtblock_t loopbody;
8573 stmtblock_t tmpblock;
8574 tree decl_type;
8575 tree tmp;
8576 tree comp;
8577 tree dcmp;
8578 tree nelems;
8579 tree index;
8580 tree var;
8581 tree cdecl;
8582 tree ctype;
8583 tree vref, dref;
8584 tree null_cond = NULL_TREE;
8585 tree add_when_allocated;
8586 tree dealloc_fndecl;
8587 tree caf_token;
8588 gfc_symbol *vtab;
8589 int caf_dereg_mode;
8590 symbol_attribute *attr;
8591 bool deallocate_called;
8592
8593 gfc_init_block (&fnblock);
8594
8595 decl_type = TREE_TYPE (decl);
8596
8597 if ((POINTER_TYPE_P (decl_type))
8598 || (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == 0))
8599 {
8600 decl = build_fold_indirect_ref_loc (input_location, decl);
8601 /* Deref dest in sync with decl, but only when it is not NULL. */
8602 if (dest)
8603 dest = build_fold_indirect_ref_loc (input_location, dest);
8604
8605 /* Update the decl_type because it got dereferenced. */
8606 decl_type = TREE_TYPE (decl);
8607 }
8608
8609 /* If this is an array of derived types with allocatable components
8610 build a loop and recursively call this function. */
8611 if (TREE_CODE (decl_type) == ARRAY_TYPE
8612 || (GFC_DESCRIPTOR_TYPE_P (decl_type) && rank != 0))
8613 {
8614 tmp = gfc_conv_array_data (decl);
8615 var = build_fold_indirect_ref_loc (input_location, tmp);
8616
8617 /* Get the number of elements - 1 and set the counter. */
8618 if (GFC_DESCRIPTOR_TYPE_P (decl_type))
8619 {
8620 /* Use the descriptor for an allocatable array. Since this
8621 is a full array reference, we only need the descriptor
8622 information from dimension = rank. */
8623 tmp = gfc_full_array_size (&fnblock, decl, rank);
8624 tmp = fold_build2_loc (input_location, MINUS_EXPR,
8625 gfc_array_index_type, tmp,
8626 gfc_index_one_node);
8627
8628 null_cond = gfc_conv_descriptor_data_get (decl);
8629 null_cond = fold_build2_loc (input_location, NE_EXPR,
8630 logical_type_node, null_cond,
8631 build_int_cst (TREE_TYPE (null_cond), 0));
8632 }
8633 else
8634 {
8635 /* Otherwise use the TYPE_DOMAIN information. */
8636 tmp = array_type_nelts (decl_type);
8637 tmp = fold_convert (gfc_array_index_type, tmp);
8638 }
8639
8640 /* Remember that this is, in fact, the no. of elements - 1. */
8641 nelems = gfc_evaluate_now (tmp, &fnblock);
8642 index = gfc_create_var (gfc_array_index_type, "S");
8643
8644 /* Build the body of the loop. */
8645 gfc_init_block (&loopbody);
8646
8647 vref = gfc_build_array_ref (var, index, NULL);
8648
8649 if ((purpose == COPY_ALLOC_COMP || purpose == COPY_ONLY_ALLOC_COMP)
8650 && !caf_enabled (caf_mode))
8651 {
8652 tmp = build_fold_indirect_ref_loc (input_location,
8653 gfc_conv_array_data (dest));
8654 dref = gfc_build_array_ref (tmp, index, NULL);
8655 tmp = structure_alloc_comps (der_type, vref, dref, rank,
8656 COPY_ALLOC_COMP, 0);
8657 }
8658 else
8659 tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose,
8660 caf_mode);
8661
8662 gfc_add_expr_to_block (&loopbody, tmp);
8663
8664 /* Build the loop and return. */
8665 gfc_init_loopinfo (&loop);
8666 loop.dimen = 1;
8667 loop.from[0] = gfc_index_zero_node;
8668 loop.loopvar[0] = index;
8669 loop.to[0] = nelems;
8670 gfc_trans_scalarizing_loops (&loop, &loopbody);
8671 gfc_add_block_to_block (&fnblock, &loop.pre);
8672
8673 tmp = gfc_finish_block (&fnblock);
8674 /* When copying allocateable components, the above implements the
8675 deep copy. Nevertheless is a deep copy only allowed, when the current
8676 component is allocated, for which code will be generated in
8677 gfc_duplicate_allocatable (), where the deep copy code is just added
8678 into the if's body, by adding tmp (the deep copy code) as last
8679 argument to gfc_duplicate_allocatable (). */
8680 if (purpose == COPY_ALLOC_COMP
8681 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
8682 tmp = gfc_duplicate_allocatable (dest, decl, decl_type, rank,
8683 tmp);
8684 else if (null_cond != NULL_TREE)
8685 tmp = build3_v (COND_EXPR, null_cond, tmp,
8686 build_empty_stmt (input_location));
8687
8688 return tmp;
8689 }
8690
8691 if (purpose == DEALLOCATE_ALLOC_COMP && der_type->attr.pdt_type)
8692 {
8693 tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
8694 DEALLOCATE_PDT_COMP, 0);
8695 gfc_add_expr_to_block (&fnblock, tmp);
8696 }
8697 else if (purpose == ALLOCATE_PDT_COMP && der_type->attr.alloc_comp)
8698 {
8699 tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
8700 NULLIFY_ALLOC_COMP, 0);
8701 gfc_add_expr_to_block (&fnblock, tmp);
8702 }
8703
8704 /* Otherwise, act on the components or recursively call self to
8705 act on a chain of components. */
8706 for (c = der_type->components; c; c = c->next)
8707 {
8708 bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED
8709 || c->ts.type == BT_CLASS)
8710 && c->ts.u.derived->attr.alloc_comp;
8711 bool same_type = (c->ts.type == BT_DERIVED && der_type == c->ts.u.derived)
8712 || (c->ts.type == BT_CLASS && der_type == CLASS_DATA (c)->ts.u.derived);
8713
8714 bool is_pdt_type = c->ts.type == BT_DERIVED
8715 && c->ts.u.derived->attr.pdt_type;
8716
8717 cdecl = c->backend_decl;
8718 ctype = TREE_TYPE (cdecl);
8719
8720 switch (purpose)
8721 {
8722 case DEALLOCATE_ALLOC_COMP:
8723
8724 gfc_init_block (&tmpblock);
8725
8726 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
8727 decl, cdecl, NULL_TREE);
8728
8729 /* Shortcut to get the attributes of the component. */
8730 if (c->ts.type == BT_CLASS)
8731 {
8732 attr = &CLASS_DATA (c)->attr;
8733 if (attr->class_pointer)
8734 continue;
8735 }
8736 else
8737 {
8738 attr = &c->attr;
8739 if (attr->pointer)
8740 continue;
8741 }
8742
8743 if ((c->ts.type == BT_DERIVED && !c->attr.pointer)
8744 || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer))
8745 /* Call the finalizer, which will free the memory and nullify the
8746 pointer of an array. */
8747 deallocate_called = gfc_add_comp_finalizer_call (&tmpblock, comp, c,
8748 caf_enabled (caf_mode))
8749 && attr->dimension;
8750 else
8751 deallocate_called = false;
8752
8753 /* Add the _class ref for classes. */
8754 if (c->ts.type == BT_CLASS && attr->allocatable)
8755 comp = gfc_class_data_get (comp);
8756
8757 add_when_allocated = NULL_TREE;
8758 if (cmp_has_alloc_comps
8759 && !c->attr.pointer && !c->attr.proc_pointer
8760 && !same_type
8761 && !deallocate_called)
8762 {
8763 /* Add checked deallocation of the components. This code is
8764 obviously added because the finalizer is not trusted to free
8765 all memory. */
8766 if (c->ts.type == BT_CLASS)
8767 {
8768 rank = CLASS_DATA (c)->as ? CLASS_DATA (c)->as->rank : 0;
8769 add_when_allocated
8770 = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
8771 comp, NULL_TREE, rank, purpose,
8772 caf_mode);
8773 }
8774 else
8775 {
8776 rank = c->as ? c->as->rank : 0;
8777 add_when_allocated = structure_alloc_comps (c->ts.u.derived,
8778 comp, NULL_TREE,
8779 rank, purpose,
8780 caf_mode);
8781 }
8782 }
8783
8784 if (attr->allocatable && !same_type
8785 && (!attr->codimension || caf_enabled (caf_mode)))
8786 {
8787 /* Handle all types of components besides components of the
8788 same_type as the current one, because those would create an
8789 endless loop. */
8790 caf_dereg_mode
8791 = (caf_in_coarray (caf_mode) || attr->codimension)
8792 ? (gfc_caf_is_dealloc_only (caf_mode)
8793 ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
8794 : GFC_CAF_COARRAY_DEREGISTER)
8795 : GFC_CAF_COARRAY_NOCOARRAY;
8796
8797 caf_token = NULL_TREE;
8798 /* Coarray components are handled directly by
8799 deallocate_with_status. */
8800 if (!attr->codimension
8801 && caf_dereg_mode != GFC_CAF_COARRAY_NOCOARRAY)
8802 {
8803 if (c->caf_token)
8804 caf_token = fold_build3_loc (input_location, COMPONENT_REF,
8805 TREE_TYPE (c->caf_token),
8806 decl, c->caf_token, NULL_TREE);
8807 else if (attr->dimension && !attr->proc_pointer)
8808 caf_token = gfc_conv_descriptor_token (comp);
8809 }
8810 if (attr->dimension && !attr->codimension && !attr->proc_pointer)
8811 /* When this is an array but not in conjunction with a coarray
8812 then add the data-ref. For coarray'ed arrays the data-ref
8813 is added by deallocate_with_status. */
8814 comp = gfc_conv_descriptor_data_get (comp);
8815
8816 tmp = gfc_deallocate_with_status (comp, NULL_TREE, NULL_TREE,
8817 NULL_TREE, NULL_TREE, true,
8818 NULL, caf_dereg_mode,
8819 add_when_allocated, caf_token);
8820
8821 gfc_add_expr_to_block (&tmpblock, tmp);
8822 }
8823 else if (attr->allocatable && !attr->codimension
8824 && !deallocate_called)
8825 {
8826 /* Case of recursive allocatable derived types. */
8827 tree is_allocated;
8828 tree ubound;
8829 tree cdesc;
8830 stmtblock_t dealloc_block;
8831
8832 gfc_init_block (&dealloc_block);
8833 if (add_when_allocated)
8834 gfc_add_expr_to_block (&dealloc_block, add_when_allocated);
8835
8836 /* Convert the component into a rank 1 descriptor type. */
8837 if (attr->dimension)
8838 {
8839 tmp = gfc_get_element_type (TREE_TYPE (comp));
8840 ubound = gfc_full_array_size (&dealloc_block, comp,
8841 c->ts.type == BT_CLASS
8842 ? CLASS_DATA (c)->as->rank
8843 : c->as->rank);
8844 }
8845 else
8846 {
8847 tmp = TREE_TYPE (comp);
8848 ubound = build_int_cst (gfc_array_index_type, 1);
8849 }
8850
8851 cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node,
8852 &ubound, 1,
8853 GFC_ARRAY_ALLOCATABLE, false);
8854
8855 cdesc = gfc_create_var (cdesc, "cdesc");
8856 DECL_ARTIFICIAL (cdesc) = 1;
8857
8858 gfc_add_modify (&dealloc_block, gfc_conv_descriptor_dtype (cdesc),
8859 gfc_get_dtype_rank_type (1, tmp));
8860 gfc_conv_descriptor_lbound_set (&dealloc_block, cdesc,
8861 gfc_index_zero_node,
8862 gfc_index_one_node);
8863 gfc_conv_descriptor_stride_set (&dealloc_block, cdesc,
8864 gfc_index_zero_node,
8865 gfc_index_one_node);
8866 gfc_conv_descriptor_ubound_set (&dealloc_block, cdesc,
8867 gfc_index_zero_node, ubound);
8868
8869 if (attr->dimension)
8870 comp = gfc_conv_descriptor_data_get (comp);
8871
8872 gfc_conv_descriptor_data_set (&dealloc_block, cdesc, comp);
8873
8874 /* Now call the deallocator. */
8875 vtab = gfc_find_vtab (&c->ts);
8876 if (vtab->backend_decl == NULL)
8877 gfc_get_symbol_decl (vtab);
8878 tmp = gfc_build_addr_expr (NULL_TREE, vtab->backend_decl);
8879 dealloc_fndecl = gfc_vptr_deallocate_get (tmp);
8880 dealloc_fndecl = build_fold_indirect_ref_loc (input_location,
8881 dealloc_fndecl);
8882 tmp = build_int_cst (TREE_TYPE (comp), 0);
8883 is_allocated = fold_build2_loc (input_location, NE_EXPR,
8884 logical_type_node, tmp,
8885 comp);
8886 cdesc = gfc_build_addr_expr (NULL_TREE, cdesc);
8887
8888 tmp = build_call_expr_loc (input_location,
8889 dealloc_fndecl, 1,
8890 cdesc);
8891 gfc_add_expr_to_block (&dealloc_block, tmp);
8892
8893 tmp = gfc_finish_block (&dealloc_block);
8894
8895 tmp = fold_build3_loc (input_location, COND_EXPR,
8896 void_type_node, is_allocated, tmp,
8897 build_empty_stmt (input_location));
8898
8899 gfc_add_expr_to_block (&tmpblock, tmp);
8900 }
8901 else if (add_when_allocated)
8902 gfc_add_expr_to_block (&tmpblock, add_when_allocated);
8903
8904 if (c->ts.type == BT_CLASS && attr->allocatable
8905 && (!attr->codimension || !caf_enabled (caf_mode)))
8906 {
8907 /* Finally, reset the vptr to the declared type vtable and, if
8908 necessary reset the _len field.
8909
8910 First recover the reference to the component and obtain
8911 the vptr. */
8912 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
8913 decl, cdecl, NULL_TREE);
8914 tmp = gfc_class_vptr_get (comp);
8915
8916 if (UNLIMITED_POLY (c))
8917 {
8918 /* Both vptr and _len field should be nulled. */
8919 gfc_add_modify (&tmpblock, tmp,
8920 build_int_cst (TREE_TYPE (tmp), 0));
8921 tmp = gfc_class_len_get (comp);
8922 gfc_add_modify (&tmpblock, tmp,
8923 build_int_cst (TREE_TYPE (tmp), 0));
8924 }
8925 else
8926 {
8927 /* Build the vtable address and set the vptr with it. */
8928 tree vtab;
8929 gfc_symbol *vtable;
8930 vtable = gfc_find_derived_vtab (c->ts.u.derived);
8931 vtab = vtable->backend_decl;
8932 if (vtab == NULL_TREE)
8933 vtab = gfc_get_symbol_decl (vtable);
8934 vtab = gfc_build_addr_expr (NULL, vtab);
8935 vtab = fold_convert (TREE_TYPE (tmp), vtab);
8936 gfc_add_modify (&tmpblock, tmp, vtab);
8937 }
8938 }
8939
8940 /* Now add the deallocation of this component. */
8941 gfc_add_block_to_block (&fnblock, &tmpblock);
8942 break;
8943
8944 case NULLIFY_ALLOC_COMP:
8945 /* Nullify
8946 - allocatable components (regular or in class)
8947 - components that have allocatable components
8948 - pointer components when in a coarray.
8949 Skip everything else especially proc_pointers, which may come
8950 coupled with the regular pointer attribute. */
8951 if (c->attr.proc_pointer
8952 || !(c->attr.allocatable || (c->ts.type == BT_CLASS
8953 && CLASS_DATA (c)->attr.allocatable)
8954 || (cmp_has_alloc_comps
8955 && ((c->ts.type == BT_DERIVED && !c->attr.pointer)
8956 || (c->ts.type == BT_CLASS
8957 && !CLASS_DATA (c)->attr.class_pointer)))
8958 || (caf_in_coarray (caf_mode) && c->attr.pointer)))
8959 continue;
8960
8961 /* Process class components first, because they always have the
8962 pointer-attribute set which would be caught wrong else. */
8963 if (c->ts.type == BT_CLASS
8964 && (CLASS_DATA (c)->attr.allocatable
8965 || CLASS_DATA (c)->attr.class_pointer))
8966 {
8967 /* Allocatable CLASS components. */
8968 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
8969 decl, cdecl, NULL_TREE);
8970
8971 comp = gfc_class_data_get (comp);
8972 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
8973 gfc_conv_descriptor_data_set (&fnblock, comp,
8974 null_pointer_node);
8975 else
8976 {
8977 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
8978 void_type_node, comp,
8979 build_int_cst (TREE_TYPE (comp), 0));
8980 gfc_add_expr_to_block (&fnblock, tmp);
8981 }
8982 cmp_has_alloc_comps = false;
8983 }
8984 /* Coarrays need the component to be nulled before the api-call
8985 is made. */
8986 else if (c->attr.pointer || c->attr.allocatable)
8987 {
8988 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
8989 decl, cdecl, NULL_TREE);
8990 if (c->attr.dimension || c->attr.codimension)
8991 gfc_conv_descriptor_data_set (&fnblock, comp,
8992 null_pointer_node);
8993 else
8994 gfc_add_modify (&fnblock, comp,
8995 build_int_cst (TREE_TYPE (comp), 0));
8996 if (gfc_deferred_strlen (c, &comp))
8997 {
8998 comp = fold_build3_loc (input_location, COMPONENT_REF,
8999 TREE_TYPE (comp),
9000 decl, comp, NULL_TREE);
9001 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
9002 TREE_TYPE (comp), comp,
9003 build_int_cst (TREE_TYPE (comp), 0));
9004 gfc_add_expr_to_block (&fnblock, tmp);
9005 }
9006 cmp_has_alloc_comps = false;
9007 }
9008
9009 if (flag_coarray == GFC_FCOARRAY_LIB && caf_in_coarray (caf_mode))
9010 {
9011 /* Register a component of a derived type coarray with the
9012 coarray library. Do not register ultimate component
9013 coarrays here. They are treated like regular coarrays and
9014 are either allocated on all images or on none. */
9015 tree token;
9016
9017 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
9018 decl, cdecl, NULL_TREE);
9019 if (c->attr.dimension)
9020 {
9021 /* Set the dtype, because caf_register needs it. */
9022 gfc_add_modify (&fnblock, gfc_conv_descriptor_dtype (comp),
9023 gfc_get_dtype (TREE_TYPE (comp)));
9024 tmp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
9025 decl, cdecl, NULL_TREE);
9026 token = gfc_conv_descriptor_token (tmp);
9027 }
9028 else
9029 {
9030 gfc_se se;
9031
9032 gfc_init_se (&se, NULL);
9033 token = fold_build3_loc (input_location, COMPONENT_REF,
9034 pvoid_type_node, decl, c->caf_token,
9035 NULL_TREE);
9036 comp = gfc_conv_scalar_to_descriptor (&se, comp,
9037 c->ts.type == BT_CLASS
9038 ? CLASS_DATA (c)->attr
9039 : c->attr);
9040 gfc_add_block_to_block (&fnblock, &se.pre);
9041 }
9042
9043 gfc_allocate_using_caf_lib (&fnblock, comp, size_zero_node,
9044 gfc_build_addr_expr (NULL_TREE,
9045 token),
9046 NULL_TREE, NULL_TREE, NULL_TREE,
9047 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
9048 }
9049
9050 if (cmp_has_alloc_comps)
9051 {
9052 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
9053 decl, cdecl, NULL_TREE);
9054 rank = c->as ? c->as->rank : 0;
9055 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
9056 rank, purpose, caf_mode);
9057 gfc_add_expr_to_block (&fnblock, tmp);
9058 }
9059 break;
9060
9061 case REASSIGN_CAF_COMP:
9062 if (caf_enabled (caf_mode)
9063 && (c->attr.codimension
9064 || (c->ts.type == BT_CLASS
9065 && (CLASS_DATA (c)->attr.coarray_comp
9066 || caf_in_coarray (caf_mode)))
9067 || (c->ts.type == BT_DERIVED
9068 && (c->ts.u.derived->attr.coarray_comp
9069 || caf_in_coarray (caf_mode))))
9070 && !same_type)
9071 {
9072 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
9073 decl, cdecl, NULL_TREE);
9074 dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
9075 dest, cdecl, NULL_TREE);
9076
9077 if (c->attr.codimension)
9078 {
9079 if (c->ts.type == BT_CLASS)
9080 {
9081 comp = gfc_class_data_get (comp);
9082 dcmp = gfc_class_data_get (dcmp);
9083 }
9084 gfc_conv_descriptor_data_set (&fnblock, dcmp,
9085 gfc_conv_descriptor_data_get (comp));
9086 }
9087 else
9088 {
9089 tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
9090 rank, purpose, caf_mode
9091 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY);
9092 gfc_add_expr_to_block (&fnblock, tmp);
9093 }
9094 }
9095 break;
9096
9097 case COPY_ALLOC_COMP:
9098 if (c->attr.pointer || c->attr.proc_pointer)
9099 continue;
9100
9101 /* We need source and destination components. */
9102 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl,
9103 cdecl, NULL_TREE);
9104 dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, dest,
9105 cdecl, NULL_TREE);
9106 dcmp = fold_convert (TREE_TYPE (comp), dcmp);
9107
9108 if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
9109 {
9110 tree ftn_tree;
9111 tree size;
9112 tree dst_data;
9113 tree src_data;
9114 tree null_data;
9115
9116 dst_data = gfc_class_data_get (dcmp);
9117 src_data = gfc_class_data_get (comp);
9118 size = fold_convert (size_type_node,
9119 gfc_class_vtab_size_get (comp));
9120
9121 if (CLASS_DATA (c)->attr.dimension)
9122 {
9123 nelems = gfc_conv_descriptor_size (src_data,
9124 CLASS_DATA (c)->as->rank);
9125 size = fold_build2_loc (input_location, MULT_EXPR,
9126 size_type_node, size,
9127 fold_convert (size_type_node,
9128 nelems));
9129 }
9130 else
9131 nelems = build_int_cst (size_type_node, 1);
9132
9133 if (CLASS_DATA (c)->attr.dimension
9134 || CLASS_DATA (c)->attr.codimension)
9135 {
9136 src_data = gfc_conv_descriptor_data_get (src_data);
9137 dst_data = gfc_conv_descriptor_data_get (dst_data);
9138 }
9139
9140 gfc_init_block (&tmpblock);
9141
9142 gfc_add_modify (&tmpblock, gfc_class_vptr_get (dcmp),
9143 gfc_class_vptr_get (comp));
9144
9145 /* Copy the unlimited '_len' field. If it is greater than zero
9146 (ie. a character(_len)), multiply it by size and use this
9147 for the malloc call. */
9148 if (UNLIMITED_POLY (c))
9149 {
9150 tree ctmp;
9151 gfc_add_modify (&tmpblock, gfc_class_len_get (dcmp),
9152 gfc_class_len_get (comp));
9153
9154 size = gfc_evaluate_now (size, &tmpblock);
9155 tmp = gfc_class_len_get (comp);
9156 ctmp = fold_build2_loc (input_location, MULT_EXPR,
9157 size_type_node, size,
9158 fold_convert (size_type_node, tmp));
9159 tmp = fold_build2_loc (input_location, GT_EXPR,
9160 logical_type_node, tmp,
9161 build_zero_cst (TREE_TYPE (tmp)));
9162 size = fold_build3_loc (input_location, COND_EXPR,
9163 size_type_node, tmp, ctmp, size);
9164 size = gfc_evaluate_now (size, &tmpblock);
9165 }
9166
9167 /* Coarray component have to have the same allocation status and
9168 shape/type-parameter/effective-type on the LHS and RHS of an
9169 intrinsic assignment. Hence, we did not deallocated them - and
9170 do not allocate them here. */
9171 if (!CLASS_DATA (c)->attr.codimension)
9172 {
9173 ftn_tree = builtin_decl_explicit (BUILT_IN_MALLOC);
9174 tmp = build_call_expr_loc (input_location, ftn_tree, 1, size);
9175 gfc_add_modify (&tmpblock, dst_data,
9176 fold_convert (TREE_TYPE (dst_data), tmp));
9177 }
9178
9179 tmp = gfc_copy_class_to_class (comp, dcmp, nelems,
9180 UNLIMITED_POLY (c));
9181 gfc_add_expr_to_block (&tmpblock, tmp);
9182 tmp = gfc_finish_block (&tmpblock);
9183
9184 gfc_init_block (&tmpblock);
9185 gfc_add_modify (&tmpblock, dst_data,
9186 fold_convert (TREE_TYPE (dst_data),
9187 null_pointer_node));
9188 null_data = gfc_finish_block (&tmpblock);
9189
9190 null_cond = fold_build2_loc (input_location, NE_EXPR,
9191 logical_type_node, src_data,
9192 null_pointer_node);
9193
9194 gfc_add_expr_to_block (&fnblock, build3_v (COND_EXPR, null_cond,
9195 tmp, null_data));
9196 continue;
9197 }
9198
9199 /* To implement guarded deep copy, i.e., deep copy only allocatable
9200 components that are really allocated, the deep copy code has to
9201 be generated first and then added to the if-block in
9202 gfc_duplicate_allocatable (). */
9203 if (cmp_has_alloc_comps && !c->attr.proc_pointer && !same_type)
9204 {
9205 rank = c->as ? c->as->rank : 0;
9206 tmp = fold_convert (TREE_TYPE (dcmp), comp);
9207 gfc_add_modify (&fnblock, dcmp, tmp);
9208 add_when_allocated = structure_alloc_comps (c->ts.u.derived,
9209 comp, dcmp,
9210 rank, purpose,
9211 caf_mode);
9212 }
9213 else
9214 add_when_allocated = NULL_TREE;
9215
9216 if (gfc_deferred_strlen (c, &tmp))
9217 {
9218 tree len, size;
9219 len = tmp;
9220 tmp = fold_build3_loc (input_location, COMPONENT_REF,
9221 TREE_TYPE (len),
9222 decl, len, NULL_TREE);
9223 len = fold_build3_loc (input_location, COMPONENT_REF,
9224 TREE_TYPE (len),
9225 dest, len, NULL_TREE);
9226 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
9227 TREE_TYPE (len), len, tmp);
9228 gfc_add_expr_to_block (&fnblock, tmp);
9229 size = size_of_string_in_bytes (c->ts.kind, len);
9230 /* This component cannot have allocatable components,
9231 therefore add_when_allocated of duplicate_allocatable ()
9232 is always NULL. */
9233 tmp = duplicate_allocatable (dcmp, comp, ctype, rank,
9234 false, false, size, NULL_TREE);
9235 gfc_add_expr_to_block (&fnblock, tmp);
9236 }
9237 else if (c->attr.pdt_array)
9238 {
9239 tmp = duplicate_allocatable (dcmp, comp, ctype,
9240 c->as ? c->as->rank : 0,
9241 false, false, NULL_TREE, NULL_TREE);
9242 gfc_add_expr_to_block (&fnblock, tmp);
9243 }
9244 else if ((c->attr.allocatable)
9245 && !c->attr.proc_pointer && !same_type
9246 && (!(cmp_has_alloc_comps && c->as) || c->attr.codimension
9247 || caf_in_coarray (caf_mode)))
9248 {
9249 rank = c->as ? c->as->rank : 0;
9250 if (c->attr.codimension)
9251 tmp = gfc_copy_allocatable_data (dcmp, comp, ctype, rank);
9252 else if (flag_coarray == GFC_FCOARRAY_LIB
9253 && caf_in_coarray (caf_mode))
9254 {
9255 tree dst_tok = c->as ? gfc_conv_descriptor_token (dcmp)
9256 : fold_build3_loc (input_location,
9257 COMPONENT_REF,
9258 pvoid_type_node, dest,
9259 c->caf_token,
9260 NULL_TREE);
9261 tmp = duplicate_allocatable_coarray (dcmp, dst_tok, comp,
9262 ctype, rank);
9263 }
9264 else
9265 tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank,
9266 add_when_allocated);
9267 gfc_add_expr_to_block (&fnblock, tmp);
9268 }
9269 else
9270 if (cmp_has_alloc_comps || is_pdt_type)
9271 gfc_add_expr_to_block (&fnblock, add_when_allocated);
9272
9273 break;
9274
9275 case ALLOCATE_PDT_COMP:
9276
9277 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
9278 decl, cdecl, NULL_TREE);
9279
9280 /* Set the PDT KIND and LEN fields. */
9281 if (c->attr.pdt_kind || c->attr.pdt_len)
9282 {
9283 gfc_se tse;
9284 gfc_expr *c_expr = NULL;
9285 gfc_actual_arglist *param = pdt_param_list;
9286 gfc_init_se (&tse, NULL);
9287 for (; param; param = param->next)
9288 if (param->name && !strcmp (c->name, param->name))
9289 c_expr = param->expr;
9290
9291 if (!c_expr)
9292 c_expr = c->initializer;
9293
9294 if (c_expr)
9295 {
9296 gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp));
9297 gfc_add_modify (&fnblock, comp, tse.expr);
9298 }
9299 }
9300
9301 if (c->attr.pdt_string)
9302 {
9303 gfc_se tse;
9304 gfc_init_se (&tse, NULL);
9305 tree strlen = NULL_TREE;
9306 gfc_expr *e = gfc_copy_expr (c->ts.u.cl->length);
9307 /* Convert the parameterized string length to its value. The
9308 string length is stored in a hidden field in the same way as
9309 deferred string lengths. */
9310 gfc_insert_parameter_exprs (e, pdt_param_list);
9311 if (gfc_deferred_strlen (c, &strlen) && strlen != NULL_TREE)
9312 {
9313 gfc_conv_expr_type (&tse, e,
9314 TREE_TYPE (strlen));
9315 strlen = fold_build3_loc (input_location, COMPONENT_REF,
9316 TREE_TYPE (strlen),
9317 decl, strlen, NULL_TREE);
9318 gfc_add_modify (&fnblock, strlen, tse.expr);
9319 c->ts.u.cl->backend_decl = strlen;
9320 }
9321 gfc_free_expr (e);
9322
9323 /* Scalar parameterized strings can be allocated now. */
9324 if (!c->as)
9325 {
9326 tmp = fold_convert (gfc_array_index_type, strlen);
9327 tmp = size_of_string_in_bytes (c->ts.kind, tmp);
9328 tmp = gfc_evaluate_now (tmp, &fnblock);
9329 tmp = gfc_call_malloc (&fnblock, TREE_TYPE (comp), tmp);
9330 gfc_add_modify (&fnblock, comp, tmp);
9331 }
9332 }
9333
9334 /* Allocate parameterized arrays of parameterized derived types. */
9335 if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT)
9336 && !((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
9337 && (c->ts.u.derived && c->ts.u.derived->attr.pdt_type)))
9338 continue;
9339
9340 if (c->ts.type == BT_CLASS)
9341 comp = gfc_class_data_get (comp);
9342
9343 if (c->attr.pdt_array)
9344 {
9345 gfc_se tse;
9346 int i;
9347 tree size = gfc_index_one_node;
9348 tree offset = gfc_index_zero_node;
9349 tree lower, upper;
9350 gfc_expr *e;
9351
9352 /* This chunk takes the expressions for 'lower' and 'upper'
9353 in the arrayspec and substitutes in the expressions for
9354 the parameters from 'pdt_param_list'. The descriptor
9355 fields can then be filled from the values so obtained. */
9356 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)));
9357 for (i = 0; i < c->as->rank; i++)
9358 {
9359 gfc_init_se (&tse, NULL);
9360 e = gfc_copy_expr (c->as->lower[i]);
9361 gfc_insert_parameter_exprs (e, pdt_param_list);
9362 gfc_conv_expr_type (&tse, e, gfc_array_index_type);
9363 gfc_free_expr (e);
9364 lower = tse.expr;
9365 gfc_conv_descriptor_lbound_set (&fnblock, comp,
9366 gfc_rank_cst[i],
9367 lower);
9368 e = gfc_copy_expr (c->as->upper[i]);
9369 gfc_insert_parameter_exprs (e, pdt_param_list);
9370 gfc_conv_expr_type (&tse, e, gfc_array_index_type);
9371 gfc_free_expr (e);
9372 upper = tse.expr;
9373 gfc_conv_descriptor_ubound_set (&fnblock, comp,
9374 gfc_rank_cst[i],
9375 upper);
9376 gfc_conv_descriptor_stride_set (&fnblock, comp,
9377 gfc_rank_cst[i],
9378 size);
9379 size = gfc_evaluate_now (size, &fnblock);
9380 offset = fold_build2_loc (input_location,
9381 MINUS_EXPR,
9382 gfc_array_index_type,
9383 offset, size);
9384 offset = gfc_evaluate_now (offset, &fnblock);
9385 tmp = fold_build2_loc (input_location, MINUS_EXPR,
9386 gfc_array_index_type,
9387 upper, lower);
9388 tmp = fold_build2_loc (input_location, PLUS_EXPR,
9389 gfc_array_index_type,
9390 tmp, gfc_index_one_node);
9391 size = fold_build2_loc (input_location, MULT_EXPR,
9392 gfc_array_index_type, size, tmp);
9393 }
9394 gfc_conv_descriptor_offset_set (&fnblock, comp, offset);
9395 if (c->ts.type == BT_CLASS)
9396 {
9397 tmp = gfc_get_vptr_from_expr (comp);
9398 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
9399 tmp = build_fold_indirect_ref_loc (input_location, tmp);
9400 tmp = gfc_vptr_size_get (tmp);
9401 }
9402 else
9403 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (ctype));
9404 tmp = fold_convert (gfc_array_index_type, tmp);
9405 size = fold_build2_loc (input_location, MULT_EXPR,
9406 gfc_array_index_type, size, tmp);
9407 size = gfc_evaluate_now (size, &fnblock);
9408 tmp = gfc_call_malloc (&fnblock, NULL, size);
9409 gfc_conv_descriptor_data_set (&fnblock, comp, tmp);
9410 tmp = gfc_conv_descriptor_dtype (comp);
9411 gfc_add_modify (&fnblock, tmp, gfc_get_dtype (ctype));
9412
9413 if (c->initializer && c->initializer->rank)
9414 {
9415 gfc_init_se (&tse, NULL);
9416 e = gfc_copy_expr (c->initializer);
9417 gfc_insert_parameter_exprs (e, pdt_param_list);
9418 gfc_conv_expr_descriptor (&tse, e);
9419 gfc_add_block_to_block (&fnblock, &tse.pre);
9420 gfc_free_expr (e);
9421 tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
9422 tmp = build_call_expr_loc (input_location, tmp, 3,
9423 gfc_conv_descriptor_data_get (comp),
9424 gfc_conv_descriptor_data_get (tse.expr),
9425 fold_convert (size_type_node, size));
9426 gfc_add_expr_to_block (&fnblock, tmp);
9427 gfc_add_block_to_block (&fnblock, &tse.post);
9428 }
9429 }
9430
9431 /* Recurse in to PDT components. */
9432 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
9433 && c->ts.u.derived && c->ts.u.derived->attr.pdt_type
9434 && !(c->attr.pointer || c->attr.allocatable))
9435 {
9436 bool is_deferred = false;
9437 gfc_actual_arglist *tail = c->param_list;
9438
9439 for (; tail; tail = tail->next)
9440 if (!tail->expr)
9441 is_deferred = true;
9442
9443 tail = is_deferred ? pdt_param_list : c->param_list;
9444 tmp = gfc_allocate_pdt_comp (c->ts.u.derived, comp,
9445 c->as ? c->as->rank : 0,
9446 tail);
9447 gfc_add_expr_to_block (&fnblock, tmp);
9448 }
9449
9450 break;
9451
9452 case DEALLOCATE_PDT_COMP:
9453 /* Deallocate array or parameterized string length components
9454 of parameterized derived types. */
9455 if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT)
9456 && !c->attr.pdt_string
9457 && !((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
9458 && (c->ts.u.derived && c->ts.u.derived->attr.pdt_type)))
9459 continue;
9460
9461 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
9462 decl, cdecl, NULL_TREE);
9463 if (c->ts.type == BT_CLASS)
9464 comp = gfc_class_data_get (comp);
9465
9466 /* Recurse in to PDT components. */
9467 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
9468 && c->ts.u.derived && c->ts.u.derived->attr.pdt_type
9469 && (!c->attr.pointer && !c->attr.allocatable))
9470 {
9471 tmp = gfc_deallocate_pdt_comp (c->ts.u.derived, comp,
9472 c->as ? c->as->rank : 0);
9473 gfc_add_expr_to_block (&fnblock, tmp);
9474 }
9475
9476 if (c->attr.pdt_array)
9477 {
9478 tmp = gfc_conv_descriptor_data_get (comp);
9479 null_cond = fold_build2_loc (input_location, NE_EXPR,
9480 logical_type_node, tmp,
9481 build_int_cst (TREE_TYPE (tmp), 0));
9482 tmp = gfc_call_free (tmp);
9483 tmp = build3_v (COND_EXPR, null_cond, tmp,
9484 build_empty_stmt (input_location));
9485 gfc_add_expr_to_block (&fnblock, tmp);
9486 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
9487 }
9488 else if (c->attr.pdt_string)
9489 {
9490 null_cond = fold_build2_loc (input_location, NE_EXPR,
9491 logical_type_node, comp,
9492 build_int_cst (TREE_TYPE (comp), 0));
9493 tmp = gfc_call_free (comp);
9494 tmp = build3_v (COND_EXPR, null_cond, tmp,
9495 build_empty_stmt (input_location));
9496 gfc_add_expr_to_block (&fnblock, tmp);
9497 tmp = fold_convert (TREE_TYPE (comp), null_pointer_node);
9498 gfc_add_modify (&fnblock, comp, tmp);
9499 }
9500
9501 break;
9502
9503 case CHECK_PDT_DUMMY:
9504
9505 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
9506 decl, cdecl, NULL_TREE);
9507 if (c->ts.type == BT_CLASS)
9508 comp = gfc_class_data_get (comp);
9509
9510 /* Recurse in to PDT components. */
9511 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
9512 && c->ts.u.derived && c->ts.u.derived->attr.pdt_type)
9513 {
9514 tmp = gfc_check_pdt_dummy (c->ts.u.derived, comp,
9515 c->as ? c->as->rank : 0,
9516 pdt_param_list);
9517 gfc_add_expr_to_block (&fnblock, tmp);
9518 }
9519
9520 if (!c->attr.pdt_len)
9521 continue;
9522 else
9523 {
9524 gfc_se tse;
9525 gfc_expr *c_expr = NULL;
9526 gfc_actual_arglist *param = pdt_param_list;
9527
9528 gfc_init_se (&tse, NULL);
9529 for (; param; param = param->next)
9530 if (!strcmp (c->name, param->name)
9531 && param->spec_type == SPEC_EXPLICIT)
9532 c_expr = param->expr;
9533
9534 if (c_expr)
9535 {
9536 tree error, cond, cname;
9537 gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp));
9538 cond = fold_build2_loc (input_location, NE_EXPR,
9539 logical_type_node,
9540 comp, tse.expr);
9541 cname = gfc_build_cstring_const (c->name);
9542 cname = gfc_build_addr_expr (pchar_type_node, cname);
9543 error = gfc_trans_runtime_error (true, NULL,
9544 "The value of the PDT LEN "
9545 "parameter '%s' does not "
9546 "agree with that in the "
9547 "dummy declaration",
9548 cname);
9549 tmp = fold_build3_loc (input_location, COND_EXPR,
9550 void_type_node, cond, error,
9551 build_empty_stmt (input_location));
9552 gfc_add_expr_to_block (&fnblock, tmp);
9553 }
9554 }
9555 break;
9556
9557 default:
9558 gcc_unreachable ();
9559 break;
9560 }
9561 }
9562
9563 return gfc_finish_block (&fnblock);
9564 }
9565
9566 /* Recursively traverse an object of derived type, generating code to
9567 nullify allocatable components. */
9568
9569 tree
gfc_nullify_alloc_comp(gfc_symbol * der_type,tree decl,int rank,int caf_mode)9570 gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
9571 int caf_mode)
9572 {
9573 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
9574 NULLIFY_ALLOC_COMP,
9575 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode);
9576 }
9577
9578
9579 /* Recursively traverse an object of derived type, generating code to
9580 deallocate allocatable components. */
9581
9582 tree
gfc_deallocate_alloc_comp(gfc_symbol * der_type,tree decl,int rank,int caf_mode)9583 gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
9584 int caf_mode)
9585 {
9586 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
9587 DEALLOCATE_ALLOC_COMP,
9588 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode);
9589 }
9590
9591
9592 /* Recursively traverse an object of derived type, generating code to
9593 deallocate allocatable components. But do not deallocate coarrays.
9594 To be used for intrinsic assignment, which may not change the allocation
9595 status of coarrays. */
9596
9597 tree
gfc_deallocate_alloc_comp_no_caf(gfc_symbol * der_type,tree decl,int rank)9598 gfc_deallocate_alloc_comp_no_caf (gfc_symbol * der_type, tree decl, int rank)
9599 {
9600 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
9601 DEALLOCATE_ALLOC_COMP, 0);
9602 }
9603
9604
9605 tree
gfc_reassign_alloc_comp_caf(gfc_symbol * der_type,tree decl,tree dest)9606 gfc_reassign_alloc_comp_caf (gfc_symbol *der_type, tree decl, tree dest)
9607 {
9608 return structure_alloc_comps (der_type, decl, dest, 0, REASSIGN_CAF_COMP,
9609 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY);
9610 }
9611
9612
9613 /* Recursively traverse an object of derived type, generating code to
9614 copy it and its allocatable components. */
9615
9616 tree
gfc_copy_alloc_comp(gfc_symbol * der_type,tree decl,tree dest,int rank,int caf_mode)9617 gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank,
9618 int caf_mode)
9619 {
9620 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP,
9621 caf_mode);
9622 }
9623
9624
9625 /* Recursively traverse an object of derived type, generating code to
9626 copy only its allocatable components. */
9627
9628 tree
gfc_copy_only_alloc_comp(gfc_symbol * der_type,tree decl,tree dest,int rank)9629 gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
9630 {
9631 return structure_alloc_comps (der_type, decl, dest, rank,
9632 COPY_ONLY_ALLOC_COMP, 0);
9633 }
9634
9635
9636 /* Recursively traverse an object of paramterized derived type, generating
9637 code to allocate parameterized components. */
9638
9639 tree
gfc_allocate_pdt_comp(gfc_symbol * der_type,tree decl,int rank,gfc_actual_arglist * param_list)9640 gfc_allocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank,
9641 gfc_actual_arglist *param_list)
9642 {
9643 tree res;
9644 gfc_actual_arglist *old_param_list = pdt_param_list;
9645 pdt_param_list = param_list;
9646 res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
9647 ALLOCATE_PDT_COMP, 0);
9648 pdt_param_list = old_param_list;
9649 return res;
9650 }
9651
9652 /* Recursively traverse an object of paramterized derived type, generating
9653 code to deallocate parameterized components. */
9654
9655 tree
gfc_deallocate_pdt_comp(gfc_symbol * der_type,tree decl,int rank)9656 gfc_deallocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank)
9657 {
9658 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
9659 DEALLOCATE_PDT_COMP, 0);
9660 }
9661
9662
9663 /* Recursively traverse a dummy of paramterized derived type to check the
9664 values of LEN parameters. */
9665
9666 tree
gfc_check_pdt_dummy(gfc_symbol * der_type,tree decl,int rank,gfc_actual_arglist * param_list)9667 gfc_check_pdt_dummy (gfc_symbol * der_type, tree decl, int rank,
9668 gfc_actual_arglist *param_list)
9669 {
9670 tree res;
9671 gfc_actual_arglist *old_param_list = pdt_param_list;
9672 pdt_param_list = param_list;
9673 res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
9674 CHECK_PDT_DUMMY, 0);
9675 pdt_param_list = old_param_list;
9676 return res;
9677 }
9678
9679
9680 /* Returns the value of LBOUND for an expression. This could be broken out
9681 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
9682 called by gfc_alloc_allocatable_for_assignment. */
9683 static tree
get_std_lbound(gfc_expr * expr,tree desc,int dim,bool assumed_size)9684 get_std_lbound (gfc_expr *expr, tree desc, int dim, bool assumed_size)
9685 {
9686 tree lbound;
9687 tree ubound;
9688 tree stride;
9689 tree cond, cond1, cond3, cond4;
9690 tree tmp;
9691 gfc_ref *ref;
9692
9693 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
9694 {
9695 tmp = gfc_rank_cst[dim];
9696 lbound = gfc_conv_descriptor_lbound_get (desc, tmp);
9697 ubound = gfc_conv_descriptor_ubound_get (desc, tmp);
9698 stride = gfc_conv_descriptor_stride_get (desc, tmp);
9699 cond1 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
9700 ubound, lbound);
9701 cond3 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
9702 stride, gfc_index_zero_node);
9703 cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9704 logical_type_node, cond3, cond1);
9705 cond4 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
9706 stride, gfc_index_zero_node);
9707 if (assumed_size)
9708 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
9709 tmp, build_int_cst (gfc_array_index_type,
9710 expr->rank - 1));
9711 else
9712 cond = logical_false_node;
9713
9714 cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
9715 logical_type_node, cond3, cond4);
9716 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
9717 logical_type_node, cond, cond1);
9718
9719 return fold_build3_loc (input_location, COND_EXPR,
9720 gfc_array_index_type, cond,
9721 lbound, gfc_index_one_node);
9722 }
9723
9724 if (expr->expr_type == EXPR_FUNCTION)
9725 {
9726 /* A conversion function, so use the argument. */
9727 gcc_assert (expr->value.function.isym
9728 && expr->value.function.isym->conversion);
9729 expr = expr->value.function.actual->expr;
9730 }
9731
9732 if (expr->expr_type == EXPR_VARIABLE)
9733 {
9734 tmp = TREE_TYPE (expr->symtree->n.sym->backend_decl);
9735 for (ref = expr->ref; ref; ref = ref->next)
9736 {
9737 if (ref->type == REF_COMPONENT
9738 && ref->u.c.component->as
9739 && ref->next
9740 && ref->next->u.ar.type == AR_FULL)
9741 tmp = TREE_TYPE (ref->u.c.component->backend_decl);
9742 }
9743 return GFC_TYPE_ARRAY_LBOUND(tmp, dim);
9744 }
9745
9746 return gfc_index_one_node;
9747 }
9748
9749
9750 /* Returns true if an expression represents an lhs that can be reallocated
9751 on assignment. */
9752
9753 bool
gfc_is_reallocatable_lhs(gfc_expr * expr)9754 gfc_is_reallocatable_lhs (gfc_expr *expr)
9755 {
9756 gfc_ref * ref;
9757 gfc_symbol *sym;
9758
9759 if (!expr->ref)
9760 return false;
9761
9762 sym = expr->symtree->n.sym;
9763
9764 if (sym->attr.associate_var && !expr->ref)
9765 return false;
9766
9767 /* An allocatable class variable with no reference. */
9768 if (sym->ts.type == BT_CLASS
9769 && !sym->attr.associate_var
9770 && CLASS_DATA (sym)->attr.allocatable
9771 && expr->ref
9772 && ((expr->ref->type == REF_ARRAY && expr->ref->u.ar.type == AR_FULL
9773 && expr->ref->next == NULL)
9774 || (expr->ref->type == REF_COMPONENT
9775 && strcmp (expr->ref->u.c.component->name, "_data") == 0
9776 && (expr->ref->next == NULL
9777 || (expr->ref->next->type == REF_ARRAY
9778 && expr->ref->next->u.ar.type == AR_FULL
9779 && expr->ref->next->next == NULL)))))
9780 return true;
9781
9782 /* An allocatable variable. */
9783 if (sym->attr.allocatable
9784 && !sym->attr.associate_var
9785 && expr->ref
9786 && expr->ref->type == REF_ARRAY
9787 && expr->ref->u.ar.type == AR_FULL)
9788 return true;
9789
9790 /* All that can be left are allocatable components. */
9791 if ((sym->ts.type != BT_DERIVED
9792 && sym->ts.type != BT_CLASS)
9793 || !sym->ts.u.derived->attr.alloc_comp)
9794 return false;
9795
9796 /* Find a component ref followed by an array reference. */
9797 for (ref = expr->ref; ref; ref = ref->next)
9798 if (ref->next
9799 && ref->type == REF_COMPONENT
9800 && ref->next->type == REF_ARRAY
9801 && !ref->next->next)
9802 break;
9803
9804 if (!ref)
9805 return false;
9806
9807 /* Return true if valid reallocatable lhs. */
9808 if (ref->u.c.component->attr.allocatable
9809 && ref->next->u.ar.type == AR_FULL)
9810 return true;
9811
9812 return false;
9813 }
9814
9815
9816 static tree
concat_str_length(gfc_expr * expr)9817 concat_str_length (gfc_expr* expr)
9818 {
9819 tree type;
9820 tree len1;
9821 tree len2;
9822 gfc_se se;
9823
9824 type = gfc_typenode_for_spec (&expr->value.op.op1->ts);
9825 len1 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
9826 if (len1 == NULL_TREE)
9827 {
9828 if (expr->value.op.op1->expr_type == EXPR_OP)
9829 len1 = concat_str_length (expr->value.op.op1);
9830 else if (expr->value.op.op1->expr_type == EXPR_CONSTANT)
9831 len1 = build_int_cst (gfc_charlen_type_node,
9832 expr->value.op.op1->value.character.length);
9833 else if (expr->value.op.op1->ts.u.cl->length)
9834 {
9835 gfc_init_se (&se, NULL);
9836 gfc_conv_expr (&se, expr->value.op.op1->ts.u.cl->length);
9837 len1 = se.expr;
9838 }
9839 else
9840 {
9841 /* Last resort! */
9842 gfc_init_se (&se, NULL);
9843 se.want_pointer = 1;
9844 se.descriptor_only = 1;
9845 gfc_conv_expr (&se, expr->value.op.op1);
9846 len1 = se.string_length;
9847 }
9848 }
9849
9850 type = gfc_typenode_for_spec (&expr->value.op.op2->ts);
9851 len2 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
9852 if (len2 == NULL_TREE)
9853 {
9854 if (expr->value.op.op2->expr_type == EXPR_OP)
9855 len2 = concat_str_length (expr->value.op.op2);
9856 else if (expr->value.op.op2->expr_type == EXPR_CONSTANT)
9857 len2 = build_int_cst (gfc_charlen_type_node,
9858 expr->value.op.op2->value.character.length);
9859 else if (expr->value.op.op2->ts.u.cl->length)
9860 {
9861 gfc_init_se (&se, NULL);
9862 gfc_conv_expr (&se, expr->value.op.op2->ts.u.cl->length);
9863 len2 = se.expr;
9864 }
9865 else
9866 {
9867 /* Last resort! */
9868 gfc_init_se (&se, NULL);
9869 se.want_pointer = 1;
9870 se.descriptor_only = 1;
9871 gfc_conv_expr (&se, expr->value.op.op2);
9872 len2 = se.string_length;
9873 }
9874 }
9875
9876 gcc_assert(len1 && len2);
9877 len1 = fold_convert (gfc_charlen_type_node, len1);
9878 len2 = fold_convert (gfc_charlen_type_node, len2);
9879
9880 return fold_build2_loc (input_location, PLUS_EXPR,
9881 gfc_charlen_type_node, len1, len2);
9882 }
9883
9884
9885 /* Allocate the lhs of an assignment to an allocatable array, otherwise
9886 reallocate it. */
9887
9888 tree
gfc_alloc_allocatable_for_assignment(gfc_loopinfo * loop,gfc_expr * expr1,gfc_expr * expr2)9889 gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
9890 gfc_expr *expr1,
9891 gfc_expr *expr2)
9892 {
9893 stmtblock_t realloc_block;
9894 stmtblock_t alloc_block;
9895 stmtblock_t fblock;
9896 gfc_ss *rss;
9897 gfc_ss *lss;
9898 gfc_array_info *linfo;
9899 tree realloc_expr;
9900 tree alloc_expr;
9901 tree size1;
9902 tree size2;
9903 tree array1;
9904 tree cond_null;
9905 tree cond;
9906 tree tmp;
9907 tree tmp2;
9908 tree lbound;
9909 tree ubound;
9910 tree desc;
9911 tree old_desc;
9912 tree desc2;
9913 tree offset;
9914 tree jump_label1;
9915 tree jump_label2;
9916 tree neq_size;
9917 tree lbd;
9918 int n;
9919 int dim;
9920 gfc_array_spec * as;
9921 bool coarray = (flag_coarray == GFC_FCOARRAY_LIB
9922 && gfc_caf_attr (expr1, true).codimension);
9923 tree token;
9924 gfc_se caf_se;
9925
9926 /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
9927 Find the lhs expression in the loop chain and set expr1 and
9928 expr2 accordingly. */
9929 if (expr1->expr_type == EXPR_FUNCTION && expr2 == NULL)
9930 {
9931 expr2 = expr1;
9932 /* Find the ss for the lhs. */
9933 lss = loop->ss;
9934 for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
9935 if (lss->info->expr && lss->info->expr->expr_type == EXPR_VARIABLE)
9936 break;
9937 if (lss == gfc_ss_terminator)
9938 return NULL_TREE;
9939 expr1 = lss->info->expr;
9940 }
9941
9942 /* Bail out if this is not a valid allocate on assignment. */
9943 if (!gfc_is_reallocatable_lhs (expr1)
9944 || (expr2 && !expr2->rank))
9945 return NULL_TREE;
9946
9947 /* Find the ss for the lhs. */
9948 lss = loop->ss;
9949 for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
9950 if (lss->info->expr == expr1)
9951 break;
9952
9953 if (lss == gfc_ss_terminator)
9954 return NULL_TREE;
9955
9956 linfo = &lss->info->data.array;
9957
9958 /* Find an ss for the rhs. For operator expressions, we see the
9959 ss's for the operands. Any one of these will do. */
9960 rss = loop->ss;
9961 for (; rss && rss != gfc_ss_terminator; rss = rss->loop_chain)
9962 if (rss->info->expr != expr1 && rss != loop->temp_ss)
9963 break;
9964
9965 if (expr2 && rss == gfc_ss_terminator)
9966 return NULL_TREE;
9967
9968 /* Ensure that the string length from the current scope is used. */
9969 if (expr2->ts.type == BT_CHARACTER
9970 && expr2->expr_type == EXPR_FUNCTION
9971 && !expr2->value.function.isym)
9972 expr2->ts.u.cl->backend_decl = rss->info->string_length;
9973
9974 gfc_start_block (&fblock);
9975
9976 /* Since the lhs is allocatable, this must be a descriptor type.
9977 Get the data and array size. */
9978 desc = linfo->descriptor;
9979 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
9980 array1 = gfc_conv_descriptor_data_get (desc);
9981
9982 /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
9983 deallocated if expr is an array of different shape or any of the
9984 corresponding length type parameter values of variable and expr
9985 differ." This assures F95 compatibility. */
9986 jump_label1 = gfc_build_label_decl (NULL_TREE);
9987 jump_label2 = gfc_build_label_decl (NULL_TREE);
9988
9989 /* Allocate if data is NULL. */
9990 cond_null = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
9991 array1, build_int_cst (TREE_TYPE (array1), 0));
9992
9993 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
9994 {
9995 tmp = fold_build2_loc (input_location, NE_EXPR,
9996 logical_type_node,
9997 lss->info->string_length,
9998 rss->info->string_length);
9999 cond_null = fold_build2_loc (input_location, TRUTH_OR_EXPR,
10000 logical_type_node, tmp, cond_null);
10001 }
10002 else
10003 cond_null= gfc_evaluate_now (cond_null, &fblock);
10004
10005 tmp = build3_v (COND_EXPR, cond_null,
10006 build1_v (GOTO_EXPR, jump_label1),
10007 build_empty_stmt (input_location));
10008 gfc_add_expr_to_block (&fblock, tmp);
10009
10010 /* Get arrayspec if expr is a full array. */
10011 if (expr2 && expr2->expr_type == EXPR_FUNCTION
10012 && expr2->value.function.isym
10013 && expr2->value.function.isym->conversion)
10014 {
10015 /* For conversion functions, take the arg. */
10016 gfc_expr *arg = expr2->value.function.actual->expr;
10017 as = gfc_get_full_arrayspec_from_expr (arg);
10018 }
10019 else if (expr2)
10020 as = gfc_get_full_arrayspec_from_expr (expr2);
10021 else
10022 as = NULL;
10023
10024 /* If the lhs shape is not the same as the rhs jump to setting the
10025 bounds and doing the reallocation....... */
10026 for (n = 0; n < expr1->rank; n++)
10027 {
10028 /* Check the shape. */
10029 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
10030 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
10031 tmp = fold_build2_loc (input_location, MINUS_EXPR,
10032 gfc_array_index_type,
10033 loop->to[n], loop->from[n]);
10034 tmp = fold_build2_loc (input_location, PLUS_EXPR,
10035 gfc_array_index_type,
10036 tmp, lbound);
10037 tmp = fold_build2_loc (input_location, MINUS_EXPR,
10038 gfc_array_index_type,
10039 tmp, ubound);
10040 cond = fold_build2_loc (input_location, NE_EXPR,
10041 logical_type_node,
10042 tmp, gfc_index_zero_node);
10043 tmp = build3_v (COND_EXPR, cond,
10044 build1_v (GOTO_EXPR, jump_label1),
10045 build_empty_stmt (input_location));
10046 gfc_add_expr_to_block (&fblock, tmp);
10047 }
10048
10049 /* ....else jump past the (re)alloc code. */
10050 tmp = build1_v (GOTO_EXPR, jump_label2);
10051 gfc_add_expr_to_block (&fblock, tmp);
10052
10053 /* Add the label to start automatic (re)allocation. */
10054 tmp = build1_v (LABEL_EXPR, jump_label1);
10055 gfc_add_expr_to_block (&fblock, tmp);
10056
10057 /* If the lhs has not been allocated, its bounds will not have been
10058 initialized and so its size is set to zero. */
10059 size1 = gfc_create_var (gfc_array_index_type, NULL);
10060 gfc_init_block (&alloc_block);
10061 gfc_add_modify (&alloc_block, size1, gfc_index_zero_node);
10062 gfc_init_block (&realloc_block);
10063 gfc_add_modify (&realloc_block, size1,
10064 gfc_conv_descriptor_size (desc, expr1->rank));
10065 tmp = build3_v (COND_EXPR, cond_null,
10066 gfc_finish_block (&alloc_block),
10067 gfc_finish_block (&realloc_block));
10068 gfc_add_expr_to_block (&fblock, tmp);
10069
10070 /* Get the rhs size and fix it. */
10071 if (expr2)
10072 desc2 = rss->info->data.array.descriptor;
10073 else
10074 desc2 = NULL_TREE;
10075
10076 size2 = gfc_index_one_node;
10077 for (n = 0; n < expr2->rank; n++)
10078 {
10079 tmp = fold_build2_loc (input_location, MINUS_EXPR,
10080 gfc_array_index_type,
10081 loop->to[n], loop->from[n]);
10082 tmp = fold_build2_loc (input_location, PLUS_EXPR,
10083 gfc_array_index_type,
10084 tmp, gfc_index_one_node);
10085 size2 = fold_build2_loc (input_location, MULT_EXPR,
10086 gfc_array_index_type,
10087 tmp, size2);
10088 }
10089 size2 = gfc_evaluate_now (size2, &fblock);
10090
10091 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10092 size1, size2);
10093
10094 /* If the lhs is deferred length, assume that the element size
10095 changes and force a reallocation. */
10096 if (expr1->ts.deferred)
10097 neq_size = gfc_evaluate_now (logical_true_node, &fblock);
10098 else
10099 neq_size = gfc_evaluate_now (cond, &fblock);
10100
10101 /* Deallocation of allocatable components will have to occur on
10102 reallocation. Fix the old descriptor now. */
10103 if ((expr1->ts.type == BT_DERIVED)
10104 && expr1->ts.u.derived->attr.alloc_comp)
10105 old_desc = gfc_evaluate_now (desc, &fblock);
10106 else
10107 old_desc = NULL_TREE;
10108
10109 /* Now modify the lhs descriptor and the associated scalarizer
10110 variables. F2003 7.4.1.3: "If variable is or becomes an
10111 unallocated allocatable variable, then it is allocated with each
10112 deferred type parameter equal to the corresponding type parameters
10113 of expr , with the shape of expr , and with each lower bound equal
10114 to the corresponding element of LBOUND(expr)."
10115 Reuse size1 to keep a dimension-by-dimension track of the
10116 stride of the new array. */
10117 size1 = gfc_index_one_node;
10118 offset = gfc_index_zero_node;
10119
10120 for (n = 0; n < expr2->rank; n++)
10121 {
10122 tmp = fold_build2_loc (input_location, MINUS_EXPR,
10123 gfc_array_index_type,
10124 loop->to[n], loop->from[n]);
10125 tmp = fold_build2_loc (input_location, PLUS_EXPR,
10126 gfc_array_index_type,
10127 tmp, gfc_index_one_node);
10128
10129 lbound = gfc_index_one_node;
10130 ubound = tmp;
10131
10132 if (as)
10133 {
10134 lbd = get_std_lbound (expr2, desc2, n,
10135 as->type == AS_ASSUMED_SIZE);
10136 ubound = fold_build2_loc (input_location,
10137 MINUS_EXPR,
10138 gfc_array_index_type,
10139 ubound, lbound);
10140 ubound = fold_build2_loc (input_location,
10141 PLUS_EXPR,
10142 gfc_array_index_type,
10143 ubound, lbd);
10144 lbound = lbd;
10145 }
10146
10147 gfc_conv_descriptor_lbound_set (&fblock, desc,
10148 gfc_rank_cst[n],
10149 lbound);
10150 gfc_conv_descriptor_ubound_set (&fblock, desc,
10151 gfc_rank_cst[n],
10152 ubound);
10153 gfc_conv_descriptor_stride_set (&fblock, desc,
10154 gfc_rank_cst[n],
10155 size1);
10156 lbound = gfc_conv_descriptor_lbound_get (desc,
10157 gfc_rank_cst[n]);
10158 tmp2 = fold_build2_loc (input_location, MULT_EXPR,
10159 gfc_array_index_type,
10160 lbound, size1);
10161 offset = fold_build2_loc (input_location, MINUS_EXPR,
10162 gfc_array_index_type,
10163 offset, tmp2);
10164 size1 = fold_build2_loc (input_location, MULT_EXPR,
10165 gfc_array_index_type,
10166 tmp, size1);
10167 }
10168
10169 /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
10170 the array offset is saved and the info.offset is used for a
10171 running offset. Use the saved_offset instead. */
10172 tmp = gfc_conv_descriptor_offset (desc);
10173 gfc_add_modify (&fblock, tmp, offset);
10174 if (linfo->saved_offset
10175 && VAR_P (linfo->saved_offset))
10176 gfc_add_modify (&fblock, linfo->saved_offset, tmp);
10177
10178 /* Now set the deltas for the lhs. */
10179 for (n = 0; n < expr1->rank; n++)
10180 {
10181 tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
10182 dim = lss->dim[n];
10183 tmp = fold_build2_loc (input_location, MINUS_EXPR,
10184 gfc_array_index_type, tmp,
10185 loop->from[dim]);
10186 if (linfo->delta[dim] && VAR_P (linfo->delta[dim]))
10187 gfc_add_modify (&fblock, linfo->delta[dim], tmp);
10188 }
10189
10190 /* Get the new lhs size in bytes. */
10191 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
10192 {
10193 if (expr2->ts.deferred)
10194 {
10195 if (expr2->ts.u.cl->backend_decl
10196 && VAR_P (expr2->ts.u.cl->backend_decl))
10197 tmp = expr2->ts.u.cl->backend_decl;
10198 else
10199 tmp = rss->info->string_length;
10200 }
10201 else
10202 {
10203 tmp = expr2->ts.u.cl->backend_decl;
10204 if (!tmp && expr2->expr_type == EXPR_OP
10205 && expr2->value.op.op == INTRINSIC_CONCAT)
10206 {
10207 tmp = concat_str_length (expr2);
10208 expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
10209 }
10210 else if (!tmp && expr2->ts.u.cl->length)
10211 {
10212 gfc_se tmpse;
10213 gfc_init_se (&tmpse, NULL);
10214 gfc_conv_expr_type (&tmpse, expr2->ts.u.cl->length,
10215 gfc_charlen_type_node);
10216 tmp = tmpse.expr;
10217 expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
10218 }
10219 tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
10220 }
10221
10222 if (expr1->ts.u.cl->backend_decl
10223 && VAR_P (expr1->ts.u.cl->backend_decl))
10224 gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
10225 else
10226 gfc_add_modify (&fblock, lss->info->string_length, tmp);
10227
10228 if (expr1->ts.kind > 1)
10229 tmp = fold_build2_loc (input_location, MULT_EXPR,
10230 TREE_TYPE (tmp),
10231 tmp, build_int_cst (TREE_TYPE (tmp),
10232 expr1->ts.kind));
10233 }
10234 else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
10235 {
10236 tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts)));
10237 tmp = fold_build2_loc (input_location, MULT_EXPR,
10238 gfc_array_index_type, tmp,
10239 expr1->ts.u.cl->backend_decl);
10240 }
10241 else if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS)
10242 tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
10243 else
10244 tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
10245 tmp = fold_convert (gfc_array_index_type, tmp);
10246
10247 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
10248 gfc_conv_descriptor_span_set (&fblock, desc, tmp);
10249
10250 size2 = fold_build2_loc (input_location, MULT_EXPR,
10251 gfc_array_index_type,
10252 tmp, size2);
10253 size2 = fold_convert (size_type_node, size2);
10254 size2 = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
10255 size2, size_one_node);
10256 size2 = gfc_evaluate_now (size2, &fblock);
10257
10258 /* For deferred character length, the 'size' field of the dtype might
10259 have changed so set the dtype. */
10260 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
10261 && expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
10262 {
10263 tree type;
10264 tmp = gfc_conv_descriptor_dtype (desc);
10265 if (expr2->ts.u.cl->backend_decl)
10266 type = gfc_typenode_for_spec (&expr2->ts);
10267 else
10268 type = gfc_typenode_for_spec (&expr1->ts);
10269
10270 gfc_add_modify (&fblock, tmp,
10271 gfc_get_dtype_rank_type (expr1->rank,type));
10272 }
10273 else if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS)
10274 {
10275 tree type;
10276 tmp = gfc_conv_descriptor_dtype (desc);
10277 type = gfc_typenode_for_spec (&expr2->ts);
10278 gfc_add_modify (&fblock, tmp,
10279 gfc_get_dtype_rank_type (expr2->rank,type));
10280 /* Set the _len field as well... */
10281 tmp = gfc_class_len_get (TREE_OPERAND (desc, 0));
10282 if (expr2->ts.type == BT_CHARACTER)
10283 gfc_add_modify (&fblock, tmp,
10284 fold_convert (TREE_TYPE (tmp),
10285 TYPE_SIZE_UNIT (type)));
10286 else
10287 gfc_add_modify (&fblock, tmp,
10288 build_int_cst (TREE_TYPE (tmp), 0));
10289 /* ...and the vptr. */
10290 tmp = gfc_class_vptr_get (TREE_OPERAND (desc, 0));
10291 tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts));
10292 tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2);
10293 gfc_add_modify (&fblock, tmp, tmp2);
10294 }
10295 else if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
10296 {
10297 gfc_add_modify (&fblock, gfc_conv_descriptor_dtype (desc),
10298 gfc_get_dtype (TREE_TYPE (desc)));
10299 }
10300
10301 /* Realloc expression. Note that the scalarizer uses desc.data
10302 in the array reference - (*desc.data)[<element>]. */
10303 gfc_init_block (&realloc_block);
10304 gfc_init_se (&caf_se, NULL);
10305
10306 if (coarray)
10307 {
10308 token = gfc_get_ultimate_alloc_ptr_comps_caf_token (&caf_se, expr1);
10309 if (token == NULL_TREE)
10310 {
10311 tmp = gfc_get_tree_for_caf_expr (expr1);
10312 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
10313 tmp = build_fold_indirect_ref (tmp);
10314 gfc_get_caf_token_offset (&caf_se, &token, NULL, tmp, NULL_TREE,
10315 expr1);
10316 token = gfc_build_addr_expr (NULL_TREE, token);
10317 }
10318
10319 gfc_add_block_to_block (&realloc_block, &caf_se.pre);
10320 }
10321 if ((expr1->ts.type == BT_DERIVED)
10322 && expr1->ts.u.derived->attr.alloc_comp)
10323 {
10324 tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, old_desc,
10325 expr1->rank);
10326 gfc_add_expr_to_block (&realloc_block, tmp);
10327 }
10328
10329 if (!coarray)
10330 {
10331 tmp = build_call_expr_loc (input_location,
10332 builtin_decl_explicit (BUILT_IN_REALLOC), 2,
10333 fold_convert (pvoid_type_node, array1),
10334 size2);
10335 gfc_conv_descriptor_data_set (&realloc_block,
10336 desc, tmp);
10337 }
10338 else
10339 {
10340 tmp = build_call_expr_loc (input_location,
10341 gfor_fndecl_caf_deregister, 5, token,
10342 build_int_cst (integer_type_node,
10343 GFC_CAF_COARRAY_DEALLOCATE_ONLY),
10344 null_pointer_node, null_pointer_node,
10345 integer_zero_node);
10346 gfc_add_expr_to_block (&realloc_block, tmp);
10347 tmp = build_call_expr_loc (input_location,
10348 gfor_fndecl_caf_register,
10349 7, size2,
10350 build_int_cst (integer_type_node,
10351 GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY),
10352 token, gfc_build_addr_expr (NULL_TREE, desc),
10353 null_pointer_node, null_pointer_node,
10354 integer_zero_node);
10355 gfc_add_expr_to_block (&realloc_block, tmp);
10356 }
10357
10358 if ((expr1->ts.type == BT_DERIVED)
10359 && expr1->ts.u.derived->attr.alloc_comp)
10360 {
10361 tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc,
10362 expr1->rank);
10363 gfc_add_expr_to_block (&realloc_block, tmp);
10364 }
10365
10366 gfc_add_block_to_block (&realloc_block, &caf_se.post);
10367 realloc_expr = gfc_finish_block (&realloc_block);
10368
10369 /* Only reallocate if sizes are different. */
10370 tmp = build3_v (COND_EXPR, neq_size, realloc_expr,
10371 build_empty_stmt (input_location));
10372 realloc_expr = tmp;
10373
10374
10375 /* Malloc expression. */
10376 gfc_init_block (&alloc_block);
10377 if (!coarray)
10378 {
10379 tmp = build_call_expr_loc (input_location,
10380 builtin_decl_explicit (BUILT_IN_MALLOC),
10381 1, size2);
10382 gfc_conv_descriptor_data_set (&alloc_block,
10383 desc, tmp);
10384 }
10385 else
10386 {
10387 tmp = build_call_expr_loc (input_location,
10388 gfor_fndecl_caf_register,
10389 7, size2,
10390 build_int_cst (integer_type_node,
10391 GFC_CAF_COARRAY_ALLOC),
10392 token, gfc_build_addr_expr (NULL_TREE, desc),
10393 null_pointer_node, null_pointer_node,
10394 integer_zero_node);
10395 gfc_add_expr_to_block (&alloc_block, tmp);
10396 }
10397
10398
10399 /* We already set the dtype in the case of deferred character
10400 length arrays and unlimited polymorphic arrays. */
10401 if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
10402 && ((expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
10403 || coarray))
10404 && !UNLIMITED_POLY (expr1))
10405 {
10406 tmp = gfc_conv_descriptor_dtype (desc);
10407 gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
10408 }
10409
10410 if ((expr1->ts.type == BT_DERIVED)
10411 && expr1->ts.u.derived->attr.alloc_comp)
10412 {
10413 tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc,
10414 expr1->rank);
10415 gfc_add_expr_to_block (&alloc_block, tmp);
10416 }
10417 alloc_expr = gfc_finish_block (&alloc_block);
10418
10419 /* Malloc if not allocated; realloc otherwise. */
10420 tmp = build_int_cst (TREE_TYPE (array1), 0);
10421 cond = fold_build2_loc (input_location, EQ_EXPR,
10422 logical_type_node,
10423 array1, tmp);
10424 tmp = build3_v (COND_EXPR, cond, alloc_expr, realloc_expr);
10425 gfc_add_expr_to_block (&fblock, tmp);
10426
10427 /* Make sure that the scalarizer data pointer is updated. */
10428 if (linfo->data && VAR_P (linfo->data))
10429 {
10430 tmp = gfc_conv_descriptor_data_get (desc);
10431 gfc_add_modify (&fblock, linfo->data, tmp);
10432 }
10433
10434 /* Add the exit label. */
10435 tmp = build1_v (LABEL_EXPR, jump_label2);
10436 gfc_add_expr_to_block (&fblock, tmp);
10437
10438 return gfc_finish_block (&fblock);
10439 }
10440
10441
10442 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
10443 Do likewise, recursively if necessary, with the allocatable components of
10444 derived types. */
10445
10446 void
gfc_trans_deferred_array(gfc_symbol * sym,gfc_wrapped_block * block)10447 gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
10448 {
10449 tree type;
10450 tree tmp;
10451 tree descriptor;
10452 stmtblock_t init;
10453 stmtblock_t cleanup;
10454 locus loc;
10455 int rank;
10456 bool sym_has_alloc_comp, has_finalizer;
10457
10458 sym_has_alloc_comp = (sym->ts.type == BT_DERIVED
10459 || sym->ts.type == BT_CLASS)
10460 && sym->ts.u.derived->attr.alloc_comp;
10461 has_finalizer = sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED
10462 ? gfc_is_finalizable (sym->ts.u.derived, NULL) : false;
10463
10464 /* Make sure the frontend gets these right. */
10465 gcc_assert (sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp
10466 || has_finalizer);
10467
10468 gfc_save_backend_locus (&loc);
10469 gfc_set_backend_locus (&sym->declared_at);
10470 gfc_init_block (&init);
10471
10472 gcc_assert (VAR_P (sym->backend_decl)
10473 || TREE_CODE (sym->backend_decl) == PARM_DECL);
10474
10475 if (sym->ts.type == BT_CHARACTER
10476 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
10477 {
10478 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
10479 gfc_trans_vla_type_sizes (sym, &init);
10480 }
10481
10482 /* Dummy, use associated and result variables don't need anything special. */
10483 if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result)
10484 {
10485 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
10486 gfc_restore_backend_locus (&loc);
10487 return;
10488 }
10489
10490 descriptor = sym->backend_decl;
10491
10492 /* Although static, derived types with default initializers and
10493 allocatable components must not be nulled wholesale; instead they
10494 are treated component by component. */
10495 if (TREE_STATIC (descriptor) && !sym_has_alloc_comp && !has_finalizer)
10496 {
10497 /* SAVEd variables are not freed on exit. */
10498 gfc_trans_static_array_pointer (sym);
10499
10500 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
10501 gfc_restore_backend_locus (&loc);
10502 return;
10503 }
10504
10505 /* Get the descriptor type. */
10506 type = TREE_TYPE (sym->backend_decl);
10507
10508 if ((sym_has_alloc_comp || (has_finalizer && sym->ts.type != BT_CLASS))
10509 && !(sym->attr.pointer || sym->attr.allocatable))
10510 {
10511 if (!sym->attr.save
10512 && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program))
10513 {
10514 if (sym->value == NULL
10515 || !gfc_has_default_initializer (sym->ts.u.derived))
10516 {
10517 rank = sym->as ? sym->as->rank : 0;
10518 tmp = gfc_nullify_alloc_comp (sym->ts.u.derived,
10519 descriptor, rank);
10520 gfc_add_expr_to_block (&init, tmp);
10521 }
10522 else
10523 gfc_init_default_dt (sym, &init, false);
10524 }
10525 }
10526 else if (!GFC_DESCRIPTOR_TYPE_P (type))
10527 {
10528 /* If the backend_decl is not a descriptor, we must have a pointer
10529 to one. */
10530 descriptor = build_fold_indirect_ref_loc (input_location,
10531 sym->backend_decl);
10532 type = TREE_TYPE (descriptor);
10533 }
10534
10535 /* NULLIFY the data pointer, for non-saved allocatables. */
10536 if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save && sym->attr.allocatable)
10537 {
10538 gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node);
10539 if (flag_coarray == GFC_FCOARRAY_LIB && sym->attr.codimension)
10540 {
10541 /* Declare the variable static so its array descriptor stays present
10542 after leaving the scope. It may still be accessed through another
10543 image. This may happen, for example, with the caf_mpi
10544 implementation. */
10545 TREE_STATIC (descriptor) = 1;
10546 tmp = gfc_conv_descriptor_token (descriptor);
10547 gfc_add_modify (&init, tmp, fold_convert (TREE_TYPE (tmp),
10548 null_pointer_node));
10549 }
10550 }
10551
10552 gfc_restore_backend_locus (&loc);
10553 gfc_init_block (&cleanup);
10554
10555 /* Allocatable arrays need to be freed when they go out of scope.
10556 The allocatable components of pointers must not be touched. */
10557 if (!sym->attr.allocatable && has_finalizer && sym->ts.type != BT_CLASS
10558 && !sym->attr.pointer && !sym->attr.artificial && !sym->attr.save
10559 && !sym->ns->proc_name->attr.is_main_program)
10560 {
10561 gfc_expr *e;
10562 sym->attr.referenced = 1;
10563 e = gfc_lval_expr_from_sym (sym);
10564 gfc_add_finalizer_call (&cleanup, e);
10565 gfc_free_expr (e);
10566 }
10567 else if ((!sym->attr.allocatable || !has_finalizer)
10568 && sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
10569 && !sym->attr.pointer && !sym->attr.save
10570 && !sym->ns->proc_name->attr.is_main_program)
10571 {
10572 int rank;
10573 rank = sym->as ? sym->as->rank : 0;
10574 tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank);
10575 gfc_add_expr_to_block (&cleanup, tmp);
10576 }
10577
10578 if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension)
10579 && !sym->attr.save && !sym->attr.result
10580 && !sym->ns->proc_name->attr.is_main_program)
10581 {
10582 gfc_expr *e;
10583 e = has_finalizer ? gfc_lval_expr_from_sym (sym) : NULL;
10584 tmp = gfc_deallocate_with_status (sym->backend_decl, NULL_TREE, NULL_TREE,
10585 NULL_TREE, NULL_TREE, true, e,
10586 sym->attr.codimension
10587 ? GFC_CAF_COARRAY_DEREGISTER
10588 : GFC_CAF_COARRAY_NOCOARRAY);
10589 if (e)
10590 gfc_free_expr (e);
10591 gfc_add_expr_to_block (&cleanup, tmp);
10592 }
10593
10594 gfc_add_init_cleanup (block, gfc_finish_block (&init),
10595 gfc_finish_block (&cleanup));
10596 }
10597
10598 /************ Expression Walking Functions ******************/
10599
10600 /* Walk a variable reference.
10601
10602 Possible extension - multiple component subscripts.
10603 x(:,:) = foo%a(:)%b(:)
10604 Transforms to
10605 forall (i=..., j=...)
10606 x(i,j) = foo%a(j)%b(i)
10607 end forall
10608 This adds a fair amount of complexity because you need to deal with more
10609 than one ref. Maybe handle in a similar manner to vector subscripts.
10610 Maybe not worth the effort. */
10611
10612
10613 static gfc_ss *
gfc_walk_variable_expr(gfc_ss * ss,gfc_expr * expr)10614 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
10615 {
10616 gfc_ref *ref;
10617
10618 gfc_fix_class_refs (expr);
10619
10620 for (ref = expr->ref; ref; ref = ref->next)
10621 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
10622 break;
10623
10624 return gfc_walk_array_ref (ss, expr, ref);
10625 }
10626
10627
10628 gfc_ss *
gfc_walk_array_ref(gfc_ss * ss,gfc_expr * expr,gfc_ref * ref)10629 gfc_walk_array_ref (gfc_ss * ss, gfc_expr * expr, gfc_ref * ref)
10630 {
10631 gfc_array_ref *ar;
10632 gfc_ss *newss;
10633 int n;
10634
10635 for (; ref; ref = ref->next)
10636 {
10637 if (ref->type == REF_SUBSTRING)
10638 {
10639 ss = gfc_get_scalar_ss (ss, ref->u.ss.start);
10640 ss = gfc_get_scalar_ss (ss, ref->u.ss.end);
10641 }
10642
10643 /* We're only interested in array sections from now on. */
10644 if (ref->type != REF_ARRAY)
10645 continue;
10646
10647 ar = &ref->u.ar;
10648
10649 switch (ar->type)
10650 {
10651 case AR_ELEMENT:
10652 for (n = ar->dimen - 1; n >= 0; n--)
10653 ss = gfc_get_scalar_ss (ss, ar->start[n]);
10654 break;
10655
10656 case AR_FULL:
10657 newss = gfc_get_array_ss (ss, expr, ar->as->rank, GFC_SS_SECTION);
10658 newss->info->data.array.ref = ref;
10659
10660 /* Make sure array is the same as array(:,:), this way
10661 we don't need to special case all the time. */
10662 ar->dimen = ar->as->rank;
10663 for (n = 0; n < ar->dimen; n++)
10664 {
10665 ar->dimen_type[n] = DIMEN_RANGE;
10666
10667 gcc_assert (ar->start[n] == NULL);
10668 gcc_assert (ar->end[n] == NULL);
10669 gcc_assert (ar->stride[n] == NULL);
10670 }
10671 ss = newss;
10672 break;
10673
10674 case AR_SECTION:
10675 newss = gfc_get_array_ss (ss, expr, 0, GFC_SS_SECTION);
10676 newss->info->data.array.ref = ref;
10677
10678 /* We add SS chains for all the subscripts in the section. */
10679 for (n = 0; n < ar->dimen; n++)
10680 {
10681 gfc_ss *indexss;
10682
10683 switch (ar->dimen_type[n])
10684 {
10685 case DIMEN_ELEMENT:
10686 /* Add SS for elemental (scalar) subscripts. */
10687 gcc_assert (ar->start[n]);
10688 indexss = gfc_get_scalar_ss (gfc_ss_terminator, ar->start[n]);
10689 indexss->loop_chain = gfc_ss_terminator;
10690 newss->info->data.array.subscript[n] = indexss;
10691 break;
10692
10693 case DIMEN_RANGE:
10694 /* We don't add anything for sections, just remember this
10695 dimension for later. */
10696 newss->dim[newss->dimen] = n;
10697 newss->dimen++;
10698 break;
10699
10700 case DIMEN_VECTOR:
10701 /* Create a GFC_SS_VECTOR index in which we can store
10702 the vector's descriptor. */
10703 indexss = gfc_get_array_ss (gfc_ss_terminator, ar->start[n],
10704 1, GFC_SS_VECTOR);
10705 indexss->loop_chain = gfc_ss_terminator;
10706 newss->info->data.array.subscript[n] = indexss;
10707 newss->dim[newss->dimen] = n;
10708 newss->dimen++;
10709 break;
10710
10711 default:
10712 /* We should know what sort of section it is by now. */
10713 gcc_unreachable ();
10714 }
10715 }
10716 /* We should have at least one non-elemental dimension,
10717 unless we are creating a descriptor for a (scalar) coarray. */
10718 gcc_assert (newss->dimen > 0
10719 || newss->info->data.array.ref->u.ar.as->corank > 0);
10720 ss = newss;
10721 break;
10722
10723 default:
10724 /* We should know what sort of section it is by now. */
10725 gcc_unreachable ();
10726 }
10727
10728 }
10729 return ss;
10730 }
10731
10732
10733 /* Walk an expression operator. If only one operand of a binary expression is
10734 scalar, we must also add the scalar term to the SS chain. */
10735
10736 static gfc_ss *
gfc_walk_op_expr(gfc_ss * ss,gfc_expr * expr)10737 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
10738 {
10739 gfc_ss *head;
10740 gfc_ss *head2;
10741
10742 head = gfc_walk_subexpr (ss, expr->value.op.op1);
10743 if (expr->value.op.op2 == NULL)
10744 head2 = head;
10745 else
10746 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
10747
10748 /* All operands are scalar. Pass back and let the caller deal with it. */
10749 if (head2 == ss)
10750 return head2;
10751
10752 /* All operands require scalarization. */
10753 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
10754 return head2;
10755
10756 /* One of the operands needs scalarization, the other is scalar.
10757 Create a gfc_ss for the scalar expression. */
10758 if (head == ss)
10759 {
10760 /* First operand is scalar. We build the chain in reverse order, so
10761 add the scalar SS after the second operand. */
10762 head = head2;
10763 while (head && head->next != ss)
10764 head = head->next;
10765 /* Check we haven't somehow broken the chain. */
10766 gcc_assert (head);
10767 head->next = gfc_get_scalar_ss (ss, expr->value.op.op1);
10768 }
10769 else /* head2 == head */
10770 {
10771 gcc_assert (head2 == head);
10772 /* Second operand is scalar. */
10773 head2 = gfc_get_scalar_ss (head2, expr->value.op.op2);
10774 }
10775
10776 return head2;
10777 }
10778
10779
10780 /* Reverse a SS chain. */
10781
10782 gfc_ss *
gfc_reverse_ss(gfc_ss * ss)10783 gfc_reverse_ss (gfc_ss * ss)
10784 {
10785 gfc_ss *next;
10786 gfc_ss *head;
10787
10788 gcc_assert (ss != NULL);
10789
10790 head = gfc_ss_terminator;
10791 while (ss != gfc_ss_terminator)
10792 {
10793 next = ss->next;
10794 /* Check we didn't somehow break the chain. */
10795 gcc_assert (next != NULL);
10796 ss->next = head;
10797 head = ss;
10798 ss = next;
10799 }
10800
10801 return (head);
10802 }
10803
10804
10805 /* Given an expression referring to a procedure, return the symbol of its
10806 interface. We can't get the procedure symbol directly as we have to handle
10807 the case of (deferred) type-bound procedures. */
10808
10809 gfc_symbol *
gfc_get_proc_ifc_for_expr(gfc_expr * procedure_ref)10810 gfc_get_proc_ifc_for_expr (gfc_expr *procedure_ref)
10811 {
10812 gfc_symbol *sym;
10813 gfc_ref *ref;
10814
10815 if (procedure_ref == NULL)
10816 return NULL;
10817
10818 /* Normal procedure case. */
10819 if (procedure_ref->expr_type == EXPR_FUNCTION
10820 && procedure_ref->value.function.esym)
10821 sym = procedure_ref->value.function.esym;
10822 else
10823 sym = procedure_ref->symtree->n.sym;
10824
10825 /* Typebound procedure case. */
10826 for (ref = procedure_ref->ref; ref; ref = ref->next)
10827 {
10828 if (ref->type == REF_COMPONENT
10829 && ref->u.c.component->attr.proc_pointer)
10830 sym = ref->u.c.component->ts.interface;
10831 else
10832 sym = NULL;
10833 }
10834
10835 return sym;
10836 }
10837
10838
10839 /* Walk the arguments of an elemental function.
10840 PROC_EXPR is used to check whether an argument is permitted to be absent. If
10841 it is NULL, we don't do the check and the argument is assumed to be present.
10842 */
10843
10844 gfc_ss *
gfc_walk_elemental_function_args(gfc_ss * ss,gfc_actual_arglist * arg,gfc_symbol * proc_ifc,gfc_ss_type type)10845 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
10846 gfc_symbol *proc_ifc, gfc_ss_type type)
10847 {
10848 gfc_formal_arglist *dummy_arg;
10849 int scalar;
10850 gfc_ss *head;
10851 gfc_ss *tail;
10852 gfc_ss *newss;
10853
10854 head = gfc_ss_terminator;
10855 tail = NULL;
10856
10857 if (proc_ifc)
10858 dummy_arg = gfc_sym_get_dummy_args (proc_ifc);
10859 else
10860 dummy_arg = NULL;
10861
10862 scalar = 1;
10863 for (; arg; arg = arg->next)
10864 {
10865 if (!arg->expr || arg->expr->expr_type == EXPR_NULL)
10866 goto loop_continue;
10867
10868 newss = gfc_walk_subexpr (head, arg->expr);
10869 if (newss == head)
10870 {
10871 /* Scalar argument. */
10872 gcc_assert (type == GFC_SS_SCALAR || type == GFC_SS_REFERENCE);
10873 newss = gfc_get_scalar_ss (head, arg->expr);
10874 newss->info->type = type;
10875 if (dummy_arg)
10876 newss->info->data.scalar.dummy_arg = dummy_arg->sym;
10877 }
10878 else
10879 scalar = 0;
10880
10881 if (dummy_arg != NULL
10882 && dummy_arg->sym->attr.optional
10883 && arg->expr->expr_type == EXPR_VARIABLE
10884 && (gfc_expr_attr (arg->expr).optional
10885 || gfc_expr_attr (arg->expr).allocatable
10886 || gfc_expr_attr (arg->expr).pointer))
10887 newss->info->can_be_null_ref = true;
10888
10889 head = newss;
10890 if (!tail)
10891 {
10892 tail = head;
10893 while (tail->next != gfc_ss_terminator)
10894 tail = tail->next;
10895 }
10896
10897 loop_continue:
10898 if (dummy_arg != NULL)
10899 dummy_arg = dummy_arg->next;
10900 }
10901
10902 if (scalar)
10903 {
10904 /* If all the arguments are scalar we don't need the argument SS. */
10905 gfc_free_ss_chain (head);
10906 /* Pass it back. */
10907 return ss;
10908 }
10909
10910 /* Add it onto the existing chain. */
10911 tail->next = ss;
10912 return head;
10913 }
10914
10915
10916 /* Walk a function call. Scalar functions are passed back, and taken out of
10917 scalarization loops. For elemental functions we walk their arguments.
10918 The result of functions returning arrays is stored in a temporary outside
10919 the loop, so that the function is only called once. Hence we do not need
10920 to walk their arguments. */
10921
10922 static gfc_ss *
gfc_walk_function_expr(gfc_ss * ss,gfc_expr * expr)10923 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
10924 {
10925 gfc_intrinsic_sym *isym;
10926 gfc_symbol *sym;
10927 gfc_component *comp = NULL;
10928
10929 isym = expr->value.function.isym;
10930
10931 /* Handle intrinsic functions separately. */
10932 if (isym)
10933 return gfc_walk_intrinsic_function (ss, expr, isym);
10934
10935 sym = expr->value.function.esym;
10936 if (!sym)
10937 sym = expr->symtree->n.sym;
10938
10939 if (gfc_is_class_array_function (expr))
10940 return gfc_get_array_ss (ss, expr,
10941 CLASS_DATA (expr->value.function.esym->result)->as->rank,
10942 GFC_SS_FUNCTION);
10943
10944 /* A function that returns arrays. */
10945 comp = gfc_get_proc_ptr_comp (expr);
10946 if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
10947 || (comp && comp->attr.dimension))
10948 return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
10949
10950 /* Walk the parameters of an elemental function. For now we always pass
10951 by reference. */
10952 if (sym->attr.elemental || (comp && comp->attr.elemental))
10953 {
10954 gfc_ss *old_ss = ss;
10955
10956 ss = gfc_walk_elemental_function_args (old_ss,
10957 expr->value.function.actual,
10958 gfc_get_proc_ifc_for_expr (expr),
10959 GFC_SS_REFERENCE);
10960 if (ss != old_ss
10961 && (comp
10962 || sym->attr.proc_pointer
10963 || sym->attr.if_source != IFSRC_DECL
10964 || sym->attr.array_outer_dependency))
10965 ss->info->array_outer_dependency = 1;
10966 }
10967
10968 /* Scalar functions are OK as these are evaluated outside the scalarization
10969 loop. Pass back and let the caller deal with it. */
10970 return ss;
10971 }
10972
10973
10974 /* An array temporary is constructed for array constructors. */
10975
10976 static gfc_ss *
gfc_walk_array_constructor(gfc_ss * ss,gfc_expr * expr)10977 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
10978 {
10979 return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_CONSTRUCTOR);
10980 }
10981
10982
10983 /* Walk an expression. Add walked expressions to the head of the SS chain.
10984 A wholly scalar expression will not be added. */
10985
10986 gfc_ss *
gfc_walk_subexpr(gfc_ss * ss,gfc_expr * expr)10987 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
10988 {
10989 gfc_ss *head;
10990
10991 switch (expr->expr_type)
10992 {
10993 case EXPR_VARIABLE:
10994 head = gfc_walk_variable_expr (ss, expr);
10995 return head;
10996
10997 case EXPR_OP:
10998 head = gfc_walk_op_expr (ss, expr);
10999 return head;
11000
11001 case EXPR_FUNCTION:
11002 head = gfc_walk_function_expr (ss, expr);
11003 return head;
11004
11005 case EXPR_CONSTANT:
11006 case EXPR_NULL:
11007 case EXPR_STRUCTURE:
11008 /* Pass back and let the caller deal with it. */
11009 break;
11010
11011 case EXPR_ARRAY:
11012 head = gfc_walk_array_constructor (ss, expr);
11013 return head;
11014
11015 case EXPR_SUBSTRING:
11016 /* Pass back and let the caller deal with it. */
11017 break;
11018
11019 default:
11020 gfc_internal_error ("bad expression type during walk (%d)",
11021 expr->expr_type);
11022 }
11023 return ss;
11024 }
11025
11026
11027 /* Entry point for expression walking.
11028 A return value equal to the passed chain means this is
11029 a scalar expression. It is up to the caller to take whatever action is
11030 necessary to translate these. */
11031
11032 gfc_ss *
gfc_walk_expr(gfc_expr * expr)11033 gfc_walk_expr (gfc_expr * expr)
11034 {
11035 gfc_ss *res;
11036
11037 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
11038 return gfc_reverse_ss (res);
11039 }
11040