1 /* Array translation routines
2 Copyright (C) 2002-2020 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
864 && (TYPE_MAX_VALUE (TYPE_DOMAIN (tmp
)) == NULL_TREE
865 || integer_zerop (TYPE_MAX_VALUE (TYPE_DOMAIN (tmp
)))))
867 if (expr
->expr_type
== EXPR_VARIABLE
868 && expr
->ts
.type
== BT_CHARACTER
)
869 tmp
= fold_convert (gfc_array_index_type
,
870 gfc_get_expr_charlen (expr
));
875 tmp
= fold_convert (gfc_array_index_type
,
876 size_in_bytes (tmp
));
882 /* Generate an initializer for a static pointer or allocatable array. */
885 gfc_trans_static_array_pointer (gfc_symbol
* sym
)
889 gcc_assert (TREE_STATIC (sym
->backend_decl
));
890 /* Just zero the data member. */
891 type
= TREE_TYPE (sym
->backend_decl
);
892 DECL_INITIAL (sym
->backend_decl
) = gfc_build_null_descriptor (type
);
896 /* If the bounds of SE's loop have not yet been set, see if they can be
897 determined from array spec AS, which is the array spec of a called
898 function. MAPPING maps the callee's dummy arguments to the values
899 that the caller is passing. Add any initialization and finalization
903 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping
* mapping
,
904 gfc_se
* se
, gfc_array_spec
* as
)
906 int n
, dim
, total_dim
;
915 if (!as
|| as
->type
!= AS_EXPLICIT
)
918 for (ss
= se
->ss
; ss
; ss
= ss
->parent
)
920 total_dim
+= ss
->loop
->dimen
;
921 for (n
= 0; n
< ss
->loop
->dimen
; n
++)
923 /* The bound is known, nothing to do. */
924 if (ss
->loop
->to
[n
] != NULL_TREE
)
928 gcc_assert (dim
< as
->rank
);
929 gcc_assert (ss
->loop
->dimen
<= as
->rank
);
931 /* Evaluate the lower bound. */
932 gfc_init_se (&tmpse
, NULL
);
933 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->lower
[dim
]);
934 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
935 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
936 lower
= fold_convert (gfc_array_index_type
, tmpse
.expr
);
938 /* ...and the upper bound. */
939 gfc_init_se (&tmpse
, NULL
);
940 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->upper
[dim
]);
941 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
942 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
943 upper
= fold_convert (gfc_array_index_type
, tmpse
.expr
);
945 /* Set the upper bound of the loop to UPPER - LOWER. */
946 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
947 gfc_array_index_type
, upper
, lower
);
948 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
949 ss
->loop
->to
[n
] = tmp
;
953 gcc_assert (total_dim
== as
->rank
);
957 /* Generate code to allocate an array temporary, or create a variable to
958 hold the data. If size is NULL, zero the descriptor so that the
959 callee will allocate the array. If DEALLOC is true, also generate code to
960 free the array afterwards.
962 If INITIAL is not NULL, it is packed using internal_pack and the result used
963 as data instead of allocating a fresh, unitialized area of memory.
965 Initialization code is added to PRE and finalization code to POST.
966 DYNAMIC is true if the caller may want to extend the array later
967 using realloc. This prevents us from putting the array on the stack. */
970 gfc_trans_allocate_array_storage (stmtblock_t
* pre
, stmtblock_t
* post
,
971 gfc_array_info
* info
, tree size
, tree nelem
,
972 tree initial
, bool dynamic
, bool dealloc
)
978 desc
= info
->descriptor
;
979 info
->offset
= gfc_index_zero_node
;
980 if (size
== NULL_TREE
|| integer_zerop (size
))
982 /* A callee allocated array. */
983 gfc_conv_descriptor_data_set (pre
, desc
, null_pointer_node
);
988 /* Allocate the temporary. */
989 onstack
= !dynamic
&& initial
== NULL_TREE
990 && (flag_stack_arrays
991 || gfc_can_put_var_on_stack (size
));
995 /* Make a temporary variable to hold the data. */
996 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (nelem
),
997 nelem
, gfc_index_one_node
);
998 tmp
= gfc_evaluate_now (tmp
, pre
);
999 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
1001 tmp
= build_array_type (gfc_get_element_type (TREE_TYPE (desc
)),
1003 tmp
= gfc_create_var (tmp
, "A");
1004 /* If we're here only because of -fstack-arrays we have to
1005 emit a DECL_EXPR to make the gimplifier emit alloca calls. */
1006 if (!gfc_can_put_var_on_stack (size
))
1007 gfc_add_expr_to_block (pre
,
1008 fold_build1_loc (input_location
,
1009 DECL_EXPR
, TREE_TYPE (tmp
),
1011 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1012 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
1016 /* Allocate memory to hold the data or call internal_pack. */
1017 if (initial
== NULL_TREE
)
1019 tmp
= gfc_call_malloc (pre
, NULL
, size
);
1020 tmp
= gfc_evaluate_now (tmp
, pre
);
1027 stmtblock_t do_copying
;
1029 tmp
= TREE_TYPE (initial
); /* Pointer to descriptor. */
1030 gcc_assert (TREE_CODE (tmp
) == POINTER_TYPE
);
1031 tmp
= TREE_TYPE (tmp
); /* The descriptor itself. */
1032 tmp
= gfc_get_element_type (tmp
);
1033 packed
= gfc_create_var (build_pointer_type (tmp
), "data");
1035 tmp
= build_call_expr_loc (input_location
,
1036 gfor_fndecl_in_pack
, 1, initial
);
1037 tmp
= fold_convert (TREE_TYPE (packed
), tmp
);
1038 gfc_add_modify (pre
, packed
, tmp
);
1040 tmp
= build_fold_indirect_ref_loc (input_location
,
1042 source_data
= gfc_conv_descriptor_data_get (tmp
);
1044 /* internal_pack may return source->data without any allocation
1045 or copying if it is already packed. If that's the case, we
1046 need to allocate and copy manually. */
1048 gfc_start_block (&do_copying
);
1049 tmp
= gfc_call_malloc (&do_copying
, NULL
, size
);
1050 tmp
= fold_convert (TREE_TYPE (packed
), tmp
);
1051 gfc_add_modify (&do_copying
, packed
, tmp
);
1052 tmp
= gfc_build_memcpy_call (packed
, source_data
, size
);
1053 gfc_add_expr_to_block (&do_copying
, tmp
);
1055 was_packed
= fold_build2_loc (input_location
, EQ_EXPR
,
1056 logical_type_node
, packed
,
1058 tmp
= gfc_finish_block (&do_copying
);
1059 tmp
= build3_v (COND_EXPR
, was_packed
, tmp
,
1060 build_empty_stmt (input_location
));
1061 gfc_add_expr_to_block (pre
, tmp
);
1063 tmp
= fold_convert (pvoid_type_node
, packed
);
1066 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
1069 info
->data
= gfc_conv_descriptor_data_get (desc
);
1071 /* The offset is zero because we create temporaries with a zero
1073 gfc_conv_descriptor_offset_set (pre
, desc
, gfc_index_zero_node
);
1075 if (dealloc
&& !onstack
)
1077 /* Free the temporary. */
1078 tmp
= gfc_conv_descriptor_data_get (desc
);
1079 tmp
= gfc_call_free (tmp
);
1080 gfc_add_expr_to_block (post
, tmp
);
1085 /* Get the scalarizer array dimension corresponding to actual array dimension
1088 For example, if SS represents the array ref a(1,:,:,1), it is a
1089 bidimensional scalarizer array, and the result would be 0 for ARRAY_DIM=1,
1090 and 1 for ARRAY_DIM=2.
1091 If SS represents transpose(a(:,1,1,:)), it is again a bidimensional
1092 scalarizer array, and the result would be 1 for ARRAY_DIM=0 and 0 for
1094 If SS represents sum(a(:,:,:,1), dim=1), it is a 2+1-dimensional scalarizer
1095 array. If called on the inner ss, the result would be respectively 0,1,2 for
1096 ARRAY_DIM=0,1,2. If called on the outer ss, the result would be 0,1
1097 for ARRAY_DIM=1,2. */
1100 get_scalarizer_dim_for_array_dim (gfc_ss
*ss
, int array_dim
)
1107 for (; ss
; ss
= ss
->parent
)
1108 for (n
= 0; n
< ss
->dimen
; n
++)
1109 if (ss
->dim
[n
] < array_dim
)
1112 return array_ref_dim
;
1117 innermost_ss (gfc_ss
*ss
)
1119 while (ss
->nested_ss
!= NULL
)
1127 /* Get the array reference dimension corresponding to the given loop dimension.
1128 It is different from the true array dimension given by the dim array in
1129 the case of a partial array reference (i.e. a(:,:,1,:) for example)
1130 It is different from the loop dimension in the case of a transposed array.
1134 get_array_ref_dim_for_loop_dim (gfc_ss
*ss
, int loop_dim
)
1136 return get_scalarizer_dim_for_array_dim (innermost_ss (ss
),
1141 /* Use the information in the ss to obtain the required information about
1142 the type and size of an array temporary, when the lhs in an assignment
1143 is a class expression. */
1146 get_class_info_from_ss (stmtblock_t
* pre
, gfc_ss
*ss
, tree
*eltype
)
1153 tree rhs_class_expr
= NULL_TREE
;
1154 tree lhs_class_expr
= NULL_TREE
;
1155 bool unlimited_rhs
= false;
1156 bool unlimited_lhs
= false;
1157 bool rhs_function
= false;
1160 /* The second element in the loop chain contains the source for the
1161 temporary; ie. the rhs of the assignment. */
1162 rhs_ss
= ss
->loop
->ss
->loop_chain
;
1164 if (rhs_ss
!= gfc_ss_terminator
1166 && rhs_ss
->info
->expr
1167 && rhs_ss
->info
->expr
->ts
.type
== BT_CLASS
1168 && rhs_ss
->info
->data
.array
.descriptor
)
1171 = gfc_get_class_from_expr (rhs_ss
->info
->data
.array
.descriptor
);
1172 unlimited_rhs
= UNLIMITED_POLY (rhs_ss
->info
->expr
);
1173 if (rhs_ss
->info
->expr
->expr_type
== EXPR_FUNCTION
)
1174 rhs_function
= true;
1177 /* For an assignment the lhs is the next element in the loop chain.
1178 If we have a class rhs, this had better be a class variable
1180 lhs_ss
= rhs_ss
->loop_chain
;
1181 if (lhs_ss
!= gfc_ss_terminator
1183 && lhs_ss
->info
->expr
1184 && lhs_ss
->info
->expr
->expr_type
==EXPR_VARIABLE
1185 && lhs_ss
->info
->expr
->ts
.type
== BT_CLASS
)
1187 tmp
= lhs_ss
->info
->data
.array
.descriptor
;
1188 unlimited_lhs
= UNLIMITED_POLY (rhs_ss
->info
->expr
);
1193 /* Get the lhs class expression. */
1194 if (tmp
!= NULL_TREE
&& lhs_ss
->loop_chain
== gfc_ss_terminator
)
1195 lhs_class_expr
= gfc_get_class_from_expr (tmp
);
1197 return rhs_class_expr
;
1199 gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (lhs_class_expr
)));
1201 /* Set the lhs vptr and, if necessary, the _len field. */
1204 /* Both lhs and rhs are class expressions. */
1205 tmp
= gfc_class_vptr_get (lhs_class_expr
);
1206 gfc_add_modify (pre
, tmp
,
1207 fold_convert (TREE_TYPE (tmp
),
1208 gfc_class_vptr_get (rhs_class_expr
)));
1211 tmp
= gfc_class_len_get (lhs_class_expr
);
1213 tmp2
= gfc_class_len_get (rhs_class_expr
);
1215 tmp2
= build_int_cst (TREE_TYPE (tmp
), 0);
1216 gfc_add_modify (pre
, tmp
, tmp2
);
1221 tmp
= gfc_class_data_get (rhs_class_expr
);
1222 gfc_conv_descriptor_offset_set (pre
, tmp
, gfc_index_zero_node
);
1227 /* lhs is class and rhs is intrinsic or derived type. */
1228 *eltype
= TREE_TYPE (rhs_ss
->info
->data
.array
.descriptor
);
1229 *eltype
= gfc_get_element_type (*eltype
);
1230 vtab
= gfc_find_vtab (&rhs_ss
->info
->expr
->ts
);
1231 vptr
= vtab
->backend_decl
;
1232 if (vptr
== NULL_TREE
)
1233 vptr
= gfc_get_symbol_decl (vtab
);
1234 vptr
= gfc_build_addr_expr (NULL_TREE
, vptr
);
1235 tmp
= gfc_class_vptr_get (lhs_class_expr
);
1236 gfc_add_modify (pre
, tmp
,
1237 fold_convert (TREE_TYPE (tmp
), vptr
));
1241 tmp
= gfc_class_len_get (lhs_class_expr
);
1243 && rhs_ss
->info
->expr
1244 && rhs_ss
->info
->expr
->ts
.type
== BT_CHARACTER
)
1245 tmp2
= build_int_cst (TREE_TYPE (tmp
),
1246 rhs_ss
->info
->expr
->ts
.kind
);
1248 tmp2
= build_int_cst (TREE_TYPE (tmp
), 0);
1249 gfc_add_modify (pre
, tmp
, tmp2
);
1253 return rhs_class_expr
;
1258 /* Generate code to create and initialize the descriptor for a temporary
1259 array. This is used for both temporaries needed by the scalarizer, and
1260 functions returning arrays. Adjusts the loop variables to be
1261 zero-based, and calculates the loop bounds for callee allocated arrays.
1262 Allocate the array unless it's callee allocated (we have a callee
1263 allocated array if 'callee_alloc' is true, or if loop->to[n] is
1264 NULL_TREE for any n). Also fills in the descriptor, data and offset
1265 fields of info if known. Returns the size of the array, or NULL for a
1266 callee allocated array.
1268 'eltype' == NULL signals that the temporary should be a class object.
1269 The 'initial' expression is used to obtain the size of the dynamic
1270 type; otherwise the allocation and initialization proceeds as for any
1273 PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
1274 gfc_trans_allocate_array_storage. */
1277 gfc_trans_create_temp_array (stmtblock_t
* pre
, stmtblock_t
* post
, gfc_ss
* ss
,
1278 tree eltype
, tree initial
, bool dynamic
,
1279 bool dealloc
, bool callee_alloc
, locus
* where
)
1283 gfc_array_info
*info
;
1284 tree from
[GFC_MAX_DIMENSIONS
], to
[GFC_MAX_DIMENSIONS
];
1293 tree class_expr
= NULL_TREE
;
1294 int n
, dim
, tmp_dim
;
1297 /* This signals a class array for which we need the size of the
1298 dynamic type. Generate an eltype and then the class expression. */
1299 if (eltype
== NULL_TREE
&& initial
)
1301 gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial
)));
1302 class_expr
= build_fold_indirect_ref_loc (input_location
, initial
);
1303 /* Obtain the structure (class) expression. */
1304 class_expr
= gfc_get_class_from_expr (class_expr
);
1305 gcc_assert (class_expr
);
1308 /* Otherwise, some expressions, such as class functions, arising from
1309 dependency checking in assignments come here with class element type.
1310 The descriptor can be obtained from the ss->info and then converted
1311 to the class object. */
1312 if (class_expr
== NULL_TREE
&& GFC_CLASS_TYPE_P (eltype
))
1313 class_expr
= get_class_info_from_ss (pre
, ss
, &eltype
);
1315 /* If the dynamic type is not available, use the declared type. */
1316 if (eltype
&& GFC_CLASS_TYPE_P (eltype
))
1317 eltype
= gfc_get_element_type (TREE_TYPE (TYPE_FIELDS (eltype
)));
1319 if (class_expr
== NULL_TREE
)
1320 elemsize
= fold_convert (gfc_array_index_type
,
1321 TYPE_SIZE_UNIT (eltype
));
1324 /* Unlimited polymorphic entities are initialised with NULL vptr. They
1325 can be tested for by checking if the len field is present. If so
1326 test the vptr before using the vtable size. */
1327 tmp
= gfc_class_vptr_get (class_expr
);
1328 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
1330 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
1331 elemsize
= fold_build3_loc (input_location
, COND_EXPR
,
1332 gfc_array_index_type
,
1334 gfc_class_vtab_size_get (class_expr
),
1335 gfc_index_zero_node
);
1336 elemsize
= gfc_evaluate_now (elemsize
, pre
);
1337 elemsize
= gfc_resize_class_size_with_len (pre
, class_expr
, elemsize
);
1338 /* Casting the data as a character of the dynamic length ensures that
1339 assignment of elements works when needed. */
1340 eltype
= gfc_get_character_type_len (1, elemsize
);
1343 memset (from
, 0, sizeof (from
));
1344 memset (to
, 0, sizeof (to
));
1346 info
= &ss
->info
->data
.array
;
1348 gcc_assert (ss
->dimen
> 0);
1349 gcc_assert (ss
->loop
->dimen
== ss
->dimen
);
1351 if (warn_array_temporaries
&& where
)
1352 gfc_warning (OPT_Warray_temporaries
,
1353 "Creating array temporary at %L", where
);
1355 /* Set the lower bound to zero. */
1356 for (s
= ss
; s
; s
= s
->parent
)
1360 total_dim
+= loop
->dimen
;
1361 for (n
= 0; n
< loop
->dimen
; n
++)
1365 /* Callee allocated arrays may not have a known bound yet. */
1367 loop
->to
[n
] = gfc_evaluate_now (
1368 fold_build2_loc (input_location
, MINUS_EXPR
,
1369 gfc_array_index_type
,
1370 loop
->to
[n
], loop
->from
[n
]),
1372 loop
->from
[n
] = gfc_index_zero_node
;
1374 /* We have just changed the loop bounds, we must clear the
1375 corresponding specloop, so that delta calculation is not skipped
1376 later in gfc_set_delta. */
1377 loop
->specloop
[n
] = NULL
;
1379 /* We are constructing the temporary's descriptor based on the loop
1380 dimensions. As the dimensions may be accessed in arbitrary order
1381 (think of transpose) the size taken from the n'th loop may not map
1382 to the n'th dimension of the array. We need to reconstruct loop
1383 infos in the right order before using it to set the descriptor
1385 tmp_dim
= get_scalarizer_dim_for_array_dim (ss
, dim
);
1386 from
[tmp_dim
] = loop
->from
[n
];
1387 to
[tmp_dim
] = loop
->to
[n
];
1389 info
->delta
[dim
] = gfc_index_zero_node
;
1390 info
->start
[dim
] = gfc_index_zero_node
;
1391 info
->end
[dim
] = gfc_index_zero_node
;
1392 info
->stride
[dim
] = gfc_index_one_node
;
1396 /* Initialize the descriptor. */
1398 gfc_get_array_type_bounds (eltype
, total_dim
, 0, from
, to
, 1,
1399 GFC_ARRAY_UNKNOWN
, true);
1400 desc
= gfc_create_var (type
, "atmp");
1401 GFC_DECL_PACKED_ARRAY (desc
) = 1;
1403 info
->descriptor
= desc
;
1404 size
= gfc_index_one_node
;
1406 /* Emit a DECL_EXPR for the variable sized array type in
1407 GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
1408 sizes works correctly. */
1409 tree arraytype
= TREE_TYPE (GFC_TYPE_ARRAY_DATAPTR_TYPE (type
));
1410 if (! TYPE_NAME (arraytype
))
1411 TYPE_NAME (arraytype
) = build_decl (UNKNOWN_LOCATION
, TYPE_DECL
,
1412 NULL_TREE
, arraytype
);
1413 gfc_add_expr_to_block (pre
, build1 (DECL_EXPR
,
1414 arraytype
, TYPE_NAME (arraytype
)));
1416 /* Fill in the array dtype. */
1417 tmp
= gfc_conv_descriptor_dtype (desc
);
1418 gfc_add_modify (pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
1421 Fill in the bounds and stride. This is a packed array, so:
1424 for (n = 0; n < rank; n++)
1427 delta = ubound[n] + 1 - lbound[n];
1428 size = size * delta;
1430 size = size * sizeof(element);
1433 or_expr
= NULL_TREE
;
1435 /* If there is at least one null loop->to[n], it is a callee allocated
1437 for (n
= 0; n
< total_dim
; n
++)
1438 if (to
[n
] == NULL_TREE
)
1444 if (size
== NULL_TREE
)
1445 for (s
= ss
; s
; s
= s
->parent
)
1446 for (n
= 0; n
< s
->loop
->dimen
; n
++)
1448 dim
= get_scalarizer_dim_for_array_dim (ss
, s
->dim
[n
]);
1450 /* For a callee allocated array express the loop bounds in terms
1451 of the descriptor fields. */
1452 tmp
= fold_build2_loc (input_location
,
1453 MINUS_EXPR
, gfc_array_index_type
,
1454 gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]),
1455 gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]));
1456 s
->loop
->to
[n
] = tmp
;
1460 for (n
= 0; n
< total_dim
; n
++)
1462 /* Store the stride and bound components in the descriptor. */
1463 gfc_conv_descriptor_stride_set (pre
, desc
, gfc_rank_cst
[n
], size
);
1465 gfc_conv_descriptor_lbound_set (pre
, desc
, gfc_rank_cst
[n
],
1466 gfc_index_zero_node
);
1468 gfc_conv_descriptor_ubound_set (pre
, desc
, gfc_rank_cst
[n
], to
[n
]);
1470 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1471 gfc_array_index_type
,
1472 to
[n
], gfc_index_one_node
);
1474 /* Check whether the size for this dimension is negative. */
1475 cond
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
1476 tmp
, gfc_index_zero_node
);
1477 cond
= gfc_evaluate_now (cond
, pre
);
1482 or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1483 logical_type_node
, or_expr
, cond
);
1485 size
= fold_build2_loc (input_location
, MULT_EXPR
,
1486 gfc_array_index_type
, size
, tmp
);
1487 size
= gfc_evaluate_now (size
, pre
);
1491 /* Get the size of the array. */
1492 if (size
&& !callee_alloc
)
1494 /* If or_expr is true, then the extent in at least one
1495 dimension is zero and the size is set to zero. */
1496 size
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
1497 or_expr
, gfc_index_zero_node
, size
);
1500 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
1510 tmp
= fold_convert (gfc_array_index_type
, elemsize
);
1511 gfc_conv_descriptor_span_set (pre
, desc
, tmp
);
1513 gfc_trans_allocate_array_storage (pre
, post
, info
, size
, nelem
, initial
,
1519 if (ss
->dimen
> ss
->loop
->temp_dim
)
1520 ss
->loop
->temp_dim
= ss
->dimen
;
1526 /* Return the number of iterations in a loop that starts at START,
1527 ends at END, and has step STEP. */
1530 gfc_get_iteration_count (tree start
, tree end
, tree step
)
1535 type
= TREE_TYPE (step
);
1536 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, end
, start
);
1537 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
, type
, tmp
, step
);
1538 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
,
1539 build_int_cst (type
, 1));
1540 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, type
, tmp
,
1541 build_int_cst (type
, 0));
1542 return fold_convert (gfc_array_index_type
, tmp
);
1546 /* Extend the data in array DESC by EXTRA elements. */
1549 gfc_grow_array (stmtblock_t
* pblock
, tree desc
, tree extra
)
1556 if (integer_zerop (extra
))
1559 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[0]);
1561 /* Add EXTRA to the upper bound. */
1562 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1564 gfc_conv_descriptor_ubound_set (pblock
, desc
, gfc_rank_cst
[0], tmp
);
1566 /* Get the value of the current data pointer. */
1567 arg0
= gfc_conv_descriptor_data_get (desc
);
1569 /* Calculate the new array size. */
1570 size
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
1571 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1572 ubound
, gfc_index_one_node
);
1573 arg1
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
1574 fold_convert (size_type_node
, tmp
),
1575 fold_convert (size_type_node
, size
));
1577 /* Call the realloc() function. */
1578 tmp
= gfc_call_realloc (pblock
, arg0
, arg1
);
1579 gfc_conv_descriptor_data_set (pblock
, desc
, tmp
);
1583 /* Return true if the bounds of iterator I can only be determined
1587 gfc_iterator_has_dynamic_bounds (gfc_iterator
* i
)
1589 return (i
->start
->expr_type
!= EXPR_CONSTANT
1590 || i
->end
->expr_type
!= EXPR_CONSTANT
1591 || i
->step
->expr_type
!= EXPR_CONSTANT
);
1595 /* Split the size of constructor element EXPR into the sum of two terms,
1596 one of which can be determined at compile time and one of which must
1597 be calculated at run time. Set *SIZE to the former and return true
1598 if the latter might be nonzero. */
1601 gfc_get_array_constructor_element_size (mpz_t
* size
, gfc_expr
* expr
)
1603 if (expr
->expr_type
== EXPR_ARRAY
)
1604 return gfc_get_array_constructor_size (size
, expr
->value
.constructor
);
1605 else if (expr
->rank
> 0)
1607 /* Calculate everything at run time. */
1608 mpz_set_ui (*size
, 0);
1613 /* A single element. */
1614 mpz_set_ui (*size
, 1);
1620 /* Like gfc_get_array_constructor_element_size, but applied to the whole
1621 of array constructor C. */
1624 gfc_get_array_constructor_size (mpz_t
* size
, gfc_constructor_base base
)
1632 mpz_set_ui (*size
, 0);
1637 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1640 if (i
&& gfc_iterator_has_dynamic_bounds (i
))
1644 dynamic
|= gfc_get_array_constructor_element_size (&len
, c
->expr
);
1647 /* Multiply the static part of the element size by the
1648 number of iterations. */
1649 mpz_sub (val
, i
->end
->value
.integer
, i
->start
->value
.integer
);
1650 mpz_fdiv_q (val
, val
, i
->step
->value
.integer
);
1651 mpz_add_ui (val
, val
, 1);
1652 if (mpz_sgn (val
) > 0)
1653 mpz_mul (len
, len
, val
);
1655 mpz_set_ui (len
, 0);
1657 mpz_add (*size
, *size
, len
);
1666 /* Make sure offset is a variable. */
1669 gfc_put_offset_into_var (stmtblock_t
* pblock
, tree
* poffset
,
1672 /* We should have already created the offset variable. We cannot
1673 create it here because we may be in an inner scope. */
1674 gcc_assert (*offsetvar
!= NULL_TREE
);
1675 gfc_add_modify (pblock
, *offsetvar
, *poffset
);
1676 *poffset
= *offsetvar
;
1677 TREE_USED (*offsetvar
) = 1;
1681 /* Variables needed for bounds-checking. */
1682 static bool first_len
;
1683 static tree first_len_val
;
1684 static bool typespec_chararray_ctor
;
1687 gfc_trans_array_ctor_element (stmtblock_t
* pblock
, tree desc
,
1688 tree offset
, gfc_se
* se
, gfc_expr
* expr
)
1692 gfc_conv_expr (se
, expr
);
1694 /* Store the value. */
1695 tmp
= build_fold_indirect_ref_loc (input_location
,
1696 gfc_conv_descriptor_data_get (desc
));
1697 tmp
= gfc_build_array_ref (tmp
, offset
, NULL
);
1699 if (expr
->ts
.type
== BT_CHARACTER
)
1701 int i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
1704 esize
= size_in_bytes (gfc_get_element_type (TREE_TYPE (desc
)));
1705 esize
= fold_convert (gfc_charlen_type_node
, esize
);
1706 esize
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1707 TREE_TYPE (esize
), esize
,
1708 build_int_cst (TREE_TYPE (esize
),
1709 gfc_character_kinds
[i
].bit_size
/ 8));
1711 gfc_conv_string_parameter (se
);
1712 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
1714 /* The temporary is an array of pointers. */
1715 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1716 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1720 /* The temporary is an array of string values. */
1721 tmp
= gfc_build_addr_expr (gfc_get_pchar_type (expr
->ts
.kind
), tmp
);
1722 /* We know the temporary and the value will be the same length,
1723 so can use memcpy. */
1724 gfc_trans_string_copy (&se
->pre
, esize
, tmp
, expr
->ts
.kind
,
1725 se
->string_length
, se
->expr
, expr
->ts
.kind
);
1727 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && !typespec_chararray_ctor
)
1731 gfc_add_modify (&se
->pre
, first_len_val
,
1732 fold_convert (TREE_TYPE (first_len_val
),
1733 se
->string_length
));
1738 /* Verify that all constructor elements are of the same
1740 tree rhs
= fold_convert (TREE_TYPE (first_len_val
),
1742 tree cond
= fold_build2_loc (input_location
, NE_EXPR
,
1743 logical_type_node
, first_len_val
,
1745 gfc_trans_runtime_check
1746 (true, false, cond
, &se
->pre
, &expr
->where
,
1747 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1748 fold_convert (long_integer_type_node
, first_len_val
),
1749 fold_convert (long_integer_type_node
, se
->string_length
));
1753 else if (GFC_CLASS_TYPE_P (TREE_TYPE (se
->expr
))
1754 && !GFC_CLASS_TYPE_P (gfc_get_element_type (TREE_TYPE (desc
))))
1756 /* Assignment of a CLASS array constructor to a derived type array. */
1757 if (expr
->expr_type
== EXPR_FUNCTION
)
1758 se
->expr
= gfc_evaluate_now (se
->expr
, pblock
);
1759 se
->expr
= gfc_class_data_get (se
->expr
);
1760 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
1761 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1762 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1766 /* TODO: Should the frontend already have done this conversion? */
1767 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1768 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1771 gfc_add_block_to_block (pblock
, &se
->pre
);
1772 gfc_add_block_to_block (pblock
, &se
->post
);
1776 /* Add the contents of an array to the constructor. DYNAMIC is as for
1777 gfc_trans_array_constructor_value. */
1780 gfc_trans_array_constructor_subarray (stmtblock_t
* pblock
,
1781 tree type ATTRIBUTE_UNUSED
,
1782 tree desc
, gfc_expr
* expr
,
1783 tree
* poffset
, tree
* offsetvar
,
1794 /* We need this to be a variable so we can increment it. */
1795 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1797 gfc_init_se (&se
, NULL
);
1799 /* Walk the array expression. */
1800 ss
= gfc_walk_expr (expr
);
1801 gcc_assert (ss
!= gfc_ss_terminator
);
1803 /* Initialize the scalarizer. */
1804 gfc_init_loopinfo (&loop
);
1805 gfc_add_ss_to_loop (&loop
, ss
);
1807 /* Initialize the loop. */
1808 gfc_conv_ss_startstride (&loop
);
1809 gfc_conv_loop_setup (&loop
, &expr
->where
);
1811 /* Make sure the constructed array has room for the new data. */
1814 /* Set SIZE to the total number of elements in the subarray. */
1815 size
= gfc_index_one_node
;
1816 for (n
= 0; n
< loop
.dimen
; n
++)
1818 tmp
= gfc_get_iteration_count (loop
.from
[n
], loop
.to
[n
],
1819 gfc_index_one_node
);
1820 size
= fold_build2_loc (input_location
, MULT_EXPR
,
1821 gfc_array_index_type
, size
, tmp
);
1824 /* Grow the constructed array by SIZE elements. */
1825 gfc_grow_array (&loop
.pre
, desc
, size
);
1828 /* Make the loop body. */
1829 gfc_mark_ss_chain_used (ss
, 1);
1830 gfc_start_scalarized_body (&loop
, &body
);
1831 gfc_copy_loopinfo_to_se (&se
, &loop
);
1834 gfc_trans_array_ctor_element (&body
, desc
, *poffset
, &se
, expr
);
1835 gcc_assert (se
.ss
== gfc_ss_terminator
);
1837 /* Increment the offset. */
1838 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1839 *poffset
, gfc_index_one_node
);
1840 gfc_add_modify (&body
, *poffset
, tmp
);
1842 /* Finish the loop. */
1843 gfc_trans_scalarizing_loops (&loop
, &body
);
1844 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
1845 tmp
= gfc_finish_block (&loop
.pre
);
1846 gfc_add_expr_to_block (pblock
, tmp
);
1848 gfc_cleanup_loop (&loop
);
1852 /* Assign the values to the elements of an array constructor. DYNAMIC
1853 is true if descriptor DESC only contains enough data for the static
1854 size calculated by gfc_get_array_constructor_size. When true, memory
1855 for the dynamic parts must be allocated using realloc. */
1858 gfc_trans_array_constructor_value (stmtblock_t
* pblock
, tree type
,
1859 tree desc
, gfc_constructor_base base
,
1860 tree
* poffset
, tree
* offsetvar
,
1864 tree start
= NULL_TREE
;
1865 tree end
= NULL_TREE
;
1866 tree step
= NULL_TREE
;
1872 tree shadow_loopvar
= NULL_TREE
;
1873 gfc_saved_var saved_loopvar
;
1876 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1878 /* If this is an iterator or an array, the offset must be a variable. */
1879 if ((c
->iterator
|| c
->expr
->rank
> 0) && INTEGER_CST_P (*poffset
))
1880 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1882 /* Shadowing the iterator avoids changing its value and saves us from
1883 keeping track of it. Further, it makes sure that there's always a
1884 backend-decl for the symbol, even if there wasn't one before,
1885 e.g. in the case of an iterator that appears in a specification
1886 expression in an interface mapping. */
1892 /* Evaluate loop bounds before substituting the loop variable
1893 in case they depend on it. Such a case is invalid, but it is
1894 not more expensive to do the right thing here.
1896 gfc_init_se (&se
, NULL
);
1897 gfc_conv_expr_val (&se
, c
->iterator
->start
);
1898 gfc_add_block_to_block (pblock
, &se
.pre
);
1899 start
= gfc_evaluate_now (se
.expr
, pblock
);
1901 gfc_init_se (&se
, NULL
);
1902 gfc_conv_expr_val (&se
, c
->iterator
->end
);
1903 gfc_add_block_to_block (pblock
, &se
.pre
);
1904 end
= gfc_evaluate_now (se
.expr
, pblock
);
1906 gfc_init_se (&se
, NULL
);
1907 gfc_conv_expr_val (&se
, c
->iterator
->step
);
1908 gfc_add_block_to_block (pblock
, &se
.pre
);
1909 step
= gfc_evaluate_now (se
.expr
, pblock
);
1911 sym
= c
->iterator
->var
->symtree
->n
.sym
;
1912 type
= gfc_typenode_for_spec (&sym
->ts
);
1914 shadow_loopvar
= gfc_create_var (type
, "shadow_loopvar");
1915 gfc_shadow_sym (sym
, shadow_loopvar
, &saved_loopvar
);
1918 gfc_start_block (&body
);
1920 if (c
->expr
->expr_type
== EXPR_ARRAY
)
1922 /* Array constructors can be nested. */
1923 gfc_trans_array_constructor_value (&body
, type
, desc
,
1924 c
->expr
->value
.constructor
,
1925 poffset
, offsetvar
, dynamic
);
1927 else if (c
->expr
->rank
> 0)
1929 gfc_trans_array_constructor_subarray (&body
, type
, desc
, c
->expr
,
1930 poffset
, offsetvar
, dynamic
);
1934 /* This code really upsets the gimplifier so don't bother for now. */
1941 while (p
&& !(p
->iterator
|| p
->expr
->expr_type
!= EXPR_CONSTANT
))
1943 p
= gfc_constructor_next (p
);
1948 /* Scalar values. */
1949 gfc_init_se (&se
, NULL
);
1950 gfc_trans_array_ctor_element (&body
, desc
, *poffset
,
1953 *poffset
= fold_build2_loc (input_location
, PLUS_EXPR
,
1954 gfc_array_index_type
,
1955 *poffset
, gfc_index_one_node
);
1959 /* Collect multiple scalar constants into a constructor. */
1960 vec
<constructor_elt
, va_gc
> *v
= NULL
;
1964 HOST_WIDE_INT idx
= 0;
1967 /* Count the number of consecutive scalar constants. */
1968 while (p
&& !(p
->iterator
1969 || p
->expr
->expr_type
!= EXPR_CONSTANT
))
1971 gfc_init_se (&se
, NULL
);
1972 gfc_conv_constant (&se
, p
->expr
);
1974 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
1975 se
.expr
= fold_convert (type
, se
.expr
);
1976 /* For constant character array constructors we build
1977 an array of pointers. */
1978 else if (POINTER_TYPE_P (type
))
1979 se
.expr
= gfc_build_addr_expr
1980 (gfc_get_pchar_type (p
->expr
->ts
.kind
),
1983 CONSTRUCTOR_APPEND_ELT (v
,
1984 build_int_cst (gfc_array_index_type
,
1988 p
= gfc_constructor_next (p
);
1991 bound
= size_int (n
- 1);
1992 /* Create an array type to hold them. */
1993 tmptype
= build_range_type (gfc_array_index_type
,
1994 gfc_index_zero_node
, bound
);
1995 tmptype
= build_array_type (type
, tmptype
);
1997 init
= build_constructor (tmptype
, v
);
1998 TREE_CONSTANT (init
) = 1;
1999 TREE_STATIC (init
) = 1;
2000 /* Create a static variable to hold the data. */
2001 tmp
= gfc_create_var (tmptype
, "data");
2002 TREE_STATIC (tmp
) = 1;
2003 TREE_CONSTANT (tmp
) = 1;
2004 TREE_READONLY (tmp
) = 1;
2005 DECL_INITIAL (tmp
) = init
;
2008 /* Use BUILTIN_MEMCPY to assign the values. */
2009 tmp
= gfc_conv_descriptor_data_get (desc
);
2010 tmp
= build_fold_indirect_ref_loc (input_location
,
2012 tmp
= gfc_build_array_ref (tmp
, *poffset
, NULL
);
2013 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2014 init
= gfc_build_addr_expr (NULL_TREE
, init
);
2016 size
= TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type
));
2017 bound
= build_int_cst (size_type_node
, n
* size
);
2018 tmp
= build_call_expr_loc (input_location
,
2019 builtin_decl_explicit (BUILT_IN_MEMCPY
),
2020 3, tmp
, init
, bound
);
2021 gfc_add_expr_to_block (&body
, tmp
);
2023 *poffset
= fold_build2_loc (input_location
, PLUS_EXPR
,
2024 gfc_array_index_type
, *poffset
,
2025 build_int_cst (gfc_array_index_type
, n
));
2027 if (!INTEGER_CST_P (*poffset
))
2029 gfc_add_modify (&body
, *offsetvar
, *poffset
);
2030 *poffset
= *offsetvar
;
2034 /* The frontend should already have done any expansions
2038 /* Pass the code as is. */
2039 tmp
= gfc_finish_block (&body
);
2040 gfc_add_expr_to_block (pblock
, tmp
);
2044 /* Build the implied do-loop. */
2045 stmtblock_t implied_do_block
;
2051 loopbody
= gfc_finish_block (&body
);
2053 /* Create a new block that holds the implied-do loop. A temporary
2054 loop-variable is used. */
2055 gfc_start_block(&implied_do_block
);
2057 /* Initialize the loop. */
2058 gfc_add_modify (&implied_do_block
, shadow_loopvar
, start
);
2060 /* If this array expands dynamically, and the number of iterations
2061 is not constant, we won't have allocated space for the static
2062 part of C->EXPR's size. Do that now. */
2063 if (dynamic
&& gfc_iterator_has_dynamic_bounds (c
->iterator
))
2065 /* Get the number of iterations. */
2066 tmp
= gfc_get_iteration_count (shadow_loopvar
, end
, step
);
2068 /* Get the static part of C->EXPR's size. */
2069 gfc_get_array_constructor_element_size (&size
, c
->expr
);
2070 tmp2
= gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
2072 /* Grow the array by TMP * TMP2 elements. */
2073 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
2074 gfc_array_index_type
, tmp
, tmp2
);
2075 gfc_grow_array (&implied_do_block
, desc
, tmp
);
2078 /* Generate the loop body. */
2079 exit_label
= gfc_build_label_decl (NULL_TREE
);
2080 gfc_start_block (&body
);
2082 /* Generate the exit condition. Depending on the sign of
2083 the step variable we have to generate the correct
2085 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
2086 step
, build_int_cst (TREE_TYPE (step
), 0));
2087 cond
= fold_build3_loc (input_location
, COND_EXPR
,
2088 logical_type_node
, tmp
,
2089 fold_build2_loc (input_location
, GT_EXPR
,
2090 logical_type_node
, shadow_loopvar
, end
),
2091 fold_build2_loc (input_location
, LT_EXPR
,
2092 logical_type_node
, shadow_loopvar
, end
));
2093 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2094 TREE_USED (exit_label
) = 1;
2095 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
2096 build_empty_stmt (input_location
));
2097 gfc_add_expr_to_block (&body
, tmp
);
2099 /* The main loop body. */
2100 gfc_add_expr_to_block (&body
, loopbody
);
2102 /* Increase loop variable by step. */
2103 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2104 TREE_TYPE (shadow_loopvar
), shadow_loopvar
,
2106 gfc_add_modify (&body
, shadow_loopvar
, tmp
);
2108 /* Finish the loop. */
2109 tmp
= gfc_finish_block (&body
);
2110 tmp
= build1_v (LOOP_EXPR
, tmp
);
2111 gfc_add_expr_to_block (&implied_do_block
, tmp
);
2113 /* Add the exit label. */
2114 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2115 gfc_add_expr_to_block (&implied_do_block
, tmp
);
2117 /* Finish the implied-do loop. */
2118 tmp
= gfc_finish_block(&implied_do_block
);
2119 gfc_add_expr_to_block(pblock
, tmp
);
2121 gfc_restore_sym (c
->iterator
->var
->symtree
->n
.sym
, &saved_loopvar
);
2128 /* The array constructor code can create a string length with an operand
2129 in the form of a temporary variable. This variable will retain its
2130 context (current_function_decl). If we store this length tree in a
2131 gfc_charlen structure which is shared by a variable in another
2132 context, the resulting gfc_charlen structure with a variable in a
2133 different context, we could trip the assertion in expand_expr_real_1
2134 when it sees that a variable has been created in one context and
2135 referenced in another.
2137 If this might be the case, we create a new gfc_charlen structure and
2138 link it into the current namespace. */
2141 store_backend_decl (gfc_charlen
**clp
, tree len
, bool force_new_cl
)
2145 gfc_charlen
*new_cl
= gfc_new_charlen (gfc_current_ns
, *clp
);
2148 (*clp
)->backend_decl
= len
;
2151 /* A catch-all to obtain the string length for anything that is not
2152 a substring of non-constant length, a constant, array or variable. */
2155 get_array_ctor_all_strlen (stmtblock_t
*block
, gfc_expr
*e
, tree
*len
)
2159 /* Don't bother if we already know the length is a constant. */
2160 if (*len
&& INTEGER_CST_P (*len
))
2163 if (!e
->ref
&& e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
2164 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2167 gfc_conv_const_charlen (e
->ts
.u
.cl
);
2168 *len
= e
->ts
.u
.cl
->backend_decl
;
2172 /* Otherwise, be brutal even if inefficient. */
2173 gfc_init_se (&se
, NULL
);
2175 /* No function call, in case of side effects. */
2176 se
.no_function_call
= 1;
2178 gfc_conv_expr (&se
, e
);
2180 gfc_conv_expr_descriptor (&se
, e
);
2182 /* Fix the value. */
2183 *len
= gfc_evaluate_now (se
.string_length
, &se
.pre
);
2185 gfc_add_block_to_block (block
, &se
.pre
);
2186 gfc_add_block_to_block (block
, &se
.post
);
2188 store_backend_decl (&e
->ts
.u
.cl
, *len
, true);
2193 /* Figure out the string length of a variable reference expression.
2194 Used by get_array_ctor_strlen. */
2197 get_array_ctor_var_strlen (stmtblock_t
*block
, gfc_expr
* expr
, tree
* len
)
2203 /* Don't bother if we already know the length is a constant. */
2204 if (*len
&& INTEGER_CST_P (*len
))
2207 ts
= &expr
->symtree
->n
.sym
->ts
;
2208 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2213 /* Array references don't change the string length. */
2215 get_array_ctor_all_strlen (block
, expr
, len
);
2219 /* Use the length of the component. */
2220 ts
= &ref
->u
.c
.component
->ts
;
2224 if (ref
->u
.ss
.end
== NULL
2225 || ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
2226 || ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
2228 /* Note that this might evaluate expr. */
2229 get_array_ctor_all_strlen (block
, expr
, len
);
2232 mpz_init_set_ui (char_len
, 1);
2233 mpz_add (char_len
, char_len
, ref
->u
.ss
.end
->value
.integer
);
2234 mpz_sub (char_len
, char_len
, ref
->u
.ss
.start
->value
.integer
);
2235 *len
= gfc_conv_mpz_to_tree_type (char_len
, gfc_charlen_type_node
);
2236 mpz_clear (char_len
);
2247 *len
= ts
->u
.cl
->backend_decl
;
2251 /* Figure out the string length of a character array constructor.
2252 If len is NULL, don't calculate the length; this happens for recursive calls
2253 when a sub-array-constructor is an element but not at the first position,
2254 so when we're not interested in the length.
2255 Returns TRUE if all elements are character constants. */
2258 get_array_ctor_strlen (stmtblock_t
*block
, gfc_constructor_base base
, tree
* len
)
2265 if (gfc_constructor_first (base
) == NULL
)
2268 *len
= build_int_cstu (gfc_charlen_type_node
, 0);
2272 /* Loop over all constructor elements to find out is_const, but in len we
2273 want to store the length of the first, not the last, element. We can
2274 of course exit the loop as soon as is_const is found to be false. */
2275 for (c
= gfc_constructor_first (base
);
2276 c
&& is_const
; c
= gfc_constructor_next (c
))
2278 switch (c
->expr
->expr_type
)
2281 if (len
&& !(*len
&& INTEGER_CST_P (*len
)))
2282 *len
= build_int_cstu (gfc_charlen_type_node
,
2283 c
->expr
->value
.character
.length
);
2287 if (!get_array_ctor_strlen (block
, c
->expr
->value
.constructor
, len
))
2294 get_array_ctor_var_strlen (block
, c
->expr
, len
);
2300 get_array_ctor_all_strlen (block
, c
->expr
, len
);
2304 /* After the first iteration, we don't want the length modified. */
2311 /* Check whether the array constructor C consists entirely of constant
2312 elements, and if so returns the number of those elements, otherwise
2313 return zero. Note, an empty or NULL array constructor returns zero. */
2315 unsigned HOST_WIDE_INT
2316 gfc_constant_array_constructor_p (gfc_constructor_base base
)
2318 unsigned HOST_WIDE_INT nelem
= 0;
2320 gfc_constructor
*c
= gfc_constructor_first (base
);
2324 || c
->expr
->rank
> 0
2325 || c
->expr
->expr_type
!= EXPR_CONSTANT
)
2327 c
= gfc_constructor_next (c
);
2334 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
2335 and the tree type of it's elements, TYPE, return a static constant
2336 variable that is compile-time initialized. */
2339 gfc_build_constant_array_constructor (gfc_expr
* expr
, tree type
)
2341 tree tmptype
, init
, tmp
;
2342 HOST_WIDE_INT nelem
;
2347 vec
<constructor_elt
, va_gc
> *v
= NULL
;
2349 /* First traverse the constructor list, converting the constants
2350 to tree to build an initializer. */
2352 c
= gfc_constructor_first (expr
->value
.constructor
);
2355 gfc_init_se (&se
, NULL
);
2356 gfc_conv_constant (&se
, c
->expr
);
2357 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
2358 se
.expr
= fold_convert (type
, se
.expr
);
2359 else if (POINTER_TYPE_P (type
))
2360 se
.expr
= gfc_build_addr_expr (gfc_get_pchar_type (c
->expr
->ts
.kind
),
2362 CONSTRUCTOR_APPEND_ELT (v
, build_int_cst (gfc_array_index_type
, nelem
),
2364 c
= gfc_constructor_next (c
);
2368 /* Next determine the tree type for the array. We use the gfortran
2369 front-end's gfc_get_nodesc_array_type in order to create a suitable
2370 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
2372 memset (&as
, 0, sizeof (gfc_array_spec
));
2374 as
.rank
= expr
->rank
;
2375 as
.type
= AS_EXPLICIT
;
2378 as
.lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2379 as
.upper
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
2383 for (i
= 0; i
< expr
->rank
; i
++)
2385 int tmp
= (int) mpz_get_si (expr
->shape
[i
]);
2386 as
.lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2387 as
.upper
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
2391 tmptype
= gfc_get_nodesc_array_type (type
, &as
, PACKED_STATIC
, true);
2393 /* as is not needed anymore. */
2394 for (i
= 0; i
< as
.rank
+ as
.corank
; i
++)
2396 gfc_free_expr (as
.lower
[i
]);
2397 gfc_free_expr (as
.upper
[i
]);
2400 init
= build_constructor (tmptype
, v
);
2402 TREE_CONSTANT (init
) = 1;
2403 TREE_STATIC (init
) = 1;
2405 tmp
= build_decl (input_location
, VAR_DECL
, create_tmp_var_name ("A"),
2407 DECL_ARTIFICIAL (tmp
) = 1;
2408 DECL_IGNORED_P (tmp
) = 1;
2409 TREE_STATIC (tmp
) = 1;
2410 TREE_CONSTANT (tmp
) = 1;
2411 TREE_READONLY (tmp
) = 1;
2412 DECL_INITIAL (tmp
) = init
;
2419 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
2420 This mostly initializes the scalarizer state info structure with the
2421 appropriate values to directly use the array created by the function
2422 gfc_build_constant_array_constructor. */
2425 trans_constant_array_constructor (gfc_ss
* ss
, tree type
)
2427 gfc_array_info
*info
;
2431 tmp
= gfc_build_constant_array_constructor (ss
->info
->expr
, type
);
2433 info
= &ss
->info
->data
.array
;
2435 info
->descriptor
= tmp
;
2436 info
->data
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2437 info
->offset
= gfc_index_zero_node
;
2439 for (i
= 0; i
< ss
->dimen
; i
++)
2441 info
->delta
[i
] = gfc_index_zero_node
;
2442 info
->start
[i
] = gfc_index_zero_node
;
2443 info
->end
[i
] = gfc_index_zero_node
;
2444 info
->stride
[i
] = gfc_index_one_node
;
2450 get_rank (gfc_loopinfo
*loop
)
2455 for (; loop
; loop
= loop
->parent
)
2456 rank
+= loop
->dimen
;
2462 /* Helper routine of gfc_trans_array_constructor to determine if the
2463 bounds of the loop specified by LOOP are constant and simple enough
2464 to use with trans_constant_array_constructor. Returns the
2465 iteration count of the loop if suitable, and NULL_TREE otherwise. */
2468 constant_array_constructor_loop_size (gfc_loopinfo
* l
)
2471 tree size
= gfc_index_one_node
;
2475 total_dim
= get_rank (l
);
2477 for (loop
= l
; loop
; loop
= loop
->parent
)
2479 for (i
= 0; i
< loop
->dimen
; i
++)
2481 /* If the bounds aren't constant, return NULL_TREE. */
2482 if (!INTEGER_CST_P (loop
->from
[i
]) || !INTEGER_CST_P (loop
->to
[i
]))
2484 if (!integer_zerop (loop
->from
[i
]))
2486 /* Only allow nonzero "from" in one-dimensional arrays. */
2489 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2490 gfc_array_index_type
,
2491 loop
->to
[i
], loop
->from
[i
]);
2495 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2496 gfc_array_index_type
, tmp
, gfc_index_one_node
);
2497 size
= fold_build2_loc (input_location
, MULT_EXPR
,
2498 gfc_array_index_type
, size
, tmp
);
2507 get_loop_upper_bound_for_array (gfc_ss
*array
, int array_dim
)
2512 gcc_assert (array
->nested_ss
== NULL
);
2514 for (ss
= array
; ss
; ss
= ss
->parent
)
2515 for (n
= 0; n
< ss
->loop
->dimen
; n
++)
2516 if (array_dim
== get_array_ref_dim_for_loop_dim (ss
, n
))
2517 return &(ss
->loop
->to
[n
]);
2523 static gfc_loopinfo
*
2524 outermost_loop (gfc_loopinfo
* loop
)
2526 while (loop
->parent
!= NULL
)
2527 loop
= loop
->parent
;
2533 /* Array constructors are handled by constructing a temporary, then using that
2534 within the scalarization loop. This is not optimal, but seems by far the
2538 trans_array_constructor (gfc_ss
* ss
, locus
* where
)
2540 gfc_constructor_base c
;
2548 bool old_first_len
, old_typespec_chararray_ctor
;
2549 tree old_first_len_val
;
2550 gfc_loopinfo
*loop
, *outer_loop
;
2551 gfc_ss_info
*ss_info
;
2557 /* Save the old values for nested checking. */
2558 old_first_len
= first_len
;
2559 old_first_len_val
= first_len_val
;
2560 old_typespec_chararray_ctor
= typespec_chararray_ctor
;
2563 outer_loop
= outermost_loop (loop
);
2565 expr
= ss_info
->expr
;
2567 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
2568 typespec was given for the array constructor. */
2569 typespec_chararray_ctor
= (expr
->ts
.type
== BT_CHARACTER
2571 && expr
->ts
.u
.cl
->length_from_typespec
);
2573 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2574 && expr
->ts
.type
== BT_CHARACTER
&& !typespec_chararray_ctor
)
2576 first_len_val
= gfc_create_var (gfc_charlen_type_node
, "len");
2580 gcc_assert (ss
->dimen
== ss
->loop
->dimen
);
2582 c
= expr
->value
.constructor
;
2583 if (expr
->ts
.type
== BT_CHARACTER
)
2586 bool force_new_cl
= false;
2588 /* get_array_ctor_strlen walks the elements of the constructor, if a
2589 typespec was given, we already know the string length and want the one
2591 if (typespec_chararray_ctor
&& expr
->ts
.u
.cl
->length
2592 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
2596 const_string
= false;
2597 gfc_init_se (&length_se
, NULL
);
2598 gfc_conv_expr_type (&length_se
, expr
->ts
.u
.cl
->length
,
2599 gfc_charlen_type_node
);
2600 ss_info
->string_length
= length_se
.expr
;
2602 /* Check if the character length is negative. If it is, then
2604 neg_len
= fold_build2_loc (input_location
, LT_EXPR
,
2605 logical_type_node
, ss_info
->string_length
,
2606 build_zero_cst (TREE_TYPE
2607 (ss_info
->string_length
)));
2608 /* Print a warning if bounds checking is enabled. */
2609 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2611 msg
= xasprintf ("Negative character length treated as LEN = 0");
2612 gfc_trans_runtime_check (false, true, neg_len
, &length_se
.pre
,
2617 ss_info
->string_length
2618 = fold_build3_loc (input_location
, COND_EXPR
,
2619 gfc_charlen_type_node
, neg_len
,
2621 (TREE_TYPE (ss_info
->string_length
)),
2622 ss_info
->string_length
);
2623 ss_info
->string_length
= gfc_evaluate_now (ss_info
->string_length
,
2625 gfc_add_block_to_block (&outer_loop
->pre
, &length_se
.pre
);
2626 gfc_add_block_to_block (&outer_loop
->post
, &length_se
.post
);
2630 const_string
= get_array_ctor_strlen (&outer_loop
->pre
, c
,
2631 &ss_info
->string_length
);
2632 force_new_cl
= true;
2635 /* Complex character array constructors should have been taken care of
2636 and not end up here. */
2637 gcc_assert (ss_info
->string_length
);
2639 store_backend_decl (&expr
->ts
.u
.cl
, ss_info
->string_length
, force_new_cl
);
2641 type
= gfc_get_character_type_len (expr
->ts
.kind
, ss_info
->string_length
);
2643 type
= build_pointer_type (type
);
2646 type
= gfc_typenode_for_spec (expr
->ts
.type
== BT_CLASS
2647 ? &CLASS_DATA (expr
)->ts
: &expr
->ts
);
2649 /* See if the constructor determines the loop bounds. */
2652 loop_ubound0
= get_loop_upper_bound_for_array (ss
, 0);
2654 if (expr
->shape
&& get_rank (loop
) > 1 && *loop_ubound0
== NULL_TREE
)
2656 /* We have a multidimensional parameter. */
2657 for (s
= ss
; s
; s
= s
->parent
)
2660 for (n
= 0; n
< s
->loop
->dimen
; n
++)
2662 s
->loop
->from
[n
] = gfc_index_zero_node
;
2663 s
->loop
->to
[n
] = gfc_conv_mpz_to_tree (expr
->shape
[s
->dim
[n
]],
2664 gfc_index_integer_kind
);
2665 s
->loop
->to
[n
] = fold_build2_loc (input_location
, MINUS_EXPR
,
2666 gfc_array_index_type
,
2668 gfc_index_one_node
);
2673 if (*loop_ubound0
== NULL_TREE
)
2677 /* We should have a 1-dimensional, zero-based loop. */
2678 gcc_assert (loop
->parent
== NULL
&& loop
->nested
== NULL
);
2679 gcc_assert (loop
->dimen
== 1);
2680 gcc_assert (integer_zerop (loop
->from
[0]));
2682 /* Split the constructor size into a static part and a dynamic part.
2683 Allocate the static size up-front and record whether the dynamic
2684 size might be nonzero. */
2686 dynamic
= gfc_get_array_constructor_size (&size
, c
);
2687 mpz_sub_ui (size
, size
, 1);
2688 loop
->to
[0] = gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
2692 /* Special case constant array constructors. */
2695 unsigned HOST_WIDE_INT nelem
= gfc_constant_array_constructor_p (c
);
2698 tree size
= constant_array_constructor_loop_size (loop
);
2699 if (size
&& compare_tree_int (size
, nelem
) == 0)
2701 trans_constant_array_constructor (ss
, type
);
2707 gfc_trans_create_temp_array (&outer_loop
->pre
, &outer_loop
->post
, ss
, type
,
2708 NULL_TREE
, dynamic
, true, false, where
);
2710 desc
= ss_info
->data
.array
.descriptor
;
2711 offset
= gfc_index_zero_node
;
2712 offsetvar
= gfc_create_var_np (gfc_array_index_type
, "offset");
2713 TREE_NO_WARNING (offsetvar
) = 1;
2714 TREE_USED (offsetvar
) = 0;
2715 gfc_trans_array_constructor_value (&outer_loop
->pre
, type
, desc
, c
,
2716 &offset
, &offsetvar
, dynamic
);
2718 /* If the array grows dynamically, the upper bound of the loop variable
2719 is determined by the array's final upper bound. */
2722 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2723 gfc_array_index_type
,
2724 offsetvar
, gfc_index_one_node
);
2725 tmp
= gfc_evaluate_now (tmp
, &outer_loop
->pre
);
2726 gfc_conv_descriptor_ubound_set (&loop
->pre
, desc
, gfc_rank_cst
[0], tmp
);
2727 if (*loop_ubound0
&& VAR_P (*loop_ubound0
))
2728 gfc_add_modify (&outer_loop
->pre
, *loop_ubound0
, tmp
);
2730 *loop_ubound0
= tmp
;
2733 if (TREE_USED (offsetvar
))
2734 pushdecl (offsetvar
);
2736 gcc_assert (INTEGER_CST_P (offset
));
2739 /* Disable bound checking for now because it's probably broken. */
2740 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2747 /* Restore old values of globals. */
2748 first_len
= old_first_len
;
2749 first_len_val
= old_first_len_val
;
2750 typespec_chararray_ctor
= old_typespec_chararray_ctor
;
2754 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
2755 called after evaluating all of INFO's vector dimensions. Go through
2756 each such vector dimension and see if we can now fill in any missing
2760 set_vector_loop_bounds (gfc_ss
* ss
)
2762 gfc_loopinfo
*loop
, *outer_loop
;
2763 gfc_array_info
*info
;
2771 outer_loop
= outermost_loop (ss
->loop
);
2773 info
= &ss
->info
->data
.array
;
2775 for (; ss
; ss
= ss
->parent
)
2779 for (n
= 0; n
< loop
->dimen
; n
++)
2782 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_VECTOR
2783 || loop
->to
[n
] != NULL
)
2786 /* Loop variable N indexes vector dimension DIM, and we don't
2787 yet know the upper bound of loop variable N. Set it to the
2788 difference between the vector's upper and lower bounds. */
2789 gcc_assert (loop
->from
[n
] == gfc_index_zero_node
);
2790 gcc_assert (info
->subscript
[dim
]
2791 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
2793 gfc_init_se (&se
, NULL
);
2794 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
2795 zero
= gfc_rank_cst
[0];
2796 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2797 gfc_array_index_type
,
2798 gfc_conv_descriptor_ubound_get (desc
, zero
),
2799 gfc_conv_descriptor_lbound_get (desc
, zero
));
2800 tmp
= gfc_evaluate_now (tmp
, &outer_loop
->pre
);
2807 /* Tells whether a scalar argument to an elemental procedure is saved out
2808 of a scalarization loop as a value or as a reference. */
2811 gfc_scalar_elemental_arg_saved_as_reference (gfc_ss_info
* ss_info
)
2813 if (ss_info
->type
!= GFC_SS_REFERENCE
)
2816 if (ss_info
->data
.scalar
.needs_temporary
)
2819 /* If the actual argument can be absent (in other words, it can
2820 be a NULL reference), don't try to evaluate it; pass instead
2821 the reference directly. */
2822 if (ss_info
->can_be_null_ref
)
2825 /* If the expression is of polymorphic type, it's actual size is not known,
2826 so we avoid copying it anywhere. */
2827 if (ss_info
->data
.scalar
.dummy_arg
2828 && ss_info
->data
.scalar
.dummy_arg
->ts
.type
== BT_CLASS
2829 && ss_info
->expr
->ts
.type
== BT_CLASS
)
2832 /* If the expression is a data reference of aggregate type,
2833 and the data reference is not used on the left hand side,
2834 avoid a copy by saving a reference to the content. */
2835 if (!ss_info
->data
.scalar
.needs_temporary
2836 && (ss_info
->expr
->ts
.type
== BT_DERIVED
2837 || ss_info
->expr
->ts
.type
== BT_CLASS
)
2838 && gfc_expr_is_variable (ss_info
->expr
))
2841 /* Otherwise the expression is evaluated to a temporary variable before the
2842 scalarization loop. */
2847 /* Add the pre and post chains for all the scalar expressions in a SS chain
2848 to loop. This is called after the loop parameters have been calculated,
2849 but before the actual scalarizing loops. */
2852 gfc_add_loop_ss_code (gfc_loopinfo
* loop
, gfc_ss
* ss
, bool subscript
,
2855 gfc_loopinfo
*nested_loop
, *outer_loop
;
2857 gfc_ss_info
*ss_info
;
2858 gfc_array_info
*info
;
2862 /* Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise,
2863 arguments could get evaluated multiple times. */
2864 if (ss
->is_alloc_lhs
)
2867 outer_loop
= outermost_loop (loop
);
2869 /* TODO: This can generate bad code if there are ordering dependencies,
2870 e.g., a callee allocated function and an unknown size constructor. */
2871 gcc_assert (ss
!= NULL
);
2873 for (; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2877 /* Cross loop arrays are handled from within the most nested loop. */
2878 if (ss
->nested_ss
!= NULL
)
2882 expr
= ss_info
->expr
;
2883 info
= &ss_info
->data
.array
;
2885 switch (ss_info
->type
)
2888 /* Scalar expression. Evaluate this now. This includes elemental
2889 dimension indices, but not array section bounds. */
2890 gfc_init_se (&se
, NULL
);
2891 gfc_conv_expr (&se
, expr
);
2892 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2894 if (expr
->ts
.type
!= BT_CHARACTER
2895 && !gfc_is_alloc_class_scalar_function (expr
))
2897 /* Move the evaluation of scalar expressions outside the
2898 scalarization loop, except for WHERE assignments. */
2900 se
.expr
= convert(gfc_array_index_type
, se
.expr
);
2901 if (!ss_info
->where
)
2902 se
.expr
= gfc_evaluate_now (se
.expr
, &outer_loop
->pre
);
2903 gfc_add_block_to_block (&outer_loop
->pre
, &se
.post
);
2906 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2908 ss_info
->data
.scalar
.value
= se
.expr
;
2909 ss_info
->string_length
= se
.string_length
;
2912 case GFC_SS_REFERENCE
:
2913 /* Scalar argument to elemental procedure. */
2914 gfc_init_se (&se
, NULL
);
2915 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info
))
2916 gfc_conv_expr_reference (&se
, expr
);
2919 /* Evaluate the argument outside the loop and pass
2920 a reference to the value. */
2921 gfc_conv_expr (&se
, expr
);
2924 /* Ensure that a pointer to the string is stored. */
2925 if (expr
->ts
.type
== BT_CHARACTER
)
2926 gfc_conv_string_parameter (&se
);
2928 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2929 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2930 if (gfc_is_class_scalar_expr (expr
))
2931 /* This is necessary because the dynamic type will always be
2932 large than the declared type. In consequence, assigning
2933 the value to a temporary could segfault.
2934 OOP-TODO: see if this is generally correct or is the value
2935 has to be written to an allocated temporary, whose address
2936 is passed via ss_info. */
2937 ss_info
->data
.scalar
.value
= se
.expr
;
2939 ss_info
->data
.scalar
.value
= gfc_evaluate_now (se
.expr
,
2942 ss_info
->string_length
= se
.string_length
;
2945 case GFC_SS_SECTION
:
2946 /* Add the expressions for scalar and vector subscripts. */
2947 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2948 if (info
->subscript
[n
])
2949 gfc_add_loop_ss_code (loop
, info
->subscript
[n
], true, where
);
2951 set_vector_loop_bounds (ss
);
2955 /* Get the vector's descriptor and store it in SS. */
2956 gfc_init_se (&se
, NULL
);
2957 gfc_conv_expr_descriptor (&se
, expr
);
2958 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2959 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2960 info
->descriptor
= se
.expr
;
2963 case GFC_SS_INTRINSIC
:
2964 gfc_add_intrinsic_ss_code (loop
, ss
);
2967 case GFC_SS_FUNCTION
:
2968 /* Array function return value. We call the function and save its
2969 result in a temporary for use inside the loop. */
2970 gfc_init_se (&se
, NULL
);
2973 if (gfc_is_class_array_function (expr
))
2974 expr
->must_finalize
= 1;
2975 gfc_conv_expr (&se
, expr
);
2976 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2977 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2978 ss_info
->string_length
= se
.string_length
;
2981 case GFC_SS_CONSTRUCTOR
:
2982 if (expr
->ts
.type
== BT_CHARACTER
2983 && ss_info
->string_length
== NULL
2985 && expr
->ts
.u
.cl
->length
2986 && expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2988 gfc_init_se (&se
, NULL
);
2989 gfc_conv_expr_type (&se
, expr
->ts
.u
.cl
->length
,
2990 gfc_charlen_type_node
);
2991 ss_info
->string_length
= se
.expr
;
2992 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2993 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2995 trans_array_constructor (ss
, where
);
2999 case GFC_SS_COMPONENT
:
3000 /* Do nothing. These are handled elsewhere. */
3009 for (nested_loop
= loop
->nested
; nested_loop
;
3010 nested_loop
= nested_loop
->next
)
3011 gfc_add_loop_ss_code (nested_loop
, nested_loop
->ss
, subscript
, where
);
3015 /* Translate expressions for the descriptor and data pointer of a SS. */
3019 gfc_conv_ss_descriptor (stmtblock_t
* block
, gfc_ss
* ss
, int base
)
3022 gfc_ss_info
*ss_info
;
3023 gfc_array_info
*info
;
3027 info
= &ss_info
->data
.array
;
3029 /* Get the descriptor for the array to be scalarized. */
3030 gcc_assert (ss_info
->expr
->expr_type
== EXPR_VARIABLE
);
3031 gfc_init_se (&se
, NULL
);
3032 se
.descriptor_only
= 1;
3033 gfc_conv_expr_lhs (&se
, ss_info
->expr
);
3034 gfc_add_block_to_block (block
, &se
.pre
);
3035 info
->descriptor
= se
.expr
;
3036 ss_info
->string_length
= se
.string_length
;
3040 if (ss_info
->expr
->ts
.type
== BT_CHARACTER
&& !ss_info
->expr
->ts
.deferred
3041 && ss_info
->expr
->ts
.u
.cl
->length
== NULL
)
3043 /* Emit a DECL_EXPR for the variable sized array type in
3044 GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
3045 sizes works correctly. */
3046 tree arraytype
= TREE_TYPE (
3047 GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (info
->descriptor
)));
3048 if (! TYPE_NAME (arraytype
))
3049 TYPE_NAME (arraytype
) = build_decl (UNKNOWN_LOCATION
, TYPE_DECL
,
3050 NULL_TREE
, arraytype
);
3051 gfc_add_expr_to_block (block
, build1 (DECL_EXPR
, arraytype
,
3052 TYPE_NAME (arraytype
)));
3054 /* Also the data pointer. */
3055 tmp
= gfc_conv_array_data (se
.expr
);
3056 /* If this is a variable or address or a class array, use it directly.
3057 Otherwise we must evaluate it now to avoid breaking dependency
3058 analysis by pulling the expressions for elemental array indices
3061 || (TREE_CODE (tmp
) == ADDR_EXPR
3062 && DECL_P (TREE_OPERAND (tmp
, 0)))
3063 || (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
.expr
))
3064 && TREE_CODE (se
.expr
) == COMPONENT_REF
3065 && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (se
.expr
, 0))))))
3066 tmp
= gfc_evaluate_now (tmp
, block
);
3069 tmp
= gfc_conv_array_offset (se
.expr
);
3070 info
->offset
= gfc_evaluate_now (tmp
, block
);
3072 /* Make absolutely sure that the saved_offset is indeed saved
3073 so that the variable is still accessible after the loops
3075 info
->saved_offset
= info
->offset
;
3080 /* Initialize a gfc_loopinfo structure. */
3083 gfc_init_loopinfo (gfc_loopinfo
* loop
)
3087 memset (loop
, 0, sizeof (gfc_loopinfo
));
3088 gfc_init_block (&loop
->pre
);
3089 gfc_init_block (&loop
->post
);
3091 /* Initially scalarize in order and default to no loop reversal. */
3092 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
3095 loop
->reverse
[n
] = GFC_INHIBIT_REVERSE
;
3098 loop
->ss
= gfc_ss_terminator
;
3102 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
3106 gfc_copy_loopinfo_to_se (gfc_se
* se
, gfc_loopinfo
* loop
)
3112 /* Return an expression for the data pointer of an array. */
3115 gfc_conv_array_data (tree descriptor
)
3119 type
= TREE_TYPE (descriptor
);
3120 if (GFC_ARRAY_TYPE_P (type
))
3122 if (TREE_CODE (type
) == POINTER_TYPE
)
3126 /* Descriptorless arrays. */
3127 return gfc_build_addr_expr (NULL_TREE
, descriptor
);
3131 return gfc_conv_descriptor_data_get (descriptor
);
3135 /* Return an expression for the base offset of an array. */
3138 gfc_conv_array_offset (tree descriptor
)
3142 type
= TREE_TYPE (descriptor
);
3143 if (GFC_ARRAY_TYPE_P (type
))
3144 return GFC_TYPE_ARRAY_OFFSET (type
);
3146 return gfc_conv_descriptor_offset_get (descriptor
);
3150 /* Get an expression for the array stride. */
3153 gfc_conv_array_stride (tree descriptor
, int dim
)
3158 type
= TREE_TYPE (descriptor
);
3160 /* For descriptorless arrays use the array size. */
3161 tmp
= GFC_TYPE_ARRAY_STRIDE (type
, dim
);
3162 if (tmp
!= NULL_TREE
)
3165 tmp
= gfc_conv_descriptor_stride_get (descriptor
, gfc_rank_cst
[dim
]);
3170 /* Like gfc_conv_array_stride, but for the lower bound. */
3173 gfc_conv_array_lbound (tree descriptor
, int dim
)
3178 type
= TREE_TYPE (descriptor
);
3180 tmp
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
3181 if (tmp
!= NULL_TREE
)
3184 tmp
= gfc_conv_descriptor_lbound_get (descriptor
, gfc_rank_cst
[dim
]);
3189 /* Like gfc_conv_array_stride, but for the upper bound. */
3192 gfc_conv_array_ubound (tree descriptor
, int dim
)
3197 type
= TREE_TYPE (descriptor
);
3199 tmp
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
3200 if (tmp
!= NULL_TREE
)
3203 /* This should only ever happen when passing an assumed shape array
3204 as an actual parameter. The value will never be used. */
3205 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor
)))
3206 return gfc_index_zero_node
;
3208 tmp
= gfc_conv_descriptor_ubound_get (descriptor
, gfc_rank_cst
[dim
]);
3213 /* Generate code to perform an array index bound check. */
3216 trans_array_bound_check (gfc_se
* se
, gfc_ss
*ss
, tree index
, int n
,
3217 locus
* where
, bool check_upper
)
3220 tree tmp_lo
, tmp_up
;
3223 const char * name
= NULL
;
3225 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
3228 descriptor
= ss
->info
->data
.array
.descriptor
;
3230 index
= gfc_evaluate_now (index
, &se
->pre
);
3232 /* We find a name for the error message. */
3233 name
= ss
->info
->expr
->symtree
->n
.sym
->name
;
3234 gcc_assert (name
!= NULL
);
3236 if (VAR_P (descriptor
))
3237 name
= IDENTIFIER_POINTER (DECL_NAME (descriptor
));
3239 /* If upper bound is present, include both bounds in the error message. */
3242 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
3243 tmp_up
= gfc_conv_array_ubound (descriptor
, n
);
3246 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3247 "outside of expected range (%%ld:%%ld)", n
+1, name
);
3249 msg
= xasprintf ("Index '%%ld' of dimension %d "
3250 "outside of expected range (%%ld:%%ld)", n
+1);
3252 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3254 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
3255 fold_convert (long_integer_type_node
, index
),
3256 fold_convert (long_integer_type_node
, tmp_lo
),
3257 fold_convert (long_integer_type_node
, tmp_up
));
3258 fault
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
3260 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
3261 fold_convert (long_integer_type_node
, index
),
3262 fold_convert (long_integer_type_node
, tmp_lo
),
3263 fold_convert (long_integer_type_node
, tmp_up
));
3268 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
3271 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3272 "below lower bound of %%ld", n
+1, name
);
3274 msg
= xasprintf ("Index '%%ld' of dimension %d "
3275 "below lower bound of %%ld", n
+1);
3277 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3279 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
3280 fold_convert (long_integer_type_node
, index
),
3281 fold_convert (long_integer_type_node
, tmp_lo
));
3289 /* Return the offset for an index. Performs bound checking for elemental
3290 dimensions. Single element references are processed separately.
3291 DIM is the array dimension, I is the loop dimension. */
3294 conv_array_index_offset (gfc_se
* se
, gfc_ss
* ss
, int dim
, int i
,
3295 gfc_array_ref
* ar
, tree stride
)
3297 gfc_array_info
*info
;
3302 info
= &ss
->info
->data
.array
;
3304 /* Get the index into the array for this dimension. */
3307 gcc_assert (ar
->type
!= AR_ELEMENT
);
3308 switch (ar
->dimen_type
[dim
])
3310 case DIMEN_THIS_IMAGE
:
3314 /* Elemental dimension. */
3315 gcc_assert (info
->subscript
[dim
]
3316 && info
->subscript
[dim
]->info
->type
== GFC_SS_SCALAR
);
3317 /* We've already translated this value outside the loop. */
3318 index
= info
->subscript
[dim
]->info
->data
.scalar
.value
;
3320 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
3321 ar
->as
->type
!= AS_ASSUMED_SIZE
3322 || dim
< ar
->dimen
- 1);
3326 gcc_assert (info
&& se
->loop
);
3327 gcc_assert (info
->subscript
[dim
]
3328 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
3329 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
3331 /* Get a zero-based index into the vector. */
3332 index
= fold_build2_loc (input_location
, MINUS_EXPR
,
3333 gfc_array_index_type
,
3334 se
->loop
->loopvar
[i
], se
->loop
->from
[i
]);
3336 /* Multiply the index by the stride. */
3337 index
= fold_build2_loc (input_location
, MULT_EXPR
,
3338 gfc_array_index_type
,
3339 index
, gfc_conv_array_stride (desc
, 0));
3341 /* Read the vector to get an index into info->descriptor. */
3342 data
= build_fold_indirect_ref_loc (input_location
,
3343 gfc_conv_array_data (desc
));
3344 index
= gfc_build_array_ref (data
, index
, NULL
);
3345 index
= gfc_evaluate_now (index
, &se
->pre
);
3346 index
= fold_convert (gfc_array_index_type
, index
);
3348 /* Do any bounds checking on the final info->descriptor index. */
3349 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
3350 ar
->as
->type
!= AS_ASSUMED_SIZE
3351 || dim
< ar
->dimen
- 1);
3355 /* Scalarized dimension. */
3356 gcc_assert (info
&& se
->loop
);
3358 /* Multiply the loop variable by the stride and delta. */
3359 index
= se
->loop
->loopvar
[i
];
3360 if (!integer_onep (info
->stride
[dim
]))
3361 index
= fold_build2_loc (input_location
, MULT_EXPR
,
3362 gfc_array_index_type
, index
,
3364 if (!integer_zerop (info
->delta
[dim
]))
3365 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
3366 gfc_array_index_type
, index
,
3376 /* Temporary array or derived type component. */
3377 gcc_assert (se
->loop
);
3378 index
= se
->loop
->loopvar
[se
->loop
->order
[i
]];
3380 /* Pointer functions can have stride[0] different from unity.
3381 Use the stride returned by the function call and stored in
3382 the descriptor for the temporary. */
3383 if (se
->ss
&& se
->ss
->info
->type
== GFC_SS_FUNCTION
3384 && se
->ss
->info
->expr
3385 && se
->ss
->info
->expr
->symtree
3386 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
3387 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
->attr
.pointer
)
3388 stride
= gfc_conv_descriptor_stride_get (info
->descriptor
,
3391 if (info
->delta
[dim
] && !integer_zerop (info
->delta
[dim
]))
3392 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
3393 gfc_array_index_type
, index
, info
->delta
[dim
]);
3396 /* Multiply by the stride. */
3397 if (stride
!= NULL
&& !integer_onep (stride
))
3398 index
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3405 /* Build a scalarized array reference using the vptr 'size'. */
3408 build_class_array_ref (gfc_se
*se
, tree base
, tree index
)
3413 tree decl
= NULL_TREE
;
3415 gfc_expr
*expr
= se
->ss
->info
->expr
;
3417 gfc_ref
*class_ref
= NULL
;
3420 if (se
->expr
&& DECL_P (se
->expr
) && DECL_LANG_SPECIFIC (se
->expr
)
3421 && GFC_DECL_SAVED_DESCRIPTOR (se
->expr
)
3422 && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (se
->expr
))))
3427 || (expr
->ts
.type
!= BT_CLASS
3428 && !gfc_is_class_array_function (expr
)
3429 && !gfc_is_class_array_ref (expr
, NULL
)))
3432 if (expr
->symtree
&& expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
3433 ts
= &expr
->symtree
->n
.sym
->ts
;
3437 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3439 if (ref
->type
== REF_COMPONENT
3440 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
3441 && ref
->next
&& ref
->next
->type
== REF_COMPONENT
3442 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0
3444 && ref
->next
->next
->type
== REF_ARRAY
3445 && ref
->next
->next
->u
.ar
.type
!= AR_ELEMENT
)
3447 ts
= &ref
->u
.c
.component
->ts
;
3457 if (class_ref
== NULL
&& expr
&& expr
->symtree
->n
.sym
->attr
.function
3458 && expr
->symtree
->n
.sym
== expr
->symtree
->n
.sym
->result
3459 && expr
->symtree
->n
.sym
->backend_decl
== current_function_decl
)
3461 decl
= gfc_get_fake_result_decl (expr
->symtree
->n
.sym
, 0);
3463 else if (expr
&& gfc_is_class_array_function (expr
))
3467 for (tmp
= base
; tmp
; tmp
= TREE_OPERAND (tmp
, 0))
3470 type
= TREE_TYPE (tmp
);
3473 if (GFC_CLASS_TYPE_P (type
))
3475 if (type
!= TYPE_CANONICAL (type
))
3476 type
= TYPE_CANONICAL (type
);
3484 if (decl
== NULL_TREE
)
3487 se
->class_vptr
= gfc_evaluate_now (gfc_class_vptr_get (decl
), &se
->pre
);
3489 else if (class_ref
== NULL
)
3491 if (decl
== NULL_TREE
)
3492 decl
= expr
->symtree
->n
.sym
->backend_decl
;
3493 /* For class arrays the tree containing the class is stored in
3494 GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl.
3495 For all others it's sym's backend_decl directly. */
3496 if (DECL_LANG_SPECIFIC (decl
) && GFC_DECL_SAVED_DESCRIPTOR (decl
))
3497 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
3501 /* Remove everything after the last class reference, convert the
3502 expression and then recover its tailend once more. */
3504 ref
= class_ref
->next
;
3505 class_ref
->next
= NULL
;
3506 gfc_init_se (&tmpse
, NULL
);
3507 gfc_conv_expr (&tmpse
, expr
);
3508 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3510 class_ref
->next
= ref
;
3513 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
3514 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
3516 if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl
)))
3519 size
= gfc_class_vtab_size_get (decl
);
3521 /* For unlimited polymorphic entities then _len component needs to be
3522 multiplied with the size. */
3523 size
= gfc_resize_class_size_with_len (&se
->pre
, decl
, size
);
3525 size
= fold_convert (TREE_TYPE (index
), size
);
3527 /* Build the address of the element. */
3528 type
= TREE_TYPE (TREE_TYPE (base
));
3529 offset
= fold_build2_loc (input_location
, MULT_EXPR
,
3530 gfc_array_index_type
,
3532 tmp
= gfc_build_addr_expr (pvoid_type_node
, base
);
3533 tmp
= fold_build_pointer_plus_loc (input_location
, tmp
, offset
);
3534 tmp
= fold_convert (build_pointer_type (type
), tmp
);
3536 /* Return the element in the se expression. */
3537 se
->expr
= build_fold_indirect_ref_loc (input_location
, tmp
);
3542 /* Build a scalarized reference to an array. */
3545 gfc_conv_scalarized_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
3547 gfc_array_info
*info
;
3548 tree decl
= NULL_TREE
;
3556 expr
= ss
->info
->expr
;
3557 info
= &ss
->info
->data
.array
;
3559 n
= se
->loop
->order
[0];
3563 index
= conv_array_index_offset (se
, ss
, ss
->dim
[n
], n
, ar
, info
->stride0
);
3564 /* Add the offset for this dimension to the stored offset for all other
3566 if (info
->offset
&& !integer_zerop (info
->offset
))
3567 index
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3568 index
, info
->offset
);
3570 base
= build_fold_indirect_ref_loc (input_location
, info
->data
);
3572 /* Use the vptr 'size' field to access the element of a class array. */
3573 if (build_class_array_ref (se
, base
, index
))
3576 if (get_CFI_desc (NULL
, expr
, &decl
, ar
))
3577 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
3579 /* A pointer array component can be detected from its field decl. Fix
3580 the descriptor, mark the resulting variable decl and pass it to
3581 gfc_build_array_ref. */
3582 if (is_pointer_array (info
->descriptor
)
3583 || (expr
&& expr
->ts
.deferred
&& info
->descriptor
3584 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info
->descriptor
))))
3586 if (TREE_CODE (info
->descriptor
) == COMPONENT_REF
)
3587 decl
= info
->descriptor
;
3588 else if (TREE_CODE (info
->descriptor
) == INDIRECT_REF
)
3589 decl
= TREE_OPERAND (info
->descriptor
, 0);
3591 if (decl
== NULL_TREE
)
3592 decl
= info
->descriptor
;
3595 se
->expr
= gfc_build_array_ref (base
, index
, decl
);
3599 /* Translate access of temporary array. */
3602 gfc_conv_tmp_array_ref (gfc_se
* se
)
3604 se
->string_length
= se
->ss
->info
->string_length
;
3605 gfc_conv_scalarized_array_ref (se
, NULL
);
3606 gfc_advance_se_ss_chain (se
);
3609 /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
3612 add_to_offset (tree
*cst_offset
, tree
*offset
, tree t
)
3614 if (TREE_CODE (t
) == INTEGER_CST
)
3615 *cst_offset
= int_const_binop (PLUS_EXPR
, *cst_offset
, t
);
3618 if (!integer_zerop (*offset
))
3619 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3620 gfc_array_index_type
, *offset
, t
);
3628 build_array_ref (tree desc
, tree offset
, tree decl
, tree vptr
)
3634 /* For class arrays the class declaration is stored in the saved
3636 if (INDIRECT_REF_P (desc
)
3637 && DECL_LANG_SPECIFIC (TREE_OPERAND (desc
, 0))
3638 && GFC_DECL_SAVED_DESCRIPTOR (TREE_OPERAND (desc
, 0)))
3639 cdesc
= gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (
3640 TREE_OPERAND (desc
, 0)));
3644 /* Class container types do not always have the GFC_CLASS_TYPE_P
3645 but the canonical type does. */
3646 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdesc
))
3647 && TREE_CODE (cdesc
) == COMPONENT_REF
)
3649 type
= TREE_TYPE (TREE_OPERAND (cdesc
, 0));
3650 if (TYPE_CANONICAL (type
)
3651 && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type
)))
3652 vptr
= gfc_class_vptr_get (TREE_OPERAND (cdesc
, 0));
3655 tmp
= gfc_conv_array_data (desc
);
3656 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3657 tmp
= gfc_build_array_ref (tmp
, offset
, decl
, vptr
);
3662 /* Build an array reference. se->expr already holds the array descriptor.
3663 This should be either a variable, indirect variable reference or component
3664 reference. For arrays which do not have a descriptor, se->expr will be
3666 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
3669 gfc_conv_array_ref (gfc_se
* se
, gfc_array_ref
* ar
, gfc_expr
*expr
,
3673 tree offset
, cst_offset
;
3676 tree decl
= NULL_TREE
;
3679 gfc_symbol
* sym
= expr
->symtree
->n
.sym
;
3680 char *var_name
= NULL
;
3684 gcc_assert (ar
->codimen
|| sym
->attr
.select_rank_temporary
3685 || (ar
->as
&& ar
->as
->corank
));
3687 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
->expr
)))
3688 se
->expr
= build_fold_indirect_ref (gfc_conv_array_data (se
->expr
));
3691 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se
->expr
))
3692 && TREE_CODE (TREE_TYPE (se
->expr
)) == POINTER_TYPE
)
3693 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3695 /* Use the actual tree type and not the wrapped coarray. */
3696 if (!se
->want_pointer
)
3697 se
->expr
= fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se
->expr
)),
3704 /* Handle scalarized references separately. */
3705 if (ar
->type
!= AR_ELEMENT
)
3707 gfc_conv_scalarized_array_ref (se
, ar
);
3708 gfc_advance_se_ss_chain (se
);
3712 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3717 len
= strlen (sym
->name
) + 1;
3718 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3720 if (ref
->type
== REF_ARRAY
&& &ref
->u
.ar
== ar
)
3722 if (ref
->type
== REF_COMPONENT
)
3723 len
+= 2 + strlen (ref
->u
.c
.component
->name
);
3726 var_name
= XALLOCAVEC (char, len
);
3727 strcpy (var_name
, sym
->name
);
3729 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3731 if (ref
->type
== REF_ARRAY
&& &ref
->u
.ar
== ar
)
3733 if (ref
->type
== REF_COMPONENT
)
3735 strcat (var_name
, "%%");
3736 strcat (var_name
, ref
->u
.c
.component
->name
);
3742 if (IS_CLASS_ARRAY (sym
) && sym
->attr
.dummy
&& ar
->as
->type
!= AS_DEFERRED
)
3743 decl
= sym
->backend_decl
;
3745 cst_offset
= offset
= gfc_index_zero_node
;
3746 add_to_offset (&cst_offset
, &offset
, gfc_conv_array_offset (decl
));
3748 /* Calculate the offsets from all the dimensions. Make sure to associate
3749 the final offset so that we form a chain of loop invariant summands. */
3750 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
3752 /* Calculate the index for this dimension. */
3753 gfc_init_se (&indexse
, se
);
3754 gfc_conv_expr_type (&indexse
, ar
->start
[n
], gfc_array_index_type
);
3755 gfc_add_block_to_block (&se
->pre
, &indexse
.pre
);
3757 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && ! expr
->no_bounds_check
)
3759 /* Check array bounds. */
3763 /* Evaluate the indexse.expr only once. */
3764 indexse
.expr
= save_expr (indexse
.expr
);
3767 tmp
= gfc_conv_array_lbound (decl
, n
);
3768 if (sym
->attr
.temporary
)
3770 gfc_init_se (&tmpse
, se
);
3771 gfc_conv_expr_type (&tmpse
, ar
->as
->lower
[n
],
3772 gfc_array_index_type
);
3773 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3777 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3779 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3780 "below lower bound of %%ld", n
+1, var_name
);
3781 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3782 fold_convert (long_integer_type_node
,
3784 fold_convert (long_integer_type_node
, tmp
));
3787 /* Upper bound, but not for the last dimension of assumed-size
3789 if (n
< ar
->dimen
- 1 || ar
->as
->type
!= AS_ASSUMED_SIZE
)
3791 tmp
= gfc_conv_array_ubound (decl
, n
);
3792 if (sym
->attr
.temporary
)
3794 gfc_init_se (&tmpse
, se
);
3795 gfc_conv_expr_type (&tmpse
, ar
->as
->upper
[n
],
3796 gfc_array_index_type
);
3797 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3801 cond
= fold_build2_loc (input_location
, GT_EXPR
,
3802 logical_type_node
, indexse
.expr
, tmp
);
3803 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3804 "above upper bound of %%ld", n
+1, var_name
);
3805 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3806 fold_convert (long_integer_type_node
,
3808 fold_convert (long_integer_type_node
, tmp
));
3813 /* Multiply the index by the stride. */
3814 stride
= gfc_conv_array_stride (decl
, n
);
3815 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3816 indexse
.expr
, stride
);
3818 /* And add it to the total. */
3819 add_to_offset (&cst_offset
, &offset
, tmp
);
3822 if (!integer_zerop (cst_offset
))
3823 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3824 gfc_array_index_type
, offset
, cst_offset
);
3826 /* A pointer array component can be detected from its field decl. Fix
3827 the descriptor, mark the resulting variable decl and pass it to
3830 if (get_CFI_desc (sym
, expr
, &decl
, ar
))
3831 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
3832 if (!expr
->ts
.deferred
&& !sym
->attr
.codimension
3833 && is_pointer_array (se
->expr
))
3835 if (TREE_CODE (se
->expr
) == COMPONENT_REF
)
3837 else if (TREE_CODE (se
->expr
) == INDIRECT_REF
)
3838 decl
= TREE_OPERAND (se
->expr
, 0);
3842 else if (expr
->ts
.deferred
3843 || (sym
->ts
.type
== BT_CHARACTER
3844 && sym
->attr
.select_type_temporary
))
3846 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
->expr
)))
3849 if (TREE_CODE (decl
) == INDIRECT_REF
)
3850 decl
= TREE_OPERAND (decl
, 0);
3853 decl
= sym
->backend_decl
;
3855 else if (sym
->ts
.type
== BT_CLASS
)
3857 if (UNLIMITED_POLY (sym
))
3859 gfc_expr
*class_expr
= gfc_find_and_cut_at_last_class_ref (expr
);
3860 gfc_init_se (&tmpse
, NULL
);
3861 gfc_conv_expr (&tmpse
, class_expr
);
3862 if (!se
->class_vptr
)
3863 se
->class_vptr
= gfc_class_vptr_get (tmpse
.expr
);
3864 gfc_free_expr (class_expr
);
3871 se
->expr
= build_array_ref (se
->expr
, offset
, decl
, se
->class_vptr
);
3875 /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
3876 LOOP_DIM dimension (if any) to array's offset. */
3879 add_array_offset (stmtblock_t
*pblock
, gfc_loopinfo
*loop
, gfc_ss
*ss
,
3880 gfc_array_ref
*ar
, int array_dim
, int loop_dim
)
3883 gfc_array_info
*info
;
3886 info
= &ss
->info
->data
.array
;
3888 gfc_init_se (&se
, NULL
);
3890 se
.expr
= info
->descriptor
;
3891 stride
= gfc_conv_array_stride (info
->descriptor
, array_dim
);
3892 index
= conv_array_index_offset (&se
, ss
, array_dim
, loop_dim
, ar
, stride
);
3893 gfc_add_block_to_block (pblock
, &se
.pre
);
3895 info
->offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3896 gfc_array_index_type
,
3897 info
->offset
, index
);
3898 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
3902 /* Generate the code to be executed immediately before entering a
3903 scalarization loop. */
3906 gfc_trans_preloop_setup (gfc_loopinfo
* loop
, int dim
, int flag
,
3907 stmtblock_t
* pblock
)
3910 gfc_ss_info
*ss_info
;
3911 gfc_array_info
*info
;
3912 gfc_ss_type ss_type
;
3914 gfc_loopinfo
*ploop
;
3918 /* This code will be executed before entering the scalarization loop
3919 for this dimension. */
3920 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3924 if ((ss_info
->useflags
& flag
) == 0)
3927 ss_type
= ss_info
->type
;
3928 if (ss_type
!= GFC_SS_SECTION
3929 && ss_type
!= GFC_SS_FUNCTION
3930 && ss_type
!= GFC_SS_CONSTRUCTOR
3931 && ss_type
!= GFC_SS_COMPONENT
)
3934 info
= &ss_info
->data
.array
;
3936 gcc_assert (dim
< ss
->dimen
);
3937 gcc_assert (ss
->dimen
== loop
->dimen
);
3940 ar
= &info
->ref
->u
.ar
;
3944 if (dim
== loop
->dimen
- 1 && loop
->parent
!= NULL
)
3946 /* If we are in the outermost dimension of this loop, the previous
3947 dimension shall be in the parent loop. */
3948 gcc_assert (ss
->parent
!= NULL
);
3951 ploop
= loop
->parent
;
3953 /* ss and ss->parent are about the same array. */
3954 gcc_assert (ss_info
== pss
->info
);
3962 if (dim
== loop
->dimen
- 1)
3967 /* For the time being, there is no loop reordering. */
3968 gcc_assert (i
== ploop
->order
[i
]);
3969 i
= ploop
->order
[i
];
3971 if (dim
== loop
->dimen
- 1 && loop
->parent
== NULL
)
3973 stride
= gfc_conv_array_stride (info
->descriptor
,
3974 innermost_ss (ss
)->dim
[i
]);
3976 /* Calculate the stride of the innermost loop. Hopefully this will
3977 allow the backend optimizers to do their stuff more effectively.
3979 info
->stride0
= gfc_evaluate_now (stride
, pblock
);
3981 /* For the outermost loop calculate the offset due to any
3982 elemental dimensions. It will have been initialized with the
3983 base offset of the array. */
3986 for (i
= 0; i
< ar
->dimen
; i
++)
3988 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
3991 add_array_offset (pblock
, loop
, ss
, ar
, i
, /* unused */ -1);
3996 /* Add the offset for the previous loop dimension. */
3997 add_array_offset (pblock
, ploop
, ss
, ar
, pss
->dim
[i
], i
);
3999 /* Remember this offset for the second loop. */
4000 if (dim
== loop
->temp_dim
- 1 && loop
->parent
== NULL
)
4001 info
->saved_offset
= info
->offset
;
4006 /* Start a scalarized expression. Creates a scope and declares loop
4010 gfc_start_scalarized_body (gfc_loopinfo
* loop
, stmtblock_t
* pbody
)
4016 gcc_assert (!loop
->array_parameter
);
4018 for (dim
= loop
->dimen
- 1; dim
>= 0; dim
--)
4020 n
= loop
->order
[dim
];
4022 gfc_start_block (&loop
->code
[n
]);
4024 /* Create the loop variable. */
4025 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "S");
4027 if (dim
< loop
->temp_dim
)
4031 /* Calculate values that will be constant within this loop. */
4032 gfc_trans_preloop_setup (loop
, dim
, flags
, &loop
->code
[n
]);
4034 gfc_start_block (pbody
);
4038 /* Generates the actual loop code for a scalarization loop. */
4041 gfc_trans_scalarized_loop_end (gfc_loopinfo
* loop
, int n
,
4042 stmtblock_t
* pbody
)
4053 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
4054 | OMPWS_SCALARIZER_BODY
))
4055 == (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
)
4056 && n
== loop
->dimen
- 1)
4058 /* We create an OMP_FOR construct for the outermost scalarized loop. */
4059 init
= make_tree_vec (1);
4060 cond
= make_tree_vec (1);
4061 incr
= make_tree_vec (1);
4063 /* Cycle statement is implemented with a goto. Exit statement must not
4064 be present for this loop. */
4065 exit_label
= gfc_build_label_decl (NULL_TREE
);
4066 TREE_USED (exit_label
) = 1;
4068 /* Label for cycle statements (if needed). */
4069 tmp
= build1_v (LABEL_EXPR
, exit_label
);
4070 gfc_add_expr_to_block (pbody
, tmp
);
4072 stmt
= make_node (OMP_FOR
);
4074 TREE_TYPE (stmt
) = void_type_node
;
4075 OMP_FOR_BODY (stmt
) = loopbody
= gfc_finish_block (pbody
);
4077 OMP_FOR_CLAUSES (stmt
) = build_omp_clause (input_location
,
4078 OMP_CLAUSE_SCHEDULE
);
4079 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt
))
4080 = OMP_CLAUSE_SCHEDULE_STATIC
;
4081 if (ompws_flags
& OMPWS_NOWAIT
)
4082 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt
))
4083 = build_omp_clause (input_location
, OMP_CLAUSE_NOWAIT
);
4085 /* Initialize the loopvar. */
4086 TREE_VEC_ELT (init
, 0) = build2_v (MODIFY_EXPR
, loop
->loopvar
[n
],
4088 OMP_FOR_INIT (stmt
) = init
;
4089 /* The exit condition. */
4090 TREE_VEC_ELT (cond
, 0) = build2_loc (input_location
, LE_EXPR
,
4092 loop
->loopvar
[n
], loop
->to
[n
]);
4093 SET_EXPR_LOCATION (TREE_VEC_ELT (cond
, 0), input_location
);
4094 OMP_FOR_COND (stmt
) = cond
;
4095 /* Increment the loopvar. */
4096 tmp
= build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4097 loop
->loopvar
[n
], gfc_index_one_node
);
4098 TREE_VEC_ELT (incr
, 0) = fold_build2_loc (input_location
, MODIFY_EXPR
,
4099 void_type_node
, loop
->loopvar
[n
], tmp
);
4100 OMP_FOR_INCR (stmt
) = incr
;
4102 ompws_flags
&= ~OMPWS_CURR_SINGLEUNIT
;
4103 gfc_add_expr_to_block (&loop
->code
[n
], stmt
);
4107 bool reverse_loop
= (loop
->reverse
[n
] == GFC_REVERSE_SET
)
4108 && (loop
->temp_ss
== NULL
);
4110 loopbody
= gfc_finish_block (pbody
);
4113 std::swap (loop
->from
[n
], loop
->to
[n
]);
4115 /* Initialize the loopvar. */
4116 if (loop
->loopvar
[n
] != loop
->from
[n
])
4117 gfc_add_modify (&loop
->code
[n
], loop
->loopvar
[n
], loop
->from
[n
]);
4119 exit_label
= gfc_build_label_decl (NULL_TREE
);
4121 /* Generate the loop body. */
4122 gfc_init_block (&block
);
4124 /* The exit condition. */
4125 cond
= fold_build2_loc (input_location
, reverse_loop
? LT_EXPR
: GT_EXPR
,
4126 logical_type_node
, loop
->loopvar
[n
], loop
->to
[n
]);
4127 tmp
= build1_v (GOTO_EXPR
, exit_label
);
4128 TREE_USED (exit_label
) = 1;
4129 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
4130 gfc_add_expr_to_block (&block
, tmp
);
4132 /* The main body. */
4133 gfc_add_expr_to_block (&block
, loopbody
);
4135 /* Increment the loopvar. */
4136 tmp
= fold_build2_loc (input_location
,
4137 reverse_loop
? MINUS_EXPR
: PLUS_EXPR
,
4138 gfc_array_index_type
, loop
->loopvar
[n
],
4139 gfc_index_one_node
);
4141 gfc_add_modify (&block
, loop
->loopvar
[n
], tmp
);
4143 /* Build the loop. */
4144 tmp
= gfc_finish_block (&block
);
4145 tmp
= build1_v (LOOP_EXPR
, tmp
);
4146 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
4148 /* Add the exit label. */
4149 tmp
= build1_v (LABEL_EXPR
, exit_label
);
4150 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
4156 /* Finishes and generates the loops for a scalarized expression. */
4159 gfc_trans_scalarizing_loops (gfc_loopinfo
* loop
, stmtblock_t
* body
)
4164 stmtblock_t
*pblock
;
4168 /* Generate the loops. */
4169 for (dim
= 0; dim
< loop
->dimen
; dim
++)
4171 n
= loop
->order
[dim
];
4172 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
4173 loop
->loopvar
[n
] = NULL_TREE
;
4174 pblock
= &loop
->code
[n
];
4177 tmp
= gfc_finish_block (pblock
);
4178 gfc_add_expr_to_block (&loop
->pre
, tmp
);
4180 /* Clear all the used flags. */
4181 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4182 if (ss
->parent
== NULL
)
4183 ss
->info
->useflags
= 0;
4187 /* Finish the main body of a scalarized expression, and start the secondary
4191 gfc_trans_scalarized_loop_boundary (gfc_loopinfo
* loop
, stmtblock_t
* body
)
4195 stmtblock_t
*pblock
;
4199 /* We finish as many loops as are used by the temporary. */
4200 for (dim
= 0; dim
< loop
->temp_dim
- 1; dim
++)
4202 n
= loop
->order
[dim
];
4203 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
4204 loop
->loopvar
[n
] = NULL_TREE
;
4205 pblock
= &loop
->code
[n
];
4208 /* We don't want to finish the outermost loop entirely. */
4209 n
= loop
->order
[loop
->temp_dim
- 1];
4210 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
4212 /* Restore the initial offsets. */
4213 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4215 gfc_ss_type ss_type
;
4216 gfc_ss_info
*ss_info
;
4220 if ((ss_info
->useflags
& 2) == 0)
4223 ss_type
= ss_info
->type
;
4224 if (ss_type
!= GFC_SS_SECTION
4225 && ss_type
!= GFC_SS_FUNCTION
4226 && ss_type
!= GFC_SS_CONSTRUCTOR
4227 && ss_type
!= GFC_SS_COMPONENT
)
4230 ss_info
->data
.array
.offset
= ss_info
->data
.array
.saved_offset
;
4233 /* Restart all the inner loops we just finished. */
4234 for (dim
= loop
->temp_dim
- 2; dim
>= 0; dim
--)
4236 n
= loop
->order
[dim
];
4238 gfc_start_block (&loop
->code
[n
]);
4240 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "Q");
4242 gfc_trans_preloop_setup (loop
, dim
, 2, &loop
->code
[n
]);
4245 /* Start a block for the secondary copying code. */
4246 gfc_start_block (body
);
4250 /* Precalculate (either lower or upper) bound of an array section.
4251 BLOCK: Block in which the (pre)calculation code will go.
4252 BOUNDS[DIM]: Where the bound value will be stored once evaluated.
4253 VALUES[DIM]: Specified bound (NULL <=> unspecified).
4254 DESC: Array descriptor from which the bound will be picked if unspecified
4255 (either lower or upper bound according to LBOUND). */
4258 evaluate_bound (stmtblock_t
*block
, tree
*bounds
, gfc_expr
** values
,
4259 tree desc
, int dim
, bool lbound
, bool deferred
)
4262 gfc_expr
* input_val
= values
[dim
];
4263 tree
*output
= &bounds
[dim
];
4268 /* Specified section bound. */
4269 gfc_init_se (&se
, NULL
);
4270 gfc_conv_expr_type (&se
, input_val
, gfc_array_index_type
);
4271 gfc_add_block_to_block (block
, &se
.pre
);
4274 else if (deferred
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
4276 /* The gfc_conv_array_lbound () routine returns a constant zero for
4277 deferred length arrays, which in the scalarizer wreaks havoc, when
4278 copying to a (newly allocated) one-based array.
4279 Keep returning the actual result in sync for both bounds. */
4280 *output
= lbound
? gfc_conv_descriptor_lbound_get (desc
,
4282 gfc_conv_descriptor_ubound_get (desc
,
4287 /* No specific bound specified so use the bound of the array. */
4288 *output
= lbound
? gfc_conv_array_lbound (desc
, dim
) :
4289 gfc_conv_array_ubound (desc
, dim
);
4291 *output
= gfc_evaluate_now (*output
, block
);
4295 /* Calculate the lower bound of an array section. */
4298 gfc_conv_section_startstride (stmtblock_t
* block
, gfc_ss
* ss
, int dim
)
4300 gfc_expr
*stride
= NULL
;
4303 gfc_array_info
*info
;
4306 gcc_assert (ss
->info
->type
== GFC_SS_SECTION
);
4308 info
= &ss
->info
->data
.array
;
4309 ar
= &info
->ref
->u
.ar
;
4311 if (ar
->dimen_type
[dim
] == DIMEN_VECTOR
)
4313 /* We use a zero-based index to access the vector. */
4314 info
->start
[dim
] = gfc_index_zero_node
;
4315 info
->end
[dim
] = NULL
;
4316 info
->stride
[dim
] = gfc_index_one_node
;
4320 gcc_assert (ar
->dimen_type
[dim
] == DIMEN_RANGE
4321 || ar
->dimen_type
[dim
] == DIMEN_THIS_IMAGE
);
4322 desc
= info
->descriptor
;
4323 stride
= ar
->stride
[dim
];
4326 /* Calculate the start of the range. For vector subscripts this will
4327 be the range of the vector. */
4328 evaluate_bound (block
, info
->start
, ar
->start
, desc
, dim
, true,
4329 ar
->as
->type
== AS_DEFERRED
);
4331 /* Similarly calculate the end. Although this is not used in the
4332 scalarizer, it is needed when checking bounds and where the end
4333 is an expression with side-effects. */
4334 evaluate_bound (block
, info
->end
, ar
->end
, desc
, dim
, false,
4335 ar
->as
->type
== AS_DEFERRED
);
4338 /* Calculate the stride. */
4340 info
->stride
[dim
] = gfc_index_one_node
;
4343 gfc_init_se (&se
, NULL
);
4344 gfc_conv_expr_type (&se
, stride
, gfc_array_index_type
);
4345 gfc_add_block_to_block (block
, &se
.pre
);
4346 info
->stride
[dim
] = gfc_evaluate_now (se
.expr
, block
);
4351 /* Calculates the range start and stride for a SS chain. Also gets the
4352 descriptor and data pointer. The range of vector subscripts is the size
4353 of the vector. Array bounds are also checked. */
4356 gfc_conv_ss_startstride (gfc_loopinfo
* loop
)
4363 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
4366 /* Determine the rank of the loop. */
4367 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4369 switch (ss
->info
->type
)
4371 case GFC_SS_SECTION
:
4372 case GFC_SS_CONSTRUCTOR
:
4373 case GFC_SS_FUNCTION
:
4374 case GFC_SS_COMPONENT
:
4375 loop
->dimen
= ss
->dimen
;
4378 /* As usual, lbound and ubound are exceptions!. */
4379 case GFC_SS_INTRINSIC
:
4380 switch (ss
->info
->expr
->value
.function
.isym
->id
)
4382 case GFC_ISYM_LBOUND
:
4383 case GFC_ISYM_UBOUND
:
4384 case GFC_ISYM_LCOBOUND
:
4385 case GFC_ISYM_UCOBOUND
:
4386 case GFC_ISYM_THIS_IMAGE
:
4387 loop
->dimen
= ss
->dimen
;
4399 /* We should have determined the rank of the expression by now. If
4400 not, that's bad news. */
4404 /* Loop over all the SS in the chain. */
4405 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4407 gfc_ss_info
*ss_info
;
4408 gfc_array_info
*info
;
4412 expr
= ss_info
->expr
;
4413 info
= &ss_info
->data
.array
;
4415 if (expr
&& expr
->shape
&& !info
->shape
)
4416 info
->shape
= expr
->shape
;
4418 switch (ss_info
->type
)
4420 case GFC_SS_SECTION
:
4421 /* Get the descriptor for the array. If it is a cross loops array,
4422 we got the descriptor already in the outermost loop. */
4423 if (ss
->parent
== NULL
)
4424 gfc_conv_ss_descriptor (&outer_loop
->pre
, ss
,
4425 !loop
->array_parameter
);
4427 for (n
= 0; n
< ss
->dimen
; n
++)
4428 gfc_conv_section_startstride (&outer_loop
->pre
, ss
, ss
->dim
[n
]);
4431 case GFC_SS_INTRINSIC
:
4432 switch (expr
->value
.function
.isym
->id
)
4434 /* Fall through to supply start and stride. */
4435 case GFC_ISYM_LBOUND
:
4436 case GFC_ISYM_UBOUND
:
4440 /* This is the variant without DIM=... */
4441 gcc_assert (expr
->value
.function
.actual
->next
->expr
== NULL
);
4443 arg
= expr
->value
.function
.actual
->expr
;
4444 if (arg
->rank
== -1)
4449 /* The rank (hence the return value's shape) is unknown,
4450 we have to retrieve it. */
4451 gfc_init_se (&se
, NULL
);
4452 se
.descriptor_only
= 1;
4453 gfc_conv_expr (&se
, arg
);
4454 /* This is a bare variable, so there is no preliminary
4456 gcc_assert (se
.pre
.head
== NULL_TREE
4457 && se
.post
.head
== NULL_TREE
);
4458 rank
= gfc_conv_descriptor_rank (se
.expr
);
4459 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4460 gfc_array_index_type
,
4461 fold_convert (gfc_array_index_type
,
4463 gfc_index_one_node
);
4464 info
->end
[0] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
4465 info
->start
[0] = gfc_index_zero_node
;
4466 info
->stride
[0] = gfc_index_one_node
;
4469 /* Otherwise fall through GFC_SS_FUNCTION. */
4472 case GFC_ISYM_LCOBOUND
:
4473 case GFC_ISYM_UCOBOUND
:
4474 case GFC_ISYM_THIS_IMAGE
:
4482 case GFC_SS_CONSTRUCTOR
:
4483 case GFC_SS_FUNCTION
:
4484 for (n
= 0; n
< ss
->dimen
; n
++)
4486 int dim
= ss
->dim
[n
];
4488 info
->start
[dim
] = gfc_index_zero_node
;
4489 info
->end
[dim
] = gfc_index_zero_node
;
4490 info
->stride
[dim
] = gfc_index_one_node
;
4499 /* The rest is just runtime bounds checking. */
4500 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
4503 tree lbound
, ubound
;
4505 tree size
[GFC_MAX_DIMENSIONS
];
4506 tree stride_pos
, stride_neg
, non_zerosized
, tmp2
, tmp3
;
4507 gfc_array_info
*info
;
4511 gfc_start_block (&block
);
4513 for (n
= 0; n
< loop
->dimen
; n
++)
4514 size
[n
] = NULL_TREE
;
4516 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4519 gfc_ss_info
*ss_info
;
4522 const char *expr_name
;
4525 if (ss_info
->type
!= GFC_SS_SECTION
)
4528 /* Catch allocatable lhs in f2003. */
4529 if (flag_realloc_lhs
&& ss
->no_bounds_check
)
4532 expr
= ss_info
->expr
;
4533 expr_loc
= &expr
->where
;
4534 expr_name
= expr
->symtree
->name
;
4536 gfc_start_block (&inner
);
4538 /* TODO: range checking for mapped dimensions. */
4539 info
= &ss_info
->data
.array
;
4541 /* This code only checks ranges. Elemental and vector
4542 dimensions are checked later. */
4543 for (n
= 0; n
< loop
->dimen
; n
++)
4548 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
4551 if (dim
== info
->ref
->u
.ar
.dimen
- 1
4552 && info
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
4553 check_upper
= false;
4557 /* Zero stride is not allowed. */
4558 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
4559 info
->stride
[dim
], gfc_index_zero_node
);
4560 msg
= xasprintf ("Zero stride is not allowed, for dimension %d "
4561 "of array '%s'", dim
+ 1, expr_name
);
4562 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4566 desc
= info
->descriptor
;
4568 /* This is the run-time equivalent of resolve.c's
4569 check_dimension(). The logical is more readable there
4570 than it is here, with all the trees. */
4571 lbound
= gfc_conv_array_lbound (desc
, dim
);
4572 end
= info
->end
[dim
];
4574 ubound
= gfc_conv_array_ubound (desc
, dim
);
4578 /* non_zerosized is true when the selected range is not
4580 stride_pos
= fold_build2_loc (input_location
, GT_EXPR
,
4581 logical_type_node
, info
->stride
[dim
],
4582 gfc_index_zero_node
);
4583 tmp
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
4584 info
->start
[dim
], end
);
4585 stride_pos
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4586 logical_type_node
, stride_pos
, tmp
);
4588 stride_neg
= fold_build2_loc (input_location
, LT_EXPR
,
4590 info
->stride
[dim
], gfc_index_zero_node
);
4591 tmp
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
4592 info
->start
[dim
], end
);
4593 stride_neg
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4596 non_zerosized
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
4598 stride_pos
, stride_neg
);
4600 /* Check the start of the range against the lower and upper
4601 bounds of the array, if the range is not empty.
4602 If upper bound is present, include both bounds in the
4606 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
4608 info
->start
[dim
], lbound
);
4609 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4611 non_zerosized
, tmp
);
4612 tmp2
= fold_build2_loc (input_location
, GT_EXPR
,
4614 info
->start
[dim
], ubound
);
4615 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4617 non_zerosized
, tmp2
);
4618 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4619 "outside of expected range (%%ld:%%ld)",
4620 dim
+ 1, expr_name
);
4621 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4623 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4624 fold_convert (long_integer_type_node
, lbound
),
4625 fold_convert (long_integer_type_node
, ubound
));
4626 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4628 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4629 fold_convert (long_integer_type_node
, lbound
),
4630 fold_convert (long_integer_type_node
, ubound
));
4635 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
4637 info
->start
[dim
], lbound
);
4638 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4639 logical_type_node
, non_zerosized
, tmp
);
4640 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4641 "below lower bound of %%ld",
4642 dim
+ 1, expr_name
);
4643 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4645 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4646 fold_convert (long_integer_type_node
, lbound
));
4650 /* Compute the last element of the range, which is not
4651 necessarily "end" (think 0:5:3, which doesn't contain 5)
4652 and check it against both lower and upper bounds. */
4654 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4655 gfc_array_index_type
, end
,
4657 tmp
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
,
4658 gfc_array_index_type
, tmp
,
4660 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4661 gfc_array_index_type
, end
, tmp
);
4662 tmp2
= fold_build2_loc (input_location
, LT_EXPR
,
4663 logical_type_node
, tmp
, lbound
);
4664 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4665 logical_type_node
, non_zerosized
, tmp2
);
4668 tmp3
= fold_build2_loc (input_location
, GT_EXPR
,
4669 logical_type_node
, tmp
, ubound
);
4670 tmp3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4671 logical_type_node
, non_zerosized
, tmp3
);
4672 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4673 "outside of expected range (%%ld:%%ld)",
4674 dim
+ 1, expr_name
);
4675 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4677 fold_convert (long_integer_type_node
, tmp
),
4678 fold_convert (long_integer_type_node
, ubound
),
4679 fold_convert (long_integer_type_node
, lbound
));
4680 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4682 fold_convert (long_integer_type_node
, tmp
),
4683 fold_convert (long_integer_type_node
, ubound
),
4684 fold_convert (long_integer_type_node
, lbound
));
4689 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4690 "below lower bound of %%ld",
4691 dim
+ 1, expr_name
);
4692 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4694 fold_convert (long_integer_type_node
, tmp
),
4695 fold_convert (long_integer_type_node
, lbound
));
4699 /* Check the section sizes match. */
4700 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4701 gfc_array_index_type
, end
,
4703 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
4704 gfc_array_index_type
, tmp
,
4706 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4707 gfc_array_index_type
,
4708 gfc_index_one_node
, tmp
);
4709 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
4710 gfc_array_index_type
, tmp
,
4711 build_int_cst (gfc_array_index_type
, 0));
4712 /* We remember the size of the first section, and check all the
4713 others against this. */
4716 tmp3
= fold_build2_loc (input_location
, NE_EXPR
,
4717 logical_type_node
, tmp
, size
[n
]);
4718 msg
= xasprintf ("Array bound mismatch for dimension %d "
4719 "of array '%s' (%%ld/%%ld)",
4720 dim
+ 1, expr_name
);
4722 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4724 fold_convert (long_integer_type_node
, tmp
),
4725 fold_convert (long_integer_type_node
, size
[n
]));
4730 size
[n
] = gfc_evaluate_now (tmp
, &inner
);
4733 tmp
= gfc_finish_block (&inner
);
4735 /* For optional arguments, only check bounds if the argument is
4737 if (expr
->symtree
->n
.sym
->attr
.optional
4738 || expr
->symtree
->n
.sym
->attr
.not_always_present
)
4739 tmp
= build3_v (COND_EXPR
,
4740 gfc_conv_expr_present (expr
->symtree
->n
.sym
),
4741 tmp
, build_empty_stmt (input_location
));
4743 gfc_add_expr_to_block (&block
, tmp
);
4747 tmp
= gfc_finish_block (&block
);
4748 gfc_add_expr_to_block (&outer_loop
->pre
, tmp
);
4751 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4752 gfc_conv_ss_startstride (loop
);
4755 /* Return true if both symbols could refer to the same data object. Does
4756 not take account of aliasing due to equivalence statements. */
4759 symbols_could_alias (gfc_symbol
*lsym
, gfc_symbol
*rsym
, bool lsym_pointer
,
4760 bool lsym_target
, bool rsym_pointer
, bool rsym_target
)
4762 /* Aliasing isn't possible if the symbols have different base types. */
4763 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
4766 /* Pointers can point to other pointers and target objects. */
4768 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4769 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4772 /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
4773 and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
4775 if (lsym_target
&& rsym_target
4776 && ((lsym
->attr
.dummy
&& !lsym
->attr
.contiguous
4777 && (!lsym
->attr
.dimension
|| lsym
->as
->type
== AS_ASSUMED_SHAPE
))
4778 || (rsym
->attr
.dummy
&& !rsym
->attr
.contiguous
4779 && (!rsym
->attr
.dimension
4780 || rsym
->as
->type
== AS_ASSUMED_SHAPE
))))
4787 /* Return true if the two SS could be aliased, i.e. both point to the same data
4789 /* TODO: resolve aliases based on frontend expressions. */
4792 gfc_could_be_alias (gfc_ss
* lss
, gfc_ss
* rss
)
4796 gfc_expr
*lexpr
, *rexpr
;
4799 bool lsym_pointer
, lsym_target
, rsym_pointer
, rsym_target
;
4801 lexpr
= lss
->info
->expr
;
4802 rexpr
= rss
->info
->expr
;
4804 lsym
= lexpr
->symtree
->n
.sym
;
4805 rsym
= rexpr
->symtree
->n
.sym
;
4807 lsym_pointer
= lsym
->attr
.pointer
;
4808 lsym_target
= lsym
->attr
.target
;
4809 rsym_pointer
= rsym
->attr
.pointer
;
4810 rsym_target
= rsym
->attr
.target
;
4812 if (symbols_could_alias (lsym
, rsym
, lsym_pointer
, lsym_target
,
4813 rsym_pointer
, rsym_target
))
4816 if (rsym
->ts
.type
!= BT_DERIVED
&& rsym
->ts
.type
!= BT_CLASS
4817 && lsym
->ts
.type
!= BT_DERIVED
&& lsym
->ts
.type
!= BT_CLASS
)
4820 /* For derived types we must check all the component types. We can ignore
4821 array references as these will have the same base type as the previous
4823 for (lref
= lexpr
->ref
; lref
!= lss
->info
->data
.array
.ref
; lref
= lref
->next
)
4825 if (lref
->type
!= REF_COMPONENT
)
4828 lsym_pointer
= lsym_pointer
|| lref
->u
.c
.sym
->attr
.pointer
;
4829 lsym_target
= lsym_target
|| lref
->u
.c
.sym
->attr
.target
;
4831 if (symbols_could_alias (lref
->u
.c
.sym
, rsym
, lsym_pointer
, lsym_target
,
4832 rsym_pointer
, rsym_target
))
4835 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4836 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4838 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4843 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
;
4846 if (rref
->type
!= REF_COMPONENT
)
4849 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4850 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4852 if (symbols_could_alias (lref
->u
.c
.sym
, rref
->u
.c
.sym
,
4853 lsym_pointer
, lsym_target
,
4854 rsym_pointer
, rsym_target
))
4857 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4858 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4860 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4861 &rref
->u
.c
.sym
->ts
))
4863 if (gfc_compare_types (&lref
->u
.c
.sym
->ts
,
4864 &rref
->u
.c
.component
->ts
))
4866 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4867 &rref
->u
.c
.component
->ts
))
4873 lsym_pointer
= lsym
->attr
.pointer
;
4874 lsym_target
= lsym
->attr
.target
;
4876 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
; rref
= rref
->next
)
4878 if (rref
->type
!= REF_COMPONENT
)
4881 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4882 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4884 if (symbols_could_alias (rref
->u
.c
.sym
, lsym
,
4885 lsym_pointer
, lsym_target
,
4886 rsym_pointer
, rsym_target
))
4889 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4890 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4892 if (gfc_compare_types (&lsym
->ts
, &rref
->u
.c
.component
->ts
))
4901 /* Resolve array data dependencies. Creates a temporary if required. */
4902 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
4906 gfc_conv_resolve_dependencies (gfc_loopinfo
* loop
, gfc_ss
* dest
,
4912 gfc_ss_info
*ss_info
;
4913 gfc_expr
*dest_expr
;
4918 loop
->temp_ss
= NULL
;
4919 dest_expr
= dest
->info
->expr
;
4921 for (ss
= rss
; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
4924 ss_expr
= ss_info
->expr
;
4926 if (ss_info
->array_outer_dependency
)
4932 if (ss_info
->type
!= GFC_SS_SECTION
)
4934 if (flag_realloc_lhs
4935 && dest_expr
!= ss_expr
4936 && gfc_is_reallocatable_lhs (dest_expr
)
4938 nDepend
= gfc_check_dependency (dest_expr
, ss_expr
, true);
4940 /* Check for cases like c(:)(1:2) = c(2)(2:3) */
4941 if (!nDepend
&& dest_expr
->rank
> 0
4942 && dest_expr
->ts
.type
== BT_CHARACTER
4943 && ss_expr
->expr_type
== EXPR_VARIABLE
)
4945 nDepend
= gfc_check_dependency (dest_expr
, ss_expr
, false);
4947 if (ss_info
->type
== GFC_SS_REFERENCE
4948 && gfc_check_dependency (dest_expr
, ss_expr
, false))
4949 ss_info
->data
.scalar
.needs_temporary
= 1;
4957 if (dest_expr
->symtree
->n
.sym
!= ss_expr
->symtree
->n
.sym
)
4959 if (gfc_could_be_alias (dest
, ss
)
4960 || gfc_are_equivalenced_arrays (dest_expr
, ss_expr
))
4968 lref
= dest_expr
->ref
;
4969 rref
= ss_expr
->ref
;
4971 nDepend
= gfc_dep_resolver (lref
, rref
, &loop
->reverse
[0]);
4976 for (i
= 0; i
< dest
->dimen
; i
++)
4977 for (j
= 0; j
< ss
->dimen
; j
++)
4979 && dest
->dim
[i
] == ss
->dim
[j
])
4981 /* If we don't access array elements in the same order,
4982 there is a dependency. */
4987 /* TODO : loop shifting. */
4990 /* Mark the dimensions for LOOP SHIFTING */
4991 for (n
= 0; n
< loop
->dimen
; n
++)
4993 int dim
= dest
->data
.info
.dim
[n
];
4995 if (lref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
4997 else if (! gfc_is_same_range (&lref
->u
.ar
,
4998 &rref
->u
.ar
, dim
, 0))
5002 /* Put all the dimensions with dependencies in the
5005 for (n
= 0; n
< loop
->dimen
; n
++)
5007 gcc_assert (loop
->order
[n
] == n
);
5009 loop
->order
[dim
++] = n
;
5011 for (n
= 0; n
< loop
->dimen
; n
++)
5014 loop
->order
[dim
++] = n
;
5017 gcc_assert (dim
== loop
->dimen
);
5028 tree base_type
= gfc_typenode_for_spec (&dest_expr
->ts
);
5029 if (GFC_ARRAY_TYPE_P (base_type
)
5030 || GFC_DESCRIPTOR_TYPE_P (base_type
))
5031 base_type
= gfc_get_element_type (base_type
);
5032 loop
->temp_ss
= gfc_get_temp_ss (base_type
, dest
->info
->string_length
,
5034 gfc_add_ss_to_loop (loop
, loop
->temp_ss
);
5037 loop
->temp_ss
= NULL
;
5041 /* Browse through each array's information from the scalarizer and set the loop
5042 bounds according to the "best" one (per dimension), i.e. the one which
5043 provides the most information (constant bounds, shape, etc.). */
5046 set_loop_bounds (gfc_loopinfo
*loop
)
5048 int n
, dim
, spec_dim
;
5049 gfc_array_info
*info
;
5050 gfc_array_info
*specinfo
;
5054 bool dynamic
[GFC_MAX_DIMENSIONS
];
5057 bool nonoptional_arr
;
5059 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
5061 loopspec
= loop
->specloop
;
5064 for (n
= 0; n
< loop
->dimen
; n
++)
5069 /* If there are both optional and nonoptional array arguments, scalarize
5070 over the nonoptional; otherwise, it does not matter as then all
5071 (optional) arrays have to be present per F2008, 125.2.12p3(6). */
5073 nonoptional_arr
= false;
5075 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
5076 if (ss
->info
->type
!= GFC_SS_SCALAR
&& ss
->info
->type
!= GFC_SS_TEMP
5077 && ss
->info
->type
!= GFC_SS_REFERENCE
&& !ss
->info
->can_be_null_ref
)
5079 nonoptional_arr
= true;
5083 /* We use one SS term, and use that to determine the bounds of the
5084 loop for this dimension. We try to pick the simplest term. */
5085 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
5087 gfc_ss_type ss_type
;
5089 ss_type
= ss
->info
->type
;
5090 if (ss_type
== GFC_SS_SCALAR
5091 || ss_type
== GFC_SS_TEMP
5092 || ss_type
== GFC_SS_REFERENCE
5093 || (ss
->info
->can_be_null_ref
&& nonoptional_arr
))
5096 info
= &ss
->info
->data
.array
;
5099 if (loopspec
[n
] != NULL
)
5101 specinfo
= &loopspec
[n
]->info
->data
.array
;
5102 spec_dim
= loopspec
[n
]->dim
[n
];
5106 /* Silence uninitialized warnings. */
5113 gcc_assert (info
->shape
[dim
]);
5114 /* The frontend has worked out the size for us. */
5117 || !integer_zerop (specinfo
->start
[spec_dim
]))
5118 /* Prefer zero-based descriptors if possible. */
5123 if (ss_type
== GFC_SS_CONSTRUCTOR
)
5125 gfc_constructor_base base
;
5126 /* An unknown size constructor will always be rank one.
5127 Higher rank constructors will either have known shape,
5128 or still be wrapped in a call to reshape. */
5129 gcc_assert (loop
->dimen
== 1);
5131 /* Always prefer to use the constructor bounds if the size
5132 can be determined at compile time. Prefer not to otherwise,
5133 since the general case involves realloc, and it's better to
5134 avoid that overhead if possible. */
5135 base
= ss
->info
->expr
->value
.constructor
;
5136 dynamic
[n
] = gfc_get_array_constructor_size (&i
, base
);
5137 if (!dynamic
[n
] || !loopspec
[n
])
5142 /* Avoid using an allocatable lhs in an assignment, since
5143 there might be a reallocation coming. */
5144 if (loopspec
[n
] && ss
->is_alloc_lhs
)
5149 /* Criteria for choosing a loop specifier (most important first):
5150 doesn't need realloc
5156 else if (loopspec
[n
]->info
->type
== GFC_SS_CONSTRUCTOR
&& dynamic
[n
])
5158 else if (integer_onep (info
->stride
[dim
])
5159 && !integer_onep (specinfo
->stride
[spec_dim
]))
5161 else if (INTEGER_CST_P (info
->stride
[dim
])
5162 && !INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
5164 else if (INTEGER_CST_P (info
->start
[dim
])
5165 && !INTEGER_CST_P (specinfo
->start
[spec_dim
])
5166 && integer_onep (info
->stride
[dim
])
5167 == integer_onep (specinfo
->stride
[spec_dim
])
5168 && INTEGER_CST_P (info
->stride
[dim
])
5169 == INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
5171 /* We don't work out the upper bound.
5172 else if (INTEGER_CST_P (info->finish[n])
5173 && ! INTEGER_CST_P (specinfo->finish[n]))
5174 loopspec[n] = ss; */
5177 /* We should have found the scalarization loop specifier. If not,
5179 gcc_assert (loopspec
[n
]);
5181 info
= &loopspec
[n
]->info
->data
.array
;
5182 dim
= loopspec
[n
]->dim
[n
];
5184 /* Set the extents of this range. */
5185 cshape
= info
->shape
;
5186 if (cshape
&& INTEGER_CST_P (info
->start
[dim
])
5187 && INTEGER_CST_P (info
->stride
[dim
]))
5189 loop
->from
[n
] = info
->start
[dim
];
5190 mpz_set (i
, cshape
[get_array_ref_dim_for_loop_dim (loopspec
[n
], n
)]);
5191 mpz_sub_ui (i
, i
, 1);
5192 /* To = from + (size - 1) * stride. */
5193 tmp
= gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
5194 if (!integer_onep (info
->stride
[dim
]))
5195 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5196 gfc_array_index_type
, tmp
,
5198 loop
->to
[n
] = fold_build2_loc (input_location
, PLUS_EXPR
,
5199 gfc_array_index_type
,
5200 loop
->from
[n
], tmp
);
5204 loop
->from
[n
] = info
->start
[dim
];
5205 switch (loopspec
[n
]->info
->type
)
5207 case GFC_SS_CONSTRUCTOR
:
5208 /* The upper bound is calculated when we expand the
5210 gcc_assert (loop
->to
[n
] == NULL_TREE
);
5213 case GFC_SS_SECTION
:
5214 /* Use the end expression if it exists and is not constant,
5215 so that it is only evaluated once. */
5216 loop
->to
[n
] = info
->end
[dim
];
5219 case GFC_SS_FUNCTION
:
5220 /* The loop bound will be set when we generate the call. */
5221 gcc_assert (loop
->to
[n
] == NULL_TREE
);
5224 case GFC_SS_INTRINSIC
:
5226 gfc_expr
*expr
= loopspec
[n
]->info
->expr
;
5228 /* The {l,u}bound of an assumed rank. */
5229 gcc_assert ((expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
5230 || expr
->value
.function
.isym
->id
== GFC_ISYM_UBOUND
)
5231 && expr
->value
.function
.actual
->next
->expr
== NULL
5232 && expr
->value
.function
.actual
->expr
->rank
== -1);
5234 loop
->to
[n
] = info
->end
[dim
];
5238 case GFC_SS_COMPONENT
:
5240 if (info
->end
[dim
] != NULL_TREE
)
5242 loop
->to
[n
] = info
->end
[dim
];
5254 /* Transform everything so we have a simple incrementing variable. */
5255 if (integer_onep (info
->stride
[dim
]))
5256 info
->delta
[dim
] = gfc_index_zero_node
;
5259 /* Set the delta for this section. */
5260 info
->delta
[dim
] = gfc_evaluate_now (loop
->from
[n
], &outer_loop
->pre
);
5261 /* Number of iterations is (end - start + step) / step.
5262 with start = 0, this simplifies to
5264 for (i = 0; i<=last; i++){...}; */
5265 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5266 gfc_array_index_type
, loop
->to
[n
],
5268 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
5269 gfc_array_index_type
, tmp
, info
->stride
[dim
]);
5270 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
5271 tmp
, build_int_cst (gfc_array_index_type
, -1));
5272 loop
->to
[n
] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
5273 /* Make the loop variable start at 0. */
5274 loop
->from
[n
] = gfc_index_zero_node
;
5279 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
5280 set_loop_bounds (loop
);
5284 /* Initialize the scalarization loop. Creates the loop variables. Determines
5285 the range of the loop variables. Creates a temporary if required.
5286 Also generates code for scalar expressions which have been
5287 moved outside the loop. */
5290 gfc_conv_loop_setup (gfc_loopinfo
* loop
, locus
* where
)
5295 set_loop_bounds (loop
);
5297 /* Add all the scalar code that can be taken out of the loops.
5298 This may include calculating the loop bounds, so do it before
5299 allocating the temporary. */
5300 gfc_add_loop_ss_code (loop
, loop
->ss
, false, where
);
5302 tmp_ss
= loop
->temp_ss
;
5303 /* If we want a temporary then create it. */
5306 gfc_ss_info
*tmp_ss_info
;
5308 tmp_ss_info
= tmp_ss
->info
;
5309 gcc_assert (tmp_ss_info
->type
== GFC_SS_TEMP
);
5310 gcc_assert (loop
->parent
== NULL
);
5312 /* Make absolutely sure that this is a complete type. */
5313 if (tmp_ss_info
->string_length
)
5314 tmp_ss_info
->data
.temp
.type
5315 = gfc_get_character_type_len_for_eltype
5316 (TREE_TYPE (tmp_ss_info
->data
.temp
.type
),
5317 tmp_ss_info
->string_length
);
5319 tmp
= tmp_ss_info
->data
.temp
.type
;
5320 memset (&tmp_ss_info
->data
.array
, 0, sizeof (gfc_array_info
));
5321 tmp_ss_info
->type
= GFC_SS_SECTION
;
5323 gcc_assert (tmp_ss
->dimen
!= 0);
5325 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, tmp_ss
, tmp
,
5326 NULL_TREE
, false, true, false, where
);
5329 /* For array parameters we don't have loop variables, so don't calculate the
5331 if (!loop
->array_parameter
)
5332 gfc_set_delta (loop
);
5336 /* Calculates how to transform from loop variables to array indices for each
5337 array: once loop bounds are chosen, sets the difference (DELTA field) between
5338 loop bounds and array reference bounds, for each array info. */
5341 gfc_set_delta (gfc_loopinfo
*loop
)
5343 gfc_ss
*ss
, **loopspec
;
5344 gfc_array_info
*info
;
5348 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
5350 loopspec
= loop
->specloop
;
5352 /* Calculate the translation from loop variables to array indices. */
5353 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
5355 gfc_ss_type ss_type
;
5357 ss_type
= ss
->info
->type
;
5358 if (ss_type
!= GFC_SS_SECTION
5359 && ss_type
!= GFC_SS_COMPONENT
5360 && ss_type
!= GFC_SS_CONSTRUCTOR
)
5363 info
= &ss
->info
->data
.array
;
5365 for (n
= 0; n
< ss
->dimen
; n
++)
5367 /* If we are specifying the range the delta is already set. */
5368 if (loopspec
[n
] != ss
)
5372 /* Calculate the offset relative to the loop variable.
5373 First multiply by the stride. */
5374 tmp
= loop
->from
[n
];
5375 if (!integer_onep (info
->stride
[dim
]))
5376 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5377 gfc_array_index_type
,
5378 tmp
, info
->stride
[dim
]);
5380 /* Then subtract this from our starting value. */
5381 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5382 gfc_array_index_type
,
5383 info
->start
[dim
], tmp
);
5385 info
->delta
[dim
] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
5390 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
5391 gfc_set_delta (loop
);
5395 /* Calculate the size of a given array dimension from the bounds. This
5396 is simply (ubound - lbound + 1) if this expression is positive
5397 or 0 if it is negative (pick either one if it is zero). Optionally
5398 (if or_expr is present) OR the (expression != 0) condition to it. */
5401 gfc_conv_array_extent_dim (tree lbound
, tree ubound
, tree
* or_expr
)
5406 /* Calculate (ubound - lbound + 1). */
5407 res
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5409 res
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
, res
,
5410 gfc_index_one_node
);
5412 /* Check whether the size for this dimension is negative. */
5413 cond
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
, res
,
5414 gfc_index_zero_node
);
5415 res
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
, cond
,
5416 gfc_index_zero_node
, res
);
5418 /* Build OR expression. */
5420 *or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
5421 logical_type_node
, *or_expr
, cond
);
5427 /* For an array descriptor, get the total number of elements. This is just
5428 the product of the extents along from_dim to to_dim. */
5431 gfc_conv_descriptor_size_1 (tree desc
, int from_dim
, int to_dim
)
5436 res
= gfc_index_one_node
;
5438 for (dim
= from_dim
; dim
< to_dim
; ++dim
)
5444 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]);
5445 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]);
5447 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
5448 res
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5456 /* Full size of an array. */
5459 gfc_conv_descriptor_size (tree desc
, int rank
)
5461 return gfc_conv_descriptor_size_1 (desc
, 0, rank
);
5465 /* Size of a coarray for all dimensions but the last. */
5468 gfc_conv_descriptor_cosize (tree desc
, int rank
, int corank
)
5470 return gfc_conv_descriptor_size_1 (desc
, rank
, rank
+ corank
- 1);
5474 /* Fills in an array descriptor, and returns the size of the array.
5475 The size will be a simple_val, ie a variable or a constant. Also
5476 calculates the offset of the base. The pointer argument overflow,
5477 which should be of integer type, will increase in value if overflow
5478 occurs during the size calculation. Returns the size of the array.
5482 for (n = 0; n < rank; n++)
5484 a.lbound[n] = specified_lower_bound;
5485 offset = offset + a.lbond[n] * stride;
5487 a.ubound[n] = specified_upper_bound;
5488 a.stride[n] = stride;
5489 size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
5490 overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
5491 stride = stride * size;
5493 for (n = rank; n < rank+corank; n++)
5494 (Set lcobound/ucobound as above.)
5495 element_size = sizeof (array element);
5498 stride = (size_t) stride;
5499 overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
5500 stride = stride * element_size;
5506 gfc_array_init_size (tree descriptor
, int rank
, int corank
, tree
* poffset
,
5507 gfc_expr
** lower
, gfc_expr
** upper
, stmtblock_t
* pblock
,
5508 stmtblock_t
* descriptor_block
, tree
* overflow
,
5509 tree expr3_elem_size
, tree
*nelems
, gfc_expr
*expr3
,
5510 tree expr3_desc
, bool e3_has_nodescriptor
, gfc_expr
*expr
,
5523 stmtblock_t thenblock
;
5524 stmtblock_t elseblock
;
5529 type
= TREE_TYPE (descriptor
);
5531 stride
= gfc_index_one_node
;
5532 offset
= gfc_index_zero_node
;
5534 /* Set the dtype before the alloc, because registration of coarrays needs
5536 if (expr
->ts
.type
== BT_CHARACTER
5537 && expr
->ts
.deferred
5538 && VAR_P (expr
->ts
.u
.cl
->backend_decl
))
5540 type
= gfc_typenode_for_spec (&expr
->ts
);
5541 tmp
= gfc_conv_descriptor_dtype (descriptor
);
5542 gfc_add_modify (pblock
, tmp
, gfc_get_dtype_rank_type (rank
, type
));
5544 else if (expr
->ts
.type
== BT_CHARACTER
5545 && expr
->ts
.deferred
5546 && TREE_CODE (descriptor
) == COMPONENT_REF
)
5548 /* Deferred character components have their string length tucked away
5549 in a hidden field of the derived type. Obtain that and use it to
5550 set the dtype. The charlen backend decl is zero because the field
5551 type is zero length. */
5554 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5555 if (ref
->type
== REF_COMPONENT
5556 && gfc_deferred_strlen (ref
->u
.c
.component
, &tmp
))
5558 gcc_assert (tmp
!= NULL_TREE
);
5559 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (tmp
),
5560 TREE_OPERAND (descriptor
, 0), tmp
, NULL_TREE
);
5561 tmp
= fold_convert (gfc_charlen_type_node
, tmp
);
5562 type
= gfc_get_character_type_len (expr
->ts
.kind
, tmp
);
5563 tmp
= gfc_conv_descriptor_dtype (descriptor
);
5564 gfc_add_modify (pblock
, tmp
, gfc_get_dtype_rank_type (rank
, type
));
5568 tmp
= gfc_conv_descriptor_dtype (descriptor
);
5569 gfc_add_modify (pblock
, tmp
, gfc_get_dtype (type
));
5572 or_expr
= logical_false_node
;
5574 for (n
= 0; n
< rank
; n
++)
5579 /* We have 3 possibilities for determining the size of the array:
5580 lower == NULL => lbound = 1, ubound = upper[n]
5581 upper[n] = NULL => lbound = 1, ubound = lower[n]
5582 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
5585 /* Set lower bound. */
5586 gfc_init_se (&se
, NULL
);
5587 if (expr3_desc
!= NULL_TREE
)
5589 if (e3_has_nodescriptor
)
5590 /* The lbound of nondescriptor arrays like array constructors,
5591 nonallocatable/nonpointer function results/variables,
5592 start at zero, but when allocating it, the standard expects
5593 the array to start at one. */
5594 se
.expr
= gfc_index_one_node
;
5596 se
.expr
= gfc_conv_descriptor_lbound_get (expr3_desc
,
5599 else if (lower
== NULL
)
5600 se
.expr
= gfc_index_one_node
;
5603 gcc_assert (lower
[n
]);
5606 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
5607 gfc_add_block_to_block (pblock
, &se
.pre
);
5611 se
.expr
= gfc_index_one_node
;
5615 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
5616 gfc_rank_cst
[n
], se
.expr
);
5617 conv_lbound
= se
.expr
;
5619 /* Work out the offset for this component. */
5620 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5622 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
5623 gfc_array_index_type
, offset
, tmp
);
5625 /* Set upper bound. */
5626 gfc_init_se (&se
, NULL
);
5627 if (expr3_desc
!= NULL_TREE
)
5629 if (e3_has_nodescriptor
)
5631 /* The lbound of nondescriptor arrays like array constructors,
5632 nonallocatable/nonpointer function results/variables,
5633 start at zero, but when allocating it, the standard expects
5634 the array to start at one. Therefore fix the upper bound to be
5635 (desc.ubound - desc.lbound) + 1. */
5636 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5637 gfc_array_index_type
,
5638 gfc_conv_descriptor_ubound_get (
5639 expr3_desc
, gfc_rank_cst
[n
]),
5640 gfc_conv_descriptor_lbound_get (
5641 expr3_desc
, gfc_rank_cst
[n
]));
5642 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5643 gfc_array_index_type
, tmp
,
5644 gfc_index_one_node
);
5645 se
.expr
= gfc_evaluate_now (tmp
, pblock
);
5648 se
.expr
= gfc_conv_descriptor_ubound_get (expr3_desc
,
5653 gcc_assert (ubound
);
5654 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
5655 gfc_add_block_to_block (pblock
, &se
.pre
);
5656 if (ubound
->expr_type
== EXPR_FUNCTION
)
5657 se
.expr
= gfc_evaluate_now (se
.expr
, pblock
);
5659 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
5660 gfc_rank_cst
[n
], se
.expr
);
5661 conv_ubound
= se
.expr
;
5663 /* Store the stride. */
5664 gfc_conv_descriptor_stride_set (descriptor_block
, descriptor
,
5665 gfc_rank_cst
[n
], stride
);
5667 /* Calculate size and check whether extent is negative. */
5668 size
= gfc_conv_array_extent_dim (conv_lbound
, conv_ubound
, &or_expr
);
5669 size
= gfc_evaluate_now (size
, pblock
);
5671 /* Check whether multiplying the stride by the number of
5672 elements in this dimension would overflow. We must also check
5673 whether the current dimension has zero size in order to avoid
5676 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
5677 gfc_array_index_type
,
5678 fold_convert (gfc_array_index_type
,
5679 TYPE_MAX_VALUE (gfc_array_index_type
)),
5681 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
5682 logical_type_node
, tmp
, stride
),
5683 PRED_FORTRAN_OVERFLOW
);
5684 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5685 integer_one_node
, integer_zero_node
);
5686 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
5687 logical_type_node
, size
,
5688 gfc_index_zero_node
),
5689 PRED_FORTRAN_SIZE_ZERO
);
5690 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5691 integer_zero_node
, tmp
);
5692 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
5694 *overflow
= gfc_evaluate_now (tmp
, pblock
);
5696 /* Multiply the stride by the number of elements in this dimension. */
5697 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
5698 gfc_array_index_type
, stride
, size
);
5699 stride
= gfc_evaluate_now (stride
, pblock
);
5702 for (n
= rank
; n
< rank
+ corank
; n
++)
5706 /* Set lower bound. */
5707 gfc_init_se (&se
, NULL
);
5708 if (lower
== NULL
|| lower
[n
] == NULL
)
5710 gcc_assert (n
== rank
+ corank
- 1);
5711 se
.expr
= gfc_index_one_node
;
5715 if (ubound
|| n
== rank
+ corank
- 1)
5717 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
5718 gfc_add_block_to_block (pblock
, &se
.pre
);
5722 se
.expr
= gfc_index_one_node
;
5726 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
5727 gfc_rank_cst
[n
], se
.expr
);
5729 if (n
< rank
+ corank
- 1)
5731 gfc_init_se (&se
, NULL
);
5732 gcc_assert (ubound
);
5733 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
5734 gfc_add_block_to_block (pblock
, &se
.pre
);
5735 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
5736 gfc_rank_cst
[n
], se
.expr
);
5740 /* The stride is the number of elements in the array, so multiply by the
5741 size of an element to get the total size. Obviously, if there is a
5742 SOURCE expression (expr3) we must use its element size. */
5743 if (expr3_elem_size
!= NULL_TREE
)
5744 tmp
= expr3_elem_size
;
5745 else if (expr3
!= NULL
)
5747 if (expr3
->ts
.type
== BT_CLASS
)
5750 gfc_expr
*sz
= gfc_copy_expr (expr3
);
5751 gfc_add_vptr_component (sz
);
5752 gfc_add_size_component (sz
);
5753 gfc_init_se (&se_sz
, NULL
);
5754 gfc_conv_expr (&se_sz
, sz
);
5760 tmp
= gfc_typenode_for_spec (&expr3
->ts
);
5761 tmp
= TYPE_SIZE_UNIT (tmp
);
5765 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
5767 /* Convert to size_t. */
5768 *element_size
= fold_convert (size_type_node
, tmp
);
5771 return *element_size
;
5773 *nelems
= gfc_evaluate_now (stride
, pblock
);
5774 stride
= fold_convert (size_type_node
, stride
);
5776 /* First check for overflow. Since an array of type character can
5777 have zero element_size, we must check for that before
5779 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
5781 TYPE_MAX_VALUE (size_type_node
), *element_size
);
5782 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
5783 logical_type_node
, tmp
, stride
),
5784 PRED_FORTRAN_OVERFLOW
);
5785 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5786 integer_one_node
, integer_zero_node
);
5787 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
5788 logical_type_node
, *element_size
,
5789 build_int_cst (size_type_node
, 0)),
5790 PRED_FORTRAN_SIZE_ZERO
);
5791 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5792 integer_zero_node
, tmp
);
5793 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
5795 *overflow
= gfc_evaluate_now (tmp
, pblock
);
5797 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5798 stride
, *element_size
);
5800 if (poffset
!= NULL
)
5802 offset
= gfc_evaluate_now (offset
, pblock
);
5806 if (integer_zerop (or_expr
))
5808 if (integer_onep (or_expr
))
5809 return build_int_cst (size_type_node
, 0);
5811 var
= gfc_create_var (TREE_TYPE (size
), "size");
5812 gfc_start_block (&thenblock
);
5813 gfc_add_modify (&thenblock
, var
, build_int_cst (size_type_node
, 0));
5814 thencase
= gfc_finish_block (&thenblock
);
5816 gfc_start_block (&elseblock
);
5817 gfc_add_modify (&elseblock
, var
, size
);
5818 elsecase
= gfc_finish_block (&elseblock
);
5820 tmp
= gfc_evaluate_now (or_expr
, pblock
);
5821 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
5822 gfc_add_expr_to_block (pblock
, tmp
);
5828 /* Retrieve the last ref from the chain. This routine is specific to
5829 gfc_array_allocate ()'s needs. */
5832 retrieve_last_ref (gfc_ref
**ref_in
, gfc_ref
**prev_ref_in
)
5834 gfc_ref
*ref
, *prev_ref
;
5837 /* Prevent warnings for uninitialized variables. */
5838 prev_ref
= *prev_ref_in
;
5839 while (ref
&& ref
->next
!= NULL
)
5841 gcc_assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
5842 || (ref
->u
.ar
.dimen
== 0 && ref
->u
.ar
.codimen
> 0));
5847 if (ref
== NULL
|| ref
->type
!= REF_ARRAY
)
5851 *prev_ref_in
= prev_ref
;
5855 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
5856 the work for an ALLOCATE statement. */
5860 gfc_array_allocate (gfc_se
* se
, gfc_expr
* expr
, tree status
, tree errmsg
,
5861 tree errlen
, tree label_finish
, tree expr3_elem_size
,
5862 tree
*nelems
, gfc_expr
*expr3
, tree e3_arr_desc
,
5863 bool e3_has_nodescriptor
)
5867 tree offset
= NULL_TREE
;
5868 tree token
= NULL_TREE
;
5871 tree error
= NULL_TREE
;
5872 tree overflow
; /* Boolean storing whether size calculation overflows. */
5873 tree var_overflow
= NULL_TREE
;
5875 tree set_descriptor
;
5876 tree not_prev_allocated
= NULL_TREE
;
5877 tree element_size
= NULL_TREE
;
5878 stmtblock_t set_descriptor_block
;
5879 stmtblock_t elseblock
;
5882 gfc_ref
*ref
, *prev_ref
= NULL
, *coref
;
5883 bool allocatable
, coarray
, dimension
, alloc_w_e3_arr_spec
= false,
5884 non_ulimate_coarray_ptr_comp
;
5888 /* Find the last reference in the chain. */
5889 if (!retrieve_last_ref (&ref
, &prev_ref
))
5892 /* Take the allocatable and coarray properties solely from the expr-ref's
5893 attributes and not from source=-expression. */
5896 allocatable
= expr
->symtree
->n
.sym
->attr
.allocatable
;
5897 dimension
= expr
->symtree
->n
.sym
->attr
.dimension
;
5898 non_ulimate_coarray_ptr_comp
= false;
5902 allocatable
= prev_ref
->u
.c
.component
->attr
.allocatable
;
5903 /* Pointer components in coarrayed derived types must be treated
5904 specially in that they are registered without a check if the are
5905 already associated. This does not hold for ultimate coarray
5907 non_ulimate_coarray_ptr_comp
= (prev_ref
->u
.c
.component
->attr
.pointer
5908 && !prev_ref
->u
.c
.component
->attr
.codimension
);
5909 dimension
= prev_ref
->u
.c
.component
->attr
.dimension
;
5912 /* For allocatable/pointer arrays in derived types, one of the refs has to be
5913 a coarray. In this case it does not matter whether we are on this_image
5916 for (coref
= expr
->ref
; coref
; coref
= coref
->next
)
5917 if (coref
->type
== REF_ARRAY
&& coref
->u
.ar
.codimen
> 0)
5924 gcc_assert (coarray
);
5926 if (ref
->u
.ar
.type
== AR_FULL
&& expr3
!= NULL
)
5928 gfc_ref
*old_ref
= ref
;
5929 /* F08:C633: Array shape from expr3. */
5932 /* Find the last reference in the chain. */
5933 if (!retrieve_last_ref (&ref
, &prev_ref
))
5935 if (expr3
->expr_type
== EXPR_FUNCTION
5936 && gfc_expr_attr (expr3
).dimension
)
5941 alloc_w_e3_arr_spec
= true;
5944 /* Figure out the size of the array. */
5945 switch (ref
->u
.ar
.type
)
5951 upper
= ref
->u
.ar
.start
;
5957 lower
= ref
->u
.ar
.start
;
5958 upper
= ref
->u
.ar
.end
;
5962 gcc_assert (ref
->u
.ar
.as
->type
== AS_EXPLICIT
5963 || alloc_w_e3_arr_spec
);
5965 lower
= ref
->u
.ar
.as
->lower
;
5966 upper
= ref
->u
.ar
.as
->upper
;
5974 overflow
= integer_zero_node
;
5976 if (expr
->ts
.type
== BT_CHARACTER
5977 && TREE_CODE (se
->string_length
) == COMPONENT_REF
5978 && expr
->ts
.u
.cl
->backend_decl
!= se
->string_length
5979 && VAR_P (expr
->ts
.u
.cl
->backend_decl
))
5980 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
5981 fold_convert (TREE_TYPE (expr
->ts
.u
.cl
->backend_decl
),
5982 se
->string_length
));
5984 gfc_init_block (&set_descriptor_block
);
5985 /* Take the corank only from the actual ref and not from the coref. The
5986 later will mislead the generation of the array dimensions for allocatable/
5987 pointer components in derived types. */
5988 size
= gfc_array_init_size (se
->expr
, alloc_w_e3_arr_spec
? expr
->rank
5989 : ref
->u
.ar
.as
->rank
,
5990 coarray
? ref
->u
.ar
.as
->corank
: 0,
5991 &offset
, lower
, upper
,
5992 &se
->pre
, &set_descriptor_block
, &overflow
,
5993 expr3_elem_size
, nelems
, expr3
, e3_arr_desc
,
5994 e3_has_nodescriptor
, expr
, &element_size
);
5998 var_overflow
= gfc_create_var (integer_type_node
, "overflow");
5999 gfc_add_modify (&se
->pre
, var_overflow
, overflow
);
6001 if (status
== NULL_TREE
)
6003 /* Generate the block of code handling overflow. */
6004 msg
= gfc_build_addr_expr (pchar_type_node
,
6005 gfc_build_localized_cstring_const
6006 ("Integer overflow when calculating the amount of "
6007 "memory to allocate"));
6008 error
= build_call_expr_loc (input_location
,
6009 gfor_fndecl_runtime_error
, 1, msg
);
6013 tree status_type
= TREE_TYPE (status
);
6014 stmtblock_t set_status_block
;
6016 gfc_start_block (&set_status_block
);
6017 gfc_add_modify (&set_status_block
, status
,
6018 build_int_cst (status_type
, LIBERROR_ALLOCATION
));
6019 error
= gfc_finish_block (&set_status_block
);
6023 /* Allocate memory to store the data. */
6024 if (POINTER_TYPE_P (TREE_TYPE (se
->expr
)))
6025 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
6027 if (coarray
&& flag_coarray
== GFC_FCOARRAY_LIB
)
6029 pointer
= non_ulimate_coarray_ptr_comp
? se
->expr
6030 : gfc_conv_descriptor_data_get (se
->expr
);
6031 token
= gfc_conv_descriptor_token (se
->expr
);
6032 token
= gfc_build_addr_expr (NULL_TREE
, token
);
6035 pointer
= gfc_conv_descriptor_data_get (se
->expr
);
6036 STRIP_NOPS (pointer
);
6040 not_prev_allocated
= gfc_create_var (logical_type_node
,
6041 "not_prev_allocated");
6042 tmp
= fold_build2_loc (input_location
, EQ_EXPR
,
6043 logical_type_node
, pointer
,
6044 build_int_cst (TREE_TYPE (pointer
), 0));
6046 gfc_add_modify (&se
->pre
, not_prev_allocated
, tmp
);
6049 gfc_start_block (&elseblock
);
6051 /* The allocatable variant takes the old pointer as first argument. */
6053 gfc_allocate_allocatable (&elseblock
, pointer
, size
, token
,
6054 status
, errmsg
, errlen
, label_finish
, expr
,
6055 coref
!= NULL
? coref
->u
.ar
.as
->corank
: 0);
6056 else if (non_ulimate_coarray_ptr_comp
&& token
)
6057 /* The token is set only for GFC_FCOARRAY_LIB mode. */
6058 gfc_allocate_using_caf_lib (&elseblock
, pointer
, size
, token
, status
,
6060 GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY
);
6062 gfc_allocate_using_malloc (&elseblock
, pointer
, size
, status
);
6066 cond
= gfc_unlikely (fold_build2_loc (input_location
, NE_EXPR
,
6067 logical_type_node
, var_overflow
, integer_zero_node
),
6068 PRED_FORTRAN_OVERFLOW
);
6069 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
6070 error
, gfc_finish_block (&elseblock
));
6073 tmp
= gfc_finish_block (&elseblock
);
6075 gfc_add_expr_to_block (&se
->pre
, tmp
);
6077 /* Update the array descriptor with the offset and the span. */
6080 gfc_conv_descriptor_offset_set (&set_descriptor_block
, se
->expr
, offset
);
6081 tmp
= fold_convert (gfc_array_index_type
, element_size
);
6082 gfc_conv_descriptor_span_set (&set_descriptor_block
, se
->expr
, tmp
);
6085 set_descriptor
= gfc_finish_block (&set_descriptor_block
);
6086 if (status
!= NULL_TREE
)
6088 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
6089 logical_type_node
, status
,
6090 build_int_cst (TREE_TYPE (status
), 0));
6092 if (not_prev_allocated
!= NULL_TREE
)
6093 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
6094 logical_type_node
, cond
, not_prev_allocated
);
6096 gfc_add_expr_to_block (&se
->pre
,
6097 fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
6100 build_empty_stmt (input_location
)));
6103 gfc_add_expr_to_block (&se
->pre
, set_descriptor
);
6109 /* Create an array constructor from an initialization expression.
6110 We assume the frontend already did any expansions and conversions. */
6113 gfc_conv_array_initializer (tree type
, gfc_expr
* expr
)
6119 vec
<constructor_elt
, va_gc
> *v
= NULL
;
6121 if (expr
->expr_type
== EXPR_VARIABLE
6122 && expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
6123 && expr
->symtree
->n
.sym
->value
)
6124 expr
= expr
->symtree
->n
.sym
->value
;
6126 switch (expr
->expr_type
)
6129 case EXPR_STRUCTURE
:
6130 /* A single scalar or derived type value. Create an array with all
6131 elements equal to that value. */
6132 gfc_init_se (&se
, NULL
);
6134 if (expr
->expr_type
== EXPR_CONSTANT
)
6135 gfc_conv_constant (&se
, expr
);
6137 gfc_conv_structure (&se
, expr
, 1);
6139 CONSTRUCTOR_APPEND_ELT (v
, build2 (RANGE_EXPR
, gfc_array_index_type
,
6140 TYPE_MIN_VALUE (TYPE_DOMAIN (type
)),
6141 TYPE_MAX_VALUE (TYPE_DOMAIN (type
))),
6146 /* Create a vector of all the elements. */
6147 for (c
= gfc_constructor_first (expr
->value
.constructor
);
6148 c
; c
= gfc_constructor_next (c
))
6152 /* Problems occur when we get something like
6153 integer :: a(lots) = (/(i, i=1, lots)/) */
6154 gfc_fatal_error ("The number of elements in the array "
6155 "constructor at %L requires an increase of "
6156 "the allowed %d upper limit. See "
6157 "%<-fmax-array-constructor%> option",
6158 &expr
->where
, flag_max_array_constructor
);
6161 if (mpz_cmp_si (c
->offset
, 0) != 0)
6162 index
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
6166 if (mpz_cmp_si (c
->repeat
, 1) > 0)
6172 mpz_add (maxval
, c
->offset
, c
->repeat
);
6173 mpz_sub_ui (maxval
, maxval
, 1);
6174 tmp2
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
6175 if (mpz_cmp_si (c
->offset
, 0) != 0)
6177 mpz_add_ui (maxval
, c
->offset
, 1);
6178 tmp1
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
6181 tmp1
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
6183 range
= fold_build2 (RANGE_EXPR
, gfc_array_index_type
, tmp1
, tmp2
);
6189 gfc_init_se (&se
, NULL
);
6190 switch (c
->expr
->expr_type
)
6193 gfc_conv_constant (&se
, c
->expr
);
6195 /* See gfortran.dg/charlen_15.f90 for instance. */
6196 if (TREE_CODE (se
.expr
) == STRING_CST
6197 && TREE_CODE (type
) == ARRAY_TYPE
)
6200 while (TREE_CODE (TREE_TYPE (atype
)) == ARRAY_TYPE
)
6201 atype
= TREE_TYPE (atype
);
6202 gcc_checking_assert (TREE_CODE (TREE_TYPE (atype
))
6204 gcc_checking_assert (TREE_TYPE (TREE_TYPE (se
.expr
))
6205 == TREE_TYPE (atype
));
6206 if (tree_to_uhwi (TYPE_SIZE_UNIT (TREE_TYPE (se
.expr
)))
6207 > tree_to_uhwi (TYPE_SIZE_UNIT (atype
)))
6209 unsigned HOST_WIDE_INT size
6210 = tree_to_uhwi (TYPE_SIZE_UNIT (atype
));
6211 const char *p
= TREE_STRING_POINTER (se
.expr
);
6213 se
.expr
= build_string (size
, p
);
6215 TREE_TYPE (se
.expr
) = atype
;
6219 case EXPR_STRUCTURE
:
6220 gfc_conv_structure (&se
, c
->expr
, 1);
6224 /* Catch those occasional beasts that do not simplify
6225 for one reason or another, assuming that if they are
6226 standard defying the frontend will catch them. */
6227 gfc_conv_expr (&se
, c
->expr
);
6231 if (range
== NULL_TREE
)
6232 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
6235 if (index
!= NULL_TREE
)
6236 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
6237 CONSTRUCTOR_APPEND_ELT (v
, range
, se
.expr
);
6243 return gfc_build_null_descriptor (type
);
6249 /* Create a constructor from the list of elements. */
6250 tmp
= build_constructor (type
, v
);
6251 TREE_CONSTANT (tmp
) = 1;
6256 /* Generate code to evaluate non-constant coarray cobounds. */
6259 gfc_trans_array_cobounds (tree type
, stmtblock_t
* pblock
,
6260 const gfc_symbol
*sym
)
6268 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
6270 for (dim
= as
->rank
; dim
< as
->rank
+ as
->corank
; dim
++)
6272 /* Evaluate non-constant array bound expressions. */
6273 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
6274 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
6276 gfc_init_se (&se
, NULL
);
6277 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
6278 gfc_add_block_to_block (pblock
, &se
.pre
);
6279 gfc_add_modify (pblock
, lbound
, se
.expr
);
6281 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
6282 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
6284 gfc_init_se (&se
, NULL
);
6285 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
6286 gfc_add_block_to_block (pblock
, &se
.pre
);
6287 gfc_add_modify (pblock
, ubound
, se
.expr
);
6293 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
6294 returns the size (in elements) of the array. */
6297 gfc_trans_array_bounds (tree type
, gfc_symbol
* sym
, tree
* poffset
,
6298 stmtblock_t
* pblock
)
6311 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
6313 size
= gfc_index_one_node
;
6314 offset
= gfc_index_zero_node
;
6315 for (dim
= 0; dim
< as
->rank
; dim
++)
6317 /* Evaluate non-constant array bound expressions. */
6318 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
6319 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
6321 gfc_init_se (&se
, NULL
);
6322 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
6323 gfc_add_block_to_block (pblock
, &se
.pre
);
6324 gfc_add_modify (pblock
, lbound
, se
.expr
);
6326 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
6327 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
6329 gfc_init_se (&se
, NULL
);
6330 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
6331 gfc_add_block_to_block (pblock
, &se
.pre
);
6332 gfc_add_modify (pblock
, ubound
, se
.expr
);
6334 /* The offset of this dimension. offset = offset - lbound * stride. */
6335 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6337 offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6340 /* The size of this dimension, and the stride of the next. */
6341 if (dim
+ 1 < as
->rank
)
6342 stride
= GFC_TYPE_ARRAY_STRIDE (type
, dim
+ 1);
6344 stride
= GFC_TYPE_ARRAY_SIZE (type
);
6346 if (ubound
!= NULL_TREE
&& !(stride
&& INTEGER_CST_P (stride
)))
6348 /* Calculate stride = size * (ubound + 1 - lbound). */
6349 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6350 gfc_array_index_type
,
6351 gfc_index_one_node
, lbound
);
6352 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6353 gfc_array_index_type
, ubound
, tmp
);
6354 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6355 gfc_array_index_type
, size
, tmp
);
6357 gfc_add_modify (pblock
, stride
, tmp
);
6359 stride
= gfc_evaluate_now (tmp
, pblock
);
6361 /* Make sure that negative size arrays are translated
6362 to being zero size. */
6363 tmp
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
6364 stride
, gfc_index_zero_node
);
6365 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6366 gfc_array_index_type
, tmp
,
6367 stride
, gfc_index_zero_node
);
6368 gfc_add_modify (pblock
, stride
, tmp
);
6374 gfc_trans_array_cobounds (type
, pblock
, sym
);
6375 gfc_trans_vla_type_sizes (sym
, pblock
);
6382 /* Generate code to initialize/allocate an array variable. */
6385 gfc_trans_auto_array_allocation (tree decl
, gfc_symbol
* sym
,
6386 gfc_wrapped_block
* block
)
6390 tree tmp
= NULL_TREE
;
6397 gcc_assert (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
));
6399 /* Do nothing for USEd variables. */
6400 if (sym
->attr
.use_assoc
)
6403 type
= TREE_TYPE (decl
);
6404 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6405 onstack
= TREE_CODE (type
) != POINTER_TYPE
;
6407 gfc_init_block (&init
);
6409 /* Evaluate character string length. */
6410 if (sym
->ts
.type
== BT_CHARACTER
6411 && onstack
&& !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
6413 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6415 gfc_trans_vla_type_sizes (sym
, &init
);
6417 /* Emit a DECL_EXPR for this variable, which will cause the
6418 gimplifier to allocate storage, and all that good stuff. */
6419 tmp
= fold_build1_loc (input_location
, DECL_EXPR
, TREE_TYPE (decl
), decl
);
6420 gfc_add_expr_to_block (&init
, tmp
);
6425 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6429 type
= TREE_TYPE (type
);
6431 gcc_assert (!sym
->attr
.use_assoc
);
6432 gcc_assert (!TREE_STATIC (decl
));
6433 gcc_assert (!sym
->module
);
6435 if (sym
->ts
.type
== BT_CHARACTER
6436 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
6437 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6439 size
= gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
6441 /* Don't actually allocate space for Cray Pointees. */
6442 if (sym
->attr
.cray_pointee
)
6444 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6445 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6447 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6451 if (flag_stack_arrays
)
6453 gcc_assert (TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
);
6454 space
= build_decl (gfc_get_location (&sym
->declared_at
),
6455 VAR_DECL
, create_tmp_var_name ("A"),
6456 TREE_TYPE (TREE_TYPE (decl
)));
6457 gfc_trans_vla_type_sizes (sym
, &init
);
6461 /* The size is the number of elements in the array, so multiply by the
6462 size of an element to get the total size. */
6463 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
6464 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6465 size
, fold_convert (gfc_array_index_type
, tmp
));
6467 /* Allocate memory to hold the data. */
6468 tmp
= gfc_call_malloc (&init
, TREE_TYPE (decl
), size
);
6469 gfc_add_modify (&init
, decl
, tmp
);
6471 /* Free the temporary. */
6472 tmp
= gfc_call_free (decl
);
6476 /* Set offset of the array. */
6477 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6478 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6480 /* Automatic arrays should not have initializers. */
6481 gcc_assert (!sym
->value
);
6483 inittree
= gfc_finish_block (&init
);
6490 /* Don't create new scope, emit the DECL_EXPR in exactly the scope
6491 where also space is located. */
6492 gfc_init_block (&init
);
6493 tmp
= fold_build1_loc (input_location
, DECL_EXPR
,
6494 TREE_TYPE (space
), space
);
6495 gfc_add_expr_to_block (&init
, tmp
);
6496 addr
= fold_build1_loc (gfc_get_location (&sym
->declared_at
),
6497 ADDR_EXPR
, TREE_TYPE (decl
), space
);
6498 gfc_add_modify (&init
, decl
, addr
);
6499 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6502 gfc_add_init_cleanup (block
, inittree
, tmp
);
6506 /* Generate entry and exit code for g77 calling convention arrays. */
6509 gfc_trans_g77_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
6519 gfc_save_backend_locus (&loc
);
6520 gfc_set_backend_locus (&sym
->declared_at
);
6522 /* Descriptor type. */
6523 parm
= sym
->backend_decl
;
6524 type
= TREE_TYPE (parm
);
6525 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6527 gfc_start_block (&init
);
6529 if (sym
->ts
.type
== BT_CHARACTER
6530 && VAR_P (sym
->ts
.u
.cl
->backend_decl
))
6531 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6533 /* Evaluate the bounds of the array. */
6534 gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
6536 /* Set the offset. */
6537 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6538 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6540 /* Set the pointer itself if we aren't using the parameter directly. */
6541 if (TREE_CODE (parm
) != PARM_DECL
)
6543 tmp
= convert (TREE_TYPE (parm
), GFC_DECL_SAVED_DESCRIPTOR (parm
));
6544 gfc_add_modify (&init
, parm
, tmp
);
6546 stmt
= gfc_finish_block (&init
);
6548 gfc_restore_backend_locus (&loc
);
6550 /* Add the initialization code to the start of the function. */
6552 if (sym
->attr
.optional
|| sym
->attr
.not_always_present
)
6555 if (TREE_CODE (parm
) != PARM_DECL
)
6556 nullify
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
6557 parm
, null_pointer_node
);
6559 nullify
= build_empty_stmt (input_location
);
6560 tmp
= gfc_conv_expr_present (sym
, true);
6561 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, nullify
);
6564 gfc_add_init_cleanup (block
, stmt
, NULL_TREE
);
6568 /* Modify the descriptor of an array parameter so that it has the
6569 correct lower bound. Also move the upper bound accordingly.
6570 If the array is not packed, it will be copied into a temporary.
6571 For each dimension we set the new lower and upper bounds. Then we copy the
6572 stride and calculate the offset for this dimension. We also work out
6573 what the stride of a packed array would be, and see it the two match.
6574 If the array need repacking, we set the stride to the values we just
6575 calculated, recalculate the offset and copy the array data.
6576 Code is also added to copy the data back at the end of the function.
6580 gfc_trans_dummy_array_bias (gfc_symbol
* sym
, tree tmpdesc
,
6581 gfc_wrapped_block
* block
)
6588 tree stmtInit
, stmtCleanup
;
6595 tree stride
, stride2
;
6605 bool is_classarray
= IS_CLASS_ARRAY (sym
);
6607 /* Do nothing for pointer and allocatable arrays. */
6608 if ((sym
->ts
.type
!= BT_CLASS
&& sym
->attr
.pointer
)
6609 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.class_pointer
)
6610 || sym
->attr
.allocatable
6611 || (is_classarray
&& CLASS_DATA (sym
)->attr
.allocatable
))
6614 if (!is_classarray
&& sym
->attr
.dummy
&& gfc_is_nodesc_array (sym
))
6616 gfc_trans_g77_array (sym
, block
);
6621 gfc_save_backend_locus (&loc
);
6622 /* loc.nextc is not set by save_backend_locus but the location routines
6624 if (loc
.nextc
== NULL
)
6625 loc
.nextc
= loc
.lb
->line
;
6626 gfc_set_backend_locus (&sym
->declared_at
);
6628 /* Descriptor type. */
6629 type
= TREE_TYPE (tmpdesc
);
6630 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6631 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6633 /* For a class array the dummy array descriptor is in the _class
6635 dumdesc
= gfc_class_data_get (dumdesc
);
6637 dumdesc
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
6638 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
6639 gfc_start_block (&init
);
6641 if (sym
->ts
.type
== BT_CHARACTER
6642 && VAR_P (sym
->ts
.u
.cl
->backend_decl
))
6643 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6645 checkparm
= (as
->type
== AS_EXPLICIT
6646 && (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
));
6648 no_repack
= !(GFC_DECL_PACKED_ARRAY (tmpdesc
)
6649 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
));
6651 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
))
6653 /* For non-constant shape arrays we only check if the first dimension
6654 is contiguous. Repacking higher dimensions wouldn't gain us
6655 anything as we still don't know the array stride. */
6656 partial
= gfc_create_var (logical_type_node
, "partial");
6657 TREE_USED (partial
) = 1;
6658 tmp
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
6659 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, tmp
,
6660 gfc_index_one_node
);
6661 gfc_add_modify (&init
, partial
, tmp
);
6664 partial
= NULL_TREE
;
6666 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
6667 here, however I think it does the right thing. */
6670 /* Set the first stride. */
6671 stride
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
6672 stride
= gfc_evaluate_now (stride
, &init
);
6674 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
6675 stride
, gfc_index_zero_node
);
6676 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
6677 tmp
, gfc_index_one_node
, stride
);
6678 stride
= GFC_TYPE_ARRAY_STRIDE (type
, 0);
6679 gfc_add_modify (&init
, stride
, tmp
);
6681 /* Allow the user to disable array repacking. */
6682 stmt_unpacked
= NULL_TREE
;
6686 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type
, 0)));
6687 /* A library call to repack the array if necessary. */
6688 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6689 stmt_unpacked
= build_call_expr_loc (input_location
,
6690 gfor_fndecl_in_pack
, 1, tmp
);
6692 stride
= gfc_index_one_node
;
6694 if (warn_array_temporaries
)
6695 gfc_warning (OPT_Warray_temporaries
,
6696 "Creating array temporary at %L", &loc
);
6699 /* This is for the case where the array data is used directly without
6700 calling the repack function. */
6701 if (no_repack
|| partial
!= NULL_TREE
)
6702 stmt_packed
= gfc_conv_descriptor_data_get (dumdesc
);
6704 stmt_packed
= NULL_TREE
;
6706 /* Assign the data pointer. */
6707 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
6709 /* Don't repack unknown shape arrays when the first stride is 1. */
6710 tmp
= fold_build3_loc (input_location
, COND_EXPR
, TREE_TYPE (stmt_packed
),
6711 partial
, stmt_packed
, stmt_unpacked
);
6714 tmp
= stmt_packed
!= NULL_TREE
? stmt_packed
: stmt_unpacked
;
6715 gfc_add_modify (&init
, tmpdesc
, fold_convert (type
, tmp
));
6717 offset
= gfc_index_zero_node
;
6718 size
= gfc_index_one_node
;
6720 /* Evaluate the bounds of the array. */
6721 for (n
= 0; n
< as
->rank
; n
++)
6723 if (checkparm
|| !as
->upper
[n
])
6725 /* Get the bounds of the actual parameter. */
6726 dubound
= gfc_conv_descriptor_ubound_get (dumdesc
, gfc_rank_cst
[n
]);
6727 dlbound
= gfc_conv_descriptor_lbound_get (dumdesc
, gfc_rank_cst
[n
]);
6731 dubound
= NULL_TREE
;
6732 dlbound
= NULL_TREE
;
6735 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, n
);
6736 if (!INTEGER_CST_P (lbound
))
6738 gfc_init_se (&se
, NULL
);
6739 gfc_conv_expr_type (&se
, as
->lower
[n
],
6740 gfc_array_index_type
);
6741 gfc_add_block_to_block (&init
, &se
.pre
);
6742 gfc_add_modify (&init
, lbound
, se
.expr
);
6745 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, n
);
6746 /* Set the desired upper bound. */
6749 /* We know what we want the upper bound to be. */
6750 if (!INTEGER_CST_P (ubound
))
6752 gfc_init_se (&se
, NULL
);
6753 gfc_conv_expr_type (&se
, as
->upper
[n
],
6754 gfc_array_index_type
);
6755 gfc_add_block_to_block (&init
, &se
.pre
);
6756 gfc_add_modify (&init
, ubound
, se
.expr
);
6759 /* Check the sizes match. */
6762 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
6766 temp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6767 gfc_array_index_type
, ubound
, lbound
);
6768 temp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6769 gfc_array_index_type
,
6770 gfc_index_one_node
, temp
);
6771 stride2
= fold_build2_loc (input_location
, MINUS_EXPR
,
6772 gfc_array_index_type
, dubound
,
6774 stride2
= fold_build2_loc (input_location
, PLUS_EXPR
,
6775 gfc_array_index_type
,
6776 gfc_index_one_node
, stride2
);
6777 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6778 gfc_array_index_type
, temp
, stride2
);
6779 msg
= xasprintf ("Dimension %d of array '%s' has extent "
6780 "%%ld instead of %%ld", n
+1, sym
->name
);
6782 gfc_trans_runtime_check (true, false, tmp
, &init
, &loc
, msg
,
6783 fold_convert (long_integer_type_node
, temp
),
6784 fold_convert (long_integer_type_node
, stride2
));
6791 /* For assumed shape arrays move the upper bound by the same amount
6792 as the lower bound. */
6793 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6794 gfc_array_index_type
, dubound
, dlbound
);
6795 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6796 gfc_array_index_type
, tmp
, lbound
);
6797 gfc_add_modify (&init
, ubound
, tmp
);
6799 /* The offset of this dimension. offset = offset - lbound * stride. */
6800 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6802 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
6803 gfc_array_index_type
, offset
, tmp
);
6805 /* The size of this dimension, and the stride of the next. */
6806 if (n
+ 1 < as
->rank
)
6808 stride
= GFC_TYPE_ARRAY_STRIDE (type
, n
+ 1);
6810 if (no_repack
|| partial
!= NULL_TREE
)
6812 gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[n
+1]);
6814 /* Figure out the stride if not a known constant. */
6815 if (!INTEGER_CST_P (stride
))
6818 stmt_packed
= NULL_TREE
;
6821 /* Calculate stride = size * (ubound + 1 - lbound). */
6822 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6823 gfc_array_index_type
,
6824 gfc_index_one_node
, lbound
);
6825 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6826 gfc_array_index_type
, ubound
, tmp
);
6827 size
= fold_build2_loc (input_location
, MULT_EXPR
,
6828 gfc_array_index_type
, size
, tmp
);
6832 /* Assign the stride. */
6833 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
6834 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6835 gfc_array_index_type
, partial
,
6836 stmt_unpacked
, stmt_packed
);
6838 tmp
= (stmt_packed
!= NULL_TREE
) ? stmt_packed
: stmt_unpacked
;
6839 gfc_add_modify (&init
, stride
, tmp
);
6844 stride
= GFC_TYPE_ARRAY_SIZE (type
);
6846 if (stride
&& !INTEGER_CST_P (stride
))
6848 /* Calculate size = stride * (ubound + 1 - lbound). */
6849 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6850 gfc_array_index_type
,
6851 gfc_index_one_node
, lbound
);
6852 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6853 gfc_array_index_type
,
6855 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6856 gfc_array_index_type
,
6857 GFC_TYPE_ARRAY_STRIDE (type
, n
), tmp
);
6858 gfc_add_modify (&init
, stride
, tmp
);
6863 gfc_trans_array_cobounds (type
, &init
, sym
);
6865 /* Set the offset. */
6866 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6867 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6869 gfc_trans_vla_type_sizes (sym
, &init
);
6871 stmtInit
= gfc_finish_block (&init
);
6873 /* Only do the entry/initialization code if the arg is present. */
6874 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6875 optional_arg
= (sym
->attr
.optional
6876 || (sym
->ns
->proc_name
->attr
.entry_master
6877 && sym
->attr
.dummy
));
6880 tree zero_init
= fold_convert (TREE_TYPE (tmpdesc
), null_pointer_node
);
6881 zero_init
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
6882 tmpdesc
, zero_init
);
6883 tmp
= gfc_conv_expr_present (sym
, true);
6884 stmtInit
= build3_v (COND_EXPR
, tmp
, stmtInit
, zero_init
);
6889 stmtCleanup
= NULL_TREE
;
6892 stmtblock_t cleanup
;
6893 gfc_start_block (&cleanup
);
6895 if (sym
->attr
.intent
!= INTENT_IN
)
6897 /* Copy the data back. */
6898 tmp
= build_call_expr_loc (input_location
,
6899 gfor_fndecl_in_unpack
, 2, dumdesc
, tmpdesc
);
6900 gfc_add_expr_to_block (&cleanup
, tmp
);
6903 /* Free the temporary. */
6904 tmp
= gfc_call_free (tmpdesc
);
6905 gfc_add_expr_to_block (&cleanup
, tmp
);
6907 stmtCleanup
= gfc_finish_block (&cleanup
);
6909 /* Only do the cleanup if the array was repacked. */
6911 /* For a class array the dummy array descriptor is in the _class
6913 tmp
= gfc_class_data_get (dumdesc
);
6915 tmp
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
6916 tmp
= gfc_conv_descriptor_data_get (tmp
);
6917 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
6919 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6920 build_empty_stmt (input_location
));
6924 tmp
= gfc_conv_expr_present (sym
);
6925 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6926 build_empty_stmt (input_location
));
6930 /* We don't need to free any memory allocated by internal_pack as it will
6931 be freed at the end of the function by pop_context. */
6932 gfc_add_init_cleanup (block
, stmtInit
, stmtCleanup
);
6934 gfc_restore_backend_locus (&loc
);
6938 /* Calculate the overall offset, including subreferences. */
6940 gfc_get_dataptr_offset (stmtblock_t
*block
, tree parm
, tree desc
, tree offset
,
6941 bool subref
, gfc_expr
*expr
)
6951 /* If offset is NULL and this is not a subreferenced array, there is
6953 if (offset
== NULL_TREE
)
6956 offset
= gfc_index_zero_node
;
6961 tmp
= build_array_ref (desc
, offset
, NULL
, NULL
);
6963 /* Offset the data pointer for pointer assignments from arrays with
6964 subreferences; e.g. my_integer => my_type(:)%integer_component. */
6967 /* Go past the array reference. */
6968 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6969 if (ref
->type
== REF_ARRAY
&&
6970 ref
->u
.ar
.type
!= AR_ELEMENT
)
6976 /* Calculate the offset for each subsequent subreference. */
6977 for (; ref
; ref
= ref
->next
)
6982 field
= ref
->u
.c
.component
->backend_decl
;
6983 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
6984 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
6986 tmp
, field
, NULL_TREE
);
6990 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
6991 gfc_init_se (&start
, NULL
);
6992 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
6993 gfc_add_block_to_block (block
, &start
.pre
);
6994 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
6998 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
6999 && ref
->u
.ar
.type
== AR_ELEMENT
);
7001 /* TODO - Add bounds checking. */
7002 stride
= gfc_index_one_node
;
7003 index
= gfc_index_zero_node
;
7004 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
7009 /* Update the index. */
7010 gfc_init_se (&start
, NULL
);
7011 gfc_conv_expr_type (&start
, ref
->u
.ar
.start
[n
], gfc_array_index_type
);
7012 itmp
= gfc_evaluate_now (start
.expr
, block
);
7013 gfc_init_se (&start
, NULL
);
7014 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->lower
[n
], gfc_array_index_type
);
7015 jtmp
= gfc_evaluate_now (start
.expr
, block
);
7016 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7017 gfc_array_index_type
, itmp
, jtmp
);
7018 itmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7019 gfc_array_index_type
, itmp
, stride
);
7020 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
7021 gfc_array_index_type
, itmp
, index
);
7022 index
= gfc_evaluate_now (index
, block
);
7024 /* Update the stride. */
7025 gfc_init_se (&start
, NULL
);
7026 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->upper
[n
], gfc_array_index_type
);
7027 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7028 gfc_array_index_type
, start
.expr
,
7030 itmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7031 gfc_array_index_type
,
7032 gfc_index_one_node
, itmp
);
7033 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
7034 gfc_array_index_type
, stride
, itmp
);
7035 stride
= gfc_evaluate_now (stride
, block
);
7038 /* Apply the index to obtain the array element. */
7039 tmp
= gfc_build_array_ref (tmp
, index
, NULL
);
7046 tmp
= fold_build1_loc (input_location
, REALPART_EXPR
,
7047 TREE_TYPE (TREE_TYPE (tmp
)), tmp
);
7051 tmp
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
7052 TREE_TYPE (TREE_TYPE (tmp
)), tmp
);
7067 /* Set the target data pointer. */
7068 offset
= gfc_build_addr_expr (gfc_array_dataptr_type (desc
), tmp
);
7069 gfc_conv_descriptor_data_set (block
, parm
, offset
);
7073 /* gfc_conv_expr_descriptor needs the string length an expression
7074 so that the size of the temporary can be obtained. This is done
7075 by adding up the string lengths of all the elements in the
7076 expression. Function with non-constant expressions have their
7077 string lengths mapped onto the actual arguments using the
7078 interface mapping machinery in trans-expr.c. */
7080 get_array_charlen (gfc_expr
*expr
, gfc_se
*se
)
7082 gfc_interface_mapping mapping
;
7083 gfc_formal_arglist
*formal
;
7084 gfc_actual_arglist
*arg
;
7088 if (expr
->ts
.u
.cl
->length
7089 && gfc_is_constant_expr (expr
->ts
.u
.cl
->length
))
7091 if (!expr
->ts
.u
.cl
->backend_decl
)
7092 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
7096 switch (expr
->expr_type
)
7100 /* This is somewhat brutal. The expression for the first
7101 element of the array is evaluated and assigned to a
7102 new string length for the original expression. */
7103 e
= gfc_constructor_first (expr
->value
.constructor
)->expr
;
7105 gfc_init_se (&tse
, NULL
);
7107 /* Avoid evaluating trailing array references since all we need is
7108 the string length. */
7110 tse
.descriptor_only
= 1;
7111 if (e
->rank
&& e
->expr_type
!= EXPR_VARIABLE
)
7112 gfc_conv_expr_descriptor (&tse
, e
);
7114 gfc_conv_expr (&tse
, e
);
7116 gfc_add_block_to_block (&se
->pre
, &tse
.pre
);
7117 gfc_add_block_to_block (&se
->post
, &tse
.post
);
7119 if (!expr
->ts
.u
.cl
->backend_decl
|| !VAR_P (expr
->ts
.u
.cl
->backend_decl
))
7121 expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
7122 expr
->ts
.u
.cl
->backend_decl
=
7123 gfc_create_var (gfc_charlen_type_node
, "sln");
7126 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
7129 /* Make sure that deferred length components point to the hidden
7130 string_length component. */
7131 if (TREE_CODE (tse
.expr
) == COMPONENT_REF
7132 && TREE_CODE (tse
.string_length
) == COMPONENT_REF
7133 && TREE_OPERAND (tse
.expr
, 0) == TREE_OPERAND (tse
.string_length
, 0))
7134 e
->ts
.u
.cl
->backend_decl
= expr
->ts
.u
.cl
->backend_decl
;
7139 get_array_charlen (expr
->value
.op
.op1
, se
);
7141 /* For parentheses the expression ts.u.cl should be identical. */
7142 if (expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
7144 if (expr
->value
.op
.op1
->ts
.u
.cl
!= expr
->ts
.u
.cl
)
7145 expr
->ts
.u
.cl
->backend_decl
7146 = expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
;
7150 expr
->ts
.u
.cl
->backend_decl
=
7151 gfc_create_var (gfc_charlen_type_node
, "sln");
7153 if (expr
->value
.op
.op2
)
7155 get_array_charlen (expr
->value
.op
.op2
, se
);
7157 gcc_assert (expr
->value
.op
.op
== INTRINSIC_CONCAT
);
7159 /* Add the string lengths and assign them to the expression
7160 string length backend declaration. */
7161 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
7162 fold_build2_loc (input_location
, PLUS_EXPR
,
7163 gfc_charlen_type_node
,
7164 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
,
7165 expr
->value
.op
.op2
->ts
.u
.cl
->backend_decl
));
7168 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
7169 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
);
7173 if (expr
->value
.function
.esym
== NULL
7174 || expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
7176 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
7180 /* Map expressions involving the dummy arguments onto the actual
7181 argument expressions. */
7182 gfc_init_interface_mapping (&mapping
);
7183 formal
= gfc_sym_get_dummy_args (expr
->symtree
->n
.sym
);
7184 arg
= expr
->value
.function
.actual
;
7186 /* Set se = NULL in the calls to the interface mapping, to suppress any
7188 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
7193 gfc_add_interface_mapping (&mapping
, formal
->sym
, NULL
, arg
->expr
);
7196 gfc_init_se (&tse
, NULL
);
7198 /* Build the expression for the character length and convert it. */
7199 gfc_apply_interface_mapping (&mapping
, &tse
, expr
->ts
.u
.cl
->length
);
7201 gfc_add_block_to_block (&se
->pre
, &tse
.pre
);
7202 gfc_add_block_to_block (&se
->post
, &tse
.post
);
7203 tse
.expr
= fold_convert (gfc_charlen_type_node
, tse
.expr
);
7204 tse
.expr
= fold_build2_loc (input_location
, MAX_EXPR
,
7205 TREE_TYPE (tse
.expr
), tse
.expr
,
7206 build_zero_cst (TREE_TYPE (tse
.expr
)));
7207 expr
->ts
.u
.cl
->backend_decl
= tse
.expr
;
7208 gfc_free_interface_mapping (&mapping
);
7212 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
7218 /* Helper function to check dimensions. */
7220 transposed_dims (gfc_ss
*ss
)
7224 for (n
= 0; n
< ss
->dimen
; n
++)
7225 if (ss
->dim
[n
] != n
)
7231 /* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
7232 AR_FULL, suitable for the scalarizer. */
7235 walk_coarray (gfc_expr
*e
)
7239 gcc_assert (gfc_get_corank (e
) > 0);
7241 ss
= gfc_walk_expr (e
);
7243 /* Fix scalar coarray. */
7244 if (ss
== gfc_ss_terminator
)
7251 if (ref
->type
== REF_ARRAY
7252 && ref
->u
.ar
.codimen
> 0)
7258 gcc_assert (ref
!= NULL
);
7259 if (ref
->u
.ar
.type
== AR_ELEMENT
)
7260 ref
->u
.ar
.type
= AR_SECTION
;
7261 ss
= gfc_reverse_ss (gfc_walk_array_ref (ss
, e
, ref
));
7268 /* Convert an array for passing as an actual argument. Expressions and
7269 vector subscripts are evaluated and stored in a temporary, which is then
7270 passed. For whole arrays the descriptor is passed. For array sections
7271 a modified copy of the descriptor is passed, but using the original data.
7273 This function is also used for array pointer assignments, and there
7276 - se->want_pointer && !se->direct_byref
7277 EXPR is an actual argument. On exit, se->expr contains a
7278 pointer to the array descriptor.
7280 - !se->want_pointer && !se->direct_byref
7281 EXPR is an actual argument to an intrinsic function or the
7282 left-hand side of a pointer assignment. On exit, se->expr
7283 contains the descriptor for EXPR.
7285 - !se->want_pointer && se->direct_byref
7286 EXPR is the right-hand side of a pointer assignment and
7287 se->expr is the descriptor for the previously-evaluated
7288 left-hand side. The function creates an assignment from
7292 The se->force_tmp flag disables the non-copying descriptor optimization
7293 that is used for transpose. It may be used in cases where there is an
7294 alias between the transpose argument and another argument in the same
7298 gfc_conv_expr_descriptor (gfc_se
*se
, gfc_expr
*expr
)
7301 gfc_ss_type ss_type
;
7302 gfc_ss_info
*ss_info
;
7304 gfc_array_info
*info
;
7312 bool subref_array_target
= false;
7313 bool deferred_array_component
= false;
7314 gfc_expr
*arg
, *ss_expr
;
7316 if (se
->want_coarray
)
7317 ss
= walk_coarray (expr
);
7319 ss
= gfc_walk_expr (expr
);
7321 gcc_assert (ss
!= NULL
);
7322 gcc_assert (ss
!= gfc_ss_terminator
);
7325 ss_type
= ss_info
->type
;
7326 ss_expr
= ss_info
->expr
;
7328 /* Special case: TRANSPOSE which needs no temporary. */
7329 while (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
7330 && (arg
= gfc_get_noncopying_intrinsic_argument (expr
)) != NULL
)
7332 /* This is a call to transpose which has already been handled by the
7333 scalarizer, so that we just need to get its argument's descriptor. */
7334 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
7335 expr
= expr
->value
.function
.actual
->expr
;
7338 /* Special case things we know we can pass easily. */
7339 switch (expr
->expr_type
)
7342 /* If we have a linear array section, we can pass it directly.
7343 Otherwise we need to copy it into a temporary. */
7345 gcc_assert (ss_type
== GFC_SS_SECTION
);
7346 gcc_assert (ss_expr
== expr
);
7347 info
= &ss_info
->data
.array
;
7349 /* Get the descriptor for the array. */
7350 gfc_conv_ss_descriptor (&se
->pre
, ss
, 0);
7351 desc
= info
->descriptor
;
7353 /* The charlen backend decl for deferred character components cannot
7354 be used because it is fixed at zero. Instead, the hidden string
7355 length component is used. */
7356 if (expr
->ts
.type
== BT_CHARACTER
7357 && expr
->ts
.deferred
7358 && TREE_CODE (desc
) == COMPONENT_REF
)
7359 deferred_array_component
= true;
7361 subref_array_target
= se
->direct_byref
&& is_subref_array (expr
);
7362 need_tmp
= gfc_ref_needs_temporary_p (expr
->ref
)
7363 && !subref_array_target
;
7367 else if (se
->force_no_tmp
)
7372 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7374 /* Create a new descriptor if the array doesn't have one. */
7377 else if (info
->ref
->u
.ar
.type
== AR_FULL
|| se
->descriptor_only
)
7379 else if (se
->direct_byref
)
7381 else if (info
->ref
->u
.ar
.dimen
== 0 && !info
->ref
->next
)
7383 else if (info
->ref
->u
.ar
.type
== AR_SECTION
&& se
->want_pointer
)
7386 full
= gfc_full_array_ref_p (info
->ref
, NULL
);
7388 if (full
&& !transposed_dims (ss
))
7390 if (se
->direct_byref
&& !se
->byref_noassign
)
7392 /* Copy the descriptor for pointer assignments. */
7393 gfc_add_modify (&se
->pre
, se
->expr
, desc
);
7395 /* Add any offsets from subreferences. */
7396 gfc_get_dataptr_offset (&se
->pre
, se
->expr
, desc
, NULL_TREE
,
7397 subref_array_target
, expr
);
7399 /* ....and set the span field. */
7400 tmp
= gfc_get_array_span (desc
, expr
);
7401 if (tmp
!= NULL_TREE
&& !integer_zerop (tmp
))
7402 gfc_conv_descriptor_span_set (&se
->pre
, se
->expr
, tmp
);
7404 else if (se
->want_pointer
)
7406 /* We pass full arrays directly. This means that pointers and
7407 allocatable arrays should also work. */
7408 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
7415 if (expr
->ts
.type
== BT_CHARACTER
&& !deferred_array_component
)
7416 se
->string_length
= gfc_get_expr_charlen (expr
);
7417 /* The ss_info string length is returned set to the value of the
7418 hidden string length component. */
7419 else if (deferred_array_component
)
7420 se
->string_length
= ss_info
->string_length
;
7422 gfc_free_ss_chain (ss
);
7428 /* A transformational function return value will be a temporary
7429 array descriptor. We still need to go through the scalarizer
7430 to create the descriptor. Elemental functions are handled as
7431 arbitrary expressions, i.e. copy to a temporary. */
7433 if (se
->direct_byref
)
7435 gcc_assert (ss_type
== GFC_SS_FUNCTION
&& ss_expr
== expr
);
7437 /* For pointer assignments pass the descriptor directly. */
7441 gcc_assert (se
->ss
== ss
);
7443 if (!is_pointer_array (se
->expr
))
7445 tmp
= gfc_get_element_type (TREE_TYPE (se
->expr
));
7446 tmp
= fold_convert (gfc_array_index_type
,
7447 size_in_bytes (tmp
));
7448 gfc_conv_descriptor_span_set (&se
->pre
, se
->expr
, tmp
);
7451 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7452 gfc_conv_expr (se
, expr
);
7454 gfc_free_ss_chain (ss
);
7458 if (ss_expr
!= expr
|| ss_type
!= GFC_SS_FUNCTION
)
7460 if (ss_expr
!= expr
)
7461 /* Elemental function. */
7462 gcc_assert ((expr
->value
.function
.esym
!= NULL
7463 && expr
->value
.function
.esym
->attr
.elemental
)
7464 || (expr
->value
.function
.isym
!= NULL
7465 && expr
->value
.function
.isym
->elemental
)
7466 || gfc_inline_intrinsic_function_p (expr
));
7468 gcc_assert (ss_type
== GFC_SS_INTRINSIC
);
7471 if (expr
->ts
.type
== BT_CHARACTER
7472 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
7473 get_array_charlen (expr
, se
);
7479 /* Transformational function. */
7480 info
= &ss_info
->data
.array
;
7486 /* Constant array constructors don't need a temporary. */
7487 if (ss_type
== GFC_SS_CONSTRUCTOR
7488 && expr
->ts
.type
!= BT_CHARACTER
7489 && gfc_constant_array_constructor_p (expr
->value
.constructor
))
7492 info
= &ss_info
->data
.array
;
7502 /* Something complicated. Copy it into a temporary. */
7508 /* If we are creating a temporary, we don't need to bother about aliases
7513 gfc_init_loopinfo (&loop
);
7515 /* Associate the SS with the loop. */
7516 gfc_add_ss_to_loop (&loop
, ss
);
7518 /* Tell the scalarizer not to bother creating loop variables, etc. */
7520 loop
.array_parameter
= 1;
7522 /* The right-hand side of a pointer assignment mustn't use a temporary. */
7523 gcc_assert (!se
->direct_byref
);
7525 /* Do we need bounds checking or not? */
7526 ss
->no_bounds_check
= expr
->no_bounds_check
;
7528 /* Setup the scalarizing loops and bounds. */
7529 gfc_conv_ss_startstride (&loop
);
7533 if (expr
->ts
.type
== BT_CHARACTER
7534 && (!expr
->ts
.u
.cl
->backend_decl
|| expr
->expr_type
== EXPR_ARRAY
))
7535 get_array_charlen (expr
, se
);
7537 /* Tell the scalarizer to make a temporary. */
7538 loop
.temp_ss
= gfc_get_temp_ss (gfc_typenode_for_spec (&expr
->ts
),
7539 ((expr
->ts
.type
== BT_CHARACTER
)
7540 ? expr
->ts
.u
.cl
->backend_decl
7544 se
->string_length
= loop
.temp_ss
->info
->string_length
;
7545 gcc_assert (loop
.temp_ss
->dimen
== loop
.dimen
);
7546 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
7549 gfc_conv_loop_setup (&loop
, & expr
->where
);
7553 /* Copy into a temporary and pass that. We don't need to copy the data
7554 back because expressions and vector subscripts must be INTENT_IN. */
7555 /* TODO: Optimize passing function return values. */
7560 /* Start the copying loops. */
7561 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
7562 gfc_mark_ss_chain_used (ss
, 1);
7563 gfc_start_scalarized_body (&loop
, &block
);
7565 /* Copy each data element. */
7566 gfc_init_se (&lse
, NULL
);
7567 gfc_copy_loopinfo_to_se (&lse
, &loop
);
7568 gfc_init_se (&rse
, NULL
);
7569 gfc_copy_loopinfo_to_se (&rse
, &loop
);
7571 lse
.ss
= loop
.temp_ss
;
7574 gfc_conv_scalarized_array_ref (&lse
, NULL
);
7575 if (expr
->ts
.type
== BT_CHARACTER
)
7577 gfc_conv_expr (&rse
, expr
);
7578 if (POINTER_TYPE_P (TREE_TYPE (rse
.expr
)))
7579 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
7583 gfc_conv_expr_val (&rse
, expr
);
7585 gfc_add_block_to_block (&block
, &rse
.pre
);
7586 gfc_add_block_to_block (&block
, &lse
.pre
);
7588 lse
.string_length
= rse
.string_length
;
7590 deep_copy
= !se
->data_not_needed
7591 && (expr
->expr_type
== EXPR_VARIABLE
7592 || expr
->expr_type
== EXPR_ARRAY
);
7593 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
,
7595 gfc_add_expr_to_block (&block
, tmp
);
7597 /* Finish the copying loops. */
7598 gfc_trans_scalarizing_loops (&loop
, &block
);
7600 desc
= loop
.temp_ss
->info
->data
.array
.descriptor
;
7602 else if (expr
->expr_type
== EXPR_FUNCTION
&& !transposed_dims (ss
))
7604 desc
= info
->descriptor
;
7605 se
->string_length
= ss_info
->string_length
;
7609 /* We pass sections without copying to a temporary. Make a new
7610 descriptor and point it at the section we want. The loop variable
7611 limits will be the limits of the section.
7612 A function may decide to repack the array to speed up access, but
7613 we're not bothered about that here. */
7614 int dim
, ndim
, codim
;
7623 ndim
= info
->ref
? info
->ref
->u
.ar
.dimen
: ss
->dimen
;
7625 if (se
->want_coarray
)
7627 gfc_array_ref
*ar
= &info
->ref
->u
.ar
;
7629 codim
= gfc_get_corank (expr
);
7630 for (n
= 0; n
< codim
- 1; n
++)
7632 /* Make sure we are not lost somehow. */
7633 gcc_assert (ar
->dimen_type
[n
+ ndim
] == DIMEN_THIS_IMAGE
);
7635 /* Make sure the call to gfc_conv_section_startstride won't
7636 generate unnecessary code to calculate stride. */
7637 gcc_assert (ar
->stride
[n
+ ndim
] == NULL
);
7639 gfc_conv_section_startstride (&loop
.pre
, ss
, n
+ ndim
);
7640 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
7641 loop
.to
[n
+ loop
.dimen
] = info
->end
[n
+ ndim
];
7644 gcc_assert (n
== codim
- 1);
7645 evaluate_bound (&loop
.pre
, info
->start
, ar
->start
,
7646 info
->descriptor
, n
+ ndim
, true,
7647 ar
->as
->type
== AS_DEFERRED
);
7648 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
7653 /* Set the string_length for a character array. */
7654 if (expr
->ts
.type
== BT_CHARACTER
)
7656 se
->string_length
= gfc_get_expr_charlen (expr
);
7657 if (VAR_P (se
->string_length
)
7658 && expr
->ts
.u
.cl
->backend_decl
== se
->string_length
)
7659 tmp
= ss_info
->string_length
;
7661 tmp
= se
->string_length
;
7663 if (expr
->ts
.deferred
)
7664 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
, tmp
);
7667 /* If we have an array section, are assigning or passing an array
7668 section argument make sure that the lower bound is 1. References
7669 to the full array should otherwise keep the original bounds. */
7670 if (!info
->ref
|| info
->ref
->u
.ar
.type
!= AR_FULL
)
7671 for (dim
= 0; dim
< loop
.dimen
; dim
++)
7672 if (!integer_onep (loop
.from
[dim
]))
7674 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7675 gfc_array_index_type
, gfc_index_one_node
,
7677 loop
.to
[dim
] = fold_build2_loc (input_location
, PLUS_EXPR
,
7678 gfc_array_index_type
,
7680 loop
.from
[dim
] = gfc_index_one_node
;
7683 desc
= info
->descriptor
;
7684 if (se
->direct_byref
&& !se
->byref_noassign
)
7686 /* For pointer assignments we fill in the destination. */
7688 parmtype
= TREE_TYPE (parm
);
7692 /* Otherwise make a new one. */
7693 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.deferred
)
7694 parmtype
= gfc_typenode_for_spec (&expr
->ts
);
7696 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
7698 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
, codim
,
7699 loop
.from
, loop
.to
, 0,
7700 GFC_ARRAY_UNKNOWN
, false);
7701 parm
= gfc_create_var (parmtype
, "parm");
7703 /* When expression is a class object, then add the class' handle to
7705 if (expr
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_VARIABLE
)
7707 gfc_expr
*class_expr
= gfc_find_and_cut_at_last_class_ref (expr
);
7710 /* class_expr can be NULL, when no _class ref is in expr.
7711 We must not fix this here with a gfc_fix_class_ref (). */
7714 gfc_init_se (&classse
, NULL
);
7715 gfc_conv_expr (&classse
, class_expr
);
7716 gfc_free_expr (class_expr
);
7718 gcc_assert (classse
.pre
.head
== NULL_TREE
7719 && classse
.post
.head
== NULL_TREE
);
7720 gfc_allocate_lang_decl (parm
);
7721 GFC_DECL_SAVED_DESCRIPTOR (parm
) = classse
.expr
;
7726 /* Set the span field. */
7727 if (expr
->ts
.type
== BT_CHARACTER
&& ss_info
->string_length
)
7728 tmp
= ss_info
->string_length
;
7730 tmp
= gfc_get_array_span (desc
, expr
);
7731 if (tmp
!= NULL_TREE
)
7732 gfc_conv_descriptor_span_set (&loop
.pre
, parm
, tmp
);
7734 /* The following can be somewhat confusing. We have two
7735 descriptors, a new one and the original array.
7736 {parm, parmtype, dim} refer to the new one.
7737 {desc, type, n, loop} refer to the original, which maybe
7738 a descriptorless array.
7739 The bounds of the scalarization are the bounds of the section.
7740 We don't have to worry about numeric overflows when calculating
7741 the offsets because all elements are within the array data. */
7743 /* Set the dtype. */
7744 tmp
= gfc_conv_descriptor_dtype (parm
);
7745 gfc_add_modify (&loop
.pre
, tmp
, gfc_get_dtype (parmtype
));
7747 /* The 1st element in the section. */
7748 base
= gfc_index_zero_node
;
7750 /* The offset from the 1st element in the section. */
7751 offset
= gfc_index_zero_node
;
7753 for (n
= 0; n
< ndim
; n
++)
7755 stride
= gfc_conv_array_stride (desc
, n
);
7757 /* Work out the 1st element in the section. */
7759 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
7761 gcc_assert (info
->subscript
[n
]
7762 && info
->subscript
[n
]->info
->type
== GFC_SS_SCALAR
);
7763 start
= info
->subscript
[n
]->info
->data
.scalar
.value
;
7767 /* Evaluate and remember the start of the section. */
7768 start
= info
->start
[n
];
7769 stride
= gfc_evaluate_now (stride
, &loop
.pre
);
7772 tmp
= gfc_conv_array_lbound (desc
, n
);
7773 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
7775 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
7777 base
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (tmp
),
7781 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
7783 /* For elemental dimensions, we only need the 1st
7784 element in the section. */
7788 /* Vector subscripts need copying and are handled elsewhere. */
7790 gcc_assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
7792 /* look for the corresponding scalarizer dimension: dim. */
7793 for (dim
= 0; dim
< ndim
; dim
++)
7794 if (ss
->dim
[dim
] == n
)
7797 /* loop exited early: the DIM being looked for has been found. */
7798 gcc_assert (dim
< ndim
);
7800 /* Set the new lower bound. */
7801 from
= loop
.from
[dim
];
7804 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
7805 gfc_rank_cst
[dim
], from
);
7807 /* Set the new upper bound. */
7808 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
7809 gfc_rank_cst
[dim
], to
);
7811 /* Multiply the stride by the section stride to get the
7813 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
7814 gfc_array_index_type
,
7815 stride
, info
->stride
[n
]);
7817 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7818 TREE_TYPE (offset
), stride
, from
);
7819 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
7820 TREE_TYPE (offset
), offset
, tmp
);
7822 /* Store the new stride. */
7823 gfc_conv_descriptor_stride_set (&loop
.pre
, parm
,
7824 gfc_rank_cst
[dim
], stride
);
7827 for (n
= loop
.dimen
; n
< loop
.dimen
+ codim
; n
++)
7829 from
= loop
.from
[n
];
7831 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
7832 gfc_rank_cst
[n
], from
);
7833 if (n
< loop
.dimen
+ codim
- 1)
7834 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
7835 gfc_rank_cst
[n
], to
);
7838 if (se
->data_not_needed
)
7839 gfc_conv_descriptor_data_set (&loop
.pre
, parm
,
7840 gfc_index_zero_node
);
7842 /* Point the data pointer at the 1st element in the section. */
7843 gfc_get_dataptr_offset (&loop
.pre
, parm
, desc
, base
,
7844 subref_array_target
, expr
);
7846 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, offset
);
7851 /* For class arrays add the class tree into the saved descriptor to
7852 enable getting of _vptr and the like. */
7853 if (expr
->expr_type
== EXPR_VARIABLE
&& VAR_P (desc
)
7854 && IS_CLASS_ARRAY (expr
->symtree
->n
.sym
))
7856 gfc_allocate_lang_decl (desc
);
7857 GFC_DECL_SAVED_DESCRIPTOR (desc
) =
7858 DECL_LANG_SPECIFIC (expr
->symtree
->n
.sym
->backend_decl
) ?
7859 GFC_DECL_SAVED_DESCRIPTOR (expr
->symtree
->n
.sym
->backend_decl
)
7860 : expr
->symtree
->n
.sym
->backend_decl
;
7862 else if (expr
->expr_type
== EXPR_ARRAY
&& VAR_P (desc
)
7863 && IS_CLASS_ARRAY (expr
))
7866 gfc_allocate_lang_decl (desc
);
7867 tmp
= gfc_create_var (expr
->ts
.u
.derived
->backend_decl
, "class");
7868 GFC_DECL_SAVED_DESCRIPTOR (desc
) = tmp
;
7869 vtype
= gfc_class_vptr_get (tmp
);
7870 gfc_add_modify (&se
->pre
, vtype
,
7871 gfc_build_addr_expr (TREE_TYPE (vtype
),
7872 gfc_find_vtab (&expr
->ts
)->backend_decl
));
7874 if (!se
->direct_byref
|| se
->byref_noassign
)
7876 /* Get a pointer to the new descriptor. */
7877 if (se
->want_pointer
)
7878 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
7883 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
7884 gfc_add_block_to_block (&se
->post
, &loop
.post
);
7886 /* Cleanup the scalarizer. */
7887 gfc_cleanup_loop (&loop
);
7890 /* Helper function for gfc_conv_array_parameter if array size needs to be
7894 array_parameter_size (tree desc
, gfc_expr
*expr
, tree
*size
)
7897 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7898 *size
= GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc
));
7899 else if (expr
->rank
> 1)
7900 *size
= build_call_expr_loc (input_location
,
7901 gfor_fndecl_size0
, 1,
7902 gfc_build_addr_expr (NULL
, desc
));
7905 tree ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_index_zero_node
);
7906 tree lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_index_zero_node
);
7908 *size
= fold_build2_loc (input_location
, MINUS_EXPR
,
7909 gfc_array_index_type
, ubound
, lbound
);
7910 *size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7911 *size
, gfc_index_one_node
);
7912 *size
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
7913 *size
, gfc_index_zero_node
);
7915 elem
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
7916 *size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7917 *size
, fold_convert (gfc_array_index_type
, elem
));
7920 /* Helper function - return true if the argument is a pointer. */
7923 is_pointer (gfc_expr
*e
)
7927 if (e
->expr_type
!= EXPR_VARIABLE
|| e
->symtree
== NULL
)
7930 sym
= e
->symtree
->n
.sym
;
7934 return sym
->attr
.pointer
|| sym
->attr
.proc_pointer
;
7937 /* Convert an array for passing as an actual parameter. */
7940 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, bool g77
,
7941 const gfc_symbol
*fsym
, const char *proc_name
,
7946 tree tmp
= NULL_TREE
;
7948 tree parent
= DECL_CONTEXT (current_function_decl
);
7949 bool full_array_var
;
7950 bool this_array_result
;
7953 bool array_constructor
;
7954 bool good_allocatable
;
7955 bool ultimate_ptr_comp
;
7956 bool ultimate_alloc_comp
;
7961 ultimate_ptr_comp
= false;
7962 ultimate_alloc_comp
= false;
7964 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7966 if (ref
->next
== NULL
)
7969 if (ref
->type
== REF_COMPONENT
)
7971 ultimate_ptr_comp
= ref
->u
.c
.component
->attr
.pointer
;
7972 ultimate_alloc_comp
= ref
->u
.c
.component
->attr
.allocatable
;
7976 full_array_var
= false;
7979 if (expr
->expr_type
== EXPR_VARIABLE
&& ref
&& !ultimate_ptr_comp
)
7980 full_array_var
= gfc_full_array_ref_p (ref
, &contiguous
);
7982 sym
= full_array_var
? expr
->symtree
->n
.sym
: NULL
;
7984 /* The symbol should have an array specification. */
7985 gcc_assert (!sym
|| sym
->as
|| ref
->u
.ar
.as
);
7987 if (expr
->expr_type
== EXPR_ARRAY
&& expr
->ts
.type
== BT_CHARACTER
)
7989 get_array_ctor_strlen (&se
->pre
, expr
->value
.constructor
, &tmp
);
7990 expr
->ts
.u
.cl
->backend_decl
= tmp
;
7991 se
->string_length
= tmp
;
7994 /* Is this the result of the enclosing procedure? */
7995 this_array_result
= (full_array_var
&& sym
->attr
.flavor
== FL_PROCEDURE
);
7996 if (this_array_result
7997 && (sym
->backend_decl
!= current_function_decl
)
7998 && (sym
->backend_decl
!= parent
))
7999 this_array_result
= false;
8001 /* Passing address of the array if it is not pointer or assumed-shape. */
8002 if (full_array_var
&& g77
&& !this_array_result
8003 && sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
8005 tmp
= gfc_get_symbol_decl (sym
);
8007 if (sym
->ts
.type
== BT_CHARACTER
)
8008 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
8010 if (!sym
->attr
.pointer
8012 && sym
->as
->type
!= AS_ASSUMED_SHAPE
8013 && sym
->as
->type
!= AS_DEFERRED
8014 && sym
->as
->type
!= AS_ASSUMED_RANK
8015 && !sym
->attr
.allocatable
)
8017 /* Some variables are declared directly, others are declared as
8018 pointers and allocated on the heap. */
8019 if (sym
->attr
.dummy
|| POINTER_TYPE_P (TREE_TYPE (tmp
)))
8022 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
8024 array_parameter_size (tmp
, expr
, size
);
8028 if (sym
->attr
.allocatable
)
8030 if (sym
->attr
.dummy
|| sym
->attr
.result
)
8032 gfc_conv_expr_descriptor (se
, expr
);
8036 array_parameter_size (tmp
, expr
, size
);
8037 se
->expr
= gfc_conv_array_data (tmp
);
8042 /* A convenient reduction in scope. */
8043 contiguous
= g77
&& !this_array_result
&& contiguous
;
8045 /* There is no need to pack and unpack the array, if it is contiguous
8046 and not a deferred- or assumed-shape array, or if it is simply
8048 no_pack
= ((sym
&& sym
->as
8049 && !sym
->attr
.pointer
8050 && sym
->as
->type
!= AS_DEFERRED
8051 && sym
->as
->type
!= AS_ASSUMED_RANK
8052 && sym
->as
->type
!= AS_ASSUMED_SHAPE
)
8054 (ref
&& ref
->u
.ar
.as
8055 && ref
->u
.ar
.as
->type
!= AS_DEFERRED
8056 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_RANK
8057 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_SHAPE
)
8059 gfc_is_simply_contiguous (expr
, false, true));
8061 no_pack
= contiguous
&& no_pack
;
8063 /* If we have an EXPR_OP or a function returning an explicit-shaped
8064 or allocatable array, an array temporary will be generated which
8065 does not need to be packed / unpacked if passed to an
8066 explicit-shape dummy array. */
8070 if (expr
->expr_type
== EXPR_OP
)
8072 else if (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.esym
)
8074 gfc_symbol
*result
= expr
->value
.function
.esym
->result
;
8075 if (result
->attr
.dimension
8076 && (result
->as
->type
== AS_EXPLICIT
8077 || result
->attr
.allocatable
8078 || result
->attr
.contiguous
))
8083 /* Array constructors are always contiguous and do not need packing. */
8084 array_constructor
= g77
&& !this_array_result
&& expr
->expr_type
== EXPR_ARRAY
;
8086 /* Same is true of contiguous sections from allocatable variables. */
8087 good_allocatable
= contiguous
8089 && expr
->symtree
->n
.sym
->attr
.allocatable
;
8091 /* Or ultimate allocatable components. */
8092 ultimate_alloc_comp
= contiguous
&& ultimate_alloc_comp
;
8094 if (no_pack
|| array_constructor
|| good_allocatable
|| ultimate_alloc_comp
)
8096 gfc_conv_expr_descriptor (se
, expr
);
8097 /* Deallocate the allocatable components of structures that are
8099 if ((expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
)
8100 && expr
->ts
.u
.derived
->attr
.alloc_comp
8101 && expr
->expr_type
!= EXPR_VARIABLE
)
8103 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, se
->expr
, expr
->rank
);
8105 /* The components shall be deallocated before their containing entity. */
8106 gfc_prepend_expr_to_block (&se
->post
, tmp
);
8108 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->expr_type
!= EXPR_FUNCTION
)
8109 se
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
8111 array_parameter_size (se
->expr
, expr
, size
);
8112 se
->expr
= gfc_conv_array_data (se
->expr
);
8116 if (this_array_result
)
8118 /* Result of the enclosing function. */
8119 gfc_conv_expr_descriptor (se
, expr
);
8121 array_parameter_size (se
->expr
, expr
, size
);
8122 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
8124 if (g77
&& TREE_TYPE (TREE_TYPE (se
->expr
)) != NULL_TREE
8125 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
8126 se
->expr
= gfc_conv_array_data (build_fold_indirect_ref_loc (input_location
,
8133 /* Every other type of array. */
8134 se
->want_pointer
= 1;
8135 gfc_conv_expr_descriptor (se
, expr
);
8138 array_parameter_size (build_fold_indirect_ref_loc (input_location
,
8143 /* Deallocate the allocatable components of structures that are
8144 not variable, for descriptorless arguments.
8145 Arguments with a descriptor are handled in gfc_conv_procedure_call. */
8146 if (g77
&& (expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
)
8147 && expr
->ts
.u
.derived
->attr
.alloc_comp
8148 && expr
->expr_type
!= EXPR_VARIABLE
)
8150 tmp
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
8151 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
, expr
->rank
);
8153 /* The components shall be deallocated before their containing entity. */
8154 gfc_prepend_expr_to_block (&se
->post
, tmp
);
8157 if (g77
|| (fsym
&& fsym
->attr
.contiguous
8158 && !gfc_is_simply_contiguous (expr
, false, true)))
8160 tree origptr
= NULL_TREE
;
8164 /* For contiguous arrays, save the original value of the descriptor. */
8167 origptr
= gfc_create_var (pvoid_type_node
, "origptr");
8168 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
8169 tmp
= gfc_conv_array_data (tmp
);
8170 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8171 TREE_TYPE (origptr
), origptr
,
8172 fold_convert (TREE_TYPE (origptr
), tmp
));
8173 gfc_add_expr_to_block (&se
->pre
, tmp
);
8176 /* Repack the array. */
8177 if (warn_array_temporaries
)
8180 gfc_warning (OPT_Warray_temporaries
,
8181 "Creating array temporary at %L for argument %qs",
8182 &expr
->where
, fsym
->name
);
8184 gfc_warning (OPT_Warray_temporaries
,
8185 "Creating array temporary at %L", &expr
->where
);
8188 /* When optmizing, we can use gfc_conv_subref_array_arg for
8189 making the packing and unpacking operation visible to the
8192 if (g77
&& flag_inline_arg_packing
&& expr
->expr_type
== EXPR_VARIABLE
8193 && !is_pointer (expr
) && ! gfc_has_dimen_vector_ref (expr
)
8194 && !(expr
->symtree
->n
.sym
->as
8195 && expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_RANK
)
8196 && (fsym
== NULL
|| fsym
->ts
.type
!= BT_ASSUMED
))
8198 gfc_conv_subref_array_arg (se
, expr
, g77
,
8199 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
8200 false, fsym
, proc_name
, sym
, true);
8204 ptr
= build_call_expr_loc (input_location
,
8205 gfor_fndecl_in_pack
, 1, desc
);
8207 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
8209 tmp
= gfc_conv_expr_present (sym
);
8210 ptr
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
8211 tmp
, fold_convert (TREE_TYPE (se
->expr
), ptr
),
8212 fold_convert (TREE_TYPE (se
->expr
), null_pointer_node
));
8215 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
8217 /* Use the packed data for the actual argument, except for contiguous arrays,
8218 where the descriptor's data component is set. */
8223 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
8225 gfc_ss
* ss
= gfc_walk_expr (expr
);
8226 if (!transposed_dims (ss
))
8227 gfc_conv_descriptor_data_set (&se
->pre
, tmp
, ptr
);
8230 tree old_field
, new_field
;
8232 /* The original descriptor has transposed dims so we can't reuse
8233 it directly; we have to create a new one. */
8234 tree old_desc
= tmp
;
8235 tree new_desc
= gfc_create_var (TREE_TYPE (old_desc
), "arg_desc");
8237 old_field
= gfc_conv_descriptor_dtype (old_desc
);
8238 new_field
= gfc_conv_descriptor_dtype (new_desc
);
8239 gfc_add_modify (&se
->pre
, new_field
, old_field
);
8241 old_field
= gfc_conv_descriptor_offset (old_desc
);
8242 new_field
= gfc_conv_descriptor_offset (new_desc
);
8243 gfc_add_modify (&se
->pre
, new_field
, old_field
);
8245 for (int i
= 0; i
< expr
->rank
; i
++)
8247 old_field
= gfc_conv_descriptor_dimension (old_desc
,
8248 gfc_rank_cst
[get_array_ref_dim_for_loop_dim (ss
, i
)]);
8249 new_field
= gfc_conv_descriptor_dimension (new_desc
,
8251 gfc_add_modify (&se
->pre
, new_field
, old_field
);
8254 if (flag_coarray
== GFC_FCOARRAY_LIB
8255 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (old_desc
))
8256 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (old_desc
))
8257 == GFC_ARRAY_ALLOCATABLE
)
8259 old_field
= gfc_conv_descriptor_token (old_desc
);
8260 new_field
= gfc_conv_descriptor_token (new_desc
);
8261 gfc_add_modify (&se
->pre
, new_field
, old_field
);
8264 gfc_conv_descriptor_data_set (&se
->pre
, new_desc
, ptr
);
8265 se
->expr
= gfc_build_addr_expr (NULL_TREE
, new_desc
);
8270 if (gfc_option
.rtcheck
& GFC_RTCHECK_ARRAY_TEMPS
)
8274 if (fsym
&& proc_name
)
8275 msg
= xasprintf ("An array temporary was created for argument "
8276 "'%s' of procedure '%s'", fsym
->name
, proc_name
);
8278 msg
= xasprintf ("An array temporary was created");
8280 tmp
= build_fold_indirect_ref_loc (input_location
,
8282 tmp
= gfc_conv_array_data (tmp
);
8283 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8284 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
8286 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
8287 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8289 gfc_conv_expr_present (sym
), tmp
);
8291 gfc_trans_runtime_check (false, true, tmp
, &se
->pre
,
8296 gfc_start_block (&block
);
8298 /* Copy the data back. */
8299 if (fsym
== NULL
|| fsym
->attr
.intent
!= INTENT_IN
)
8301 tmp
= build_call_expr_loc (input_location
,
8302 gfor_fndecl_in_unpack
, 2, desc
, ptr
);
8303 gfc_add_expr_to_block (&block
, tmp
);
8306 /* Free the temporary. */
8307 tmp
= gfc_call_free (ptr
);
8308 gfc_add_expr_to_block (&block
, tmp
);
8310 stmt
= gfc_finish_block (&block
);
8312 gfc_init_block (&block
);
8313 /* Only if it was repacked. This code needs to be executed before the
8314 loop cleanup code. */
8315 tmp
= build_fold_indirect_ref_loc (input_location
,
8317 tmp
= gfc_conv_array_data (tmp
);
8318 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8319 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
8321 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
8322 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8324 gfc_conv_expr_present (sym
), tmp
);
8326 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
8328 gfc_add_expr_to_block (&block
, tmp
);
8329 gfc_add_block_to_block (&block
, &se
->post
);
8331 gfc_init_block (&se
->post
);
8333 /* Reset the descriptor pointer. */
8336 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
8337 gfc_conv_descriptor_data_set (&se
->post
, tmp
, origptr
);
8340 gfc_add_block_to_block (&se
->post
, &block
);
8345 /* This helper function calculates the size in words of a full array. */
8348 gfc_full_array_size (stmtblock_t
*block
, tree decl
, int rank
)
8353 idx
= gfc_rank_cst
[rank
- 1];
8354 nelems
= gfc_conv_descriptor_ubound_get (decl
, idx
);
8355 tmp
= gfc_conv_descriptor_lbound_get (decl
, idx
);
8356 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
8358 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
8359 tmp
, gfc_index_one_node
);
8360 tmp
= gfc_evaluate_now (tmp
, block
);
8362 nelems
= gfc_conv_descriptor_stride_get (decl
, idx
);
8363 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8365 return gfc_evaluate_now (tmp
, block
);
8369 /* Allocate dest to the same size as src, and copy src -> dest.
8370 If no_malloc is set, only the copy is done. */
8373 duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
8374 bool no_malloc
, bool no_memcpy
, tree str_sz
,
8375 tree add_when_allocated
)
8384 /* If the source is null, set the destination to null. Then,
8385 allocate memory to the destination. */
8386 gfc_init_block (&block
);
8388 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
8390 gfc_add_modify (&block
, dest
, fold_convert (type
, null_pointer_node
));
8391 null_data
= gfc_finish_block (&block
);
8393 gfc_init_block (&block
);
8394 if (str_sz
!= NULL_TREE
)
8397 size
= TYPE_SIZE_UNIT (TREE_TYPE (type
));
8401 tmp
= gfc_call_malloc (&block
, type
, size
);
8402 gfc_add_modify (&block
, dest
, fold_convert (type
, tmp
));
8407 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8408 tmp
= build_call_expr_loc (input_location
, tmp
, 3, dest
, src
,
8409 fold_convert (size_type_node
, size
));
8410 gfc_add_expr_to_block (&block
, tmp
);
8415 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
8416 null_data
= gfc_finish_block (&block
);
8418 gfc_init_block (&block
);
8420 nelems
= gfc_full_array_size (&block
, src
, rank
);
8422 nelems
= gfc_index_one_node
;
8424 if (str_sz
!= NULL_TREE
)
8425 tmp
= fold_convert (gfc_array_index_type
, str_sz
);
8427 tmp
= fold_convert (gfc_array_index_type
,
8428 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
8429 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8433 tmp
= TREE_TYPE (gfc_conv_descriptor_data_get (src
));
8434 tmp
= gfc_call_malloc (&block
, tmp
, size
);
8435 gfc_conv_descriptor_data_set (&block
, dest
, tmp
);
8438 /* We know the temporary and the value will be the same length,
8439 so can use memcpy. */
8442 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8443 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
8444 gfc_conv_descriptor_data_get (dest
),
8445 gfc_conv_descriptor_data_get (src
),
8446 fold_convert (size_type_node
, size
));
8447 gfc_add_expr_to_block (&block
, tmp
);
8451 gfc_add_expr_to_block (&block
, add_when_allocated
);
8452 tmp
= gfc_finish_block (&block
);
8454 /* Null the destination if the source is null; otherwise do
8455 the allocate and copy. */
8456 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src
)))
8459 null_cond
= gfc_conv_descriptor_data_get (src
);
8461 null_cond
= convert (pvoid_type_node
, null_cond
);
8462 null_cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8463 null_cond
, null_pointer_node
);
8464 return build3_v (COND_EXPR
, null_cond
, tmp
, null_data
);
8468 /* Allocate dest to the same size as src, and copy data src -> dest. */
8471 gfc_duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
8472 tree add_when_allocated
)
8474 return duplicate_allocatable (dest
, src
, type
, rank
, false, false,
8475 NULL_TREE
, add_when_allocated
);
8479 /* Copy data src -> dest. */
8482 gfc_copy_allocatable_data (tree dest
, tree src
, tree type
, int rank
)
8484 return duplicate_allocatable (dest
, src
, type
, rank
, true, false,
8485 NULL_TREE
, NULL_TREE
);
8488 /* Allocate dest to the same size as src, but don't copy anything. */
8491 gfc_duplicate_allocatable_nocopy (tree dest
, tree src
, tree type
, int rank
)
8493 return duplicate_allocatable (dest
, src
, type
, rank
, false, true,
8494 NULL_TREE
, NULL_TREE
);
8499 duplicate_allocatable_coarray (tree dest
, tree dest_tok
, tree src
,
8500 tree type
, int rank
)
8507 stmtblock_t block
, globalblock
;
8509 /* If the source is null, set the destination to null. Then,
8510 allocate memory to the destination. */
8511 gfc_init_block (&block
);
8512 gfc_init_block (&globalblock
);
8514 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
8517 symbol_attribute attr
;
8520 gfc_init_se (&se
, NULL
);
8521 gfc_clear_attr (&attr
);
8522 attr
.allocatable
= 1;
8523 dummy_desc
= gfc_conv_scalar_to_descriptor (&se
, dest
, attr
);
8524 gfc_add_block_to_block (&globalblock
, &se
.pre
);
8525 size
= TYPE_SIZE_UNIT (TREE_TYPE (type
));
8527 gfc_add_modify (&block
, dest
, fold_convert (type
, null_pointer_node
));
8528 gfc_allocate_using_caf_lib (&block
, dummy_desc
, size
,
8529 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8530 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8531 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
8532 null_data
= gfc_finish_block (&block
);
8534 gfc_init_block (&block
);
8536 gfc_allocate_using_caf_lib (&block
, dummy_desc
,
8537 fold_convert (size_type_node
, size
),
8538 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8539 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8540 GFC_CAF_COARRAY_ALLOC
);
8542 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8543 tmp
= build_call_expr_loc (input_location
, tmp
, 3, dest
, src
,
8544 fold_convert (size_type_node
, size
));
8545 gfc_add_expr_to_block (&block
, tmp
);
8549 /* Set the rank or unitialized memory access may be reported. */
8550 tmp
= gfc_conv_descriptor_rank (dest
);
8551 gfc_add_modify (&globalblock
, tmp
, build_int_cst (TREE_TYPE (tmp
), rank
));
8554 nelems
= gfc_full_array_size (&block
, src
, rank
);
8556 nelems
= integer_one_node
;
8558 tmp
= fold_convert (size_type_node
,
8559 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
8560 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
8561 fold_convert (size_type_node
, nelems
), tmp
);
8563 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
8564 gfc_allocate_using_caf_lib (&block
, dest
, fold_convert (size_type_node
,
8566 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8567 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8568 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
8569 null_data
= gfc_finish_block (&block
);
8571 gfc_init_block (&block
);
8572 gfc_allocate_using_caf_lib (&block
, dest
,
8573 fold_convert (size_type_node
, size
),
8574 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8575 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8576 GFC_CAF_COARRAY_ALLOC
);
8578 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8579 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
8580 gfc_conv_descriptor_data_get (dest
),
8581 gfc_conv_descriptor_data_get (src
),
8582 fold_convert (size_type_node
, size
));
8583 gfc_add_expr_to_block (&block
, tmp
);
8586 tmp
= gfc_finish_block (&block
);
8588 /* Null the destination if the source is null; otherwise do
8589 the register and copy. */
8590 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src
)))
8593 null_cond
= gfc_conv_descriptor_data_get (src
);
8595 null_cond
= convert (pvoid_type_node
, null_cond
);
8596 null_cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8597 null_cond
, null_pointer_node
);
8598 gfc_add_expr_to_block (&globalblock
, build3_v (COND_EXPR
, null_cond
, tmp
,
8600 return gfc_finish_block (&globalblock
);
8604 /* Helper function to abstract whether coarray processing is enabled. */
8607 caf_enabled (int caf_mode
)
8609 return (caf_mode
& GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
)
8610 == GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
;
8614 /* Helper function to abstract whether coarray processing is enabled
8615 and we are in a derived type coarray. */
8618 caf_in_coarray (int caf_mode
)
8620 static const int pat
= GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
8621 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
;
8622 return (caf_mode
& pat
) == pat
;
8626 /* Helper function to abstract whether coarray is to deallocate only. */
8629 gfc_caf_is_dealloc_only (int caf_mode
)
8631 return (caf_mode
& GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY
)
8632 == GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY
;
8636 /* Recursively traverse an object of derived type, generating code to
8637 deallocate, nullify or copy allocatable components. This is the work horse
8638 function for the functions named in this enum. */
8640 enum {DEALLOCATE_ALLOC_COMP
= 1, NULLIFY_ALLOC_COMP
,
8641 COPY_ALLOC_COMP
, COPY_ONLY_ALLOC_COMP
, REASSIGN_CAF_COMP
,
8642 ALLOCATE_PDT_COMP
, DEALLOCATE_PDT_COMP
, CHECK_PDT_DUMMY
,
8645 static gfc_actual_arglist
*pdt_param_list
;
8648 structure_alloc_comps (gfc_symbol
* der_type
, tree decl
,
8649 tree dest
, int rank
, int purpose
, int caf_mode
,
8650 gfc_co_subroutines_args
*args
)
8654 stmtblock_t fnblock
;
8655 stmtblock_t loopbody
;
8656 stmtblock_t tmpblock
;
8667 tree null_cond
= NULL_TREE
;
8668 tree add_when_allocated
;
8669 tree dealloc_fndecl
;
8673 symbol_attribute
*attr
;
8674 bool deallocate_called
;
8676 gfc_init_block (&fnblock
);
8678 decl_type
= TREE_TYPE (decl
);
8680 if ((POINTER_TYPE_P (decl_type
))
8681 || (TREE_CODE (decl_type
) == REFERENCE_TYPE
&& rank
== 0))
8683 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
8684 /* Deref dest in sync with decl, but only when it is not NULL. */
8686 dest
= build_fold_indirect_ref_loc (input_location
, dest
);
8688 /* Update the decl_type because it got dereferenced. */
8689 decl_type
= TREE_TYPE (decl
);
8692 /* If this is an array of derived types with allocatable components
8693 build a loop and recursively call this function. */
8694 if (TREE_CODE (decl_type
) == ARRAY_TYPE
8695 || (GFC_DESCRIPTOR_TYPE_P (decl_type
) && rank
!= 0))
8697 tmp
= gfc_conv_array_data (decl
);
8698 var
= build_fold_indirect_ref_loc (input_location
, tmp
);
8700 /* Get the number of elements - 1 and set the counter. */
8701 if (GFC_DESCRIPTOR_TYPE_P (decl_type
))
8703 /* Use the descriptor for an allocatable array. Since this
8704 is a full array reference, we only need the descriptor
8705 information from dimension = rank. */
8706 tmp
= gfc_full_array_size (&fnblock
, decl
, rank
);
8707 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8708 gfc_array_index_type
, tmp
,
8709 gfc_index_one_node
);
8711 null_cond
= gfc_conv_descriptor_data_get (decl
);
8712 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
8713 logical_type_node
, null_cond
,
8714 build_int_cst (TREE_TYPE (null_cond
), 0));
8718 /* Otherwise use the TYPE_DOMAIN information. */
8719 tmp
= array_type_nelts (decl_type
);
8720 tmp
= fold_convert (gfc_array_index_type
, tmp
);
8723 /* Remember that this is, in fact, the no. of elements - 1. */
8724 nelems
= gfc_evaluate_now (tmp
, &fnblock
);
8725 index
= gfc_create_var (gfc_array_index_type
, "S");
8727 /* Build the body of the loop. */
8728 gfc_init_block (&loopbody
);
8730 vref
= gfc_build_array_ref (var
, index
, NULL
);
8732 if (purpose
== COPY_ALLOC_COMP
|| purpose
== COPY_ONLY_ALLOC_COMP
)
8734 tmp
= build_fold_indirect_ref_loc (input_location
,
8735 gfc_conv_array_data (dest
));
8736 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
8737 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
,
8738 COPY_ALLOC_COMP
, caf_mode
, args
);
8741 tmp
= structure_alloc_comps (der_type
, vref
, NULL_TREE
, rank
, purpose
,
8744 gfc_add_expr_to_block (&loopbody
, tmp
);
8746 /* Build the loop and return. */
8747 gfc_init_loopinfo (&loop
);
8749 loop
.from
[0] = gfc_index_zero_node
;
8750 loop
.loopvar
[0] = index
;
8751 loop
.to
[0] = nelems
;
8752 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
8753 gfc_add_block_to_block (&fnblock
, &loop
.pre
);
8755 tmp
= gfc_finish_block (&fnblock
);
8756 /* When copying allocateable components, the above implements the
8757 deep copy. Nevertheless is a deep copy only allowed, when the current
8758 component is allocated, for which code will be generated in
8759 gfc_duplicate_allocatable (), where the deep copy code is just added
8760 into the if's body, by adding tmp (the deep copy code) as last
8761 argument to gfc_duplicate_allocatable (). */
8762 if (purpose
== COPY_ALLOC_COMP
8763 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
8764 tmp
= gfc_duplicate_allocatable (dest
, decl
, decl_type
, rank
,
8766 else if (null_cond
!= NULL_TREE
)
8767 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
8768 build_empty_stmt (input_location
));
8773 if (purpose
== DEALLOCATE_ALLOC_COMP
&& der_type
->attr
.pdt_type
)
8775 tmp
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
8776 DEALLOCATE_PDT_COMP
, 0, args
);
8777 gfc_add_expr_to_block (&fnblock
, tmp
);
8779 else if (purpose
== ALLOCATE_PDT_COMP
&& der_type
->attr
.alloc_comp
)
8781 tmp
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
8782 NULLIFY_ALLOC_COMP
, 0, args
);
8783 gfc_add_expr_to_block (&fnblock
, tmp
);
8786 /* Otherwise, act on the components or recursively call self to
8787 act on a chain of components. */
8788 for (c
= der_type
->components
; c
; c
= c
->next
)
8790 bool cmp_has_alloc_comps
= (c
->ts
.type
== BT_DERIVED
8791 || c
->ts
.type
== BT_CLASS
)
8792 && c
->ts
.u
.derived
->attr
.alloc_comp
;
8793 bool same_type
= (c
->ts
.type
== BT_DERIVED
&& der_type
== c
->ts
.u
.derived
)
8794 || (c
->ts
.type
== BT_CLASS
&& der_type
== CLASS_DATA (c
)->ts
.u
.derived
);
8796 bool is_pdt_type
= c
->ts
.type
== BT_DERIVED
8797 && c
->ts
.u
.derived
->attr
.pdt_type
;
8799 cdecl = c
->backend_decl
;
8800 ctype
= TREE_TYPE (cdecl);
8805 case BCAST_ALLOC_COMP
:
8809 stmtblock_t derived_type_block
;
8811 gfc_init_block (&tmpblock
);
8813 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8814 decl
, cdecl, NULL_TREE
);
8816 /* Shortcut to get the attributes of the component. */
8817 if (c
->ts
.type
== BT_CLASS
)
8819 attr
= &CLASS_DATA (c
)->attr
;
8820 if (attr
->class_pointer
)
8830 add_when_allocated
= NULL_TREE
;
8831 if (cmp_has_alloc_comps
8832 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
)
8834 if (c
->ts
.type
== BT_CLASS
)
8836 rank
= CLASS_DATA (c
)->as
? CLASS_DATA (c
)->as
->rank
: 0;
8838 = structure_alloc_comps (CLASS_DATA (c
)->ts
.u
.derived
,
8839 comp
, NULL_TREE
, rank
, purpose
,
8844 rank
= c
->as
? c
->as
->rank
: 0;
8845 add_when_allocated
= structure_alloc_comps (c
->ts
.u
.derived
,
8852 gfc_init_block (&derived_type_block
);
8853 if (add_when_allocated
)
8854 gfc_add_expr_to_block (&derived_type_block
, add_when_allocated
);
8855 tmp
= gfc_finish_block (&derived_type_block
);
8856 gfc_add_expr_to_block (&tmpblock
, tmp
);
8858 /* Convert the component into a rank 1 descriptor type. */
8859 if (attr
->dimension
)
8861 tmp
= gfc_get_element_type (TREE_TYPE (comp
));
8862 ubound
= gfc_full_array_size (&tmpblock
, comp
,
8863 c
->ts
.type
== BT_CLASS
8864 ? CLASS_DATA (c
)->as
->rank
8869 tmp
= TREE_TYPE (comp
);
8870 ubound
= build_int_cst (gfc_array_index_type
, 1);
8873 cdesc
= gfc_get_array_type_bounds (tmp
, 1, 0, &gfc_index_one_node
,
8875 GFC_ARRAY_ALLOCATABLE
, false);
8877 cdesc
= gfc_create_var (cdesc
, "cdesc");
8878 DECL_ARTIFICIAL (cdesc
) = 1;
8880 gfc_add_modify (&tmpblock
, gfc_conv_descriptor_dtype (cdesc
),
8881 gfc_get_dtype_rank_type (1, tmp
));
8882 gfc_conv_descriptor_lbound_set (&tmpblock
, cdesc
,
8883 gfc_index_zero_node
,
8884 gfc_index_one_node
);
8885 gfc_conv_descriptor_stride_set (&tmpblock
, cdesc
,
8886 gfc_index_zero_node
,
8887 gfc_index_one_node
);
8888 gfc_conv_descriptor_ubound_set (&tmpblock
, cdesc
,
8889 gfc_index_zero_node
, ubound
);
8891 if (attr
->dimension
)
8892 comp
= gfc_conv_descriptor_data_get (comp
);
8897 gfc_init_se (&se
, NULL
);
8899 comp
= gfc_conv_scalar_to_descriptor (&se
, comp
,
8900 c
->ts
.type
== BT_CLASS
8901 ? CLASS_DATA (c
)->attr
8903 comp
= gfc_build_addr_expr (NULL_TREE
, comp
);
8904 gfc_add_block_to_block (&tmpblock
, &se
.pre
);
8907 gfc_conv_descriptor_data_set (&tmpblock
, cdesc
, comp
);
8911 fndecl
= build_call_expr_loc (input_location
,
8912 gfor_fndecl_co_broadcast
, 5,
8913 gfc_build_addr_expr (pvoid_type_node
,cdesc
),
8915 null_pointer_node
, null_pointer_node
,
8918 gfc_add_expr_to_block (&tmpblock
, fndecl
);
8919 gfc_add_block_to_block (&fnblock
, &tmpblock
);
8923 case DEALLOCATE_ALLOC_COMP
:
8925 gfc_init_block (&tmpblock
);
8927 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8928 decl
, cdecl, NULL_TREE
);
8930 /* Shortcut to get the attributes of the component. */
8931 if (c
->ts
.type
== BT_CLASS
)
8933 attr
= &CLASS_DATA (c
)->attr
;
8934 if (attr
->class_pointer
)
8944 if ((c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
)
8945 || (c
->ts
.type
== BT_CLASS
&& !CLASS_DATA (c
)->attr
.class_pointer
))
8946 /* Call the finalizer, which will free the memory and nullify the
8947 pointer of an array. */
8948 deallocate_called
= gfc_add_comp_finalizer_call (&tmpblock
, comp
, c
,
8949 caf_enabled (caf_mode
))
8952 deallocate_called
= false;
8954 /* Add the _class ref for classes. */
8955 if (c
->ts
.type
== BT_CLASS
&& attr
->allocatable
)
8956 comp
= gfc_class_data_get (comp
);
8958 add_when_allocated
= NULL_TREE
;
8959 if (cmp_has_alloc_comps
8960 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
8962 && !deallocate_called
)
8964 /* Add checked deallocation of the components. This code is
8965 obviously added because the finalizer is not trusted to free
8967 if (c
->ts
.type
== BT_CLASS
)
8969 rank
= CLASS_DATA (c
)->as
? CLASS_DATA (c
)->as
->rank
: 0;
8971 = structure_alloc_comps (CLASS_DATA (c
)->ts
.u
.derived
,
8972 comp
, NULL_TREE
, rank
, purpose
,
8977 rank
= c
->as
? c
->as
->rank
: 0;
8978 add_when_allocated
= structure_alloc_comps (c
->ts
.u
.derived
,
8985 if (attr
->allocatable
&& !same_type
8986 && (!attr
->codimension
|| caf_enabled (caf_mode
)))
8988 /* Handle all types of components besides components of the
8989 same_type as the current one, because those would create an
8992 = (caf_in_coarray (caf_mode
) || attr
->codimension
)
8993 ? (gfc_caf_is_dealloc_only (caf_mode
)
8994 ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
8995 : GFC_CAF_COARRAY_DEREGISTER
)
8996 : GFC_CAF_COARRAY_NOCOARRAY
;
8998 caf_token
= NULL_TREE
;
8999 /* Coarray components are handled directly by
9000 deallocate_with_status. */
9001 if (!attr
->codimension
9002 && caf_dereg_mode
!= GFC_CAF_COARRAY_NOCOARRAY
)
9005 caf_token
= fold_build3_loc (input_location
, COMPONENT_REF
,
9006 TREE_TYPE (c
->caf_token
),
9007 decl
, c
->caf_token
, NULL_TREE
);
9008 else if (attr
->dimension
&& !attr
->proc_pointer
)
9009 caf_token
= gfc_conv_descriptor_token (comp
);
9011 if (attr
->dimension
&& !attr
->codimension
&& !attr
->proc_pointer
)
9012 /* When this is an array but not in conjunction with a coarray
9013 then add the data-ref. For coarray'ed arrays the data-ref
9014 is added by deallocate_with_status. */
9015 comp
= gfc_conv_descriptor_data_get (comp
);
9017 tmp
= gfc_deallocate_with_status (comp
, NULL_TREE
, NULL_TREE
,
9018 NULL_TREE
, NULL_TREE
, true,
9019 NULL
, caf_dereg_mode
,
9020 add_when_allocated
, caf_token
);
9022 gfc_add_expr_to_block (&tmpblock
, tmp
);
9024 else if (attr
->allocatable
&& !attr
->codimension
9025 && !deallocate_called
)
9027 /* Case of recursive allocatable derived types. */
9031 stmtblock_t dealloc_block
;
9033 gfc_init_block (&dealloc_block
);
9034 if (add_when_allocated
)
9035 gfc_add_expr_to_block (&dealloc_block
, add_when_allocated
);
9037 /* Convert the component into a rank 1 descriptor type. */
9038 if (attr
->dimension
)
9040 tmp
= gfc_get_element_type (TREE_TYPE (comp
));
9041 ubound
= gfc_full_array_size (&dealloc_block
, comp
,
9042 c
->ts
.type
== BT_CLASS
9043 ? CLASS_DATA (c
)->as
->rank
9048 tmp
= TREE_TYPE (comp
);
9049 ubound
= build_int_cst (gfc_array_index_type
, 1);
9052 cdesc
= gfc_get_array_type_bounds (tmp
, 1, 0, &gfc_index_one_node
,
9054 GFC_ARRAY_ALLOCATABLE
, false);
9056 cdesc
= gfc_create_var (cdesc
, "cdesc");
9057 DECL_ARTIFICIAL (cdesc
) = 1;
9059 gfc_add_modify (&dealloc_block
, gfc_conv_descriptor_dtype (cdesc
),
9060 gfc_get_dtype_rank_type (1, tmp
));
9061 gfc_conv_descriptor_lbound_set (&dealloc_block
, cdesc
,
9062 gfc_index_zero_node
,
9063 gfc_index_one_node
);
9064 gfc_conv_descriptor_stride_set (&dealloc_block
, cdesc
,
9065 gfc_index_zero_node
,
9066 gfc_index_one_node
);
9067 gfc_conv_descriptor_ubound_set (&dealloc_block
, cdesc
,
9068 gfc_index_zero_node
, ubound
);
9070 if (attr
->dimension
)
9071 comp
= gfc_conv_descriptor_data_get (comp
);
9073 gfc_conv_descriptor_data_set (&dealloc_block
, cdesc
, comp
);
9075 /* Now call the deallocator. */
9076 vtab
= gfc_find_vtab (&c
->ts
);
9077 if (vtab
->backend_decl
== NULL
)
9078 gfc_get_symbol_decl (vtab
);
9079 tmp
= gfc_build_addr_expr (NULL_TREE
, vtab
->backend_decl
);
9080 dealloc_fndecl
= gfc_vptr_deallocate_get (tmp
);
9081 dealloc_fndecl
= build_fold_indirect_ref_loc (input_location
,
9083 tmp
= build_int_cst (TREE_TYPE (comp
), 0);
9084 is_allocated
= fold_build2_loc (input_location
, NE_EXPR
,
9085 logical_type_node
, tmp
,
9087 cdesc
= gfc_build_addr_expr (NULL_TREE
, cdesc
);
9089 tmp
= build_call_expr_loc (input_location
,
9092 gfc_add_expr_to_block (&dealloc_block
, tmp
);
9094 tmp
= gfc_finish_block (&dealloc_block
);
9096 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
9097 void_type_node
, is_allocated
, tmp
,
9098 build_empty_stmt (input_location
));
9100 gfc_add_expr_to_block (&tmpblock
, tmp
);
9102 else if (add_when_allocated
)
9103 gfc_add_expr_to_block (&tmpblock
, add_when_allocated
);
9105 if (c
->ts
.type
== BT_CLASS
&& attr
->allocatable
9106 && (!attr
->codimension
|| !caf_enabled (caf_mode
)))
9108 /* Finally, reset the vptr to the declared type vtable and, if
9109 necessary reset the _len field.
9111 First recover the reference to the component and obtain
9113 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9114 decl
, cdecl, NULL_TREE
);
9115 tmp
= gfc_class_vptr_get (comp
);
9117 if (UNLIMITED_POLY (c
))
9119 /* Both vptr and _len field should be nulled. */
9120 gfc_add_modify (&tmpblock
, tmp
,
9121 build_int_cst (TREE_TYPE (tmp
), 0));
9122 tmp
= gfc_class_len_get (comp
);
9123 gfc_add_modify (&tmpblock
, tmp
,
9124 build_int_cst (TREE_TYPE (tmp
), 0));
9128 /* Build the vtable address and set the vptr with it. */
9131 vtable
= gfc_find_derived_vtab (c
->ts
.u
.derived
);
9132 vtab
= vtable
->backend_decl
;
9133 if (vtab
== NULL_TREE
)
9134 vtab
= gfc_get_symbol_decl (vtable
);
9135 vtab
= gfc_build_addr_expr (NULL
, vtab
);
9136 vtab
= fold_convert (TREE_TYPE (tmp
), vtab
);
9137 gfc_add_modify (&tmpblock
, tmp
, vtab
);
9141 /* Now add the deallocation of this component. */
9142 gfc_add_block_to_block (&fnblock
, &tmpblock
);
9145 case NULLIFY_ALLOC_COMP
:
9147 - allocatable components (regular or in class)
9148 - components that have allocatable components
9149 - pointer components when in a coarray.
9150 Skip everything else especially proc_pointers, which may come
9151 coupled with the regular pointer attribute. */
9152 if (c
->attr
.proc_pointer
9153 || !(c
->attr
.allocatable
|| (c
->ts
.type
== BT_CLASS
9154 && CLASS_DATA (c
)->attr
.allocatable
)
9155 || (cmp_has_alloc_comps
9156 && ((c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
)
9157 || (c
->ts
.type
== BT_CLASS
9158 && !CLASS_DATA (c
)->attr
.class_pointer
)))
9159 || (caf_in_coarray (caf_mode
) && c
->attr
.pointer
)))
9162 /* Process class components first, because they always have the
9163 pointer-attribute set which would be caught wrong else. */
9164 if (c
->ts
.type
== BT_CLASS
9165 && (CLASS_DATA (c
)->attr
.allocatable
9166 || CLASS_DATA (c
)->attr
.class_pointer
))
9170 /* Allocatable CLASS components. */
9171 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9172 decl
, cdecl, NULL_TREE
);
9174 vptr_decl
= gfc_class_vptr_get (comp
);
9176 comp
= gfc_class_data_get (comp
);
9177 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp
)))
9178 gfc_conv_descriptor_data_set (&fnblock
, comp
,
9182 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
9183 void_type_node
, comp
,
9184 build_int_cst (TREE_TYPE (comp
), 0));
9185 gfc_add_expr_to_block (&fnblock
, tmp
);
9188 /* The dynamic type of a disassociated pointer or unallocated
9189 allocatable variable is its declared type. An unlimited
9190 polymorphic entity has no declared type. */
9191 if (!UNLIMITED_POLY (c
))
9193 vtab
= gfc_find_derived_vtab (c
->ts
.u
.derived
);
9194 if (!vtab
->backend_decl
)
9195 gfc_get_symbol_decl (vtab
);
9196 tmp
= gfc_build_addr_expr (NULL_TREE
, vtab
->backend_decl
);
9199 tmp
= build_int_cst (TREE_TYPE (vptr_decl
), 0);
9201 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
9202 void_type_node
, vptr_decl
, tmp
);
9203 gfc_add_expr_to_block (&fnblock
, tmp
);
9205 cmp_has_alloc_comps
= false;
9207 /* Coarrays need the component to be nulled before the api-call
9209 else if (c
->attr
.pointer
|| c
->attr
.allocatable
)
9211 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9212 decl
, cdecl, NULL_TREE
);
9213 if (c
->attr
.dimension
|| c
->attr
.codimension
)
9214 gfc_conv_descriptor_data_set (&fnblock
, comp
,
9217 gfc_add_modify (&fnblock
, comp
,
9218 build_int_cst (TREE_TYPE (comp
), 0));
9219 if (gfc_deferred_strlen (c
, &comp
))
9221 comp
= fold_build3_loc (input_location
, COMPONENT_REF
,
9223 decl
, comp
, NULL_TREE
);
9224 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
9225 TREE_TYPE (comp
), comp
,
9226 build_int_cst (TREE_TYPE (comp
), 0));
9227 gfc_add_expr_to_block (&fnblock
, tmp
);
9229 cmp_has_alloc_comps
= false;
9232 if (flag_coarray
== GFC_FCOARRAY_LIB
&& caf_in_coarray (caf_mode
))
9234 /* Register a component of a derived type coarray with the
9235 coarray library. Do not register ultimate component
9236 coarrays here. They are treated like regular coarrays and
9237 are either allocated on all images or on none. */
9240 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9241 decl
, cdecl, NULL_TREE
);
9242 if (c
->attr
.dimension
)
9244 /* Set the dtype, because caf_register needs it. */
9245 gfc_add_modify (&fnblock
, gfc_conv_descriptor_dtype (comp
),
9246 gfc_get_dtype (TREE_TYPE (comp
)));
9247 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9248 decl
, cdecl, NULL_TREE
);
9249 token
= gfc_conv_descriptor_token (tmp
);
9255 gfc_init_se (&se
, NULL
);
9256 token
= fold_build3_loc (input_location
, COMPONENT_REF
,
9257 pvoid_type_node
, decl
, c
->caf_token
,
9259 comp
= gfc_conv_scalar_to_descriptor (&se
, comp
,
9260 c
->ts
.type
== BT_CLASS
9261 ? CLASS_DATA (c
)->attr
9263 gfc_add_block_to_block (&fnblock
, &se
.pre
);
9266 gfc_allocate_using_caf_lib (&fnblock
, comp
, size_zero_node
,
9267 gfc_build_addr_expr (NULL_TREE
,
9269 NULL_TREE
, NULL_TREE
, NULL_TREE
,
9270 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
9273 if (cmp_has_alloc_comps
)
9275 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9276 decl
, cdecl, NULL_TREE
);
9277 rank
= c
->as
? c
->as
->rank
: 0;
9278 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
9279 rank
, purpose
, caf_mode
, args
);
9280 gfc_add_expr_to_block (&fnblock
, tmp
);
9284 case REASSIGN_CAF_COMP
:
9285 if (caf_enabled (caf_mode
)
9286 && (c
->attr
.codimension
9287 || (c
->ts
.type
== BT_CLASS
9288 && (CLASS_DATA (c
)->attr
.coarray_comp
9289 || caf_in_coarray (caf_mode
)))
9290 || (c
->ts
.type
== BT_DERIVED
9291 && (c
->ts
.u
.derived
->attr
.coarray_comp
9292 || caf_in_coarray (caf_mode
))))
9295 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9296 decl
, cdecl, NULL_TREE
);
9297 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9298 dest
, cdecl, NULL_TREE
);
9300 if (c
->attr
.codimension
)
9302 if (c
->ts
.type
== BT_CLASS
)
9304 comp
= gfc_class_data_get (comp
);
9305 dcmp
= gfc_class_data_get (dcmp
);
9307 gfc_conv_descriptor_data_set (&fnblock
, dcmp
,
9308 gfc_conv_descriptor_data_get (comp
));
9312 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, dcmp
,
9313 rank
, purpose
, caf_mode
9314 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
,
9316 gfc_add_expr_to_block (&fnblock
, tmp
);
9321 case COPY_ALLOC_COMP
:
9322 if (c
->attr
.pointer
|| c
->attr
.proc_pointer
)
9325 /* We need source and destination components. */
9326 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, decl
,
9328 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, dest
,
9330 dcmp
= fold_convert (TREE_TYPE (comp
), dcmp
);
9332 if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
9340 dst_data
= gfc_class_data_get (dcmp
);
9341 src_data
= gfc_class_data_get (comp
);
9342 size
= fold_convert (size_type_node
,
9343 gfc_class_vtab_size_get (comp
));
9345 if (CLASS_DATA (c
)->attr
.dimension
)
9347 nelems
= gfc_conv_descriptor_size (src_data
,
9348 CLASS_DATA (c
)->as
->rank
);
9349 size
= fold_build2_loc (input_location
, MULT_EXPR
,
9350 size_type_node
, size
,
9351 fold_convert (size_type_node
,
9355 nelems
= build_int_cst (size_type_node
, 1);
9357 if (CLASS_DATA (c
)->attr
.dimension
9358 || CLASS_DATA (c
)->attr
.codimension
)
9360 src_data
= gfc_conv_descriptor_data_get (src_data
);
9361 dst_data
= gfc_conv_descriptor_data_get (dst_data
);
9364 gfc_init_block (&tmpblock
);
9366 gfc_add_modify (&tmpblock
, gfc_class_vptr_get (dcmp
),
9367 gfc_class_vptr_get (comp
));
9369 /* Copy the unlimited '_len' field. If it is greater than zero
9370 (ie. a character(_len)), multiply it by size and use this
9371 for the malloc call. */
9372 if (UNLIMITED_POLY (c
))
9374 gfc_add_modify (&tmpblock
, gfc_class_len_get (dcmp
),
9375 gfc_class_len_get (comp
));
9376 size
= gfc_resize_class_size_with_len (&tmpblock
, comp
, size
);
9379 /* Coarray component have to have the same allocation status and
9380 shape/type-parameter/effective-type on the LHS and RHS of an
9381 intrinsic assignment. Hence, we did not deallocated them - and
9382 do not allocate them here. */
9383 if (!CLASS_DATA (c
)->attr
.codimension
)
9385 ftn_tree
= builtin_decl_explicit (BUILT_IN_MALLOC
);
9386 tmp
= build_call_expr_loc (input_location
, ftn_tree
, 1, size
);
9387 gfc_add_modify (&tmpblock
, dst_data
,
9388 fold_convert (TREE_TYPE (dst_data
), tmp
));
9391 tmp
= gfc_copy_class_to_class (comp
, dcmp
, nelems
,
9392 UNLIMITED_POLY (c
));
9393 gfc_add_expr_to_block (&tmpblock
, tmp
);
9394 tmp
= gfc_finish_block (&tmpblock
);
9396 gfc_init_block (&tmpblock
);
9397 gfc_add_modify (&tmpblock
, dst_data
,
9398 fold_convert (TREE_TYPE (dst_data
),
9399 null_pointer_node
));
9400 null_data
= gfc_finish_block (&tmpblock
);
9402 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
9403 logical_type_node
, src_data
,
9406 gfc_add_expr_to_block (&fnblock
, build3_v (COND_EXPR
, null_cond
,
9411 /* To implement guarded deep copy, i.e., deep copy only allocatable
9412 components that are really allocated, the deep copy code has to
9413 be generated first and then added to the if-block in
9414 gfc_duplicate_allocatable (). */
9415 if (cmp_has_alloc_comps
&& !c
->attr
.proc_pointer
&& !same_type
)
9417 rank
= c
->as
? c
->as
->rank
: 0;
9418 tmp
= fold_convert (TREE_TYPE (dcmp
), comp
);
9419 gfc_add_modify (&fnblock
, dcmp
, tmp
);
9420 add_when_allocated
= structure_alloc_comps (c
->ts
.u
.derived
,
9426 add_when_allocated
= NULL_TREE
;
9428 if (gfc_deferred_strlen (c
, &tmp
))
9432 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
9434 decl
, len
, NULL_TREE
);
9435 len
= fold_build3_loc (input_location
, COMPONENT_REF
,
9437 dest
, len
, NULL_TREE
);
9438 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
9439 TREE_TYPE (len
), len
, tmp
);
9440 gfc_add_expr_to_block (&fnblock
, tmp
);
9441 size
= size_of_string_in_bytes (c
->ts
.kind
, len
);
9442 /* This component cannot have allocatable components,
9443 therefore add_when_allocated of duplicate_allocatable ()
9445 tmp
= duplicate_allocatable (dcmp
, comp
, ctype
, rank
,
9446 false, false, size
, NULL_TREE
);
9447 gfc_add_expr_to_block (&fnblock
, tmp
);
9449 else if (c
->attr
.pdt_array
)
9451 tmp
= duplicate_allocatable (dcmp
, comp
, ctype
,
9452 c
->as
? c
->as
->rank
: 0,
9453 false, false, NULL_TREE
, NULL_TREE
);
9454 gfc_add_expr_to_block (&fnblock
, tmp
);
9456 else if ((c
->attr
.allocatable
)
9457 && !c
->attr
.proc_pointer
&& !same_type
9458 && (!(cmp_has_alloc_comps
&& c
->as
) || c
->attr
.codimension
9459 || caf_in_coarray (caf_mode
)))
9461 rank
= c
->as
? c
->as
->rank
: 0;
9462 if (c
->attr
.codimension
)
9463 tmp
= gfc_copy_allocatable_data (dcmp
, comp
, ctype
, rank
);
9464 else if (flag_coarray
== GFC_FCOARRAY_LIB
9465 && caf_in_coarray (caf_mode
))
9469 dst_tok
= gfc_conv_descriptor_token (dcmp
);
9472 /* For a scalar allocatable component the caf_token is
9473 the next component. */
9475 c
->caf_token
= c
->next
->backend_decl
;
9476 dst_tok
= fold_build3_loc (input_location
,
9478 pvoid_type_node
, dest
,
9482 tmp
= duplicate_allocatable_coarray (dcmp
, dst_tok
, comp
,
9486 tmp
= gfc_duplicate_allocatable (dcmp
, comp
, ctype
, rank
,
9487 add_when_allocated
);
9488 gfc_add_expr_to_block (&fnblock
, tmp
);
9491 if (cmp_has_alloc_comps
|| is_pdt_type
)
9492 gfc_add_expr_to_block (&fnblock
, add_when_allocated
);
9496 case ALLOCATE_PDT_COMP
:
9498 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9499 decl
, cdecl, NULL_TREE
);
9501 /* Set the PDT KIND and LEN fields. */
9502 if (c
->attr
.pdt_kind
|| c
->attr
.pdt_len
)
9505 gfc_expr
*c_expr
= NULL
;
9506 gfc_actual_arglist
*param
= pdt_param_list
;
9507 gfc_init_se (&tse
, NULL
);
9508 for (; param
; param
= param
->next
)
9509 if (param
->name
&& !strcmp (c
->name
, param
->name
))
9510 c_expr
= param
->expr
;
9513 c_expr
= c
->initializer
;
9517 gfc_conv_expr_type (&tse
, c_expr
, TREE_TYPE (comp
));
9518 gfc_add_modify (&fnblock
, comp
, tse
.expr
);
9522 if (c
->attr
.pdt_string
)
9525 gfc_init_se (&tse
, NULL
);
9526 tree strlen
= NULL_TREE
;
9527 gfc_expr
*e
= gfc_copy_expr (c
->ts
.u
.cl
->length
);
9528 /* Convert the parameterized string length to its value. The
9529 string length is stored in a hidden field in the same way as
9530 deferred string lengths. */
9531 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9532 if (gfc_deferred_strlen (c
, &strlen
) && strlen
!= NULL_TREE
)
9534 gfc_conv_expr_type (&tse
, e
,
9535 TREE_TYPE (strlen
));
9536 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
9538 decl
, strlen
, NULL_TREE
);
9539 gfc_add_modify (&fnblock
, strlen
, tse
.expr
);
9540 c
->ts
.u
.cl
->backend_decl
= strlen
;
9544 /* Scalar parameterized strings can be allocated now. */
9547 tmp
= fold_convert (gfc_array_index_type
, strlen
);
9548 tmp
= size_of_string_in_bytes (c
->ts
.kind
, tmp
);
9549 tmp
= gfc_evaluate_now (tmp
, &fnblock
);
9550 tmp
= gfc_call_malloc (&fnblock
, TREE_TYPE (comp
), tmp
);
9551 gfc_add_modify (&fnblock
, comp
, tmp
);
9555 /* Allocate parameterized arrays of parameterized derived types. */
9556 if (!(c
->attr
.pdt_array
&& c
->as
&& c
->as
->type
== AS_EXPLICIT
)
9557 && !((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9558 && (c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
)))
9561 if (c
->ts
.type
== BT_CLASS
)
9562 comp
= gfc_class_data_get (comp
);
9564 if (c
->attr
.pdt_array
)
9568 tree size
= gfc_index_one_node
;
9569 tree offset
= gfc_index_zero_node
;
9573 /* This chunk takes the expressions for 'lower' and 'upper'
9574 in the arrayspec and substitutes in the expressions for
9575 the parameters from 'pdt_param_list'. The descriptor
9576 fields can then be filled from the values so obtained. */
9577 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp
)));
9578 for (i
= 0; i
< c
->as
->rank
; i
++)
9580 gfc_init_se (&tse
, NULL
);
9581 e
= gfc_copy_expr (c
->as
->lower
[i
]);
9582 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9583 gfc_conv_expr_type (&tse
, e
, gfc_array_index_type
);
9586 gfc_conv_descriptor_lbound_set (&fnblock
, comp
,
9589 e
= gfc_copy_expr (c
->as
->upper
[i
]);
9590 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9591 gfc_conv_expr_type (&tse
, e
, gfc_array_index_type
);
9594 gfc_conv_descriptor_ubound_set (&fnblock
, comp
,
9597 gfc_conv_descriptor_stride_set (&fnblock
, comp
,
9600 size
= gfc_evaluate_now (size
, &fnblock
);
9601 offset
= fold_build2_loc (input_location
,
9603 gfc_array_index_type
,
9605 offset
= gfc_evaluate_now (offset
, &fnblock
);
9606 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9607 gfc_array_index_type
,
9609 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9610 gfc_array_index_type
,
9611 tmp
, gfc_index_one_node
);
9612 size
= fold_build2_loc (input_location
, MULT_EXPR
,
9613 gfc_array_index_type
, size
, tmp
);
9615 gfc_conv_descriptor_offset_set (&fnblock
, comp
, offset
);
9616 if (c
->ts
.type
== BT_CLASS
)
9618 tmp
= gfc_get_vptr_from_expr (comp
);
9619 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
9620 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
9621 tmp
= gfc_vptr_size_get (tmp
);
9624 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (ctype
));
9625 tmp
= fold_convert (gfc_array_index_type
, tmp
);
9626 size
= fold_build2_loc (input_location
, MULT_EXPR
,
9627 gfc_array_index_type
, size
, tmp
);
9628 size
= gfc_evaluate_now (size
, &fnblock
);
9629 tmp
= gfc_call_malloc (&fnblock
, NULL
, size
);
9630 gfc_conv_descriptor_data_set (&fnblock
, comp
, tmp
);
9631 tmp
= gfc_conv_descriptor_dtype (comp
);
9632 gfc_add_modify (&fnblock
, tmp
, gfc_get_dtype (ctype
));
9634 if (c
->initializer
&& c
->initializer
->rank
)
9636 gfc_init_se (&tse
, NULL
);
9637 e
= gfc_copy_expr (c
->initializer
);
9638 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9639 gfc_conv_expr_descriptor (&tse
, e
);
9640 gfc_add_block_to_block (&fnblock
, &tse
.pre
);
9642 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
9643 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
9644 gfc_conv_descriptor_data_get (comp
),
9645 gfc_conv_descriptor_data_get (tse
.expr
),
9646 fold_convert (size_type_node
, size
));
9647 gfc_add_expr_to_block (&fnblock
, tmp
);
9648 gfc_add_block_to_block (&fnblock
, &tse
.post
);
9652 /* Recurse in to PDT components. */
9653 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9654 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
9655 && !(c
->attr
.pointer
|| c
->attr
.allocatable
))
9657 bool is_deferred
= false;
9658 gfc_actual_arglist
*tail
= c
->param_list
;
9660 for (; tail
; tail
= tail
->next
)
9664 tail
= is_deferred
? pdt_param_list
: c
->param_list
;
9665 tmp
= gfc_allocate_pdt_comp (c
->ts
.u
.derived
, comp
,
9666 c
->as
? c
->as
->rank
: 0,
9668 gfc_add_expr_to_block (&fnblock
, tmp
);
9673 case DEALLOCATE_PDT_COMP
:
9674 /* Deallocate array or parameterized string length components
9675 of parameterized derived types. */
9676 if (!(c
->attr
.pdt_array
&& c
->as
&& c
->as
->type
== AS_EXPLICIT
)
9677 && !c
->attr
.pdt_string
9678 && !((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9679 && (c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
)))
9682 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9683 decl
, cdecl, NULL_TREE
);
9684 if (c
->ts
.type
== BT_CLASS
)
9685 comp
= gfc_class_data_get (comp
);
9687 /* Recurse in to PDT components. */
9688 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9689 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
9690 && (!c
->attr
.pointer
&& !c
->attr
.allocatable
))
9692 tmp
= gfc_deallocate_pdt_comp (c
->ts
.u
.derived
, comp
,
9693 c
->as
? c
->as
->rank
: 0);
9694 gfc_add_expr_to_block (&fnblock
, tmp
);
9697 if (c
->attr
.pdt_array
)
9699 tmp
= gfc_conv_descriptor_data_get (comp
);
9700 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
9701 logical_type_node
, tmp
,
9702 build_int_cst (TREE_TYPE (tmp
), 0));
9703 tmp
= gfc_call_free (tmp
);
9704 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
9705 build_empty_stmt (input_location
));
9706 gfc_add_expr_to_block (&fnblock
, tmp
);
9707 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
9709 else if (c
->attr
.pdt_string
)
9711 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
9712 logical_type_node
, comp
,
9713 build_int_cst (TREE_TYPE (comp
), 0));
9714 tmp
= gfc_call_free (comp
);
9715 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
9716 build_empty_stmt (input_location
));
9717 gfc_add_expr_to_block (&fnblock
, tmp
);
9718 tmp
= fold_convert (TREE_TYPE (comp
), null_pointer_node
);
9719 gfc_add_modify (&fnblock
, comp
, tmp
);
9724 case CHECK_PDT_DUMMY
:
9726 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9727 decl
, cdecl, NULL_TREE
);
9728 if (c
->ts
.type
== BT_CLASS
)
9729 comp
= gfc_class_data_get (comp
);
9731 /* Recurse in to PDT components. */
9732 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9733 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
)
9735 tmp
= gfc_check_pdt_dummy (c
->ts
.u
.derived
, comp
,
9736 c
->as
? c
->as
->rank
: 0,
9738 gfc_add_expr_to_block (&fnblock
, tmp
);
9741 if (!c
->attr
.pdt_len
)
9746 gfc_expr
*c_expr
= NULL
;
9747 gfc_actual_arglist
*param
= pdt_param_list
;
9749 gfc_init_se (&tse
, NULL
);
9750 for (; param
; param
= param
->next
)
9751 if (!strcmp (c
->name
, param
->name
)
9752 && param
->spec_type
== SPEC_EXPLICIT
)
9753 c_expr
= param
->expr
;
9757 tree error
, cond
, cname
;
9758 gfc_conv_expr_type (&tse
, c_expr
, TREE_TYPE (comp
));
9759 cond
= fold_build2_loc (input_location
, NE_EXPR
,
9762 cname
= gfc_build_cstring_const (c
->name
);
9763 cname
= gfc_build_addr_expr (pchar_type_node
, cname
);
9764 error
= gfc_trans_runtime_error (true, NULL
,
9765 "The value of the PDT LEN "
9766 "parameter '%s' does not "
9767 "agree with that in the "
9768 "dummy declaration",
9770 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
9771 void_type_node
, cond
, error
,
9772 build_empty_stmt (input_location
));
9773 gfc_add_expr_to_block (&fnblock
, tmp
);
9784 return gfc_finish_block (&fnblock
);
9787 /* Recursively traverse an object of derived type, generating code to
9788 nullify allocatable components. */
9791 gfc_nullify_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
9794 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9796 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
| caf_mode
, NULL
);
9800 /* Recursively traverse an object of derived type, generating code to
9801 deallocate allocatable components. */
9804 gfc_deallocate_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
9807 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9808 DEALLOCATE_ALLOC_COMP
,
9809 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
| caf_mode
, NULL
);
9813 gfc_bcast_alloc_comp (gfc_symbol
*derived
, gfc_expr
*expr
, int rank
,
9814 tree image_index
, tree stat
, tree errmsg
,
9819 stmtblock_t block
, post_block
;
9820 gfc_co_subroutines_args args
;
9822 args
.image_index
= image_index
;
9824 args
.errmsg
= errmsg
;
9825 args
.errmsg_len
= errmsg_len
;
9829 gfc_start_block (&block
);
9830 gfc_init_block (&post_block
);
9831 gfc_init_se (&argse
, NULL
);
9832 gfc_conv_expr (&argse
, expr
);
9833 gfc_add_block_to_block (&block
, &argse
.pre
);
9834 gfc_add_block_to_block (&post_block
, &argse
.post
);
9839 gfc_init_se (&argse
, NULL
);
9840 argse
.want_pointer
= 1;
9841 gfc_conv_expr_descriptor (&argse
, expr
);
9845 tmp
= structure_alloc_comps (derived
, array
, NULL_TREE
, rank
,
9847 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
, &args
);
9851 /* Recursively traverse an object of derived type, generating code to
9852 deallocate allocatable components. But do not deallocate coarrays.
9853 To be used for intrinsic assignment, which may not change the allocation
9854 status of coarrays. */
9857 gfc_deallocate_alloc_comp_no_caf (gfc_symbol
* der_type
, tree decl
, int rank
)
9859 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9860 DEALLOCATE_ALLOC_COMP
, 0, NULL
);
9865 gfc_reassign_alloc_comp_caf (gfc_symbol
*der_type
, tree decl
, tree dest
)
9867 return structure_alloc_comps (der_type
, decl
, dest
, 0, REASSIGN_CAF_COMP
,
9868 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
, NULL
);
9872 /* Recursively traverse an object of derived type, generating code to
9873 copy it and its allocatable components. */
9876 gfc_copy_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
,
9879 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ALLOC_COMP
,
9884 /* Recursively traverse an object of derived type, generating code to
9885 copy only its allocatable components. */
9888 gfc_copy_only_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
9890 return structure_alloc_comps (der_type
, decl
, dest
, rank
,
9891 COPY_ONLY_ALLOC_COMP
, 0, NULL
);
9895 /* Recursively traverse an object of parameterized derived type, generating
9896 code to allocate parameterized components. */
9899 gfc_allocate_pdt_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
9900 gfc_actual_arglist
*param_list
)
9903 gfc_actual_arglist
*old_param_list
= pdt_param_list
;
9904 pdt_param_list
= param_list
;
9905 res
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9906 ALLOCATE_PDT_COMP
, 0, NULL
);
9907 pdt_param_list
= old_param_list
;
9911 /* Recursively traverse an object of parameterized derived type, generating
9912 code to deallocate parameterized components. */
9915 gfc_deallocate_pdt_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
9917 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9918 DEALLOCATE_PDT_COMP
, 0, NULL
);
9922 /* Recursively traverse a dummy of parameterized derived type to check the
9923 values of LEN parameters. */
9926 gfc_check_pdt_dummy (gfc_symbol
* der_type
, tree decl
, int rank
,
9927 gfc_actual_arglist
*param_list
)
9930 gfc_actual_arglist
*old_param_list
= pdt_param_list
;
9931 pdt_param_list
= param_list
;
9932 res
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9933 CHECK_PDT_DUMMY
, 0, NULL
);
9934 pdt_param_list
= old_param_list
;
9939 /* Returns the value of LBOUND for an expression. This could be broken out
9940 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
9941 called by gfc_alloc_allocatable_for_assignment. */
9943 get_std_lbound (gfc_expr
*expr
, tree desc
, int dim
, bool assumed_size
)
9948 tree cond
, cond1
, cond3
, cond4
;
9952 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
9954 tmp
= gfc_rank_cst
[dim
];
9955 lbound
= gfc_conv_descriptor_lbound_get (desc
, tmp
);
9956 ubound
= gfc_conv_descriptor_ubound_get (desc
, tmp
);
9957 stride
= gfc_conv_descriptor_stride_get (desc
, tmp
);
9958 cond1
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
9960 cond3
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
9961 stride
, gfc_index_zero_node
);
9962 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
9963 logical_type_node
, cond3
, cond1
);
9964 cond4
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
9965 stride
, gfc_index_zero_node
);
9967 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
9968 tmp
, build_int_cst (gfc_array_index_type
,
9971 cond
= logical_false_node
;
9973 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
9974 logical_type_node
, cond3
, cond4
);
9975 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
9976 logical_type_node
, cond
, cond1
);
9978 return fold_build3_loc (input_location
, COND_EXPR
,
9979 gfc_array_index_type
, cond
,
9980 lbound
, gfc_index_one_node
);
9983 if (expr
->expr_type
== EXPR_FUNCTION
)
9985 /* A conversion function, so use the argument. */
9986 gcc_assert (expr
->value
.function
.isym
9987 && expr
->value
.function
.isym
->conversion
);
9988 expr
= expr
->value
.function
.actual
->expr
;
9991 if (expr
->expr_type
== EXPR_VARIABLE
)
9993 tmp
= TREE_TYPE (expr
->symtree
->n
.sym
->backend_decl
);
9994 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
9996 if (ref
->type
== REF_COMPONENT
9997 && ref
->u
.c
.component
->as
9999 && ref
->next
->u
.ar
.type
== AR_FULL
)
10000 tmp
= TREE_TYPE (ref
->u
.c
.component
->backend_decl
);
10002 return GFC_TYPE_ARRAY_LBOUND(tmp
, dim
);
10005 return gfc_index_one_node
;
10009 /* Returns true if an expression represents an lhs that can be reallocated
10013 gfc_is_reallocatable_lhs (gfc_expr
*expr
)
10021 sym
= expr
->symtree
->n
.sym
;
10023 if (sym
->attr
.associate_var
&& !expr
->ref
)
10026 /* An allocatable class variable with no reference. */
10027 if (sym
->ts
.type
== BT_CLASS
10028 && !sym
->attr
.associate_var
10029 && CLASS_DATA (sym
)->attr
.allocatable
10031 && ((expr
->ref
->type
== REF_ARRAY
&& expr
->ref
->u
.ar
.type
== AR_FULL
10032 && expr
->ref
->next
== NULL
)
10033 || (expr
->ref
->type
== REF_COMPONENT
10034 && strcmp (expr
->ref
->u
.c
.component
->name
, "_data") == 0
10035 && (expr
->ref
->next
== NULL
10036 || (expr
->ref
->next
->type
== REF_ARRAY
10037 && expr
->ref
->next
->u
.ar
.type
== AR_FULL
10038 && expr
->ref
->next
->next
== NULL
)))))
10041 /* An allocatable variable. */
10042 if (sym
->attr
.allocatable
10043 && !sym
->attr
.associate_var
10045 && expr
->ref
->type
== REF_ARRAY
10046 && expr
->ref
->u
.ar
.type
== AR_FULL
)
10049 /* All that can be left are allocatable components. */
10050 if ((sym
->ts
.type
!= BT_DERIVED
10051 && sym
->ts
.type
!= BT_CLASS
)
10052 || !sym
->ts
.u
.derived
->attr
.alloc_comp
)
10055 /* Find a component ref followed by an array reference. */
10056 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
10058 && ref
->type
== REF_COMPONENT
10059 && ref
->next
->type
== REF_ARRAY
10060 && !ref
->next
->next
)
10066 /* Return true if valid reallocatable lhs. */
10067 if (ref
->u
.c
.component
->attr
.allocatable
10068 && ref
->next
->u
.ar
.type
== AR_FULL
)
10076 concat_str_length (gfc_expr
* expr
)
10083 type
= gfc_typenode_for_spec (&expr
->value
.op
.op1
->ts
);
10084 len1
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
10085 if (len1
== NULL_TREE
)
10087 if (expr
->value
.op
.op1
->expr_type
== EXPR_OP
)
10088 len1
= concat_str_length (expr
->value
.op
.op1
);
10089 else if (expr
->value
.op
.op1
->expr_type
== EXPR_CONSTANT
)
10090 len1
= build_int_cst (gfc_charlen_type_node
,
10091 expr
->value
.op
.op1
->value
.character
.length
);
10092 else if (expr
->value
.op
.op1
->ts
.u
.cl
->length
)
10094 gfc_init_se (&se
, NULL
);
10095 gfc_conv_expr (&se
, expr
->value
.op
.op1
->ts
.u
.cl
->length
);
10101 gfc_init_se (&se
, NULL
);
10102 se
.want_pointer
= 1;
10103 se
.descriptor_only
= 1;
10104 gfc_conv_expr (&se
, expr
->value
.op
.op1
);
10105 len1
= se
.string_length
;
10109 type
= gfc_typenode_for_spec (&expr
->value
.op
.op2
->ts
);
10110 len2
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
10111 if (len2
== NULL_TREE
)
10113 if (expr
->value
.op
.op2
->expr_type
== EXPR_OP
)
10114 len2
= concat_str_length (expr
->value
.op
.op2
);
10115 else if (expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
10116 len2
= build_int_cst (gfc_charlen_type_node
,
10117 expr
->value
.op
.op2
->value
.character
.length
);
10118 else if (expr
->value
.op
.op2
->ts
.u
.cl
->length
)
10120 gfc_init_se (&se
, NULL
);
10121 gfc_conv_expr (&se
, expr
->value
.op
.op2
->ts
.u
.cl
->length
);
10127 gfc_init_se (&se
, NULL
);
10128 se
.want_pointer
= 1;
10129 se
.descriptor_only
= 1;
10130 gfc_conv_expr (&se
, expr
->value
.op
.op2
);
10131 len2
= se
.string_length
;
10135 gcc_assert(len1
&& len2
);
10136 len1
= fold_convert (gfc_charlen_type_node
, len1
);
10137 len2
= fold_convert (gfc_charlen_type_node
, len2
);
10139 return fold_build2_loc (input_location
, PLUS_EXPR
,
10140 gfc_charlen_type_node
, len1
, len2
);
10144 /* Allocate the lhs of an assignment to an allocatable array, otherwise
10148 gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop
,
10152 stmtblock_t realloc_block
;
10153 stmtblock_t alloc_block
;
10154 stmtblock_t fblock
;
10157 gfc_array_info
*linfo
;
10179 tree class_expr2
= NULL_TREE
;
10182 gfc_array_spec
* as
;
10183 bool coarray
= (flag_coarray
== GFC_FCOARRAY_LIB
10184 && gfc_caf_attr (expr1
, true).codimension
);
10188 /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
10189 Find the lhs expression in the loop chain and set expr1 and
10190 expr2 accordingly. */
10191 if (expr1
->expr_type
== EXPR_FUNCTION
&& expr2
== NULL
)
10194 /* Find the ss for the lhs. */
10196 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
10197 if (lss
->info
->expr
&& lss
->info
->expr
->expr_type
== EXPR_VARIABLE
)
10199 if (lss
== gfc_ss_terminator
)
10201 expr1
= lss
->info
->expr
;
10204 /* Bail out if this is not a valid allocate on assignment. */
10205 if (!gfc_is_reallocatable_lhs (expr1
)
10206 || (expr2
&& !expr2
->rank
))
10209 /* Find the ss for the lhs. */
10211 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
10212 if (lss
->info
->expr
== expr1
)
10215 if (lss
== gfc_ss_terminator
)
10218 linfo
= &lss
->info
->data
.array
;
10220 /* Find an ss for the rhs. For operator expressions, we see the
10221 ss's for the operands. Any one of these will do. */
10223 for (; rss
&& rss
!= gfc_ss_terminator
; rss
= rss
->loop_chain
)
10224 if (rss
->info
->expr
!= expr1
&& rss
!= loop
->temp_ss
)
10227 if (expr2
&& rss
== gfc_ss_terminator
)
10230 /* Ensure that the string length from the current scope is used. */
10231 if (expr2
->ts
.type
== BT_CHARACTER
10232 && expr2
->expr_type
== EXPR_FUNCTION
10233 && !expr2
->value
.function
.isym
)
10234 expr2
->ts
.u
.cl
->backend_decl
= rss
->info
->string_length
;
10236 gfc_start_block (&fblock
);
10238 /* Since the lhs is allocatable, this must be a descriptor type.
10239 Get the data and array size. */
10240 desc
= linfo
->descriptor
;
10241 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)));
10242 array1
= gfc_conv_descriptor_data_get (desc
);
10245 desc2
= rss
->info
->data
.array
.descriptor
;
10249 /* Get the old lhs element size for deferred character and class expr1. */
10250 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10252 if (expr1
->ts
.u
.cl
->backend_decl
10253 && VAR_P (expr1
->ts
.u
.cl
->backend_decl
))
10254 elemsize1
= expr1
->ts
.u
.cl
->backend_decl
;
10256 elemsize1
= lss
->info
->string_length
;
10258 else if (expr1
->ts
.type
== BT_CLASS
)
10260 tmp
= expr1
->rank
? gfc_get_class_from_expr (desc
) : NULL_TREE
;
10261 if (tmp
== NULL_TREE
)
10262 tmp
= gfc_get_class_from_gfc_expr (expr1
);
10264 if (tmp
!= NULL_TREE
)
10266 tmp2
= gfc_class_vptr_get (tmp
);
10267 cond
= fold_build2_loc (input_location
, NE_EXPR
,
10268 logical_type_node
, tmp2
,
10269 build_int_cst (TREE_TYPE (tmp2
), 0));
10270 elemsize1
= gfc_class_vtab_size_get (tmp
);
10271 elemsize1
= fold_build3_loc (input_location
, COND_EXPR
,
10272 gfc_array_index_type
, cond
,
10273 elemsize1
, gfc_index_zero_node
);
10276 elemsize1
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&CLASS_DATA (expr1
)->ts
));
10279 elemsize1
= NULL_TREE
;
10280 if (elemsize1
!= NULL_TREE
)
10281 elemsize1
= gfc_evaluate_now (elemsize1
, &fblock
);
10283 /* Get the new lhs size in bytes. */
10284 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10286 if (expr2
->ts
.deferred
)
10288 if (expr2
->ts
.u
.cl
->backend_decl
10289 && VAR_P (expr2
->ts
.u
.cl
->backend_decl
))
10290 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
10292 tmp
= rss
->info
->string_length
;
10296 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
10297 if (!tmp
&& expr2
->expr_type
== EXPR_OP
10298 && expr2
->value
.op
.op
== INTRINSIC_CONCAT
)
10300 tmp
= concat_str_length (expr2
);
10301 expr2
->ts
.u
.cl
->backend_decl
= gfc_evaluate_now (tmp
, &fblock
);
10303 else if (!tmp
&& expr2
->ts
.u
.cl
->length
)
10306 gfc_init_se (&tmpse
, NULL
);
10307 gfc_conv_expr_type (&tmpse
, expr2
->ts
.u
.cl
->length
,
10308 gfc_charlen_type_node
);
10310 expr2
->ts
.u
.cl
->backend_decl
= gfc_evaluate_now (tmp
, &fblock
);
10312 tmp
= fold_convert (TREE_TYPE (expr1
->ts
.u
.cl
->backend_decl
), tmp
);
10315 if (expr1
->ts
.u
.cl
->backend_decl
10316 && VAR_P (expr1
->ts
.u
.cl
->backend_decl
))
10317 gfc_add_modify (&fblock
, expr1
->ts
.u
.cl
->backend_decl
, tmp
);
10319 gfc_add_modify (&fblock
, lss
->info
->string_length
, tmp
);
10321 if (expr1
->ts
.kind
> 1)
10322 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
10324 tmp
, build_int_cst (TREE_TYPE (tmp
),
10327 else if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.u
.cl
->backend_decl
)
10329 tmp
= TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
)));
10330 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
10331 gfc_array_index_type
, tmp
,
10332 expr1
->ts
.u
.cl
->backend_decl
);
10334 else if (UNLIMITED_POLY (expr1
) && expr2
->ts
.type
!= BT_CLASS
)
10335 tmp
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2
->ts
));
10336 else if (expr1
->ts
.type
== BT_CLASS
&& expr2
->ts
.type
== BT_CLASS
)
10338 tmp
= expr2
->rank
? gfc_get_class_from_expr (desc2
) : NULL_TREE
;
10339 if (tmp
== NULL_TREE
&& expr2
->expr_type
== EXPR_VARIABLE
)
10340 tmp
= class_expr2
= gfc_get_class_from_gfc_expr (expr2
);
10342 if (tmp
!= NULL_TREE
)
10343 tmp
= gfc_class_vtab_size_get (tmp
);
10345 tmp
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&CLASS_DATA (expr2
)->ts
));
10348 tmp
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2
->ts
));
10349 elemsize2
= fold_convert (gfc_array_index_type
, tmp
);
10350 elemsize2
= gfc_evaluate_now (elemsize2
, &fblock
);
10352 /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
10353 deallocated if expr is an array of different shape or any of the
10354 corresponding length type parameter values of variable and expr
10355 differ." This assures F95 compatibility. */
10356 jump_label1
= gfc_build_label_decl (NULL_TREE
);
10357 jump_label2
= gfc_build_label_decl (NULL_TREE
);
10359 /* Allocate if data is NULL. */
10360 cond_null
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
10361 array1
, build_int_cst (TREE_TYPE (array1
), 0));
10363 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10365 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
10367 lss
->info
->string_length
,
10368 rss
->info
->string_length
);
10369 cond_null
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
10370 logical_type_node
, tmp
, cond_null
);
10371 cond_null
= gfc_evaluate_now (cond_null
, &fblock
);
10374 cond_null
= gfc_evaluate_now (cond_null
, &fblock
);
10376 tmp
= build3_v (COND_EXPR
, cond_null
,
10377 build1_v (GOTO_EXPR
, jump_label1
),
10378 build_empty_stmt (input_location
));
10379 gfc_add_expr_to_block (&fblock
, tmp
);
10381 /* Get arrayspec if expr is a full array. */
10382 if (expr2
&& expr2
->expr_type
== EXPR_FUNCTION
10383 && expr2
->value
.function
.isym
10384 && expr2
->value
.function
.isym
->conversion
)
10386 /* For conversion functions, take the arg. */
10387 gfc_expr
*arg
= expr2
->value
.function
.actual
->expr
;
10388 as
= gfc_get_full_arrayspec_from_expr (arg
);
10391 as
= gfc_get_full_arrayspec_from_expr (expr2
);
10395 /* If the lhs shape is not the same as the rhs jump to setting the
10396 bounds and doing the reallocation....... */
10397 for (n
= 0; n
< expr1
->rank
; n
++)
10399 /* Check the shape. */
10400 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
10401 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
10402 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10403 gfc_array_index_type
,
10404 loop
->to
[n
], loop
->from
[n
]);
10405 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
10406 gfc_array_index_type
,
10408 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10409 gfc_array_index_type
,
10411 cond
= fold_build2_loc (input_location
, NE_EXPR
,
10413 tmp
, gfc_index_zero_node
);
10414 tmp
= build3_v (COND_EXPR
, cond
,
10415 build1_v (GOTO_EXPR
, jump_label1
),
10416 build_empty_stmt (input_location
));
10417 gfc_add_expr_to_block (&fblock
, tmp
);
10420 /* ...else if the element lengths are not the same also go to
10421 setting the bounds and doing the reallocation.... */
10422 if (elemsize1
!= NULL_TREE
)
10424 cond
= fold_build2_loc (input_location
, NE_EXPR
,
10426 elemsize1
, elemsize2
);
10427 tmp
= build3_v (COND_EXPR
, cond
,
10428 build1_v (GOTO_EXPR
, jump_label1
),
10429 build_empty_stmt (input_location
));
10430 gfc_add_expr_to_block (&fblock
, tmp
);
10433 /* ....else jump past the (re)alloc code. */
10434 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
10435 gfc_add_expr_to_block (&fblock
, tmp
);
10437 /* Add the label to start automatic (re)allocation. */
10438 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
10439 gfc_add_expr_to_block (&fblock
, tmp
);
10441 /* If the lhs has not been allocated, its bounds will not have been
10442 initialized and so its size is set to zero. */
10443 size1
= gfc_create_var (gfc_array_index_type
, NULL
);
10444 gfc_init_block (&alloc_block
);
10445 gfc_add_modify (&alloc_block
, size1
, gfc_index_zero_node
);
10446 gfc_init_block (&realloc_block
);
10447 gfc_add_modify (&realloc_block
, size1
,
10448 gfc_conv_descriptor_size (desc
, expr1
->rank
));
10449 tmp
= build3_v (COND_EXPR
, cond_null
,
10450 gfc_finish_block (&alloc_block
),
10451 gfc_finish_block (&realloc_block
));
10452 gfc_add_expr_to_block (&fblock
, tmp
);
10454 /* Get the rhs size and fix it. */
10455 size2
= gfc_index_one_node
;
10456 for (n
= 0; n
< expr2
->rank
; n
++)
10458 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10459 gfc_array_index_type
,
10460 loop
->to
[n
], loop
->from
[n
]);
10461 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
10462 gfc_array_index_type
,
10463 tmp
, gfc_index_one_node
);
10464 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
10465 gfc_array_index_type
,
10468 size2
= gfc_evaluate_now (size2
, &fblock
);
10470 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
10473 /* If the lhs is deferred length, assume that the element size
10474 changes and force a reallocation. */
10475 if (expr1
->ts
.deferred
)
10476 neq_size
= gfc_evaluate_now (logical_true_node
, &fblock
);
10478 neq_size
= gfc_evaluate_now (cond
, &fblock
);
10480 /* Deallocation of allocatable components will have to occur on
10481 reallocation. Fix the old descriptor now. */
10482 if ((expr1
->ts
.type
== BT_DERIVED
)
10483 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10484 old_desc
= gfc_evaluate_now (desc
, &fblock
);
10486 old_desc
= NULL_TREE
;
10488 /* Now modify the lhs descriptor and the associated scalarizer
10489 variables. F2003 7.4.1.3: "If variable is or becomes an
10490 unallocated allocatable variable, then it is allocated with each
10491 deferred type parameter equal to the corresponding type parameters
10492 of expr , with the shape of expr , and with each lower bound equal
10493 to the corresponding element of LBOUND(expr)."
10494 Reuse size1 to keep a dimension-by-dimension track of the
10495 stride of the new array. */
10496 size1
= gfc_index_one_node
;
10497 offset
= gfc_index_zero_node
;
10499 for (n
= 0; n
< expr2
->rank
; n
++)
10501 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10502 gfc_array_index_type
,
10503 loop
->to
[n
], loop
->from
[n
]);
10504 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
10505 gfc_array_index_type
,
10506 tmp
, gfc_index_one_node
);
10508 lbound
= gfc_index_one_node
;
10513 lbd
= get_std_lbound (expr2
, desc2
, n
,
10514 as
->type
== AS_ASSUMED_SIZE
);
10515 ubound
= fold_build2_loc (input_location
,
10517 gfc_array_index_type
,
10519 ubound
= fold_build2_loc (input_location
,
10521 gfc_array_index_type
,
10526 gfc_conv_descriptor_lbound_set (&fblock
, desc
,
10529 gfc_conv_descriptor_ubound_set (&fblock
, desc
,
10532 gfc_conv_descriptor_stride_set (&fblock
, desc
,
10535 lbound
= gfc_conv_descriptor_lbound_get (desc
,
10537 tmp2
= fold_build2_loc (input_location
, MULT_EXPR
,
10538 gfc_array_index_type
,
10540 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
10541 gfc_array_index_type
,
10543 size1
= fold_build2_loc (input_location
, MULT_EXPR
,
10544 gfc_array_index_type
,
10548 /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
10549 the array offset is saved and the info.offset is used for a
10550 running offset. Use the saved_offset instead. */
10551 tmp
= gfc_conv_descriptor_offset (desc
);
10552 gfc_add_modify (&fblock
, tmp
, offset
);
10553 if (linfo
->saved_offset
10554 && VAR_P (linfo
->saved_offset
))
10555 gfc_add_modify (&fblock
, linfo
->saved_offset
, tmp
);
10557 /* Now set the deltas for the lhs. */
10558 for (n
= 0; n
< expr1
->rank
; n
++)
10560 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
10562 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10563 gfc_array_index_type
, tmp
,
10565 if (linfo
->delta
[dim
] && VAR_P (linfo
->delta
[dim
]))
10566 gfc_add_modify (&fblock
, linfo
->delta
[dim
], tmp
);
10569 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
10570 gfc_conv_descriptor_span_set (&fblock
, desc
, elemsize2
);
10572 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
10573 gfc_array_index_type
,
10575 size2
= fold_convert (size_type_node
, size2
);
10576 size2
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
10577 size2
, size_one_node
);
10578 size2
= gfc_evaluate_now (size2
, &fblock
);
10580 /* For deferred character length, the 'size' field of the dtype might
10581 have changed so set the dtype. */
10582 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
10583 && expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10586 tmp
= gfc_conv_descriptor_dtype (desc
);
10587 if (expr2
->ts
.u
.cl
->backend_decl
)
10588 type
= gfc_typenode_for_spec (&expr2
->ts
);
10590 type
= gfc_typenode_for_spec (&expr1
->ts
);
10592 gfc_add_modify (&fblock
, tmp
,
10593 gfc_get_dtype_rank_type (expr1
->rank
,type
));
10595 else if (expr1
->ts
.type
== BT_CLASS
)
10598 tmp
= gfc_conv_descriptor_dtype (desc
);
10600 if (expr2
->ts
.type
!= BT_CLASS
)
10601 type
= gfc_typenode_for_spec (&expr2
->ts
);
10603 type
= gfc_get_character_type_len (1, elemsize2
);
10605 gfc_add_modify (&fblock
, tmp
,
10606 gfc_get_dtype_rank_type (expr2
->rank
,type
));
10607 /* Set the _len field as well... */
10608 if (UNLIMITED_POLY (expr1
))
10610 tmp
= gfc_class_len_get (TREE_OPERAND (desc
, 0));
10611 if (expr2
->ts
.type
== BT_CHARACTER
)
10612 gfc_add_modify (&fblock
, tmp
,
10613 fold_convert (TREE_TYPE (tmp
),
10614 TYPE_SIZE_UNIT (type
)));
10616 gfc_add_modify (&fblock
, tmp
,
10617 build_int_cst (TREE_TYPE (tmp
), 0));
10619 /* ...and the vptr. */
10620 tmp
= gfc_class_vptr_get (TREE_OPERAND (desc
, 0));
10621 if (expr2
->ts
.type
== BT_CLASS
&& !VAR_P (desc2
)
10622 && TREE_CODE (desc2
) == COMPONENT_REF
)
10624 tmp2
= gfc_get_class_from_expr (desc2
);
10625 tmp2
= gfc_class_vptr_get (tmp2
);
10627 else if (expr2
->ts
.type
== BT_CLASS
&& class_expr2
!= NULL_TREE
)
10628 tmp2
= gfc_class_vptr_get (class_expr2
);
10631 tmp2
= gfc_get_symbol_decl (gfc_find_vtab (&expr2
->ts
));
10632 tmp2
= gfc_build_addr_expr (TREE_TYPE (tmp
), tmp2
);
10635 gfc_add_modify (&fblock
, tmp
, fold_convert (TREE_TYPE (tmp
), tmp2
));
10637 else if (coarray
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
10639 gfc_add_modify (&fblock
, gfc_conv_descriptor_dtype (desc
),
10640 gfc_get_dtype (TREE_TYPE (desc
)));
10643 /* Realloc expression. Note that the scalarizer uses desc.data
10644 in the array reference - (*desc.data)[<element>]. */
10645 gfc_init_block (&realloc_block
);
10646 gfc_init_se (&caf_se
, NULL
);
10650 token
= gfc_get_ultimate_alloc_ptr_comps_caf_token (&caf_se
, expr1
);
10651 if (token
== NULL_TREE
)
10653 tmp
= gfc_get_tree_for_caf_expr (expr1
);
10654 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
10655 tmp
= build_fold_indirect_ref (tmp
);
10656 gfc_get_caf_token_offset (&caf_se
, &token
, NULL
, tmp
, NULL_TREE
,
10658 token
= gfc_build_addr_expr (NULL_TREE
, token
);
10661 gfc_add_block_to_block (&realloc_block
, &caf_se
.pre
);
10663 if ((expr1
->ts
.type
== BT_DERIVED
)
10664 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10666 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, old_desc
,
10668 gfc_add_expr_to_block (&realloc_block
, tmp
);
10673 tmp
= build_call_expr_loc (input_location
,
10674 builtin_decl_explicit (BUILT_IN_REALLOC
), 2,
10675 fold_convert (pvoid_type_node
, array1
),
10677 gfc_conv_descriptor_data_set (&realloc_block
,
10682 tmp
= build_call_expr_loc (input_location
,
10683 gfor_fndecl_caf_deregister
, 5, token
,
10684 build_int_cst (integer_type_node
,
10685 GFC_CAF_COARRAY_DEALLOCATE_ONLY
),
10686 null_pointer_node
, null_pointer_node
,
10687 integer_zero_node
);
10688 gfc_add_expr_to_block (&realloc_block
, tmp
);
10689 tmp
= build_call_expr_loc (input_location
,
10690 gfor_fndecl_caf_register
,
10692 build_int_cst (integer_type_node
,
10693 GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY
),
10694 token
, gfc_build_addr_expr (NULL_TREE
, desc
),
10695 null_pointer_node
, null_pointer_node
,
10696 integer_zero_node
);
10697 gfc_add_expr_to_block (&realloc_block
, tmp
);
10700 if ((expr1
->ts
.type
== BT_DERIVED
)
10701 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10703 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, desc
,
10705 gfc_add_expr_to_block (&realloc_block
, tmp
);
10708 gfc_add_block_to_block (&realloc_block
, &caf_se
.post
);
10709 realloc_expr
= gfc_finish_block (&realloc_block
);
10711 /* Reallocate if sizes or dynamic types are different. */
10714 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
10715 elemsize1
, elemsize2
);
10716 tmp
= gfc_evaluate_now (tmp
, &fblock
);
10717 neq_size
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
10718 logical_type_node
, neq_size
, tmp
);
10720 tmp
= build3_v (COND_EXPR
, neq_size
, realloc_expr
,
10721 build_empty_stmt (input_location
));
10723 realloc_expr
= tmp
;
10725 /* Malloc expression. */
10726 gfc_init_block (&alloc_block
);
10729 tmp
= build_call_expr_loc (input_location
,
10730 builtin_decl_explicit (BUILT_IN_MALLOC
),
10732 gfc_conv_descriptor_data_set (&alloc_block
,
10737 tmp
= build_call_expr_loc (input_location
,
10738 gfor_fndecl_caf_register
,
10740 build_int_cst (integer_type_node
,
10741 GFC_CAF_COARRAY_ALLOC
),
10742 token
, gfc_build_addr_expr (NULL_TREE
, desc
),
10743 null_pointer_node
, null_pointer_node
,
10744 integer_zero_node
);
10745 gfc_add_expr_to_block (&alloc_block
, tmp
);
10749 /* We already set the dtype in the case of deferred character
10750 length arrays and unlimited polymorphic arrays. */
10751 if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
10752 && ((expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10754 && !UNLIMITED_POLY (expr1
))
10756 tmp
= gfc_conv_descriptor_dtype (desc
);
10757 gfc_add_modify (&alloc_block
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
10760 if ((expr1
->ts
.type
== BT_DERIVED
)
10761 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10763 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, desc
,
10765 gfc_add_expr_to_block (&alloc_block
, tmp
);
10767 alloc_expr
= gfc_finish_block (&alloc_block
);
10769 /* Malloc if not allocated; realloc otherwise. */
10770 tmp
= build3_v (COND_EXPR
, cond_null
, alloc_expr
, realloc_expr
);
10771 gfc_add_expr_to_block (&fblock
, tmp
);
10773 /* Make sure that the scalarizer data pointer is updated. */
10774 if (linfo
->data
&& VAR_P (linfo
->data
))
10776 tmp
= gfc_conv_descriptor_data_get (desc
);
10777 gfc_add_modify (&fblock
, linfo
->data
, tmp
);
10780 /* Add the label for same shape lhs and rhs. */
10781 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
10782 gfc_add_expr_to_block (&fblock
, tmp
);
10784 return gfc_finish_block (&fblock
);
10788 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
10789 Do likewise, recursively if necessary, with the allocatable components of
10790 derived types. This function is also called for assumed-rank arrays, which
10791 are always dummy arguments. */
10794 gfc_trans_deferred_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
10800 stmtblock_t cleanup
;
10803 bool sym_has_alloc_comp
, has_finalizer
;
10805 sym_has_alloc_comp
= (sym
->ts
.type
== BT_DERIVED
10806 || sym
->ts
.type
== BT_CLASS
)
10807 && sym
->ts
.u
.derived
->attr
.alloc_comp
;
10808 has_finalizer
= sym
->ts
.type
== BT_CLASS
|| sym
->ts
.type
== BT_DERIVED
10809 ? gfc_is_finalizable (sym
->ts
.u
.derived
, NULL
) : false;
10811 /* Make sure the frontend gets these right. */
10812 gcc_assert (sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym_has_alloc_comp
10814 || (sym
->as
->type
== AS_ASSUMED_RANK
&& sym
->attr
.dummy
));
10816 gfc_save_backend_locus (&loc
);
10817 gfc_set_backend_locus (&sym
->declared_at
);
10818 gfc_init_block (&init
);
10820 gcc_assert (VAR_P (sym
->backend_decl
)
10821 || TREE_CODE (sym
->backend_decl
) == PARM_DECL
);
10823 if (sym
->ts
.type
== BT_CHARACTER
10824 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
10826 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
10827 gfc_trans_vla_type_sizes (sym
, &init
);
10830 /* Dummy, use associated and result variables don't need anything special. */
10831 if (sym
->attr
.dummy
|| sym
->attr
.use_assoc
|| sym
->attr
.result
)
10833 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
10834 gfc_restore_backend_locus (&loc
);
10838 descriptor
= sym
->backend_decl
;
10840 /* Although static, derived types with default initializers and
10841 allocatable components must not be nulled wholesale; instead they
10842 are treated component by component. */
10843 if (TREE_STATIC (descriptor
) && !sym_has_alloc_comp
&& !has_finalizer
)
10845 /* SAVEd variables are not freed on exit. */
10846 gfc_trans_static_array_pointer (sym
);
10848 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
10849 gfc_restore_backend_locus (&loc
);
10853 /* Get the descriptor type. */
10854 type
= TREE_TYPE (sym
->backend_decl
);
10856 if ((sym_has_alloc_comp
|| (has_finalizer
&& sym
->ts
.type
!= BT_CLASS
))
10857 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
10859 if (!sym
->attr
.save
10860 && !(TREE_STATIC (sym
->backend_decl
) && sym
->attr
.is_main_program
))
10862 if (sym
->value
== NULL
10863 || !gfc_has_default_initializer (sym
->ts
.u
.derived
))
10865 rank
= sym
->as
? sym
->as
->rank
: 0;
10866 tmp
= gfc_nullify_alloc_comp (sym
->ts
.u
.derived
,
10868 gfc_add_expr_to_block (&init
, tmp
);
10871 gfc_init_default_dt (sym
, &init
, false);
10874 else if (!GFC_DESCRIPTOR_TYPE_P (type
))
10876 /* If the backend_decl is not a descriptor, we must have a pointer
10878 descriptor
= build_fold_indirect_ref_loc (input_location
,
10879 sym
->backend_decl
);
10880 type
= TREE_TYPE (descriptor
);
10883 /* NULLIFY the data pointer, for non-saved allocatables. */
10884 if (GFC_DESCRIPTOR_TYPE_P (type
) && !sym
->attr
.save
&& sym
->attr
.allocatable
)
10886 gfc_conv_descriptor_data_set (&init
, descriptor
, null_pointer_node
);
10887 if (flag_coarray
== GFC_FCOARRAY_LIB
&& sym
->attr
.codimension
)
10889 /* Declare the variable static so its array descriptor stays present
10890 after leaving the scope. It may still be accessed through another
10891 image. This may happen, for example, with the caf_mpi
10893 TREE_STATIC (descriptor
) = 1;
10894 tmp
= gfc_conv_descriptor_token (descriptor
);
10895 gfc_add_modify (&init
, tmp
, fold_convert (TREE_TYPE (tmp
),
10896 null_pointer_node
));
10900 gfc_restore_backend_locus (&loc
);
10901 gfc_init_block (&cleanup
);
10903 /* Allocatable arrays need to be freed when they go out of scope.
10904 The allocatable components of pointers must not be touched. */
10905 if (!sym
->attr
.allocatable
&& has_finalizer
&& sym
->ts
.type
!= BT_CLASS
10906 && !sym
->attr
.pointer
&& !sym
->attr
.artificial
&& !sym
->attr
.save
10907 && !sym
->ns
->proc_name
->attr
.is_main_program
)
10910 sym
->attr
.referenced
= 1;
10911 e
= gfc_lval_expr_from_sym (sym
);
10912 gfc_add_finalizer_call (&cleanup
, e
);
10915 else if ((!sym
->attr
.allocatable
|| !has_finalizer
)
10916 && sym_has_alloc_comp
&& !(sym
->attr
.function
|| sym
->attr
.result
)
10917 && !sym
->attr
.pointer
&& !sym
->attr
.save
10918 && !sym
->ns
->proc_name
->attr
.is_main_program
)
10921 rank
= sym
->as
? sym
->as
->rank
: 0;
10922 tmp
= gfc_deallocate_alloc_comp (sym
->ts
.u
.derived
, descriptor
, rank
);
10923 gfc_add_expr_to_block (&cleanup
, tmp
);
10926 if (sym
->attr
.allocatable
&& (sym
->attr
.dimension
|| sym
->attr
.codimension
)
10927 && !sym
->attr
.save
&& !sym
->attr
.result
10928 && !sym
->ns
->proc_name
->attr
.is_main_program
)
10931 e
= has_finalizer
? gfc_lval_expr_from_sym (sym
) : NULL
;
10932 tmp
= gfc_deallocate_with_status (sym
->backend_decl
, NULL_TREE
, NULL_TREE
,
10933 NULL_TREE
, NULL_TREE
, true, e
,
10934 sym
->attr
.codimension
10935 ? GFC_CAF_COARRAY_DEREGISTER
10936 : GFC_CAF_COARRAY_NOCOARRAY
);
10939 gfc_add_expr_to_block (&cleanup
, tmp
);
10942 gfc_add_init_cleanup (block
, gfc_finish_block (&init
),
10943 gfc_finish_block (&cleanup
));
10946 /************ Expression Walking Functions ******************/
10948 /* Walk a variable reference.
10950 Possible extension - multiple component subscripts.
10951 x(:,:) = foo%a(:)%b(:)
10953 forall (i=..., j=...)
10954 x(i,j) = foo%a(j)%b(i)
10956 This adds a fair amount of complexity because you need to deal with more
10957 than one ref. Maybe handle in a similar manner to vector subscripts.
10958 Maybe not worth the effort. */
10962 gfc_walk_variable_expr (gfc_ss
* ss
, gfc_expr
* expr
)
10966 gfc_fix_class_refs (expr
);
10968 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
10969 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
10972 return gfc_walk_array_ref (ss
, expr
, ref
);
10977 gfc_walk_array_ref (gfc_ss
* ss
, gfc_expr
* expr
, gfc_ref
* ref
)
10983 for (; ref
; ref
= ref
->next
)
10985 if (ref
->type
== REF_SUBSTRING
)
10987 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.start
);
10989 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.end
);
10992 /* We're only interested in array sections from now on. */
10993 if (ref
->type
!= REF_ARRAY
)
11001 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
11002 ss
= gfc_get_scalar_ss (ss
, ar
->start
[n
]);
11006 newss
= gfc_get_array_ss (ss
, expr
, ar
->as
->rank
, GFC_SS_SECTION
);
11007 newss
->info
->data
.array
.ref
= ref
;
11009 /* Make sure array is the same as array(:,:), this way
11010 we don't need to special case all the time. */
11011 ar
->dimen
= ar
->as
->rank
;
11012 for (n
= 0; n
< ar
->dimen
; n
++)
11014 ar
->dimen_type
[n
] = DIMEN_RANGE
;
11016 gcc_assert (ar
->start
[n
] == NULL
);
11017 gcc_assert (ar
->end
[n
] == NULL
);
11018 gcc_assert (ar
->stride
[n
] == NULL
);
11024 newss
= gfc_get_array_ss (ss
, expr
, 0, GFC_SS_SECTION
);
11025 newss
->info
->data
.array
.ref
= ref
;
11027 /* We add SS chains for all the subscripts in the section. */
11028 for (n
= 0; n
< ar
->dimen
; n
++)
11032 switch (ar
->dimen_type
[n
])
11034 case DIMEN_ELEMENT
:
11035 /* Add SS for elemental (scalar) subscripts. */
11036 gcc_assert (ar
->start
[n
]);
11037 indexss
= gfc_get_scalar_ss (gfc_ss_terminator
, ar
->start
[n
]);
11038 indexss
->loop_chain
= gfc_ss_terminator
;
11039 newss
->info
->data
.array
.subscript
[n
] = indexss
;
11043 /* We don't add anything for sections, just remember this
11044 dimension for later. */
11045 newss
->dim
[newss
->dimen
] = n
;
11050 /* Create a GFC_SS_VECTOR index in which we can store
11051 the vector's descriptor. */
11052 indexss
= gfc_get_array_ss (gfc_ss_terminator
, ar
->start
[n
],
11054 indexss
->loop_chain
= gfc_ss_terminator
;
11055 newss
->info
->data
.array
.subscript
[n
] = indexss
;
11056 newss
->dim
[newss
->dimen
] = n
;
11061 /* We should know what sort of section it is by now. */
11062 gcc_unreachable ();
11065 /* We should have at least one non-elemental dimension,
11066 unless we are creating a descriptor for a (scalar) coarray. */
11067 gcc_assert (newss
->dimen
> 0
11068 || newss
->info
->data
.array
.ref
->u
.ar
.as
->corank
> 0);
11073 /* We should know what sort of section it is by now. */
11074 gcc_unreachable ();
11082 /* Walk an expression operator. If only one operand of a binary expression is
11083 scalar, we must also add the scalar term to the SS chain. */
11086 gfc_walk_op_expr (gfc_ss
* ss
, gfc_expr
* expr
)
11091 head
= gfc_walk_subexpr (ss
, expr
->value
.op
.op1
);
11092 if (expr
->value
.op
.op2
== NULL
)
11095 head2
= gfc_walk_subexpr (head
, expr
->value
.op
.op2
);
11097 /* All operands are scalar. Pass back and let the caller deal with it. */
11101 /* All operands require scalarization. */
11102 if (head
!= ss
&& (expr
->value
.op
.op2
== NULL
|| head2
!= head
))
11105 /* One of the operands needs scalarization, the other is scalar.
11106 Create a gfc_ss for the scalar expression. */
11109 /* First operand is scalar. We build the chain in reverse order, so
11110 add the scalar SS after the second operand. */
11112 while (head
&& head
->next
!= ss
)
11114 /* Check we haven't somehow broken the chain. */
11116 head
->next
= gfc_get_scalar_ss (ss
, expr
->value
.op
.op1
);
11118 else /* head2 == head */
11120 gcc_assert (head2
== head
);
11121 /* Second operand is scalar. */
11122 head2
= gfc_get_scalar_ss (head2
, expr
->value
.op
.op2
);
11129 /* Reverse a SS chain. */
11132 gfc_reverse_ss (gfc_ss
* ss
)
11137 gcc_assert (ss
!= NULL
);
11139 head
= gfc_ss_terminator
;
11140 while (ss
!= gfc_ss_terminator
)
11143 /* Check we didn't somehow break the chain. */
11144 gcc_assert (next
!= NULL
);
11154 /* Given an expression referring to a procedure, return the symbol of its
11155 interface. We can't get the procedure symbol directly as we have to handle
11156 the case of (deferred) type-bound procedures. */
11159 gfc_get_proc_ifc_for_expr (gfc_expr
*procedure_ref
)
11164 if (procedure_ref
== NULL
)
11167 /* Normal procedure case. */
11168 if (procedure_ref
->expr_type
== EXPR_FUNCTION
11169 && procedure_ref
->value
.function
.esym
)
11170 sym
= procedure_ref
->value
.function
.esym
;
11172 sym
= procedure_ref
->symtree
->n
.sym
;
11174 /* Typebound procedure case. */
11175 for (ref
= procedure_ref
->ref
; ref
; ref
= ref
->next
)
11177 if (ref
->type
== REF_COMPONENT
11178 && ref
->u
.c
.component
->attr
.proc_pointer
)
11179 sym
= ref
->u
.c
.component
->ts
.interface
;
11188 /* Walk the arguments of an elemental function.
11189 PROC_EXPR is used to check whether an argument is permitted to be absent. If
11190 it is NULL, we don't do the check and the argument is assumed to be present.
11194 gfc_walk_elemental_function_args (gfc_ss
* ss
, gfc_actual_arglist
*arg
,
11195 gfc_symbol
*proc_ifc
, gfc_ss_type type
)
11197 gfc_formal_arglist
*dummy_arg
;
11203 head
= gfc_ss_terminator
;
11207 dummy_arg
= gfc_sym_get_dummy_args (proc_ifc
);
11212 for (; arg
; arg
= arg
->next
)
11214 if (!arg
->expr
|| arg
->expr
->expr_type
== EXPR_NULL
)
11215 goto loop_continue
;
11217 newss
= gfc_walk_subexpr (head
, arg
->expr
);
11220 /* Scalar argument. */
11221 gcc_assert (type
== GFC_SS_SCALAR
|| type
== GFC_SS_REFERENCE
);
11222 newss
= gfc_get_scalar_ss (head
, arg
->expr
);
11223 newss
->info
->type
= type
;
11225 newss
->info
->data
.scalar
.dummy_arg
= dummy_arg
->sym
;
11230 if (dummy_arg
!= NULL
11231 && dummy_arg
->sym
->attr
.optional
11232 && arg
->expr
->expr_type
== EXPR_VARIABLE
11233 && (gfc_expr_attr (arg
->expr
).optional
11234 || gfc_expr_attr (arg
->expr
).allocatable
11235 || gfc_expr_attr (arg
->expr
).pointer
))
11236 newss
->info
->can_be_null_ref
= true;
11242 while (tail
->next
!= gfc_ss_terminator
)
11247 if (dummy_arg
!= NULL
)
11248 dummy_arg
= dummy_arg
->next
;
11253 /* If all the arguments are scalar we don't need the argument SS. */
11254 gfc_free_ss_chain (head
);
11255 /* Pass it back. */
11259 /* Add it onto the existing chain. */
11265 /* Walk a function call. Scalar functions are passed back, and taken out of
11266 scalarization loops. For elemental functions we walk their arguments.
11267 The result of functions returning arrays is stored in a temporary outside
11268 the loop, so that the function is only called once. Hence we do not need
11269 to walk their arguments. */
11272 gfc_walk_function_expr (gfc_ss
* ss
, gfc_expr
* expr
)
11274 gfc_intrinsic_sym
*isym
;
11276 gfc_component
*comp
= NULL
;
11278 isym
= expr
->value
.function
.isym
;
11280 /* Handle intrinsic functions separately. */
11282 return gfc_walk_intrinsic_function (ss
, expr
, isym
);
11284 sym
= expr
->value
.function
.esym
;
11286 sym
= expr
->symtree
->n
.sym
;
11288 if (gfc_is_class_array_function (expr
))
11289 return gfc_get_array_ss (ss
, expr
,
11290 CLASS_DATA (expr
->value
.function
.esym
->result
)->as
->rank
,
11293 /* A function that returns arrays. */
11294 comp
= gfc_get_proc_ptr_comp (expr
);
11295 if ((!comp
&& gfc_return_by_reference (sym
) && sym
->result
->attr
.dimension
)
11296 || (comp
&& comp
->attr
.dimension
))
11297 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
11299 /* Walk the parameters of an elemental function. For now we always pass
11301 if (sym
->attr
.elemental
|| (comp
&& comp
->attr
.elemental
))
11303 gfc_ss
*old_ss
= ss
;
11305 ss
= gfc_walk_elemental_function_args (old_ss
,
11306 expr
->value
.function
.actual
,
11307 gfc_get_proc_ifc_for_expr (expr
),
11311 || sym
->attr
.proc_pointer
11312 || sym
->attr
.if_source
!= IFSRC_DECL
11313 || sym
->attr
.array_outer_dependency
))
11314 ss
->info
->array_outer_dependency
= 1;
11317 /* Scalar functions are OK as these are evaluated outside the scalarization
11318 loop. Pass back and let the caller deal with it. */
11323 /* An array temporary is constructed for array constructors. */
11326 gfc_walk_array_constructor (gfc_ss
* ss
, gfc_expr
* expr
)
11328 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_CONSTRUCTOR
);
11332 /* Walk an expression. Add walked expressions to the head of the SS chain.
11333 A wholly scalar expression will not be added. */
11336 gfc_walk_subexpr (gfc_ss
* ss
, gfc_expr
* expr
)
11340 switch (expr
->expr_type
)
11342 case EXPR_VARIABLE
:
11343 head
= gfc_walk_variable_expr (ss
, expr
);
11347 head
= gfc_walk_op_expr (ss
, expr
);
11350 case EXPR_FUNCTION
:
11351 head
= gfc_walk_function_expr (ss
, expr
);
11354 case EXPR_CONSTANT
:
11356 case EXPR_STRUCTURE
:
11357 /* Pass back and let the caller deal with it. */
11361 head
= gfc_walk_array_constructor (ss
, expr
);
11364 case EXPR_SUBSTRING
:
11365 /* Pass back and let the caller deal with it. */
11369 gfc_internal_error ("bad expression type during walk (%d)",
11376 /* Entry point for expression walking.
11377 A return value equal to the passed chain means this is
11378 a scalar expression. It is up to the caller to take whatever action is
11379 necessary to translate these. */
11382 gfc_walk_expr (gfc_expr
* expr
)
11386 res
= gfc_walk_subexpr (gfc_ss_terminator
, expr
);
11387 return gfc_reverse_ss (res
);