1 /* Array translation routines
2 Copyright (C) 2002-2014 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"
82 #include "gimple-expr.h"
83 #include "diagnostic-core.h" /* For internal_error/fatal_error. */
86 #include "constructor.h"
88 #include "trans-stmt.h"
89 #include "trans-types.h"
90 #include "trans-array.h"
91 #include "trans-const.h"
92 #include "dependency.h"
94 static bool gfc_get_array_constructor_size (mpz_t
*, gfc_constructor_base
);
96 /* The contents of this structure aren't actually used, just the address. */
97 static gfc_ss gfc_ss_terminator_var
;
98 gfc_ss
* const gfc_ss_terminator
= &gfc_ss_terminator_var
;
102 gfc_array_dataptr_type (tree desc
)
104 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
)));
108 /* Build expressions to access the members of an array descriptor.
109 It's surprisingly easy to mess up here, so never access
110 an array descriptor by "brute force", always use these
111 functions. This also avoids problems if we change the format
112 of an array descriptor.
114 To understand these magic numbers, look at the comments
115 before gfc_build_array_type() in trans-types.c.
117 The code within these defines should be the only code which knows the format
118 of an array descriptor.
120 Any code just needing to read obtain the bounds of an array should use
121 gfc_conv_array_* rather than the following functions as these will return
122 know constant values, and work with arrays which do not have descriptors.
124 Don't forget to #undef these! */
127 #define OFFSET_FIELD 1
128 #define DTYPE_FIELD 2
129 #define DIMENSION_FIELD 3
130 #define CAF_TOKEN_FIELD 4
132 #define STRIDE_SUBFIELD 0
133 #define LBOUND_SUBFIELD 1
134 #define UBOUND_SUBFIELD 2
136 /* This provides READ-ONLY access to the data field. The field itself
137 doesn't have the proper type. */
140 gfc_conv_descriptor_data_get (tree desc
)
144 type
= TREE_TYPE (desc
);
145 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
147 field
= TYPE_FIELDS (type
);
148 gcc_assert (DATA_FIELD
== 0);
150 t
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
), desc
,
152 t
= fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type
), t
);
157 /* This provides WRITE access to the data field.
159 TUPLES_P is true if we are generating tuples.
161 This function gets called through the following macros:
162 gfc_conv_descriptor_data_set
163 gfc_conv_descriptor_data_set. */
166 gfc_conv_descriptor_data_set (stmtblock_t
*block
, tree desc
, tree value
)
170 type
= TREE_TYPE (desc
);
171 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
173 field
= TYPE_FIELDS (type
);
174 gcc_assert (DATA_FIELD
== 0);
176 t
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
), desc
,
178 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (field
), value
));
182 /* This provides address access to the data field. This should only be
183 used by array allocation, passing this on to the runtime. */
186 gfc_conv_descriptor_data_addr (tree desc
)
190 type
= TREE_TYPE (desc
);
191 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
193 field
= TYPE_FIELDS (type
);
194 gcc_assert (DATA_FIELD
== 0);
196 t
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
), desc
,
198 return gfc_build_addr_expr (NULL_TREE
, t
);
202 gfc_conv_descriptor_offset (tree desc
)
207 type
= TREE_TYPE (desc
);
208 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
210 field
= gfc_advance_chain (TYPE_FIELDS (type
), OFFSET_FIELD
);
211 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
213 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
214 desc
, field
, NULL_TREE
);
218 gfc_conv_descriptor_offset_get (tree desc
)
220 return gfc_conv_descriptor_offset (desc
);
224 gfc_conv_descriptor_offset_set (stmtblock_t
*block
, tree desc
,
227 tree t
= gfc_conv_descriptor_offset (desc
);
228 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
233 gfc_conv_descriptor_dtype (tree desc
)
238 type
= TREE_TYPE (desc
);
239 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
241 field
= gfc_advance_chain (TYPE_FIELDS (type
), DTYPE_FIELD
);
242 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
244 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
245 desc
, field
, NULL_TREE
);
250 gfc_conv_descriptor_rank (tree desc
)
255 dtype
= gfc_conv_descriptor_dtype (desc
);
256 tmp
= build_int_cst (TREE_TYPE (dtype
), GFC_DTYPE_RANK_MASK
);
257 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, TREE_TYPE (dtype
),
259 return fold_convert (gfc_get_int_type (gfc_default_integer_kind
), tmp
);
264 gfc_get_descriptor_dimension (tree desc
)
268 type
= TREE_TYPE (desc
);
269 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
271 field
= gfc_advance_chain (TYPE_FIELDS (type
), DIMENSION_FIELD
);
272 gcc_assert (field
!= NULL_TREE
273 && TREE_CODE (TREE_TYPE (field
)) == ARRAY_TYPE
274 && TREE_CODE (TREE_TYPE (TREE_TYPE (field
))) == RECORD_TYPE
);
276 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
277 desc
, field
, NULL_TREE
);
282 gfc_conv_descriptor_dimension (tree desc
, tree dim
)
286 tmp
= gfc_get_descriptor_dimension (desc
);
288 return gfc_build_array_ref (tmp
, dim
, NULL
);
293 gfc_conv_descriptor_token (tree desc
)
298 type
= TREE_TYPE (desc
);
299 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
300 gcc_assert (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ALLOCATABLE
);
301 gcc_assert (gfc_option
.coarray
== GFC_FCOARRAY_LIB
);
302 field
= gfc_advance_chain (TYPE_FIELDS (type
), CAF_TOKEN_FIELD
);
304 /* Should be a restricted pointer - except in the finalization wrapper. */
305 gcc_assert (field
!= NULL_TREE
306 && (TREE_TYPE (field
) == prvoid_type_node
307 || TREE_TYPE (field
) == pvoid_type_node
));
309 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
310 desc
, field
, NULL_TREE
);
315 gfc_conv_descriptor_stride (tree desc
, tree dim
)
320 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
321 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
322 field
= gfc_advance_chain (field
, STRIDE_SUBFIELD
);
323 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
325 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
326 tmp
, field
, NULL_TREE
);
331 gfc_conv_descriptor_stride_get (tree desc
, tree dim
)
333 tree type
= TREE_TYPE (desc
);
334 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
335 if (integer_zerop (dim
)
336 && (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ALLOCATABLE
337 ||GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE_CONT
338 ||GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_RANK_CONT
339 ||GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER_CONT
))
340 return gfc_index_one_node
;
342 return gfc_conv_descriptor_stride (desc
, dim
);
346 gfc_conv_descriptor_stride_set (stmtblock_t
*block
, tree desc
,
347 tree dim
, tree value
)
349 tree t
= gfc_conv_descriptor_stride (desc
, dim
);
350 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
354 gfc_conv_descriptor_lbound (tree desc
, tree dim
)
359 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
360 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
361 field
= gfc_advance_chain (field
, LBOUND_SUBFIELD
);
362 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
364 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
365 tmp
, field
, NULL_TREE
);
370 gfc_conv_descriptor_lbound_get (tree desc
, tree dim
)
372 return gfc_conv_descriptor_lbound (desc
, dim
);
376 gfc_conv_descriptor_lbound_set (stmtblock_t
*block
, tree desc
,
377 tree dim
, tree value
)
379 tree t
= gfc_conv_descriptor_lbound (desc
, dim
);
380 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
384 gfc_conv_descriptor_ubound (tree desc
, tree dim
)
389 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
390 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
391 field
= gfc_advance_chain (field
, UBOUND_SUBFIELD
);
392 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
394 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
395 tmp
, field
, NULL_TREE
);
400 gfc_conv_descriptor_ubound_get (tree desc
, tree dim
)
402 return gfc_conv_descriptor_ubound (desc
, dim
);
406 gfc_conv_descriptor_ubound_set (stmtblock_t
*block
, tree desc
,
407 tree dim
, tree value
)
409 tree t
= gfc_conv_descriptor_ubound (desc
, dim
);
410 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
413 /* Build a null array descriptor constructor. */
416 gfc_build_null_descriptor (tree type
)
421 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
422 gcc_assert (DATA_FIELD
== 0);
423 field
= TYPE_FIELDS (type
);
425 /* Set a NULL data pointer. */
426 tmp
= build_constructor_single (type
, field
, null_pointer_node
);
427 TREE_CONSTANT (tmp
) = 1;
428 /* All other fields are ignored. */
434 /* Modify a descriptor such that the lbound of a given dimension is the value
435 specified. This also updates ubound and offset accordingly. */
438 gfc_conv_shift_descriptor_lbound (stmtblock_t
* block
, tree desc
,
439 int dim
, tree new_lbound
)
441 tree offs
, ubound
, lbound
, stride
;
442 tree diff
, offs_diff
;
444 new_lbound
= fold_convert (gfc_array_index_type
, new_lbound
);
446 offs
= gfc_conv_descriptor_offset_get (desc
);
447 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]);
448 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]);
449 stride
= gfc_conv_descriptor_stride_get (desc
, gfc_rank_cst
[dim
]);
451 /* Get difference (new - old) by which to shift stuff. */
452 diff
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
455 /* Shift ubound and offset accordingly. This has to be done before
456 updating the lbound, as they depend on the lbound expression! */
457 ubound
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
459 gfc_conv_descriptor_ubound_set (block
, desc
, gfc_rank_cst
[dim
], ubound
);
460 offs_diff
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
462 offs
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
464 gfc_conv_descriptor_offset_set (block
, desc
, offs
);
466 /* Finally set lbound to value we want. */
467 gfc_conv_descriptor_lbound_set (block
, desc
, gfc_rank_cst
[dim
], new_lbound
);
471 /* Cleanup those #defines. */
476 #undef DIMENSION_FIELD
477 #undef CAF_TOKEN_FIELD
478 #undef STRIDE_SUBFIELD
479 #undef LBOUND_SUBFIELD
480 #undef UBOUND_SUBFIELD
483 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
484 flags & 1 = Main loop body.
485 flags & 2 = temp copy loop. */
488 gfc_mark_ss_chain_used (gfc_ss
* ss
, unsigned flags
)
490 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
491 ss
->info
->useflags
= flags
;
495 /* Free a gfc_ss chain. */
498 gfc_free_ss_chain (gfc_ss
* ss
)
502 while (ss
!= gfc_ss_terminator
)
504 gcc_assert (ss
!= NULL
);
513 free_ss_info (gfc_ss_info
*ss_info
)
518 if (ss_info
->refcount
> 0)
521 gcc_assert (ss_info
->refcount
== 0);
523 switch (ss_info
->type
)
526 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
527 if (ss_info
->data
.array
.subscript
[n
])
528 gfc_free_ss_chain (ss_info
->data
.array
.subscript
[n
]);
542 gfc_free_ss (gfc_ss
* ss
)
544 free_ss_info (ss
->info
);
549 /* Creates and initializes an array type gfc_ss struct. */
552 gfc_get_array_ss (gfc_ss
*next
, gfc_expr
*expr
, int dimen
, gfc_ss_type type
)
555 gfc_ss_info
*ss_info
;
558 ss_info
= gfc_get_ss_info ();
560 ss_info
->type
= type
;
561 ss_info
->expr
= expr
;
567 for (i
= 0; i
< ss
->dimen
; i
++)
574 /* Creates and initializes a temporary type gfc_ss struct. */
577 gfc_get_temp_ss (tree type
, tree string_length
, int dimen
)
580 gfc_ss_info
*ss_info
;
583 ss_info
= gfc_get_ss_info ();
585 ss_info
->type
= GFC_SS_TEMP
;
586 ss_info
->string_length
= string_length
;
587 ss_info
->data
.temp
.type
= type
;
591 ss
->next
= gfc_ss_terminator
;
593 for (i
= 0; i
< ss
->dimen
; i
++)
600 /* Creates and initializes a scalar type gfc_ss struct. */
603 gfc_get_scalar_ss (gfc_ss
*next
, gfc_expr
*expr
)
606 gfc_ss_info
*ss_info
;
608 ss_info
= gfc_get_ss_info ();
610 ss_info
->type
= GFC_SS_SCALAR
;
611 ss_info
->expr
= expr
;
621 /* Free all the SS associated with a loop. */
624 gfc_cleanup_loop (gfc_loopinfo
* loop
)
626 gfc_loopinfo
*loop_next
, **ploop
;
631 while (ss
!= gfc_ss_terminator
)
633 gcc_assert (ss
!= NULL
);
634 next
= ss
->loop_chain
;
639 /* Remove reference to self in the parent loop. */
641 for (ploop
= &loop
->parent
->nested
; *ploop
; ploop
= &(*ploop
)->next
)
648 /* Free non-freed nested loops. */
649 for (loop
= loop
->nested
; loop
; loop
= loop_next
)
651 loop_next
= loop
->next
;
652 gfc_cleanup_loop (loop
);
659 set_ss_loop (gfc_ss
*ss
, gfc_loopinfo
*loop
)
663 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
667 if (ss
->info
->type
== GFC_SS_SCALAR
668 || ss
->info
->type
== GFC_SS_REFERENCE
669 || ss
->info
->type
== GFC_SS_TEMP
)
672 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
673 if (ss
->info
->data
.array
.subscript
[n
] != NULL
)
674 set_ss_loop (ss
->info
->data
.array
.subscript
[n
], loop
);
679 /* Associate a SS chain with a loop. */
682 gfc_add_ss_to_loop (gfc_loopinfo
* loop
, gfc_ss
* head
)
685 gfc_loopinfo
*nested_loop
;
687 if (head
== gfc_ss_terminator
)
690 set_ss_loop (head
, loop
);
693 for (; ss
&& ss
!= gfc_ss_terminator
; ss
= ss
->next
)
697 nested_loop
= ss
->nested_ss
->loop
;
699 /* More than one ss can belong to the same loop. Hence, we add the
700 loop to the chain only if it is different from the previously
701 added one, to avoid duplicate nested loops. */
702 if (nested_loop
!= loop
->nested
)
704 gcc_assert (nested_loop
->parent
== NULL
);
705 nested_loop
->parent
= loop
;
707 gcc_assert (nested_loop
->next
== NULL
);
708 nested_loop
->next
= loop
->nested
;
709 loop
->nested
= nested_loop
;
712 gcc_assert (nested_loop
->parent
== loop
);
715 if (ss
->next
== gfc_ss_terminator
)
716 ss
->loop_chain
= loop
->ss
;
718 ss
->loop_chain
= ss
->next
;
720 gcc_assert (ss
== gfc_ss_terminator
);
725 /* Generate an initializer for a static pointer or allocatable array. */
728 gfc_trans_static_array_pointer (gfc_symbol
* sym
)
732 gcc_assert (TREE_STATIC (sym
->backend_decl
));
733 /* Just zero the data member. */
734 type
= TREE_TYPE (sym
->backend_decl
);
735 DECL_INITIAL (sym
->backend_decl
) = gfc_build_null_descriptor (type
);
739 /* If the bounds of SE's loop have not yet been set, see if they can be
740 determined from array spec AS, which is the array spec of a called
741 function. MAPPING maps the callee's dummy arguments to the values
742 that the caller is passing. Add any initialization and finalization
746 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping
* mapping
,
747 gfc_se
* se
, gfc_array_spec
* as
)
749 int n
, dim
, total_dim
;
758 if (!as
|| as
->type
!= AS_EXPLICIT
)
761 for (ss
= se
->ss
; ss
; ss
= ss
->parent
)
763 total_dim
+= ss
->loop
->dimen
;
764 for (n
= 0; n
< ss
->loop
->dimen
; n
++)
766 /* The bound is known, nothing to do. */
767 if (ss
->loop
->to
[n
] != NULL_TREE
)
771 gcc_assert (dim
< as
->rank
);
772 gcc_assert (ss
->loop
->dimen
<= as
->rank
);
774 /* Evaluate the lower bound. */
775 gfc_init_se (&tmpse
, NULL
);
776 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->lower
[dim
]);
777 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
778 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
779 lower
= fold_convert (gfc_array_index_type
, tmpse
.expr
);
781 /* ...and the upper bound. */
782 gfc_init_se (&tmpse
, NULL
);
783 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->upper
[dim
]);
784 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
785 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
786 upper
= fold_convert (gfc_array_index_type
, tmpse
.expr
);
788 /* Set the upper bound of the loop to UPPER - LOWER. */
789 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
790 gfc_array_index_type
, upper
, lower
);
791 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
792 ss
->loop
->to
[n
] = tmp
;
796 gcc_assert (total_dim
== as
->rank
);
800 /* Generate code to allocate an array temporary, or create a variable to
801 hold the data. If size is NULL, zero the descriptor so that the
802 callee will allocate the array. If DEALLOC is true, also generate code to
803 free the array afterwards.
805 If INITIAL is not NULL, it is packed using internal_pack and the result used
806 as data instead of allocating a fresh, unitialized area of memory.
808 Initialization code is added to PRE and finalization code to POST.
809 DYNAMIC is true if the caller may want to extend the array later
810 using realloc. This prevents us from putting the array on the stack. */
813 gfc_trans_allocate_array_storage (stmtblock_t
* pre
, stmtblock_t
* post
,
814 gfc_array_info
* info
, tree size
, tree nelem
,
815 tree initial
, bool dynamic
, bool dealloc
)
821 desc
= info
->descriptor
;
822 info
->offset
= gfc_index_zero_node
;
823 if (size
== NULL_TREE
|| integer_zerop (size
))
825 /* A callee allocated array. */
826 gfc_conv_descriptor_data_set (pre
, desc
, null_pointer_node
);
831 /* Allocate the temporary. */
832 onstack
= !dynamic
&& initial
== NULL_TREE
833 && (gfc_option
.flag_stack_arrays
834 || gfc_can_put_var_on_stack (size
));
838 /* Make a temporary variable to hold the data. */
839 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (nelem
),
840 nelem
, gfc_index_one_node
);
841 tmp
= gfc_evaluate_now (tmp
, pre
);
842 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
844 tmp
= build_array_type (gfc_get_element_type (TREE_TYPE (desc
)),
846 tmp
= gfc_create_var (tmp
, "A");
847 /* If we're here only because of -fstack-arrays we have to
848 emit a DECL_EXPR to make the gimplifier emit alloca calls. */
849 if (!gfc_can_put_var_on_stack (size
))
850 gfc_add_expr_to_block (pre
,
851 fold_build1_loc (input_location
,
852 DECL_EXPR
, TREE_TYPE (tmp
),
854 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
855 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
859 /* Allocate memory to hold the data or call internal_pack. */
860 if (initial
== NULL_TREE
)
862 tmp
= gfc_call_malloc (pre
, NULL
, size
);
863 tmp
= gfc_evaluate_now (tmp
, pre
);
870 stmtblock_t do_copying
;
872 tmp
= TREE_TYPE (initial
); /* Pointer to descriptor. */
873 gcc_assert (TREE_CODE (tmp
) == POINTER_TYPE
);
874 tmp
= TREE_TYPE (tmp
); /* The descriptor itself. */
875 tmp
= gfc_get_element_type (tmp
);
876 gcc_assert (tmp
== gfc_get_element_type (TREE_TYPE (desc
)));
877 packed
= gfc_create_var (build_pointer_type (tmp
), "data");
879 tmp
= build_call_expr_loc (input_location
,
880 gfor_fndecl_in_pack
, 1, initial
);
881 tmp
= fold_convert (TREE_TYPE (packed
), tmp
);
882 gfc_add_modify (pre
, packed
, tmp
);
884 tmp
= build_fold_indirect_ref_loc (input_location
,
886 source_data
= gfc_conv_descriptor_data_get (tmp
);
888 /* internal_pack may return source->data without any allocation
889 or copying if it is already packed. If that's the case, we
890 need to allocate and copy manually. */
892 gfc_start_block (&do_copying
);
893 tmp
= gfc_call_malloc (&do_copying
, NULL
, size
);
894 tmp
= fold_convert (TREE_TYPE (packed
), tmp
);
895 gfc_add_modify (&do_copying
, packed
, tmp
);
896 tmp
= gfc_build_memcpy_call (packed
, source_data
, size
);
897 gfc_add_expr_to_block (&do_copying
, tmp
);
899 was_packed
= fold_build2_loc (input_location
, EQ_EXPR
,
900 boolean_type_node
, packed
,
902 tmp
= gfc_finish_block (&do_copying
);
903 tmp
= build3_v (COND_EXPR
, was_packed
, tmp
,
904 build_empty_stmt (input_location
));
905 gfc_add_expr_to_block (pre
, tmp
);
907 tmp
= fold_convert (pvoid_type_node
, packed
);
910 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
913 info
->data
= gfc_conv_descriptor_data_get (desc
);
915 /* The offset is zero because we create temporaries with a zero
917 gfc_conv_descriptor_offset_set (pre
, desc
, gfc_index_zero_node
);
919 if (dealloc
&& !onstack
)
921 /* Free the temporary. */
922 tmp
= gfc_conv_descriptor_data_get (desc
);
923 tmp
= gfc_call_free (fold_convert (pvoid_type_node
, tmp
));
924 gfc_add_expr_to_block (post
, tmp
);
929 /* Get the scalarizer array dimension corresponding to actual array dimension
932 For example, if SS represents the array ref a(1,:,:,1), it is a
933 bidimensional scalarizer array, and the result would be 0 for ARRAY_DIM=1,
934 and 1 for ARRAY_DIM=2.
935 If SS represents transpose(a(:,1,1,:)), it is again a bidimensional
936 scalarizer array, and the result would be 1 for ARRAY_DIM=0 and 0 for
938 If SS represents sum(a(:,:,:,1), dim=1), it is a 2+1-dimensional scalarizer
939 array. If called on the inner ss, the result would be respectively 0,1,2 for
940 ARRAY_DIM=0,1,2. If called on the outer ss, the result would be 0,1
941 for ARRAY_DIM=1,2. */
944 get_scalarizer_dim_for_array_dim (gfc_ss
*ss
, int array_dim
)
951 for (; ss
; ss
= ss
->parent
)
952 for (n
= 0; n
< ss
->dimen
; n
++)
953 if (ss
->dim
[n
] < array_dim
)
956 return array_ref_dim
;
961 innermost_ss (gfc_ss
*ss
)
963 while (ss
->nested_ss
!= NULL
)
971 /* Get the array reference dimension corresponding to the given loop dimension.
972 It is different from the true array dimension given by the dim array in
973 the case of a partial array reference (i.e. a(:,:,1,:) for example)
974 It is different from the loop dimension in the case of a transposed array.
978 get_array_ref_dim_for_loop_dim (gfc_ss
*ss
, int loop_dim
)
980 return get_scalarizer_dim_for_array_dim (innermost_ss (ss
),
985 /* Generate code to create and initialize the descriptor for a temporary
986 array. This is used for both temporaries needed by the scalarizer, and
987 functions returning arrays. Adjusts the loop variables to be
988 zero-based, and calculates the loop bounds for callee allocated arrays.
989 Allocate the array unless it's callee allocated (we have a callee
990 allocated array if 'callee_alloc' is true, or if loop->to[n] is
991 NULL_TREE for any n). Also fills in the descriptor, data and offset
992 fields of info if known. Returns the size of the array, or NULL for a
993 callee allocated array.
995 'eltype' == NULL signals that the temporary should be a class object.
996 The 'initial' expression is used to obtain the size of the dynamic
997 type; otherwise the allocation and initialization proceeds as for any
1000 PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
1001 gfc_trans_allocate_array_storage. */
1004 gfc_trans_create_temp_array (stmtblock_t
* pre
, stmtblock_t
* post
, gfc_ss
* ss
,
1005 tree eltype
, tree initial
, bool dynamic
,
1006 bool dealloc
, bool callee_alloc
, locus
* where
)
1010 gfc_array_info
*info
;
1011 tree from
[GFC_MAX_DIMENSIONS
], to
[GFC_MAX_DIMENSIONS
];
1019 tree class_expr
= NULL_TREE
;
1020 int n
, dim
, tmp_dim
;
1023 /* This signals a class array for which we need the size of the
1024 dynamic type. Generate an eltype and then the class expression. */
1025 if (eltype
== NULL_TREE
&& initial
)
1027 gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial
)));
1028 class_expr
= build_fold_indirect_ref_loc (input_location
, initial
);
1029 eltype
= TREE_TYPE (class_expr
);
1030 eltype
= gfc_get_element_type (eltype
);
1031 /* Obtain the structure (class) expression. */
1032 class_expr
= TREE_OPERAND (class_expr
, 0);
1033 gcc_assert (class_expr
);
1036 memset (from
, 0, sizeof (from
));
1037 memset (to
, 0, sizeof (to
));
1039 info
= &ss
->info
->data
.array
;
1041 gcc_assert (ss
->dimen
> 0);
1042 gcc_assert (ss
->loop
->dimen
== ss
->dimen
);
1044 if (gfc_option
.warn_array_temp
&& where
)
1045 gfc_warning ("Creating array temporary at %L", where
);
1047 /* Set the lower bound to zero. */
1048 for (s
= ss
; s
; s
= s
->parent
)
1052 total_dim
+= loop
->dimen
;
1053 for (n
= 0; n
< loop
->dimen
; n
++)
1057 /* Callee allocated arrays may not have a known bound yet. */
1059 loop
->to
[n
] = gfc_evaluate_now (
1060 fold_build2_loc (input_location
, MINUS_EXPR
,
1061 gfc_array_index_type
,
1062 loop
->to
[n
], loop
->from
[n
]),
1064 loop
->from
[n
] = gfc_index_zero_node
;
1066 /* We have just changed the loop bounds, we must clear the
1067 corresponding specloop, so that delta calculation is not skipped
1068 later in gfc_set_delta. */
1069 loop
->specloop
[n
] = NULL
;
1071 /* We are constructing the temporary's descriptor based on the loop
1072 dimensions. As the dimensions may be accessed in arbitrary order
1073 (think of transpose) the size taken from the n'th loop may not map
1074 to the n'th dimension of the array. We need to reconstruct loop
1075 infos in the right order before using it to set the descriptor
1077 tmp_dim
= get_scalarizer_dim_for_array_dim (ss
, dim
);
1078 from
[tmp_dim
] = loop
->from
[n
];
1079 to
[tmp_dim
] = loop
->to
[n
];
1081 info
->delta
[dim
] = gfc_index_zero_node
;
1082 info
->start
[dim
] = gfc_index_zero_node
;
1083 info
->end
[dim
] = gfc_index_zero_node
;
1084 info
->stride
[dim
] = gfc_index_one_node
;
1088 /* Initialize the descriptor. */
1090 gfc_get_array_type_bounds (eltype
, total_dim
, 0, from
, to
, 1,
1091 GFC_ARRAY_UNKNOWN
, true);
1092 desc
= gfc_create_var (type
, "atmp");
1093 GFC_DECL_PACKED_ARRAY (desc
) = 1;
1095 info
->descriptor
= desc
;
1096 size
= gfc_index_one_node
;
1098 /* Fill in the array dtype. */
1099 tmp
= gfc_conv_descriptor_dtype (desc
);
1100 gfc_add_modify (pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
1103 Fill in the bounds and stride. This is a packed array, so:
1106 for (n = 0; n < rank; n++)
1109 delta = ubound[n] + 1 - lbound[n];
1110 size = size * delta;
1112 size = size * sizeof(element);
1115 or_expr
= NULL_TREE
;
1117 /* If there is at least one null loop->to[n], it is a callee allocated
1119 for (n
= 0; n
< total_dim
; n
++)
1120 if (to
[n
] == NULL_TREE
)
1126 if (size
== NULL_TREE
)
1127 for (s
= ss
; s
; s
= s
->parent
)
1128 for (n
= 0; n
< s
->loop
->dimen
; n
++)
1130 dim
= get_scalarizer_dim_for_array_dim (ss
, s
->dim
[n
]);
1132 /* For a callee allocated array express the loop bounds in terms
1133 of the descriptor fields. */
1134 tmp
= fold_build2_loc (input_location
,
1135 MINUS_EXPR
, gfc_array_index_type
,
1136 gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]),
1137 gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]));
1138 s
->loop
->to
[n
] = tmp
;
1142 for (n
= 0; n
< total_dim
; n
++)
1144 /* Store the stride and bound components in the descriptor. */
1145 gfc_conv_descriptor_stride_set (pre
, desc
, gfc_rank_cst
[n
], size
);
1147 gfc_conv_descriptor_lbound_set (pre
, desc
, gfc_rank_cst
[n
],
1148 gfc_index_zero_node
);
1150 gfc_conv_descriptor_ubound_set (pre
, desc
, gfc_rank_cst
[n
], to
[n
]);
1152 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1153 gfc_array_index_type
,
1154 to
[n
], gfc_index_one_node
);
1156 /* Check whether the size for this dimension is negative. */
1157 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
1158 tmp
, gfc_index_zero_node
);
1159 cond
= gfc_evaluate_now (cond
, pre
);
1164 or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1165 boolean_type_node
, or_expr
, cond
);
1167 size
= fold_build2_loc (input_location
, MULT_EXPR
,
1168 gfc_array_index_type
, size
, tmp
);
1169 size
= gfc_evaluate_now (size
, pre
);
1173 /* Get the size of the array. */
1174 if (size
&& !callee_alloc
)
1177 /* If or_expr is true, then the extent in at least one
1178 dimension is zero and the size is set to zero. */
1179 size
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
1180 or_expr
, gfc_index_zero_node
, size
);
1183 if (class_expr
== NULL_TREE
)
1184 elemsize
= fold_convert (gfc_array_index_type
,
1185 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
1187 elemsize
= gfc_vtable_size_get (class_expr
);
1189 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
1198 gfc_trans_allocate_array_storage (pre
, post
, info
, size
, nelem
, initial
,
1204 if (ss
->dimen
> ss
->loop
->temp_dim
)
1205 ss
->loop
->temp_dim
= ss
->dimen
;
1211 /* Return the number of iterations in a loop that starts at START,
1212 ends at END, and has step STEP. */
1215 gfc_get_iteration_count (tree start
, tree end
, tree step
)
1220 type
= TREE_TYPE (step
);
1221 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, end
, start
);
1222 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
, type
, tmp
, step
);
1223 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
,
1224 build_int_cst (type
, 1));
1225 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, type
, tmp
,
1226 build_int_cst (type
, 0));
1227 return fold_convert (gfc_array_index_type
, tmp
);
1231 /* Extend the data in array DESC by EXTRA elements. */
1234 gfc_grow_array (stmtblock_t
* pblock
, tree desc
, tree extra
)
1241 if (integer_zerop (extra
))
1244 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[0]);
1246 /* Add EXTRA to the upper bound. */
1247 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1249 gfc_conv_descriptor_ubound_set (pblock
, desc
, gfc_rank_cst
[0], tmp
);
1251 /* Get the value of the current data pointer. */
1252 arg0
= gfc_conv_descriptor_data_get (desc
);
1254 /* Calculate the new array size. */
1255 size
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
1256 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1257 ubound
, gfc_index_one_node
);
1258 arg1
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
1259 fold_convert (size_type_node
, tmp
),
1260 fold_convert (size_type_node
, size
));
1262 /* Call the realloc() function. */
1263 tmp
= gfc_call_realloc (pblock
, arg0
, arg1
);
1264 gfc_conv_descriptor_data_set (pblock
, desc
, tmp
);
1268 /* Return true if the bounds of iterator I can only be determined
1272 gfc_iterator_has_dynamic_bounds (gfc_iterator
* i
)
1274 return (i
->start
->expr_type
!= EXPR_CONSTANT
1275 || i
->end
->expr_type
!= EXPR_CONSTANT
1276 || i
->step
->expr_type
!= EXPR_CONSTANT
);
1280 /* Split the size of constructor element EXPR into the sum of two terms,
1281 one of which can be determined at compile time and one of which must
1282 be calculated at run time. Set *SIZE to the former and return true
1283 if the latter might be nonzero. */
1286 gfc_get_array_constructor_element_size (mpz_t
* size
, gfc_expr
* expr
)
1288 if (expr
->expr_type
== EXPR_ARRAY
)
1289 return gfc_get_array_constructor_size (size
, expr
->value
.constructor
);
1290 else if (expr
->rank
> 0)
1292 /* Calculate everything at run time. */
1293 mpz_set_ui (*size
, 0);
1298 /* A single element. */
1299 mpz_set_ui (*size
, 1);
1305 /* Like gfc_get_array_constructor_element_size, but applied to the whole
1306 of array constructor C. */
1309 gfc_get_array_constructor_size (mpz_t
* size
, gfc_constructor_base base
)
1317 mpz_set_ui (*size
, 0);
1322 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1325 if (i
&& gfc_iterator_has_dynamic_bounds (i
))
1329 dynamic
|= gfc_get_array_constructor_element_size (&len
, c
->expr
);
1332 /* Multiply the static part of the element size by the
1333 number of iterations. */
1334 mpz_sub (val
, i
->end
->value
.integer
, i
->start
->value
.integer
);
1335 mpz_fdiv_q (val
, val
, i
->step
->value
.integer
);
1336 mpz_add_ui (val
, val
, 1);
1337 if (mpz_sgn (val
) > 0)
1338 mpz_mul (len
, len
, val
);
1340 mpz_set_ui (len
, 0);
1342 mpz_add (*size
, *size
, len
);
1351 /* Make sure offset is a variable. */
1354 gfc_put_offset_into_var (stmtblock_t
* pblock
, tree
* poffset
,
1357 /* We should have already created the offset variable. We cannot
1358 create it here because we may be in an inner scope. */
1359 gcc_assert (*offsetvar
!= NULL_TREE
);
1360 gfc_add_modify (pblock
, *offsetvar
, *poffset
);
1361 *poffset
= *offsetvar
;
1362 TREE_USED (*offsetvar
) = 1;
1366 /* Variables needed for bounds-checking. */
1367 static bool first_len
;
1368 static tree first_len_val
;
1369 static bool typespec_chararray_ctor
;
1372 gfc_trans_array_ctor_element (stmtblock_t
* pblock
, tree desc
,
1373 tree offset
, gfc_se
* se
, gfc_expr
* expr
)
1377 gfc_conv_expr (se
, expr
);
1379 /* Store the value. */
1380 tmp
= build_fold_indirect_ref_loc (input_location
,
1381 gfc_conv_descriptor_data_get (desc
));
1382 tmp
= gfc_build_array_ref (tmp
, offset
, NULL
);
1384 if (expr
->ts
.type
== BT_CHARACTER
)
1386 int i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
1389 esize
= size_in_bytes (gfc_get_element_type (TREE_TYPE (desc
)));
1390 esize
= fold_convert (gfc_charlen_type_node
, esize
);
1391 esize
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1392 gfc_charlen_type_node
, esize
,
1393 build_int_cst (gfc_charlen_type_node
,
1394 gfc_character_kinds
[i
].bit_size
/ 8));
1396 gfc_conv_string_parameter (se
);
1397 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
1399 /* The temporary is an array of pointers. */
1400 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1401 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1405 /* The temporary is an array of string values. */
1406 tmp
= gfc_build_addr_expr (gfc_get_pchar_type (expr
->ts
.kind
), tmp
);
1407 /* We know the temporary and the value will be the same length,
1408 so can use memcpy. */
1409 gfc_trans_string_copy (&se
->pre
, esize
, tmp
, expr
->ts
.kind
,
1410 se
->string_length
, se
->expr
, expr
->ts
.kind
);
1412 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && !typespec_chararray_ctor
)
1416 gfc_add_modify (&se
->pre
, first_len_val
,
1422 /* Verify that all constructor elements are of the same
1424 tree cond
= fold_build2_loc (input_location
, NE_EXPR
,
1425 boolean_type_node
, first_len_val
,
1427 gfc_trans_runtime_check
1428 (true, false, cond
, &se
->pre
, &expr
->where
,
1429 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1430 fold_convert (long_integer_type_node
, first_len_val
),
1431 fold_convert (long_integer_type_node
, se
->string_length
));
1437 /* TODO: Should the frontend already have done this conversion? */
1438 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1439 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1442 gfc_add_block_to_block (pblock
, &se
->pre
);
1443 gfc_add_block_to_block (pblock
, &se
->post
);
1447 /* Add the contents of an array to the constructor. DYNAMIC is as for
1448 gfc_trans_array_constructor_value. */
1451 gfc_trans_array_constructor_subarray (stmtblock_t
* pblock
,
1452 tree type ATTRIBUTE_UNUSED
,
1453 tree desc
, gfc_expr
* expr
,
1454 tree
* poffset
, tree
* offsetvar
,
1465 /* We need this to be a variable so we can increment it. */
1466 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1468 gfc_init_se (&se
, NULL
);
1470 /* Walk the array expression. */
1471 ss
= gfc_walk_expr (expr
);
1472 gcc_assert (ss
!= gfc_ss_terminator
);
1474 /* Initialize the scalarizer. */
1475 gfc_init_loopinfo (&loop
);
1476 gfc_add_ss_to_loop (&loop
, ss
);
1478 /* Initialize the loop. */
1479 gfc_conv_ss_startstride (&loop
);
1480 gfc_conv_loop_setup (&loop
, &expr
->where
);
1482 /* Make sure the constructed array has room for the new data. */
1485 /* Set SIZE to the total number of elements in the subarray. */
1486 size
= gfc_index_one_node
;
1487 for (n
= 0; n
< loop
.dimen
; n
++)
1489 tmp
= gfc_get_iteration_count (loop
.from
[n
], loop
.to
[n
],
1490 gfc_index_one_node
);
1491 size
= fold_build2_loc (input_location
, MULT_EXPR
,
1492 gfc_array_index_type
, size
, tmp
);
1495 /* Grow the constructed array by SIZE elements. */
1496 gfc_grow_array (&loop
.pre
, desc
, size
);
1499 /* Make the loop body. */
1500 gfc_mark_ss_chain_used (ss
, 1);
1501 gfc_start_scalarized_body (&loop
, &body
);
1502 gfc_copy_loopinfo_to_se (&se
, &loop
);
1505 gfc_trans_array_ctor_element (&body
, desc
, *poffset
, &se
, expr
);
1506 gcc_assert (se
.ss
== gfc_ss_terminator
);
1508 /* Increment the offset. */
1509 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1510 *poffset
, gfc_index_one_node
);
1511 gfc_add_modify (&body
, *poffset
, tmp
);
1513 /* Finish the loop. */
1514 gfc_trans_scalarizing_loops (&loop
, &body
);
1515 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
1516 tmp
= gfc_finish_block (&loop
.pre
);
1517 gfc_add_expr_to_block (pblock
, tmp
);
1519 gfc_cleanup_loop (&loop
);
1523 /* Assign the values to the elements of an array constructor. DYNAMIC
1524 is true if descriptor DESC only contains enough data for the static
1525 size calculated by gfc_get_array_constructor_size. When true, memory
1526 for the dynamic parts must be allocated using realloc. */
1529 gfc_trans_array_constructor_value (stmtblock_t
* pblock
, tree type
,
1530 tree desc
, gfc_constructor_base base
,
1531 tree
* poffset
, tree
* offsetvar
,
1535 tree start
= NULL_TREE
;
1536 tree end
= NULL_TREE
;
1537 tree step
= NULL_TREE
;
1543 tree shadow_loopvar
= NULL_TREE
;
1544 gfc_saved_var saved_loopvar
;
1547 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1549 /* If this is an iterator or an array, the offset must be a variable. */
1550 if ((c
->iterator
|| c
->expr
->rank
> 0) && INTEGER_CST_P (*poffset
))
1551 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1553 /* Shadowing the iterator avoids changing its value and saves us from
1554 keeping track of it. Further, it makes sure that there's always a
1555 backend-decl for the symbol, even if there wasn't one before,
1556 e.g. in the case of an iterator that appears in a specification
1557 expression in an interface mapping. */
1563 /* Evaluate loop bounds before substituting the loop variable
1564 in case they depend on it. Such a case is invalid, but it is
1565 not more expensive to do the right thing here.
1567 gfc_init_se (&se
, NULL
);
1568 gfc_conv_expr_val (&se
, c
->iterator
->start
);
1569 gfc_add_block_to_block (pblock
, &se
.pre
);
1570 start
= gfc_evaluate_now (se
.expr
, pblock
);
1572 gfc_init_se (&se
, NULL
);
1573 gfc_conv_expr_val (&se
, c
->iterator
->end
);
1574 gfc_add_block_to_block (pblock
, &se
.pre
);
1575 end
= gfc_evaluate_now (se
.expr
, pblock
);
1577 gfc_init_se (&se
, NULL
);
1578 gfc_conv_expr_val (&se
, c
->iterator
->step
);
1579 gfc_add_block_to_block (pblock
, &se
.pre
);
1580 step
= gfc_evaluate_now (se
.expr
, pblock
);
1582 sym
= c
->iterator
->var
->symtree
->n
.sym
;
1583 type
= gfc_typenode_for_spec (&sym
->ts
);
1585 shadow_loopvar
= gfc_create_var (type
, "shadow_loopvar");
1586 gfc_shadow_sym (sym
, shadow_loopvar
, &saved_loopvar
);
1589 gfc_start_block (&body
);
1591 if (c
->expr
->expr_type
== EXPR_ARRAY
)
1593 /* Array constructors can be nested. */
1594 gfc_trans_array_constructor_value (&body
, type
, desc
,
1595 c
->expr
->value
.constructor
,
1596 poffset
, offsetvar
, dynamic
);
1598 else if (c
->expr
->rank
> 0)
1600 gfc_trans_array_constructor_subarray (&body
, type
, desc
, c
->expr
,
1601 poffset
, offsetvar
, dynamic
);
1605 /* This code really upsets the gimplifier so don't bother for now. */
1612 while (p
&& !(p
->iterator
|| p
->expr
->expr_type
!= EXPR_CONSTANT
))
1614 p
= gfc_constructor_next (p
);
1619 /* Scalar values. */
1620 gfc_init_se (&se
, NULL
);
1621 gfc_trans_array_ctor_element (&body
, desc
, *poffset
,
1624 *poffset
= fold_build2_loc (input_location
, PLUS_EXPR
,
1625 gfc_array_index_type
,
1626 *poffset
, gfc_index_one_node
);
1630 /* Collect multiple scalar constants into a constructor. */
1631 vec
<constructor_elt
, va_gc
> *v
= NULL
;
1635 HOST_WIDE_INT idx
= 0;
1638 /* Count the number of consecutive scalar constants. */
1639 while (p
&& !(p
->iterator
1640 || p
->expr
->expr_type
!= EXPR_CONSTANT
))
1642 gfc_init_se (&se
, NULL
);
1643 gfc_conv_constant (&se
, p
->expr
);
1645 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
1646 se
.expr
= fold_convert (type
, se
.expr
);
1647 /* For constant character array constructors we build
1648 an array of pointers. */
1649 else if (POINTER_TYPE_P (type
))
1650 se
.expr
= gfc_build_addr_expr
1651 (gfc_get_pchar_type (p
->expr
->ts
.kind
),
1654 CONSTRUCTOR_APPEND_ELT (v
,
1655 build_int_cst (gfc_array_index_type
,
1659 p
= gfc_constructor_next (p
);
1662 bound
= size_int (n
- 1);
1663 /* Create an array type to hold them. */
1664 tmptype
= build_range_type (gfc_array_index_type
,
1665 gfc_index_zero_node
, bound
);
1666 tmptype
= build_array_type (type
, tmptype
);
1668 init
= build_constructor (tmptype
, v
);
1669 TREE_CONSTANT (init
) = 1;
1670 TREE_STATIC (init
) = 1;
1671 /* Create a static variable to hold the data. */
1672 tmp
= gfc_create_var (tmptype
, "data");
1673 TREE_STATIC (tmp
) = 1;
1674 TREE_CONSTANT (tmp
) = 1;
1675 TREE_READONLY (tmp
) = 1;
1676 DECL_INITIAL (tmp
) = init
;
1679 /* Use BUILTIN_MEMCPY to assign the values. */
1680 tmp
= gfc_conv_descriptor_data_get (desc
);
1681 tmp
= build_fold_indirect_ref_loc (input_location
,
1683 tmp
= gfc_build_array_ref (tmp
, *poffset
, NULL
);
1684 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1685 init
= gfc_build_addr_expr (NULL_TREE
, init
);
1687 size
= TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type
));
1688 bound
= build_int_cst (size_type_node
, n
* size
);
1689 tmp
= build_call_expr_loc (input_location
,
1690 builtin_decl_explicit (BUILT_IN_MEMCPY
),
1691 3, tmp
, init
, bound
);
1692 gfc_add_expr_to_block (&body
, tmp
);
1694 *poffset
= fold_build2_loc (input_location
, PLUS_EXPR
,
1695 gfc_array_index_type
, *poffset
,
1696 build_int_cst (gfc_array_index_type
, n
));
1698 if (!INTEGER_CST_P (*poffset
))
1700 gfc_add_modify (&body
, *offsetvar
, *poffset
);
1701 *poffset
= *offsetvar
;
1705 /* The frontend should already have done any expansions
1709 /* Pass the code as is. */
1710 tmp
= gfc_finish_block (&body
);
1711 gfc_add_expr_to_block (pblock
, tmp
);
1715 /* Build the implied do-loop. */
1716 stmtblock_t implied_do_block
;
1722 loopbody
= gfc_finish_block (&body
);
1724 /* Create a new block that holds the implied-do loop. A temporary
1725 loop-variable is used. */
1726 gfc_start_block(&implied_do_block
);
1728 /* Initialize the loop. */
1729 gfc_add_modify (&implied_do_block
, shadow_loopvar
, start
);
1731 /* If this array expands dynamically, and the number of iterations
1732 is not constant, we won't have allocated space for the static
1733 part of C->EXPR's size. Do that now. */
1734 if (dynamic
&& gfc_iterator_has_dynamic_bounds (c
->iterator
))
1736 /* Get the number of iterations. */
1737 tmp
= gfc_get_iteration_count (shadow_loopvar
, end
, step
);
1739 /* Get the static part of C->EXPR's size. */
1740 gfc_get_array_constructor_element_size (&size
, c
->expr
);
1741 tmp2
= gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
1743 /* Grow the array by TMP * TMP2 elements. */
1744 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
1745 gfc_array_index_type
, tmp
, tmp2
);
1746 gfc_grow_array (&implied_do_block
, desc
, tmp
);
1749 /* Generate the loop body. */
1750 exit_label
= gfc_build_label_decl (NULL_TREE
);
1751 gfc_start_block (&body
);
1753 /* Generate the exit condition. Depending on the sign of
1754 the step variable we have to generate the correct
1756 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1757 step
, build_int_cst (TREE_TYPE (step
), 0));
1758 cond
= fold_build3_loc (input_location
, COND_EXPR
,
1759 boolean_type_node
, tmp
,
1760 fold_build2_loc (input_location
, GT_EXPR
,
1761 boolean_type_node
, shadow_loopvar
, end
),
1762 fold_build2_loc (input_location
, LT_EXPR
,
1763 boolean_type_node
, shadow_loopvar
, end
));
1764 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1765 TREE_USED (exit_label
) = 1;
1766 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
1767 build_empty_stmt (input_location
));
1768 gfc_add_expr_to_block (&body
, tmp
);
1770 /* The main loop body. */
1771 gfc_add_expr_to_block (&body
, loopbody
);
1773 /* Increase loop variable by step. */
1774 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1775 TREE_TYPE (shadow_loopvar
), shadow_loopvar
,
1777 gfc_add_modify (&body
, shadow_loopvar
, tmp
);
1779 /* Finish the loop. */
1780 tmp
= gfc_finish_block (&body
);
1781 tmp
= build1_v (LOOP_EXPR
, tmp
);
1782 gfc_add_expr_to_block (&implied_do_block
, tmp
);
1784 /* Add the exit label. */
1785 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1786 gfc_add_expr_to_block (&implied_do_block
, tmp
);
1788 /* Finish the implied-do loop. */
1789 tmp
= gfc_finish_block(&implied_do_block
);
1790 gfc_add_expr_to_block(pblock
, tmp
);
1792 gfc_restore_sym (c
->iterator
->var
->symtree
->n
.sym
, &saved_loopvar
);
1799 /* A catch-all to obtain the string length for anything that is not
1800 a substring of non-constant length, a constant, array or variable. */
1803 get_array_ctor_all_strlen (stmtblock_t
*block
, gfc_expr
*e
, tree
*len
)
1807 /* Don't bother if we already know the length is a constant. */
1808 if (*len
&& INTEGER_CST_P (*len
))
1811 if (!e
->ref
&& e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
1812 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1815 gfc_conv_const_charlen (e
->ts
.u
.cl
);
1816 *len
= e
->ts
.u
.cl
->backend_decl
;
1820 /* Otherwise, be brutal even if inefficient. */
1821 gfc_init_se (&se
, NULL
);
1823 /* No function call, in case of side effects. */
1824 se
.no_function_call
= 1;
1826 gfc_conv_expr (&se
, e
);
1828 gfc_conv_expr_descriptor (&se
, e
);
1830 /* Fix the value. */
1831 *len
= gfc_evaluate_now (se
.string_length
, &se
.pre
);
1833 gfc_add_block_to_block (block
, &se
.pre
);
1834 gfc_add_block_to_block (block
, &se
.post
);
1836 e
->ts
.u
.cl
->backend_decl
= *len
;
1841 /* Figure out the string length of a variable reference expression.
1842 Used by get_array_ctor_strlen. */
1845 get_array_ctor_var_strlen (stmtblock_t
*block
, gfc_expr
* expr
, tree
* len
)
1851 /* Don't bother if we already know the length is a constant. */
1852 if (*len
&& INTEGER_CST_P (*len
))
1855 ts
= &expr
->symtree
->n
.sym
->ts
;
1856 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1861 /* Array references don't change the string length. */
1865 /* Use the length of the component. */
1866 ts
= &ref
->u
.c
.component
->ts
;
1870 if (ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1871 || ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1873 /* Note that this might evaluate expr. */
1874 get_array_ctor_all_strlen (block
, expr
, len
);
1877 mpz_init_set_ui (char_len
, 1);
1878 mpz_add (char_len
, char_len
, ref
->u
.ss
.end
->value
.integer
);
1879 mpz_sub (char_len
, char_len
, ref
->u
.ss
.start
->value
.integer
);
1880 *len
= gfc_conv_mpz_to_tree (char_len
, gfc_default_integer_kind
);
1881 *len
= convert (gfc_charlen_type_node
, *len
);
1882 mpz_clear (char_len
);
1890 *len
= ts
->u
.cl
->backend_decl
;
1894 /* Figure out the string length of a character array constructor.
1895 If len is NULL, don't calculate the length; this happens for recursive calls
1896 when a sub-array-constructor is an element but not at the first position,
1897 so when we're not interested in the length.
1898 Returns TRUE if all elements are character constants. */
1901 get_array_ctor_strlen (stmtblock_t
*block
, gfc_constructor_base base
, tree
* len
)
1908 if (gfc_constructor_first (base
) == NULL
)
1911 *len
= build_int_cstu (gfc_charlen_type_node
, 0);
1915 /* Loop over all constructor elements to find out is_const, but in len we
1916 want to store the length of the first, not the last, element. We can
1917 of course exit the loop as soon as is_const is found to be false. */
1918 for (c
= gfc_constructor_first (base
);
1919 c
&& is_const
; c
= gfc_constructor_next (c
))
1921 switch (c
->expr
->expr_type
)
1924 if (len
&& !(*len
&& INTEGER_CST_P (*len
)))
1925 *len
= build_int_cstu (gfc_charlen_type_node
,
1926 c
->expr
->value
.character
.length
);
1930 if (!get_array_ctor_strlen (block
, c
->expr
->value
.constructor
, len
))
1937 get_array_ctor_var_strlen (block
, c
->expr
, len
);
1943 get_array_ctor_all_strlen (block
, c
->expr
, len
);
1947 /* After the first iteration, we don't want the length modified. */
1954 /* Check whether the array constructor C consists entirely of constant
1955 elements, and if so returns the number of those elements, otherwise
1956 return zero. Note, an empty or NULL array constructor returns zero. */
1958 unsigned HOST_WIDE_INT
1959 gfc_constant_array_constructor_p (gfc_constructor_base base
)
1961 unsigned HOST_WIDE_INT nelem
= 0;
1963 gfc_constructor
*c
= gfc_constructor_first (base
);
1967 || c
->expr
->rank
> 0
1968 || c
->expr
->expr_type
!= EXPR_CONSTANT
)
1970 c
= gfc_constructor_next (c
);
1977 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1978 and the tree type of it's elements, TYPE, return a static constant
1979 variable that is compile-time initialized. */
1982 gfc_build_constant_array_constructor (gfc_expr
* expr
, tree type
)
1984 tree tmptype
, init
, tmp
;
1985 HOST_WIDE_INT nelem
;
1990 vec
<constructor_elt
, va_gc
> *v
= NULL
;
1992 /* First traverse the constructor list, converting the constants
1993 to tree to build an initializer. */
1995 c
= gfc_constructor_first (expr
->value
.constructor
);
1998 gfc_init_se (&se
, NULL
);
1999 gfc_conv_constant (&se
, c
->expr
);
2000 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
2001 se
.expr
= fold_convert (type
, se
.expr
);
2002 else if (POINTER_TYPE_P (type
))
2003 se
.expr
= gfc_build_addr_expr (gfc_get_pchar_type (c
->expr
->ts
.kind
),
2005 CONSTRUCTOR_APPEND_ELT (v
, build_int_cst (gfc_array_index_type
, nelem
),
2007 c
= gfc_constructor_next (c
);
2011 /* Next determine the tree type for the array. We use the gfortran
2012 front-end's gfc_get_nodesc_array_type in order to create a suitable
2013 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
2015 memset (&as
, 0, sizeof (gfc_array_spec
));
2017 as
.rank
= expr
->rank
;
2018 as
.type
= AS_EXPLICIT
;
2021 as
.lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2022 as
.upper
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
2026 for (i
= 0; i
< expr
->rank
; i
++)
2028 int tmp
= (int) mpz_get_si (expr
->shape
[i
]);
2029 as
.lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2030 as
.upper
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
2034 tmptype
= gfc_get_nodesc_array_type (type
, &as
, PACKED_STATIC
, true);
2036 /* as is not needed anymore. */
2037 for (i
= 0; i
< as
.rank
+ as
.corank
; i
++)
2039 gfc_free_expr (as
.lower
[i
]);
2040 gfc_free_expr (as
.upper
[i
]);
2043 init
= build_constructor (tmptype
, v
);
2045 TREE_CONSTANT (init
) = 1;
2046 TREE_STATIC (init
) = 1;
2048 tmp
= gfc_create_var (tmptype
, "A");
2049 TREE_STATIC (tmp
) = 1;
2050 TREE_CONSTANT (tmp
) = 1;
2051 TREE_READONLY (tmp
) = 1;
2052 DECL_INITIAL (tmp
) = init
;
2058 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
2059 This mostly initializes the scalarizer state info structure with the
2060 appropriate values to directly use the array created by the function
2061 gfc_build_constant_array_constructor. */
2064 trans_constant_array_constructor (gfc_ss
* ss
, tree type
)
2066 gfc_array_info
*info
;
2070 tmp
= gfc_build_constant_array_constructor (ss
->info
->expr
, type
);
2072 info
= &ss
->info
->data
.array
;
2074 info
->descriptor
= tmp
;
2075 info
->data
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2076 info
->offset
= gfc_index_zero_node
;
2078 for (i
= 0; i
< ss
->dimen
; i
++)
2080 info
->delta
[i
] = gfc_index_zero_node
;
2081 info
->start
[i
] = gfc_index_zero_node
;
2082 info
->end
[i
] = gfc_index_zero_node
;
2083 info
->stride
[i
] = gfc_index_one_node
;
2089 get_rank (gfc_loopinfo
*loop
)
2094 for (; loop
; loop
= loop
->parent
)
2095 rank
+= loop
->dimen
;
2101 /* Helper routine of gfc_trans_array_constructor to determine if the
2102 bounds of the loop specified by LOOP are constant and simple enough
2103 to use with trans_constant_array_constructor. Returns the
2104 iteration count of the loop if suitable, and NULL_TREE otherwise. */
2107 constant_array_constructor_loop_size (gfc_loopinfo
* l
)
2110 tree size
= gfc_index_one_node
;
2114 total_dim
= get_rank (l
);
2116 for (loop
= l
; loop
; loop
= loop
->parent
)
2118 for (i
= 0; i
< loop
->dimen
; i
++)
2120 /* If the bounds aren't constant, return NULL_TREE. */
2121 if (!INTEGER_CST_P (loop
->from
[i
]) || !INTEGER_CST_P (loop
->to
[i
]))
2123 if (!integer_zerop (loop
->from
[i
]))
2125 /* Only allow nonzero "from" in one-dimensional arrays. */
2128 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2129 gfc_array_index_type
,
2130 loop
->to
[i
], loop
->from
[i
]);
2134 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2135 gfc_array_index_type
, tmp
, gfc_index_one_node
);
2136 size
= fold_build2_loc (input_location
, MULT_EXPR
,
2137 gfc_array_index_type
, size
, tmp
);
2146 get_loop_upper_bound_for_array (gfc_ss
*array
, int array_dim
)
2151 gcc_assert (array
->nested_ss
== NULL
);
2153 for (ss
= array
; ss
; ss
= ss
->parent
)
2154 for (n
= 0; n
< ss
->loop
->dimen
; n
++)
2155 if (array_dim
== get_array_ref_dim_for_loop_dim (ss
, n
))
2156 return &(ss
->loop
->to
[n
]);
2162 static gfc_loopinfo
*
2163 outermost_loop (gfc_loopinfo
* loop
)
2165 while (loop
->parent
!= NULL
)
2166 loop
= loop
->parent
;
2172 /* Array constructors are handled by constructing a temporary, then using that
2173 within the scalarization loop. This is not optimal, but seems by far the
2177 trans_array_constructor (gfc_ss
* ss
, locus
* where
)
2179 gfc_constructor_base c
;
2187 bool old_first_len
, old_typespec_chararray_ctor
;
2188 tree old_first_len_val
;
2189 gfc_loopinfo
*loop
, *outer_loop
;
2190 gfc_ss_info
*ss_info
;
2194 /* Save the old values for nested checking. */
2195 old_first_len
= first_len
;
2196 old_first_len_val
= first_len_val
;
2197 old_typespec_chararray_ctor
= typespec_chararray_ctor
;
2200 outer_loop
= outermost_loop (loop
);
2202 expr
= ss_info
->expr
;
2204 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
2205 typespec was given for the array constructor. */
2206 typespec_chararray_ctor
= (expr
->ts
.u
.cl
2207 && expr
->ts
.u
.cl
->length_from_typespec
);
2209 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2210 && expr
->ts
.type
== BT_CHARACTER
&& !typespec_chararray_ctor
)
2212 first_len_val
= gfc_create_var (gfc_charlen_type_node
, "len");
2216 gcc_assert (ss
->dimen
== ss
->loop
->dimen
);
2218 c
= expr
->value
.constructor
;
2219 if (expr
->ts
.type
== BT_CHARACTER
)
2223 /* get_array_ctor_strlen walks the elements of the constructor, if a
2224 typespec was given, we already know the string length and want the one
2226 if (typespec_chararray_ctor
&& expr
->ts
.u
.cl
->length
2227 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
2231 const_string
= false;
2232 gfc_init_se (&length_se
, NULL
);
2233 gfc_conv_expr_type (&length_se
, expr
->ts
.u
.cl
->length
,
2234 gfc_charlen_type_node
);
2235 ss_info
->string_length
= length_se
.expr
;
2236 gfc_add_block_to_block (&outer_loop
->pre
, &length_se
.pre
);
2237 gfc_add_block_to_block (&outer_loop
->post
, &length_se
.post
);
2240 const_string
= get_array_ctor_strlen (&outer_loop
->pre
, c
,
2241 &ss_info
->string_length
);
2243 /* Complex character array constructors should have been taken care of
2244 and not end up here. */
2245 gcc_assert (ss_info
->string_length
);
2247 expr
->ts
.u
.cl
->backend_decl
= ss_info
->string_length
;
2249 type
= gfc_get_character_type_len (expr
->ts
.kind
, ss_info
->string_length
);
2251 type
= build_pointer_type (type
);
2254 type
= gfc_typenode_for_spec (&expr
->ts
);
2256 /* See if the constructor determines the loop bounds. */
2259 loop_ubound0
= get_loop_upper_bound_for_array (ss
, 0);
2261 if (expr
->shape
&& get_rank (loop
) > 1 && *loop_ubound0
== NULL_TREE
)
2263 /* We have a multidimensional parameter. */
2264 for (s
= ss
; s
; s
= s
->parent
)
2267 for (n
= 0; n
< s
->loop
->dimen
; n
++)
2269 s
->loop
->from
[n
] = gfc_index_zero_node
;
2270 s
->loop
->to
[n
] = gfc_conv_mpz_to_tree (expr
->shape
[s
->dim
[n
]],
2271 gfc_index_integer_kind
);
2272 s
->loop
->to
[n
] = fold_build2_loc (input_location
, MINUS_EXPR
,
2273 gfc_array_index_type
,
2275 gfc_index_one_node
);
2280 if (*loop_ubound0
== NULL_TREE
)
2284 /* We should have a 1-dimensional, zero-based loop. */
2285 gcc_assert (loop
->parent
== NULL
&& loop
->nested
== NULL
);
2286 gcc_assert (loop
->dimen
== 1);
2287 gcc_assert (integer_zerop (loop
->from
[0]));
2289 /* Split the constructor size into a static part and a dynamic part.
2290 Allocate the static size up-front and record whether the dynamic
2291 size might be nonzero. */
2293 dynamic
= gfc_get_array_constructor_size (&size
, c
);
2294 mpz_sub_ui (size
, size
, 1);
2295 loop
->to
[0] = gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
2299 /* Special case constant array constructors. */
2302 unsigned HOST_WIDE_INT nelem
= gfc_constant_array_constructor_p (c
);
2305 tree size
= constant_array_constructor_loop_size (loop
);
2306 if (size
&& compare_tree_int (size
, nelem
) == 0)
2308 trans_constant_array_constructor (ss
, type
);
2314 gfc_trans_create_temp_array (&outer_loop
->pre
, &outer_loop
->post
, ss
, type
,
2315 NULL_TREE
, dynamic
, true, false, where
);
2317 desc
= ss_info
->data
.array
.descriptor
;
2318 offset
= gfc_index_zero_node
;
2319 offsetvar
= gfc_create_var_np (gfc_array_index_type
, "offset");
2320 TREE_NO_WARNING (offsetvar
) = 1;
2321 TREE_USED (offsetvar
) = 0;
2322 gfc_trans_array_constructor_value (&outer_loop
->pre
, type
, desc
, c
,
2323 &offset
, &offsetvar
, dynamic
);
2325 /* If the array grows dynamically, the upper bound of the loop variable
2326 is determined by the array's final upper bound. */
2329 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2330 gfc_array_index_type
,
2331 offsetvar
, gfc_index_one_node
);
2332 tmp
= gfc_evaluate_now (tmp
, &outer_loop
->pre
);
2333 gfc_conv_descriptor_ubound_set (&loop
->pre
, desc
, gfc_rank_cst
[0], tmp
);
2334 if (*loop_ubound0
&& TREE_CODE (*loop_ubound0
) == VAR_DECL
)
2335 gfc_add_modify (&outer_loop
->pre
, *loop_ubound0
, tmp
);
2337 *loop_ubound0
= tmp
;
2340 if (TREE_USED (offsetvar
))
2341 pushdecl (offsetvar
);
2343 gcc_assert (INTEGER_CST_P (offset
));
2346 /* Disable bound checking for now because it's probably broken. */
2347 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2354 /* Restore old values of globals. */
2355 first_len
= old_first_len
;
2356 first_len_val
= old_first_len_val
;
2357 typespec_chararray_ctor
= old_typespec_chararray_ctor
;
2361 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
2362 called after evaluating all of INFO's vector dimensions. Go through
2363 each such vector dimension and see if we can now fill in any missing
2367 set_vector_loop_bounds (gfc_ss
* ss
)
2369 gfc_loopinfo
*loop
, *outer_loop
;
2370 gfc_array_info
*info
;
2378 outer_loop
= outermost_loop (ss
->loop
);
2380 info
= &ss
->info
->data
.array
;
2382 for (; ss
; ss
= ss
->parent
)
2386 for (n
= 0; n
< loop
->dimen
; n
++)
2389 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_VECTOR
2390 || loop
->to
[n
] != NULL
)
2393 /* Loop variable N indexes vector dimension DIM, and we don't
2394 yet know the upper bound of loop variable N. Set it to the
2395 difference between the vector's upper and lower bounds. */
2396 gcc_assert (loop
->from
[n
] == gfc_index_zero_node
);
2397 gcc_assert (info
->subscript
[dim
]
2398 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
2400 gfc_init_se (&se
, NULL
);
2401 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
2402 zero
= gfc_rank_cst
[0];
2403 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2404 gfc_array_index_type
,
2405 gfc_conv_descriptor_ubound_get (desc
, zero
),
2406 gfc_conv_descriptor_lbound_get (desc
, zero
));
2407 tmp
= gfc_evaluate_now (tmp
, &outer_loop
->pre
);
2414 /* Add the pre and post chains for all the scalar expressions in a SS chain
2415 to loop. This is called after the loop parameters have been calculated,
2416 but before the actual scalarizing loops. */
2419 gfc_add_loop_ss_code (gfc_loopinfo
* loop
, gfc_ss
* ss
, bool subscript
,
2422 gfc_loopinfo
*nested_loop
, *outer_loop
;
2424 gfc_ss_info
*ss_info
;
2425 gfc_array_info
*info
;
2429 /* Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise,
2430 arguments could get evaluated multiple times. */
2431 if (ss
->is_alloc_lhs
)
2434 outer_loop
= outermost_loop (loop
);
2436 /* TODO: This can generate bad code if there are ordering dependencies,
2437 e.g., a callee allocated function and an unknown size constructor. */
2438 gcc_assert (ss
!= NULL
);
2440 for (; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2444 /* Cross loop arrays are handled from within the most nested loop. */
2445 if (ss
->nested_ss
!= NULL
)
2449 expr
= ss_info
->expr
;
2450 info
= &ss_info
->data
.array
;
2452 switch (ss_info
->type
)
2455 /* Scalar expression. Evaluate this now. This includes elemental
2456 dimension indices, but not array section bounds. */
2457 gfc_init_se (&se
, NULL
);
2458 gfc_conv_expr (&se
, expr
);
2459 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2461 if (expr
->ts
.type
!= BT_CHARACTER
)
2463 /* Move the evaluation of scalar expressions outside the
2464 scalarization loop, except for WHERE assignments. */
2466 se
.expr
= convert(gfc_array_index_type
, se
.expr
);
2467 if (!ss_info
->where
)
2468 se
.expr
= gfc_evaluate_now (se
.expr
, &outer_loop
->pre
);
2469 gfc_add_block_to_block (&outer_loop
->pre
, &se
.post
);
2472 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2474 ss_info
->data
.scalar
.value
= se
.expr
;
2475 ss_info
->string_length
= se
.string_length
;
2478 case GFC_SS_REFERENCE
:
2479 /* Scalar argument to elemental procedure. */
2480 gfc_init_se (&se
, NULL
);
2481 if (ss_info
->can_be_null_ref
)
2483 /* If the actual argument can be absent (in other words, it can
2484 be a NULL reference), don't try to evaluate it; pass instead
2485 the reference directly. */
2486 gfc_conv_expr_reference (&se
, expr
);
2490 /* Otherwise, evaluate the argument outside the loop and pass
2491 a reference to the value. */
2492 gfc_conv_expr (&se
, expr
);
2495 /* Ensure that a pointer to the string is stored. */
2496 if (expr
->ts
.type
== BT_CHARACTER
)
2497 gfc_conv_string_parameter (&se
);
2499 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2500 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2501 if (gfc_is_class_scalar_expr (expr
))
2502 /* This is necessary because the dynamic type will always be
2503 large than the declared type. In consequence, assigning
2504 the value to a temporary could segfault.
2505 OOP-TODO: see if this is generally correct or is the value
2506 has to be written to an allocated temporary, whose address
2507 is passed via ss_info. */
2508 ss_info
->data
.scalar
.value
= se
.expr
;
2510 ss_info
->data
.scalar
.value
= gfc_evaluate_now (se
.expr
,
2513 ss_info
->string_length
= se
.string_length
;
2516 case GFC_SS_SECTION
:
2517 /* Add the expressions for scalar and vector subscripts. */
2518 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2519 if (info
->subscript
[n
])
2520 gfc_add_loop_ss_code (loop
, info
->subscript
[n
], true, where
);
2522 set_vector_loop_bounds (ss
);
2526 /* Get the vector's descriptor and store it in SS. */
2527 gfc_init_se (&se
, NULL
);
2528 gfc_conv_expr_descriptor (&se
, expr
);
2529 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2530 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2531 info
->descriptor
= se
.expr
;
2534 case GFC_SS_INTRINSIC
:
2535 gfc_add_intrinsic_ss_code (loop
, ss
);
2538 case GFC_SS_FUNCTION
:
2539 /* Array function return value. We call the function and save its
2540 result in a temporary for use inside the loop. */
2541 gfc_init_se (&se
, NULL
);
2544 gfc_conv_expr (&se
, expr
);
2545 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2546 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2547 ss_info
->string_length
= se
.string_length
;
2550 case GFC_SS_CONSTRUCTOR
:
2551 if (expr
->ts
.type
== BT_CHARACTER
2552 && ss_info
->string_length
== NULL
2554 && expr
->ts
.u
.cl
->length
)
2556 gfc_init_se (&se
, NULL
);
2557 gfc_conv_expr_type (&se
, expr
->ts
.u
.cl
->length
,
2558 gfc_charlen_type_node
);
2559 ss_info
->string_length
= se
.expr
;
2560 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2561 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2563 trans_array_constructor (ss
, where
);
2567 case GFC_SS_COMPONENT
:
2568 /* Do nothing. These are handled elsewhere. */
2577 for (nested_loop
= loop
->nested
; nested_loop
;
2578 nested_loop
= nested_loop
->next
)
2579 gfc_add_loop_ss_code (nested_loop
, nested_loop
->ss
, subscript
, where
);
2583 /* Translate expressions for the descriptor and data pointer of a SS. */
2587 gfc_conv_ss_descriptor (stmtblock_t
* block
, gfc_ss
* ss
, int base
)
2590 gfc_ss_info
*ss_info
;
2591 gfc_array_info
*info
;
2595 info
= &ss_info
->data
.array
;
2597 /* Get the descriptor for the array to be scalarized. */
2598 gcc_assert (ss_info
->expr
->expr_type
== EXPR_VARIABLE
);
2599 gfc_init_se (&se
, NULL
);
2600 se
.descriptor_only
= 1;
2601 gfc_conv_expr_lhs (&se
, ss_info
->expr
);
2602 gfc_add_block_to_block (block
, &se
.pre
);
2603 info
->descriptor
= se
.expr
;
2604 ss_info
->string_length
= se
.string_length
;
2608 /* Also the data pointer. */
2609 tmp
= gfc_conv_array_data (se
.expr
);
2610 /* If this is a variable or address of a variable we use it directly.
2611 Otherwise we must evaluate it now to avoid breaking dependency
2612 analysis by pulling the expressions for elemental array indices
2615 || (TREE_CODE (tmp
) == ADDR_EXPR
2616 && DECL_P (TREE_OPERAND (tmp
, 0)))))
2617 tmp
= gfc_evaluate_now (tmp
, block
);
2620 tmp
= gfc_conv_array_offset (se
.expr
);
2621 info
->offset
= gfc_evaluate_now (tmp
, block
);
2623 /* Make absolutely sure that the saved_offset is indeed saved
2624 so that the variable is still accessible after the loops
2626 info
->saved_offset
= info
->offset
;
2631 /* Initialize a gfc_loopinfo structure. */
2634 gfc_init_loopinfo (gfc_loopinfo
* loop
)
2638 memset (loop
, 0, sizeof (gfc_loopinfo
));
2639 gfc_init_block (&loop
->pre
);
2640 gfc_init_block (&loop
->post
);
2642 /* Initially scalarize in order and default to no loop reversal. */
2643 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2646 loop
->reverse
[n
] = GFC_INHIBIT_REVERSE
;
2649 loop
->ss
= gfc_ss_terminator
;
2653 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2657 gfc_copy_loopinfo_to_se (gfc_se
* se
, gfc_loopinfo
* loop
)
2663 /* Return an expression for the data pointer of an array. */
2666 gfc_conv_array_data (tree descriptor
)
2670 type
= TREE_TYPE (descriptor
);
2671 if (GFC_ARRAY_TYPE_P (type
))
2673 if (TREE_CODE (type
) == POINTER_TYPE
)
2677 /* Descriptorless arrays. */
2678 return gfc_build_addr_expr (NULL_TREE
, descriptor
);
2682 return gfc_conv_descriptor_data_get (descriptor
);
2686 /* Return an expression for the base offset of an array. */
2689 gfc_conv_array_offset (tree descriptor
)
2693 type
= TREE_TYPE (descriptor
);
2694 if (GFC_ARRAY_TYPE_P (type
))
2695 return GFC_TYPE_ARRAY_OFFSET (type
);
2697 return gfc_conv_descriptor_offset_get (descriptor
);
2701 /* Get an expression for the array stride. */
2704 gfc_conv_array_stride (tree descriptor
, int dim
)
2709 type
= TREE_TYPE (descriptor
);
2711 /* For descriptorless arrays use the array size. */
2712 tmp
= GFC_TYPE_ARRAY_STRIDE (type
, dim
);
2713 if (tmp
!= NULL_TREE
)
2716 tmp
= gfc_conv_descriptor_stride_get (descriptor
, gfc_rank_cst
[dim
]);
2721 /* Like gfc_conv_array_stride, but for the lower bound. */
2724 gfc_conv_array_lbound (tree descriptor
, int dim
)
2729 type
= TREE_TYPE (descriptor
);
2731 tmp
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
2732 if (tmp
!= NULL_TREE
)
2735 tmp
= gfc_conv_descriptor_lbound_get (descriptor
, gfc_rank_cst
[dim
]);
2740 /* Like gfc_conv_array_stride, but for the upper bound. */
2743 gfc_conv_array_ubound (tree descriptor
, int dim
)
2748 type
= TREE_TYPE (descriptor
);
2750 tmp
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
2751 if (tmp
!= NULL_TREE
)
2754 /* This should only ever happen when passing an assumed shape array
2755 as an actual parameter. The value will never be used. */
2756 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor
)))
2757 return gfc_index_zero_node
;
2759 tmp
= gfc_conv_descriptor_ubound_get (descriptor
, gfc_rank_cst
[dim
]);
2764 /* Generate code to perform an array index bound check. */
2767 trans_array_bound_check (gfc_se
* se
, gfc_ss
*ss
, tree index
, int n
,
2768 locus
* where
, bool check_upper
)
2771 tree tmp_lo
, tmp_up
;
2774 const char * name
= NULL
;
2776 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
2779 descriptor
= ss
->info
->data
.array
.descriptor
;
2781 index
= gfc_evaluate_now (index
, &se
->pre
);
2783 /* We find a name for the error message. */
2784 name
= ss
->info
->expr
->symtree
->n
.sym
->name
;
2785 gcc_assert (name
!= NULL
);
2787 if (TREE_CODE (descriptor
) == VAR_DECL
)
2788 name
= IDENTIFIER_POINTER (DECL_NAME (descriptor
));
2790 /* If upper bound is present, include both bounds in the error message. */
2793 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
2794 tmp_up
= gfc_conv_array_ubound (descriptor
, n
);
2797 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
2798 "outside of expected range (%%ld:%%ld)", n
+1, name
);
2800 asprintf (&msg
, "Index '%%ld' of dimension %d "
2801 "outside of expected range (%%ld:%%ld)", n
+1);
2803 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2805 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2806 fold_convert (long_integer_type_node
, index
),
2807 fold_convert (long_integer_type_node
, tmp_lo
),
2808 fold_convert (long_integer_type_node
, tmp_up
));
2809 fault
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2811 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2812 fold_convert (long_integer_type_node
, index
),
2813 fold_convert (long_integer_type_node
, tmp_lo
),
2814 fold_convert (long_integer_type_node
, tmp_up
));
2819 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
2822 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
2823 "below lower bound of %%ld", n
+1, name
);
2825 asprintf (&msg
, "Index '%%ld' of dimension %d "
2826 "below lower bound of %%ld", n
+1);
2828 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2830 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2831 fold_convert (long_integer_type_node
, index
),
2832 fold_convert (long_integer_type_node
, tmp_lo
));
2840 /* Return the offset for an index. Performs bound checking for elemental
2841 dimensions. Single element references are processed separately.
2842 DIM is the array dimension, I is the loop dimension. */
2845 conv_array_index_offset (gfc_se
* se
, gfc_ss
* ss
, int dim
, int i
,
2846 gfc_array_ref
* ar
, tree stride
)
2848 gfc_array_info
*info
;
2853 info
= &ss
->info
->data
.array
;
2855 /* Get the index into the array for this dimension. */
2858 gcc_assert (ar
->type
!= AR_ELEMENT
);
2859 switch (ar
->dimen_type
[dim
])
2861 case DIMEN_THIS_IMAGE
:
2865 /* Elemental dimension. */
2866 gcc_assert (info
->subscript
[dim
]
2867 && info
->subscript
[dim
]->info
->type
== GFC_SS_SCALAR
);
2868 /* We've already translated this value outside the loop. */
2869 index
= info
->subscript
[dim
]->info
->data
.scalar
.value
;
2871 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
2872 ar
->as
->type
!= AS_ASSUMED_SIZE
2873 || dim
< ar
->dimen
- 1);
2877 gcc_assert (info
&& se
->loop
);
2878 gcc_assert (info
->subscript
[dim
]
2879 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
2880 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
2882 /* Get a zero-based index into the vector. */
2883 index
= fold_build2_loc (input_location
, MINUS_EXPR
,
2884 gfc_array_index_type
,
2885 se
->loop
->loopvar
[i
], se
->loop
->from
[i
]);
2887 /* Multiply the index by the stride. */
2888 index
= fold_build2_loc (input_location
, MULT_EXPR
,
2889 gfc_array_index_type
,
2890 index
, gfc_conv_array_stride (desc
, 0));
2892 /* Read the vector to get an index into info->descriptor. */
2893 data
= build_fold_indirect_ref_loc (input_location
,
2894 gfc_conv_array_data (desc
));
2895 index
= gfc_build_array_ref (data
, index
, NULL
);
2896 index
= gfc_evaluate_now (index
, &se
->pre
);
2897 index
= fold_convert (gfc_array_index_type
, index
);
2899 /* Do any bounds checking on the final info->descriptor index. */
2900 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
2901 ar
->as
->type
!= AS_ASSUMED_SIZE
2902 || dim
< ar
->dimen
- 1);
2906 /* Scalarized dimension. */
2907 gcc_assert (info
&& se
->loop
);
2909 /* Multiply the loop variable by the stride and delta. */
2910 index
= se
->loop
->loopvar
[i
];
2911 if (!integer_onep (info
->stride
[dim
]))
2912 index
= fold_build2_loc (input_location
, MULT_EXPR
,
2913 gfc_array_index_type
, index
,
2915 if (!integer_zerop (info
->delta
[dim
]))
2916 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
2917 gfc_array_index_type
, index
,
2927 /* Temporary array or derived type component. */
2928 gcc_assert (se
->loop
);
2929 index
= se
->loop
->loopvar
[se
->loop
->order
[i
]];
2931 /* Pointer functions can have stride[0] different from unity.
2932 Use the stride returned by the function call and stored in
2933 the descriptor for the temporary. */
2934 if (se
->ss
&& se
->ss
->info
->type
== GFC_SS_FUNCTION
2935 && se
->ss
->info
->expr
2936 && se
->ss
->info
->expr
->symtree
2937 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
2938 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
->attr
.pointer
)
2939 stride
= gfc_conv_descriptor_stride_get (info
->descriptor
,
2942 if (!integer_zerop (info
->delta
[dim
]))
2943 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
2944 gfc_array_index_type
, index
, info
->delta
[dim
]);
2947 /* Multiply by the stride. */
2948 if (!integer_onep (stride
))
2949 index
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
2956 /* Build a scalarized array reference using the vptr 'size'. */
2959 build_class_array_ref (gfc_se
*se
, tree base
, tree index
)
2966 gfc_expr
*expr
= se
->ss
->info
->expr
;
2971 if (expr
== NULL
|| expr
->ts
.type
!= BT_CLASS
)
2974 if (expr
->symtree
&& expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
2975 ts
= &expr
->symtree
->n
.sym
->ts
;
2980 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2982 if (ref
->type
== REF_COMPONENT
2983 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
2984 && ref
->next
&& ref
->next
->type
== REF_COMPONENT
2985 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0
2987 && ref
->next
->next
->type
== REF_ARRAY
2988 && ref
->next
->next
->u
.ar
.type
!= AR_ELEMENT
)
2990 ts
= &ref
->u
.c
.component
->ts
;
2999 if (class_ref
== NULL
&& expr
->symtree
->n
.sym
->attr
.function
3000 && expr
->symtree
->n
.sym
== expr
->symtree
->n
.sym
->result
)
3002 gcc_assert (expr
->symtree
->n
.sym
->backend_decl
== current_function_decl
);
3003 decl
= gfc_get_fake_result_decl (expr
->symtree
->n
.sym
, 0);
3005 else if (class_ref
== NULL
)
3006 decl
= expr
->symtree
->n
.sym
->backend_decl
;
3009 /* Remove everything after the last class reference, convert the
3010 expression and then recover its tailend once more. */
3012 ref
= class_ref
->next
;
3013 class_ref
->next
= NULL
;
3014 gfc_init_se (&tmpse
, NULL
);
3015 gfc_conv_expr (&tmpse
, expr
);
3017 class_ref
->next
= ref
;
3020 size
= gfc_vtable_size_get (decl
);
3022 /* Build the address of the element. */
3023 type
= TREE_TYPE (TREE_TYPE (base
));
3024 size
= fold_convert (TREE_TYPE (index
), size
);
3025 offset
= fold_build2_loc (input_location
, MULT_EXPR
,
3026 gfc_array_index_type
,
3028 tmp
= gfc_build_addr_expr (pvoid_type_node
, base
);
3029 tmp
= fold_build_pointer_plus_loc (input_location
, tmp
, offset
);
3030 tmp
= fold_convert (build_pointer_type (type
), tmp
);
3032 /* Return the element in the se expression. */
3033 se
->expr
= build_fold_indirect_ref_loc (input_location
, tmp
);
3038 /* Build a scalarized reference to an array. */
3041 gfc_conv_scalarized_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
3043 gfc_array_info
*info
;
3044 tree decl
= NULL_TREE
;
3052 expr
= ss
->info
->expr
;
3053 info
= &ss
->info
->data
.array
;
3055 n
= se
->loop
->order
[0];
3059 index
= conv_array_index_offset (se
, ss
, ss
->dim
[n
], n
, ar
, info
->stride0
);
3060 /* Add the offset for this dimension to the stored offset for all other
3062 if (!integer_zerop (info
->offset
))
3063 index
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3064 index
, info
->offset
);
3066 if (expr
&& is_subref_array (expr
))
3067 decl
= expr
->symtree
->n
.sym
->backend_decl
;
3069 tmp
= build_fold_indirect_ref_loc (input_location
, info
->data
);
3071 /* Use the vptr 'size' field to access a class the element of a class
3073 if (build_class_array_ref (se
, tmp
, index
))
3076 se
->expr
= gfc_build_array_ref (tmp
, index
, decl
);
3080 /* Translate access of temporary array. */
3083 gfc_conv_tmp_array_ref (gfc_se
* se
)
3085 se
->string_length
= se
->ss
->info
->string_length
;
3086 gfc_conv_scalarized_array_ref (se
, NULL
);
3087 gfc_advance_se_ss_chain (se
);
3090 /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
3093 add_to_offset (tree
*cst_offset
, tree
*offset
, tree t
)
3095 if (TREE_CODE (t
) == INTEGER_CST
)
3096 *cst_offset
= int_const_binop (PLUS_EXPR
, *cst_offset
, t
);
3099 if (!integer_zerop (*offset
))
3100 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3101 gfc_array_index_type
, *offset
, t
);
3109 build_array_ref (tree desc
, tree offset
, tree decl
)
3114 /* Class container types do not always have the GFC_CLASS_TYPE_P
3115 but the canonical type does. */
3116 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
3117 && TREE_CODE (desc
) == COMPONENT_REF
)
3119 type
= TREE_TYPE (TREE_OPERAND (desc
, 0));
3120 if (TYPE_CANONICAL (type
)
3121 && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type
)))
3122 type
= TYPE_CANONICAL (type
);
3127 /* Class array references need special treatment because the assigned
3128 type size needs to be used to point to the element. */
3129 if (type
&& GFC_CLASS_TYPE_P (type
))
3131 type
= gfc_get_element_type (TREE_TYPE (desc
));
3132 tmp
= TREE_OPERAND (desc
, 0);
3133 tmp
= gfc_get_class_array_ref (offset
, tmp
);
3134 tmp
= fold_convert (build_pointer_type (type
), tmp
);
3135 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3139 tmp
= gfc_conv_array_data (desc
);
3140 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3141 tmp
= gfc_build_array_ref (tmp
, offset
, decl
);
3146 /* Build an array reference. se->expr already holds the array descriptor.
3147 This should be either a variable, indirect variable reference or component
3148 reference. For arrays which do not have a descriptor, se->expr will be
3150 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
3153 gfc_conv_array_ref (gfc_se
* se
, gfc_array_ref
* ar
, gfc_expr
*expr
,
3157 tree offset
, cst_offset
;
3162 gfc_symbol
* sym
= expr
->symtree
->n
.sym
;
3163 char *var_name
= NULL
;
3167 gcc_assert (ar
->codimen
);
3169 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
->expr
)))
3170 se
->expr
= build_fold_indirect_ref (gfc_conv_array_data (se
->expr
));
3173 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se
->expr
))
3174 && TREE_CODE (TREE_TYPE (se
->expr
)) == POINTER_TYPE
)
3175 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3177 /* Use the actual tree type and not the wrapped coarray. */
3178 if (!se
->want_pointer
)
3179 se
->expr
= fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se
->expr
)),
3186 /* Handle scalarized references separately. */
3187 if (ar
->type
!= AR_ELEMENT
)
3189 gfc_conv_scalarized_array_ref (se
, ar
);
3190 gfc_advance_se_ss_chain (se
);
3194 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3199 len
= strlen (sym
->name
) + 1;
3200 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3202 if (ref
->type
== REF_ARRAY
&& &ref
->u
.ar
== ar
)
3204 if (ref
->type
== REF_COMPONENT
)
3205 len
+= 1 + strlen (ref
->u
.c
.component
->name
);
3208 var_name
= XALLOCAVEC (char, len
);
3209 strcpy (var_name
, sym
->name
);
3211 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3213 if (ref
->type
== REF_ARRAY
&& &ref
->u
.ar
== ar
)
3215 if (ref
->type
== REF_COMPONENT
)
3217 strcat (var_name
, "%%");
3218 strcat (var_name
, ref
->u
.c
.component
->name
);
3223 cst_offset
= offset
= gfc_index_zero_node
;
3224 add_to_offset (&cst_offset
, &offset
, gfc_conv_array_offset (se
->expr
));
3226 /* Calculate the offsets from all the dimensions. Make sure to associate
3227 the final offset so that we form a chain of loop invariant summands. */
3228 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
3230 /* Calculate the index for this dimension. */
3231 gfc_init_se (&indexse
, se
);
3232 gfc_conv_expr_type (&indexse
, ar
->start
[n
], gfc_array_index_type
);
3233 gfc_add_block_to_block (&se
->pre
, &indexse
.pre
);
3235 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3237 /* Check array bounds. */
3241 /* Evaluate the indexse.expr only once. */
3242 indexse
.expr
= save_expr (indexse
.expr
);
3245 tmp
= gfc_conv_array_lbound (se
->expr
, n
);
3246 if (sym
->attr
.temporary
)
3248 gfc_init_se (&tmpse
, se
);
3249 gfc_conv_expr_type (&tmpse
, ar
->as
->lower
[n
],
3250 gfc_array_index_type
);
3251 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3255 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
3257 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
3258 "below lower bound of %%ld", n
+1, var_name
);
3259 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3260 fold_convert (long_integer_type_node
,
3262 fold_convert (long_integer_type_node
, tmp
));
3265 /* Upper bound, but not for the last dimension of assumed-size
3267 if (n
< ar
->dimen
- 1 || ar
->as
->type
!= AS_ASSUMED_SIZE
)
3269 tmp
= gfc_conv_array_ubound (se
->expr
, n
);
3270 if (sym
->attr
.temporary
)
3272 gfc_init_se (&tmpse
, se
);
3273 gfc_conv_expr_type (&tmpse
, ar
->as
->upper
[n
],
3274 gfc_array_index_type
);
3275 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3279 cond
= fold_build2_loc (input_location
, GT_EXPR
,
3280 boolean_type_node
, indexse
.expr
, tmp
);
3281 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
3282 "above upper bound of %%ld", n
+1, var_name
);
3283 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3284 fold_convert (long_integer_type_node
,
3286 fold_convert (long_integer_type_node
, tmp
));
3291 /* Multiply the index by the stride. */
3292 stride
= gfc_conv_array_stride (se
->expr
, n
);
3293 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3294 indexse
.expr
, stride
);
3296 /* And add it to the total. */
3297 add_to_offset (&cst_offset
, &offset
, tmp
);
3300 if (!integer_zerop (cst_offset
))
3301 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3302 gfc_array_index_type
, offset
, cst_offset
);
3304 se
->expr
= build_array_ref (se
->expr
, offset
, sym
->backend_decl
);
3308 /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
3309 LOOP_DIM dimension (if any) to array's offset. */
3312 add_array_offset (stmtblock_t
*pblock
, gfc_loopinfo
*loop
, gfc_ss
*ss
,
3313 gfc_array_ref
*ar
, int array_dim
, int loop_dim
)
3316 gfc_array_info
*info
;
3319 info
= &ss
->info
->data
.array
;
3321 gfc_init_se (&se
, NULL
);
3323 se
.expr
= info
->descriptor
;
3324 stride
= gfc_conv_array_stride (info
->descriptor
, array_dim
);
3325 index
= conv_array_index_offset (&se
, ss
, array_dim
, loop_dim
, ar
, stride
);
3326 gfc_add_block_to_block (pblock
, &se
.pre
);
3328 info
->offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3329 gfc_array_index_type
,
3330 info
->offset
, index
);
3331 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
3335 /* Generate the code to be executed immediately before entering a
3336 scalarization loop. */
3339 gfc_trans_preloop_setup (gfc_loopinfo
* loop
, int dim
, int flag
,
3340 stmtblock_t
* pblock
)
3343 gfc_ss_info
*ss_info
;
3344 gfc_array_info
*info
;
3345 gfc_ss_type ss_type
;
3347 gfc_loopinfo
*ploop
;
3351 /* This code will be executed before entering the scalarization loop
3352 for this dimension. */
3353 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3357 if ((ss_info
->useflags
& flag
) == 0)
3360 ss_type
= ss_info
->type
;
3361 if (ss_type
!= GFC_SS_SECTION
3362 && ss_type
!= GFC_SS_FUNCTION
3363 && ss_type
!= GFC_SS_CONSTRUCTOR
3364 && ss_type
!= GFC_SS_COMPONENT
)
3367 info
= &ss_info
->data
.array
;
3369 gcc_assert (dim
< ss
->dimen
);
3370 gcc_assert (ss
->dimen
== loop
->dimen
);
3373 ar
= &info
->ref
->u
.ar
;
3377 if (dim
== loop
->dimen
- 1 && loop
->parent
!= NULL
)
3379 /* If we are in the outermost dimension of this loop, the previous
3380 dimension shall be in the parent loop. */
3381 gcc_assert (ss
->parent
!= NULL
);
3384 ploop
= loop
->parent
;
3386 /* ss and ss->parent are about the same array. */
3387 gcc_assert (ss_info
== pss
->info
);
3395 if (dim
== loop
->dimen
- 1)
3400 /* For the time being, there is no loop reordering. */
3401 gcc_assert (i
== ploop
->order
[i
]);
3402 i
= ploop
->order
[i
];
3404 if (dim
== loop
->dimen
- 1 && loop
->parent
== NULL
)
3406 stride
= gfc_conv_array_stride (info
->descriptor
,
3407 innermost_ss (ss
)->dim
[i
]);
3409 /* Calculate the stride of the innermost loop. Hopefully this will
3410 allow the backend optimizers to do their stuff more effectively.
3412 info
->stride0
= gfc_evaluate_now (stride
, pblock
);
3414 /* For the outermost loop calculate the offset due to any
3415 elemental dimensions. It will have been initialized with the
3416 base offset of the array. */
3419 for (i
= 0; i
< ar
->dimen
; i
++)
3421 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
3424 add_array_offset (pblock
, loop
, ss
, ar
, i
, /* unused */ -1);
3429 /* Add the offset for the previous loop dimension. */
3430 add_array_offset (pblock
, ploop
, ss
, ar
, pss
->dim
[i
], i
);
3432 /* Remember this offset for the second loop. */
3433 if (dim
== loop
->temp_dim
- 1 && loop
->parent
== NULL
)
3434 info
->saved_offset
= info
->offset
;
3439 /* Start a scalarized expression. Creates a scope and declares loop
3443 gfc_start_scalarized_body (gfc_loopinfo
* loop
, stmtblock_t
* pbody
)
3449 gcc_assert (!loop
->array_parameter
);
3451 for (dim
= loop
->dimen
- 1; dim
>= 0; dim
--)
3453 n
= loop
->order
[dim
];
3455 gfc_start_block (&loop
->code
[n
]);
3457 /* Create the loop variable. */
3458 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "S");
3460 if (dim
< loop
->temp_dim
)
3464 /* Calculate values that will be constant within this loop. */
3465 gfc_trans_preloop_setup (loop
, dim
, flags
, &loop
->code
[n
]);
3467 gfc_start_block (pbody
);
3471 /* Generates the actual loop code for a scalarization loop. */
3474 gfc_trans_scalarized_loop_end (gfc_loopinfo
* loop
, int n
,
3475 stmtblock_t
* pbody
)
3486 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
))
3487 == (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
)
3488 && n
== loop
->dimen
- 1)
3490 /* We create an OMP_FOR construct for the outermost scalarized loop. */
3491 init
= make_tree_vec (1);
3492 cond
= make_tree_vec (1);
3493 incr
= make_tree_vec (1);
3495 /* Cycle statement is implemented with a goto. Exit statement must not
3496 be present for this loop. */
3497 exit_label
= gfc_build_label_decl (NULL_TREE
);
3498 TREE_USED (exit_label
) = 1;
3500 /* Label for cycle statements (if needed). */
3501 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3502 gfc_add_expr_to_block (pbody
, tmp
);
3504 stmt
= make_node (OMP_FOR
);
3506 TREE_TYPE (stmt
) = void_type_node
;
3507 OMP_FOR_BODY (stmt
) = loopbody
= gfc_finish_block (pbody
);
3509 OMP_FOR_CLAUSES (stmt
) = build_omp_clause (input_location
,
3510 OMP_CLAUSE_SCHEDULE
);
3511 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt
))
3512 = OMP_CLAUSE_SCHEDULE_STATIC
;
3513 if (ompws_flags
& OMPWS_NOWAIT
)
3514 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt
))
3515 = build_omp_clause (input_location
, OMP_CLAUSE_NOWAIT
);
3517 /* Initialize the loopvar. */
3518 TREE_VEC_ELT (init
, 0) = build2_v (MODIFY_EXPR
, loop
->loopvar
[n
],
3520 OMP_FOR_INIT (stmt
) = init
;
3521 /* The exit condition. */
3522 TREE_VEC_ELT (cond
, 0) = build2_loc (input_location
, LE_EXPR
,
3524 loop
->loopvar
[n
], loop
->to
[n
]);
3525 SET_EXPR_LOCATION (TREE_VEC_ELT (cond
, 0), input_location
);
3526 OMP_FOR_COND (stmt
) = cond
;
3527 /* Increment the loopvar. */
3528 tmp
= build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3529 loop
->loopvar
[n
], gfc_index_one_node
);
3530 TREE_VEC_ELT (incr
, 0) = fold_build2_loc (input_location
, MODIFY_EXPR
,
3531 void_type_node
, loop
->loopvar
[n
], tmp
);
3532 OMP_FOR_INCR (stmt
) = incr
;
3534 ompws_flags
&= ~OMPWS_CURR_SINGLEUNIT
;
3535 gfc_add_expr_to_block (&loop
->code
[n
], stmt
);
3539 bool reverse_loop
= (loop
->reverse
[n
] == GFC_REVERSE_SET
)
3540 && (loop
->temp_ss
== NULL
);
3542 loopbody
= gfc_finish_block (pbody
);
3546 tmp
= loop
->from
[n
];
3547 loop
->from
[n
] = loop
->to
[n
];
3551 /* Initialize the loopvar. */
3552 if (loop
->loopvar
[n
] != loop
->from
[n
])
3553 gfc_add_modify (&loop
->code
[n
], loop
->loopvar
[n
], loop
->from
[n
]);
3555 exit_label
= gfc_build_label_decl (NULL_TREE
);
3557 /* Generate the loop body. */
3558 gfc_init_block (&block
);
3560 /* The exit condition. */
3561 cond
= fold_build2_loc (input_location
, reverse_loop
? LT_EXPR
: GT_EXPR
,
3562 boolean_type_node
, loop
->loopvar
[n
], loop
->to
[n
]);
3563 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3564 TREE_USED (exit_label
) = 1;
3565 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3566 gfc_add_expr_to_block (&block
, tmp
);
3568 /* The main body. */
3569 gfc_add_expr_to_block (&block
, loopbody
);
3571 /* Increment the loopvar. */
3572 tmp
= fold_build2_loc (input_location
,
3573 reverse_loop
? MINUS_EXPR
: PLUS_EXPR
,
3574 gfc_array_index_type
, loop
->loopvar
[n
],
3575 gfc_index_one_node
);
3577 gfc_add_modify (&block
, loop
->loopvar
[n
], tmp
);
3579 /* Build the loop. */
3580 tmp
= gfc_finish_block (&block
);
3581 tmp
= build1_v (LOOP_EXPR
, tmp
);
3582 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
3584 /* Add the exit label. */
3585 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3586 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
3592 /* Finishes and generates the loops for a scalarized expression. */
3595 gfc_trans_scalarizing_loops (gfc_loopinfo
* loop
, stmtblock_t
* body
)
3600 stmtblock_t
*pblock
;
3604 /* Generate the loops. */
3605 for (dim
= 0; dim
< loop
->dimen
; dim
++)
3607 n
= loop
->order
[dim
];
3608 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
3609 loop
->loopvar
[n
] = NULL_TREE
;
3610 pblock
= &loop
->code
[n
];
3613 tmp
= gfc_finish_block (pblock
);
3614 gfc_add_expr_to_block (&loop
->pre
, tmp
);
3616 /* Clear all the used flags. */
3617 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3618 if (ss
->parent
== NULL
)
3619 ss
->info
->useflags
= 0;
3623 /* Finish the main body of a scalarized expression, and start the secondary
3627 gfc_trans_scalarized_loop_boundary (gfc_loopinfo
* loop
, stmtblock_t
* body
)
3631 stmtblock_t
*pblock
;
3635 /* We finish as many loops as are used by the temporary. */
3636 for (dim
= 0; dim
< loop
->temp_dim
- 1; dim
++)
3638 n
= loop
->order
[dim
];
3639 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
3640 loop
->loopvar
[n
] = NULL_TREE
;
3641 pblock
= &loop
->code
[n
];
3644 /* We don't want to finish the outermost loop entirely. */
3645 n
= loop
->order
[loop
->temp_dim
- 1];
3646 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
3648 /* Restore the initial offsets. */
3649 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3651 gfc_ss_type ss_type
;
3652 gfc_ss_info
*ss_info
;
3656 if ((ss_info
->useflags
& 2) == 0)
3659 ss_type
= ss_info
->type
;
3660 if (ss_type
!= GFC_SS_SECTION
3661 && ss_type
!= GFC_SS_FUNCTION
3662 && ss_type
!= GFC_SS_CONSTRUCTOR
3663 && ss_type
!= GFC_SS_COMPONENT
)
3666 ss_info
->data
.array
.offset
= ss_info
->data
.array
.saved_offset
;
3669 /* Restart all the inner loops we just finished. */
3670 for (dim
= loop
->temp_dim
- 2; dim
>= 0; dim
--)
3672 n
= loop
->order
[dim
];
3674 gfc_start_block (&loop
->code
[n
]);
3676 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "Q");
3678 gfc_trans_preloop_setup (loop
, dim
, 2, &loop
->code
[n
]);
3681 /* Start a block for the secondary copying code. */
3682 gfc_start_block (body
);
3686 /* Precalculate (either lower or upper) bound of an array section.
3687 BLOCK: Block in which the (pre)calculation code will go.
3688 BOUNDS[DIM]: Where the bound value will be stored once evaluated.
3689 VALUES[DIM]: Specified bound (NULL <=> unspecified).
3690 DESC: Array descriptor from which the bound will be picked if unspecified
3691 (either lower or upper bound according to LBOUND). */
3694 evaluate_bound (stmtblock_t
*block
, tree
*bounds
, gfc_expr
** values
,
3695 tree desc
, int dim
, bool lbound
)
3698 gfc_expr
* input_val
= values
[dim
];
3699 tree
*output
= &bounds
[dim
];
3704 /* Specified section bound. */
3705 gfc_init_se (&se
, NULL
);
3706 gfc_conv_expr_type (&se
, input_val
, gfc_array_index_type
);
3707 gfc_add_block_to_block (block
, &se
.pre
);
3712 /* No specific bound specified so use the bound of the array. */
3713 *output
= lbound
? gfc_conv_array_lbound (desc
, dim
) :
3714 gfc_conv_array_ubound (desc
, dim
);
3716 *output
= gfc_evaluate_now (*output
, block
);
3720 /* Calculate the lower bound of an array section. */
3723 gfc_conv_section_startstride (stmtblock_t
* block
, gfc_ss
* ss
, int dim
)
3725 gfc_expr
*stride
= NULL
;
3728 gfc_array_info
*info
;
3731 gcc_assert (ss
->info
->type
== GFC_SS_SECTION
);
3733 info
= &ss
->info
->data
.array
;
3734 ar
= &info
->ref
->u
.ar
;
3736 if (ar
->dimen_type
[dim
] == DIMEN_VECTOR
)
3738 /* We use a zero-based index to access the vector. */
3739 info
->start
[dim
] = gfc_index_zero_node
;
3740 info
->end
[dim
] = NULL
;
3741 info
->stride
[dim
] = gfc_index_one_node
;
3745 gcc_assert (ar
->dimen_type
[dim
] == DIMEN_RANGE
3746 || ar
->dimen_type
[dim
] == DIMEN_THIS_IMAGE
);
3747 desc
= info
->descriptor
;
3748 stride
= ar
->stride
[dim
];
3750 /* Calculate the start of the range. For vector subscripts this will
3751 be the range of the vector. */
3752 evaluate_bound (block
, info
->start
, ar
->start
, desc
, dim
, true);
3754 /* Similarly calculate the end. Although this is not used in the
3755 scalarizer, it is needed when checking bounds and where the end
3756 is an expression with side-effects. */
3757 evaluate_bound (block
, info
->end
, ar
->end
, desc
, dim
, false);
3759 /* Calculate the stride. */
3761 info
->stride
[dim
] = gfc_index_one_node
;
3764 gfc_init_se (&se
, NULL
);
3765 gfc_conv_expr_type (&se
, stride
, gfc_array_index_type
);
3766 gfc_add_block_to_block (block
, &se
.pre
);
3767 info
->stride
[dim
] = gfc_evaluate_now (se
.expr
, block
);
3772 /* Calculates the range start and stride for a SS chain. Also gets the
3773 descriptor and data pointer. The range of vector subscripts is the size
3774 of the vector. Array bounds are also checked. */
3777 gfc_conv_ss_startstride (gfc_loopinfo
* loop
)
3784 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
3787 /* Determine the rank of the loop. */
3788 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3790 switch (ss
->info
->type
)
3792 case GFC_SS_SECTION
:
3793 case GFC_SS_CONSTRUCTOR
:
3794 case GFC_SS_FUNCTION
:
3795 case GFC_SS_COMPONENT
:
3796 loop
->dimen
= ss
->dimen
;
3799 /* As usual, lbound and ubound are exceptions!. */
3800 case GFC_SS_INTRINSIC
:
3801 switch (ss
->info
->expr
->value
.function
.isym
->id
)
3803 case GFC_ISYM_LBOUND
:
3804 case GFC_ISYM_UBOUND
:
3805 case GFC_ISYM_LCOBOUND
:
3806 case GFC_ISYM_UCOBOUND
:
3807 case GFC_ISYM_THIS_IMAGE
:
3808 loop
->dimen
= ss
->dimen
;
3820 /* We should have determined the rank of the expression by now. If
3821 not, that's bad news. */
3825 /* Loop over all the SS in the chain. */
3826 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3828 gfc_ss_info
*ss_info
;
3829 gfc_array_info
*info
;
3833 expr
= ss_info
->expr
;
3834 info
= &ss_info
->data
.array
;
3836 if (expr
&& expr
->shape
&& !info
->shape
)
3837 info
->shape
= expr
->shape
;
3839 switch (ss_info
->type
)
3841 case GFC_SS_SECTION
:
3842 /* Get the descriptor for the array. If it is a cross loops array,
3843 we got the descriptor already in the outermost loop. */
3844 if (ss
->parent
== NULL
)
3845 gfc_conv_ss_descriptor (&outer_loop
->pre
, ss
,
3846 !loop
->array_parameter
);
3848 for (n
= 0; n
< ss
->dimen
; n
++)
3849 gfc_conv_section_startstride (&outer_loop
->pre
, ss
, ss
->dim
[n
]);
3852 case GFC_SS_INTRINSIC
:
3853 switch (expr
->value
.function
.isym
->id
)
3855 /* Fall through to supply start and stride. */
3856 case GFC_ISYM_LBOUND
:
3857 case GFC_ISYM_UBOUND
:
3861 /* This is the variant without DIM=... */
3862 gcc_assert (expr
->value
.function
.actual
->next
->expr
== NULL
);
3864 arg
= expr
->value
.function
.actual
->expr
;
3865 if (arg
->rank
== -1)
3870 /* The rank (hence the return value's shape) is unknown,
3871 we have to retrieve it. */
3872 gfc_init_se (&se
, NULL
);
3873 se
.descriptor_only
= 1;
3874 gfc_conv_expr (&se
, arg
);
3875 /* This is a bare variable, so there is no preliminary
3877 gcc_assert (se
.pre
.head
== NULL_TREE
3878 && se
.post
.head
== NULL_TREE
);
3879 rank
= gfc_conv_descriptor_rank (se
.expr
);
3880 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3881 gfc_array_index_type
,
3882 fold_convert (gfc_array_index_type
,
3884 gfc_index_one_node
);
3885 info
->end
[0] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
3886 info
->start
[0] = gfc_index_zero_node
;
3887 info
->stride
[0] = gfc_index_one_node
;
3890 /* Otherwise fall through GFC_SS_FUNCTION. */
3892 case GFC_ISYM_LCOBOUND
:
3893 case GFC_ISYM_UCOBOUND
:
3894 case GFC_ISYM_THIS_IMAGE
:
3901 case GFC_SS_CONSTRUCTOR
:
3902 case GFC_SS_FUNCTION
:
3903 for (n
= 0; n
< ss
->dimen
; n
++)
3905 int dim
= ss
->dim
[n
];
3907 info
->start
[dim
] = gfc_index_zero_node
;
3908 info
->end
[dim
] = gfc_index_zero_node
;
3909 info
->stride
[dim
] = gfc_index_one_node
;
3918 /* The rest is just runtime bound checking. */
3919 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3922 tree lbound
, ubound
;
3924 tree size
[GFC_MAX_DIMENSIONS
];
3925 tree stride_pos
, stride_neg
, non_zerosized
, tmp2
, tmp3
;
3926 gfc_array_info
*info
;
3930 gfc_start_block (&block
);
3932 for (n
= 0; n
< loop
->dimen
; n
++)
3933 size
[n
] = NULL_TREE
;
3935 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3938 gfc_ss_info
*ss_info
;
3941 const char *expr_name
;
3944 if (ss_info
->type
!= GFC_SS_SECTION
)
3947 /* Catch allocatable lhs in f2003. */
3948 if (gfc_option
.flag_realloc_lhs
&& ss
->is_alloc_lhs
)
3951 expr
= ss_info
->expr
;
3952 expr_loc
= &expr
->where
;
3953 expr_name
= expr
->symtree
->name
;
3955 gfc_start_block (&inner
);
3957 /* TODO: range checking for mapped dimensions. */
3958 info
= &ss_info
->data
.array
;
3960 /* This code only checks ranges. Elemental and vector
3961 dimensions are checked later. */
3962 for (n
= 0; n
< loop
->dimen
; n
++)
3967 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
3970 if (dim
== info
->ref
->u
.ar
.dimen
- 1
3971 && info
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
3972 check_upper
= false;
3976 /* Zero stride is not allowed. */
3977 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
3978 info
->stride
[dim
], gfc_index_zero_node
);
3979 asprintf (&msg
, "Zero stride is not allowed, for dimension %d "
3980 "of array '%s'", dim
+ 1, expr_name
);
3981 gfc_trans_runtime_check (true, false, tmp
, &inner
,
3985 desc
= info
->descriptor
;
3987 /* This is the run-time equivalent of resolve.c's
3988 check_dimension(). The logical is more readable there
3989 than it is here, with all the trees. */
3990 lbound
= gfc_conv_array_lbound (desc
, dim
);
3991 end
= info
->end
[dim
];
3993 ubound
= gfc_conv_array_ubound (desc
, dim
);
3997 /* non_zerosized is true when the selected range is not
3999 stride_pos
= fold_build2_loc (input_location
, GT_EXPR
,
4000 boolean_type_node
, info
->stride
[dim
],
4001 gfc_index_zero_node
);
4002 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
4003 info
->start
[dim
], end
);
4004 stride_pos
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4005 boolean_type_node
, stride_pos
, tmp
);
4007 stride_neg
= fold_build2_loc (input_location
, LT_EXPR
,
4009 info
->stride
[dim
], gfc_index_zero_node
);
4010 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
4011 info
->start
[dim
], end
);
4012 stride_neg
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4015 non_zerosized
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
4017 stride_pos
, stride_neg
);
4019 /* Check the start of the range against the lower and upper
4020 bounds of the array, if the range is not empty.
4021 If upper bound is present, include both bounds in the
4025 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
4027 info
->start
[dim
], lbound
);
4028 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4030 non_zerosized
, tmp
);
4031 tmp2
= fold_build2_loc (input_location
, GT_EXPR
,
4033 info
->start
[dim
], ubound
);
4034 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4036 non_zerosized
, tmp2
);
4037 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
4038 "outside of expected range (%%ld:%%ld)",
4039 dim
+ 1, expr_name
);
4040 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4042 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4043 fold_convert (long_integer_type_node
, lbound
),
4044 fold_convert (long_integer_type_node
, ubound
));
4045 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4047 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4048 fold_convert (long_integer_type_node
, lbound
),
4049 fold_convert (long_integer_type_node
, ubound
));
4054 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
4056 info
->start
[dim
], lbound
);
4057 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4058 boolean_type_node
, non_zerosized
, tmp
);
4059 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
4060 "below lower bound of %%ld",
4061 dim
+ 1, expr_name
);
4062 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4064 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4065 fold_convert (long_integer_type_node
, lbound
));
4069 /* Compute the last element of the range, which is not
4070 necessarily "end" (think 0:5:3, which doesn't contain 5)
4071 and check it against both lower and upper bounds. */
4073 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4074 gfc_array_index_type
, end
,
4076 tmp
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
,
4077 gfc_array_index_type
, tmp
,
4079 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4080 gfc_array_index_type
, end
, tmp
);
4081 tmp2
= fold_build2_loc (input_location
, LT_EXPR
,
4082 boolean_type_node
, tmp
, lbound
);
4083 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4084 boolean_type_node
, non_zerosized
, tmp2
);
4087 tmp3
= fold_build2_loc (input_location
, GT_EXPR
,
4088 boolean_type_node
, tmp
, ubound
);
4089 tmp3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4090 boolean_type_node
, non_zerosized
, tmp3
);
4091 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
4092 "outside of expected range (%%ld:%%ld)",
4093 dim
+ 1, expr_name
);
4094 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4096 fold_convert (long_integer_type_node
, tmp
),
4097 fold_convert (long_integer_type_node
, ubound
),
4098 fold_convert (long_integer_type_node
, lbound
));
4099 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4101 fold_convert (long_integer_type_node
, tmp
),
4102 fold_convert (long_integer_type_node
, ubound
),
4103 fold_convert (long_integer_type_node
, lbound
));
4108 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
4109 "below lower bound of %%ld",
4110 dim
+ 1, expr_name
);
4111 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4113 fold_convert (long_integer_type_node
, tmp
),
4114 fold_convert (long_integer_type_node
, lbound
));
4118 /* Check the section sizes match. */
4119 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4120 gfc_array_index_type
, end
,
4122 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
4123 gfc_array_index_type
, tmp
,
4125 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4126 gfc_array_index_type
,
4127 gfc_index_one_node
, tmp
);
4128 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
4129 gfc_array_index_type
, tmp
,
4130 build_int_cst (gfc_array_index_type
, 0));
4131 /* We remember the size of the first section, and check all the
4132 others against this. */
4135 tmp3
= fold_build2_loc (input_location
, NE_EXPR
,
4136 boolean_type_node
, tmp
, size
[n
]);
4137 asprintf (&msg
, "Array bound mismatch for dimension %d "
4138 "of array '%s' (%%ld/%%ld)",
4139 dim
+ 1, expr_name
);
4141 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4143 fold_convert (long_integer_type_node
, tmp
),
4144 fold_convert (long_integer_type_node
, size
[n
]));
4149 size
[n
] = gfc_evaluate_now (tmp
, &inner
);
4152 tmp
= gfc_finish_block (&inner
);
4154 /* For optional arguments, only check bounds if the argument is
4156 if (expr
->symtree
->n
.sym
->attr
.optional
4157 || expr
->symtree
->n
.sym
->attr
.not_always_present
)
4158 tmp
= build3_v (COND_EXPR
,
4159 gfc_conv_expr_present (expr
->symtree
->n
.sym
),
4160 tmp
, build_empty_stmt (input_location
));
4162 gfc_add_expr_to_block (&block
, tmp
);
4166 tmp
= gfc_finish_block (&block
);
4167 gfc_add_expr_to_block (&outer_loop
->pre
, tmp
);
4170 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4171 gfc_conv_ss_startstride (loop
);
4174 /* Return true if both symbols could refer to the same data object. Does
4175 not take account of aliasing due to equivalence statements. */
4178 symbols_could_alias (gfc_symbol
*lsym
, gfc_symbol
*rsym
, bool lsym_pointer
,
4179 bool lsym_target
, bool rsym_pointer
, bool rsym_target
)
4181 /* Aliasing isn't possible if the symbols have different base types. */
4182 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
4185 /* Pointers can point to other pointers and target objects. */
4187 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4188 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4191 /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
4192 and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
4194 if (lsym_target
&& rsym_target
4195 && ((lsym
->attr
.dummy
&& !lsym
->attr
.contiguous
4196 && (!lsym
->attr
.dimension
|| lsym
->as
->type
== AS_ASSUMED_SHAPE
))
4197 || (rsym
->attr
.dummy
&& !rsym
->attr
.contiguous
4198 && (!rsym
->attr
.dimension
4199 || rsym
->as
->type
== AS_ASSUMED_SHAPE
))))
4206 /* Return true if the two SS could be aliased, i.e. both point to the same data
4208 /* TODO: resolve aliases based on frontend expressions. */
4211 gfc_could_be_alias (gfc_ss
* lss
, gfc_ss
* rss
)
4215 gfc_expr
*lexpr
, *rexpr
;
4218 bool lsym_pointer
, lsym_target
, rsym_pointer
, rsym_target
;
4220 lexpr
= lss
->info
->expr
;
4221 rexpr
= rss
->info
->expr
;
4223 lsym
= lexpr
->symtree
->n
.sym
;
4224 rsym
= rexpr
->symtree
->n
.sym
;
4226 lsym_pointer
= lsym
->attr
.pointer
;
4227 lsym_target
= lsym
->attr
.target
;
4228 rsym_pointer
= rsym
->attr
.pointer
;
4229 rsym_target
= rsym
->attr
.target
;
4231 if (symbols_could_alias (lsym
, rsym
, lsym_pointer
, lsym_target
,
4232 rsym_pointer
, rsym_target
))
4235 if (rsym
->ts
.type
!= BT_DERIVED
&& rsym
->ts
.type
!= BT_CLASS
4236 && lsym
->ts
.type
!= BT_DERIVED
&& lsym
->ts
.type
!= BT_CLASS
)
4239 /* For derived types we must check all the component types. We can ignore
4240 array references as these will have the same base type as the previous
4242 for (lref
= lexpr
->ref
; lref
!= lss
->info
->data
.array
.ref
; lref
= lref
->next
)
4244 if (lref
->type
!= REF_COMPONENT
)
4247 lsym_pointer
= lsym_pointer
|| lref
->u
.c
.sym
->attr
.pointer
;
4248 lsym_target
= lsym_target
|| lref
->u
.c
.sym
->attr
.target
;
4250 if (symbols_could_alias (lref
->u
.c
.sym
, rsym
, lsym_pointer
, lsym_target
,
4251 rsym_pointer
, rsym_target
))
4254 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4255 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4257 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4262 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
;
4265 if (rref
->type
!= REF_COMPONENT
)
4268 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4269 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4271 if (symbols_could_alias (lref
->u
.c
.sym
, rref
->u
.c
.sym
,
4272 lsym_pointer
, lsym_target
,
4273 rsym_pointer
, rsym_target
))
4276 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4277 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4279 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4280 &rref
->u
.c
.sym
->ts
))
4282 if (gfc_compare_types (&lref
->u
.c
.sym
->ts
,
4283 &rref
->u
.c
.component
->ts
))
4285 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4286 &rref
->u
.c
.component
->ts
))
4292 lsym_pointer
= lsym
->attr
.pointer
;
4293 lsym_target
= lsym
->attr
.target
;
4294 lsym_pointer
= lsym
->attr
.pointer
;
4295 lsym_target
= lsym
->attr
.target
;
4297 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
; rref
= rref
->next
)
4299 if (rref
->type
!= REF_COMPONENT
)
4302 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4303 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4305 if (symbols_could_alias (rref
->u
.c
.sym
, lsym
,
4306 lsym_pointer
, lsym_target
,
4307 rsym_pointer
, rsym_target
))
4310 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4311 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4313 if (gfc_compare_types (&lsym
->ts
, &rref
->u
.c
.component
->ts
))
4322 /* Resolve array data dependencies. Creates a temporary if required. */
4323 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
4327 gfc_conv_resolve_dependencies (gfc_loopinfo
* loop
, gfc_ss
* dest
,
4333 gfc_expr
*dest_expr
;
4338 loop
->temp_ss
= NULL
;
4339 dest_expr
= dest
->info
->expr
;
4341 for (ss
= rss
; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
4343 ss_expr
= ss
->info
->expr
;
4345 if (ss
->info
->type
!= GFC_SS_SECTION
)
4347 if (gfc_option
.flag_realloc_lhs
4348 && dest_expr
!= ss_expr
4349 && gfc_is_reallocatable_lhs (dest_expr
)
4351 nDepend
= gfc_check_dependency (dest_expr
, ss_expr
, true);
4356 if (dest_expr
->symtree
->n
.sym
!= ss_expr
->symtree
->n
.sym
)
4358 if (gfc_could_be_alias (dest
, ss
)
4359 || gfc_are_equivalenced_arrays (dest_expr
, ss_expr
))
4367 lref
= dest_expr
->ref
;
4368 rref
= ss_expr
->ref
;
4370 nDepend
= gfc_dep_resolver (lref
, rref
, &loop
->reverse
[0]);
4375 for (i
= 0; i
< dest
->dimen
; i
++)
4376 for (j
= 0; j
< ss
->dimen
; j
++)
4378 && dest
->dim
[i
] == ss
->dim
[j
])
4380 /* If we don't access array elements in the same order,
4381 there is a dependency. */
4386 /* TODO : loop shifting. */
4389 /* Mark the dimensions for LOOP SHIFTING */
4390 for (n
= 0; n
< loop
->dimen
; n
++)
4392 int dim
= dest
->data
.info
.dim
[n
];
4394 if (lref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
4396 else if (! gfc_is_same_range (&lref
->u
.ar
,
4397 &rref
->u
.ar
, dim
, 0))
4401 /* Put all the dimensions with dependencies in the
4404 for (n
= 0; n
< loop
->dimen
; n
++)
4406 gcc_assert (loop
->order
[n
] == n
);
4408 loop
->order
[dim
++] = n
;
4410 for (n
= 0; n
< loop
->dimen
; n
++)
4413 loop
->order
[dim
++] = n
;
4416 gcc_assert (dim
== loop
->dimen
);
4427 tree base_type
= gfc_typenode_for_spec (&dest_expr
->ts
);
4428 if (GFC_ARRAY_TYPE_P (base_type
)
4429 || GFC_DESCRIPTOR_TYPE_P (base_type
))
4430 base_type
= gfc_get_element_type (base_type
);
4431 loop
->temp_ss
= gfc_get_temp_ss (base_type
, dest
->info
->string_length
,
4433 gfc_add_ss_to_loop (loop
, loop
->temp_ss
);
4436 loop
->temp_ss
= NULL
;
4440 /* Browse through each array's information from the scalarizer and set the loop
4441 bounds according to the "best" one (per dimension), i.e. the one which
4442 provides the most information (constant bounds, shape, etc.). */
4445 set_loop_bounds (gfc_loopinfo
*loop
)
4447 int n
, dim
, spec_dim
;
4448 gfc_array_info
*info
;
4449 gfc_array_info
*specinfo
;
4453 bool dynamic
[GFC_MAX_DIMENSIONS
];
4456 bool nonoptional_arr
;
4458 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
4460 loopspec
= loop
->specloop
;
4463 for (n
= 0; n
< loop
->dimen
; n
++)
4468 /* If there are both optional and nonoptional array arguments, scalarize
4469 over the nonoptional; otherwise, it does not matter as then all
4470 (optional) arrays have to be present per F2008, 125.2.12p3(6). */
4472 nonoptional_arr
= false;
4474 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4475 if (ss
->info
->type
!= GFC_SS_SCALAR
&& ss
->info
->type
!= GFC_SS_TEMP
4476 && ss
->info
->type
!= GFC_SS_REFERENCE
&& !ss
->info
->can_be_null_ref
)
4478 nonoptional_arr
= true;
4482 /* We use one SS term, and use that to determine the bounds of the
4483 loop for this dimension. We try to pick the simplest term. */
4484 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4486 gfc_ss_type ss_type
;
4488 ss_type
= ss
->info
->type
;
4489 if (ss_type
== GFC_SS_SCALAR
4490 || ss_type
== GFC_SS_TEMP
4491 || ss_type
== GFC_SS_REFERENCE
4492 || (ss
->info
->can_be_null_ref
&& nonoptional_arr
))
4495 info
= &ss
->info
->data
.array
;
4498 if (loopspec
[n
] != NULL
)
4500 specinfo
= &loopspec
[n
]->info
->data
.array
;
4501 spec_dim
= loopspec
[n
]->dim
[n
];
4505 /* Silence uninitialized warnings. */
4512 gcc_assert (info
->shape
[dim
]);
4513 /* The frontend has worked out the size for us. */
4516 || !integer_zerop (specinfo
->start
[spec_dim
]))
4517 /* Prefer zero-based descriptors if possible. */
4522 if (ss_type
== GFC_SS_CONSTRUCTOR
)
4524 gfc_constructor_base base
;
4525 /* An unknown size constructor will always be rank one.
4526 Higher rank constructors will either have known shape,
4527 or still be wrapped in a call to reshape. */
4528 gcc_assert (loop
->dimen
== 1);
4530 /* Always prefer to use the constructor bounds if the size
4531 can be determined at compile time. Prefer not to otherwise,
4532 since the general case involves realloc, and it's better to
4533 avoid that overhead if possible. */
4534 base
= ss
->info
->expr
->value
.constructor
;
4535 dynamic
[n
] = gfc_get_array_constructor_size (&i
, base
);
4536 if (!dynamic
[n
] || !loopspec
[n
])
4541 /* Avoid using an allocatable lhs in an assignment, since
4542 there might be a reallocation coming. */
4543 if (loopspec
[n
] && ss
->is_alloc_lhs
)
4548 /* Criteria for choosing a loop specifier (most important first):
4549 doesn't need realloc
4555 else if (loopspec
[n
]->info
->type
== GFC_SS_CONSTRUCTOR
&& dynamic
[n
])
4557 else if (integer_onep (info
->stride
[dim
])
4558 && !integer_onep (specinfo
->stride
[spec_dim
]))
4560 else if (INTEGER_CST_P (info
->stride
[dim
])
4561 && !INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
4563 else if (INTEGER_CST_P (info
->start
[dim
])
4564 && !INTEGER_CST_P (specinfo
->start
[spec_dim
])
4565 && integer_onep (info
->stride
[dim
])
4566 == integer_onep (specinfo
->stride
[spec_dim
])
4567 && INTEGER_CST_P (info
->stride
[dim
])
4568 == INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
4570 /* We don't work out the upper bound.
4571 else if (INTEGER_CST_P (info->finish[n])
4572 && ! INTEGER_CST_P (specinfo->finish[n]))
4573 loopspec[n] = ss; */
4576 /* We should have found the scalarization loop specifier. If not,
4578 gcc_assert (loopspec
[n
]);
4580 info
= &loopspec
[n
]->info
->data
.array
;
4581 dim
= loopspec
[n
]->dim
[n
];
4583 /* Set the extents of this range. */
4584 cshape
= info
->shape
;
4585 if (cshape
&& INTEGER_CST_P (info
->start
[dim
])
4586 && INTEGER_CST_P (info
->stride
[dim
]))
4588 loop
->from
[n
] = info
->start
[dim
];
4589 mpz_set (i
, cshape
[get_array_ref_dim_for_loop_dim (loopspec
[n
], n
)]);
4590 mpz_sub_ui (i
, i
, 1);
4591 /* To = from + (size - 1) * stride. */
4592 tmp
= gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
4593 if (!integer_onep (info
->stride
[dim
]))
4594 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
4595 gfc_array_index_type
, tmp
,
4597 loop
->to
[n
] = fold_build2_loc (input_location
, PLUS_EXPR
,
4598 gfc_array_index_type
,
4599 loop
->from
[n
], tmp
);
4603 loop
->from
[n
] = info
->start
[dim
];
4604 switch (loopspec
[n
]->info
->type
)
4606 case GFC_SS_CONSTRUCTOR
:
4607 /* The upper bound is calculated when we expand the
4609 gcc_assert (loop
->to
[n
] == NULL_TREE
);
4612 case GFC_SS_SECTION
:
4613 /* Use the end expression if it exists and is not constant,
4614 so that it is only evaluated once. */
4615 loop
->to
[n
] = info
->end
[dim
];
4618 case GFC_SS_FUNCTION
:
4619 /* The loop bound will be set when we generate the call. */
4620 gcc_assert (loop
->to
[n
] == NULL_TREE
);
4623 case GFC_SS_INTRINSIC
:
4625 gfc_expr
*expr
= loopspec
[n
]->info
->expr
;
4627 /* The {l,u}bound of an assumed rank. */
4628 gcc_assert ((expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
4629 || expr
->value
.function
.isym
->id
== GFC_ISYM_UBOUND
)
4630 && expr
->value
.function
.actual
->next
->expr
== NULL
4631 && expr
->value
.function
.actual
->expr
->rank
== -1);
4633 loop
->to
[n
] = info
->end
[dim
];
4642 /* Transform everything so we have a simple incrementing variable. */
4643 if (integer_onep (info
->stride
[dim
]))
4644 info
->delta
[dim
] = gfc_index_zero_node
;
4647 /* Set the delta for this section. */
4648 info
->delta
[dim
] = gfc_evaluate_now (loop
->from
[n
], &outer_loop
->pre
);
4649 /* Number of iterations is (end - start + step) / step.
4650 with start = 0, this simplifies to
4652 for (i = 0; i<=last; i++){...}; */
4653 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4654 gfc_array_index_type
, loop
->to
[n
],
4656 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
4657 gfc_array_index_type
, tmp
, info
->stride
[dim
]);
4658 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
4659 tmp
, build_int_cst (gfc_array_index_type
, -1));
4660 loop
->to
[n
] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
4661 /* Make the loop variable start at 0. */
4662 loop
->from
[n
] = gfc_index_zero_node
;
4667 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4668 set_loop_bounds (loop
);
4672 /* Initialize the scalarization loop. Creates the loop variables. Determines
4673 the range of the loop variables. Creates a temporary if required.
4674 Also generates code for scalar expressions which have been
4675 moved outside the loop. */
4678 gfc_conv_loop_setup (gfc_loopinfo
* loop
, locus
* where
)
4683 set_loop_bounds (loop
);
4685 /* Add all the scalar code that can be taken out of the loops.
4686 This may include calculating the loop bounds, so do it before
4687 allocating the temporary. */
4688 gfc_add_loop_ss_code (loop
, loop
->ss
, false, where
);
4690 tmp_ss
= loop
->temp_ss
;
4691 /* If we want a temporary then create it. */
4694 gfc_ss_info
*tmp_ss_info
;
4696 tmp_ss_info
= tmp_ss
->info
;
4697 gcc_assert (tmp_ss_info
->type
== GFC_SS_TEMP
);
4698 gcc_assert (loop
->parent
== NULL
);
4700 /* Make absolutely sure that this is a complete type. */
4701 if (tmp_ss_info
->string_length
)
4702 tmp_ss_info
->data
.temp
.type
4703 = gfc_get_character_type_len_for_eltype
4704 (TREE_TYPE (tmp_ss_info
->data
.temp
.type
),
4705 tmp_ss_info
->string_length
);
4707 tmp
= tmp_ss_info
->data
.temp
.type
;
4708 memset (&tmp_ss_info
->data
.array
, 0, sizeof (gfc_array_info
));
4709 tmp_ss_info
->type
= GFC_SS_SECTION
;
4711 gcc_assert (tmp_ss
->dimen
!= 0);
4713 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, tmp_ss
, tmp
,
4714 NULL_TREE
, false, true, false, where
);
4717 /* For array parameters we don't have loop variables, so don't calculate the
4719 if (!loop
->array_parameter
)
4720 gfc_set_delta (loop
);
4724 /* Calculates how to transform from loop variables to array indices for each
4725 array: once loop bounds are chosen, sets the difference (DELTA field) between
4726 loop bounds and array reference bounds, for each array info. */
4729 gfc_set_delta (gfc_loopinfo
*loop
)
4731 gfc_ss
*ss
, **loopspec
;
4732 gfc_array_info
*info
;
4736 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
4738 loopspec
= loop
->specloop
;
4740 /* Calculate the translation from loop variables to array indices. */
4741 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4743 gfc_ss_type ss_type
;
4745 ss_type
= ss
->info
->type
;
4746 if (ss_type
!= GFC_SS_SECTION
4747 && ss_type
!= GFC_SS_COMPONENT
4748 && ss_type
!= GFC_SS_CONSTRUCTOR
)
4751 info
= &ss
->info
->data
.array
;
4753 for (n
= 0; n
< ss
->dimen
; n
++)
4755 /* If we are specifying the range the delta is already set. */
4756 if (loopspec
[n
] != ss
)
4760 /* Calculate the offset relative to the loop variable.
4761 First multiply by the stride. */
4762 tmp
= loop
->from
[n
];
4763 if (!integer_onep (info
->stride
[dim
]))
4764 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
4765 gfc_array_index_type
,
4766 tmp
, info
->stride
[dim
]);
4768 /* Then subtract this from our starting value. */
4769 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4770 gfc_array_index_type
,
4771 info
->start
[dim
], tmp
);
4773 info
->delta
[dim
] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
4778 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4779 gfc_set_delta (loop
);
4783 /* Calculate the size of a given array dimension from the bounds. This
4784 is simply (ubound - lbound + 1) if this expression is positive
4785 or 0 if it is negative (pick either one if it is zero). Optionally
4786 (if or_expr is present) OR the (expression != 0) condition to it. */
4789 gfc_conv_array_extent_dim (tree lbound
, tree ubound
, tree
* or_expr
)
4794 /* Calculate (ubound - lbound + 1). */
4795 res
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4797 res
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
, res
,
4798 gfc_index_one_node
);
4800 /* Check whether the size for this dimension is negative. */
4801 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, res
,
4802 gfc_index_zero_node
);
4803 res
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
, cond
,
4804 gfc_index_zero_node
, res
);
4806 /* Build OR expression. */
4808 *or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
4809 boolean_type_node
, *or_expr
, cond
);
4815 /* For an array descriptor, get the total number of elements. This is just
4816 the product of the extents along from_dim to to_dim. */
4819 gfc_conv_descriptor_size_1 (tree desc
, int from_dim
, int to_dim
)
4824 res
= gfc_index_one_node
;
4826 for (dim
= from_dim
; dim
< to_dim
; ++dim
)
4832 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]);
4833 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]);
4835 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
4836 res
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4844 /* Full size of an array. */
4847 gfc_conv_descriptor_size (tree desc
, int rank
)
4849 return gfc_conv_descriptor_size_1 (desc
, 0, rank
);
4853 /* Size of a coarray for all dimensions but the last. */
4856 gfc_conv_descriptor_cosize (tree desc
, int rank
, int corank
)
4858 return gfc_conv_descriptor_size_1 (desc
, rank
, rank
+ corank
- 1);
4862 /* Fills in an array descriptor, and returns the size of the array.
4863 The size will be a simple_val, ie a variable or a constant. Also
4864 calculates the offset of the base. The pointer argument overflow,
4865 which should be of integer type, will increase in value if overflow
4866 occurs during the size calculation. Returns the size of the array.
4870 for (n = 0; n < rank; n++)
4872 a.lbound[n] = specified_lower_bound;
4873 offset = offset + a.lbond[n] * stride;
4875 a.ubound[n] = specified_upper_bound;
4876 a.stride[n] = stride;
4877 size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
4878 overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
4879 stride = stride * size;
4881 for (n = rank; n < rank+corank; n++)
4882 (Set lcobound/ucobound as above.)
4883 element_size = sizeof (array element);
4886 stride = (size_t) stride;
4887 overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
4888 stride = stride * element_size;
4894 gfc_array_init_size (tree descriptor
, int rank
, int corank
, tree
* poffset
,
4895 gfc_expr
** lower
, gfc_expr
** upper
, stmtblock_t
* pblock
,
4896 stmtblock_t
* descriptor_block
, tree
* overflow
,
4897 tree expr3_elem_size
, tree
*nelems
, gfc_expr
*expr3
,
4911 stmtblock_t thenblock
;
4912 stmtblock_t elseblock
;
4917 type
= TREE_TYPE (descriptor
);
4919 stride
= gfc_index_one_node
;
4920 offset
= gfc_index_zero_node
;
4922 /* Set the dtype. */
4923 tmp
= gfc_conv_descriptor_dtype (descriptor
);
4924 gfc_add_modify (descriptor_block
, tmp
, gfc_get_dtype (TREE_TYPE (descriptor
)));
4926 or_expr
= boolean_false_node
;
4928 for (n
= 0; n
< rank
; n
++)
4933 /* We have 3 possibilities for determining the size of the array:
4934 lower == NULL => lbound = 1, ubound = upper[n]
4935 upper[n] = NULL => lbound = 1, ubound = lower[n]
4936 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
4939 /* Set lower bound. */
4940 gfc_init_se (&se
, NULL
);
4942 se
.expr
= gfc_index_one_node
;
4945 gcc_assert (lower
[n
]);
4948 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
4949 gfc_add_block_to_block (pblock
, &se
.pre
);
4953 se
.expr
= gfc_index_one_node
;
4957 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
4958 gfc_rank_cst
[n
], se
.expr
);
4959 conv_lbound
= se
.expr
;
4961 /* Work out the offset for this component. */
4962 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4964 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
4965 gfc_array_index_type
, offset
, tmp
);
4967 /* Set upper bound. */
4968 gfc_init_se (&se
, NULL
);
4969 gcc_assert (ubound
);
4970 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
4971 gfc_add_block_to_block (pblock
, &se
.pre
);
4973 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
4974 gfc_rank_cst
[n
], se
.expr
);
4975 conv_ubound
= se
.expr
;
4977 /* Store the stride. */
4978 gfc_conv_descriptor_stride_set (descriptor_block
, descriptor
,
4979 gfc_rank_cst
[n
], stride
);
4981 /* Calculate size and check whether extent is negative. */
4982 size
= gfc_conv_array_extent_dim (conv_lbound
, conv_ubound
, &or_expr
);
4983 size
= gfc_evaluate_now (size
, pblock
);
4985 /* Check whether multiplying the stride by the number of
4986 elements in this dimension would overflow. We must also check
4987 whether the current dimension has zero size in order to avoid
4990 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
4991 gfc_array_index_type
,
4992 fold_convert (gfc_array_index_type
,
4993 TYPE_MAX_VALUE (gfc_array_index_type
)),
4995 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
4996 boolean_type_node
, tmp
, stride
));
4997 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
4998 integer_one_node
, integer_zero_node
);
4999 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
5000 boolean_type_node
, size
,
5001 gfc_index_zero_node
));
5002 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5003 integer_zero_node
, tmp
);
5004 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
5006 *overflow
= gfc_evaluate_now (tmp
, pblock
);
5008 /* Multiply the stride by the number of elements in this dimension. */
5009 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
5010 gfc_array_index_type
, stride
, size
);
5011 stride
= gfc_evaluate_now (stride
, pblock
);
5014 for (n
= rank
; n
< rank
+ corank
; n
++)
5018 /* Set lower bound. */
5019 gfc_init_se (&se
, NULL
);
5020 if (lower
== NULL
|| lower
[n
] == NULL
)
5022 gcc_assert (n
== rank
+ corank
- 1);
5023 se
.expr
= gfc_index_one_node
;
5027 if (ubound
|| n
== rank
+ corank
- 1)
5029 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
5030 gfc_add_block_to_block (pblock
, &se
.pre
);
5034 se
.expr
= gfc_index_one_node
;
5038 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
5039 gfc_rank_cst
[n
], se
.expr
);
5041 if (n
< rank
+ corank
- 1)
5043 gfc_init_se (&se
, NULL
);
5044 gcc_assert (ubound
);
5045 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
5046 gfc_add_block_to_block (pblock
, &se
.pre
);
5047 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
5048 gfc_rank_cst
[n
], se
.expr
);
5052 /* The stride is the number of elements in the array, so multiply by the
5053 size of an element to get the total size. Obviously, if there is a
5054 SOURCE expression (expr3) we must use its element size. */
5055 if (expr3_elem_size
!= NULL_TREE
)
5056 tmp
= expr3_elem_size
;
5057 else if (expr3
!= NULL
)
5059 if (expr3
->ts
.type
== BT_CLASS
)
5062 gfc_expr
*sz
= gfc_copy_expr (expr3
);
5063 gfc_add_vptr_component (sz
);
5064 gfc_add_size_component (sz
);
5065 gfc_init_se (&se_sz
, NULL
);
5066 gfc_conv_expr (&se_sz
, sz
);
5072 tmp
= gfc_typenode_for_spec (&expr3
->ts
);
5073 tmp
= TYPE_SIZE_UNIT (tmp
);
5076 else if (ts
->type
!= BT_UNKNOWN
&& ts
->type
!= BT_CHARACTER
)
5077 /* FIXME: Properly handle characters. See PR 57456. */
5078 tmp
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (ts
));
5080 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
5082 /* Convert to size_t. */
5083 element_size
= fold_convert (size_type_node
, tmp
);
5086 return element_size
;
5088 *nelems
= gfc_evaluate_now (stride
, pblock
);
5089 stride
= fold_convert (size_type_node
, stride
);
5091 /* First check for overflow. Since an array of type character can
5092 have zero element_size, we must check for that before
5094 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
5096 TYPE_MAX_VALUE (size_type_node
), element_size
);
5097 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
5098 boolean_type_node
, tmp
, stride
));
5099 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5100 integer_one_node
, integer_zero_node
);
5101 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
5102 boolean_type_node
, element_size
,
5103 build_int_cst (size_type_node
, 0)));
5104 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5105 integer_zero_node
, tmp
);
5106 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
5108 *overflow
= gfc_evaluate_now (tmp
, pblock
);
5110 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5111 stride
, element_size
);
5113 if (poffset
!= NULL
)
5115 offset
= gfc_evaluate_now (offset
, pblock
);
5119 if (integer_zerop (or_expr
))
5121 if (integer_onep (or_expr
))
5122 return build_int_cst (size_type_node
, 0);
5124 var
= gfc_create_var (TREE_TYPE (size
), "size");
5125 gfc_start_block (&thenblock
);
5126 gfc_add_modify (&thenblock
, var
, build_int_cst (size_type_node
, 0));
5127 thencase
= gfc_finish_block (&thenblock
);
5129 gfc_start_block (&elseblock
);
5130 gfc_add_modify (&elseblock
, var
, size
);
5131 elsecase
= gfc_finish_block (&elseblock
);
5133 tmp
= gfc_evaluate_now (or_expr
, pblock
);
5134 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
5135 gfc_add_expr_to_block (pblock
, tmp
);
5141 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
5142 the work for an ALLOCATE statement. */
5146 gfc_array_allocate (gfc_se
* se
, gfc_expr
* expr
, tree status
, tree errmsg
,
5147 tree errlen
, tree label_finish
, tree expr3_elem_size
,
5148 tree
*nelems
, gfc_expr
*expr3
, gfc_typespec
*ts
)
5152 tree offset
= NULL_TREE
;
5153 tree token
= NULL_TREE
;
5156 tree error
= NULL_TREE
;
5157 tree overflow
; /* Boolean storing whether size calculation overflows. */
5158 tree var_overflow
= NULL_TREE
;
5160 tree set_descriptor
;
5161 stmtblock_t set_descriptor_block
;
5162 stmtblock_t elseblock
;
5165 gfc_ref
*ref
, *prev_ref
= NULL
;
5166 bool allocatable
, coarray
, dimension
;
5170 /* Find the last reference in the chain. */
5171 while (ref
&& ref
->next
!= NULL
)
5173 gcc_assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
5174 || (ref
->u
.ar
.dimen
== 0 && ref
->u
.ar
.codimen
> 0));
5179 if (ref
== NULL
|| ref
->type
!= REF_ARRAY
)
5184 allocatable
= expr
->symtree
->n
.sym
->attr
.allocatable
;
5185 coarray
= expr
->symtree
->n
.sym
->attr
.codimension
;
5186 dimension
= expr
->symtree
->n
.sym
->attr
.dimension
;
5190 allocatable
= prev_ref
->u
.c
.component
->attr
.allocatable
;
5191 coarray
= prev_ref
->u
.c
.component
->attr
.codimension
;
5192 dimension
= prev_ref
->u
.c
.component
->attr
.dimension
;
5196 gcc_assert (coarray
);
5198 /* Figure out the size of the array. */
5199 switch (ref
->u
.ar
.type
)
5205 upper
= ref
->u
.ar
.start
;
5211 lower
= ref
->u
.ar
.start
;
5212 upper
= ref
->u
.ar
.end
;
5216 gcc_assert (ref
->u
.ar
.as
->type
== AS_EXPLICIT
);
5218 lower
= ref
->u
.ar
.as
->lower
;
5219 upper
= ref
->u
.ar
.as
->upper
;
5227 overflow
= integer_zero_node
;
5229 gfc_init_block (&set_descriptor_block
);
5230 size
= gfc_array_init_size (se
->expr
, ref
->u
.ar
.as
->rank
,
5231 ref
->u
.ar
.as
->corank
, &offset
, lower
, upper
,
5232 &se
->pre
, &set_descriptor_block
, &overflow
,
5233 expr3_elem_size
, nelems
, expr3
, ts
);
5237 var_overflow
= gfc_create_var (integer_type_node
, "overflow");
5238 gfc_add_modify (&se
->pre
, var_overflow
, overflow
);
5240 if (status
== NULL_TREE
)
5242 /* Generate the block of code handling overflow. */
5243 msg
= gfc_build_addr_expr (pchar_type_node
,
5244 gfc_build_localized_cstring_const
5245 ("Integer overflow when calculating the amount of "
5246 "memory to allocate"));
5247 error
= build_call_expr_loc (input_location
,
5248 gfor_fndecl_runtime_error
, 1, msg
);
5252 tree status_type
= TREE_TYPE (status
);
5253 stmtblock_t set_status_block
;
5255 gfc_start_block (&set_status_block
);
5256 gfc_add_modify (&set_status_block
, status
,
5257 build_int_cst (status_type
, LIBERROR_ALLOCATION
));
5258 error
= gfc_finish_block (&set_status_block
);
5262 gfc_start_block (&elseblock
);
5264 /* Allocate memory to store the data. */
5265 if (POINTER_TYPE_P (TREE_TYPE (se
->expr
)))
5266 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
5268 pointer
= gfc_conv_descriptor_data_get (se
->expr
);
5269 STRIP_NOPS (pointer
);
5271 if (coarray
&& gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
5272 token
= gfc_build_addr_expr (NULL_TREE
,
5273 gfc_conv_descriptor_token (se
->expr
));
5275 /* The allocatable variant takes the old pointer as first argument. */
5277 gfc_allocate_allocatable (&elseblock
, pointer
, size
, token
,
5278 status
, errmsg
, errlen
, label_finish
, expr
);
5280 gfc_allocate_using_malloc (&elseblock
, pointer
, size
, status
);
5284 cond
= gfc_unlikely (fold_build2_loc (input_location
, NE_EXPR
,
5285 boolean_type_node
, var_overflow
, integer_zero_node
));
5286 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
5287 error
, gfc_finish_block (&elseblock
));
5290 tmp
= gfc_finish_block (&elseblock
);
5292 gfc_add_expr_to_block (&se
->pre
, tmp
);
5294 /* Update the array descriptors. */
5296 gfc_conv_descriptor_offset_set (&set_descriptor_block
, se
->expr
, offset
);
5298 set_descriptor
= gfc_finish_block (&set_descriptor_block
);
5299 if (status
!= NULL_TREE
)
5301 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
5302 boolean_type_node
, status
,
5303 build_int_cst (TREE_TYPE (status
), 0));
5304 gfc_add_expr_to_block (&se
->pre
,
5305 fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5306 gfc_likely (cond
), set_descriptor
,
5307 build_empty_stmt (input_location
)));
5310 gfc_add_expr_to_block (&se
->pre
, set_descriptor
);
5312 if ((expr
->ts
.type
== BT_DERIVED
)
5313 && expr
->ts
.u
.derived
->attr
.alloc_comp
)
5315 tmp
= gfc_nullify_alloc_comp (expr
->ts
.u
.derived
, se
->expr
,
5316 ref
->u
.ar
.as
->rank
);
5317 gfc_add_expr_to_block (&se
->pre
, tmp
);
5324 /* Deallocate an array variable. Also used when an allocated variable goes
5329 gfc_array_deallocate (tree descriptor
, tree pstat
, tree errmsg
, tree errlen
,
5330 tree label_finish
, gfc_expr
* expr
)
5335 bool coarray
= gfc_is_coarray (expr
);
5337 gfc_start_block (&block
);
5339 /* Get a pointer to the data. */
5340 var
= gfc_conv_descriptor_data_get (descriptor
);
5343 /* Parameter is the address of the data component. */
5344 tmp
= gfc_deallocate_with_status (coarray
? descriptor
: var
, pstat
, errmsg
,
5345 errlen
, label_finish
, false, expr
, coarray
);
5346 gfc_add_expr_to_block (&block
, tmp
);
5348 /* Zero the data pointer; only for coarrays an error can occur and then
5349 the allocation status may not be changed. */
5350 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
5351 var
, build_int_cst (TREE_TYPE (var
), 0));
5352 if (pstat
!= NULL_TREE
&& coarray
&& gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
5355 tree stat
= build_fold_indirect_ref_loc (input_location
, pstat
);
5357 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5358 stat
, build_int_cst (TREE_TYPE (stat
), 0));
5359 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5360 cond
, tmp
, build_empty_stmt (input_location
));
5363 gfc_add_expr_to_block (&block
, tmp
);
5365 return gfc_finish_block (&block
);
5369 /* Create an array constructor from an initialization expression.
5370 We assume the frontend already did any expansions and conversions. */
5373 gfc_conv_array_initializer (tree type
, gfc_expr
* expr
)
5379 unsigned HOST_WIDE_INT lo
;
5381 vec
<constructor_elt
, va_gc
> *v
= NULL
;
5383 if (expr
->expr_type
== EXPR_VARIABLE
5384 && expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
5385 && expr
->symtree
->n
.sym
->value
)
5386 expr
= expr
->symtree
->n
.sym
->value
;
5388 switch (expr
->expr_type
)
5391 case EXPR_STRUCTURE
:
5392 /* A single scalar or derived type value. Create an array with all
5393 elements equal to that value. */
5394 gfc_init_se (&se
, NULL
);
5396 if (expr
->expr_type
== EXPR_CONSTANT
)
5397 gfc_conv_constant (&se
, expr
);
5399 gfc_conv_structure (&se
, expr
, 1);
5401 tmp
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
5402 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
5403 hi
= TREE_INT_CST_HIGH (tmp
);
5404 lo
= TREE_INT_CST_LOW (tmp
);
5408 /* This will probably eat buckets of memory for large arrays. */
5409 while (hi
!= 0 || lo
!= 0)
5411 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
, se
.expr
);
5419 /* Create a vector of all the elements. */
5420 for (c
= gfc_constructor_first (expr
->value
.constructor
);
5421 c
; c
= gfc_constructor_next (c
))
5425 /* Problems occur when we get something like
5426 integer :: a(lots) = (/(i, i=1, lots)/) */
5427 gfc_fatal_error ("The number of elements in the array constructor "
5428 "at %L requires an increase of the allowed %d "
5429 "upper limit. See -fmax-array-constructor "
5430 "option", &expr
->where
,
5431 gfc_option
.flag_max_array_constructor
);
5434 if (mpz_cmp_si (c
->offset
, 0) != 0)
5435 index
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
5439 if (mpz_cmp_si (c
->repeat
, 1) > 0)
5445 mpz_add (maxval
, c
->offset
, c
->repeat
);
5446 mpz_sub_ui (maxval
, maxval
, 1);
5447 tmp2
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
5448 if (mpz_cmp_si (c
->offset
, 0) != 0)
5450 mpz_add_ui (maxval
, c
->offset
, 1);
5451 tmp1
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
5454 tmp1
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
5456 range
= fold_build2 (RANGE_EXPR
, gfc_array_index_type
, tmp1
, tmp2
);
5462 gfc_init_se (&se
, NULL
);
5463 switch (c
->expr
->expr_type
)
5466 gfc_conv_constant (&se
, c
->expr
);
5469 case EXPR_STRUCTURE
:
5470 gfc_conv_structure (&se
, c
->expr
, 1);
5474 /* Catch those occasional beasts that do not simplify
5475 for one reason or another, assuming that if they are
5476 standard defying the frontend will catch them. */
5477 gfc_conv_expr (&se
, c
->expr
);
5481 if (range
== NULL_TREE
)
5482 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
5485 if (index
!= NULL_TREE
)
5486 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
5487 CONSTRUCTOR_APPEND_ELT (v
, range
, se
.expr
);
5493 return gfc_build_null_descriptor (type
);
5499 /* Create a constructor from the list of elements. */
5500 tmp
= build_constructor (type
, v
);
5501 TREE_CONSTANT (tmp
) = 1;
5506 /* Generate code to evaluate non-constant coarray cobounds. */
5509 gfc_trans_array_cobounds (tree type
, stmtblock_t
* pblock
,
5510 const gfc_symbol
*sym
)
5520 for (dim
= as
->rank
; dim
< as
->rank
+ as
->corank
; dim
++)
5522 /* Evaluate non-constant array bound expressions. */
5523 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
5524 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
5526 gfc_init_se (&se
, NULL
);
5527 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
5528 gfc_add_block_to_block (pblock
, &se
.pre
);
5529 gfc_add_modify (pblock
, lbound
, se
.expr
);
5531 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
5532 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
5534 gfc_init_se (&se
, NULL
);
5535 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
5536 gfc_add_block_to_block (pblock
, &se
.pre
);
5537 gfc_add_modify (pblock
, ubound
, se
.expr
);
5543 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
5544 returns the size (in elements) of the array. */
5547 gfc_trans_array_bounds (tree type
, gfc_symbol
* sym
, tree
* poffset
,
5548 stmtblock_t
* pblock
)
5563 size
= gfc_index_one_node
;
5564 offset
= gfc_index_zero_node
;
5565 for (dim
= 0; dim
< as
->rank
; dim
++)
5567 /* Evaluate non-constant array bound expressions. */
5568 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
5569 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
5571 gfc_init_se (&se
, NULL
);
5572 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
5573 gfc_add_block_to_block (pblock
, &se
.pre
);
5574 gfc_add_modify (pblock
, lbound
, se
.expr
);
5576 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
5577 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
5579 gfc_init_se (&se
, NULL
);
5580 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
5581 gfc_add_block_to_block (pblock
, &se
.pre
);
5582 gfc_add_modify (pblock
, ubound
, se
.expr
);
5584 /* The offset of this dimension. offset = offset - lbound * stride. */
5585 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5587 offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5590 /* The size of this dimension, and the stride of the next. */
5591 if (dim
+ 1 < as
->rank
)
5592 stride
= GFC_TYPE_ARRAY_STRIDE (type
, dim
+ 1);
5594 stride
= GFC_TYPE_ARRAY_SIZE (type
);
5596 if (ubound
!= NULL_TREE
&& !(stride
&& INTEGER_CST_P (stride
)))
5598 /* Calculate stride = size * (ubound + 1 - lbound). */
5599 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5600 gfc_array_index_type
,
5601 gfc_index_one_node
, lbound
);
5602 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5603 gfc_array_index_type
, ubound
, tmp
);
5604 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5605 gfc_array_index_type
, size
, tmp
);
5607 gfc_add_modify (pblock
, stride
, tmp
);
5609 stride
= gfc_evaluate_now (tmp
, pblock
);
5611 /* Make sure that negative size arrays are translated
5612 to being zero size. */
5613 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
5614 stride
, gfc_index_zero_node
);
5615 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5616 gfc_array_index_type
, tmp
,
5617 stride
, gfc_index_zero_node
);
5618 gfc_add_modify (pblock
, stride
, tmp
);
5624 gfc_trans_array_cobounds (type
, pblock
, sym
);
5625 gfc_trans_vla_type_sizes (sym
, pblock
);
5632 /* Generate code to initialize/allocate an array variable. */
5635 gfc_trans_auto_array_allocation (tree decl
, gfc_symbol
* sym
,
5636 gfc_wrapped_block
* block
)
5640 tree tmp
= NULL_TREE
;
5647 gcc_assert (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
));
5649 /* Do nothing for USEd variables. */
5650 if (sym
->attr
.use_assoc
)
5653 type
= TREE_TYPE (decl
);
5654 gcc_assert (GFC_ARRAY_TYPE_P (type
));
5655 onstack
= TREE_CODE (type
) != POINTER_TYPE
;
5657 gfc_init_block (&init
);
5659 /* Evaluate character string length. */
5660 if (sym
->ts
.type
== BT_CHARACTER
5661 && onstack
&& !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
5663 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
5665 gfc_trans_vla_type_sizes (sym
, &init
);
5667 /* Emit a DECL_EXPR for this variable, which will cause the
5668 gimplifier to allocate storage, and all that good stuff. */
5669 tmp
= fold_build1_loc (input_location
, DECL_EXPR
, TREE_TYPE (decl
), decl
);
5670 gfc_add_expr_to_block (&init
, tmp
);
5675 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
5679 type
= TREE_TYPE (type
);
5681 gcc_assert (!sym
->attr
.use_assoc
);
5682 gcc_assert (!TREE_STATIC (decl
));
5683 gcc_assert (!sym
->module
);
5685 if (sym
->ts
.type
== BT_CHARACTER
5686 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
5687 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
5689 size
= gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
5691 /* Don't actually allocate space for Cray Pointees. */
5692 if (sym
->attr
.cray_pointee
)
5694 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
5695 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
5697 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
5701 if (gfc_option
.flag_stack_arrays
)
5703 gcc_assert (TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
);
5704 space
= build_decl (sym
->declared_at
.lb
->location
,
5705 VAR_DECL
, create_tmp_var_name ("A"),
5706 TREE_TYPE (TREE_TYPE (decl
)));
5707 gfc_trans_vla_type_sizes (sym
, &init
);
5711 /* The size is the number of elements in the array, so multiply by the
5712 size of an element to get the total size. */
5713 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
5714 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5715 size
, fold_convert (gfc_array_index_type
, tmp
));
5717 /* Allocate memory to hold the data. */
5718 tmp
= gfc_call_malloc (&init
, TREE_TYPE (decl
), size
);
5719 gfc_add_modify (&init
, decl
, tmp
);
5721 /* Free the temporary. */
5722 tmp
= gfc_call_free (convert (pvoid_type_node
, decl
));
5726 /* Set offset of the array. */
5727 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
5728 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
5730 /* Automatic arrays should not have initializers. */
5731 gcc_assert (!sym
->value
);
5733 inittree
= gfc_finish_block (&init
);
5740 /* Don't create new scope, emit the DECL_EXPR in exactly the scope
5741 where also space is located. */
5742 gfc_init_block (&init
);
5743 tmp
= fold_build1_loc (input_location
, DECL_EXPR
,
5744 TREE_TYPE (space
), space
);
5745 gfc_add_expr_to_block (&init
, tmp
);
5746 addr
= fold_build1_loc (sym
->declared_at
.lb
->location
,
5747 ADDR_EXPR
, TREE_TYPE (decl
), space
);
5748 gfc_add_modify (&init
, decl
, addr
);
5749 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
5752 gfc_add_init_cleanup (block
, inittree
, tmp
);
5756 /* Generate entry and exit code for g77 calling convention arrays. */
5759 gfc_trans_g77_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
5769 gfc_save_backend_locus (&loc
);
5770 gfc_set_backend_locus (&sym
->declared_at
);
5772 /* Descriptor type. */
5773 parm
= sym
->backend_decl
;
5774 type
= TREE_TYPE (parm
);
5775 gcc_assert (GFC_ARRAY_TYPE_P (type
));
5777 gfc_start_block (&init
);
5779 if (sym
->ts
.type
== BT_CHARACTER
5780 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
5781 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
5783 /* Evaluate the bounds of the array. */
5784 gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
5786 /* Set the offset. */
5787 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
5788 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
5790 /* Set the pointer itself if we aren't using the parameter directly. */
5791 if (TREE_CODE (parm
) != PARM_DECL
)
5793 tmp
= convert (TREE_TYPE (parm
), GFC_DECL_SAVED_DESCRIPTOR (parm
));
5794 gfc_add_modify (&init
, parm
, tmp
);
5796 stmt
= gfc_finish_block (&init
);
5798 gfc_restore_backend_locus (&loc
);
5800 /* Add the initialization code to the start of the function. */
5802 if (sym
->attr
.optional
|| sym
->attr
.not_always_present
)
5804 tmp
= gfc_conv_expr_present (sym
);
5805 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
5808 gfc_add_init_cleanup (block
, stmt
, NULL_TREE
);
5812 /* Modify the descriptor of an array parameter so that it has the
5813 correct lower bound. Also move the upper bound accordingly.
5814 If the array is not packed, it will be copied into a temporary.
5815 For each dimension we set the new lower and upper bounds. Then we copy the
5816 stride and calculate the offset for this dimension. We also work out
5817 what the stride of a packed array would be, and see it the two match.
5818 If the array need repacking, we set the stride to the values we just
5819 calculated, recalculate the offset and copy the array data.
5820 Code is also added to copy the data back at the end of the function.
5824 gfc_trans_dummy_array_bias (gfc_symbol
* sym
, tree tmpdesc
,
5825 gfc_wrapped_block
* block
)
5832 tree stmtInit
, stmtCleanup
;
5839 tree stride
, stride2
;
5849 /* Do nothing for pointer and allocatable arrays. */
5850 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
5853 if (sym
->attr
.dummy
&& gfc_is_nodesc_array (sym
))
5855 gfc_trans_g77_array (sym
, block
);
5859 gfc_save_backend_locus (&loc
);
5860 gfc_set_backend_locus (&sym
->declared_at
);
5862 /* Descriptor type. */
5863 type
= TREE_TYPE (tmpdesc
);
5864 gcc_assert (GFC_ARRAY_TYPE_P (type
));
5865 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
5866 dumdesc
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
5867 gfc_start_block (&init
);
5869 if (sym
->ts
.type
== BT_CHARACTER
5870 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
5871 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
5873 checkparm
= (sym
->as
->type
== AS_EXPLICIT
5874 && (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
));
5876 no_repack
= !(GFC_DECL_PACKED_ARRAY (tmpdesc
)
5877 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
));
5879 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
))
5881 /* For non-constant shape arrays we only check if the first dimension
5882 is contiguous. Repacking higher dimensions wouldn't gain us
5883 anything as we still don't know the array stride. */
5884 partial
= gfc_create_var (boolean_type_node
, "partial");
5885 TREE_USED (partial
) = 1;
5886 tmp
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
5887 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, tmp
,
5888 gfc_index_one_node
);
5889 gfc_add_modify (&init
, partial
, tmp
);
5892 partial
= NULL_TREE
;
5894 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
5895 here, however I think it does the right thing. */
5898 /* Set the first stride. */
5899 stride
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
5900 stride
= gfc_evaluate_now (stride
, &init
);
5902 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5903 stride
, gfc_index_zero_node
);
5904 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
5905 tmp
, gfc_index_one_node
, stride
);
5906 stride
= GFC_TYPE_ARRAY_STRIDE (type
, 0);
5907 gfc_add_modify (&init
, stride
, tmp
);
5909 /* Allow the user to disable array repacking. */
5910 stmt_unpacked
= NULL_TREE
;
5914 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type
, 0)));
5915 /* A library call to repack the array if necessary. */
5916 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
5917 stmt_unpacked
= build_call_expr_loc (input_location
,
5918 gfor_fndecl_in_pack
, 1, tmp
);
5920 stride
= gfc_index_one_node
;
5922 if (gfc_option
.warn_array_temp
)
5923 gfc_warning ("Creating array temporary at %L", &loc
);
5926 /* This is for the case where the array data is used directly without
5927 calling the repack function. */
5928 if (no_repack
|| partial
!= NULL_TREE
)
5929 stmt_packed
= gfc_conv_descriptor_data_get (dumdesc
);
5931 stmt_packed
= NULL_TREE
;
5933 /* Assign the data pointer. */
5934 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
5936 /* Don't repack unknown shape arrays when the first stride is 1. */
5937 tmp
= fold_build3_loc (input_location
, COND_EXPR
, TREE_TYPE (stmt_packed
),
5938 partial
, stmt_packed
, stmt_unpacked
);
5941 tmp
= stmt_packed
!= NULL_TREE
? stmt_packed
: stmt_unpacked
;
5942 gfc_add_modify (&init
, tmpdesc
, fold_convert (type
, tmp
));
5944 offset
= gfc_index_zero_node
;
5945 size
= gfc_index_one_node
;
5947 /* Evaluate the bounds of the array. */
5948 for (n
= 0; n
< sym
->as
->rank
; n
++)
5950 if (checkparm
|| !sym
->as
->upper
[n
])
5952 /* Get the bounds of the actual parameter. */
5953 dubound
= gfc_conv_descriptor_ubound_get (dumdesc
, gfc_rank_cst
[n
]);
5954 dlbound
= gfc_conv_descriptor_lbound_get (dumdesc
, gfc_rank_cst
[n
]);
5958 dubound
= NULL_TREE
;
5959 dlbound
= NULL_TREE
;
5962 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, n
);
5963 if (!INTEGER_CST_P (lbound
))
5965 gfc_init_se (&se
, NULL
);
5966 gfc_conv_expr_type (&se
, sym
->as
->lower
[n
],
5967 gfc_array_index_type
);
5968 gfc_add_block_to_block (&init
, &se
.pre
);
5969 gfc_add_modify (&init
, lbound
, se
.expr
);
5972 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, n
);
5973 /* Set the desired upper bound. */
5974 if (sym
->as
->upper
[n
])
5976 /* We know what we want the upper bound to be. */
5977 if (!INTEGER_CST_P (ubound
))
5979 gfc_init_se (&se
, NULL
);
5980 gfc_conv_expr_type (&se
, sym
->as
->upper
[n
],
5981 gfc_array_index_type
);
5982 gfc_add_block_to_block (&init
, &se
.pre
);
5983 gfc_add_modify (&init
, ubound
, se
.expr
);
5986 /* Check the sizes match. */
5989 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
5993 temp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5994 gfc_array_index_type
, ubound
, lbound
);
5995 temp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5996 gfc_array_index_type
,
5997 gfc_index_one_node
, temp
);
5998 stride2
= fold_build2_loc (input_location
, MINUS_EXPR
,
5999 gfc_array_index_type
, dubound
,
6001 stride2
= fold_build2_loc (input_location
, PLUS_EXPR
,
6002 gfc_array_index_type
,
6003 gfc_index_one_node
, stride2
);
6004 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6005 gfc_array_index_type
, temp
, stride2
);
6006 asprintf (&msg
, "Dimension %d of array '%s' has extent "
6007 "%%ld instead of %%ld", n
+1, sym
->name
);
6009 gfc_trans_runtime_check (true, false, tmp
, &init
, &loc
, msg
,
6010 fold_convert (long_integer_type_node
, temp
),
6011 fold_convert (long_integer_type_node
, stride2
));
6018 /* For assumed shape arrays move the upper bound by the same amount
6019 as the lower bound. */
6020 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6021 gfc_array_index_type
, dubound
, dlbound
);
6022 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6023 gfc_array_index_type
, tmp
, lbound
);
6024 gfc_add_modify (&init
, ubound
, tmp
);
6026 /* The offset of this dimension. offset = offset - lbound * stride. */
6027 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6029 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
6030 gfc_array_index_type
, offset
, tmp
);
6032 /* The size of this dimension, and the stride of the next. */
6033 if (n
+ 1 < sym
->as
->rank
)
6035 stride
= GFC_TYPE_ARRAY_STRIDE (type
, n
+ 1);
6037 if (no_repack
|| partial
!= NULL_TREE
)
6039 gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[n
+1]);
6041 /* Figure out the stride if not a known constant. */
6042 if (!INTEGER_CST_P (stride
))
6045 stmt_packed
= NULL_TREE
;
6048 /* Calculate stride = size * (ubound + 1 - lbound). */
6049 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6050 gfc_array_index_type
,
6051 gfc_index_one_node
, lbound
);
6052 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6053 gfc_array_index_type
, ubound
, tmp
);
6054 size
= fold_build2_loc (input_location
, MULT_EXPR
,
6055 gfc_array_index_type
, size
, tmp
);
6059 /* Assign the stride. */
6060 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
6061 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6062 gfc_array_index_type
, partial
,
6063 stmt_unpacked
, stmt_packed
);
6065 tmp
= (stmt_packed
!= NULL_TREE
) ? stmt_packed
: stmt_unpacked
;
6066 gfc_add_modify (&init
, stride
, tmp
);
6071 stride
= GFC_TYPE_ARRAY_SIZE (type
);
6073 if (stride
&& !INTEGER_CST_P (stride
))
6075 /* Calculate size = stride * (ubound + 1 - lbound). */
6076 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6077 gfc_array_index_type
,
6078 gfc_index_one_node
, lbound
);
6079 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6080 gfc_array_index_type
,
6082 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6083 gfc_array_index_type
,
6084 GFC_TYPE_ARRAY_STRIDE (type
, n
), tmp
);
6085 gfc_add_modify (&init
, stride
, tmp
);
6090 gfc_trans_array_cobounds (type
, &init
, sym
);
6092 /* Set the offset. */
6093 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
6094 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6096 gfc_trans_vla_type_sizes (sym
, &init
);
6098 stmtInit
= gfc_finish_block (&init
);
6100 /* Only do the entry/initialization code if the arg is present. */
6101 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6102 optional_arg
= (sym
->attr
.optional
6103 || (sym
->ns
->proc_name
->attr
.entry_master
6104 && sym
->attr
.dummy
));
6107 tmp
= gfc_conv_expr_present (sym
);
6108 stmtInit
= build3_v (COND_EXPR
, tmp
, stmtInit
,
6109 build_empty_stmt (input_location
));
6114 stmtCleanup
= NULL_TREE
;
6117 stmtblock_t cleanup
;
6118 gfc_start_block (&cleanup
);
6120 if (sym
->attr
.intent
!= INTENT_IN
)
6122 /* Copy the data back. */
6123 tmp
= build_call_expr_loc (input_location
,
6124 gfor_fndecl_in_unpack
, 2, dumdesc
, tmpdesc
);
6125 gfc_add_expr_to_block (&cleanup
, tmp
);
6128 /* Free the temporary. */
6129 tmp
= gfc_call_free (tmpdesc
);
6130 gfc_add_expr_to_block (&cleanup
, tmp
);
6132 stmtCleanup
= gfc_finish_block (&cleanup
);
6134 /* Only do the cleanup if the array was repacked. */
6135 tmp
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
6136 tmp
= gfc_conv_descriptor_data_get (tmp
);
6137 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6139 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6140 build_empty_stmt (input_location
));
6144 tmp
= gfc_conv_expr_present (sym
);
6145 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6146 build_empty_stmt (input_location
));
6150 /* We don't need to free any memory allocated by internal_pack as it will
6151 be freed at the end of the function by pop_context. */
6152 gfc_add_init_cleanup (block
, stmtInit
, stmtCleanup
);
6154 gfc_restore_backend_locus (&loc
);
6158 /* Calculate the overall offset, including subreferences. */
6160 gfc_get_dataptr_offset (stmtblock_t
*block
, tree parm
, tree desc
, tree offset
,
6161 bool subref
, gfc_expr
*expr
)
6171 /* If offset is NULL and this is not a subreferenced array, there is
6173 if (offset
== NULL_TREE
)
6176 offset
= gfc_index_zero_node
;
6181 tmp
= build_array_ref (desc
, offset
, NULL
);
6183 /* Offset the data pointer for pointer assignments from arrays with
6184 subreferences; e.g. my_integer => my_type(:)%integer_component. */
6187 /* Go past the array reference. */
6188 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6189 if (ref
->type
== REF_ARRAY
&&
6190 ref
->u
.ar
.type
!= AR_ELEMENT
)
6196 /* Calculate the offset for each subsequent subreference. */
6197 for (; ref
; ref
= ref
->next
)
6202 field
= ref
->u
.c
.component
->backend_decl
;
6203 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
6204 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
6206 tmp
, field
, NULL_TREE
);
6210 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
6211 gfc_init_se (&start
, NULL
);
6212 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
6213 gfc_add_block_to_block (block
, &start
.pre
);
6214 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
6218 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
6219 && ref
->u
.ar
.type
== AR_ELEMENT
);
6221 /* TODO - Add bounds checking. */
6222 stride
= gfc_index_one_node
;
6223 index
= gfc_index_zero_node
;
6224 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
6229 /* Update the index. */
6230 gfc_init_se (&start
, NULL
);
6231 gfc_conv_expr_type (&start
, ref
->u
.ar
.start
[n
], gfc_array_index_type
);
6232 itmp
= gfc_evaluate_now (start
.expr
, block
);
6233 gfc_init_se (&start
, NULL
);
6234 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->lower
[n
], gfc_array_index_type
);
6235 jtmp
= gfc_evaluate_now (start
.expr
, block
);
6236 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6237 gfc_array_index_type
, itmp
, jtmp
);
6238 itmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6239 gfc_array_index_type
, itmp
, stride
);
6240 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
6241 gfc_array_index_type
, itmp
, index
);
6242 index
= gfc_evaluate_now (index
, block
);
6244 /* Update the stride. */
6245 gfc_init_se (&start
, NULL
);
6246 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->upper
[n
], gfc_array_index_type
);
6247 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6248 gfc_array_index_type
, start
.expr
,
6250 itmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6251 gfc_array_index_type
,
6252 gfc_index_one_node
, itmp
);
6253 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
6254 gfc_array_index_type
, stride
, itmp
);
6255 stride
= gfc_evaluate_now (stride
, block
);
6258 /* Apply the index to obtain the array element. */
6259 tmp
= gfc_build_array_ref (tmp
, index
, NULL
);
6269 /* Set the target data pointer. */
6270 offset
= gfc_build_addr_expr (gfc_array_dataptr_type (desc
), tmp
);
6271 gfc_conv_descriptor_data_set (block
, parm
, offset
);
6275 /* gfc_conv_expr_descriptor needs the string length an expression
6276 so that the size of the temporary can be obtained. This is done
6277 by adding up the string lengths of all the elements in the
6278 expression. Function with non-constant expressions have their
6279 string lengths mapped onto the actual arguments using the
6280 interface mapping machinery in trans-expr.c. */
6282 get_array_charlen (gfc_expr
*expr
, gfc_se
*se
)
6284 gfc_interface_mapping mapping
;
6285 gfc_formal_arglist
*formal
;
6286 gfc_actual_arglist
*arg
;
6289 if (expr
->ts
.u
.cl
->length
6290 && gfc_is_constant_expr (expr
->ts
.u
.cl
->length
))
6292 if (!expr
->ts
.u
.cl
->backend_decl
)
6293 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6297 switch (expr
->expr_type
)
6300 get_array_charlen (expr
->value
.op
.op1
, se
);
6302 /* For parentheses the expression ts.u.cl is identical. */
6303 if (expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
6306 expr
->ts
.u
.cl
->backend_decl
=
6307 gfc_create_var (gfc_charlen_type_node
, "sln");
6309 if (expr
->value
.op
.op2
)
6311 get_array_charlen (expr
->value
.op
.op2
, se
);
6313 gcc_assert (expr
->value
.op
.op
== INTRINSIC_CONCAT
);
6315 /* Add the string lengths and assign them to the expression
6316 string length backend declaration. */
6317 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
6318 fold_build2_loc (input_location
, PLUS_EXPR
,
6319 gfc_charlen_type_node
,
6320 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
,
6321 expr
->value
.op
.op2
->ts
.u
.cl
->backend_decl
));
6324 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
6325 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
);
6329 if (expr
->value
.function
.esym
== NULL
6330 || expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6332 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6336 /* Map expressions involving the dummy arguments onto the actual
6337 argument expressions. */
6338 gfc_init_interface_mapping (&mapping
);
6339 formal
= gfc_sym_get_dummy_args (expr
->symtree
->n
.sym
);
6340 arg
= expr
->value
.function
.actual
;
6342 /* Set se = NULL in the calls to the interface mapping, to suppress any
6344 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
6349 gfc_add_interface_mapping (&mapping
, formal
->sym
, NULL
, arg
->expr
);
6352 gfc_init_se (&tse
, NULL
);
6354 /* Build the expression for the character length and convert it. */
6355 gfc_apply_interface_mapping (&mapping
, &tse
, expr
->ts
.u
.cl
->length
);
6357 gfc_add_block_to_block (&se
->pre
, &tse
.pre
);
6358 gfc_add_block_to_block (&se
->post
, &tse
.post
);
6359 tse
.expr
= fold_convert (gfc_charlen_type_node
, tse
.expr
);
6360 tse
.expr
= fold_build2_loc (input_location
, MAX_EXPR
,
6361 gfc_charlen_type_node
, tse
.expr
,
6362 build_int_cst (gfc_charlen_type_node
, 0));
6363 expr
->ts
.u
.cl
->backend_decl
= tse
.expr
;
6364 gfc_free_interface_mapping (&mapping
);
6368 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6374 /* Helper function to check dimensions. */
6376 transposed_dims (gfc_ss
*ss
)
6380 for (n
= 0; n
< ss
->dimen
; n
++)
6381 if (ss
->dim
[n
] != n
)
6387 /* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
6388 AR_FULL, suitable for the scalarizer. */
6391 walk_coarray (gfc_expr
*e
)
6395 gcc_assert (gfc_get_corank (e
) > 0);
6397 ss
= gfc_walk_expr (e
);
6399 /* Fix scalar coarray. */
6400 if (ss
== gfc_ss_terminator
)
6407 if (ref
->type
== REF_ARRAY
6408 && ref
->u
.ar
.codimen
> 0)
6414 gcc_assert (ref
!= NULL
);
6415 if (ref
->u
.ar
.type
== AR_ELEMENT
)
6416 ref
->u
.ar
.type
= AR_SECTION
;
6417 ss
= gfc_reverse_ss (gfc_walk_array_ref (ss
, e
, ref
));
6424 /* Convert an array for passing as an actual argument. Expressions and
6425 vector subscripts are evaluated and stored in a temporary, which is then
6426 passed. For whole arrays the descriptor is passed. For array sections
6427 a modified copy of the descriptor is passed, but using the original data.
6429 This function is also used for array pointer assignments, and there
6432 - se->want_pointer && !se->direct_byref
6433 EXPR is an actual argument. On exit, se->expr contains a
6434 pointer to the array descriptor.
6436 - !se->want_pointer && !se->direct_byref
6437 EXPR is an actual argument to an intrinsic function or the
6438 left-hand side of a pointer assignment. On exit, se->expr
6439 contains the descriptor for EXPR.
6441 - !se->want_pointer && se->direct_byref
6442 EXPR is the right-hand side of a pointer assignment and
6443 se->expr is the descriptor for the previously-evaluated
6444 left-hand side. The function creates an assignment from
6448 The se->force_tmp flag disables the non-copying descriptor optimization
6449 that is used for transpose. It may be used in cases where there is an
6450 alias between the transpose argument and another argument in the same
6454 gfc_conv_expr_descriptor (gfc_se
*se
, gfc_expr
*expr
)
6457 gfc_ss_type ss_type
;
6458 gfc_ss_info
*ss_info
;
6460 gfc_array_info
*info
;
6469 bool subref_array_target
= false;
6470 gfc_expr
*arg
, *ss_expr
;
6472 if (se
->want_coarray
)
6473 ss
= walk_coarray (expr
);
6475 ss
= gfc_walk_expr (expr
);
6477 gcc_assert (ss
!= NULL
);
6478 gcc_assert (ss
!= gfc_ss_terminator
);
6481 ss_type
= ss_info
->type
;
6482 ss_expr
= ss_info
->expr
;
6484 /* Special case: TRANSPOSE which needs no temporary. */
6485 while (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
6486 && NULL
!= (arg
= gfc_get_noncopying_intrinsic_argument (expr
)))
6488 /* This is a call to transpose which has already been handled by the
6489 scalarizer, so that we just need to get its argument's descriptor. */
6490 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
6491 expr
= expr
->value
.function
.actual
->expr
;
6494 /* Special case things we know we can pass easily. */
6495 switch (expr
->expr_type
)
6498 /* If we have a linear array section, we can pass it directly.
6499 Otherwise we need to copy it into a temporary. */
6501 gcc_assert (ss_type
== GFC_SS_SECTION
);
6502 gcc_assert (ss_expr
== expr
);
6503 info
= &ss_info
->data
.array
;
6505 /* Get the descriptor for the array. */
6506 gfc_conv_ss_descriptor (&se
->pre
, ss
, 0);
6507 desc
= info
->descriptor
;
6509 subref_array_target
= se
->direct_byref
&& is_subref_array (expr
);
6510 need_tmp
= gfc_ref_needs_temporary_p (expr
->ref
)
6511 && !subref_array_target
;
6518 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
6520 /* Create a new descriptor if the array doesn't have one. */
6523 else if (info
->ref
->u
.ar
.type
== AR_FULL
|| se
->descriptor_only
)
6525 else if (se
->direct_byref
)
6528 full
= gfc_full_array_ref_p (info
->ref
, NULL
);
6530 if (full
&& !transposed_dims (ss
))
6532 if (se
->direct_byref
&& !se
->byref_noassign
)
6534 /* Copy the descriptor for pointer assignments. */
6535 gfc_add_modify (&se
->pre
, se
->expr
, desc
);
6537 /* Add any offsets from subreferences. */
6538 gfc_get_dataptr_offset (&se
->pre
, se
->expr
, desc
, NULL_TREE
,
6539 subref_array_target
, expr
);
6541 else if (se
->want_pointer
)
6543 /* We pass full arrays directly. This means that pointers and
6544 allocatable arrays should also work. */
6545 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
6552 if (expr
->ts
.type
== BT_CHARACTER
)
6553 se
->string_length
= gfc_get_expr_charlen (expr
);
6555 gfc_free_ss_chain (ss
);
6561 /* A transformational function return value will be a temporary
6562 array descriptor. We still need to go through the scalarizer
6563 to create the descriptor. Elemental functions are handled as
6564 arbitrary expressions, i.e. copy to a temporary. */
6566 if (se
->direct_byref
)
6568 gcc_assert (ss_type
== GFC_SS_FUNCTION
&& ss_expr
== expr
);
6570 /* For pointer assignments pass the descriptor directly. */
6574 gcc_assert (se
->ss
== ss
);
6575 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
6576 gfc_conv_expr (se
, expr
);
6577 gfc_free_ss_chain (ss
);
6581 if (ss_expr
!= expr
|| ss_type
!= GFC_SS_FUNCTION
)
6583 if (ss_expr
!= expr
)
6584 /* Elemental function. */
6585 gcc_assert ((expr
->value
.function
.esym
!= NULL
6586 && expr
->value
.function
.esym
->attr
.elemental
)
6587 || (expr
->value
.function
.isym
!= NULL
6588 && expr
->value
.function
.isym
->elemental
)
6589 || gfc_inline_intrinsic_function_p (expr
));
6591 gcc_assert (ss_type
== GFC_SS_INTRINSIC
);
6594 if (expr
->ts
.type
== BT_CHARACTER
6595 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
6596 get_array_charlen (expr
, se
);
6602 /* Transformational function. */
6603 info
= &ss_info
->data
.array
;
6609 /* Constant array constructors don't need a temporary. */
6610 if (ss_type
== GFC_SS_CONSTRUCTOR
6611 && expr
->ts
.type
!= BT_CHARACTER
6612 && gfc_constant_array_constructor_p (expr
->value
.constructor
))
6615 info
= &ss_info
->data
.array
;
6625 /* Something complicated. Copy it into a temporary. */
6631 /* If we are creating a temporary, we don't need to bother about aliases
6636 gfc_init_loopinfo (&loop
);
6638 /* Associate the SS with the loop. */
6639 gfc_add_ss_to_loop (&loop
, ss
);
6641 /* Tell the scalarizer not to bother creating loop variables, etc. */
6643 loop
.array_parameter
= 1;
6645 /* The right-hand side of a pointer assignment mustn't use a temporary. */
6646 gcc_assert (!se
->direct_byref
);
6648 /* Setup the scalarizing loops and bounds. */
6649 gfc_conv_ss_startstride (&loop
);
6653 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
6654 get_array_charlen (expr
, se
);
6656 /* Tell the scalarizer to make a temporary. */
6657 loop
.temp_ss
= gfc_get_temp_ss (gfc_typenode_for_spec (&expr
->ts
),
6658 ((expr
->ts
.type
== BT_CHARACTER
)
6659 ? expr
->ts
.u
.cl
->backend_decl
6663 se
->string_length
= loop
.temp_ss
->info
->string_length
;
6664 gcc_assert (loop
.temp_ss
->dimen
== loop
.dimen
);
6665 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
6668 gfc_conv_loop_setup (&loop
, & expr
->where
);
6672 /* Copy into a temporary and pass that. We don't need to copy the data
6673 back because expressions and vector subscripts must be INTENT_IN. */
6674 /* TODO: Optimize passing function return values. */
6678 /* Start the copying loops. */
6679 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
6680 gfc_mark_ss_chain_used (ss
, 1);
6681 gfc_start_scalarized_body (&loop
, &block
);
6683 /* Copy each data element. */
6684 gfc_init_se (&lse
, NULL
);
6685 gfc_copy_loopinfo_to_se (&lse
, &loop
);
6686 gfc_init_se (&rse
, NULL
);
6687 gfc_copy_loopinfo_to_se (&rse
, &loop
);
6689 lse
.ss
= loop
.temp_ss
;
6692 gfc_conv_scalarized_array_ref (&lse
, NULL
);
6693 if (expr
->ts
.type
== BT_CHARACTER
)
6695 gfc_conv_expr (&rse
, expr
);
6696 if (POINTER_TYPE_P (TREE_TYPE (rse
.expr
)))
6697 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
6701 gfc_conv_expr_val (&rse
, expr
);
6703 gfc_add_block_to_block (&block
, &rse
.pre
);
6704 gfc_add_block_to_block (&block
, &lse
.pre
);
6706 lse
.string_length
= rse
.string_length
;
6707 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true,
6708 expr
->expr_type
== EXPR_VARIABLE
6709 || expr
->expr_type
== EXPR_ARRAY
, true);
6710 gfc_add_expr_to_block (&block
, tmp
);
6712 /* Finish the copying loops. */
6713 gfc_trans_scalarizing_loops (&loop
, &block
);
6715 desc
= loop
.temp_ss
->info
->data
.array
.descriptor
;
6717 else if (expr
->expr_type
== EXPR_FUNCTION
&& !transposed_dims (ss
))
6719 desc
= info
->descriptor
;
6720 se
->string_length
= ss_info
->string_length
;
6724 /* We pass sections without copying to a temporary. Make a new
6725 descriptor and point it at the section we want. The loop variable
6726 limits will be the limits of the section.
6727 A function may decide to repack the array to speed up access, but
6728 we're not bothered about that here. */
6729 int dim
, ndim
, codim
;
6737 ndim
= info
->ref
? info
->ref
->u
.ar
.dimen
: ss
->dimen
;
6739 if (se
->want_coarray
)
6741 gfc_array_ref
*ar
= &info
->ref
->u
.ar
;
6743 codim
= gfc_get_corank (expr
);
6744 for (n
= 0; n
< codim
- 1; n
++)
6746 /* Make sure we are not lost somehow. */
6747 gcc_assert (ar
->dimen_type
[n
+ ndim
] == DIMEN_THIS_IMAGE
);
6749 /* Make sure the call to gfc_conv_section_startstride won't
6750 generate unnecessary code to calculate stride. */
6751 gcc_assert (ar
->stride
[n
+ ndim
] == NULL
);
6753 gfc_conv_section_startstride (&loop
.pre
, ss
, n
+ ndim
);
6754 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
6755 loop
.to
[n
+ loop
.dimen
] = info
->end
[n
+ ndim
];
6758 gcc_assert (n
== codim
- 1);
6759 evaluate_bound (&loop
.pre
, info
->start
, ar
->start
,
6760 info
->descriptor
, n
+ ndim
, true);
6761 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
6766 /* Set the string_length for a character array. */
6767 if (expr
->ts
.type
== BT_CHARACTER
)
6768 se
->string_length
= gfc_get_expr_charlen (expr
);
6770 desc
= info
->descriptor
;
6771 if (se
->direct_byref
&& !se
->byref_noassign
)
6773 /* For pointer assignments we fill in the destination. */
6775 parmtype
= TREE_TYPE (parm
);
6779 /* Otherwise make a new one. */
6780 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
6781 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
, codim
,
6782 loop
.from
, loop
.to
, 0,
6783 GFC_ARRAY_UNKNOWN
, false);
6784 parm
= gfc_create_var (parmtype
, "parm");
6787 offset
= gfc_index_zero_node
;
6789 /* The following can be somewhat confusing. We have two
6790 descriptors, a new one and the original array.
6791 {parm, parmtype, dim} refer to the new one.
6792 {desc, type, n, loop} refer to the original, which maybe
6793 a descriptorless array.
6794 The bounds of the scalarization are the bounds of the section.
6795 We don't have to worry about numeric overflows when calculating
6796 the offsets because all elements are within the array data. */
6798 /* Set the dtype. */
6799 tmp
= gfc_conv_descriptor_dtype (parm
);
6800 gfc_add_modify (&loop
.pre
, tmp
, gfc_get_dtype (parmtype
));
6802 /* Set offset for assignments to pointer only to zero if it is not
6804 if (se
->direct_byref
6805 && info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
6806 base
= gfc_index_zero_node
;
6807 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
6808 base
= gfc_evaluate_now (gfc_conv_array_offset (desc
), &loop
.pre
);
6812 for (n
= 0; n
< ndim
; n
++)
6814 stride
= gfc_conv_array_stride (desc
, n
);
6816 /* Work out the offset. */
6818 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
6820 gcc_assert (info
->subscript
[n
]
6821 && info
->subscript
[n
]->info
->type
== GFC_SS_SCALAR
);
6822 start
= info
->subscript
[n
]->info
->data
.scalar
.value
;
6826 /* Evaluate and remember the start of the section. */
6827 start
= info
->start
[n
];
6828 stride
= gfc_evaluate_now (stride
, &loop
.pre
);
6831 tmp
= gfc_conv_array_lbound (desc
, n
);
6832 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
6834 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
6836 offset
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (tmp
),
6840 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
6842 /* For elemental dimensions, we only need the offset. */
6846 /* Vector subscripts need copying and are handled elsewhere. */
6848 gcc_assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
6850 /* look for the corresponding scalarizer dimension: dim. */
6851 for (dim
= 0; dim
< ndim
; dim
++)
6852 if (ss
->dim
[dim
] == n
)
6855 /* loop exited early: the DIM being looked for has been found. */
6856 gcc_assert (dim
< ndim
);
6858 /* Set the new lower bound. */
6859 from
= loop
.from
[dim
];
6862 /* If we have an array section or are assigning make sure that
6863 the lower bound is 1. References to the full
6864 array should otherwise keep the original bounds. */
6866 || info
->ref
->u
.ar
.type
!= AR_FULL
)
6867 && !integer_onep (from
))
6869 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6870 gfc_array_index_type
, gfc_index_one_node
,
6872 to
= fold_build2_loc (input_location
, PLUS_EXPR
,
6873 gfc_array_index_type
, to
, tmp
);
6874 from
= gfc_index_one_node
;
6876 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
6877 gfc_rank_cst
[dim
], from
);
6879 /* Set the new upper bound. */
6880 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
6881 gfc_rank_cst
[dim
], to
);
6883 /* Multiply the stride by the section stride to get the
6885 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
6886 gfc_array_index_type
,
6887 stride
, info
->stride
[n
]);
6889 if (se
->direct_byref
6891 && info
->ref
->u
.ar
.type
!= AR_FULL
)
6893 base
= fold_build2_loc (input_location
, MINUS_EXPR
,
6894 TREE_TYPE (base
), base
, stride
);
6896 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
6898 tmp
= gfc_conv_array_lbound (desc
, n
);
6899 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6900 TREE_TYPE (base
), tmp
, loop
.from
[dim
]);
6901 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6902 TREE_TYPE (base
), tmp
,
6903 gfc_conv_array_stride (desc
, n
));
6904 base
= fold_build2_loc (input_location
, PLUS_EXPR
,
6905 TREE_TYPE (base
), tmp
, base
);
6908 /* Store the new stride. */
6909 gfc_conv_descriptor_stride_set (&loop
.pre
, parm
,
6910 gfc_rank_cst
[dim
], stride
);
6913 for (n
= loop
.dimen
; n
< loop
.dimen
+ codim
; n
++)
6915 from
= loop
.from
[n
];
6917 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
6918 gfc_rank_cst
[n
], from
);
6919 if (n
< loop
.dimen
+ codim
- 1)
6920 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
6921 gfc_rank_cst
[n
], to
);
6924 if (se
->data_not_needed
)
6925 gfc_conv_descriptor_data_set (&loop
.pre
, parm
,
6926 gfc_index_zero_node
);
6928 /* Point the data pointer at the 1st element in the section. */
6929 gfc_get_dataptr_offset (&loop
.pre
, parm
, desc
, offset
,
6930 subref_array_target
, expr
);
6932 if ((se
->direct_byref
|| GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
6933 && !se
->data_not_needed
)
6935 /* Set the offset. */
6936 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, base
);
6940 /* Only the callee knows what the correct offset it, so just set
6942 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, gfc_index_zero_node
);
6947 if (!se
->direct_byref
|| se
->byref_noassign
)
6949 /* Get a pointer to the new descriptor. */
6950 if (se
->want_pointer
)
6951 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
6956 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
6957 gfc_add_block_to_block (&se
->post
, &loop
.post
);
6959 /* Cleanup the scalarizer. */
6960 gfc_cleanup_loop (&loop
);
6963 /* Helper function for gfc_conv_array_parameter if array size needs to be
6967 array_parameter_size (tree desc
, gfc_expr
*expr
, tree
*size
)
6970 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
6971 *size
= GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc
));
6972 else if (expr
->rank
> 1)
6973 *size
= build_call_expr_loc (input_location
,
6974 gfor_fndecl_size0
, 1,
6975 gfc_build_addr_expr (NULL
, desc
));
6978 tree ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_index_zero_node
);
6979 tree lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_index_zero_node
);
6981 *size
= fold_build2_loc (input_location
, MINUS_EXPR
,
6982 gfc_array_index_type
, ubound
, lbound
);
6983 *size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
6984 *size
, gfc_index_one_node
);
6985 *size
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
6986 *size
, gfc_index_zero_node
);
6988 elem
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
6989 *size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6990 *size
, fold_convert (gfc_array_index_type
, elem
));
6993 /* Convert an array for passing as an actual parameter. */
6994 /* TODO: Optimize passing g77 arrays. */
6997 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, bool g77
,
6998 const gfc_symbol
*fsym
, const char *proc_name
,
7003 tree tmp
= NULL_TREE
;
7005 tree parent
= DECL_CONTEXT (current_function_decl
);
7006 bool full_array_var
;
7007 bool this_array_result
;
7010 bool array_constructor
;
7011 bool good_allocatable
;
7012 bool ultimate_ptr_comp
;
7013 bool ultimate_alloc_comp
;
7018 ultimate_ptr_comp
= false;
7019 ultimate_alloc_comp
= false;
7021 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7023 if (ref
->next
== NULL
)
7026 if (ref
->type
== REF_COMPONENT
)
7028 ultimate_ptr_comp
= ref
->u
.c
.component
->attr
.pointer
;
7029 ultimate_alloc_comp
= ref
->u
.c
.component
->attr
.allocatable
;
7033 full_array_var
= false;
7036 if (expr
->expr_type
== EXPR_VARIABLE
&& ref
&& !ultimate_ptr_comp
)
7037 full_array_var
= gfc_full_array_ref_p (ref
, &contiguous
);
7039 sym
= full_array_var
? expr
->symtree
->n
.sym
: NULL
;
7041 /* The symbol should have an array specification. */
7042 gcc_assert (!sym
|| sym
->as
|| ref
->u
.ar
.as
);
7044 if (expr
->expr_type
== EXPR_ARRAY
&& expr
->ts
.type
== BT_CHARACTER
)
7046 get_array_ctor_strlen (&se
->pre
, expr
->value
.constructor
, &tmp
);
7047 expr
->ts
.u
.cl
->backend_decl
= tmp
;
7048 se
->string_length
= tmp
;
7051 /* Is this the result of the enclosing procedure? */
7052 this_array_result
= (full_array_var
&& sym
->attr
.flavor
== FL_PROCEDURE
);
7053 if (this_array_result
7054 && (sym
->backend_decl
!= current_function_decl
)
7055 && (sym
->backend_decl
!= parent
))
7056 this_array_result
= false;
7058 /* Passing address of the array if it is not pointer or assumed-shape. */
7059 if (full_array_var
&& g77
&& !this_array_result
7060 && sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
7062 tmp
= gfc_get_symbol_decl (sym
);
7064 if (sym
->ts
.type
== BT_CHARACTER
)
7065 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
7067 if (!sym
->attr
.pointer
7069 && sym
->as
->type
!= AS_ASSUMED_SHAPE
7070 && sym
->as
->type
!= AS_DEFERRED
7071 && sym
->as
->type
!= AS_ASSUMED_RANK
7072 && !sym
->attr
.allocatable
)
7074 /* Some variables are declared directly, others are declared as
7075 pointers and allocated on the heap. */
7076 if (sym
->attr
.dummy
|| POINTER_TYPE_P (TREE_TYPE (tmp
)))
7079 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
7081 array_parameter_size (tmp
, expr
, size
);
7085 if (sym
->attr
.allocatable
)
7087 if (sym
->attr
.dummy
|| sym
->attr
.result
)
7089 gfc_conv_expr_descriptor (se
, expr
);
7093 array_parameter_size (tmp
, expr
, size
);
7094 se
->expr
= gfc_conv_array_data (tmp
);
7099 /* A convenient reduction in scope. */
7100 contiguous
= g77
&& !this_array_result
&& contiguous
;
7102 /* There is no need to pack and unpack the array, if it is contiguous
7103 and not a deferred- or assumed-shape array, or if it is simply
7105 no_pack
= ((sym
&& sym
->as
7106 && !sym
->attr
.pointer
7107 && sym
->as
->type
!= AS_DEFERRED
7108 && sym
->as
->type
!= AS_ASSUMED_RANK
7109 && sym
->as
->type
!= AS_ASSUMED_SHAPE
)
7111 (ref
&& ref
->u
.ar
.as
7112 && ref
->u
.ar
.as
->type
!= AS_DEFERRED
7113 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_RANK
7114 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_SHAPE
)
7116 gfc_is_simply_contiguous (expr
, false));
7118 no_pack
= contiguous
&& no_pack
;
7120 /* Array constructors are always contiguous and do not need packing. */
7121 array_constructor
= g77
&& !this_array_result
&& expr
->expr_type
== EXPR_ARRAY
;
7123 /* Same is true of contiguous sections from allocatable variables. */
7124 good_allocatable
= contiguous
7126 && expr
->symtree
->n
.sym
->attr
.allocatable
;
7128 /* Or ultimate allocatable components. */
7129 ultimate_alloc_comp
= contiguous
&& ultimate_alloc_comp
;
7131 if (no_pack
|| array_constructor
|| good_allocatable
|| ultimate_alloc_comp
)
7133 gfc_conv_expr_descriptor (se
, expr
);
7134 if (expr
->ts
.type
== BT_CHARACTER
)
7135 se
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
7137 array_parameter_size (se
->expr
, expr
, size
);
7138 se
->expr
= gfc_conv_array_data (se
->expr
);
7142 if (this_array_result
)
7144 /* Result of the enclosing function. */
7145 gfc_conv_expr_descriptor (se
, expr
);
7147 array_parameter_size (se
->expr
, expr
, size
);
7148 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7150 if (g77
&& TREE_TYPE (TREE_TYPE (se
->expr
)) != NULL_TREE
7151 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
7152 se
->expr
= gfc_conv_array_data (build_fold_indirect_ref_loc (input_location
,
7159 /* Every other type of array. */
7160 se
->want_pointer
= 1;
7161 gfc_conv_expr_descriptor (se
, expr
);
7163 array_parameter_size (build_fold_indirect_ref_loc (input_location
,
7168 /* Deallocate the allocatable components of structures that are
7170 if ((expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
)
7171 && expr
->ts
.u
.derived
->attr
.alloc_comp
7172 && expr
->expr_type
!= EXPR_VARIABLE
)
7174 tmp
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7175 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
, expr
->rank
);
7177 /* The components shall be deallocated before their containing entity. */
7178 gfc_prepend_expr_to_block (&se
->post
, tmp
);
7181 if (g77
|| (fsym
&& fsym
->attr
.contiguous
7182 && !gfc_is_simply_contiguous (expr
, false)))
7184 tree origptr
= NULL_TREE
;
7188 /* For contiguous arrays, save the original value of the descriptor. */
7191 origptr
= gfc_create_var (pvoid_type_node
, "origptr");
7192 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7193 tmp
= gfc_conv_array_data (tmp
);
7194 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7195 TREE_TYPE (origptr
), origptr
,
7196 fold_convert (TREE_TYPE (origptr
), tmp
));
7197 gfc_add_expr_to_block (&se
->pre
, tmp
);
7200 /* Repack the array. */
7201 if (gfc_option
.warn_array_temp
)
7204 gfc_warning ("Creating array temporary at %L for argument '%s'",
7205 &expr
->where
, fsym
->name
);
7207 gfc_warning ("Creating array temporary at %L", &expr
->where
);
7210 ptr
= build_call_expr_loc (input_location
,
7211 gfor_fndecl_in_pack
, 1, desc
);
7213 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7215 tmp
= gfc_conv_expr_present (sym
);
7216 ptr
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
7217 tmp
, fold_convert (TREE_TYPE (se
->expr
), ptr
),
7218 fold_convert (TREE_TYPE (se
->expr
), null_pointer_node
));
7221 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
7223 /* Use the packed data for the actual argument, except for contiguous arrays,
7224 where the descriptor's data component is set. */
7229 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7230 gfc_conv_descriptor_data_set (&se
->pre
, tmp
, ptr
);
7233 if (gfc_option
.rtcheck
& GFC_RTCHECK_ARRAY_TEMPS
)
7237 if (fsym
&& proc_name
)
7238 asprintf (&msg
, "An array temporary was created for argument "
7239 "'%s' of procedure '%s'", fsym
->name
, proc_name
);
7241 asprintf (&msg
, "An array temporary was created");
7243 tmp
= build_fold_indirect_ref_loc (input_location
,
7245 tmp
= gfc_conv_array_data (tmp
);
7246 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7247 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
7249 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7250 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7252 gfc_conv_expr_present (sym
), tmp
);
7254 gfc_trans_runtime_check (false, true, tmp
, &se
->pre
,
7259 gfc_start_block (&block
);
7261 /* Copy the data back. */
7262 if (fsym
== NULL
|| fsym
->attr
.intent
!= INTENT_IN
)
7264 tmp
= build_call_expr_loc (input_location
,
7265 gfor_fndecl_in_unpack
, 2, desc
, ptr
);
7266 gfc_add_expr_to_block (&block
, tmp
);
7269 /* Free the temporary. */
7270 tmp
= gfc_call_free (convert (pvoid_type_node
, ptr
));
7271 gfc_add_expr_to_block (&block
, tmp
);
7273 stmt
= gfc_finish_block (&block
);
7275 gfc_init_block (&block
);
7276 /* Only if it was repacked. This code needs to be executed before the
7277 loop cleanup code. */
7278 tmp
= build_fold_indirect_ref_loc (input_location
,
7280 tmp
= gfc_conv_array_data (tmp
);
7281 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7282 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
7284 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7285 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7287 gfc_conv_expr_present (sym
), tmp
);
7289 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
7291 gfc_add_expr_to_block (&block
, tmp
);
7292 gfc_add_block_to_block (&block
, &se
->post
);
7294 gfc_init_block (&se
->post
);
7296 /* Reset the descriptor pointer. */
7299 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7300 gfc_conv_descriptor_data_set (&se
->post
, tmp
, origptr
);
7303 gfc_add_block_to_block (&se
->post
, &block
);
7308 /* Generate code to deallocate an array, if it is allocated. */
7311 gfc_trans_dealloc_allocated (tree descriptor
, bool coarray
, gfc_expr
*expr
)
7317 gfc_start_block (&block
);
7319 var
= gfc_conv_descriptor_data_get (descriptor
);
7322 /* Call array_deallocate with an int * present in the second argument.
7323 Although it is ignored here, it's presence ensures that arrays that
7324 are already deallocated are ignored. */
7325 tmp
= gfc_deallocate_with_status (coarray
? descriptor
: var
, NULL_TREE
,
7326 NULL_TREE
, NULL_TREE
, NULL_TREE
, true,
7328 gfc_add_expr_to_block (&block
, tmp
);
7330 /* Zero the data pointer. */
7331 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
7332 var
, build_int_cst (TREE_TYPE (var
), 0));
7333 gfc_add_expr_to_block (&block
, tmp
);
7335 return gfc_finish_block (&block
);
7339 /* This helper function calculates the size in words of a full array. */
7342 get_full_array_size (stmtblock_t
*block
, tree decl
, int rank
)
7347 idx
= gfc_rank_cst
[rank
- 1];
7348 nelems
= gfc_conv_descriptor_ubound_get (decl
, idx
);
7349 tmp
= gfc_conv_descriptor_lbound_get (decl
, idx
);
7350 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7352 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7353 tmp
, gfc_index_one_node
);
7354 tmp
= gfc_evaluate_now (tmp
, block
);
7356 nelems
= gfc_conv_descriptor_stride_get (decl
, idx
);
7357 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7359 return gfc_evaluate_now (tmp
, block
);
7363 /* Allocate dest to the same size as src, and copy src -> dest.
7364 If no_malloc is set, only the copy is done. */
7367 duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
7377 /* If the source is null, set the destination to null. Then,
7378 allocate memory to the destination. */
7379 gfc_init_block (&block
);
7381 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
7383 tmp
= null_pointer_node
;
7384 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, type
, dest
, tmp
);
7385 gfc_add_expr_to_block (&block
, tmp
);
7386 null_data
= gfc_finish_block (&block
);
7388 gfc_init_block (&block
);
7389 size
= TYPE_SIZE_UNIT (TREE_TYPE (type
));
7392 tmp
= gfc_call_malloc (&block
, type
, size
);
7393 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
7394 dest
, fold_convert (type
, tmp
));
7395 gfc_add_expr_to_block (&block
, tmp
);
7398 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
7399 tmp
= build_call_expr_loc (input_location
, tmp
, 3, dest
, src
,
7400 fold_convert (size_type_node
, size
));
7404 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
7405 null_data
= gfc_finish_block (&block
);
7407 gfc_init_block (&block
);
7409 nelems
= get_full_array_size (&block
, src
, rank
);
7411 nelems
= gfc_index_one_node
;
7413 tmp
= fold_convert (gfc_array_index_type
,
7414 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
7415 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7419 tmp
= TREE_TYPE (gfc_conv_descriptor_data_get (src
));
7420 tmp
= gfc_call_malloc (&block
, tmp
, size
);
7421 gfc_conv_descriptor_data_set (&block
, dest
, tmp
);
7424 /* We know the temporary and the value will be the same length,
7425 so can use memcpy. */
7426 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
7427 tmp
= build_call_expr_loc (input_location
,
7428 tmp
, 3, gfc_conv_descriptor_data_get (dest
),
7429 gfc_conv_descriptor_data_get (src
),
7430 fold_convert (size_type_node
, size
));
7433 gfc_add_expr_to_block (&block
, tmp
);
7434 tmp
= gfc_finish_block (&block
);
7436 /* Null the destination if the source is null; otherwise do
7437 the allocate and copy. */
7438 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src
)))
7441 null_cond
= gfc_conv_descriptor_data_get (src
);
7443 null_cond
= convert (pvoid_type_node
, null_cond
);
7444 null_cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7445 null_cond
, null_pointer_node
);
7446 return build3_v (COND_EXPR
, null_cond
, tmp
, null_data
);
7450 /* Allocate dest to the same size as src, and copy data src -> dest. */
7453 gfc_duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
)
7455 return duplicate_allocatable (dest
, src
, type
, rank
, false);
7459 /* Copy data src -> dest. */
7462 gfc_copy_allocatable_data (tree dest
, tree src
, tree type
, int rank
)
7464 return duplicate_allocatable (dest
, src
, type
, rank
, true);
7468 /* Recursively traverse an object of derived type, generating code to
7469 deallocate, nullify or copy allocatable components. This is the work horse
7470 function for the functions named in this enum. */
7472 enum {DEALLOCATE_ALLOC_COMP
= 1, DEALLOCATE_ALLOC_COMP_NO_CAF
,
7473 NULLIFY_ALLOC_COMP
, COPY_ALLOC_COMP
, COPY_ONLY_ALLOC_COMP
,
7474 COPY_ALLOC_COMP_CAF
};
7477 structure_alloc_comps (gfc_symbol
* der_type
, tree decl
,
7478 tree dest
, int rank
, int purpose
)
7482 stmtblock_t fnblock
;
7483 stmtblock_t loopbody
;
7484 stmtblock_t tmpblock
;
7495 tree null_cond
= NULL_TREE
;
7496 bool called_dealloc_with_status
;
7498 gfc_init_block (&fnblock
);
7500 decl_type
= TREE_TYPE (decl
);
7502 if ((POINTER_TYPE_P (decl_type
) && rank
!= 0)
7503 || (TREE_CODE (decl_type
) == REFERENCE_TYPE
&& rank
== 0))
7504 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
7506 /* Just in case in gets dereferenced. */
7507 decl_type
= TREE_TYPE (decl
);
7509 /* If this an array of derived types with allocatable components
7510 build a loop and recursively call this function. */
7511 if (TREE_CODE (decl_type
) == ARRAY_TYPE
7512 || (GFC_DESCRIPTOR_TYPE_P (decl_type
) && rank
!= 0))
7514 tmp
= gfc_conv_array_data (decl
);
7515 var
= build_fold_indirect_ref_loc (input_location
,
7518 /* Get the number of elements - 1 and set the counter. */
7519 if (GFC_DESCRIPTOR_TYPE_P (decl_type
))
7521 /* Use the descriptor for an allocatable array. Since this
7522 is a full array reference, we only need the descriptor
7523 information from dimension = rank. */
7524 tmp
= get_full_array_size (&fnblock
, decl
, rank
);
7525 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7526 gfc_array_index_type
, tmp
,
7527 gfc_index_one_node
);
7529 null_cond
= gfc_conv_descriptor_data_get (decl
);
7530 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
7531 boolean_type_node
, null_cond
,
7532 build_int_cst (TREE_TYPE (null_cond
), 0));
7536 /* Otherwise use the TYPE_DOMAIN information. */
7537 tmp
= array_type_nelts (decl_type
);
7538 tmp
= fold_convert (gfc_array_index_type
, tmp
);
7541 /* Remember that this is, in fact, the no. of elements - 1. */
7542 nelems
= gfc_evaluate_now (tmp
, &fnblock
);
7543 index
= gfc_create_var (gfc_array_index_type
, "S");
7545 /* Build the body of the loop. */
7546 gfc_init_block (&loopbody
);
7548 vref
= gfc_build_array_ref (var
, index
, NULL
);
7550 if (purpose
== COPY_ALLOC_COMP
)
7552 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
7554 tmp
= gfc_duplicate_allocatable (dest
, decl
, decl_type
, rank
);
7555 gfc_add_expr_to_block (&fnblock
, tmp
);
7557 tmp
= build_fold_indirect_ref_loc (input_location
,
7558 gfc_conv_array_data (dest
));
7559 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
7560 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
, purpose
);
7562 else if (purpose
== COPY_ONLY_ALLOC_COMP
)
7564 tmp
= build_fold_indirect_ref_loc (input_location
,
7565 gfc_conv_array_data (dest
));
7566 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
7567 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
,
7571 tmp
= structure_alloc_comps (der_type
, vref
, NULL_TREE
, rank
, purpose
);
7573 gfc_add_expr_to_block (&loopbody
, tmp
);
7575 /* Build the loop and return. */
7576 gfc_init_loopinfo (&loop
);
7578 loop
.from
[0] = gfc_index_zero_node
;
7579 loop
.loopvar
[0] = index
;
7580 loop
.to
[0] = nelems
;
7581 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
7582 gfc_add_block_to_block (&fnblock
, &loop
.pre
);
7584 tmp
= gfc_finish_block (&fnblock
);
7585 if (null_cond
!= NULL_TREE
)
7586 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
7587 build_empty_stmt (input_location
));
7592 /* Otherwise, act on the components or recursively call self to
7593 act on a chain of components. */
7594 for (c
= der_type
->components
; c
; c
= c
->next
)
7596 bool cmp_has_alloc_comps
= (c
->ts
.type
== BT_DERIVED
7597 || c
->ts
.type
== BT_CLASS
)
7598 && c
->ts
.u
.derived
->attr
.alloc_comp
;
7599 cdecl = c
->backend_decl
;
7600 ctype
= TREE_TYPE (cdecl);
7604 case DEALLOCATE_ALLOC_COMP
:
7605 case DEALLOCATE_ALLOC_COMP_NO_CAF
:
7607 /* gfc_deallocate_scalar_with_status calls gfc_deallocate_alloc_comp
7608 (i.e. this function) so generate all the calls and suppress the
7609 recursion from here, if necessary. */
7610 called_dealloc_with_status
= false;
7611 gfc_init_block (&tmpblock
);
7613 if ((c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
)
7614 || (c
->ts
.type
== BT_CLASS
&& !CLASS_DATA (c
)->attr
.class_pointer
))
7616 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7617 decl
, cdecl, NULL_TREE
);
7619 /* The finalizer frees allocatable components. */
7620 called_dealloc_with_status
7621 = gfc_add_comp_finalizer_call (&tmpblock
, comp
, c
,
7622 purpose
== DEALLOCATE_ALLOC_COMP
);
7627 if (c
->attr
.allocatable
&& !c
->attr
.proc_pointer
7628 && (c
->attr
.dimension
7629 || (c
->attr
.codimension
7630 && purpose
!= DEALLOCATE_ALLOC_COMP_NO_CAF
)))
7632 if (comp
== NULL_TREE
)
7633 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7634 decl
, cdecl, NULL_TREE
);
7635 tmp
= gfc_trans_dealloc_allocated (comp
, c
->attr
.codimension
, NULL
);
7636 gfc_add_expr_to_block (&tmpblock
, tmp
);
7638 else if (c
->attr
.allocatable
&& !c
->attr
.codimension
)
7640 /* Allocatable scalar components. */
7641 if (comp
== NULL_TREE
)
7642 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7643 decl
, cdecl, NULL_TREE
);
7645 tmp
= gfc_deallocate_scalar_with_status (comp
, NULL
, true, NULL
,
7647 gfc_add_expr_to_block (&tmpblock
, tmp
);
7648 called_dealloc_with_status
= true;
7650 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7651 void_type_node
, comp
,
7652 build_int_cst (TREE_TYPE (comp
), 0));
7653 gfc_add_expr_to_block (&tmpblock
, tmp
);
7655 else if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
7656 && (!CLASS_DATA (c
)->attr
.codimension
7657 || purpose
!= DEALLOCATE_ALLOC_COMP_NO_CAF
))
7659 /* Allocatable CLASS components. */
7661 /* Add reference to '_data' component. */
7662 tmp
= CLASS_DATA (c
)->backend_decl
;
7663 comp
= fold_build3_loc (input_location
, COMPONENT_REF
,
7664 TREE_TYPE (tmp
), comp
, tmp
, NULL_TREE
);
7666 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp
)))
7667 tmp
= gfc_trans_dealloc_allocated (comp
,
7668 CLASS_DATA (c
)->attr
.codimension
, NULL
);
7671 tmp
= gfc_deallocate_scalar_with_status (comp
, NULL_TREE
, true, NULL
,
7672 CLASS_DATA (c
)->ts
);
7673 gfc_add_expr_to_block (&tmpblock
, tmp
);
7674 called_dealloc_with_status
= true;
7676 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7677 void_type_node
, comp
,
7678 build_int_cst (TREE_TYPE (comp
), 0));
7680 gfc_add_expr_to_block (&tmpblock
, tmp
);
7683 if (cmp_has_alloc_comps
7685 && !called_dealloc_with_status
)
7687 /* Do not deallocate the components of ultimate pointer
7688 components or iteratively call self if call has been made
7689 to gfc_trans_dealloc_allocated */
7690 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7691 decl
, cdecl, NULL_TREE
);
7692 rank
= c
->as
? c
->as
->rank
: 0;
7693 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
7695 gfc_add_expr_to_block (&fnblock
, tmp
);
7698 /* Now add the deallocation of this component. */
7699 gfc_add_block_to_block (&fnblock
, &tmpblock
);
7702 case NULLIFY_ALLOC_COMP
:
7703 if (c
->attr
.pointer
)
7705 else if (c
->attr
.allocatable
7706 && (c
->attr
.dimension
|| c
->attr
.codimension
))
7708 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7709 decl
, cdecl, NULL_TREE
);
7710 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
7712 else if (c
->attr
.allocatable
)
7714 /* Allocatable scalar components. */
7715 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7716 decl
, cdecl, NULL_TREE
);
7717 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7718 void_type_node
, comp
,
7719 build_int_cst (TREE_TYPE (comp
), 0));
7720 gfc_add_expr_to_block (&fnblock
, tmp
);
7722 else if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
7724 /* Allocatable CLASS components. */
7725 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7726 decl
, cdecl, NULL_TREE
);
7727 /* Add reference to '_data' component. */
7728 tmp
= CLASS_DATA (c
)->backend_decl
;
7729 comp
= fold_build3_loc (input_location
, COMPONENT_REF
,
7730 TREE_TYPE (tmp
), comp
, tmp
, NULL_TREE
);
7731 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp
)))
7732 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
7735 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7736 void_type_node
, comp
,
7737 build_int_cst (TREE_TYPE (comp
), 0));
7738 gfc_add_expr_to_block (&fnblock
, tmp
);
7741 else if (cmp_has_alloc_comps
)
7743 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7744 decl
, cdecl, NULL_TREE
);
7745 rank
= c
->as
? c
->as
->rank
: 0;
7746 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
7748 gfc_add_expr_to_block (&fnblock
, tmp
);
7752 case COPY_ALLOC_COMP_CAF
:
7753 if (!c
->attr
.codimension
7754 && (c
->ts
.type
!= BT_CLASS
|| CLASS_DATA (c
)->attr
.coarray_comp
)
7755 && (c
->ts
.type
!= BT_DERIVED
7756 || !c
->ts
.u
.derived
->attr
.coarray_comp
))
7759 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, decl
,
7761 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, dest
,
7764 if (c
->attr
.codimension
)
7766 if (c
->ts
.type
== BT_CLASS
)
7768 comp
= gfc_class_data_get (comp
);
7769 dcmp
= gfc_class_data_get (dcmp
);
7771 gfc_conv_descriptor_data_set (&fnblock
, dcmp
,
7772 gfc_conv_descriptor_data_get (comp
));
7776 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, dcmp
,
7778 gfc_add_expr_to_block (&fnblock
, tmp
);
7783 case COPY_ALLOC_COMP
:
7784 if (c
->attr
.pointer
)
7787 /* We need source and destination components. */
7788 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, decl
,
7790 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, dest
,
7792 dcmp
= fold_convert (TREE_TYPE (comp
), dcmp
);
7794 if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
7802 dst_data
= gfc_class_data_get (dcmp
);
7803 src_data
= gfc_class_data_get (comp
);
7804 size
= fold_convert (size_type_node
, gfc_vtable_size_get (comp
));
7806 if (CLASS_DATA (c
)->attr
.dimension
)
7808 nelems
= gfc_conv_descriptor_size (src_data
,
7809 CLASS_DATA (c
)->as
->rank
);
7810 size
= fold_build2_loc (input_location
, MULT_EXPR
,
7811 size_type_node
, size
,
7812 fold_convert (size_type_node
,
7816 nelems
= build_int_cst (size_type_node
, 1);
7818 if (CLASS_DATA (c
)->attr
.dimension
7819 || CLASS_DATA (c
)->attr
.codimension
)
7821 src_data
= gfc_conv_descriptor_data_get (src_data
);
7822 dst_data
= gfc_conv_descriptor_data_get (dst_data
);
7825 gfc_init_block (&tmpblock
);
7827 /* Coarray component have to have the same allocation status and
7828 shape/type-parameter/effective-type on the LHS and RHS of an
7829 intrinsic assignment. Hence, we did not deallocated them - and
7830 do not allocate them here. */
7831 if (!CLASS_DATA (c
)->attr
.codimension
)
7833 ftn_tree
= builtin_decl_explicit (BUILT_IN_MALLOC
);
7834 tmp
= build_call_expr_loc (input_location
, ftn_tree
, 1, size
);
7835 gfc_add_modify (&tmpblock
, dst_data
,
7836 fold_convert (TREE_TYPE (dst_data
), tmp
));
7839 tmp
= gfc_copy_class_to_class (comp
, dcmp
, nelems
);
7840 gfc_add_expr_to_block (&tmpblock
, tmp
);
7841 tmp
= gfc_finish_block (&tmpblock
);
7843 gfc_init_block (&tmpblock
);
7844 gfc_add_modify (&tmpblock
, dst_data
,
7845 fold_convert (TREE_TYPE (dst_data
),
7846 null_pointer_node
));
7847 null_data
= gfc_finish_block (&tmpblock
);
7849 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
7850 boolean_type_node
, src_data
,
7853 gfc_add_expr_to_block (&fnblock
, build3_v (COND_EXPR
, null_cond
,
7858 if (c
->attr
.allocatable
&& !c
->attr
.proc_pointer
7859 && !cmp_has_alloc_comps
)
7861 rank
= c
->as
? c
->as
->rank
: 0;
7862 if (c
->attr
.codimension
)
7863 tmp
= gfc_copy_allocatable_data (dcmp
, comp
, ctype
, rank
);
7865 tmp
= gfc_duplicate_allocatable (dcmp
, comp
, ctype
, rank
);
7866 gfc_add_expr_to_block (&fnblock
, tmp
);
7869 if (cmp_has_alloc_comps
)
7871 rank
= c
->as
? c
->as
->rank
: 0;
7872 tmp
= fold_convert (TREE_TYPE (dcmp
), comp
);
7873 gfc_add_modify (&fnblock
, dcmp
, tmp
);
7874 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, dcmp
,
7876 gfc_add_expr_to_block (&fnblock
, tmp
);
7886 return gfc_finish_block (&fnblock
);
7889 /* Recursively traverse an object of derived type, generating code to
7890 nullify allocatable components. */
7893 gfc_nullify_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
7895 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
7896 NULLIFY_ALLOC_COMP
);
7900 /* Recursively traverse an object of derived type, generating code to
7901 deallocate allocatable components. */
7904 gfc_deallocate_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
7906 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
7907 DEALLOCATE_ALLOC_COMP
);
7911 /* Recursively traverse an object of derived type, generating code to
7912 deallocate allocatable components. But do not deallocate coarrays.
7913 To be used for intrinsic assignment, which may not change the allocation
7914 status of coarrays. */
7917 gfc_deallocate_alloc_comp_no_caf (gfc_symbol
* der_type
, tree decl
, int rank
)
7919 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
7920 DEALLOCATE_ALLOC_COMP_NO_CAF
);
7925 gfc_reassign_alloc_comp_caf (gfc_symbol
*der_type
, tree decl
, tree dest
)
7927 return structure_alloc_comps (der_type
, decl
, dest
, 0, COPY_ALLOC_COMP_CAF
);
7931 /* Recursively traverse an object of derived type, generating code to
7932 copy it and its allocatable components. */
7935 gfc_copy_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
7937 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ALLOC_COMP
);
7941 /* Recursively traverse an object of derived type, generating code to
7942 copy only its allocatable components. */
7945 gfc_copy_only_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
7947 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ONLY_ALLOC_COMP
);
7951 /* Returns the value of LBOUND for an expression. This could be broken out
7952 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
7953 called by gfc_alloc_allocatable_for_assignment. */
7955 get_std_lbound (gfc_expr
*expr
, tree desc
, int dim
, bool assumed_size
)
7960 tree cond
, cond1
, cond3
, cond4
;
7964 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
7966 tmp
= gfc_rank_cst
[dim
];
7967 lbound
= gfc_conv_descriptor_lbound_get (desc
, tmp
);
7968 ubound
= gfc_conv_descriptor_ubound_get (desc
, tmp
);
7969 stride
= gfc_conv_descriptor_stride_get (desc
, tmp
);
7970 cond1
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
7972 cond3
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
7973 stride
, gfc_index_zero_node
);
7974 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7975 boolean_type_node
, cond3
, cond1
);
7976 cond4
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
7977 stride
, gfc_index_zero_node
);
7979 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
7980 tmp
, build_int_cst (gfc_array_index_type
,
7983 cond
= boolean_false_node
;
7985 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
7986 boolean_type_node
, cond3
, cond4
);
7987 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
7988 boolean_type_node
, cond
, cond1
);
7990 return fold_build3_loc (input_location
, COND_EXPR
,
7991 gfc_array_index_type
, cond
,
7992 lbound
, gfc_index_one_node
);
7995 if (expr
->expr_type
== EXPR_FUNCTION
)
7997 /* A conversion function, so use the argument. */
7998 gcc_assert (expr
->value
.function
.isym
7999 && expr
->value
.function
.isym
->conversion
);
8000 expr
= expr
->value
.function
.actual
->expr
;
8003 if (expr
->expr_type
== EXPR_VARIABLE
)
8005 tmp
= TREE_TYPE (expr
->symtree
->n
.sym
->backend_decl
);
8006 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
8008 if (ref
->type
== REF_COMPONENT
8009 && ref
->u
.c
.component
->as
8011 && ref
->next
->u
.ar
.type
== AR_FULL
)
8012 tmp
= TREE_TYPE (ref
->u
.c
.component
->backend_decl
);
8014 return GFC_TYPE_ARRAY_LBOUND(tmp
, dim
);
8017 return gfc_index_one_node
;
8021 /* Returns true if an expression represents an lhs that can be reallocated
8025 gfc_is_reallocatable_lhs (gfc_expr
*expr
)
8032 /* An allocatable variable. */
8033 if (expr
->symtree
->n
.sym
->attr
.allocatable
8035 && expr
->ref
->type
== REF_ARRAY
8036 && expr
->ref
->u
.ar
.type
== AR_FULL
)
8039 /* All that can be left are allocatable components. */
8040 if ((expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
8041 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
8042 || !expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
8045 /* Find a component ref followed by an array reference. */
8046 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
8048 && ref
->type
== REF_COMPONENT
8049 && ref
->next
->type
== REF_ARRAY
8050 && !ref
->next
->next
)
8056 /* Return true if valid reallocatable lhs. */
8057 if (ref
->u
.c
.component
->attr
.allocatable
8058 && ref
->next
->u
.ar
.type
== AR_FULL
)
8065 /* Allocate the lhs of an assignment to an allocatable array, otherwise
8069 gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop
,
8073 stmtblock_t realloc_block
;
8074 stmtblock_t alloc_block
;
8078 gfc_array_info
*linfo
;
8100 gfc_array_spec
* as
;
8102 /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
8103 Find the lhs expression in the loop chain and set expr1 and
8104 expr2 accordingly. */
8105 if (expr1
->expr_type
== EXPR_FUNCTION
&& expr2
== NULL
)
8108 /* Find the ss for the lhs. */
8110 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
8111 if (lss
->info
->expr
&& lss
->info
->expr
->expr_type
== EXPR_VARIABLE
)
8113 if (lss
== gfc_ss_terminator
)
8115 expr1
= lss
->info
->expr
;
8118 /* Bail out if this is not a valid allocate on assignment. */
8119 if (!gfc_is_reallocatable_lhs (expr1
)
8120 || (expr2
&& !expr2
->rank
))
8123 /* Find the ss for the lhs. */
8125 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
8126 if (lss
->info
->expr
== expr1
)
8129 if (lss
== gfc_ss_terminator
)
8132 linfo
= &lss
->info
->data
.array
;
8134 /* Find an ss for the rhs. For operator expressions, we see the
8135 ss's for the operands. Any one of these will do. */
8137 for (; rss
&& rss
!= gfc_ss_terminator
; rss
= rss
->loop_chain
)
8138 if (rss
->info
->expr
!= expr1
&& rss
!= loop
->temp_ss
)
8141 if (expr2
&& rss
== gfc_ss_terminator
)
8144 gfc_start_block (&fblock
);
8146 /* Since the lhs is allocatable, this must be a descriptor type.
8147 Get the data and array size. */
8148 desc
= linfo
->descriptor
;
8149 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)));
8150 array1
= gfc_conv_descriptor_data_get (desc
);
8152 /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
8153 deallocated if expr is an array of different shape or any of the
8154 corresponding length type parameter values of variable and expr
8155 differ." This assures F95 compatibility. */
8156 jump_label1
= gfc_build_label_decl (NULL_TREE
);
8157 jump_label2
= gfc_build_label_decl (NULL_TREE
);
8159 /* Allocate if data is NULL. */
8160 cond_null
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
8161 array1
, build_int_cst (TREE_TYPE (array1
), 0));
8162 tmp
= build3_v (COND_EXPR
, cond_null
,
8163 build1_v (GOTO_EXPR
, jump_label1
),
8164 build_empty_stmt (input_location
));
8165 gfc_add_expr_to_block (&fblock
, tmp
);
8167 /* Get arrayspec if expr is a full array. */
8168 if (expr2
&& expr2
->expr_type
== EXPR_FUNCTION
8169 && expr2
->value
.function
.isym
8170 && expr2
->value
.function
.isym
->conversion
)
8172 /* For conversion functions, take the arg. */
8173 gfc_expr
*arg
= expr2
->value
.function
.actual
->expr
;
8174 as
= gfc_get_full_arrayspec_from_expr (arg
);
8177 as
= gfc_get_full_arrayspec_from_expr (expr2
);
8181 /* If the lhs shape is not the same as the rhs jump to setting the
8182 bounds and doing the reallocation....... */
8183 for (n
= 0; n
< expr1
->rank
; n
++)
8185 /* Check the shape. */
8186 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
8187 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
8188 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8189 gfc_array_index_type
,
8190 loop
->to
[n
], loop
->from
[n
]);
8191 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8192 gfc_array_index_type
,
8194 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8195 gfc_array_index_type
,
8197 cond
= fold_build2_loc (input_location
, NE_EXPR
,
8199 tmp
, gfc_index_zero_node
);
8200 tmp
= build3_v (COND_EXPR
, cond
,
8201 build1_v (GOTO_EXPR
, jump_label1
),
8202 build_empty_stmt (input_location
));
8203 gfc_add_expr_to_block (&fblock
, tmp
);
8206 /* ....else jump past the (re)alloc code. */
8207 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
8208 gfc_add_expr_to_block (&fblock
, tmp
);
8210 /* Add the label to start automatic (re)allocation. */
8211 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
8212 gfc_add_expr_to_block (&fblock
, tmp
);
8214 /* If the lhs has not been allocated, its bounds will not have been
8215 initialized and so its size is set to zero. */
8216 size1
= gfc_create_var (gfc_array_index_type
, NULL
);
8217 gfc_init_block (&alloc_block
);
8218 gfc_add_modify (&alloc_block
, size1
, gfc_index_zero_node
);
8219 gfc_init_block (&realloc_block
);
8220 gfc_add_modify (&realloc_block
, size1
,
8221 gfc_conv_descriptor_size (desc
, expr1
->rank
));
8222 tmp
= build3_v (COND_EXPR
, cond_null
,
8223 gfc_finish_block (&alloc_block
),
8224 gfc_finish_block (&realloc_block
));
8225 gfc_add_expr_to_block (&fblock
, tmp
);
8227 /* Get the rhs size and fix it. */
8229 desc2
= rss
->info
->data
.array
.descriptor
;
8233 size2
= gfc_index_one_node
;
8234 for (n
= 0; n
< expr2
->rank
; n
++)
8236 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8237 gfc_array_index_type
,
8238 loop
->to
[n
], loop
->from
[n
]);
8239 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8240 gfc_array_index_type
,
8241 tmp
, gfc_index_one_node
);
8242 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
8243 gfc_array_index_type
,
8246 size2
= gfc_evaluate_now (size2
, &fblock
);
8248 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
8250 neq_size
= gfc_evaluate_now (cond
, &fblock
);
8252 /* Deallocation of allocatable components will have to occur on
8253 reallocation. Fix the old descriptor now. */
8254 if ((expr1
->ts
.type
== BT_DERIVED
)
8255 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
8256 old_desc
= gfc_evaluate_now (desc
, &fblock
);
8258 old_desc
= NULL_TREE
;
8260 /* Now modify the lhs descriptor and the associated scalarizer
8261 variables. F2003 7.4.1.3: "If variable is or becomes an
8262 unallocated allocatable variable, then it is allocated with each
8263 deferred type parameter equal to the corresponding type parameters
8264 of expr , with the shape of expr , and with each lower bound equal
8265 to the corresponding element of LBOUND(expr)."
8266 Reuse size1 to keep a dimension-by-dimension track of the
8267 stride of the new array. */
8268 size1
= gfc_index_one_node
;
8269 offset
= gfc_index_zero_node
;
8271 for (n
= 0; n
< expr2
->rank
; n
++)
8273 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8274 gfc_array_index_type
,
8275 loop
->to
[n
], loop
->from
[n
]);
8276 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8277 gfc_array_index_type
,
8278 tmp
, gfc_index_one_node
);
8280 lbound
= gfc_index_one_node
;
8285 lbd
= get_std_lbound (expr2
, desc2
, n
,
8286 as
->type
== AS_ASSUMED_SIZE
);
8287 ubound
= fold_build2_loc (input_location
,
8289 gfc_array_index_type
,
8291 ubound
= fold_build2_loc (input_location
,
8293 gfc_array_index_type
,
8298 gfc_conv_descriptor_lbound_set (&fblock
, desc
,
8301 gfc_conv_descriptor_ubound_set (&fblock
, desc
,
8304 gfc_conv_descriptor_stride_set (&fblock
, desc
,
8307 lbound
= gfc_conv_descriptor_lbound_get (desc
,
8309 tmp2
= fold_build2_loc (input_location
, MULT_EXPR
,
8310 gfc_array_index_type
,
8312 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
8313 gfc_array_index_type
,
8315 size1
= fold_build2_loc (input_location
, MULT_EXPR
,
8316 gfc_array_index_type
,
8320 /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
8321 the array offset is saved and the info.offset is used for a
8322 running offset. Use the saved_offset instead. */
8323 tmp
= gfc_conv_descriptor_offset (desc
);
8324 gfc_add_modify (&fblock
, tmp
, offset
);
8325 if (linfo
->saved_offset
8326 && TREE_CODE (linfo
->saved_offset
) == VAR_DECL
)
8327 gfc_add_modify (&fblock
, linfo
->saved_offset
, tmp
);
8329 /* Now set the deltas for the lhs. */
8330 for (n
= 0; n
< expr1
->rank
; n
++)
8332 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
8334 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8335 gfc_array_index_type
, tmp
,
8337 if (linfo
->delta
[dim
]
8338 && TREE_CODE (linfo
->delta
[dim
]) == VAR_DECL
)
8339 gfc_add_modify (&fblock
, linfo
->delta
[dim
], tmp
);
8342 /* Get the new lhs size in bytes. */
8343 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
8345 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
8346 gcc_assert (expr1
->ts
.u
.cl
->backend_decl
);
8347 tmp
= fold_convert (TREE_TYPE (expr1
->ts
.u
.cl
->backend_decl
), tmp
);
8348 gfc_add_modify (&fblock
, expr1
->ts
.u
.cl
->backend_decl
, tmp
);
8350 else if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.u
.cl
->backend_decl
)
8352 tmp
= TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
)));
8353 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8354 gfc_array_index_type
, tmp
,
8355 expr1
->ts
.u
.cl
->backend_decl
);
8358 tmp
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
8359 tmp
= fold_convert (gfc_array_index_type
, tmp
);
8360 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
8361 gfc_array_index_type
,
8363 size2
= fold_convert (size_type_node
, size2
);
8364 size2
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
8365 size2
, size_one_node
);
8366 size2
= gfc_evaluate_now (size2
, &fblock
);
8368 /* Realloc expression. Note that the scalarizer uses desc.data
8369 in the array reference - (*desc.data)[<element>]. */
8370 gfc_init_block (&realloc_block
);
8372 if ((expr1
->ts
.type
== BT_DERIVED
)
8373 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
8375 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, old_desc
,
8377 gfc_add_expr_to_block (&realloc_block
, tmp
);
8380 tmp
= build_call_expr_loc (input_location
,
8381 builtin_decl_explicit (BUILT_IN_REALLOC
), 2,
8382 fold_convert (pvoid_type_node
, array1
),
8384 gfc_conv_descriptor_data_set (&realloc_block
,
8387 if ((expr1
->ts
.type
== BT_DERIVED
)
8388 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
8390 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, desc
,
8392 gfc_add_expr_to_block (&realloc_block
, tmp
);
8395 realloc_expr
= gfc_finish_block (&realloc_block
);
8397 /* Only reallocate if sizes are different. */
8398 tmp
= build3_v (COND_EXPR
, neq_size
, realloc_expr
,
8399 build_empty_stmt (input_location
));
8403 /* Malloc expression. */
8404 gfc_init_block (&alloc_block
);
8405 tmp
= build_call_expr_loc (input_location
,
8406 builtin_decl_explicit (BUILT_IN_MALLOC
),
8408 gfc_conv_descriptor_data_set (&alloc_block
,
8410 tmp
= gfc_conv_descriptor_dtype (desc
);
8411 gfc_add_modify (&alloc_block
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
8412 if ((expr1
->ts
.type
== BT_DERIVED
)
8413 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
8415 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, desc
,
8417 gfc_add_expr_to_block (&alloc_block
, tmp
);
8419 alloc_expr
= gfc_finish_block (&alloc_block
);
8421 /* Malloc if not allocated; realloc otherwise. */
8422 tmp
= build_int_cst (TREE_TYPE (array1
), 0);
8423 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
8426 tmp
= build3_v (COND_EXPR
, cond
, alloc_expr
, realloc_expr
);
8427 gfc_add_expr_to_block (&fblock
, tmp
);
8429 /* Make sure that the scalarizer data pointer is updated. */
8431 && TREE_CODE (linfo
->data
) == VAR_DECL
)
8433 tmp
= gfc_conv_descriptor_data_get (desc
);
8434 gfc_add_modify (&fblock
, linfo
->data
, tmp
);
8437 /* Add the exit label. */
8438 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
8439 gfc_add_expr_to_block (&fblock
, tmp
);
8441 return gfc_finish_block (&fblock
);
8445 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
8446 Do likewise, recursively if necessary, with the allocatable components of
8450 gfc_trans_deferred_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
8456 stmtblock_t cleanup
;
8459 bool sym_has_alloc_comp
, has_finalizer
;
8461 sym_has_alloc_comp
= (sym
->ts
.type
== BT_DERIVED
8462 || sym
->ts
.type
== BT_CLASS
)
8463 && sym
->ts
.u
.derived
->attr
.alloc_comp
;
8464 has_finalizer
= sym
->ts
.type
== BT_CLASS
|| sym
->ts
.type
== BT_DERIVED
8465 ? gfc_is_finalizable (sym
->ts
.u
.derived
, NULL
) : false;
8467 /* Make sure the frontend gets these right. */
8468 gcc_assert (sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym_has_alloc_comp
8471 gfc_save_backend_locus (&loc
);
8472 gfc_set_backend_locus (&sym
->declared_at
);
8473 gfc_init_block (&init
);
8475 gcc_assert (TREE_CODE (sym
->backend_decl
) == VAR_DECL
8476 || TREE_CODE (sym
->backend_decl
) == PARM_DECL
);
8478 if (sym
->ts
.type
== BT_CHARACTER
8479 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
8481 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
8482 gfc_trans_vla_type_sizes (sym
, &init
);
8485 /* Dummy, use associated and result variables don't need anything special. */
8486 if (sym
->attr
.dummy
|| sym
->attr
.use_assoc
|| sym
->attr
.result
)
8488 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
8489 gfc_restore_backend_locus (&loc
);
8493 descriptor
= sym
->backend_decl
;
8495 /* Although static, derived types with default initializers and
8496 allocatable components must not be nulled wholesale; instead they
8497 are treated component by component. */
8498 if (TREE_STATIC (descriptor
) && !sym_has_alloc_comp
&& !has_finalizer
)
8500 /* SAVEd variables are not freed on exit. */
8501 gfc_trans_static_array_pointer (sym
);
8503 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
8504 gfc_restore_backend_locus (&loc
);
8508 /* Get the descriptor type. */
8509 type
= TREE_TYPE (sym
->backend_decl
);
8511 if ((sym_has_alloc_comp
|| (has_finalizer
&& sym
->ts
.type
!= BT_CLASS
))
8512 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
8515 && !(TREE_STATIC (sym
->backend_decl
) && sym
->attr
.is_main_program
))
8517 if (sym
->value
== NULL
8518 || !gfc_has_default_initializer (sym
->ts
.u
.derived
))
8520 rank
= sym
->as
? sym
->as
->rank
: 0;
8521 tmp
= gfc_nullify_alloc_comp (sym
->ts
.u
.derived
,
8523 gfc_add_expr_to_block (&init
, tmp
);
8526 gfc_init_default_dt (sym
, &init
, false);
8529 else if (!GFC_DESCRIPTOR_TYPE_P (type
))
8531 /* If the backend_decl is not a descriptor, we must have a pointer
8533 descriptor
= build_fold_indirect_ref_loc (input_location
,
8535 type
= TREE_TYPE (descriptor
);
8538 /* NULLIFY the data pointer. */
8539 if (GFC_DESCRIPTOR_TYPE_P (type
) && !sym
->attr
.save
)
8540 gfc_conv_descriptor_data_set (&init
, descriptor
, null_pointer_node
);
8542 gfc_restore_backend_locus (&loc
);
8543 gfc_init_block (&cleanup
);
8545 /* Allocatable arrays need to be freed when they go out of scope.
8546 The allocatable components of pointers must not be touched. */
8547 if (!sym
->attr
.allocatable
&& has_finalizer
&& sym
->ts
.type
!= BT_CLASS
8548 && !sym
->attr
.pointer
&& !sym
->attr
.artificial
&& !sym
->attr
.save
8549 && !sym
->ns
->proc_name
->attr
.is_main_program
)
8552 sym
->attr
.referenced
= 1;
8553 e
= gfc_lval_expr_from_sym (sym
);
8554 gfc_add_finalizer_call (&cleanup
, e
);
8557 else if ((!sym
->attr
.allocatable
|| !has_finalizer
)
8558 && sym_has_alloc_comp
&& !(sym
->attr
.function
|| sym
->attr
.result
)
8559 && !sym
->attr
.pointer
&& !sym
->attr
.save
8560 && !sym
->ns
->proc_name
->attr
.is_main_program
)
8563 rank
= sym
->as
? sym
->as
->rank
: 0;
8564 tmp
= gfc_deallocate_alloc_comp (sym
->ts
.u
.derived
, descriptor
, rank
);
8565 gfc_add_expr_to_block (&cleanup
, tmp
);
8568 if (sym
->attr
.allocatable
&& (sym
->attr
.dimension
|| sym
->attr
.codimension
)
8569 && !sym
->attr
.save
&& !sym
->attr
.result
8570 && !sym
->ns
->proc_name
->attr
.is_main_program
)
8573 e
= has_finalizer
? gfc_lval_expr_from_sym (sym
) : NULL
;
8574 tmp
= gfc_trans_dealloc_allocated (sym
->backend_decl
,
8575 sym
->attr
.codimension
, e
);
8578 gfc_add_expr_to_block (&cleanup
, tmp
);
8581 gfc_add_init_cleanup (block
, gfc_finish_block (&init
),
8582 gfc_finish_block (&cleanup
));
8585 /************ Expression Walking Functions ******************/
8587 /* Walk a variable reference.
8589 Possible extension - multiple component subscripts.
8590 x(:,:) = foo%a(:)%b(:)
8592 forall (i=..., j=...)
8593 x(i,j) = foo%a(j)%b(i)
8595 This adds a fair amount of complexity because you need to deal with more
8596 than one ref. Maybe handle in a similar manner to vector subscripts.
8597 Maybe not worth the effort. */
8601 gfc_walk_variable_expr (gfc_ss
* ss
, gfc_expr
* expr
)
8605 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
8606 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
8609 return gfc_walk_array_ref (ss
, expr
, ref
);
8614 gfc_walk_array_ref (gfc_ss
* ss
, gfc_expr
* expr
, gfc_ref
* ref
)
8620 for (; ref
; ref
= ref
->next
)
8622 if (ref
->type
== REF_SUBSTRING
)
8624 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.start
);
8625 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.end
);
8628 /* We're only interested in array sections from now on. */
8629 if (ref
->type
!= REF_ARRAY
)
8637 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
8638 ss
= gfc_get_scalar_ss (ss
, ar
->start
[n
]);
8642 newss
= gfc_get_array_ss (ss
, expr
, ar
->as
->rank
, GFC_SS_SECTION
);
8643 newss
->info
->data
.array
.ref
= ref
;
8645 /* Make sure array is the same as array(:,:), this way
8646 we don't need to special case all the time. */
8647 ar
->dimen
= ar
->as
->rank
;
8648 for (n
= 0; n
< ar
->dimen
; n
++)
8650 ar
->dimen_type
[n
] = DIMEN_RANGE
;
8652 gcc_assert (ar
->start
[n
] == NULL
);
8653 gcc_assert (ar
->end
[n
] == NULL
);
8654 gcc_assert (ar
->stride
[n
] == NULL
);
8660 newss
= gfc_get_array_ss (ss
, expr
, 0, GFC_SS_SECTION
);
8661 newss
->info
->data
.array
.ref
= ref
;
8663 /* We add SS chains for all the subscripts in the section. */
8664 for (n
= 0; n
< ar
->dimen
; n
++)
8668 switch (ar
->dimen_type
[n
])
8671 /* Add SS for elemental (scalar) subscripts. */
8672 gcc_assert (ar
->start
[n
]);
8673 indexss
= gfc_get_scalar_ss (gfc_ss_terminator
, ar
->start
[n
]);
8674 indexss
->loop_chain
= gfc_ss_terminator
;
8675 newss
->info
->data
.array
.subscript
[n
] = indexss
;
8679 /* We don't add anything for sections, just remember this
8680 dimension for later. */
8681 newss
->dim
[newss
->dimen
] = n
;
8686 /* Create a GFC_SS_VECTOR index in which we can store
8687 the vector's descriptor. */
8688 indexss
= gfc_get_array_ss (gfc_ss_terminator
, ar
->start
[n
],
8690 indexss
->loop_chain
= gfc_ss_terminator
;
8691 newss
->info
->data
.array
.subscript
[n
] = indexss
;
8692 newss
->dim
[newss
->dimen
] = n
;
8697 /* We should know what sort of section it is by now. */
8701 /* We should have at least one non-elemental dimension,
8702 unless we are creating a descriptor for a (scalar) coarray. */
8703 gcc_assert (newss
->dimen
> 0
8704 || newss
->info
->data
.array
.ref
->u
.ar
.as
->corank
> 0);
8709 /* We should know what sort of section it is by now. */
8718 /* Walk an expression operator. If only one operand of a binary expression is
8719 scalar, we must also add the scalar term to the SS chain. */
8722 gfc_walk_op_expr (gfc_ss
* ss
, gfc_expr
* expr
)
8727 head
= gfc_walk_subexpr (ss
, expr
->value
.op
.op1
);
8728 if (expr
->value
.op
.op2
== NULL
)
8731 head2
= gfc_walk_subexpr (head
, expr
->value
.op
.op2
);
8733 /* All operands are scalar. Pass back and let the caller deal with it. */
8737 /* All operands require scalarization. */
8738 if (head
!= ss
&& (expr
->value
.op
.op2
== NULL
|| head2
!= head
))
8741 /* One of the operands needs scalarization, the other is scalar.
8742 Create a gfc_ss for the scalar expression. */
8745 /* First operand is scalar. We build the chain in reverse order, so
8746 add the scalar SS after the second operand. */
8748 while (head
&& head
->next
!= ss
)
8750 /* Check we haven't somehow broken the chain. */
8752 head
->next
= gfc_get_scalar_ss (ss
, expr
->value
.op
.op1
);
8754 else /* head2 == head */
8756 gcc_assert (head2
== head
);
8757 /* Second operand is scalar. */
8758 head2
= gfc_get_scalar_ss (head2
, expr
->value
.op
.op2
);
8765 /* Reverse a SS chain. */
8768 gfc_reverse_ss (gfc_ss
* ss
)
8773 gcc_assert (ss
!= NULL
);
8775 head
= gfc_ss_terminator
;
8776 while (ss
!= gfc_ss_terminator
)
8779 /* Check we didn't somehow break the chain. */
8780 gcc_assert (next
!= NULL
);
8790 /* Given an expression referring to a procedure, return the symbol of its
8791 interface. We can't get the procedure symbol directly as we have to handle
8792 the case of (deferred) type-bound procedures. */
8795 gfc_get_proc_ifc_for_expr (gfc_expr
*procedure_ref
)
8800 if (procedure_ref
== NULL
)
8803 /* Normal procedure case. */
8804 sym
= procedure_ref
->symtree
->n
.sym
;
8806 /* Typebound procedure case. */
8807 for (ref
= procedure_ref
->ref
; ref
; ref
= ref
->next
)
8809 if (ref
->type
== REF_COMPONENT
8810 && ref
->u
.c
.component
->attr
.proc_pointer
)
8811 sym
= ref
->u
.c
.component
->ts
.interface
;
8820 /* Walk the arguments of an elemental function.
8821 PROC_EXPR is used to check whether an argument is permitted to be absent. If
8822 it is NULL, we don't do the check and the argument is assumed to be present.
8826 gfc_walk_elemental_function_args (gfc_ss
* ss
, gfc_actual_arglist
*arg
,
8827 gfc_symbol
*proc_ifc
, gfc_ss_type type
)
8829 gfc_formal_arglist
*dummy_arg
;
8835 head
= gfc_ss_terminator
;
8839 dummy_arg
= gfc_sym_get_dummy_args (proc_ifc
);
8844 for (; arg
; arg
= arg
->next
)
8846 if (!arg
->expr
|| arg
->expr
->expr_type
== EXPR_NULL
)
8849 newss
= gfc_walk_subexpr (head
, arg
->expr
);
8852 /* Scalar argument. */
8853 gcc_assert (type
== GFC_SS_SCALAR
|| type
== GFC_SS_REFERENCE
);
8854 newss
= gfc_get_scalar_ss (head
, arg
->expr
);
8855 newss
->info
->type
= type
;
8861 if (dummy_arg
!= NULL
8862 && dummy_arg
->sym
->attr
.optional
8863 && arg
->expr
->expr_type
== EXPR_VARIABLE
8864 && (gfc_expr_attr (arg
->expr
).optional
8865 || gfc_expr_attr (arg
->expr
).allocatable
8866 || gfc_expr_attr (arg
->expr
).pointer
))
8867 newss
->info
->can_be_null_ref
= true;
8873 while (tail
->next
!= gfc_ss_terminator
)
8877 if (dummy_arg
!= NULL
)
8878 dummy_arg
= dummy_arg
->next
;
8883 /* If all the arguments are scalar we don't need the argument SS. */
8884 gfc_free_ss_chain (head
);
8889 /* Add it onto the existing chain. */
8895 /* Walk a function call. Scalar functions are passed back, and taken out of
8896 scalarization loops. For elemental functions we walk their arguments.
8897 The result of functions returning arrays is stored in a temporary outside
8898 the loop, so that the function is only called once. Hence we do not need
8899 to walk their arguments. */
8902 gfc_walk_function_expr (gfc_ss
* ss
, gfc_expr
* expr
)
8904 gfc_intrinsic_sym
*isym
;
8906 gfc_component
*comp
= NULL
;
8908 isym
= expr
->value
.function
.isym
;
8910 /* Handle intrinsic functions separately. */
8912 return gfc_walk_intrinsic_function (ss
, expr
, isym
);
8914 sym
= expr
->value
.function
.esym
;
8916 sym
= expr
->symtree
->n
.sym
;
8918 /* A function that returns arrays. */
8919 comp
= gfc_get_proc_ptr_comp (expr
);
8920 if ((!comp
&& gfc_return_by_reference (sym
) && sym
->result
->attr
.dimension
)
8921 || (comp
&& comp
->attr
.dimension
))
8922 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
8924 /* Walk the parameters of an elemental function. For now we always pass
8926 if (sym
->attr
.elemental
|| (comp
&& comp
->attr
.elemental
))
8927 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
8928 gfc_get_proc_ifc_for_expr (expr
),
8931 /* Scalar functions are OK as these are evaluated outside the scalarization
8932 loop. Pass back and let the caller deal with it. */
8937 /* An array temporary is constructed for array constructors. */
8940 gfc_walk_array_constructor (gfc_ss
* ss
, gfc_expr
* expr
)
8942 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_CONSTRUCTOR
);
8946 /* Walk an expression. Add walked expressions to the head of the SS chain.
8947 A wholly scalar expression will not be added. */
8950 gfc_walk_subexpr (gfc_ss
* ss
, gfc_expr
* expr
)
8954 switch (expr
->expr_type
)
8957 head
= gfc_walk_variable_expr (ss
, expr
);
8961 head
= gfc_walk_op_expr (ss
, expr
);
8965 head
= gfc_walk_function_expr (ss
, expr
);
8970 case EXPR_STRUCTURE
:
8971 /* Pass back and let the caller deal with it. */
8975 head
= gfc_walk_array_constructor (ss
, expr
);
8978 case EXPR_SUBSTRING
:
8979 /* Pass back and let the caller deal with it. */
8983 internal_error ("bad expression type during walk (%d)",
8990 /* Entry point for expression walking.
8991 A return value equal to the passed chain means this is
8992 a scalar expression. It is up to the caller to take whatever action is
8993 necessary to translate these. */
8996 gfc_walk_expr (gfc_expr
* expr
)
9000 res
= gfc_walk_subexpr (gfc_ss_terminator
, expr
);
9001 return gfc_reverse_ss (res
);