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