1 /* Array translation routines
2 Copyright (C) 2002-2022 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
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
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
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/>. */
22 /* trans-array.cc-- Various array related code, including scalarization,
23 allocation, initialization and other support routines. */
25 /* How the scalarizer works.
26 In gfortran, array expressions use the same core routines as scalar
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.
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.
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.
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.
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
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.
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.
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.
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.
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. */
80 #include "coretypes.h"
84 #include "gimple-expr.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"
93 static bool gfc_get_array_constructor_size (mpz_t
*, gfc_constructor_base
);
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
;
101 gfc_array_dataptr_type (tree desc
)
103 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
)));
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
115 #define CFI_DIM_FIELD_LOWER_BOUND 0
116 #define CFI_DIM_FIELD_EXTENT 1
117 #define CFI_DIM_FIELD_SM 2
120 gfc_get_cfi_descriptor_field (tree desc
, unsigned field_idx
)
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
))))
128 tree field
= gfc_advance_chain (TYPE_FIELDS (type
), field_idx
);
129 gcc_assert (field
!= NULL_TREE
);
131 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
132 desc
, field
, NULL_TREE
);
136 gfc_get_cfi_desc_base_addr (tree desc
)
138 return gfc_get_cfi_descriptor_field (desc
, CFI_FIELD_BASE_ADDR
);
142 gfc_get_cfi_desc_elem_len (tree desc
)
144 return gfc_get_cfi_descriptor_field (desc
, CFI_FIELD_ELEM_LEN
);
148 gfc_get_cfi_desc_version (tree desc
)
150 return gfc_get_cfi_descriptor_field (desc
, CFI_FIELD_VERSION
);
154 gfc_get_cfi_desc_rank (tree desc
)
156 return gfc_get_cfi_descriptor_field (desc
, CFI_FIELD_RANK
);
160 gfc_get_cfi_desc_type (tree desc
)
162 return gfc_get_cfi_descriptor_field (desc
, CFI_FIELD_TYPE
);
166 gfc_get_cfi_desc_attribute (tree desc
)
168 return gfc_get_cfi_descriptor_field (desc
, CFI_FIELD_ATTRIBUTE
);
172 gfc_get_cfi_dim_item (tree desc
, tree idx
, unsigned field_idx
)
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
);
183 gfc_get_cfi_dim_lbound (tree desc
, tree idx
)
185 return gfc_get_cfi_dim_item (desc
, idx
, CFI_DIM_FIELD_LOWER_BOUND
);
189 gfc_get_cfi_dim_extent (tree desc
, tree idx
)
191 return gfc_get_cfi_dim_item (desc
, idx
, CFI_DIM_FIELD_EXTENT
);
195 gfc_get_cfi_dim_sm (tree desc
, tree idx
)
197 return gfc_get_cfi_dim_item (desc
, idx
, CFI_DIM_FIELD_SM
);
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
208 #undef CFI_DIM_FIELD_LOWER_BOUND
209 #undef CFI_DIM_FIELD_EXTENT
210 #undef CFI_DIM_FIELD_SM
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.
218 To understand these magic numbers, look at the comments
219 before gfc_build_array_type() in trans-types.cc.
221 The code within these defines should be the only code which knows the format
222 of an array descriptor.
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.
228 Don't forget to #undef these! */
231 #define OFFSET_FIELD 1
232 #define DTYPE_FIELD 2
234 #define DIMENSION_FIELD 4
235 #define CAF_TOKEN_FIELD 5
237 #define STRIDE_SUBFIELD 0
238 #define LBOUND_SUBFIELD 1
239 #define UBOUND_SUBFIELD 2
242 gfc_get_descriptor_field (tree desc
, unsigned field_idx
)
244 tree type
= TREE_TYPE (desc
);
245 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
247 tree field
= gfc_advance_chain (TYPE_FIELDS (type
), field_idx
);
248 gcc_assert (field
!= NULL_TREE
);
250 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
251 desc
, field
, NULL_TREE
);
254 /* This provides READ-ONLY access to the data field. The field itself
255 doesn't have the proper type. */
258 gfc_conv_descriptor_data_get (tree desc
)
260 tree type
= TREE_TYPE (desc
);
261 if (TREE_CODE (type
) == REFERENCE_TYPE
)
264 tree field
= gfc_get_descriptor_field (desc
, DATA_FIELD
);
265 return fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type
), field
);
268 /* This provides WRITE access to the data field.
270 TUPLES_P is true if we are generating tuples.
272 This function gets called through the following macros:
273 gfc_conv_descriptor_data_set
274 gfc_conv_descriptor_data_set. */
277 gfc_conv_descriptor_data_set (stmtblock_t
*block
, tree desc
, tree value
)
279 tree field
= gfc_get_descriptor_field (desc
, DATA_FIELD
);
280 gfc_add_modify (block
, field
, fold_convert (TREE_TYPE (field
), value
));
284 /* This provides address access to the data field. This should only be
285 used by array allocation, passing this on to the runtime. */
288 gfc_conv_descriptor_data_addr (tree desc
)
290 tree field
= gfc_get_descriptor_field (desc
, DATA_FIELD
);
291 return gfc_build_addr_expr (NULL_TREE
, field
);
295 gfc_conv_descriptor_offset (tree desc
)
297 tree field
= gfc_get_descriptor_field (desc
, OFFSET_FIELD
);
298 gcc_assert (TREE_TYPE (field
) == gfc_array_index_type
);
303 gfc_conv_descriptor_offset_get (tree desc
)
305 return gfc_conv_descriptor_offset (desc
);
309 gfc_conv_descriptor_offset_set (stmtblock_t
*block
, tree desc
,
312 tree t
= gfc_conv_descriptor_offset (desc
);
313 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
318 gfc_conv_descriptor_dtype (tree desc
)
320 tree field
= gfc_get_descriptor_field (desc
, DTYPE_FIELD
);
321 gcc_assert (TREE_TYPE (field
) == get_dtype_type_node ());
326 gfc_conv_descriptor_span (tree desc
)
328 tree field
= gfc_get_descriptor_field (desc
, SPAN_FIELD
);
329 gcc_assert (TREE_TYPE (field
) == gfc_array_index_type
);
334 gfc_conv_descriptor_span_get (tree desc
)
336 return gfc_conv_descriptor_span (desc
);
340 gfc_conv_descriptor_span_set (stmtblock_t
*block
, tree desc
,
343 tree t
= gfc_conv_descriptor_span (desc
);
344 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
349 gfc_conv_descriptor_rank (tree desc
)
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
);
363 /* Return the element length from the descriptor dtype field. */
366 gfc_conv_descriptor_elem_len (tree desc
)
371 dtype
= gfc_conv_descriptor_dtype (desc
);
372 tmp
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype
)),
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
);
382 gfc_conv_descriptor_attribute (tree desc
)
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
);
397 gfc_conv_descriptor_type (tree desc
)
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
);
411 gfc_get_descriptor_dimension (tree desc
)
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
);
421 gfc_conv_descriptor_dimension (tree desc
, tree dim
)
425 tmp
= gfc_get_descriptor_dimension (desc
);
427 return gfc_build_array_ref (tmp
, dim
, NULL
);
432 gfc_conv_descriptor_token (tree desc
)
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
);
443 gfc_conv_descriptor_subfield (tree desc
, tree dim
, unsigned field_idx
)
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
);
449 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
450 tmp
, field
, NULL_TREE
);
454 gfc_conv_descriptor_stride (tree desc
, tree dim
)
456 tree field
= gfc_conv_descriptor_subfield (desc
, dim
, STRIDE_SUBFIELD
);
457 gcc_assert (TREE_TYPE (field
) == gfc_array_index_type
);
462 gfc_conv_descriptor_stride_get (tree desc
, tree dim
)
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
;
473 return gfc_conv_descriptor_stride (desc
, dim
);
477 gfc_conv_descriptor_stride_set (stmtblock_t
*block
, tree desc
,
478 tree dim
, tree value
)
480 tree t
= gfc_conv_descriptor_stride (desc
, dim
);
481 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
485 gfc_conv_descriptor_lbound (tree desc
, tree dim
)
487 tree field
= gfc_conv_descriptor_subfield (desc
, dim
, LBOUND_SUBFIELD
);
488 gcc_assert (TREE_TYPE (field
) == gfc_array_index_type
);
493 gfc_conv_descriptor_lbound_get (tree desc
, tree dim
)
495 return gfc_conv_descriptor_lbound (desc
, dim
);
499 gfc_conv_descriptor_lbound_set (stmtblock_t
*block
, tree desc
,
500 tree dim
, tree value
)
502 tree t
= gfc_conv_descriptor_lbound (desc
, dim
);
503 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
507 gfc_conv_descriptor_ubound (tree desc
, tree dim
)
509 tree field
= gfc_conv_descriptor_subfield (desc
, dim
, UBOUND_SUBFIELD
);
510 gcc_assert (TREE_TYPE (field
) == gfc_array_index_type
);
515 gfc_conv_descriptor_ubound_get (tree desc
, tree dim
)
517 return gfc_conv_descriptor_ubound (desc
, dim
);
521 gfc_conv_descriptor_ubound_set (stmtblock_t
*block
, tree desc
,
522 tree dim
, tree value
)
524 tree t
= gfc_conv_descriptor_ubound (desc
, dim
);
525 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
528 /* Build a null array descriptor constructor. */
531 gfc_build_null_descriptor (tree type
)
536 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
537 gcc_assert (DATA_FIELD
== 0);
538 field
= TYPE_FIELDS (type
);
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. */
549 /* Modify a descriptor such that the lbound of a given dimension is the value
550 specified. This also updates ubound and offset accordingly. */
553 gfc_conv_shift_descriptor_lbound (stmtblock_t
* block
, tree desc
,
554 int dim
, tree new_lbound
)
556 tree offs
, ubound
, lbound
, stride
;
557 tree diff
, offs_diff
;
559 new_lbound
= fold_convert (gfc_array_index_type
, new_lbound
);
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
]);
566 /* Get difference (new - old) by which to shift stuff. */
567 diff
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
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
,
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
,
577 offs
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
579 gfc_conv_descriptor_offset_set (block
, desc
, offs
);
581 /* Finally set lbound to value we want. */
582 gfc_conv_descriptor_lbound_set (block
, desc
, gfc_rank_cst
[dim
], new_lbound
);
586 /* Obtain offsets for trans-types.cc(gfc_get_array_descr_info). */
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
,
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
);
618 /* Cleanup those #defines. */
624 #undef DIMENSION_FIELD
625 #undef CAF_TOKEN_FIELD
626 #undef STRIDE_SUBFIELD
627 #undef LBOUND_SUBFIELD
628 #undef UBOUND_SUBFIELD
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. */
636 gfc_mark_ss_chain_used (gfc_ss
* ss
, unsigned flags
)
638 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
639 ss
->info
->useflags
= flags
;
643 /* Free a gfc_ss chain. */
646 gfc_free_ss_chain (gfc_ss
* ss
)
650 while (ss
!= gfc_ss_terminator
)
652 gcc_assert (ss
!= NULL
);
661 free_ss_info (gfc_ss_info
*ss_info
)
666 if (ss_info
->refcount
> 0)
669 gcc_assert (ss_info
->refcount
== 0);
671 switch (ss_info
->type
)
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
]);
690 gfc_free_ss (gfc_ss
* ss
)
692 free_ss_info (ss
->info
);
697 /* Creates and initializes an array type gfc_ss struct. */
700 gfc_get_array_ss (gfc_ss
*next
, gfc_expr
*expr
, int dimen
, gfc_ss_type type
)
703 gfc_ss_info
*ss_info
;
706 ss_info
= gfc_get_ss_info ();
708 ss_info
->type
= type
;
709 ss_info
->expr
= expr
;
715 for (i
= 0; i
< ss
->dimen
; i
++)
722 /* Creates and initializes a temporary type gfc_ss struct. */
725 gfc_get_temp_ss (tree type
, tree string_length
, int dimen
)
728 gfc_ss_info
*ss_info
;
731 ss_info
= gfc_get_ss_info ();
733 ss_info
->type
= GFC_SS_TEMP
;
734 ss_info
->string_length
= string_length
;
735 ss_info
->data
.temp
.type
= type
;
739 ss
->next
= gfc_ss_terminator
;
741 for (i
= 0; i
< ss
->dimen
; i
++)
748 /* Creates and initializes a scalar type gfc_ss struct. */
751 gfc_get_scalar_ss (gfc_ss
*next
, gfc_expr
*expr
)
754 gfc_ss_info
*ss_info
;
756 ss_info
= gfc_get_ss_info ();
758 ss_info
->type
= GFC_SS_SCALAR
;
759 ss_info
->expr
= expr
;
769 /* Free all the SS associated with a loop. */
772 gfc_cleanup_loop (gfc_loopinfo
* loop
)
774 gfc_loopinfo
*loop_next
, **ploop
;
779 while (ss
!= gfc_ss_terminator
)
781 gcc_assert (ss
!= NULL
);
782 next
= ss
->loop_chain
;
787 /* Remove reference to self in the parent loop. */
789 for (ploop
= &loop
->parent
->nested
; *ploop
; ploop
= &(*ploop
)->next
)
796 /* Free non-freed nested loops. */
797 for (loop
= loop
->nested
; loop
; loop
= loop_next
)
799 loop_next
= loop
->next
;
800 gfc_cleanup_loop (loop
);
807 set_ss_loop (gfc_ss
*ss
, gfc_loopinfo
*loop
)
811 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
815 if (ss
->info
->type
== GFC_SS_SCALAR
816 || ss
->info
->type
== GFC_SS_REFERENCE
817 || ss
->info
->type
== GFC_SS_TEMP
)
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
);
827 /* Associate a SS chain with a loop. */
830 gfc_add_ss_to_loop (gfc_loopinfo
* loop
, gfc_ss
* head
)
833 gfc_loopinfo
*nested_loop
;
835 if (head
== gfc_ss_terminator
)
838 set_ss_loop (head
, loop
);
841 for (; ss
&& ss
!= gfc_ss_terminator
; ss
= ss
->next
)
845 nested_loop
= ss
->nested_ss
->loop
;
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
)
852 gcc_assert (nested_loop
->parent
== NULL
);
853 nested_loop
->parent
= loop
;
855 gcc_assert (nested_loop
->next
== NULL
);
856 nested_loop
->next
= loop
->nested
;
857 loop
->nested
= nested_loop
;
860 gcc_assert (nested_loop
->parent
== loop
);
863 if (ss
->next
== gfc_ss_terminator
)
864 ss
->loop_chain
= loop
->ss
;
866 ss
->loop_chain
= ss
->next
;
868 gcc_assert (ss
== gfc_ss_terminator
);
873 /* Returns true if the expression is an array pointer. */
876 is_pointer_array (tree expr
)
878 if (expr
== NULL_TREE
879 || !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr
))
880 || GFC_CLASS_TYPE_P (TREE_TYPE (expr
)))
883 if (TREE_CODE (expr
) == VAR_DECL
884 && GFC_DECL_PTR_ARRAY_P (expr
))
887 if (TREE_CODE (expr
) == PARM_DECL
888 && GFC_DECL_PTR_ARRAY_P (expr
))
891 if (TREE_CODE (expr
) == INDIRECT_REF
892 && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr
, 0)))
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))))
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! */
912 get_CFI_desc (gfc_symbol
*sym
, gfc_expr
*expr
,
913 tree
*desc
, gfc_array_ref
*ar
)
917 if (!is_CFI_desc (sym
, expr
))
922 if (!(expr
->ref
&& expr
->ref
->type
== REF_ARRAY
)
923 || (&expr
->ref
->u
.ar
!= ar
))
928 tmp
= expr
->symtree
->n
.sym
->backend_decl
;
930 tmp
= sym
->backend_decl
;
932 if (tmp
&& DECL_LANG_SPECIFIC (tmp
) && GFC_DECL_SAVED_DESCRIPTOR (tmp
))
933 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmp
);
940 /* Return the span of an array. */
943 gfc_get_array_span (tree desc
, gfc_expr
*expr
)
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
)))))
953 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
954 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
956 /* This will have the span field set. */
957 tmp
= gfc_conv_descriptor_span_get (desc
);
959 else if (expr
->ts
.type
== BT_ASSUMED
)
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
);
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))))
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
);
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
)
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
);
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
))
996 gcc_assert (expr
->ts
.type
== BT_CHARACTER
);
998 tmp
= gfc_get_character_len_in_bytes (tmp
);
1000 if (tmp
== NULL_TREE
|| integer_zerop (tmp
))
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
);
1011 tmp
= (tmp
&& !integer_zerop (tmp
))
1012 ? (fold_convert (gfc_array_index_type
, tmp
)) : (NULL_TREE
);
1015 tmp
= fold_convert (gfc_array_index_type
,
1016 size_in_bytes (tmp
));
1022 /* Generate an initializer for a static pointer or allocatable array. */
1025 gfc_trans_static_array_pointer (gfc_symbol
* sym
)
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
);
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
1043 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping
* mapping
,
1044 gfc_se
* se
, gfc_array_spec
* as
)
1046 int n
, dim
, total_dim
;
1055 if (!as
|| as
->type
!= AS_EXPLICIT
)
1058 for (ss
= se
->ss
; ss
; ss
= ss
->parent
)
1060 total_dim
+= ss
->loop
->dimen
;
1061 for (n
= 0; n
< ss
->loop
->dimen
; n
++)
1063 /* The bound is known, nothing to do. */
1064 if (ss
->loop
->to
[n
] != NULL_TREE
)
1068 gcc_assert (dim
< as
->rank
);
1069 gcc_assert (ss
->loop
->dimen
<= as
->rank
);
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
);
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
);
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
;
1093 gcc_assert (total_dim
== as
->rank
);
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.
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.
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. */
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
)
1118 desc
= info
->descriptor
;
1119 info
->offset
= gfc_index_zero_node
;
1120 if (size
== NULL_TREE
|| integer_zerop (size
))
1122 /* A callee allocated array. */
1123 gfc_conv_descriptor_data_set (pre
, desc
, null_pointer_node
);
1128 /* Allocate the temporary. */
1129 onstack
= !dynamic
&& initial
== NULL_TREE
1130 && (flag_stack_arrays
1131 || gfc_can_put_var_on_stack (size
));
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
,
1141 tmp
= build_array_type (gfc_get_element_type (TREE_TYPE (desc
)),
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
),
1151 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1152 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
1156 /* Allocate memory to hold the data or call internal_pack. */
1157 if (initial
== NULL_TREE
)
1159 tmp
= gfc_call_malloc (pre
, NULL
, size
);
1160 tmp
= gfc_evaluate_now (tmp
, pre
);
1167 stmtblock_t do_copying
;
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");
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
);
1180 tmp
= build_fold_indirect_ref_loc (input_location
,
1182 source_data
= gfc_conv_descriptor_data_get (tmp
);
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. */
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
);
1195 was_packed
= fold_build2_loc (input_location
, EQ_EXPR
,
1196 logical_type_node
, packed
,
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
);
1203 tmp
= fold_convert (pvoid_type_node
, packed
);
1206 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
1209 info
->data
= gfc_conv_descriptor_data_get (desc
);
1211 /* The offset is zero because we create temporaries with a zero
1213 gfc_conv_descriptor_offset_set (pre
, desc
, gfc_index_zero_node
);
1215 if (dealloc
&& !onstack
)
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
);
1225 /* Get the scalarizer array dimension corresponding to actual array dimension
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
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. */
1240 get_scalarizer_dim_for_array_dim (gfc_ss
*ss
, int array_dim
)
1247 for (; ss
; ss
= ss
->parent
)
1248 for (n
= 0; n
< ss
->dimen
; n
++)
1249 if (ss
->dim
[n
] < array_dim
)
1252 return array_ref_dim
;
1257 innermost_ss (gfc_ss
*ss
)
1259 while (ss
->nested_ss
!= NULL
)
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.
1274 get_array_ref_dim_for_loop_dim (gfc_ss
*ss
, int loop_dim
)
1276 return get_scalarizer_dim_for_array_dim (innermost_ss (ss
),
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. */
1286 get_class_info_from_ss (stmtblock_t
* pre
, gfc_ss
*ss
, tree
*eltype
)
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;
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
;
1304 if (rhs_ss
!= gfc_ss_terminator
1306 && rhs_ss
->info
->expr
1307 && rhs_ss
->info
->expr
->ts
.type
== BT_CLASS
1308 && rhs_ss
->info
->data
.array
.descriptor
)
1310 if (rhs_ss
->info
->expr
->expr_type
!= EXPR_VARIABLE
)
1312 = gfc_get_class_from_expr (rhs_ss
->info
->data
.array
.descriptor
);
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;
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
1323 lhs_ss
= rhs_ss
->loop_chain
;
1324 if (lhs_ss
!= gfc_ss_terminator
1326 && lhs_ss
->info
->expr
1327 && lhs_ss
->info
->expr
->expr_type
==EXPR_VARIABLE
1328 && lhs_ss
->info
->expr
->ts
.type
== BT_CLASS
)
1330 tmp
= lhs_ss
->info
->data
.array
.descriptor
;
1331 unlimited_lhs
= UNLIMITED_POLY (rhs_ss
->info
->expr
);
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
);
1340 return rhs_class_expr
;
1342 gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (lhs_class_expr
)));
1344 /* Set the lhs vptr and, if necessary, the _len field. */
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
)));
1354 tmp
= gfc_class_len_get (lhs_class_expr
);
1356 tmp2
= gfc_class_len_get (rhs_class_expr
);
1358 tmp2
= build_int_cst (TREE_TYPE (tmp
), 0);
1359 gfc_add_modify (pre
, tmp
, tmp2
);
1364 tmp
= gfc_class_data_get (rhs_class_expr
);
1365 gfc_conv_descriptor_offset_set (pre
, tmp
, gfc_index_zero_node
);
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
));
1384 tmp
= gfc_class_len_get (lhs_class_expr
);
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
);
1391 tmp2
= build_int_cst (TREE_TYPE (tmp
), 0);
1392 gfc_add_modify (pre
, tmp
, tmp2
);
1396 return rhs_class_expr
;
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.
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
1416 PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
1417 gfc_trans_allocate_array_storage. */
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
)
1426 gfc_array_info
*info
;
1427 tree from
[GFC_MAX_DIMENSIONS
], to
[GFC_MAX_DIMENSIONS
];
1436 tree class_expr
= NULL_TREE
;
1437 int n
, dim
, tmp_dim
;
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
)
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
);
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
);
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
)));
1462 if (class_expr
== NULL_TREE
)
1463 elemsize
= fold_convert (gfc_array_index_type
,
1464 TYPE_SIZE_UNIT (eltype
));
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
,
1473 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
1474 elemsize
= fold_build3_loc (input_location
, COND_EXPR
,
1475 gfc_array_index_type
,
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
);
1486 memset (from
, 0, sizeof (from
));
1487 memset (to
, 0, sizeof (to
));
1489 info
= &ss
->info
->data
.array
;
1491 gcc_assert (ss
->dimen
> 0);
1492 gcc_assert (ss
->loop
->dimen
== ss
->dimen
);
1494 if (warn_array_temporaries
&& where
)
1495 gfc_warning (OPT_Warray_temporaries
,
1496 "Creating array temporary at %L", where
);
1498 /* Set the lower bound to zero. */
1499 for (s
= ss
; s
; s
= s
->parent
)
1503 total_dim
+= loop
->dimen
;
1504 for (n
= 0; n
< loop
->dimen
; n
++)
1508 /* Callee allocated arrays may not have a known bound yet. */
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
]),
1515 loop
->from
[n
] = gfc_index_zero_node
;
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
;
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
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
];
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
;
1539 /* Initialize the descriptor. */
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;
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
)));
1556 if (class_expr
!= NULL_TREE
)
1561 /* Create a class temporary. */
1562 tmp
= gfc_create_var (TREE_TYPE (class_expr
), "ctmp");
1563 gfc_add_modify (pre
, tmp
, class_expr
);
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
);
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
);
1578 /* Point desc to the class _data field. */
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
)));
1588 info
->descriptor
= desc
;
1589 size
= gfc_index_one_node
;
1592 Fill in the bounds and stride. This is a packed array, so:
1595 for (n = 0; n < rank; n++)
1598 delta = ubound[n] + 1 - lbound[n];
1599 size = size * delta;
1601 size = size * sizeof(element);
1604 or_expr
= NULL_TREE
;
1606 /* If there is at least one null loop->to[n], it is a callee allocated
1608 for (n
= 0; n
< total_dim
; n
++)
1609 if (to
[n
] == NULL_TREE
)
1615 if (size
== NULL_TREE
)
1616 for (s
= ss
; s
; s
= s
->parent
)
1617 for (n
= 0; n
< s
->loop
->dimen
; n
++)
1619 dim
= get_scalarizer_dim_for_array_dim (ss
, s
->dim
[n
]);
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
;
1631 for (n
= 0; n
< total_dim
; n
++)
1633 /* Store the stride and bound components in the descriptor. */
1634 gfc_conv_descriptor_stride_set (pre
, desc
, gfc_rank_cst
[n
], size
);
1636 gfc_conv_descriptor_lbound_set (pre
, desc
, gfc_rank_cst
[n
],
1637 gfc_index_zero_node
);
1639 gfc_conv_descriptor_ubound_set (pre
, desc
, gfc_rank_cst
[n
], to
[n
]);
1641 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1642 gfc_array_index_type
,
1643 to
[n
], gfc_index_one_node
);
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
);
1653 or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1654 logical_type_node
, or_expr
, cond
);
1656 size
= fold_build2_loc (input_location
, MULT_EXPR
,
1657 gfc_array_index_type
, size
, tmp
);
1658 size
= gfc_evaluate_now (size
, pre
);
1662 /* Get the size of the array. */
1663 if (size
&& !callee_alloc
)
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
);
1671 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
1681 tmp
= fold_convert (gfc_array_index_type
, elemsize
);
1682 gfc_conv_descriptor_span_set (pre
, desc
, tmp
);
1684 gfc_trans_allocate_array_storage (pre
, post
, info
, size
, nelem
, initial
,
1690 if (ss
->dimen
> ss
->loop
->temp_dim
)
1691 ss
->loop
->temp_dim
= ss
->dimen
;
1697 /* Return the number of iterations in a loop that starts at START,
1698 ends at END, and has step STEP. */
1701 gfc_get_iteration_count (tree start
, tree end
, tree step
)
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
);
1717 /* Extend the data in array DESC by EXTRA elements. */
1720 gfc_grow_array (stmtblock_t
* pblock
, tree desc
, tree extra
)
1727 if (integer_zerop (extra
))
1730 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[0]);
1732 /* Add EXTRA to the upper bound. */
1733 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1735 gfc_conv_descriptor_ubound_set (pblock
, desc
, gfc_rank_cst
[0], tmp
);
1737 /* Get the value of the current data pointer. */
1738 arg0
= gfc_conv_descriptor_data_get (desc
);
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
));
1748 /* Call the realloc() function. */
1749 tmp
= gfc_call_realloc (pblock
, arg0
, arg1
);
1750 gfc_conv_descriptor_data_set (pblock
, desc
, tmp
);
1754 /* Return true if the bounds of iterator I can only be determined
1758 gfc_iterator_has_dynamic_bounds (gfc_iterator
* i
)
1760 return (i
->start
->expr_type
!= EXPR_CONSTANT
1761 || i
->end
->expr_type
!= EXPR_CONSTANT
1762 || i
->step
->expr_type
!= EXPR_CONSTANT
);
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. */
1772 gfc_get_array_constructor_element_size (mpz_t
* size
, gfc_expr
* expr
)
1774 if (expr
->expr_type
== EXPR_ARRAY
)
1775 return gfc_get_array_constructor_size (size
, expr
->value
.constructor
);
1776 else if (expr
->rank
> 0)
1778 /* Calculate everything at run time. */
1779 mpz_set_ui (*size
, 0);
1784 /* A single element. */
1785 mpz_set_ui (*size
, 1);
1791 /* Like gfc_get_array_constructor_element_size, but applied to the whole
1792 of array constructor C. */
1795 gfc_get_array_constructor_size (mpz_t
* size
, gfc_constructor_base base
)
1803 mpz_set_ui (*size
, 0);
1808 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1811 if (i
&& gfc_iterator_has_dynamic_bounds (i
))
1815 dynamic
|= gfc_get_array_constructor_element_size (&len
, c
->expr
);
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
);
1826 mpz_set_ui (len
, 0);
1828 mpz_add (*size
, *size
, len
);
1837 /* Make sure offset is a variable. */
1840 gfc_put_offset_into_var (stmtblock_t
* pblock
, tree
* poffset
,
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;
1852 /* Variables needed for bounds-checking. */
1853 static bool first_len
;
1854 static tree first_len_val
;
1855 static bool typespec_chararray_ctor
;
1858 gfc_trans_array_ctor_element (stmtblock_t
* pblock
, tree desc
,
1859 tree offset
, gfc_se
* se
, gfc_expr
* expr
)
1863 gfc_conv_expr (se
, expr
);
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
);
1870 if (expr
->ts
.type
== BT_CHARACTER
)
1872 int i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
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));
1882 gfc_conv_string_parameter (se
);
1883 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
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
);
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
);
1898 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && !typespec_chararray_ctor
)
1902 gfc_add_modify (&se
->pre
, first_len_val
,
1903 fold_convert (TREE_TYPE (first_len_val
),
1904 se
->string_length
));
1909 /* Verify that all constructor elements are of the same
1911 tree rhs
= fold_convert (TREE_TYPE (first_len_val
),
1913 tree cond
= fold_build2_loc (input_location
, NE_EXPR
,
1914 logical_type_node
, first_len_val
,
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
));
1924 else if (GFC_CLASS_TYPE_P (TREE_TYPE (se
->expr
))
1925 && !GFC_CLASS_TYPE_P (gfc_get_element_type (TREE_TYPE (desc
))))
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
);
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
);
1942 gfc_add_block_to_block (pblock
, &se
->pre
);
1943 gfc_add_block_to_block (pblock
, &se
->post
);
1947 /* Add the contents of an array to the constructor. DYNAMIC is as for
1948 gfc_trans_array_constructor_value. */
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
,
1965 /* We need this to be a variable so we can increment it. */
1966 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1968 gfc_init_se (&se
, NULL
);
1970 /* Walk the array expression. */
1971 ss
= gfc_walk_expr (expr
);
1972 gcc_assert (ss
!= gfc_ss_terminator
);
1974 /* Initialize the scalarizer. */
1975 gfc_init_loopinfo (&loop
);
1976 gfc_add_ss_to_loop (&loop
, ss
);
1978 /* Initialize the loop. */
1979 gfc_conv_ss_startstride (&loop
);
1980 gfc_conv_loop_setup (&loop
, &expr
->where
);
1982 /* Make sure the constructed array has room for the new data. */
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
++)
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
);
1995 /* Grow the constructed array by SIZE elements. */
1996 gfc_grow_array (&loop
.pre
, desc
, size
);
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
);
2005 gfc_trans_array_ctor_element (&body
, desc
, *poffset
, &se
, expr
);
2006 gcc_assert (se
.ss
== gfc_ss_terminator
);
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
);
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
);
2019 gfc_cleanup_loop (&loop
);
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. */
2029 gfc_trans_array_constructor_value (stmtblock_t
* pblock
, tree type
,
2030 tree desc
, gfc_constructor_base base
,
2031 tree
* poffset
, tree
* offsetvar
,
2035 tree start
= NULL_TREE
;
2036 tree end
= NULL_TREE
;
2037 tree step
= NULL_TREE
;
2043 tree shadow_loopvar
= NULL_TREE
;
2044 gfc_saved_var saved_loopvar
;
2047 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
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
);
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. */
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.
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
);
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
);
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
);
2082 sym
= c
->iterator
->var
->symtree
->n
.sym
;
2083 type
= gfc_typenode_for_spec (&sym
->ts
);
2085 shadow_loopvar
= gfc_create_var (type
, "shadow_loopvar");
2086 gfc_shadow_sym (sym
, shadow_loopvar
, &saved_loopvar
);
2089 gfc_start_block (&body
);
2091 if (c
->expr
->expr_type
== EXPR_ARRAY
)
2093 /* Array constructors can be nested. */
2094 gfc_trans_array_constructor_value (&body
, type
, desc
,
2095 c
->expr
->value
.constructor
,
2096 poffset
, offsetvar
, dynamic
);
2098 else if (c
->expr
->rank
> 0)
2100 gfc_trans_array_constructor_subarray (&body
, type
, desc
, c
->expr
,
2101 poffset
, offsetvar
, dynamic
);
2105 /* This code really upsets the gimplifier so don't bother for now. */
2112 while (p
&& !(p
->iterator
|| p
->expr
->expr_type
!= EXPR_CONSTANT
))
2114 p
= gfc_constructor_next (p
);
2119 /* Scalar values. */
2120 gfc_init_se (&se
, NULL
);
2121 gfc_trans_array_ctor_element (&body
, desc
, *poffset
,
2124 *poffset
= fold_build2_loc (input_location
, PLUS_EXPR
,
2125 gfc_array_index_type
,
2126 *poffset
, gfc_index_one_node
);
2130 /* Collect multiple scalar constants into a constructor. */
2131 vec
<constructor_elt
, va_gc
> *v
= NULL
;
2135 HOST_WIDE_INT idx
= 0;
2138 /* Count the number of consecutive scalar constants. */
2139 while (p
&& !(p
->iterator
2140 || p
->expr
->expr_type
!= EXPR_CONSTANT
))
2142 gfc_init_se (&se
, NULL
);
2143 gfc_conv_constant (&se
, p
->expr
);
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
),
2154 CONSTRUCTOR_APPEND_ELT (v
,
2155 build_int_cst (gfc_array_index_type
,
2159 p
= gfc_constructor_next (p
);
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
);
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
;
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
,
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
);
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
);
2194 *poffset
= fold_build2_loc (input_location
, PLUS_EXPR
,
2195 gfc_array_index_type
, *poffset
,
2196 build_int_cst (gfc_array_index_type
, n
));
2198 if (!INTEGER_CST_P (*poffset
))
2200 gfc_add_modify (&body
, *offsetvar
, *poffset
);
2201 *poffset
= *offsetvar
;
2205 /* The frontend should already have done any expansions
2209 /* Pass the code as is. */
2210 tmp
= gfc_finish_block (&body
);
2211 gfc_add_expr_to_block (pblock
, tmp
);
2215 /* Build the implied do-loop. */
2216 stmtblock_t implied_do_block
;
2222 loopbody
= gfc_finish_block (&body
);
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
);
2228 /* Initialize the loop. */
2229 gfc_add_modify (&implied_do_block
, shadow_loopvar
, start
);
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
))
2236 /* Get the number of iterations. */
2237 tmp
= gfc_get_iteration_count (shadow_loopvar
, end
, step
);
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
);
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
);
2249 /* Generate the loop body. */
2250 exit_label
= gfc_build_label_decl (NULL_TREE
);
2251 gfc_start_block (&body
);
2253 /* Generate the exit condition. Depending on the sign of
2254 the step variable we have to generate the correct
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
);
2270 /* The main loop body. */
2271 gfc_add_expr_to_block (&body
, loopbody
);
2273 /* Increase loop variable by step. */
2274 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2275 TREE_TYPE (shadow_loopvar
), shadow_loopvar
,
2277 gfc_add_modify (&body
, shadow_loopvar
, tmp
);
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
);
2284 /* Add the exit label. */
2285 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2286 gfc_add_expr_to_block (&implied_do_block
, tmp
);
2288 /* Finish the implied-do loop. */
2289 tmp
= gfc_finish_block(&implied_do_block
);
2290 gfc_add_expr_to_block(pblock
, tmp
);
2292 gfc_restore_sym (c
->iterator
->var
->symtree
->n
.sym
, &saved_loopvar
);
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.
2308 If this might be the case, we create a new gfc_charlen structure and
2309 link it into the current namespace. */
2312 store_backend_decl (gfc_charlen
**clp
, tree len
, bool force_new_cl
)
2316 gfc_charlen
*new_cl
= gfc_new_charlen (gfc_current_ns
, *clp
);
2319 (*clp
)->backend_decl
= len
;
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. */
2326 get_array_ctor_all_strlen (stmtblock_t
*block
, gfc_expr
*e
, tree
*len
)
2330 /* Don't bother if we already know the length is a constant. */
2331 if (*len
&& INTEGER_CST_P (*len
))
2334 if (!e
->ref
&& e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
2335 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2338 gfc_conv_const_charlen (e
->ts
.u
.cl
);
2339 *len
= e
->ts
.u
.cl
->backend_decl
;
2343 /* Otherwise, be brutal even if inefficient. */
2344 gfc_init_se (&se
, NULL
);
2346 /* No function call, in case of side effects. */
2347 se
.no_function_call
= 1;
2349 gfc_conv_expr (&se
, e
);
2351 gfc_conv_expr_descriptor (&se
, e
);
2353 /* Fix the value. */
2354 *len
= gfc_evaluate_now (se
.string_length
, &se
.pre
);
2356 gfc_add_block_to_block (block
, &se
.pre
);
2357 gfc_add_block_to_block (block
, &se
.post
);
2359 store_backend_decl (&e
->ts
.u
.cl
, *len
, true);
2364 /* Figure out the string length of a variable reference expression.
2365 Used by get_array_ctor_strlen. */
2368 get_array_ctor_var_strlen (stmtblock_t
*block
, gfc_expr
* expr
, tree
* len
)
2375 /* Don't bother if we already know the length is a constant. */
2376 if (*len
&& INTEGER_CST_P (*len
))
2379 ts
= &expr
->symtree
->n
.sym
->ts
;
2380 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2385 /* Array references don't change the string length. */
2387 get_array_ctor_all_strlen (block
, expr
, len
);
2391 /* Use the length of the component. */
2392 ts
= &ref
->u
.c
.component
->ts
;
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
)
2400 /* Note that this might evaluate expr. */
2401 get_array_ctor_all_strlen (block
, expr
, len
);
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
);
2419 /* A last ditch attempt that is sometimes needed for deferred characters. */
2420 if (!ts
->u
.cl
->backend_decl
)
2422 gfc_init_se (&se
, NULL
);
2424 gfc_conv_expr_descriptor (&se
, expr
);
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
;
2432 *len
= ts
->u
.cl
->backend_decl
;
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. */
2443 get_array_ctor_strlen (stmtblock_t
*block
, gfc_constructor_base base
, tree
* len
)
2450 if (gfc_constructor_first (base
) == NULL
)
2453 *len
= build_int_cstu (gfc_charlen_type_node
, 0);
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
))
2463 switch (c
->expr
->expr_type
)
2466 if (len
&& !(*len
&& INTEGER_CST_P (*len
)))
2467 *len
= build_int_cstu (gfc_charlen_type_node
,
2468 c
->expr
->value
.character
.length
);
2472 if (!get_array_ctor_strlen (block
, c
->expr
->value
.constructor
, len
))
2479 get_array_ctor_var_strlen (block
, c
->expr
, len
);
2485 get_array_ctor_all_strlen (block
, c
->expr
, len
);
2489 /* After the first iteration, we don't want the length modified. */
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. */
2500 unsigned HOST_WIDE_INT
2501 gfc_constant_array_constructor_p (gfc_constructor_base base
)
2503 unsigned HOST_WIDE_INT nelem
= 0;
2505 gfc_constructor
*c
= gfc_constructor_first (base
);
2509 || c
->expr
->rank
> 0
2510 || c
->expr
->expr_type
!= EXPR_CONSTANT
)
2512 c
= gfc_constructor_next (c
);
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. */
2524 gfc_build_constant_array_constructor (gfc_expr
* expr
, tree type
)
2526 tree tmptype
, init
, tmp
;
2527 HOST_WIDE_INT nelem
;
2532 vec
<constructor_elt
, va_gc
> *v
= NULL
;
2534 /* First traverse the constructor list, converting the constants
2535 to tree to build an initializer. */
2537 c
= gfc_constructor_first (expr
->value
.constructor
);
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
),
2547 CONSTRUCTOR_APPEND_ELT (v
, build_int_cst (gfc_array_index_type
, nelem
),
2549 c
= gfc_constructor_next (c
);
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. */
2557 memset (&as
, 0, sizeof (gfc_array_spec
));
2559 as
.rank
= expr
->rank
;
2560 as
.type
= AS_EXPLICIT
;
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
,
2568 for (i
= 0; i
< expr
->rank
; i
++)
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
,
2576 tmptype
= gfc_get_nodesc_array_type (type
, &as
, PACKED_STATIC
, true);
2578 /* as is not needed anymore. */
2579 for (i
= 0; i
< as
.rank
+ as
.corank
; i
++)
2581 gfc_free_expr (as
.lower
[i
]);
2582 gfc_free_expr (as
.upper
[i
]);
2585 init
= build_constructor (tmptype
, v
);
2587 TREE_CONSTANT (init
) = 1;
2588 TREE_STATIC (init
) = 1;
2590 tmp
= build_decl (input_location
, VAR_DECL
, create_tmp_var_name ("A"),
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
;
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. */
2610 trans_constant_array_constructor (gfc_ss
* ss
, tree type
)
2612 gfc_array_info
*info
;
2616 tmp
= gfc_build_constant_array_constructor (ss
->info
->expr
, type
);
2618 info
= &ss
->info
->data
.array
;
2620 info
->descriptor
= tmp
;
2621 info
->data
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2622 info
->offset
= gfc_index_zero_node
;
2624 for (i
= 0; i
< ss
->dimen
; i
++)
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
;
2635 get_rank (gfc_loopinfo
*loop
)
2640 for (; loop
; loop
= loop
->parent
)
2641 rank
+= loop
->dimen
;
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. */
2653 constant_array_constructor_loop_size (gfc_loopinfo
* l
)
2656 tree size
= gfc_index_one_node
;
2660 total_dim
= get_rank (l
);
2662 for (loop
= l
; loop
; loop
= loop
->parent
)
2664 for (i
= 0; i
< loop
->dimen
; i
++)
2666 /* If the bounds aren't constant, return NULL_TREE. */
2667 if (!INTEGER_CST_P (loop
->from
[i
]) || !INTEGER_CST_P (loop
->to
[i
]))
2669 if (!integer_zerop (loop
->from
[i
]))
2671 /* Only allow nonzero "from" in one-dimensional arrays. */
2674 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2675 gfc_array_index_type
,
2676 loop
->to
[i
], loop
->from
[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
);
2692 get_loop_upper_bound_for_array (gfc_ss
*array
, int array_dim
)
2697 gcc_assert (array
->nested_ss
== NULL
);
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
]);
2708 static gfc_loopinfo
*
2709 outermost_loop (gfc_loopinfo
* loop
)
2711 while (loop
->parent
!= NULL
)
2712 loop
= loop
->parent
;
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
2723 trans_array_constructor (gfc_ss
* ss
, locus
* where
)
2725 gfc_constructor_base c
;
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
;
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
;
2748 outer_loop
= outermost_loop (loop
);
2750 expr
= ss_info
->expr
;
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
2756 && expr
->ts
.u
.cl
->length_from_typespec
);
2758 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2759 && expr
->ts
.type
== BT_CHARACTER
&& !typespec_chararray_ctor
)
2761 first_len_val
= gfc_create_var (gfc_charlen_type_node
, "len");
2765 gcc_assert (ss
->dimen
== ss
->loop
->dimen
);
2767 c
= expr
->value
.constructor
;
2768 if (expr
->ts
.type
== BT_CHARACTER
)
2771 bool force_new_cl
= false;
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
2776 if (typespec_chararray_ctor
&& expr
->ts
.u
.cl
->length
2777 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
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
;
2787 /* Check if the character length is negative. If it is, then
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
)
2796 msg
= xasprintf ("Negative character length treated as LEN = 0");
2797 gfc_trans_runtime_check (false, true, neg_len
, &length_se
.pre
,
2802 ss_info
->string_length
2803 = fold_build3_loc (input_location
, COND_EXPR
,
2804 gfc_charlen_type_node
, neg_len
,
2806 (TREE_TYPE (ss_info
->string_length
)),
2807 ss_info
->string_length
);
2808 ss_info
->string_length
= gfc_evaluate_now (ss_info
->string_length
,
2810 gfc_add_block_to_block (&outer_loop
->pre
, &length_se
.pre
);
2811 gfc_add_block_to_block (&outer_loop
->post
, &length_se
.post
);
2815 const_string
= get_array_ctor_strlen (&outer_loop
->pre
, c
,
2816 &ss_info
->string_length
);
2817 force_new_cl
= true;
2820 /* Complex character array constructors should have been taken care of
2821 and not end up here. */
2822 gcc_assert (ss_info
->string_length
);
2824 store_backend_decl (&expr
->ts
.u
.cl
, ss_info
->string_length
, force_new_cl
);
2826 type
= gfc_get_character_type_len (expr
->ts
.kind
, ss_info
->string_length
);
2828 type
= build_pointer_type (type
);
2831 type
= gfc_typenode_for_spec (expr
->ts
.type
== BT_CLASS
2832 ? &CLASS_DATA (expr
)->ts
: &expr
->ts
);
2834 /* See if the constructor determines the loop bounds. */
2837 loop_ubound0
= get_loop_upper_bound_for_array (ss
, 0);
2839 if (expr
->shape
&& get_rank (loop
) > 1 && *loop_ubound0
== NULL_TREE
)
2841 /* We have a multidimensional parameter. */
2842 for (s
= ss
; s
; s
= s
->parent
)
2845 for (n
= 0; n
< s
->loop
->dimen
; n
++)
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
,
2853 gfc_index_one_node
);
2858 if (*loop_ubound0
== NULL_TREE
)
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]));
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. */
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
);
2877 /* Special case constant array constructors. */
2880 unsigned HOST_WIDE_INT nelem
= gfc_constant_array_constructor_p (c
);
2883 tree size
= constant_array_constructor_loop_size (loop
);
2884 if (size
&& compare_tree_int (size
, nelem
) == 0)
2886 trans_constant_array_constructor (ss
, type
);
2892 gfc_trans_create_temp_array (&outer_loop
->pre
, &outer_loop
->post
, ss
, type
,
2893 NULL_TREE
, dynamic
, true, false, where
);
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
);
2903 /* If the array grows dynamically, the upper bound of the loop variable
2904 is determined by the array's final upper bound. */
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
);
2915 *loop_ubound0
= tmp
;
2918 if (TREE_USED (offsetvar
))
2919 pushdecl (offsetvar
);
2921 gcc_assert (INTEGER_CST_P (offset
));
2924 /* Disable bound checking for now because it's probably broken. */
2925 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
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
;
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
2945 set_vector_loop_bounds (gfc_ss
* ss
)
2947 gfc_loopinfo
*loop
, *outer_loop
;
2948 gfc_array_info
*info
;
2956 outer_loop
= outermost_loop (ss
->loop
);
2958 info
= &ss
->info
->data
.array
;
2960 for (; ss
; ss
= ss
->parent
)
2964 for (n
= 0; n
< loop
->dimen
; n
++)
2967 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_VECTOR
2968 || loop
->to
[n
] != NULL
)
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
);
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
);
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. */
2996 gfc_scalar_elemental_arg_saved_as_reference (gfc_ss_info
* ss_info
)
2998 if (ss_info
->type
!= GFC_SS_REFERENCE
)
3001 if (ss_info
->data
.scalar
.needs_temporary
)
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
)
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
3015 && ss_info
->expr
->ts
.type
== BT_CLASS
)
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
))
3027 /* Otherwise the expression is evaluated to a temporary variable before the
3028 scalarization loop. */
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. */
3038 gfc_add_loop_ss_code (gfc_loopinfo
* loop
, gfc_ss
* ss
, bool subscript
,
3041 gfc_loopinfo
*nested_loop
, *outer_loop
;
3043 gfc_ss_info
*ss_info
;
3044 gfc_array_info
*info
;
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
)
3053 outer_loop
= outermost_loop (loop
);
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
);
3059 for (; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3063 /* Cross loop arrays are handled from within the most nested loop. */
3064 if (ss
->nested_ss
!= NULL
)
3068 expr
= ss_info
->expr
;
3069 info
= &ss_info
->data
.array
;
3071 switch (ss_info
->type
)
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
);
3080 if (expr
->ts
.type
!= BT_CHARACTER
3081 && !gfc_is_alloc_class_scalar_function (expr
))
3083 /* Move the evaluation of scalar expressions outside the
3084 scalarization loop, except for WHERE assignments. */
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
);
3092 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
3094 ss_info
->data
.scalar
.value
= se
.expr
;
3095 ss_info
->string_length
= se
.string_length
;
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
);
3105 /* Evaluate the argument outside the loop and pass
3106 a reference to the value. */
3107 gfc_conv_expr (&se
, expr
);
3110 /* Ensure that a pointer to the string is stored. */
3111 if (expr
->ts
.type
== BT_CHARACTER
)
3112 gfc_conv_string_parameter (&se
);
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
;
3125 ss_info
->data
.scalar
.value
= gfc_evaluate_now (se
.expr
,
3128 ss_info
->string_length
= se
.string_length
;
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
);
3137 set_vector_loop_bounds (ss
);
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
;
3149 case GFC_SS_INTRINSIC
:
3150 gfc_add_intrinsic_ss_code (loop
, ss
);
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
);
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
;
3167 case GFC_SS_CONSTRUCTOR
:
3168 if (expr
->ts
.type
== BT_CHARACTER
3169 && ss_info
->string_length
== NULL
3171 && expr
->ts
.u
.cl
->length
3172 && expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
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
);
3181 trans_array_constructor (ss
, where
);
3185 case GFC_SS_COMPONENT
:
3186 /* Do nothing. These are handled elsewhere. */
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
);
3201 /* Translate expressions for the descriptor and data pointer of a SS. */
3205 gfc_conv_ss_descriptor (stmtblock_t
* block
, gfc_ss
* ss
, int base
)
3208 gfc_ss_info
*ss_info
;
3209 gfc_array_info
*info
;
3213 info
= &ss_info
->data
.array
;
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
;
3226 if (ss_info
->expr
->ts
.type
== BT_CHARACTER
&& !ss_info
->expr
->ts
.deferred
3227 && ss_info
->expr
->ts
.u
.cl
->length
== NULL
)
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
)));
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
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
);
3255 tmp
= gfc_conv_array_offset (se
.expr
);
3256 info
->offset
= gfc_evaluate_now (tmp
, block
);
3258 /* Make absolutely sure that the saved_offset is indeed saved
3259 so that the variable is still accessible after the loops
3261 info
->saved_offset
= info
->offset
;
3266 /* Initialize a gfc_loopinfo structure. */
3269 gfc_init_loopinfo (gfc_loopinfo
* loop
)
3273 memset (loop
, 0, sizeof (gfc_loopinfo
));
3274 gfc_init_block (&loop
->pre
);
3275 gfc_init_block (&loop
->post
);
3277 /* Initially scalarize in order and default to no loop reversal. */
3278 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
3281 loop
->reverse
[n
] = GFC_INHIBIT_REVERSE
;
3284 loop
->ss
= gfc_ss_terminator
;
3288 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
3292 gfc_copy_loopinfo_to_se (gfc_se
* se
, gfc_loopinfo
* loop
)
3298 /* Return an expression for the data pointer of an array. */
3301 gfc_conv_array_data (tree descriptor
)
3305 type
= TREE_TYPE (descriptor
);
3306 if (GFC_ARRAY_TYPE_P (type
))
3308 if (TREE_CODE (type
) == POINTER_TYPE
)
3312 /* Descriptorless arrays. */
3313 return gfc_build_addr_expr (NULL_TREE
, descriptor
);
3317 return gfc_conv_descriptor_data_get (descriptor
);
3321 /* Return an expression for the base offset of an array. */
3324 gfc_conv_array_offset (tree descriptor
)
3328 type
= TREE_TYPE (descriptor
);
3329 if (GFC_ARRAY_TYPE_P (type
))
3330 return GFC_TYPE_ARRAY_OFFSET (type
);
3332 return gfc_conv_descriptor_offset_get (descriptor
);
3336 /* Get an expression for the array stride. */
3339 gfc_conv_array_stride (tree descriptor
, int dim
)
3344 type
= TREE_TYPE (descriptor
);
3346 /* For descriptorless arrays use the array size. */
3347 tmp
= GFC_TYPE_ARRAY_STRIDE (type
, dim
);
3348 if (tmp
!= NULL_TREE
)
3351 tmp
= gfc_conv_descriptor_stride_get (descriptor
, gfc_rank_cst
[dim
]);
3356 /* Like gfc_conv_array_stride, but for the lower bound. */
3359 gfc_conv_array_lbound (tree descriptor
, int dim
)
3364 type
= TREE_TYPE (descriptor
);
3366 tmp
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
3367 if (tmp
!= NULL_TREE
)
3370 tmp
= gfc_conv_descriptor_lbound_get (descriptor
, gfc_rank_cst
[dim
]);
3375 /* Like gfc_conv_array_stride, but for the upper bound. */
3378 gfc_conv_array_ubound (tree descriptor
, int dim
)
3383 type
= TREE_TYPE (descriptor
);
3385 tmp
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
3386 if (tmp
!= NULL_TREE
)
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
;
3394 tmp
= gfc_conv_descriptor_ubound_get (descriptor
, gfc_rank_cst
[dim
]);
3399 /* Generate code to perform an array index bound check. */
3402 trans_array_bound_check (gfc_se
* se
, gfc_ss
*ss
, tree index
, int n
,
3403 locus
* where
, bool check_upper
)
3406 tree tmp_lo
, tmp_up
;
3409 const char * name
= NULL
;
3411 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
3414 descriptor
= ss
->info
->data
.array
.descriptor
;
3416 index
= gfc_evaluate_now (index
, &se
->pre
);
3418 /* We find a name for the error message. */
3419 name
= ss
->info
->expr
->symtree
->n
.sym
->name
;
3420 gcc_assert (name
!= NULL
);
3422 if (VAR_P (descriptor
))
3423 name
= IDENTIFIER_POINTER (DECL_NAME (descriptor
));
3425 /* If upper bound is present, include both bounds in the error message. */
3428 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
3429 tmp_up
= gfc_conv_array_ubound (descriptor
, n
);
3432 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3433 "outside of expected range (%%ld:%%ld)", n
+1, name
);
3435 msg
= xasprintf ("Index '%%ld' of dimension %d "
3436 "outside of expected range (%%ld:%%ld)", n
+1);
3438 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
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
,
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
));
3454 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
3457 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3458 "below lower bound of %%ld", n
+1, name
);
3460 msg
= xasprintf ("Index '%%ld' of dimension %d "
3461 "below lower bound of %%ld", n
+1);
3463 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
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
));
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. */
3480 conv_array_index_offset (gfc_se
* se
, gfc_ss
* ss
, int dim
, int i
,
3481 gfc_array_ref
* ar
, tree stride
)
3483 gfc_array_info
*info
;
3488 info
= &ss
->info
->data
.array
;
3490 /* Get the index into the array for this dimension. */
3493 gcc_assert (ar
->type
!= AR_ELEMENT
);
3494 switch (ar
->dimen_type
[dim
])
3496 case DIMEN_THIS_IMAGE
:
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
;
3506 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
3507 ar
->as
->type
!= AS_ASSUMED_SIZE
3508 || dim
< ar
->dimen
- 1);
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
;
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
]);
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));
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
);
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);
3541 /* Scalarized dimension. */
3542 gcc_assert (info
&& se
->loop
);
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
,
3550 if (!integer_zerop (info
->delta
[dim
]))
3551 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
3552 gfc_array_index_type
, index
,
3562 /* Temporary array or derived type component. */
3563 gcc_assert (se
->loop
);
3564 index
= se
->loop
->loopvar
[se
->loop
->order
[i
]];
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
,
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
]);
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
,
3591 /* Build a scalarized array reference using the vptr 'size'. */
3594 build_class_array_ref (gfc_se
*se
, tree base
, tree index
)
3597 tree decl
= NULL_TREE
;
3599 gfc_expr
*expr
= se
->ss
->info
->expr
;
3600 gfc_expr
*class_expr
;
3604 tmp
= !VAR_P (base
) ? gfc_get_class_from_expr (base
) : NULL_TREE
;
3606 if (tmp
!= NULL_TREE
)
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. */
3614 || (expr
->ts
.type
!= BT_CLASS
3615 && !gfc_is_class_array_ref (expr
, NULL
)))
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
);
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);
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
);
3644 decl
= gfc_get_class_from_gfc_expr (class_expr
);
3646 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
3647 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
3649 if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl
)))
3653 se
->class_vptr
= gfc_evaluate_now (gfc_class_vptr_get (decl
), &se
->pre
);
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
);
3661 /* Return the element in the se expression. */
3662 se
->expr
= gfc_build_spanned_array_ref (base
, index
, size
);
3667 /* Build a scalarized reference to an array. */
3670 gfc_conv_scalarized_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
3672 gfc_array_info
*info
;
3673 tree decl
= NULL_TREE
;
3681 expr
= ss
->info
->expr
;
3682 info
= &ss
->info
->data
.array
;
3684 n
= se
->loop
->order
[0];
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
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
);
3695 base
= build_fold_indirect_ref_loc (input_location
, info
->data
);
3697 /* Use the vptr 'size' field to access the element of a class array. */
3698 if (build_class_array_ref (se
, base
, index
))
3701 if (get_CFI_desc (NULL
, expr
, &decl
, ar
))
3702 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
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
))))
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);
3716 if (decl
== NULL_TREE
)
3717 decl
= info
->descriptor
;
3720 se
->expr
= gfc_build_array_ref (base
, index
, decl
);
3724 /* Translate access of temporary array. */
3727 gfc_conv_tmp_array_ref (gfc_se
* se
)
3729 se
->string_length
= se
->ss
->info
->string_length
;
3730 gfc_conv_scalarized_array_ref (se
, NULL
);
3731 gfc_advance_se_ss_chain (se
);
3734 /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
3737 add_to_offset (tree
*cst_offset
, tree
*offset
, tree t
)
3739 if (TREE_CODE (t
) == INTEGER_CST
)
3740 *cst_offset
= int_const_binop (PLUS_EXPR
, *cst_offset
, t
);
3743 if (!integer_zerop (*offset
))
3744 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3745 gfc_array_index_type
, *offset
, t
);
3753 build_array_ref (tree desc
, tree offset
, tree decl
, tree vptr
)
3759 /* For class arrays the class declaration is stored in the saved
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)));
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
)
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));
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
);
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
3791 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
3794 gfc_conv_array_ref (gfc_se
* se
, gfc_array_ref
* ar
, gfc_expr
*expr
,
3798 tree offset
, cst_offset
;
3801 tree decl
= NULL_TREE
;
3804 gfc_symbol
* sym
= expr
->symtree
->n
.sym
;
3805 char *var_name
= NULL
;
3809 gcc_assert (ar
->codimen
|| sym
->attr
.select_rank_temporary
3810 || (ar
->as
&& ar
->as
->corank
));
3812 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
->expr
)))
3813 se
->expr
= build_fold_indirect_ref (gfc_conv_array_data (se
->expr
));
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
);
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
)),
3829 /* Handle scalarized references separately. */
3830 if (ar
->type
!= AR_ELEMENT
)
3832 gfc_conv_scalarized_array_ref (se
, ar
);
3833 gfc_advance_se_ss_chain (se
);
3837 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3842 len
= strlen (sym
->name
) + 1;
3843 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3845 if (ref
->type
== REF_ARRAY
&& &ref
->u
.ar
== ar
)
3847 if (ref
->type
== REF_COMPONENT
)
3848 len
+= 2 + strlen (ref
->u
.c
.component
->name
);
3851 var_name
= XALLOCAVEC (char, len
);
3852 strcpy (var_name
, sym
->name
);
3854 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3856 if (ref
->type
== REF_ARRAY
&& &ref
->u
.ar
== ar
)
3858 if (ref
->type
== REF_COMPONENT
)
3860 strcat (var_name
, "%%");
3861 strcat (var_name
, ref
->u
.c
.component
->name
);
3867 if (IS_CLASS_ARRAY (sym
) && sym
->attr
.dummy
&& ar
->as
->type
!= AS_DEFERRED
)
3868 decl
= sym
->backend_decl
;
3870 cst_offset
= offset
= gfc_index_zero_node
;
3871 add_to_offset (&cst_offset
, &offset
, gfc_conv_array_offset (decl
));
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
--)
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
);
3882 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && ! expr
->no_bounds_check
)
3884 /* Check array bounds. */
3888 /* Evaluate the indexse.expr only once. */
3889 indexse
.expr
= save_expr (indexse
.expr
);
3892 tmp
= gfc_conv_array_lbound (decl
, n
);
3893 if (sym
->attr
.temporary
)
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
);
3902 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
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
,
3909 fold_convert (long_integer_type_node
, tmp
));
3912 /* Upper bound, but not for the last dimension of assumed-size
3914 if (n
< ar
->dimen
- 1 || ar
->as
->type
!= AS_ASSUMED_SIZE
)
3916 tmp
= gfc_conv_array_ubound (decl
, n
);
3917 if (sym
->attr
.temporary
)
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
);
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
,
3933 fold_convert (long_integer_type_node
, tmp
));
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
);
3943 /* And add it to the total. */
3944 add_to_offset (&cst_offset
, &offset
, tmp
);
3947 if (!integer_zerop (cst_offset
))
3948 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3949 gfc_array_index_type
, offset
, cst_offset
);
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
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
))
3960 if (TREE_CODE (se
->expr
) == COMPONENT_REF
)
3962 else if (TREE_CODE (se
->expr
) == INDIRECT_REF
)
3963 decl
= TREE_OPERAND (se
->expr
, 0);
3967 else if (expr
->ts
.deferred
3968 || (sym
->ts
.type
== BT_CHARACTER
3969 && sym
->attr
.select_type_temporary
))
3971 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
->expr
)))
3974 if (TREE_CODE (decl
) == INDIRECT_REF
)
3975 decl
= TREE_OPERAND (decl
, 0);
3978 decl
= sym
->backend_decl
;
3980 else if (sym
->ts
.type
== BT_CLASS
)
3982 if (UNLIMITED_POLY (sym
))
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
);
3996 se
->expr
= build_array_ref (se
->expr
, offset
, decl
, se
->class_vptr
);
4000 /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
4001 LOOP_DIM dimension (if any) to array's offset. */
4004 add_array_offset (stmtblock_t
*pblock
, gfc_loopinfo
*loop
, gfc_ss
*ss
,
4005 gfc_array_ref
*ar
, int array_dim
, int loop_dim
)
4008 gfc_array_info
*info
;
4011 info
= &ss
->info
->data
.array
;
4013 gfc_init_se (&se
, NULL
);
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
);
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
);
4027 /* Generate the code to be executed immediately before entering a
4028 scalarization loop. */
4031 gfc_trans_preloop_setup (gfc_loopinfo
* loop
, int dim
, int flag
,
4032 stmtblock_t
* pblock
)
4035 gfc_ss_info
*ss_info
;
4036 gfc_array_info
*info
;
4037 gfc_ss_type ss_type
;
4039 gfc_loopinfo
*ploop
;
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
)
4049 if ((ss_info
->useflags
& flag
) == 0)
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
)
4059 info
= &ss_info
->data
.array
;
4061 gcc_assert (dim
< ss
->dimen
);
4062 gcc_assert (ss
->dimen
== loop
->dimen
);
4065 ar
= &info
->ref
->u
.ar
;
4069 if (dim
== loop
->dimen
- 1 && loop
->parent
!= NULL
)
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
);
4076 ploop
= loop
->parent
;
4078 /* ss and ss->parent are about the same array. */
4079 gcc_assert (ss_info
== pss
->info
);
4087 if (dim
== loop
->dimen
- 1)
4092 /* For the time being, there is no loop reordering. */
4093 gcc_assert (i
== ploop
->order
[i
]);
4094 i
= ploop
->order
[i
];
4096 if (dim
== loop
->dimen
- 1 && loop
->parent
== NULL
)
4098 stride
= gfc_conv_array_stride (info
->descriptor
,
4099 innermost_ss (ss
)->dim
[i
]);
4101 /* Calculate the stride of the innermost loop. Hopefully this will
4102 allow the backend optimizers to do their stuff more effectively.
4104 info
->stride0
= gfc_evaluate_now (stride
, pblock
);
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. */
4111 for (i
= 0; i
< ar
->dimen
; i
++)
4113 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
4116 add_array_offset (pblock
, loop
, ss
, ar
, i
, /* unused */ -1);
4121 /* Add the offset for the previous loop dimension. */
4122 add_array_offset (pblock
, ploop
, ss
, ar
, pss
->dim
[i
], i
);
4124 /* Remember this offset for the second loop. */
4125 if (dim
== loop
->temp_dim
- 1 && loop
->parent
== NULL
)
4126 info
->saved_offset
= info
->offset
;
4131 /* Start a scalarized expression. Creates a scope and declares loop
4135 gfc_start_scalarized_body (gfc_loopinfo
* loop
, stmtblock_t
* pbody
)
4141 gcc_assert (!loop
->array_parameter
);
4143 for (dim
= loop
->dimen
- 1; dim
>= 0; dim
--)
4145 n
= loop
->order
[dim
];
4147 gfc_start_block (&loop
->code
[n
]);
4149 /* Create the loop variable. */
4150 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "S");
4152 if (dim
< loop
->temp_dim
)
4156 /* Calculate values that will be constant within this loop. */
4157 gfc_trans_preloop_setup (loop
, dim
, flags
, &loop
->code
[n
]);
4159 gfc_start_block (pbody
);
4163 /* Generates the actual loop code for a scalarization loop. */
4166 gfc_trans_scalarized_loop_end (gfc_loopinfo
* loop
, int n
,
4167 stmtblock_t
* pbody
)
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)
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);
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;
4193 /* Label for cycle statements (if needed). */
4194 tmp
= build1_v (LABEL_EXPR
, exit_label
);
4195 gfc_add_expr_to_block (pbody
, tmp
);
4197 stmt
= make_node (OMP_FOR
);
4199 TREE_TYPE (stmt
) = void_type_node
;
4200 OMP_FOR_BODY (stmt
) = loopbody
= gfc_finish_block (pbody
);
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
);
4210 /* Initialize the loopvar. */
4211 TREE_VEC_ELT (init
, 0) = build2_v (MODIFY_EXPR
, loop
->loopvar
[n
],
4213 OMP_FOR_INIT (stmt
) = init
;
4214 /* The exit condition. */
4215 TREE_VEC_ELT (cond
, 0) = build2_loc (input_location
, LE_EXPR
,
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
;
4227 ompws_flags
&= ~OMPWS_CURR_SINGLEUNIT
;
4228 gfc_add_expr_to_block (&loop
->code
[n
], stmt
);
4232 bool reverse_loop
= (loop
->reverse
[n
] == GFC_REVERSE_SET
)
4233 && (loop
->temp_ss
== NULL
);
4235 loopbody
= gfc_finish_block (pbody
);
4238 std::swap (loop
->from
[n
], loop
->to
[n
]);
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
]);
4244 exit_label
= gfc_build_label_decl (NULL_TREE
);
4246 /* Generate the loop body. */
4247 gfc_init_block (&block
);
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
);
4257 /* The main body. */
4258 gfc_add_expr_to_block (&block
, loopbody
);
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
);
4266 gfc_add_modify (&block
, loop
->loopvar
[n
], tmp
);
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
);
4273 /* Add the exit label. */
4274 tmp
= build1_v (LABEL_EXPR
, exit_label
);
4275 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
4281 /* Finishes and generates the loops for a scalarized expression. */
4284 gfc_trans_scalarizing_loops (gfc_loopinfo
* loop
, stmtblock_t
* body
)
4289 stmtblock_t
*pblock
;
4293 /* Generate the loops. */
4294 for (dim
= 0; dim
< loop
->dimen
; dim
++)
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
];
4302 tmp
= gfc_finish_block (pblock
);
4303 gfc_add_expr_to_block (&loop
->pre
, tmp
);
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;
4312 /* Finish the main body of a scalarized expression, and start the secondary
4316 gfc_trans_scalarized_loop_boundary (gfc_loopinfo
* loop
, stmtblock_t
* body
)
4320 stmtblock_t
*pblock
;
4324 /* We finish as many loops as are used by the temporary. */
4325 for (dim
= 0; dim
< loop
->temp_dim
- 1; dim
++)
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
];
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
);
4337 /* Restore the initial offsets. */
4338 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4340 gfc_ss_type ss_type
;
4341 gfc_ss_info
*ss_info
;
4345 if ((ss_info
->useflags
& 2) == 0)
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
)
4355 ss_info
->data
.array
.offset
= ss_info
->data
.array
.saved_offset
;
4358 /* Restart all the inner loops we just finished. */
4359 for (dim
= loop
->temp_dim
- 2; dim
>= 0; dim
--)
4361 n
= loop
->order
[dim
];
4363 gfc_start_block (&loop
->code
[n
]);
4365 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "Q");
4367 gfc_trans_preloop_setup (loop
, dim
, 2, &loop
->code
[n
]);
4370 /* Start a block for the secondary copying code. */
4371 gfc_start_block (body
);
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). */
4383 evaluate_bound (stmtblock_t
*block
, tree
*bounds
, gfc_expr
** values
,
4384 tree desc
, int dim
, bool lbound
, bool deferred
)
4387 gfc_expr
* input_val
= values
[dim
];
4388 tree
*output
= &bounds
[dim
];
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
);
4399 else if (deferred
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
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
,
4407 gfc_conv_descriptor_ubound_get (desc
,
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
);
4416 *output
= gfc_evaluate_now (*output
, block
);
4420 /* Calculate the lower bound of an array section. */
4423 gfc_conv_section_startstride (stmtblock_t
* block
, gfc_ss
* ss
, int dim
)
4425 gfc_expr
*stride
= NULL
;
4428 gfc_array_info
*info
;
4431 gcc_assert (ss
->info
->type
== GFC_SS_SECTION
);
4433 info
= &ss
->info
->data
.array
;
4434 ar
= &info
->ref
->u
.ar
;
4436 if (ar
->dimen_type
[dim
] == DIMEN_VECTOR
)
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
;
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
];
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
);
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
);
4463 /* Calculate the stride. */
4465 info
->stride
[dim
] = gfc_index_one_node
;
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
);
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. */
4481 gfc_conv_ss_startstride (gfc_loopinfo
* loop
)
4488 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
4491 /* Determine the rank of the loop. */
4492 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4494 switch (ss
->info
->type
)
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
;
4503 /* As usual, lbound and ubound are exceptions!. */
4504 case GFC_SS_INTRINSIC
:
4505 switch (ss
->info
->expr
->value
.function
.isym
->id
)
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
;
4525 /* We should have determined the rank of the expression by now. If
4526 not, that's bad news. */
4530 /* Loop over all the SS in the chain. */
4531 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4533 gfc_ss_info
*ss_info
;
4534 gfc_array_info
*info
;
4538 expr
= ss_info
->expr
;
4539 info
= &ss_info
->data
.array
;
4541 if (expr
&& expr
->shape
&& !info
->shape
)
4542 info
->shape
= expr
->shape
;
4544 switch (ss_info
->type
)
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
);
4553 for (n
= 0; n
< ss
->dimen
; n
++)
4554 gfc_conv_section_startstride (&outer_loop
->pre
, ss
, ss
->dim
[n
]);
4557 case GFC_SS_INTRINSIC
:
4558 switch (expr
->value
.function
.isym
->id
)
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
);
4567 case GFC_ISYM_SHAPE
:
4571 arg
= expr
->value
.function
.actual
->expr
;
4572 if (arg
->rank
== -1)
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
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
,
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
;
4597 /* Otherwise fall through GFC_SS_FUNCTION. */
4600 case GFC_ISYM_LCOBOUND
:
4601 case GFC_ISYM_UCOBOUND
:
4602 case GFC_ISYM_THIS_IMAGE
:
4610 case GFC_SS_CONSTRUCTOR
:
4611 case GFC_SS_FUNCTION
:
4612 for (n
= 0; n
< ss
->dimen
; n
++)
4614 int dim
= ss
->dim
[n
];
4616 info
->start
[dim
] = gfc_index_zero_node
;
4617 info
->end
[dim
] = gfc_index_zero_node
;
4618 info
->stride
[dim
] = gfc_index_one_node
;
4627 /* The rest is just runtime bounds checking. */
4628 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
4631 tree lbound
, ubound
;
4633 tree size
[GFC_MAX_DIMENSIONS
];
4634 tree stride_pos
, stride_neg
, non_zerosized
, tmp2
, tmp3
;
4635 gfc_array_info
*info
;
4639 gfc_start_block (&block
);
4641 for (n
= 0; n
< loop
->dimen
; n
++)
4642 size
[n
] = NULL_TREE
;
4644 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4647 gfc_ss_info
*ss_info
;
4650 const char *expr_name
;
4653 if (ss_info
->type
!= GFC_SS_SECTION
)
4656 /* Catch allocatable lhs in f2003. */
4657 if (flag_realloc_lhs
&& ss
->no_bounds_check
)
4660 expr
= ss_info
->expr
;
4661 expr_loc
= &expr
->where
;
4662 expr_name
= expr
->symtree
->name
;
4664 gfc_start_block (&inner
);
4666 /* TODO: range checking for mapped dimensions. */
4667 info
= &ss_info
->data
.array
;
4669 /* This code only checks ranges. Elemental and vector
4670 dimensions are checked later. */
4671 for (n
= 0; n
< loop
->dimen
; n
++)
4676 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
4679 if (dim
== info
->ref
->u
.ar
.dimen
- 1
4680 && info
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
4681 check_upper
= false;
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
,
4694 desc
= info
->descriptor
;
4696 /* This is the run-time equivalent of resolve.cc'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
];
4702 ubound
= gfc_conv_array_ubound (desc
, dim
);
4706 /* non_zerosized is true when the selected range is not
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
);
4716 stride_neg
= fold_build2_loc (input_location
, LT_EXPR
,
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
,
4724 non_zerosized
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
4726 stride_pos
, stride_neg
);
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
4734 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
4736 info
->start
[dim
], lbound
);
4737 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4739 non_zerosized
, tmp
);
4740 tmp2
= fold_build2_loc (input_location
, GT_EXPR
,
4742 info
->start
[dim
], ubound
);
4743 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
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
,
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
,
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
));
4763 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
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
,
4773 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4774 fold_convert (long_integer_type_node
, lbound
));
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. */
4782 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4783 gfc_array_index_type
, end
,
4785 tmp
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
,
4786 gfc_array_index_type
, tmp
,
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
);
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
,
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
,
4810 fold_convert (long_integer_type_node
, tmp
),
4811 fold_convert (long_integer_type_node
, ubound
),
4812 fold_convert (long_integer_type_node
, lbound
));
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
,
4822 fold_convert (long_integer_type_node
, tmp
),
4823 fold_convert (long_integer_type_node
, lbound
));
4827 /* Check the section sizes match. */
4828 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4829 gfc_array_index_type
, end
,
4831 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
4832 gfc_array_index_type
, tmp
,
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. */
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
);
4850 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4852 fold_convert (long_integer_type_node
, tmp
),
4853 fold_convert (long_integer_type_node
, size
[n
]));
4858 size
[n
] = gfc_evaluate_now (tmp
, &inner
);
4861 tmp
= gfc_finish_block (&inner
);
4863 /* For optional arguments, only check bounds if the argument is
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
));
4872 gfc_add_expr_to_block (&block
, tmp
);
4876 tmp
= gfc_finish_block (&block
);
4877 gfc_add_expr_to_block (&outer_loop
->pre
, tmp
);
4880 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4881 gfc_conv_ss_startstride (loop
);
4884 /* Return true if both symbols could refer to the same data object. Does
4885 not take account of aliasing due to equivalence statements. */
4888 symbols_could_alias (gfc_symbol
*lsym
, gfc_symbol
*rsym
, bool lsym_pointer
,
4889 bool lsym_target
, bool rsym_pointer
, bool rsym_target
)
4891 /* Aliasing isn't possible if the symbols have different base types. */
4892 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
4895 /* Pointers can point to other pointers and target objects. */
4897 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4898 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
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
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
))))
4916 /* Return true if the two SS could be aliased, i.e. both point to the same data
4918 /* TODO: resolve aliases based on frontend expressions. */
4921 gfc_could_be_alias (gfc_ss
* lss
, gfc_ss
* rss
)
4925 gfc_expr
*lexpr
, *rexpr
;
4928 bool lsym_pointer
, lsym_target
, rsym_pointer
, rsym_target
;
4930 lexpr
= lss
->info
->expr
;
4931 rexpr
= rss
->info
->expr
;
4933 lsym
= lexpr
->symtree
->n
.sym
;
4934 rsym
= rexpr
->symtree
->n
.sym
;
4936 lsym_pointer
= lsym
->attr
.pointer
;
4937 lsym_target
= lsym
->attr
.target
;
4938 rsym_pointer
= rsym
->attr
.pointer
;
4939 rsym_target
= rsym
->attr
.target
;
4941 if (symbols_could_alias (lsym
, rsym
, lsym_pointer
, lsym_target
,
4942 rsym_pointer
, rsym_target
))
4945 if (rsym
->ts
.type
!= BT_DERIVED
&& rsym
->ts
.type
!= BT_CLASS
4946 && lsym
->ts
.type
!= BT_DERIVED
&& lsym
->ts
.type
!= BT_CLASS
)
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
4952 for (lref
= lexpr
->ref
; lref
!= lss
->info
->data
.array
.ref
; lref
= lref
->next
)
4954 if (lref
->type
!= REF_COMPONENT
)
4957 lsym_pointer
= lsym_pointer
|| lref
->u
.c
.sym
->attr
.pointer
;
4958 lsym_target
= lsym_target
|| lref
->u
.c
.sym
->attr
.target
;
4960 if (symbols_could_alias (lref
->u
.c
.sym
, rsym
, lsym_pointer
, lsym_target
,
4961 rsym_pointer
, rsym_target
))
4964 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4965 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4967 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4972 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
;
4975 if (rref
->type
!= REF_COMPONENT
)
4978 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4979 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4981 if (symbols_could_alias (lref
->u
.c
.sym
, rref
->u
.c
.sym
,
4982 lsym_pointer
, lsym_target
,
4983 rsym_pointer
, rsym_target
))
4986 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4987 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4989 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4990 &rref
->u
.c
.sym
->ts
))
4992 if (gfc_compare_types (&lref
->u
.c
.sym
->ts
,
4993 &rref
->u
.c
.component
->ts
))
4995 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4996 &rref
->u
.c
.component
->ts
))
5002 lsym_pointer
= lsym
->attr
.pointer
;
5003 lsym_target
= lsym
->attr
.target
;
5005 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
; rref
= rref
->next
)
5007 if (rref
->type
!= REF_COMPONENT
)
5010 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
5011 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
5013 if (symbols_could_alias (rref
->u
.c
.sym
, lsym
,
5014 lsym_pointer
, lsym_target
,
5015 rsym_pointer
, rsym_target
))
5018 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
5019 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
5021 if (gfc_compare_types (&lsym
->ts
, &rref
->u
.c
.component
->ts
))
5030 /* Resolve array data dependencies. Creates a temporary if required. */
5031 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
5035 gfc_conv_resolve_dependencies (gfc_loopinfo
* loop
, gfc_ss
* dest
,
5041 gfc_ss_info
*ss_info
;
5042 gfc_expr
*dest_expr
;
5047 loop
->temp_ss
= NULL
;
5048 dest_expr
= dest
->info
->expr
;
5050 for (ss
= rss
; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
5053 ss_expr
= ss_info
->expr
;
5055 if (ss_info
->array_outer_dependency
)
5061 if (ss_info
->type
!= GFC_SS_SECTION
)
5063 if (flag_realloc_lhs
5064 && dest_expr
!= ss_expr
5065 && gfc_is_reallocatable_lhs (dest_expr
)
5067 nDepend
= gfc_check_dependency (dest_expr
, ss_expr
, true);
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
)
5074 nDepend
= gfc_check_dependency (dest_expr
, ss_expr
, false);
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;
5086 if (dest_expr
->symtree
->n
.sym
!= ss_expr
->symtree
->n
.sym
)
5088 if (gfc_could_be_alias (dest
, ss
)
5089 || gfc_are_equivalenced_arrays (dest_expr
, ss_expr
))
5097 lref
= dest_expr
->ref
;
5098 rref
= ss_expr
->ref
;
5100 nDepend
= gfc_dep_resolver (lref
, rref
, &loop
->reverse
[0]);
5105 for (i
= 0; i
< dest
->dimen
; i
++)
5106 for (j
= 0; j
< ss
->dimen
; j
++)
5108 && dest
->dim
[i
] == ss
->dim
[j
])
5110 /* If we don't access array elements in the same order,
5111 there is a dependency. */
5116 /* TODO : loop shifting. */
5119 /* Mark the dimensions for LOOP SHIFTING */
5120 for (n
= 0; n
< loop
->dimen
; n
++)
5122 int dim
= dest
->data
.info
.dim
[n
];
5124 if (lref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
5126 else if (! gfc_is_same_range (&lref
->u
.ar
,
5127 &rref
->u
.ar
, dim
, 0))
5131 /* Put all the dimensions with dependencies in the
5134 for (n
= 0; n
< loop
->dimen
; n
++)
5136 gcc_assert (loop
->order
[n
] == n
);
5138 loop
->order
[dim
++] = n
;
5140 for (n
= 0; n
< loop
->dimen
; n
++)
5143 loop
->order
[dim
++] = n
;
5146 gcc_assert (dim
== loop
->dimen
);
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
,
5163 gfc_add_ss_to_loop (loop
, loop
->temp_ss
);
5166 loop
->temp_ss
= NULL
;
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.). */
5175 set_loop_bounds (gfc_loopinfo
*loop
)
5177 int n
, dim
, spec_dim
;
5178 gfc_array_info
*info
;
5179 gfc_array_info
*specinfo
;
5183 bool dynamic
[GFC_MAX_DIMENSIONS
];
5186 bool nonoptional_arr
;
5188 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
5190 loopspec
= loop
->specloop
;
5193 for (n
= 0; n
< loop
->dimen
; n
++)
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). */
5202 nonoptional_arr
= false;
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
)
5208 nonoptional_arr
= true;
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
)
5216 gfc_ss_type ss_type
;
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
))
5225 info
= &ss
->info
->data
.array
;
5228 if (loopspec
[n
] != NULL
)
5230 specinfo
= &loopspec
[n
]->info
->data
.array
;
5231 spec_dim
= loopspec
[n
]->dim
[n
];
5235 /* Silence uninitialized warnings. */
5242 /* The frontend has worked out the size for us. */
5245 || !integer_zerop (specinfo
->start
[spec_dim
]))
5246 /* Prefer zero-based descriptors if possible. */
5251 if (ss_type
== GFC_SS_CONSTRUCTOR
)
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);
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
])
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
)
5277 /* Criteria for choosing a loop specifier (most important first):
5278 doesn't need realloc
5284 else if (loopspec
[n
]->info
->type
== GFC_SS_CONSTRUCTOR
&& dynamic
[n
])
5286 else if (integer_onep (info
->stride
[dim
])
5287 && !integer_onep (specinfo
->stride
[spec_dim
]))
5289 else if (INTEGER_CST_P (info
->stride
[dim
])
5290 && !INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
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
]))
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; */
5305 /* We should have found the scalarization loop specifier. If not,
5307 gcc_assert (loopspec
[n
]);
5309 info
= &loopspec
[n
]->info
->data
.array
;
5310 dim
= loopspec
[n
]->dim
[n
];
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
]))
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
,
5326 loop
->to
[n
] = fold_build2_loc (input_location
, PLUS_EXPR
,
5327 gfc_array_index_type
,
5328 loop
->from
[n
], tmp
);
5332 loop
->from
[n
] = info
->start
[dim
];
5333 switch (loopspec
[n
]->info
->type
)
5335 case GFC_SS_CONSTRUCTOR
:
5336 /* The upper bound is calculated when we expand the
5338 gcc_assert (loop
->to
[n
] == NULL_TREE
);
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
];
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
);
5352 case GFC_SS_INTRINSIC
:
5354 gfc_expr
*expr
= loopspec
[n
]->info
->expr
;
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);
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);
5365 loop
->to
[n
] = info
->end
[dim
];
5369 case GFC_SS_COMPONENT
:
5371 if (info
->end
[dim
] != NULL_TREE
)
5373 loop
->to
[n
] = info
->end
[dim
];
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
;
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
5395 for (i = 0; i<=last; i++){...}; */
5396 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5397 gfc_array_index_type
, loop
->to
[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
;
5410 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
5411 set_loop_bounds (loop
);
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. */
5421 gfc_conv_loop_setup (gfc_loopinfo
* loop
, locus
* where
)
5426 set_loop_bounds (loop
);
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
);
5433 tmp_ss
= loop
->temp_ss
;
5434 /* If we want a temporary then create it. */
5437 gfc_ss_info
*tmp_ss_info
;
5439 tmp_ss_info
= tmp_ss
->info
;
5440 gcc_assert (tmp_ss_info
->type
== GFC_SS_TEMP
);
5441 gcc_assert (loop
->parent
== NULL
);
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
);
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
;
5454 gcc_assert (tmp_ss
->dimen
!= 0);
5456 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, tmp_ss
, tmp
,
5457 NULL_TREE
, false, true, false, where
);
5460 /* For array parameters we don't have loop variables, so don't calculate the
5462 if (!loop
->array_parameter
)
5463 gfc_set_delta (loop
);
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. */
5472 gfc_set_delta (gfc_loopinfo
*loop
)
5474 gfc_ss
*ss
, **loopspec
;
5475 gfc_array_info
*info
;
5479 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
5481 loopspec
= loop
->specloop
;
5483 /* Calculate the translation from loop variables to array indices. */
5484 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
5486 gfc_ss_type ss_type
;
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
)
5494 info
= &ss
->info
->data
.array
;
5496 for (n
= 0; n
< ss
->dimen
; n
++)
5498 /* If we are specifying the range the delta is already set. */
5499 if (loopspec
[n
] != ss
)
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
]);
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
);
5516 info
->delta
[dim
] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
5521 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
5522 gfc_set_delta (loop
);
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. */
5532 gfc_conv_array_extent_dim (tree lbound
, tree ubound
, tree
* or_expr
)
5537 /* Calculate (ubound - lbound + 1). */
5538 res
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5540 res
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
, res
,
5541 gfc_index_one_node
);
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
);
5549 /* Build OR expression. */
5551 *or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
5552 logical_type_node
, *or_expr
, cond
);
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. */
5562 gfc_conv_descriptor_size_1 (tree desc
, int from_dim
, int to_dim
)
5567 res
= gfc_index_one_node
;
5569 for (dim
= from_dim
; dim
< to_dim
; ++dim
)
5575 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]);
5576 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]);
5578 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
5579 res
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5587 /* Full size of an array. */
5590 gfc_conv_descriptor_size (tree desc
, int rank
)
5592 return gfc_conv_descriptor_size_1 (desc
, 0, rank
);
5596 /* Size of a coarray for all dimensions but the last. */
5599 gfc_conv_descriptor_cosize (tree desc
, int rank
, int corank
)
5601 return gfc_conv_descriptor_size_1 (desc
, rank
, rank
+ corank
- 1);
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.
5613 for (n = 0; n < rank; n++)
5615 a.lbound[n] = specified_lower_bound;
5616 offset = offset + a.lbond[n] * stride;
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;
5624 for (n = rank; n < rank+corank; n++)
5625 (Set lcobound/ucobound as above.)
5626 element_size = sizeof (array element);
5629 stride = (size_t) stride;
5630 overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
5631 stride = stride * 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
,
5654 stmtblock_t thenblock
;
5655 stmtblock_t elseblock
;
5660 type
= TREE_TYPE (descriptor
);
5662 stride
= gfc_index_one_node
;
5663 offset
= gfc_index_zero_node
;
5665 /* Set the dtype before the alloc, because registration of coarrays needs
5667 if (expr
->ts
.type
== BT_CHARACTER
5668 && expr
->ts
.deferred
5669 && VAR_P (expr
->ts
.u
.cl
->backend_decl
))
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
));
5675 else if (expr
->ts
.type
== BT_CHARACTER
5676 && expr
->ts
.deferred
5677 && TREE_CODE (descriptor
) == COMPONENT_REF
)
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. */
5685 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5686 if (ref
->type
== REF_COMPONENT
5687 && gfc_deferred_strlen (ref
->u
.c
.component
, &tmp
))
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
));
5699 tmp
= gfc_conv_descriptor_dtype (descriptor
);
5700 gfc_add_modify (pblock
, tmp
, gfc_get_dtype (type
));
5703 or_expr
= logical_false_node
;
5705 for (n
= 0; n
< rank
; n
++)
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] */
5716 /* Set lower bound. */
5717 gfc_init_se (&se
, NULL
);
5718 if (expr3_desc
!= NULL_TREE
)
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
;
5727 se
.expr
= gfc_conv_descriptor_lbound_get (expr3_desc
,
5730 else if (lower
== NULL
)
5731 se
.expr
= gfc_index_one_node
;
5734 gcc_assert (lower
[n
]);
5737 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
5738 gfc_add_block_to_block (pblock
, &se
.pre
);
5742 se
.expr
= gfc_index_one_node
;
5746 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
5747 gfc_rank_cst
[n
], se
.expr
);
5748 conv_lbound
= se
.expr
;
5750 /* Work out the offset for this component. */
5751 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5753 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
5754 gfc_array_index_type
, offset
, tmp
);
5756 /* Set upper bound. */
5757 gfc_init_se (&se
, NULL
);
5758 if (expr3_desc
!= NULL_TREE
)
5760 if (e3_has_nodescriptor
)
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
);
5779 se
.expr
= gfc_conv_descriptor_ubound_get (expr3_desc
,
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
);
5790 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
5791 gfc_rank_cst
[n
], se
.expr
);
5792 conv_ubound
= se
.expr
;
5794 /* Store the stride. */
5795 gfc_conv_descriptor_stride_set (descriptor_block
, descriptor
,
5796 gfc_rank_cst
[n
], stride
);
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
);
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
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
)),
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
,
5825 *overflow
= gfc_evaluate_now (tmp
, pblock
);
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
);
5833 for (n
= rank
; n
< rank
+ corank
; n
++)
5837 /* Set lower bound. */
5838 gfc_init_se (&se
, NULL
);
5839 if (lower
== NULL
|| lower
[n
] == NULL
)
5841 gcc_assert (n
== rank
+ corank
- 1);
5842 se
.expr
= gfc_index_one_node
;
5846 if (ubound
|| n
== rank
+ corank
- 1)
5848 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
5849 gfc_add_block_to_block (pblock
, &se
.pre
);
5853 se
.expr
= gfc_index_one_node
;
5857 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
5858 gfc_rank_cst
[n
], se
.expr
);
5860 if (n
< rank
+ corank
- 1)
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
);
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
)
5878 if (expr3
->ts
.type
== BT_CLASS
)
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
);
5891 tmp
= gfc_typenode_for_spec (&expr3
->ts
);
5892 tmp
= TYPE_SIZE_UNIT (tmp
);
5896 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
5898 /* Convert to size_t. */
5899 *element_size
= fold_convert (size_type_node
, tmp
);
5902 return *element_size
;
5904 *nelems
= gfc_evaluate_now (stride
, pblock
);
5905 stride
= fold_convert (size_type_node
, stride
);
5907 /* First check for overflow. Since an array of type character can
5908 have zero element_size, we must check for that before
5910 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
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
,
5926 *overflow
= gfc_evaluate_now (tmp
, pblock
);
5928 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5929 stride
, *element_size
);
5931 if (poffset
!= NULL
)
5933 offset
= gfc_evaluate_now (offset
, pblock
);
5937 if (integer_zerop (or_expr
))
5939 if (integer_onep (or_expr
))
5940 return build_int_cst (size_type_node
, 0);
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
);
5947 gfc_start_block (&elseblock
);
5948 gfc_add_modify (&elseblock
, var
, size
);
5949 elsecase
= gfc_finish_block (&elseblock
);
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
);
5959 /* Retrieve the last ref from the chain. This routine is specific to
5960 gfc_array_allocate ()'s needs. */
5963 retrieve_last_ref (gfc_ref
**ref_in
, gfc_ref
**prev_ref_in
)
5965 gfc_ref
*ref
, *prev_ref
;
5968 /* Prevent warnings for uninitialized variables. */
5969 prev_ref
= *prev_ref_in
;
5970 while (ref
&& ref
->next
!= NULL
)
5972 gcc_assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
5973 || (ref
->u
.ar
.dimen
== 0 && ref
->u
.ar
.codimen
> 0));
5978 if (ref
== NULL
|| ref
->type
!= REF_ARRAY
)
5982 *prev_ref_in
= prev_ref
;
5986 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
5987 the work for an ALLOCATE statement. */
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
)
5998 tree offset
= NULL_TREE
;
5999 tree token
= NULL_TREE
;
6002 tree error
= NULL_TREE
;
6003 tree overflow
; /* Boolean storing whether size calculation overflows. */
6004 tree var_overflow
= NULL_TREE
;
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
;
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
;
6019 /* Find the last reference in the chain. */
6020 if (!retrieve_last_ref (&ref
, &prev_ref
))
6023 /* Take the allocatable and coarray properties solely from the expr-ref's
6024 attributes and not from source=-expression. */
6027 allocatable
= expr
->symtree
->n
.sym
->attr
.allocatable
;
6028 dimension
= expr
->symtree
->n
.sym
->attr
.dimension
;
6029 non_ulimate_coarray_ptr_comp
= false;
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
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
;
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
6047 for (coref
= expr
->ref
; coref
; coref
= coref
->next
)
6048 if (coref
->type
== REF_ARRAY
&& coref
->u
.ar
.codimen
> 0)
6055 gcc_assert (coarray
);
6057 if (ref
->u
.ar
.type
== AR_FULL
&& expr3
!= NULL
)
6059 gfc_ref
*old_ref
= ref
;
6060 /* F08:C633: Array shape from expr3. */
6063 /* Find the last reference in the chain. */
6064 if (!retrieve_last_ref (&ref
, &prev_ref
))
6066 if (expr3
->expr_type
== EXPR_FUNCTION
6067 && gfc_expr_attr (expr3
).dimension
)
6072 alloc_w_e3_arr_spec
= true;
6075 /* Figure out the size of the array. */
6076 switch (ref
->u
.ar
.type
)
6082 upper
= ref
->u
.ar
.start
;
6088 lower
= ref
->u
.ar
.start
;
6089 upper
= ref
->u
.ar
.end
;
6093 gcc_assert (ref
->u
.ar
.as
->type
== AS_EXPLICIT
6094 || alloc_w_e3_arr_spec
);
6096 lower
= ref
->u
.ar
.as
->lower
;
6097 upper
= ref
->u
.ar
.as
->upper
;
6105 overflow
= integer_zero_node
;
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
));
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
);
6129 var_overflow
= gfc_create_var (integer_type_node
, "overflow");
6130 gfc_add_modify (&se
->pre
, var_overflow
, overflow
);
6132 if (status
== NULL_TREE
)
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
);
6144 tree status_type
= TREE_TYPE (status
);
6145 stmtblock_t set_status_block
;
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
);
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
);
6158 if (coarray
&& flag_coarray
== GFC_FCOARRAY_LIB
)
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
);
6166 pointer
= gfc_conv_descriptor_data_get (se
->expr
);
6167 STRIP_NOPS (pointer
);
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));
6177 gfc_add_modify (&se
->pre
, not_prev_allocated
, tmp
);
6180 gfc_start_block (&elseblock
);
6182 /* The allocatable variant takes the old pointer as first argument. */
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
,
6191 GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY
);
6193 gfc_allocate_using_malloc (&elseblock
, pointer
, size
, status
);
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
));
6204 tmp
= gfc_finish_block (&elseblock
);
6206 gfc_add_expr_to_block (&se
->pre
, tmp
);
6208 /* Update the array descriptor with the offset and the span. */
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
);
6216 set_descriptor
= gfc_finish_block (&set_descriptor_block
);
6217 if (status
!= NULL_TREE
)
6219 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
6220 logical_type_node
, status
,
6221 build_int_cst (TREE_TYPE (status
), 0));
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
);
6227 gfc_add_expr_to_block (&se
->pre
,
6228 fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
6231 build_empty_stmt (input_location
)));
6234 gfc_add_expr_to_block (&se
->pre
, set_descriptor
);
6240 /* Create an array constructor from an initialization expression.
6241 We assume the frontend already did any expansions and conversions. */
6244 gfc_conv_array_initializer (tree type
, gfc_expr
* expr
)
6250 vec
<constructor_elt
, va_gc
> *v
= NULL
;
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
;
6257 switch (expr
->expr_type
)
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
);
6265 if (expr
->expr_type
== EXPR_CONSTANT
)
6266 gfc_conv_constant (&se
, expr
);
6268 gfc_conv_structure (&se
, expr
, 1);
6270 if (tree_int_cst_lt (TYPE_MAX_VALUE (TYPE_DOMAIN (type
)),
6271 TYPE_MIN_VALUE (TYPE_DOMAIN (type
))))
6273 else if (tree_int_cst_equal (TYPE_MIN_VALUE (TYPE_DOMAIN (type
)),
6274 TYPE_MAX_VALUE (TYPE_DOMAIN (type
))))
6275 range
= TYPE_MIN_VALUE (TYPE_DOMAIN (type
));
6277 range
= build2 (RANGE_EXPR
, gfc_array_index_type
,
6278 TYPE_MIN_VALUE (TYPE_DOMAIN (type
)),
6279 TYPE_MAX_VALUE (TYPE_DOMAIN (type
)));
6280 CONSTRUCTOR_APPEND_ELT (v
, range
, se
.expr
);
6284 /* Create a vector of all the elements. */
6285 for (c
= gfc_constructor_first (expr
->value
.constructor
);
6286 c
&& c
->expr
; c
= gfc_constructor_next (c
))
6290 /* Problems occur when we get something like
6291 integer :: a(lots) = (/(i, i=1, lots)/) */
6292 gfc_fatal_error ("The number of elements in the array "
6293 "constructor at %L requires an increase of "
6294 "the allowed %d upper limit. See "
6295 "%<-fmax-array-constructor%> option",
6296 &expr
->where
, flag_max_array_constructor
);
6299 if (mpz_cmp_si (c
->offset
, 0) != 0)
6300 index
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
6304 if (mpz_cmp_si (c
->repeat
, 1) > 0)
6310 mpz_add (maxval
, c
->offset
, c
->repeat
);
6311 mpz_sub_ui (maxval
, maxval
, 1);
6312 tmp2
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
6313 if (mpz_cmp_si (c
->offset
, 0) != 0)
6315 mpz_add_ui (maxval
, c
->offset
, 1);
6316 tmp1
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
6319 tmp1
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
6321 range
= fold_build2 (RANGE_EXPR
, gfc_array_index_type
, tmp1
, tmp2
);
6327 gfc_init_se (&se
, NULL
);
6328 switch (c
->expr
->expr_type
)
6331 gfc_conv_constant (&se
, c
->expr
);
6333 /* See gfortran.dg/charlen_15.f90 for instance. */
6334 if (TREE_CODE (se
.expr
) == STRING_CST
6335 && TREE_CODE (type
) == ARRAY_TYPE
)
6338 while (TREE_CODE (TREE_TYPE (atype
)) == ARRAY_TYPE
)
6339 atype
= TREE_TYPE (atype
);
6340 gcc_checking_assert (TREE_CODE (TREE_TYPE (atype
))
6342 gcc_checking_assert (TREE_TYPE (TREE_TYPE (se
.expr
))
6343 == TREE_TYPE (atype
));
6344 if (tree_to_uhwi (TYPE_SIZE_UNIT (TREE_TYPE (se
.expr
)))
6345 > tree_to_uhwi (TYPE_SIZE_UNIT (atype
)))
6347 unsigned HOST_WIDE_INT size
6348 = tree_to_uhwi (TYPE_SIZE_UNIT (atype
));
6349 const char *p
= TREE_STRING_POINTER (se
.expr
);
6351 se
.expr
= build_string (size
, p
);
6353 TREE_TYPE (se
.expr
) = atype
;
6357 case EXPR_STRUCTURE
:
6358 gfc_conv_structure (&se
, c
->expr
, 1);
6362 /* Catch those occasional beasts that do not simplify
6363 for one reason or another, assuming that if they are
6364 standard defying the frontend will catch them. */
6365 gfc_conv_expr (&se
, c
->expr
);
6369 if (range
== NULL_TREE
)
6370 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
6373 if (index
!= NULL_TREE
)
6374 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
6375 CONSTRUCTOR_APPEND_ELT (v
, range
, se
.expr
);
6381 return gfc_build_null_descriptor (type
);
6387 /* Create a constructor from the list of elements. */
6388 tmp
= build_constructor (type
, v
);
6389 TREE_CONSTANT (tmp
) = 1;
6394 /* Generate code to evaluate non-constant coarray cobounds. */
6397 gfc_trans_array_cobounds (tree type
, stmtblock_t
* pblock
,
6398 const gfc_symbol
*sym
)
6406 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
6408 for (dim
= as
->rank
; dim
< as
->rank
+ as
->corank
; dim
++)
6410 /* Evaluate non-constant array bound expressions. */
6411 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
6412 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
6414 gfc_init_se (&se
, NULL
);
6415 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
6416 gfc_add_block_to_block (pblock
, &se
.pre
);
6417 gfc_add_modify (pblock
, lbound
, se
.expr
);
6419 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
6420 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
6422 gfc_init_se (&se
, NULL
);
6423 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
6424 gfc_add_block_to_block (pblock
, &se
.pre
);
6425 gfc_add_modify (pblock
, ubound
, se
.expr
);
6431 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
6432 returns the size (in elements) of the array. */
6435 gfc_trans_array_bounds (tree type
, gfc_symbol
* sym
, tree
* poffset
,
6436 stmtblock_t
* pblock
)
6449 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
6451 size
= gfc_index_one_node
;
6452 offset
= gfc_index_zero_node
;
6453 for (dim
= 0; dim
< as
->rank
; dim
++)
6455 /* Evaluate non-constant array bound expressions. */
6456 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
6457 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
6459 gfc_init_se (&se
, NULL
);
6460 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
6461 gfc_add_block_to_block (pblock
, &se
.pre
);
6462 gfc_add_modify (pblock
, lbound
, se
.expr
);
6464 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
6465 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
6467 gfc_init_se (&se
, NULL
);
6468 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
6469 gfc_add_block_to_block (pblock
, &se
.pre
);
6470 gfc_add_modify (pblock
, ubound
, se
.expr
);
6472 /* The offset of this dimension. offset = offset - lbound * stride. */
6473 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6475 offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6478 /* The size of this dimension, and the stride of the next. */
6479 if (dim
+ 1 < as
->rank
)
6480 stride
= GFC_TYPE_ARRAY_STRIDE (type
, dim
+ 1);
6482 stride
= GFC_TYPE_ARRAY_SIZE (type
);
6484 if (ubound
!= NULL_TREE
&& !(stride
&& INTEGER_CST_P (stride
)))
6486 /* Calculate stride = size * (ubound + 1 - lbound). */
6487 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6488 gfc_array_index_type
,
6489 gfc_index_one_node
, lbound
);
6490 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6491 gfc_array_index_type
, ubound
, tmp
);
6492 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6493 gfc_array_index_type
, size
, tmp
);
6495 gfc_add_modify (pblock
, stride
, tmp
);
6497 stride
= gfc_evaluate_now (tmp
, pblock
);
6499 /* Make sure that negative size arrays are translated
6500 to being zero size. */
6501 tmp
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
6502 stride
, gfc_index_zero_node
);
6503 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6504 gfc_array_index_type
, tmp
,
6505 stride
, gfc_index_zero_node
);
6506 gfc_add_modify (pblock
, stride
, tmp
);
6512 gfc_trans_array_cobounds (type
, pblock
, sym
);
6513 gfc_trans_vla_type_sizes (sym
, pblock
);
6520 /* Generate code to initialize/allocate an array variable. */
6523 gfc_trans_auto_array_allocation (tree decl
, gfc_symbol
* sym
,
6524 gfc_wrapped_block
* block
)
6528 tree tmp
= NULL_TREE
;
6535 gcc_assert (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
));
6537 /* Do nothing for USEd variables. */
6538 if (sym
->attr
.use_assoc
)
6541 type
= TREE_TYPE (decl
);
6542 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6543 onstack
= TREE_CODE (type
) != POINTER_TYPE
;
6545 gfc_init_block (&init
);
6547 /* Evaluate character string length. */
6548 if (sym
->ts
.type
== BT_CHARACTER
6549 && onstack
&& !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
6551 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6553 gfc_trans_vla_type_sizes (sym
, &init
);
6555 /* Emit a DECL_EXPR for this variable, which will cause the
6556 gimplifier to allocate storage, and all that good stuff. */
6557 tmp
= fold_build1_loc (input_location
, DECL_EXPR
, TREE_TYPE (decl
), decl
);
6558 gfc_add_expr_to_block (&init
, tmp
);
6563 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6567 type
= TREE_TYPE (type
);
6569 gcc_assert (!sym
->attr
.use_assoc
);
6570 gcc_assert (!TREE_STATIC (decl
));
6571 gcc_assert (!sym
->module
);
6573 if (sym
->ts
.type
== BT_CHARACTER
6574 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
6575 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6577 size
= gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
6579 /* Don't actually allocate space for Cray Pointees. */
6580 if (sym
->attr
.cray_pointee
)
6582 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6583 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6585 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6589 if (flag_stack_arrays
)
6591 gcc_assert (TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
);
6592 space
= build_decl (gfc_get_location (&sym
->declared_at
),
6593 VAR_DECL
, create_tmp_var_name ("A"),
6594 TREE_TYPE (TREE_TYPE (decl
)));
6595 gfc_trans_vla_type_sizes (sym
, &init
);
6599 /* The size is the number of elements in the array, so multiply by the
6600 size of an element to get the total size. */
6601 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
6602 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6603 size
, fold_convert (gfc_array_index_type
, tmp
));
6605 /* Allocate memory to hold the data. */
6606 tmp
= gfc_call_malloc (&init
, TREE_TYPE (decl
), size
);
6607 gfc_add_modify (&init
, decl
, tmp
);
6609 /* Free the temporary. */
6610 tmp
= gfc_call_free (decl
);
6614 /* Set offset of the array. */
6615 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6616 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6618 /* Automatic arrays should not have initializers. */
6619 gcc_assert (!sym
->value
);
6621 inittree
= gfc_finish_block (&init
);
6628 /* Don't create new scope, emit the DECL_EXPR in exactly the scope
6629 where also space is located. */
6630 gfc_init_block (&init
);
6631 tmp
= fold_build1_loc (input_location
, DECL_EXPR
,
6632 TREE_TYPE (space
), space
);
6633 gfc_add_expr_to_block (&init
, tmp
);
6634 addr
= fold_build1_loc (gfc_get_location (&sym
->declared_at
),
6635 ADDR_EXPR
, TREE_TYPE (decl
), space
);
6636 gfc_add_modify (&init
, decl
, addr
);
6637 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6640 gfc_add_init_cleanup (block
, inittree
, tmp
);
6644 /* Generate entry and exit code for g77 calling convention arrays. */
6647 gfc_trans_g77_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
6657 gfc_save_backend_locus (&loc
);
6658 gfc_set_backend_locus (&sym
->declared_at
);
6660 /* Descriptor type. */
6661 parm
= sym
->backend_decl
;
6662 type
= TREE_TYPE (parm
);
6663 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6665 gfc_start_block (&init
);
6667 if (sym
->ts
.type
== BT_CHARACTER
6668 && VAR_P (sym
->ts
.u
.cl
->backend_decl
))
6669 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6671 /* Evaluate the bounds of the array. */
6672 gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
6674 /* Set the offset. */
6675 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6676 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6678 /* Set the pointer itself if we aren't using the parameter directly. */
6679 if (TREE_CODE (parm
) != PARM_DECL
)
6681 tmp
= GFC_DECL_SAVED_DESCRIPTOR (parm
);
6682 if (sym
->ts
.type
== BT_CLASS
)
6684 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
6685 tmp
= gfc_class_data_get (tmp
);
6686 tmp
= gfc_conv_descriptor_data_get (tmp
);
6688 tmp
= convert (TREE_TYPE (parm
), tmp
);
6689 gfc_add_modify (&init
, parm
, tmp
);
6691 stmt
= gfc_finish_block (&init
);
6693 gfc_restore_backend_locus (&loc
);
6695 /* Add the initialization code to the start of the function. */
6697 if ((sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.optional
)
6698 || sym
->attr
.optional
6699 || sym
->attr
.not_always_present
)
6702 if (TREE_CODE (parm
) != PARM_DECL
)
6703 nullify
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
6704 parm
, null_pointer_node
);
6706 nullify
= build_empty_stmt (input_location
);
6707 tmp
= gfc_conv_expr_present (sym
, true);
6708 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, nullify
);
6711 gfc_add_init_cleanup (block
, stmt
, NULL_TREE
);
6715 /* Modify the descriptor of an array parameter so that it has the
6716 correct lower bound. Also move the upper bound accordingly.
6717 If the array is not packed, it will be copied into a temporary.
6718 For each dimension we set the new lower and upper bounds. Then we copy the
6719 stride and calculate the offset for this dimension. We also work out
6720 what the stride of a packed array would be, and see it the two match.
6721 If the array need repacking, we set the stride to the values we just
6722 calculated, recalculate the offset and copy the array data.
6723 Code is also added to copy the data back at the end of the function.
6727 gfc_trans_dummy_array_bias (gfc_symbol
* sym
, tree tmpdesc
,
6728 gfc_wrapped_block
* block
)
6735 tree stmtInit
, stmtCleanup
;
6742 tree stride
, stride2
;
6752 bool is_classarray
= IS_CLASS_ARRAY (sym
);
6754 /* Do nothing for pointer and allocatable arrays. */
6755 if ((sym
->ts
.type
!= BT_CLASS
&& sym
->attr
.pointer
)
6756 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.class_pointer
)
6757 || sym
->attr
.allocatable
6758 || (is_classarray
&& CLASS_DATA (sym
)->attr
.allocatable
))
6761 if (!is_classarray
&& sym
->attr
.dummy
&& gfc_is_nodesc_array (sym
))
6763 gfc_trans_g77_array (sym
, block
);
6768 gfc_save_backend_locus (&loc
);
6769 /* loc.nextc is not set by save_backend_locus but the location routines
6771 if (loc
.nextc
== NULL
)
6772 loc
.nextc
= loc
.lb
->line
;
6773 gfc_set_backend_locus (&sym
->declared_at
);
6775 /* Descriptor type. */
6776 type
= TREE_TYPE (tmpdesc
);
6777 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6778 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6780 /* For a class array the dummy array descriptor is in the _class
6782 dumdesc
= gfc_class_data_get (dumdesc
);
6784 dumdesc
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
6785 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
6786 gfc_start_block (&init
);
6788 if (sym
->ts
.type
== BT_CHARACTER
6789 && VAR_P (sym
->ts
.u
.cl
->backend_decl
))
6790 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6792 /* TODO: Fix the exclusion of class arrays from extent checking. */
6793 checkparm
= (as
->type
== AS_EXPLICIT
&& !is_classarray
6794 && (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
));
6796 no_repack
= !(GFC_DECL_PACKED_ARRAY (tmpdesc
)
6797 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
));
6799 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
))
6801 /* For non-constant shape arrays we only check if the first dimension
6802 is contiguous. Repacking higher dimensions wouldn't gain us
6803 anything as we still don't know the array stride. */
6804 partial
= gfc_create_var (logical_type_node
, "partial");
6805 TREE_USED (partial
) = 1;
6806 tmp
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
6807 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, tmp
,
6808 gfc_index_one_node
);
6809 gfc_add_modify (&init
, partial
, tmp
);
6812 partial
= NULL_TREE
;
6814 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
6815 here, however I think it does the right thing. */
6818 /* Set the first stride. */
6819 stride
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
6820 stride
= gfc_evaluate_now (stride
, &init
);
6822 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
6823 stride
, gfc_index_zero_node
);
6824 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
6825 tmp
, gfc_index_one_node
, stride
);
6826 stride
= GFC_TYPE_ARRAY_STRIDE (type
, 0);
6827 gfc_add_modify (&init
, stride
, tmp
);
6829 /* Allow the user to disable array repacking. */
6830 stmt_unpacked
= NULL_TREE
;
6834 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type
, 0)));
6835 /* A library call to repack the array if necessary. */
6836 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6837 stmt_unpacked
= build_call_expr_loc (input_location
,
6838 gfor_fndecl_in_pack
, 1, tmp
);
6840 stride
= gfc_index_one_node
;
6842 if (warn_array_temporaries
)
6843 gfc_warning (OPT_Warray_temporaries
,
6844 "Creating array temporary at %L", &loc
);
6847 /* This is for the case where the array data is used directly without
6848 calling the repack function. */
6849 if (no_repack
|| partial
!= NULL_TREE
)
6850 stmt_packed
= gfc_conv_descriptor_data_get (dumdesc
);
6852 stmt_packed
= NULL_TREE
;
6854 /* Assign the data pointer. */
6855 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
6857 /* Don't repack unknown shape arrays when the first stride is 1. */
6858 tmp
= fold_build3_loc (input_location
, COND_EXPR
, TREE_TYPE (stmt_packed
),
6859 partial
, stmt_packed
, stmt_unpacked
);
6862 tmp
= stmt_packed
!= NULL_TREE
? stmt_packed
: stmt_unpacked
;
6863 gfc_add_modify (&init
, tmpdesc
, fold_convert (type
, tmp
));
6865 offset
= gfc_index_zero_node
;
6866 size
= gfc_index_one_node
;
6868 /* Evaluate the bounds of the array. */
6869 for (n
= 0; n
< as
->rank
; n
++)
6871 if (checkparm
|| !as
->upper
[n
])
6873 /* Get the bounds of the actual parameter. */
6874 dubound
= gfc_conv_descriptor_ubound_get (dumdesc
, gfc_rank_cst
[n
]);
6875 dlbound
= gfc_conv_descriptor_lbound_get (dumdesc
, gfc_rank_cst
[n
]);
6879 dubound
= NULL_TREE
;
6880 dlbound
= NULL_TREE
;
6883 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, n
);
6884 if (!INTEGER_CST_P (lbound
))
6886 gfc_init_se (&se
, NULL
);
6887 gfc_conv_expr_type (&se
, as
->lower
[n
],
6888 gfc_array_index_type
);
6889 gfc_add_block_to_block (&init
, &se
.pre
);
6890 gfc_add_modify (&init
, lbound
, se
.expr
);
6893 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, n
);
6894 /* Set the desired upper bound. */
6897 /* We know what we want the upper bound to be. */
6898 if (!INTEGER_CST_P (ubound
))
6900 gfc_init_se (&se
, NULL
);
6901 gfc_conv_expr_type (&se
, as
->upper
[n
],
6902 gfc_array_index_type
);
6903 gfc_add_block_to_block (&init
, &se
.pre
);
6904 gfc_add_modify (&init
, ubound
, se
.expr
);
6907 /* Check the sizes match. */
6910 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
6914 temp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6915 gfc_array_index_type
, ubound
, lbound
);
6916 temp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6917 gfc_array_index_type
,
6918 gfc_index_one_node
, temp
);
6919 stride2
= fold_build2_loc (input_location
, MINUS_EXPR
,
6920 gfc_array_index_type
, dubound
,
6922 stride2
= fold_build2_loc (input_location
, PLUS_EXPR
,
6923 gfc_array_index_type
,
6924 gfc_index_one_node
, stride2
);
6925 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6926 gfc_array_index_type
, temp
, stride2
);
6927 msg
= xasprintf ("Dimension %d of array '%s' has extent "
6928 "%%ld instead of %%ld", n
+1, sym
->name
);
6930 gfc_trans_runtime_check (true, false, tmp
, &init
, &loc
, msg
,
6931 fold_convert (long_integer_type_node
, temp
),
6932 fold_convert (long_integer_type_node
, stride2
));
6939 /* For assumed shape arrays move the upper bound by the same amount
6940 as the lower bound. */
6941 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6942 gfc_array_index_type
, dubound
, dlbound
);
6943 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6944 gfc_array_index_type
, tmp
, lbound
);
6945 gfc_add_modify (&init
, ubound
, tmp
);
6947 /* The offset of this dimension. offset = offset - lbound * stride. */
6948 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6950 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
6951 gfc_array_index_type
, offset
, tmp
);
6953 /* The size of this dimension, and the stride of the next. */
6954 if (n
+ 1 < as
->rank
)
6956 stride
= GFC_TYPE_ARRAY_STRIDE (type
, n
+ 1);
6958 if (no_repack
|| partial
!= NULL_TREE
)
6960 gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[n
+1]);
6962 /* Figure out the stride if not a known constant. */
6963 if (!INTEGER_CST_P (stride
))
6966 stmt_packed
= NULL_TREE
;
6969 /* Calculate stride = size * (ubound + 1 - lbound). */
6970 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6971 gfc_array_index_type
,
6972 gfc_index_one_node
, lbound
);
6973 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6974 gfc_array_index_type
, ubound
, tmp
);
6975 size
= fold_build2_loc (input_location
, MULT_EXPR
,
6976 gfc_array_index_type
, size
, tmp
);
6980 /* Assign the stride. */
6981 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
6982 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6983 gfc_array_index_type
, partial
,
6984 stmt_unpacked
, stmt_packed
);
6986 tmp
= (stmt_packed
!= NULL_TREE
) ? stmt_packed
: stmt_unpacked
;
6987 gfc_add_modify (&init
, stride
, tmp
);
6992 stride
= GFC_TYPE_ARRAY_SIZE (type
);
6994 if (stride
&& !INTEGER_CST_P (stride
))
6996 /* Calculate size = stride * (ubound + 1 - lbound). */
6997 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6998 gfc_array_index_type
,
6999 gfc_index_one_node
, lbound
);
7000 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7001 gfc_array_index_type
,
7003 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7004 gfc_array_index_type
,
7005 GFC_TYPE_ARRAY_STRIDE (type
, n
), tmp
);
7006 gfc_add_modify (&init
, stride
, tmp
);
7011 gfc_trans_array_cobounds (type
, &init
, sym
);
7013 /* Set the offset. */
7014 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
7015 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
7017 gfc_trans_vla_type_sizes (sym
, &init
);
7019 stmtInit
= gfc_finish_block (&init
);
7021 /* Only do the entry/initialization code if the arg is present. */
7022 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
7023 optional_arg
= (sym
->attr
.optional
7024 || (sym
->ns
->proc_name
->attr
.entry_master
7025 && sym
->attr
.dummy
));
7028 tree zero_init
= fold_convert (TREE_TYPE (tmpdesc
), null_pointer_node
);
7029 zero_init
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
7030 tmpdesc
, zero_init
);
7031 tmp
= gfc_conv_expr_present (sym
, true);
7032 stmtInit
= build3_v (COND_EXPR
, tmp
, stmtInit
, zero_init
);
7037 stmtCleanup
= NULL_TREE
;
7040 stmtblock_t cleanup
;
7041 gfc_start_block (&cleanup
);
7043 if (sym
->attr
.intent
!= INTENT_IN
)
7045 /* Copy the data back. */
7046 tmp
= build_call_expr_loc (input_location
,
7047 gfor_fndecl_in_unpack
, 2, dumdesc
, tmpdesc
);
7048 gfc_add_expr_to_block (&cleanup
, tmp
);
7051 /* Free the temporary. */
7052 tmp
= gfc_call_free (tmpdesc
);
7053 gfc_add_expr_to_block (&cleanup
, tmp
);
7055 stmtCleanup
= gfc_finish_block (&cleanup
);
7057 /* Only do the cleanup if the array was repacked. */
7059 /* For a class array the dummy array descriptor is in the _class
7061 tmp
= gfc_class_data_get (dumdesc
);
7063 tmp
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
7064 tmp
= gfc_conv_descriptor_data_get (tmp
);
7065 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
7067 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
7068 build_empty_stmt (input_location
));
7072 tmp
= gfc_conv_expr_present (sym
);
7073 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
7074 build_empty_stmt (input_location
));
7078 /* We don't need to free any memory allocated by internal_pack as it will
7079 be freed at the end of the function by pop_context. */
7080 gfc_add_init_cleanup (block
, stmtInit
, stmtCleanup
);
7082 gfc_restore_backend_locus (&loc
);
7086 /* Calculate the overall offset, including subreferences. */
7088 gfc_get_dataptr_offset (stmtblock_t
*block
, tree parm
, tree desc
, tree offset
,
7089 bool subref
, gfc_expr
*expr
)
7099 /* If offset is NULL and this is not a subreferenced array, there is
7101 if (offset
== NULL_TREE
)
7104 offset
= gfc_index_zero_node
;
7109 tmp
= build_array_ref (desc
, offset
, NULL
, NULL
);
7111 /* Offset the data pointer for pointer assignments from arrays with
7112 subreferences; e.g. my_integer => my_type(:)%integer_component. */
7115 /* Go past the array reference. */
7116 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7117 if (ref
->type
== REF_ARRAY
&&
7118 ref
->u
.ar
.type
!= AR_ELEMENT
)
7124 /* Calculate the offset for each subsequent subreference. */
7125 for (; ref
; ref
= ref
->next
)
7130 field
= ref
->u
.c
.component
->backend_decl
;
7131 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
7132 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
7134 tmp
, field
, NULL_TREE
);
7138 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
7139 gfc_init_se (&start
, NULL
);
7140 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
7141 gfc_add_block_to_block (block
, &start
.pre
);
7142 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
7146 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
7147 && ref
->u
.ar
.type
== AR_ELEMENT
);
7149 /* TODO - Add bounds checking. */
7150 stride
= gfc_index_one_node
;
7151 index
= gfc_index_zero_node
;
7152 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
7157 /* Update the index. */
7158 gfc_init_se (&start
, NULL
);
7159 gfc_conv_expr_type (&start
, ref
->u
.ar
.start
[n
], gfc_array_index_type
);
7160 itmp
= gfc_evaluate_now (start
.expr
, block
);
7161 gfc_init_se (&start
, NULL
);
7162 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->lower
[n
], gfc_array_index_type
);
7163 jtmp
= gfc_evaluate_now (start
.expr
, block
);
7164 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7165 gfc_array_index_type
, itmp
, jtmp
);
7166 itmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7167 gfc_array_index_type
, itmp
, stride
);
7168 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
7169 gfc_array_index_type
, itmp
, index
);
7170 index
= gfc_evaluate_now (index
, block
);
7172 /* Update the stride. */
7173 gfc_init_se (&start
, NULL
);
7174 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->upper
[n
], gfc_array_index_type
);
7175 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7176 gfc_array_index_type
, start
.expr
,
7178 itmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7179 gfc_array_index_type
,
7180 gfc_index_one_node
, itmp
);
7181 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
7182 gfc_array_index_type
, stride
, itmp
);
7183 stride
= gfc_evaluate_now (stride
, block
);
7186 /* Apply the index to obtain the array element. */
7187 tmp
= gfc_build_array_ref (tmp
, index
, NULL
);
7194 tmp
= fold_build1_loc (input_location
, REALPART_EXPR
,
7195 TREE_TYPE (TREE_TYPE (tmp
)), tmp
);
7199 tmp
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
7200 TREE_TYPE (TREE_TYPE (tmp
)), tmp
);
7215 /* Set the target data pointer. */
7216 offset
= gfc_build_addr_expr (gfc_array_dataptr_type (desc
), tmp
);
7217 gfc_conv_descriptor_data_set (block
, parm
, offset
);
7221 /* gfc_conv_expr_descriptor needs the string length an expression
7222 so that the size of the temporary can be obtained. This is done
7223 by adding up the string lengths of all the elements in the
7224 expression. Function with non-constant expressions have their
7225 string lengths mapped onto the actual arguments using the
7226 interface mapping machinery in trans-expr.cc. */
7228 get_array_charlen (gfc_expr
*expr
, gfc_se
*se
)
7230 gfc_interface_mapping mapping
;
7231 gfc_formal_arglist
*formal
;
7232 gfc_actual_arglist
*arg
;
7236 if (expr
->ts
.u
.cl
->length
7237 && gfc_is_constant_expr (expr
->ts
.u
.cl
->length
))
7239 if (!expr
->ts
.u
.cl
->backend_decl
)
7240 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
7244 switch (expr
->expr_type
)
7248 /* This is somewhat brutal. The expression for the first
7249 element of the array is evaluated and assigned to a
7250 new string length for the original expression. */
7251 e
= gfc_constructor_first (expr
->value
.constructor
)->expr
;
7253 gfc_init_se (&tse
, NULL
);
7255 /* Avoid evaluating trailing array references since all we need is
7256 the string length. */
7258 tse
.descriptor_only
= 1;
7259 if (e
->rank
&& e
->expr_type
!= EXPR_VARIABLE
)
7260 gfc_conv_expr_descriptor (&tse
, e
);
7262 gfc_conv_expr (&tse
, e
);
7264 gfc_add_block_to_block (&se
->pre
, &tse
.pre
);
7265 gfc_add_block_to_block (&se
->post
, &tse
.post
);
7267 if (!expr
->ts
.u
.cl
->backend_decl
|| !VAR_P (expr
->ts
.u
.cl
->backend_decl
))
7269 expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
7270 expr
->ts
.u
.cl
->backend_decl
=
7271 gfc_create_var (gfc_charlen_type_node
, "sln");
7274 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
7277 /* Make sure that deferred length components point to the hidden
7278 string_length component. */
7279 if (TREE_CODE (tse
.expr
) == COMPONENT_REF
7280 && TREE_CODE (tse
.string_length
) == COMPONENT_REF
7281 && TREE_OPERAND (tse
.expr
, 0) == TREE_OPERAND (tse
.string_length
, 0))
7282 e
->ts
.u
.cl
->backend_decl
= expr
->ts
.u
.cl
->backend_decl
;
7287 get_array_charlen (expr
->value
.op
.op1
, se
);
7289 /* For parentheses the expression ts.u.cl should be identical. */
7290 if (expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
7292 if (expr
->value
.op
.op1
->ts
.u
.cl
!= expr
->ts
.u
.cl
)
7293 expr
->ts
.u
.cl
->backend_decl
7294 = expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
;
7298 expr
->ts
.u
.cl
->backend_decl
=
7299 gfc_create_var (gfc_charlen_type_node
, "sln");
7301 if (expr
->value
.op
.op2
)
7303 get_array_charlen (expr
->value
.op
.op2
, se
);
7305 gcc_assert (expr
->value
.op
.op
== INTRINSIC_CONCAT
);
7307 /* Add the string lengths and assign them to the expression
7308 string length backend declaration. */
7309 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
7310 fold_build2_loc (input_location
, PLUS_EXPR
,
7311 gfc_charlen_type_node
,
7312 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
,
7313 expr
->value
.op
.op2
->ts
.u
.cl
->backend_decl
));
7316 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
7317 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
);
7321 if (expr
->value
.function
.esym
== NULL
7322 || expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
7324 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
7328 /* Map expressions involving the dummy arguments onto the actual
7329 argument expressions. */
7330 gfc_init_interface_mapping (&mapping
);
7331 formal
= gfc_sym_get_dummy_args (expr
->symtree
->n
.sym
);
7332 arg
= expr
->value
.function
.actual
;
7334 /* Set se = NULL in the calls to the interface mapping, to suppress any
7336 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
7341 gfc_add_interface_mapping (&mapping
, formal
->sym
, NULL
, arg
->expr
);
7344 gfc_init_se (&tse
, NULL
);
7346 /* Build the expression for the character length and convert it. */
7347 gfc_apply_interface_mapping (&mapping
, &tse
, expr
->ts
.u
.cl
->length
);
7349 gfc_add_block_to_block (&se
->pre
, &tse
.pre
);
7350 gfc_add_block_to_block (&se
->post
, &tse
.post
);
7351 tse
.expr
= fold_convert (gfc_charlen_type_node
, tse
.expr
);
7352 tse
.expr
= fold_build2_loc (input_location
, MAX_EXPR
,
7353 TREE_TYPE (tse
.expr
), tse
.expr
,
7354 build_zero_cst (TREE_TYPE (tse
.expr
)));
7355 expr
->ts
.u
.cl
->backend_decl
= tse
.expr
;
7356 gfc_free_interface_mapping (&mapping
);
7360 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
7366 /* Helper function to check dimensions. */
7368 transposed_dims (gfc_ss
*ss
)
7372 for (n
= 0; n
< ss
->dimen
; n
++)
7373 if (ss
->dim
[n
] != n
)
7379 /* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
7380 AR_FULL, suitable for the scalarizer. */
7383 walk_coarray (gfc_expr
*e
)
7387 gcc_assert (gfc_get_corank (e
) > 0);
7389 ss
= gfc_walk_expr (e
);
7391 /* Fix scalar coarray. */
7392 if (ss
== gfc_ss_terminator
)
7399 if (ref
->type
== REF_ARRAY
7400 && ref
->u
.ar
.codimen
> 0)
7406 gcc_assert (ref
!= NULL
);
7407 if (ref
->u
.ar
.type
== AR_ELEMENT
)
7408 ref
->u
.ar
.type
= AR_SECTION
;
7409 ss
= gfc_reverse_ss (gfc_walk_array_ref (ss
, e
, ref
));
7416 /* Convert an array for passing as an actual argument. Expressions and
7417 vector subscripts are evaluated and stored in a temporary, which is then
7418 passed. For whole arrays the descriptor is passed. For array sections
7419 a modified copy of the descriptor is passed, but using the original data.
7421 This function is also used for array pointer assignments, and there
7424 - se->want_pointer && !se->direct_byref
7425 EXPR is an actual argument. On exit, se->expr contains a
7426 pointer to the array descriptor.
7428 - !se->want_pointer && !se->direct_byref
7429 EXPR is an actual argument to an intrinsic function or the
7430 left-hand side of a pointer assignment. On exit, se->expr
7431 contains the descriptor for EXPR.
7433 - !se->want_pointer && se->direct_byref
7434 EXPR is the right-hand side of a pointer assignment and
7435 se->expr is the descriptor for the previously-evaluated
7436 left-hand side. The function creates an assignment from
7440 The se->force_tmp flag disables the non-copying descriptor optimization
7441 that is used for transpose. It may be used in cases where there is an
7442 alias between the transpose argument and another argument in the same
7446 gfc_conv_expr_descriptor (gfc_se
*se
, gfc_expr
*expr
)
7449 gfc_ss_type ss_type
;
7450 gfc_ss_info
*ss_info
;
7452 gfc_array_info
*info
;
7460 bool subref_array_target
= false;
7461 bool deferred_array_component
= false;
7462 gfc_expr
*arg
, *ss_expr
;
7464 if (se
->want_coarray
)
7465 ss
= walk_coarray (expr
);
7467 ss
= gfc_walk_expr (expr
);
7469 gcc_assert (ss
!= NULL
);
7470 gcc_assert (ss
!= gfc_ss_terminator
);
7473 ss_type
= ss_info
->type
;
7474 ss_expr
= ss_info
->expr
;
7476 /* Special case: TRANSPOSE which needs no temporary. */
7477 while (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
7478 && (arg
= gfc_get_noncopying_intrinsic_argument (expr
)) != NULL
)
7480 /* This is a call to transpose which has already been handled by the
7481 scalarizer, so that we just need to get its argument's descriptor. */
7482 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
7483 expr
= expr
->value
.function
.actual
->expr
;
7486 if (!se
->direct_byref
)
7487 se
->unlimited_polymorphic
= UNLIMITED_POLY (expr
);
7489 /* Special case things we know we can pass easily. */
7490 switch (expr
->expr_type
)
7493 /* If we have a linear array section, we can pass it directly.
7494 Otherwise we need to copy it into a temporary. */
7496 gcc_assert (ss_type
== GFC_SS_SECTION
);
7497 gcc_assert (ss_expr
== expr
);
7498 info
= &ss_info
->data
.array
;
7500 /* Get the descriptor for the array. */
7501 gfc_conv_ss_descriptor (&se
->pre
, ss
, 0);
7502 desc
= info
->descriptor
;
7504 /* The charlen backend decl for deferred character components cannot
7505 be used because it is fixed at zero. Instead, the hidden string
7506 length component is used. */
7507 if (expr
->ts
.type
== BT_CHARACTER
7508 && expr
->ts
.deferred
7509 && TREE_CODE (desc
) == COMPONENT_REF
)
7510 deferred_array_component
= true;
7512 subref_array_target
= (is_subref_array (expr
)
7513 && (se
->direct_byref
7514 || expr
->ts
.type
== BT_CHARACTER
));
7515 need_tmp
= (gfc_ref_needs_temporary_p (expr
->ref
)
7516 && !subref_array_target
);
7520 else if (se
->force_no_tmp
)
7525 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7527 /* Create a new descriptor if the array doesn't have one. */
7530 else if (info
->ref
->u
.ar
.type
== AR_FULL
|| se
->descriptor_only
)
7532 else if (se
->direct_byref
)
7534 else if (info
->ref
->u
.ar
.dimen
== 0 && !info
->ref
->next
)
7536 else if (info
->ref
->u
.ar
.type
== AR_SECTION
&& se
->want_pointer
)
7539 full
= gfc_full_array_ref_p (info
->ref
, NULL
);
7541 if (full
&& !transposed_dims (ss
))
7543 if (se
->direct_byref
&& !se
->byref_noassign
)
7545 /* Copy the descriptor for pointer assignments. */
7546 gfc_add_modify (&se
->pre
, se
->expr
, desc
);
7548 /* Add any offsets from subreferences. */
7549 gfc_get_dataptr_offset (&se
->pre
, se
->expr
, desc
, NULL_TREE
,
7550 subref_array_target
, expr
);
7552 /* ....and set the span field. */
7553 tmp
= gfc_conv_descriptor_span_get (desc
);
7554 gfc_conv_descriptor_span_set (&se
->pre
, se
->expr
, tmp
);
7556 else if (se
->want_pointer
)
7558 /* We pass full arrays directly. This means that pointers and
7559 allocatable arrays should also work. */
7560 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
7567 if (expr
->ts
.type
== BT_CHARACTER
&& !deferred_array_component
)
7568 se
->string_length
= gfc_get_expr_charlen (expr
);
7569 /* The ss_info string length is returned set to the value of the
7570 hidden string length component. */
7571 else if (deferred_array_component
)
7572 se
->string_length
= ss_info
->string_length
;
7574 gfc_free_ss_chain (ss
);
7580 /* A transformational function return value will be a temporary
7581 array descriptor. We still need to go through the scalarizer
7582 to create the descriptor. Elemental functions are handled as
7583 arbitrary expressions, i.e. copy to a temporary. */
7585 if (se
->direct_byref
)
7587 gcc_assert (ss_type
== GFC_SS_FUNCTION
&& ss_expr
== expr
);
7589 /* For pointer assignments pass the descriptor directly. */
7593 gcc_assert (se
->ss
== ss
);
7595 if (!is_pointer_array (se
->expr
))
7597 tmp
= gfc_get_element_type (TREE_TYPE (se
->expr
));
7598 tmp
= fold_convert (gfc_array_index_type
,
7599 size_in_bytes (tmp
));
7600 gfc_conv_descriptor_span_set (&se
->pre
, se
->expr
, tmp
);
7603 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7604 gfc_conv_expr (se
, expr
);
7606 gfc_free_ss_chain (ss
);
7610 if (ss_expr
!= expr
|| ss_type
!= GFC_SS_FUNCTION
)
7612 if (ss_expr
!= expr
)
7613 /* Elemental function. */
7614 gcc_assert ((expr
->value
.function
.esym
!= NULL
7615 && expr
->value
.function
.esym
->attr
.elemental
)
7616 || (expr
->value
.function
.isym
!= NULL
7617 && expr
->value
.function
.isym
->elemental
)
7618 || (gfc_expr_attr (expr
).proc_pointer
7619 && gfc_expr_attr (expr
).elemental
)
7620 || gfc_inline_intrinsic_function_p (expr
));
7623 if (expr
->ts
.type
== BT_CHARACTER
7624 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
7625 get_array_charlen (expr
, se
);
7631 /* Transformational function. */
7632 info
= &ss_info
->data
.array
;
7638 /* Constant array constructors don't need a temporary. */
7639 if (ss_type
== GFC_SS_CONSTRUCTOR
7640 && expr
->ts
.type
!= BT_CHARACTER
7641 && gfc_constant_array_constructor_p (expr
->value
.constructor
))
7644 info
= &ss_info
->data
.array
;
7654 /* Something complicated. Copy it into a temporary. */
7660 /* If we are creating a temporary, we don't need to bother about aliases
7665 gfc_init_loopinfo (&loop
);
7667 /* Associate the SS with the loop. */
7668 gfc_add_ss_to_loop (&loop
, ss
);
7670 /* Tell the scalarizer not to bother creating loop variables, etc. */
7672 loop
.array_parameter
= 1;
7674 /* The right-hand side of a pointer assignment mustn't use a temporary. */
7675 gcc_assert (!se
->direct_byref
);
7677 /* Do we need bounds checking or not? */
7678 ss
->no_bounds_check
= expr
->no_bounds_check
;
7680 /* Setup the scalarizing loops and bounds. */
7681 gfc_conv_ss_startstride (&loop
);
7685 if (expr
->ts
.type
== BT_CHARACTER
7686 && (!expr
->ts
.u
.cl
->backend_decl
|| expr
->expr_type
== EXPR_ARRAY
))
7687 get_array_charlen (expr
, se
);
7689 /* Tell the scalarizer to make a temporary. */
7690 loop
.temp_ss
= gfc_get_temp_ss (gfc_typenode_for_spec (&expr
->ts
),
7691 ((expr
->ts
.type
== BT_CHARACTER
)
7692 ? expr
->ts
.u
.cl
->backend_decl
7696 se
->string_length
= loop
.temp_ss
->info
->string_length
;
7697 gcc_assert (loop
.temp_ss
->dimen
== loop
.dimen
);
7698 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
7701 gfc_conv_loop_setup (&loop
, & expr
->where
);
7705 /* Copy into a temporary and pass that. We don't need to copy the data
7706 back because expressions and vector subscripts must be INTENT_IN. */
7707 /* TODO: Optimize passing function return values. */
7712 /* Start the copying loops. */
7713 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
7714 gfc_mark_ss_chain_used (ss
, 1);
7715 gfc_start_scalarized_body (&loop
, &block
);
7717 /* Copy each data element. */
7718 gfc_init_se (&lse
, NULL
);
7719 gfc_copy_loopinfo_to_se (&lse
, &loop
);
7720 gfc_init_se (&rse
, NULL
);
7721 gfc_copy_loopinfo_to_se (&rse
, &loop
);
7723 lse
.ss
= loop
.temp_ss
;
7726 gfc_conv_scalarized_array_ref (&lse
, NULL
);
7727 if (expr
->ts
.type
== BT_CHARACTER
)
7729 gfc_conv_expr (&rse
, expr
);
7730 if (POINTER_TYPE_P (TREE_TYPE (rse
.expr
)))
7731 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
7735 gfc_conv_expr_val (&rse
, expr
);
7737 gfc_add_block_to_block (&block
, &rse
.pre
);
7738 gfc_add_block_to_block (&block
, &lse
.pre
);
7740 lse
.string_length
= rse
.string_length
;
7742 deep_copy
= !se
->data_not_needed
7743 && (expr
->expr_type
== EXPR_VARIABLE
7744 || expr
->expr_type
== EXPR_ARRAY
);
7745 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
,
7747 gfc_add_expr_to_block (&block
, tmp
);
7749 /* Finish the copying loops. */
7750 gfc_trans_scalarizing_loops (&loop
, &block
);
7752 desc
= loop
.temp_ss
->info
->data
.array
.descriptor
;
7754 else if (expr
->expr_type
== EXPR_FUNCTION
&& !transposed_dims (ss
))
7756 desc
= info
->descriptor
;
7757 se
->string_length
= ss_info
->string_length
;
7761 /* We pass sections without copying to a temporary. Make a new
7762 descriptor and point it at the section we want. The loop variable
7763 limits will be the limits of the section.
7764 A function may decide to repack the array to speed up access, but
7765 we're not bothered about that here. */
7766 int dim
, ndim
, codim
;
7776 ndim
= info
->ref
? info
->ref
->u
.ar
.dimen
: ss
->dimen
;
7778 if (se
->want_coarray
)
7780 gfc_array_ref
*ar
= &info
->ref
->u
.ar
;
7782 codim
= gfc_get_corank (expr
);
7783 for (n
= 0; n
< codim
- 1; n
++)
7785 /* Make sure we are not lost somehow. */
7786 gcc_assert (ar
->dimen_type
[n
+ ndim
] == DIMEN_THIS_IMAGE
);
7788 /* Make sure the call to gfc_conv_section_startstride won't
7789 generate unnecessary code to calculate stride. */
7790 gcc_assert (ar
->stride
[n
+ ndim
] == NULL
);
7792 gfc_conv_section_startstride (&loop
.pre
, ss
, n
+ ndim
);
7793 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
7794 loop
.to
[n
+ loop
.dimen
] = info
->end
[n
+ ndim
];
7797 gcc_assert (n
== codim
- 1);
7798 evaluate_bound (&loop
.pre
, info
->start
, ar
->start
,
7799 info
->descriptor
, n
+ ndim
, true,
7800 ar
->as
->type
== AS_DEFERRED
);
7801 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
7806 /* Set the string_length for a character array. */
7807 if (expr
->ts
.type
== BT_CHARACTER
)
7809 if (deferred_array_component
)
7810 se
->string_length
= ss_info
->string_length
;
7812 se
->string_length
= gfc_get_expr_charlen (expr
);
7814 if (VAR_P (se
->string_length
)
7815 && expr
->ts
.u
.cl
->backend_decl
== se
->string_length
)
7816 tmp
= ss_info
->string_length
;
7818 tmp
= se
->string_length
;
7820 if (expr
->ts
.deferred
&& VAR_P (expr
->ts
.u
.cl
->backend_decl
))
7821 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
, tmp
);
7823 expr
->ts
.u
.cl
->backend_decl
= tmp
;
7826 /* If we have an array section, are assigning or passing an array
7827 section argument make sure that the lower bound is 1. References
7828 to the full array should otherwise keep the original bounds. */
7829 if (!info
->ref
|| info
->ref
->u
.ar
.type
!= AR_FULL
)
7830 for (dim
= 0; dim
< loop
.dimen
; dim
++)
7831 if (!integer_onep (loop
.from
[dim
]))
7833 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7834 gfc_array_index_type
, gfc_index_one_node
,
7836 loop
.to
[dim
] = fold_build2_loc (input_location
, PLUS_EXPR
,
7837 gfc_array_index_type
,
7839 loop
.from
[dim
] = gfc_index_one_node
;
7842 desc
= info
->descriptor
;
7843 if (se
->direct_byref
&& !se
->byref_noassign
)
7845 /* For pointer assignments we fill in the destination. */
7847 parmtype
= TREE_TYPE (parm
);
7851 /* Otherwise make a new one. */
7852 if (expr
->ts
.type
== BT_CHARACTER
)
7853 parmtype
= gfc_typenode_for_spec (&expr
->ts
);
7855 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
7857 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
, codim
,
7858 loop
.from
, loop
.to
, 0,
7859 GFC_ARRAY_UNKNOWN
, false);
7860 parm
= gfc_create_var (parmtype
, "parm");
7862 /* When expression is a class object, then add the class' handle to
7864 if (expr
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_VARIABLE
)
7866 gfc_expr
*class_expr
= gfc_find_and_cut_at_last_class_ref (expr
);
7869 /* class_expr can be NULL, when no _class ref is in expr.
7870 We must not fix this here with a gfc_fix_class_ref (). */
7873 gfc_init_se (&classse
, NULL
);
7874 gfc_conv_expr (&classse
, class_expr
);
7875 gfc_free_expr (class_expr
);
7877 gcc_assert (classse
.pre
.head
== NULL_TREE
7878 && classse
.post
.head
== NULL_TREE
);
7879 gfc_allocate_lang_decl (parm
);
7880 GFC_DECL_SAVED_DESCRIPTOR (parm
) = classse
.expr
;
7885 /* Set the span field. */
7886 tmp
= gfc_get_array_span (desc
, expr
);
7888 gfc_conv_descriptor_span_set (&loop
.pre
, parm
, tmp
);
7890 /* The following can be somewhat confusing. We have two
7891 descriptors, a new one and the original array.
7892 {parm, parmtype, dim} refer to the new one.
7893 {desc, type, n, loop} refer to the original, which maybe
7894 a descriptorless array.
7895 The bounds of the scalarization are the bounds of the section.
7896 We don't have to worry about numeric overflows when calculating
7897 the offsets because all elements are within the array data. */
7899 /* Set the dtype. */
7900 tmp
= gfc_conv_descriptor_dtype (parm
);
7901 if (se
->unlimited_polymorphic
)
7902 dtype
= gfc_get_dtype (TREE_TYPE (desc
), &loop
.dimen
);
7903 else if (expr
->ts
.type
== BT_ASSUMED
)
7906 if (DECL_LANG_SPECIFIC (tmp2
) && GFC_DECL_SAVED_DESCRIPTOR (tmp2
))
7907 tmp2
= GFC_DECL_SAVED_DESCRIPTOR (tmp2
);
7908 if (POINTER_TYPE_P (TREE_TYPE (tmp2
)))
7909 tmp2
= build_fold_indirect_ref_loc (input_location
, tmp2
);
7910 dtype
= gfc_conv_descriptor_dtype (tmp2
);
7913 dtype
= gfc_get_dtype (parmtype
);
7914 gfc_add_modify (&loop
.pre
, tmp
, dtype
);
7916 /* The 1st element in the section. */
7917 base
= gfc_index_zero_node
;
7919 /* The offset from the 1st element in the section. */
7920 offset
= gfc_index_zero_node
;
7922 for (n
= 0; n
< ndim
; n
++)
7924 stride
= gfc_conv_array_stride (desc
, n
);
7926 /* Work out the 1st element in the section. */
7928 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
7930 gcc_assert (info
->subscript
[n
]
7931 && info
->subscript
[n
]->info
->type
== GFC_SS_SCALAR
);
7932 start
= info
->subscript
[n
]->info
->data
.scalar
.value
;
7936 /* Evaluate and remember the start of the section. */
7937 start
= info
->start
[n
];
7938 stride
= gfc_evaluate_now (stride
, &loop
.pre
);
7941 tmp
= gfc_conv_array_lbound (desc
, n
);
7942 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
7944 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
7946 base
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (tmp
),
7950 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
7952 /* For elemental dimensions, we only need the 1st
7953 element in the section. */
7957 /* Vector subscripts need copying and are handled elsewhere. */
7959 gcc_assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
7961 /* look for the corresponding scalarizer dimension: dim. */
7962 for (dim
= 0; dim
< ndim
; dim
++)
7963 if (ss
->dim
[dim
] == n
)
7966 /* loop exited early: the DIM being looked for has been found. */
7967 gcc_assert (dim
< ndim
);
7969 /* Set the new lower bound. */
7970 from
= loop
.from
[dim
];
7973 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
7974 gfc_rank_cst
[dim
], from
);
7976 /* Set the new upper bound. */
7977 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
7978 gfc_rank_cst
[dim
], to
);
7980 /* Multiply the stride by the section stride to get the
7982 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
7983 gfc_array_index_type
,
7984 stride
, info
->stride
[n
]);
7986 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7987 TREE_TYPE (offset
), stride
, from
);
7988 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
7989 TREE_TYPE (offset
), offset
, tmp
);
7991 /* Store the new stride. */
7992 gfc_conv_descriptor_stride_set (&loop
.pre
, parm
,
7993 gfc_rank_cst
[dim
], stride
);
7996 for (n
= loop
.dimen
; n
< loop
.dimen
+ codim
; n
++)
7998 from
= loop
.from
[n
];
8000 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
8001 gfc_rank_cst
[n
], from
);
8002 if (n
< loop
.dimen
+ codim
- 1)
8003 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
8004 gfc_rank_cst
[n
], to
);
8007 if (se
->data_not_needed
)
8008 gfc_conv_descriptor_data_set (&loop
.pre
, parm
,
8009 gfc_index_zero_node
);
8011 /* Point the data pointer at the 1st element in the section. */
8012 gfc_get_dataptr_offset (&loop
.pre
, parm
, desc
, base
,
8013 subref_array_target
, expr
);
8015 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, offset
);
8020 /* For class arrays add the class tree into the saved descriptor to
8021 enable getting of _vptr and the like. */
8022 if (expr
->expr_type
== EXPR_VARIABLE
&& VAR_P (desc
)
8023 && IS_CLASS_ARRAY (expr
->symtree
->n
.sym
))
8025 gfc_allocate_lang_decl (desc
);
8026 GFC_DECL_SAVED_DESCRIPTOR (desc
) =
8027 DECL_LANG_SPECIFIC (expr
->symtree
->n
.sym
->backend_decl
) ?
8028 GFC_DECL_SAVED_DESCRIPTOR (expr
->symtree
->n
.sym
->backend_decl
)
8029 : expr
->symtree
->n
.sym
->backend_decl
;
8031 else if (expr
->expr_type
== EXPR_ARRAY
&& VAR_P (desc
)
8032 && IS_CLASS_ARRAY (expr
))
8035 gfc_allocate_lang_decl (desc
);
8036 tmp
= gfc_create_var (expr
->ts
.u
.derived
->backend_decl
, "class");
8037 GFC_DECL_SAVED_DESCRIPTOR (desc
) = tmp
;
8038 vtype
= gfc_class_vptr_get (tmp
);
8039 gfc_add_modify (&se
->pre
, vtype
,
8040 gfc_build_addr_expr (TREE_TYPE (vtype
),
8041 gfc_find_vtab (&expr
->ts
)->backend_decl
));
8043 if (!se
->direct_byref
|| se
->byref_noassign
)
8045 /* Get a pointer to the new descriptor. */
8046 if (se
->want_pointer
)
8047 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
8052 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
8053 gfc_add_block_to_block (&se
->post
, &loop
.post
);
8055 /* Cleanup the scalarizer. */
8056 gfc_cleanup_loop (&loop
);
8060 /* Calculate the array size (number of elements); if dim != NULL_TREE,
8061 return size for that dim (dim=0..rank-1; only for GFC_DESCRIPTOR_TYPE_P). */
8063 gfc_tree_array_size (stmtblock_t
*block
, tree desc
, gfc_expr
*expr
, tree dim
)
8065 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
8067 gcc_assert (dim
== NULL_TREE
);
8068 return GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc
));
8070 tree size
, tmp
, rank
= NULL_TREE
, cond
= NULL_TREE
;
8071 symbol_attribute attr
= gfc_expr_attr (expr
);
8072 gfc_array_spec
*as
= gfc_get_full_arrayspec_from_expr (expr
);
8073 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)));
8074 if ((!attr
.pointer
&& !attr
.allocatable
&& as
&& as
->type
== AS_ASSUMED_RANK
)
8078 rank
= fold_convert (signed_char_type_node
,
8079 gfc_conv_descriptor_rank (desc
));
8081 rank
= build_int_cst (signed_char_type_node
, expr
->rank
);
8084 if (dim
|| expr
->rank
== 1)
8087 dim
= gfc_index_zero_node
;
8088 tree ubound
= gfc_conv_descriptor_ubound_get (desc
, dim
);
8089 tree lbound
= gfc_conv_descriptor_lbound_get (desc
, dim
);
8091 size
= fold_build2_loc (input_location
, MINUS_EXPR
,
8092 gfc_array_index_type
, ubound
, lbound
);
8093 size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
8094 size
, gfc_index_one_node
);
8095 /* if (!allocatable && !pointer && assumed rank)
8096 size = (idx == rank && ubound[rank-1] == -1 ? -1 : size;
8098 size = max (0, size); */
8099 size
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
8100 size
, gfc_index_zero_node
);
8101 if (!attr
.pointer
&& !attr
.allocatable
8102 && as
&& as
->type
== AS_ASSUMED_RANK
)
8104 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, signed_char_type_node
,
8105 rank
, build_int_cst (signed_char_type_node
, 1));
8106 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
8107 fold_convert (signed_char_type_node
, dim
),
8109 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
8110 gfc_conv_descriptor_ubound_get (desc
, dim
),
8111 build_int_cst (gfc_array_index_type
, -1));
8112 cond
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, boolean_type_node
,
8114 tmp
= build_int_cst (gfc_array_index_type
, -1);
8115 size
= build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
8122 size
= gfc_create_var (gfc_array_index_type
, "size");
8123 gfc_add_modify (block
, size
, build_int_cst (TREE_TYPE (size
), 1));
8124 tree extent
= gfc_create_var (gfc_array_index_type
, "extent");
8126 stmtblock_t cond_block
, loop_body
;
8127 gfc_init_block (&cond_block
);
8128 gfc_init_block (&loop_body
);
8130 /* Loop: for (i = 0; i < rank; ++i). */
8131 tree idx
= gfc_create_var (signed_char_type_node
, "idx");
8133 /* #if (assumed-rank + !allocatable && !pointer)
8134 if (idx == rank - 1 && dim[idx].ubound == -1)
8138 extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1
8143 if (!attr
.pointer
&& !attr
.allocatable
&& as
&& as
->type
== AS_ASSUMED_RANK
)
8145 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, signed_char_type_node
,
8146 rank
, build_int_cst (signed_char_type_node
, 1));
8147 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
8149 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
8150 gfc_conv_descriptor_ubound_get (desc
, idx
),
8151 build_int_cst (gfc_array_index_type
, -1));
8152 cond
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, boolean_type_node
,
8155 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
8156 gfc_conv_descriptor_ubound_get (desc
, idx
),
8157 gfc_conv_descriptor_lbound_get (desc
, idx
));
8158 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
8159 tmp
, gfc_index_one_node
);
8160 gfc_add_modify (&cond_block
, extent
, tmp
);
8161 tmp
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
8162 extent
, gfc_index_zero_node
);
8163 tmp
= build3_v (COND_EXPR
, tmp
,
8164 fold_build2_loc (input_location
, MODIFY_EXPR
,
8165 gfc_array_index_type
,
8166 extent
, gfc_index_zero_node
),
8167 build_empty_stmt (input_location
));
8168 gfc_add_expr_to_block (&cond_block
, tmp
);
8169 tmp
= gfc_finish_block (&cond_block
);
8171 tmp
= build3_v (COND_EXPR
, cond
,
8172 fold_build2_loc (input_location
, MODIFY_EXPR
,
8173 gfc_array_index_type
, extent
,
8174 build_int_cst (gfc_array_index_type
, -1)),
8176 gfc_add_expr_to_block (&loop_body
, tmp
);
8177 /* size *= extent. */
8178 gfc_add_modify (&loop_body
, size
,
8179 fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8181 /* Generate loop. */
8182 gfc_simple_for_loop (block
, idx
, build_int_cst (TREE_TYPE (idx
), 0), rank
, LT_EXPR
,
8183 build_int_cst (TREE_TYPE (idx
), 1),
8184 gfc_finish_block (&loop_body
));
8188 /* Helper function for gfc_conv_array_parameter if array size needs to be
8192 array_parameter_size (stmtblock_t
*block
, tree desc
, gfc_expr
*expr
, tree
*size
)
8195 *size
= gfc_tree_array_size (block
, desc
, expr
, NULL
);
8196 elem
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
8197 *size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8198 *size
, fold_convert (gfc_array_index_type
, elem
));
8201 /* Helper function - return true if the argument is a pointer. */
8204 is_pointer (gfc_expr
*e
)
8208 if (e
->expr_type
!= EXPR_VARIABLE
|| e
->symtree
== NULL
)
8211 sym
= e
->symtree
->n
.sym
;
8215 return sym
->attr
.pointer
|| sym
->attr
.proc_pointer
;
8218 /* Convert an array for passing as an actual parameter. */
8221 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, bool g77
,
8222 const gfc_symbol
*fsym
, const char *proc_name
,
8227 tree tmp
= NULL_TREE
;
8229 tree parent
= DECL_CONTEXT (current_function_decl
);
8230 bool full_array_var
;
8231 bool this_array_result
;
8234 bool array_constructor
;
8235 bool good_allocatable
;
8236 bool ultimate_ptr_comp
;
8237 bool ultimate_alloc_comp
;
8242 ultimate_ptr_comp
= false;
8243 ultimate_alloc_comp
= false;
8245 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
8247 if (ref
->next
== NULL
)
8250 if (ref
->type
== REF_COMPONENT
)
8252 ultimate_ptr_comp
= ref
->u
.c
.component
->attr
.pointer
;
8253 ultimate_alloc_comp
= ref
->u
.c
.component
->attr
.allocatable
;
8257 full_array_var
= false;
8260 if (expr
->expr_type
== EXPR_VARIABLE
&& ref
&& !ultimate_ptr_comp
)
8261 full_array_var
= gfc_full_array_ref_p (ref
, &contiguous
);
8263 sym
= full_array_var
? expr
->symtree
->n
.sym
: NULL
;
8265 /* The symbol should have an array specification. */
8266 gcc_assert (!sym
|| sym
->as
|| ref
->u
.ar
.as
);
8268 if (expr
->expr_type
== EXPR_ARRAY
&& expr
->ts
.type
== BT_CHARACTER
)
8270 get_array_ctor_strlen (&se
->pre
, expr
->value
.constructor
, &tmp
);
8271 expr
->ts
.u
.cl
->backend_decl
= tmp
;
8272 se
->string_length
= tmp
;
8275 /* Is this the result of the enclosing procedure? */
8276 this_array_result
= (full_array_var
&& sym
->attr
.flavor
== FL_PROCEDURE
);
8277 if (this_array_result
8278 && (sym
->backend_decl
!= current_function_decl
)
8279 && (sym
->backend_decl
!= parent
))
8280 this_array_result
= false;
8282 /* Passing address of the array if it is not pointer or assumed-shape. */
8283 if (full_array_var
&& g77
&& !this_array_result
8284 && sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
8286 tmp
= gfc_get_symbol_decl (sym
);
8288 if (sym
->ts
.type
== BT_CHARACTER
)
8289 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
8291 if (!sym
->attr
.pointer
8293 && sym
->as
->type
!= AS_ASSUMED_SHAPE
8294 && sym
->as
->type
!= AS_DEFERRED
8295 && sym
->as
->type
!= AS_ASSUMED_RANK
8296 && !sym
->attr
.allocatable
)
8298 /* Some variables are declared directly, others are declared as
8299 pointers and allocated on the heap. */
8300 if (sym
->attr
.dummy
|| POINTER_TYPE_P (TREE_TYPE (tmp
)))
8303 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
8305 array_parameter_size (&se
->pre
, tmp
, expr
, size
);
8309 if (sym
->attr
.allocatable
)
8311 if (sym
->attr
.dummy
|| sym
->attr
.result
)
8313 gfc_conv_expr_descriptor (se
, expr
);
8317 array_parameter_size (&se
->pre
, tmp
, expr
, size
);
8318 se
->expr
= gfc_conv_array_data (tmp
);
8323 /* A convenient reduction in scope. */
8324 contiguous
= g77
&& !this_array_result
&& contiguous
;
8326 /* There is no need to pack and unpack the array, if it is contiguous
8327 and not a deferred- or assumed-shape array, or if it is simply
8329 no_pack
= ((sym
&& sym
->as
8330 && !sym
->attr
.pointer
8331 && sym
->as
->type
!= AS_DEFERRED
8332 && sym
->as
->type
!= AS_ASSUMED_RANK
8333 && sym
->as
->type
!= AS_ASSUMED_SHAPE
)
8335 (ref
&& ref
->u
.ar
.as
8336 && ref
->u
.ar
.as
->type
!= AS_DEFERRED
8337 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_RANK
8338 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_SHAPE
)
8340 gfc_is_simply_contiguous (expr
, false, true));
8342 no_pack
= contiguous
&& no_pack
;
8344 /* If we have an EXPR_OP or a function returning an explicit-shaped
8345 or allocatable array, an array temporary will be generated which
8346 does not need to be packed / unpacked if passed to an
8347 explicit-shape dummy array. */
8351 if (expr
->expr_type
== EXPR_OP
)
8353 else if (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.esym
)
8355 gfc_symbol
*result
= expr
->value
.function
.esym
->result
;
8356 if (result
->attr
.dimension
8357 && (result
->as
->type
== AS_EXPLICIT
8358 || result
->attr
.allocatable
8359 || result
->attr
.contiguous
))
8364 /* Array constructors are always contiguous and do not need packing. */
8365 array_constructor
= g77
&& !this_array_result
&& expr
->expr_type
== EXPR_ARRAY
;
8367 /* Same is true of contiguous sections from allocatable variables. */
8368 good_allocatable
= contiguous
8370 && expr
->symtree
->n
.sym
->attr
.allocatable
;
8372 /* Or ultimate allocatable components. */
8373 ultimate_alloc_comp
= contiguous
&& ultimate_alloc_comp
;
8375 if (no_pack
|| array_constructor
|| good_allocatable
|| ultimate_alloc_comp
)
8377 gfc_conv_expr_descriptor (se
, expr
);
8378 /* Deallocate the allocatable components of structures that are
8380 if ((expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
)
8381 && expr
->ts
.u
.derived
->attr
.alloc_comp
8382 && expr
->expr_type
!= EXPR_VARIABLE
)
8384 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, se
->expr
, expr
->rank
);
8386 /* The components shall be deallocated before their containing entity. */
8387 gfc_prepend_expr_to_block (&se
->post
, tmp
);
8389 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->expr_type
!= EXPR_FUNCTION
)
8390 se
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
8392 array_parameter_size (&se
->pre
, se
->expr
, expr
, size
);
8393 se
->expr
= gfc_conv_array_data (se
->expr
);
8397 if (this_array_result
)
8399 /* Result of the enclosing function. */
8400 gfc_conv_expr_descriptor (se
, expr
);
8402 array_parameter_size (&se
->pre
, se
->expr
, expr
, size
);
8403 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
8405 if (g77
&& TREE_TYPE (TREE_TYPE (se
->expr
)) != NULL_TREE
8406 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
8407 se
->expr
= gfc_conv_array_data (build_fold_indirect_ref_loc (input_location
,
8414 /* Every other type of array. */
8415 se
->want_pointer
= 1;
8416 gfc_conv_expr_descriptor (se
, expr
);
8419 array_parameter_size (&se
->pre
,
8420 build_fold_indirect_ref_loc (input_location
,
8425 /* Deallocate the allocatable components of structures that are
8426 not variable, for descriptorless arguments.
8427 Arguments with a descriptor are handled in gfc_conv_procedure_call. */
8428 if (g77
&& (expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
)
8429 && expr
->ts
.u
.derived
->attr
.alloc_comp
8430 && expr
->expr_type
!= EXPR_VARIABLE
)
8432 tmp
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
8433 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
, expr
->rank
);
8435 /* The components shall be deallocated before their containing entity. */
8436 gfc_prepend_expr_to_block (&se
->post
, tmp
);
8439 if (g77
|| (fsym
&& fsym
->attr
.contiguous
8440 && !gfc_is_simply_contiguous (expr
, false, true)))
8442 tree origptr
= NULL_TREE
;
8446 /* For contiguous arrays, save the original value of the descriptor. */
8449 origptr
= gfc_create_var (pvoid_type_node
, "origptr");
8450 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
8451 tmp
= gfc_conv_array_data (tmp
);
8452 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8453 TREE_TYPE (origptr
), origptr
,
8454 fold_convert (TREE_TYPE (origptr
), tmp
));
8455 gfc_add_expr_to_block (&se
->pre
, tmp
);
8458 /* Repack the array. */
8459 if (warn_array_temporaries
)
8462 gfc_warning (OPT_Warray_temporaries
,
8463 "Creating array temporary at %L for argument %qs",
8464 &expr
->where
, fsym
->name
);
8466 gfc_warning (OPT_Warray_temporaries
,
8467 "Creating array temporary at %L", &expr
->where
);
8470 /* When optmizing, we can use gfc_conv_subref_array_arg for
8471 making the packing and unpacking operation visible to the
8474 if (g77
&& flag_inline_arg_packing
&& expr
->expr_type
== EXPR_VARIABLE
8475 && !is_pointer (expr
) && ! gfc_has_dimen_vector_ref (expr
)
8476 && !(expr
->symtree
->n
.sym
->as
8477 && expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_RANK
)
8478 && (fsym
== NULL
|| fsym
->ts
.type
!= BT_ASSUMED
))
8480 gfc_conv_subref_array_arg (se
, expr
, g77
,
8481 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
8482 false, fsym
, proc_name
, sym
, true);
8486 ptr
= build_call_expr_loc (input_location
,
8487 gfor_fndecl_in_pack
, 1, desc
);
8489 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
8491 tmp
= gfc_conv_expr_present (sym
);
8492 ptr
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
8493 tmp
, fold_convert (TREE_TYPE (se
->expr
), ptr
),
8494 fold_convert (TREE_TYPE (se
->expr
), null_pointer_node
));
8497 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
8499 /* Use the packed data for the actual argument, except for contiguous arrays,
8500 where the descriptor's data component is set. */
8505 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
8507 gfc_ss
* ss
= gfc_walk_expr (expr
);
8508 if (!transposed_dims (ss
))
8509 gfc_conv_descriptor_data_set (&se
->pre
, tmp
, ptr
);
8512 tree old_field
, new_field
;
8514 /* The original descriptor has transposed dims so we can't reuse
8515 it directly; we have to create a new one. */
8516 tree old_desc
= tmp
;
8517 tree new_desc
= gfc_create_var (TREE_TYPE (old_desc
), "arg_desc");
8519 old_field
= gfc_conv_descriptor_dtype (old_desc
);
8520 new_field
= gfc_conv_descriptor_dtype (new_desc
);
8521 gfc_add_modify (&se
->pre
, new_field
, old_field
);
8523 old_field
= gfc_conv_descriptor_offset (old_desc
);
8524 new_field
= gfc_conv_descriptor_offset (new_desc
);
8525 gfc_add_modify (&se
->pre
, new_field
, old_field
);
8527 for (int i
= 0; i
< expr
->rank
; i
++)
8529 old_field
= gfc_conv_descriptor_dimension (old_desc
,
8530 gfc_rank_cst
[get_array_ref_dim_for_loop_dim (ss
, i
)]);
8531 new_field
= gfc_conv_descriptor_dimension (new_desc
,
8533 gfc_add_modify (&se
->pre
, new_field
, old_field
);
8536 if (flag_coarray
== GFC_FCOARRAY_LIB
8537 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (old_desc
))
8538 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (old_desc
))
8539 == GFC_ARRAY_ALLOCATABLE
)
8541 old_field
= gfc_conv_descriptor_token (old_desc
);
8542 new_field
= gfc_conv_descriptor_token (new_desc
);
8543 gfc_add_modify (&se
->pre
, new_field
, old_field
);
8546 gfc_conv_descriptor_data_set (&se
->pre
, new_desc
, ptr
);
8547 se
->expr
= gfc_build_addr_expr (NULL_TREE
, new_desc
);
8552 if (gfc_option
.rtcheck
& GFC_RTCHECK_ARRAY_TEMPS
)
8556 if (fsym
&& proc_name
)
8557 msg
= xasprintf ("An array temporary was created for argument "
8558 "'%s' of procedure '%s'", fsym
->name
, proc_name
);
8560 msg
= xasprintf ("An array temporary was created");
8562 tmp
= build_fold_indirect_ref_loc (input_location
,
8564 tmp
= gfc_conv_array_data (tmp
);
8565 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8566 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
8568 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
8569 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8571 gfc_conv_expr_present (sym
), tmp
);
8573 gfc_trans_runtime_check (false, true, tmp
, &se
->pre
,
8578 gfc_start_block (&block
);
8580 /* Copy the data back. */
8581 if (fsym
== NULL
|| fsym
->attr
.intent
!= INTENT_IN
)
8583 tmp
= build_call_expr_loc (input_location
,
8584 gfor_fndecl_in_unpack
, 2, desc
, ptr
);
8585 gfc_add_expr_to_block (&block
, tmp
);
8588 /* Free the temporary. */
8589 tmp
= gfc_call_free (ptr
);
8590 gfc_add_expr_to_block (&block
, tmp
);
8592 stmt
= gfc_finish_block (&block
);
8594 gfc_init_block (&block
);
8595 /* Only if it was repacked. This code needs to be executed before the
8596 loop cleanup code. */
8597 tmp
= build_fold_indirect_ref_loc (input_location
,
8599 tmp
= gfc_conv_array_data (tmp
);
8600 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8601 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
8603 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
8604 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8606 gfc_conv_expr_present (sym
), tmp
);
8608 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
8610 gfc_add_expr_to_block (&block
, tmp
);
8611 gfc_add_block_to_block (&block
, &se
->post
);
8613 gfc_init_block (&se
->post
);
8615 /* Reset the descriptor pointer. */
8618 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
8619 gfc_conv_descriptor_data_set (&se
->post
, tmp
, origptr
);
8622 gfc_add_block_to_block (&se
->post
, &block
);
8627 /* This helper function calculates the size in words of a full array. */
8630 gfc_full_array_size (stmtblock_t
*block
, tree decl
, int rank
)
8635 idx
= gfc_rank_cst
[rank
- 1];
8636 nelems
= gfc_conv_descriptor_ubound_get (decl
, idx
);
8637 tmp
= gfc_conv_descriptor_lbound_get (decl
, idx
);
8638 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
8640 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
8641 tmp
, gfc_index_one_node
);
8642 tmp
= gfc_evaluate_now (tmp
, block
);
8644 nelems
= gfc_conv_descriptor_stride_get (decl
, idx
);
8645 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8647 return gfc_evaluate_now (tmp
, block
);
8651 /* Allocate dest to the same size as src, and copy src -> dest.
8652 If no_malloc is set, only the copy is done. */
8655 duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
8656 bool no_malloc
, bool no_memcpy
, tree str_sz
,
8657 tree add_when_allocated
)
8666 /* If the source is null, set the destination to null. Then,
8667 allocate memory to the destination. */
8668 gfc_init_block (&block
);
8670 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
8672 gfc_add_modify (&block
, dest
, fold_convert (type
, null_pointer_node
));
8673 null_data
= gfc_finish_block (&block
);
8675 gfc_init_block (&block
);
8676 if (str_sz
!= NULL_TREE
)
8679 size
= TYPE_SIZE_UNIT (TREE_TYPE (type
));
8683 tmp
= gfc_call_malloc (&block
, type
, size
);
8684 gfc_add_modify (&block
, dest
, fold_convert (type
, tmp
));
8689 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8690 tmp
= build_call_expr_loc (input_location
, tmp
, 3, dest
, src
,
8691 fold_convert (size_type_node
, size
));
8692 gfc_add_expr_to_block (&block
, tmp
);
8697 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
8698 null_data
= gfc_finish_block (&block
);
8700 gfc_init_block (&block
);
8702 nelems
= gfc_full_array_size (&block
, src
, rank
);
8704 nelems
= gfc_index_one_node
;
8706 if (str_sz
!= NULL_TREE
)
8707 tmp
= fold_convert (gfc_array_index_type
, str_sz
);
8709 tmp
= fold_convert (gfc_array_index_type
,
8710 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
8711 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8715 tmp
= TREE_TYPE (gfc_conv_descriptor_data_get (src
));
8716 tmp
= gfc_call_malloc (&block
, tmp
, size
);
8717 gfc_conv_descriptor_data_set (&block
, dest
, tmp
);
8720 /* We know the temporary and the value will be the same length,
8721 so can use memcpy. */
8724 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8725 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
8726 gfc_conv_descriptor_data_get (dest
),
8727 gfc_conv_descriptor_data_get (src
),
8728 fold_convert (size_type_node
, size
));
8729 gfc_add_expr_to_block (&block
, tmp
);
8733 gfc_add_expr_to_block (&block
, add_when_allocated
);
8734 tmp
= gfc_finish_block (&block
);
8736 /* Null the destination if the source is null; otherwise do
8737 the allocate and copy. */
8738 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src
)))
8741 null_cond
= gfc_conv_descriptor_data_get (src
);
8743 null_cond
= convert (pvoid_type_node
, null_cond
);
8744 null_cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8745 null_cond
, null_pointer_node
);
8746 return build3_v (COND_EXPR
, null_cond
, tmp
, null_data
);
8750 /* Allocate dest to the same size as src, and copy data src -> dest. */
8753 gfc_duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
8754 tree add_when_allocated
)
8756 return duplicate_allocatable (dest
, src
, type
, rank
, false, false,
8757 NULL_TREE
, add_when_allocated
);
8761 /* Copy data src -> dest. */
8764 gfc_copy_allocatable_data (tree dest
, tree src
, tree type
, int rank
)
8766 return duplicate_allocatable (dest
, src
, type
, rank
, true, false,
8767 NULL_TREE
, NULL_TREE
);
8770 /* Allocate dest to the same size as src, but don't copy anything. */
8773 gfc_duplicate_allocatable_nocopy (tree dest
, tree src
, tree type
, int rank
)
8775 return duplicate_allocatable (dest
, src
, type
, rank
, false, true,
8776 NULL_TREE
, NULL_TREE
);
8781 duplicate_allocatable_coarray (tree dest
, tree dest_tok
, tree src
,
8782 tree type
, int rank
)
8789 stmtblock_t block
, globalblock
;
8791 /* If the source is null, set the destination to null. Then,
8792 allocate memory to the destination. */
8793 gfc_init_block (&block
);
8794 gfc_init_block (&globalblock
);
8796 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
8799 symbol_attribute attr
;
8802 gfc_init_se (&se
, NULL
);
8803 gfc_clear_attr (&attr
);
8804 attr
.allocatable
= 1;
8805 dummy_desc
= gfc_conv_scalar_to_descriptor (&se
, dest
, attr
);
8806 gfc_add_block_to_block (&globalblock
, &se
.pre
);
8807 size
= TYPE_SIZE_UNIT (TREE_TYPE (type
));
8809 gfc_add_modify (&block
, dest
, fold_convert (type
, null_pointer_node
));
8810 gfc_allocate_using_caf_lib (&block
, dummy_desc
, size
,
8811 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8812 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8813 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
8814 null_data
= gfc_finish_block (&block
);
8816 gfc_init_block (&block
);
8818 gfc_allocate_using_caf_lib (&block
, dummy_desc
,
8819 fold_convert (size_type_node
, size
),
8820 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8821 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8822 GFC_CAF_COARRAY_ALLOC
);
8824 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8825 tmp
= build_call_expr_loc (input_location
, tmp
, 3, dest
, src
,
8826 fold_convert (size_type_node
, size
));
8827 gfc_add_expr_to_block (&block
, tmp
);
8831 /* Set the rank or unitialized memory access may be reported. */
8832 tmp
= gfc_conv_descriptor_rank (dest
);
8833 gfc_add_modify (&globalblock
, tmp
, build_int_cst (TREE_TYPE (tmp
), rank
));
8836 nelems
= gfc_full_array_size (&block
, src
, rank
);
8838 nelems
= integer_one_node
;
8840 tmp
= fold_convert (size_type_node
,
8841 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
8842 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
8843 fold_convert (size_type_node
, nelems
), tmp
);
8845 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
8846 gfc_allocate_using_caf_lib (&block
, dest
, fold_convert (size_type_node
,
8848 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8849 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8850 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
8851 null_data
= gfc_finish_block (&block
);
8853 gfc_init_block (&block
);
8854 gfc_allocate_using_caf_lib (&block
, dest
,
8855 fold_convert (size_type_node
, size
),
8856 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8857 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8858 GFC_CAF_COARRAY_ALLOC
);
8860 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8861 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
8862 gfc_conv_descriptor_data_get (dest
),
8863 gfc_conv_descriptor_data_get (src
),
8864 fold_convert (size_type_node
, size
));
8865 gfc_add_expr_to_block (&block
, tmp
);
8868 tmp
= gfc_finish_block (&block
);
8870 /* Null the destination if the source is null; otherwise do
8871 the register and copy. */
8872 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src
)))
8875 null_cond
= gfc_conv_descriptor_data_get (src
);
8877 null_cond
= convert (pvoid_type_node
, null_cond
);
8878 null_cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8879 null_cond
, null_pointer_node
);
8880 gfc_add_expr_to_block (&globalblock
, build3_v (COND_EXPR
, null_cond
, tmp
,
8882 return gfc_finish_block (&globalblock
);
8886 /* Helper function to abstract whether coarray processing is enabled. */
8889 caf_enabled (int caf_mode
)
8891 return (caf_mode
& GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
)
8892 == GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
;
8896 /* Helper function to abstract whether coarray processing is enabled
8897 and we are in a derived type coarray. */
8900 caf_in_coarray (int caf_mode
)
8902 static const int pat
= GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
8903 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
;
8904 return (caf_mode
& pat
) == pat
;
8908 /* Helper function to abstract whether coarray is to deallocate only. */
8911 gfc_caf_is_dealloc_only (int caf_mode
)
8913 return (caf_mode
& GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY
)
8914 == GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY
;
8918 /* Recursively traverse an object of derived type, generating code to
8919 deallocate, nullify or copy allocatable components. This is the work horse
8920 function for the functions named in this enum. */
8922 enum {DEALLOCATE_ALLOC_COMP
= 1, NULLIFY_ALLOC_COMP
,
8923 COPY_ALLOC_COMP
, COPY_ONLY_ALLOC_COMP
, REASSIGN_CAF_COMP
,
8924 ALLOCATE_PDT_COMP
, DEALLOCATE_PDT_COMP
, CHECK_PDT_DUMMY
,
8927 static gfc_actual_arglist
*pdt_param_list
;
8930 structure_alloc_comps (gfc_symbol
* der_type
, tree decl
,
8931 tree dest
, int rank
, int purpose
, int caf_mode
,
8932 gfc_co_subroutines_args
*args
)
8936 stmtblock_t fnblock
;
8937 stmtblock_t loopbody
;
8938 stmtblock_t tmpblock
;
8949 tree null_cond
= NULL_TREE
;
8950 tree add_when_allocated
;
8951 tree dealloc_fndecl
;
8955 symbol_attribute
*attr
;
8956 bool deallocate_called
;
8958 gfc_init_block (&fnblock
);
8960 decl_type
= TREE_TYPE (decl
);
8962 if ((POINTER_TYPE_P (decl_type
))
8963 || (TREE_CODE (decl_type
) == REFERENCE_TYPE
&& rank
== 0))
8965 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
8966 /* Deref dest in sync with decl, but only when it is not NULL. */
8968 dest
= build_fold_indirect_ref_loc (input_location
, dest
);
8970 /* Update the decl_type because it got dereferenced. */
8971 decl_type
= TREE_TYPE (decl
);
8974 /* If this is an array of derived types with allocatable components
8975 build a loop and recursively call this function. */
8976 if (TREE_CODE (decl_type
) == ARRAY_TYPE
8977 || (GFC_DESCRIPTOR_TYPE_P (decl_type
) && rank
!= 0))
8979 tmp
= gfc_conv_array_data (decl
);
8980 var
= build_fold_indirect_ref_loc (input_location
, tmp
);
8982 /* Get the number of elements - 1 and set the counter. */
8983 if (GFC_DESCRIPTOR_TYPE_P (decl_type
))
8985 /* Use the descriptor for an allocatable array. Since this
8986 is a full array reference, we only need the descriptor
8987 information from dimension = rank. */
8988 tmp
= gfc_full_array_size (&fnblock
, decl
, rank
);
8989 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8990 gfc_array_index_type
, tmp
,
8991 gfc_index_one_node
);
8993 null_cond
= gfc_conv_descriptor_data_get (decl
);
8994 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
8995 logical_type_node
, null_cond
,
8996 build_int_cst (TREE_TYPE (null_cond
), 0));
9000 /* Otherwise use the TYPE_DOMAIN information. */
9001 tmp
= array_type_nelts (decl_type
);
9002 tmp
= fold_convert (gfc_array_index_type
, tmp
);
9005 /* Remember that this is, in fact, the no. of elements - 1. */
9006 nelems
= gfc_evaluate_now (tmp
, &fnblock
);
9007 index
= gfc_create_var (gfc_array_index_type
, "S");
9009 /* Build the body of the loop. */
9010 gfc_init_block (&loopbody
);
9012 vref
= gfc_build_array_ref (var
, index
, NULL
);
9014 if (purpose
== COPY_ALLOC_COMP
|| purpose
== COPY_ONLY_ALLOC_COMP
)
9016 tmp
= build_fold_indirect_ref_loc (input_location
,
9017 gfc_conv_array_data (dest
));
9018 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
9019 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
,
9020 COPY_ALLOC_COMP
, caf_mode
, args
);
9023 tmp
= structure_alloc_comps (der_type
, vref
, NULL_TREE
, rank
, purpose
,
9026 gfc_add_expr_to_block (&loopbody
, tmp
);
9028 /* Build the loop and return. */
9029 gfc_init_loopinfo (&loop
);
9031 loop
.from
[0] = gfc_index_zero_node
;
9032 loop
.loopvar
[0] = index
;
9033 loop
.to
[0] = nelems
;
9034 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
9035 gfc_add_block_to_block (&fnblock
, &loop
.pre
);
9037 tmp
= gfc_finish_block (&fnblock
);
9038 /* When copying allocateable components, the above implements the
9039 deep copy. Nevertheless is a deep copy only allowed, when the current
9040 component is allocated, for which code will be generated in
9041 gfc_duplicate_allocatable (), where the deep copy code is just added
9042 into the if's body, by adding tmp (the deep copy code) as last
9043 argument to gfc_duplicate_allocatable (). */
9044 if (purpose
== COPY_ALLOC_COMP
9045 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
9046 tmp
= gfc_duplicate_allocatable (dest
, decl
, decl_type
, rank
,
9048 else if (null_cond
!= NULL_TREE
)
9049 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
9050 build_empty_stmt (input_location
));
9055 if (purpose
== DEALLOCATE_ALLOC_COMP
&& der_type
->attr
.pdt_type
)
9057 tmp
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9058 DEALLOCATE_PDT_COMP
, 0, args
);
9059 gfc_add_expr_to_block (&fnblock
, tmp
);
9061 else if (purpose
== ALLOCATE_PDT_COMP
&& der_type
->attr
.alloc_comp
)
9063 tmp
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9064 NULLIFY_ALLOC_COMP
, 0, args
);
9065 gfc_add_expr_to_block (&fnblock
, tmp
);
9068 /* Otherwise, act on the components or recursively call self to
9069 act on a chain of components. */
9070 for (c
= der_type
->components
; c
; c
= c
->next
)
9072 bool cmp_has_alloc_comps
= (c
->ts
.type
== BT_DERIVED
9073 || c
->ts
.type
== BT_CLASS
)
9074 && c
->ts
.u
.derived
->attr
.alloc_comp
;
9075 bool same_type
= (c
->ts
.type
== BT_DERIVED
&& der_type
== c
->ts
.u
.derived
)
9076 || (c
->ts
.type
== BT_CLASS
&& der_type
== CLASS_DATA (c
)->ts
.u
.derived
);
9078 bool is_pdt_type
= c
->ts
.type
== BT_DERIVED
9079 && c
->ts
.u
.derived
->attr
.pdt_type
;
9081 cdecl = c
->backend_decl
;
9082 ctype
= TREE_TYPE (cdecl);
9087 case BCAST_ALLOC_COMP
:
9091 stmtblock_t derived_type_block
;
9093 gfc_init_block (&tmpblock
);
9095 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9096 decl
, cdecl, NULL_TREE
);
9098 /* Shortcut to get the attributes of the component. */
9099 if (c
->ts
.type
== BT_CLASS
)
9101 attr
= &CLASS_DATA (c
)->attr
;
9102 if (attr
->class_pointer
)
9112 /* Do not broadcast a caf_token. These are local to the image. */
9113 if (attr
->caf_token
)
9116 add_when_allocated
= NULL_TREE
;
9117 if (cmp_has_alloc_comps
9118 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
)
9120 if (c
->ts
.type
== BT_CLASS
)
9122 rank
= CLASS_DATA (c
)->as
? CLASS_DATA (c
)->as
->rank
: 0;
9124 = structure_alloc_comps (CLASS_DATA (c
)->ts
.u
.derived
,
9125 comp
, NULL_TREE
, rank
, purpose
,
9130 rank
= c
->as
? c
->as
->rank
: 0;
9131 add_when_allocated
= structure_alloc_comps (c
->ts
.u
.derived
,
9138 gfc_init_block (&derived_type_block
);
9139 if (add_when_allocated
)
9140 gfc_add_expr_to_block (&derived_type_block
, add_when_allocated
);
9141 tmp
= gfc_finish_block (&derived_type_block
);
9142 gfc_add_expr_to_block (&tmpblock
, tmp
);
9144 /* Convert the component into a rank 1 descriptor type. */
9145 if (attr
->dimension
)
9147 tmp
= gfc_get_element_type (TREE_TYPE (comp
));
9148 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp
)))
9149 ubound
= GFC_TYPE_ARRAY_SIZE (TREE_TYPE (comp
));
9151 ubound
= gfc_full_array_size (&tmpblock
, comp
,
9152 c
->ts
.type
== BT_CLASS
9153 ? CLASS_DATA (c
)->as
->rank
9158 tmp
= TREE_TYPE (comp
);
9159 ubound
= build_int_cst (gfc_array_index_type
, 1);
9162 /* Treat strings like arrays. Or the other way around, do not
9163 * generate an additional array layer for scalar components. */
9164 if (attr
->dimension
|| c
->ts
.type
== BT_CHARACTER
)
9166 cdesc
= gfc_get_array_type_bounds (tmp
, 1, 0, &gfc_index_one_node
,
9168 GFC_ARRAY_ALLOCATABLE
, false);
9170 cdesc
= gfc_create_var (cdesc
, "cdesc");
9171 DECL_ARTIFICIAL (cdesc
) = 1;
9173 gfc_add_modify (&tmpblock
, gfc_conv_descriptor_dtype (cdesc
),
9174 gfc_get_dtype_rank_type (1, tmp
));
9175 gfc_conv_descriptor_lbound_set (&tmpblock
, cdesc
,
9176 gfc_index_zero_node
,
9177 gfc_index_one_node
);
9178 gfc_conv_descriptor_stride_set (&tmpblock
, cdesc
,
9179 gfc_index_zero_node
,
9180 gfc_index_one_node
);
9181 gfc_conv_descriptor_ubound_set (&tmpblock
, cdesc
,
9182 gfc_index_zero_node
, ubound
);
9185 /* Prevent warning. */
9188 if (attr
->dimension
)
9190 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp
)))
9191 comp
= gfc_conv_descriptor_data_get (comp
);
9193 comp
= gfc_build_addr_expr (NULL_TREE
, comp
);
9199 gfc_init_se (&se
, NULL
);
9201 comp
= gfc_conv_scalar_to_descriptor (&se
, comp
,
9202 c
->ts
.type
== BT_CLASS
9203 ? CLASS_DATA (c
)->attr
9205 if (c
->ts
.type
== BT_CHARACTER
)
9206 comp
= gfc_build_addr_expr (NULL_TREE
, comp
);
9207 gfc_add_block_to_block (&tmpblock
, &se
.pre
);
9210 if (attr
->dimension
|| c
->ts
.type
== BT_CHARACTER
)
9211 gfc_conv_descriptor_data_set (&tmpblock
, cdesc
, comp
);
9217 fndecl
= build_call_expr_loc (input_location
,
9218 gfor_fndecl_co_broadcast
, 5,
9219 gfc_build_addr_expr (pvoid_type_node
,cdesc
),
9221 null_pointer_node
, null_pointer_node
,
9224 gfc_add_expr_to_block (&tmpblock
, fndecl
);
9225 gfc_add_block_to_block (&fnblock
, &tmpblock
);
9229 case DEALLOCATE_ALLOC_COMP
:
9231 gfc_init_block (&tmpblock
);
9233 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9234 decl
, cdecl, NULL_TREE
);
9236 /* Shortcut to get the attributes of the component. */
9237 if (c
->ts
.type
== BT_CLASS
)
9239 attr
= &CLASS_DATA (c
)->attr
;
9240 if (attr
->class_pointer
)
9250 if ((c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
)
9251 || (c
->ts
.type
== BT_CLASS
&& !CLASS_DATA (c
)->attr
.class_pointer
))
9252 /* Call the finalizer, which will free the memory and nullify the
9253 pointer of an array. */
9254 deallocate_called
= gfc_add_comp_finalizer_call (&tmpblock
, comp
, c
,
9255 caf_enabled (caf_mode
))
9258 deallocate_called
= false;
9260 /* Add the _class ref for classes. */
9261 if (c
->ts
.type
== BT_CLASS
&& attr
->allocatable
)
9262 comp
= gfc_class_data_get (comp
);
9264 add_when_allocated
= NULL_TREE
;
9265 if (cmp_has_alloc_comps
9266 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
9268 && !deallocate_called
)
9270 /* Add checked deallocation of the components. This code is
9271 obviously added because the finalizer is not trusted to free
9273 if (c
->ts
.type
== BT_CLASS
)
9275 rank
= CLASS_DATA (c
)->as
? CLASS_DATA (c
)->as
->rank
: 0;
9277 = structure_alloc_comps (CLASS_DATA (c
)->ts
.u
.derived
,
9278 comp
, NULL_TREE
, rank
, purpose
,
9283 rank
= c
->as
? c
->as
->rank
: 0;
9284 add_when_allocated
= structure_alloc_comps (c
->ts
.u
.derived
,
9291 if (attr
->allocatable
&& !same_type
9292 && (!attr
->codimension
|| caf_enabled (caf_mode
)))
9294 /* Handle all types of components besides components of the
9295 same_type as the current one, because those would create an
9298 = (caf_in_coarray (caf_mode
) || attr
->codimension
)
9299 ? (gfc_caf_is_dealloc_only (caf_mode
)
9300 ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
9301 : GFC_CAF_COARRAY_DEREGISTER
)
9302 : GFC_CAF_COARRAY_NOCOARRAY
;
9304 caf_token
= NULL_TREE
;
9305 /* Coarray components are handled directly by
9306 deallocate_with_status. */
9307 if (!attr
->codimension
9308 && caf_dereg_mode
!= GFC_CAF_COARRAY_NOCOARRAY
)
9311 caf_token
= fold_build3_loc (input_location
, COMPONENT_REF
,
9312 TREE_TYPE (c
->caf_token
),
9313 decl
, c
->caf_token
, NULL_TREE
);
9314 else if (attr
->dimension
&& !attr
->proc_pointer
)
9315 caf_token
= gfc_conv_descriptor_token (comp
);
9317 if (attr
->dimension
&& !attr
->codimension
&& !attr
->proc_pointer
)
9318 /* When this is an array but not in conjunction with a coarray
9319 then add the data-ref. For coarray'ed arrays the data-ref
9320 is added by deallocate_with_status. */
9321 comp
= gfc_conv_descriptor_data_get (comp
);
9323 tmp
= gfc_deallocate_with_status (comp
, NULL_TREE
, NULL_TREE
,
9324 NULL_TREE
, NULL_TREE
, true,
9325 NULL
, caf_dereg_mode
,
9326 add_when_allocated
, caf_token
);
9328 gfc_add_expr_to_block (&tmpblock
, tmp
);
9330 else if (attr
->allocatable
&& !attr
->codimension
9331 && !deallocate_called
)
9333 /* Case of recursive allocatable derived types. */
9337 stmtblock_t dealloc_block
;
9339 gfc_init_block (&dealloc_block
);
9340 if (add_when_allocated
)
9341 gfc_add_expr_to_block (&dealloc_block
, add_when_allocated
);
9343 /* Convert the component into a rank 1 descriptor type. */
9344 if (attr
->dimension
)
9346 tmp
= gfc_get_element_type (TREE_TYPE (comp
));
9347 ubound
= gfc_full_array_size (&dealloc_block
, comp
,
9348 c
->ts
.type
== BT_CLASS
9349 ? CLASS_DATA (c
)->as
->rank
9354 tmp
= TREE_TYPE (comp
);
9355 ubound
= build_int_cst (gfc_array_index_type
, 1);
9358 cdesc
= gfc_get_array_type_bounds (tmp
, 1, 0, &gfc_index_one_node
,
9360 GFC_ARRAY_ALLOCATABLE
, false);
9362 cdesc
= gfc_create_var (cdesc
, "cdesc");
9363 DECL_ARTIFICIAL (cdesc
) = 1;
9365 gfc_add_modify (&dealloc_block
, gfc_conv_descriptor_dtype (cdesc
),
9366 gfc_get_dtype_rank_type (1, tmp
));
9367 gfc_conv_descriptor_lbound_set (&dealloc_block
, cdesc
,
9368 gfc_index_zero_node
,
9369 gfc_index_one_node
);
9370 gfc_conv_descriptor_stride_set (&dealloc_block
, cdesc
,
9371 gfc_index_zero_node
,
9372 gfc_index_one_node
);
9373 gfc_conv_descriptor_ubound_set (&dealloc_block
, cdesc
,
9374 gfc_index_zero_node
, ubound
);
9376 if (attr
->dimension
)
9377 comp
= gfc_conv_descriptor_data_get (comp
);
9379 gfc_conv_descriptor_data_set (&dealloc_block
, cdesc
, comp
);
9381 /* Now call the deallocator. */
9382 vtab
= gfc_find_vtab (&c
->ts
);
9383 if (vtab
->backend_decl
== NULL
)
9384 gfc_get_symbol_decl (vtab
);
9385 tmp
= gfc_build_addr_expr (NULL_TREE
, vtab
->backend_decl
);
9386 dealloc_fndecl
= gfc_vptr_deallocate_get (tmp
);
9387 dealloc_fndecl
= build_fold_indirect_ref_loc (input_location
,
9389 tmp
= build_int_cst (TREE_TYPE (comp
), 0);
9390 is_allocated
= fold_build2_loc (input_location
, NE_EXPR
,
9391 logical_type_node
, tmp
,
9393 cdesc
= gfc_build_addr_expr (NULL_TREE
, cdesc
);
9395 tmp
= build_call_expr_loc (input_location
,
9398 gfc_add_expr_to_block (&dealloc_block
, tmp
);
9400 tmp
= gfc_finish_block (&dealloc_block
);
9402 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
9403 void_type_node
, is_allocated
, tmp
,
9404 build_empty_stmt (input_location
));
9406 gfc_add_expr_to_block (&tmpblock
, tmp
);
9408 else if (add_when_allocated
)
9409 gfc_add_expr_to_block (&tmpblock
, add_when_allocated
);
9411 if (c
->ts
.type
== BT_CLASS
&& attr
->allocatable
9412 && (!attr
->codimension
|| !caf_enabled (caf_mode
)))
9414 /* Finally, reset the vptr to the declared type vtable and, if
9415 necessary reset the _len field.
9417 First recover the reference to the component and obtain
9419 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9420 decl
, cdecl, NULL_TREE
);
9421 tmp
= gfc_class_vptr_get (comp
);
9423 if (UNLIMITED_POLY (c
))
9425 /* Both vptr and _len field should be nulled. */
9426 gfc_add_modify (&tmpblock
, tmp
,
9427 build_int_cst (TREE_TYPE (tmp
), 0));
9428 tmp
= gfc_class_len_get (comp
);
9429 gfc_add_modify (&tmpblock
, tmp
,
9430 build_int_cst (TREE_TYPE (tmp
), 0));
9434 /* Build the vtable address and set the vptr with it. */
9437 vtable
= gfc_find_derived_vtab (c
->ts
.u
.derived
);
9438 vtab
= vtable
->backend_decl
;
9439 if (vtab
== NULL_TREE
)
9440 vtab
= gfc_get_symbol_decl (vtable
);
9441 vtab
= gfc_build_addr_expr (NULL
, vtab
);
9442 vtab
= fold_convert (TREE_TYPE (tmp
), vtab
);
9443 gfc_add_modify (&tmpblock
, tmp
, vtab
);
9447 /* Now add the deallocation of this component. */
9448 gfc_add_block_to_block (&fnblock
, &tmpblock
);
9451 case NULLIFY_ALLOC_COMP
:
9453 - allocatable components (regular or in class)
9454 - components that have allocatable components
9455 - pointer components when in a coarray.
9456 Skip everything else especially proc_pointers, which may come
9457 coupled with the regular pointer attribute. */
9458 if (c
->attr
.proc_pointer
9459 || !(c
->attr
.allocatable
|| (c
->ts
.type
== BT_CLASS
9460 && CLASS_DATA (c
)->attr
.allocatable
)
9461 || (cmp_has_alloc_comps
9462 && ((c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
)
9463 || (c
->ts
.type
== BT_CLASS
9464 && !CLASS_DATA (c
)->attr
.class_pointer
)))
9465 || (caf_in_coarray (caf_mode
) && c
->attr
.pointer
)))
9468 /* Process class components first, because they always have the
9469 pointer-attribute set which would be caught wrong else. */
9470 if (c
->ts
.type
== BT_CLASS
9471 && (CLASS_DATA (c
)->attr
.allocatable
9472 || CLASS_DATA (c
)->attr
.class_pointer
))
9476 /* Allocatable CLASS components. */
9477 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9478 decl
, cdecl, NULL_TREE
);
9480 vptr_decl
= gfc_class_vptr_get (comp
);
9482 comp
= gfc_class_data_get (comp
);
9483 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp
)))
9484 gfc_conv_descriptor_data_set (&fnblock
, comp
,
9488 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
9489 void_type_node
, comp
,
9490 build_int_cst (TREE_TYPE (comp
), 0));
9491 gfc_add_expr_to_block (&fnblock
, tmp
);
9494 /* The dynamic type of a disassociated pointer or unallocated
9495 allocatable variable is its declared type. An unlimited
9496 polymorphic entity has no declared type. */
9497 if (!UNLIMITED_POLY (c
))
9499 vtab
= gfc_find_derived_vtab (c
->ts
.u
.derived
);
9500 if (!vtab
->backend_decl
)
9501 gfc_get_symbol_decl (vtab
);
9502 tmp
= gfc_build_addr_expr (NULL_TREE
, vtab
->backend_decl
);
9505 tmp
= build_int_cst (TREE_TYPE (vptr_decl
), 0);
9507 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
9508 void_type_node
, vptr_decl
, tmp
);
9509 gfc_add_expr_to_block (&fnblock
, tmp
);
9511 cmp_has_alloc_comps
= false;
9513 /* Coarrays need the component to be nulled before the api-call
9515 else if (c
->attr
.pointer
|| c
->attr
.allocatable
)
9517 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9518 decl
, cdecl, NULL_TREE
);
9519 if (c
->attr
.dimension
|| c
->attr
.codimension
)
9520 gfc_conv_descriptor_data_set (&fnblock
, comp
,
9523 gfc_add_modify (&fnblock
, comp
,
9524 build_int_cst (TREE_TYPE (comp
), 0));
9525 if (gfc_deferred_strlen (c
, &comp
))
9527 comp
= fold_build3_loc (input_location
, COMPONENT_REF
,
9529 decl
, comp
, NULL_TREE
);
9530 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
9531 TREE_TYPE (comp
), comp
,
9532 build_int_cst (TREE_TYPE (comp
), 0));
9533 gfc_add_expr_to_block (&fnblock
, tmp
);
9535 cmp_has_alloc_comps
= false;
9538 if (flag_coarray
== GFC_FCOARRAY_LIB
&& caf_in_coarray (caf_mode
))
9540 /* Register a component of a derived type coarray with the
9541 coarray library. Do not register ultimate component
9542 coarrays here. They are treated like regular coarrays and
9543 are either allocated on all images or on none. */
9546 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9547 decl
, cdecl, NULL_TREE
);
9548 if (c
->attr
.dimension
)
9550 /* Set the dtype, because caf_register needs it. */
9551 gfc_add_modify (&fnblock
, gfc_conv_descriptor_dtype (comp
),
9552 gfc_get_dtype (TREE_TYPE (comp
)));
9553 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9554 decl
, cdecl, NULL_TREE
);
9555 token
= gfc_conv_descriptor_token (tmp
);
9561 gfc_init_se (&se
, NULL
);
9562 token
= fold_build3_loc (input_location
, COMPONENT_REF
,
9563 pvoid_type_node
, decl
, c
->caf_token
,
9565 comp
= gfc_conv_scalar_to_descriptor (&se
, comp
,
9566 c
->ts
.type
== BT_CLASS
9567 ? CLASS_DATA (c
)->attr
9569 gfc_add_block_to_block (&fnblock
, &se
.pre
);
9572 gfc_allocate_using_caf_lib (&fnblock
, comp
, size_zero_node
,
9573 gfc_build_addr_expr (NULL_TREE
,
9575 NULL_TREE
, NULL_TREE
, NULL_TREE
,
9576 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
9579 if (cmp_has_alloc_comps
)
9581 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9582 decl
, cdecl, NULL_TREE
);
9583 rank
= c
->as
? c
->as
->rank
: 0;
9584 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
9585 rank
, purpose
, caf_mode
, args
);
9586 gfc_add_expr_to_block (&fnblock
, tmp
);
9590 case REASSIGN_CAF_COMP
:
9591 if (caf_enabled (caf_mode
)
9592 && (c
->attr
.codimension
9593 || (c
->ts
.type
== BT_CLASS
9594 && (CLASS_DATA (c
)->attr
.coarray_comp
9595 || caf_in_coarray (caf_mode
)))
9596 || (c
->ts
.type
== BT_DERIVED
9597 && (c
->ts
.u
.derived
->attr
.coarray_comp
9598 || caf_in_coarray (caf_mode
))))
9601 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9602 decl
, cdecl, NULL_TREE
);
9603 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9604 dest
, cdecl, NULL_TREE
);
9606 if (c
->attr
.codimension
)
9608 if (c
->ts
.type
== BT_CLASS
)
9610 comp
= gfc_class_data_get (comp
);
9611 dcmp
= gfc_class_data_get (dcmp
);
9613 gfc_conv_descriptor_data_set (&fnblock
, dcmp
,
9614 gfc_conv_descriptor_data_get (comp
));
9618 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, dcmp
,
9619 rank
, purpose
, caf_mode
9620 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
,
9622 gfc_add_expr_to_block (&fnblock
, tmp
);
9627 case COPY_ALLOC_COMP
:
9628 if (c
->attr
.pointer
|| c
->attr
.proc_pointer
)
9631 /* We need source and destination components. */
9632 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, decl
,
9634 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, dest
,
9636 dcmp
= fold_convert (TREE_TYPE (comp
), dcmp
);
9638 if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
9646 dst_data
= gfc_class_data_get (dcmp
);
9647 src_data
= gfc_class_data_get (comp
);
9648 size
= fold_convert (size_type_node
,
9649 gfc_class_vtab_size_get (comp
));
9651 if (CLASS_DATA (c
)->attr
.dimension
)
9653 nelems
= gfc_conv_descriptor_size (src_data
,
9654 CLASS_DATA (c
)->as
->rank
);
9655 size
= fold_build2_loc (input_location
, MULT_EXPR
,
9656 size_type_node
, size
,
9657 fold_convert (size_type_node
,
9661 nelems
= build_int_cst (size_type_node
, 1);
9663 if (CLASS_DATA (c
)->attr
.dimension
9664 || CLASS_DATA (c
)->attr
.codimension
)
9666 src_data
= gfc_conv_descriptor_data_get (src_data
);
9667 dst_data
= gfc_conv_descriptor_data_get (dst_data
);
9670 gfc_init_block (&tmpblock
);
9672 gfc_add_modify (&tmpblock
, gfc_class_vptr_get (dcmp
),
9673 gfc_class_vptr_get (comp
));
9675 /* Copy the unlimited '_len' field. If it is greater than zero
9676 (ie. a character(_len)), multiply it by size and use this
9677 for the malloc call. */
9678 if (UNLIMITED_POLY (c
))
9680 gfc_add_modify (&tmpblock
, gfc_class_len_get (dcmp
),
9681 gfc_class_len_get (comp
));
9682 size
= gfc_resize_class_size_with_len (&tmpblock
, comp
, size
);
9685 /* Coarray component have to have the same allocation status and
9686 shape/type-parameter/effective-type on the LHS and RHS of an
9687 intrinsic assignment. Hence, we did not deallocated them - and
9688 do not allocate them here. */
9689 if (!CLASS_DATA (c
)->attr
.codimension
)
9691 ftn_tree
= builtin_decl_explicit (BUILT_IN_MALLOC
);
9692 tmp
= build_call_expr_loc (input_location
, ftn_tree
, 1, size
);
9693 gfc_add_modify (&tmpblock
, dst_data
,
9694 fold_convert (TREE_TYPE (dst_data
), tmp
));
9697 tmp
= gfc_copy_class_to_class (comp
, dcmp
, nelems
,
9698 UNLIMITED_POLY (c
));
9699 gfc_add_expr_to_block (&tmpblock
, tmp
);
9700 tmp
= gfc_finish_block (&tmpblock
);
9702 gfc_init_block (&tmpblock
);
9703 gfc_add_modify (&tmpblock
, dst_data
,
9704 fold_convert (TREE_TYPE (dst_data
),
9705 null_pointer_node
));
9706 null_data
= gfc_finish_block (&tmpblock
);
9708 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
9709 logical_type_node
, src_data
,
9712 gfc_add_expr_to_block (&fnblock
, build3_v (COND_EXPR
, null_cond
,
9717 /* To implement guarded deep copy, i.e., deep copy only allocatable
9718 components that are really allocated, the deep copy code has to
9719 be generated first and then added to the if-block in
9720 gfc_duplicate_allocatable (). */
9721 if (cmp_has_alloc_comps
&& !c
->attr
.proc_pointer
&& !same_type
)
9723 rank
= c
->as
? c
->as
->rank
: 0;
9724 tmp
= fold_convert (TREE_TYPE (dcmp
), comp
);
9725 gfc_add_modify (&fnblock
, dcmp
, tmp
);
9726 add_when_allocated
= structure_alloc_comps (c
->ts
.u
.derived
,
9732 add_when_allocated
= NULL_TREE
;
9734 if (gfc_deferred_strlen (c
, &tmp
))
9738 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
9740 decl
, len
, NULL_TREE
);
9741 len
= fold_build3_loc (input_location
, COMPONENT_REF
,
9743 dest
, len
, NULL_TREE
);
9744 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
9745 TREE_TYPE (len
), len
, tmp
);
9746 gfc_add_expr_to_block (&fnblock
, tmp
);
9747 size
= size_of_string_in_bytes (c
->ts
.kind
, len
);
9748 /* This component cannot have allocatable components,
9749 therefore add_when_allocated of duplicate_allocatable ()
9751 tmp
= duplicate_allocatable (dcmp
, comp
, ctype
, rank
,
9752 false, false, size
, NULL_TREE
);
9753 gfc_add_expr_to_block (&fnblock
, tmp
);
9755 else if (c
->attr
.pdt_array
)
9757 tmp
= duplicate_allocatable (dcmp
, comp
, ctype
,
9758 c
->as
? c
->as
->rank
: 0,
9759 false, false, NULL_TREE
, NULL_TREE
);
9760 gfc_add_expr_to_block (&fnblock
, tmp
);
9762 else if ((c
->attr
.allocatable
)
9763 && !c
->attr
.proc_pointer
&& !same_type
9764 && (!(cmp_has_alloc_comps
&& c
->as
) || c
->attr
.codimension
9765 || caf_in_coarray (caf_mode
)))
9767 rank
= c
->as
? c
->as
->rank
: 0;
9768 if (c
->attr
.codimension
)
9769 tmp
= gfc_copy_allocatable_data (dcmp
, comp
, ctype
, rank
);
9770 else if (flag_coarray
== GFC_FCOARRAY_LIB
9771 && caf_in_coarray (caf_mode
))
9775 dst_tok
= gfc_conv_descriptor_token (dcmp
);
9778 /* For a scalar allocatable component the caf_token is
9779 the next component. */
9781 c
->caf_token
= c
->next
->backend_decl
;
9782 dst_tok
= fold_build3_loc (input_location
,
9784 pvoid_type_node
, dest
,
9788 tmp
= duplicate_allocatable_coarray (dcmp
, dst_tok
, comp
,
9792 tmp
= gfc_duplicate_allocatable (dcmp
, comp
, ctype
, rank
,
9793 add_when_allocated
);
9794 gfc_add_expr_to_block (&fnblock
, tmp
);
9797 if (cmp_has_alloc_comps
|| is_pdt_type
)
9798 gfc_add_expr_to_block (&fnblock
, add_when_allocated
);
9802 case ALLOCATE_PDT_COMP
:
9804 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9805 decl
, cdecl, NULL_TREE
);
9807 /* Set the PDT KIND and LEN fields. */
9808 if (c
->attr
.pdt_kind
|| c
->attr
.pdt_len
)
9811 gfc_expr
*c_expr
= NULL
;
9812 gfc_actual_arglist
*param
= pdt_param_list
;
9813 gfc_init_se (&tse
, NULL
);
9814 for (; param
; param
= param
->next
)
9815 if (param
->name
&& !strcmp (c
->name
, param
->name
))
9816 c_expr
= param
->expr
;
9819 c_expr
= c
->initializer
;
9823 gfc_conv_expr_type (&tse
, c_expr
, TREE_TYPE (comp
));
9824 gfc_add_modify (&fnblock
, comp
, tse
.expr
);
9828 if (c
->attr
.pdt_string
)
9831 gfc_init_se (&tse
, NULL
);
9832 tree strlen
= NULL_TREE
;
9833 gfc_expr
*e
= gfc_copy_expr (c
->ts
.u
.cl
->length
);
9834 /* Convert the parameterized string length to its value. The
9835 string length is stored in a hidden field in the same way as
9836 deferred string lengths. */
9837 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9838 if (gfc_deferred_strlen (c
, &strlen
) && strlen
!= NULL_TREE
)
9840 gfc_conv_expr_type (&tse
, e
,
9841 TREE_TYPE (strlen
));
9842 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
9844 decl
, strlen
, NULL_TREE
);
9845 gfc_add_modify (&fnblock
, strlen
, tse
.expr
);
9846 c
->ts
.u
.cl
->backend_decl
= strlen
;
9850 /* Scalar parameterized strings can be allocated now. */
9853 tmp
= fold_convert (gfc_array_index_type
, strlen
);
9854 tmp
= size_of_string_in_bytes (c
->ts
.kind
, tmp
);
9855 tmp
= gfc_evaluate_now (tmp
, &fnblock
);
9856 tmp
= gfc_call_malloc (&fnblock
, TREE_TYPE (comp
), tmp
);
9857 gfc_add_modify (&fnblock
, comp
, tmp
);
9861 /* Allocate parameterized arrays of parameterized derived types. */
9862 if (!(c
->attr
.pdt_array
&& c
->as
&& c
->as
->type
== AS_EXPLICIT
)
9863 && !((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9864 && (c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
)))
9867 if (c
->ts
.type
== BT_CLASS
)
9868 comp
= gfc_class_data_get (comp
);
9870 if (c
->attr
.pdt_array
)
9874 tree size
= gfc_index_one_node
;
9875 tree offset
= gfc_index_zero_node
;
9879 /* This chunk takes the expressions for 'lower' and 'upper'
9880 in the arrayspec and substitutes in the expressions for
9881 the parameters from 'pdt_param_list'. The descriptor
9882 fields can then be filled from the values so obtained. */
9883 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp
)));
9884 for (i
= 0; i
< c
->as
->rank
; i
++)
9886 gfc_init_se (&tse
, NULL
);
9887 e
= gfc_copy_expr (c
->as
->lower
[i
]);
9888 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9889 gfc_conv_expr_type (&tse
, e
, gfc_array_index_type
);
9892 gfc_conv_descriptor_lbound_set (&fnblock
, comp
,
9895 e
= gfc_copy_expr (c
->as
->upper
[i
]);
9896 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9897 gfc_conv_expr_type (&tse
, e
, gfc_array_index_type
);
9900 gfc_conv_descriptor_ubound_set (&fnblock
, comp
,
9903 gfc_conv_descriptor_stride_set (&fnblock
, comp
,
9906 size
= gfc_evaluate_now (size
, &fnblock
);
9907 offset
= fold_build2_loc (input_location
,
9909 gfc_array_index_type
,
9911 offset
= gfc_evaluate_now (offset
, &fnblock
);
9912 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9913 gfc_array_index_type
,
9915 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9916 gfc_array_index_type
,
9917 tmp
, gfc_index_one_node
);
9918 size
= fold_build2_loc (input_location
, MULT_EXPR
,
9919 gfc_array_index_type
, size
, tmp
);
9921 gfc_conv_descriptor_offset_set (&fnblock
, comp
, offset
);
9922 if (c
->ts
.type
== BT_CLASS
)
9924 tmp
= gfc_get_vptr_from_expr (comp
);
9925 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
9926 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
9927 tmp
= gfc_vptr_size_get (tmp
);
9930 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (ctype
));
9931 tmp
= fold_convert (gfc_array_index_type
, tmp
);
9932 size
= fold_build2_loc (input_location
, MULT_EXPR
,
9933 gfc_array_index_type
, size
, tmp
);
9934 size
= gfc_evaluate_now (size
, &fnblock
);
9935 tmp
= gfc_call_malloc (&fnblock
, NULL
, size
);
9936 gfc_conv_descriptor_data_set (&fnblock
, comp
, tmp
);
9937 tmp
= gfc_conv_descriptor_dtype (comp
);
9938 gfc_add_modify (&fnblock
, tmp
, gfc_get_dtype (ctype
));
9940 if (c
->initializer
&& c
->initializer
->rank
)
9942 gfc_init_se (&tse
, NULL
);
9943 e
= gfc_copy_expr (c
->initializer
);
9944 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9945 gfc_conv_expr_descriptor (&tse
, e
);
9946 gfc_add_block_to_block (&fnblock
, &tse
.pre
);
9948 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
9949 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
9950 gfc_conv_descriptor_data_get (comp
),
9951 gfc_conv_descriptor_data_get (tse
.expr
),
9952 fold_convert (size_type_node
, size
));
9953 gfc_add_expr_to_block (&fnblock
, tmp
);
9954 gfc_add_block_to_block (&fnblock
, &tse
.post
);
9958 /* Recurse in to PDT components. */
9959 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9960 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
9961 && !(c
->attr
.pointer
|| c
->attr
.allocatable
))
9963 bool is_deferred
= false;
9964 gfc_actual_arglist
*tail
= c
->param_list
;
9966 for (; tail
; tail
= tail
->next
)
9970 tail
= is_deferred
? pdt_param_list
: c
->param_list
;
9971 tmp
= gfc_allocate_pdt_comp (c
->ts
.u
.derived
, comp
,
9972 c
->as
? c
->as
->rank
: 0,
9974 gfc_add_expr_to_block (&fnblock
, tmp
);
9979 case DEALLOCATE_PDT_COMP
:
9980 /* Deallocate array or parameterized string length components
9981 of parameterized derived types. */
9982 if (!(c
->attr
.pdt_array
&& c
->as
&& c
->as
->type
== AS_EXPLICIT
)
9983 && !c
->attr
.pdt_string
9984 && !((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9985 && (c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
)))
9988 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9989 decl
, cdecl, NULL_TREE
);
9990 if (c
->ts
.type
== BT_CLASS
)
9991 comp
= gfc_class_data_get (comp
);
9993 /* Recurse in to PDT components. */
9994 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9995 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
9996 && (!c
->attr
.pointer
&& !c
->attr
.allocatable
))
9998 tmp
= gfc_deallocate_pdt_comp (c
->ts
.u
.derived
, comp
,
9999 c
->as
? c
->as
->rank
: 0);
10000 gfc_add_expr_to_block (&fnblock
, tmp
);
10003 if (c
->attr
.pdt_array
)
10005 tmp
= gfc_conv_descriptor_data_get (comp
);
10006 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
10007 logical_type_node
, tmp
,
10008 build_int_cst (TREE_TYPE (tmp
), 0));
10009 tmp
= gfc_call_free (tmp
);
10010 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
10011 build_empty_stmt (input_location
));
10012 gfc_add_expr_to_block (&fnblock
, tmp
);
10013 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
10015 else if (c
->attr
.pdt_string
)
10017 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
10018 logical_type_node
, comp
,
10019 build_int_cst (TREE_TYPE (comp
), 0));
10020 tmp
= gfc_call_free (comp
);
10021 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
10022 build_empty_stmt (input_location
));
10023 gfc_add_expr_to_block (&fnblock
, tmp
);
10024 tmp
= fold_convert (TREE_TYPE (comp
), null_pointer_node
);
10025 gfc_add_modify (&fnblock
, comp
, tmp
);
10030 case CHECK_PDT_DUMMY
:
10032 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
10033 decl
, cdecl, NULL_TREE
);
10034 if (c
->ts
.type
== BT_CLASS
)
10035 comp
= gfc_class_data_get (comp
);
10037 /* Recurse in to PDT components. */
10038 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
10039 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
)
10041 tmp
= gfc_check_pdt_dummy (c
->ts
.u
.derived
, comp
,
10042 c
->as
? c
->as
->rank
: 0,
10044 gfc_add_expr_to_block (&fnblock
, tmp
);
10047 if (!c
->attr
.pdt_len
)
10052 gfc_expr
*c_expr
= NULL
;
10053 gfc_actual_arglist
*param
= pdt_param_list
;
10055 gfc_init_se (&tse
, NULL
);
10056 for (; param
; param
= param
->next
)
10057 if (!strcmp (c
->name
, param
->name
)
10058 && param
->spec_type
== SPEC_EXPLICIT
)
10059 c_expr
= param
->expr
;
10063 tree error
, cond
, cname
;
10064 gfc_conv_expr_type (&tse
, c_expr
, TREE_TYPE (comp
));
10065 cond
= fold_build2_loc (input_location
, NE_EXPR
,
10068 cname
= gfc_build_cstring_const (c
->name
);
10069 cname
= gfc_build_addr_expr (pchar_type_node
, cname
);
10070 error
= gfc_trans_runtime_error (true, NULL
,
10071 "The value of the PDT LEN "
10072 "parameter '%s' does not "
10073 "agree with that in the "
10074 "dummy declaration",
10076 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
10077 void_type_node
, cond
, error
,
10078 build_empty_stmt (input_location
));
10079 gfc_add_expr_to_block (&fnblock
, tmp
);
10085 gcc_unreachable ();
10090 return gfc_finish_block (&fnblock
);
10093 /* Recursively traverse an object of derived type, generating code to
10094 nullify allocatable components. */
10097 gfc_nullify_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
10100 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
10101 NULLIFY_ALLOC_COMP
,
10102 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
| caf_mode
, NULL
);
10106 /* Recursively traverse an object of derived type, generating code to
10107 deallocate allocatable components. */
10110 gfc_deallocate_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
10113 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
10114 DEALLOCATE_ALLOC_COMP
,
10115 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
| caf_mode
, NULL
);
10119 gfc_bcast_alloc_comp (gfc_symbol
*derived
, gfc_expr
*expr
, int rank
,
10120 tree image_index
, tree stat
, tree errmsg
,
10125 stmtblock_t block
, post_block
;
10126 gfc_co_subroutines_args args
;
10128 args
.image_index
= image_index
;
10130 args
.errmsg
= errmsg
;
10131 args
.errmsg_len
= errmsg_len
;
10135 gfc_start_block (&block
);
10136 gfc_init_block (&post_block
);
10137 gfc_init_se (&argse
, NULL
);
10138 gfc_conv_expr (&argse
, expr
);
10139 gfc_add_block_to_block (&block
, &argse
.pre
);
10140 gfc_add_block_to_block (&post_block
, &argse
.post
);
10141 array
= argse
.expr
;
10145 gfc_init_se (&argse
, NULL
);
10146 argse
.want_pointer
= 1;
10147 gfc_conv_expr_descriptor (&argse
, expr
);
10148 array
= argse
.expr
;
10151 tmp
= structure_alloc_comps (derived
, array
, NULL_TREE
, rank
,
10153 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
, &args
);
10157 /* Recursively traverse an object of derived type, generating code to
10158 deallocate allocatable components. But do not deallocate coarrays.
10159 To be used for intrinsic assignment, which may not change the allocation
10160 status of coarrays. */
10163 gfc_deallocate_alloc_comp_no_caf (gfc_symbol
* der_type
, tree decl
, int rank
)
10165 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
10166 DEALLOCATE_ALLOC_COMP
, 0, NULL
);
10171 gfc_reassign_alloc_comp_caf (gfc_symbol
*der_type
, tree decl
, tree dest
)
10173 return structure_alloc_comps (der_type
, decl
, dest
, 0, REASSIGN_CAF_COMP
,
10174 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
, NULL
);
10178 /* Recursively traverse an object of derived type, generating code to
10179 copy it and its allocatable components. */
10182 gfc_copy_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
,
10185 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ALLOC_COMP
,
10190 /* Recursively traverse an object of derived type, generating code to
10191 copy only its allocatable components. */
10194 gfc_copy_only_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
10196 return structure_alloc_comps (der_type
, decl
, dest
, rank
,
10197 COPY_ONLY_ALLOC_COMP
, 0, NULL
);
10201 /* Recursively traverse an object of parameterized derived type, generating
10202 code to allocate parameterized components. */
10205 gfc_allocate_pdt_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
10206 gfc_actual_arglist
*param_list
)
10209 gfc_actual_arglist
*old_param_list
= pdt_param_list
;
10210 pdt_param_list
= param_list
;
10211 res
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
10212 ALLOCATE_PDT_COMP
, 0, NULL
);
10213 pdt_param_list
= old_param_list
;
10217 /* Recursively traverse an object of parameterized derived type, generating
10218 code to deallocate parameterized components. */
10221 gfc_deallocate_pdt_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
10223 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
10224 DEALLOCATE_PDT_COMP
, 0, NULL
);
10228 /* Recursively traverse a dummy of parameterized derived type to check the
10229 values of LEN parameters. */
10232 gfc_check_pdt_dummy (gfc_symbol
* der_type
, tree decl
, int rank
,
10233 gfc_actual_arglist
*param_list
)
10236 gfc_actual_arglist
*old_param_list
= pdt_param_list
;
10237 pdt_param_list
= param_list
;
10238 res
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
10239 CHECK_PDT_DUMMY
, 0, NULL
);
10240 pdt_param_list
= old_param_list
;
10245 /* Returns the value of LBOUND for an expression. This could be broken out
10246 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
10247 called by gfc_alloc_allocatable_for_assignment. */
10249 get_std_lbound (gfc_expr
*expr
, tree desc
, int dim
, bool assumed_size
)
10254 tree cond
, cond1
, cond3
, cond4
;
10258 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
10260 tmp
= gfc_rank_cst
[dim
];
10261 lbound
= gfc_conv_descriptor_lbound_get (desc
, tmp
);
10262 ubound
= gfc_conv_descriptor_ubound_get (desc
, tmp
);
10263 stride
= gfc_conv_descriptor_stride_get (desc
, tmp
);
10264 cond1
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
10266 cond3
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
10267 stride
, gfc_index_zero_node
);
10268 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
10269 logical_type_node
, cond3
, cond1
);
10270 cond4
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
10271 stride
, gfc_index_zero_node
);
10273 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
10274 tmp
, build_int_cst (gfc_array_index_type
,
10277 cond
= logical_false_node
;
10279 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
10280 logical_type_node
, cond3
, cond4
);
10281 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
10282 logical_type_node
, cond
, cond1
);
10284 return fold_build3_loc (input_location
, COND_EXPR
,
10285 gfc_array_index_type
, cond
,
10286 lbound
, gfc_index_one_node
);
10289 if (expr
->expr_type
== EXPR_FUNCTION
)
10291 /* A conversion function, so use the argument. */
10292 gcc_assert (expr
->value
.function
.isym
10293 && expr
->value
.function
.isym
->conversion
);
10294 expr
= expr
->value
.function
.actual
->expr
;
10297 if (expr
->expr_type
== EXPR_VARIABLE
)
10299 tmp
= TREE_TYPE (expr
->symtree
->n
.sym
->backend_decl
);
10300 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
10302 if (ref
->type
== REF_COMPONENT
10303 && ref
->u
.c
.component
->as
10305 && ref
->next
->u
.ar
.type
== AR_FULL
)
10306 tmp
= TREE_TYPE (ref
->u
.c
.component
->backend_decl
);
10308 return GFC_TYPE_ARRAY_LBOUND(tmp
, dim
);
10311 return gfc_index_one_node
;
10315 /* Returns true if an expression represents an lhs that can be reallocated
10319 gfc_is_reallocatable_lhs (gfc_expr
*expr
)
10327 sym
= expr
->symtree
->n
.sym
;
10329 if (sym
->attr
.associate_var
&& !expr
->ref
)
10332 /* An allocatable class variable with no reference. */
10333 if (sym
->ts
.type
== BT_CLASS
10334 && !sym
->attr
.associate_var
10335 && CLASS_DATA (sym
)->attr
.allocatable
10337 && ((expr
->ref
->type
== REF_ARRAY
&& expr
->ref
->u
.ar
.type
== AR_FULL
10338 && expr
->ref
->next
== NULL
)
10339 || (expr
->ref
->type
== REF_COMPONENT
10340 && strcmp (expr
->ref
->u
.c
.component
->name
, "_data") == 0
10341 && (expr
->ref
->next
== NULL
10342 || (expr
->ref
->next
->type
== REF_ARRAY
10343 && expr
->ref
->next
->u
.ar
.type
== AR_FULL
10344 && expr
->ref
->next
->next
== NULL
)))))
10347 /* An allocatable variable. */
10348 if (sym
->attr
.allocatable
10349 && !sym
->attr
.associate_var
10351 && expr
->ref
->type
== REF_ARRAY
10352 && expr
->ref
->u
.ar
.type
== AR_FULL
)
10355 /* All that can be left are allocatable components. */
10356 if ((sym
->ts
.type
!= BT_DERIVED
10357 && sym
->ts
.type
!= BT_CLASS
)
10358 || !sym
->ts
.u
.derived
->attr
.alloc_comp
)
10361 /* Find a component ref followed by an array reference. */
10362 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
10364 && ref
->type
== REF_COMPONENT
10365 && ref
->next
->type
== REF_ARRAY
10366 && !ref
->next
->next
)
10372 /* Return true if valid reallocatable lhs. */
10373 if (ref
->u
.c
.component
->attr
.allocatable
10374 && ref
->next
->u
.ar
.type
== AR_FULL
)
10382 concat_str_length (gfc_expr
* expr
)
10389 type
= gfc_typenode_for_spec (&expr
->value
.op
.op1
->ts
);
10390 len1
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
10391 if (len1
== NULL_TREE
)
10393 if (expr
->value
.op
.op1
->expr_type
== EXPR_OP
)
10394 len1
= concat_str_length (expr
->value
.op
.op1
);
10395 else if (expr
->value
.op
.op1
->expr_type
== EXPR_CONSTANT
)
10396 len1
= build_int_cst (gfc_charlen_type_node
,
10397 expr
->value
.op
.op1
->value
.character
.length
);
10398 else if (expr
->value
.op
.op1
->ts
.u
.cl
->length
)
10400 gfc_init_se (&se
, NULL
);
10401 gfc_conv_expr (&se
, expr
->value
.op
.op1
->ts
.u
.cl
->length
);
10407 gfc_init_se (&se
, NULL
);
10408 se
.want_pointer
= 1;
10409 se
.descriptor_only
= 1;
10410 gfc_conv_expr (&se
, expr
->value
.op
.op1
);
10411 len1
= se
.string_length
;
10415 type
= gfc_typenode_for_spec (&expr
->value
.op
.op2
->ts
);
10416 len2
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
10417 if (len2
== NULL_TREE
)
10419 if (expr
->value
.op
.op2
->expr_type
== EXPR_OP
)
10420 len2
= concat_str_length (expr
->value
.op
.op2
);
10421 else if (expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
10422 len2
= build_int_cst (gfc_charlen_type_node
,
10423 expr
->value
.op
.op2
->value
.character
.length
);
10424 else if (expr
->value
.op
.op2
->ts
.u
.cl
->length
)
10426 gfc_init_se (&se
, NULL
);
10427 gfc_conv_expr (&se
, expr
->value
.op
.op2
->ts
.u
.cl
->length
);
10433 gfc_init_se (&se
, NULL
);
10434 se
.want_pointer
= 1;
10435 se
.descriptor_only
= 1;
10436 gfc_conv_expr (&se
, expr
->value
.op
.op2
);
10437 len2
= se
.string_length
;
10441 gcc_assert(len1
&& len2
);
10442 len1
= fold_convert (gfc_charlen_type_node
, len1
);
10443 len2
= fold_convert (gfc_charlen_type_node
, len2
);
10445 return fold_build2_loc (input_location
, PLUS_EXPR
,
10446 gfc_charlen_type_node
, len1
, len2
);
10450 /* Allocate the lhs of an assignment to an allocatable array, otherwise
10454 gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop
,
10458 stmtblock_t realloc_block
;
10459 stmtblock_t alloc_block
;
10460 stmtblock_t fblock
;
10463 gfc_array_info
*linfo
;
10485 tree class_expr2
= NULL_TREE
;
10488 gfc_array_spec
* as
;
10489 bool coarray
= (flag_coarray
== GFC_FCOARRAY_LIB
10490 && gfc_caf_attr (expr1
, true).codimension
);
10494 /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
10495 Find the lhs expression in the loop chain and set expr1 and
10496 expr2 accordingly. */
10497 if (expr1
->expr_type
== EXPR_FUNCTION
&& expr2
== NULL
)
10500 /* Find the ss for the lhs. */
10502 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
10503 if (lss
->info
->expr
&& lss
->info
->expr
->expr_type
== EXPR_VARIABLE
)
10505 if (lss
== gfc_ss_terminator
)
10507 expr1
= lss
->info
->expr
;
10510 /* Bail out if this is not a valid allocate on assignment. */
10511 if (!gfc_is_reallocatable_lhs (expr1
)
10512 || (expr2
&& !expr2
->rank
))
10515 /* Find the ss for the lhs. */
10517 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
10518 if (lss
->info
->expr
== expr1
)
10521 if (lss
== gfc_ss_terminator
)
10524 linfo
= &lss
->info
->data
.array
;
10526 /* Find an ss for the rhs. For operator expressions, we see the
10527 ss's for the operands. Any one of these will do. */
10529 for (; rss
&& rss
!= gfc_ss_terminator
; rss
= rss
->loop_chain
)
10530 if (rss
->info
->expr
!= expr1
&& rss
!= loop
->temp_ss
)
10533 if (expr2
&& rss
== gfc_ss_terminator
)
10536 /* Ensure that the string length from the current scope is used. */
10537 if (expr2
->ts
.type
== BT_CHARACTER
10538 && expr2
->expr_type
== EXPR_FUNCTION
10539 && !expr2
->value
.function
.isym
)
10540 expr2
->ts
.u
.cl
->backend_decl
= rss
->info
->string_length
;
10542 gfc_start_block (&fblock
);
10544 /* Since the lhs is allocatable, this must be a descriptor type.
10545 Get the data and array size. */
10546 desc
= linfo
->descriptor
;
10547 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)));
10548 array1
= gfc_conv_descriptor_data_get (desc
);
10551 desc2
= rss
->info
->data
.array
.descriptor
;
10555 /* Get the old lhs element size for deferred character and class expr1. */
10556 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10558 if (expr1
->ts
.u
.cl
->backend_decl
10559 && VAR_P (expr1
->ts
.u
.cl
->backend_decl
))
10560 elemsize1
= expr1
->ts
.u
.cl
->backend_decl
;
10562 elemsize1
= lss
->info
->string_length
;
10564 else if (expr1
->ts
.type
== BT_CLASS
)
10566 /* Unfortunately, the lhs vptr is set too early in many cases.
10567 Play it safe by using the descriptor element length. */
10568 tmp
= gfc_conv_descriptor_elem_len (desc
);
10569 elemsize1
= fold_convert (gfc_array_index_type
, tmp
);
10572 elemsize1
= NULL_TREE
;
10573 if (elemsize1
!= NULL_TREE
)
10574 elemsize1
= gfc_evaluate_now (elemsize1
, &fblock
);
10576 /* Get the new lhs size in bytes. */
10577 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10579 if (expr2
->ts
.deferred
)
10581 if (expr2
->ts
.u
.cl
->backend_decl
10582 && VAR_P (expr2
->ts
.u
.cl
->backend_decl
))
10583 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
10585 tmp
= rss
->info
->string_length
;
10589 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
10590 if (!tmp
&& expr2
->expr_type
== EXPR_OP
10591 && expr2
->value
.op
.op
== INTRINSIC_CONCAT
)
10593 tmp
= concat_str_length (expr2
);
10594 expr2
->ts
.u
.cl
->backend_decl
= gfc_evaluate_now (tmp
, &fblock
);
10596 else if (!tmp
&& expr2
->ts
.u
.cl
->length
)
10599 gfc_init_se (&tmpse
, NULL
);
10600 gfc_conv_expr_type (&tmpse
, expr2
->ts
.u
.cl
->length
,
10601 gfc_charlen_type_node
);
10603 expr2
->ts
.u
.cl
->backend_decl
= gfc_evaluate_now (tmp
, &fblock
);
10605 tmp
= fold_convert (TREE_TYPE (expr1
->ts
.u
.cl
->backend_decl
), tmp
);
10608 if (expr1
->ts
.u
.cl
->backend_decl
10609 && VAR_P (expr1
->ts
.u
.cl
->backend_decl
))
10610 gfc_add_modify (&fblock
, expr1
->ts
.u
.cl
->backend_decl
, tmp
);
10612 gfc_add_modify (&fblock
, lss
->info
->string_length
, tmp
);
10614 if (expr1
->ts
.kind
> 1)
10615 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
10617 tmp
, build_int_cst (TREE_TYPE (tmp
),
10620 else if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.u
.cl
->backend_decl
)
10622 tmp
= TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
)));
10623 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
10624 gfc_array_index_type
, tmp
,
10625 expr1
->ts
.u
.cl
->backend_decl
);
10627 else if (UNLIMITED_POLY (expr1
) && expr2
->ts
.type
!= BT_CLASS
)
10628 tmp
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2
->ts
));
10629 else if (expr1
->ts
.type
== BT_CLASS
&& expr2
->ts
.type
== BT_CLASS
)
10631 tmp
= expr2
->rank
? gfc_get_class_from_expr (desc2
) : NULL_TREE
;
10632 if (tmp
== NULL_TREE
&& expr2
->expr_type
== EXPR_VARIABLE
)
10633 tmp
= class_expr2
= gfc_get_class_from_gfc_expr (expr2
);
10635 if (tmp
!= NULL_TREE
)
10636 tmp
= gfc_class_vtab_size_get (tmp
);
10638 tmp
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&CLASS_DATA (expr2
)->ts
));
10641 tmp
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2
->ts
));
10642 elemsize2
= fold_convert (gfc_array_index_type
, tmp
);
10643 elemsize2
= gfc_evaluate_now (elemsize2
, &fblock
);
10645 /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
10646 deallocated if expr is an array of different shape or any of the
10647 corresponding length type parameter values of variable and expr
10648 differ." This assures F95 compatibility. */
10649 jump_label1
= gfc_build_label_decl (NULL_TREE
);
10650 jump_label2
= gfc_build_label_decl (NULL_TREE
);
10652 /* Allocate if data is NULL. */
10653 cond_null
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
10654 array1
, build_int_cst (TREE_TYPE (array1
), 0));
10656 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10658 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
10660 lss
->info
->string_length
,
10661 rss
->info
->string_length
);
10662 cond_null
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
10663 logical_type_node
, tmp
, cond_null
);
10664 cond_null
= gfc_evaluate_now (cond_null
, &fblock
);
10667 cond_null
= gfc_evaluate_now (cond_null
, &fblock
);
10669 tmp
= build3_v (COND_EXPR
, cond_null
,
10670 build1_v (GOTO_EXPR
, jump_label1
),
10671 build_empty_stmt (input_location
));
10672 gfc_add_expr_to_block (&fblock
, tmp
);
10674 /* Get arrayspec if expr is a full array. */
10675 if (expr2
&& expr2
->expr_type
== EXPR_FUNCTION
10676 && expr2
->value
.function
.isym
10677 && expr2
->value
.function
.isym
->conversion
)
10679 /* For conversion functions, take the arg. */
10680 gfc_expr
*arg
= expr2
->value
.function
.actual
->expr
;
10681 as
= gfc_get_full_arrayspec_from_expr (arg
);
10684 as
= gfc_get_full_arrayspec_from_expr (expr2
);
10688 /* If the lhs shape is not the same as the rhs jump to setting the
10689 bounds and doing the reallocation....... */
10690 for (n
= 0; n
< expr1
->rank
; n
++)
10692 /* Check the shape. */
10693 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
10694 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
10695 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10696 gfc_array_index_type
,
10697 loop
->to
[n
], loop
->from
[n
]);
10698 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
10699 gfc_array_index_type
,
10701 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10702 gfc_array_index_type
,
10704 cond
= fold_build2_loc (input_location
, NE_EXPR
,
10706 tmp
, gfc_index_zero_node
);
10707 tmp
= build3_v (COND_EXPR
, cond
,
10708 build1_v (GOTO_EXPR
, jump_label1
),
10709 build_empty_stmt (input_location
));
10710 gfc_add_expr_to_block (&fblock
, tmp
);
10713 /* ...else if the element lengths are not the same also go to
10714 setting the bounds and doing the reallocation.... */
10715 if (elemsize1
!= NULL_TREE
)
10717 cond
= fold_build2_loc (input_location
, NE_EXPR
,
10719 elemsize1
, elemsize2
);
10720 tmp
= build3_v (COND_EXPR
, cond
,
10721 build1_v (GOTO_EXPR
, jump_label1
),
10722 build_empty_stmt (input_location
));
10723 gfc_add_expr_to_block (&fblock
, tmp
);
10726 /* ....else jump past the (re)alloc code. */
10727 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
10728 gfc_add_expr_to_block (&fblock
, tmp
);
10730 /* Add the label to start automatic (re)allocation. */
10731 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
10732 gfc_add_expr_to_block (&fblock
, tmp
);
10734 /* If the lhs has not been allocated, its bounds will not have been
10735 initialized and so its size is set to zero. */
10736 size1
= gfc_create_var (gfc_array_index_type
, NULL
);
10737 gfc_init_block (&alloc_block
);
10738 gfc_add_modify (&alloc_block
, size1
, gfc_index_zero_node
);
10739 gfc_init_block (&realloc_block
);
10740 gfc_add_modify (&realloc_block
, size1
,
10741 gfc_conv_descriptor_size (desc
, expr1
->rank
));
10742 tmp
= build3_v (COND_EXPR
, cond_null
,
10743 gfc_finish_block (&alloc_block
),
10744 gfc_finish_block (&realloc_block
));
10745 gfc_add_expr_to_block (&fblock
, tmp
);
10747 /* Get the rhs size and fix it. */
10748 size2
= gfc_index_one_node
;
10749 for (n
= 0; n
< expr2
->rank
; n
++)
10751 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10752 gfc_array_index_type
,
10753 loop
->to
[n
], loop
->from
[n
]);
10754 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
10755 gfc_array_index_type
,
10756 tmp
, gfc_index_one_node
);
10757 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
10758 gfc_array_index_type
,
10761 size2
= gfc_evaluate_now (size2
, &fblock
);
10763 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
10766 /* If the lhs is deferred length, assume that the element size
10767 changes and force a reallocation. */
10768 if (expr1
->ts
.deferred
)
10769 neq_size
= gfc_evaluate_now (logical_true_node
, &fblock
);
10771 neq_size
= gfc_evaluate_now (cond
, &fblock
);
10773 /* Deallocation of allocatable components will have to occur on
10774 reallocation. Fix the old descriptor now. */
10775 if ((expr1
->ts
.type
== BT_DERIVED
)
10776 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10777 old_desc
= gfc_evaluate_now (desc
, &fblock
);
10779 old_desc
= NULL_TREE
;
10781 /* Now modify the lhs descriptor and the associated scalarizer
10782 variables. F2003 7.4.1.3: "If variable is or becomes an
10783 unallocated allocatable variable, then it is allocated with each
10784 deferred type parameter equal to the corresponding type parameters
10785 of expr , with the shape of expr , and with each lower bound equal
10786 to the corresponding element of LBOUND(expr)."
10787 Reuse size1 to keep a dimension-by-dimension track of the
10788 stride of the new array. */
10789 size1
= gfc_index_one_node
;
10790 offset
= gfc_index_zero_node
;
10792 for (n
= 0; n
< expr2
->rank
; n
++)
10794 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10795 gfc_array_index_type
,
10796 loop
->to
[n
], loop
->from
[n
]);
10797 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
10798 gfc_array_index_type
,
10799 tmp
, gfc_index_one_node
);
10801 lbound
= gfc_index_one_node
;
10806 lbd
= get_std_lbound (expr2
, desc2
, n
,
10807 as
->type
== AS_ASSUMED_SIZE
);
10808 ubound
= fold_build2_loc (input_location
,
10810 gfc_array_index_type
,
10812 ubound
= fold_build2_loc (input_location
,
10814 gfc_array_index_type
,
10819 gfc_conv_descriptor_lbound_set (&fblock
, desc
,
10822 gfc_conv_descriptor_ubound_set (&fblock
, desc
,
10825 gfc_conv_descriptor_stride_set (&fblock
, desc
,
10828 lbound
= gfc_conv_descriptor_lbound_get (desc
,
10830 tmp2
= fold_build2_loc (input_location
, MULT_EXPR
,
10831 gfc_array_index_type
,
10833 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
10834 gfc_array_index_type
,
10836 size1
= fold_build2_loc (input_location
, MULT_EXPR
,
10837 gfc_array_index_type
,
10841 /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
10842 the array offset is saved and the info.offset is used for a
10843 running offset. Use the saved_offset instead. */
10844 tmp
= gfc_conv_descriptor_offset (desc
);
10845 gfc_add_modify (&fblock
, tmp
, offset
);
10846 if (linfo
->saved_offset
10847 && VAR_P (linfo
->saved_offset
))
10848 gfc_add_modify (&fblock
, linfo
->saved_offset
, tmp
);
10850 /* Now set the deltas for the lhs. */
10851 for (n
= 0; n
< expr1
->rank
; n
++)
10853 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
10855 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10856 gfc_array_index_type
, tmp
,
10858 if (linfo
->delta
[dim
] && VAR_P (linfo
->delta
[dim
]))
10859 gfc_add_modify (&fblock
, linfo
->delta
[dim
], tmp
);
10862 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
10863 gfc_conv_descriptor_span_set (&fblock
, desc
, elemsize2
);
10865 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
10866 gfc_array_index_type
,
10868 size2
= fold_convert (size_type_node
, size2
);
10869 size2
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
10870 size2
, size_one_node
);
10871 size2
= gfc_evaluate_now (size2
, &fblock
);
10873 /* For deferred character length, the 'size' field of the dtype might
10874 have changed so set the dtype. */
10875 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
10876 && expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10879 tmp
= gfc_conv_descriptor_dtype (desc
);
10880 if (expr2
->ts
.u
.cl
->backend_decl
)
10881 type
= gfc_typenode_for_spec (&expr2
->ts
);
10883 type
= gfc_typenode_for_spec (&expr1
->ts
);
10885 gfc_add_modify (&fblock
, tmp
,
10886 gfc_get_dtype_rank_type (expr1
->rank
,type
));
10888 else if (expr1
->ts
.type
== BT_CLASS
)
10891 tmp
= gfc_conv_descriptor_dtype (desc
);
10893 if (expr2
->ts
.type
!= BT_CLASS
)
10894 type
= gfc_typenode_for_spec (&expr2
->ts
);
10896 type
= gfc_get_character_type_len (1, elemsize2
);
10898 gfc_add_modify (&fblock
, tmp
,
10899 gfc_get_dtype_rank_type (expr2
->rank
,type
));
10900 /* Set the _len field as well... */
10901 if (UNLIMITED_POLY (expr1
))
10903 tmp
= gfc_class_len_get (TREE_OPERAND (desc
, 0));
10904 if (expr2
->ts
.type
== BT_CHARACTER
)
10905 gfc_add_modify (&fblock
, tmp
,
10906 fold_convert (TREE_TYPE (tmp
),
10907 TYPE_SIZE_UNIT (type
)));
10909 gfc_add_modify (&fblock
, tmp
,
10910 build_int_cst (TREE_TYPE (tmp
), 0));
10912 /* ...and the vptr. */
10913 tmp
= gfc_class_vptr_get (TREE_OPERAND (desc
, 0));
10914 if (expr2
->ts
.type
== BT_CLASS
&& !VAR_P (desc2
)
10915 && TREE_CODE (desc2
) == COMPONENT_REF
)
10917 tmp2
= gfc_get_class_from_expr (desc2
);
10918 tmp2
= gfc_class_vptr_get (tmp2
);
10920 else if (expr2
->ts
.type
== BT_CLASS
&& class_expr2
!= NULL_TREE
)
10921 tmp2
= gfc_class_vptr_get (class_expr2
);
10924 tmp2
= gfc_get_symbol_decl (gfc_find_vtab (&expr2
->ts
));
10925 tmp2
= gfc_build_addr_expr (TREE_TYPE (tmp
), tmp2
);
10928 gfc_add_modify (&fblock
, tmp
, fold_convert (TREE_TYPE (tmp
), tmp2
));
10930 else if (coarray
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
10932 gfc_add_modify (&fblock
, gfc_conv_descriptor_dtype (desc
),
10933 gfc_get_dtype (TREE_TYPE (desc
)));
10936 /* Realloc expression. Note that the scalarizer uses desc.data
10937 in the array reference - (*desc.data)[<element>]. */
10938 gfc_init_block (&realloc_block
);
10939 gfc_init_se (&caf_se
, NULL
);
10943 token
= gfc_get_ultimate_alloc_ptr_comps_caf_token (&caf_se
, expr1
);
10944 if (token
== NULL_TREE
)
10946 tmp
= gfc_get_tree_for_caf_expr (expr1
);
10947 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
10948 tmp
= build_fold_indirect_ref (tmp
);
10949 gfc_get_caf_token_offset (&caf_se
, &token
, NULL
, tmp
, NULL_TREE
,
10951 token
= gfc_build_addr_expr (NULL_TREE
, token
);
10954 gfc_add_block_to_block (&realloc_block
, &caf_se
.pre
);
10956 if ((expr1
->ts
.type
== BT_DERIVED
)
10957 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10959 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, old_desc
,
10961 gfc_add_expr_to_block (&realloc_block
, tmp
);
10966 tmp
= build_call_expr_loc (input_location
,
10967 builtin_decl_explicit (BUILT_IN_REALLOC
), 2,
10968 fold_convert (pvoid_type_node
, array1
),
10970 gfc_conv_descriptor_data_set (&realloc_block
,
10975 tmp
= build_call_expr_loc (input_location
,
10976 gfor_fndecl_caf_deregister
, 5, token
,
10977 build_int_cst (integer_type_node
,
10978 GFC_CAF_COARRAY_DEALLOCATE_ONLY
),
10979 null_pointer_node
, null_pointer_node
,
10980 integer_zero_node
);
10981 gfc_add_expr_to_block (&realloc_block
, tmp
);
10982 tmp
= build_call_expr_loc (input_location
,
10983 gfor_fndecl_caf_register
,
10985 build_int_cst (integer_type_node
,
10986 GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY
),
10987 token
, gfc_build_addr_expr (NULL_TREE
, desc
),
10988 null_pointer_node
, null_pointer_node
,
10989 integer_zero_node
);
10990 gfc_add_expr_to_block (&realloc_block
, tmp
);
10993 if ((expr1
->ts
.type
== BT_DERIVED
)
10994 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10996 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, desc
,
10998 gfc_add_expr_to_block (&realloc_block
, tmp
);
11001 gfc_add_block_to_block (&realloc_block
, &caf_se
.post
);
11002 realloc_expr
= gfc_finish_block (&realloc_block
);
11004 /* Reallocate if sizes or dynamic types are different. */
11007 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
11008 elemsize1
, elemsize2
);
11009 tmp
= gfc_evaluate_now (tmp
, &fblock
);
11010 neq_size
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
11011 logical_type_node
, neq_size
, tmp
);
11013 tmp
= build3_v (COND_EXPR
, neq_size
, realloc_expr
,
11014 build_empty_stmt (input_location
));
11016 realloc_expr
= tmp
;
11018 /* Malloc expression. */
11019 gfc_init_block (&alloc_block
);
11022 tmp
= build_call_expr_loc (input_location
,
11023 builtin_decl_explicit (BUILT_IN_MALLOC
),
11025 gfc_conv_descriptor_data_set (&alloc_block
,
11030 tmp
= build_call_expr_loc (input_location
,
11031 gfor_fndecl_caf_register
,
11033 build_int_cst (integer_type_node
,
11034 GFC_CAF_COARRAY_ALLOC
),
11035 token
, gfc_build_addr_expr (NULL_TREE
, desc
),
11036 null_pointer_node
, null_pointer_node
,
11037 integer_zero_node
);
11038 gfc_add_expr_to_block (&alloc_block
, tmp
);
11042 /* We already set the dtype in the case of deferred character
11043 length arrays and class lvalues. */
11044 if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
11045 && ((expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
11047 && expr1
->ts
.type
!= BT_CLASS
)
11049 tmp
= gfc_conv_descriptor_dtype (desc
);
11050 gfc_add_modify (&alloc_block
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
11053 if ((expr1
->ts
.type
== BT_DERIVED
)
11054 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
11056 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, desc
,
11058 gfc_add_expr_to_block (&alloc_block
, tmp
);
11060 alloc_expr
= gfc_finish_block (&alloc_block
);
11062 /* Malloc if not allocated; realloc otherwise. */
11063 tmp
= build3_v (COND_EXPR
, cond_null
, alloc_expr
, realloc_expr
);
11064 gfc_add_expr_to_block (&fblock
, tmp
);
11066 /* Make sure that the scalarizer data pointer is updated. */
11067 if (linfo
->data
&& VAR_P (linfo
->data
))
11069 tmp
= gfc_conv_descriptor_data_get (desc
);
11070 gfc_add_modify (&fblock
, linfo
->data
, tmp
);
11073 /* Add the label for same shape lhs and rhs. */
11074 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
11075 gfc_add_expr_to_block (&fblock
, tmp
);
11077 return gfc_finish_block (&fblock
);
11081 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
11082 Do likewise, recursively if necessary, with the allocatable components of
11083 derived types. This function is also called for assumed-rank arrays, which
11084 are always dummy arguments. */
11087 gfc_trans_deferred_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
11093 stmtblock_t cleanup
;
11096 bool sym_has_alloc_comp
, has_finalizer
;
11098 sym_has_alloc_comp
= (sym
->ts
.type
== BT_DERIVED
11099 || sym
->ts
.type
== BT_CLASS
)
11100 && sym
->ts
.u
.derived
->attr
.alloc_comp
;
11101 has_finalizer
= sym
->ts
.type
== BT_CLASS
|| sym
->ts
.type
== BT_DERIVED
11102 ? gfc_is_finalizable (sym
->ts
.u
.derived
, NULL
) : false;
11104 /* Make sure the frontend gets these right. */
11105 gcc_assert (sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym_has_alloc_comp
11107 || (sym
->as
->type
== AS_ASSUMED_RANK
&& sym
->attr
.dummy
));
11109 gfc_save_backend_locus (&loc
);
11110 gfc_set_backend_locus (&sym
->declared_at
);
11111 gfc_init_block (&init
);
11113 gcc_assert (VAR_P (sym
->backend_decl
)
11114 || TREE_CODE (sym
->backend_decl
) == PARM_DECL
);
11116 if (sym
->ts
.type
== BT_CHARACTER
11117 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
11119 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
11120 gfc_trans_vla_type_sizes (sym
, &init
);
11123 /* Dummy, use associated and result variables don't need anything special. */
11124 if (sym
->attr
.dummy
|| sym
->attr
.use_assoc
|| sym
->attr
.result
)
11126 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
11127 gfc_restore_backend_locus (&loc
);
11131 descriptor
= sym
->backend_decl
;
11133 /* Although static, derived types with default initializers and
11134 allocatable components must not be nulled wholesale; instead they
11135 are treated component by component. */
11136 if (TREE_STATIC (descriptor
) && !sym_has_alloc_comp
&& !has_finalizer
)
11138 /* SAVEd variables are not freed on exit. */
11139 gfc_trans_static_array_pointer (sym
);
11141 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
11142 gfc_restore_backend_locus (&loc
);
11146 /* Get the descriptor type. */
11147 type
= TREE_TYPE (sym
->backend_decl
);
11149 if ((sym_has_alloc_comp
|| (has_finalizer
&& sym
->ts
.type
!= BT_CLASS
))
11150 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
11152 if (!sym
->attr
.save
11153 && !(TREE_STATIC (sym
->backend_decl
) && sym
->attr
.is_main_program
))
11155 if (sym
->value
== NULL
11156 || !gfc_has_default_initializer (sym
->ts
.u
.derived
))
11158 rank
= sym
->as
? sym
->as
->rank
: 0;
11159 tmp
= gfc_nullify_alloc_comp (sym
->ts
.u
.derived
,
11161 gfc_add_expr_to_block (&init
, tmp
);
11164 gfc_init_default_dt (sym
, &init
, false);
11167 else if (!GFC_DESCRIPTOR_TYPE_P (type
))
11169 /* If the backend_decl is not a descriptor, we must have a pointer
11171 descriptor
= build_fold_indirect_ref_loc (input_location
,
11172 sym
->backend_decl
);
11173 type
= TREE_TYPE (descriptor
);
11176 /* NULLIFY the data pointer, for non-saved allocatables. */
11177 if (GFC_DESCRIPTOR_TYPE_P (type
) && !sym
->attr
.save
&& sym
->attr
.allocatable
)
11179 gfc_conv_descriptor_data_set (&init
, descriptor
, null_pointer_node
);
11180 if (flag_coarray
== GFC_FCOARRAY_LIB
&& sym
->attr
.codimension
)
11182 /* Declare the variable static so its array descriptor stays present
11183 after leaving the scope. It may still be accessed through another
11184 image. This may happen, for example, with the caf_mpi
11186 TREE_STATIC (descriptor
) = 1;
11187 tmp
= gfc_conv_descriptor_token (descriptor
);
11188 gfc_add_modify (&init
, tmp
, fold_convert (TREE_TYPE (tmp
),
11189 null_pointer_node
));
11193 /* Set initial TKR for pointers and allocatables */
11194 if (GFC_DESCRIPTOR_TYPE_P (type
)
11195 && (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
11199 gcc_assert (sym
->as
&& sym
->as
->rank
>=0);
11200 tmp
= gfc_conv_descriptor_dtype (descriptor
);
11201 etype
= gfc_get_element_type (type
);
11202 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
11203 TREE_TYPE (tmp
), tmp
,
11204 gfc_get_dtype_rank_type (sym
->as
->rank
, etype
));
11205 gfc_add_expr_to_block (&init
, tmp
);
11207 gfc_restore_backend_locus (&loc
);
11208 gfc_init_block (&cleanup
);
11210 /* Allocatable arrays need to be freed when they go out of scope.
11211 The allocatable components of pointers must not be touched. */
11212 if (!sym
->attr
.allocatable
&& has_finalizer
&& sym
->ts
.type
!= BT_CLASS
11213 && !sym
->attr
.pointer
&& !sym
->attr
.artificial
&& !sym
->attr
.save
11214 && !sym
->ns
->proc_name
->attr
.is_main_program
)
11217 sym
->attr
.referenced
= 1;
11218 e
= gfc_lval_expr_from_sym (sym
);
11219 gfc_add_finalizer_call (&cleanup
, e
);
11222 else if ((!sym
->attr
.allocatable
|| !has_finalizer
)
11223 && sym_has_alloc_comp
&& !(sym
->attr
.function
|| sym
->attr
.result
)
11224 && !sym
->attr
.pointer
&& !sym
->attr
.save
11225 && !sym
->ns
->proc_name
->attr
.is_main_program
)
11228 rank
= sym
->as
? sym
->as
->rank
: 0;
11229 tmp
= gfc_deallocate_alloc_comp (sym
->ts
.u
.derived
, descriptor
, rank
);
11230 gfc_add_expr_to_block (&cleanup
, tmp
);
11233 if (sym
->attr
.allocatable
&& (sym
->attr
.dimension
|| sym
->attr
.codimension
)
11234 && !sym
->attr
.save
&& !sym
->attr
.result
11235 && !sym
->ns
->proc_name
->attr
.is_main_program
)
11238 e
= has_finalizer
? gfc_lval_expr_from_sym (sym
) : NULL
;
11239 tmp
= gfc_deallocate_with_status (sym
->backend_decl
, NULL_TREE
, NULL_TREE
,
11240 NULL_TREE
, NULL_TREE
, true, e
,
11241 sym
->attr
.codimension
11242 ? GFC_CAF_COARRAY_DEREGISTER
11243 : GFC_CAF_COARRAY_NOCOARRAY
);
11246 gfc_add_expr_to_block (&cleanup
, tmp
);
11249 gfc_add_init_cleanup (block
, gfc_finish_block (&init
),
11250 gfc_finish_block (&cleanup
));
11253 /************ Expression Walking Functions ******************/
11255 /* Walk a variable reference.
11257 Possible extension - multiple component subscripts.
11258 x(:,:) = foo%a(:)%b(:)
11260 forall (i=..., j=...)
11261 x(i,j) = foo%a(j)%b(i)
11263 This adds a fair amount of complexity because you need to deal with more
11264 than one ref. Maybe handle in a similar manner to vector subscripts.
11265 Maybe not worth the effort. */
11269 gfc_walk_variable_expr (gfc_ss
* ss
, gfc_expr
* expr
)
11273 gfc_fix_class_refs (expr
);
11275 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
11276 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
11279 return gfc_walk_array_ref (ss
, expr
, ref
);
11284 gfc_walk_array_ref (gfc_ss
* ss
, gfc_expr
* expr
, gfc_ref
* ref
)
11290 for (; ref
; ref
= ref
->next
)
11292 if (ref
->type
== REF_SUBSTRING
)
11294 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.start
);
11296 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.end
);
11299 /* We're only interested in array sections from now on. */
11300 if (ref
->type
!= REF_ARRAY
)
11308 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
11309 ss
= gfc_get_scalar_ss (ss
, ar
->start
[n
]);
11313 newss
= gfc_get_array_ss (ss
, expr
, ar
->as
->rank
, GFC_SS_SECTION
);
11314 newss
->info
->data
.array
.ref
= ref
;
11316 /* Make sure array is the same as array(:,:), this way
11317 we don't need to special case all the time. */
11318 ar
->dimen
= ar
->as
->rank
;
11319 for (n
= 0; n
< ar
->dimen
; n
++)
11321 ar
->dimen_type
[n
] = DIMEN_RANGE
;
11323 gcc_assert (ar
->start
[n
] == NULL
);
11324 gcc_assert (ar
->end
[n
] == NULL
);
11325 gcc_assert (ar
->stride
[n
] == NULL
);
11331 newss
= gfc_get_array_ss (ss
, expr
, 0, GFC_SS_SECTION
);
11332 newss
->info
->data
.array
.ref
= ref
;
11334 /* We add SS chains for all the subscripts in the section. */
11335 for (n
= 0; n
< ar
->dimen
; n
++)
11339 switch (ar
->dimen_type
[n
])
11341 case DIMEN_ELEMENT
:
11342 /* Add SS for elemental (scalar) subscripts. */
11343 gcc_assert (ar
->start
[n
]);
11344 indexss
= gfc_get_scalar_ss (gfc_ss_terminator
, ar
->start
[n
]);
11345 indexss
->loop_chain
= gfc_ss_terminator
;
11346 newss
->info
->data
.array
.subscript
[n
] = indexss
;
11350 /* We don't add anything for sections, just remember this
11351 dimension for later. */
11352 newss
->dim
[newss
->dimen
] = n
;
11357 /* Create a GFC_SS_VECTOR index in which we can store
11358 the vector's descriptor. */
11359 indexss
= gfc_get_array_ss (gfc_ss_terminator
, ar
->start
[n
],
11361 indexss
->loop_chain
= gfc_ss_terminator
;
11362 newss
->info
->data
.array
.subscript
[n
] = indexss
;
11363 newss
->dim
[newss
->dimen
] = n
;
11368 /* We should know what sort of section it is by now. */
11369 gcc_unreachable ();
11372 /* We should have at least one non-elemental dimension,
11373 unless we are creating a descriptor for a (scalar) coarray. */
11374 gcc_assert (newss
->dimen
> 0
11375 || newss
->info
->data
.array
.ref
->u
.ar
.as
->corank
> 0);
11380 /* We should know what sort of section it is by now. */
11381 gcc_unreachable ();
11389 /* Walk an expression operator. If only one operand of a binary expression is
11390 scalar, we must also add the scalar term to the SS chain. */
11393 gfc_walk_op_expr (gfc_ss
* ss
, gfc_expr
* expr
)
11398 head
= gfc_walk_subexpr (ss
, expr
->value
.op
.op1
);
11399 if (expr
->value
.op
.op2
== NULL
)
11402 head2
= gfc_walk_subexpr (head
, expr
->value
.op
.op2
);
11404 /* All operands are scalar. Pass back and let the caller deal with it. */
11408 /* All operands require scalarization. */
11409 if (head
!= ss
&& (expr
->value
.op
.op2
== NULL
|| head2
!= head
))
11412 /* One of the operands needs scalarization, the other is scalar.
11413 Create a gfc_ss for the scalar expression. */
11416 /* First operand is scalar. We build the chain in reverse order, so
11417 add the scalar SS after the second operand. */
11419 while (head
&& head
->next
!= ss
)
11421 /* Check we haven't somehow broken the chain. */
11423 head
->next
= gfc_get_scalar_ss (ss
, expr
->value
.op
.op1
);
11425 else /* head2 == head */
11427 gcc_assert (head2
== head
);
11428 /* Second operand is scalar. */
11429 head2
= gfc_get_scalar_ss (head2
, expr
->value
.op
.op2
);
11436 /* Reverse a SS chain. */
11439 gfc_reverse_ss (gfc_ss
* ss
)
11444 gcc_assert (ss
!= NULL
);
11446 head
= gfc_ss_terminator
;
11447 while (ss
!= gfc_ss_terminator
)
11450 /* Check we didn't somehow break the chain. */
11451 gcc_assert (next
!= NULL
);
11461 /* Given an expression referring to a procedure, return the symbol of its
11462 interface. We can't get the procedure symbol directly as we have to handle
11463 the case of (deferred) type-bound procedures. */
11466 gfc_get_proc_ifc_for_expr (gfc_expr
*procedure_ref
)
11471 if (procedure_ref
== NULL
)
11474 /* Normal procedure case. */
11475 if (procedure_ref
->expr_type
== EXPR_FUNCTION
11476 && procedure_ref
->value
.function
.esym
)
11477 sym
= procedure_ref
->value
.function
.esym
;
11479 sym
= procedure_ref
->symtree
->n
.sym
;
11481 /* Typebound procedure case. */
11482 for (ref
= procedure_ref
->ref
; ref
; ref
= ref
->next
)
11484 if (ref
->type
== REF_COMPONENT
11485 && ref
->u
.c
.component
->attr
.proc_pointer
)
11486 sym
= ref
->u
.c
.component
->ts
.interface
;
11495 /* Given an expression referring to an intrinsic function call,
11496 return the intrinsic symbol. */
11498 gfc_intrinsic_sym
*
11499 gfc_get_intrinsic_for_expr (gfc_expr
*call
)
11504 /* Normal procedure case. */
11505 if (call
->expr_type
== EXPR_FUNCTION
)
11506 return call
->value
.function
.isym
;
11512 /* Indicates whether an argument to an intrinsic function should be used in
11513 scalarization. It is usually the case, except for some intrinsics
11514 requiring the value to be constant, and using the value at compile time only.
11515 As the value is not used at runtime in those cases, we don’t produce code
11516 for it, and it should not be visible to the scalarizer.
11517 FUNCTION is the intrinsic function being called, ACTUAL_ARG is the actual
11518 argument being examined in that call, and ARG_NUM the index number
11519 of ACTUAL_ARG in the list of arguments.
11520 The intrinsic procedure’s dummy argument associated with ACTUAL_ARG is
11521 identified using the name in ACTUAL_ARG if it is present (that is: if it’s
11522 a keyword argument), otherwise using ARG_NUM. */
11525 arg_evaluated_for_scalarization (gfc_intrinsic_sym
*function
,
11526 gfc_dummy_arg
*dummy_arg
)
11528 if (function
!= NULL
&& dummy_arg
!= NULL
)
11530 switch (function
->id
)
11532 case GFC_ISYM_INDEX
:
11533 case GFC_ISYM_LEN_TRIM
:
11534 case GFC_ISYM_MASKL
:
11535 case GFC_ISYM_MASKR
:
11536 case GFC_ISYM_SCAN
:
11537 case GFC_ISYM_VERIFY
:
11538 if (strcmp ("kind", gfc_dummy_arg_get_name (*dummy_arg
)) == 0)
11551 /* Walk the arguments of an elemental function.
11552 PROC_EXPR is used to check whether an argument is permitted to be absent. If
11553 it is NULL, we don't do the check and the argument is assumed to be present.
11557 gfc_walk_elemental_function_args (gfc_ss
* ss
, gfc_actual_arglist
*arg
,
11558 gfc_intrinsic_sym
*intrinsic_sym
,
11566 head
= gfc_ss_terminator
;
11570 for (; arg
; arg
= arg
->next
)
11572 gfc_dummy_arg
* const dummy_arg
= arg
->associated_dummy
;
11574 || arg
->expr
->expr_type
== EXPR_NULL
11575 || !arg_evaluated_for_scalarization (intrinsic_sym
, dummy_arg
))
11578 newss
= gfc_walk_subexpr (head
, arg
->expr
);
11581 /* Scalar argument. */
11582 gcc_assert (type
== GFC_SS_SCALAR
|| type
== GFC_SS_REFERENCE
);
11583 newss
= gfc_get_scalar_ss (head
, arg
->expr
);
11584 newss
->info
->type
= type
;
11586 newss
->info
->data
.scalar
.dummy_arg
= dummy_arg
;
11591 if (dummy_arg
!= NULL
11592 && gfc_dummy_arg_is_optional (*dummy_arg
)
11593 && arg
->expr
->expr_type
== EXPR_VARIABLE
11594 && (gfc_expr_attr (arg
->expr
).optional
11595 || gfc_expr_attr (arg
->expr
).allocatable
11596 || gfc_expr_attr (arg
->expr
).pointer
))
11597 newss
->info
->can_be_null_ref
= true;
11603 while (tail
->next
!= gfc_ss_terminator
)
11610 /* If all the arguments are scalar we don't need the argument SS. */
11611 gfc_free_ss_chain (head
);
11612 /* Pass it back. */
11616 /* Add it onto the existing chain. */
11622 /* Walk a function call. Scalar functions are passed back, and taken out of
11623 scalarization loops. For elemental functions we walk their arguments.
11624 The result of functions returning arrays is stored in a temporary outside
11625 the loop, so that the function is only called once. Hence we do not need
11626 to walk their arguments. */
11629 gfc_walk_function_expr (gfc_ss
* ss
, gfc_expr
* expr
)
11631 gfc_intrinsic_sym
*isym
;
11633 gfc_component
*comp
= NULL
;
11635 isym
= expr
->value
.function
.isym
;
11637 /* Handle intrinsic functions separately. */
11639 return gfc_walk_intrinsic_function (ss
, expr
, isym
);
11641 sym
= expr
->value
.function
.esym
;
11643 sym
= expr
->symtree
->n
.sym
;
11645 if (gfc_is_class_array_function (expr
))
11646 return gfc_get_array_ss (ss
, expr
,
11647 CLASS_DATA (expr
->value
.function
.esym
->result
)->as
->rank
,
11650 /* A function that returns arrays. */
11651 comp
= gfc_get_proc_ptr_comp (expr
);
11652 if ((!comp
&& gfc_return_by_reference (sym
) && sym
->result
->attr
.dimension
)
11653 || (comp
&& comp
->attr
.dimension
))
11654 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
11656 /* Walk the parameters of an elemental function. For now we always pass
11658 if (sym
->attr
.elemental
|| (comp
&& comp
->attr
.elemental
))
11660 gfc_ss
*old_ss
= ss
;
11662 ss
= gfc_walk_elemental_function_args (old_ss
,
11663 expr
->value
.function
.actual
,
11664 gfc_get_intrinsic_for_expr (expr
),
11668 || sym
->attr
.proc_pointer
11669 || sym
->attr
.if_source
!= IFSRC_DECL
11670 || sym
->attr
.array_outer_dependency
))
11671 ss
->info
->array_outer_dependency
= 1;
11674 /* Scalar functions are OK as these are evaluated outside the scalarization
11675 loop. Pass back and let the caller deal with it. */
11680 /* An array temporary is constructed for array constructors. */
11683 gfc_walk_array_constructor (gfc_ss
* ss
, gfc_expr
* expr
)
11685 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_CONSTRUCTOR
);
11689 /* Walk an expression. Add walked expressions to the head of the SS chain.
11690 A wholly scalar expression will not be added. */
11693 gfc_walk_subexpr (gfc_ss
* ss
, gfc_expr
* expr
)
11697 switch (expr
->expr_type
)
11699 case EXPR_VARIABLE
:
11700 head
= gfc_walk_variable_expr (ss
, expr
);
11704 head
= gfc_walk_op_expr (ss
, expr
);
11707 case EXPR_FUNCTION
:
11708 head
= gfc_walk_function_expr (ss
, expr
);
11711 case EXPR_CONSTANT
:
11713 case EXPR_STRUCTURE
:
11714 /* Pass back and let the caller deal with it. */
11718 head
= gfc_walk_array_constructor (ss
, expr
);
11721 case EXPR_SUBSTRING
:
11722 /* Pass back and let the caller deal with it. */
11726 gfc_internal_error ("bad expression type during walk (%d)",
11733 /* Entry point for expression walking.
11734 A return value equal to the passed chain means this is
11735 a scalar expression. It is up to the caller to take whatever action is
11736 necessary to translate these. */
11739 gfc_walk_expr (gfc_expr
* expr
)
11743 res
= gfc_walk_subexpr (gfc_ss_terminator
, expr
);
11744 return gfc_reverse_ss (res
);