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