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