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