1 /* Array translation routines
2 Copyright (C) 2002-2021 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
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.c-- 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
)));
107 /* Build expressions to access the members of an array descriptor.
108 It's surprisingly easy to mess up here, so never access
109 an array descriptor by "brute force", always use these
110 functions. This also avoids problems if we change the format
111 of an array descriptor.
113 To understand these magic numbers, look at the comments
114 before gfc_build_array_type() in trans-types.c.
116 The code within these defines should be the only code which knows the format
117 of an array descriptor.
119 Any code just needing to read obtain the bounds of an array should use
120 gfc_conv_array_* rather than the following functions as these will return
121 know constant values, and work with arrays which do not have descriptors.
123 Don't forget to #undef these! */
126 #define OFFSET_FIELD 1
127 #define DTYPE_FIELD 2
129 #define DIMENSION_FIELD 4
130 #define CAF_TOKEN_FIELD 5
132 #define STRIDE_SUBFIELD 0
133 #define LBOUND_SUBFIELD 1
134 #define UBOUND_SUBFIELD 2
137 gfc_get_descriptor_field (tree desc
, unsigned field_idx
)
139 tree type
= TREE_TYPE (desc
);
140 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
142 tree field
= gfc_advance_chain (TYPE_FIELDS (type
), field_idx
);
143 gcc_assert (field
!= NULL_TREE
);
145 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
146 desc
, field
, NULL_TREE
);
149 /* This provides READ-ONLY access to the data field. The field itself
150 doesn't have the proper type. */
153 gfc_conv_descriptor_data_get (tree desc
)
155 tree type
= TREE_TYPE (desc
);
156 if (TREE_CODE (type
) == REFERENCE_TYPE
)
159 tree field
= gfc_get_descriptor_field (desc
, DATA_FIELD
);
160 return fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type
), field
);
163 /* This provides WRITE access to the data field.
165 TUPLES_P is true if we are generating tuples.
167 This function gets called through the following macros:
168 gfc_conv_descriptor_data_set
169 gfc_conv_descriptor_data_set. */
172 gfc_conv_descriptor_data_set (stmtblock_t
*block
, tree desc
, tree value
)
174 tree field
= gfc_get_descriptor_field (desc
, DATA_FIELD
);
175 gfc_add_modify (block
, field
, fold_convert (TREE_TYPE (field
), value
));
179 /* This provides address access to the data field. This should only be
180 used by array allocation, passing this on to the runtime. */
183 gfc_conv_descriptor_data_addr (tree desc
)
185 tree field
= gfc_get_descriptor_field (desc
, DATA_FIELD
);
186 return gfc_build_addr_expr (NULL_TREE
, field
);
190 gfc_conv_descriptor_offset (tree desc
)
192 tree field
= gfc_get_descriptor_field (desc
, OFFSET_FIELD
);
193 gcc_assert (TREE_TYPE (field
) == gfc_array_index_type
);
198 gfc_conv_descriptor_offset_get (tree desc
)
200 return gfc_conv_descriptor_offset (desc
);
204 gfc_conv_descriptor_offset_set (stmtblock_t
*block
, tree desc
,
207 tree t
= gfc_conv_descriptor_offset (desc
);
208 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
213 gfc_conv_descriptor_dtype (tree desc
)
215 tree field
= gfc_get_descriptor_field (desc
, DTYPE_FIELD
);
216 gcc_assert (TREE_TYPE (field
) == get_dtype_type_node ());
221 gfc_conv_descriptor_span (tree desc
)
223 tree field
= gfc_get_descriptor_field (desc
, SPAN_FIELD
);
224 gcc_assert (TREE_TYPE (field
) == gfc_array_index_type
);
229 gfc_conv_descriptor_span_get (tree desc
)
231 return gfc_conv_descriptor_span (desc
);
235 gfc_conv_descriptor_span_set (stmtblock_t
*block
, tree desc
,
238 tree t
= gfc_conv_descriptor_span (desc
);
239 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
244 gfc_conv_descriptor_rank (tree desc
)
249 dtype
= gfc_conv_descriptor_dtype (desc
);
250 tmp
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype
)), GFC_DTYPE_RANK
);
251 gcc_assert (tmp
!= NULL_TREE
252 && TREE_TYPE (tmp
) == signed_char_type_node
);
253 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (tmp
),
254 dtype
, tmp
, NULL_TREE
);
258 /* Return the element length from the descriptor dtype field. */
261 gfc_conv_descriptor_elem_len (tree desc
)
266 dtype
= gfc_conv_descriptor_dtype (desc
);
267 tmp
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype
)),
269 gcc_assert (tmp
!= NULL_TREE
270 && TREE_TYPE (tmp
) == size_type_node
);
271 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (tmp
),
272 dtype
, tmp
, NULL_TREE
);
277 gfc_conv_descriptor_attribute (tree desc
)
282 dtype
= gfc_conv_descriptor_dtype (desc
);
283 tmp
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype
)),
284 GFC_DTYPE_ATTRIBUTE
);
285 gcc_assert (tmp
!= NULL_TREE
286 && TREE_TYPE (tmp
) == short_integer_type_node
);
287 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (tmp
),
288 dtype
, tmp
, NULL_TREE
);
292 gfc_get_descriptor_dimension (tree desc
)
294 tree field
= gfc_get_descriptor_field (desc
, DIMENSION_FIELD
);
295 gcc_assert (TREE_CODE (TREE_TYPE (field
)) == ARRAY_TYPE
296 && TREE_CODE (TREE_TYPE (TREE_TYPE (field
))) == RECORD_TYPE
);
302 gfc_conv_descriptor_dimension (tree desc
, tree dim
)
306 tmp
= gfc_get_descriptor_dimension (desc
);
308 return gfc_build_array_ref (tmp
, dim
, NULL
);
313 gfc_conv_descriptor_token (tree desc
)
315 gcc_assert (flag_coarray
== GFC_FCOARRAY_LIB
);
316 tree field
= gfc_get_descriptor_field (desc
, CAF_TOKEN_FIELD
);
317 /* Should be a restricted pointer - except in the finalization wrapper. */
318 gcc_assert (TREE_TYPE (field
) == prvoid_type_node
319 || TREE_TYPE (field
) == pvoid_type_node
);
324 gfc_conv_descriptor_subfield (tree desc
, tree dim
, unsigned field_idx
)
326 tree tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
327 tree field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)), field_idx
);
328 gcc_assert (field
!= NULL_TREE
);
330 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
331 tmp
, field
, NULL_TREE
);
335 gfc_conv_descriptor_stride (tree desc
, tree dim
)
337 tree field
= gfc_conv_descriptor_subfield (desc
, dim
, STRIDE_SUBFIELD
);
338 gcc_assert (TREE_TYPE (field
) == gfc_array_index_type
);
343 gfc_conv_descriptor_stride_get (tree desc
, tree dim
)
345 tree type
= TREE_TYPE (desc
);
346 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
347 if (integer_zerop (dim
)
348 && (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ALLOCATABLE
349 ||GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE_CONT
350 ||GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_RANK_CONT
351 ||GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER_CONT
))
352 return gfc_index_one_node
;
354 return gfc_conv_descriptor_stride (desc
, dim
);
358 gfc_conv_descriptor_stride_set (stmtblock_t
*block
, tree desc
,
359 tree dim
, tree value
)
361 tree t
= gfc_conv_descriptor_stride (desc
, dim
);
362 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
366 gfc_conv_descriptor_lbound (tree desc
, tree dim
)
368 tree field
= gfc_conv_descriptor_subfield (desc
, dim
, LBOUND_SUBFIELD
);
369 gcc_assert (TREE_TYPE (field
) == gfc_array_index_type
);
374 gfc_conv_descriptor_lbound_get (tree desc
, tree dim
)
376 return gfc_conv_descriptor_lbound (desc
, dim
);
380 gfc_conv_descriptor_lbound_set (stmtblock_t
*block
, tree desc
,
381 tree dim
, tree value
)
383 tree t
= gfc_conv_descriptor_lbound (desc
, dim
);
384 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
388 gfc_conv_descriptor_ubound (tree desc
, tree dim
)
390 tree field
= gfc_conv_descriptor_subfield (desc
, dim
, UBOUND_SUBFIELD
);
391 gcc_assert (TREE_TYPE (field
) == gfc_array_index_type
);
396 gfc_conv_descriptor_ubound_get (tree desc
, tree dim
)
398 return gfc_conv_descriptor_ubound (desc
, dim
);
402 gfc_conv_descriptor_ubound_set (stmtblock_t
*block
, tree desc
,
403 tree dim
, tree value
)
405 tree t
= gfc_conv_descriptor_ubound (desc
, dim
);
406 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
409 /* Build a null array descriptor constructor. */
412 gfc_build_null_descriptor (tree type
)
417 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
418 gcc_assert (DATA_FIELD
== 0);
419 field
= TYPE_FIELDS (type
);
421 /* Set a NULL data pointer. */
422 tmp
= build_constructor_single (type
, field
, null_pointer_node
);
423 TREE_CONSTANT (tmp
) = 1;
424 /* All other fields are ignored. */
430 /* Modify a descriptor such that the lbound of a given dimension is the value
431 specified. This also updates ubound and offset accordingly. */
434 gfc_conv_shift_descriptor_lbound (stmtblock_t
* block
, tree desc
,
435 int dim
, tree new_lbound
)
437 tree offs
, ubound
, lbound
, stride
;
438 tree diff
, offs_diff
;
440 new_lbound
= fold_convert (gfc_array_index_type
, new_lbound
);
442 offs
= gfc_conv_descriptor_offset_get (desc
);
443 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]);
444 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]);
445 stride
= gfc_conv_descriptor_stride_get (desc
, gfc_rank_cst
[dim
]);
447 /* Get difference (new - old) by which to shift stuff. */
448 diff
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
451 /* Shift ubound and offset accordingly. This has to be done before
452 updating the lbound, as they depend on the lbound expression! */
453 ubound
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
455 gfc_conv_descriptor_ubound_set (block
, desc
, gfc_rank_cst
[dim
], ubound
);
456 offs_diff
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
458 offs
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
460 gfc_conv_descriptor_offset_set (block
, desc
, offs
);
462 /* Finally set lbound to value we want. */
463 gfc_conv_descriptor_lbound_set (block
, desc
, gfc_rank_cst
[dim
], new_lbound
);
467 /* Obtain offsets for trans-types.c(gfc_get_array_descr_info). */
470 gfc_get_descriptor_offsets_for_info (const_tree desc_type
, tree
*data_off
,
471 tree
*dtype_off
, tree
*span_off
,
472 tree
*dim_off
, tree
*dim_size
,
473 tree
*stride_suboff
, tree
*lower_suboff
,
479 type
= TYPE_MAIN_VARIANT (desc_type
);
480 field
= gfc_advance_chain (TYPE_FIELDS (type
), DATA_FIELD
);
481 *data_off
= byte_position (field
);
482 field
= gfc_advance_chain (TYPE_FIELDS (type
), DTYPE_FIELD
);
483 *dtype_off
= byte_position (field
);
484 field
= gfc_advance_chain (TYPE_FIELDS (type
), SPAN_FIELD
);
485 *span_off
= byte_position (field
);
486 field
= gfc_advance_chain (TYPE_FIELDS (type
), DIMENSION_FIELD
);
487 *dim_off
= byte_position (field
);
488 type
= TREE_TYPE (TREE_TYPE (field
));
489 *dim_size
= TYPE_SIZE_UNIT (type
);
490 field
= gfc_advance_chain (TYPE_FIELDS (type
), STRIDE_SUBFIELD
);
491 *stride_suboff
= byte_position (field
);
492 field
= gfc_advance_chain (TYPE_FIELDS (type
), LBOUND_SUBFIELD
);
493 *lower_suboff
= byte_position (field
);
494 field
= gfc_advance_chain (TYPE_FIELDS (type
), UBOUND_SUBFIELD
);
495 *upper_suboff
= byte_position (field
);
499 /* Cleanup those #defines. */
505 #undef DIMENSION_FIELD
506 #undef CAF_TOKEN_FIELD
507 #undef STRIDE_SUBFIELD
508 #undef LBOUND_SUBFIELD
509 #undef UBOUND_SUBFIELD
512 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
513 flags & 1 = Main loop body.
514 flags & 2 = temp copy loop. */
517 gfc_mark_ss_chain_used (gfc_ss
* ss
, unsigned flags
)
519 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
520 ss
->info
->useflags
= flags
;
524 /* Free a gfc_ss chain. */
527 gfc_free_ss_chain (gfc_ss
* ss
)
531 while (ss
!= gfc_ss_terminator
)
533 gcc_assert (ss
!= NULL
);
542 free_ss_info (gfc_ss_info
*ss_info
)
547 if (ss_info
->refcount
> 0)
550 gcc_assert (ss_info
->refcount
== 0);
552 switch (ss_info
->type
)
555 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
556 if (ss_info
->data
.array
.subscript
[n
])
557 gfc_free_ss_chain (ss_info
->data
.array
.subscript
[n
]);
571 gfc_free_ss (gfc_ss
* ss
)
573 free_ss_info (ss
->info
);
578 /* Creates and initializes an array type gfc_ss struct. */
581 gfc_get_array_ss (gfc_ss
*next
, gfc_expr
*expr
, int dimen
, gfc_ss_type type
)
584 gfc_ss_info
*ss_info
;
587 ss_info
= gfc_get_ss_info ();
589 ss_info
->type
= type
;
590 ss_info
->expr
= expr
;
596 for (i
= 0; i
< ss
->dimen
; i
++)
603 /* Creates and initializes a temporary type gfc_ss struct. */
606 gfc_get_temp_ss (tree type
, tree string_length
, int dimen
)
609 gfc_ss_info
*ss_info
;
612 ss_info
= gfc_get_ss_info ();
614 ss_info
->type
= GFC_SS_TEMP
;
615 ss_info
->string_length
= string_length
;
616 ss_info
->data
.temp
.type
= type
;
620 ss
->next
= gfc_ss_terminator
;
622 for (i
= 0; i
< ss
->dimen
; i
++)
629 /* Creates and initializes a scalar type gfc_ss struct. */
632 gfc_get_scalar_ss (gfc_ss
*next
, gfc_expr
*expr
)
635 gfc_ss_info
*ss_info
;
637 ss_info
= gfc_get_ss_info ();
639 ss_info
->type
= GFC_SS_SCALAR
;
640 ss_info
->expr
= expr
;
650 /* Free all the SS associated with a loop. */
653 gfc_cleanup_loop (gfc_loopinfo
* loop
)
655 gfc_loopinfo
*loop_next
, **ploop
;
660 while (ss
!= gfc_ss_terminator
)
662 gcc_assert (ss
!= NULL
);
663 next
= ss
->loop_chain
;
668 /* Remove reference to self in the parent loop. */
670 for (ploop
= &loop
->parent
->nested
; *ploop
; ploop
= &(*ploop
)->next
)
677 /* Free non-freed nested loops. */
678 for (loop
= loop
->nested
; loop
; loop
= loop_next
)
680 loop_next
= loop
->next
;
681 gfc_cleanup_loop (loop
);
688 set_ss_loop (gfc_ss
*ss
, gfc_loopinfo
*loop
)
692 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
696 if (ss
->info
->type
== GFC_SS_SCALAR
697 || ss
->info
->type
== GFC_SS_REFERENCE
698 || ss
->info
->type
== GFC_SS_TEMP
)
701 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
702 if (ss
->info
->data
.array
.subscript
[n
] != NULL
)
703 set_ss_loop (ss
->info
->data
.array
.subscript
[n
], loop
);
708 /* Associate a SS chain with a loop. */
711 gfc_add_ss_to_loop (gfc_loopinfo
* loop
, gfc_ss
* head
)
714 gfc_loopinfo
*nested_loop
;
716 if (head
== gfc_ss_terminator
)
719 set_ss_loop (head
, loop
);
722 for (; ss
&& ss
!= gfc_ss_terminator
; ss
= ss
->next
)
726 nested_loop
= ss
->nested_ss
->loop
;
728 /* More than one ss can belong to the same loop. Hence, we add the
729 loop to the chain only if it is different from the previously
730 added one, to avoid duplicate nested loops. */
731 if (nested_loop
!= loop
->nested
)
733 gcc_assert (nested_loop
->parent
== NULL
);
734 nested_loop
->parent
= loop
;
736 gcc_assert (nested_loop
->next
== NULL
);
737 nested_loop
->next
= loop
->nested
;
738 loop
->nested
= nested_loop
;
741 gcc_assert (nested_loop
->parent
== loop
);
744 if (ss
->next
== gfc_ss_terminator
)
745 ss
->loop_chain
= loop
->ss
;
747 ss
->loop_chain
= ss
->next
;
749 gcc_assert (ss
== gfc_ss_terminator
);
754 /* Returns true if the expression is an array pointer. */
757 is_pointer_array (tree expr
)
759 if (expr
== NULL_TREE
760 || !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr
))
761 || GFC_CLASS_TYPE_P (TREE_TYPE (expr
)))
764 if (TREE_CODE (expr
) == VAR_DECL
765 && GFC_DECL_PTR_ARRAY_P (expr
))
768 if (TREE_CODE (expr
) == PARM_DECL
769 && GFC_DECL_PTR_ARRAY_P (expr
))
772 if (TREE_CODE (expr
) == INDIRECT_REF
773 && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr
, 0)))
776 /* The field declaration is marked as an pointer array. */
777 if (TREE_CODE (expr
) == COMPONENT_REF
778 && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr
, 1))
779 && !GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (expr
, 1))))
786 /* If the symbol or expression reference a CFI descriptor, return the
787 pointer to the converted gfc descriptor. If an array reference is
788 present as the last argument, check that it is the one applied to
789 the CFI descriptor in the expression. Note that the CFI object is
790 always the symbol in the expression! */
793 get_CFI_desc (gfc_symbol
*sym
, gfc_expr
*expr
,
794 tree
*desc
, gfc_array_ref
*ar
)
798 if (!is_CFI_desc (sym
, expr
))
803 if (!(expr
->ref
&& expr
->ref
->type
== REF_ARRAY
)
804 || (&expr
->ref
->u
.ar
!= ar
))
809 tmp
= expr
->symtree
->n
.sym
->backend_decl
;
811 tmp
= sym
->backend_decl
;
813 if (tmp
&& DECL_LANG_SPECIFIC (tmp
) && GFC_DECL_SAVED_DESCRIPTOR (tmp
))
814 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmp
);
821 /* Return the span of an array. */
824 gfc_get_array_span (tree desc
, gfc_expr
*expr
)
828 if (is_pointer_array (desc
) || get_CFI_desc (NULL
, expr
, &desc
, NULL
))
830 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
831 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
833 /* This will have the span field set. */
834 tmp
= gfc_conv_descriptor_span_get (desc
);
836 else if (TREE_CODE (desc
) == COMPONENT_REF
837 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
838 && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (desc
, 0))))
840 /* The descriptor is a class _data field and so use the vtable
841 size for the receiving span field. */
842 tmp
= gfc_get_vptr_from_expr (desc
);
843 tmp
= gfc_vptr_size_get (tmp
);
845 else if (expr
&& expr
->expr_type
== EXPR_VARIABLE
846 && expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
847 && expr
->ref
->type
== REF_COMPONENT
848 && expr
->ref
->next
->type
== REF_ARRAY
849 && expr
->ref
->next
->next
== NULL
850 && CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.dimension
)
852 /* Dummys come in sometimes with the descriptor detached from
853 the class field or declaration. */
854 tmp
= gfc_class_vptr_get (expr
->symtree
->n
.sym
->backend_decl
);
855 tmp
= gfc_vptr_size_get (tmp
);
859 /* If none of the fancy stuff works, the span is the element
860 size of the array. Attempt to deal with unbounded character
861 types if possible. Otherwise, return NULL_TREE. */
862 tmp
= gfc_get_element_type (TREE_TYPE (desc
));
863 if (tmp
&& TREE_CODE (tmp
) == ARRAY_TYPE
&& TYPE_STRING_FLAG (tmp
))
865 gcc_assert (expr
->ts
.type
== BT_CHARACTER
);
867 tmp
= gfc_get_character_len_in_bytes (tmp
);
869 if (tmp
== NULL_TREE
|| integer_zerop (tmp
))
873 tmp
= gfc_get_expr_charlen (expr
);
874 tmp
= fold_convert (gfc_array_index_type
, tmp
);
875 bs
= build_int_cst (gfc_array_index_type
, expr
->ts
.kind
);
876 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
877 gfc_array_index_type
, tmp
, bs
);
880 tmp
= (tmp
&& !integer_zerop (tmp
))
881 ? (fold_convert (gfc_array_index_type
, tmp
)) : (NULL_TREE
);
884 tmp
= fold_convert (gfc_array_index_type
,
885 size_in_bytes (tmp
));
891 /* Generate an initializer for a static pointer or allocatable array. */
894 gfc_trans_static_array_pointer (gfc_symbol
* sym
)
898 gcc_assert (TREE_STATIC (sym
->backend_decl
));
899 /* Just zero the data member. */
900 type
= TREE_TYPE (sym
->backend_decl
);
901 DECL_INITIAL (sym
->backend_decl
) = gfc_build_null_descriptor (type
);
905 /* If the bounds of SE's loop have not yet been set, see if they can be
906 determined from array spec AS, which is the array spec of a called
907 function. MAPPING maps the callee's dummy arguments to the values
908 that the caller is passing. Add any initialization and finalization
912 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping
* mapping
,
913 gfc_se
* se
, gfc_array_spec
* as
)
915 int n
, dim
, total_dim
;
924 if (!as
|| as
->type
!= AS_EXPLICIT
)
927 for (ss
= se
->ss
; ss
; ss
= ss
->parent
)
929 total_dim
+= ss
->loop
->dimen
;
930 for (n
= 0; n
< ss
->loop
->dimen
; n
++)
932 /* The bound is known, nothing to do. */
933 if (ss
->loop
->to
[n
] != NULL_TREE
)
937 gcc_assert (dim
< as
->rank
);
938 gcc_assert (ss
->loop
->dimen
<= as
->rank
);
940 /* Evaluate the lower bound. */
941 gfc_init_se (&tmpse
, NULL
);
942 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->lower
[dim
]);
943 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
944 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
945 lower
= fold_convert (gfc_array_index_type
, tmpse
.expr
);
947 /* ...and the upper bound. */
948 gfc_init_se (&tmpse
, NULL
);
949 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->upper
[dim
]);
950 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
951 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
952 upper
= fold_convert (gfc_array_index_type
, tmpse
.expr
);
954 /* Set the upper bound of the loop to UPPER - LOWER. */
955 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
956 gfc_array_index_type
, upper
, lower
);
957 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
958 ss
->loop
->to
[n
] = tmp
;
962 gcc_assert (total_dim
== as
->rank
);
966 /* Generate code to allocate an array temporary, or create a variable to
967 hold the data. If size is NULL, zero the descriptor so that the
968 callee will allocate the array. If DEALLOC is true, also generate code to
969 free the array afterwards.
971 If INITIAL is not NULL, it is packed using internal_pack and the result used
972 as data instead of allocating a fresh, unitialized area of memory.
974 Initialization code is added to PRE and finalization code to POST.
975 DYNAMIC is true if the caller may want to extend the array later
976 using realloc. This prevents us from putting the array on the stack. */
979 gfc_trans_allocate_array_storage (stmtblock_t
* pre
, stmtblock_t
* post
,
980 gfc_array_info
* info
, tree size
, tree nelem
,
981 tree initial
, bool dynamic
, bool dealloc
)
987 desc
= info
->descriptor
;
988 info
->offset
= gfc_index_zero_node
;
989 if (size
== NULL_TREE
|| integer_zerop (size
))
991 /* A callee allocated array. */
992 gfc_conv_descriptor_data_set (pre
, desc
, null_pointer_node
);
997 /* Allocate the temporary. */
998 onstack
= !dynamic
&& initial
== NULL_TREE
999 && (flag_stack_arrays
1000 || gfc_can_put_var_on_stack (size
));
1004 /* Make a temporary variable to hold the data. */
1005 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (nelem
),
1006 nelem
, gfc_index_one_node
);
1007 tmp
= gfc_evaluate_now (tmp
, pre
);
1008 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
1010 tmp
= build_array_type (gfc_get_element_type (TREE_TYPE (desc
)),
1012 tmp
= gfc_create_var (tmp
, "A");
1013 /* If we're here only because of -fstack-arrays we have to
1014 emit a DECL_EXPR to make the gimplifier emit alloca calls. */
1015 if (!gfc_can_put_var_on_stack (size
))
1016 gfc_add_expr_to_block (pre
,
1017 fold_build1_loc (input_location
,
1018 DECL_EXPR
, TREE_TYPE (tmp
),
1020 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1021 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
1025 /* Allocate memory to hold the data or call internal_pack. */
1026 if (initial
== NULL_TREE
)
1028 tmp
= gfc_call_malloc (pre
, NULL
, size
);
1029 tmp
= gfc_evaluate_now (tmp
, pre
);
1036 stmtblock_t do_copying
;
1038 tmp
= TREE_TYPE (initial
); /* Pointer to descriptor. */
1039 gcc_assert (TREE_CODE (tmp
) == POINTER_TYPE
);
1040 tmp
= TREE_TYPE (tmp
); /* The descriptor itself. */
1041 tmp
= gfc_get_element_type (tmp
);
1042 packed
= gfc_create_var (build_pointer_type (tmp
), "data");
1044 tmp
= build_call_expr_loc (input_location
,
1045 gfor_fndecl_in_pack
, 1, initial
);
1046 tmp
= fold_convert (TREE_TYPE (packed
), tmp
);
1047 gfc_add_modify (pre
, packed
, tmp
);
1049 tmp
= build_fold_indirect_ref_loc (input_location
,
1051 source_data
= gfc_conv_descriptor_data_get (tmp
);
1053 /* internal_pack may return source->data without any allocation
1054 or copying if it is already packed. If that's the case, we
1055 need to allocate and copy manually. */
1057 gfc_start_block (&do_copying
);
1058 tmp
= gfc_call_malloc (&do_copying
, NULL
, size
);
1059 tmp
= fold_convert (TREE_TYPE (packed
), tmp
);
1060 gfc_add_modify (&do_copying
, packed
, tmp
);
1061 tmp
= gfc_build_memcpy_call (packed
, source_data
, size
);
1062 gfc_add_expr_to_block (&do_copying
, tmp
);
1064 was_packed
= fold_build2_loc (input_location
, EQ_EXPR
,
1065 logical_type_node
, packed
,
1067 tmp
= gfc_finish_block (&do_copying
);
1068 tmp
= build3_v (COND_EXPR
, was_packed
, tmp
,
1069 build_empty_stmt (input_location
));
1070 gfc_add_expr_to_block (pre
, tmp
);
1072 tmp
= fold_convert (pvoid_type_node
, packed
);
1075 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
1078 info
->data
= gfc_conv_descriptor_data_get (desc
);
1080 /* The offset is zero because we create temporaries with a zero
1082 gfc_conv_descriptor_offset_set (pre
, desc
, gfc_index_zero_node
);
1084 if (dealloc
&& !onstack
)
1086 /* Free the temporary. */
1087 tmp
= gfc_conv_descriptor_data_get (desc
);
1088 tmp
= gfc_call_free (tmp
);
1089 gfc_add_expr_to_block (post
, tmp
);
1094 /* Get the scalarizer array dimension corresponding to actual array dimension
1097 For example, if SS represents the array ref a(1,:,:,1), it is a
1098 bidimensional scalarizer array, and the result would be 0 for ARRAY_DIM=1,
1099 and 1 for ARRAY_DIM=2.
1100 If SS represents transpose(a(:,1,1,:)), it is again a bidimensional
1101 scalarizer array, and the result would be 1 for ARRAY_DIM=0 and 0 for
1103 If SS represents sum(a(:,:,:,1), dim=1), it is a 2+1-dimensional scalarizer
1104 array. If called on the inner ss, the result would be respectively 0,1,2 for
1105 ARRAY_DIM=0,1,2. If called on the outer ss, the result would be 0,1
1106 for ARRAY_DIM=1,2. */
1109 get_scalarizer_dim_for_array_dim (gfc_ss
*ss
, int array_dim
)
1116 for (; ss
; ss
= ss
->parent
)
1117 for (n
= 0; n
< ss
->dimen
; n
++)
1118 if (ss
->dim
[n
] < array_dim
)
1121 return array_ref_dim
;
1126 innermost_ss (gfc_ss
*ss
)
1128 while (ss
->nested_ss
!= NULL
)
1136 /* Get the array reference dimension corresponding to the given loop dimension.
1137 It is different from the true array dimension given by the dim array in
1138 the case of a partial array reference (i.e. a(:,:,1,:) for example)
1139 It is different from the loop dimension in the case of a transposed array.
1143 get_array_ref_dim_for_loop_dim (gfc_ss
*ss
, int loop_dim
)
1145 return get_scalarizer_dim_for_array_dim (innermost_ss (ss
),
1150 /* Use the information in the ss to obtain the required information about
1151 the type and size of an array temporary, when the lhs in an assignment
1152 is a class expression. */
1155 get_class_info_from_ss (stmtblock_t
* pre
, gfc_ss
*ss
, tree
*eltype
)
1162 tree rhs_class_expr
= NULL_TREE
;
1163 tree lhs_class_expr
= NULL_TREE
;
1164 bool unlimited_rhs
= false;
1165 bool unlimited_lhs
= false;
1166 bool rhs_function
= false;
1169 /* The second element in the loop chain contains the source for the
1170 temporary; ie. the rhs of the assignment. */
1171 rhs_ss
= ss
->loop
->ss
->loop_chain
;
1173 if (rhs_ss
!= gfc_ss_terminator
1175 && rhs_ss
->info
->expr
1176 && rhs_ss
->info
->expr
->ts
.type
== BT_CLASS
1177 && rhs_ss
->info
->data
.array
.descriptor
)
1179 if (rhs_ss
->info
->expr
->expr_type
!= EXPR_VARIABLE
)
1181 = gfc_get_class_from_expr (rhs_ss
->info
->data
.array
.descriptor
);
1183 rhs_class_expr
= gfc_get_class_from_gfc_expr (rhs_ss
->info
->expr
);
1184 unlimited_rhs
= UNLIMITED_POLY (rhs_ss
->info
->expr
);
1185 if (rhs_ss
->info
->expr
->expr_type
== EXPR_FUNCTION
)
1186 rhs_function
= true;
1189 /* For an assignment the lhs is the next element in the loop chain.
1190 If we have a class rhs, this had better be a class variable
1192 lhs_ss
= rhs_ss
->loop_chain
;
1193 if (lhs_ss
!= gfc_ss_terminator
1195 && lhs_ss
->info
->expr
1196 && lhs_ss
->info
->expr
->expr_type
==EXPR_VARIABLE
1197 && lhs_ss
->info
->expr
->ts
.type
== BT_CLASS
)
1199 tmp
= lhs_ss
->info
->data
.array
.descriptor
;
1200 unlimited_lhs
= UNLIMITED_POLY (rhs_ss
->info
->expr
);
1205 /* Get the lhs class expression. */
1206 if (tmp
!= NULL_TREE
&& lhs_ss
->loop_chain
== gfc_ss_terminator
)
1207 lhs_class_expr
= gfc_get_class_from_expr (tmp
);
1209 return rhs_class_expr
;
1211 gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (lhs_class_expr
)));
1213 /* Set the lhs vptr and, if necessary, the _len field. */
1216 /* Both lhs and rhs are class expressions. */
1217 tmp
= gfc_class_vptr_get (lhs_class_expr
);
1218 gfc_add_modify (pre
, tmp
,
1219 fold_convert (TREE_TYPE (tmp
),
1220 gfc_class_vptr_get (rhs_class_expr
)));
1223 tmp
= gfc_class_len_get (lhs_class_expr
);
1225 tmp2
= gfc_class_len_get (rhs_class_expr
);
1227 tmp2
= build_int_cst (TREE_TYPE (tmp
), 0);
1228 gfc_add_modify (pre
, tmp
, tmp2
);
1233 tmp
= gfc_class_data_get (rhs_class_expr
);
1234 gfc_conv_descriptor_offset_set (pre
, tmp
, gfc_index_zero_node
);
1239 /* lhs is class and rhs is intrinsic or derived type. */
1240 *eltype
= TREE_TYPE (rhs_ss
->info
->data
.array
.descriptor
);
1241 *eltype
= gfc_get_element_type (*eltype
);
1242 vtab
= gfc_find_vtab (&rhs_ss
->info
->expr
->ts
);
1243 vptr
= vtab
->backend_decl
;
1244 if (vptr
== NULL_TREE
)
1245 vptr
= gfc_get_symbol_decl (vtab
);
1246 vptr
= gfc_build_addr_expr (NULL_TREE
, vptr
);
1247 tmp
= gfc_class_vptr_get (lhs_class_expr
);
1248 gfc_add_modify (pre
, tmp
,
1249 fold_convert (TREE_TYPE (tmp
), vptr
));
1253 tmp
= gfc_class_len_get (lhs_class_expr
);
1255 && rhs_ss
->info
->expr
1256 && rhs_ss
->info
->expr
->ts
.type
== BT_CHARACTER
)
1257 tmp2
= build_int_cst (TREE_TYPE (tmp
),
1258 rhs_ss
->info
->expr
->ts
.kind
);
1260 tmp2
= build_int_cst (TREE_TYPE (tmp
), 0);
1261 gfc_add_modify (pre
, tmp
, tmp2
);
1265 return rhs_class_expr
;
1270 /* Generate code to create and initialize the descriptor for a temporary
1271 array. This is used for both temporaries needed by the scalarizer, and
1272 functions returning arrays. Adjusts the loop variables to be
1273 zero-based, and calculates the loop bounds for callee allocated arrays.
1274 Allocate the array unless it's callee allocated (we have a callee
1275 allocated array if 'callee_alloc' is true, or if loop->to[n] is
1276 NULL_TREE for any n). Also fills in the descriptor, data and offset
1277 fields of info if known. Returns the size of the array, or NULL for a
1278 callee allocated array.
1280 'eltype' == NULL signals that the temporary should be a class object.
1281 The 'initial' expression is used to obtain the size of the dynamic
1282 type; otherwise the allocation and initialization proceeds as for any
1285 PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
1286 gfc_trans_allocate_array_storage. */
1289 gfc_trans_create_temp_array (stmtblock_t
* pre
, stmtblock_t
* post
, gfc_ss
* ss
,
1290 tree eltype
, tree initial
, bool dynamic
,
1291 bool dealloc
, bool callee_alloc
, locus
* where
)
1295 gfc_array_info
*info
;
1296 tree from
[GFC_MAX_DIMENSIONS
], to
[GFC_MAX_DIMENSIONS
];
1305 tree class_expr
= NULL_TREE
;
1306 int n
, dim
, tmp_dim
;
1309 /* This signals a class array for which we need the size of the
1310 dynamic type. Generate an eltype and then the class expression. */
1311 if (eltype
== NULL_TREE
&& initial
)
1313 gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial
)));
1314 class_expr
= build_fold_indirect_ref_loc (input_location
, initial
);
1315 /* Obtain the structure (class) expression. */
1316 class_expr
= gfc_get_class_from_expr (class_expr
);
1317 gcc_assert (class_expr
);
1320 /* Otherwise, some expressions, such as class functions, arising from
1321 dependency checking in assignments come here with class element type.
1322 The descriptor can be obtained from the ss->info and then converted
1323 to the class object. */
1324 if (class_expr
== NULL_TREE
&& GFC_CLASS_TYPE_P (eltype
))
1325 class_expr
= get_class_info_from_ss (pre
, ss
, &eltype
);
1327 /* If the dynamic type is not available, use the declared type. */
1328 if (eltype
&& GFC_CLASS_TYPE_P (eltype
))
1329 eltype
= gfc_get_element_type (TREE_TYPE (TYPE_FIELDS (eltype
)));
1331 if (class_expr
== NULL_TREE
)
1332 elemsize
= fold_convert (gfc_array_index_type
,
1333 TYPE_SIZE_UNIT (eltype
));
1336 /* Unlimited polymorphic entities are initialised with NULL vptr. They
1337 can be tested for by checking if the len field is present. If so
1338 test the vptr before using the vtable size. */
1339 tmp
= gfc_class_vptr_get (class_expr
);
1340 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
1342 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
1343 elemsize
= fold_build3_loc (input_location
, COND_EXPR
,
1344 gfc_array_index_type
,
1346 gfc_class_vtab_size_get (class_expr
),
1347 gfc_index_zero_node
);
1348 elemsize
= gfc_evaluate_now (elemsize
, pre
);
1349 elemsize
= gfc_resize_class_size_with_len (pre
, class_expr
, elemsize
);
1350 /* Casting the data as a character of the dynamic length ensures that
1351 assignment of elements works when needed. */
1352 eltype
= gfc_get_character_type_len (1, elemsize
);
1355 memset (from
, 0, sizeof (from
));
1356 memset (to
, 0, sizeof (to
));
1358 info
= &ss
->info
->data
.array
;
1360 gcc_assert (ss
->dimen
> 0);
1361 gcc_assert (ss
->loop
->dimen
== ss
->dimen
);
1363 if (warn_array_temporaries
&& where
)
1364 gfc_warning (OPT_Warray_temporaries
,
1365 "Creating array temporary at %L", where
);
1367 /* Set the lower bound to zero. */
1368 for (s
= ss
; s
; s
= s
->parent
)
1372 total_dim
+= loop
->dimen
;
1373 for (n
= 0; n
< loop
->dimen
; n
++)
1377 /* Callee allocated arrays may not have a known bound yet. */
1379 loop
->to
[n
] = gfc_evaluate_now (
1380 fold_build2_loc (input_location
, MINUS_EXPR
,
1381 gfc_array_index_type
,
1382 loop
->to
[n
], loop
->from
[n
]),
1384 loop
->from
[n
] = gfc_index_zero_node
;
1386 /* We have just changed the loop bounds, we must clear the
1387 corresponding specloop, so that delta calculation is not skipped
1388 later in gfc_set_delta. */
1389 loop
->specloop
[n
] = NULL
;
1391 /* We are constructing the temporary's descriptor based on the loop
1392 dimensions. As the dimensions may be accessed in arbitrary order
1393 (think of transpose) the size taken from the n'th loop may not map
1394 to the n'th dimension of the array. We need to reconstruct loop
1395 infos in the right order before using it to set the descriptor
1397 tmp_dim
= get_scalarizer_dim_for_array_dim (ss
, dim
);
1398 from
[tmp_dim
] = loop
->from
[n
];
1399 to
[tmp_dim
] = loop
->to
[n
];
1401 info
->delta
[dim
] = gfc_index_zero_node
;
1402 info
->start
[dim
] = gfc_index_zero_node
;
1403 info
->end
[dim
] = gfc_index_zero_node
;
1404 info
->stride
[dim
] = gfc_index_one_node
;
1408 /* Initialize the descriptor. */
1410 gfc_get_array_type_bounds (eltype
, total_dim
, 0, from
, to
, 1,
1411 GFC_ARRAY_UNKNOWN
, true);
1412 desc
= gfc_create_var (type
, "atmp");
1413 GFC_DECL_PACKED_ARRAY (desc
) = 1;
1415 /* Emit a DECL_EXPR for the variable sized array type in
1416 GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
1417 sizes works correctly. */
1418 tree arraytype
= TREE_TYPE (GFC_TYPE_ARRAY_DATAPTR_TYPE (type
));
1419 if (! TYPE_NAME (arraytype
))
1420 TYPE_NAME (arraytype
) = build_decl (UNKNOWN_LOCATION
, TYPE_DECL
,
1421 NULL_TREE
, arraytype
);
1422 gfc_add_expr_to_block (pre
, build1 (DECL_EXPR
,
1423 arraytype
, TYPE_NAME (arraytype
)));
1425 if (class_expr
!= NULL_TREE
)
1430 /* Create a class temporary. */
1431 tmp
= gfc_create_var (TREE_TYPE (class_expr
), "ctmp");
1432 gfc_add_modify (pre
, tmp
, class_expr
);
1434 /* Assign the new descriptor to the _data field. This allows the
1435 vptr _copy to be used for scalarized assignment since the class
1436 temporary can be found from the descriptor. */
1437 class_data
= gfc_class_data_get (tmp
);
1438 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
1439 TREE_TYPE (desc
), desc
);
1440 gfc_add_modify (pre
, class_data
, tmp
);
1442 /* Take the dtype from the class expression. */
1443 dtype
= gfc_conv_descriptor_dtype (gfc_class_data_get (class_expr
));
1444 tmp
= gfc_conv_descriptor_dtype (class_data
);
1445 gfc_add_modify (pre
, tmp
, dtype
);
1447 /* Point desc to the class _data field. */
1452 /* Fill in the array dtype. */
1453 tmp
= gfc_conv_descriptor_dtype (desc
);
1454 gfc_add_modify (pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
1457 info
->descriptor
= desc
;
1458 size
= gfc_index_one_node
;
1461 Fill in the bounds and stride. This is a packed array, so:
1464 for (n = 0; n < rank; n++)
1467 delta = ubound[n] + 1 - lbound[n];
1468 size = size * delta;
1470 size = size * sizeof(element);
1473 or_expr
= NULL_TREE
;
1475 /* If there is at least one null loop->to[n], it is a callee allocated
1477 for (n
= 0; n
< total_dim
; n
++)
1478 if (to
[n
] == NULL_TREE
)
1484 if (size
== NULL_TREE
)
1485 for (s
= ss
; s
; s
= s
->parent
)
1486 for (n
= 0; n
< s
->loop
->dimen
; n
++)
1488 dim
= get_scalarizer_dim_for_array_dim (ss
, s
->dim
[n
]);
1490 /* For a callee allocated array express the loop bounds in terms
1491 of the descriptor fields. */
1492 tmp
= fold_build2_loc (input_location
,
1493 MINUS_EXPR
, gfc_array_index_type
,
1494 gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]),
1495 gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]));
1496 s
->loop
->to
[n
] = tmp
;
1500 for (n
= 0; n
< total_dim
; n
++)
1502 /* Store the stride and bound components in the descriptor. */
1503 gfc_conv_descriptor_stride_set (pre
, desc
, gfc_rank_cst
[n
], size
);
1505 gfc_conv_descriptor_lbound_set (pre
, desc
, gfc_rank_cst
[n
],
1506 gfc_index_zero_node
);
1508 gfc_conv_descriptor_ubound_set (pre
, desc
, gfc_rank_cst
[n
], to
[n
]);
1510 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1511 gfc_array_index_type
,
1512 to
[n
], gfc_index_one_node
);
1514 /* Check whether the size for this dimension is negative. */
1515 cond
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
1516 tmp
, gfc_index_zero_node
);
1517 cond
= gfc_evaluate_now (cond
, pre
);
1522 or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1523 logical_type_node
, or_expr
, cond
);
1525 size
= fold_build2_loc (input_location
, MULT_EXPR
,
1526 gfc_array_index_type
, size
, tmp
);
1527 size
= gfc_evaluate_now (size
, pre
);
1531 /* Get the size of the array. */
1532 if (size
&& !callee_alloc
)
1534 /* If or_expr is true, then the extent in at least one
1535 dimension is zero and the size is set to zero. */
1536 size
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
1537 or_expr
, gfc_index_zero_node
, size
);
1540 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
1550 tmp
= fold_convert (gfc_array_index_type
, elemsize
);
1551 gfc_conv_descriptor_span_set (pre
, desc
, tmp
);
1553 gfc_trans_allocate_array_storage (pre
, post
, info
, size
, nelem
, initial
,
1559 if (ss
->dimen
> ss
->loop
->temp_dim
)
1560 ss
->loop
->temp_dim
= ss
->dimen
;
1566 /* Return the number of iterations in a loop that starts at START,
1567 ends at END, and has step STEP. */
1570 gfc_get_iteration_count (tree start
, tree end
, tree step
)
1575 type
= TREE_TYPE (step
);
1576 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, end
, start
);
1577 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
, type
, tmp
, step
);
1578 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
,
1579 build_int_cst (type
, 1));
1580 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, type
, tmp
,
1581 build_int_cst (type
, 0));
1582 return fold_convert (gfc_array_index_type
, tmp
);
1586 /* Extend the data in array DESC by EXTRA elements. */
1589 gfc_grow_array (stmtblock_t
* pblock
, tree desc
, tree extra
)
1596 if (integer_zerop (extra
))
1599 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[0]);
1601 /* Add EXTRA to the upper bound. */
1602 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1604 gfc_conv_descriptor_ubound_set (pblock
, desc
, gfc_rank_cst
[0], tmp
);
1606 /* Get the value of the current data pointer. */
1607 arg0
= gfc_conv_descriptor_data_get (desc
);
1609 /* Calculate the new array size. */
1610 size
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
1611 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1612 ubound
, gfc_index_one_node
);
1613 arg1
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
1614 fold_convert (size_type_node
, tmp
),
1615 fold_convert (size_type_node
, size
));
1617 /* Call the realloc() function. */
1618 tmp
= gfc_call_realloc (pblock
, arg0
, arg1
);
1619 gfc_conv_descriptor_data_set (pblock
, desc
, tmp
);
1623 /* Return true if the bounds of iterator I can only be determined
1627 gfc_iterator_has_dynamic_bounds (gfc_iterator
* i
)
1629 return (i
->start
->expr_type
!= EXPR_CONSTANT
1630 || i
->end
->expr_type
!= EXPR_CONSTANT
1631 || i
->step
->expr_type
!= EXPR_CONSTANT
);
1635 /* Split the size of constructor element EXPR into the sum of two terms,
1636 one of which can be determined at compile time and one of which must
1637 be calculated at run time. Set *SIZE to the former and return true
1638 if the latter might be nonzero. */
1641 gfc_get_array_constructor_element_size (mpz_t
* size
, gfc_expr
* expr
)
1643 if (expr
->expr_type
== EXPR_ARRAY
)
1644 return gfc_get_array_constructor_size (size
, expr
->value
.constructor
);
1645 else if (expr
->rank
> 0)
1647 /* Calculate everything at run time. */
1648 mpz_set_ui (*size
, 0);
1653 /* A single element. */
1654 mpz_set_ui (*size
, 1);
1660 /* Like gfc_get_array_constructor_element_size, but applied to the whole
1661 of array constructor C. */
1664 gfc_get_array_constructor_size (mpz_t
* size
, gfc_constructor_base base
)
1672 mpz_set_ui (*size
, 0);
1677 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1680 if (i
&& gfc_iterator_has_dynamic_bounds (i
))
1684 dynamic
|= gfc_get_array_constructor_element_size (&len
, c
->expr
);
1687 /* Multiply the static part of the element size by the
1688 number of iterations. */
1689 mpz_sub (val
, i
->end
->value
.integer
, i
->start
->value
.integer
);
1690 mpz_fdiv_q (val
, val
, i
->step
->value
.integer
);
1691 mpz_add_ui (val
, val
, 1);
1692 if (mpz_sgn (val
) > 0)
1693 mpz_mul (len
, len
, val
);
1695 mpz_set_ui (len
, 0);
1697 mpz_add (*size
, *size
, len
);
1706 /* Make sure offset is a variable. */
1709 gfc_put_offset_into_var (stmtblock_t
* pblock
, tree
* poffset
,
1712 /* We should have already created the offset variable. We cannot
1713 create it here because we may be in an inner scope. */
1714 gcc_assert (*offsetvar
!= NULL_TREE
);
1715 gfc_add_modify (pblock
, *offsetvar
, *poffset
);
1716 *poffset
= *offsetvar
;
1717 TREE_USED (*offsetvar
) = 1;
1721 /* Variables needed for bounds-checking. */
1722 static bool first_len
;
1723 static tree first_len_val
;
1724 static bool typespec_chararray_ctor
;
1727 gfc_trans_array_ctor_element (stmtblock_t
* pblock
, tree desc
,
1728 tree offset
, gfc_se
* se
, gfc_expr
* expr
)
1732 gfc_conv_expr (se
, expr
);
1734 /* Store the value. */
1735 tmp
= build_fold_indirect_ref_loc (input_location
,
1736 gfc_conv_descriptor_data_get (desc
));
1737 tmp
= gfc_build_array_ref (tmp
, offset
, NULL
);
1739 if (expr
->ts
.type
== BT_CHARACTER
)
1741 int i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
1744 esize
= size_in_bytes (gfc_get_element_type (TREE_TYPE (desc
)));
1745 esize
= fold_convert (gfc_charlen_type_node
, esize
);
1746 esize
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1747 TREE_TYPE (esize
), esize
,
1748 build_int_cst (TREE_TYPE (esize
),
1749 gfc_character_kinds
[i
].bit_size
/ 8));
1751 gfc_conv_string_parameter (se
);
1752 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
1754 /* The temporary is an array of pointers. */
1755 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1756 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1760 /* The temporary is an array of string values. */
1761 tmp
= gfc_build_addr_expr (gfc_get_pchar_type (expr
->ts
.kind
), tmp
);
1762 /* We know the temporary and the value will be the same length,
1763 so can use memcpy. */
1764 gfc_trans_string_copy (&se
->pre
, esize
, tmp
, expr
->ts
.kind
,
1765 se
->string_length
, se
->expr
, expr
->ts
.kind
);
1767 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && !typespec_chararray_ctor
)
1771 gfc_add_modify (&se
->pre
, first_len_val
,
1772 fold_convert (TREE_TYPE (first_len_val
),
1773 se
->string_length
));
1778 /* Verify that all constructor elements are of the same
1780 tree rhs
= fold_convert (TREE_TYPE (first_len_val
),
1782 tree cond
= fold_build2_loc (input_location
, NE_EXPR
,
1783 logical_type_node
, first_len_val
,
1785 gfc_trans_runtime_check
1786 (true, false, cond
, &se
->pre
, &expr
->where
,
1787 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1788 fold_convert (long_integer_type_node
, first_len_val
),
1789 fold_convert (long_integer_type_node
, se
->string_length
));
1793 else if (GFC_CLASS_TYPE_P (TREE_TYPE (se
->expr
))
1794 && !GFC_CLASS_TYPE_P (gfc_get_element_type (TREE_TYPE (desc
))))
1796 /* Assignment of a CLASS array constructor to a derived type array. */
1797 if (expr
->expr_type
== EXPR_FUNCTION
)
1798 se
->expr
= gfc_evaluate_now (se
->expr
, pblock
);
1799 se
->expr
= gfc_class_data_get (se
->expr
);
1800 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
1801 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1802 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1806 /* TODO: Should the frontend already have done this conversion? */
1807 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1808 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1811 gfc_add_block_to_block (pblock
, &se
->pre
);
1812 gfc_add_block_to_block (pblock
, &se
->post
);
1816 /* Add the contents of an array to the constructor. DYNAMIC is as for
1817 gfc_trans_array_constructor_value. */
1820 gfc_trans_array_constructor_subarray (stmtblock_t
* pblock
,
1821 tree type ATTRIBUTE_UNUSED
,
1822 tree desc
, gfc_expr
* expr
,
1823 tree
* poffset
, tree
* offsetvar
,
1834 /* We need this to be a variable so we can increment it. */
1835 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1837 gfc_init_se (&se
, NULL
);
1839 /* Walk the array expression. */
1840 ss
= gfc_walk_expr (expr
);
1841 gcc_assert (ss
!= gfc_ss_terminator
);
1843 /* Initialize the scalarizer. */
1844 gfc_init_loopinfo (&loop
);
1845 gfc_add_ss_to_loop (&loop
, ss
);
1847 /* Initialize the loop. */
1848 gfc_conv_ss_startstride (&loop
);
1849 gfc_conv_loop_setup (&loop
, &expr
->where
);
1851 /* Make sure the constructed array has room for the new data. */
1854 /* Set SIZE to the total number of elements in the subarray. */
1855 size
= gfc_index_one_node
;
1856 for (n
= 0; n
< loop
.dimen
; n
++)
1858 tmp
= gfc_get_iteration_count (loop
.from
[n
], loop
.to
[n
],
1859 gfc_index_one_node
);
1860 size
= fold_build2_loc (input_location
, MULT_EXPR
,
1861 gfc_array_index_type
, size
, tmp
);
1864 /* Grow the constructed array by SIZE elements. */
1865 gfc_grow_array (&loop
.pre
, desc
, size
);
1868 /* Make the loop body. */
1869 gfc_mark_ss_chain_used (ss
, 1);
1870 gfc_start_scalarized_body (&loop
, &body
);
1871 gfc_copy_loopinfo_to_se (&se
, &loop
);
1874 gfc_trans_array_ctor_element (&body
, desc
, *poffset
, &se
, expr
);
1875 gcc_assert (se
.ss
== gfc_ss_terminator
);
1877 /* Increment the offset. */
1878 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1879 *poffset
, gfc_index_one_node
);
1880 gfc_add_modify (&body
, *poffset
, tmp
);
1882 /* Finish the loop. */
1883 gfc_trans_scalarizing_loops (&loop
, &body
);
1884 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
1885 tmp
= gfc_finish_block (&loop
.pre
);
1886 gfc_add_expr_to_block (pblock
, tmp
);
1888 gfc_cleanup_loop (&loop
);
1892 /* Assign the values to the elements of an array constructor. DYNAMIC
1893 is true if descriptor DESC only contains enough data for the static
1894 size calculated by gfc_get_array_constructor_size. When true, memory
1895 for the dynamic parts must be allocated using realloc. */
1898 gfc_trans_array_constructor_value (stmtblock_t
* pblock
, tree type
,
1899 tree desc
, gfc_constructor_base base
,
1900 tree
* poffset
, tree
* offsetvar
,
1904 tree start
= NULL_TREE
;
1905 tree end
= NULL_TREE
;
1906 tree step
= NULL_TREE
;
1912 tree shadow_loopvar
= NULL_TREE
;
1913 gfc_saved_var saved_loopvar
;
1916 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1918 /* If this is an iterator or an array, the offset must be a variable. */
1919 if ((c
->iterator
|| c
->expr
->rank
> 0) && INTEGER_CST_P (*poffset
))
1920 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1922 /* Shadowing the iterator avoids changing its value and saves us from
1923 keeping track of it. Further, it makes sure that there's always a
1924 backend-decl for the symbol, even if there wasn't one before,
1925 e.g. in the case of an iterator that appears in a specification
1926 expression in an interface mapping. */
1932 /* Evaluate loop bounds before substituting the loop variable
1933 in case they depend on it. Such a case is invalid, but it is
1934 not more expensive to do the right thing here.
1936 gfc_init_se (&se
, NULL
);
1937 gfc_conv_expr_val (&se
, c
->iterator
->start
);
1938 gfc_add_block_to_block (pblock
, &se
.pre
);
1939 start
= gfc_evaluate_now (se
.expr
, pblock
);
1941 gfc_init_se (&se
, NULL
);
1942 gfc_conv_expr_val (&se
, c
->iterator
->end
);
1943 gfc_add_block_to_block (pblock
, &se
.pre
);
1944 end
= gfc_evaluate_now (se
.expr
, pblock
);
1946 gfc_init_se (&se
, NULL
);
1947 gfc_conv_expr_val (&se
, c
->iterator
->step
);
1948 gfc_add_block_to_block (pblock
, &se
.pre
);
1949 step
= gfc_evaluate_now (se
.expr
, pblock
);
1951 sym
= c
->iterator
->var
->symtree
->n
.sym
;
1952 type
= gfc_typenode_for_spec (&sym
->ts
);
1954 shadow_loopvar
= gfc_create_var (type
, "shadow_loopvar");
1955 gfc_shadow_sym (sym
, shadow_loopvar
, &saved_loopvar
);
1958 gfc_start_block (&body
);
1960 if (c
->expr
->expr_type
== EXPR_ARRAY
)
1962 /* Array constructors can be nested. */
1963 gfc_trans_array_constructor_value (&body
, type
, desc
,
1964 c
->expr
->value
.constructor
,
1965 poffset
, offsetvar
, dynamic
);
1967 else if (c
->expr
->rank
> 0)
1969 gfc_trans_array_constructor_subarray (&body
, type
, desc
, c
->expr
,
1970 poffset
, offsetvar
, dynamic
);
1974 /* This code really upsets the gimplifier so don't bother for now. */
1981 while (p
&& !(p
->iterator
|| p
->expr
->expr_type
!= EXPR_CONSTANT
))
1983 p
= gfc_constructor_next (p
);
1988 /* Scalar values. */
1989 gfc_init_se (&se
, NULL
);
1990 gfc_trans_array_ctor_element (&body
, desc
, *poffset
,
1993 *poffset
= fold_build2_loc (input_location
, PLUS_EXPR
,
1994 gfc_array_index_type
,
1995 *poffset
, gfc_index_one_node
);
1999 /* Collect multiple scalar constants into a constructor. */
2000 vec
<constructor_elt
, va_gc
> *v
= NULL
;
2004 HOST_WIDE_INT idx
= 0;
2007 /* Count the number of consecutive scalar constants. */
2008 while (p
&& !(p
->iterator
2009 || p
->expr
->expr_type
!= EXPR_CONSTANT
))
2011 gfc_init_se (&se
, NULL
);
2012 gfc_conv_constant (&se
, p
->expr
);
2014 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
2015 se
.expr
= fold_convert (type
, se
.expr
);
2016 /* For constant character array constructors we build
2017 an array of pointers. */
2018 else if (POINTER_TYPE_P (type
))
2019 se
.expr
= gfc_build_addr_expr
2020 (gfc_get_pchar_type (p
->expr
->ts
.kind
),
2023 CONSTRUCTOR_APPEND_ELT (v
,
2024 build_int_cst (gfc_array_index_type
,
2028 p
= gfc_constructor_next (p
);
2031 bound
= size_int (n
- 1);
2032 /* Create an array type to hold them. */
2033 tmptype
= build_range_type (gfc_array_index_type
,
2034 gfc_index_zero_node
, bound
);
2035 tmptype
= build_array_type (type
, tmptype
);
2037 init
= build_constructor (tmptype
, v
);
2038 TREE_CONSTANT (init
) = 1;
2039 TREE_STATIC (init
) = 1;
2040 /* Create a static variable to hold the data. */
2041 tmp
= gfc_create_var (tmptype
, "data");
2042 TREE_STATIC (tmp
) = 1;
2043 TREE_CONSTANT (tmp
) = 1;
2044 TREE_READONLY (tmp
) = 1;
2045 DECL_INITIAL (tmp
) = init
;
2048 /* Use BUILTIN_MEMCPY to assign the values. */
2049 tmp
= gfc_conv_descriptor_data_get (desc
);
2050 tmp
= build_fold_indirect_ref_loc (input_location
,
2052 tmp
= gfc_build_array_ref (tmp
, *poffset
, NULL
);
2053 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2054 init
= gfc_build_addr_expr (NULL_TREE
, init
);
2056 size
= TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type
));
2057 bound
= build_int_cst (size_type_node
, n
* size
);
2058 tmp
= build_call_expr_loc (input_location
,
2059 builtin_decl_explicit (BUILT_IN_MEMCPY
),
2060 3, tmp
, init
, bound
);
2061 gfc_add_expr_to_block (&body
, tmp
);
2063 *poffset
= fold_build2_loc (input_location
, PLUS_EXPR
,
2064 gfc_array_index_type
, *poffset
,
2065 build_int_cst (gfc_array_index_type
, n
));
2067 if (!INTEGER_CST_P (*poffset
))
2069 gfc_add_modify (&body
, *offsetvar
, *poffset
);
2070 *poffset
= *offsetvar
;
2074 /* The frontend should already have done any expansions
2078 /* Pass the code as is. */
2079 tmp
= gfc_finish_block (&body
);
2080 gfc_add_expr_to_block (pblock
, tmp
);
2084 /* Build the implied do-loop. */
2085 stmtblock_t implied_do_block
;
2091 loopbody
= gfc_finish_block (&body
);
2093 /* Create a new block that holds the implied-do loop. A temporary
2094 loop-variable is used. */
2095 gfc_start_block(&implied_do_block
);
2097 /* Initialize the loop. */
2098 gfc_add_modify (&implied_do_block
, shadow_loopvar
, start
);
2100 /* If this array expands dynamically, and the number of iterations
2101 is not constant, we won't have allocated space for the static
2102 part of C->EXPR's size. Do that now. */
2103 if (dynamic
&& gfc_iterator_has_dynamic_bounds (c
->iterator
))
2105 /* Get the number of iterations. */
2106 tmp
= gfc_get_iteration_count (shadow_loopvar
, end
, step
);
2108 /* Get the static part of C->EXPR's size. */
2109 gfc_get_array_constructor_element_size (&size
, c
->expr
);
2110 tmp2
= gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
2112 /* Grow the array by TMP * TMP2 elements. */
2113 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
2114 gfc_array_index_type
, tmp
, tmp2
);
2115 gfc_grow_array (&implied_do_block
, desc
, tmp
);
2118 /* Generate the loop body. */
2119 exit_label
= gfc_build_label_decl (NULL_TREE
);
2120 gfc_start_block (&body
);
2122 /* Generate the exit condition. Depending on the sign of
2123 the step variable we have to generate the correct
2125 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
2126 step
, build_int_cst (TREE_TYPE (step
), 0));
2127 cond
= fold_build3_loc (input_location
, COND_EXPR
,
2128 logical_type_node
, tmp
,
2129 fold_build2_loc (input_location
, GT_EXPR
,
2130 logical_type_node
, shadow_loopvar
, end
),
2131 fold_build2_loc (input_location
, LT_EXPR
,
2132 logical_type_node
, shadow_loopvar
, end
));
2133 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2134 TREE_USED (exit_label
) = 1;
2135 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
2136 build_empty_stmt (input_location
));
2137 gfc_add_expr_to_block (&body
, tmp
);
2139 /* The main loop body. */
2140 gfc_add_expr_to_block (&body
, loopbody
);
2142 /* Increase loop variable by step. */
2143 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2144 TREE_TYPE (shadow_loopvar
), shadow_loopvar
,
2146 gfc_add_modify (&body
, shadow_loopvar
, tmp
);
2148 /* Finish the loop. */
2149 tmp
= gfc_finish_block (&body
);
2150 tmp
= build1_v (LOOP_EXPR
, tmp
);
2151 gfc_add_expr_to_block (&implied_do_block
, tmp
);
2153 /* Add the exit label. */
2154 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2155 gfc_add_expr_to_block (&implied_do_block
, tmp
);
2157 /* Finish the implied-do loop. */
2158 tmp
= gfc_finish_block(&implied_do_block
);
2159 gfc_add_expr_to_block(pblock
, tmp
);
2161 gfc_restore_sym (c
->iterator
->var
->symtree
->n
.sym
, &saved_loopvar
);
2168 /* The array constructor code can create a string length with an operand
2169 in the form of a temporary variable. This variable will retain its
2170 context (current_function_decl). If we store this length tree in a
2171 gfc_charlen structure which is shared by a variable in another
2172 context, the resulting gfc_charlen structure with a variable in a
2173 different context, we could trip the assertion in expand_expr_real_1
2174 when it sees that a variable has been created in one context and
2175 referenced in another.
2177 If this might be the case, we create a new gfc_charlen structure and
2178 link it into the current namespace. */
2181 store_backend_decl (gfc_charlen
**clp
, tree len
, bool force_new_cl
)
2185 gfc_charlen
*new_cl
= gfc_new_charlen (gfc_current_ns
, *clp
);
2188 (*clp
)->backend_decl
= len
;
2191 /* A catch-all to obtain the string length for anything that is not
2192 a substring of non-constant length, a constant, array or variable. */
2195 get_array_ctor_all_strlen (stmtblock_t
*block
, gfc_expr
*e
, tree
*len
)
2199 /* Don't bother if we already know the length is a constant. */
2200 if (*len
&& INTEGER_CST_P (*len
))
2203 if (!e
->ref
&& e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
2204 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2207 gfc_conv_const_charlen (e
->ts
.u
.cl
);
2208 *len
= e
->ts
.u
.cl
->backend_decl
;
2212 /* Otherwise, be brutal even if inefficient. */
2213 gfc_init_se (&se
, NULL
);
2215 /* No function call, in case of side effects. */
2216 se
.no_function_call
= 1;
2218 gfc_conv_expr (&se
, e
);
2220 gfc_conv_expr_descriptor (&se
, e
);
2222 /* Fix the value. */
2223 *len
= gfc_evaluate_now (se
.string_length
, &se
.pre
);
2225 gfc_add_block_to_block (block
, &se
.pre
);
2226 gfc_add_block_to_block (block
, &se
.post
);
2228 store_backend_decl (&e
->ts
.u
.cl
, *len
, true);
2233 /* Figure out the string length of a variable reference expression.
2234 Used by get_array_ctor_strlen. */
2237 get_array_ctor_var_strlen (stmtblock_t
*block
, gfc_expr
* expr
, tree
* len
)
2244 /* Don't bother if we already know the length is a constant. */
2245 if (*len
&& INTEGER_CST_P (*len
))
2248 ts
= &expr
->symtree
->n
.sym
->ts
;
2249 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2254 /* Array references don't change the string length. */
2256 get_array_ctor_all_strlen (block
, expr
, len
);
2260 /* Use the length of the component. */
2261 ts
= &ref
->u
.c
.component
->ts
;
2265 if (ref
->u
.ss
.end
== NULL
2266 || ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
2267 || ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
2269 /* Note that this might evaluate expr. */
2270 get_array_ctor_all_strlen (block
, expr
, len
);
2273 mpz_init_set_ui (char_len
, 1);
2274 mpz_add (char_len
, char_len
, ref
->u
.ss
.end
->value
.integer
);
2275 mpz_sub (char_len
, char_len
, ref
->u
.ss
.start
->value
.integer
);
2276 *len
= gfc_conv_mpz_to_tree_type (char_len
, gfc_charlen_type_node
);
2277 mpz_clear (char_len
);
2288 /* A last ditch attempt that is sometimes needed for deferred characters. */
2289 if (!ts
->u
.cl
->backend_decl
)
2291 gfc_init_se (&se
, NULL
);
2293 gfc_conv_expr_descriptor (&se
, expr
);
2295 gfc_conv_expr (&se
, expr
);
2296 gcc_assert (se
.string_length
!= NULL_TREE
);
2297 gfc_add_block_to_block (block
, &se
.pre
);
2298 ts
->u
.cl
->backend_decl
= se
.string_length
;
2301 *len
= ts
->u
.cl
->backend_decl
;
2305 /* Figure out the string length of a character array constructor.
2306 If len is NULL, don't calculate the length; this happens for recursive calls
2307 when a sub-array-constructor is an element but not at the first position,
2308 so when we're not interested in the length.
2309 Returns TRUE if all elements are character constants. */
2312 get_array_ctor_strlen (stmtblock_t
*block
, gfc_constructor_base base
, tree
* len
)
2319 if (gfc_constructor_first (base
) == NULL
)
2322 *len
= build_int_cstu (gfc_charlen_type_node
, 0);
2326 /* Loop over all constructor elements to find out is_const, but in len we
2327 want to store the length of the first, not the last, element. We can
2328 of course exit the loop as soon as is_const is found to be false. */
2329 for (c
= gfc_constructor_first (base
);
2330 c
&& is_const
; c
= gfc_constructor_next (c
))
2332 switch (c
->expr
->expr_type
)
2335 if (len
&& !(*len
&& INTEGER_CST_P (*len
)))
2336 *len
= build_int_cstu (gfc_charlen_type_node
,
2337 c
->expr
->value
.character
.length
);
2341 if (!get_array_ctor_strlen (block
, c
->expr
->value
.constructor
, len
))
2348 get_array_ctor_var_strlen (block
, c
->expr
, len
);
2354 get_array_ctor_all_strlen (block
, c
->expr
, len
);
2358 /* After the first iteration, we don't want the length modified. */
2365 /* Check whether the array constructor C consists entirely of constant
2366 elements, and if so returns the number of those elements, otherwise
2367 return zero. Note, an empty or NULL array constructor returns zero. */
2369 unsigned HOST_WIDE_INT
2370 gfc_constant_array_constructor_p (gfc_constructor_base base
)
2372 unsigned HOST_WIDE_INT nelem
= 0;
2374 gfc_constructor
*c
= gfc_constructor_first (base
);
2378 || c
->expr
->rank
> 0
2379 || c
->expr
->expr_type
!= EXPR_CONSTANT
)
2381 c
= gfc_constructor_next (c
);
2388 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
2389 and the tree type of it's elements, TYPE, return a static constant
2390 variable that is compile-time initialized. */
2393 gfc_build_constant_array_constructor (gfc_expr
* expr
, tree type
)
2395 tree tmptype
, init
, tmp
;
2396 HOST_WIDE_INT nelem
;
2401 vec
<constructor_elt
, va_gc
> *v
= NULL
;
2403 /* First traverse the constructor list, converting the constants
2404 to tree to build an initializer. */
2406 c
= gfc_constructor_first (expr
->value
.constructor
);
2409 gfc_init_se (&se
, NULL
);
2410 gfc_conv_constant (&se
, c
->expr
);
2411 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
2412 se
.expr
= fold_convert (type
, se
.expr
);
2413 else if (POINTER_TYPE_P (type
))
2414 se
.expr
= gfc_build_addr_expr (gfc_get_pchar_type (c
->expr
->ts
.kind
),
2416 CONSTRUCTOR_APPEND_ELT (v
, build_int_cst (gfc_array_index_type
, nelem
),
2418 c
= gfc_constructor_next (c
);
2422 /* Next determine the tree type for the array. We use the gfortran
2423 front-end's gfc_get_nodesc_array_type in order to create a suitable
2424 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
2426 memset (&as
, 0, sizeof (gfc_array_spec
));
2428 as
.rank
= expr
->rank
;
2429 as
.type
= AS_EXPLICIT
;
2432 as
.lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2433 as
.upper
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
2437 for (i
= 0; i
< expr
->rank
; i
++)
2439 int tmp
= (int) mpz_get_si (expr
->shape
[i
]);
2440 as
.lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2441 as
.upper
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
2445 tmptype
= gfc_get_nodesc_array_type (type
, &as
, PACKED_STATIC
, true);
2447 /* as is not needed anymore. */
2448 for (i
= 0; i
< as
.rank
+ as
.corank
; i
++)
2450 gfc_free_expr (as
.lower
[i
]);
2451 gfc_free_expr (as
.upper
[i
]);
2454 init
= build_constructor (tmptype
, v
);
2456 TREE_CONSTANT (init
) = 1;
2457 TREE_STATIC (init
) = 1;
2459 tmp
= build_decl (input_location
, VAR_DECL
, create_tmp_var_name ("A"),
2461 DECL_ARTIFICIAL (tmp
) = 1;
2462 DECL_IGNORED_P (tmp
) = 1;
2463 TREE_STATIC (tmp
) = 1;
2464 TREE_CONSTANT (tmp
) = 1;
2465 TREE_READONLY (tmp
) = 1;
2466 DECL_INITIAL (tmp
) = init
;
2473 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
2474 This mostly initializes the scalarizer state info structure with the
2475 appropriate values to directly use the array created by the function
2476 gfc_build_constant_array_constructor. */
2479 trans_constant_array_constructor (gfc_ss
* ss
, tree type
)
2481 gfc_array_info
*info
;
2485 tmp
= gfc_build_constant_array_constructor (ss
->info
->expr
, type
);
2487 info
= &ss
->info
->data
.array
;
2489 info
->descriptor
= tmp
;
2490 info
->data
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2491 info
->offset
= gfc_index_zero_node
;
2493 for (i
= 0; i
< ss
->dimen
; i
++)
2495 info
->delta
[i
] = gfc_index_zero_node
;
2496 info
->start
[i
] = gfc_index_zero_node
;
2497 info
->end
[i
] = gfc_index_zero_node
;
2498 info
->stride
[i
] = gfc_index_one_node
;
2504 get_rank (gfc_loopinfo
*loop
)
2509 for (; loop
; loop
= loop
->parent
)
2510 rank
+= loop
->dimen
;
2516 /* Helper routine of gfc_trans_array_constructor to determine if the
2517 bounds of the loop specified by LOOP are constant and simple enough
2518 to use with trans_constant_array_constructor. Returns the
2519 iteration count of the loop if suitable, and NULL_TREE otherwise. */
2522 constant_array_constructor_loop_size (gfc_loopinfo
* l
)
2525 tree size
= gfc_index_one_node
;
2529 total_dim
= get_rank (l
);
2531 for (loop
= l
; loop
; loop
= loop
->parent
)
2533 for (i
= 0; i
< loop
->dimen
; i
++)
2535 /* If the bounds aren't constant, return NULL_TREE. */
2536 if (!INTEGER_CST_P (loop
->from
[i
]) || !INTEGER_CST_P (loop
->to
[i
]))
2538 if (!integer_zerop (loop
->from
[i
]))
2540 /* Only allow nonzero "from" in one-dimensional arrays. */
2543 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2544 gfc_array_index_type
,
2545 loop
->to
[i
], loop
->from
[i
]);
2549 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2550 gfc_array_index_type
, tmp
, gfc_index_one_node
);
2551 size
= fold_build2_loc (input_location
, MULT_EXPR
,
2552 gfc_array_index_type
, size
, tmp
);
2561 get_loop_upper_bound_for_array (gfc_ss
*array
, int array_dim
)
2566 gcc_assert (array
->nested_ss
== NULL
);
2568 for (ss
= array
; ss
; ss
= ss
->parent
)
2569 for (n
= 0; n
< ss
->loop
->dimen
; n
++)
2570 if (array_dim
== get_array_ref_dim_for_loop_dim (ss
, n
))
2571 return &(ss
->loop
->to
[n
]);
2577 static gfc_loopinfo
*
2578 outermost_loop (gfc_loopinfo
* loop
)
2580 while (loop
->parent
!= NULL
)
2581 loop
= loop
->parent
;
2587 /* Array constructors are handled by constructing a temporary, then using that
2588 within the scalarization loop. This is not optimal, but seems by far the
2592 trans_array_constructor (gfc_ss
* ss
, locus
* where
)
2594 gfc_constructor_base c
;
2602 bool old_first_len
, old_typespec_chararray_ctor
;
2603 tree old_first_len_val
;
2604 gfc_loopinfo
*loop
, *outer_loop
;
2605 gfc_ss_info
*ss_info
;
2611 /* Save the old values for nested checking. */
2612 old_first_len
= first_len
;
2613 old_first_len_val
= first_len_val
;
2614 old_typespec_chararray_ctor
= typespec_chararray_ctor
;
2617 outer_loop
= outermost_loop (loop
);
2619 expr
= ss_info
->expr
;
2621 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
2622 typespec was given for the array constructor. */
2623 typespec_chararray_ctor
= (expr
->ts
.type
== BT_CHARACTER
2625 && expr
->ts
.u
.cl
->length_from_typespec
);
2627 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2628 && expr
->ts
.type
== BT_CHARACTER
&& !typespec_chararray_ctor
)
2630 first_len_val
= gfc_create_var (gfc_charlen_type_node
, "len");
2634 gcc_assert (ss
->dimen
== ss
->loop
->dimen
);
2636 c
= expr
->value
.constructor
;
2637 if (expr
->ts
.type
== BT_CHARACTER
)
2640 bool force_new_cl
= false;
2642 /* get_array_ctor_strlen walks the elements of the constructor, if a
2643 typespec was given, we already know the string length and want the one
2645 if (typespec_chararray_ctor
&& expr
->ts
.u
.cl
->length
2646 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
2650 const_string
= false;
2651 gfc_init_se (&length_se
, NULL
);
2652 gfc_conv_expr_type (&length_se
, expr
->ts
.u
.cl
->length
,
2653 gfc_charlen_type_node
);
2654 ss_info
->string_length
= length_se
.expr
;
2656 /* Check if the character length is negative. If it is, then
2658 neg_len
= fold_build2_loc (input_location
, LT_EXPR
,
2659 logical_type_node
, ss_info
->string_length
,
2660 build_zero_cst (TREE_TYPE
2661 (ss_info
->string_length
)));
2662 /* Print a warning if bounds checking is enabled. */
2663 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2665 msg
= xasprintf ("Negative character length treated as LEN = 0");
2666 gfc_trans_runtime_check (false, true, neg_len
, &length_se
.pre
,
2671 ss_info
->string_length
2672 = fold_build3_loc (input_location
, COND_EXPR
,
2673 gfc_charlen_type_node
, neg_len
,
2675 (TREE_TYPE (ss_info
->string_length
)),
2676 ss_info
->string_length
);
2677 ss_info
->string_length
= gfc_evaluate_now (ss_info
->string_length
,
2679 gfc_add_block_to_block (&outer_loop
->pre
, &length_se
.pre
);
2680 gfc_add_block_to_block (&outer_loop
->post
, &length_se
.post
);
2684 const_string
= get_array_ctor_strlen (&outer_loop
->pre
, c
,
2685 &ss_info
->string_length
);
2686 force_new_cl
= true;
2689 /* Complex character array constructors should have been taken care of
2690 and not end up here. */
2691 gcc_assert (ss_info
->string_length
);
2693 store_backend_decl (&expr
->ts
.u
.cl
, ss_info
->string_length
, force_new_cl
);
2695 type
= gfc_get_character_type_len (expr
->ts
.kind
, ss_info
->string_length
);
2697 type
= build_pointer_type (type
);
2700 type
= gfc_typenode_for_spec (expr
->ts
.type
== BT_CLASS
2701 ? &CLASS_DATA (expr
)->ts
: &expr
->ts
);
2703 /* See if the constructor determines the loop bounds. */
2706 loop_ubound0
= get_loop_upper_bound_for_array (ss
, 0);
2708 if (expr
->shape
&& get_rank (loop
) > 1 && *loop_ubound0
== NULL_TREE
)
2710 /* We have a multidimensional parameter. */
2711 for (s
= ss
; s
; s
= s
->parent
)
2714 for (n
= 0; n
< s
->loop
->dimen
; n
++)
2716 s
->loop
->from
[n
] = gfc_index_zero_node
;
2717 s
->loop
->to
[n
] = gfc_conv_mpz_to_tree (expr
->shape
[s
->dim
[n
]],
2718 gfc_index_integer_kind
);
2719 s
->loop
->to
[n
] = fold_build2_loc (input_location
, MINUS_EXPR
,
2720 gfc_array_index_type
,
2722 gfc_index_one_node
);
2727 if (*loop_ubound0
== NULL_TREE
)
2731 /* We should have a 1-dimensional, zero-based loop. */
2732 gcc_assert (loop
->parent
== NULL
&& loop
->nested
== NULL
);
2733 gcc_assert (loop
->dimen
== 1);
2734 gcc_assert (integer_zerop (loop
->from
[0]));
2736 /* Split the constructor size into a static part and a dynamic part.
2737 Allocate the static size up-front and record whether the dynamic
2738 size might be nonzero. */
2740 dynamic
= gfc_get_array_constructor_size (&size
, c
);
2741 mpz_sub_ui (size
, size
, 1);
2742 loop
->to
[0] = gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
2746 /* Special case constant array constructors. */
2749 unsigned HOST_WIDE_INT nelem
= gfc_constant_array_constructor_p (c
);
2752 tree size
= constant_array_constructor_loop_size (loop
);
2753 if (size
&& compare_tree_int (size
, nelem
) == 0)
2755 trans_constant_array_constructor (ss
, type
);
2761 gfc_trans_create_temp_array (&outer_loop
->pre
, &outer_loop
->post
, ss
, type
,
2762 NULL_TREE
, dynamic
, true, false, where
);
2764 desc
= ss_info
->data
.array
.descriptor
;
2765 offset
= gfc_index_zero_node
;
2766 offsetvar
= gfc_create_var_np (gfc_array_index_type
, "offset");
2767 suppress_warning (offsetvar
);
2768 TREE_USED (offsetvar
) = 0;
2769 gfc_trans_array_constructor_value (&outer_loop
->pre
, type
, desc
, c
,
2770 &offset
, &offsetvar
, dynamic
);
2772 /* If the array grows dynamically, the upper bound of the loop variable
2773 is determined by the array's final upper bound. */
2776 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2777 gfc_array_index_type
,
2778 offsetvar
, gfc_index_one_node
);
2779 tmp
= gfc_evaluate_now (tmp
, &outer_loop
->pre
);
2780 gfc_conv_descriptor_ubound_set (&loop
->pre
, desc
, gfc_rank_cst
[0], tmp
);
2781 if (*loop_ubound0
&& VAR_P (*loop_ubound0
))
2782 gfc_add_modify (&outer_loop
->pre
, *loop_ubound0
, tmp
);
2784 *loop_ubound0
= tmp
;
2787 if (TREE_USED (offsetvar
))
2788 pushdecl (offsetvar
);
2790 gcc_assert (INTEGER_CST_P (offset
));
2793 /* Disable bound checking for now because it's probably broken. */
2794 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2801 /* Restore old values of globals. */
2802 first_len
= old_first_len
;
2803 first_len_val
= old_first_len_val
;
2804 typespec_chararray_ctor
= old_typespec_chararray_ctor
;
2808 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
2809 called after evaluating all of INFO's vector dimensions. Go through
2810 each such vector dimension and see if we can now fill in any missing
2814 set_vector_loop_bounds (gfc_ss
* ss
)
2816 gfc_loopinfo
*loop
, *outer_loop
;
2817 gfc_array_info
*info
;
2825 outer_loop
= outermost_loop (ss
->loop
);
2827 info
= &ss
->info
->data
.array
;
2829 for (; ss
; ss
= ss
->parent
)
2833 for (n
= 0; n
< loop
->dimen
; n
++)
2836 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_VECTOR
2837 || loop
->to
[n
] != NULL
)
2840 /* Loop variable N indexes vector dimension DIM, and we don't
2841 yet know the upper bound of loop variable N. Set it to the
2842 difference between the vector's upper and lower bounds. */
2843 gcc_assert (loop
->from
[n
] == gfc_index_zero_node
);
2844 gcc_assert (info
->subscript
[dim
]
2845 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
2847 gfc_init_se (&se
, NULL
);
2848 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
2849 zero
= gfc_rank_cst
[0];
2850 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2851 gfc_array_index_type
,
2852 gfc_conv_descriptor_ubound_get (desc
, zero
),
2853 gfc_conv_descriptor_lbound_get (desc
, zero
));
2854 tmp
= gfc_evaluate_now (tmp
, &outer_loop
->pre
);
2861 /* Tells whether a scalar argument to an elemental procedure is saved out
2862 of a scalarization loop as a value or as a reference. */
2865 gfc_scalar_elemental_arg_saved_as_reference (gfc_ss_info
* ss_info
)
2867 if (ss_info
->type
!= GFC_SS_REFERENCE
)
2870 if (ss_info
->data
.scalar
.needs_temporary
)
2873 /* If the actual argument can be absent (in other words, it can
2874 be a NULL reference), don't try to evaluate it; pass instead
2875 the reference directly. */
2876 if (ss_info
->can_be_null_ref
)
2879 /* If the expression is of polymorphic type, it's actual size is not known,
2880 so we avoid copying it anywhere. */
2881 if (ss_info
->data
.scalar
.dummy_arg
2882 && ss_info
->data
.scalar
.dummy_arg
->ts
.type
== BT_CLASS
2883 && ss_info
->expr
->ts
.type
== BT_CLASS
)
2886 /* If the expression is a data reference of aggregate type,
2887 and the data reference is not used on the left hand side,
2888 avoid a copy by saving a reference to the content. */
2889 if (!ss_info
->data
.scalar
.needs_temporary
2890 && (ss_info
->expr
->ts
.type
== BT_DERIVED
2891 || ss_info
->expr
->ts
.type
== BT_CLASS
)
2892 && gfc_expr_is_variable (ss_info
->expr
))
2895 /* Otherwise the expression is evaluated to a temporary variable before the
2896 scalarization loop. */
2901 /* Add the pre and post chains for all the scalar expressions in a SS chain
2902 to loop. This is called after the loop parameters have been calculated,
2903 but before the actual scalarizing loops. */
2906 gfc_add_loop_ss_code (gfc_loopinfo
* loop
, gfc_ss
* ss
, bool subscript
,
2909 gfc_loopinfo
*nested_loop
, *outer_loop
;
2911 gfc_ss_info
*ss_info
;
2912 gfc_array_info
*info
;
2916 /* Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise,
2917 arguments could get evaluated multiple times. */
2918 if (ss
->is_alloc_lhs
)
2921 outer_loop
= outermost_loop (loop
);
2923 /* TODO: This can generate bad code if there are ordering dependencies,
2924 e.g., a callee allocated function and an unknown size constructor. */
2925 gcc_assert (ss
!= NULL
);
2927 for (; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2931 /* Cross loop arrays are handled from within the most nested loop. */
2932 if (ss
->nested_ss
!= NULL
)
2936 expr
= ss_info
->expr
;
2937 info
= &ss_info
->data
.array
;
2939 switch (ss_info
->type
)
2942 /* Scalar expression. Evaluate this now. This includes elemental
2943 dimension indices, but not array section bounds. */
2944 gfc_init_se (&se
, NULL
);
2945 gfc_conv_expr (&se
, expr
);
2946 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2948 if (expr
->ts
.type
!= BT_CHARACTER
2949 && !gfc_is_alloc_class_scalar_function (expr
))
2951 /* Move the evaluation of scalar expressions outside the
2952 scalarization loop, except for WHERE assignments. */
2954 se
.expr
= convert(gfc_array_index_type
, se
.expr
);
2955 if (!ss_info
->where
)
2956 se
.expr
= gfc_evaluate_now (se
.expr
, &outer_loop
->pre
);
2957 gfc_add_block_to_block (&outer_loop
->pre
, &se
.post
);
2960 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2962 ss_info
->data
.scalar
.value
= se
.expr
;
2963 ss_info
->string_length
= se
.string_length
;
2966 case GFC_SS_REFERENCE
:
2967 /* Scalar argument to elemental procedure. */
2968 gfc_init_se (&se
, NULL
);
2969 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info
))
2970 gfc_conv_expr_reference (&se
, expr
);
2973 /* Evaluate the argument outside the loop and pass
2974 a reference to the value. */
2975 gfc_conv_expr (&se
, expr
);
2978 /* Ensure that a pointer to the string is stored. */
2979 if (expr
->ts
.type
== BT_CHARACTER
)
2980 gfc_conv_string_parameter (&se
);
2982 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2983 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2984 if (gfc_is_class_scalar_expr (expr
))
2985 /* This is necessary because the dynamic type will always be
2986 large than the declared type. In consequence, assigning
2987 the value to a temporary could segfault.
2988 OOP-TODO: see if this is generally correct or is the value
2989 has to be written to an allocated temporary, whose address
2990 is passed via ss_info. */
2991 ss_info
->data
.scalar
.value
= se
.expr
;
2993 ss_info
->data
.scalar
.value
= gfc_evaluate_now (se
.expr
,
2996 ss_info
->string_length
= se
.string_length
;
2999 case GFC_SS_SECTION
:
3000 /* Add the expressions for scalar and vector subscripts. */
3001 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
3002 if (info
->subscript
[n
])
3003 gfc_add_loop_ss_code (loop
, info
->subscript
[n
], true, where
);
3005 set_vector_loop_bounds (ss
);
3009 /* Get the vector's descriptor and store it in SS. */
3010 gfc_init_se (&se
, NULL
);
3011 gfc_conv_expr_descriptor (&se
, expr
);
3012 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
3013 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
3014 info
->descriptor
= se
.expr
;
3017 case GFC_SS_INTRINSIC
:
3018 gfc_add_intrinsic_ss_code (loop
, ss
);
3021 case GFC_SS_FUNCTION
:
3022 /* Array function return value. We call the function and save its
3023 result in a temporary for use inside the loop. */
3024 gfc_init_se (&se
, NULL
);
3027 if (gfc_is_class_array_function (expr
))
3028 expr
->must_finalize
= 1;
3029 gfc_conv_expr (&se
, expr
);
3030 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
3031 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
3032 ss_info
->string_length
= se
.string_length
;
3035 case GFC_SS_CONSTRUCTOR
:
3036 if (expr
->ts
.type
== BT_CHARACTER
3037 && ss_info
->string_length
== NULL
3039 && expr
->ts
.u
.cl
->length
3040 && expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
3042 gfc_init_se (&se
, NULL
);
3043 gfc_conv_expr_type (&se
, expr
->ts
.u
.cl
->length
,
3044 gfc_charlen_type_node
);
3045 ss_info
->string_length
= se
.expr
;
3046 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
3047 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
3049 trans_array_constructor (ss
, where
);
3053 case GFC_SS_COMPONENT
:
3054 /* Do nothing. These are handled elsewhere. */
3063 for (nested_loop
= loop
->nested
; nested_loop
;
3064 nested_loop
= nested_loop
->next
)
3065 gfc_add_loop_ss_code (nested_loop
, nested_loop
->ss
, subscript
, where
);
3069 /* Translate expressions for the descriptor and data pointer of a SS. */
3073 gfc_conv_ss_descriptor (stmtblock_t
* block
, gfc_ss
* ss
, int base
)
3076 gfc_ss_info
*ss_info
;
3077 gfc_array_info
*info
;
3081 info
= &ss_info
->data
.array
;
3083 /* Get the descriptor for the array to be scalarized. */
3084 gcc_assert (ss_info
->expr
->expr_type
== EXPR_VARIABLE
);
3085 gfc_init_se (&se
, NULL
);
3086 se
.descriptor_only
= 1;
3087 gfc_conv_expr_lhs (&se
, ss_info
->expr
);
3088 gfc_add_block_to_block (block
, &se
.pre
);
3089 info
->descriptor
= se
.expr
;
3090 ss_info
->string_length
= se
.string_length
;
3094 if (ss_info
->expr
->ts
.type
== BT_CHARACTER
&& !ss_info
->expr
->ts
.deferred
3095 && ss_info
->expr
->ts
.u
.cl
->length
== NULL
)
3097 /* Emit a DECL_EXPR for the variable sized array type in
3098 GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
3099 sizes works correctly. */
3100 tree arraytype
= TREE_TYPE (
3101 GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (info
->descriptor
)));
3102 if (! TYPE_NAME (arraytype
))
3103 TYPE_NAME (arraytype
) = build_decl (UNKNOWN_LOCATION
, TYPE_DECL
,
3104 NULL_TREE
, arraytype
);
3105 gfc_add_expr_to_block (block
, build1 (DECL_EXPR
, arraytype
,
3106 TYPE_NAME (arraytype
)));
3108 /* Also the data pointer. */
3109 tmp
= gfc_conv_array_data (se
.expr
);
3110 /* If this is a variable or address or a class array, use it directly.
3111 Otherwise we must evaluate it now to avoid breaking dependency
3112 analysis by pulling the expressions for elemental array indices
3115 || (TREE_CODE (tmp
) == ADDR_EXPR
3116 && DECL_P (TREE_OPERAND (tmp
, 0)))
3117 || (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
.expr
))
3118 && TREE_CODE (se
.expr
) == COMPONENT_REF
3119 && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (se
.expr
, 0))))))
3120 tmp
= gfc_evaluate_now (tmp
, block
);
3123 tmp
= gfc_conv_array_offset (se
.expr
);
3124 info
->offset
= gfc_evaluate_now (tmp
, block
);
3126 /* Make absolutely sure that the saved_offset is indeed saved
3127 so that the variable is still accessible after the loops
3129 info
->saved_offset
= info
->offset
;
3134 /* Initialize a gfc_loopinfo structure. */
3137 gfc_init_loopinfo (gfc_loopinfo
* loop
)
3141 memset (loop
, 0, sizeof (gfc_loopinfo
));
3142 gfc_init_block (&loop
->pre
);
3143 gfc_init_block (&loop
->post
);
3145 /* Initially scalarize in order and default to no loop reversal. */
3146 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
3149 loop
->reverse
[n
] = GFC_INHIBIT_REVERSE
;
3152 loop
->ss
= gfc_ss_terminator
;
3156 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
3160 gfc_copy_loopinfo_to_se (gfc_se
* se
, gfc_loopinfo
* loop
)
3166 /* Return an expression for the data pointer of an array. */
3169 gfc_conv_array_data (tree descriptor
)
3173 type
= TREE_TYPE (descriptor
);
3174 if (GFC_ARRAY_TYPE_P (type
))
3176 if (TREE_CODE (type
) == POINTER_TYPE
)
3180 /* Descriptorless arrays. */
3181 return gfc_build_addr_expr (NULL_TREE
, descriptor
);
3185 return gfc_conv_descriptor_data_get (descriptor
);
3189 /* Return an expression for the base offset of an array. */
3192 gfc_conv_array_offset (tree descriptor
)
3196 type
= TREE_TYPE (descriptor
);
3197 if (GFC_ARRAY_TYPE_P (type
))
3198 return GFC_TYPE_ARRAY_OFFSET (type
);
3200 return gfc_conv_descriptor_offset_get (descriptor
);
3204 /* Get an expression for the array stride. */
3207 gfc_conv_array_stride (tree descriptor
, int dim
)
3212 type
= TREE_TYPE (descriptor
);
3214 /* For descriptorless arrays use the array size. */
3215 tmp
= GFC_TYPE_ARRAY_STRIDE (type
, dim
);
3216 if (tmp
!= NULL_TREE
)
3219 tmp
= gfc_conv_descriptor_stride_get (descriptor
, gfc_rank_cst
[dim
]);
3224 /* Like gfc_conv_array_stride, but for the lower bound. */
3227 gfc_conv_array_lbound (tree descriptor
, int dim
)
3232 type
= TREE_TYPE (descriptor
);
3234 tmp
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
3235 if (tmp
!= NULL_TREE
)
3238 tmp
= gfc_conv_descriptor_lbound_get (descriptor
, gfc_rank_cst
[dim
]);
3243 /* Like gfc_conv_array_stride, but for the upper bound. */
3246 gfc_conv_array_ubound (tree descriptor
, int dim
)
3251 type
= TREE_TYPE (descriptor
);
3253 tmp
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
3254 if (tmp
!= NULL_TREE
)
3257 /* This should only ever happen when passing an assumed shape array
3258 as an actual parameter. The value will never be used. */
3259 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor
)))
3260 return gfc_index_zero_node
;
3262 tmp
= gfc_conv_descriptor_ubound_get (descriptor
, gfc_rank_cst
[dim
]);
3267 /* Generate code to perform an array index bound check. */
3270 trans_array_bound_check (gfc_se
* se
, gfc_ss
*ss
, tree index
, int n
,
3271 locus
* where
, bool check_upper
)
3274 tree tmp_lo
, tmp_up
;
3277 const char * name
= NULL
;
3279 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
3282 descriptor
= ss
->info
->data
.array
.descriptor
;
3284 index
= gfc_evaluate_now (index
, &se
->pre
);
3286 /* We find a name for the error message. */
3287 name
= ss
->info
->expr
->symtree
->n
.sym
->name
;
3288 gcc_assert (name
!= NULL
);
3290 if (VAR_P (descriptor
))
3291 name
= IDENTIFIER_POINTER (DECL_NAME (descriptor
));
3293 /* If upper bound is present, include both bounds in the error message. */
3296 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
3297 tmp_up
= gfc_conv_array_ubound (descriptor
, n
);
3300 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3301 "outside of expected range (%%ld:%%ld)", n
+1, name
);
3303 msg
= xasprintf ("Index '%%ld' of dimension %d "
3304 "outside of expected range (%%ld:%%ld)", n
+1);
3306 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3308 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
3309 fold_convert (long_integer_type_node
, index
),
3310 fold_convert (long_integer_type_node
, tmp_lo
),
3311 fold_convert (long_integer_type_node
, tmp_up
));
3312 fault
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
3314 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
3315 fold_convert (long_integer_type_node
, index
),
3316 fold_convert (long_integer_type_node
, tmp_lo
),
3317 fold_convert (long_integer_type_node
, tmp_up
));
3322 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
3325 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3326 "below lower bound of %%ld", n
+1, name
);
3328 msg
= xasprintf ("Index '%%ld' of dimension %d "
3329 "below lower bound of %%ld", n
+1);
3331 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3333 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
3334 fold_convert (long_integer_type_node
, index
),
3335 fold_convert (long_integer_type_node
, tmp_lo
));
3343 /* Return the offset for an index. Performs bound checking for elemental
3344 dimensions. Single element references are processed separately.
3345 DIM is the array dimension, I is the loop dimension. */
3348 conv_array_index_offset (gfc_se
* se
, gfc_ss
* ss
, int dim
, int i
,
3349 gfc_array_ref
* ar
, tree stride
)
3351 gfc_array_info
*info
;
3356 info
= &ss
->info
->data
.array
;
3358 /* Get the index into the array for this dimension. */
3361 gcc_assert (ar
->type
!= AR_ELEMENT
);
3362 switch (ar
->dimen_type
[dim
])
3364 case DIMEN_THIS_IMAGE
:
3368 /* Elemental dimension. */
3369 gcc_assert (info
->subscript
[dim
]
3370 && info
->subscript
[dim
]->info
->type
== GFC_SS_SCALAR
);
3371 /* We've already translated this value outside the loop. */
3372 index
= info
->subscript
[dim
]->info
->data
.scalar
.value
;
3374 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
3375 ar
->as
->type
!= AS_ASSUMED_SIZE
3376 || dim
< ar
->dimen
- 1);
3380 gcc_assert (info
&& se
->loop
);
3381 gcc_assert (info
->subscript
[dim
]
3382 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
3383 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
3385 /* Get a zero-based index into the vector. */
3386 index
= fold_build2_loc (input_location
, MINUS_EXPR
,
3387 gfc_array_index_type
,
3388 se
->loop
->loopvar
[i
], se
->loop
->from
[i
]);
3390 /* Multiply the index by the stride. */
3391 index
= fold_build2_loc (input_location
, MULT_EXPR
,
3392 gfc_array_index_type
,
3393 index
, gfc_conv_array_stride (desc
, 0));
3395 /* Read the vector to get an index into info->descriptor. */
3396 data
= build_fold_indirect_ref_loc (input_location
,
3397 gfc_conv_array_data (desc
));
3398 index
= gfc_build_array_ref (data
, index
, NULL
);
3399 index
= gfc_evaluate_now (index
, &se
->pre
);
3400 index
= fold_convert (gfc_array_index_type
, index
);
3402 /* Do any bounds checking on the final info->descriptor index. */
3403 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
3404 ar
->as
->type
!= AS_ASSUMED_SIZE
3405 || dim
< ar
->dimen
- 1);
3409 /* Scalarized dimension. */
3410 gcc_assert (info
&& se
->loop
);
3412 /* Multiply the loop variable by the stride and delta. */
3413 index
= se
->loop
->loopvar
[i
];
3414 if (!integer_onep (info
->stride
[dim
]))
3415 index
= fold_build2_loc (input_location
, MULT_EXPR
,
3416 gfc_array_index_type
, index
,
3418 if (!integer_zerop (info
->delta
[dim
]))
3419 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
3420 gfc_array_index_type
, index
,
3430 /* Temporary array or derived type component. */
3431 gcc_assert (se
->loop
);
3432 index
= se
->loop
->loopvar
[se
->loop
->order
[i
]];
3434 /* Pointer functions can have stride[0] different from unity.
3435 Use the stride returned by the function call and stored in
3436 the descriptor for the temporary. */
3437 if (se
->ss
&& se
->ss
->info
->type
== GFC_SS_FUNCTION
3438 && se
->ss
->info
->expr
3439 && se
->ss
->info
->expr
->symtree
3440 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
3441 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
->attr
.pointer
)
3442 stride
= gfc_conv_descriptor_stride_get (info
->descriptor
,
3445 if (info
->delta
[dim
] && !integer_zerop (info
->delta
[dim
]))
3446 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
3447 gfc_array_index_type
, index
, info
->delta
[dim
]);
3450 /* Multiply by the stride. */
3451 if (stride
!= NULL
&& !integer_onep (stride
))
3452 index
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3459 /* Build a scalarized array reference using the vptr 'size'. */
3462 build_class_array_ref (gfc_se
*se
, tree base
, tree index
)
3465 tree decl
= NULL_TREE
;
3467 gfc_expr
*expr
= se
->ss
->info
->expr
;
3468 gfc_expr
*class_expr
;
3472 tmp
= !VAR_P (base
) ? gfc_get_class_from_expr (base
) : NULL_TREE
;
3474 if (tmp
!= NULL_TREE
)
3478 /* The base expression does not contain a class component, either
3479 because it is a temporary array or array descriptor. Class
3480 array functions are correctly resolved above. */
3482 || (expr
->ts
.type
!= BT_CLASS
3483 && !gfc_is_class_array_ref (expr
, NULL
)))
3486 /* Obtain the expression for the class entity or component that is
3487 followed by an array reference, which is not an element, so that
3488 the span of the array can be obtained. */
3489 class_expr
= gfc_find_and_cut_at_last_class_ref (expr
, false, &ts
);
3494 sym
= (!class_expr
&& expr
) ? expr
->symtree
->n
.sym
: NULL
;
3495 if (sym
&& sym
->attr
.function
3496 && sym
== sym
->result
3497 && sym
->backend_decl
== current_function_decl
)
3498 /* The temporary is the data field of the class data component
3499 of the current function. */
3500 decl
= gfc_get_fake_result_decl (sym
, 0);
3503 if (decl
== NULL_TREE
)
3504 decl
= expr
->symtree
->n
.sym
->backend_decl
;
3505 /* For class arrays the tree containing the class is stored in
3506 GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl.
3507 For all others it's sym's backend_decl directly. */
3508 if (DECL_LANG_SPECIFIC (decl
) && GFC_DECL_SAVED_DESCRIPTOR (decl
))
3509 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
3512 decl
= gfc_get_class_from_gfc_expr (class_expr
);
3514 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
3515 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
3517 if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl
)))
3521 se
->class_vptr
= gfc_evaluate_now (gfc_class_vptr_get (decl
), &se
->pre
);
3523 size
= gfc_class_vtab_size_get (decl
);
3524 /* For unlimited polymorphic entities then _len component needs to be
3525 multiplied with the size. */
3526 size
= gfc_resize_class_size_with_len (&se
->pre
, decl
, size
);
3527 size
= fold_convert (TREE_TYPE (index
), size
);
3529 /* Return the element in the se expression. */
3530 se
->expr
= gfc_build_spanned_array_ref (base
, index
, size
);
3535 /* Build a scalarized reference to an array. */
3538 gfc_conv_scalarized_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
3540 gfc_array_info
*info
;
3541 tree decl
= NULL_TREE
;
3549 expr
= ss
->info
->expr
;
3550 info
= &ss
->info
->data
.array
;
3552 n
= se
->loop
->order
[0];
3556 index
= conv_array_index_offset (se
, ss
, ss
->dim
[n
], n
, ar
, info
->stride0
);
3557 /* Add the offset for this dimension to the stored offset for all other
3559 if (info
->offset
&& !integer_zerop (info
->offset
))
3560 index
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3561 index
, info
->offset
);
3563 base
= build_fold_indirect_ref_loc (input_location
, info
->data
);
3565 /* Use the vptr 'size' field to access the element of a class array. */
3566 if (build_class_array_ref (se
, base
, index
))
3569 if (get_CFI_desc (NULL
, expr
, &decl
, ar
))
3570 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
3572 /* A pointer array component can be detected from its field decl. Fix
3573 the descriptor, mark the resulting variable decl and pass it to
3574 gfc_build_array_ref. */
3575 if (is_pointer_array (info
->descriptor
)
3576 || (expr
&& expr
->ts
.deferred
&& info
->descriptor
3577 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info
->descriptor
))))
3579 if (TREE_CODE (info
->descriptor
) == COMPONENT_REF
)
3580 decl
= info
->descriptor
;
3581 else if (TREE_CODE (info
->descriptor
) == INDIRECT_REF
)
3582 decl
= TREE_OPERAND (info
->descriptor
, 0);
3584 if (decl
== NULL_TREE
)
3585 decl
= info
->descriptor
;
3588 se
->expr
= gfc_build_array_ref (base
, index
, decl
);
3592 /* Translate access of temporary array. */
3595 gfc_conv_tmp_array_ref (gfc_se
* se
)
3597 se
->string_length
= se
->ss
->info
->string_length
;
3598 gfc_conv_scalarized_array_ref (se
, NULL
);
3599 gfc_advance_se_ss_chain (se
);
3602 /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
3605 add_to_offset (tree
*cst_offset
, tree
*offset
, tree t
)
3607 if (TREE_CODE (t
) == INTEGER_CST
)
3608 *cst_offset
= int_const_binop (PLUS_EXPR
, *cst_offset
, t
);
3611 if (!integer_zerop (*offset
))
3612 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3613 gfc_array_index_type
, *offset
, t
);
3621 build_array_ref (tree desc
, tree offset
, tree decl
, tree vptr
)
3627 /* For class arrays the class declaration is stored in the saved
3629 if (INDIRECT_REF_P (desc
)
3630 && DECL_LANG_SPECIFIC (TREE_OPERAND (desc
, 0))
3631 && GFC_DECL_SAVED_DESCRIPTOR (TREE_OPERAND (desc
, 0)))
3632 cdesc
= gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (
3633 TREE_OPERAND (desc
, 0)));
3637 /* Class container types do not always have the GFC_CLASS_TYPE_P
3638 but the canonical type does. */
3639 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdesc
))
3640 && TREE_CODE (cdesc
) == COMPONENT_REF
)
3642 type
= TREE_TYPE (TREE_OPERAND (cdesc
, 0));
3643 if (TYPE_CANONICAL (type
)
3644 && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type
)))
3645 vptr
= gfc_class_vptr_get (TREE_OPERAND (cdesc
, 0));
3648 tmp
= gfc_conv_array_data (desc
);
3649 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3650 tmp
= gfc_build_array_ref (tmp
, offset
, decl
, vptr
);
3655 /* Build an array reference. se->expr already holds the array descriptor.
3656 This should be either a variable, indirect variable reference or component
3657 reference. For arrays which do not have a descriptor, se->expr will be
3659 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
3662 gfc_conv_array_ref (gfc_se
* se
, gfc_array_ref
* ar
, gfc_expr
*expr
,
3666 tree offset
, cst_offset
;
3669 tree decl
= NULL_TREE
;
3672 gfc_symbol
* sym
= expr
->symtree
->n
.sym
;
3673 char *var_name
= NULL
;
3677 gcc_assert (ar
->codimen
|| sym
->attr
.select_rank_temporary
3678 || (ar
->as
&& ar
->as
->corank
));
3680 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
->expr
)))
3681 se
->expr
= build_fold_indirect_ref (gfc_conv_array_data (se
->expr
));
3684 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se
->expr
))
3685 && TREE_CODE (TREE_TYPE (se
->expr
)) == POINTER_TYPE
)
3686 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3688 /* Use the actual tree type and not the wrapped coarray. */
3689 if (!se
->want_pointer
)
3690 se
->expr
= fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se
->expr
)),
3697 /* Handle scalarized references separately. */
3698 if (ar
->type
!= AR_ELEMENT
)
3700 gfc_conv_scalarized_array_ref (se
, ar
);
3701 gfc_advance_se_ss_chain (se
);
3705 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3710 len
= strlen (sym
->name
) + 1;
3711 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3713 if (ref
->type
== REF_ARRAY
&& &ref
->u
.ar
== ar
)
3715 if (ref
->type
== REF_COMPONENT
)
3716 len
+= 2 + strlen (ref
->u
.c
.component
->name
);
3719 var_name
= XALLOCAVEC (char, len
);
3720 strcpy (var_name
, sym
->name
);
3722 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3724 if (ref
->type
== REF_ARRAY
&& &ref
->u
.ar
== ar
)
3726 if (ref
->type
== REF_COMPONENT
)
3728 strcat (var_name
, "%%");
3729 strcat (var_name
, ref
->u
.c
.component
->name
);
3735 if (IS_CLASS_ARRAY (sym
) && sym
->attr
.dummy
&& ar
->as
->type
!= AS_DEFERRED
)
3736 decl
= sym
->backend_decl
;
3738 cst_offset
= offset
= gfc_index_zero_node
;
3739 add_to_offset (&cst_offset
, &offset
, gfc_conv_array_offset (decl
));
3741 /* Calculate the offsets from all the dimensions. Make sure to associate
3742 the final offset so that we form a chain of loop invariant summands. */
3743 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
3745 /* Calculate the index for this dimension. */
3746 gfc_init_se (&indexse
, se
);
3747 gfc_conv_expr_type (&indexse
, ar
->start
[n
], gfc_array_index_type
);
3748 gfc_add_block_to_block (&se
->pre
, &indexse
.pre
);
3750 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && ! expr
->no_bounds_check
)
3752 /* Check array bounds. */
3756 /* Evaluate the indexse.expr only once. */
3757 indexse
.expr
= save_expr (indexse
.expr
);
3760 tmp
= gfc_conv_array_lbound (decl
, n
);
3761 if (sym
->attr
.temporary
)
3763 gfc_init_se (&tmpse
, se
);
3764 gfc_conv_expr_type (&tmpse
, ar
->as
->lower
[n
],
3765 gfc_array_index_type
);
3766 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3770 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3772 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3773 "below lower bound of %%ld", n
+1, var_name
);
3774 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3775 fold_convert (long_integer_type_node
,
3777 fold_convert (long_integer_type_node
, tmp
));
3780 /* Upper bound, but not for the last dimension of assumed-size
3782 if (n
< ar
->dimen
- 1 || ar
->as
->type
!= AS_ASSUMED_SIZE
)
3784 tmp
= gfc_conv_array_ubound (decl
, n
);
3785 if (sym
->attr
.temporary
)
3787 gfc_init_se (&tmpse
, se
);
3788 gfc_conv_expr_type (&tmpse
, ar
->as
->upper
[n
],
3789 gfc_array_index_type
);
3790 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3794 cond
= fold_build2_loc (input_location
, GT_EXPR
,
3795 logical_type_node
, indexse
.expr
, tmp
);
3796 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3797 "above upper bound of %%ld", n
+1, var_name
);
3798 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3799 fold_convert (long_integer_type_node
,
3801 fold_convert (long_integer_type_node
, tmp
));
3806 /* Multiply the index by the stride. */
3807 stride
= gfc_conv_array_stride (decl
, n
);
3808 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3809 indexse
.expr
, stride
);
3811 /* And add it to the total. */
3812 add_to_offset (&cst_offset
, &offset
, tmp
);
3815 if (!integer_zerop (cst_offset
))
3816 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3817 gfc_array_index_type
, offset
, cst_offset
);
3819 /* A pointer array component can be detected from its field decl. Fix
3820 the descriptor, mark the resulting variable decl and pass it to
3823 if (get_CFI_desc (sym
, expr
, &decl
, ar
))
3824 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
3825 if (!expr
->ts
.deferred
&& !sym
->attr
.codimension
3826 && is_pointer_array (se
->expr
))
3828 if (TREE_CODE (se
->expr
) == COMPONENT_REF
)
3830 else if (TREE_CODE (se
->expr
) == INDIRECT_REF
)
3831 decl
= TREE_OPERAND (se
->expr
, 0);
3835 else if (expr
->ts
.deferred
3836 || (sym
->ts
.type
== BT_CHARACTER
3837 && sym
->attr
.select_type_temporary
))
3839 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
->expr
)))
3842 if (TREE_CODE (decl
) == INDIRECT_REF
)
3843 decl
= TREE_OPERAND (decl
, 0);
3846 decl
= sym
->backend_decl
;
3848 else if (sym
->ts
.type
== BT_CLASS
)
3850 if (UNLIMITED_POLY (sym
))
3852 gfc_expr
*class_expr
= gfc_find_and_cut_at_last_class_ref (expr
);
3853 gfc_init_se (&tmpse
, NULL
);
3854 gfc_conv_expr (&tmpse
, class_expr
);
3855 if (!se
->class_vptr
)
3856 se
->class_vptr
= gfc_class_vptr_get (tmpse
.expr
);
3857 gfc_free_expr (class_expr
);
3864 se
->expr
= build_array_ref (se
->expr
, offset
, decl
, se
->class_vptr
);
3868 /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
3869 LOOP_DIM dimension (if any) to array's offset. */
3872 add_array_offset (stmtblock_t
*pblock
, gfc_loopinfo
*loop
, gfc_ss
*ss
,
3873 gfc_array_ref
*ar
, int array_dim
, int loop_dim
)
3876 gfc_array_info
*info
;
3879 info
= &ss
->info
->data
.array
;
3881 gfc_init_se (&se
, NULL
);
3883 se
.expr
= info
->descriptor
;
3884 stride
= gfc_conv_array_stride (info
->descriptor
, array_dim
);
3885 index
= conv_array_index_offset (&se
, ss
, array_dim
, loop_dim
, ar
, stride
);
3886 gfc_add_block_to_block (pblock
, &se
.pre
);
3888 info
->offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3889 gfc_array_index_type
,
3890 info
->offset
, index
);
3891 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
3895 /* Generate the code to be executed immediately before entering a
3896 scalarization loop. */
3899 gfc_trans_preloop_setup (gfc_loopinfo
* loop
, int dim
, int flag
,
3900 stmtblock_t
* pblock
)
3903 gfc_ss_info
*ss_info
;
3904 gfc_array_info
*info
;
3905 gfc_ss_type ss_type
;
3907 gfc_loopinfo
*ploop
;
3911 /* This code will be executed before entering the scalarization loop
3912 for this dimension. */
3913 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3917 if ((ss_info
->useflags
& flag
) == 0)
3920 ss_type
= ss_info
->type
;
3921 if (ss_type
!= GFC_SS_SECTION
3922 && ss_type
!= GFC_SS_FUNCTION
3923 && ss_type
!= GFC_SS_CONSTRUCTOR
3924 && ss_type
!= GFC_SS_COMPONENT
)
3927 info
= &ss_info
->data
.array
;
3929 gcc_assert (dim
< ss
->dimen
);
3930 gcc_assert (ss
->dimen
== loop
->dimen
);
3933 ar
= &info
->ref
->u
.ar
;
3937 if (dim
== loop
->dimen
- 1 && loop
->parent
!= NULL
)
3939 /* If we are in the outermost dimension of this loop, the previous
3940 dimension shall be in the parent loop. */
3941 gcc_assert (ss
->parent
!= NULL
);
3944 ploop
= loop
->parent
;
3946 /* ss and ss->parent are about the same array. */
3947 gcc_assert (ss_info
== pss
->info
);
3955 if (dim
== loop
->dimen
- 1)
3960 /* For the time being, there is no loop reordering. */
3961 gcc_assert (i
== ploop
->order
[i
]);
3962 i
= ploop
->order
[i
];
3964 if (dim
== loop
->dimen
- 1 && loop
->parent
== NULL
)
3966 stride
= gfc_conv_array_stride (info
->descriptor
,
3967 innermost_ss (ss
)->dim
[i
]);
3969 /* Calculate the stride of the innermost loop. Hopefully this will
3970 allow the backend optimizers to do their stuff more effectively.
3972 info
->stride0
= gfc_evaluate_now (stride
, pblock
);
3974 /* For the outermost loop calculate the offset due to any
3975 elemental dimensions. It will have been initialized with the
3976 base offset of the array. */
3979 for (i
= 0; i
< ar
->dimen
; i
++)
3981 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
3984 add_array_offset (pblock
, loop
, ss
, ar
, i
, /* unused */ -1);
3989 /* Add the offset for the previous loop dimension. */
3990 add_array_offset (pblock
, ploop
, ss
, ar
, pss
->dim
[i
], i
);
3992 /* Remember this offset for the second loop. */
3993 if (dim
== loop
->temp_dim
- 1 && loop
->parent
== NULL
)
3994 info
->saved_offset
= info
->offset
;
3999 /* Start a scalarized expression. Creates a scope and declares loop
4003 gfc_start_scalarized_body (gfc_loopinfo
* loop
, stmtblock_t
* pbody
)
4009 gcc_assert (!loop
->array_parameter
);
4011 for (dim
= loop
->dimen
- 1; dim
>= 0; dim
--)
4013 n
= loop
->order
[dim
];
4015 gfc_start_block (&loop
->code
[n
]);
4017 /* Create the loop variable. */
4018 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "S");
4020 if (dim
< loop
->temp_dim
)
4024 /* Calculate values that will be constant within this loop. */
4025 gfc_trans_preloop_setup (loop
, dim
, flags
, &loop
->code
[n
]);
4027 gfc_start_block (pbody
);
4031 /* Generates the actual loop code for a scalarization loop. */
4034 gfc_trans_scalarized_loop_end (gfc_loopinfo
* loop
, int n
,
4035 stmtblock_t
* pbody
)
4046 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
4047 | OMPWS_SCALARIZER_BODY
))
4048 == (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
)
4049 && n
== loop
->dimen
- 1)
4051 /* We create an OMP_FOR construct for the outermost scalarized loop. */
4052 init
= make_tree_vec (1);
4053 cond
= make_tree_vec (1);
4054 incr
= make_tree_vec (1);
4056 /* Cycle statement is implemented with a goto. Exit statement must not
4057 be present for this loop. */
4058 exit_label
= gfc_build_label_decl (NULL_TREE
);
4059 TREE_USED (exit_label
) = 1;
4061 /* Label for cycle statements (if needed). */
4062 tmp
= build1_v (LABEL_EXPR
, exit_label
);
4063 gfc_add_expr_to_block (pbody
, tmp
);
4065 stmt
= make_node (OMP_FOR
);
4067 TREE_TYPE (stmt
) = void_type_node
;
4068 OMP_FOR_BODY (stmt
) = loopbody
= gfc_finish_block (pbody
);
4070 OMP_FOR_CLAUSES (stmt
) = build_omp_clause (input_location
,
4071 OMP_CLAUSE_SCHEDULE
);
4072 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt
))
4073 = OMP_CLAUSE_SCHEDULE_STATIC
;
4074 if (ompws_flags
& OMPWS_NOWAIT
)
4075 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt
))
4076 = build_omp_clause (input_location
, OMP_CLAUSE_NOWAIT
);
4078 /* Initialize the loopvar. */
4079 TREE_VEC_ELT (init
, 0) = build2_v (MODIFY_EXPR
, loop
->loopvar
[n
],
4081 OMP_FOR_INIT (stmt
) = init
;
4082 /* The exit condition. */
4083 TREE_VEC_ELT (cond
, 0) = build2_loc (input_location
, LE_EXPR
,
4085 loop
->loopvar
[n
], loop
->to
[n
]);
4086 SET_EXPR_LOCATION (TREE_VEC_ELT (cond
, 0), input_location
);
4087 OMP_FOR_COND (stmt
) = cond
;
4088 /* Increment the loopvar. */
4089 tmp
= build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4090 loop
->loopvar
[n
], gfc_index_one_node
);
4091 TREE_VEC_ELT (incr
, 0) = fold_build2_loc (input_location
, MODIFY_EXPR
,
4092 void_type_node
, loop
->loopvar
[n
], tmp
);
4093 OMP_FOR_INCR (stmt
) = incr
;
4095 ompws_flags
&= ~OMPWS_CURR_SINGLEUNIT
;
4096 gfc_add_expr_to_block (&loop
->code
[n
], stmt
);
4100 bool reverse_loop
= (loop
->reverse
[n
] == GFC_REVERSE_SET
)
4101 && (loop
->temp_ss
== NULL
);
4103 loopbody
= gfc_finish_block (pbody
);
4106 std::swap (loop
->from
[n
], loop
->to
[n
]);
4108 /* Initialize the loopvar. */
4109 if (loop
->loopvar
[n
] != loop
->from
[n
])
4110 gfc_add_modify (&loop
->code
[n
], loop
->loopvar
[n
], loop
->from
[n
]);
4112 exit_label
= gfc_build_label_decl (NULL_TREE
);
4114 /* Generate the loop body. */
4115 gfc_init_block (&block
);
4117 /* The exit condition. */
4118 cond
= fold_build2_loc (input_location
, reverse_loop
? LT_EXPR
: GT_EXPR
,
4119 logical_type_node
, loop
->loopvar
[n
], loop
->to
[n
]);
4120 tmp
= build1_v (GOTO_EXPR
, exit_label
);
4121 TREE_USED (exit_label
) = 1;
4122 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
4123 gfc_add_expr_to_block (&block
, tmp
);
4125 /* The main body. */
4126 gfc_add_expr_to_block (&block
, loopbody
);
4128 /* Increment the loopvar. */
4129 tmp
= fold_build2_loc (input_location
,
4130 reverse_loop
? MINUS_EXPR
: PLUS_EXPR
,
4131 gfc_array_index_type
, loop
->loopvar
[n
],
4132 gfc_index_one_node
);
4134 gfc_add_modify (&block
, loop
->loopvar
[n
], tmp
);
4136 /* Build the loop. */
4137 tmp
= gfc_finish_block (&block
);
4138 tmp
= build1_v (LOOP_EXPR
, tmp
);
4139 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
4141 /* Add the exit label. */
4142 tmp
= build1_v (LABEL_EXPR
, exit_label
);
4143 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
4149 /* Finishes and generates the loops for a scalarized expression. */
4152 gfc_trans_scalarizing_loops (gfc_loopinfo
* loop
, stmtblock_t
* body
)
4157 stmtblock_t
*pblock
;
4161 /* Generate the loops. */
4162 for (dim
= 0; dim
< loop
->dimen
; dim
++)
4164 n
= loop
->order
[dim
];
4165 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
4166 loop
->loopvar
[n
] = NULL_TREE
;
4167 pblock
= &loop
->code
[n
];
4170 tmp
= gfc_finish_block (pblock
);
4171 gfc_add_expr_to_block (&loop
->pre
, tmp
);
4173 /* Clear all the used flags. */
4174 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4175 if (ss
->parent
== NULL
)
4176 ss
->info
->useflags
= 0;
4180 /* Finish the main body of a scalarized expression, and start the secondary
4184 gfc_trans_scalarized_loop_boundary (gfc_loopinfo
* loop
, stmtblock_t
* body
)
4188 stmtblock_t
*pblock
;
4192 /* We finish as many loops as are used by the temporary. */
4193 for (dim
= 0; dim
< loop
->temp_dim
- 1; dim
++)
4195 n
= loop
->order
[dim
];
4196 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
4197 loop
->loopvar
[n
] = NULL_TREE
;
4198 pblock
= &loop
->code
[n
];
4201 /* We don't want to finish the outermost loop entirely. */
4202 n
= loop
->order
[loop
->temp_dim
- 1];
4203 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
4205 /* Restore the initial offsets. */
4206 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4208 gfc_ss_type ss_type
;
4209 gfc_ss_info
*ss_info
;
4213 if ((ss_info
->useflags
& 2) == 0)
4216 ss_type
= ss_info
->type
;
4217 if (ss_type
!= GFC_SS_SECTION
4218 && ss_type
!= GFC_SS_FUNCTION
4219 && ss_type
!= GFC_SS_CONSTRUCTOR
4220 && ss_type
!= GFC_SS_COMPONENT
)
4223 ss_info
->data
.array
.offset
= ss_info
->data
.array
.saved_offset
;
4226 /* Restart all the inner loops we just finished. */
4227 for (dim
= loop
->temp_dim
- 2; dim
>= 0; dim
--)
4229 n
= loop
->order
[dim
];
4231 gfc_start_block (&loop
->code
[n
]);
4233 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "Q");
4235 gfc_trans_preloop_setup (loop
, dim
, 2, &loop
->code
[n
]);
4238 /* Start a block for the secondary copying code. */
4239 gfc_start_block (body
);
4243 /* Precalculate (either lower or upper) bound of an array section.
4244 BLOCK: Block in which the (pre)calculation code will go.
4245 BOUNDS[DIM]: Where the bound value will be stored once evaluated.
4246 VALUES[DIM]: Specified bound (NULL <=> unspecified).
4247 DESC: Array descriptor from which the bound will be picked if unspecified
4248 (either lower or upper bound according to LBOUND). */
4251 evaluate_bound (stmtblock_t
*block
, tree
*bounds
, gfc_expr
** values
,
4252 tree desc
, int dim
, bool lbound
, bool deferred
)
4255 gfc_expr
* input_val
= values
[dim
];
4256 tree
*output
= &bounds
[dim
];
4261 /* Specified section bound. */
4262 gfc_init_se (&se
, NULL
);
4263 gfc_conv_expr_type (&se
, input_val
, gfc_array_index_type
);
4264 gfc_add_block_to_block (block
, &se
.pre
);
4267 else if (deferred
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
4269 /* The gfc_conv_array_lbound () routine returns a constant zero for
4270 deferred length arrays, which in the scalarizer wreaks havoc, when
4271 copying to a (newly allocated) one-based array.
4272 Keep returning the actual result in sync for both bounds. */
4273 *output
= lbound
? gfc_conv_descriptor_lbound_get (desc
,
4275 gfc_conv_descriptor_ubound_get (desc
,
4280 /* No specific bound specified so use the bound of the array. */
4281 *output
= lbound
? gfc_conv_array_lbound (desc
, dim
) :
4282 gfc_conv_array_ubound (desc
, dim
);
4284 *output
= gfc_evaluate_now (*output
, block
);
4288 /* Calculate the lower bound of an array section. */
4291 gfc_conv_section_startstride (stmtblock_t
* block
, gfc_ss
* ss
, int dim
)
4293 gfc_expr
*stride
= NULL
;
4296 gfc_array_info
*info
;
4299 gcc_assert (ss
->info
->type
== GFC_SS_SECTION
);
4301 info
= &ss
->info
->data
.array
;
4302 ar
= &info
->ref
->u
.ar
;
4304 if (ar
->dimen_type
[dim
] == DIMEN_VECTOR
)
4306 /* We use a zero-based index to access the vector. */
4307 info
->start
[dim
] = gfc_index_zero_node
;
4308 info
->end
[dim
] = NULL
;
4309 info
->stride
[dim
] = gfc_index_one_node
;
4313 gcc_assert (ar
->dimen_type
[dim
] == DIMEN_RANGE
4314 || ar
->dimen_type
[dim
] == DIMEN_THIS_IMAGE
);
4315 desc
= info
->descriptor
;
4316 stride
= ar
->stride
[dim
];
4319 /* Calculate the start of the range. For vector subscripts this will
4320 be the range of the vector. */
4321 evaluate_bound (block
, info
->start
, ar
->start
, desc
, dim
, true,
4322 ar
->as
->type
== AS_DEFERRED
);
4324 /* Similarly calculate the end. Although this is not used in the
4325 scalarizer, it is needed when checking bounds and where the end
4326 is an expression with side-effects. */
4327 evaluate_bound (block
, info
->end
, ar
->end
, desc
, dim
, false,
4328 ar
->as
->type
== AS_DEFERRED
);
4331 /* Calculate the stride. */
4333 info
->stride
[dim
] = gfc_index_one_node
;
4336 gfc_init_se (&se
, NULL
);
4337 gfc_conv_expr_type (&se
, stride
, gfc_array_index_type
);
4338 gfc_add_block_to_block (block
, &se
.pre
);
4339 info
->stride
[dim
] = gfc_evaluate_now (se
.expr
, block
);
4344 /* Calculates the range start and stride for a SS chain. Also gets the
4345 descriptor and data pointer. The range of vector subscripts is the size
4346 of the vector. Array bounds are also checked. */
4349 gfc_conv_ss_startstride (gfc_loopinfo
* loop
)
4356 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
4359 /* Determine the rank of the loop. */
4360 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4362 switch (ss
->info
->type
)
4364 case GFC_SS_SECTION
:
4365 case GFC_SS_CONSTRUCTOR
:
4366 case GFC_SS_FUNCTION
:
4367 case GFC_SS_COMPONENT
:
4368 loop
->dimen
= ss
->dimen
;
4371 /* As usual, lbound and ubound are exceptions!. */
4372 case GFC_SS_INTRINSIC
:
4373 switch (ss
->info
->expr
->value
.function
.isym
->id
)
4375 case GFC_ISYM_LBOUND
:
4376 case GFC_ISYM_UBOUND
:
4377 case GFC_ISYM_LCOBOUND
:
4378 case GFC_ISYM_UCOBOUND
:
4379 case GFC_ISYM_THIS_IMAGE
:
4380 loop
->dimen
= ss
->dimen
;
4392 /* We should have determined the rank of the expression by now. If
4393 not, that's bad news. */
4397 /* Loop over all the SS in the chain. */
4398 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4400 gfc_ss_info
*ss_info
;
4401 gfc_array_info
*info
;
4405 expr
= ss_info
->expr
;
4406 info
= &ss_info
->data
.array
;
4408 if (expr
&& expr
->shape
&& !info
->shape
)
4409 info
->shape
= expr
->shape
;
4411 switch (ss_info
->type
)
4413 case GFC_SS_SECTION
:
4414 /* Get the descriptor for the array. If it is a cross loops array,
4415 we got the descriptor already in the outermost loop. */
4416 if (ss
->parent
== NULL
)
4417 gfc_conv_ss_descriptor (&outer_loop
->pre
, ss
,
4418 !loop
->array_parameter
);
4420 for (n
= 0; n
< ss
->dimen
; n
++)
4421 gfc_conv_section_startstride (&outer_loop
->pre
, ss
, ss
->dim
[n
]);
4424 case GFC_SS_INTRINSIC
:
4425 switch (expr
->value
.function
.isym
->id
)
4427 /* Fall through to supply start and stride. */
4428 case GFC_ISYM_LBOUND
:
4429 case GFC_ISYM_UBOUND
:
4433 /* This is the variant without DIM=... */
4434 gcc_assert (expr
->value
.function
.actual
->next
->expr
== NULL
);
4436 arg
= expr
->value
.function
.actual
->expr
;
4437 if (arg
->rank
== -1)
4442 /* The rank (hence the return value's shape) is unknown,
4443 we have to retrieve it. */
4444 gfc_init_se (&se
, NULL
);
4445 se
.descriptor_only
= 1;
4446 gfc_conv_expr (&se
, arg
);
4447 /* This is a bare variable, so there is no preliminary
4449 gcc_assert (se
.pre
.head
== NULL_TREE
4450 && se
.post
.head
== NULL_TREE
);
4451 rank
= gfc_conv_descriptor_rank (se
.expr
);
4452 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4453 gfc_array_index_type
,
4454 fold_convert (gfc_array_index_type
,
4456 gfc_index_one_node
);
4457 info
->end
[0] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
4458 info
->start
[0] = gfc_index_zero_node
;
4459 info
->stride
[0] = gfc_index_one_node
;
4462 /* Otherwise fall through GFC_SS_FUNCTION. */
4465 case GFC_ISYM_LCOBOUND
:
4466 case GFC_ISYM_UCOBOUND
:
4467 case GFC_ISYM_THIS_IMAGE
:
4475 case GFC_SS_CONSTRUCTOR
:
4476 case GFC_SS_FUNCTION
:
4477 for (n
= 0; n
< ss
->dimen
; n
++)
4479 int dim
= ss
->dim
[n
];
4481 info
->start
[dim
] = gfc_index_zero_node
;
4482 info
->end
[dim
] = gfc_index_zero_node
;
4483 info
->stride
[dim
] = gfc_index_one_node
;
4492 /* The rest is just runtime bounds checking. */
4493 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
4496 tree lbound
, ubound
;
4498 tree size
[GFC_MAX_DIMENSIONS
];
4499 tree stride_pos
, stride_neg
, non_zerosized
, tmp2
, tmp3
;
4500 gfc_array_info
*info
;
4504 gfc_start_block (&block
);
4506 for (n
= 0; n
< loop
->dimen
; n
++)
4507 size
[n
] = NULL_TREE
;
4509 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4512 gfc_ss_info
*ss_info
;
4515 const char *expr_name
;
4518 if (ss_info
->type
!= GFC_SS_SECTION
)
4521 /* Catch allocatable lhs in f2003. */
4522 if (flag_realloc_lhs
&& ss
->no_bounds_check
)
4525 expr
= ss_info
->expr
;
4526 expr_loc
= &expr
->where
;
4527 expr_name
= expr
->symtree
->name
;
4529 gfc_start_block (&inner
);
4531 /* TODO: range checking for mapped dimensions. */
4532 info
= &ss_info
->data
.array
;
4534 /* This code only checks ranges. Elemental and vector
4535 dimensions are checked later. */
4536 for (n
= 0; n
< loop
->dimen
; n
++)
4541 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
4544 if (dim
== info
->ref
->u
.ar
.dimen
- 1
4545 && info
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
4546 check_upper
= false;
4550 /* Zero stride is not allowed. */
4551 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
4552 info
->stride
[dim
], gfc_index_zero_node
);
4553 msg
= xasprintf ("Zero stride is not allowed, for dimension %d "
4554 "of array '%s'", dim
+ 1, expr_name
);
4555 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4559 desc
= info
->descriptor
;
4561 /* This is the run-time equivalent of resolve.c's
4562 check_dimension(). The logical is more readable there
4563 than it is here, with all the trees. */
4564 lbound
= gfc_conv_array_lbound (desc
, dim
);
4565 end
= info
->end
[dim
];
4567 ubound
= gfc_conv_array_ubound (desc
, dim
);
4571 /* non_zerosized is true when the selected range is not
4573 stride_pos
= fold_build2_loc (input_location
, GT_EXPR
,
4574 logical_type_node
, info
->stride
[dim
],
4575 gfc_index_zero_node
);
4576 tmp
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
4577 info
->start
[dim
], end
);
4578 stride_pos
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4579 logical_type_node
, stride_pos
, tmp
);
4581 stride_neg
= fold_build2_loc (input_location
, LT_EXPR
,
4583 info
->stride
[dim
], gfc_index_zero_node
);
4584 tmp
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
4585 info
->start
[dim
], end
);
4586 stride_neg
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4589 non_zerosized
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
4591 stride_pos
, stride_neg
);
4593 /* Check the start of the range against the lower and upper
4594 bounds of the array, if the range is not empty.
4595 If upper bound is present, include both bounds in the
4599 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
4601 info
->start
[dim
], lbound
);
4602 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4604 non_zerosized
, tmp
);
4605 tmp2
= fold_build2_loc (input_location
, GT_EXPR
,
4607 info
->start
[dim
], ubound
);
4608 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4610 non_zerosized
, tmp2
);
4611 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4612 "outside of expected range (%%ld:%%ld)",
4613 dim
+ 1, expr_name
);
4614 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4616 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4617 fold_convert (long_integer_type_node
, lbound
),
4618 fold_convert (long_integer_type_node
, ubound
));
4619 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4621 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4622 fold_convert (long_integer_type_node
, lbound
),
4623 fold_convert (long_integer_type_node
, ubound
));
4628 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
4630 info
->start
[dim
], lbound
);
4631 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4632 logical_type_node
, non_zerosized
, tmp
);
4633 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4634 "below lower bound of %%ld",
4635 dim
+ 1, expr_name
);
4636 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4638 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4639 fold_convert (long_integer_type_node
, lbound
));
4643 /* Compute the last element of the range, which is not
4644 necessarily "end" (think 0:5:3, which doesn't contain 5)
4645 and check it against both lower and upper bounds. */
4647 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4648 gfc_array_index_type
, end
,
4650 tmp
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
,
4651 gfc_array_index_type
, tmp
,
4653 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4654 gfc_array_index_type
, end
, tmp
);
4655 tmp2
= fold_build2_loc (input_location
, LT_EXPR
,
4656 logical_type_node
, tmp
, lbound
);
4657 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4658 logical_type_node
, non_zerosized
, tmp2
);
4661 tmp3
= fold_build2_loc (input_location
, GT_EXPR
,
4662 logical_type_node
, tmp
, ubound
);
4663 tmp3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4664 logical_type_node
, non_zerosized
, tmp3
);
4665 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4666 "outside of expected range (%%ld:%%ld)",
4667 dim
+ 1, expr_name
);
4668 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4670 fold_convert (long_integer_type_node
, tmp
),
4671 fold_convert (long_integer_type_node
, ubound
),
4672 fold_convert (long_integer_type_node
, lbound
));
4673 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4675 fold_convert (long_integer_type_node
, tmp
),
4676 fold_convert (long_integer_type_node
, ubound
),
4677 fold_convert (long_integer_type_node
, lbound
));
4682 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4683 "below lower bound of %%ld",
4684 dim
+ 1, expr_name
);
4685 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4687 fold_convert (long_integer_type_node
, tmp
),
4688 fold_convert (long_integer_type_node
, lbound
));
4692 /* Check the section sizes match. */
4693 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4694 gfc_array_index_type
, end
,
4696 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
4697 gfc_array_index_type
, tmp
,
4699 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4700 gfc_array_index_type
,
4701 gfc_index_one_node
, tmp
);
4702 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
4703 gfc_array_index_type
, tmp
,
4704 build_int_cst (gfc_array_index_type
, 0));
4705 /* We remember the size of the first section, and check all the
4706 others against this. */
4709 tmp3
= fold_build2_loc (input_location
, NE_EXPR
,
4710 logical_type_node
, tmp
, size
[n
]);
4711 msg
= xasprintf ("Array bound mismatch for dimension %d "
4712 "of array '%s' (%%ld/%%ld)",
4713 dim
+ 1, expr_name
);
4715 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4717 fold_convert (long_integer_type_node
, tmp
),
4718 fold_convert (long_integer_type_node
, size
[n
]));
4723 size
[n
] = gfc_evaluate_now (tmp
, &inner
);
4726 tmp
= gfc_finish_block (&inner
);
4728 /* For optional arguments, only check bounds if the argument is
4730 if ((expr
->symtree
->n
.sym
->attr
.optional
4731 || expr
->symtree
->n
.sym
->attr
.not_always_present
)
4732 && expr
->symtree
->n
.sym
->attr
.dummy
)
4733 tmp
= build3_v (COND_EXPR
,
4734 gfc_conv_expr_present (expr
->symtree
->n
.sym
),
4735 tmp
, build_empty_stmt (input_location
));
4737 gfc_add_expr_to_block (&block
, tmp
);
4741 tmp
= gfc_finish_block (&block
);
4742 gfc_add_expr_to_block (&outer_loop
->pre
, tmp
);
4745 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4746 gfc_conv_ss_startstride (loop
);
4749 /* Return true if both symbols could refer to the same data object. Does
4750 not take account of aliasing due to equivalence statements. */
4753 symbols_could_alias (gfc_symbol
*lsym
, gfc_symbol
*rsym
, bool lsym_pointer
,
4754 bool lsym_target
, bool rsym_pointer
, bool rsym_target
)
4756 /* Aliasing isn't possible if the symbols have different base types. */
4757 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
4760 /* Pointers can point to other pointers and target objects. */
4762 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4763 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4766 /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
4767 and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
4769 if (lsym_target
&& rsym_target
4770 && ((lsym
->attr
.dummy
&& !lsym
->attr
.contiguous
4771 && (!lsym
->attr
.dimension
|| lsym
->as
->type
== AS_ASSUMED_SHAPE
))
4772 || (rsym
->attr
.dummy
&& !rsym
->attr
.contiguous
4773 && (!rsym
->attr
.dimension
4774 || rsym
->as
->type
== AS_ASSUMED_SHAPE
))))
4781 /* Return true if the two SS could be aliased, i.e. both point to the same data
4783 /* TODO: resolve aliases based on frontend expressions. */
4786 gfc_could_be_alias (gfc_ss
* lss
, gfc_ss
* rss
)
4790 gfc_expr
*lexpr
, *rexpr
;
4793 bool lsym_pointer
, lsym_target
, rsym_pointer
, rsym_target
;
4795 lexpr
= lss
->info
->expr
;
4796 rexpr
= rss
->info
->expr
;
4798 lsym
= lexpr
->symtree
->n
.sym
;
4799 rsym
= rexpr
->symtree
->n
.sym
;
4801 lsym_pointer
= lsym
->attr
.pointer
;
4802 lsym_target
= lsym
->attr
.target
;
4803 rsym_pointer
= rsym
->attr
.pointer
;
4804 rsym_target
= rsym
->attr
.target
;
4806 if (symbols_could_alias (lsym
, rsym
, lsym_pointer
, lsym_target
,
4807 rsym_pointer
, rsym_target
))
4810 if (rsym
->ts
.type
!= BT_DERIVED
&& rsym
->ts
.type
!= BT_CLASS
4811 && lsym
->ts
.type
!= BT_DERIVED
&& lsym
->ts
.type
!= BT_CLASS
)
4814 /* For derived types we must check all the component types. We can ignore
4815 array references as these will have the same base type as the previous
4817 for (lref
= lexpr
->ref
; lref
!= lss
->info
->data
.array
.ref
; lref
= lref
->next
)
4819 if (lref
->type
!= REF_COMPONENT
)
4822 lsym_pointer
= lsym_pointer
|| lref
->u
.c
.sym
->attr
.pointer
;
4823 lsym_target
= lsym_target
|| lref
->u
.c
.sym
->attr
.target
;
4825 if (symbols_could_alias (lref
->u
.c
.sym
, rsym
, lsym_pointer
, lsym_target
,
4826 rsym_pointer
, rsym_target
))
4829 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4830 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4832 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4837 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
;
4840 if (rref
->type
!= REF_COMPONENT
)
4843 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4844 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4846 if (symbols_could_alias (lref
->u
.c
.sym
, rref
->u
.c
.sym
,
4847 lsym_pointer
, lsym_target
,
4848 rsym_pointer
, rsym_target
))
4851 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4852 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4854 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4855 &rref
->u
.c
.sym
->ts
))
4857 if (gfc_compare_types (&lref
->u
.c
.sym
->ts
,
4858 &rref
->u
.c
.component
->ts
))
4860 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4861 &rref
->u
.c
.component
->ts
))
4867 lsym_pointer
= lsym
->attr
.pointer
;
4868 lsym_target
= lsym
->attr
.target
;
4870 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
; rref
= rref
->next
)
4872 if (rref
->type
!= REF_COMPONENT
)
4875 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4876 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4878 if (symbols_could_alias (rref
->u
.c
.sym
, lsym
,
4879 lsym_pointer
, lsym_target
,
4880 rsym_pointer
, rsym_target
))
4883 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4884 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4886 if (gfc_compare_types (&lsym
->ts
, &rref
->u
.c
.component
->ts
))
4895 /* Resolve array data dependencies. Creates a temporary if required. */
4896 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
4900 gfc_conv_resolve_dependencies (gfc_loopinfo
* loop
, gfc_ss
* dest
,
4906 gfc_ss_info
*ss_info
;
4907 gfc_expr
*dest_expr
;
4912 loop
->temp_ss
= NULL
;
4913 dest_expr
= dest
->info
->expr
;
4915 for (ss
= rss
; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
4918 ss_expr
= ss_info
->expr
;
4920 if (ss_info
->array_outer_dependency
)
4926 if (ss_info
->type
!= GFC_SS_SECTION
)
4928 if (flag_realloc_lhs
4929 && dest_expr
!= ss_expr
4930 && gfc_is_reallocatable_lhs (dest_expr
)
4932 nDepend
= gfc_check_dependency (dest_expr
, ss_expr
, true);
4934 /* Check for cases like c(:)(1:2) = c(2)(2:3) */
4935 if (!nDepend
&& dest_expr
->rank
> 0
4936 && dest_expr
->ts
.type
== BT_CHARACTER
4937 && ss_expr
->expr_type
== EXPR_VARIABLE
)
4939 nDepend
= gfc_check_dependency (dest_expr
, ss_expr
, false);
4941 if (ss_info
->type
== GFC_SS_REFERENCE
4942 && gfc_check_dependency (dest_expr
, ss_expr
, false))
4943 ss_info
->data
.scalar
.needs_temporary
= 1;
4951 if (dest_expr
->symtree
->n
.sym
!= ss_expr
->symtree
->n
.sym
)
4953 if (gfc_could_be_alias (dest
, ss
)
4954 || gfc_are_equivalenced_arrays (dest_expr
, ss_expr
))
4962 lref
= dest_expr
->ref
;
4963 rref
= ss_expr
->ref
;
4965 nDepend
= gfc_dep_resolver (lref
, rref
, &loop
->reverse
[0]);
4970 for (i
= 0; i
< dest
->dimen
; i
++)
4971 for (j
= 0; j
< ss
->dimen
; j
++)
4973 && dest
->dim
[i
] == ss
->dim
[j
])
4975 /* If we don't access array elements in the same order,
4976 there is a dependency. */
4981 /* TODO : loop shifting. */
4984 /* Mark the dimensions for LOOP SHIFTING */
4985 for (n
= 0; n
< loop
->dimen
; n
++)
4987 int dim
= dest
->data
.info
.dim
[n
];
4989 if (lref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
4991 else if (! gfc_is_same_range (&lref
->u
.ar
,
4992 &rref
->u
.ar
, dim
, 0))
4996 /* Put all the dimensions with dependencies in the
4999 for (n
= 0; n
< loop
->dimen
; n
++)
5001 gcc_assert (loop
->order
[n
] == n
);
5003 loop
->order
[dim
++] = n
;
5005 for (n
= 0; n
< loop
->dimen
; n
++)
5008 loop
->order
[dim
++] = n
;
5011 gcc_assert (dim
== loop
->dimen
);
5022 tree base_type
= gfc_typenode_for_spec (&dest_expr
->ts
);
5023 if (GFC_ARRAY_TYPE_P (base_type
)
5024 || GFC_DESCRIPTOR_TYPE_P (base_type
))
5025 base_type
= gfc_get_element_type (base_type
);
5026 loop
->temp_ss
= gfc_get_temp_ss (base_type
, dest
->info
->string_length
,
5028 gfc_add_ss_to_loop (loop
, loop
->temp_ss
);
5031 loop
->temp_ss
= NULL
;
5035 /* Browse through each array's information from the scalarizer and set the loop
5036 bounds according to the "best" one (per dimension), i.e. the one which
5037 provides the most information (constant bounds, shape, etc.). */
5040 set_loop_bounds (gfc_loopinfo
*loop
)
5042 int n
, dim
, spec_dim
;
5043 gfc_array_info
*info
;
5044 gfc_array_info
*specinfo
;
5048 bool dynamic
[GFC_MAX_DIMENSIONS
];
5051 bool nonoptional_arr
;
5053 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
5055 loopspec
= loop
->specloop
;
5058 for (n
= 0; n
< loop
->dimen
; n
++)
5063 /* If there are both optional and nonoptional array arguments, scalarize
5064 over the nonoptional; otherwise, it does not matter as then all
5065 (optional) arrays have to be present per F2008, 125.2.12p3(6). */
5067 nonoptional_arr
= false;
5069 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
5070 if (ss
->info
->type
!= GFC_SS_SCALAR
&& ss
->info
->type
!= GFC_SS_TEMP
5071 && ss
->info
->type
!= GFC_SS_REFERENCE
&& !ss
->info
->can_be_null_ref
)
5073 nonoptional_arr
= true;
5077 /* We use one SS term, and use that to determine the bounds of the
5078 loop for this dimension. We try to pick the simplest term. */
5079 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
5081 gfc_ss_type ss_type
;
5083 ss_type
= ss
->info
->type
;
5084 if (ss_type
== GFC_SS_SCALAR
5085 || ss_type
== GFC_SS_TEMP
5086 || ss_type
== GFC_SS_REFERENCE
5087 || (ss
->info
->can_be_null_ref
&& nonoptional_arr
))
5090 info
= &ss
->info
->data
.array
;
5093 if (loopspec
[n
] != NULL
)
5095 specinfo
= &loopspec
[n
]->info
->data
.array
;
5096 spec_dim
= loopspec
[n
]->dim
[n
];
5100 /* Silence uninitialized warnings. */
5107 gcc_assert (info
->shape
[dim
]);
5108 /* The frontend has worked out the size for us. */
5111 || !integer_zerop (specinfo
->start
[spec_dim
]))
5112 /* Prefer zero-based descriptors if possible. */
5117 if (ss_type
== GFC_SS_CONSTRUCTOR
)
5119 gfc_constructor_base base
;
5120 /* An unknown size constructor will always be rank one.
5121 Higher rank constructors will either have known shape,
5122 or still be wrapped in a call to reshape. */
5123 gcc_assert (loop
->dimen
== 1);
5125 /* Always prefer to use the constructor bounds if the size
5126 can be determined at compile time. Prefer not to otherwise,
5127 since the general case involves realloc, and it's better to
5128 avoid that overhead if possible. */
5129 base
= ss
->info
->expr
->value
.constructor
;
5130 dynamic
[n
] = gfc_get_array_constructor_size (&i
, base
);
5131 if (!dynamic
[n
] || !loopspec
[n
])
5136 /* Avoid using an allocatable lhs in an assignment, since
5137 there might be a reallocation coming. */
5138 if (loopspec
[n
] && ss
->is_alloc_lhs
)
5143 /* Criteria for choosing a loop specifier (most important first):
5144 doesn't need realloc
5150 else if (loopspec
[n
]->info
->type
== GFC_SS_CONSTRUCTOR
&& dynamic
[n
])
5152 else if (integer_onep (info
->stride
[dim
])
5153 && !integer_onep (specinfo
->stride
[spec_dim
]))
5155 else if (INTEGER_CST_P (info
->stride
[dim
])
5156 && !INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
5158 else if (INTEGER_CST_P (info
->start
[dim
])
5159 && !INTEGER_CST_P (specinfo
->start
[spec_dim
])
5160 && integer_onep (info
->stride
[dim
])
5161 == integer_onep (specinfo
->stride
[spec_dim
])
5162 && INTEGER_CST_P (info
->stride
[dim
])
5163 == INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
5165 /* We don't work out the upper bound.
5166 else if (INTEGER_CST_P (info->finish[n])
5167 && ! INTEGER_CST_P (specinfo->finish[n]))
5168 loopspec[n] = ss; */
5171 /* We should have found the scalarization loop specifier. If not,
5173 gcc_assert (loopspec
[n
]);
5175 info
= &loopspec
[n
]->info
->data
.array
;
5176 dim
= loopspec
[n
]->dim
[n
];
5178 /* Set the extents of this range. */
5179 cshape
= info
->shape
;
5180 if (cshape
&& INTEGER_CST_P (info
->start
[dim
])
5181 && INTEGER_CST_P (info
->stride
[dim
]))
5183 loop
->from
[n
] = info
->start
[dim
];
5184 mpz_set (i
, cshape
[get_array_ref_dim_for_loop_dim (loopspec
[n
], n
)]);
5185 mpz_sub_ui (i
, i
, 1);
5186 /* To = from + (size - 1) * stride. */
5187 tmp
= gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
5188 if (!integer_onep (info
->stride
[dim
]))
5189 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5190 gfc_array_index_type
, tmp
,
5192 loop
->to
[n
] = fold_build2_loc (input_location
, PLUS_EXPR
,
5193 gfc_array_index_type
,
5194 loop
->from
[n
], tmp
);
5198 loop
->from
[n
] = info
->start
[dim
];
5199 switch (loopspec
[n
]->info
->type
)
5201 case GFC_SS_CONSTRUCTOR
:
5202 /* The upper bound is calculated when we expand the
5204 gcc_assert (loop
->to
[n
] == NULL_TREE
);
5207 case GFC_SS_SECTION
:
5208 /* Use the end expression if it exists and is not constant,
5209 so that it is only evaluated once. */
5210 loop
->to
[n
] = info
->end
[dim
];
5213 case GFC_SS_FUNCTION
:
5214 /* The loop bound will be set when we generate the call. */
5215 gcc_assert (loop
->to
[n
] == NULL_TREE
);
5218 case GFC_SS_INTRINSIC
:
5220 gfc_expr
*expr
= loopspec
[n
]->info
->expr
;
5222 /* The {l,u}bound of an assumed rank. */
5223 gcc_assert ((expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
5224 || expr
->value
.function
.isym
->id
== GFC_ISYM_UBOUND
)
5225 && expr
->value
.function
.actual
->next
->expr
== NULL
5226 && expr
->value
.function
.actual
->expr
->rank
== -1);
5228 loop
->to
[n
] = info
->end
[dim
];
5232 case GFC_SS_COMPONENT
:
5234 if (info
->end
[dim
] != NULL_TREE
)
5236 loop
->to
[n
] = info
->end
[dim
];
5248 /* Transform everything so we have a simple incrementing variable. */
5249 if (integer_onep (info
->stride
[dim
]))
5250 info
->delta
[dim
] = gfc_index_zero_node
;
5253 /* Set the delta for this section. */
5254 info
->delta
[dim
] = gfc_evaluate_now (loop
->from
[n
], &outer_loop
->pre
);
5255 /* Number of iterations is (end - start + step) / step.
5256 with start = 0, this simplifies to
5258 for (i = 0; i<=last; i++){...}; */
5259 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5260 gfc_array_index_type
, loop
->to
[n
],
5262 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
5263 gfc_array_index_type
, tmp
, info
->stride
[dim
]);
5264 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
5265 tmp
, build_int_cst (gfc_array_index_type
, -1));
5266 loop
->to
[n
] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
5267 /* Make the loop variable start at 0. */
5268 loop
->from
[n
] = gfc_index_zero_node
;
5273 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
5274 set_loop_bounds (loop
);
5278 /* Initialize the scalarization loop. Creates the loop variables. Determines
5279 the range of the loop variables. Creates a temporary if required.
5280 Also generates code for scalar expressions which have been
5281 moved outside the loop. */
5284 gfc_conv_loop_setup (gfc_loopinfo
* loop
, locus
* where
)
5289 set_loop_bounds (loop
);
5291 /* Add all the scalar code that can be taken out of the loops.
5292 This may include calculating the loop bounds, so do it before
5293 allocating the temporary. */
5294 gfc_add_loop_ss_code (loop
, loop
->ss
, false, where
);
5296 tmp_ss
= loop
->temp_ss
;
5297 /* If we want a temporary then create it. */
5300 gfc_ss_info
*tmp_ss_info
;
5302 tmp_ss_info
= tmp_ss
->info
;
5303 gcc_assert (tmp_ss_info
->type
== GFC_SS_TEMP
);
5304 gcc_assert (loop
->parent
== NULL
);
5306 /* Make absolutely sure that this is a complete type. */
5307 if (tmp_ss_info
->string_length
)
5308 tmp_ss_info
->data
.temp
.type
5309 = gfc_get_character_type_len_for_eltype
5310 (TREE_TYPE (tmp_ss_info
->data
.temp
.type
),
5311 tmp_ss_info
->string_length
);
5313 tmp
= tmp_ss_info
->data
.temp
.type
;
5314 memset (&tmp_ss_info
->data
.array
, 0, sizeof (gfc_array_info
));
5315 tmp_ss_info
->type
= GFC_SS_SECTION
;
5317 gcc_assert (tmp_ss
->dimen
!= 0);
5319 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, tmp_ss
, tmp
,
5320 NULL_TREE
, false, true, false, where
);
5323 /* For array parameters we don't have loop variables, so don't calculate the
5325 if (!loop
->array_parameter
)
5326 gfc_set_delta (loop
);
5330 /* Calculates how to transform from loop variables to array indices for each
5331 array: once loop bounds are chosen, sets the difference (DELTA field) between
5332 loop bounds and array reference bounds, for each array info. */
5335 gfc_set_delta (gfc_loopinfo
*loop
)
5337 gfc_ss
*ss
, **loopspec
;
5338 gfc_array_info
*info
;
5342 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
5344 loopspec
= loop
->specloop
;
5346 /* Calculate the translation from loop variables to array indices. */
5347 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
5349 gfc_ss_type ss_type
;
5351 ss_type
= ss
->info
->type
;
5352 if (ss_type
!= GFC_SS_SECTION
5353 && ss_type
!= GFC_SS_COMPONENT
5354 && ss_type
!= GFC_SS_CONSTRUCTOR
)
5357 info
= &ss
->info
->data
.array
;
5359 for (n
= 0; n
< ss
->dimen
; n
++)
5361 /* If we are specifying the range the delta is already set. */
5362 if (loopspec
[n
] != ss
)
5366 /* Calculate the offset relative to the loop variable.
5367 First multiply by the stride. */
5368 tmp
= loop
->from
[n
];
5369 if (!integer_onep (info
->stride
[dim
]))
5370 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5371 gfc_array_index_type
,
5372 tmp
, info
->stride
[dim
]);
5374 /* Then subtract this from our starting value. */
5375 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5376 gfc_array_index_type
,
5377 info
->start
[dim
], tmp
);
5379 info
->delta
[dim
] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
5384 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
5385 gfc_set_delta (loop
);
5389 /* Calculate the size of a given array dimension from the bounds. This
5390 is simply (ubound - lbound + 1) if this expression is positive
5391 or 0 if it is negative (pick either one if it is zero). Optionally
5392 (if or_expr is present) OR the (expression != 0) condition to it. */
5395 gfc_conv_array_extent_dim (tree lbound
, tree ubound
, tree
* or_expr
)
5400 /* Calculate (ubound - lbound + 1). */
5401 res
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5403 res
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
, res
,
5404 gfc_index_one_node
);
5406 /* Check whether the size for this dimension is negative. */
5407 cond
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
, res
,
5408 gfc_index_zero_node
);
5409 res
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
, cond
,
5410 gfc_index_zero_node
, res
);
5412 /* Build OR expression. */
5414 *or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
5415 logical_type_node
, *or_expr
, cond
);
5421 /* For an array descriptor, get the total number of elements. This is just
5422 the product of the extents along from_dim to to_dim. */
5425 gfc_conv_descriptor_size_1 (tree desc
, int from_dim
, int to_dim
)
5430 res
= gfc_index_one_node
;
5432 for (dim
= from_dim
; dim
< to_dim
; ++dim
)
5438 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]);
5439 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]);
5441 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
5442 res
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5450 /* Full size of an array. */
5453 gfc_conv_descriptor_size (tree desc
, int rank
)
5455 return gfc_conv_descriptor_size_1 (desc
, 0, rank
);
5459 /* Size of a coarray for all dimensions but the last. */
5462 gfc_conv_descriptor_cosize (tree desc
, int rank
, int corank
)
5464 return gfc_conv_descriptor_size_1 (desc
, rank
, rank
+ corank
- 1);
5468 /* Fills in an array descriptor, and returns the size of the array.
5469 The size will be a simple_val, ie a variable or a constant. Also
5470 calculates the offset of the base. The pointer argument overflow,
5471 which should be of integer type, will increase in value if overflow
5472 occurs during the size calculation. Returns the size of the array.
5476 for (n = 0; n < rank; n++)
5478 a.lbound[n] = specified_lower_bound;
5479 offset = offset + a.lbond[n] * stride;
5481 a.ubound[n] = specified_upper_bound;
5482 a.stride[n] = stride;
5483 size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
5484 overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
5485 stride = stride * size;
5487 for (n = rank; n < rank+corank; n++)
5488 (Set lcobound/ucobound as above.)
5489 element_size = sizeof (array element);
5492 stride = (size_t) stride;
5493 overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
5494 stride = stride * element_size;
5500 gfc_array_init_size (tree descriptor
, int rank
, int corank
, tree
* poffset
,
5501 gfc_expr
** lower
, gfc_expr
** upper
, stmtblock_t
* pblock
,
5502 stmtblock_t
* descriptor_block
, tree
* overflow
,
5503 tree expr3_elem_size
, tree
*nelems
, gfc_expr
*expr3
,
5504 tree expr3_desc
, bool e3_has_nodescriptor
, gfc_expr
*expr
,
5517 stmtblock_t thenblock
;
5518 stmtblock_t elseblock
;
5523 type
= TREE_TYPE (descriptor
);
5525 stride
= gfc_index_one_node
;
5526 offset
= gfc_index_zero_node
;
5528 /* Set the dtype before the alloc, because registration of coarrays needs
5530 if (expr
->ts
.type
== BT_CHARACTER
5531 && expr
->ts
.deferred
5532 && VAR_P (expr
->ts
.u
.cl
->backend_decl
))
5534 type
= gfc_typenode_for_spec (&expr
->ts
);
5535 tmp
= gfc_conv_descriptor_dtype (descriptor
);
5536 gfc_add_modify (pblock
, tmp
, gfc_get_dtype_rank_type (rank
, type
));
5538 else if (expr
->ts
.type
== BT_CHARACTER
5539 && expr
->ts
.deferred
5540 && TREE_CODE (descriptor
) == COMPONENT_REF
)
5542 /* Deferred character components have their string length tucked away
5543 in a hidden field of the derived type. Obtain that and use it to
5544 set the dtype. The charlen backend decl is zero because the field
5545 type is zero length. */
5548 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5549 if (ref
->type
== REF_COMPONENT
5550 && gfc_deferred_strlen (ref
->u
.c
.component
, &tmp
))
5552 gcc_assert (tmp
!= NULL_TREE
);
5553 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (tmp
),
5554 TREE_OPERAND (descriptor
, 0), tmp
, NULL_TREE
);
5555 tmp
= fold_convert (gfc_charlen_type_node
, tmp
);
5556 type
= gfc_get_character_type_len (expr
->ts
.kind
, tmp
);
5557 tmp
= gfc_conv_descriptor_dtype (descriptor
);
5558 gfc_add_modify (pblock
, tmp
, gfc_get_dtype_rank_type (rank
, type
));
5562 tmp
= gfc_conv_descriptor_dtype (descriptor
);
5563 gfc_add_modify (pblock
, tmp
, gfc_get_dtype (type
));
5566 or_expr
= logical_false_node
;
5568 for (n
= 0; n
< rank
; n
++)
5573 /* We have 3 possibilities for determining the size of the array:
5574 lower == NULL => lbound = 1, ubound = upper[n]
5575 upper[n] = NULL => lbound = 1, ubound = lower[n]
5576 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
5579 /* Set lower bound. */
5580 gfc_init_se (&se
, NULL
);
5581 if (expr3_desc
!= NULL_TREE
)
5583 if (e3_has_nodescriptor
)
5584 /* The lbound of nondescriptor arrays like array constructors,
5585 nonallocatable/nonpointer function results/variables,
5586 start at zero, but when allocating it, the standard expects
5587 the array to start at one. */
5588 se
.expr
= gfc_index_one_node
;
5590 se
.expr
= gfc_conv_descriptor_lbound_get (expr3_desc
,
5593 else if (lower
== NULL
)
5594 se
.expr
= gfc_index_one_node
;
5597 gcc_assert (lower
[n
]);
5600 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
5601 gfc_add_block_to_block (pblock
, &se
.pre
);
5605 se
.expr
= gfc_index_one_node
;
5609 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
5610 gfc_rank_cst
[n
], se
.expr
);
5611 conv_lbound
= se
.expr
;
5613 /* Work out the offset for this component. */
5614 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5616 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
5617 gfc_array_index_type
, offset
, tmp
);
5619 /* Set upper bound. */
5620 gfc_init_se (&se
, NULL
);
5621 if (expr3_desc
!= NULL_TREE
)
5623 if (e3_has_nodescriptor
)
5625 /* The lbound of nondescriptor arrays like array constructors,
5626 nonallocatable/nonpointer function results/variables,
5627 start at zero, but when allocating it, the standard expects
5628 the array to start at one. Therefore fix the upper bound to be
5629 (desc.ubound - desc.lbound) + 1. */
5630 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5631 gfc_array_index_type
,
5632 gfc_conv_descriptor_ubound_get (
5633 expr3_desc
, gfc_rank_cst
[n
]),
5634 gfc_conv_descriptor_lbound_get (
5635 expr3_desc
, gfc_rank_cst
[n
]));
5636 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5637 gfc_array_index_type
, tmp
,
5638 gfc_index_one_node
);
5639 se
.expr
= gfc_evaluate_now (tmp
, pblock
);
5642 se
.expr
= gfc_conv_descriptor_ubound_get (expr3_desc
,
5647 gcc_assert (ubound
);
5648 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
5649 gfc_add_block_to_block (pblock
, &se
.pre
);
5650 if (ubound
->expr_type
== EXPR_FUNCTION
)
5651 se
.expr
= gfc_evaluate_now (se
.expr
, pblock
);
5653 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
5654 gfc_rank_cst
[n
], se
.expr
);
5655 conv_ubound
= se
.expr
;
5657 /* Store the stride. */
5658 gfc_conv_descriptor_stride_set (descriptor_block
, descriptor
,
5659 gfc_rank_cst
[n
], stride
);
5661 /* Calculate size and check whether extent is negative. */
5662 size
= gfc_conv_array_extent_dim (conv_lbound
, conv_ubound
, &or_expr
);
5663 size
= gfc_evaluate_now (size
, pblock
);
5665 /* Check whether multiplying the stride by the number of
5666 elements in this dimension would overflow. We must also check
5667 whether the current dimension has zero size in order to avoid
5670 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
5671 gfc_array_index_type
,
5672 fold_convert (gfc_array_index_type
,
5673 TYPE_MAX_VALUE (gfc_array_index_type
)),
5675 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
5676 logical_type_node
, tmp
, stride
),
5677 PRED_FORTRAN_OVERFLOW
);
5678 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5679 integer_one_node
, integer_zero_node
);
5680 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
5681 logical_type_node
, size
,
5682 gfc_index_zero_node
),
5683 PRED_FORTRAN_SIZE_ZERO
);
5684 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5685 integer_zero_node
, tmp
);
5686 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
5688 *overflow
= gfc_evaluate_now (tmp
, pblock
);
5690 /* Multiply the stride by the number of elements in this dimension. */
5691 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
5692 gfc_array_index_type
, stride
, size
);
5693 stride
= gfc_evaluate_now (stride
, pblock
);
5696 for (n
= rank
; n
< rank
+ corank
; n
++)
5700 /* Set lower bound. */
5701 gfc_init_se (&se
, NULL
);
5702 if (lower
== NULL
|| lower
[n
] == NULL
)
5704 gcc_assert (n
== rank
+ corank
- 1);
5705 se
.expr
= gfc_index_one_node
;
5709 if (ubound
|| n
== rank
+ corank
- 1)
5711 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
5712 gfc_add_block_to_block (pblock
, &se
.pre
);
5716 se
.expr
= gfc_index_one_node
;
5720 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
5721 gfc_rank_cst
[n
], se
.expr
);
5723 if (n
< rank
+ corank
- 1)
5725 gfc_init_se (&se
, NULL
);
5726 gcc_assert (ubound
);
5727 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
5728 gfc_add_block_to_block (pblock
, &se
.pre
);
5729 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
5730 gfc_rank_cst
[n
], se
.expr
);
5734 /* The stride is the number of elements in the array, so multiply by the
5735 size of an element to get the total size. Obviously, if there is a
5736 SOURCE expression (expr3) we must use its element size. */
5737 if (expr3_elem_size
!= NULL_TREE
)
5738 tmp
= expr3_elem_size
;
5739 else if (expr3
!= NULL
)
5741 if (expr3
->ts
.type
== BT_CLASS
)
5744 gfc_expr
*sz
= gfc_copy_expr (expr3
);
5745 gfc_add_vptr_component (sz
);
5746 gfc_add_size_component (sz
);
5747 gfc_init_se (&se_sz
, NULL
);
5748 gfc_conv_expr (&se_sz
, sz
);
5754 tmp
= gfc_typenode_for_spec (&expr3
->ts
);
5755 tmp
= TYPE_SIZE_UNIT (tmp
);
5759 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
5761 /* Convert to size_t. */
5762 *element_size
= fold_convert (size_type_node
, tmp
);
5765 return *element_size
;
5767 *nelems
= gfc_evaluate_now (stride
, pblock
);
5768 stride
= fold_convert (size_type_node
, stride
);
5770 /* First check for overflow. Since an array of type character can
5771 have zero element_size, we must check for that before
5773 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
5775 TYPE_MAX_VALUE (size_type_node
), *element_size
);
5776 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
5777 logical_type_node
, tmp
, stride
),
5778 PRED_FORTRAN_OVERFLOW
);
5779 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5780 integer_one_node
, integer_zero_node
);
5781 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
5782 logical_type_node
, *element_size
,
5783 build_int_cst (size_type_node
, 0)),
5784 PRED_FORTRAN_SIZE_ZERO
);
5785 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5786 integer_zero_node
, tmp
);
5787 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
5789 *overflow
= gfc_evaluate_now (tmp
, pblock
);
5791 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5792 stride
, *element_size
);
5794 if (poffset
!= NULL
)
5796 offset
= gfc_evaluate_now (offset
, pblock
);
5800 if (integer_zerop (or_expr
))
5802 if (integer_onep (or_expr
))
5803 return build_int_cst (size_type_node
, 0);
5805 var
= gfc_create_var (TREE_TYPE (size
), "size");
5806 gfc_start_block (&thenblock
);
5807 gfc_add_modify (&thenblock
, var
, build_int_cst (size_type_node
, 0));
5808 thencase
= gfc_finish_block (&thenblock
);
5810 gfc_start_block (&elseblock
);
5811 gfc_add_modify (&elseblock
, var
, size
);
5812 elsecase
= gfc_finish_block (&elseblock
);
5814 tmp
= gfc_evaluate_now (or_expr
, pblock
);
5815 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
5816 gfc_add_expr_to_block (pblock
, tmp
);
5822 /* Retrieve the last ref from the chain. This routine is specific to
5823 gfc_array_allocate ()'s needs. */
5826 retrieve_last_ref (gfc_ref
**ref_in
, gfc_ref
**prev_ref_in
)
5828 gfc_ref
*ref
, *prev_ref
;
5831 /* Prevent warnings for uninitialized variables. */
5832 prev_ref
= *prev_ref_in
;
5833 while (ref
&& ref
->next
!= NULL
)
5835 gcc_assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
5836 || (ref
->u
.ar
.dimen
== 0 && ref
->u
.ar
.codimen
> 0));
5841 if (ref
== NULL
|| ref
->type
!= REF_ARRAY
)
5845 *prev_ref_in
= prev_ref
;
5849 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
5850 the work for an ALLOCATE statement. */
5854 gfc_array_allocate (gfc_se
* se
, gfc_expr
* expr
, tree status
, tree errmsg
,
5855 tree errlen
, tree label_finish
, tree expr3_elem_size
,
5856 tree
*nelems
, gfc_expr
*expr3
, tree e3_arr_desc
,
5857 bool e3_has_nodescriptor
)
5861 tree offset
= NULL_TREE
;
5862 tree token
= NULL_TREE
;
5865 tree error
= NULL_TREE
;
5866 tree overflow
; /* Boolean storing whether size calculation overflows. */
5867 tree var_overflow
= NULL_TREE
;
5869 tree set_descriptor
;
5870 tree not_prev_allocated
= NULL_TREE
;
5871 tree element_size
= NULL_TREE
;
5872 stmtblock_t set_descriptor_block
;
5873 stmtblock_t elseblock
;
5876 gfc_ref
*ref
, *prev_ref
= NULL
, *coref
;
5877 bool allocatable
, coarray
, dimension
, alloc_w_e3_arr_spec
= false,
5878 non_ulimate_coarray_ptr_comp
;
5882 /* Find the last reference in the chain. */
5883 if (!retrieve_last_ref (&ref
, &prev_ref
))
5886 /* Take the allocatable and coarray properties solely from the expr-ref's
5887 attributes and not from source=-expression. */
5890 allocatable
= expr
->symtree
->n
.sym
->attr
.allocatable
;
5891 dimension
= expr
->symtree
->n
.sym
->attr
.dimension
;
5892 non_ulimate_coarray_ptr_comp
= false;
5896 allocatable
= prev_ref
->u
.c
.component
->attr
.allocatable
;
5897 /* Pointer components in coarrayed derived types must be treated
5898 specially in that they are registered without a check if the are
5899 already associated. This does not hold for ultimate coarray
5901 non_ulimate_coarray_ptr_comp
= (prev_ref
->u
.c
.component
->attr
.pointer
5902 && !prev_ref
->u
.c
.component
->attr
.codimension
);
5903 dimension
= prev_ref
->u
.c
.component
->attr
.dimension
;
5906 /* For allocatable/pointer arrays in derived types, one of the refs has to be
5907 a coarray. In this case it does not matter whether we are on this_image
5910 for (coref
= expr
->ref
; coref
; coref
= coref
->next
)
5911 if (coref
->type
== REF_ARRAY
&& coref
->u
.ar
.codimen
> 0)
5918 gcc_assert (coarray
);
5920 if (ref
->u
.ar
.type
== AR_FULL
&& expr3
!= NULL
)
5922 gfc_ref
*old_ref
= ref
;
5923 /* F08:C633: Array shape from expr3. */
5926 /* Find the last reference in the chain. */
5927 if (!retrieve_last_ref (&ref
, &prev_ref
))
5929 if (expr3
->expr_type
== EXPR_FUNCTION
5930 && gfc_expr_attr (expr3
).dimension
)
5935 alloc_w_e3_arr_spec
= true;
5938 /* Figure out the size of the array. */
5939 switch (ref
->u
.ar
.type
)
5945 upper
= ref
->u
.ar
.start
;
5951 lower
= ref
->u
.ar
.start
;
5952 upper
= ref
->u
.ar
.end
;
5956 gcc_assert (ref
->u
.ar
.as
->type
== AS_EXPLICIT
5957 || alloc_w_e3_arr_spec
);
5959 lower
= ref
->u
.ar
.as
->lower
;
5960 upper
= ref
->u
.ar
.as
->upper
;
5968 overflow
= integer_zero_node
;
5970 if (expr
->ts
.type
== BT_CHARACTER
5971 && TREE_CODE (se
->string_length
) == COMPONENT_REF
5972 && expr
->ts
.u
.cl
->backend_decl
!= se
->string_length
5973 && VAR_P (expr
->ts
.u
.cl
->backend_decl
))
5974 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
5975 fold_convert (TREE_TYPE (expr
->ts
.u
.cl
->backend_decl
),
5976 se
->string_length
));
5978 gfc_init_block (&set_descriptor_block
);
5979 /* Take the corank only from the actual ref and not from the coref. The
5980 later will mislead the generation of the array dimensions for allocatable/
5981 pointer components in derived types. */
5982 size
= gfc_array_init_size (se
->expr
, alloc_w_e3_arr_spec
? expr
->rank
5983 : ref
->u
.ar
.as
->rank
,
5984 coarray
? ref
->u
.ar
.as
->corank
: 0,
5985 &offset
, lower
, upper
,
5986 &se
->pre
, &set_descriptor_block
, &overflow
,
5987 expr3_elem_size
, nelems
, expr3
, e3_arr_desc
,
5988 e3_has_nodescriptor
, expr
, &element_size
);
5992 var_overflow
= gfc_create_var (integer_type_node
, "overflow");
5993 gfc_add_modify (&se
->pre
, var_overflow
, overflow
);
5995 if (status
== NULL_TREE
)
5997 /* Generate the block of code handling overflow. */
5998 msg
= gfc_build_addr_expr (pchar_type_node
,
5999 gfc_build_localized_cstring_const
6000 ("Integer overflow when calculating the amount of "
6001 "memory to allocate"));
6002 error
= build_call_expr_loc (input_location
,
6003 gfor_fndecl_runtime_error
, 1, msg
);
6007 tree status_type
= TREE_TYPE (status
);
6008 stmtblock_t set_status_block
;
6010 gfc_start_block (&set_status_block
);
6011 gfc_add_modify (&set_status_block
, status
,
6012 build_int_cst (status_type
, LIBERROR_ALLOCATION
));
6013 error
= gfc_finish_block (&set_status_block
);
6017 /* Allocate memory to store the data. */
6018 if (POINTER_TYPE_P (TREE_TYPE (se
->expr
)))
6019 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
6021 if (coarray
&& flag_coarray
== GFC_FCOARRAY_LIB
)
6023 pointer
= non_ulimate_coarray_ptr_comp
? se
->expr
6024 : gfc_conv_descriptor_data_get (se
->expr
);
6025 token
= gfc_conv_descriptor_token (se
->expr
);
6026 token
= gfc_build_addr_expr (NULL_TREE
, token
);
6029 pointer
= gfc_conv_descriptor_data_get (se
->expr
);
6030 STRIP_NOPS (pointer
);
6034 not_prev_allocated
= gfc_create_var (logical_type_node
,
6035 "not_prev_allocated");
6036 tmp
= fold_build2_loc (input_location
, EQ_EXPR
,
6037 logical_type_node
, pointer
,
6038 build_int_cst (TREE_TYPE (pointer
), 0));
6040 gfc_add_modify (&se
->pre
, not_prev_allocated
, tmp
);
6043 gfc_start_block (&elseblock
);
6045 /* The allocatable variant takes the old pointer as first argument. */
6047 gfc_allocate_allocatable (&elseblock
, pointer
, size
, token
,
6048 status
, errmsg
, errlen
, label_finish
, expr
,
6049 coref
!= NULL
? coref
->u
.ar
.as
->corank
: 0);
6050 else if (non_ulimate_coarray_ptr_comp
&& token
)
6051 /* The token is set only for GFC_FCOARRAY_LIB mode. */
6052 gfc_allocate_using_caf_lib (&elseblock
, pointer
, size
, token
, status
,
6054 GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY
);
6056 gfc_allocate_using_malloc (&elseblock
, pointer
, size
, status
);
6060 cond
= gfc_unlikely (fold_build2_loc (input_location
, NE_EXPR
,
6061 logical_type_node
, var_overflow
, integer_zero_node
),
6062 PRED_FORTRAN_OVERFLOW
);
6063 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
6064 error
, gfc_finish_block (&elseblock
));
6067 tmp
= gfc_finish_block (&elseblock
);
6069 gfc_add_expr_to_block (&se
->pre
, tmp
);
6071 /* Update the array descriptor with the offset and the span. */
6074 gfc_conv_descriptor_offset_set (&set_descriptor_block
, se
->expr
, offset
);
6075 tmp
= fold_convert (gfc_array_index_type
, element_size
);
6076 gfc_conv_descriptor_span_set (&set_descriptor_block
, se
->expr
, tmp
);
6079 set_descriptor
= gfc_finish_block (&set_descriptor_block
);
6080 if (status
!= NULL_TREE
)
6082 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
6083 logical_type_node
, status
,
6084 build_int_cst (TREE_TYPE (status
), 0));
6086 if (not_prev_allocated
!= NULL_TREE
)
6087 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
6088 logical_type_node
, cond
, not_prev_allocated
);
6090 gfc_add_expr_to_block (&se
->pre
,
6091 fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
6094 build_empty_stmt (input_location
)));
6097 gfc_add_expr_to_block (&se
->pre
, set_descriptor
);
6103 /* Create an array constructor from an initialization expression.
6104 We assume the frontend already did any expansions and conversions. */
6107 gfc_conv_array_initializer (tree type
, gfc_expr
* expr
)
6113 vec
<constructor_elt
, va_gc
> *v
= NULL
;
6115 if (expr
->expr_type
== EXPR_VARIABLE
6116 && expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
6117 && expr
->symtree
->n
.sym
->value
)
6118 expr
= expr
->symtree
->n
.sym
->value
;
6120 switch (expr
->expr_type
)
6123 case EXPR_STRUCTURE
:
6124 /* A single scalar or derived type value. Create an array with all
6125 elements equal to that value. */
6126 gfc_init_se (&se
, NULL
);
6128 if (expr
->expr_type
== EXPR_CONSTANT
)
6129 gfc_conv_constant (&se
, expr
);
6131 gfc_conv_structure (&se
, expr
, 1);
6133 CONSTRUCTOR_APPEND_ELT (v
, build2 (RANGE_EXPR
, gfc_array_index_type
,
6134 TYPE_MIN_VALUE (TYPE_DOMAIN (type
)),
6135 TYPE_MAX_VALUE (TYPE_DOMAIN (type
))),
6140 /* Create a vector of all the elements. */
6141 for (c
= gfc_constructor_first (expr
->value
.constructor
);
6142 c
&& c
->expr
; c
= gfc_constructor_next (c
))
6146 /* Problems occur when we get something like
6147 integer :: a(lots) = (/(i, i=1, lots)/) */
6148 gfc_fatal_error ("The number of elements in the array "
6149 "constructor at %L requires an increase of "
6150 "the allowed %d upper limit. See "
6151 "%<-fmax-array-constructor%> option",
6152 &expr
->where
, flag_max_array_constructor
);
6155 if (mpz_cmp_si (c
->offset
, 0) != 0)
6156 index
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
6160 if (mpz_cmp_si (c
->repeat
, 1) > 0)
6166 mpz_add (maxval
, c
->offset
, c
->repeat
);
6167 mpz_sub_ui (maxval
, maxval
, 1);
6168 tmp2
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
6169 if (mpz_cmp_si (c
->offset
, 0) != 0)
6171 mpz_add_ui (maxval
, c
->offset
, 1);
6172 tmp1
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
6175 tmp1
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
6177 range
= fold_build2 (RANGE_EXPR
, gfc_array_index_type
, tmp1
, tmp2
);
6183 gfc_init_se (&se
, NULL
);
6184 switch (c
->expr
->expr_type
)
6187 gfc_conv_constant (&se
, c
->expr
);
6189 /* See gfortran.dg/charlen_15.f90 for instance. */
6190 if (TREE_CODE (se
.expr
) == STRING_CST
6191 && TREE_CODE (type
) == ARRAY_TYPE
)
6194 while (TREE_CODE (TREE_TYPE (atype
)) == ARRAY_TYPE
)
6195 atype
= TREE_TYPE (atype
);
6196 gcc_checking_assert (TREE_CODE (TREE_TYPE (atype
))
6198 gcc_checking_assert (TREE_TYPE (TREE_TYPE (se
.expr
))
6199 == TREE_TYPE (atype
));
6200 if (tree_to_uhwi (TYPE_SIZE_UNIT (TREE_TYPE (se
.expr
)))
6201 > tree_to_uhwi (TYPE_SIZE_UNIT (atype
)))
6203 unsigned HOST_WIDE_INT size
6204 = tree_to_uhwi (TYPE_SIZE_UNIT (atype
));
6205 const char *p
= TREE_STRING_POINTER (se
.expr
);
6207 se
.expr
= build_string (size
, p
);
6209 TREE_TYPE (se
.expr
) = atype
;
6213 case EXPR_STRUCTURE
:
6214 gfc_conv_structure (&se
, c
->expr
, 1);
6218 /* Catch those occasional beasts that do not simplify
6219 for one reason or another, assuming that if they are
6220 standard defying the frontend will catch them. */
6221 gfc_conv_expr (&se
, c
->expr
);
6225 if (range
== NULL_TREE
)
6226 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
6229 if (index
!= NULL_TREE
)
6230 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
6231 CONSTRUCTOR_APPEND_ELT (v
, range
, se
.expr
);
6237 return gfc_build_null_descriptor (type
);
6243 /* Create a constructor from the list of elements. */
6244 tmp
= build_constructor (type
, v
);
6245 TREE_CONSTANT (tmp
) = 1;
6250 /* Generate code to evaluate non-constant coarray cobounds. */
6253 gfc_trans_array_cobounds (tree type
, stmtblock_t
* pblock
,
6254 const gfc_symbol
*sym
)
6262 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
6264 for (dim
= as
->rank
; dim
< as
->rank
+ as
->corank
; dim
++)
6266 /* Evaluate non-constant array bound expressions. */
6267 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
6268 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
6270 gfc_init_se (&se
, NULL
);
6271 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
6272 gfc_add_block_to_block (pblock
, &se
.pre
);
6273 gfc_add_modify (pblock
, lbound
, se
.expr
);
6275 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
6276 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
6278 gfc_init_se (&se
, NULL
);
6279 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
6280 gfc_add_block_to_block (pblock
, &se
.pre
);
6281 gfc_add_modify (pblock
, ubound
, se
.expr
);
6287 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
6288 returns the size (in elements) of the array. */
6291 gfc_trans_array_bounds (tree type
, gfc_symbol
* sym
, tree
* poffset
,
6292 stmtblock_t
* pblock
)
6305 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
6307 size
= gfc_index_one_node
;
6308 offset
= gfc_index_zero_node
;
6309 for (dim
= 0; dim
< as
->rank
; dim
++)
6311 /* Evaluate non-constant array bound expressions. */
6312 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
6313 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
6315 gfc_init_se (&se
, NULL
);
6316 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
6317 gfc_add_block_to_block (pblock
, &se
.pre
);
6318 gfc_add_modify (pblock
, lbound
, se
.expr
);
6320 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
6321 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
6323 gfc_init_se (&se
, NULL
);
6324 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
6325 gfc_add_block_to_block (pblock
, &se
.pre
);
6326 gfc_add_modify (pblock
, ubound
, se
.expr
);
6328 /* The offset of this dimension. offset = offset - lbound * stride. */
6329 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6331 offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6334 /* The size of this dimension, and the stride of the next. */
6335 if (dim
+ 1 < as
->rank
)
6336 stride
= GFC_TYPE_ARRAY_STRIDE (type
, dim
+ 1);
6338 stride
= GFC_TYPE_ARRAY_SIZE (type
);
6340 if (ubound
!= NULL_TREE
&& !(stride
&& INTEGER_CST_P (stride
)))
6342 /* Calculate stride = size * (ubound + 1 - lbound). */
6343 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6344 gfc_array_index_type
,
6345 gfc_index_one_node
, lbound
);
6346 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6347 gfc_array_index_type
, ubound
, tmp
);
6348 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6349 gfc_array_index_type
, size
, tmp
);
6351 gfc_add_modify (pblock
, stride
, tmp
);
6353 stride
= gfc_evaluate_now (tmp
, pblock
);
6355 /* Make sure that negative size arrays are translated
6356 to being zero size. */
6357 tmp
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
6358 stride
, gfc_index_zero_node
);
6359 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6360 gfc_array_index_type
, tmp
,
6361 stride
, gfc_index_zero_node
);
6362 gfc_add_modify (pblock
, stride
, tmp
);
6368 gfc_trans_array_cobounds (type
, pblock
, sym
);
6369 gfc_trans_vla_type_sizes (sym
, pblock
);
6376 /* Generate code to initialize/allocate an array variable. */
6379 gfc_trans_auto_array_allocation (tree decl
, gfc_symbol
* sym
,
6380 gfc_wrapped_block
* block
)
6384 tree tmp
= NULL_TREE
;
6391 gcc_assert (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
));
6393 /* Do nothing for USEd variables. */
6394 if (sym
->attr
.use_assoc
)
6397 type
= TREE_TYPE (decl
);
6398 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6399 onstack
= TREE_CODE (type
) != POINTER_TYPE
;
6401 gfc_init_block (&init
);
6403 /* Evaluate character string length. */
6404 if (sym
->ts
.type
== BT_CHARACTER
6405 && onstack
&& !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
6407 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6409 gfc_trans_vla_type_sizes (sym
, &init
);
6411 /* Emit a DECL_EXPR for this variable, which will cause the
6412 gimplifier to allocate storage, and all that good stuff. */
6413 tmp
= fold_build1_loc (input_location
, DECL_EXPR
, TREE_TYPE (decl
), decl
);
6414 gfc_add_expr_to_block (&init
, tmp
);
6419 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6423 type
= TREE_TYPE (type
);
6425 gcc_assert (!sym
->attr
.use_assoc
);
6426 gcc_assert (!TREE_STATIC (decl
));
6427 gcc_assert (!sym
->module
);
6429 if (sym
->ts
.type
== BT_CHARACTER
6430 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
6431 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6433 size
= gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
6435 /* Don't actually allocate space for Cray Pointees. */
6436 if (sym
->attr
.cray_pointee
)
6438 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6439 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6441 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6445 if (flag_stack_arrays
)
6447 gcc_assert (TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
);
6448 space
= build_decl (gfc_get_location (&sym
->declared_at
),
6449 VAR_DECL
, create_tmp_var_name ("A"),
6450 TREE_TYPE (TREE_TYPE (decl
)));
6451 gfc_trans_vla_type_sizes (sym
, &init
);
6455 /* The size is the number of elements in the array, so multiply by the
6456 size of an element to get the total size. */
6457 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
6458 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6459 size
, fold_convert (gfc_array_index_type
, tmp
));
6461 /* Allocate memory to hold the data. */
6462 tmp
= gfc_call_malloc (&init
, TREE_TYPE (decl
), size
);
6463 gfc_add_modify (&init
, decl
, tmp
);
6465 /* Free the temporary. */
6466 tmp
= gfc_call_free (decl
);
6470 /* Set offset of the array. */
6471 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6472 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6474 /* Automatic arrays should not have initializers. */
6475 gcc_assert (!sym
->value
);
6477 inittree
= gfc_finish_block (&init
);
6484 /* Don't create new scope, emit the DECL_EXPR in exactly the scope
6485 where also space is located. */
6486 gfc_init_block (&init
);
6487 tmp
= fold_build1_loc (input_location
, DECL_EXPR
,
6488 TREE_TYPE (space
), space
);
6489 gfc_add_expr_to_block (&init
, tmp
);
6490 addr
= fold_build1_loc (gfc_get_location (&sym
->declared_at
),
6491 ADDR_EXPR
, TREE_TYPE (decl
), space
);
6492 gfc_add_modify (&init
, decl
, addr
);
6493 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6496 gfc_add_init_cleanup (block
, inittree
, tmp
);
6500 /* Generate entry and exit code for g77 calling convention arrays. */
6503 gfc_trans_g77_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
6513 gfc_save_backend_locus (&loc
);
6514 gfc_set_backend_locus (&sym
->declared_at
);
6516 /* Descriptor type. */
6517 parm
= sym
->backend_decl
;
6518 type
= TREE_TYPE (parm
);
6519 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6521 gfc_start_block (&init
);
6523 if (sym
->ts
.type
== BT_CHARACTER
6524 && VAR_P (sym
->ts
.u
.cl
->backend_decl
))
6525 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6527 /* Evaluate the bounds of the array. */
6528 gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
6530 /* Set the offset. */
6531 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6532 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6534 /* Set the pointer itself if we aren't using the parameter directly. */
6535 if (TREE_CODE (parm
) != PARM_DECL
)
6537 tmp
= GFC_DECL_SAVED_DESCRIPTOR (parm
);
6538 if (sym
->ts
.type
== BT_CLASS
)
6540 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
6541 tmp
= gfc_class_data_get (tmp
);
6542 tmp
= gfc_conv_descriptor_data_get (tmp
);
6544 tmp
= convert (TREE_TYPE (parm
), tmp
);
6545 gfc_add_modify (&init
, parm
, tmp
);
6547 stmt
= gfc_finish_block (&init
);
6549 gfc_restore_backend_locus (&loc
);
6551 /* Add the initialization code to the start of the function. */
6553 if (sym
->attr
.optional
|| sym
->attr
.not_always_present
)
6556 if (TREE_CODE (parm
) != PARM_DECL
)
6557 nullify
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
6558 parm
, null_pointer_node
);
6560 nullify
= build_empty_stmt (input_location
);
6561 tmp
= gfc_conv_expr_present (sym
, true);
6562 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, nullify
);
6565 gfc_add_init_cleanup (block
, stmt
, NULL_TREE
);
6569 /* Modify the descriptor of an array parameter so that it has the
6570 correct lower bound. Also move the upper bound accordingly.
6571 If the array is not packed, it will be copied into a temporary.
6572 For each dimension we set the new lower and upper bounds. Then we copy the
6573 stride and calculate the offset for this dimension. We also work out
6574 what the stride of a packed array would be, and see it the two match.
6575 If the array need repacking, we set the stride to the values we just
6576 calculated, recalculate the offset and copy the array data.
6577 Code is also added to copy the data back at the end of the function.
6581 gfc_trans_dummy_array_bias (gfc_symbol
* sym
, tree tmpdesc
,
6582 gfc_wrapped_block
* block
)
6589 tree stmtInit
, stmtCleanup
;
6596 tree stride
, stride2
;
6606 bool is_classarray
= IS_CLASS_ARRAY (sym
);
6608 /* Do nothing for pointer and allocatable arrays. */
6609 if ((sym
->ts
.type
!= BT_CLASS
&& sym
->attr
.pointer
)
6610 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.class_pointer
)
6611 || sym
->attr
.allocatable
6612 || (is_classarray
&& CLASS_DATA (sym
)->attr
.allocatable
))
6615 if (!is_classarray
&& sym
->attr
.dummy
&& gfc_is_nodesc_array (sym
))
6617 gfc_trans_g77_array (sym
, block
);
6622 gfc_save_backend_locus (&loc
);
6623 /* loc.nextc is not set by save_backend_locus but the location routines
6625 if (loc
.nextc
== NULL
)
6626 loc
.nextc
= loc
.lb
->line
;
6627 gfc_set_backend_locus (&sym
->declared_at
);
6629 /* Descriptor type. */
6630 type
= TREE_TYPE (tmpdesc
);
6631 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6632 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6634 /* For a class array the dummy array descriptor is in the _class
6636 dumdesc
= gfc_class_data_get (dumdesc
);
6638 dumdesc
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
6639 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
6640 gfc_start_block (&init
);
6642 if (sym
->ts
.type
== BT_CHARACTER
6643 && VAR_P (sym
->ts
.u
.cl
->backend_decl
))
6644 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6646 /* TODO: Fix the exclusion of class arrays from extent checking. */
6647 checkparm
= (as
->type
== AS_EXPLICIT
&& !is_classarray
6648 && (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
));
6650 no_repack
= !(GFC_DECL_PACKED_ARRAY (tmpdesc
)
6651 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
));
6653 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
))
6655 /* For non-constant shape arrays we only check if the first dimension
6656 is contiguous. Repacking higher dimensions wouldn't gain us
6657 anything as we still don't know the array stride. */
6658 partial
= gfc_create_var (logical_type_node
, "partial");
6659 TREE_USED (partial
) = 1;
6660 tmp
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
6661 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, tmp
,
6662 gfc_index_one_node
);
6663 gfc_add_modify (&init
, partial
, tmp
);
6666 partial
= NULL_TREE
;
6668 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
6669 here, however I think it does the right thing. */
6672 /* Set the first stride. */
6673 stride
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
6674 stride
= gfc_evaluate_now (stride
, &init
);
6676 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
6677 stride
, gfc_index_zero_node
);
6678 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
6679 tmp
, gfc_index_one_node
, stride
);
6680 stride
= GFC_TYPE_ARRAY_STRIDE (type
, 0);
6681 gfc_add_modify (&init
, stride
, tmp
);
6683 /* Allow the user to disable array repacking. */
6684 stmt_unpacked
= NULL_TREE
;
6688 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type
, 0)));
6689 /* A library call to repack the array if necessary. */
6690 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6691 stmt_unpacked
= build_call_expr_loc (input_location
,
6692 gfor_fndecl_in_pack
, 1, tmp
);
6694 stride
= gfc_index_one_node
;
6696 if (warn_array_temporaries
)
6697 gfc_warning (OPT_Warray_temporaries
,
6698 "Creating array temporary at %L", &loc
);
6701 /* This is for the case where the array data is used directly without
6702 calling the repack function. */
6703 if (no_repack
|| partial
!= NULL_TREE
)
6704 stmt_packed
= gfc_conv_descriptor_data_get (dumdesc
);
6706 stmt_packed
= NULL_TREE
;
6708 /* Assign the data pointer. */
6709 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
6711 /* Don't repack unknown shape arrays when the first stride is 1. */
6712 tmp
= fold_build3_loc (input_location
, COND_EXPR
, TREE_TYPE (stmt_packed
),
6713 partial
, stmt_packed
, stmt_unpacked
);
6716 tmp
= stmt_packed
!= NULL_TREE
? stmt_packed
: stmt_unpacked
;
6717 gfc_add_modify (&init
, tmpdesc
, fold_convert (type
, tmp
));
6719 offset
= gfc_index_zero_node
;
6720 size
= gfc_index_one_node
;
6722 /* Evaluate the bounds of the array. */
6723 for (n
= 0; n
< as
->rank
; n
++)
6725 if (checkparm
|| !as
->upper
[n
])
6727 /* Get the bounds of the actual parameter. */
6728 dubound
= gfc_conv_descriptor_ubound_get (dumdesc
, gfc_rank_cst
[n
]);
6729 dlbound
= gfc_conv_descriptor_lbound_get (dumdesc
, gfc_rank_cst
[n
]);
6733 dubound
= NULL_TREE
;
6734 dlbound
= NULL_TREE
;
6737 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, n
);
6738 if (!INTEGER_CST_P (lbound
))
6740 gfc_init_se (&se
, NULL
);
6741 gfc_conv_expr_type (&se
, as
->lower
[n
],
6742 gfc_array_index_type
);
6743 gfc_add_block_to_block (&init
, &se
.pre
);
6744 gfc_add_modify (&init
, lbound
, se
.expr
);
6747 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, n
);
6748 /* Set the desired upper bound. */
6751 /* We know what we want the upper bound to be. */
6752 if (!INTEGER_CST_P (ubound
))
6754 gfc_init_se (&se
, NULL
);
6755 gfc_conv_expr_type (&se
, as
->upper
[n
],
6756 gfc_array_index_type
);
6757 gfc_add_block_to_block (&init
, &se
.pre
);
6758 gfc_add_modify (&init
, ubound
, se
.expr
);
6761 /* Check the sizes match. */
6764 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
6768 temp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6769 gfc_array_index_type
, ubound
, lbound
);
6770 temp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6771 gfc_array_index_type
,
6772 gfc_index_one_node
, temp
);
6773 stride2
= fold_build2_loc (input_location
, MINUS_EXPR
,
6774 gfc_array_index_type
, dubound
,
6776 stride2
= fold_build2_loc (input_location
, PLUS_EXPR
,
6777 gfc_array_index_type
,
6778 gfc_index_one_node
, stride2
);
6779 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6780 gfc_array_index_type
, temp
, stride2
);
6781 msg
= xasprintf ("Dimension %d of array '%s' has extent "
6782 "%%ld instead of %%ld", n
+1, sym
->name
);
6784 gfc_trans_runtime_check (true, false, tmp
, &init
, &loc
, msg
,
6785 fold_convert (long_integer_type_node
, temp
),
6786 fold_convert (long_integer_type_node
, stride2
));
6793 /* For assumed shape arrays move the upper bound by the same amount
6794 as the lower bound. */
6795 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6796 gfc_array_index_type
, dubound
, dlbound
);
6797 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6798 gfc_array_index_type
, tmp
, lbound
);
6799 gfc_add_modify (&init
, ubound
, tmp
);
6801 /* The offset of this dimension. offset = offset - lbound * stride. */
6802 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6804 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
6805 gfc_array_index_type
, offset
, tmp
);
6807 /* The size of this dimension, and the stride of the next. */
6808 if (n
+ 1 < as
->rank
)
6810 stride
= GFC_TYPE_ARRAY_STRIDE (type
, n
+ 1);
6812 if (no_repack
|| partial
!= NULL_TREE
)
6814 gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[n
+1]);
6816 /* Figure out the stride if not a known constant. */
6817 if (!INTEGER_CST_P (stride
))
6820 stmt_packed
= NULL_TREE
;
6823 /* Calculate stride = size * (ubound + 1 - lbound). */
6824 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6825 gfc_array_index_type
,
6826 gfc_index_one_node
, lbound
);
6827 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6828 gfc_array_index_type
, ubound
, tmp
);
6829 size
= fold_build2_loc (input_location
, MULT_EXPR
,
6830 gfc_array_index_type
, size
, tmp
);
6834 /* Assign the stride. */
6835 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
6836 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6837 gfc_array_index_type
, partial
,
6838 stmt_unpacked
, stmt_packed
);
6840 tmp
= (stmt_packed
!= NULL_TREE
) ? stmt_packed
: stmt_unpacked
;
6841 gfc_add_modify (&init
, stride
, tmp
);
6846 stride
= GFC_TYPE_ARRAY_SIZE (type
);
6848 if (stride
&& !INTEGER_CST_P (stride
))
6850 /* Calculate size = stride * (ubound + 1 - lbound). */
6851 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6852 gfc_array_index_type
,
6853 gfc_index_one_node
, lbound
);
6854 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6855 gfc_array_index_type
,
6857 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6858 gfc_array_index_type
,
6859 GFC_TYPE_ARRAY_STRIDE (type
, n
), tmp
);
6860 gfc_add_modify (&init
, stride
, tmp
);
6865 gfc_trans_array_cobounds (type
, &init
, sym
);
6867 /* Set the offset. */
6868 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6869 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6871 gfc_trans_vla_type_sizes (sym
, &init
);
6873 stmtInit
= gfc_finish_block (&init
);
6875 /* Only do the entry/initialization code if the arg is present. */
6876 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6877 optional_arg
= (sym
->attr
.optional
6878 || (sym
->ns
->proc_name
->attr
.entry_master
6879 && sym
->attr
.dummy
));
6882 tree zero_init
= fold_convert (TREE_TYPE (tmpdesc
), null_pointer_node
);
6883 zero_init
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
6884 tmpdesc
, zero_init
);
6885 tmp
= gfc_conv_expr_present (sym
, true);
6886 stmtInit
= build3_v (COND_EXPR
, tmp
, stmtInit
, zero_init
);
6891 stmtCleanup
= NULL_TREE
;
6894 stmtblock_t cleanup
;
6895 gfc_start_block (&cleanup
);
6897 if (sym
->attr
.intent
!= INTENT_IN
)
6899 /* Copy the data back. */
6900 tmp
= build_call_expr_loc (input_location
,
6901 gfor_fndecl_in_unpack
, 2, dumdesc
, tmpdesc
);
6902 gfc_add_expr_to_block (&cleanup
, tmp
);
6905 /* Free the temporary. */
6906 tmp
= gfc_call_free (tmpdesc
);
6907 gfc_add_expr_to_block (&cleanup
, tmp
);
6909 stmtCleanup
= gfc_finish_block (&cleanup
);
6911 /* Only do the cleanup if the array was repacked. */
6913 /* For a class array the dummy array descriptor is in the _class
6915 tmp
= gfc_class_data_get (dumdesc
);
6917 tmp
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
6918 tmp
= gfc_conv_descriptor_data_get (tmp
);
6919 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
6921 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6922 build_empty_stmt (input_location
));
6926 tmp
= gfc_conv_expr_present (sym
);
6927 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6928 build_empty_stmt (input_location
));
6932 /* We don't need to free any memory allocated by internal_pack as it will
6933 be freed at the end of the function by pop_context. */
6934 gfc_add_init_cleanup (block
, stmtInit
, stmtCleanup
);
6936 gfc_restore_backend_locus (&loc
);
6940 /* Calculate the overall offset, including subreferences. */
6942 gfc_get_dataptr_offset (stmtblock_t
*block
, tree parm
, tree desc
, tree offset
,
6943 bool subref
, gfc_expr
*expr
)
6953 /* If offset is NULL and this is not a subreferenced array, there is
6955 if (offset
== NULL_TREE
)
6958 offset
= gfc_index_zero_node
;
6963 tmp
= build_array_ref (desc
, offset
, NULL
, NULL
);
6965 /* Offset the data pointer for pointer assignments from arrays with
6966 subreferences; e.g. my_integer => my_type(:)%integer_component. */
6969 /* Go past the array reference. */
6970 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6971 if (ref
->type
== REF_ARRAY
&&
6972 ref
->u
.ar
.type
!= AR_ELEMENT
)
6978 /* Calculate the offset for each subsequent subreference. */
6979 for (; ref
; ref
= ref
->next
)
6984 field
= ref
->u
.c
.component
->backend_decl
;
6985 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
6986 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
6988 tmp
, field
, NULL_TREE
);
6992 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
6993 gfc_init_se (&start
, NULL
);
6994 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
6995 gfc_add_block_to_block (block
, &start
.pre
);
6996 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
7000 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
7001 && ref
->u
.ar
.type
== AR_ELEMENT
);
7003 /* TODO - Add bounds checking. */
7004 stride
= gfc_index_one_node
;
7005 index
= gfc_index_zero_node
;
7006 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
7011 /* Update the index. */
7012 gfc_init_se (&start
, NULL
);
7013 gfc_conv_expr_type (&start
, ref
->u
.ar
.start
[n
], gfc_array_index_type
);
7014 itmp
= gfc_evaluate_now (start
.expr
, block
);
7015 gfc_init_se (&start
, NULL
);
7016 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->lower
[n
], gfc_array_index_type
);
7017 jtmp
= gfc_evaluate_now (start
.expr
, block
);
7018 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7019 gfc_array_index_type
, itmp
, jtmp
);
7020 itmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7021 gfc_array_index_type
, itmp
, stride
);
7022 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
7023 gfc_array_index_type
, itmp
, index
);
7024 index
= gfc_evaluate_now (index
, block
);
7026 /* Update the stride. */
7027 gfc_init_se (&start
, NULL
);
7028 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->upper
[n
], gfc_array_index_type
);
7029 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7030 gfc_array_index_type
, start
.expr
,
7032 itmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7033 gfc_array_index_type
,
7034 gfc_index_one_node
, itmp
);
7035 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
7036 gfc_array_index_type
, stride
, itmp
);
7037 stride
= gfc_evaluate_now (stride
, block
);
7040 /* Apply the index to obtain the array element. */
7041 tmp
= gfc_build_array_ref (tmp
, index
, NULL
);
7048 tmp
= fold_build1_loc (input_location
, REALPART_EXPR
,
7049 TREE_TYPE (TREE_TYPE (tmp
)), tmp
);
7053 tmp
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
7054 TREE_TYPE (TREE_TYPE (tmp
)), tmp
);
7069 /* Set the target data pointer. */
7070 offset
= gfc_build_addr_expr (gfc_array_dataptr_type (desc
), tmp
);
7071 gfc_conv_descriptor_data_set (block
, parm
, offset
);
7075 /* gfc_conv_expr_descriptor needs the string length an expression
7076 so that the size of the temporary can be obtained. This is done
7077 by adding up the string lengths of all the elements in the
7078 expression. Function with non-constant expressions have their
7079 string lengths mapped onto the actual arguments using the
7080 interface mapping machinery in trans-expr.c. */
7082 get_array_charlen (gfc_expr
*expr
, gfc_se
*se
)
7084 gfc_interface_mapping mapping
;
7085 gfc_formal_arglist
*formal
;
7086 gfc_actual_arglist
*arg
;
7090 if (expr
->ts
.u
.cl
->length
7091 && gfc_is_constant_expr (expr
->ts
.u
.cl
->length
))
7093 if (!expr
->ts
.u
.cl
->backend_decl
)
7094 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
7098 switch (expr
->expr_type
)
7102 /* This is somewhat brutal. The expression for the first
7103 element of the array is evaluated and assigned to a
7104 new string length for the original expression. */
7105 e
= gfc_constructor_first (expr
->value
.constructor
)->expr
;
7107 gfc_init_se (&tse
, NULL
);
7109 /* Avoid evaluating trailing array references since all we need is
7110 the string length. */
7112 tse
.descriptor_only
= 1;
7113 if (e
->rank
&& e
->expr_type
!= EXPR_VARIABLE
)
7114 gfc_conv_expr_descriptor (&tse
, e
);
7116 gfc_conv_expr (&tse
, e
);
7118 gfc_add_block_to_block (&se
->pre
, &tse
.pre
);
7119 gfc_add_block_to_block (&se
->post
, &tse
.post
);
7121 if (!expr
->ts
.u
.cl
->backend_decl
|| !VAR_P (expr
->ts
.u
.cl
->backend_decl
))
7123 expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
7124 expr
->ts
.u
.cl
->backend_decl
=
7125 gfc_create_var (gfc_charlen_type_node
, "sln");
7128 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
7131 /* Make sure that deferred length components point to the hidden
7132 string_length component. */
7133 if (TREE_CODE (tse
.expr
) == COMPONENT_REF
7134 && TREE_CODE (tse
.string_length
) == COMPONENT_REF
7135 && TREE_OPERAND (tse
.expr
, 0) == TREE_OPERAND (tse
.string_length
, 0))
7136 e
->ts
.u
.cl
->backend_decl
= expr
->ts
.u
.cl
->backend_decl
;
7141 get_array_charlen (expr
->value
.op
.op1
, se
);
7143 /* For parentheses the expression ts.u.cl should be identical. */
7144 if (expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
7146 if (expr
->value
.op
.op1
->ts
.u
.cl
!= expr
->ts
.u
.cl
)
7147 expr
->ts
.u
.cl
->backend_decl
7148 = expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
;
7152 expr
->ts
.u
.cl
->backend_decl
=
7153 gfc_create_var (gfc_charlen_type_node
, "sln");
7155 if (expr
->value
.op
.op2
)
7157 get_array_charlen (expr
->value
.op
.op2
, se
);
7159 gcc_assert (expr
->value
.op
.op
== INTRINSIC_CONCAT
);
7161 /* Add the string lengths and assign them to the expression
7162 string length backend declaration. */
7163 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
7164 fold_build2_loc (input_location
, PLUS_EXPR
,
7165 gfc_charlen_type_node
,
7166 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
,
7167 expr
->value
.op
.op2
->ts
.u
.cl
->backend_decl
));
7170 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
7171 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
);
7175 if (expr
->value
.function
.esym
== NULL
7176 || expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
7178 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
7182 /* Map expressions involving the dummy arguments onto the actual
7183 argument expressions. */
7184 gfc_init_interface_mapping (&mapping
);
7185 formal
= gfc_sym_get_dummy_args (expr
->symtree
->n
.sym
);
7186 arg
= expr
->value
.function
.actual
;
7188 /* Set se = NULL in the calls to the interface mapping, to suppress any
7190 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
7195 gfc_add_interface_mapping (&mapping
, formal
->sym
, NULL
, arg
->expr
);
7198 gfc_init_se (&tse
, NULL
);
7200 /* Build the expression for the character length and convert it. */
7201 gfc_apply_interface_mapping (&mapping
, &tse
, expr
->ts
.u
.cl
->length
);
7203 gfc_add_block_to_block (&se
->pre
, &tse
.pre
);
7204 gfc_add_block_to_block (&se
->post
, &tse
.post
);
7205 tse
.expr
= fold_convert (gfc_charlen_type_node
, tse
.expr
);
7206 tse
.expr
= fold_build2_loc (input_location
, MAX_EXPR
,
7207 TREE_TYPE (tse
.expr
), tse
.expr
,
7208 build_zero_cst (TREE_TYPE (tse
.expr
)));
7209 expr
->ts
.u
.cl
->backend_decl
= tse
.expr
;
7210 gfc_free_interface_mapping (&mapping
);
7214 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
7220 /* Helper function to check dimensions. */
7222 transposed_dims (gfc_ss
*ss
)
7226 for (n
= 0; n
< ss
->dimen
; n
++)
7227 if (ss
->dim
[n
] != n
)
7233 /* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
7234 AR_FULL, suitable for the scalarizer. */
7237 walk_coarray (gfc_expr
*e
)
7241 gcc_assert (gfc_get_corank (e
) > 0);
7243 ss
= gfc_walk_expr (e
);
7245 /* Fix scalar coarray. */
7246 if (ss
== gfc_ss_terminator
)
7253 if (ref
->type
== REF_ARRAY
7254 && ref
->u
.ar
.codimen
> 0)
7260 gcc_assert (ref
!= NULL
);
7261 if (ref
->u
.ar
.type
== AR_ELEMENT
)
7262 ref
->u
.ar
.type
= AR_SECTION
;
7263 ss
= gfc_reverse_ss (gfc_walk_array_ref (ss
, e
, ref
));
7270 /* Convert an array for passing as an actual argument. Expressions and
7271 vector subscripts are evaluated and stored in a temporary, which is then
7272 passed. For whole arrays the descriptor is passed. For array sections
7273 a modified copy of the descriptor is passed, but using the original data.
7275 This function is also used for array pointer assignments, and there
7278 - se->want_pointer && !se->direct_byref
7279 EXPR is an actual argument. On exit, se->expr contains a
7280 pointer to the array descriptor.
7282 - !se->want_pointer && !se->direct_byref
7283 EXPR is an actual argument to an intrinsic function or the
7284 left-hand side of a pointer assignment. On exit, se->expr
7285 contains the descriptor for EXPR.
7287 - !se->want_pointer && se->direct_byref
7288 EXPR is the right-hand side of a pointer assignment and
7289 se->expr is the descriptor for the previously-evaluated
7290 left-hand side. The function creates an assignment from
7294 The se->force_tmp flag disables the non-copying descriptor optimization
7295 that is used for transpose. It may be used in cases where there is an
7296 alias between the transpose argument and another argument in the same
7300 gfc_conv_expr_descriptor (gfc_se
*se
, gfc_expr
*expr
)
7303 gfc_ss_type ss_type
;
7304 gfc_ss_info
*ss_info
;
7306 gfc_array_info
*info
;
7314 bool subref_array_target
= false;
7315 bool deferred_array_component
= false;
7316 gfc_expr
*arg
, *ss_expr
;
7318 if (se
->want_coarray
)
7319 ss
= walk_coarray (expr
);
7321 ss
= gfc_walk_expr (expr
);
7323 gcc_assert (ss
!= NULL
);
7324 gcc_assert (ss
!= gfc_ss_terminator
);
7327 ss_type
= ss_info
->type
;
7328 ss_expr
= ss_info
->expr
;
7330 /* Special case: TRANSPOSE which needs no temporary. */
7331 while (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
7332 && (arg
= gfc_get_noncopying_intrinsic_argument (expr
)) != NULL
)
7334 /* This is a call to transpose which has already been handled by the
7335 scalarizer, so that we just need to get its argument's descriptor. */
7336 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
7337 expr
= expr
->value
.function
.actual
->expr
;
7340 if (!se
->direct_byref
)
7341 se
->unlimited_polymorphic
= UNLIMITED_POLY (expr
);
7343 /* Special case things we know we can pass easily. */
7344 switch (expr
->expr_type
)
7347 /* If we have a linear array section, we can pass it directly.
7348 Otherwise we need to copy it into a temporary. */
7350 gcc_assert (ss_type
== GFC_SS_SECTION
);
7351 gcc_assert (ss_expr
== expr
);
7352 info
= &ss_info
->data
.array
;
7354 /* Get the descriptor for the array. */
7355 gfc_conv_ss_descriptor (&se
->pre
, ss
, 0);
7356 desc
= info
->descriptor
;
7358 /* The charlen backend decl for deferred character components cannot
7359 be used because it is fixed at zero. Instead, the hidden string
7360 length component is used. */
7361 if (expr
->ts
.type
== BT_CHARACTER
7362 && expr
->ts
.deferred
7363 && TREE_CODE (desc
) == COMPONENT_REF
)
7364 deferred_array_component
= true;
7366 subref_array_target
= (is_subref_array (expr
)
7367 && (se
->direct_byref
7368 || expr
->ts
.type
== BT_CHARACTER
));
7369 need_tmp
= (gfc_ref_needs_temporary_p (expr
->ref
)
7370 && !subref_array_target
);
7374 else if (se
->force_no_tmp
)
7379 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7381 /* Create a new descriptor if the array doesn't have one. */
7384 else if (info
->ref
->u
.ar
.type
== AR_FULL
|| se
->descriptor_only
)
7386 else if (se
->direct_byref
)
7388 else if (info
->ref
->u
.ar
.dimen
== 0 && !info
->ref
->next
)
7390 else if (info
->ref
->u
.ar
.type
== AR_SECTION
&& se
->want_pointer
)
7393 full
= gfc_full_array_ref_p (info
->ref
, NULL
);
7395 if (full
&& !transposed_dims (ss
))
7397 if (se
->direct_byref
&& !se
->byref_noassign
)
7399 /* Copy the descriptor for pointer assignments. */
7400 gfc_add_modify (&se
->pre
, se
->expr
, desc
);
7402 /* Add any offsets from subreferences. */
7403 gfc_get_dataptr_offset (&se
->pre
, se
->expr
, desc
, NULL_TREE
,
7404 subref_array_target
, expr
);
7406 /* ....and set the span field. */
7407 tmp
= gfc_conv_descriptor_span_get (desc
);
7408 gfc_conv_descriptor_span_set (&se
->pre
, se
->expr
, tmp
);
7410 else if (se
->want_pointer
)
7412 /* We pass full arrays directly. This means that pointers and
7413 allocatable arrays should also work. */
7414 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
7421 if (expr
->ts
.type
== BT_CHARACTER
&& !deferred_array_component
)
7422 se
->string_length
= gfc_get_expr_charlen (expr
);
7423 /* The ss_info string length is returned set to the value of the
7424 hidden string length component. */
7425 else if (deferred_array_component
)
7426 se
->string_length
= ss_info
->string_length
;
7428 gfc_free_ss_chain (ss
);
7434 /* A transformational function return value will be a temporary
7435 array descriptor. We still need to go through the scalarizer
7436 to create the descriptor. Elemental functions are handled as
7437 arbitrary expressions, i.e. copy to a temporary. */
7439 if (se
->direct_byref
)
7441 gcc_assert (ss_type
== GFC_SS_FUNCTION
&& ss_expr
== expr
);
7443 /* For pointer assignments pass the descriptor directly. */
7447 gcc_assert (se
->ss
== ss
);
7449 if (!is_pointer_array (se
->expr
))
7451 tmp
= gfc_get_element_type (TREE_TYPE (se
->expr
));
7452 tmp
= fold_convert (gfc_array_index_type
,
7453 size_in_bytes (tmp
));
7454 gfc_conv_descriptor_span_set (&se
->pre
, se
->expr
, tmp
);
7457 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7458 gfc_conv_expr (se
, expr
);
7460 gfc_free_ss_chain (ss
);
7464 if (ss_expr
!= expr
|| ss_type
!= GFC_SS_FUNCTION
)
7466 if (ss_expr
!= expr
)
7467 /* Elemental function. */
7468 gcc_assert ((expr
->value
.function
.esym
!= NULL
7469 && expr
->value
.function
.esym
->attr
.elemental
)
7470 || (expr
->value
.function
.isym
!= NULL
7471 && expr
->value
.function
.isym
->elemental
)
7472 || (gfc_expr_attr (expr
).proc_pointer
7473 && gfc_expr_attr (expr
).elemental
)
7474 || gfc_inline_intrinsic_function_p (expr
));
7477 if (expr
->ts
.type
== BT_CHARACTER
7478 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
7479 get_array_charlen (expr
, se
);
7485 /* Transformational function. */
7486 info
= &ss_info
->data
.array
;
7492 /* Constant array constructors don't need a temporary. */
7493 if (ss_type
== GFC_SS_CONSTRUCTOR
7494 && expr
->ts
.type
!= BT_CHARACTER
7495 && gfc_constant_array_constructor_p (expr
->value
.constructor
))
7498 info
= &ss_info
->data
.array
;
7508 /* Something complicated. Copy it into a temporary. */
7514 /* If we are creating a temporary, we don't need to bother about aliases
7519 gfc_init_loopinfo (&loop
);
7521 /* Associate the SS with the loop. */
7522 gfc_add_ss_to_loop (&loop
, ss
);
7524 /* Tell the scalarizer not to bother creating loop variables, etc. */
7526 loop
.array_parameter
= 1;
7528 /* The right-hand side of a pointer assignment mustn't use a temporary. */
7529 gcc_assert (!se
->direct_byref
);
7531 /* Do we need bounds checking or not? */
7532 ss
->no_bounds_check
= expr
->no_bounds_check
;
7534 /* Setup the scalarizing loops and bounds. */
7535 gfc_conv_ss_startstride (&loop
);
7539 if (expr
->ts
.type
== BT_CHARACTER
7540 && (!expr
->ts
.u
.cl
->backend_decl
|| expr
->expr_type
== EXPR_ARRAY
))
7541 get_array_charlen (expr
, se
);
7543 /* Tell the scalarizer to make a temporary. */
7544 loop
.temp_ss
= gfc_get_temp_ss (gfc_typenode_for_spec (&expr
->ts
),
7545 ((expr
->ts
.type
== BT_CHARACTER
)
7546 ? expr
->ts
.u
.cl
->backend_decl
7550 se
->string_length
= loop
.temp_ss
->info
->string_length
;
7551 gcc_assert (loop
.temp_ss
->dimen
== loop
.dimen
);
7552 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
7555 gfc_conv_loop_setup (&loop
, & expr
->where
);
7559 /* Copy into a temporary and pass that. We don't need to copy the data
7560 back because expressions and vector subscripts must be INTENT_IN. */
7561 /* TODO: Optimize passing function return values. */
7566 /* Start the copying loops. */
7567 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
7568 gfc_mark_ss_chain_used (ss
, 1);
7569 gfc_start_scalarized_body (&loop
, &block
);
7571 /* Copy each data element. */
7572 gfc_init_se (&lse
, NULL
);
7573 gfc_copy_loopinfo_to_se (&lse
, &loop
);
7574 gfc_init_se (&rse
, NULL
);
7575 gfc_copy_loopinfo_to_se (&rse
, &loop
);
7577 lse
.ss
= loop
.temp_ss
;
7580 gfc_conv_scalarized_array_ref (&lse
, NULL
);
7581 if (expr
->ts
.type
== BT_CHARACTER
)
7583 gfc_conv_expr (&rse
, expr
);
7584 if (POINTER_TYPE_P (TREE_TYPE (rse
.expr
)))
7585 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
7589 gfc_conv_expr_val (&rse
, expr
);
7591 gfc_add_block_to_block (&block
, &rse
.pre
);
7592 gfc_add_block_to_block (&block
, &lse
.pre
);
7594 lse
.string_length
= rse
.string_length
;
7596 deep_copy
= !se
->data_not_needed
7597 && (expr
->expr_type
== EXPR_VARIABLE
7598 || expr
->expr_type
== EXPR_ARRAY
);
7599 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
,
7601 gfc_add_expr_to_block (&block
, tmp
);
7603 /* Finish the copying loops. */
7604 gfc_trans_scalarizing_loops (&loop
, &block
);
7606 desc
= loop
.temp_ss
->info
->data
.array
.descriptor
;
7608 else if (expr
->expr_type
== EXPR_FUNCTION
&& !transposed_dims (ss
))
7610 desc
= info
->descriptor
;
7611 se
->string_length
= ss_info
->string_length
;
7615 /* We pass sections without copying to a temporary. Make a new
7616 descriptor and point it at the section we want. The loop variable
7617 limits will be the limits of the section.
7618 A function may decide to repack the array to speed up access, but
7619 we're not bothered about that here. */
7620 int dim
, ndim
, codim
;
7630 ndim
= info
->ref
? info
->ref
->u
.ar
.dimen
: ss
->dimen
;
7632 if (se
->want_coarray
)
7634 gfc_array_ref
*ar
= &info
->ref
->u
.ar
;
7636 codim
= gfc_get_corank (expr
);
7637 for (n
= 0; n
< codim
- 1; n
++)
7639 /* Make sure we are not lost somehow. */
7640 gcc_assert (ar
->dimen_type
[n
+ ndim
] == DIMEN_THIS_IMAGE
);
7642 /* Make sure the call to gfc_conv_section_startstride won't
7643 generate unnecessary code to calculate stride. */
7644 gcc_assert (ar
->stride
[n
+ ndim
] == NULL
);
7646 gfc_conv_section_startstride (&loop
.pre
, ss
, n
+ ndim
);
7647 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
7648 loop
.to
[n
+ loop
.dimen
] = info
->end
[n
+ ndim
];
7651 gcc_assert (n
== codim
- 1);
7652 evaluate_bound (&loop
.pre
, info
->start
, ar
->start
,
7653 info
->descriptor
, n
+ ndim
, true,
7654 ar
->as
->type
== AS_DEFERRED
);
7655 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
7660 /* Set the string_length for a character array. */
7661 if (expr
->ts
.type
== BT_CHARACTER
)
7663 if (deferred_array_component
)
7664 se
->string_length
= ss_info
->string_length
;
7666 se
->string_length
= gfc_get_expr_charlen (expr
);
7668 if (VAR_P (se
->string_length
)
7669 && expr
->ts
.u
.cl
->backend_decl
== se
->string_length
)
7670 tmp
= ss_info
->string_length
;
7672 tmp
= se
->string_length
;
7674 if (expr
->ts
.deferred
&& VAR_P (expr
->ts
.u
.cl
->backend_decl
))
7675 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
, tmp
);
7677 expr
->ts
.u
.cl
->backend_decl
= tmp
;
7680 /* If we have an array section, are assigning or passing an array
7681 section argument make sure that the lower bound is 1. References
7682 to the full array should otherwise keep the original bounds. */
7683 if (!info
->ref
|| info
->ref
->u
.ar
.type
!= AR_FULL
)
7684 for (dim
= 0; dim
< loop
.dimen
; dim
++)
7685 if (!integer_onep (loop
.from
[dim
]))
7687 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7688 gfc_array_index_type
, gfc_index_one_node
,
7690 loop
.to
[dim
] = fold_build2_loc (input_location
, PLUS_EXPR
,
7691 gfc_array_index_type
,
7693 loop
.from
[dim
] = gfc_index_one_node
;
7696 desc
= info
->descriptor
;
7697 if (se
->direct_byref
&& !se
->byref_noassign
)
7699 /* For pointer assignments we fill in the destination. */
7701 parmtype
= TREE_TYPE (parm
);
7705 /* Otherwise make a new one. */
7706 if (expr
->ts
.type
== BT_CHARACTER
)
7707 parmtype
= gfc_typenode_for_spec (&expr
->ts
);
7709 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
7711 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
, codim
,
7712 loop
.from
, loop
.to
, 0,
7713 GFC_ARRAY_UNKNOWN
, false);
7714 parm
= gfc_create_var (parmtype
, "parm");
7716 /* When expression is a class object, then add the class' handle to
7718 if (expr
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_VARIABLE
)
7720 gfc_expr
*class_expr
= gfc_find_and_cut_at_last_class_ref (expr
);
7723 /* class_expr can be NULL, when no _class ref is in expr.
7724 We must not fix this here with a gfc_fix_class_ref (). */
7727 gfc_init_se (&classse
, NULL
);
7728 gfc_conv_expr (&classse
, class_expr
);
7729 gfc_free_expr (class_expr
);
7731 gcc_assert (classse
.pre
.head
== NULL_TREE
7732 && classse
.post
.head
== NULL_TREE
);
7733 gfc_allocate_lang_decl (parm
);
7734 GFC_DECL_SAVED_DESCRIPTOR (parm
) = classse
.expr
;
7739 /* Set the span field. */
7740 tmp
= gfc_get_array_span (desc
, expr
);
7742 gfc_conv_descriptor_span_set (&loop
.pre
, parm
, tmp
);
7744 /* The following can be somewhat confusing. We have two
7745 descriptors, a new one and the original array.
7746 {parm, parmtype, dim} refer to the new one.
7747 {desc, type, n, loop} refer to the original, which maybe
7748 a descriptorless array.
7749 The bounds of the scalarization are the bounds of the section.
7750 We don't have to worry about numeric overflows when calculating
7751 the offsets because all elements are within the array data. */
7753 /* Set the dtype. */
7754 tmp
= gfc_conv_descriptor_dtype (parm
);
7755 if (se
->unlimited_polymorphic
)
7756 dtype
= gfc_get_dtype (TREE_TYPE (desc
), &loop
.dimen
);
7758 dtype
= gfc_get_dtype (parmtype
);
7759 gfc_add_modify (&loop
.pre
, tmp
, dtype
);
7761 /* The 1st element in the section. */
7762 base
= gfc_index_zero_node
;
7764 /* The offset from the 1st element in the section. */
7765 offset
= gfc_index_zero_node
;
7767 for (n
= 0; n
< ndim
; n
++)
7769 stride
= gfc_conv_array_stride (desc
, n
);
7771 /* Work out the 1st element in the section. */
7773 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
7775 gcc_assert (info
->subscript
[n
]
7776 && info
->subscript
[n
]->info
->type
== GFC_SS_SCALAR
);
7777 start
= info
->subscript
[n
]->info
->data
.scalar
.value
;
7781 /* Evaluate and remember the start of the section. */
7782 start
= info
->start
[n
];
7783 stride
= gfc_evaluate_now (stride
, &loop
.pre
);
7786 tmp
= gfc_conv_array_lbound (desc
, n
);
7787 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
7789 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
7791 base
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (tmp
),
7795 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
7797 /* For elemental dimensions, we only need the 1st
7798 element in the section. */
7802 /* Vector subscripts need copying and are handled elsewhere. */
7804 gcc_assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
7806 /* look for the corresponding scalarizer dimension: dim. */
7807 for (dim
= 0; dim
< ndim
; dim
++)
7808 if (ss
->dim
[dim
] == n
)
7811 /* loop exited early: the DIM being looked for has been found. */
7812 gcc_assert (dim
< ndim
);
7814 /* Set the new lower bound. */
7815 from
= loop
.from
[dim
];
7818 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
7819 gfc_rank_cst
[dim
], from
);
7821 /* Set the new upper bound. */
7822 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
7823 gfc_rank_cst
[dim
], to
);
7825 /* Multiply the stride by the section stride to get the
7827 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
7828 gfc_array_index_type
,
7829 stride
, info
->stride
[n
]);
7831 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7832 TREE_TYPE (offset
), stride
, from
);
7833 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
7834 TREE_TYPE (offset
), offset
, tmp
);
7836 /* Store the new stride. */
7837 gfc_conv_descriptor_stride_set (&loop
.pre
, parm
,
7838 gfc_rank_cst
[dim
], stride
);
7841 for (n
= loop
.dimen
; n
< loop
.dimen
+ codim
; n
++)
7843 from
= loop
.from
[n
];
7845 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
7846 gfc_rank_cst
[n
], from
);
7847 if (n
< loop
.dimen
+ codim
- 1)
7848 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
7849 gfc_rank_cst
[n
], to
);
7852 if (se
->data_not_needed
)
7853 gfc_conv_descriptor_data_set (&loop
.pre
, parm
,
7854 gfc_index_zero_node
);
7856 /* Point the data pointer at the 1st element in the section. */
7857 gfc_get_dataptr_offset (&loop
.pre
, parm
, desc
, base
,
7858 subref_array_target
, expr
);
7860 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, offset
);
7865 /* For class arrays add the class tree into the saved descriptor to
7866 enable getting of _vptr and the like. */
7867 if (expr
->expr_type
== EXPR_VARIABLE
&& VAR_P (desc
)
7868 && IS_CLASS_ARRAY (expr
->symtree
->n
.sym
))
7870 gfc_allocate_lang_decl (desc
);
7871 GFC_DECL_SAVED_DESCRIPTOR (desc
) =
7872 DECL_LANG_SPECIFIC (expr
->symtree
->n
.sym
->backend_decl
) ?
7873 GFC_DECL_SAVED_DESCRIPTOR (expr
->symtree
->n
.sym
->backend_decl
)
7874 : expr
->symtree
->n
.sym
->backend_decl
;
7876 else if (expr
->expr_type
== EXPR_ARRAY
&& VAR_P (desc
)
7877 && IS_CLASS_ARRAY (expr
))
7880 gfc_allocate_lang_decl (desc
);
7881 tmp
= gfc_create_var (expr
->ts
.u
.derived
->backend_decl
, "class");
7882 GFC_DECL_SAVED_DESCRIPTOR (desc
) = tmp
;
7883 vtype
= gfc_class_vptr_get (tmp
);
7884 gfc_add_modify (&se
->pre
, vtype
,
7885 gfc_build_addr_expr (TREE_TYPE (vtype
),
7886 gfc_find_vtab (&expr
->ts
)->backend_decl
));
7888 if (!se
->direct_byref
|| se
->byref_noassign
)
7890 /* Get a pointer to the new descriptor. */
7891 if (se
->want_pointer
)
7892 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
7897 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
7898 gfc_add_block_to_block (&se
->post
, &loop
.post
);
7900 /* Cleanup the scalarizer. */
7901 gfc_cleanup_loop (&loop
);
7904 /* Helper function for gfc_conv_array_parameter if array size needs to be
7908 array_parameter_size (tree desc
, gfc_expr
*expr
, tree
*size
)
7911 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7912 *size
= GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc
));
7913 else if (expr
->rank
> 1)
7914 *size
= build_call_expr_loc (input_location
,
7915 gfor_fndecl_size0
, 1,
7916 gfc_build_addr_expr (NULL
, desc
));
7919 tree ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_index_zero_node
);
7920 tree lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_index_zero_node
);
7922 *size
= fold_build2_loc (input_location
, MINUS_EXPR
,
7923 gfc_array_index_type
, ubound
, lbound
);
7924 *size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7925 *size
, gfc_index_one_node
);
7926 *size
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
7927 *size
, gfc_index_zero_node
);
7929 elem
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
7930 *size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7931 *size
, fold_convert (gfc_array_index_type
, elem
));
7934 /* Helper function - return true if the argument is a pointer. */
7937 is_pointer (gfc_expr
*e
)
7941 if (e
->expr_type
!= EXPR_VARIABLE
|| e
->symtree
== NULL
)
7944 sym
= e
->symtree
->n
.sym
;
7948 return sym
->attr
.pointer
|| sym
->attr
.proc_pointer
;
7951 /* Convert an array for passing as an actual parameter. */
7954 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, bool g77
,
7955 const gfc_symbol
*fsym
, const char *proc_name
,
7960 tree tmp
= NULL_TREE
;
7962 tree parent
= DECL_CONTEXT (current_function_decl
);
7963 bool full_array_var
;
7964 bool this_array_result
;
7967 bool array_constructor
;
7968 bool good_allocatable
;
7969 bool ultimate_ptr_comp
;
7970 bool ultimate_alloc_comp
;
7975 ultimate_ptr_comp
= false;
7976 ultimate_alloc_comp
= false;
7978 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7980 if (ref
->next
== NULL
)
7983 if (ref
->type
== REF_COMPONENT
)
7985 ultimate_ptr_comp
= ref
->u
.c
.component
->attr
.pointer
;
7986 ultimate_alloc_comp
= ref
->u
.c
.component
->attr
.allocatable
;
7990 full_array_var
= false;
7993 if (expr
->expr_type
== EXPR_VARIABLE
&& ref
&& !ultimate_ptr_comp
)
7994 full_array_var
= gfc_full_array_ref_p (ref
, &contiguous
);
7996 sym
= full_array_var
? expr
->symtree
->n
.sym
: NULL
;
7998 /* The symbol should have an array specification. */
7999 gcc_assert (!sym
|| sym
->as
|| ref
->u
.ar
.as
);
8001 if (expr
->expr_type
== EXPR_ARRAY
&& expr
->ts
.type
== BT_CHARACTER
)
8003 get_array_ctor_strlen (&se
->pre
, expr
->value
.constructor
, &tmp
);
8004 expr
->ts
.u
.cl
->backend_decl
= tmp
;
8005 se
->string_length
= tmp
;
8008 /* Is this the result of the enclosing procedure? */
8009 this_array_result
= (full_array_var
&& sym
->attr
.flavor
== FL_PROCEDURE
);
8010 if (this_array_result
8011 && (sym
->backend_decl
!= current_function_decl
)
8012 && (sym
->backend_decl
!= parent
))
8013 this_array_result
= false;
8015 /* Passing address of the array if it is not pointer or assumed-shape. */
8016 if (full_array_var
&& g77
&& !this_array_result
8017 && sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
8019 tmp
= gfc_get_symbol_decl (sym
);
8021 if (sym
->ts
.type
== BT_CHARACTER
)
8022 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
8024 if (!sym
->attr
.pointer
8026 && sym
->as
->type
!= AS_ASSUMED_SHAPE
8027 && sym
->as
->type
!= AS_DEFERRED
8028 && sym
->as
->type
!= AS_ASSUMED_RANK
8029 && !sym
->attr
.allocatable
)
8031 /* Some variables are declared directly, others are declared as
8032 pointers and allocated on the heap. */
8033 if (sym
->attr
.dummy
|| POINTER_TYPE_P (TREE_TYPE (tmp
)))
8036 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
8038 array_parameter_size (tmp
, expr
, size
);
8042 if (sym
->attr
.allocatable
)
8044 if (sym
->attr
.dummy
|| sym
->attr
.result
)
8046 gfc_conv_expr_descriptor (se
, expr
);
8050 array_parameter_size (tmp
, expr
, size
);
8051 se
->expr
= gfc_conv_array_data (tmp
);
8056 /* A convenient reduction in scope. */
8057 contiguous
= g77
&& !this_array_result
&& contiguous
;
8059 /* There is no need to pack and unpack the array, if it is contiguous
8060 and not a deferred- or assumed-shape array, or if it is simply
8062 no_pack
= ((sym
&& sym
->as
8063 && !sym
->attr
.pointer
8064 && sym
->as
->type
!= AS_DEFERRED
8065 && sym
->as
->type
!= AS_ASSUMED_RANK
8066 && sym
->as
->type
!= AS_ASSUMED_SHAPE
)
8068 (ref
&& ref
->u
.ar
.as
8069 && ref
->u
.ar
.as
->type
!= AS_DEFERRED
8070 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_RANK
8071 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_SHAPE
)
8073 gfc_is_simply_contiguous (expr
, false, true));
8075 no_pack
= contiguous
&& no_pack
;
8077 /* If we have an EXPR_OP or a function returning an explicit-shaped
8078 or allocatable array, an array temporary will be generated which
8079 does not need to be packed / unpacked if passed to an
8080 explicit-shape dummy array. */
8084 if (expr
->expr_type
== EXPR_OP
)
8086 else if (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.esym
)
8088 gfc_symbol
*result
= expr
->value
.function
.esym
->result
;
8089 if (result
->attr
.dimension
8090 && (result
->as
->type
== AS_EXPLICIT
8091 || result
->attr
.allocatable
8092 || result
->attr
.contiguous
))
8097 /* Array constructors are always contiguous and do not need packing. */
8098 array_constructor
= g77
&& !this_array_result
&& expr
->expr_type
== EXPR_ARRAY
;
8100 /* Same is true of contiguous sections from allocatable variables. */
8101 good_allocatable
= contiguous
8103 && expr
->symtree
->n
.sym
->attr
.allocatable
;
8105 /* Or ultimate allocatable components. */
8106 ultimate_alloc_comp
= contiguous
&& ultimate_alloc_comp
;
8108 if (no_pack
|| array_constructor
|| good_allocatable
|| ultimate_alloc_comp
)
8110 gfc_conv_expr_descriptor (se
, expr
);
8111 /* Deallocate the allocatable components of structures that are
8113 if ((expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
)
8114 && expr
->ts
.u
.derived
->attr
.alloc_comp
8115 && expr
->expr_type
!= EXPR_VARIABLE
)
8117 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, se
->expr
, expr
->rank
);
8119 /* The components shall be deallocated before their containing entity. */
8120 gfc_prepend_expr_to_block (&se
->post
, tmp
);
8122 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->expr_type
!= EXPR_FUNCTION
)
8123 se
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
8125 array_parameter_size (se
->expr
, expr
, size
);
8126 se
->expr
= gfc_conv_array_data (se
->expr
);
8130 if (this_array_result
)
8132 /* Result of the enclosing function. */
8133 gfc_conv_expr_descriptor (se
, expr
);
8135 array_parameter_size (se
->expr
, expr
, size
);
8136 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
8138 if (g77
&& TREE_TYPE (TREE_TYPE (se
->expr
)) != NULL_TREE
8139 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
8140 se
->expr
= gfc_conv_array_data (build_fold_indirect_ref_loc (input_location
,
8147 /* Every other type of array. */
8148 se
->want_pointer
= 1;
8149 gfc_conv_expr_descriptor (se
, expr
);
8152 array_parameter_size (build_fold_indirect_ref_loc (input_location
,
8157 /* Deallocate the allocatable components of structures that are
8158 not variable, for descriptorless arguments.
8159 Arguments with a descriptor are handled in gfc_conv_procedure_call. */
8160 if (g77
&& (expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
)
8161 && expr
->ts
.u
.derived
->attr
.alloc_comp
8162 && expr
->expr_type
!= EXPR_VARIABLE
)
8164 tmp
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
8165 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
, expr
->rank
);
8167 /* The components shall be deallocated before their containing entity. */
8168 gfc_prepend_expr_to_block (&se
->post
, tmp
);
8171 if (g77
|| (fsym
&& fsym
->attr
.contiguous
8172 && !gfc_is_simply_contiguous (expr
, false, true)))
8174 tree origptr
= NULL_TREE
;
8178 /* For contiguous arrays, save the original value of the descriptor. */
8181 origptr
= gfc_create_var (pvoid_type_node
, "origptr");
8182 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
8183 tmp
= gfc_conv_array_data (tmp
);
8184 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8185 TREE_TYPE (origptr
), origptr
,
8186 fold_convert (TREE_TYPE (origptr
), tmp
));
8187 gfc_add_expr_to_block (&se
->pre
, tmp
);
8190 /* Repack the array. */
8191 if (warn_array_temporaries
)
8194 gfc_warning (OPT_Warray_temporaries
,
8195 "Creating array temporary at %L for argument %qs",
8196 &expr
->where
, fsym
->name
);
8198 gfc_warning (OPT_Warray_temporaries
,
8199 "Creating array temporary at %L", &expr
->where
);
8202 /* When optmizing, we can use gfc_conv_subref_array_arg for
8203 making the packing and unpacking operation visible to the
8206 if (g77
&& flag_inline_arg_packing
&& expr
->expr_type
== EXPR_VARIABLE
8207 && !is_pointer (expr
) && ! gfc_has_dimen_vector_ref (expr
)
8208 && !(expr
->symtree
->n
.sym
->as
8209 && expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_RANK
)
8210 && (fsym
== NULL
|| fsym
->ts
.type
!= BT_ASSUMED
))
8212 gfc_conv_subref_array_arg (se
, expr
, g77
,
8213 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
8214 false, fsym
, proc_name
, sym
, true);
8218 ptr
= build_call_expr_loc (input_location
,
8219 gfor_fndecl_in_pack
, 1, desc
);
8221 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
8223 tmp
= gfc_conv_expr_present (sym
);
8224 ptr
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
8225 tmp
, fold_convert (TREE_TYPE (se
->expr
), ptr
),
8226 fold_convert (TREE_TYPE (se
->expr
), null_pointer_node
));
8229 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
8231 /* Use the packed data for the actual argument, except for contiguous arrays,
8232 where the descriptor's data component is set. */
8237 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
8239 gfc_ss
* ss
= gfc_walk_expr (expr
);
8240 if (!transposed_dims (ss
))
8241 gfc_conv_descriptor_data_set (&se
->pre
, tmp
, ptr
);
8244 tree old_field
, new_field
;
8246 /* The original descriptor has transposed dims so we can't reuse
8247 it directly; we have to create a new one. */
8248 tree old_desc
= tmp
;
8249 tree new_desc
= gfc_create_var (TREE_TYPE (old_desc
), "arg_desc");
8251 old_field
= gfc_conv_descriptor_dtype (old_desc
);
8252 new_field
= gfc_conv_descriptor_dtype (new_desc
);
8253 gfc_add_modify (&se
->pre
, new_field
, old_field
);
8255 old_field
= gfc_conv_descriptor_offset (old_desc
);
8256 new_field
= gfc_conv_descriptor_offset (new_desc
);
8257 gfc_add_modify (&se
->pre
, new_field
, old_field
);
8259 for (int i
= 0; i
< expr
->rank
; i
++)
8261 old_field
= gfc_conv_descriptor_dimension (old_desc
,
8262 gfc_rank_cst
[get_array_ref_dim_for_loop_dim (ss
, i
)]);
8263 new_field
= gfc_conv_descriptor_dimension (new_desc
,
8265 gfc_add_modify (&se
->pre
, new_field
, old_field
);
8268 if (flag_coarray
== GFC_FCOARRAY_LIB
8269 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (old_desc
))
8270 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (old_desc
))
8271 == GFC_ARRAY_ALLOCATABLE
)
8273 old_field
= gfc_conv_descriptor_token (old_desc
);
8274 new_field
= gfc_conv_descriptor_token (new_desc
);
8275 gfc_add_modify (&se
->pre
, new_field
, old_field
);
8278 gfc_conv_descriptor_data_set (&se
->pre
, new_desc
, ptr
);
8279 se
->expr
= gfc_build_addr_expr (NULL_TREE
, new_desc
);
8284 if (gfc_option
.rtcheck
& GFC_RTCHECK_ARRAY_TEMPS
)
8288 if (fsym
&& proc_name
)
8289 msg
= xasprintf ("An array temporary was created for argument "
8290 "'%s' of procedure '%s'", fsym
->name
, proc_name
);
8292 msg
= xasprintf ("An array temporary was created");
8294 tmp
= build_fold_indirect_ref_loc (input_location
,
8296 tmp
= gfc_conv_array_data (tmp
);
8297 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8298 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
8300 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
8301 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8303 gfc_conv_expr_present (sym
), tmp
);
8305 gfc_trans_runtime_check (false, true, tmp
, &se
->pre
,
8310 gfc_start_block (&block
);
8312 /* Copy the data back. */
8313 if (fsym
== NULL
|| fsym
->attr
.intent
!= INTENT_IN
)
8315 tmp
= build_call_expr_loc (input_location
,
8316 gfor_fndecl_in_unpack
, 2, desc
, ptr
);
8317 gfc_add_expr_to_block (&block
, tmp
);
8320 /* Free the temporary. */
8321 tmp
= gfc_call_free (ptr
);
8322 gfc_add_expr_to_block (&block
, tmp
);
8324 stmt
= gfc_finish_block (&block
);
8326 gfc_init_block (&block
);
8327 /* Only if it was repacked. This code needs to be executed before the
8328 loop cleanup code. */
8329 tmp
= build_fold_indirect_ref_loc (input_location
,
8331 tmp
= gfc_conv_array_data (tmp
);
8332 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8333 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
8335 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
8336 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8338 gfc_conv_expr_present (sym
), tmp
);
8340 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
8342 gfc_add_expr_to_block (&block
, tmp
);
8343 gfc_add_block_to_block (&block
, &se
->post
);
8345 gfc_init_block (&se
->post
);
8347 /* Reset the descriptor pointer. */
8350 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
8351 gfc_conv_descriptor_data_set (&se
->post
, tmp
, origptr
);
8354 gfc_add_block_to_block (&se
->post
, &block
);
8359 /* This helper function calculates the size in words of a full array. */
8362 gfc_full_array_size (stmtblock_t
*block
, tree decl
, int rank
)
8367 idx
= gfc_rank_cst
[rank
- 1];
8368 nelems
= gfc_conv_descriptor_ubound_get (decl
, idx
);
8369 tmp
= gfc_conv_descriptor_lbound_get (decl
, idx
);
8370 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
8372 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
8373 tmp
, gfc_index_one_node
);
8374 tmp
= gfc_evaluate_now (tmp
, block
);
8376 nelems
= gfc_conv_descriptor_stride_get (decl
, idx
);
8377 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8379 return gfc_evaluate_now (tmp
, block
);
8383 /* Allocate dest to the same size as src, and copy src -> dest.
8384 If no_malloc is set, only the copy is done. */
8387 duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
8388 bool no_malloc
, bool no_memcpy
, tree str_sz
,
8389 tree add_when_allocated
)
8398 /* If the source is null, set the destination to null. Then,
8399 allocate memory to the destination. */
8400 gfc_init_block (&block
);
8402 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
8404 gfc_add_modify (&block
, dest
, fold_convert (type
, null_pointer_node
));
8405 null_data
= gfc_finish_block (&block
);
8407 gfc_init_block (&block
);
8408 if (str_sz
!= NULL_TREE
)
8411 size
= TYPE_SIZE_UNIT (TREE_TYPE (type
));
8415 tmp
= gfc_call_malloc (&block
, type
, size
);
8416 gfc_add_modify (&block
, dest
, fold_convert (type
, tmp
));
8421 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8422 tmp
= build_call_expr_loc (input_location
, tmp
, 3, dest
, src
,
8423 fold_convert (size_type_node
, size
));
8424 gfc_add_expr_to_block (&block
, tmp
);
8429 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
8430 null_data
= gfc_finish_block (&block
);
8432 gfc_init_block (&block
);
8434 nelems
= gfc_full_array_size (&block
, src
, rank
);
8436 nelems
= gfc_index_one_node
;
8438 if (str_sz
!= NULL_TREE
)
8439 tmp
= fold_convert (gfc_array_index_type
, str_sz
);
8441 tmp
= fold_convert (gfc_array_index_type
,
8442 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
8443 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8447 tmp
= TREE_TYPE (gfc_conv_descriptor_data_get (src
));
8448 tmp
= gfc_call_malloc (&block
, tmp
, size
);
8449 gfc_conv_descriptor_data_set (&block
, dest
, tmp
);
8452 /* We know the temporary and the value will be the same length,
8453 so can use memcpy. */
8456 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8457 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
8458 gfc_conv_descriptor_data_get (dest
),
8459 gfc_conv_descriptor_data_get (src
),
8460 fold_convert (size_type_node
, size
));
8461 gfc_add_expr_to_block (&block
, tmp
);
8465 gfc_add_expr_to_block (&block
, add_when_allocated
);
8466 tmp
= gfc_finish_block (&block
);
8468 /* Null the destination if the source is null; otherwise do
8469 the allocate and copy. */
8470 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src
)))
8473 null_cond
= gfc_conv_descriptor_data_get (src
);
8475 null_cond
= convert (pvoid_type_node
, null_cond
);
8476 null_cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8477 null_cond
, null_pointer_node
);
8478 return build3_v (COND_EXPR
, null_cond
, tmp
, null_data
);
8482 /* Allocate dest to the same size as src, and copy data src -> dest. */
8485 gfc_duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
8486 tree add_when_allocated
)
8488 return duplicate_allocatable (dest
, src
, type
, rank
, false, false,
8489 NULL_TREE
, add_when_allocated
);
8493 /* Copy data src -> dest. */
8496 gfc_copy_allocatable_data (tree dest
, tree src
, tree type
, int rank
)
8498 return duplicate_allocatable (dest
, src
, type
, rank
, true, false,
8499 NULL_TREE
, NULL_TREE
);
8502 /* Allocate dest to the same size as src, but don't copy anything. */
8505 gfc_duplicate_allocatable_nocopy (tree dest
, tree src
, tree type
, int rank
)
8507 return duplicate_allocatable (dest
, src
, type
, rank
, false, true,
8508 NULL_TREE
, NULL_TREE
);
8513 duplicate_allocatable_coarray (tree dest
, tree dest_tok
, tree src
,
8514 tree type
, int rank
)
8521 stmtblock_t block
, globalblock
;
8523 /* If the source is null, set the destination to null. Then,
8524 allocate memory to the destination. */
8525 gfc_init_block (&block
);
8526 gfc_init_block (&globalblock
);
8528 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
8531 symbol_attribute attr
;
8534 gfc_init_se (&se
, NULL
);
8535 gfc_clear_attr (&attr
);
8536 attr
.allocatable
= 1;
8537 dummy_desc
= gfc_conv_scalar_to_descriptor (&se
, dest
, attr
);
8538 gfc_add_block_to_block (&globalblock
, &se
.pre
);
8539 size
= TYPE_SIZE_UNIT (TREE_TYPE (type
));
8541 gfc_add_modify (&block
, dest
, fold_convert (type
, null_pointer_node
));
8542 gfc_allocate_using_caf_lib (&block
, dummy_desc
, size
,
8543 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8544 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8545 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
8546 null_data
= gfc_finish_block (&block
);
8548 gfc_init_block (&block
);
8550 gfc_allocate_using_caf_lib (&block
, dummy_desc
,
8551 fold_convert (size_type_node
, size
),
8552 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8553 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8554 GFC_CAF_COARRAY_ALLOC
);
8556 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8557 tmp
= build_call_expr_loc (input_location
, tmp
, 3, dest
, src
,
8558 fold_convert (size_type_node
, size
));
8559 gfc_add_expr_to_block (&block
, tmp
);
8563 /* Set the rank or unitialized memory access may be reported. */
8564 tmp
= gfc_conv_descriptor_rank (dest
);
8565 gfc_add_modify (&globalblock
, tmp
, build_int_cst (TREE_TYPE (tmp
), rank
));
8568 nelems
= gfc_full_array_size (&block
, src
, rank
);
8570 nelems
= integer_one_node
;
8572 tmp
= fold_convert (size_type_node
,
8573 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
8574 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
8575 fold_convert (size_type_node
, nelems
), tmp
);
8577 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
8578 gfc_allocate_using_caf_lib (&block
, dest
, fold_convert (size_type_node
,
8580 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8581 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8582 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
8583 null_data
= gfc_finish_block (&block
);
8585 gfc_init_block (&block
);
8586 gfc_allocate_using_caf_lib (&block
, dest
,
8587 fold_convert (size_type_node
, size
),
8588 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8589 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8590 GFC_CAF_COARRAY_ALLOC
);
8592 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8593 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
8594 gfc_conv_descriptor_data_get (dest
),
8595 gfc_conv_descriptor_data_get (src
),
8596 fold_convert (size_type_node
, size
));
8597 gfc_add_expr_to_block (&block
, tmp
);
8600 tmp
= gfc_finish_block (&block
);
8602 /* Null the destination if the source is null; otherwise do
8603 the register and copy. */
8604 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src
)))
8607 null_cond
= gfc_conv_descriptor_data_get (src
);
8609 null_cond
= convert (pvoid_type_node
, null_cond
);
8610 null_cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8611 null_cond
, null_pointer_node
);
8612 gfc_add_expr_to_block (&globalblock
, build3_v (COND_EXPR
, null_cond
, tmp
,
8614 return gfc_finish_block (&globalblock
);
8618 /* Helper function to abstract whether coarray processing is enabled. */
8621 caf_enabled (int caf_mode
)
8623 return (caf_mode
& GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
)
8624 == GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
;
8628 /* Helper function to abstract whether coarray processing is enabled
8629 and we are in a derived type coarray. */
8632 caf_in_coarray (int caf_mode
)
8634 static const int pat
= GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
8635 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
;
8636 return (caf_mode
& pat
) == pat
;
8640 /* Helper function to abstract whether coarray is to deallocate only. */
8643 gfc_caf_is_dealloc_only (int caf_mode
)
8645 return (caf_mode
& GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY
)
8646 == GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY
;
8650 /* Recursively traverse an object of derived type, generating code to
8651 deallocate, nullify or copy allocatable components. This is the work horse
8652 function for the functions named in this enum. */
8654 enum {DEALLOCATE_ALLOC_COMP
= 1, NULLIFY_ALLOC_COMP
,
8655 COPY_ALLOC_COMP
, COPY_ONLY_ALLOC_COMP
, REASSIGN_CAF_COMP
,
8656 ALLOCATE_PDT_COMP
, DEALLOCATE_PDT_COMP
, CHECK_PDT_DUMMY
,
8659 static gfc_actual_arglist
*pdt_param_list
;
8662 structure_alloc_comps (gfc_symbol
* der_type
, tree decl
,
8663 tree dest
, int rank
, int purpose
, int caf_mode
,
8664 gfc_co_subroutines_args
*args
)
8668 stmtblock_t fnblock
;
8669 stmtblock_t loopbody
;
8670 stmtblock_t tmpblock
;
8681 tree null_cond
= NULL_TREE
;
8682 tree add_when_allocated
;
8683 tree dealloc_fndecl
;
8687 symbol_attribute
*attr
;
8688 bool deallocate_called
;
8690 gfc_init_block (&fnblock
);
8692 decl_type
= TREE_TYPE (decl
);
8694 if ((POINTER_TYPE_P (decl_type
))
8695 || (TREE_CODE (decl_type
) == REFERENCE_TYPE
&& rank
== 0))
8697 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
8698 /* Deref dest in sync with decl, but only when it is not NULL. */
8700 dest
= build_fold_indirect_ref_loc (input_location
, dest
);
8702 /* Update the decl_type because it got dereferenced. */
8703 decl_type
= TREE_TYPE (decl
);
8706 /* If this is an array of derived types with allocatable components
8707 build a loop and recursively call this function. */
8708 if (TREE_CODE (decl_type
) == ARRAY_TYPE
8709 || (GFC_DESCRIPTOR_TYPE_P (decl_type
) && rank
!= 0))
8711 tmp
= gfc_conv_array_data (decl
);
8712 var
= build_fold_indirect_ref_loc (input_location
, tmp
);
8714 /* Get the number of elements - 1 and set the counter. */
8715 if (GFC_DESCRIPTOR_TYPE_P (decl_type
))
8717 /* Use the descriptor for an allocatable array. Since this
8718 is a full array reference, we only need the descriptor
8719 information from dimension = rank. */
8720 tmp
= gfc_full_array_size (&fnblock
, decl
, rank
);
8721 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8722 gfc_array_index_type
, tmp
,
8723 gfc_index_one_node
);
8725 null_cond
= gfc_conv_descriptor_data_get (decl
);
8726 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
8727 logical_type_node
, null_cond
,
8728 build_int_cst (TREE_TYPE (null_cond
), 0));
8732 /* Otherwise use the TYPE_DOMAIN information. */
8733 tmp
= array_type_nelts (decl_type
);
8734 tmp
= fold_convert (gfc_array_index_type
, tmp
);
8737 /* Remember that this is, in fact, the no. of elements - 1. */
8738 nelems
= gfc_evaluate_now (tmp
, &fnblock
);
8739 index
= gfc_create_var (gfc_array_index_type
, "S");
8741 /* Build the body of the loop. */
8742 gfc_init_block (&loopbody
);
8744 vref
= gfc_build_array_ref (var
, index
, NULL
);
8746 if (purpose
== COPY_ALLOC_COMP
|| purpose
== COPY_ONLY_ALLOC_COMP
)
8748 tmp
= build_fold_indirect_ref_loc (input_location
,
8749 gfc_conv_array_data (dest
));
8750 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
8751 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
,
8752 COPY_ALLOC_COMP
, caf_mode
, args
);
8755 tmp
= structure_alloc_comps (der_type
, vref
, NULL_TREE
, rank
, purpose
,
8758 gfc_add_expr_to_block (&loopbody
, tmp
);
8760 /* Build the loop and return. */
8761 gfc_init_loopinfo (&loop
);
8763 loop
.from
[0] = gfc_index_zero_node
;
8764 loop
.loopvar
[0] = index
;
8765 loop
.to
[0] = nelems
;
8766 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
8767 gfc_add_block_to_block (&fnblock
, &loop
.pre
);
8769 tmp
= gfc_finish_block (&fnblock
);
8770 /* When copying allocateable components, the above implements the
8771 deep copy. Nevertheless is a deep copy only allowed, when the current
8772 component is allocated, for which code will be generated in
8773 gfc_duplicate_allocatable (), where the deep copy code is just added
8774 into the if's body, by adding tmp (the deep copy code) as last
8775 argument to gfc_duplicate_allocatable (). */
8776 if (purpose
== COPY_ALLOC_COMP
8777 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
8778 tmp
= gfc_duplicate_allocatable (dest
, decl
, decl_type
, rank
,
8780 else if (null_cond
!= NULL_TREE
)
8781 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
8782 build_empty_stmt (input_location
));
8787 if (purpose
== DEALLOCATE_ALLOC_COMP
&& der_type
->attr
.pdt_type
)
8789 tmp
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
8790 DEALLOCATE_PDT_COMP
, 0, args
);
8791 gfc_add_expr_to_block (&fnblock
, tmp
);
8793 else if (purpose
== ALLOCATE_PDT_COMP
&& der_type
->attr
.alloc_comp
)
8795 tmp
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
8796 NULLIFY_ALLOC_COMP
, 0, args
);
8797 gfc_add_expr_to_block (&fnblock
, tmp
);
8800 /* Otherwise, act on the components or recursively call self to
8801 act on a chain of components. */
8802 for (c
= der_type
->components
; c
; c
= c
->next
)
8804 bool cmp_has_alloc_comps
= (c
->ts
.type
== BT_DERIVED
8805 || c
->ts
.type
== BT_CLASS
)
8806 && c
->ts
.u
.derived
->attr
.alloc_comp
;
8807 bool same_type
= (c
->ts
.type
== BT_DERIVED
&& der_type
== c
->ts
.u
.derived
)
8808 || (c
->ts
.type
== BT_CLASS
&& der_type
== CLASS_DATA (c
)->ts
.u
.derived
);
8810 bool is_pdt_type
= c
->ts
.type
== BT_DERIVED
8811 && c
->ts
.u
.derived
->attr
.pdt_type
;
8813 cdecl = c
->backend_decl
;
8814 ctype
= TREE_TYPE (cdecl);
8819 case BCAST_ALLOC_COMP
:
8823 stmtblock_t derived_type_block
;
8825 gfc_init_block (&tmpblock
);
8827 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8828 decl
, cdecl, NULL_TREE
);
8830 /* Shortcut to get the attributes of the component. */
8831 if (c
->ts
.type
== BT_CLASS
)
8833 attr
= &CLASS_DATA (c
)->attr
;
8834 if (attr
->class_pointer
)
8844 add_when_allocated
= NULL_TREE
;
8845 if (cmp_has_alloc_comps
8846 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
)
8848 if (c
->ts
.type
== BT_CLASS
)
8850 rank
= CLASS_DATA (c
)->as
? CLASS_DATA (c
)->as
->rank
: 0;
8852 = structure_alloc_comps (CLASS_DATA (c
)->ts
.u
.derived
,
8853 comp
, NULL_TREE
, rank
, purpose
,
8858 rank
= c
->as
? c
->as
->rank
: 0;
8859 add_when_allocated
= structure_alloc_comps (c
->ts
.u
.derived
,
8866 gfc_init_block (&derived_type_block
);
8867 if (add_when_allocated
)
8868 gfc_add_expr_to_block (&derived_type_block
, add_when_allocated
);
8869 tmp
= gfc_finish_block (&derived_type_block
);
8870 gfc_add_expr_to_block (&tmpblock
, tmp
);
8872 /* Convert the component into a rank 1 descriptor type. */
8873 if (attr
->dimension
)
8875 tmp
= gfc_get_element_type (TREE_TYPE (comp
));
8876 ubound
= gfc_full_array_size (&tmpblock
, comp
,
8877 c
->ts
.type
== BT_CLASS
8878 ? CLASS_DATA (c
)->as
->rank
8883 tmp
= TREE_TYPE (comp
);
8884 ubound
= build_int_cst (gfc_array_index_type
, 1);
8887 cdesc
= gfc_get_array_type_bounds (tmp
, 1, 0, &gfc_index_one_node
,
8889 GFC_ARRAY_ALLOCATABLE
, false);
8891 cdesc
= gfc_create_var (cdesc
, "cdesc");
8892 DECL_ARTIFICIAL (cdesc
) = 1;
8894 gfc_add_modify (&tmpblock
, gfc_conv_descriptor_dtype (cdesc
),
8895 gfc_get_dtype_rank_type (1, tmp
));
8896 gfc_conv_descriptor_lbound_set (&tmpblock
, cdesc
,
8897 gfc_index_zero_node
,
8898 gfc_index_one_node
);
8899 gfc_conv_descriptor_stride_set (&tmpblock
, cdesc
,
8900 gfc_index_zero_node
,
8901 gfc_index_one_node
);
8902 gfc_conv_descriptor_ubound_set (&tmpblock
, cdesc
,
8903 gfc_index_zero_node
, ubound
);
8905 if (attr
->dimension
)
8906 comp
= gfc_conv_descriptor_data_get (comp
);
8911 gfc_init_se (&se
, NULL
);
8913 comp
= gfc_conv_scalar_to_descriptor (&se
, comp
,
8914 c
->ts
.type
== BT_CLASS
8915 ? CLASS_DATA (c
)->attr
8917 comp
= gfc_build_addr_expr (NULL_TREE
, comp
);
8918 gfc_add_block_to_block (&tmpblock
, &se
.pre
);
8921 gfc_conv_descriptor_data_set (&tmpblock
, cdesc
, comp
);
8925 fndecl
= build_call_expr_loc (input_location
,
8926 gfor_fndecl_co_broadcast
, 5,
8927 gfc_build_addr_expr (pvoid_type_node
,cdesc
),
8929 null_pointer_node
, null_pointer_node
,
8932 gfc_add_expr_to_block (&tmpblock
, fndecl
);
8933 gfc_add_block_to_block (&fnblock
, &tmpblock
);
8937 case DEALLOCATE_ALLOC_COMP
:
8939 gfc_init_block (&tmpblock
);
8941 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8942 decl
, cdecl, NULL_TREE
);
8944 /* Shortcut to get the attributes of the component. */
8945 if (c
->ts
.type
== BT_CLASS
)
8947 attr
= &CLASS_DATA (c
)->attr
;
8948 if (attr
->class_pointer
)
8958 if ((c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
)
8959 || (c
->ts
.type
== BT_CLASS
&& !CLASS_DATA (c
)->attr
.class_pointer
))
8960 /* Call the finalizer, which will free the memory and nullify the
8961 pointer of an array. */
8962 deallocate_called
= gfc_add_comp_finalizer_call (&tmpblock
, comp
, c
,
8963 caf_enabled (caf_mode
))
8966 deallocate_called
= false;
8968 /* Add the _class ref for classes. */
8969 if (c
->ts
.type
== BT_CLASS
&& attr
->allocatable
)
8970 comp
= gfc_class_data_get (comp
);
8972 add_when_allocated
= NULL_TREE
;
8973 if (cmp_has_alloc_comps
8974 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
8976 && !deallocate_called
)
8978 /* Add checked deallocation of the components. This code is
8979 obviously added because the finalizer is not trusted to free
8981 if (c
->ts
.type
== BT_CLASS
)
8983 rank
= CLASS_DATA (c
)->as
? CLASS_DATA (c
)->as
->rank
: 0;
8985 = structure_alloc_comps (CLASS_DATA (c
)->ts
.u
.derived
,
8986 comp
, NULL_TREE
, rank
, purpose
,
8991 rank
= c
->as
? c
->as
->rank
: 0;
8992 add_when_allocated
= structure_alloc_comps (c
->ts
.u
.derived
,
8999 if (attr
->allocatable
&& !same_type
9000 && (!attr
->codimension
|| caf_enabled (caf_mode
)))
9002 /* Handle all types of components besides components of the
9003 same_type as the current one, because those would create an
9006 = (caf_in_coarray (caf_mode
) || attr
->codimension
)
9007 ? (gfc_caf_is_dealloc_only (caf_mode
)
9008 ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
9009 : GFC_CAF_COARRAY_DEREGISTER
)
9010 : GFC_CAF_COARRAY_NOCOARRAY
;
9012 caf_token
= NULL_TREE
;
9013 /* Coarray components are handled directly by
9014 deallocate_with_status. */
9015 if (!attr
->codimension
9016 && caf_dereg_mode
!= GFC_CAF_COARRAY_NOCOARRAY
)
9019 caf_token
= fold_build3_loc (input_location
, COMPONENT_REF
,
9020 TREE_TYPE (c
->caf_token
),
9021 decl
, c
->caf_token
, NULL_TREE
);
9022 else if (attr
->dimension
&& !attr
->proc_pointer
)
9023 caf_token
= gfc_conv_descriptor_token (comp
);
9025 if (attr
->dimension
&& !attr
->codimension
&& !attr
->proc_pointer
)
9026 /* When this is an array but not in conjunction with a coarray
9027 then add the data-ref. For coarray'ed arrays the data-ref
9028 is added by deallocate_with_status. */
9029 comp
= gfc_conv_descriptor_data_get (comp
);
9031 tmp
= gfc_deallocate_with_status (comp
, NULL_TREE
, NULL_TREE
,
9032 NULL_TREE
, NULL_TREE
, true,
9033 NULL
, caf_dereg_mode
,
9034 add_when_allocated
, caf_token
);
9036 gfc_add_expr_to_block (&tmpblock
, tmp
);
9038 else if (attr
->allocatable
&& !attr
->codimension
9039 && !deallocate_called
)
9041 /* Case of recursive allocatable derived types. */
9045 stmtblock_t dealloc_block
;
9047 gfc_init_block (&dealloc_block
);
9048 if (add_when_allocated
)
9049 gfc_add_expr_to_block (&dealloc_block
, add_when_allocated
);
9051 /* Convert the component into a rank 1 descriptor type. */
9052 if (attr
->dimension
)
9054 tmp
= gfc_get_element_type (TREE_TYPE (comp
));
9055 ubound
= gfc_full_array_size (&dealloc_block
, comp
,
9056 c
->ts
.type
== BT_CLASS
9057 ? CLASS_DATA (c
)->as
->rank
9062 tmp
= TREE_TYPE (comp
);
9063 ubound
= build_int_cst (gfc_array_index_type
, 1);
9066 cdesc
= gfc_get_array_type_bounds (tmp
, 1, 0, &gfc_index_one_node
,
9068 GFC_ARRAY_ALLOCATABLE
, false);
9070 cdesc
= gfc_create_var (cdesc
, "cdesc");
9071 DECL_ARTIFICIAL (cdesc
) = 1;
9073 gfc_add_modify (&dealloc_block
, gfc_conv_descriptor_dtype (cdesc
),
9074 gfc_get_dtype_rank_type (1, tmp
));
9075 gfc_conv_descriptor_lbound_set (&dealloc_block
, cdesc
,
9076 gfc_index_zero_node
,
9077 gfc_index_one_node
);
9078 gfc_conv_descriptor_stride_set (&dealloc_block
, cdesc
,
9079 gfc_index_zero_node
,
9080 gfc_index_one_node
);
9081 gfc_conv_descriptor_ubound_set (&dealloc_block
, cdesc
,
9082 gfc_index_zero_node
, ubound
);
9084 if (attr
->dimension
)
9085 comp
= gfc_conv_descriptor_data_get (comp
);
9087 gfc_conv_descriptor_data_set (&dealloc_block
, cdesc
, comp
);
9089 /* Now call the deallocator. */
9090 vtab
= gfc_find_vtab (&c
->ts
);
9091 if (vtab
->backend_decl
== NULL
)
9092 gfc_get_symbol_decl (vtab
);
9093 tmp
= gfc_build_addr_expr (NULL_TREE
, vtab
->backend_decl
);
9094 dealloc_fndecl
= gfc_vptr_deallocate_get (tmp
);
9095 dealloc_fndecl
= build_fold_indirect_ref_loc (input_location
,
9097 tmp
= build_int_cst (TREE_TYPE (comp
), 0);
9098 is_allocated
= fold_build2_loc (input_location
, NE_EXPR
,
9099 logical_type_node
, tmp
,
9101 cdesc
= gfc_build_addr_expr (NULL_TREE
, cdesc
);
9103 tmp
= build_call_expr_loc (input_location
,
9106 gfc_add_expr_to_block (&dealloc_block
, tmp
);
9108 tmp
= gfc_finish_block (&dealloc_block
);
9110 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
9111 void_type_node
, is_allocated
, tmp
,
9112 build_empty_stmt (input_location
));
9114 gfc_add_expr_to_block (&tmpblock
, tmp
);
9116 else if (add_when_allocated
)
9117 gfc_add_expr_to_block (&tmpblock
, add_when_allocated
);
9119 if (c
->ts
.type
== BT_CLASS
&& attr
->allocatable
9120 && (!attr
->codimension
|| !caf_enabled (caf_mode
)))
9122 /* Finally, reset the vptr to the declared type vtable and, if
9123 necessary reset the _len field.
9125 First recover the reference to the component and obtain
9127 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9128 decl
, cdecl, NULL_TREE
);
9129 tmp
= gfc_class_vptr_get (comp
);
9131 if (UNLIMITED_POLY (c
))
9133 /* Both vptr and _len field should be nulled. */
9134 gfc_add_modify (&tmpblock
, tmp
,
9135 build_int_cst (TREE_TYPE (tmp
), 0));
9136 tmp
= gfc_class_len_get (comp
);
9137 gfc_add_modify (&tmpblock
, tmp
,
9138 build_int_cst (TREE_TYPE (tmp
), 0));
9142 /* Build the vtable address and set the vptr with it. */
9145 vtable
= gfc_find_derived_vtab (c
->ts
.u
.derived
);
9146 vtab
= vtable
->backend_decl
;
9147 if (vtab
== NULL_TREE
)
9148 vtab
= gfc_get_symbol_decl (vtable
);
9149 vtab
= gfc_build_addr_expr (NULL
, vtab
);
9150 vtab
= fold_convert (TREE_TYPE (tmp
), vtab
);
9151 gfc_add_modify (&tmpblock
, tmp
, vtab
);
9155 /* Now add the deallocation of this component. */
9156 gfc_add_block_to_block (&fnblock
, &tmpblock
);
9159 case NULLIFY_ALLOC_COMP
:
9161 - allocatable components (regular or in class)
9162 - components that have allocatable components
9163 - pointer components when in a coarray.
9164 Skip everything else especially proc_pointers, which may come
9165 coupled with the regular pointer attribute. */
9166 if (c
->attr
.proc_pointer
9167 || !(c
->attr
.allocatable
|| (c
->ts
.type
== BT_CLASS
9168 && CLASS_DATA (c
)->attr
.allocatable
)
9169 || (cmp_has_alloc_comps
9170 && ((c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
)
9171 || (c
->ts
.type
== BT_CLASS
9172 && !CLASS_DATA (c
)->attr
.class_pointer
)))
9173 || (caf_in_coarray (caf_mode
) && c
->attr
.pointer
)))
9176 /* Process class components first, because they always have the
9177 pointer-attribute set which would be caught wrong else. */
9178 if (c
->ts
.type
== BT_CLASS
9179 && (CLASS_DATA (c
)->attr
.allocatable
9180 || CLASS_DATA (c
)->attr
.class_pointer
))
9184 /* Allocatable CLASS components. */
9185 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9186 decl
, cdecl, NULL_TREE
);
9188 vptr_decl
= gfc_class_vptr_get (comp
);
9190 comp
= gfc_class_data_get (comp
);
9191 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp
)))
9192 gfc_conv_descriptor_data_set (&fnblock
, comp
,
9196 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
9197 void_type_node
, comp
,
9198 build_int_cst (TREE_TYPE (comp
), 0));
9199 gfc_add_expr_to_block (&fnblock
, tmp
);
9202 /* The dynamic type of a disassociated pointer or unallocated
9203 allocatable variable is its declared type. An unlimited
9204 polymorphic entity has no declared type. */
9205 if (!UNLIMITED_POLY (c
))
9207 vtab
= gfc_find_derived_vtab (c
->ts
.u
.derived
);
9208 if (!vtab
->backend_decl
)
9209 gfc_get_symbol_decl (vtab
);
9210 tmp
= gfc_build_addr_expr (NULL_TREE
, vtab
->backend_decl
);
9213 tmp
= build_int_cst (TREE_TYPE (vptr_decl
), 0);
9215 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
9216 void_type_node
, vptr_decl
, tmp
);
9217 gfc_add_expr_to_block (&fnblock
, tmp
);
9219 cmp_has_alloc_comps
= false;
9221 /* Coarrays need the component to be nulled before the api-call
9223 else if (c
->attr
.pointer
|| c
->attr
.allocatable
)
9225 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9226 decl
, cdecl, NULL_TREE
);
9227 if (c
->attr
.dimension
|| c
->attr
.codimension
)
9228 gfc_conv_descriptor_data_set (&fnblock
, comp
,
9231 gfc_add_modify (&fnblock
, comp
,
9232 build_int_cst (TREE_TYPE (comp
), 0));
9233 if (gfc_deferred_strlen (c
, &comp
))
9235 comp
= fold_build3_loc (input_location
, COMPONENT_REF
,
9237 decl
, comp
, NULL_TREE
);
9238 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
9239 TREE_TYPE (comp
), comp
,
9240 build_int_cst (TREE_TYPE (comp
), 0));
9241 gfc_add_expr_to_block (&fnblock
, tmp
);
9243 cmp_has_alloc_comps
= false;
9246 if (flag_coarray
== GFC_FCOARRAY_LIB
&& caf_in_coarray (caf_mode
))
9248 /* Register a component of a derived type coarray with the
9249 coarray library. Do not register ultimate component
9250 coarrays here. They are treated like regular coarrays and
9251 are either allocated on all images or on none. */
9254 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9255 decl
, cdecl, NULL_TREE
);
9256 if (c
->attr
.dimension
)
9258 /* Set the dtype, because caf_register needs it. */
9259 gfc_add_modify (&fnblock
, gfc_conv_descriptor_dtype (comp
),
9260 gfc_get_dtype (TREE_TYPE (comp
)));
9261 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9262 decl
, cdecl, NULL_TREE
);
9263 token
= gfc_conv_descriptor_token (tmp
);
9269 gfc_init_se (&se
, NULL
);
9270 token
= fold_build3_loc (input_location
, COMPONENT_REF
,
9271 pvoid_type_node
, decl
, c
->caf_token
,
9273 comp
= gfc_conv_scalar_to_descriptor (&se
, comp
,
9274 c
->ts
.type
== BT_CLASS
9275 ? CLASS_DATA (c
)->attr
9277 gfc_add_block_to_block (&fnblock
, &se
.pre
);
9280 gfc_allocate_using_caf_lib (&fnblock
, comp
, size_zero_node
,
9281 gfc_build_addr_expr (NULL_TREE
,
9283 NULL_TREE
, NULL_TREE
, NULL_TREE
,
9284 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
9287 if (cmp_has_alloc_comps
)
9289 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9290 decl
, cdecl, NULL_TREE
);
9291 rank
= c
->as
? c
->as
->rank
: 0;
9292 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
9293 rank
, purpose
, caf_mode
, args
);
9294 gfc_add_expr_to_block (&fnblock
, tmp
);
9298 case REASSIGN_CAF_COMP
:
9299 if (caf_enabled (caf_mode
)
9300 && (c
->attr
.codimension
9301 || (c
->ts
.type
== BT_CLASS
9302 && (CLASS_DATA (c
)->attr
.coarray_comp
9303 || caf_in_coarray (caf_mode
)))
9304 || (c
->ts
.type
== BT_DERIVED
9305 && (c
->ts
.u
.derived
->attr
.coarray_comp
9306 || caf_in_coarray (caf_mode
))))
9309 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9310 decl
, cdecl, NULL_TREE
);
9311 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9312 dest
, cdecl, NULL_TREE
);
9314 if (c
->attr
.codimension
)
9316 if (c
->ts
.type
== BT_CLASS
)
9318 comp
= gfc_class_data_get (comp
);
9319 dcmp
= gfc_class_data_get (dcmp
);
9321 gfc_conv_descriptor_data_set (&fnblock
, dcmp
,
9322 gfc_conv_descriptor_data_get (comp
));
9326 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, dcmp
,
9327 rank
, purpose
, caf_mode
9328 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
,
9330 gfc_add_expr_to_block (&fnblock
, tmp
);
9335 case COPY_ALLOC_COMP
:
9336 if (c
->attr
.pointer
|| c
->attr
.proc_pointer
)
9339 /* We need source and destination components. */
9340 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, decl
,
9342 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, dest
,
9344 dcmp
= fold_convert (TREE_TYPE (comp
), dcmp
);
9346 if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
9354 dst_data
= gfc_class_data_get (dcmp
);
9355 src_data
= gfc_class_data_get (comp
);
9356 size
= fold_convert (size_type_node
,
9357 gfc_class_vtab_size_get (comp
));
9359 if (CLASS_DATA (c
)->attr
.dimension
)
9361 nelems
= gfc_conv_descriptor_size (src_data
,
9362 CLASS_DATA (c
)->as
->rank
);
9363 size
= fold_build2_loc (input_location
, MULT_EXPR
,
9364 size_type_node
, size
,
9365 fold_convert (size_type_node
,
9369 nelems
= build_int_cst (size_type_node
, 1);
9371 if (CLASS_DATA (c
)->attr
.dimension
9372 || CLASS_DATA (c
)->attr
.codimension
)
9374 src_data
= gfc_conv_descriptor_data_get (src_data
);
9375 dst_data
= gfc_conv_descriptor_data_get (dst_data
);
9378 gfc_init_block (&tmpblock
);
9380 gfc_add_modify (&tmpblock
, gfc_class_vptr_get (dcmp
),
9381 gfc_class_vptr_get (comp
));
9383 /* Copy the unlimited '_len' field. If it is greater than zero
9384 (ie. a character(_len)), multiply it by size and use this
9385 for the malloc call. */
9386 if (UNLIMITED_POLY (c
))
9388 gfc_add_modify (&tmpblock
, gfc_class_len_get (dcmp
),
9389 gfc_class_len_get (comp
));
9390 size
= gfc_resize_class_size_with_len (&tmpblock
, comp
, size
);
9393 /* Coarray component have to have the same allocation status and
9394 shape/type-parameter/effective-type on the LHS and RHS of an
9395 intrinsic assignment. Hence, we did not deallocated them - and
9396 do not allocate them here. */
9397 if (!CLASS_DATA (c
)->attr
.codimension
)
9399 ftn_tree
= builtin_decl_explicit (BUILT_IN_MALLOC
);
9400 tmp
= build_call_expr_loc (input_location
, ftn_tree
, 1, size
);
9401 gfc_add_modify (&tmpblock
, dst_data
,
9402 fold_convert (TREE_TYPE (dst_data
), tmp
));
9405 tmp
= gfc_copy_class_to_class (comp
, dcmp
, nelems
,
9406 UNLIMITED_POLY (c
));
9407 gfc_add_expr_to_block (&tmpblock
, tmp
);
9408 tmp
= gfc_finish_block (&tmpblock
);
9410 gfc_init_block (&tmpblock
);
9411 gfc_add_modify (&tmpblock
, dst_data
,
9412 fold_convert (TREE_TYPE (dst_data
),
9413 null_pointer_node
));
9414 null_data
= gfc_finish_block (&tmpblock
);
9416 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
9417 logical_type_node
, src_data
,
9420 gfc_add_expr_to_block (&fnblock
, build3_v (COND_EXPR
, null_cond
,
9425 /* To implement guarded deep copy, i.e., deep copy only allocatable
9426 components that are really allocated, the deep copy code has to
9427 be generated first and then added to the if-block in
9428 gfc_duplicate_allocatable (). */
9429 if (cmp_has_alloc_comps
&& !c
->attr
.proc_pointer
&& !same_type
)
9431 rank
= c
->as
? c
->as
->rank
: 0;
9432 tmp
= fold_convert (TREE_TYPE (dcmp
), comp
);
9433 gfc_add_modify (&fnblock
, dcmp
, tmp
);
9434 add_when_allocated
= structure_alloc_comps (c
->ts
.u
.derived
,
9440 add_when_allocated
= NULL_TREE
;
9442 if (gfc_deferred_strlen (c
, &tmp
))
9446 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
9448 decl
, len
, NULL_TREE
);
9449 len
= fold_build3_loc (input_location
, COMPONENT_REF
,
9451 dest
, len
, NULL_TREE
);
9452 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
9453 TREE_TYPE (len
), len
, tmp
);
9454 gfc_add_expr_to_block (&fnblock
, tmp
);
9455 size
= size_of_string_in_bytes (c
->ts
.kind
, len
);
9456 /* This component cannot have allocatable components,
9457 therefore add_when_allocated of duplicate_allocatable ()
9459 tmp
= duplicate_allocatable (dcmp
, comp
, ctype
, rank
,
9460 false, false, size
, NULL_TREE
);
9461 gfc_add_expr_to_block (&fnblock
, tmp
);
9463 else if (c
->attr
.pdt_array
)
9465 tmp
= duplicate_allocatable (dcmp
, comp
, ctype
,
9466 c
->as
? c
->as
->rank
: 0,
9467 false, false, NULL_TREE
, NULL_TREE
);
9468 gfc_add_expr_to_block (&fnblock
, tmp
);
9470 else if ((c
->attr
.allocatable
)
9471 && !c
->attr
.proc_pointer
&& !same_type
9472 && (!(cmp_has_alloc_comps
&& c
->as
) || c
->attr
.codimension
9473 || caf_in_coarray (caf_mode
)))
9475 rank
= c
->as
? c
->as
->rank
: 0;
9476 if (c
->attr
.codimension
)
9477 tmp
= gfc_copy_allocatable_data (dcmp
, comp
, ctype
, rank
);
9478 else if (flag_coarray
== GFC_FCOARRAY_LIB
9479 && caf_in_coarray (caf_mode
))
9483 dst_tok
= gfc_conv_descriptor_token (dcmp
);
9486 /* For a scalar allocatable component the caf_token is
9487 the next component. */
9489 c
->caf_token
= c
->next
->backend_decl
;
9490 dst_tok
= fold_build3_loc (input_location
,
9492 pvoid_type_node
, dest
,
9496 tmp
= duplicate_allocatable_coarray (dcmp
, dst_tok
, comp
,
9500 tmp
= gfc_duplicate_allocatable (dcmp
, comp
, ctype
, rank
,
9501 add_when_allocated
);
9502 gfc_add_expr_to_block (&fnblock
, tmp
);
9505 if (cmp_has_alloc_comps
|| is_pdt_type
)
9506 gfc_add_expr_to_block (&fnblock
, add_when_allocated
);
9510 case ALLOCATE_PDT_COMP
:
9512 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9513 decl
, cdecl, NULL_TREE
);
9515 /* Set the PDT KIND and LEN fields. */
9516 if (c
->attr
.pdt_kind
|| c
->attr
.pdt_len
)
9519 gfc_expr
*c_expr
= NULL
;
9520 gfc_actual_arglist
*param
= pdt_param_list
;
9521 gfc_init_se (&tse
, NULL
);
9522 for (; param
; param
= param
->next
)
9523 if (param
->name
&& !strcmp (c
->name
, param
->name
))
9524 c_expr
= param
->expr
;
9527 c_expr
= c
->initializer
;
9531 gfc_conv_expr_type (&tse
, c_expr
, TREE_TYPE (comp
));
9532 gfc_add_modify (&fnblock
, comp
, tse
.expr
);
9536 if (c
->attr
.pdt_string
)
9539 gfc_init_se (&tse
, NULL
);
9540 tree strlen
= NULL_TREE
;
9541 gfc_expr
*e
= gfc_copy_expr (c
->ts
.u
.cl
->length
);
9542 /* Convert the parameterized string length to its value. The
9543 string length is stored in a hidden field in the same way as
9544 deferred string lengths. */
9545 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9546 if (gfc_deferred_strlen (c
, &strlen
) && strlen
!= NULL_TREE
)
9548 gfc_conv_expr_type (&tse
, e
,
9549 TREE_TYPE (strlen
));
9550 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
9552 decl
, strlen
, NULL_TREE
);
9553 gfc_add_modify (&fnblock
, strlen
, tse
.expr
);
9554 c
->ts
.u
.cl
->backend_decl
= strlen
;
9558 /* Scalar parameterized strings can be allocated now. */
9561 tmp
= fold_convert (gfc_array_index_type
, strlen
);
9562 tmp
= size_of_string_in_bytes (c
->ts
.kind
, tmp
);
9563 tmp
= gfc_evaluate_now (tmp
, &fnblock
);
9564 tmp
= gfc_call_malloc (&fnblock
, TREE_TYPE (comp
), tmp
);
9565 gfc_add_modify (&fnblock
, comp
, tmp
);
9569 /* Allocate parameterized arrays of parameterized derived types. */
9570 if (!(c
->attr
.pdt_array
&& c
->as
&& c
->as
->type
== AS_EXPLICIT
)
9571 && !((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9572 && (c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
)))
9575 if (c
->ts
.type
== BT_CLASS
)
9576 comp
= gfc_class_data_get (comp
);
9578 if (c
->attr
.pdt_array
)
9582 tree size
= gfc_index_one_node
;
9583 tree offset
= gfc_index_zero_node
;
9587 /* This chunk takes the expressions for 'lower' and 'upper'
9588 in the arrayspec and substitutes in the expressions for
9589 the parameters from 'pdt_param_list'. The descriptor
9590 fields can then be filled from the values so obtained. */
9591 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp
)));
9592 for (i
= 0; i
< c
->as
->rank
; i
++)
9594 gfc_init_se (&tse
, NULL
);
9595 e
= gfc_copy_expr (c
->as
->lower
[i
]);
9596 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9597 gfc_conv_expr_type (&tse
, e
, gfc_array_index_type
);
9600 gfc_conv_descriptor_lbound_set (&fnblock
, comp
,
9603 e
= gfc_copy_expr (c
->as
->upper
[i
]);
9604 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9605 gfc_conv_expr_type (&tse
, e
, gfc_array_index_type
);
9608 gfc_conv_descriptor_ubound_set (&fnblock
, comp
,
9611 gfc_conv_descriptor_stride_set (&fnblock
, comp
,
9614 size
= gfc_evaluate_now (size
, &fnblock
);
9615 offset
= fold_build2_loc (input_location
,
9617 gfc_array_index_type
,
9619 offset
= gfc_evaluate_now (offset
, &fnblock
);
9620 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9621 gfc_array_index_type
,
9623 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9624 gfc_array_index_type
,
9625 tmp
, gfc_index_one_node
);
9626 size
= fold_build2_loc (input_location
, MULT_EXPR
,
9627 gfc_array_index_type
, size
, tmp
);
9629 gfc_conv_descriptor_offset_set (&fnblock
, comp
, offset
);
9630 if (c
->ts
.type
== BT_CLASS
)
9632 tmp
= gfc_get_vptr_from_expr (comp
);
9633 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
9634 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
9635 tmp
= gfc_vptr_size_get (tmp
);
9638 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (ctype
));
9639 tmp
= fold_convert (gfc_array_index_type
, tmp
);
9640 size
= fold_build2_loc (input_location
, MULT_EXPR
,
9641 gfc_array_index_type
, size
, tmp
);
9642 size
= gfc_evaluate_now (size
, &fnblock
);
9643 tmp
= gfc_call_malloc (&fnblock
, NULL
, size
);
9644 gfc_conv_descriptor_data_set (&fnblock
, comp
, tmp
);
9645 tmp
= gfc_conv_descriptor_dtype (comp
);
9646 gfc_add_modify (&fnblock
, tmp
, gfc_get_dtype (ctype
));
9648 if (c
->initializer
&& c
->initializer
->rank
)
9650 gfc_init_se (&tse
, NULL
);
9651 e
= gfc_copy_expr (c
->initializer
);
9652 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9653 gfc_conv_expr_descriptor (&tse
, e
);
9654 gfc_add_block_to_block (&fnblock
, &tse
.pre
);
9656 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
9657 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
9658 gfc_conv_descriptor_data_get (comp
),
9659 gfc_conv_descriptor_data_get (tse
.expr
),
9660 fold_convert (size_type_node
, size
));
9661 gfc_add_expr_to_block (&fnblock
, tmp
);
9662 gfc_add_block_to_block (&fnblock
, &tse
.post
);
9666 /* Recurse in to PDT components. */
9667 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9668 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
9669 && !(c
->attr
.pointer
|| c
->attr
.allocatable
))
9671 bool is_deferred
= false;
9672 gfc_actual_arglist
*tail
= c
->param_list
;
9674 for (; tail
; tail
= tail
->next
)
9678 tail
= is_deferred
? pdt_param_list
: c
->param_list
;
9679 tmp
= gfc_allocate_pdt_comp (c
->ts
.u
.derived
, comp
,
9680 c
->as
? c
->as
->rank
: 0,
9682 gfc_add_expr_to_block (&fnblock
, tmp
);
9687 case DEALLOCATE_PDT_COMP
:
9688 /* Deallocate array or parameterized string length components
9689 of parameterized derived types. */
9690 if (!(c
->attr
.pdt_array
&& c
->as
&& c
->as
->type
== AS_EXPLICIT
)
9691 && !c
->attr
.pdt_string
9692 && !((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9693 && (c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
)))
9696 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9697 decl
, cdecl, NULL_TREE
);
9698 if (c
->ts
.type
== BT_CLASS
)
9699 comp
= gfc_class_data_get (comp
);
9701 /* Recurse in to PDT components. */
9702 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9703 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
9704 && (!c
->attr
.pointer
&& !c
->attr
.allocatable
))
9706 tmp
= gfc_deallocate_pdt_comp (c
->ts
.u
.derived
, comp
,
9707 c
->as
? c
->as
->rank
: 0);
9708 gfc_add_expr_to_block (&fnblock
, tmp
);
9711 if (c
->attr
.pdt_array
)
9713 tmp
= gfc_conv_descriptor_data_get (comp
);
9714 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
9715 logical_type_node
, tmp
,
9716 build_int_cst (TREE_TYPE (tmp
), 0));
9717 tmp
= gfc_call_free (tmp
);
9718 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
9719 build_empty_stmt (input_location
));
9720 gfc_add_expr_to_block (&fnblock
, tmp
);
9721 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
9723 else if (c
->attr
.pdt_string
)
9725 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
9726 logical_type_node
, comp
,
9727 build_int_cst (TREE_TYPE (comp
), 0));
9728 tmp
= gfc_call_free (comp
);
9729 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
9730 build_empty_stmt (input_location
));
9731 gfc_add_expr_to_block (&fnblock
, tmp
);
9732 tmp
= fold_convert (TREE_TYPE (comp
), null_pointer_node
);
9733 gfc_add_modify (&fnblock
, comp
, tmp
);
9738 case CHECK_PDT_DUMMY
:
9740 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9741 decl
, cdecl, NULL_TREE
);
9742 if (c
->ts
.type
== BT_CLASS
)
9743 comp
= gfc_class_data_get (comp
);
9745 /* Recurse in to PDT components. */
9746 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9747 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
)
9749 tmp
= gfc_check_pdt_dummy (c
->ts
.u
.derived
, comp
,
9750 c
->as
? c
->as
->rank
: 0,
9752 gfc_add_expr_to_block (&fnblock
, tmp
);
9755 if (!c
->attr
.pdt_len
)
9760 gfc_expr
*c_expr
= NULL
;
9761 gfc_actual_arglist
*param
= pdt_param_list
;
9763 gfc_init_se (&tse
, NULL
);
9764 for (; param
; param
= param
->next
)
9765 if (!strcmp (c
->name
, param
->name
)
9766 && param
->spec_type
== SPEC_EXPLICIT
)
9767 c_expr
= param
->expr
;
9771 tree error
, cond
, cname
;
9772 gfc_conv_expr_type (&tse
, c_expr
, TREE_TYPE (comp
));
9773 cond
= fold_build2_loc (input_location
, NE_EXPR
,
9776 cname
= gfc_build_cstring_const (c
->name
);
9777 cname
= gfc_build_addr_expr (pchar_type_node
, cname
);
9778 error
= gfc_trans_runtime_error (true, NULL
,
9779 "The value of the PDT LEN "
9780 "parameter '%s' does not "
9781 "agree with that in the "
9782 "dummy declaration",
9784 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
9785 void_type_node
, cond
, error
,
9786 build_empty_stmt (input_location
));
9787 gfc_add_expr_to_block (&fnblock
, tmp
);
9798 return gfc_finish_block (&fnblock
);
9801 /* Recursively traverse an object of derived type, generating code to
9802 nullify allocatable components. */
9805 gfc_nullify_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
9808 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9810 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
| caf_mode
, NULL
);
9814 /* Recursively traverse an object of derived type, generating code to
9815 deallocate allocatable components. */
9818 gfc_deallocate_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
9821 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9822 DEALLOCATE_ALLOC_COMP
,
9823 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
| caf_mode
, NULL
);
9827 gfc_bcast_alloc_comp (gfc_symbol
*derived
, gfc_expr
*expr
, int rank
,
9828 tree image_index
, tree stat
, tree errmsg
,
9833 stmtblock_t block
, post_block
;
9834 gfc_co_subroutines_args args
;
9836 args
.image_index
= image_index
;
9838 args
.errmsg
= errmsg
;
9839 args
.errmsg_len
= errmsg_len
;
9843 gfc_start_block (&block
);
9844 gfc_init_block (&post_block
);
9845 gfc_init_se (&argse
, NULL
);
9846 gfc_conv_expr (&argse
, expr
);
9847 gfc_add_block_to_block (&block
, &argse
.pre
);
9848 gfc_add_block_to_block (&post_block
, &argse
.post
);
9853 gfc_init_se (&argse
, NULL
);
9854 argse
.want_pointer
= 1;
9855 gfc_conv_expr_descriptor (&argse
, expr
);
9859 tmp
= structure_alloc_comps (derived
, array
, NULL_TREE
, rank
,
9861 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
, &args
);
9865 /* Recursively traverse an object of derived type, generating code to
9866 deallocate allocatable components. But do not deallocate coarrays.
9867 To be used for intrinsic assignment, which may not change the allocation
9868 status of coarrays. */
9871 gfc_deallocate_alloc_comp_no_caf (gfc_symbol
* der_type
, tree decl
, int rank
)
9873 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9874 DEALLOCATE_ALLOC_COMP
, 0, NULL
);
9879 gfc_reassign_alloc_comp_caf (gfc_symbol
*der_type
, tree decl
, tree dest
)
9881 return structure_alloc_comps (der_type
, decl
, dest
, 0, REASSIGN_CAF_COMP
,
9882 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
, NULL
);
9886 /* Recursively traverse an object of derived type, generating code to
9887 copy it and its allocatable components. */
9890 gfc_copy_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
,
9893 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ALLOC_COMP
,
9898 /* Recursively traverse an object of derived type, generating code to
9899 copy only its allocatable components. */
9902 gfc_copy_only_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
9904 return structure_alloc_comps (der_type
, decl
, dest
, rank
,
9905 COPY_ONLY_ALLOC_COMP
, 0, NULL
);
9909 /* Recursively traverse an object of parameterized derived type, generating
9910 code to allocate parameterized components. */
9913 gfc_allocate_pdt_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
9914 gfc_actual_arglist
*param_list
)
9917 gfc_actual_arglist
*old_param_list
= pdt_param_list
;
9918 pdt_param_list
= param_list
;
9919 res
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9920 ALLOCATE_PDT_COMP
, 0, NULL
);
9921 pdt_param_list
= old_param_list
;
9925 /* Recursively traverse an object of parameterized derived type, generating
9926 code to deallocate parameterized components. */
9929 gfc_deallocate_pdt_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
9931 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9932 DEALLOCATE_PDT_COMP
, 0, NULL
);
9936 /* Recursively traverse a dummy of parameterized derived type to check the
9937 values of LEN parameters. */
9940 gfc_check_pdt_dummy (gfc_symbol
* der_type
, tree decl
, int rank
,
9941 gfc_actual_arglist
*param_list
)
9944 gfc_actual_arglist
*old_param_list
= pdt_param_list
;
9945 pdt_param_list
= param_list
;
9946 res
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9947 CHECK_PDT_DUMMY
, 0, NULL
);
9948 pdt_param_list
= old_param_list
;
9953 /* Returns the value of LBOUND for an expression. This could be broken out
9954 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
9955 called by gfc_alloc_allocatable_for_assignment. */
9957 get_std_lbound (gfc_expr
*expr
, tree desc
, int dim
, bool assumed_size
)
9962 tree cond
, cond1
, cond3
, cond4
;
9966 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
9968 tmp
= gfc_rank_cst
[dim
];
9969 lbound
= gfc_conv_descriptor_lbound_get (desc
, tmp
);
9970 ubound
= gfc_conv_descriptor_ubound_get (desc
, tmp
);
9971 stride
= gfc_conv_descriptor_stride_get (desc
, tmp
);
9972 cond1
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
9974 cond3
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
9975 stride
, gfc_index_zero_node
);
9976 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
9977 logical_type_node
, cond3
, cond1
);
9978 cond4
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
9979 stride
, gfc_index_zero_node
);
9981 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
9982 tmp
, build_int_cst (gfc_array_index_type
,
9985 cond
= logical_false_node
;
9987 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
9988 logical_type_node
, cond3
, cond4
);
9989 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
9990 logical_type_node
, cond
, cond1
);
9992 return fold_build3_loc (input_location
, COND_EXPR
,
9993 gfc_array_index_type
, cond
,
9994 lbound
, gfc_index_one_node
);
9997 if (expr
->expr_type
== EXPR_FUNCTION
)
9999 /* A conversion function, so use the argument. */
10000 gcc_assert (expr
->value
.function
.isym
10001 && expr
->value
.function
.isym
->conversion
);
10002 expr
= expr
->value
.function
.actual
->expr
;
10005 if (expr
->expr_type
== EXPR_VARIABLE
)
10007 tmp
= TREE_TYPE (expr
->symtree
->n
.sym
->backend_decl
);
10008 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
10010 if (ref
->type
== REF_COMPONENT
10011 && ref
->u
.c
.component
->as
10013 && ref
->next
->u
.ar
.type
== AR_FULL
)
10014 tmp
= TREE_TYPE (ref
->u
.c
.component
->backend_decl
);
10016 return GFC_TYPE_ARRAY_LBOUND(tmp
, dim
);
10019 return gfc_index_one_node
;
10023 /* Returns true if an expression represents an lhs that can be reallocated
10027 gfc_is_reallocatable_lhs (gfc_expr
*expr
)
10035 sym
= expr
->symtree
->n
.sym
;
10037 if (sym
->attr
.associate_var
&& !expr
->ref
)
10040 /* An allocatable class variable with no reference. */
10041 if (sym
->ts
.type
== BT_CLASS
10042 && !sym
->attr
.associate_var
10043 && CLASS_DATA (sym
)->attr
.allocatable
10045 && ((expr
->ref
->type
== REF_ARRAY
&& expr
->ref
->u
.ar
.type
== AR_FULL
10046 && expr
->ref
->next
== NULL
)
10047 || (expr
->ref
->type
== REF_COMPONENT
10048 && strcmp (expr
->ref
->u
.c
.component
->name
, "_data") == 0
10049 && (expr
->ref
->next
== NULL
10050 || (expr
->ref
->next
->type
== REF_ARRAY
10051 && expr
->ref
->next
->u
.ar
.type
== AR_FULL
10052 && expr
->ref
->next
->next
== NULL
)))))
10055 /* An allocatable variable. */
10056 if (sym
->attr
.allocatable
10057 && !sym
->attr
.associate_var
10059 && expr
->ref
->type
== REF_ARRAY
10060 && expr
->ref
->u
.ar
.type
== AR_FULL
)
10063 /* All that can be left are allocatable components. */
10064 if ((sym
->ts
.type
!= BT_DERIVED
10065 && sym
->ts
.type
!= BT_CLASS
)
10066 || !sym
->ts
.u
.derived
->attr
.alloc_comp
)
10069 /* Find a component ref followed by an array reference. */
10070 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
10072 && ref
->type
== REF_COMPONENT
10073 && ref
->next
->type
== REF_ARRAY
10074 && !ref
->next
->next
)
10080 /* Return true if valid reallocatable lhs. */
10081 if (ref
->u
.c
.component
->attr
.allocatable
10082 && ref
->next
->u
.ar
.type
== AR_FULL
)
10090 concat_str_length (gfc_expr
* expr
)
10097 type
= gfc_typenode_for_spec (&expr
->value
.op
.op1
->ts
);
10098 len1
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
10099 if (len1
== NULL_TREE
)
10101 if (expr
->value
.op
.op1
->expr_type
== EXPR_OP
)
10102 len1
= concat_str_length (expr
->value
.op
.op1
);
10103 else if (expr
->value
.op
.op1
->expr_type
== EXPR_CONSTANT
)
10104 len1
= build_int_cst (gfc_charlen_type_node
,
10105 expr
->value
.op
.op1
->value
.character
.length
);
10106 else if (expr
->value
.op
.op1
->ts
.u
.cl
->length
)
10108 gfc_init_se (&se
, NULL
);
10109 gfc_conv_expr (&se
, expr
->value
.op
.op1
->ts
.u
.cl
->length
);
10115 gfc_init_se (&se
, NULL
);
10116 se
.want_pointer
= 1;
10117 se
.descriptor_only
= 1;
10118 gfc_conv_expr (&se
, expr
->value
.op
.op1
);
10119 len1
= se
.string_length
;
10123 type
= gfc_typenode_for_spec (&expr
->value
.op
.op2
->ts
);
10124 len2
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
10125 if (len2
== NULL_TREE
)
10127 if (expr
->value
.op
.op2
->expr_type
== EXPR_OP
)
10128 len2
= concat_str_length (expr
->value
.op
.op2
);
10129 else if (expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
10130 len2
= build_int_cst (gfc_charlen_type_node
,
10131 expr
->value
.op
.op2
->value
.character
.length
);
10132 else if (expr
->value
.op
.op2
->ts
.u
.cl
->length
)
10134 gfc_init_se (&se
, NULL
);
10135 gfc_conv_expr (&se
, expr
->value
.op
.op2
->ts
.u
.cl
->length
);
10141 gfc_init_se (&se
, NULL
);
10142 se
.want_pointer
= 1;
10143 se
.descriptor_only
= 1;
10144 gfc_conv_expr (&se
, expr
->value
.op
.op2
);
10145 len2
= se
.string_length
;
10149 gcc_assert(len1
&& len2
);
10150 len1
= fold_convert (gfc_charlen_type_node
, len1
);
10151 len2
= fold_convert (gfc_charlen_type_node
, len2
);
10153 return fold_build2_loc (input_location
, PLUS_EXPR
,
10154 gfc_charlen_type_node
, len1
, len2
);
10158 /* Allocate the lhs of an assignment to an allocatable array, otherwise
10162 gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop
,
10166 stmtblock_t realloc_block
;
10167 stmtblock_t alloc_block
;
10168 stmtblock_t fblock
;
10171 gfc_array_info
*linfo
;
10193 tree class_expr2
= NULL_TREE
;
10196 gfc_array_spec
* as
;
10197 bool coarray
= (flag_coarray
== GFC_FCOARRAY_LIB
10198 && gfc_caf_attr (expr1
, true).codimension
);
10202 /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
10203 Find the lhs expression in the loop chain and set expr1 and
10204 expr2 accordingly. */
10205 if (expr1
->expr_type
== EXPR_FUNCTION
&& expr2
== NULL
)
10208 /* Find the ss for the lhs. */
10210 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
10211 if (lss
->info
->expr
&& lss
->info
->expr
->expr_type
== EXPR_VARIABLE
)
10213 if (lss
== gfc_ss_terminator
)
10215 expr1
= lss
->info
->expr
;
10218 /* Bail out if this is not a valid allocate on assignment. */
10219 if (!gfc_is_reallocatable_lhs (expr1
)
10220 || (expr2
&& !expr2
->rank
))
10223 /* Find the ss for the lhs. */
10225 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
10226 if (lss
->info
->expr
== expr1
)
10229 if (lss
== gfc_ss_terminator
)
10232 linfo
= &lss
->info
->data
.array
;
10234 /* Find an ss for the rhs. For operator expressions, we see the
10235 ss's for the operands. Any one of these will do. */
10237 for (; rss
&& rss
!= gfc_ss_terminator
; rss
= rss
->loop_chain
)
10238 if (rss
->info
->expr
!= expr1
&& rss
!= loop
->temp_ss
)
10241 if (expr2
&& rss
== gfc_ss_terminator
)
10244 /* Ensure that the string length from the current scope is used. */
10245 if (expr2
->ts
.type
== BT_CHARACTER
10246 && expr2
->expr_type
== EXPR_FUNCTION
10247 && !expr2
->value
.function
.isym
)
10248 expr2
->ts
.u
.cl
->backend_decl
= rss
->info
->string_length
;
10250 gfc_start_block (&fblock
);
10252 /* Since the lhs is allocatable, this must be a descriptor type.
10253 Get the data and array size. */
10254 desc
= linfo
->descriptor
;
10255 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)));
10256 array1
= gfc_conv_descriptor_data_get (desc
);
10259 desc2
= rss
->info
->data
.array
.descriptor
;
10263 /* Get the old lhs element size for deferred character and class expr1. */
10264 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10266 if (expr1
->ts
.u
.cl
->backend_decl
10267 && VAR_P (expr1
->ts
.u
.cl
->backend_decl
))
10268 elemsize1
= expr1
->ts
.u
.cl
->backend_decl
;
10270 elemsize1
= lss
->info
->string_length
;
10272 else if (expr1
->ts
.type
== BT_CLASS
)
10274 /* Unfortunately, the lhs vptr is set too early in many cases.
10275 Play it safe by using the descriptor element length. */
10276 tmp
= gfc_conv_descriptor_elem_len (desc
);
10277 elemsize1
= fold_convert (gfc_array_index_type
, tmp
);
10280 elemsize1
= NULL_TREE
;
10281 if (elemsize1
!= NULL_TREE
)
10282 elemsize1
= gfc_evaluate_now (elemsize1
, &fblock
);
10284 /* Get the new lhs size in bytes. */
10285 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10287 if (expr2
->ts
.deferred
)
10289 if (expr2
->ts
.u
.cl
->backend_decl
10290 && VAR_P (expr2
->ts
.u
.cl
->backend_decl
))
10291 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
10293 tmp
= rss
->info
->string_length
;
10297 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
10298 if (!tmp
&& expr2
->expr_type
== EXPR_OP
10299 && expr2
->value
.op
.op
== INTRINSIC_CONCAT
)
10301 tmp
= concat_str_length (expr2
);
10302 expr2
->ts
.u
.cl
->backend_decl
= gfc_evaluate_now (tmp
, &fblock
);
10304 else if (!tmp
&& expr2
->ts
.u
.cl
->length
)
10307 gfc_init_se (&tmpse
, NULL
);
10308 gfc_conv_expr_type (&tmpse
, expr2
->ts
.u
.cl
->length
,
10309 gfc_charlen_type_node
);
10311 expr2
->ts
.u
.cl
->backend_decl
= gfc_evaluate_now (tmp
, &fblock
);
10313 tmp
= fold_convert (TREE_TYPE (expr1
->ts
.u
.cl
->backend_decl
), tmp
);
10316 if (expr1
->ts
.u
.cl
->backend_decl
10317 && VAR_P (expr1
->ts
.u
.cl
->backend_decl
))
10318 gfc_add_modify (&fblock
, expr1
->ts
.u
.cl
->backend_decl
, tmp
);
10320 gfc_add_modify (&fblock
, lss
->info
->string_length
, tmp
);
10322 if (expr1
->ts
.kind
> 1)
10323 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
10325 tmp
, build_int_cst (TREE_TYPE (tmp
),
10328 else if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.u
.cl
->backend_decl
)
10330 tmp
= TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
)));
10331 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
10332 gfc_array_index_type
, tmp
,
10333 expr1
->ts
.u
.cl
->backend_decl
);
10335 else if (UNLIMITED_POLY (expr1
) && expr2
->ts
.type
!= BT_CLASS
)
10336 tmp
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2
->ts
));
10337 else if (expr1
->ts
.type
== BT_CLASS
&& expr2
->ts
.type
== BT_CLASS
)
10339 tmp
= expr2
->rank
? gfc_get_class_from_expr (desc2
) : NULL_TREE
;
10340 if (tmp
== NULL_TREE
&& expr2
->expr_type
== EXPR_VARIABLE
)
10341 tmp
= class_expr2
= gfc_get_class_from_gfc_expr (expr2
);
10343 if (tmp
!= NULL_TREE
)
10344 tmp
= gfc_class_vtab_size_get (tmp
);
10346 tmp
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&CLASS_DATA (expr2
)->ts
));
10349 tmp
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2
->ts
));
10350 elemsize2
= fold_convert (gfc_array_index_type
, tmp
);
10351 elemsize2
= gfc_evaluate_now (elemsize2
, &fblock
);
10353 /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
10354 deallocated if expr is an array of different shape or any of the
10355 corresponding length type parameter values of variable and expr
10356 differ." This assures F95 compatibility. */
10357 jump_label1
= gfc_build_label_decl (NULL_TREE
);
10358 jump_label2
= gfc_build_label_decl (NULL_TREE
);
10360 /* Allocate if data is NULL. */
10361 cond_null
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
10362 array1
, build_int_cst (TREE_TYPE (array1
), 0));
10364 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10366 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
10368 lss
->info
->string_length
,
10369 rss
->info
->string_length
);
10370 cond_null
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
10371 logical_type_node
, tmp
, cond_null
);
10372 cond_null
= gfc_evaluate_now (cond_null
, &fblock
);
10375 cond_null
= gfc_evaluate_now (cond_null
, &fblock
);
10377 tmp
= build3_v (COND_EXPR
, cond_null
,
10378 build1_v (GOTO_EXPR
, jump_label1
),
10379 build_empty_stmt (input_location
));
10380 gfc_add_expr_to_block (&fblock
, tmp
);
10382 /* Get arrayspec if expr is a full array. */
10383 if (expr2
&& expr2
->expr_type
== EXPR_FUNCTION
10384 && expr2
->value
.function
.isym
10385 && expr2
->value
.function
.isym
->conversion
)
10387 /* For conversion functions, take the arg. */
10388 gfc_expr
*arg
= expr2
->value
.function
.actual
->expr
;
10389 as
= gfc_get_full_arrayspec_from_expr (arg
);
10392 as
= gfc_get_full_arrayspec_from_expr (expr2
);
10396 /* If the lhs shape is not the same as the rhs jump to setting the
10397 bounds and doing the reallocation....... */
10398 for (n
= 0; n
< expr1
->rank
; n
++)
10400 /* Check the shape. */
10401 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
10402 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
10403 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10404 gfc_array_index_type
,
10405 loop
->to
[n
], loop
->from
[n
]);
10406 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
10407 gfc_array_index_type
,
10409 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10410 gfc_array_index_type
,
10412 cond
= fold_build2_loc (input_location
, NE_EXPR
,
10414 tmp
, gfc_index_zero_node
);
10415 tmp
= build3_v (COND_EXPR
, cond
,
10416 build1_v (GOTO_EXPR
, jump_label1
),
10417 build_empty_stmt (input_location
));
10418 gfc_add_expr_to_block (&fblock
, tmp
);
10421 /* ...else if the element lengths are not the same also go to
10422 setting the bounds and doing the reallocation.... */
10423 if (elemsize1
!= NULL_TREE
)
10425 cond
= fold_build2_loc (input_location
, NE_EXPR
,
10427 elemsize1
, elemsize2
);
10428 tmp
= build3_v (COND_EXPR
, cond
,
10429 build1_v (GOTO_EXPR
, jump_label1
),
10430 build_empty_stmt (input_location
));
10431 gfc_add_expr_to_block (&fblock
, tmp
);
10434 /* ....else jump past the (re)alloc code. */
10435 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
10436 gfc_add_expr_to_block (&fblock
, tmp
);
10438 /* Add the label to start automatic (re)allocation. */
10439 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
10440 gfc_add_expr_to_block (&fblock
, tmp
);
10442 /* If the lhs has not been allocated, its bounds will not have been
10443 initialized and so its size is set to zero. */
10444 size1
= gfc_create_var (gfc_array_index_type
, NULL
);
10445 gfc_init_block (&alloc_block
);
10446 gfc_add_modify (&alloc_block
, size1
, gfc_index_zero_node
);
10447 gfc_init_block (&realloc_block
);
10448 gfc_add_modify (&realloc_block
, size1
,
10449 gfc_conv_descriptor_size (desc
, expr1
->rank
));
10450 tmp
= build3_v (COND_EXPR
, cond_null
,
10451 gfc_finish_block (&alloc_block
),
10452 gfc_finish_block (&realloc_block
));
10453 gfc_add_expr_to_block (&fblock
, tmp
);
10455 /* Get the rhs size and fix it. */
10456 size2
= gfc_index_one_node
;
10457 for (n
= 0; n
< expr2
->rank
; n
++)
10459 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10460 gfc_array_index_type
,
10461 loop
->to
[n
], loop
->from
[n
]);
10462 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
10463 gfc_array_index_type
,
10464 tmp
, gfc_index_one_node
);
10465 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
10466 gfc_array_index_type
,
10469 size2
= gfc_evaluate_now (size2
, &fblock
);
10471 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
10474 /* If the lhs is deferred length, assume that the element size
10475 changes and force a reallocation. */
10476 if (expr1
->ts
.deferred
)
10477 neq_size
= gfc_evaluate_now (logical_true_node
, &fblock
);
10479 neq_size
= gfc_evaluate_now (cond
, &fblock
);
10481 /* Deallocation of allocatable components will have to occur on
10482 reallocation. Fix the old descriptor now. */
10483 if ((expr1
->ts
.type
== BT_DERIVED
)
10484 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10485 old_desc
= gfc_evaluate_now (desc
, &fblock
);
10487 old_desc
= NULL_TREE
;
10489 /* Now modify the lhs descriptor and the associated scalarizer
10490 variables. F2003 7.4.1.3: "If variable is or becomes an
10491 unallocated allocatable variable, then it is allocated with each
10492 deferred type parameter equal to the corresponding type parameters
10493 of expr , with the shape of expr , and with each lower bound equal
10494 to the corresponding element of LBOUND(expr)."
10495 Reuse size1 to keep a dimension-by-dimension track of the
10496 stride of the new array. */
10497 size1
= gfc_index_one_node
;
10498 offset
= gfc_index_zero_node
;
10500 for (n
= 0; n
< expr2
->rank
; n
++)
10502 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10503 gfc_array_index_type
,
10504 loop
->to
[n
], loop
->from
[n
]);
10505 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
10506 gfc_array_index_type
,
10507 tmp
, gfc_index_one_node
);
10509 lbound
= gfc_index_one_node
;
10514 lbd
= get_std_lbound (expr2
, desc2
, n
,
10515 as
->type
== AS_ASSUMED_SIZE
);
10516 ubound
= fold_build2_loc (input_location
,
10518 gfc_array_index_type
,
10520 ubound
= fold_build2_loc (input_location
,
10522 gfc_array_index_type
,
10527 gfc_conv_descriptor_lbound_set (&fblock
, desc
,
10530 gfc_conv_descriptor_ubound_set (&fblock
, desc
,
10533 gfc_conv_descriptor_stride_set (&fblock
, desc
,
10536 lbound
= gfc_conv_descriptor_lbound_get (desc
,
10538 tmp2
= fold_build2_loc (input_location
, MULT_EXPR
,
10539 gfc_array_index_type
,
10541 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
10542 gfc_array_index_type
,
10544 size1
= fold_build2_loc (input_location
, MULT_EXPR
,
10545 gfc_array_index_type
,
10549 /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
10550 the array offset is saved and the info.offset is used for a
10551 running offset. Use the saved_offset instead. */
10552 tmp
= gfc_conv_descriptor_offset (desc
);
10553 gfc_add_modify (&fblock
, tmp
, offset
);
10554 if (linfo
->saved_offset
10555 && VAR_P (linfo
->saved_offset
))
10556 gfc_add_modify (&fblock
, linfo
->saved_offset
, tmp
);
10558 /* Now set the deltas for the lhs. */
10559 for (n
= 0; n
< expr1
->rank
; n
++)
10561 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
10563 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10564 gfc_array_index_type
, tmp
,
10566 if (linfo
->delta
[dim
] && VAR_P (linfo
->delta
[dim
]))
10567 gfc_add_modify (&fblock
, linfo
->delta
[dim
], tmp
);
10570 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
10571 gfc_conv_descriptor_span_set (&fblock
, desc
, elemsize2
);
10573 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
10574 gfc_array_index_type
,
10576 size2
= fold_convert (size_type_node
, size2
);
10577 size2
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
10578 size2
, size_one_node
);
10579 size2
= gfc_evaluate_now (size2
, &fblock
);
10581 /* For deferred character length, the 'size' field of the dtype might
10582 have changed so set the dtype. */
10583 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
10584 && expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10587 tmp
= gfc_conv_descriptor_dtype (desc
);
10588 if (expr2
->ts
.u
.cl
->backend_decl
)
10589 type
= gfc_typenode_for_spec (&expr2
->ts
);
10591 type
= gfc_typenode_for_spec (&expr1
->ts
);
10593 gfc_add_modify (&fblock
, tmp
,
10594 gfc_get_dtype_rank_type (expr1
->rank
,type
));
10596 else if (expr1
->ts
.type
== BT_CLASS
)
10599 tmp
= gfc_conv_descriptor_dtype (desc
);
10601 if (expr2
->ts
.type
!= BT_CLASS
)
10602 type
= gfc_typenode_for_spec (&expr2
->ts
);
10604 type
= gfc_get_character_type_len (1, elemsize2
);
10606 gfc_add_modify (&fblock
, tmp
,
10607 gfc_get_dtype_rank_type (expr2
->rank
,type
));
10608 /* Set the _len field as well... */
10609 if (UNLIMITED_POLY (expr1
))
10611 tmp
= gfc_class_len_get (TREE_OPERAND (desc
, 0));
10612 if (expr2
->ts
.type
== BT_CHARACTER
)
10613 gfc_add_modify (&fblock
, tmp
,
10614 fold_convert (TREE_TYPE (tmp
),
10615 TYPE_SIZE_UNIT (type
)));
10617 gfc_add_modify (&fblock
, tmp
,
10618 build_int_cst (TREE_TYPE (tmp
), 0));
10620 /* ...and the vptr. */
10621 tmp
= gfc_class_vptr_get (TREE_OPERAND (desc
, 0));
10622 if (expr2
->ts
.type
== BT_CLASS
&& !VAR_P (desc2
)
10623 && TREE_CODE (desc2
) == COMPONENT_REF
)
10625 tmp2
= gfc_get_class_from_expr (desc2
);
10626 tmp2
= gfc_class_vptr_get (tmp2
);
10628 else if (expr2
->ts
.type
== BT_CLASS
&& class_expr2
!= NULL_TREE
)
10629 tmp2
= gfc_class_vptr_get (class_expr2
);
10632 tmp2
= gfc_get_symbol_decl (gfc_find_vtab (&expr2
->ts
));
10633 tmp2
= gfc_build_addr_expr (TREE_TYPE (tmp
), tmp2
);
10636 gfc_add_modify (&fblock
, tmp
, fold_convert (TREE_TYPE (tmp
), tmp2
));
10638 else if (coarray
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
10640 gfc_add_modify (&fblock
, gfc_conv_descriptor_dtype (desc
),
10641 gfc_get_dtype (TREE_TYPE (desc
)));
10644 /* Realloc expression. Note that the scalarizer uses desc.data
10645 in the array reference - (*desc.data)[<element>]. */
10646 gfc_init_block (&realloc_block
);
10647 gfc_init_se (&caf_se
, NULL
);
10651 token
= gfc_get_ultimate_alloc_ptr_comps_caf_token (&caf_se
, expr1
);
10652 if (token
== NULL_TREE
)
10654 tmp
= gfc_get_tree_for_caf_expr (expr1
);
10655 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
10656 tmp
= build_fold_indirect_ref (tmp
);
10657 gfc_get_caf_token_offset (&caf_se
, &token
, NULL
, tmp
, NULL_TREE
,
10659 token
= gfc_build_addr_expr (NULL_TREE
, token
);
10662 gfc_add_block_to_block (&realloc_block
, &caf_se
.pre
);
10664 if ((expr1
->ts
.type
== BT_DERIVED
)
10665 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10667 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, old_desc
,
10669 gfc_add_expr_to_block (&realloc_block
, tmp
);
10674 tmp
= build_call_expr_loc (input_location
,
10675 builtin_decl_explicit (BUILT_IN_REALLOC
), 2,
10676 fold_convert (pvoid_type_node
, array1
),
10678 gfc_conv_descriptor_data_set (&realloc_block
,
10683 tmp
= build_call_expr_loc (input_location
,
10684 gfor_fndecl_caf_deregister
, 5, token
,
10685 build_int_cst (integer_type_node
,
10686 GFC_CAF_COARRAY_DEALLOCATE_ONLY
),
10687 null_pointer_node
, null_pointer_node
,
10688 integer_zero_node
);
10689 gfc_add_expr_to_block (&realloc_block
, tmp
);
10690 tmp
= build_call_expr_loc (input_location
,
10691 gfor_fndecl_caf_register
,
10693 build_int_cst (integer_type_node
,
10694 GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY
),
10695 token
, gfc_build_addr_expr (NULL_TREE
, desc
),
10696 null_pointer_node
, null_pointer_node
,
10697 integer_zero_node
);
10698 gfc_add_expr_to_block (&realloc_block
, tmp
);
10701 if ((expr1
->ts
.type
== BT_DERIVED
)
10702 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10704 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, desc
,
10706 gfc_add_expr_to_block (&realloc_block
, tmp
);
10709 gfc_add_block_to_block (&realloc_block
, &caf_se
.post
);
10710 realloc_expr
= gfc_finish_block (&realloc_block
);
10712 /* Reallocate if sizes or dynamic types are different. */
10715 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
10716 elemsize1
, elemsize2
);
10717 tmp
= gfc_evaluate_now (tmp
, &fblock
);
10718 neq_size
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
10719 logical_type_node
, neq_size
, tmp
);
10721 tmp
= build3_v (COND_EXPR
, neq_size
, realloc_expr
,
10722 build_empty_stmt (input_location
));
10724 realloc_expr
= tmp
;
10726 /* Malloc expression. */
10727 gfc_init_block (&alloc_block
);
10730 tmp
= build_call_expr_loc (input_location
,
10731 builtin_decl_explicit (BUILT_IN_MALLOC
),
10733 gfc_conv_descriptor_data_set (&alloc_block
,
10738 tmp
= build_call_expr_loc (input_location
,
10739 gfor_fndecl_caf_register
,
10741 build_int_cst (integer_type_node
,
10742 GFC_CAF_COARRAY_ALLOC
),
10743 token
, gfc_build_addr_expr (NULL_TREE
, desc
),
10744 null_pointer_node
, null_pointer_node
,
10745 integer_zero_node
);
10746 gfc_add_expr_to_block (&alloc_block
, tmp
);
10750 /* We already set the dtype in the case of deferred character
10751 length arrays and class lvalues. */
10752 if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
10753 && ((expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10755 && expr1
->ts
.type
!= BT_CLASS
)
10757 tmp
= gfc_conv_descriptor_dtype (desc
);
10758 gfc_add_modify (&alloc_block
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
10761 if ((expr1
->ts
.type
== BT_DERIVED
)
10762 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10764 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, desc
,
10766 gfc_add_expr_to_block (&alloc_block
, tmp
);
10768 alloc_expr
= gfc_finish_block (&alloc_block
);
10770 /* Malloc if not allocated; realloc otherwise. */
10771 tmp
= build3_v (COND_EXPR
, cond_null
, alloc_expr
, realloc_expr
);
10772 gfc_add_expr_to_block (&fblock
, tmp
);
10774 /* Make sure that the scalarizer data pointer is updated. */
10775 if (linfo
->data
&& VAR_P (linfo
->data
))
10777 tmp
= gfc_conv_descriptor_data_get (desc
);
10778 gfc_add_modify (&fblock
, linfo
->data
, tmp
);
10781 /* Add the label for same shape lhs and rhs. */
10782 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
10783 gfc_add_expr_to_block (&fblock
, tmp
);
10785 return gfc_finish_block (&fblock
);
10789 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
10790 Do likewise, recursively if necessary, with the allocatable components of
10791 derived types. This function is also called for assumed-rank arrays, which
10792 are always dummy arguments. */
10795 gfc_trans_deferred_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
10801 stmtblock_t cleanup
;
10804 bool sym_has_alloc_comp
, has_finalizer
;
10806 sym_has_alloc_comp
= (sym
->ts
.type
== BT_DERIVED
10807 || sym
->ts
.type
== BT_CLASS
)
10808 && sym
->ts
.u
.derived
->attr
.alloc_comp
;
10809 has_finalizer
= sym
->ts
.type
== BT_CLASS
|| sym
->ts
.type
== BT_DERIVED
10810 ? gfc_is_finalizable (sym
->ts
.u
.derived
, NULL
) : false;
10812 /* Make sure the frontend gets these right. */
10813 gcc_assert (sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym_has_alloc_comp
10815 || (sym
->as
->type
== AS_ASSUMED_RANK
&& sym
->attr
.dummy
));
10817 gfc_save_backend_locus (&loc
);
10818 gfc_set_backend_locus (&sym
->declared_at
);
10819 gfc_init_block (&init
);
10821 gcc_assert (VAR_P (sym
->backend_decl
)
10822 || TREE_CODE (sym
->backend_decl
) == PARM_DECL
);
10824 if (sym
->ts
.type
== BT_CHARACTER
10825 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
10827 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
10828 gfc_trans_vla_type_sizes (sym
, &init
);
10831 /* Dummy, use associated and result variables don't need anything special. */
10832 if (sym
->attr
.dummy
|| sym
->attr
.use_assoc
|| sym
->attr
.result
)
10834 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
10835 gfc_restore_backend_locus (&loc
);
10839 descriptor
= sym
->backend_decl
;
10841 /* Although static, derived types with default initializers and
10842 allocatable components must not be nulled wholesale; instead they
10843 are treated component by component. */
10844 if (TREE_STATIC (descriptor
) && !sym_has_alloc_comp
&& !has_finalizer
)
10846 /* SAVEd variables are not freed on exit. */
10847 gfc_trans_static_array_pointer (sym
);
10849 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
10850 gfc_restore_backend_locus (&loc
);
10854 /* Get the descriptor type. */
10855 type
= TREE_TYPE (sym
->backend_decl
);
10857 if ((sym_has_alloc_comp
|| (has_finalizer
&& sym
->ts
.type
!= BT_CLASS
))
10858 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
10860 if (!sym
->attr
.save
10861 && !(TREE_STATIC (sym
->backend_decl
) && sym
->attr
.is_main_program
))
10863 if (sym
->value
== NULL
10864 || !gfc_has_default_initializer (sym
->ts
.u
.derived
))
10866 rank
= sym
->as
? sym
->as
->rank
: 0;
10867 tmp
= gfc_nullify_alloc_comp (sym
->ts
.u
.derived
,
10869 gfc_add_expr_to_block (&init
, tmp
);
10872 gfc_init_default_dt (sym
, &init
, false);
10875 else if (!GFC_DESCRIPTOR_TYPE_P (type
))
10877 /* If the backend_decl is not a descriptor, we must have a pointer
10879 descriptor
= build_fold_indirect_ref_loc (input_location
,
10880 sym
->backend_decl
);
10881 type
= TREE_TYPE (descriptor
);
10884 /* NULLIFY the data pointer, for non-saved allocatables. */
10885 if (GFC_DESCRIPTOR_TYPE_P (type
) && !sym
->attr
.save
&& sym
->attr
.allocatable
)
10887 gfc_conv_descriptor_data_set (&init
, descriptor
, null_pointer_node
);
10888 if (flag_coarray
== GFC_FCOARRAY_LIB
&& sym
->attr
.codimension
)
10890 /* Declare the variable static so its array descriptor stays present
10891 after leaving the scope. It may still be accessed through another
10892 image. This may happen, for example, with the caf_mpi
10894 TREE_STATIC (descriptor
) = 1;
10895 tmp
= gfc_conv_descriptor_token (descriptor
);
10896 gfc_add_modify (&init
, tmp
, fold_convert (TREE_TYPE (tmp
),
10897 null_pointer_node
));
10901 /* Set initial TKR for pointers and allocatables */
10902 if (GFC_DESCRIPTOR_TYPE_P (type
)
10903 && (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
10907 gcc_assert (sym
->as
&& sym
->as
->rank
>=0);
10908 tmp
= gfc_conv_descriptor_dtype (descriptor
);
10909 etype
= gfc_get_element_type (type
);
10910 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
10911 TREE_TYPE (tmp
), tmp
,
10912 gfc_get_dtype_rank_type (sym
->as
->rank
, etype
));
10913 gfc_add_expr_to_block (&init
, tmp
);
10915 gfc_restore_backend_locus (&loc
);
10916 gfc_init_block (&cleanup
);
10918 /* Allocatable arrays need to be freed when they go out of scope.
10919 The allocatable components of pointers must not be touched. */
10920 if (!sym
->attr
.allocatable
&& has_finalizer
&& sym
->ts
.type
!= BT_CLASS
10921 && !sym
->attr
.pointer
&& !sym
->attr
.artificial
&& !sym
->attr
.save
10922 && !sym
->ns
->proc_name
->attr
.is_main_program
)
10925 sym
->attr
.referenced
= 1;
10926 e
= gfc_lval_expr_from_sym (sym
);
10927 gfc_add_finalizer_call (&cleanup
, e
);
10930 else if ((!sym
->attr
.allocatable
|| !has_finalizer
)
10931 && sym_has_alloc_comp
&& !(sym
->attr
.function
|| sym
->attr
.result
)
10932 && !sym
->attr
.pointer
&& !sym
->attr
.save
10933 && !sym
->ns
->proc_name
->attr
.is_main_program
)
10936 rank
= sym
->as
? sym
->as
->rank
: 0;
10937 tmp
= gfc_deallocate_alloc_comp (sym
->ts
.u
.derived
, descriptor
, rank
);
10938 gfc_add_expr_to_block (&cleanup
, tmp
);
10941 if (sym
->attr
.allocatable
&& (sym
->attr
.dimension
|| sym
->attr
.codimension
)
10942 && !sym
->attr
.save
&& !sym
->attr
.result
10943 && !sym
->ns
->proc_name
->attr
.is_main_program
)
10946 e
= has_finalizer
? gfc_lval_expr_from_sym (sym
) : NULL
;
10947 tmp
= gfc_deallocate_with_status (sym
->backend_decl
, NULL_TREE
, NULL_TREE
,
10948 NULL_TREE
, NULL_TREE
, true, e
,
10949 sym
->attr
.codimension
10950 ? GFC_CAF_COARRAY_DEREGISTER
10951 : GFC_CAF_COARRAY_NOCOARRAY
);
10954 gfc_add_expr_to_block (&cleanup
, tmp
);
10957 gfc_add_init_cleanup (block
, gfc_finish_block (&init
),
10958 gfc_finish_block (&cleanup
));
10961 /************ Expression Walking Functions ******************/
10963 /* Walk a variable reference.
10965 Possible extension - multiple component subscripts.
10966 x(:,:) = foo%a(:)%b(:)
10968 forall (i=..., j=...)
10969 x(i,j) = foo%a(j)%b(i)
10971 This adds a fair amount of complexity because you need to deal with more
10972 than one ref. Maybe handle in a similar manner to vector subscripts.
10973 Maybe not worth the effort. */
10977 gfc_walk_variable_expr (gfc_ss
* ss
, gfc_expr
* expr
)
10981 gfc_fix_class_refs (expr
);
10983 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
10984 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
10987 return gfc_walk_array_ref (ss
, expr
, ref
);
10992 gfc_walk_array_ref (gfc_ss
* ss
, gfc_expr
* expr
, gfc_ref
* ref
)
10998 for (; ref
; ref
= ref
->next
)
11000 if (ref
->type
== REF_SUBSTRING
)
11002 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.start
);
11004 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.end
);
11007 /* We're only interested in array sections from now on. */
11008 if (ref
->type
!= REF_ARRAY
)
11016 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
11017 ss
= gfc_get_scalar_ss (ss
, ar
->start
[n
]);
11021 newss
= gfc_get_array_ss (ss
, expr
, ar
->as
->rank
, GFC_SS_SECTION
);
11022 newss
->info
->data
.array
.ref
= ref
;
11024 /* Make sure array is the same as array(:,:), this way
11025 we don't need to special case all the time. */
11026 ar
->dimen
= ar
->as
->rank
;
11027 for (n
= 0; n
< ar
->dimen
; n
++)
11029 ar
->dimen_type
[n
] = DIMEN_RANGE
;
11031 gcc_assert (ar
->start
[n
] == NULL
);
11032 gcc_assert (ar
->end
[n
] == NULL
);
11033 gcc_assert (ar
->stride
[n
] == NULL
);
11039 newss
= gfc_get_array_ss (ss
, expr
, 0, GFC_SS_SECTION
);
11040 newss
->info
->data
.array
.ref
= ref
;
11042 /* We add SS chains for all the subscripts in the section. */
11043 for (n
= 0; n
< ar
->dimen
; n
++)
11047 switch (ar
->dimen_type
[n
])
11049 case DIMEN_ELEMENT
:
11050 /* Add SS for elemental (scalar) subscripts. */
11051 gcc_assert (ar
->start
[n
]);
11052 indexss
= gfc_get_scalar_ss (gfc_ss_terminator
, ar
->start
[n
]);
11053 indexss
->loop_chain
= gfc_ss_terminator
;
11054 newss
->info
->data
.array
.subscript
[n
] = indexss
;
11058 /* We don't add anything for sections, just remember this
11059 dimension for later. */
11060 newss
->dim
[newss
->dimen
] = n
;
11065 /* Create a GFC_SS_VECTOR index in which we can store
11066 the vector's descriptor. */
11067 indexss
= gfc_get_array_ss (gfc_ss_terminator
, ar
->start
[n
],
11069 indexss
->loop_chain
= gfc_ss_terminator
;
11070 newss
->info
->data
.array
.subscript
[n
] = indexss
;
11071 newss
->dim
[newss
->dimen
] = n
;
11076 /* We should know what sort of section it is by now. */
11077 gcc_unreachable ();
11080 /* We should have at least one non-elemental dimension,
11081 unless we are creating a descriptor for a (scalar) coarray. */
11082 gcc_assert (newss
->dimen
> 0
11083 || newss
->info
->data
.array
.ref
->u
.ar
.as
->corank
> 0);
11088 /* We should know what sort of section it is by now. */
11089 gcc_unreachable ();
11097 /* Walk an expression operator. If only one operand of a binary expression is
11098 scalar, we must also add the scalar term to the SS chain. */
11101 gfc_walk_op_expr (gfc_ss
* ss
, gfc_expr
* expr
)
11106 head
= gfc_walk_subexpr (ss
, expr
->value
.op
.op1
);
11107 if (expr
->value
.op
.op2
== NULL
)
11110 head2
= gfc_walk_subexpr (head
, expr
->value
.op
.op2
);
11112 /* All operands are scalar. Pass back and let the caller deal with it. */
11116 /* All operands require scalarization. */
11117 if (head
!= ss
&& (expr
->value
.op
.op2
== NULL
|| head2
!= head
))
11120 /* One of the operands needs scalarization, the other is scalar.
11121 Create a gfc_ss for the scalar expression. */
11124 /* First operand is scalar. We build the chain in reverse order, so
11125 add the scalar SS after the second operand. */
11127 while (head
&& head
->next
!= ss
)
11129 /* Check we haven't somehow broken the chain. */
11131 head
->next
= gfc_get_scalar_ss (ss
, expr
->value
.op
.op1
);
11133 else /* head2 == head */
11135 gcc_assert (head2
== head
);
11136 /* Second operand is scalar. */
11137 head2
= gfc_get_scalar_ss (head2
, expr
->value
.op
.op2
);
11144 /* Reverse a SS chain. */
11147 gfc_reverse_ss (gfc_ss
* ss
)
11152 gcc_assert (ss
!= NULL
);
11154 head
= gfc_ss_terminator
;
11155 while (ss
!= gfc_ss_terminator
)
11158 /* Check we didn't somehow break the chain. */
11159 gcc_assert (next
!= NULL
);
11169 /* Given an expression referring to a procedure, return the symbol of its
11170 interface. We can't get the procedure symbol directly as we have to handle
11171 the case of (deferred) type-bound procedures. */
11174 gfc_get_proc_ifc_for_expr (gfc_expr
*procedure_ref
)
11179 if (procedure_ref
== NULL
)
11182 /* Normal procedure case. */
11183 if (procedure_ref
->expr_type
== EXPR_FUNCTION
11184 && procedure_ref
->value
.function
.esym
)
11185 sym
= procedure_ref
->value
.function
.esym
;
11187 sym
= procedure_ref
->symtree
->n
.sym
;
11189 /* Typebound procedure case. */
11190 for (ref
= procedure_ref
->ref
; ref
; ref
= ref
->next
)
11192 if (ref
->type
== REF_COMPONENT
11193 && ref
->u
.c
.component
->attr
.proc_pointer
)
11194 sym
= ref
->u
.c
.component
->ts
.interface
;
11203 /* Walk the arguments of an elemental function.
11204 PROC_EXPR is used to check whether an argument is permitted to be absent. If
11205 it is NULL, we don't do the check and the argument is assumed to be present.
11209 gfc_walk_elemental_function_args (gfc_ss
* ss
, gfc_actual_arglist
*arg
,
11210 gfc_symbol
*proc_ifc
, gfc_ss_type type
)
11212 gfc_formal_arglist
*dummy_arg
;
11218 head
= gfc_ss_terminator
;
11222 dummy_arg
= gfc_sym_get_dummy_args (proc_ifc
);
11227 for (; arg
; arg
= arg
->next
)
11229 if (!arg
->expr
|| arg
->expr
->expr_type
== EXPR_NULL
)
11230 goto loop_continue
;
11232 newss
= gfc_walk_subexpr (head
, arg
->expr
);
11235 /* Scalar argument. */
11236 gcc_assert (type
== GFC_SS_SCALAR
|| type
== GFC_SS_REFERENCE
);
11237 newss
= gfc_get_scalar_ss (head
, arg
->expr
);
11238 newss
->info
->type
= type
;
11240 newss
->info
->data
.scalar
.dummy_arg
= dummy_arg
->sym
;
11245 if (dummy_arg
!= NULL
11246 && dummy_arg
->sym
->attr
.optional
11247 && arg
->expr
->expr_type
== EXPR_VARIABLE
11248 && (gfc_expr_attr (arg
->expr
).optional
11249 || gfc_expr_attr (arg
->expr
).allocatable
11250 || gfc_expr_attr (arg
->expr
).pointer
))
11251 newss
->info
->can_be_null_ref
= true;
11257 while (tail
->next
!= gfc_ss_terminator
)
11262 if (dummy_arg
!= NULL
)
11263 dummy_arg
= dummy_arg
->next
;
11268 /* If all the arguments are scalar we don't need the argument SS. */
11269 gfc_free_ss_chain (head
);
11270 /* Pass it back. */
11274 /* Add it onto the existing chain. */
11280 /* Walk a function call. Scalar functions are passed back, and taken out of
11281 scalarization loops. For elemental functions we walk their arguments.
11282 The result of functions returning arrays is stored in a temporary outside
11283 the loop, so that the function is only called once. Hence we do not need
11284 to walk their arguments. */
11287 gfc_walk_function_expr (gfc_ss
* ss
, gfc_expr
* expr
)
11289 gfc_intrinsic_sym
*isym
;
11291 gfc_component
*comp
= NULL
;
11293 isym
= expr
->value
.function
.isym
;
11295 /* Handle intrinsic functions separately. */
11297 return gfc_walk_intrinsic_function (ss
, expr
, isym
);
11299 sym
= expr
->value
.function
.esym
;
11301 sym
= expr
->symtree
->n
.sym
;
11303 if (gfc_is_class_array_function (expr
))
11304 return gfc_get_array_ss (ss
, expr
,
11305 CLASS_DATA (expr
->value
.function
.esym
->result
)->as
->rank
,
11308 /* A function that returns arrays. */
11309 comp
= gfc_get_proc_ptr_comp (expr
);
11310 if ((!comp
&& gfc_return_by_reference (sym
) && sym
->result
->attr
.dimension
)
11311 || (comp
&& comp
->attr
.dimension
))
11312 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
11314 /* Walk the parameters of an elemental function. For now we always pass
11316 if (sym
->attr
.elemental
|| (comp
&& comp
->attr
.elemental
))
11318 gfc_ss
*old_ss
= ss
;
11320 ss
= gfc_walk_elemental_function_args (old_ss
,
11321 expr
->value
.function
.actual
,
11322 gfc_get_proc_ifc_for_expr (expr
),
11326 || sym
->attr
.proc_pointer
11327 || sym
->attr
.if_source
!= IFSRC_DECL
11328 || sym
->attr
.array_outer_dependency
))
11329 ss
->info
->array_outer_dependency
= 1;
11332 /* Scalar functions are OK as these are evaluated outside the scalarization
11333 loop. Pass back and let the caller deal with it. */
11338 /* An array temporary is constructed for array constructors. */
11341 gfc_walk_array_constructor (gfc_ss
* ss
, gfc_expr
* expr
)
11343 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_CONSTRUCTOR
);
11347 /* Walk an expression. Add walked expressions to the head of the SS chain.
11348 A wholly scalar expression will not be added. */
11351 gfc_walk_subexpr (gfc_ss
* ss
, gfc_expr
* expr
)
11355 switch (expr
->expr_type
)
11357 case EXPR_VARIABLE
:
11358 head
= gfc_walk_variable_expr (ss
, expr
);
11362 head
= gfc_walk_op_expr (ss
, expr
);
11365 case EXPR_FUNCTION
:
11366 head
= gfc_walk_function_expr (ss
, expr
);
11369 case EXPR_CONSTANT
:
11371 case EXPR_STRUCTURE
:
11372 /* Pass back and let the caller deal with it. */
11376 head
= gfc_walk_array_constructor (ss
, expr
);
11379 case EXPR_SUBSTRING
:
11380 /* Pass back and let the caller deal with it. */
11384 gfc_internal_error ("bad expression type during walk (%d)",
11391 /* Entry point for expression walking.
11392 A return value equal to the passed chain means this is
11393 a scalar expression. It is up to the caller to take whatever action is
11394 necessary to translate these. */
11397 gfc_walk_expr (gfc_expr
* expr
)
11401 res
= gfc_walk_subexpr (gfc_ss_terminator
, expr
);
11402 return gfc_reverse_ss (res
);