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