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