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