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 = GFC_DECL_SAVED_DESCRIPTOR (parm);
6615 if (sym->ts.type == BT_CLASS)
6616 {
6617 tmp = build_fold_indirect_ref_loc (input_location, tmp);
6618 tmp = gfc_class_data_get (tmp);
6619 tmp = gfc_conv_descriptor_data_get (tmp);
6620 }
6621 tmp = convert (TREE_TYPE (parm), tmp);
6622 gfc_add_modify (&init, parm, tmp);
6623 }
6624 stmt = gfc_finish_block (&init);
6625
6626 gfc_restore_backend_locus (&loc);
6627
6628 /* Add the initialization code to the start of the function. */
6629
6630 if (sym->attr.optional || sym->attr.not_always_present)
6631 {
6632 tree nullify;
6633 if (TREE_CODE (parm) != PARM_DECL)
6634 nullify = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6635 parm, null_pointer_node);
6636 else
6637 nullify = build_empty_stmt (input_location);
6638 tmp = gfc_conv_expr_present (sym, true);
6639 stmt = build3_v (COND_EXPR, tmp, stmt, nullify);
6640 }
6641
6642 gfc_add_init_cleanup (block, stmt, NULL_TREE);
6643 }
6644
6645
6646 /* Modify the descriptor of an array parameter so that it has the
6647 correct lower bound. Also move the upper bound accordingly.
6648 If the array is not packed, it will be copied into a temporary.
6649 For each dimension we set the new lower and upper bounds. Then we copy the
6650 stride and calculate the offset for this dimension. We also work out
6651 what the stride of a packed array would be, and see it the two match.
6652 If the array need repacking, we set the stride to the values we just
6653 calculated, recalculate the offset and copy the array data.
6654 Code is also added to copy the data back at the end of the function.
6655 */
6656
6657 void
gfc_trans_dummy_array_bias(gfc_symbol * sym,tree tmpdesc,gfc_wrapped_block * block)6658 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
6659 gfc_wrapped_block * block)
6660 {
6661 tree size;
6662 tree type;
6663 tree offset;
6664 locus loc;
6665 stmtblock_t init;
6666 tree stmtInit, stmtCleanup;
6667 tree lbound;
6668 tree ubound;
6669 tree dubound;
6670 tree dlbound;
6671 tree dumdesc;
6672 tree tmp;
6673 tree stride, stride2;
6674 tree stmt_packed;
6675 tree stmt_unpacked;
6676 tree partial;
6677 gfc_se se;
6678 int n;
6679 int checkparm;
6680 int no_repack;
6681 bool optional_arg;
6682 gfc_array_spec *as;
6683 bool is_classarray = IS_CLASS_ARRAY (sym);
6684
6685 /* Do nothing for pointer and allocatable arrays. */
6686 if ((sym->ts.type != BT_CLASS && sym->attr.pointer)
6687 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer)
6688 || sym->attr.allocatable
6689 || (is_classarray && CLASS_DATA (sym)->attr.allocatable))
6690 return;
6691
6692 if (!is_classarray && sym->attr.dummy && gfc_is_nodesc_array (sym))
6693 {
6694 gfc_trans_g77_array (sym, block);
6695 return;
6696 }
6697
6698 loc.nextc = NULL;
6699 gfc_save_backend_locus (&loc);
6700 /* loc.nextc is not set by save_backend_locus but the location routines
6701 depend on it. */
6702 if (loc.nextc == NULL)
6703 loc.nextc = loc.lb->line;
6704 gfc_set_backend_locus (&sym->declared_at);
6705
6706 /* Descriptor type. */
6707 type = TREE_TYPE (tmpdesc);
6708 gcc_assert (GFC_ARRAY_TYPE_P (type));
6709 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
6710 if (is_classarray)
6711 /* For a class array the dummy array descriptor is in the _class
6712 component. */
6713 dumdesc = gfc_class_data_get (dumdesc);
6714 else
6715 dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc);
6716 as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
6717 gfc_start_block (&init);
6718
6719 if (sym->ts.type == BT_CHARACTER
6720 && VAR_P (sym->ts.u.cl->backend_decl))
6721 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
6722
6723 /* TODO: Fix the exclusion of class arrays from extent checking. */
6724 checkparm = (as->type == AS_EXPLICIT && !is_classarray
6725 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
6726
6727 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
6728 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
6729
6730 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
6731 {
6732 /* For non-constant shape arrays we only check if the first dimension
6733 is contiguous. Repacking higher dimensions wouldn't gain us
6734 anything as we still don't know the array stride. */
6735 partial = gfc_create_var (logical_type_node, "partial");
6736 TREE_USED (partial) = 1;
6737 tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
6738 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, tmp,
6739 gfc_index_one_node);
6740 gfc_add_modify (&init, partial, tmp);
6741 }
6742 else
6743 partial = NULL_TREE;
6744
6745 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
6746 here, however I think it does the right thing. */
6747 if (no_repack)
6748 {
6749 /* Set the first stride. */
6750 stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
6751 stride = gfc_evaluate_now (stride, &init);
6752
6753 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
6754 stride, gfc_index_zero_node);
6755 tmp = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
6756 tmp, gfc_index_one_node, stride);
6757 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
6758 gfc_add_modify (&init, stride, tmp);
6759
6760 /* Allow the user to disable array repacking. */
6761 stmt_unpacked = NULL_TREE;
6762 }
6763 else
6764 {
6765 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
6766 /* A library call to repack the array if necessary. */
6767 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
6768 stmt_unpacked = build_call_expr_loc (input_location,
6769 gfor_fndecl_in_pack, 1, tmp);
6770
6771 stride = gfc_index_one_node;
6772
6773 if (warn_array_temporaries)
6774 gfc_warning (OPT_Warray_temporaries,
6775 "Creating array temporary at %L", &loc);
6776 }
6777
6778 /* This is for the case where the array data is used directly without
6779 calling the repack function. */
6780 if (no_repack || partial != NULL_TREE)
6781 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
6782 else
6783 stmt_packed = NULL_TREE;
6784
6785 /* Assign the data pointer. */
6786 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
6787 {
6788 /* Don't repack unknown shape arrays when the first stride is 1. */
6789 tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (stmt_packed),
6790 partial, stmt_packed, stmt_unpacked);
6791 }
6792 else
6793 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
6794 gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp));
6795
6796 offset = gfc_index_zero_node;
6797 size = gfc_index_one_node;
6798
6799 /* Evaluate the bounds of the array. */
6800 for (n = 0; n < as->rank; n++)
6801 {
6802 if (checkparm || !as->upper[n])
6803 {
6804 /* Get the bounds of the actual parameter. */
6805 dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]);
6806 dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]);
6807 }
6808 else
6809 {
6810 dubound = NULL_TREE;
6811 dlbound = NULL_TREE;
6812 }
6813
6814 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
6815 if (!INTEGER_CST_P (lbound))
6816 {
6817 gfc_init_se (&se, NULL);
6818 gfc_conv_expr_type (&se, as->lower[n],
6819 gfc_array_index_type);
6820 gfc_add_block_to_block (&init, &se.pre);
6821 gfc_add_modify (&init, lbound, se.expr);
6822 }
6823
6824 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
6825 /* Set the desired upper bound. */
6826 if (as->upper[n])
6827 {
6828 /* We know what we want the upper bound to be. */
6829 if (!INTEGER_CST_P (ubound))
6830 {
6831 gfc_init_se (&se, NULL);
6832 gfc_conv_expr_type (&se, as->upper[n],
6833 gfc_array_index_type);
6834 gfc_add_block_to_block (&init, &se.pre);
6835 gfc_add_modify (&init, ubound, se.expr);
6836 }
6837
6838 /* Check the sizes match. */
6839 if (checkparm)
6840 {
6841 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
6842 char * msg;
6843 tree temp;
6844
6845 temp = fold_build2_loc (input_location, MINUS_EXPR,
6846 gfc_array_index_type, ubound, lbound);
6847 temp = fold_build2_loc (input_location, PLUS_EXPR,
6848 gfc_array_index_type,
6849 gfc_index_one_node, temp);
6850 stride2 = fold_build2_loc (input_location, MINUS_EXPR,
6851 gfc_array_index_type, dubound,
6852 dlbound);
6853 stride2 = fold_build2_loc (input_location, PLUS_EXPR,
6854 gfc_array_index_type,
6855 gfc_index_one_node, stride2);
6856 tmp = fold_build2_loc (input_location, NE_EXPR,
6857 gfc_array_index_type, temp, stride2);
6858 msg = xasprintf ("Dimension %d of array '%s' has extent "
6859 "%%ld instead of %%ld", n+1, sym->name);
6860
6861 gfc_trans_runtime_check (true, false, tmp, &init, &loc, msg,
6862 fold_convert (long_integer_type_node, temp),
6863 fold_convert (long_integer_type_node, stride2));
6864
6865 free (msg);
6866 }
6867 }
6868 else
6869 {
6870 /* For assumed shape arrays move the upper bound by the same amount
6871 as the lower bound. */
6872 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6873 gfc_array_index_type, dubound, dlbound);
6874 tmp = fold_build2_loc (input_location, PLUS_EXPR,
6875 gfc_array_index_type, tmp, lbound);
6876 gfc_add_modify (&init, ubound, tmp);
6877 }
6878 /* The offset of this dimension. offset = offset - lbound * stride. */
6879 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6880 lbound, stride);
6881 offset = fold_build2_loc (input_location, MINUS_EXPR,
6882 gfc_array_index_type, offset, tmp);
6883
6884 /* The size of this dimension, and the stride of the next. */
6885 if (n + 1 < as->rank)
6886 {
6887 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
6888
6889 if (no_repack || partial != NULL_TREE)
6890 stmt_unpacked =
6891 gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]);
6892
6893 /* Figure out the stride if not a known constant. */
6894 if (!INTEGER_CST_P (stride))
6895 {
6896 if (no_repack)
6897 stmt_packed = NULL_TREE;
6898 else
6899 {
6900 /* Calculate stride = size * (ubound + 1 - lbound). */
6901 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6902 gfc_array_index_type,
6903 gfc_index_one_node, lbound);
6904 tmp = fold_build2_loc (input_location, PLUS_EXPR,
6905 gfc_array_index_type, ubound, tmp);
6906 size = fold_build2_loc (input_location, MULT_EXPR,
6907 gfc_array_index_type, size, tmp);
6908 stmt_packed = size;
6909 }
6910
6911 /* Assign the stride. */
6912 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
6913 tmp = fold_build3_loc (input_location, COND_EXPR,
6914 gfc_array_index_type, partial,
6915 stmt_unpacked, stmt_packed);
6916 else
6917 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
6918 gfc_add_modify (&init, stride, tmp);
6919 }
6920 }
6921 else
6922 {
6923 stride = GFC_TYPE_ARRAY_SIZE (type);
6924
6925 if (stride && !INTEGER_CST_P (stride))
6926 {
6927 /* Calculate size = stride * (ubound + 1 - lbound). */
6928 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6929 gfc_array_index_type,
6930 gfc_index_one_node, lbound);
6931 tmp = fold_build2_loc (input_location, PLUS_EXPR,
6932 gfc_array_index_type,
6933 ubound, tmp);
6934 tmp = fold_build2_loc (input_location, MULT_EXPR,
6935 gfc_array_index_type,
6936 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
6937 gfc_add_modify (&init, stride, tmp);
6938 }
6939 }
6940 }
6941
6942 gfc_trans_array_cobounds (type, &init, sym);
6943
6944 /* Set the offset. */
6945 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
6946 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
6947
6948 gfc_trans_vla_type_sizes (sym, &init);
6949
6950 stmtInit = gfc_finish_block (&init);
6951
6952 /* Only do the entry/initialization code if the arg is present. */
6953 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
6954 optional_arg = (sym->attr.optional
6955 || (sym->ns->proc_name->attr.entry_master
6956 && sym->attr.dummy));
6957 if (optional_arg)
6958 {
6959 tree zero_init = fold_convert (TREE_TYPE (tmpdesc), null_pointer_node);
6960 zero_init = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6961 tmpdesc, zero_init);
6962 tmp = gfc_conv_expr_present (sym, true);
6963 stmtInit = build3_v (COND_EXPR, tmp, stmtInit, zero_init);
6964 }
6965
6966 /* Cleanup code. */
6967 if (no_repack)
6968 stmtCleanup = NULL_TREE;
6969 else
6970 {
6971 stmtblock_t cleanup;
6972 gfc_start_block (&cleanup);
6973
6974 if (sym->attr.intent != INTENT_IN)
6975 {
6976 /* Copy the data back. */
6977 tmp = build_call_expr_loc (input_location,
6978 gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
6979 gfc_add_expr_to_block (&cleanup, tmp);
6980 }
6981
6982 /* Free the temporary. */
6983 tmp = gfc_call_free (tmpdesc);
6984 gfc_add_expr_to_block (&cleanup, tmp);
6985
6986 stmtCleanup = gfc_finish_block (&cleanup);
6987
6988 /* Only do the cleanup if the array was repacked. */
6989 if (is_classarray)
6990 /* For a class array the dummy array descriptor is in the _class
6991 component. */
6992 tmp = gfc_class_data_get (dumdesc);
6993 else
6994 tmp = build_fold_indirect_ref_loc (input_location, dumdesc);
6995 tmp = gfc_conv_descriptor_data_get (tmp);
6996 tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
6997 tmp, tmpdesc);
6998 stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
6999 build_empty_stmt (input_location));
7000
7001 if (optional_arg)
7002 {
7003 tmp = gfc_conv_expr_present (sym);
7004 stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
7005 build_empty_stmt (input_location));
7006 }
7007 }
7008
7009 /* We don't need to free any memory allocated by internal_pack as it will
7010 be freed at the end of the function by pop_context. */
7011 gfc_add_init_cleanup (block, stmtInit, stmtCleanup);
7012
7013 gfc_restore_backend_locus (&loc);
7014 }
7015
7016
7017 /* Calculate the overall offset, including subreferences. */
7018 void
gfc_get_dataptr_offset(stmtblock_t * block,tree parm,tree desc,tree offset,bool subref,gfc_expr * expr)7019 gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
7020 bool subref, gfc_expr *expr)
7021 {
7022 tree tmp;
7023 tree field;
7024 tree stride;
7025 tree index;
7026 gfc_ref *ref;
7027 gfc_se start;
7028 int n;
7029
7030 /* If offset is NULL and this is not a subreferenced array, there is
7031 nothing to do. */
7032 if (offset == NULL_TREE)
7033 {
7034 if (subref)
7035 offset = gfc_index_zero_node;
7036 else
7037 return;
7038 }
7039
7040 tmp = build_array_ref (desc, offset, NULL, NULL);
7041
7042 /* Offset the data pointer for pointer assignments from arrays with
7043 subreferences; e.g. my_integer => my_type(:)%integer_component. */
7044 if (subref)
7045 {
7046 /* Go past the array reference. */
7047 for (ref = expr->ref; ref; ref = ref->next)
7048 if (ref->type == REF_ARRAY &&
7049 ref->u.ar.type != AR_ELEMENT)
7050 {
7051 ref = ref->next;
7052 break;
7053 }
7054
7055 /* Calculate the offset for each subsequent subreference. */
7056 for (; ref; ref = ref->next)
7057 {
7058 switch (ref->type)
7059 {
7060 case REF_COMPONENT:
7061 field = ref->u.c.component->backend_decl;
7062 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
7063 tmp = fold_build3_loc (input_location, COMPONENT_REF,
7064 TREE_TYPE (field),
7065 tmp, field, NULL_TREE);
7066 break;
7067
7068 case REF_SUBSTRING:
7069 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
7070 gfc_init_se (&start, NULL);
7071 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
7072 gfc_add_block_to_block (block, &start.pre);
7073 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
7074 break;
7075
7076 case REF_ARRAY:
7077 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
7078 && ref->u.ar.type == AR_ELEMENT);
7079
7080 /* TODO - Add bounds checking. */
7081 stride = gfc_index_one_node;
7082 index = gfc_index_zero_node;
7083 for (n = 0; n < ref->u.ar.dimen; n++)
7084 {
7085 tree itmp;
7086 tree jtmp;
7087
7088 /* Update the index. */
7089 gfc_init_se (&start, NULL);
7090 gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
7091 itmp = gfc_evaluate_now (start.expr, block);
7092 gfc_init_se (&start, NULL);
7093 gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
7094 jtmp = gfc_evaluate_now (start.expr, block);
7095 itmp = fold_build2_loc (input_location, MINUS_EXPR,
7096 gfc_array_index_type, itmp, jtmp);
7097 itmp = fold_build2_loc (input_location, MULT_EXPR,
7098 gfc_array_index_type, itmp, stride);
7099 index = fold_build2_loc (input_location, PLUS_EXPR,
7100 gfc_array_index_type, itmp, index);
7101 index = gfc_evaluate_now (index, block);
7102
7103 /* Update the stride. */
7104 gfc_init_se (&start, NULL);
7105 gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
7106 itmp = fold_build2_loc (input_location, MINUS_EXPR,
7107 gfc_array_index_type, start.expr,
7108 jtmp);
7109 itmp = fold_build2_loc (input_location, PLUS_EXPR,
7110 gfc_array_index_type,
7111 gfc_index_one_node, itmp);
7112 stride = fold_build2_loc (input_location, MULT_EXPR,
7113 gfc_array_index_type, stride, itmp);
7114 stride = gfc_evaluate_now (stride, block);
7115 }
7116
7117 /* Apply the index to obtain the array element. */
7118 tmp = gfc_build_array_ref (tmp, index, NULL);
7119 break;
7120
7121 case REF_INQUIRY:
7122 switch (ref->u.i)
7123 {
7124 case INQUIRY_RE:
7125 tmp = fold_build1_loc (input_location, REALPART_EXPR,
7126 TREE_TYPE (TREE_TYPE (tmp)), tmp);
7127 break;
7128
7129 case INQUIRY_IM:
7130 tmp = fold_build1_loc (input_location, IMAGPART_EXPR,
7131 TREE_TYPE (TREE_TYPE (tmp)), tmp);
7132 break;
7133
7134 default:
7135 break;
7136 }
7137 break;
7138
7139 default:
7140 gcc_unreachable ();
7141 break;
7142 }
7143 }
7144 }
7145
7146 /* Set the target data pointer. */
7147 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
7148 gfc_conv_descriptor_data_set (block, parm, offset);
7149 }
7150
7151
7152 /* gfc_conv_expr_descriptor needs the string length an expression
7153 so that the size of the temporary can be obtained. This is done
7154 by adding up the string lengths of all the elements in the
7155 expression. Function with non-constant expressions have their
7156 string lengths mapped onto the actual arguments using the
7157 interface mapping machinery in trans-expr.c. */
7158 static void
get_array_charlen(gfc_expr * expr,gfc_se * se)7159 get_array_charlen (gfc_expr *expr, gfc_se *se)
7160 {
7161 gfc_interface_mapping mapping;
7162 gfc_formal_arglist *formal;
7163 gfc_actual_arglist *arg;
7164 gfc_se tse;
7165 gfc_expr *e;
7166
7167 if (expr->ts.u.cl->length
7168 && gfc_is_constant_expr (expr->ts.u.cl->length))
7169 {
7170 if (!expr->ts.u.cl->backend_decl)
7171 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
7172 return;
7173 }
7174
7175 switch (expr->expr_type)
7176 {
7177 case EXPR_ARRAY:
7178
7179 /* This is somewhat brutal. The expression for the first
7180 element of the array is evaluated and assigned to a
7181 new string length for the original expression. */
7182 e = gfc_constructor_first (expr->value.constructor)->expr;
7183
7184 gfc_init_se (&tse, NULL);
7185
7186 /* Avoid evaluating trailing array references since all we need is
7187 the string length. */
7188 if (e->rank)
7189 tse.descriptor_only = 1;
7190 if (e->rank && e->expr_type != EXPR_VARIABLE)
7191 gfc_conv_expr_descriptor (&tse, e);
7192 else
7193 gfc_conv_expr (&tse, e);
7194
7195 gfc_add_block_to_block (&se->pre, &tse.pre);
7196 gfc_add_block_to_block (&se->post, &tse.post);
7197
7198 if (!expr->ts.u.cl->backend_decl || !VAR_P (expr->ts.u.cl->backend_decl))
7199 {
7200 expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
7201 expr->ts.u.cl->backend_decl =
7202 gfc_create_var (gfc_charlen_type_node, "sln");
7203 }
7204
7205 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
7206 tse.string_length);
7207
7208 /* Make sure that deferred length components point to the hidden
7209 string_length component. */
7210 if (TREE_CODE (tse.expr) == COMPONENT_REF
7211 && TREE_CODE (tse.string_length) == COMPONENT_REF
7212 && TREE_OPERAND (tse.expr, 0) == TREE_OPERAND (tse.string_length, 0))
7213 e->ts.u.cl->backend_decl = expr->ts.u.cl->backend_decl;
7214
7215 return;
7216
7217 case EXPR_OP:
7218 get_array_charlen (expr->value.op.op1, se);
7219
7220 /* For parentheses the expression ts.u.cl should be identical. */
7221 if (expr->value.op.op == INTRINSIC_PARENTHESES)
7222 {
7223 if (expr->value.op.op1->ts.u.cl != expr->ts.u.cl)
7224 expr->ts.u.cl->backend_decl
7225 = expr->value.op.op1->ts.u.cl->backend_decl;
7226 return;
7227 }
7228
7229 expr->ts.u.cl->backend_decl =
7230 gfc_create_var (gfc_charlen_type_node, "sln");
7231
7232 if (expr->value.op.op2)
7233 {
7234 get_array_charlen (expr->value.op.op2, se);
7235
7236 gcc_assert (expr->value.op.op == INTRINSIC_CONCAT);
7237
7238 /* Add the string lengths and assign them to the expression
7239 string length backend declaration. */
7240 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
7241 fold_build2_loc (input_location, PLUS_EXPR,
7242 gfc_charlen_type_node,
7243 expr->value.op.op1->ts.u.cl->backend_decl,
7244 expr->value.op.op2->ts.u.cl->backend_decl));
7245 }
7246 else
7247 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
7248 expr->value.op.op1->ts.u.cl->backend_decl);
7249 break;
7250
7251 case EXPR_FUNCTION:
7252 if (expr->value.function.esym == NULL
7253 || expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
7254 {
7255 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
7256 break;
7257 }
7258
7259 /* Map expressions involving the dummy arguments onto the actual
7260 argument expressions. */
7261 gfc_init_interface_mapping (&mapping);
7262 formal = gfc_sym_get_dummy_args (expr->symtree->n.sym);
7263 arg = expr->value.function.actual;
7264
7265 /* Set se = NULL in the calls to the interface mapping, to suppress any
7266 backend stuff. */
7267 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
7268 {
7269 if (!arg->expr)
7270 continue;
7271 if (formal->sym)
7272 gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
7273 }
7274
7275 gfc_init_se (&tse, NULL);
7276
7277 /* Build the expression for the character length and convert it. */
7278 gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length);
7279
7280 gfc_add_block_to_block (&se->pre, &tse.pre);
7281 gfc_add_block_to_block (&se->post, &tse.post);
7282 tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
7283 tse.expr = fold_build2_loc (input_location, MAX_EXPR,
7284 TREE_TYPE (tse.expr), tse.expr,
7285 build_zero_cst (TREE_TYPE (tse.expr)));
7286 expr->ts.u.cl->backend_decl = tse.expr;
7287 gfc_free_interface_mapping (&mapping);
7288 break;
7289
7290 default:
7291 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
7292 break;
7293 }
7294 }
7295
7296
7297 /* Helper function to check dimensions. */
7298 static bool
transposed_dims(gfc_ss * ss)7299 transposed_dims (gfc_ss *ss)
7300 {
7301 int n;
7302
7303 for (n = 0; n < ss->dimen; n++)
7304 if (ss->dim[n] != n)
7305 return true;
7306 return false;
7307 }
7308
7309
7310 /* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
7311 AR_FULL, suitable for the scalarizer. */
7312
7313 static gfc_ss *
walk_coarray(gfc_expr * e)7314 walk_coarray (gfc_expr *e)
7315 {
7316 gfc_ss *ss;
7317
7318 gcc_assert (gfc_get_corank (e) > 0);
7319
7320 ss = gfc_walk_expr (e);
7321
7322 /* Fix scalar coarray. */
7323 if (ss == gfc_ss_terminator)
7324 {
7325 gfc_ref *ref;
7326
7327 ref = e->ref;
7328 while (ref)
7329 {
7330 if (ref->type == REF_ARRAY
7331 && ref->u.ar.codimen > 0)
7332 break;
7333
7334 ref = ref->next;
7335 }
7336
7337 gcc_assert (ref != NULL);
7338 if (ref->u.ar.type == AR_ELEMENT)
7339 ref->u.ar.type = AR_SECTION;
7340 ss = gfc_reverse_ss (gfc_walk_array_ref (ss, e, ref));
7341 }
7342
7343 return ss;
7344 }
7345
7346
7347 /* Convert an array for passing as an actual argument. Expressions and
7348 vector subscripts are evaluated and stored in a temporary, which is then
7349 passed. For whole arrays the descriptor is passed. For array sections
7350 a modified copy of the descriptor is passed, but using the original data.
7351
7352 This function is also used for array pointer assignments, and there
7353 are three cases:
7354
7355 - se->want_pointer && !se->direct_byref
7356 EXPR is an actual argument. On exit, se->expr contains a
7357 pointer to the array descriptor.
7358
7359 - !se->want_pointer && !se->direct_byref
7360 EXPR is an actual argument to an intrinsic function or the
7361 left-hand side of a pointer assignment. On exit, se->expr
7362 contains the descriptor for EXPR.
7363
7364 - !se->want_pointer && se->direct_byref
7365 EXPR is the right-hand side of a pointer assignment and
7366 se->expr is the descriptor for the previously-evaluated
7367 left-hand side. The function creates an assignment from
7368 EXPR to se->expr.
7369
7370
7371 The se->force_tmp flag disables the non-copying descriptor optimization
7372 that is used for transpose. It may be used in cases where there is an
7373 alias between the transpose argument and another argument in the same
7374 function call. */
7375
7376 void
gfc_conv_expr_descriptor(gfc_se * se,gfc_expr * expr)7377 gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
7378 {
7379 gfc_ss *ss;
7380 gfc_ss_type ss_type;
7381 gfc_ss_info *ss_info;
7382 gfc_loopinfo loop;
7383 gfc_array_info *info;
7384 int need_tmp;
7385 int n;
7386 tree tmp;
7387 tree desc;
7388 stmtblock_t block;
7389 tree start;
7390 tree offset;
7391 int full;
7392 bool subref_array_target = false;
7393 bool deferred_array_component = false;
7394 gfc_expr *arg, *ss_expr;
7395
7396 if (se->want_coarray)
7397 ss = walk_coarray (expr);
7398 else
7399 ss = gfc_walk_expr (expr);
7400
7401 gcc_assert (ss != NULL);
7402 gcc_assert (ss != gfc_ss_terminator);
7403
7404 ss_info = ss->info;
7405 ss_type = ss_info->type;
7406 ss_expr = ss_info->expr;
7407
7408 /* Special case: TRANSPOSE which needs no temporary. */
7409 while (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym
7410 && (arg = gfc_get_noncopying_intrinsic_argument (expr)) != NULL)
7411 {
7412 /* This is a call to transpose which has already been handled by the
7413 scalarizer, so that we just need to get its argument's descriptor. */
7414 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
7415 expr = expr->value.function.actual->expr;
7416 }
7417
7418 /* Special case things we know we can pass easily. */
7419 switch (expr->expr_type)
7420 {
7421 case EXPR_VARIABLE:
7422 /* If we have a linear array section, we can pass it directly.
7423 Otherwise we need to copy it into a temporary. */
7424
7425 gcc_assert (ss_type == GFC_SS_SECTION);
7426 gcc_assert (ss_expr == expr);
7427 info = &ss_info->data.array;
7428
7429 /* Get the descriptor for the array. */
7430 gfc_conv_ss_descriptor (&se->pre, ss, 0);
7431 desc = info->descriptor;
7432
7433 /* The charlen backend decl for deferred character components cannot
7434 be used because it is fixed at zero. Instead, the hidden string
7435 length component is used. */
7436 if (expr->ts.type == BT_CHARACTER
7437 && expr->ts.deferred
7438 && TREE_CODE (desc) == COMPONENT_REF)
7439 deferred_array_component = true;
7440
7441 subref_array_target = se->direct_byref && is_subref_array (expr);
7442 need_tmp = gfc_ref_needs_temporary_p (expr->ref)
7443 && !subref_array_target;
7444
7445 if (se->force_tmp)
7446 need_tmp = 1;
7447 else if (se->force_no_tmp)
7448 need_tmp = 0;
7449
7450 if (need_tmp)
7451 full = 0;
7452 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
7453 {
7454 /* Create a new descriptor if the array doesn't have one. */
7455 full = 0;
7456 }
7457 else if (info->ref->u.ar.type == AR_FULL || se->descriptor_only)
7458 full = 1;
7459 else if (se->direct_byref)
7460 full = 0;
7461 else
7462 full = gfc_full_array_ref_p (info->ref, NULL);
7463
7464 if (full && !transposed_dims (ss))
7465 {
7466 if (se->direct_byref && !se->byref_noassign)
7467 {
7468 /* Copy the descriptor for pointer assignments. */
7469 gfc_add_modify (&se->pre, se->expr, desc);
7470
7471 /* Add any offsets from subreferences. */
7472 gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
7473 subref_array_target, expr);
7474
7475 /* ....and set the span field. */
7476 tmp = gfc_get_array_span (desc, expr);
7477 if (tmp != NULL_TREE && !integer_zerop (tmp))
7478 gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp);
7479 }
7480 else if (se->want_pointer)
7481 {
7482 /* We pass full arrays directly. This means that pointers and
7483 allocatable arrays should also work. */
7484 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
7485 }
7486 else
7487 {
7488 se->expr = desc;
7489 }
7490
7491 if (expr->ts.type == BT_CHARACTER && !deferred_array_component)
7492 se->string_length = gfc_get_expr_charlen (expr);
7493 /* The ss_info string length is returned set to the value of the
7494 hidden string length component. */
7495 else if (deferred_array_component)
7496 se->string_length = ss_info->string_length;
7497
7498 gfc_free_ss_chain (ss);
7499 return;
7500 }
7501 break;
7502
7503 case EXPR_FUNCTION:
7504 /* A transformational function return value will be a temporary
7505 array descriptor. We still need to go through the scalarizer
7506 to create the descriptor. Elemental functions are handled as
7507 arbitrary expressions, i.e. copy to a temporary. */
7508
7509 if (se->direct_byref)
7510 {
7511 gcc_assert (ss_type == GFC_SS_FUNCTION && ss_expr == expr);
7512
7513 /* For pointer assignments pass the descriptor directly. */
7514 if (se->ss == NULL)
7515 se->ss = ss;
7516 else
7517 gcc_assert (se->ss == ss);
7518
7519 if (!is_pointer_array (se->expr))
7520 {
7521 tmp = gfc_get_element_type (TREE_TYPE (se->expr));
7522 tmp = fold_convert (gfc_array_index_type,
7523 size_in_bytes (tmp));
7524 gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp);
7525 }
7526
7527 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
7528 gfc_conv_expr (se, expr);
7529
7530 gfc_free_ss_chain (ss);
7531 return;
7532 }
7533
7534 if (ss_expr != expr || ss_type != GFC_SS_FUNCTION)
7535 {
7536 if (ss_expr != expr)
7537 /* Elemental function. */
7538 gcc_assert ((expr->value.function.esym != NULL
7539 && expr->value.function.esym->attr.elemental)
7540 || (expr->value.function.isym != NULL
7541 && expr->value.function.isym->elemental)
7542 || (gfc_expr_attr (expr).proc_pointer
7543 && gfc_expr_attr (expr).elemental)
7544 || gfc_inline_intrinsic_function_p (expr));
7545
7546 need_tmp = 1;
7547 if (expr->ts.type == BT_CHARACTER
7548 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
7549 get_array_charlen (expr, se);
7550
7551 info = NULL;
7552 }
7553 else
7554 {
7555 /* Transformational function. */
7556 info = &ss_info->data.array;
7557 need_tmp = 0;
7558 }
7559 break;
7560
7561 case EXPR_ARRAY:
7562 /* Constant array constructors don't need a temporary. */
7563 if (ss_type == GFC_SS_CONSTRUCTOR
7564 && expr->ts.type != BT_CHARACTER
7565 && gfc_constant_array_constructor_p (expr->value.constructor))
7566 {
7567 need_tmp = 0;
7568 info = &ss_info->data.array;
7569 }
7570 else
7571 {
7572 need_tmp = 1;
7573 info = NULL;
7574 }
7575 break;
7576
7577 default:
7578 /* Something complicated. Copy it into a temporary. */
7579 need_tmp = 1;
7580 info = NULL;
7581 break;
7582 }
7583
7584 /* If we are creating a temporary, we don't need to bother about aliases
7585 anymore. */
7586 if (need_tmp)
7587 se->force_tmp = 0;
7588
7589 gfc_init_loopinfo (&loop);
7590
7591 /* Associate the SS with the loop. */
7592 gfc_add_ss_to_loop (&loop, ss);
7593
7594 /* Tell the scalarizer not to bother creating loop variables, etc. */
7595 if (!need_tmp)
7596 loop.array_parameter = 1;
7597 else
7598 /* The right-hand side of a pointer assignment mustn't use a temporary. */
7599 gcc_assert (!se->direct_byref);
7600
7601 /* Do we need bounds checking or not? */
7602 ss->no_bounds_check = expr->no_bounds_check;
7603
7604 /* Setup the scalarizing loops and bounds. */
7605 gfc_conv_ss_startstride (&loop);
7606
7607 if (need_tmp)
7608 {
7609 if (expr->ts.type == BT_CHARACTER
7610 && (!expr->ts.u.cl->backend_decl || expr->expr_type == EXPR_ARRAY))
7611 get_array_charlen (expr, se);
7612
7613 /* Tell the scalarizer to make a temporary. */
7614 loop.temp_ss = gfc_get_temp_ss (gfc_typenode_for_spec (&expr->ts),
7615 ((expr->ts.type == BT_CHARACTER)
7616 ? expr->ts.u.cl->backend_decl
7617 : NULL),
7618 loop.dimen);
7619
7620 se->string_length = loop.temp_ss->info->string_length;
7621 gcc_assert (loop.temp_ss->dimen == loop.dimen);
7622 gfc_add_ss_to_loop (&loop, loop.temp_ss);
7623 }
7624
7625 gfc_conv_loop_setup (&loop, & expr->where);
7626
7627 if (need_tmp)
7628 {
7629 /* Copy into a temporary and pass that. We don't need to copy the data
7630 back because expressions and vector subscripts must be INTENT_IN. */
7631 /* TODO: Optimize passing function return values. */
7632 gfc_se lse;
7633 gfc_se rse;
7634 bool deep_copy;
7635
7636 /* Start the copying loops. */
7637 gfc_mark_ss_chain_used (loop.temp_ss, 1);
7638 gfc_mark_ss_chain_used (ss, 1);
7639 gfc_start_scalarized_body (&loop, &block);
7640
7641 /* Copy each data element. */
7642 gfc_init_se (&lse, NULL);
7643 gfc_copy_loopinfo_to_se (&lse, &loop);
7644 gfc_init_se (&rse, NULL);
7645 gfc_copy_loopinfo_to_se (&rse, &loop);
7646
7647 lse.ss = loop.temp_ss;
7648 rse.ss = ss;
7649
7650 gfc_conv_scalarized_array_ref (&lse, NULL);
7651 if (expr->ts.type == BT_CHARACTER)
7652 {
7653 gfc_conv_expr (&rse, expr);
7654 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
7655 rse.expr = build_fold_indirect_ref_loc (input_location,
7656 rse.expr);
7657 }
7658 else
7659 gfc_conv_expr_val (&rse, expr);
7660
7661 gfc_add_block_to_block (&block, &rse.pre);
7662 gfc_add_block_to_block (&block, &lse.pre);
7663
7664 lse.string_length = rse.string_length;
7665
7666 deep_copy = !se->data_not_needed
7667 && (expr->expr_type == EXPR_VARIABLE
7668 || expr->expr_type == EXPR_ARRAY);
7669 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts,
7670 deep_copy, false);
7671 gfc_add_expr_to_block (&block, tmp);
7672
7673 /* Finish the copying loops. */
7674 gfc_trans_scalarizing_loops (&loop, &block);
7675
7676 desc = loop.temp_ss->info->data.array.descriptor;
7677 }
7678 else if (expr->expr_type == EXPR_FUNCTION && !transposed_dims (ss))
7679 {
7680 desc = info->descriptor;
7681 se->string_length = ss_info->string_length;
7682 }
7683 else
7684 {
7685 /* We pass sections without copying to a temporary. Make a new
7686 descriptor and point it at the section we want. The loop variable
7687 limits will be the limits of the section.
7688 A function may decide to repack the array to speed up access, but
7689 we're not bothered about that here. */
7690 int dim, ndim, codim;
7691 tree parm;
7692 tree parmtype;
7693 tree stride;
7694 tree from;
7695 tree to;
7696 tree base;
7697 bool onebased = false, rank_remap;
7698
7699 ndim = info->ref ? info->ref->u.ar.dimen : ss->dimen;
7700 rank_remap = ss->dimen < ndim;
7701
7702 if (se->want_coarray)
7703 {
7704 gfc_array_ref *ar = &info->ref->u.ar;
7705
7706 codim = gfc_get_corank (expr);
7707 for (n = 0; n < codim - 1; n++)
7708 {
7709 /* Make sure we are not lost somehow. */
7710 gcc_assert (ar->dimen_type[n + ndim] == DIMEN_THIS_IMAGE);
7711
7712 /* Make sure the call to gfc_conv_section_startstride won't
7713 generate unnecessary code to calculate stride. */
7714 gcc_assert (ar->stride[n + ndim] == NULL);
7715
7716 gfc_conv_section_startstride (&loop.pre, ss, n + ndim);
7717 loop.from[n + loop.dimen] = info->start[n + ndim];
7718 loop.to[n + loop.dimen] = info->end[n + ndim];
7719 }
7720
7721 gcc_assert (n == codim - 1);
7722 evaluate_bound (&loop.pre, info->start, ar->start,
7723 info->descriptor, n + ndim, true,
7724 ar->as->type == AS_DEFERRED);
7725 loop.from[n + loop.dimen] = info->start[n + ndim];
7726 }
7727 else
7728 codim = 0;
7729
7730 /* Set the string_length for a character array. */
7731 if (expr->ts.type == BT_CHARACTER)
7732 {
7733 if (deferred_array_component)
7734 se->string_length = ss_info->string_length;
7735 else
7736 se->string_length = gfc_get_expr_charlen (expr);
7737
7738 if (VAR_P (se->string_length)
7739 && expr->ts.u.cl->backend_decl == se->string_length)
7740 tmp = ss_info->string_length;
7741 else
7742 tmp = se->string_length;
7743
7744 if (expr->ts.deferred && VAR_P (expr->ts.u.cl->backend_decl))
7745 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, tmp);
7746 else
7747 expr->ts.u.cl->backend_decl = tmp;
7748 }
7749
7750 /* If we have an array section or are assigning make sure that
7751 the lower bound is 1. References to the full
7752 array should otherwise keep the original bounds. */
7753 if ((!info->ref || info->ref->u.ar.type != AR_FULL) && !se->want_pointer)
7754 for (dim = 0; dim < loop.dimen; dim++)
7755 if (!integer_onep (loop.from[dim]))
7756 {
7757 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7758 gfc_array_index_type, gfc_index_one_node,
7759 loop.from[dim]);
7760 loop.to[dim] = fold_build2_loc (input_location, PLUS_EXPR,
7761 gfc_array_index_type,
7762 loop.to[dim], tmp);
7763 loop.from[dim] = gfc_index_one_node;
7764 }
7765
7766 desc = info->descriptor;
7767 if (se->direct_byref && !se->byref_noassign)
7768 {
7769 /* For pointer assignments we fill in the destination. */
7770 parm = se->expr;
7771 parmtype = TREE_TYPE (parm);
7772 }
7773 else
7774 {
7775 /* Otherwise make a new one. */
7776 if (expr->ts.type == BT_CHARACTER && expr->ts.deferred)
7777 parmtype = gfc_typenode_for_spec (&expr->ts);
7778 else
7779 parmtype = gfc_get_element_type (TREE_TYPE (desc));
7780
7781 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, codim,
7782 loop.from, loop.to, 0,
7783 GFC_ARRAY_UNKNOWN, false);
7784 parm = gfc_create_var (parmtype, "parm");
7785
7786 /* When expression is a class object, then add the class' handle to
7787 the parm_decl. */
7788 if (expr->ts.type == BT_CLASS && expr->expr_type == EXPR_VARIABLE)
7789 {
7790 gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr);
7791 gfc_se classse;
7792
7793 /* class_expr can be NULL, when no _class ref is in expr.
7794 We must not fix this here with a gfc_fix_class_ref (). */
7795 if (class_expr)
7796 {
7797 gfc_init_se (&classse, NULL);
7798 gfc_conv_expr (&classse, class_expr);
7799 gfc_free_expr (class_expr);
7800
7801 gcc_assert (classse.pre.head == NULL_TREE
7802 && classse.post.head == NULL_TREE);
7803 gfc_allocate_lang_decl (parm);
7804 GFC_DECL_SAVED_DESCRIPTOR (parm) = classse.expr;
7805 }
7806 }
7807 }
7808
7809 /* Set the span field. */
7810 if (expr->ts.type == BT_CHARACTER && ss_info->string_length)
7811 tmp = ss_info->string_length;
7812 else
7813 tmp = gfc_get_array_span (desc, expr);
7814 if (tmp != NULL_TREE)
7815 gfc_conv_descriptor_span_set (&loop.pre, parm, tmp);
7816
7817 offset = gfc_index_zero_node;
7818
7819 /* The following can be somewhat confusing. We have two
7820 descriptors, a new one and the original array.
7821 {parm, parmtype, dim} refer to the new one.
7822 {desc, type, n, loop} refer to the original, which maybe
7823 a descriptorless array.
7824 The bounds of the scalarization are the bounds of the section.
7825 We don't have to worry about numeric overflows when calculating
7826 the offsets because all elements are within the array data. */
7827
7828 /* Set the dtype. */
7829 tmp = gfc_conv_descriptor_dtype (parm);
7830 gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
7831
7832 /* Set offset for assignments to pointer only to zero if it is not
7833 the full array. */
7834 if ((se->direct_byref || se->use_offset)
7835 && ((info->ref && info->ref->u.ar.type != AR_FULL)
7836 || (expr->expr_type == EXPR_ARRAY && se->use_offset)))
7837 base = gfc_index_zero_node;
7838 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
7839 base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
7840 else
7841 base = NULL_TREE;
7842
7843 for (n = 0; n < ndim; n++)
7844 {
7845 stride = gfc_conv_array_stride (desc, n);
7846
7847 /* Work out the offset. */
7848 if (info->ref
7849 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
7850 {
7851 gcc_assert (info->subscript[n]
7852 && info->subscript[n]->info->type == GFC_SS_SCALAR);
7853 start = info->subscript[n]->info->data.scalar.value;
7854 }
7855 else
7856 {
7857 /* Evaluate and remember the start of the section. */
7858 start = info->start[n];
7859 stride = gfc_evaluate_now (stride, &loop.pre);
7860 }
7861
7862 tmp = gfc_conv_array_lbound (desc, n);
7863 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
7864 start, tmp);
7865 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
7866 tmp, stride);
7867 offset = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
7868 offset, tmp);
7869
7870 if (info->ref
7871 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
7872 {
7873 /* For elemental dimensions, we only need the offset. */
7874 continue;
7875 }
7876
7877 /* Vector subscripts need copying and are handled elsewhere. */
7878 if (info->ref)
7879 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
7880
7881 /* look for the corresponding scalarizer dimension: dim. */
7882 for (dim = 0; dim < ndim; dim++)
7883 if (ss->dim[dim] == n)
7884 break;
7885
7886 /* loop exited early: the DIM being looked for has been found. */
7887 gcc_assert (dim < ndim);
7888
7889 /* Set the new lower bound. */
7890 from = loop.from[dim];
7891 to = loop.to[dim];
7892
7893 onebased = integer_onep (from);
7894 gfc_conv_descriptor_lbound_set (&loop.pre, parm,
7895 gfc_rank_cst[dim], from);
7896
7897 /* Set the new upper bound. */
7898 gfc_conv_descriptor_ubound_set (&loop.pre, parm,
7899 gfc_rank_cst[dim], to);
7900
7901 /* Multiply the stride by the section stride to get the
7902 total stride. */
7903 stride = fold_build2_loc (input_location, MULT_EXPR,
7904 gfc_array_index_type,
7905 stride, info->stride[n]);
7906
7907 if ((se->direct_byref || se->use_offset)
7908 && ((info->ref && info->ref->u.ar.type != AR_FULL)
7909 || (expr->expr_type == EXPR_ARRAY && se->use_offset)))
7910 {
7911 base = fold_build2_loc (input_location, MINUS_EXPR,
7912 TREE_TYPE (base), base, stride);
7913 }
7914 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)) || se->use_offset)
7915 {
7916 bool toonebased;
7917 tmp = gfc_conv_array_lbound (desc, n);
7918 toonebased = integer_onep (tmp);
7919 // lb(arr) - from (- start + 1)
7920 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7921 TREE_TYPE (base), tmp, from);
7922 if (onebased && toonebased)
7923 {
7924 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7925 TREE_TYPE (base), tmp, start);
7926 tmp = fold_build2_loc (input_location, PLUS_EXPR,
7927 TREE_TYPE (base), tmp,
7928 gfc_index_one_node);
7929 }
7930 tmp = fold_build2_loc (input_location, MULT_EXPR,
7931 TREE_TYPE (base), tmp,
7932 gfc_conv_array_stride (desc, n));
7933 base = fold_build2_loc (input_location, PLUS_EXPR,
7934 TREE_TYPE (base), tmp, base);
7935 }
7936
7937 /* Store the new stride. */
7938 gfc_conv_descriptor_stride_set (&loop.pre, parm,
7939 gfc_rank_cst[dim], stride);
7940 }
7941
7942 for (n = loop.dimen; n < loop.dimen + codim; n++)
7943 {
7944 from = loop.from[n];
7945 to = loop.to[n];
7946 gfc_conv_descriptor_lbound_set (&loop.pre, parm,
7947 gfc_rank_cst[n], from);
7948 if (n < loop.dimen + codim - 1)
7949 gfc_conv_descriptor_ubound_set (&loop.pre, parm,
7950 gfc_rank_cst[n], to);
7951 }
7952
7953 if (se->data_not_needed)
7954 gfc_conv_descriptor_data_set (&loop.pre, parm,
7955 gfc_index_zero_node);
7956 else
7957 /* Point the data pointer at the 1st element in the section. */
7958 gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
7959 subref_array_target, expr);
7960
7961 /* Force the offset to be -1, when the lower bound of the highest
7962 dimension is one and the symbol is present and is not a
7963 pointer/allocatable or associated. */
7964 if (((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
7965 && !se->data_not_needed)
7966 || (se->use_offset && base != NULL_TREE))
7967 {
7968 /* Set the offset depending on base. */
7969 tmp = rank_remap && !se->direct_byref ?
7970 fold_build2_loc (input_location, PLUS_EXPR,
7971 gfc_array_index_type, base,
7972 offset)
7973 : base;
7974 gfc_conv_descriptor_offset_set (&loop.pre, parm, tmp);
7975 }
7976 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
7977 && !se->data_not_needed
7978 && (!rank_remap || se->use_offset))
7979 {
7980 gfc_conv_descriptor_offset_set (&loop.pre, parm,
7981 gfc_conv_descriptor_offset_get (desc));
7982 }
7983 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
7984 && !se->data_not_needed
7985 && gfc_expr_attr (expr).select_rank_temporary)
7986 {
7987 gfc_conv_descriptor_offset_set (&loop.pre, parm, gfc_index_zero_node);
7988 }
7989 else if (onebased && (!rank_remap || se->use_offset)
7990 && expr->symtree
7991 && !(expr->symtree->n.sym && expr->symtree->n.sym->ts.type == BT_CLASS
7992 && !CLASS_DATA (expr->symtree->n.sym)->attr.class_pointer)
7993 && !expr->symtree->n.sym->attr.allocatable
7994 && !expr->symtree->n.sym->attr.pointer
7995 && !expr->symtree->n.sym->attr.host_assoc
7996 && !expr->symtree->n.sym->attr.use_assoc)
7997 {
7998 /* Set the offset to -1. */
7999 mpz_t minus_one;
8000 mpz_init_set_si (minus_one, -1);
8001 tmp = gfc_conv_mpz_to_tree (minus_one, gfc_index_integer_kind);
8002 gfc_conv_descriptor_offset_set (&loop.pre, parm, tmp);
8003 }
8004 else
8005 {
8006 /* Only the callee knows what the correct offset it, so just set
8007 it to zero here. */
8008 gfc_conv_descriptor_offset_set (&loop.pre, parm, gfc_index_zero_node);
8009 }
8010 desc = parm;
8011 }
8012
8013 /* For class arrays add the class tree into the saved descriptor to
8014 enable getting of _vptr and the like. */
8015 if (expr->expr_type == EXPR_VARIABLE && VAR_P (desc)
8016 && IS_CLASS_ARRAY (expr->symtree->n.sym))
8017 {
8018 gfc_allocate_lang_decl (desc);
8019 GFC_DECL_SAVED_DESCRIPTOR (desc) =
8020 DECL_LANG_SPECIFIC (expr->symtree->n.sym->backend_decl) ?
8021 GFC_DECL_SAVED_DESCRIPTOR (expr->symtree->n.sym->backend_decl)
8022 : expr->symtree->n.sym->backend_decl;
8023 }
8024 else if (expr->expr_type == EXPR_ARRAY && VAR_P (desc)
8025 && IS_CLASS_ARRAY (expr))
8026 {
8027 tree vtype;
8028 gfc_allocate_lang_decl (desc);
8029 tmp = gfc_create_var (expr->ts.u.derived->backend_decl, "class");
8030 GFC_DECL_SAVED_DESCRIPTOR (desc) = tmp;
8031 vtype = gfc_class_vptr_get (tmp);
8032 gfc_add_modify (&se->pre, vtype,
8033 gfc_build_addr_expr (TREE_TYPE (vtype),
8034 gfc_find_vtab (&expr->ts)->backend_decl));
8035 }
8036 if (!se->direct_byref || se->byref_noassign)
8037 {
8038 /* Get a pointer to the new descriptor. */
8039 if (se->want_pointer)
8040 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
8041 else
8042 se->expr = desc;
8043 }
8044
8045 gfc_add_block_to_block (&se->pre, &loop.pre);
8046 gfc_add_block_to_block (&se->post, &loop.post);
8047
8048 /* Cleanup the scalarizer. */
8049 gfc_cleanup_loop (&loop);
8050 }
8051
8052 /* Helper function for gfc_conv_array_parameter if array size needs to be
8053 computed. */
8054
8055 static void
array_parameter_size(tree desc,gfc_expr * expr,tree * size)8056 array_parameter_size (tree desc, gfc_expr *expr, tree *size)
8057 {
8058 tree elem;
8059 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
8060 *size = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
8061 else if (expr->rank > 1)
8062 *size = build_call_expr_loc (input_location,
8063 gfor_fndecl_size0, 1,
8064 gfc_build_addr_expr (NULL, desc));
8065 else
8066 {
8067 tree ubound = gfc_conv_descriptor_ubound_get (desc, gfc_index_zero_node);
8068 tree lbound = gfc_conv_descriptor_lbound_get (desc, gfc_index_zero_node);
8069
8070 *size = fold_build2_loc (input_location, MINUS_EXPR,
8071 gfc_array_index_type, ubound, lbound);
8072 *size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
8073 *size, gfc_index_one_node);
8074 *size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
8075 *size, gfc_index_zero_node);
8076 }
8077 elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
8078 *size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
8079 *size, fold_convert (gfc_array_index_type, elem));
8080 }
8081
8082 /* Helper function - return true if the argument is a pointer. */
8083
8084 static bool
is_pointer(gfc_expr * e)8085 is_pointer (gfc_expr *e)
8086 {
8087 gfc_symbol *sym;
8088
8089 if (e->expr_type != EXPR_VARIABLE || e->symtree == NULL)
8090 return false;
8091
8092 sym = e->symtree->n.sym;
8093 if (sym == NULL)
8094 return false;
8095
8096 return sym->attr.pointer || sym->attr.proc_pointer;
8097 }
8098
8099 /* Convert an array for passing as an actual parameter. */
8100
8101 void
gfc_conv_array_parameter(gfc_se * se,gfc_expr * expr,bool g77,const gfc_symbol * fsym,const char * proc_name,tree * size)8102 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
8103 const gfc_symbol *fsym, const char *proc_name,
8104 tree *size)
8105 {
8106 tree ptr;
8107 tree desc;
8108 tree tmp = NULL_TREE;
8109 tree stmt;
8110 tree parent = DECL_CONTEXT (current_function_decl);
8111 bool full_array_var;
8112 bool this_array_result;
8113 bool contiguous;
8114 bool no_pack;
8115 bool array_constructor;
8116 bool good_allocatable;
8117 bool ultimate_ptr_comp;
8118 bool ultimate_alloc_comp;
8119 gfc_symbol *sym;
8120 stmtblock_t block;
8121 gfc_ref *ref;
8122
8123 ultimate_ptr_comp = false;
8124 ultimate_alloc_comp = false;
8125
8126 for (ref = expr->ref; ref; ref = ref->next)
8127 {
8128 if (ref->next == NULL)
8129 break;
8130
8131 if (ref->type == REF_COMPONENT)
8132 {
8133 ultimate_ptr_comp = ref->u.c.component->attr.pointer;
8134 ultimate_alloc_comp = ref->u.c.component->attr.allocatable;
8135 }
8136 }
8137
8138 full_array_var = false;
8139 contiguous = false;
8140
8141 if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp)
8142 full_array_var = gfc_full_array_ref_p (ref, &contiguous);
8143
8144 sym = full_array_var ? expr->symtree->n.sym : NULL;
8145
8146 /* The symbol should have an array specification. */
8147 gcc_assert (!sym || sym->as || ref->u.ar.as);
8148
8149 if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
8150 {
8151 get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
8152 expr->ts.u.cl->backend_decl = tmp;
8153 se->string_length = tmp;
8154 }
8155
8156 /* Is this the result of the enclosing procedure? */
8157 this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
8158 if (this_array_result
8159 && (sym->backend_decl != current_function_decl)
8160 && (sym->backend_decl != parent))
8161 this_array_result = false;
8162
8163 /* Passing address of the array if it is not pointer or assumed-shape. */
8164 if (full_array_var && g77 && !this_array_result
8165 && sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
8166 {
8167 tmp = gfc_get_symbol_decl (sym);
8168
8169 if (sym->ts.type == BT_CHARACTER)
8170 se->string_length = sym->ts.u.cl->backend_decl;
8171
8172 if (!sym->attr.pointer
8173 && sym->as
8174 && sym->as->type != AS_ASSUMED_SHAPE
8175 && sym->as->type != AS_DEFERRED
8176 && sym->as->type != AS_ASSUMED_RANK
8177 && !sym->attr.allocatable)
8178 {
8179 /* Some variables are declared directly, others are declared as
8180 pointers and allocated on the heap. */
8181 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
8182 se->expr = tmp;
8183 else
8184 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
8185 if (size)
8186 array_parameter_size (tmp, expr, size);
8187 return;
8188 }
8189
8190 if (sym->attr.allocatable)
8191 {
8192 if (sym->attr.dummy || sym->attr.result)
8193 {
8194 gfc_conv_expr_descriptor (se, expr);
8195 tmp = se->expr;
8196 }
8197 if (size)
8198 array_parameter_size (tmp, expr, size);
8199 se->expr = gfc_conv_array_data (tmp);
8200 return;
8201 }
8202 }
8203
8204 /* A convenient reduction in scope. */
8205 contiguous = g77 && !this_array_result && contiguous;
8206
8207 /* There is no need to pack and unpack the array, if it is contiguous
8208 and not a deferred- or assumed-shape array, or if it is simply
8209 contiguous. */
8210 no_pack = ((sym && sym->as
8211 && !sym->attr.pointer
8212 && sym->as->type != AS_DEFERRED
8213 && sym->as->type != AS_ASSUMED_RANK
8214 && sym->as->type != AS_ASSUMED_SHAPE)
8215 ||
8216 (ref && ref->u.ar.as
8217 && ref->u.ar.as->type != AS_DEFERRED
8218 && ref->u.ar.as->type != AS_ASSUMED_RANK
8219 && ref->u.ar.as->type != AS_ASSUMED_SHAPE)
8220 ||
8221 gfc_is_simply_contiguous (expr, false, true));
8222
8223 no_pack = contiguous && no_pack;
8224
8225 /* If we have an EXPR_OP or a function returning an explicit-shaped
8226 or allocatable array, an array temporary will be generated which
8227 does not need to be packed / unpacked if passed to an
8228 explicit-shape dummy array. */
8229
8230 if (g77)
8231 {
8232 if (expr->expr_type == EXPR_OP)
8233 no_pack = 1;
8234 else if (expr->expr_type == EXPR_FUNCTION && expr->value.function.esym)
8235 {
8236 gfc_symbol *result = expr->value.function.esym->result;
8237 if (result->attr.dimension
8238 && (result->as->type == AS_EXPLICIT
8239 || result->attr.allocatable
8240 || result->attr.contiguous))
8241 no_pack = 1;
8242 }
8243 }
8244
8245 /* Array constructors are always contiguous and do not need packing. */
8246 array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY;
8247
8248 /* Same is true of contiguous sections from allocatable variables. */
8249 good_allocatable = contiguous
8250 && expr->symtree
8251 && expr->symtree->n.sym->attr.allocatable;
8252
8253 /* Or ultimate allocatable components. */
8254 ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
8255
8256 if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp)
8257 {
8258 gfc_conv_expr_descriptor (se, expr);
8259 /* Deallocate the allocatable components of structures that are
8260 not variable. */
8261 if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
8262 && expr->ts.u.derived->attr.alloc_comp
8263 && expr->expr_type != EXPR_VARIABLE)
8264 {
8265 tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, se->expr, expr->rank);
8266
8267 /* The components shall be deallocated before their containing entity. */
8268 gfc_prepend_expr_to_block (&se->post, tmp);
8269 }
8270 if (expr->ts.type == BT_CHARACTER && expr->expr_type != EXPR_FUNCTION)
8271 se->string_length = expr->ts.u.cl->backend_decl;
8272 if (size)
8273 array_parameter_size (se->expr, expr, size);
8274 se->expr = gfc_conv_array_data (se->expr);
8275 return;
8276 }
8277
8278 if (this_array_result)
8279 {
8280 /* Result of the enclosing function. */
8281 gfc_conv_expr_descriptor (se, expr);
8282 if (size)
8283 array_parameter_size (se->expr, expr, size);
8284 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
8285
8286 if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
8287 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
8288 se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location,
8289 se->expr));
8290
8291 return;
8292 }
8293 else
8294 {
8295 /* Every other type of array. */
8296 se->want_pointer = 1;
8297 gfc_conv_expr_descriptor (se, expr);
8298
8299 if (size)
8300 array_parameter_size (build_fold_indirect_ref_loc (input_location,
8301 se->expr),
8302 expr, size);
8303 }
8304
8305 /* Deallocate the allocatable components of structures that are
8306 not variable, for descriptorless arguments.
8307 Arguments with a descriptor are handled in gfc_conv_procedure_call. */
8308 if (g77 && (expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
8309 && expr->ts.u.derived->attr.alloc_comp
8310 && expr->expr_type != EXPR_VARIABLE)
8311 {
8312 tmp = build_fold_indirect_ref_loc (input_location, se->expr);
8313 tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank);
8314
8315 /* The components shall be deallocated before their containing entity. */
8316 gfc_prepend_expr_to_block (&se->post, tmp);
8317 }
8318
8319 if (g77 || (fsym && fsym->attr.contiguous
8320 && !gfc_is_simply_contiguous (expr, false, true)))
8321 {
8322 tree origptr = NULL_TREE;
8323
8324 desc = se->expr;
8325
8326 /* For contiguous arrays, save the original value of the descriptor. */
8327 if (!g77)
8328 {
8329 origptr = gfc_create_var (pvoid_type_node, "origptr");
8330 tmp = build_fold_indirect_ref_loc (input_location, desc);
8331 tmp = gfc_conv_array_data (tmp);
8332 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
8333 TREE_TYPE (origptr), origptr,
8334 fold_convert (TREE_TYPE (origptr), tmp));
8335 gfc_add_expr_to_block (&se->pre, tmp);
8336 }
8337
8338 /* Repack the array. */
8339 if (warn_array_temporaries)
8340 {
8341 if (fsym)
8342 gfc_warning (OPT_Warray_temporaries,
8343 "Creating array temporary at %L for argument %qs",
8344 &expr->where, fsym->name);
8345 else
8346 gfc_warning (OPT_Warray_temporaries,
8347 "Creating array temporary at %L", &expr->where);
8348 }
8349
8350 /* When optmizing, we can use gfc_conv_subref_array_arg for
8351 making the packing and unpacking operation visible to the
8352 optimizers. */
8353
8354 if (g77 && flag_inline_arg_packing && expr->expr_type == EXPR_VARIABLE
8355 && !is_pointer (expr) && ! gfc_has_dimen_vector_ref (expr)
8356 && !(expr->symtree->n.sym->as
8357 && expr->symtree->n.sym->as->type == AS_ASSUMED_RANK)
8358 && (fsym == NULL || fsym->ts.type != BT_ASSUMED))
8359 {
8360 gfc_conv_subref_array_arg (se, expr, g77,
8361 fsym ? fsym->attr.intent : INTENT_INOUT,
8362 false, fsym, proc_name, sym, true);
8363 return;
8364 }
8365
8366 ptr = build_call_expr_loc (input_location,
8367 gfor_fndecl_in_pack, 1, desc);
8368
8369 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
8370 {
8371 tmp = gfc_conv_expr_present (sym);
8372 ptr = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
8373 tmp, fold_convert (TREE_TYPE (se->expr), ptr),
8374 fold_convert (TREE_TYPE (se->expr), null_pointer_node));
8375 }
8376
8377 ptr = gfc_evaluate_now (ptr, &se->pre);
8378
8379 /* Use the packed data for the actual argument, except for contiguous arrays,
8380 where the descriptor's data component is set. */
8381 if (g77)
8382 se->expr = ptr;
8383 else
8384 {
8385 tmp = build_fold_indirect_ref_loc (input_location, desc);
8386
8387 gfc_ss * ss = gfc_walk_expr (expr);
8388 if (!transposed_dims (ss))
8389 gfc_conv_descriptor_data_set (&se->pre, tmp, ptr);
8390 else
8391 {
8392 tree old_field, new_field;
8393
8394 /* The original descriptor has transposed dims so we can't reuse
8395 it directly; we have to create a new one. */
8396 tree old_desc = tmp;
8397 tree new_desc = gfc_create_var (TREE_TYPE (old_desc), "arg_desc");
8398
8399 old_field = gfc_conv_descriptor_dtype (old_desc);
8400 new_field = gfc_conv_descriptor_dtype (new_desc);
8401 gfc_add_modify (&se->pre, new_field, old_field);
8402
8403 old_field = gfc_conv_descriptor_offset (old_desc);
8404 new_field = gfc_conv_descriptor_offset (new_desc);
8405 gfc_add_modify (&se->pre, new_field, old_field);
8406
8407 for (int i = 0; i < expr->rank; i++)
8408 {
8409 old_field = gfc_conv_descriptor_dimension (old_desc,
8410 gfc_rank_cst[get_array_ref_dim_for_loop_dim (ss, i)]);
8411 new_field = gfc_conv_descriptor_dimension (new_desc,
8412 gfc_rank_cst[i]);
8413 gfc_add_modify (&se->pre, new_field, old_field);
8414 }
8415
8416 if (flag_coarray == GFC_FCOARRAY_LIB
8417 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (old_desc))
8418 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (old_desc))
8419 == GFC_ARRAY_ALLOCATABLE)
8420 {
8421 old_field = gfc_conv_descriptor_token (old_desc);
8422 new_field = gfc_conv_descriptor_token (new_desc);
8423 gfc_add_modify (&se->pre, new_field, old_field);
8424 }
8425
8426 gfc_conv_descriptor_data_set (&se->pre, new_desc, ptr);
8427 se->expr = gfc_build_addr_expr (NULL_TREE, new_desc);
8428 }
8429 gfc_free_ss (ss);
8430 }
8431
8432 if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
8433 {
8434 char * msg;
8435
8436 if (fsym && proc_name)
8437 msg = xasprintf ("An array temporary was created for argument "
8438 "'%s' of procedure '%s'", fsym->name, proc_name);
8439 else
8440 msg = xasprintf ("An array temporary was created");
8441
8442 tmp = build_fold_indirect_ref_loc (input_location,
8443 desc);
8444 tmp = gfc_conv_array_data (tmp);
8445 tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
8446 fold_convert (TREE_TYPE (tmp), ptr), tmp);
8447
8448 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
8449 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
8450 logical_type_node,
8451 gfc_conv_expr_present (sym), tmp);
8452
8453 gfc_trans_runtime_check (false, true, tmp, &se->pre,
8454 &expr->where, msg);
8455 free (msg);
8456 }
8457
8458 gfc_start_block (&block);
8459
8460 /* Copy the data back. */
8461 if (fsym == NULL || fsym->attr.intent != INTENT_IN)
8462 {
8463 tmp = build_call_expr_loc (input_location,
8464 gfor_fndecl_in_unpack, 2, desc, ptr);
8465 gfc_add_expr_to_block (&block, tmp);
8466 }
8467
8468 /* Free the temporary. */
8469 tmp = gfc_call_free (ptr);
8470 gfc_add_expr_to_block (&block, tmp);
8471
8472 stmt = gfc_finish_block (&block);
8473
8474 gfc_init_block (&block);
8475 /* Only if it was repacked. This code needs to be executed before the
8476 loop cleanup code. */
8477 tmp = build_fold_indirect_ref_loc (input_location,
8478 desc);
8479 tmp = gfc_conv_array_data (tmp);
8480 tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
8481 fold_convert (TREE_TYPE (tmp), ptr), tmp);
8482
8483 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
8484 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
8485 logical_type_node,
8486 gfc_conv_expr_present (sym), tmp);
8487
8488 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
8489
8490 gfc_add_expr_to_block (&block, tmp);
8491 gfc_add_block_to_block (&block, &se->post);
8492
8493 gfc_init_block (&se->post);
8494
8495 /* Reset the descriptor pointer. */
8496 if (!g77)
8497 {
8498 tmp = build_fold_indirect_ref_loc (input_location, desc);
8499 gfc_conv_descriptor_data_set (&se->post, tmp, origptr);
8500 }
8501
8502 gfc_add_block_to_block (&se->post, &block);
8503 }
8504 }
8505
8506
8507 /* This helper function calculates the size in words of a full array. */
8508
8509 tree
gfc_full_array_size(stmtblock_t * block,tree decl,int rank)8510 gfc_full_array_size (stmtblock_t *block, tree decl, int rank)
8511 {
8512 tree idx;
8513 tree nelems;
8514 tree tmp;
8515 idx = gfc_rank_cst[rank - 1];
8516 nelems = gfc_conv_descriptor_ubound_get (decl, idx);
8517 tmp = gfc_conv_descriptor_lbound_get (decl, idx);
8518 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8519 nelems, tmp);
8520 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
8521 tmp, gfc_index_one_node);
8522 tmp = gfc_evaluate_now (tmp, block);
8523
8524 nelems = gfc_conv_descriptor_stride_get (decl, idx);
8525 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
8526 nelems, tmp);
8527 return gfc_evaluate_now (tmp, block);
8528 }
8529
8530
8531 /* Allocate dest to the same size as src, and copy src -> dest.
8532 If no_malloc is set, only the copy is done. */
8533
8534 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)8535 duplicate_allocatable (tree dest, tree src, tree type, int rank,
8536 bool no_malloc, bool no_memcpy, tree str_sz,
8537 tree add_when_allocated)
8538 {
8539 tree tmp;
8540 tree size;
8541 tree nelems;
8542 tree null_cond;
8543 tree null_data;
8544 stmtblock_t block;
8545
8546 /* If the source is null, set the destination to null. Then,
8547 allocate memory to the destination. */
8548 gfc_init_block (&block);
8549
8550 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
8551 {
8552 gfc_add_modify (&block, dest, fold_convert (type, null_pointer_node));
8553 null_data = gfc_finish_block (&block);
8554
8555 gfc_init_block (&block);
8556 if (str_sz != NULL_TREE)
8557 size = str_sz;
8558 else
8559 size = TYPE_SIZE_UNIT (TREE_TYPE (type));
8560
8561 if (!no_malloc)
8562 {
8563 tmp = gfc_call_malloc (&block, type, size);
8564 gfc_add_modify (&block, dest, fold_convert (type, tmp));
8565 }
8566
8567 if (!no_memcpy)
8568 {
8569 tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
8570 tmp = build_call_expr_loc (input_location, tmp, 3, dest, src,
8571 fold_convert (size_type_node, size));
8572 gfc_add_expr_to_block (&block, tmp);
8573 }
8574 }
8575 else
8576 {
8577 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
8578 null_data = gfc_finish_block (&block);
8579
8580 gfc_init_block (&block);
8581 if (rank)
8582 nelems = gfc_full_array_size (&block, src, rank);
8583 else
8584 nelems = gfc_index_one_node;
8585
8586 if (str_sz != NULL_TREE)
8587 tmp = fold_convert (gfc_array_index_type, str_sz);
8588 else
8589 tmp = fold_convert (gfc_array_index_type,
8590 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
8591 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
8592 nelems, tmp);
8593 if (!no_malloc)
8594 {
8595 tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src));
8596 tmp = gfc_call_malloc (&block, tmp, size);
8597 gfc_conv_descriptor_data_set (&block, dest, tmp);
8598 }
8599
8600 /* We know the temporary and the value will be the same length,
8601 so can use memcpy. */
8602 if (!no_memcpy)
8603 {
8604 tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
8605 tmp = build_call_expr_loc (input_location, tmp, 3,
8606 gfc_conv_descriptor_data_get (dest),
8607 gfc_conv_descriptor_data_get (src),
8608 fold_convert (size_type_node, size));
8609 gfc_add_expr_to_block (&block, tmp);
8610 }
8611 }
8612
8613 gfc_add_expr_to_block (&block, add_when_allocated);
8614 tmp = gfc_finish_block (&block);
8615
8616 /* Null the destination if the source is null; otherwise do
8617 the allocate and copy. */
8618 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src)))
8619 null_cond = src;
8620 else
8621 null_cond = gfc_conv_descriptor_data_get (src);
8622
8623 null_cond = convert (pvoid_type_node, null_cond);
8624 null_cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
8625 null_cond, null_pointer_node);
8626 return build3_v (COND_EXPR, null_cond, tmp, null_data);
8627 }
8628
8629
8630 /* Allocate dest to the same size as src, and copy data src -> dest. */
8631
8632 tree
gfc_duplicate_allocatable(tree dest,tree src,tree type,int rank,tree add_when_allocated)8633 gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank,
8634 tree add_when_allocated)
8635 {
8636 return duplicate_allocatable (dest, src, type, rank, false, false,
8637 NULL_TREE, add_when_allocated);
8638 }
8639
8640
8641 /* Copy data src -> dest. */
8642
8643 tree
gfc_copy_allocatable_data(tree dest,tree src,tree type,int rank)8644 gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
8645 {
8646 return duplicate_allocatable (dest, src, type, rank, true, false,
8647 NULL_TREE, NULL_TREE);
8648 }
8649
8650 /* Allocate dest to the same size as src, but don't copy anything. */
8651
8652 tree
gfc_duplicate_allocatable_nocopy(tree dest,tree src,tree type,int rank)8653 gfc_duplicate_allocatable_nocopy (tree dest, tree src, tree type, int rank)
8654 {
8655 return duplicate_allocatable (dest, src, type, rank, false, true,
8656 NULL_TREE, NULL_TREE);
8657 }
8658
8659
8660 static tree
duplicate_allocatable_coarray(tree dest,tree dest_tok,tree src,tree type,int rank)8661 duplicate_allocatable_coarray (tree dest, tree dest_tok, tree src,
8662 tree type, int rank)
8663 {
8664 tree tmp;
8665 tree size;
8666 tree nelems;
8667 tree null_cond;
8668 tree null_data;
8669 stmtblock_t block, globalblock;
8670
8671 /* If the source is null, set the destination to null. Then,
8672 allocate memory to the destination. */
8673 gfc_init_block (&block);
8674 gfc_init_block (&globalblock);
8675
8676 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
8677 {
8678 gfc_se se;
8679 symbol_attribute attr;
8680 tree dummy_desc;
8681
8682 gfc_init_se (&se, NULL);
8683 gfc_clear_attr (&attr);
8684 attr.allocatable = 1;
8685 dummy_desc = gfc_conv_scalar_to_descriptor (&se, dest, attr);
8686 gfc_add_block_to_block (&globalblock, &se.pre);
8687 size = TYPE_SIZE_UNIT (TREE_TYPE (type));
8688
8689 gfc_add_modify (&block, dest, fold_convert (type, null_pointer_node));
8690 gfc_allocate_using_caf_lib (&block, dummy_desc, size,
8691 gfc_build_addr_expr (NULL_TREE, dest_tok),
8692 NULL_TREE, NULL_TREE, NULL_TREE,
8693 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
8694 null_data = gfc_finish_block (&block);
8695
8696 gfc_init_block (&block);
8697
8698 gfc_allocate_using_caf_lib (&block, dummy_desc,
8699 fold_convert (size_type_node, size),
8700 gfc_build_addr_expr (NULL_TREE, dest_tok),
8701 NULL_TREE, NULL_TREE, NULL_TREE,
8702 GFC_CAF_COARRAY_ALLOC);
8703
8704 tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
8705 tmp = build_call_expr_loc (input_location, tmp, 3, dest, src,
8706 fold_convert (size_type_node, size));
8707 gfc_add_expr_to_block (&block, tmp);
8708 }
8709 else
8710 {
8711 /* Set the rank or unitialized memory access may be reported. */
8712 tmp = gfc_conv_descriptor_rank (dest);
8713 gfc_add_modify (&globalblock, tmp, build_int_cst (TREE_TYPE (tmp), rank));
8714
8715 if (rank)
8716 nelems = gfc_full_array_size (&block, src, rank);
8717 else
8718 nelems = integer_one_node;
8719
8720 tmp = fold_convert (size_type_node,
8721 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
8722 size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
8723 fold_convert (size_type_node, nelems), tmp);
8724
8725 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
8726 gfc_allocate_using_caf_lib (&block, dest, fold_convert (size_type_node,
8727 size),
8728 gfc_build_addr_expr (NULL_TREE, dest_tok),
8729 NULL_TREE, NULL_TREE, NULL_TREE,
8730 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
8731 null_data = gfc_finish_block (&block);
8732
8733 gfc_init_block (&block);
8734 gfc_allocate_using_caf_lib (&block, dest,
8735 fold_convert (size_type_node, size),
8736 gfc_build_addr_expr (NULL_TREE, dest_tok),
8737 NULL_TREE, NULL_TREE, NULL_TREE,
8738 GFC_CAF_COARRAY_ALLOC);
8739
8740 tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
8741 tmp = build_call_expr_loc (input_location, tmp, 3,
8742 gfc_conv_descriptor_data_get (dest),
8743 gfc_conv_descriptor_data_get (src),
8744 fold_convert (size_type_node, size));
8745 gfc_add_expr_to_block (&block, tmp);
8746 }
8747
8748 tmp = gfc_finish_block (&block);
8749
8750 /* Null the destination if the source is null; otherwise do
8751 the register and copy. */
8752 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src)))
8753 null_cond = src;
8754 else
8755 null_cond = gfc_conv_descriptor_data_get (src);
8756
8757 null_cond = convert (pvoid_type_node, null_cond);
8758 null_cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
8759 null_cond, null_pointer_node);
8760 gfc_add_expr_to_block (&globalblock, build3_v (COND_EXPR, null_cond, tmp,
8761 null_data));
8762 return gfc_finish_block (&globalblock);
8763 }
8764
8765
8766 /* Helper function to abstract whether coarray processing is enabled. */
8767
8768 static bool
caf_enabled(int caf_mode)8769 caf_enabled (int caf_mode)
8770 {
8771 return (caf_mode & GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY)
8772 == GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY;
8773 }
8774
8775
8776 /* Helper function to abstract whether coarray processing is enabled
8777 and we are in a derived type coarray. */
8778
8779 static bool
caf_in_coarray(int caf_mode)8780 caf_in_coarray (int caf_mode)
8781 {
8782 static const int pat = GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
8783 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY;
8784 return (caf_mode & pat) == pat;
8785 }
8786
8787
8788 /* Helper function to abstract whether coarray is to deallocate only. */
8789
8790 bool
gfc_caf_is_dealloc_only(int caf_mode)8791 gfc_caf_is_dealloc_only (int caf_mode)
8792 {
8793 return (caf_mode & GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY)
8794 == GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY;
8795 }
8796
8797
8798 /* Recursively traverse an object of derived type, generating code to
8799 deallocate, nullify or copy allocatable components. This is the work horse
8800 function for the functions named in this enum. */
8801
8802 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP,
8803 COPY_ALLOC_COMP, COPY_ONLY_ALLOC_COMP, REASSIGN_CAF_COMP,
8804 ALLOCATE_PDT_COMP, DEALLOCATE_PDT_COMP, CHECK_PDT_DUMMY,
8805 BCAST_ALLOC_COMP};
8806
8807 static gfc_actual_arglist *pdt_param_list;
8808
8809 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)8810 structure_alloc_comps (gfc_symbol * der_type, tree decl,
8811 tree dest, int rank, int purpose, int caf_mode,
8812 gfc_co_subroutines_args *args)
8813 {
8814 gfc_component *c;
8815 gfc_loopinfo loop;
8816 stmtblock_t fnblock;
8817 stmtblock_t loopbody;
8818 stmtblock_t tmpblock;
8819 tree decl_type;
8820 tree tmp;
8821 tree comp;
8822 tree dcmp;
8823 tree nelems;
8824 tree index;
8825 tree var;
8826 tree cdecl;
8827 tree ctype;
8828 tree vref, dref;
8829 tree null_cond = NULL_TREE;
8830 tree add_when_allocated;
8831 tree dealloc_fndecl;
8832 tree caf_token;
8833 gfc_symbol *vtab;
8834 int caf_dereg_mode;
8835 symbol_attribute *attr;
8836 bool deallocate_called;
8837
8838 gfc_init_block (&fnblock);
8839
8840 decl_type = TREE_TYPE (decl);
8841
8842 if ((POINTER_TYPE_P (decl_type))
8843 || (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == 0))
8844 {
8845 decl = build_fold_indirect_ref_loc (input_location, decl);
8846 /* Deref dest in sync with decl, but only when it is not NULL. */
8847 if (dest)
8848 dest = build_fold_indirect_ref_loc (input_location, dest);
8849
8850 /* Update the decl_type because it got dereferenced. */
8851 decl_type = TREE_TYPE (decl);
8852 }
8853
8854 /* If this is an array of derived types with allocatable components
8855 build a loop and recursively call this function. */
8856 if (TREE_CODE (decl_type) == ARRAY_TYPE
8857 || (GFC_DESCRIPTOR_TYPE_P (decl_type) && rank != 0))
8858 {
8859 tmp = gfc_conv_array_data (decl);
8860 var = build_fold_indirect_ref_loc (input_location, tmp);
8861
8862 /* Get the number of elements - 1 and set the counter. */
8863 if (GFC_DESCRIPTOR_TYPE_P (decl_type))
8864 {
8865 /* Use the descriptor for an allocatable array. Since this
8866 is a full array reference, we only need the descriptor
8867 information from dimension = rank. */
8868 tmp = gfc_full_array_size (&fnblock, decl, rank);
8869 tmp = fold_build2_loc (input_location, MINUS_EXPR,
8870 gfc_array_index_type, tmp,
8871 gfc_index_one_node);
8872
8873 null_cond = gfc_conv_descriptor_data_get (decl);
8874 null_cond = fold_build2_loc (input_location, NE_EXPR,
8875 logical_type_node, null_cond,
8876 build_int_cst (TREE_TYPE (null_cond), 0));
8877 }
8878 else
8879 {
8880 /* Otherwise use the TYPE_DOMAIN information. */
8881 tmp = array_type_nelts (decl_type);
8882 tmp = fold_convert (gfc_array_index_type, tmp);
8883 }
8884
8885 /* Remember that this is, in fact, the no. of elements - 1. */
8886 nelems = gfc_evaluate_now (tmp, &fnblock);
8887 index = gfc_create_var (gfc_array_index_type, "S");
8888
8889 /* Build the body of the loop. */
8890 gfc_init_block (&loopbody);
8891
8892 vref = gfc_build_array_ref (var, index, NULL);
8893
8894 if ((purpose == COPY_ALLOC_COMP || purpose == COPY_ONLY_ALLOC_COMP)
8895 && !caf_enabled (caf_mode))
8896 {
8897 tmp = build_fold_indirect_ref_loc (input_location,
8898 gfc_conv_array_data (dest));
8899 dref = gfc_build_array_ref (tmp, index, NULL);
8900 tmp = structure_alloc_comps (der_type, vref, dref, rank,
8901 COPY_ALLOC_COMP, 0, args);
8902 }
8903 else
8904 tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose,
8905 caf_mode, args);
8906
8907 gfc_add_expr_to_block (&loopbody, tmp);
8908
8909 /* Build the loop and return. */
8910 gfc_init_loopinfo (&loop);
8911 loop.dimen = 1;
8912 loop.from[0] = gfc_index_zero_node;
8913 loop.loopvar[0] = index;
8914 loop.to[0] = nelems;
8915 gfc_trans_scalarizing_loops (&loop, &loopbody);
8916 gfc_add_block_to_block (&fnblock, &loop.pre);
8917
8918 tmp = gfc_finish_block (&fnblock);
8919 /* When copying allocateable components, the above implements the
8920 deep copy. Nevertheless is a deep copy only allowed, when the current
8921 component is allocated, for which code will be generated in
8922 gfc_duplicate_allocatable (), where the deep copy code is just added
8923 into the if's body, by adding tmp (the deep copy code) as last
8924 argument to gfc_duplicate_allocatable (). */
8925 if (purpose == COPY_ALLOC_COMP
8926 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
8927 tmp = gfc_duplicate_allocatable (dest, decl, decl_type, rank,
8928 tmp);
8929 else if (null_cond != NULL_TREE)
8930 tmp = build3_v (COND_EXPR, null_cond, tmp,
8931 build_empty_stmt (input_location));
8932
8933 return tmp;
8934 }
8935
8936 if (purpose == DEALLOCATE_ALLOC_COMP && der_type->attr.pdt_type)
8937 {
8938 tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
8939 DEALLOCATE_PDT_COMP, 0, args);
8940 gfc_add_expr_to_block (&fnblock, tmp);
8941 }
8942 else if (purpose == ALLOCATE_PDT_COMP && der_type->attr.alloc_comp)
8943 {
8944 tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
8945 NULLIFY_ALLOC_COMP, 0, args);
8946 gfc_add_expr_to_block (&fnblock, tmp);
8947 }
8948
8949 /* Otherwise, act on the components or recursively call self to
8950 act on a chain of components. */
8951 for (c = der_type->components; c; c = c->next)
8952 {
8953 bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED
8954 || c->ts.type == BT_CLASS)
8955 && c->ts.u.derived->attr.alloc_comp;
8956 bool same_type = (c->ts.type == BT_DERIVED && der_type == c->ts.u.derived)
8957 || (c->ts.type == BT_CLASS && der_type == CLASS_DATA (c)->ts.u.derived);
8958
8959 bool is_pdt_type = c->ts.type == BT_DERIVED
8960 && c->ts.u.derived->attr.pdt_type;
8961
8962 cdecl = c->backend_decl;
8963 ctype = TREE_TYPE (cdecl);
8964
8965 switch (purpose)
8966 {
8967
8968 case BCAST_ALLOC_COMP:
8969
8970 tree ubound;
8971 tree cdesc;
8972 stmtblock_t derived_type_block;
8973
8974 gfc_init_block (&tmpblock);
8975
8976 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
8977 decl, cdecl, NULL_TREE);
8978
8979 /* Shortcut to get the attributes of the component. */
8980 if (c->ts.type == BT_CLASS)
8981 {
8982 attr = &CLASS_DATA (c)->attr;
8983 if (attr->class_pointer)
8984 continue;
8985 }
8986 else
8987 {
8988 attr = &c->attr;
8989 if (attr->pointer)
8990 continue;
8991 }
8992
8993 add_when_allocated = NULL_TREE;
8994 if (cmp_has_alloc_comps
8995 && !c->attr.pointer && !c->attr.proc_pointer)
8996 {
8997 if (c->ts.type == BT_CLASS)
8998 {
8999 rank = CLASS_DATA (c)->as ? CLASS_DATA (c)->as->rank : 0;
9000 add_when_allocated
9001 = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
9002 comp, NULL_TREE, rank, purpose,
9003 caf_mode, args);
9004 }
9005 else
9006 {
9007 rank = c->as ? c->as->rank : 0;
9008 add_when_allocated = structure_alloc_comps (c->ts.u.derived,
9009 comp, NULL_TREE,
9010 rank, purpose,
9011 caf_mode, args);
9012 }
9013 }
9014
9015 gfc_init_block (&derived_type_block);
9016 if (add_when_allocated)
9017 gfc_add_expr_to_block (&derived_type_block, add_when_allocated);
9018 tmp = gfc_finish_block (&derived_type_block);
9019 gfc_add_expr_to_block (&tmpblock, tmp);
9020
9021 /* Convert the component into a rank 1 descriptor type. */
9022 if (attr->dimension)
9023 {
9024 tmp = gfc_get_element_type (TREE_TYPE (comp));
9025 ubound = gfc_full_array_size (&tmpblock, comp,
9026 c->ts.type == BT_CLASS
9027 ? CLASS_DATA (c)->as->rank
9028 : c->as->rank);
9029 }
9030 else
9031 {
9032 tmp = TREE_TYPE (comp);
9033 ubound = build_int_cst (gfc_array_index_type, 1);
9034 }
9035
9036 cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node,
9037 &ubound, 1,
9038 GFC_ARRAY_ALLOCATABLE, false);
9039
9040 cdesc = gfc_create_var (cdesc, "cdesc");
9041 DECL_ARTIFICIAL (cdesc) = 1;
9042
9043 gfc_add_modify (&tmpblock, gfc_conv_descriptor_dtype (cdesc),
9044 gfc_get_dtype_rank_type (1, tmp));
9045 gfc_conv_descriptor_lbound_set (&tmpblock, cdesc,
9046 gfc_index_zero_node,
9047 gfc_index_one_node);
9048 gfc_conv_descriptor_stride_set (&tmpblock, cdesc,
9049 gfc_index_zero_node,
9050 gfc_index_one_node);
9051 gfc_conv_descriptor_ubound_set (&tmpblock, cdesc,
9052 gfc_index_zero_node, ubound);
9053
9054 if (attr->dimension)
9055 comp = gfc_conv_descriptor_data_get (comp);
9056 else
9057 {
9058 gfc_se se;
9059
9060 gfc_init_se (&se, NULL);
9061
9062 comp = gfc_conv_scalar_to_descriptor (&se, comp,
9063 c->ts.type == BT_CLASS
9064 ? CLASS_DATA (c)->attr
9065 : c->attr);
9066 comp = gfc_build_addr_expr (NULL_TREE, comp);
9067 gfc_add_block_to_block (&tmpblock, &se.pre);
9068 }
9069
9070 gfc_conv_descriptor_data_set (&tmpblock, cdesc, comp);
9071
9072 tree fndecl;
9073
9074 fndecl = build_call_expr_loc (input_location,
9075 gfor_fndecl_co_broadcast, 5,
9076 gfc_build_addr_expr (pvoid_type_node,cdesc),
9077 args->image_index,
9078 null_pointer_node, null_pointer_node,
9079 null_pointer_node);
9080
9081 gfc_add_expr_to_block (&tmpblock, fndecl);
9082 gfc_add_block_to_block (&fnblock, &tmpblock);
9083
9084 break;
9085
9086 case DEALLOCATE_ALLOC_COMP:
9087
9088 gfc_init_block (&tmpblock);
9089
9090 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
9091 decl, cdecl, NULL_TREE);
9092
9093 /* Shortcut to get the attributes of the component. */
9094 if (c->ts.type == BT_CLASS)
9095 {
9096 attr = &CLASS_DATA (c)->attr;
9097 if (attr->class_pointer)
9098 continue;
9099 }
9100 else
9101 {
9102 attr = &c->attr;
9103 if (attr->pointer)
9104 continue;
9105 }
9106
9107 if ((c->ts.type == BT_DERIVED && !c->attr.pointer)
9108 || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer))
9109 /* Call the finalizer, which will free the memory and nullify the
9110 pointer of an array. */
9111 deallocate_called = gfc_add_comp_finalizer_call (&tmpblock, comp, c,
9112 caf_enabled (caf_mode))
9113 && attr->dimension;
9114 else
9115 deallocate_called = false;
9116
9117 /* Add the _class ref for classes. */
9118 if (c->ts.type == BT_CLASS && attr->allocatable)
9119 comp = gfc_class_data_get (comp);
9120
9121 add_when_allocated = NULL_TREE;
9122 if (cmp_has_alloc_comps
9123 && !c->attr.pointer && !c->attr.proc_pointer
9124 && !same_type
9125 && !deallocate_called)
9126 {
9127 /* Add checked deallocation of the components. This code is
9128 obviously added because the finalizer is not trusted to free
9129 all memory. */
9130 if (c->ts.type == BT_CLASS)
9131 {
9132 rank = CLASS_DATA (c)->as ? CLASS_DATA (c)->as->rank : 0;
9133 add_when_allocated
9134 = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
9135 comp, NULL_TREE, rank, purpose,
9136 caf_mode, args);
9137 }
9138 else
9139 {
9140 rank = c->as ? c->as->rank : 0;
9141 add_when_allocated = structure_alloc_comps (c->ts.u.derived,
9142 comp, NULL_TREE,
9143 rank, purpose,
9144 caf_mode, args);
9145 }
9146 }
9147
9148 if (attr->allocatable && !same_type
9149 && (!attr->codimension || caf_enabled (caf_mode)))
9150 {
9151 /* Handle all types of components besides components of the
9152 same_type as the current one, because those would create an
9153 endless loop. */
9154 caf_dereg_mode
9155 = (caf_in_coarray (caf_mode) || attr->codimension)
9156 ? (gfc_caf_is_dealloc_only (caf_mode)
9157 ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
9158 : GFC_CAF_COARRAY_DEREGISTER)
9159 : GFC_CAF_COARRAY_NOCOARRAY;
9160
9161 caf_token = NULL_TREE;
9162 /* Coarray components are handled directly by
9163 deallocate_with_status. */
9164 if (!attr->codimension
9165 && caf_dereg_mode != GFC_CAF_COARRAY_NOCOARRAY)
9166 {
9167 if (c->caf_token)
9168 caf_token = fold_build3_loc (input_location, COMPONENT_REF,
9169 TREE_TYPE (c->caf_token),
9170 decl, c->caf_token, NULL_TREE);
9171 else if (attr->dimension && !attr->proc_pointer)
9172 caf_token = gfc_conv_descriptor_token (comp);
9173 }
9174 if (attr->dimension && !attr->codimension && !attr->proc_pointer)
9175 /* When this is an array but not in conjunction with a coarray
9176 then add the data-ref. For coarray'ed arrays the data-ref
9177 is added by deallocate_with_status. */
9178 comp = gfc_conv_descriptor_data_get (comp);
9179
9180 tmp = gfc_deallocate_with_status (comp, NULL_TREE, NULL_TREE,
9181 NULL_TREE, NULL_TREE, true,
9182 NULL, caf_dereg_mode,
9183 add_when_allocated, caf_token);
9184
9185 gfc_add_expr_to_block (&tmpblock, tmp);
9186 }
9187 else if (attr->allocatable && !attr->codimension
9188 && !deallocate_called)
9189 {
9190 /* Case of recursive allocatable derived types. */
9191 tree is_allocated;
9192 tree ubound;
9193 tree cdesc;
9194 stmtblock_t dealloc_block;
9195
9196 gfc_init_block (&dealloc_block);
9197 if (add_when_allocated)
9198 gfc_add_expr_to_block (&dealloc_block, add_when_allocated);
9199
9200 /* Convert the component into a rank 1 descriptor type. */
9201 if (attr->dimension)
9202 {
9203 tmp = gfc_get_element_type (TREE_TYPE (comp));
9204 ubound = gfc_full_array_size (&dealloc_block, comp,
9205 c->ts.type == BT_CLASS
9206 ? CLASS_DATA (c)->as->rank
9207 : c->as->rank);
9208 }
9209 else
9210 {
9211 tmp = TREE_TYPE (comp);
9212 ubound = build_int_cst (gfc_array_index_type, 1);
9213 }
9214
9215 cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node,
9216 &ubound, 1,
9217 GFC_ARRAY_ALLOCATABLE, false);
9218
9219 cdesc = gfc_create_var (cdesc, "cdesc");
9220 DECL_ARTIFICIAL (cdesc) = 1;
9221
9222 gfc_add_modify (&dealloc_block, gfc_conv_descriptor_dtype (cdesc),
9223 gfc_get_dtype_rank_type (1, tmp));
9224 gfc_conv_descriptor_lbound_set (&dealloc_block, cdesc,
9225 gfc_index_zero_node,
9226 gfc_index_one_node);
9227 gfc_conv_descriptor_stride_set (&dealloc_block, cdesc,
9228 gfc_index_zero_node,
9229 gfc_index_one_node);
9230 gfc_conv_descriptor_ubound_set (&dealloc_block, cdesc,
9231 gfc_index_zero_node, ubound);
9232
9233 if (attr->dimension)
9234 comp = gfc_conv_descriptor_data_get (comp);
9235
9236 gfc_conv_descriptor_data_set (&dealloc_block, cdesc, comp);
9237
9238 /* Now call the deallocator. */
9239 vtab = gfc_find_vtab (&c->ts);
9240 if (vtab->backend_decl == NULL)
9241 gfc_get_symbol_decl (vtab);
9242 tmp = gfc_build_addr_expr (NULL_TREE, vtab->backend_decl);
9243 dealloc_fndecl = gfc_vptr_deallocate_get (tmp);
9244 dealloc_fndecl = build_fold_indirect_ref_loc (input_location,
9245 dealloc_fndecl);
9246 tmp = build_int_cst (TREE_TYPE (comp), 0);
9247 is_allocated = fold_build2_loc (input_location, NE_EXPR,
9248 logical_type_node, tmp,
9249 comp);
9250 cdesc = gfc_build_addr_expr (NULL_TREE, cdesc);
9251
9252 tmp = build_call_expr_loc (input_location,
9253 dealloc_fndecl, 1,
9254 cdesc);
9255 gfc_add_expr_to_block (&dealloc_block, tmp);
9256
9257 tmp = gfc_finish_block (&dealloc_block);
9258
9259 tmp = fold_build3_loc (input_location, COND_EXPR,
9260 void_type_node, is_allocated, tmp,
9261 build_empty_stmt (input_location));
9262
9263 gfc_add_expr_to_block (&tmpblock, tmp);
9264 }
9265 else if (add_when_allocated)
9266 gfc_add_expr_to_block (&tmpblock, add_when_allocated);
9267
9268 if (c->ts.type == BT_CLASS && attr->allocatable
9269 && (!attr->codimension || !caf_enabled (caf_mode)))
9270 {
9271 /* Finally, reset the vptr to the declared type vtable and, if
9272 necessary reset the _len field.
9273
9274 First recover the reference to the component and obtain
9275 the vptr. */
9276 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
9277 decl, cdecl, NULL_TREE);
9278 tmp = gfc_class_vptr_get (comp);
9279
9280 if (UNLIMITED_POLY (c))
9281 {
9282 /* Both vptr and _len field should be nulled. */
9283 gfc_add_modify (&tmpblock, tmp,
9284 build_int_cst (TREE_TYPE (tmp), 0));
9285 tmp = gfc_class_len_get (comp);
9286 gfc_add_modify (&tmpblock, tmp,
9287 build_int_cst (TREE_TYPE (tmp), 0));
9288 }
9289 else
9290 {
9291 /* Build the vtable address and set the vptr with it. */
9292 tree vtab;
9293 gfc_symbol *vtable;
9294 vtable = gfc_find_derived_vtab (c->ts.u.derived);
9295 vtab = vtable->backend_decl;
9296 if (vtab == NULL_TREE)
9297 vtab = gfc_get_symbol_decl (vtable);
9298 vtab = gfc_build_addr_expr (NULL, vtab);
9299 vtab = fold_convert (TREE_TYPE (tmp), vtab);
9300 gfc_add_modify (&tmpblock, tmp, vtab);
9301 }
9302 }
9303
9304 /* Now add the deallocation of this component. */
9305 gfc_add_block_to_block (&fnblock, &tmpblock);
9306 break;
9307
9308 case NULLIFY_ALLOC_COMP:
9309 /* Nullify
9310 - allocatable components (regular or in class)
9311 - components that have allocatable components
9312 - pointer components when in a coarray.
9313 Skip everything else especially proc_pointers, which may come
9314 coupled with the regular pointer attribute. */
9315 if (c->attr.proc_pointer
9316 || !(c->attr.allocatable || (c->ts.type == BT_CLASS
9317 && CLASS_DATA (c)->attr.allocatable)
9318 || (cmp_has_alloc_comps
9319 && ((c->ts.type == BT_DERIVED && !c->attr.pointer)
9320 || (c->ts.type == BT_CLASS
9321 && !CLASS_DATA (c)->attr.class_pointer)))
9322 || (caf_in_coarray (caf_mode) && c->attr.pointer)))
9323 continue;
9324
9325 /* Process class components first, because they always have the
9326 pointer-attribute set which would be caught wrong else. */
9327 if (c->ts.type == BT_CLASS
9328 && (CLASS_DATA (c)->attr.allocatable
9329 || CLASS_DATA (c)->attr.class_pointer))
9330 {
9331 tree vptr_decl;
9332
9333 /* Allocatable CLASS components. */
9334 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
9335 decl, cdecl, NULL_TREE);
9336
9337 vptr_decl = gfc_class_vptr_get (comp);
9338
9339 comp = gfc_class_data_get (comp);
9340 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
9341 gfc_conv_descriptor_data_set (&fnblock, comp,
9342 null_pointer_node);
9343 else
9344 {
9345 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
9346 void_type_node, comp,
9347 build_int_cst (TREE_TYPE (comp), 0));
9348 gfc_add_expr_to_block (&fnblock, tmp);
9349 }
9350
9351 /* The dynamic type of a disassociated pointer or unallocated
9352 allocatable variable is its declared type. An unlimited
9353 polymorphic entity has no declared type. */
9354 if (!UNLIMITED_POLY (c))
9355 {
9356 vtab = gfc_find_derived_vtab (c->ts.u.derived);
9357 if (!vtab->backend_decl)
9358 gfc_get_symbol_decl (vtab);
9359 tmp = gfc_build_addr_expr (NULL_TREE, vtab->backend_decl);
9360 }
9361 else
9362 tmp = build_int_cst (TREE_TYPE (vptr_decl), 0);
9363
9364 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
9365 void_type_node, vptr_decl, tmp);
9366 gfc_add_expr_to_block (&fnblock, tmp);
9367
9368 cmp_has_alloc_comps = false;
9369 }
9370 /* Coarrays need the component to be nulled before the api-call
9371 is made. */
9372 else if (c->attr.pointer || c->attr.allocatable)
9373 {
9374 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
9375 decl, cdecl, NULL_TREE);
9376 if (c->attr.dimension || c->attr.codimension)
9377 gfc_conv_descriptor_data_set (&fnblock, comp,
9378 null_pointer_node);
9379 else
9380 gfc_add_modify (&fnblock, comp,
9381 build_int_cst (TREE_TYPE (comp), 0));
9382 if (gfc_deferred_strlen (c, &comp))
9383 {
9384 comp = fold_build3_loc (input_location, COMPONENT_REF,
9385 TREE_TYPE (comp),
9386 decl, comp, NULL_TREE);
9387 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
9388 TREE_TYPE (comp), comp,
9389 build_int_cst (TREE_TYPE (comp), 0));
9390 gfc_add_expr_to_block (&fnblock, tmp);
9391 }
9392 cmp_has_alloc_comps = false;
9393 }
9394
9395 if (flag_coarray == GFC_FCOARRAY_LIB && caf_in_coarray (caf_mode))
9396 {
9397 /* Register a component of a derived type coarray with the
9398 coarray library. Do not register ultimate component
9399 coarrays here. They are treated like regular coarrays and
9400 are either allocated on all images or on none. */
9401 tree token;
9402
9403 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
9404 decl, cdecl, NULL_TREE);
9405 if (c->attr.dimension)
9406 {
9407 /* Set the dtype, because caf_register needs it. */
9408 gfc_add_modify (&fnblock, gfc_conv_descriptor_dtype (comp),
9409 gfc_get_dtype (TREE_TYPE (comp)));
9410 tmp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
9411 decl, cdecl, NULL_TREE);
9412 token = gfc_conv_descriptor_token (tmp);
9413 }
9414 else
9415 {
9416 gfc_se se;
9417
9418 gfc_init_se (&se, NULL);
9419 token = fold_build3_loc (input_location, COMPONENT_REF,
9420 pvoid_type_node, decl, c->caf_token,
9421 NULL_TREE);
9422 comp = gfc_conv_scalar_to_descriptor (&se, comp,
9423 c->ts.type == BT_CLASS
9424 ? CLASS_DATA (c)->attr
9425 : c->attr);
9426 gfc_add_block_to_block (&fnblock, &se.pre);
9427 }
9428
9429 gfc_allocate_using_caf_lib (&fnblock, comp, size_zero_node,
9430 gfc_build_addr_expr (NULL_TREE,
9431 token),
9432 NULL_TREE, NULL_TREE, NULL_TREE,
9433 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
9434 }
9435
9436 if (cmp_has_alloc_comps)
9437 {
9438 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
9439 decl, cdecl, NULL_TREE);
9440 rank = c->as ? c->as->rank : 0;
9441 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
9442 rank, purpose, caf_mode, args);
9443 gfc_add_expr_to_block (&fnblock, tmp);
9444 }
9445 break;
9446
9447 case REASSIGN_CAF_COMP:
9448 if (caf_enabled (caf_mode)
9449 && (c->attr.codimension
9450 || (c->ts.type == BT_CLASS
9451 && (CLASS_DATA (c)->attr.coarray_comp
9452 || caf_in_coarray (caf_mode)))
9453 || (c->ts.type == BT_DERIVED
9454 && (c->ts.u.derived->attr.coarray_comp
9455 || caf_in_coarray (caf_mode))))
9456 && !same_type)
9457 {
9458 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
9459 decl, cdecl, NULL_TREE);
9460 dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
9461 dest, cdecl, NULL_TREE);
9462
9463 if (c->attr.codimension)
9464 {
9465 if (c->ts.type == BT_CLASS)
9466 {
9467 comp = gfc_class_data_get (comp);
9468 dcmp = gfc_class_data_get (dcmp);
9469 }
9470 gfc_conv_descriptor_data_set (&fnblock, dcmp,
9471 gfc_conv_descriptor_data_get (comp));
9472 }
9473 else
9474 {
9475 tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
9476 rank, purpose, caf_mode
9477 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY,
9478 args);
9479 gfc_add_expr_to_block (&fnblock, tmp);
9480 }
9481 }
9482 break;
9483
9484 case COPY_ALLOC_COMP:
9485 if (c->attr.pointer || c->attr.proc_pointer)
9486 continue;
9487
9488 /* We need source and destination components. */
9489 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl,
9490 cdecl, NULL_TREE);
9491 dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, dest,
9492 cdecl, NULL_TREE);
9493 dcmp = fold_convert (TREE_TYPE (comp), dcmp);
9494
9495 if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
9496 {
9497 tree ftn_tree;
9498 tree size;
9499 tree dst_data;
9500 tree src_data;
9501 tree null_data;
9502
9503 dst_data = gfc_class_data_get (dcmp);
9504 src_data = gfc_class_data_get (comp);
9505 size = fold_convert (size_type_node,
9506 gfc_class_vtab_size_get (comp));
9507
9508 if (CLASS_DATA (c)->attr.dimension)
9509 {
9510 nelems = gfc_conv_descriptor_size (src_data,
9511 CLASS_DATA (c)->as->rank);
9512 size = fold_build2_loc (input_location, MULT_EXPR,
9513 size_type_node, size,
9514 fold_convert (size_type_node,
9515 nelems));
9516 }
9517 else
9518 nelems = build_int_cst (size_type_node, 1);
9519
9520 if (CLASS_DATA (c)->attr.dimension
9521 || CLASS_DATA (c)->attr.codimension)
9522 {
9523 src_data = gfc_conv_descriptor_data_get (src_data);
9524 dst_data = gfc_conv_descriptor_data_get (dst_data);
9525 }
9526
9527 gfc_init_block (&tmpblock);
9528
9529 gfc_add_modify (&tmpblock, gfc_class_vptr_get (dcmp),
9530 gfc_class_vptr_get (comp));
9531
9532 /* Copy the unlimited '_len' field. If it is greater than zero
9533 (ie. a character(_len)), multiply it by size and use this
9534 for the malloc call. */
9535 if (UNLIMITED_POLY (c))
9536 {
9537 gfc_add_modify (&tmpblock, gfc_class_len_get (dcmp),
9538 gfc_class_len_get (comp));
9539 size = gfc_resize_class_size_with_len (&tmpblock, comp, size);
9540 }
9541
9542 /* Coarray component have to have the same allocation status and
9543 shape/type-parameter/effective-type on the LHS and RHS of an
9544 intrinsic assignment. Hence, we did not deallocated them - and
9545 do not allocate them here. */
9546 if (!CLASS_DATA (c)->attr.codimension)
9547 {
9548 ftn_tree = builtin_decl_explicit (BUILT_IN_MALLOC);
9549 tmp = build_call_expr_loc (input_location, ftn_tree, 1, size);
9550 gfc_add_modify (&tmpblock, dst_data,
9551 fold_convert (TREE_TYPE (dst_data), tmp));
9552 }
9553
9554 tmp = gfc_copy_class_to_class (comp, dcmp, nelems,
9555 UNLIMITED_POLY (c));
9556 gfc_add_expr_to_block (&tmpblock, tmp);
9557 tmp = gfc_finish_block (&tmpblock);
9558
9559 gfc_init_block (&tmpblock);
9560 gfc_add_modify (&tmpblock, dst_data,
9561 fold_convert (TREE_TYPE (dst_data),
9562 null_pointer_node));
9563 null_data = gfc_finish_block (&tmpblock);
9564
9565 null_cond = fold_build2_loc (input_location, NE_EXPR,
9566 logical_type_node, src_data,
9567 null_pointer_node);
9568
9569 gfc_add_expr_to_block (&fnblock, build3_v (COND_EXPR, null_cond,
9570 tmp, null_data));
9571 continue;
9572 }
9573
9574 /* To implement guarded deep copy, i.e., deep copy only allocatable
9575 components that are really allocated, the deep copy code has to
9576 be generated first and then added to the if-block in
9577 gfc_duplicate_allocatable (). */
9578 if (cmp_has_alloc_comps && !c->attr.proc_pointer && !same_type)
9579 {
9580 rank = c->as ? c->as->rank : 0;
9581 tmp = fold_convert (TREE_TYPE (dcmp), comp);
9582 gfc_add_modify (&fnblock, dcmp, tmp);
9583 add_when_allocated = structure_alloc_comps (c->ts.u.derived,
9584 comp, dcmp,
9585 rank, purpose,
9586 caf_mode, args);
9587 }
9588 else
9589 add_when_allocated = NULL_TREE;
9590
9591 if (gfc_deferred_strlen (c, &tmp))
9592 {
9593 tree len, size;
9594 len = tmp;
9595 tmp = fold_build3_loc (input_location, COMPONENT_REF,
9596 TREE_TYPE (len),
9597 decl, len, NULL_TREE);
9598 len = fold_build3_loc (input_location, COMPONENT_REF,
9599 TREE_TYPE (len),
9600 dest, len, NULL_TREE);
9601 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
9602 TREE_TYPE (len), len, tmp);
9603 gfc_add_expr_to_block (&fnblock, tmp);
9604 size = size_of_string_in_bytes (c->ts.kind, len);
9605 /* This component cannot have allocatable components,
9606 therefore add_when_allocated of duplicate_allocatable ()
9607 is always NULL. */
9608 tmp = duplicate_allocatable (dcmp, comp, ctype, rank,
9609 false, false, size, NULL_TREE);
9610 gfc_add_expr_to_block (&fnblock, tmp);
9611 }
9612 else if (c->attr.pdt_array)
9613 {
9614 tmp = duplicate_allocatable (dcmp, comp, ctype,
9615 c->as ? c->as->rank : 0,
9616 false, false, NULL_TREE, NULL_TREE);
9617 gfc_add_expr_to_block (&fnblock, tmp);
9618 }
9619 else if ((c->attr.allocatable)
9620 && !c->attr.proc_pointer && !same_type
9621 && (!(cmp_has_alloc_comps && c->as) || c->attr.codimension
9622 || caf_in_coarray (caf_mode)))
9623 {
9624 rank = c->as ? c->as->rank : 0;
9625 if (c->attr.codimension)
9626 tmp = gfc_copy_allocatable_data (dcmp, comp, ctype, rank);
9627 else if (flag_coarray == GFC_FCOARRAY_LIB
9628 && caf_in_coarray (caf_mode))
9629 {
9630 tree dst_tok = c->as ? gfc_conv_descriptor_token (dcmp)
9631 : fold_build3_loc (input_location,
9632 COMPONENT_REF,
9633 pvoid_type_node, dest,
9634 c->caf_token,
9635 NULL_TREE);
9636 tmp = duplicate_allocatable_coarray (dcmp, dst_tok, comp,
9637 ctype, rank);
9638 }
9639 else
9640 tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank,
9641 add_when_allocated);
9642 gfc_add_expr_to_block (&fnblock, tmp);
9643 }
9644 else
9645 if (cmp_has_alloc_comps || is_pdt_type)
9646 gfc_add_expr_to_block (&fnblock, add_when_allocated);
9647
9648 break;
9649
9650 case ALLOCATE_PDT_COMP:
9651
9652 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
9653 decl, cdecl, NULL_TREE);
9654
9655 /* Set the PDT KIND and LEN fields. */
9656 if (c->attr.pdt_kind || c->attr.pdt_len)
9657 {
9658 gfc_se tse;
9659 gfc_expr *c_expr = NULL;
9660 gfc_actual_arglist *param = pdt_param_list;
9661 gfc_init_se (&tse, NULL);
9662 for (; param; param = param->next)
9663 if (param->name && !strcmp (c->name, param->name))
9664 c_expr = param->expr;
9665
9666 if (!c_expr)
9667 c_expr = c->initializer;
9668
9669 if (c_expr)
9670 {
9671 gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp));
9672 gfc_add_modify (&fnblock, comp, tse.expr);
9673 }
9674 }
9675
9676 if (c->attr.pdt_string)
9677 {
9678 gfc_se tse;
9679 gfc_init_se (&tse, NULL);
9680 tree strlen = NULL_TREE;
9681 gfc_expr *e = gfc_copy_expr (c->ts.u.cl->length);
9682 /* Convert the parameterized string length to its value. The
9683 string length is stored in a hidden field in the same way as
9684 deferred string lengths. */
9685 gfc_insert_parameter_exprs (e, pdt_param_list);
9686 if (gfc_deferred_strlen (c, &strlen) && strlen != NULL_TREE)
9687 {
9688 gfc_conv_expr_type (&tse, e,
9689 TREE_TYPE (strlen));
9690 strlen = fold_build3_loc (input_location, COMPONENT_REF,
9691 TREE_TYPE (strlen),
9692 decl, strlen, NULL_TREE);
9693 gfc_add_modify (&fnblock, strlen, tse.expr);
9694 c->ts.u.cl->backend_decl = strlen;
9695 }
9696 gfc_free_expr (e);
9697
9698 /* Scalar parameterized strings can be allocated now. */
9699 if (!c->as)
9700 {
9701 tmp = fold_convert (gfc_array_index_type, strlen);
9702 tmp = size_of_string_in_bytes (c->ts.kind, tmp);
9703 tmp = gfc_evaluate_now (tmp, &fnblock);
9704 tmp = gfc_call_malloc (&fnblock, TREE_TYPE (comp), tmp);
9705 gfc_add_modify (&fnblock, comp, tmp);
9706 }
9707 }
9708
9709 /* Allocate parameterized arrays of parameterized derived types. */
9710 if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT)
9711 && !((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
9712 && (c->ts.u.derived && c->ts.u.derived->attr.pdt_type)))
9713 continue;
9714
9715 if (c->ts.type == BT_CLASS)
9716 comp = gfc_class_data_get (comp);
9717
9718 if (c->attr.pdt_array)
9719 {
9720 gfc_se tse;
9721 int i;
9722 tree size = gfc_index_one_node;
9723 tree offset = gfc_index_zero_node;
9724 tree lower, upper;
9725 gfc_expr *e;
9726
9727 /* This chunk takes the expressions for 'lower' and 'upper'
9728 in the arrayspec and substitutes in the expressions for
9729 the parameters from 'pdt_param_list'. The descriptor
9730 fields can then be filled from the values so obtained. */
9731 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)));
9732 for (i = 0; i < c->as->rank; i++)
9733 {
9734 gfc_init_se (&tse, NULL);
9735 e = gfc_copy_expr (c->as->lower[i]);
9736 gfc_insert_parameter_exprs (e, pdt_param_list);
9737 gfc_conv_expr_type (&tse, e, gfc_array_index_type);
9738 gfc_free_expr (e);
9739 lower = tse.expr;
9740 gfc_conv_descriptor_lbound_set (&fnblock, comp,
9741 gfc_rank_cst[i],
9742 lower);
9743 e = gfc_copy_expr (c->as->upper[i]);
9744 gfc_insert_parameter_exprs (e, pdt_param_list);
9745 gfc_conv_expr_type (&tse, e, gfc_array_index_type);
9746 gfc_free_expr (e);
9747 upper = tse.expr;
9748 gfc_conv_descriptor_ubound_set (&fnblock, comp,
9749 gfc_rank_cst[i],
9750 upper);
9751 gfc_conv_descriptor_stride_set (&fnblock, comp,
9752 gfc_rank_cst[i],
9753 size);
9754 size = gfc_evaluate_now (size, &fnblock);
9755 offset = fold_build2_loc (input_location,
9756 MINUS_EXPR,
9757 gfc_array_index_type,
9758 offset, size);
9759 offset = gfc_evaluate_now (offset, &fnblock);
9760 tmp = fold_build2_loc (input_location, MINUS_EXPR,
9761 gfc_array_index_type,
9762 upper, lower);
9763 tmp = fold_build2_loc (input_location, PLUS_EXPR,
9764 gfc_array_index_type,
9765 tmp, gfc_index_one_node);
9766 size = fold_build2_loc (input_location, MULT_EXPR,
9767 gfc_array_index_type, size, tmp);
9768 }
9769 gfc_conv_descriptor_offset_set (&fnblock, comp, offset);
9770 if (c->ts.type == BT_CLASS)
9771 {
9772 tmp = gfc_get_vptr_from_expr (comp);
9773 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
9774 tmp = build_fold_indirect_ref_loc (input_location, tmp);
9775 tmp = gfc_vptr_size_get (tmp);
9776 }
9777 else
9778 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (ctype));
9779 tmp = fold_convert (gfc_array_index_type, tmp);
9780 size = fold_build2_loc (input_location, MULT_EXPR,
9781 gfc_array_index_type, size, tmp);
9782 size = gfc_evaluate_now (size, &fnblock);
9783 tmp = gfc_call_malloc (&fnblock, NULL, size);
9784 gfc_conv_descriptor_data_set (&fnblock, comp, tmp);
9785 tmp = gfc_conv_descriptor_dtype (comp);
9786 gfc_add_modify (&fnblock, tmp, gfc_get_dtype (ctype));
9787
9788 if (c->initializer && c->initializer->rank)
9789 {
9790 gfc_init_se (&tse, NULL);
9791 e = gfc_copy_expr (c->initializer);
9792 gfc_insert_parameter_exprs (e, pdt_param_list);
9793 gfc_conv_expr_descriptor (&tse, e);
9794 gfc_add_block_to_block (&fnblock, &tse.pre);
9795 gfc_free_expr (e);
9796 tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
9797 tmp = build_call_expr_loc (input_location, tmp, 3,
9798 gfc_conv_descriptor_data_get (comp),
9799 gfc_conv_descriptor_data_get (tse.expr),
9800 fold_convert (size_type_node, size));
9801 gfc_add_expr_to_block (&fnblock, tmp);
9802 gfc_add_block_to_block (&fnblock, &tse.post);
9803 }
9804 }
9805
9806 /* Recurse in to PDT components. */
9807 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
9808 && c->ts.u.derived && c->ts.u.derived->attr.pdt_type
9809 && !(c->attr.pointer || c->attr.allocatable))
9810 {
9811 bool is_deferred = false;
9812 gfc_actual_arglist *tail = c->param_list;
9813
9814 for (; tail; tail = tail->next)
9815 if (!tail->expr)
9816 is_deferred = true;
9817
9818 tail = is_deferred ? pdt_param_list : c->param_list;
9819 tmp = gfc_allocate_pdt_comp (c->ts.u.derived, comp,
9820 c->as ? c->as->rank : 0,
9821 tail);
9822 gfc_add_expr_to_block (&fnblock, tmp);
9823 }
9824
9825 break;
9826
9827 case DEALLOCATE_PDT_COMP:
9828 /* Deallocate array or parameterized string length components
9829 of parameterized derived types. */
9830 if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT)
9831 && !c->attr.pdt_string
9832 && !((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
9833 && (c->ts.u.derived && c->ts.u.derived->attr.pdt_type)))
9834 continue;
9835
9836 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
9837 decl, cdecl, NULL_TREE);
9838 if (c->ts.type == BT_CLASS)
9839 comp = gfc_class_data_get (comp);
9840
9841 /* Recurse in to PDT components. */
9842 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
9843 && c->ts.u.derived && c->ts.u.derived->attr.pdt_type
9844 && (!c->attr.pointer && !c->attr.allocatable))
9845 {
9846 tmp = gfc_deallocate_pdt_comp (c->ts.u.derived, comp,
9847 c->as ? c->as->rank : 0);
9848 gfc_add_expr_to_block (&fnblock, tmp);
9849 }
9850
9851 if (c->attr.pdt_array)
9852 {
9853 tmp = gfc_conv_descriptor_data_get (comp);
9854 null_cond = fold_build2_loc (input_location, NE_EXPR,
9855 logical_type_node, tmp,
9856 build_int_cst (TREE_TYPE (tmp), 0));
9857 tmp = gfc_call_free (tmp);
9858 tmp = build3_v (COND_EXPR, null_cond, tmp,
9859 build_empty_stmt (input_location));
9860 gfc_add_expr_to_block (&fnblock, tmp);
9861 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
9862 }
9863 else if (c->attr.pdt_string)
9864 {
9865 null_cond = fold_build2_loc (input_location, NE_EXPR,
9866 logical_type_node, comp,
9867 build_int_cst (TREE_TYPE (comp), 0));
9868 tmp = gfc_call_free (comp);
9869 tmp = build3_v (COND_EXPR, null_cond, tmp,
9870 build_empty_stmt (input_location));
9871 gfc_add_expr_to_block (&fnblock, tmp);
9872 tmp = fold_convert (TREE_TYPE (comp), null_pointer_node);
9873 gfc_add_modify (&fnblock, comp, tmp);
9874 }
9875
9876 break;
9877
9878 case CHECK_PDT_DUMMY:
9879
9880 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
9881 decl, cdecl, NULL_TREE);
9882 if (c->ts.type == BT_CLASS)
9883 comp = gfc_class_data_get (comp);
9884
9885 /* Recurse in to PDT components. */
9886 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
9887 && c->ts.u.derived && c->ts.u.derived->attr.pdt_type)
9888 {
9889 tmp = gfc_check_pdt_dummy (c->ts.u.derived, comp,
9890 c->as ? c->as->rank : 0,
9891 pdt_param_list);
9892 gfc_add_expr_to_block (&fnblock, tmp);
9893 }
9894
9895 if (!c->attr.pdt_len)
9896 continue;
9897 else
9898 {
9899 gfc_se tse;
9900 gfc_expr *c_expr = NULL;
9901 gfc_actual_arglist *param = pdt_param_list;
9902
9903 gfc_init_se (&tse, NULL);
9904 for (; param; param = param->next)
9905 if (!strcmp (c->name, param->name)
9906 && param->spec_type == SPEC_EXPLICIT)
9907 c_expr = param->expr;
9908
9909 if (c_expr)
9910 {
9911 tree error, cond, cname;
9912 gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp));
9913 cond = fold_build2_loc (input_location, NE_EXPR,
9914 logical_type_node,
9915 comp, tse.expr);
9916 cname = gfc_build_cstring_const (c->name);
9917 cname = gfc_build_addr_expr (pchar_type_node, cname);
9918 error = gfc_trans_runtime_error (true, NULL,
9919 "The value of the PDT LEN "
9920 "parameter '%s' does not "
9921 "agree with that in the "
9922 "dummy declaration",
9923 cname);
9924 tmp = fold_build3_loc (input_location, COND_EXPR,
9925 void_type_node, cond, error,
9926 build_empty_stmt (input_location));
9927 gfc_add_expr_to_block (&fnblock, tmp);
9928 }
9929 }
9930 break;
9931
9932 default:
9933 gcc_unreachable ();
9934 break;
9935 }
9936 }
9937
9938 return gfc_finish_block (&fnblock);
9939 }
9940
9941 /* Recursively traverse an object of derived type, generating code to
9942 nullify allocatable components. */
9943
9944 tree
gfc_nullify_alloc_comp(gfc_symbol * der_type,tree decl,int rank,int caf_mode)9945 gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
9946 int caf_mode)
9947 {
9948 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
9949 NULLIFY_ALLOC_COMP,
9950 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode, NULL);
9951 }
9952
9953
9954 /* Recursively traverse an object of derived type, generating code to
9955 deallocate allocatable components. */
9956
9957 tree
gfc_deallocate_alloc_comp(gfc_symbol * der_type,tree decl,int rank,int caf_mode)9958 gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
9959 int caf_mode)
9960 {
9961 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
9962 DEALLOCATE_ALLOC_COMP,
9963 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode, NULL);
9964 }
9965
9966 tree
gfc_bcast_alloc_comp(gfc_symbol * derived,gfc_expr * expr,int rank,tree image_index,tree stat,tree errmsg,tree errmsg_len)9967 gfc_bcast_alloc_comp (gfc_symbol *derived, gfc_expr *expr, int rank,
9968 tree image_index, tree stat, tree errmsg,
9969 tree errmsg_len)
9970 {
9971 tree tmp, array;
9972 gfc_se argse;
9973 stmtblock_t block, post_block;
9974 gfc_co_subroutines_args args;
9975
9976 args.image_index = image_index;
9977 args.stat = stat;
9978 args.errmsg = errmsg;
9979 args.errmsg = errmsg_len;
9980
9981 if (rank == 0)
9982 {
9983 gfc_start_block (&block);
9984 gfc_init_block (&post_block);
9985 gfc_init_se (&argse, NULL);
9986 gfc_conv_expr (&argse, expr);
9987 gfc_add_block_to_block (&block, &argse.pre);
9988 gfc_add_block_to_block (&post_block, &argse.post);
9989 array = argse.expr;
9990 }
9991 else
9992 {
9993 gfc_init_se (&argse, NULL);
9994 argse.want_pointer = 1;
9995 gfc_conv_expr_descriptor (&argse, expr);
9996 array = argse.expr;
9997 }
9998
9999 tmp = structure_alloc_comps (derived, array, NULL_TREE, rank,
10000 BCAST_ALLOC_COMP,
10001 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY, &args);
10002 return tmp;
10003 }
10004
10005 /* Recursively traverse an object of derived type, generating code to
10006 deallocate allocatable components. But do not deallocate coarrays.
10007 To be used for intrinsic assignment, which may not change the allocation
10008 status of coarrays. */
10009
10010 tree
gfc_deallocate_alloc_comp_no_caf(gfc_symbol * der_type,tree decl,int rank)10011 gfc_deallocate_alloc_comp_no_caf (gfc_symbol * der_type, tree decl, int rank)
10012 {
10013 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
10014 DEALLOCATE_ALLOC_COMP, 0, NULL);
10015 }
10016
10017
10018 tree
gfc_reassign_alloc_comp_caf(gfc_symbol * der_type,tree decl,tree dest)10019 gfc_reassign_alloc_comp_caf (gfc_symbol *der_type, tree decl, tree dest)
10020 {
10021 return structure_alloc_comps (der_type, decl, dest, 0, REASSIGN_CAF_COMP,
10022 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY, NULL);
10023 }
10024
10025
10026 /* Recursively traverse an object of derived type, generating code to
10027 copy it and its allocatable components. */
10028
10029 tree
gfc_copy_alloc_comp(gfc_symbol * der_type,tree decl,tree dest,int rank,int caf_mode)10030 gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank,
10031 int caf_mode)
10032 {
10033 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP,
10034 caf_mode, NULL);
10035 }
10036
10037
10038 /* Recursively traverse an object of derived type, generating code to
10039 copy only its allocatable components. */
10040
10041 tree
gfc_copy_only_alloc_comp(gfc_symbol * der_type,tree decl,tree dest,int rank)10042 gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
10043 {
10044 return structure_alloc_comps (der_type, decl, dest, rank,
10045 COPY_ONLY_ALLOC_COMP, 0, NULL);
10046 }
10047
10048
10049 /* Recursively traverse an object of parameterized derived type, generating
10050 code to allocate parameterized components. */
10051
10052 tree
gfc_allocate_pdt_comp(gfc_symbol * der_type,tree decl,int rank,gfc_actual_arglist * param_list)10053 gfc_allocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank,
10054 gfc_actual_arglist *param_list)
10055 {
10056 tree res;
10057 gfc_actual_arglist *old_param_list = pdt_param_list;
10058 pdt_param_list = param_list;
10059 res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
10060 ALLOCATE_PDT_COMP, 0, NULL);
10061 pdt_param_list = old_param_list;
10062 return res;
10063 }
10064
10065 /* Recursively traverse an object of parameterized derived type, generating
10066 code to deallocate parameterized components. */
10067
10068 tree
gfc_deallocate_pdt_comp(gfc_symbol * der_type,tree decl,int rank)10069 gfc_deallocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank)
10070 {
10071 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
10072 DEALLOCATE_PDT_COMP, 0, NULL);
10073 }
10074
10075
10076 /* Recursively traverse a dummy of parameterized derived type to check the
10077 values of LEN parameters. */
10078
10079 tree
gfc_check_pdt_dummy(gfc_symbol * der_type,tree decl,int rank,gfc_actual_arglist * param_list)10080 gfc_check_pdt_dummy (gfc_symbol * der_type, tree decl, int rank,
10081 gfc_actual_arglist *param_list)
10082 {
10083 tree res;
10084 gfc_actual_arglist *old_param_list = pdt_param_list;
10085 pdt_param_list = param_list;
10086 res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
10087 CHECK_PDT_DUMMY, 0, NULL);
10088 pdt_param_list = old_param_list;
10089 return res;
10090 }
10091
10092
10093 /* Returns the value of LBOUND for an expression. This could be broken out
10094 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
10095 called by gfc_alloc_allocatable_for_assignment. */
10096 static tree
get_std_lbound(gfc_expr * expr,tree desc,int dim,bool assumed_size)10097 get_std_lbound (gfc_expr *expr, tree desc, int dim, bool assumed_size)
10098 {
10099 tree lbound;
10100 tree ubound;
10101 tree stride;
10102 tree cond, cond1, cond3, cond4;
10103 tree tmp;
10104 gfc_ref *ref;
10105
10106 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
10107 {
10108 tmp = gfc_rank_cst[dim];
10109 lbound = gfc_conv_descriptor_lbound_get (desc, tmp);
10110 ubound = gfc_conv_descriptor_ubound_get (desc, tmp);
10111 stride = gfc_conv_descriptor_stride_get (desc, tmp);
10112 cond1 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
10113 ubound, lbound);
10114 cond3 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
10115 stride, gfc_index_zero_node);
10116 cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
10117 logical_type_node, cond3, cond1);
10118 cond4 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
10119 stride, gfc_index_zero_node);
10120 if (assumed_size)
10121 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10122 tmp, build_int_cst (gfc_array_index_type,
10123 expr->rank - 1));
10124 else
10125 cond = logical_false_node;
10126
10127 cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
10128 logical_type_node, cond3, cond4);
10129 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
10130 logical_type_node, cond, cond1);
10131
10132 return fold_build3_loc (input_location, COND_EXPR,
10133 gfc_array_index_type, cond,
10134 lbound, gfc_index_one_node);
10135 }
10136
10137 if (expr->expr_type == EXPR_FUNCTION)
10138 {
10139 /* A conversion function, so use the argument. */
10140 gcc_assert (expr->value.function.isym
10141 && expr->value.function.isym->conversion);
10142 expr = expr->value.function.actual->expr;
10143 }
10144
10145 if (expr->expr_type == EXPR_VARIABLE)
10146 {
10147 tmp = TREE_TYPE (expr->symtree->n.sym->backend_decl);
10148 for (ref = expr->ref; ref; ref = ref->next)
10149 {
10150 if (ref->type == REF_COMPONENT
10151 && ref->u.c.component->as
10152 && ref->next
10153 && ref->next->u.ar.type == AR_FULL)
10154 tmp = TREE_TYPE (ref->u.c.component->backend_decl);
10155 }
10156 return GFC_TYPE_ARRAY_LBOUND(tmp, dim);
10157 }
10158
10159 return gfc_index_one_node;
10160 }
10161
10162
10163 /* Returns true if an expression represents an lhs that can be reallocated
10164 on assignment. */
10165
10166 bool
gfc_is_reallocatable_lhs(gfc_expr * expr)10167 gfc_is_reallocatable_lhs (gfc_expr *expr)
10168 {
10169 gfc_ref * ref;
10170 gfc_symbol *sym;
10171
10172 if (!expr->ref)
10173 return false;
10174
10175 sym = expr->symtree->n.sym;
10176
10177 if (sym->attr.associate_var && !expr->ref)
10178 return false;
10179
10180 /* An allocatable class variable with no reference. */
10181 if (sym->ts.type == BT_CLASS
10182 && !sym->attr.associate_var
10183 && CLASS_DATA (sym)->attr.allocatable
10184 && expr->ref
10185 && ((expr->ref->type == REF_ARRAY && expr->ref->u.ar.type == AR_FULL
10186 && expr->ref->next == NULL)
10187 || (expr->ref->type == REF_COMPONENT
10188 && strcmp (expr->ref->u.c.component->name, "_data") == 0
10189 && (expr->ref->next == NULL
10190 || (expr->ref->next->type == REF_ARRAY
10191 && expr->ref->next->u.ar.type == AR_FULL
10192 && expr->ref->next->next == NULL)))))
10193 return true;
10194
10195 /* An allocatable variable. */
10196 if (sym->attr.allocatable
10197 && !sym->attr.associate_var
10198 && expr->ref
10199 && expr->ref->type == REF_ARRAY
10200 && expr->ref->u.ar.type == AR_FULL)
10201 return true;
10202
10203 /* All that can be left are allocatable components. */
10204 if ((sym->ts.type != BT_DERIVED
10205 && sym->ts.type != BT_CLASS)
10206 || !sym->ts.u.derived->attr.alloc_comp)
10207 return false;
10208
10209 /* Find a component ref followed by an array reference. */
10210 for (ref = expr->ref; ref; ref = ref->next)
10211 if (ref->next
10212 && ref->type == REF_COMPONENT
10213 && ref->next->type == REF_ARRAY
10214 && !ref->next->next)
10215 break;
10216
10217 if (!ref)
10218 return false;
10219
10220 /* Return true if valid reallocatable lhs. */
10221 if (ref->u.c.component->attr.allocatable
10222 && ref->next->u.ar.type == AR_FULL)
10223 return true;
10224
10225 return false;
10226 }
10227
10228
10229 static tree
concat_str_length(gfc_expr * expr)10230 concat_str_length (gfc_expr* expr)
10231 {
10232 tree type;
10233 tree len1;
10234 tree len2;
10235 gfc_se se;
10236
10237 type = gfc_typenode_for_spec (&expr->value.op.op1->ts);
10238 len1 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
10239 if (len1 == NULL_TREE)
10240 {
10241 if (expr->value.op.op1->expr_type == EXPR_OP)
10242 len1 = concat_str_length (expr->value.op.op1);
10243 else if (expr->value.op.op1->expr_type == EXPR_CONSTANT)
10244 len1 = build_int_cst (gfc_charlen_type_node,
10245 expr->value.op.op1->value.character.length);
10246 else if (expr->value.op.op1->ts.u.cl->length)
10247 {
10248 gfc_init_se (&se, NULL);
10249 gfc_conv_expr (&se, expr->value.op.op1->ts.u.cl->length);
10250 len1 = se.expr;
10251 }
10252 else
10253 {
10254 /* Last resort! */
10255 gfc_init_se (&se, NULL);
10256 se.want_pointer = 1;
10257 se.descriptor_only = 1;
10258 gfc_conv_expr (&se, expr->value.op.op1);
10259 len1 = se.string_length;
10260 }
10261 }
10262
10263 type = gfc_typenode_for_spec (&expr->value.op.op2->ts);
10264 len2 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
10265 if (len2 == NULL_TREE)
10266 {
10267 if (expr->value.op.op2->expr_type == EXPR_OP)
10268 len2 = concat_str_length (expr->value.op.op2);
10269 else if (expr->value.op.op2->expr_type == EXPR_CONSTANT)
10270 len2 = build_int_cst (gfc_charlen_type_node,
10271 expr->value.op.op2->value.character.length);
10272 else if (expr->value.op.op2->ts.u.cl->length)
10273 {
10274 gfc_init_se (&se, NULL);
10275 gfc_conv_expr (&se, expr->value.op.op2->ts.u.cl->length);
10276 len2 = se.expr;
10277 }
10278 else
10279 {
10280 /* Last resort! */
10281 gfc_init_se (&se, NULL);
10282 se.want_pointer = 1;
10283 se.descriptor_only = 1;
10284 gfc_conv_expr (&se, expr->value.op.op2);
10285 len2 = se.string_length;
10286 }
10287 }
10288
10289 gcc_assert(len1 && len2);
10290 len1 = fold_convert (gfc_charlen_type_node, len1);
10291 len2 = fold_convert (gfc_charlen_type_node, len2);
10292
10293 return fold_build2_loc (input_location, PLUS_EXPR,
10294 gfc_charlen_type_node, len1, len2);
10295 }
10296
10297
10298 /* Allocate the lhs of an assignment to an allocatable array, otherwise
10299 reallocate it. */
10300
10301 tree
gfc_alloc_allocatable_for_assignment(gfc_loopinfo * loop,gfc_expr * expr1,gfc_expr * expr2)10302 gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
10303 gfc_expr *expr1,
10304 gfc_expr *expr2)
10305 {
10306 stmtblock_t realloc_block;
10307 stmtblock_t alloc_block;
10308 stmtblock_t fblock;
10309 gfc_ss *rss;
10310 gfc_ss *lss;
10311 gfc_array_info *linfo;
10312 tree realloc_expr;
10313 tree alloc_expr;
10314 tree size1;
10315 tree size2;
10316 tree elemsize1;
10317 tree elemsize2;
10318 tree array1;
10319 tree cond_null;
10320 tree cond;
10321 tree tmp;
10322 tree tmp2;
10323 tree lbound;
10324 tree ubound;
10325 tree desc;
10326 tree old_desc;
10327 tree desc2;
10328 tree offset;
10329 tree jump_label1;
10330 tree jump_label2;
10331 tree neq_size;
10332 tree lbd;
10333 tree class_expr2 = NULL_TREE;
10334 int n;
10335 int dim;
10336 gfc_array_spec * as;
10337 bool coarray = (flag_coarray == GFC_FCOARRAY_LIB
10338 && gfc_caf_attr (expr1, true).codimension);
10339 tree token;
10340 gfc_se caf_se;
10341
10342 /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
10343 Find the lhs expression in the loop chain and set expr1 and
10344 expr2 accordingly. */
10345 if (expr1->expr_type == EXPR_FUNCTION && expr2 == NULL)
10346 {
10347 expr2 = expr1;
10348 /* Find the ss for the lhs. */
10349 lss = loop->ss;
10350 for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
10351 if (lss->info->expr && lss->info->expr->expr_type == EXPR_VARIABLE)
10352 break;
10353 if (lss == gfc_ss_terminator)
10354 return NULL_TREE;
10355 expr1 = lss->info->expr;
10356 }
10357
10358 /* Bail out if this is not a valid allocate on assignment. */
10359 if (!gfc_is_reallocatable_lhs (expr1)
10360 || (expr2 && !expr2->rank))
10361 return NULL_TREE;
10362
10363 /* Find the ss for the lhs. */
10364 lss = loop->ss;
10365 for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
10366 if (lss->info->expr == expr1)
10367 break;
10368
10369 if (lss == gfc_ss_terminator)
10370 return NULL_TREE;
10371
10372 linfo = &lss->info->data.array;
10373
10374 /* Find an ss for the rhs. For operator expressions, we see the
10375 ss's for the operands. Any one of these will do. */
10376 rss = loop->ss;
10377 for (; rss && rss != gfc_ss_terminator; rss = rss->loop_chain)
10378 if (rss->info->expr != expr1 && rss != loop->temp_ss)
10379 break;
10380
10381 if (expr2 && rss == gfc_ss_terminator)
10382 return NULL_TREE;
10383
10384 /* Ensure that the string length from the current scope is used. */
10385 if (expr2->ts.type == BT_CHARACTER
10386 && expr2->expr_type == EXPR_FUNCTION
10387 && !expr2->value.function.isym)
10388 expr2->ts.u.cl->backend_decl = rss->info->string_length;
10389
10390 gfc_start_block (&fblock);
10391
10392 /* Since the lhs is allocatable, this must be a descriptor type.
10393 Get the data and array size. */
10394 desc = linfo->descriptor;
10395 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
10396 array1 = gfc_conv_descriptor_data_get (desc);
10397
10398 if (expr2)
10399 desc2 = rss->info->data.array.descriptor;
10400 else
10401 desc2 = NULL_TREE;
10402
10403 /* Get the old lhs element size for deferred character and class expr1. */
10404 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
10405 {
10406 if (expr1->ts.u.cl->backend_decl
10407 && VAR_P (expr1->ts.u.cl->backend_decl))
10408 elemsize1 = expr1->ts.u.cl->backend_decl;
10409 else
10410 elemsize1 = lss->info->string_length;
10411 }
10412 else if (expr1->ts.type == BT_CLASS)
10413 {
10414 tmp = expr1->rank ? gfc_get_class_from_expr (desc) : NULL_TREE;
10415 if (tmp == NULL_TREE)
10416 tmp = gfc_get_class_from_gfc_expr (expr1);
10417
10418 if (tmp != NULL_TREE)
10419 {
10420 tmp2 = gfc_class_vptr_get (tmp);
10421 cond = fold_build2_loc (input_location, NE_EXPR,
10422 logical_type_node, tmp2,
10423 build_int_cst (TREE_TYPE (tmp2), 0));
10424 elemsize1 = gfc_class_vtab_size_get (tmp);
10425 elemsize1 = fold_build3_loc (input_location, COND_EXPR,
10426 gfc_array_index_type, cond,
10427 elemsize1, gfc_index_zero_node);
10428 }
10429 else
10430 elemsize1 = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&CLASS_DATA (expr1)->ts));
10431 }
10432 else
10433 elemsize1 = NULL_TREE;
10434 if (elemsize1 != NULL_TREE)
10435 elemsize1 = gfc_evaluate_now (elemsize1, &fblock);
10436
10437 /* Get the new lhs size in bytes. */
10438 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
10439 {
10440 if (expr2->ts.deferred)
10441 {
10442 if (expr2->ts.u.cl->backend_decl
10443 && VAR_P (expr2->ts.u.cl->backend_decl))
10444 tmp = expr2->ts.u.cl->backend_decl;
10445 else
10446 tmp = rss->info->string_length;
10447 }
10448 else
10449 {
10450 tmp = expr2->ts.u.cl->backend_decl;
10451 if (!tmp && expr2->expr_type == EXPR_OP
10452 && expr2->value.op.op == INTRINSIC_CONCAT)
10453 {
10454 tmp = concat_str_length (expr2);
10455 expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
10456 }
10457 else if (!tmp && expr2->ts.u.cl->length)
10458 {
10459 gfc_se tmpse;
10460 gfc_init_se (&tmpse, NULL);
10461 gfc_conv_expr_type (&tmpse, expr2->ts.u.cl->length,
10462 gfc_charlen_type_node);
10463 tmp = tmpse.expr;
10464 expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
10465 }
10466 tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
10467 }
10468
10469 if (expr1->ts.u.cl->backend_decl
10470 && VAR_P (expr1->ts.u.cl->backend_decl))
10471 gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
10472 else
10473 gfc_add_modify (&fblock, lss->info->string_length, tmp);
10474
10475 if (expr1->ts.kind > 1)
10476 tmp = fold_build2_loc (input_location, MULT_EXPR,
10477 TREE_TYPE (tmp),
10478 tmp, build_int_cst (TREE_TYPE (tmp),
10479 expr1->ts.kind));
10480 }
10481 else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
10482 {
10483 tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts)));
10484 tmp = fold_build2_loc (input_location, MULT_EXPR,
10485 gfc_array_index_type, tmp,
10486 expr1->ts.u.cl->backend_decl);
10487 }
10488 else if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS)
10489 tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
10490 else if (expr1->ts.type == BT_CLASS && expr2->ts.type == BT_CLASS)
10491 {
10492 tmp = expr2->rank ? gfc_get_class_from_expr (desc2) : NULL_TREE;
10493 if (tmp == NULL_TREE && expr2->expr_type == EXPR_VARIABLE)
10494 tmp = class_expr2 = gfc_get_class_from_gfc_expr (expr2);
10495
10496 if (tmp != NULL_TREE)
10497 tmp = gfc_class_vtab_size_get (tmp);
10498 else
10499 tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&CLASS_DATA (expr2)->ts));
10500 }
10501 else
10502 tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
10503 elemsize2 = fold_convert (gfc_array_index_type, tmp);
10504 elemsize2 = gfc_evaluate_now (elemsize2, &fblock);
10505
10506 /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
10507 deallocated if expr is an array of different shape or any of the
10508 corresponding length type parameter values of variable and expr
10509 differ." This assures F95 compatibility. */
10510 jump_label1 = gfc_build_label_decl (NULL_TREE);
10511 jump_label2 = gfc_build_label_decl (NULL_TREE);
10512
10513 /* Allocate if data is NULL. */
10514 cond_null = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10515 array1, build_int_cst (TREE_TYPE (array1), 0));
10516
10517 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
10518 {
10519 tmp = fold_build2_loc (input_location, NE_EXPR,
10520 logical_type_node,
10521 lss->info->string_length,
10522 rss->info->string_length);
10523 cond_null = fold_build2_loc (input_location, TRUTH_OR_EXPR,
10524 logical_type_node, tmp, cond_null);
10525 cond_null= gfc_evaluate_now (cond_null, &fblock);
10526 }
10527 else
10528 cond_null= gfc_evaluate_now (cond_null, &fblock);
10529
10530 tmp = build3_v (COND_EXPR, cond_null,
10531 build1_v (GOTO_EXPR, jump_label1),
10532 build_empty_stmt (input_location));
10533 gfc_add_expr_to_block (&fblock, tmp);
10534
10535 /* Get arrayspec if expr is a full array. */
10536 if (expr2 && expr2->expr_type == EXPR_FUNCTION
10537 && expr2->value.function.isym
10538 && expr2->value.function.isym->conversion)
10539 {
10540 /* For conversion functions, take the arg. */
10541 gfc_expr *arg = expr2->value.function.actual->expr;
10542 as = gfc_get_full_arrayspec_from_expr (arg);
10543 }
10544 else if (expr2)
10545 as = gfc_get_full_arrayspec_from_expr (expr2);
10546 else
10547 as = NULL;
10548
10549 /* If the lhs shape is not the same as the rhs jump to setting the
10550 bounds and doing the reallocation....... */
10551 for (n = 0; n < expr1->rank; n++)
10552 {
10553 /* Check the shape. */
10554 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
10555 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
10556 tmp = fold_build2_loc (input_location, MINUS_EXPR,
10557 gfc_array_index_type,
10558 loop->to[n], loop->from[n]);
10559 tmp = fold_build2_loc (input_location, PLUS_EXPR,
10560 gfc_array_index_type,
10561 tmp, lbound);
10562 tmp = fold_build2_loc (input_location, MINUS_EXPR,
10563 gfc_array_index_type,
10564 tmp, ubound);
10565 cond = fold_build2_loc (input_location, NE_EXPR,
10566 logical_type_node,
10567 tmp, gfc_index_zero_node);
10568 tmp = build3_v (COND_EXPR, cond,
10569 build1_v (GOTO_EXPR, jump_label1),
10570 build_empty_stmt (input_location));
10571 gfc_add_expr_to_block (&fblock, tmp);
10572 }
10573
10574 /* ...else if the element lengths are not the same also go to
10575 setting the bounds and doing the reallocation.... */
10576 if (elemsize1 != NULL_TREE)
10577 {
10578 cond = fold_build2_loc (input_location, NE_EXPR,
10579 logical_type_node,
10580 elemsize1, elemsize2);
10581 tmp = build3_v (COND_EXPR, cond,
10582 build1_v (GOTO_EXPR, jump_label1),
10583 build_empty_stmt (input_location));
10584 gfc_add_expr_to_block (&fblock, tmp);
10585 }
10586
10587 /* ....else jump past the (re)alloc code. */
10588 tmp = build1_v (GOTO_EXPR, jump_label2);
10589 gfc_add_expr_to_block (&fblock, tmp);
10590
10591 /* Add the label to start automatic (re)allocation. */
10592 tmp = build1_v (LABEL_EXPR, jump_label1);
10593 gfc_add_expr_to_block (&fblock, tmp);
10594
10595 /* If the lhs has not been allocated, its bounds will not have been
10596 initialized and so its size is set to zero. */
10597 size1 = gfc_create_var (gfc_array_index_type, NULL);
10598 gfc_init_block (&alloc_block);
10599 gfc_add_modify (&alloc_block, size1, gfc_index_zero_node);
10600 gfc_init_block (&realloc_block);
10601 gfc_add_modify (&realloc_block, size1,
10602 gfc_conv_descriptor_size (desc, expr1->rank));
10603 tmp = build3_v (COND_EXPR, cond_null,
10604 gfc_finish_block (&alloc_block),
10605 gfc_finish_block (&realloc_block));
10606 gfc_add_expr_to_block (&fblock, tmp);
10607
10608 /* Get the rhs size and fix it. */
10609 size2 = gfc_index_one_node;
10610 for (n = 0; n < expr2->rank; n++)
10611 {
10612 tmp = fold_build2_loc (input_location, MINUS_EXPR,
10613 gfc_array_index_type,
10614 loop->to[n], loop->from[n]);
10615 tmp = fold_build2_loc (input_location, PLUS_EXPR,
10616 gfc_array_index_type,
10617 tmp, gfc_index_one_node);
10618 size2 = fold_build2_loc (input_location, MULT_EXPR,
10619 gfc_array_index_type,
10620 tmp, size2);
10621 }
10622 size2 = gfc_evaluate_now (size2, &fblock);
10623
10624 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10625 size1, size2);
10626
10627 /* If the lhs is deferred length, assume that the element size
10628 changes and force a reallocation. */
10629 if (expr1->ts.deferred)
10630 neq_size = gfc_evaluate_now (logical_true_node, &fblock);
10631 else
10632 neq_size = gfc_evaluate_now (cond, &fblock);
10633
10634 /* Deallocation of allocatable components will have to occur on
10635 reallocation. Fix the old descriptor now. */
10636 if ((expr1->ts.type == BT_DERIVED)
10637 && expr1->ts.u.derived->attr.alloc_comp)
10638 old_desc = gfc_evaluate_now (desc, &fblock);
10639 else
10640 old_desc = NULL_TREE;
10641
10642 /* Now modify the lhs descriptor and the associated scalarizer
10643 variables. F2003 7.4.1.3: "If variable is or becomes an
10644 unallocated allocatable variable, then it is allocated with each
10645 deferred type parameter equal to the corresponding type parameters
10646 of expr , with the shape of expr , and with each lower bound equal
10647 to the corresponding element of LBOUND(expr)."
10648 Reuse size1 to keep a dimension-by-dimension track of the
10649 stride of the new array. */
10650 size1 = gfc_index_one_node;
10651 offset = gfc_index_zero_node;
10652
10653 for (n = 0; n < expr2->rank; n++)
10654 {
10655 tmp = fold_build2_loc (input_location, MINUS_EXPR,
10656 gfc_array_index_type,
10657 loop->to[n], loop->from[n]);
10658 tmp = fold_build2_loc (input_location, PLUS_EXPR,
10659 gfc_array_index_type,
10660 tmp, gfc_index_one_node);
10661
10662 lbound = gfc_index_one_node;
10663 ubound = tmp;
10664
10665 if (as)
10666 {
10667 lbd = get_std_lbound (expr2, desc2, n,
10668 as->type == AS_ASSUMED_SIZE);
10669 ubound = fold_build2_loc (input_location,
10670 MINUS_EXPR,
10671 gfc_array_index_type,
10672 ubound, lbound);
10673 ubound = fold_build2_loc (input_location,
10674 PLUS_EXPR,
10675 gfc_array_index_type,
10676 ubound, lbd);
10677 lbound = lbd;
10678 }
10679
10680 gfc_conv_descriptor_lbound_set (&fblock, desc,
10681 gfc_rank_cst[n],
10682 lbound);
10683 gfc_conv_descriptor_ubound_set (&fblock, desc,
10684 gfc_rank_cst[n],
10685 ubound);
10686 gfc_conv_descriptor_stride_set (&fblock, desc,
10687 gfc_rank_cst[n],
10688 size1);
10689 lbound = gfc_conv_descriptor_lbound_get (desc,
10690 gfc_rank_cst[n]);
10691 tmp2 = fold_build2_loc (input_location, MULT_EXPR,
10692 gfc_array_index_type,
10693 lbound, size1);
10694 offset = fold_build2_loc (input_location, MINUS_EXPR,
10695 gfc_array_index_type,
10696 offset, tmp2);
10697 size1 = fold_build2_loc (input_location, MULT_EXPR,
10698 gfc_array_index_type,
10699 tmp, size1);
10700 }
10701
10702 /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
10703 the array offset is saved and the info.offset is used for a
10704 running offset. Use the saved_offset instead. */
10705 tmp = gfc_conv_descriptor_offset (desc);
10706 gfc_add_modify (&fblock, tmp, offset);
10707 if (linfo->saved_offset
10708 && VAR_P (linfo->saved_offset))
10709 gfc_add_modify (&fblock, linfo->saved_offset, tmp);
10710
10711 /* Now set the deltas for the lhs. */
10712 for (n = 0; n < expr1->rank; n++)
10713 {
10714 tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
10715 dim = lss->dim[n];
10716 tmp = fold_build2_loc (input_location, MINUS_EXPR,
10717 gfc_array_index_type, tmp,
10718 loop->from[dim]);
10719 if (linfo->delta[dim] && VAR_P (linfo->delta[dim]))
10720 gfc_add_modify (&fblock, linfo->delta[dim], tmp);
10721 }
10722
10723 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
10724 gfc_conv_descriptor_span_set (&fblock, desc, elemsize2);
10725
10726 size2 = fold_build2_loc (input_location, MULT_EXPR,
10727 gfc_array_index_type,
10728 elemsize2, size2);
10729 size2 = fold_convert (size_type_node, size2);
10730 size2 = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
10731 size2, size_one_node);
10732 size2 = gfc_evaluate_now (size2, &fblock);
10733
10734 /* For deferred character length, the 'size' field of the dtype might
10735 have changed so set the dtype. */
10736 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
10737 && expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
10738 {
10739 tree type;
10740 tmp = gfc_conv_descriptor_dtype (desc);
10741 if (expr2->ts.u.cl->backend_decl)
10742 type = gfc_typenode_for_spec (&expr2->ts);
10743 else
10744 type = gfc_typenode_for_spec (&expr1->ts);
10745
10746 gfc_add_modify (&fblock, tmp,
10747 gfc_get_dtype_rank_type (expr1->rank,type));
10748 }
10749 else if (expr1->ts.type == BT_CLASS)
10750 {
10751 tree type;
10752 tmp = gfc_conv_descriptor_dtype (desc);
10753
10754 if (expr2->ts.type != BT_CLASS)
10755 type = gfc_typenode_for_spec (&expr2->ts);
10756 else
10757 type = gfc_get_character_type_len (1, elemsize2);
10758
10759 gfc_add_modify (&fblock, tmp,
10760 gfc_get_dtype_rank_type (expr2->rank,type));
10761 /* Set the _len field as well... */
10762 if (UNLIMITED_POLY (expr1))
10763 {
10764 tmp = gfc_class_len_get (TREE_OPERAND (desc, 0));
10765 if (expr2->ts.type == BT_CHARACTER)
10766 gfc_add_modify (&fblock, tmp,
10767 fold_convert (TREE_TYPE (tmp),
10768 TYPE_SIZE_UNIT (type)));
10769 else
10770 gfc_add_modify (&fblock, tmp,
10771 build_int_cst (TREE_TYPE (tmp), 0));
10772 }
10773 /* ...and the vptr. */
10774 tmp = gfc_class_vptr_get (TREE_OPERAND (desc, 0));
10775 if (expr2->ts.type == BT_CLASS && !VAR_P (desc2)
10776 && TREE_CODE (desc2) == COMPONENT_REF)
10777 {
10778 tmp2 = gfc_get_class_from_expr (desc2);
10779 tmp2 = gfc_class_vptr_get (tmp2);
10780 }
10781 else if (expr2->ts.type == BT_CLASS && class_expr2 != NULL_TREE)
10782 tmp2 = gfc_class_vptr_get (class_expr2);
10783 else
10784 {
10785 tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts));
10786 tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2);
10787 }
10788
10789 gfc_add_modify (&fblock, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
10790 }
10791 else if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
10792 {
10793 gfc_add_modify (&fblock, gfc_conv_descriptor_dtype (desc),
10794 gfc_get_dtype (TREE_TYPE (desc)));
10795 }
10796
10797 /* Realloc expression. Note that the scalarizer uses desc.data
10798 in the array reference - (*desc.data)[<element>]. */
10799 gfc_init_block (&realloc_block);
10800 gfc_init_se (&caf_se, NULL);
10801
10802 if (coarray)
10803 {
10804 token = gfc_get_ultimate_alloc_ptr_comps_caf_token (&caf_se, expr1);
10805 if (token == NULL_TREE)
10806 {
10807 tmp = gfc_get_tree_for_caf_expr (expr1);
10808 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
10809 tmp = build_fold_indirect_ref (tmp);
10810 gfc_get_caf_token_offset (&caf_se, &token, NULL, tmp, NULL_TREE,
10811 expr1);
10812 token = gfc_build_addr_expr (NULL_TREE, token);
10813 }
10814
10815 gfc_add_block_to_block (&realloc_block, &caf_se.pre);
10816 }
10817 if ((expr1->ts.type == BT_DERIVED)
10818 && expr1->ts.u.derived->attr.alloc_comp)
10819 {
10820 tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, old_desc,
10821 expr1->rank);
10822 gfc_add_expr_to_block (&realloc_block, tmp);
10823 }
10824
10825 if (!coarray)
10826 {
10827 tmp = build_call_expr_loc (input_location,
10828 builtin_decl_explicit (BUILT_IN_REALLOC), 2,
10829 fold_convert (pvoid_type_node, array1),
10830 size2);
10831 gfc_conv_descriptor_data_set (&realloc_block,
10832 desc, tmp);
10833 }
10834 else
10835 {
10836 tmp = build_call_expr_loc (input_location,
10837 gfor_fndecl_caf_deregister, 5, token,
10838 build_int_cst (integer_type_node,
10839 GFC_CAF_COARRAY_DEALLOCATE_ONLY),
10840 null_pointer_node, null_pointer_node,
10841 integer_zero_node);
10842 gfc_add_expr_to_block (&realloc_block, tmp);
10843 tmp = build_call_expr_loc (input_location,
10844 gfor_fndecl_caf_register,
10845 7, size2,
10846 build_int_cst (integer_type_node,
10847 GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY),
10848 token, gfc_build_addr_expr (NULL_TREE, desc),
10849 null_pointer_node, null_pointer_node,
10850 integer_zero_node);
10851 gfc_add_expr_to_block (&realloc_block, tmp);
10852 }
10853
10854 if ((expr1->ts.type == BT_DERIVED)
10855 && expr1->ts.u.derived->attr.alloc_comp)
10856 {
10857 tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc,
10858 expr1->rank);
10859 gfc_add_expr_to_block (&realloc_block, tmp);
10860 }
10861
10862 gfc_add_block_to_block (&realloc_block, &caf_se.post);
10863 realloc_expr = gfc_finish_block (&realloc_block);
10864
10865 /* Reallocate if sizes or dynamic types are different. */
10866 if (elemsize1)
10867 {
10868 tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10869 elemsize1, elemsize2);
10870 tmp = gfc_evaluate_now (tmp, &fblock);
10871 neq_size = fold_build2_loc (input_location, TRUTH_OR_EXPR,
10872 logical_type_node, neq_size, tmp);
10873 }
10874 tmp = build3_v (COND_EXPR, neq_size, realloc_expr,
10875 build_empty_stmt (input_location));
10876
10877 realloc_expr = tmp;
10878
10879 /* Malloc expression. */
10880 gfc_init_block (&alloc_block);
10881 if (!coarray)
10882 {
10883 tmp = build_call_expr_loc (input_location,
10884 builtin_decl_explicit (BUILT_IN_MALLOC),
10885 1, size2);
10886 gfc_conv_descriptor_data_set (&alloc_block,
10887 desc, tmp);
10888 }
10889 else
10890 {
10891 tmp = build_call_expr_loc (input_location,
10892 gfor_fndecl_caf_register,
10893 7, size2,
10894 build_int_cst (integer_type_node,
10895 GFC_CAF_COARRAY_ALLOC),
10896 token, gfc_build_addr_expr (NULL_TREE, desc),
10897 null_pointer_node, null_pointer_node,
10898 integer_zero_node);
10899 gfc_add_expr_to_block (&alloc_block, tmp);
10900 }
10901
10902
10903 /* We already set the dtype in the case of deferred character
10904 length arrays and unlimited polymorphic arrays. */
10905 if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
10906 && ((expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
10907 || coarray))
10908 && !UNLIMITED_POLY (expr1))
10909 {
10910 tmp = gfc_conv_descriptor_dtype (desc);
10911 gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
10912 }
10913
10914 if ((expr1->ts.type == BT_DERIVED)
10915 && expr1->ts.u.derived->attr.alloc_comp)
10916 {
10917 tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc,
10918 expr1->rank);
10919 gfc_add_expr_to_block (&alloc_block, tmp);
10920 }
10921 alloc_expr = gfc_finish_block (&alloc_block);
10922
10923 /* Malloc if not allocated; realloc otherwise. */
10924 tmp = build3_v (COND_EXPR, cond_null, alloc_expr, realloc_expr);
10925 gfc_add_expr_to_block (&fblock, tmp);
10926
10927 /* Make sure that the scalarizer data pointer is updated. */
10928 if (linfo->data && VAR_P (linfo->data))
10929 {
10930 tmp = gfc_conv_descriptor_data_get (desc);
10931 gfc_add_modify (&fblock, linfo->data, tmp);
10932 }
10933
10934 /* Add the label for same shape lhs and rhs. */
10935 tmp = build1_v (LABEL_EXPR, jump_label2);
10936 gfc_add_expr_to_block (&fblock, tmp);
10937
10938 return gfc_finish_block (&fblock);
10939 }
10940
10941
10942 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
10943 Do likewise, recursively if necessary, with the allocatable components of
10944 derived types. This function is also called for assumed-rank arrays, which
10945 are always dummy arguments. */
10946
10947 void
gfc_trans_deferred_array(gfc_symbol * sym,gfc_wrapped_block * block)10948 gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
10949 {
10950 tree type;
10951 tree tmp;
10952 tree descriptor;
10953 stmtblock_t init;
10954 stmtblock_t cleanup;
10955 locus loc;
10956 int rank;
10957 bool sym_has_alloc_comp, has_finalizer;
10958
10959 sym_has_alloc_comp = (sym->ts.type == BT_DERIVED
10960 || sym->ts.type == BT_CLASS)
10961 && sym->ts.u.derived->attr.alloc_comp;
10962 has_finalizer = sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED
10963 ? gfc_is_finalizable (sym->ts.u.derived, NULL) : false;
10964
10965 /* Make sure the frontend gets these right. */
10966 gcc_assert (sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp
10967 || has_finalizer
10968 || (sym->as->type == AS_ASSUMED_RANK && sym->attr.dummy));
10969
10970 gfc_save_backend_locus (&loc);
10971 gfc_set_backend_locus (&sym->declared_at);
10972 gfc_init_block (&init);
10973
10974 gcc_assert (VAR_P (sym->backend_decl)
10975 || TREE_CODE (sym->backend_decl) == PARM_DECL);
10976
10977 if (sym->ts.type == BT_CHARACTER
10978 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
10979 {
10980 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
10981 gfc_trans_vla_type_sizes (sym, &init);
10982 }
10983
10984 /* Dummy, use associated and result variables don't need anything special. */
10985 if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result)
10986 {
10987 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
10988 gfc_restore_backend_locus (&loc);
10989 return;
10990 }
10991
10992 descriptor = sym->backend_decl;
10993
10994 /* Although static, derived types with default initializers and
10995 allocatable components must not be nulled wholesale; instead they
10996 are treated component by component. */
10997 if (TREE_STATIC (descriptor) && !sym_has_alloc_comp && !has_finalizer)
10998 {
10999 /* SAVEd variables are not freed on exit. */
11000 gfc_trans_static_array_pointer (sym);
11001
11002 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
11003 gfc_restore_backend_locus (&loc);
11004 return;
11005 }
11006
11007 /* Get the descriptor type. */
11008 type = TREE_TYPE (sym->backend_decl);
11009
11010 if ((sym_has_alloc_comp || (has_finalizer && sym->ts.type != BT_CLASS))
11011 && !(sym->attr.pointer || sym->attr.allocatable))
11012 {
11013 if (!sym->attr.save
11014 && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program))
11015 {
11016 if (sym->value == NULL
11017 || !gfc_has_default_initializer (sym->ts.u.derived))
11018 {
11019 rank = sym->as ? sym->as->rank : 0;
11020 tmp = gfc_nullify_alloc_comp (sym->ts.u.derived,
11021 descriptor, rank);
11022 gfc_add_expr_to_block (&init, tmp);
11023 }
11024 else
11025 gfc_init_default_dt (sym, &init, false);
11026 }
11027 }
11028 else if (!GFC_DESCRIPTOR_TYPE_P (type))
11029 {
11030 /* If the backend_decl is not a descriptor, we must have a pointer
11031 to one. */
11032 descriptor = build_fold_indirect_ref_loc (input_location,
11033 sym->backend_decl);
11034 type = TREE_TYPE (descriptor);
11035 }
11036
11037 /* NULLIFY the data pointer, for non-saved allocatables. */
11038 if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save && sym->attr.allocatable)
11039 {
11040 gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node);
11041 if (flag_coarray == GFC_FCOARRAY_LIB && sym->attr.codimension)
11042 {
11043 /* Declare the variable static so its array descriptor stays present
11044 after leaving the scope. It may still be accessed through another
11045 image. This may happen, for example, with the caf_mpi
11046 implementation. */
11047 TREE_STATIC (descriptor) = 1;
11048 tmp = gfc_conv_descriptor_token (descriptor);
11049 gfc_add_modify (&init, tmp, fold_convert (TREE_TYPE (tmp),
11050 null_pointer_node));
11051 }
11052 }
11053
11054 gfc_restore_backend_locus (&loc);
11055 gfc_init_block (&cleanup);
11056
11057 /* Allocatable arrays need to be freed when they go out of scope.
11058 The allocatable components of pointers must not be touched. */
11059 if (!sym->attr.allocatable && has_finalizer && sym->ts.type != BT_CLASS
11060 && !sym->attr.pointer && !sym->attr.artificial && !sym->attr.save
11061 && !sym->ns->proc_name->attr.is_main_program)
11062 {
11063 gfc_expr *e;
11064 sym->attr.referenced = 1;
11065 e = gfc_lval_expr_from_sym (sym);
11066 gfc_add_finalizer_call (&cleanup, e);
11067 gfc_free_expr (e);
11068 }
11069 else if ((!sym->attr.allocatable || !has_finalizer)
11070 && sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
11071 && !sym->attr.pointer && !sym->attr.save
11072 && !sym->ns->proc_name->attr.is_main_program)
11073 {
11074 int rank;
11075 rank = sym->as ? sym->as->rank : 0;
11076 tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank);
11077 gfc_add_expr_to_block (&cleanup, tmp);
11078 }
11079
11080 if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension)
11081 && !sym->attr.save && !sym->attr.result
11082 && !sym->ns->proc_name->attr.is_main_program)
11083 {
11084 gfc_expr *e;
11085 e = has_finalizer ? gfc_lval_expr_from_sym (sym) : NULL;
11086 tmp = gfc_deallocate_with_status (sym->backend_decl, NULL_TREE, NULL_TREE,
11087 NULL_TREE, NULL_TREE, true, e,
11088 sym->attr.codimension
11089 ? GFC_CAF_COARRAY_DEREGISTER
11090 : GFC_CAF_COARRAY_NOCOARRAY);
11091 if (e)
11092 gfc_free_expr (e);
11093 gfc_add_expr_to_block (&cleanup, tmp);
11094 }
11095
11096 gfc_add_init_cleanup (block, gfc_finish_block (&init),
11097 gfc_finish_block (&cleanup));
11098 }
11099
11100 /************ Expression Walking Functions ******************/
11101
11102 /* Walk a variable reference.
11103
11104 Possible extension - multiple component subscripts.
11105 x(:,:) = foo%a(:)%b(:)
11106 Transforms to
11107 forall (i=..., j=...)
11108 x(i,j) = foo%a(j)%b(i)
11109 end forall
11110 This adds a fair amount of complexity because you need to deal with more
11111 than one ref. Maybe handle in a similar manner to vector subscripts.
11112 Maybe not worth the effort. */
11113
11114
11115 static gfc_ss *
gfc_walk_variable_expr(gfc_ss * ss,gfc_expr * expr)11116 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
11117 {
11118 gfc_ref *ref;
11119
11120 gfc_fix_class_refs (expr);
11121
11122 for (ref = expr->ref; ref; ref = ref->next)
11123 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
11124 break;
11125
11126 return gfc_walk_array_ref (ss, expr, ref);
11127 }
11128
11129
11130 gfc_ss *
gfc_walk_array_ref(gfc_ss * ss,gfc_expr * expr,gfc_ref * ref)11131 gfc_walk_array_ref (gfc_ss * ss, gfc_expr * expr, gfc_ref * ref)
11132 {
11133 gfc_array_ref *ar;
11134 gfc_ss *newss;
11135 int n;
11136
11137 for (; ref; ref = ref->next)
11138 {
11139 if (ref->type == REF_SUBSTRING)
11140 {
11141 ss = gfc_get_scalar_ss (ss, ref->u.ss.start);
11142 ss = gfc_get_scalar_ss (ss, ref->u.ss.end);
11143 }
11144
11145 /* We're only interested in array sections from now on. */
11146 if (ref->type != REF_ARRAY)
11147 continue;
11148
11149 ar = &ref->u.ar;
11150
11151 switch (ar->type)
11152 {
11153 case AR_ELEMENT:
11154 for (n = ar->dimen - 1; n >= 0; n--)
11155 ss = gfc_get_scalar_ss (ss, ar->start[n]);
11156 break;
11157
11158 case AR_FULL:
11159 newss = gfc_get_array_ss (ss, expr, ar->as->rank, GFC_SS_SECTION);
11160 newss->info->data.array.ref = ref;
11161
11162 /* Make sure array is the same as array(:,:), this way
11163 we don't need to special case all the time. */
11164 ar->dimen = ar->as->rank;
11165 for (n = 0; n < ar->dimen; n++)
11166 {
11167 ar->dimen_type[n] = DIMEN_RANGE;
11168
11169 gcc_assert (ar->start[n] == NULL);
11170 gcc_assert (ar->end[n] == NULL);
11171 gcc_assert (ar->stride[n] == NULL);
11172 }
11173 ss = newss;
11174 break;
11175
11176 case AR_SECTION:
11177 newss = gfc_get_array_ss (ss, expr, 0, GFC_SS_SECTION);
11178 newss->info->data.array.ref = ref;
11179
11180 /* We add SS chains for all the subscripts in the section. */
11181 for (n = 0; n < ar->dimen; n++)
11182 {
11183 gfc_ss *indexss;
11184
11185 switch (ar->dimen_type[n])
11186 {
11187 case DIMEN_ELEMENT:
11188 /* Add SS for elemental (scalar) subscripts. */
11189 gcc_assert (ar->start[n]);
11190 indexss = gfc_get_scalar_ss (gfc_ss_terminator, ar->start[n]);
11191 indexss->loop_chain = gfc_ss_terminator;
11192 newss->info->data.array.subscript[n] = indexss;
11193 break;
11194
11195 case DIMEN_RANGE:
11196 /* We don't add anything for sections, just remember this
11197 dimension for later. */
11198 newss->dim[newss->dimen] = n;
11199 newss->dimen++;
11200 break;
11201
11202 case DIMEN_VECTOR:
11203 /* Create a GFC_SS_VECTOR index in which we can store
11204 the vector's descriptor. */
11205 indexss = gfc_get_array_ss (gfc_ss_terminator, ar->start[n],
11206 1, GFC_SS_VECTOR);
11207 indexss->loop_chain = gfc_ss_terminator;
11208 newss->info->data.array.subscript[n] = indexss;
11209 newss->dim[newss->dimen] = n;
11210 newss->dimen++;
11211 break;
11212
11213 default:
11214 /* We should know what sort of section it is by now. */
11215 gcc_unreachable ();
11216 }
11217 }
11218 /* We should have at least one non-elemental dimension,
11219 unless we are creating a descriptor for a (scalar) coarray. */
11220 gcc_assert (newss->dimen > 0
11221 || newss->info->data.array.ref->u.ar.as->corank > 0);
11222 ss = newss;
11223 break;
11224
11225 default:
11226 /* We should know what sort of section it is by now. */
11227 gcc_unreachable ();
11228 }
11229
11230 }
11231 return ss;
11232 }
11233
11234
11235 /* Walk an expression operator. If only one operand of a binary expression is
11236 scalar, we must also add the scalar term to the SS chain. */
11237
11238 static gfc_ss *
gfc_walk_op_expr(gfc_ss * ss,gfc_expr * expr)11239 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
11240 {
11241 gfc_ss *head;
11242 gfc_ss *head2;
11243
11244 head = gfc_walk_subexpr (ss, expr->value.op.op1);
11245 if (expr->value.op.op2 == NULL)
11246 head2 = head;
11247 else
11248 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
11249
11250 /* All operands are scalar. Pass back and let the caller deal with it. */
11251 if (head2 == ss)
11252 return head2;
11253
11254 /* All operands require scalarization. */
11255 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
11256 return head2;
11257
11258 /* One of the operands needs scalarization, the other is scalar.
11259 Create a gfc_ss for the scalar expression. */
11260 if (head == ss)
11261 {
11262 /* First operand is scalar. We build the chain in reverse order, so
11263 add the scalar SS after the second operand. */
11264 head = head2;
11265 while (head && head->next != ss)
11266 head = head->next;
11267 /* Check we haven't somehow broken the chain. */
11268 gcc_assert (head);
11269 head->next = gfc_get_scalar_ss (ss, expr->value.op.op1);
11270 }
11271 else /* head2 == head */
11272 {
11273 gcc_assert (head2 == head);
11274 /* Second operand is scalar. */
11275 head2 = gfc_get_scalar_ss (head2, expr->value.op.op2);
11276 }
11277
11278 return head2;
11279 }
11280
11281
11282 /* Reverse a SS chain. */
11283
11284 gfc_ss *
gfc_reverse_ss(gfc_ss * ss)11285 gfc_reverse_ss (gfc_ss * ss)
11286 {
11287 gfc_ss *next;
11288 gfc_ss *head;
11289
11290 gcc_assert (ss != NULL);
11291
11292 head = gfc_ss_terminator;
11293 while (ss != gfc_ss_terminator)
11294 {
11295 next = ss->next;
11296 /* Check we didn't somehow break the chain. */
11297 gcc_assert (next != NULL);
11298 ss->next = head;
11299 head = ss;
11300 ss = next;
11301 }
11302
11303 return (head);
11304 }
11305
11306
11307 /* Given an expression referring to a procedure, return the symbol of its
11308 interface. We can't get the procedure symbol directly as we have to handle
11309 the case of (deferred) type-bound procedures. */
11310
11311 gfc_symbol *
gfc_get_proc_ifc_for_expr(gfc_expr * procedure_ref)11312 gfc_get_proc_ifc_for_expr (gfc_expr *procedure_ref)
11313 {
11314 gfc_symbol *sym;
11315 gfc_ref *ref;
11316
11317 if (procedure_ref == NULL)
11318 return NULL;
11319
11320 /* Normal procedure case. */
11321 if (procedure_ref->expr_type == EXPR_FUNCTION
11322 && procedure_ref->value.function.esym)
11323 sym = procedure_ref->value.function.esym;
11324 else
11325 sym = procedure_ref->symtree->n.sym;
11326
11327 /* Typebound procedure case. */
11328 for (ref = procedure_ref->ref; ref; ref = ref->next)
11329 {
11330 if (ref->type == REF_COMPONENT
11331 && ref->u.c.component->attr.proc_pointer)
11332 sym = ref->u.c.component->ts.interface;
11333 else
11334 sym = NULL;
11335 }
11336
11337 return sym;
11338 }
11339
11340
11341 /* Walk the arguments of an elemental function.
11342 PROC_EXPR is used to check whether an argument is permitted to be absent. If
11343 it is NULL, we don't do the check and the argument is assumed to be present.
11344 */
11345
11346 gfc_ss *
gfc_walk_elemental_function_args(gfc_ss * ss,gfc_actual_arglist * arg,gfc_symbol * proc_ifc,gfc_ss_type type)11347 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
11348 gfc_symbol *proc_ifc, gfc_ss_type type)
11349 {
11350 gfc_formal_arglist *dummy_arg;
11351 int scalar;
11352 gfc_ss *head;
11353 gfc_ss *tail;
11354 gfc_ss *newss;
11355
11356 head = gfc_ss_terminator;
11357 tail = NULL;
11358
11359 if (proc_ifc)
11360 dummy_arg = gfc_sym_get_dummy_args (proc_ifc);
11361 else
11362 dummy_arg = NULL;
11363
11364 scalar = 1;
11365 for (; arg; arg = arg->next)
11366 {
11367 if (!arg->expr || arg->expr->expr_type == EXPR_NULL)
11368 goto loop_continue;
11369
11370 newss = gfc_walk_subexpr (head, arg->expr);
11371 if (newss == head)
11372 {
11373 /* Scalar argument. */
11374 gcc_assert (type == GFC_SS_SCALAR || type == GFC_SS_REFERENCE);
11375 newss = gfc_get_scalar_ss (head, arg->expr);
11376 newss->info->type = type;
11377 if (dummy_arg)
11378 newss->info->data.scalar.dummy_arg = dummy_arg->sym;
11379 }
11380 else
11381 scalar = 0;
11382
11383 if (dummy_arg != NULL
11384 && dummy_arg->sym->attr.optional
11385 && arg->expr->expr_type == EXPR_VARIABLE
11386 && (gfc_expr_attr (arg->expr).optional
11387 || gfc_expr_attr (arg->expr).allocatable
11388 || gfc_expr_attr (arg->expr).pointer))
11389 newss->info->can_be_null_ref = true;
11390
11391 head = newss;
11392 if (!tail)
11393 {
11394 tail = head;
11395 while (tail->next != gfc_ss_terminator)
11396 tail = tail->next;
11397 }
11398
11399 loop_continue:
11400 if (dummy_arg != NULL)
11401 dummy_arg = dummy_arg->next;
11402 }
11403
11404 if (scalar)
11405 {
11406 /* If all the arguments are scalar we don't need the argument SS. */
11407 gfc_free_ss_chain (head);
11408 /* Pass it back. */
11409 return ss;
11410 }
11411
11412 /* Add it onto the existing chain. */
11413 tail->next = ss;
11414 return head;
11415 }
11416
11417
11418 /* Walk a function call. Scalar functions are passed back, and taken out of
11419 scalarization loops. For elemental functions we walk their arguments.
11420 The result of functions returning arrays is stored in a temporary outside
11421 the loop, so that the function is only called once. Hence we do not need
11422 to walk their arguments. */
11423
11424 static gfc_ss *
gfc_walk_function_expr(gfc_ss * ss,gfc_expr * expr)11425 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
11426 {
11427 gfc_intrinsic_sym *isym;
11428 gfc_symbol *sym;
11429 gfc_component *comp = NULL;
11430
11431 isym = expr->value.function.isym;
11432
11433 /* Handle intrinsic functions separately. */
11434 if (isym)
11435 return gfc_walk_intrinsic_function (ss, expr, isym);
11436
11437 sym = expr->value.function.esym;
11438 if (!sym)
11439 sym = expr->symtree->n.sym;
11440
11441 if (gfc_is_class_array_function (expr))
11442 return gfc_get_array_ss (ss, expr,
11443 CLASS_DATA (expr->value.function.esym->result)->as->rank,
11444 GFC_SS_FUNCTION);
11445
11446 /* A function that returns arrays. */
11447 comp = gfc_get_proc_ptr_comp (expr);
11448 if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
11449 || (comp && comp->attr.dimension))
11450 return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
11451
11452 /* Walk the parameters of an elemental function. For now we always pass
11453 by reference. */
11454 if (sym->attr.elemental || (comp && comp->attr.elemental))
11455 {
11456 gfc_ss *old_ss = ss;
11457
11458 ss = gfc_walk_elemental_function_args (old_ss,
11459 expr->value.function.actual,
11460 gfc_get_proc_ifc_for_expr (expr),
11461 GFC_SS_REFERENCE);
11462 if (ss != old_ss
11463 && (comp
11464 || sym->attr.proc_pointer
11465 || sym->attr.if_source != IFSRC_DECL
11466 || sym->attr.array_outer_dependency))
11467 ss->info->array_outer_dependency = 1;
11468 }
11469
11470 /* Scalar functions are OK as these are evaluated outside the scalarization
11471 loop. Pass back and let the caller deal with it. */
11472 return ss;
11473 }
11474
11475
11476 /* An array temporary is constructed for array constructors. */
11477
11478 static gfc_ss *
gfc_walk_array_constructor(gfc_ss * ss,gfc_expr * expr)11479 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
11480 {
11481 return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_CONSTRUCTOR);
11482 }
11483
11484
11485 /* Walk an expression. Add walked expressions to the head of the SS chain.
11486 A wholly scalar expression will not be added. */
11487
11488 gfc_ss *
gfc_walk_subexpr(gfc_ss * ss,gfc_expr * expr)11489 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
11490 {
11491 gfc_ss *head;
11492
11493 switch (expr->expr_type)
11494 {
11495 case EXPR_VARIABLE:
11496 head = gfc_walk_variable_expr (ss, expr);
11497 return head;
11498
11499 case EXPR_OP:
11500 head = gfc_walk_op_expr (ss, expr);
11501 return head;
11502
11503 case EXPR_FUNCTION:
11504 head = gfc_walk_function_expr (ss, expr);
11505 return head;
11506
11507 case EXPR_CONSTANT:
11508 case EXPR_NULL:
11509 case EXPR_STRUCTURE:
11510 /* Pass back and let the caller deal with it. */
11511 break;
11512
11513 case EXPR_ARRAY:
11514 head = gfc_walk_array_constructor (ss, expr);
11515 return head;
11516
11517 case EXPR_SUBSTRING:
11518 /* Pass back and let the caller deal with it. */
11519 break;
11520
11521 default:
11522 gfc_internal_error ("bad expression type during walk (%d)",
11523 expr->expr_type);
11524 }
11525 return ss;
11526 }
11527
11528
11529 /* Entry point for expression walking.
11530 A return value equal to the passed chain means this is
11531 a scalar expression. It is up to the caller to take whatever action is
11532 necessary to translate these. */
11533
11534 gfc_ss *
gfc_walk_expr(gfc_expr * expr)11535 gfc_walk_expr (gfc_expr * expr)
11536 {
11537 gfc_ss *res;
11538
11539 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
11540 return gfc_reverse_ss (res);
11541 }
11542