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"
83 #include "gimple-expr.h"
84 #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"
95 static bool gfc_get_array_constructor_size (mpz_t
*, gfc_constructor_base
);
97 /* The contents of this structure aren't actually used, just the address. */
98 static gfc_ss gfc_ss_terminator_var
;
99 gfc_ss
* const gfc_ss_terminator
= &gfc_ss_terminator_var
;
103 gfc_array_dataptr_type (tree desc
)
105 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
)));
109 /* Build expressions to access the members of an array descriptor.
110 It's surprisingly easy to mess up here, so never access
111 an array descriptor by "brute force", always use these
112 functions. This also avoids problems if we change the format
113 of an array descriptor.
115 To understand these magic numbers, look at the comments
116 before gfc_build_array_type() in trans-types.c.
118 The code within these defines should be the only code which knows the format
119 of an array descriptor.
121 Any code just needing to read obtain the bounds of an array should use
122 gfc_conv_array_* rather than the following functions as these will return
123 know constant values, and work with arrays which do not have descriptors.
125 Don't forget to #undef these! */
128 #define OFFSET_FIELD 1
129 #define DTYPE_FIELD 2
130 #define DIMENSION_FIELD 3
131 #define CAF_TOKEN_FIELD 4
133 #define STRIDE_SUBFIELD 0
134 #define LBOUND_SUBFIELD 1
135 #define UBOUND_SUBFIELD 2
137 /* This provides READ-ONLY access to the data field. The field itself
138 doesn't have the proper type. */
141 gfc_conv_descriptor_data_get (tree desc
)
145 type
= TREE_TYPE (desc
);
146 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
148 field
= TYPE_FIELDS (type
);
149 gcc_assert (DATA_FIELD
== 0);
151 t
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
), desc
,
153 t
= fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type
), t
);
158 /* This provides WRITE access to the data field.
160 TUPLES_P is true if we are generating tuples.
162 This function gets called through the following macros:
163 gfc_conv_descriptor_data_set
164 gfc_conv_descriptor_data_set. */
167 gfc_conv_descriptor_data_set (stmtblock_t
*block
, tree desc
, tree value
)
171 type
= TREE_TYPE (desc
);
172 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
174 field
= TYPE_FIELDS (type
);
175 gcc_assert (DATA_FIELD
== 0);
177 t
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
), desc
,
179 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (field
), value
));
183 /* This provides address access to the data field. This should only be
184 used by array allocation, passing this on to the runtime. */
187 gfc_conv_descriptor_data_addr (tree desc
)
191 type
= TREE_TYPE (desc
);
192 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
194 field
= TYPE_FIELDS (type
);
195 gcc_assert (DATA_FIELD
== 0);
197 t
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
), desc
,
199 return gfc_build_addr_expr (NULL_TREE
, t
);
203 gfc_conv_descriptor_offset (tree desc
)
208 type
= TREE_TYPE (desc
);
209 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
211 field
= gfc_advance_chain (TYPE_FIELDS (type
), OFFSET_FIELD
);
212 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
214 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
215 desc
, field
, NULL_TREE
);
219 gfc_conv_descriptor_offset_get (tree desc
)
221 return gfc_conv_descriptor_offset (desc
);
225 gfc_conv_descriptor_offset_set (stmtblock_t
*block
, tree desc
,
228 tree t
= gfc_conv_descriptor_offset (desc
);
229 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
234 gfc_conv_descriptor_dtype (tree desc
)
239 type
= TREE_TYPE (desc
);
240 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
242 field
= gfc_advance_chain (TYPE_FIELDS (type
), DTYPE_FIELD
);
243 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
245 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
246 desc
, field
, NULL_TREE
);
251 gfc_conv_descriptor_rank (tree desc
)
256 dtype
= gfc_conv_descriptor_dtype (desc
);
257 tmp
= build_int_cst (TREE_TYPE (dtype
), GFC_DTYPE_RANK_MASK
);
258 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, TREE_TYPE (dtype
),
260 return fold_convert (gfc_get_int_type (gfc_default_integer_kind
), tmp
);
265 gfc_get_descriptor_dimension (tree desc
)
269 type
= TREE_TYPE (desc
);
270 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
272 field
= gfc_advance_chain (TYPE_FIELDS (type
), DIMENSION_FIELD
);
273 gcc_assert (field
!= NULL_TREE
274 && TREE_CODE (TREE_TYPE (field
)) == ARRAY_TYPE
275 && TREE_CODE (TREE_TYPE (TREE_TYPE (field
))) == RECORD_TYPE
);
277 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
278 desc
, field
, NULL_TREE
);
283 gfc_conv_descriptor_dimension (tree desc
, tree dim
)
287 tmp
= gfc_get_descriptor_dimension (desc
);
289 return gfc_build_array_ref (tmp
, dim
, NULL
);
294 gfc_conv_descriptor_token (tree desc
)
299 type
= TREE_TYPE (desc
);
300 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
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
= build_decl (input_location
, VAR_DECL
, create_tmp_var_name ("A"),
2050 DECL_ARTIFICIAL (tmp
) = 1;
2051 DECL_IGNORED_P (tmp
) = 1;
2052 TREE_STATIC (tmp
) = 1;
2053 TREE_CONSTANT (tmp
) = 1;
2054 TREE_READONLY (tmp
) = 1;
2055 DECL_INITIAL (tmp
) = init
;
2062 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
2063 This mostly initializes the scalarizer state info structure with the
2064 appropriate values to directly use the array created by the function
2065 gfc_build_constant_array_constructor. */
2068 trans_constant_array_constructor (gfc_ss
* ss
, tree type
)
2070 gfc_array_info
*info
;
2074 tmp
= gfc_build_constant_array_constructor (ss
->info
->expr
, type
);
2076 info
= &ss
->info
->data
.array
;
2078 info
->descriptor
= tmp
;
2079 info
->data
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2080 info
->offset
= gfc_index_zero_node
;
2082 for (i
= 0; i
< ss
->dimen
; i
++)
2084 info
->delta
[i
] = gfc_index_zero_node
;
2085 info
->start
[i
] = gfc_index_zero_node
;
2086 info
->end
[i
] = gfc_index_zero_node
;
2087 info
->stride
[i
] = gfc_index_one_node
;
2093 get_rank (gfc_loopinfo
*loop
)
2098 for (; loop
; loop
= loop
->parent
)
2099 rank
+= loop
->dimen
;
2105 /* Helper routine of gfc_trans_array_constructor to determine if the
2106 bounds of the loop specified by LOOP are constant and simple enough
2107 to use with trans_constant_array_constructor. Returns the
2108 iteration count of the loop if suitable, and NULL_TREE otherwise. */
2111 constant_array_constructor_loop_size (gfc_loopinfo
* l
)
2114 tree size
= gfc_index_one_node
;
2118 total_dim
= get_rank (l
);
2120 for (loop
= l
; loop
; loop
= loop
->parent
)
2122 for (i
= 0; i
< loop
->dimen
; i
++)
2124 /* If the bounds aren't constant, return NULL_TREE. */
2125 if (!INTEGER_CST_P (loop
->from
[i
]) || !INTEGER_CST_P (loop
->to
[i
]))
2127 if (!integer_zerop (loop
->from
[i
]))
2129 /* Only allow nonzero "from" in one-dimensional arrays. */
2132 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2133 gfc_array_index_type
,
2134 loop
->to
[i
], loop
->from
[i
]);
2138 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2139 gfc_array_index_type
, tmp
, gfc_index_one_node
);
2140 size
= fold_build2_loc (input_location
, MULT_EXPR
,
2141 gfc_array_index_type
, size
, tmp
);
2150 get_loop_upper_bound_for_array (gfc_ss
*array
, int array_dim
)
2155 gcc_assert (array
->nested_ss
== NULL
);
2157 for (ss
= array
; ss
; ss
= ss
->parent
)
2158 for (n
= 0; n
< ss
->loop
->dimen
; n
++)
2159 if (array_dim
== get_array_ref_dim_for_loop_dim (ss
, n
))
2160 return &(ss
->loop
->to
[n
]);
2166 static gfc_loopinfo
*
2167 outermost_loop (gfc_loopinfo
* loop
)
2169 while (loop
->parent
!= NULL
)
2170 loop
= loop
->parent
;
2176 /* Array constructors are handled by constructing a temporary, then using that
2177 within the scalarization loop. This is not optimal, but seems by far the
2181 trans_array_constructor (gfc_ss
* ss
, locus
* where
)
2183 gfc_constructor_base c
;
2191 bool old_first_len
, old_typespec_chararray_ctor
;
2192 tree old_first_len_val
;
2193 gfc_loopinfo
*loop
, *outer_loop
;
2194 gfc_ss_info
*ss_info
;
2198 /* Save the old values for nested checking. */
2199 old_first_len
= first_len
;
2200 old_first_len_val
= first_len_val
;
2201 old_typespec_chararray_ctor
= typespec_chararray_ctor
;
2204 outer_loop
= outermost_loop (loop
);
2206 expr
= ss_info
->expr
;
2208 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
2209 typespec was given for the array constructor. */
2210 typespec_chararray_ctor
= (expr
->ts
.u
.cl
2211 && expr
->ts
.u
.cl
->length_from_typespec
);
2213 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2214 && expr
->ts
.type
== BT_CHARACTER
&& !typespec_chararray_ctor
)
2216 first_len_val
= gfc_create_var (gfc_charlen_type_node
, "len");
2220 gcc_assert (ss
->dimen
== ss
->loop
->dimen
);
2222 c
= expr
->value
.constructor
;
2223 if (expr
->ts
.type
== BT_CHARACTER
)
2227 /* get_array_ctor_strlen walks the elements of the constructor, if a
2228 typespec was given, we already know the string length and want the one
2230 if (typespec_chararray_ctor
&& expr
->ts
.u
.cl
->length
2231 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
2235 const_string
= false;
2236 gfc_init_se (&length_se
, NULL
);
2237 gfc_conv_expr_type (&length_se
, expr
->ts
.u
.cl
->length
,
2238 gfc_charlen_type_node
);
2239 ss_info
->string_length
= length_se
.expr
;
2240 gfc_add_block_to_block (&outer_loop
->pre
, &length_se
.pre
);
2241 gfc_add_block_to_block (&outer_loop
->post
, &length_se
.post
);
2244 const_string
= get_array_ctor_strlen (&outer_loop
->pre
, c
,
2245 &ss_info
->string_length
);
2247 /* Complex character array constructors should have been taken care of
2248 and not end up here. */
2249 gcc_assert (ss_info
->string_length
);
2251 expr
->ts
.u
.cl
->backend_decl
= ss_info
->string_length
;
2253 type
= gfc_get_character_type_len (expr
->ts
.kind
, ss_info
->string_length
);
2255 type
= build_pointer_type (type
);
2258 type
= gfc_typenode_for_spec (&expr
->ts
);
2260 /* See if the constructor determines the loop bounds. */
2263 loop_ubound0
= get_loop_upper_bound_for_array (ss
, 0);
2265 if (expr
->shape
&& get_rank (loop
) > 1 && *loop_ubound0
== NULL_TREE
)
2267 /* We have a multidimensional parameter. */
2268 for (s
= ss
; s
; s
= s
->parent
)
2271 for (n
= 0; n
< s
->loop
->dimen
; n
++)
2273 s
->loop
->from
[n
] = gfc_index_zero_node
;
2274 s
->loop
->to
[n
] = gfc_conv_mpz_to_tree (expr
->shape
[s
->dim
[n
]],
2275 gfc_index_integer_kind
);
2276 s
->loop
->to
[n
] = fold_build2_loc (input_location
, MINUS_EXPR
,
2277 gfc_array_index_type
,
2279 gfc_index_one_node
);
2284 if (*loop_ubound0
== NULL_TREE
)
2288 /* We should have a 1-dimensional, zero-based loop. */
2289 gcc_assert (loop
->parent
== NULL
&& loop
->nested
== NULL
);
2290 gcc_assert (loop
->dimen
== 1);
2291 gcc_assert (integer_zerop (loop
->from
[0]));
2293 /* Split the constructor size into a static part and a dynamic part.
2294 Allocate the static size up-front and record whether the dynamic
2295 size might be nonzero. */
2297 dynamic
= gfc_get_array_constructor_size (&size
, c
);
2298 mpz_sub_ui (size
, size
, 1);
2299 loop
->to
[0] = gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
2303 /* Special case constant array constructors. */
2306 unsigned HOST_WIDE_INT nelem
= gfc_constant_array_constructor_p (c
);
2309 tree size
= constant_array_constructor_loop_size (loop
);
2310 if (size
&& compare_tree_int (size
, nelem
) == 0)
2312 trans_constant_array_constructor (ss
, type
);
2318 gfc_trans_create_temp_array (&outer_loop
->pre
, &outer_loop
->post
, ss
, type
,
2319 NULL_TREE
, dynamic
, true, false, where
);
2321 desc
= ss_info
->data
.array
.descriptor
;
2322 offset
= gfc_index_zero_node
;
2323 offsetvar
= gfc_create_var_np (gfc_array_index_type
, "offset");
2324 TREE_NO_WARNING (offsetvar
) = 1;
2325 TREE_USED (offsetvar
) = 0;
2326 gfc_trans_array_constructor_value (&outer_loop
->pre
, type
, desc
, c
,
2327 &offset
, &offsetvar
, dynamic
);
2329 /* If the array grows dynamically, the upper bound of the loop variable
2330 is determined by the array's final upper bound. */
2333 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2334 gfc_array_index_type
,
2335 offsetvar
, gfc_index_one_node
);
2336 tmp
= gfc_evaluate_now (tmp
, &outer_loop
->pre
);
2337 gfc_conv_descriptor_ubound_set (&loop
->pre
, desc
, gfc_rank_cst
[0], tmp
);
2338 if (*loop_ubound0
&& TREE_CODE (*loop_ubound0
) == VAR_DECL
)
2339 gfc_add_modify (&outer_loop
->pre
, *loop_ubound0
, tmp
);
2341 *loop_ubound0
= tmp
;
2344 if (TREE_USED (offsetvar
))
2345 pushdecl (offsetvar
);
2347 gcc_assert (INTEGER_CST_P (offset
));
2350 /* Disable bound checking for now because it's probably broken. */
2351 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2358 /* Restore old values of globals. */
2359 first_len
= old_first_len
;
2360 first_len_val
= old_first_len_val
;
2361 typespec_chararray_ctor
= old_typespec_chararray_ctor
;
2365 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
2366 called after evaluating all of INFO's vector dimensions. Go through
2367 each such vector dimension and see if we can now fill in any missing
2371 set_vector_loop_bounds (gfc_ss
* ss
)
2373 gfc_loopinfo
*loop
, *outer_loop
;
2374 gfc_array_info
*info
;
2382 outer_loop
= outermost_loop (ss
->loop
);
2384 info
= &ss
->info
->data
.array
;
2386 for (; ss
; ss
= ss
->parent
)
2390 for (n
= 0; n
< loop
->dimen
; n
++)
2393 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_VECTOR
2394 || loop
->to
[n
] != NULL
)
2397 /* Loop variable N indexes vector dimension DIM, and we don't
2398 yet know the upper bound of loop variable N. Set it to the
2399 difference between the vector's upper and lower bounds. */
2400 gcc_assert (loop
->from
[n
] == gfc_index_zero_node
);
2401 gcc_assert (info
->subscript
[dim
]
2402 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
2404 gfc_init_se (&se
, NULL
);
2405 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
2406 zero
= gfc_rank_cst
[0];
2407 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2408 gfc_array_index_type
,
2409 gfc_conv_descriptor_ubound_get (desc
, zero
),
2410 gfc_conv_descriptor_lbound_get (desc
, zero
));
2411 tmp
= gfc_evaluate_now (tmp
, &outer_loop
->pre
);
2418 /* Add the pre and post chains for all the scalar expressions in a SS chain
2419 to loop. This is called after the loop parameters have been calculated,
2420 but before the actual scalarizing loops. */
2423 gfc_add_loop_ss_code (gfc_loopinfo
* loop
, gfc_ss
* ss
, bool subscript
,
2426 gfc_loopinfo
*nested_loop
, *outer_loop
;
2428 gfc_ss_info
*ss_info
;
2429 gfc_array_info
*info
;
2433 /* Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise,
2434 arguments could get evaluated multiple times. */
2435 if (ss
->is_alloc_lhs
)
2438 outer_loop
= outermost_loop (loop
);
2440 /* TODO: This can generate bad code if there are ordering dependencies,
2441 e.g., a callee allocated function and an unknown size constructor. */
2442 gcc_assert (ss
!= NULL
);
2444 for (; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2448 /* Cross loop arrays are handled from within the most nested loop. */
2449 if (ss
->nested_ss
!= NULL
)
2453 expr
= ss_info
->expr
;
2454 info
= &ss_info
->data
.array
;
2456 switch (ss_info
->type
)
2459 /* Scalar expression. Evaluate this now. This includes elemental
2460 dimension indices, but not array section bounds. */
2461 gfc_init_se (&se
, NULL
);
2462 gfc_conv_expr (&se
, expr
);
2463 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2465 if (expr
->ts
.type
!= BT_CHARACTER
)
2467 /* Move the evaluation of scalar expressions outside the
2468 scalarization loop, except for WHERE assignments. */
2470 se
.expr
= convert(gfc_array_index_type
, se
.expr
);
2471 if (!ss_info
->where
)
2472 se
.expr
= gfc_evaluate_now (se
.expr
, &outer_loop
->pre
);
2473 gfc_add_block_to_block (&outer_loop
->pre
, &se
.post
);
2476 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2478 ss_info
->data
.scalar
.value
= se
.expr
;
2479 ss_info
->string_length
= se
.string_length
;
2482 case GFC_SS_REFERENCE
:
2483 /* Scalar argument to elemental procedure. */
2484 gfc_init_se (&se
, NULL
);
2485 if (ss_info
->can_be_null_ref
)
2487 /* If the actual argument can be absent (in other words, it can
2488 be a NULL reference), don't try to evaluate it; pass instead
2489 the reference directly. */
2490 gfc_conv_expr_reference (&se
, expr
);
2494 /* Otherwise, evaluate the argument outside the loop and pass
2495 a reference to the value. */
2496 gfc_conv_expr (&se
, expr
);
2499 /* Ensure that a pointer to the string is stored. */
2500 if (expr
->ts
.type
== BT_CHARACTER
)
2501 gfc_conv_string_parameter (&se
);
2503 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2504 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2505 if (gfc_is_class_scalar_expr (expr
))
2506 /* This is necessary because the dynamic type will always be
2507 large than the declared type. In consequence, assigning
2508 the value to a temporary could segfault.
2509 OOP-TODO: see if this is generally correct or is the value
2510 has to be written to an allocated temporary, whose address
2511 is passed via ss_info. */
2512 ss_info
->data
.scalar
.value
= se
.expr
;
2514 ss_info
->data
.scalar
.value
= gfc_evaluate_now (se
.expr
,
2517 ss_info
->string_length
= se
.string_length
;
2520 case GFC_SS_SECTION
:
2521 /* Add the expressions for scalar and vector subscripts. */
2522 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2523 if (info
->subscript
[n
])
2524 gfc_add_loop_ss_code (loop
, info
->subscript
[n
], true, where
);
2526 set_vector_loop_bounds (ss
);
2530 /* Get the vector's descriptor and store it in SS. */
2531 gfc_init_se (&se
, NULL
);
2532 gfc_conv_expr_descriptor (&se
, expr
);
2533 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2534 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2535 info
->descriptor
= se
.expr
;
2538 case GFC_SS_INTRINSIC
:
2539 gfc_add_intrinsic_ss_code (loop
, ss
);
2542 case GFC_SS_FUNCTION
:
2543 /* Array function return value. We call the function and save its
2544 result in a temporary for use inside the loop. */
2545 gfc_init_se (&se
, NULL
);
2548 gfc_conv_expr (&se
, expr
);
2549 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2550 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2551 ss_info
->string_length
= se
.string_length
;
2554 case GFC_SS_CONSTRUCTOR
:
2555 if (expr
->ts
.type
== BT_CHARACTER
2556 && ss_info
->string_length
== NULL
2558 && expr
->ts
.u
.cl
->length
)
2560 gfc_init_se (&se
, NULL
);
2561 gfc_conv_expr_type (&se
, expr
->ts
.u
.cl
->length
,
2562 gfc_charlen_type_node
);
2563 ss_info
->string_length
= se
.expr
;
2564 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2565 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2567 trans_array_constructor (ss
, where
);
2571 case GFC_SS_COMPONENT
:
2572 /* Do nothing. These are handled elsewhere. */
2581 for (nested_loop
= loop
->nested
; nested_loop
;
2582 nested_loop
= nested_loop
->next
)
2583 gfc_add_loop_ss_code (nested_loop
, nested_loop
->ss
, subscript
, where
);
2587 /* Translate expressions for the descriptor and data pointer of a SS. */
2591 gfc_conv_ss_descriptor (stmtblock_t
* block
, gfc_ss
* ss
, int base
)
2594 gfc_ss_info
*ss_info
;
2595 gfc_array_info
*info
;
2599 info
= &ss_info
->data
.array
;
2601 /* Get the descriptor for the array to be scalarized. */
2602 gcc_assert (ss_info
->expr
->expr_type
== EXPR_VARIABLE
);
2603 gfc_init_se (&se
, NULL
);
2604 se
.descriptor_only
= 1;
2605 gfc_conv_expr_lhs (&se
, ss_info
->expr
);
2606 gfc_add_block_to_block (block
, &se
.pre
);
2607 info
->descriptor
= se
.expr
;
2608 ss_info
->string_length
= se
.string_length
;
2612 /* Also the data pointer. */
2613 tmp
= gfc_conv_array_data (se
.expr
);
2614 /* If this is a variable or address of a variable we use it directly.
2615 Otherwise we must evaluate it now to avoid breaking dependency
2616 analysis by pulling the expressions for elemental array indices
2619 || (TREE_CODE (tmp
) == ADDR_EXPR
2620 && DECL_P (TREE_OPERAND (tmp
, 0)))))
2621 tmp
= gfc_evaluate_now (tmp
, block
);
2624 tmp
= gfc_conv_array_offset (se
.expr
);
2625 info
->offset
= gfc_evaluate_now (tmp
, block
);
2627 /* Make absolutely sure that the saved_offset is indeed saved
2628 so that the variable is still accessible after the loops
2630 info
->saved_offset
= info
->offset
;
2635 /* Initialize a gfc_loopinfo structure. */
2638 gfc_init_loopinfo (gfc_loopinfo
* loop
)
2642 memset (loop
, 0, sizeof (gfc_loopinfo
));
2643 gfc_init_block (&loop
->pre
);
2644 gfc_init_block (&loop
->post
);
2646 /* Initially scalarize in order and default to no loop reversal. */
2647 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2650 loop
->reverse
[n
] = GFC_INHIBIT_REVERSE
;
2653 loop
->ss
= gfc_ss_terminator
;
2657 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2661 gfc_copy_loopinfo_to_se (gfc_se
* se
, gfc_loopinfo
* loop
)
2667 /* Return an expression for the data pointer of an array. */
2670 gfc_conv_array_data (tree descriptor
)
2674 type
= TREE_TYPE (descriptor
);
2675 if (GFC_ARRAY_TYPE_P (type
))
2677 if (TREE_CODE (type
) == POINTER_TYPE
)
2681 /* Descriptorless arrays. */
2682 return gfc_build_addr_expr (NULL_TREE
, descriptor
);
2686 return gfc_conv_descriptor_data_get (descriptor
);
2690 /* Return an expression for the base offset of an array. */
2693 gfc_conv_array_offset (tree descriptor
)
2697 type
= TREE_TYPE (descriptor
);
2698 if (GFC_ARRAY_TYPE_P (type
))
2699 return GFC_TYPE_ARRAY_OFFSET (type
);
2701 return gfc_conv_descriptor_offset_get (descriptor
);
2705 /* Get an expression for the array stride. */
2708 gfc_conv_array_stride (tree descriptor
, int dim
)
2713 type
= TREE_TYPE (descriptor
);
2715 /* For descriptorless arrays use the array size. */
2716 tmp
= GFC_TYPE_ARRAY_STRIDE (type
, dim
);
2717 if (tmp
!= NULL_TREE
)
2720 tmp
= gfc_conv_descriptor_stride_get (descriptor
, gfc_rank_cst
[dim
]);
2725 /* Like gfc_conv_array_stride, but for the lower bound. */
2728 gfc_conv_array_lbound (tree descriptor
, int dim
)
2733 type
= TREE_TYPE (descriptor
);
2735 tmp
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
2736 if (tmp
!= NULL_TREE
)
2739 tmp
= gfc_conv_descriptor_lbound_get (descriptor
, gfc_rank_cst
[dim
]);
2744 /* Like gfc_conv_array_stride, but for the upper bound. */
2747 gfc_conv_array_ubound (tree descriptor
, int dim
)
2752 type
= TREE_TYPE (descriptor
);
2754 tmp
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
2755 if (tmp
!= NULL_TREE
)
2758 /* This should only ever happen when passing an assumed shape array
2759 as an actual parameter. The value will never be used. */
2760 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor
)))
2761 return gfc_index_zero_node
;
2763 tmp
= gfc_conv_descriptor_ubound_get (descriptor
, gfc_rank_cst
[dim
]);
2768 /* Generate code to perform an array index bound check. */
2771 trans_array_bound_check (gfc_se
* se
, gfc_ss
*ss
, tree index
, int n
,
2772 locus
* where
, bool check_upper
)
2775 tree tmp_lo
, tmp_up
;
2778 const char * name
= NULL
;
2780 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
2783 descriptor
= ss
->info
->data
.array
.descriptor
;
2785 index
= gfc_evaluate_now (index
, &se
->pre
);
2787 /* We find a name for the error message. */
2788 name
= ss
->info
->expr
->symtree
->n
.sym
->name
;
2789 gcc_assert (name
!= NULL
);
2791 if (TREE_CODE (descriptor
) == VAR_DECL
)
2792 name
= IDENTIFIER_POINTER (DECL_NAME (descriptor
));
2794 /* If upper bound is present, include both bounds in the error message. */
2797 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
2798 tmp_up
= gfc_conv_array_ubound (descriptor
, n
);
2801 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
2802 "outside of expected range (%%ld:%%ld)", n
+1, name
);
2804 asprintf (&msg
, "Index '%%ld' of dimension %d "
2805 "outside of expected range (%%ld:%%ld)", n
+1);
2807 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2809 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2810 fold_convert (long_integer_type_node
, index
),
2811 fold_convert (long_integer_type_node
, tmp_lo
),
2812 fold_convert (long_integer_type_node
, tmp_up
));
2813 fault
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2815 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2816 fold_convert (long_integer_type_node
, index
),
2817 fold_convert (long_integer_type_node
, tmp_lo
),
2818 fold_convert (long_integer_type_node
, tmp_up
));
2823 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
2826 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
2827 "below lower bound of %%ld", n
+1, name
);
2829 asprintf (&msg
, "Index '%%ld' of dimension %d "
2830 "below lower bound of %%ld", n
+1);
2832 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2834 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2835 fold_convert (long_integer_type_node
, index
),
2836 fold_convert (long_integer_type_node
, tmp_lo
));
2844 /* Return the offset for an index. Performs bound checking for elemental
2845 dimensions. Single element references are processed separately.
2846 DIM is the array dimension, I is the loop dimension. */
2849 conv_array_index_offset (gfc_se
* se
, gfc_ss
* ss
, int dim
, int i
,
2850 gfc_array_ref
* ar
, tree stride
)
2852 gfc_array_info
*info
;
2857 info
= &ss
->info
->data
.array
;
2859 /* Get the index into the array for this dimension. */
2862 gcc_assert (ar
->type
!= AR_ELEMENT
);
2863 switch (ar
->dimen_type
[dim
])
2865 case DIMEN_THIS_IMAGE
:
2869 /* Elemental dimension. */
2870 gcc_assert (info
->subscript
[dim
]
2871 && info
->subscript
[dim
]->info
->type
== GFC_SS_SCALAR
);
2872 /* We've already translated this value outside the loop. */
2873 index
= info
->subscript
[dim
]->info
->data
.scalar
.value
;
2875 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
2876 ar
->as
->type
!= AS_ASSUMED_SIZE
2877 || dim
< ar
->dimen
- 1);
2881 gcc_assert (info
&& se
->loop
);
2882 gcc_assert (info
->subscript
[dim
]
2883 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
2884 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
2886 /* Get a zero-based index into the vector. */
2887 index
= fold_build2_loc (input_location
, MINUS_EXPR
,
2888 gfc_array_index_type
,
2889 se
->loop
->loopvar
[i
], se
->loop
->from
[i
]);
2891 /* Multiply the index by the stride. */
2892 index
= fold_build2_loc (input_location
, MULT_EXPR
,
2893 gfc_array_index_type
,
2894 index
, gfc_conv_array_stride (desc
, 0));
2896 /* Read the vector to get an index into info->descriptor. */
2897 data
= build_fold_indirect_ref_loc (input_location
,
2898 gfc_conv_array_data (desc
));
2899 index
= gfc_build_array_ref (data
, index
, NULL
);
2900 index
= gfc_evaluate_now (index
, &se
->pre
);
2901 index
= fold_convert (gfc_array_index_type
, index
);
2903 /* Do any bounds checking on the final info->descriptor index. */
2904 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
2905 ar
->as
->type
!= AS_ASSUMED_SIZE
2906 || dim
< ar
->dimen
- 1);
2910 /* Scalarized dimension. */
2911 gcc_assert (info
&& se
->loop
);
2913 /* Multiply the loop variable by the stride and delta. */
2914 index
= se
->loop
->loopvar
[i
];
2915 if (!integer_onep (info
->stride
[dim
]))
2916 index
= fold_build2_loc (input_location
, MULT_EXPR
,
2917 gfc_array_index_type
, index
,
2919 if (!integer_zerop (info
->delta
[dim
]))
2920 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
2921 gfc_array_index_type
, index
,
2931 /* Temporary array or derived type component. */
2932 gcc_assert (se
->loop
);
2933 index
= se
->loop
->loopvar
[se
->loop
->order
[i
]];
2935 /* Pointer functions can have stride[0] different from unity.
2936 Use the stride returned by the function call and stored in
2937 the descriptor for the temporary. */
2938 if (se
->ss
&& se
->ss
->info
->type
== GFC_SS_FUNCTION
2939 && se
->ss
->info
->expr
2940 && se
->ss
->info
->expr
->symtree
2941 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
2942 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
->attr
.pointer
)
2943 stride
= gfc_conv_descriptor_stride_get (info
->descriptor
,
2946 if (!integer_zerop (info
->delta
[dim
]))
2947 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
2948 gfc_array_index_type
, index
, info
->delta
[dim
]);
2951 /* Multiply by the stride. */
2952 if (!integer_onep (stride
))
2953 index
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
2960 /* Build a scalarized array reference using the vptr 'size'. */
2963 build_class_array_ref (gfc_se
*se
, tree base
, tree index
)
2970 gfc_expr
*expr
= se
->ss
->info
->expr
;
2975 if (expr
== NULL
|| expr
->ts
.type
!= BT_CLASS
)
2978 if (expr
->symtree
&& expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
2979 ts
= &expr
->symtree
->n
.sym
->ts
;
2984 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2986 if (ref
->type
== REF_COMPONENT
2987 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
2988 && ref
->next
&& ref
->next
->type
== REF_COMPONENT
2989 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0
2991 && ref
->next
->next
->type
== REF_ARRAY
2992 && ref
->next
->next
->u
.ar
.type
!= AR_ELEMENT
)
2994 ts
= &ref
->u
.c
.component
->ts
;
3003 if (class_ref
== NULL
&& expr
->symtree
->n
.sym
->attr
.function
3004 && expr
->symtree
->n
.sym
== expr
->symtree
->n
.sym
->result
)
3006 gcc_assert (expr
->symtree
->n
.sym
->backend_decl
== current_function_decl
);
3007 decl
= gfc_get_fake_result_decl (expr
->symtree
->n
.sym
, 0);
3009 else if (class_ref
== NULL
)
3010 decl
= expr
->symtree
->n
.sym
->backend_decl
;
3013 /* Remove everything after the last class reference, convert the
3014 expression and then recover its tailend once more. */
3016 ref
= class_ref
->next
;
3017 class_ref
->next
= NULL
;
3018 gfc_init_se (&tmpse
, NULL
);
3019 gfc_conv_expr (&tmpse
, expr
);
3021 class_ref
->next
= ref
;
3024 size
= gfc_vtable_size_get (decl
);
3026 /* Build the address of the element. */
3027 type
= TREE_TYPE (TREE_TYPE (base
));
3028 size
= fold_convert (TREE_TYPE (index
), size
);
3029 offset
= fold_build2_loc (input_location
, MULT_EXPR
,
3030 gfc_array_index_type
,
3032 tmp
= gfc_build_addr_expr (pvoid_type_node
, base
);
3033 tmp
= fold_build_pointer_plus_loc (input_location
, tmp
, offset
);
3034 tmp
= fold_convert (build_pointer_type (type
), tmp
);
3036 /* Return the element in the se expression. */
3037 se
->expr
= build_fold_indirect_ref_loc (input_location
, tmp
);
3042 /* Build a scalarized reference to an array. */
3045 gfc_conv_scalarized_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
3047 gfc_array_info
*info
;
3048 tree decl
= NULL_TREE
;
3056 expr
= ss
->info
->expr
;
3057 info
= &ss
->info
->data
.array
;
3059 n
= se
->loop
->order
[0];
3063 index
= conv_array_index_offset (se
, ss
, ss
->dim
[n
], n
, ar
, info
->stride0
);
3064 /* Add the offset for this dimension to the stored offset for all other
3066 if (!integer_zerop (info
->offset
))
3067 index
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3068 index
, info
->offset
);
3070 if (expr
&& is_subref_array (expr
))
3071 decl
= expr
->symtree
->n
.sym
->backend_decl
;
3073 tmp
= build_fold_indirect_ref_loc (input_location
, info
->data
);
3075 /* Use the vptr 'size' field to access a class the element of a class
3077 if (build_class_array_ref (se
, tmp
, index
))
3080 se
->expr
= gfc_build_array_ref (tmp
, index
, decl
);
3084 /* Translate access of temporary array. */
3087 gfc_conv_tmp_array_ref (gfc_se
* se
)
3089 se
->string_length
= se
->ss
->info
->string_length
;
3090 gfc_conv_scalarized_array_ref (se
, NULL
);
3091 gfc_advance_se_ss_chain (se
);
3094 /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
3097 add_to_offset (tree
*cst_offset
, tree
*offset
, tree t
)
3099 if (TREE_CODE (t
) == INTEGER_CST
)
3100 *cst_offset
= int_const_binop (PLUS_EXPR
, *cst_offset
, t
);
3103 if (!integer_zerop (*offset
))
3104 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3105 gfc_array_index_type
, *offset
, t
);
3113 build_array_ref (tree desc
, tree offset
, tree decl
)
3118 /* Class container types do not always have the GFC_CLASS_TYPE_P
3119 but the canonical type does. */
3120 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
3121 && TREE_CODE (desc
) == COMPONENT_REF
)
3123 type
= TREE_TYPE (TREE_OPERAND (desc
, 0));
3124 if (TYPE_CANONICAL (type
)
3125 && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type
)))
3126 type
= TYPE_CANONICAL (type
);
3131 /* Class array references need special treatment because the assigned
3132 type size needs to be used to point to the element. */
3133 if (type
&& GFC_CLASS_TYPE_P (type
))
3135 type
= gfc_get_element_type (TREE_TYPE (desc
));
3136 tmp
= TREE_OPERAND (desc
, 0);
3137 tmp
= gfc_get_class_array_ref (offset
, tmp
);
3138 tmp
= fold_convert (build_pointer_type (type
), tmp
);
3139 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3143 tmp
= gfc_conv_array_data (desc
);
3144 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3145 tmp
= gfc_build_array_ref (tmp
, offset
, decl
);
3150 /* Build an array reference. se->expr already holds the array descriptor.
3151 This should be either a variable, indirect variable reference or component
3152 reference. For arrays which do not have a descriptor, se->expr will be
3154 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
3157 gfc_conv_array_ref (gfc_se
* se
, gfc_array_ref
* ar
, gfc_expr
*expr
,
3161 tree offset
, cst_offset
;
3166 gfc_symbol
* sym
= expr
->symtree
->n
.sym
;
3167 char *var_name
= NULL
;
3171 gcc_assert (ar
->codimen
);
3173 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
->expr
)))
3174 se
->expr
= build_fold_indirect_ref (gfc_conv_array_data (se
->expr
));
3177 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se
->expr
))
3178 && TREE_CODE (TREE_TYPE (se
->expr
)) == POINTER_TYPE
)
3179 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3181 /* Use the actual tree type and not the wrapped coarray. */
3182 if (!se
->want_pointer
)
3183 se
->expr
= fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se
->expr
)),
3190 /* Handle scalarized references separately. */
3191 if (ar
->type
!= AR_ELEMENT
)
3193 gfc_conv_scalarized_array_ref (se
, ar
);
3194 gfc_advance_se_ss_chain (se
);
3198 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3203 len
= strlen (sym
->name
) + 1;
3204 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3206 if (ref
->type
== REF_ARRAY
&& &ref
->u
.ar
== ar
)
3208 if (ref
->type
== REF_COMPONENT
)
3209 len
+= 1 + strlen (ref
->u
.c
.component
->name
);
3212 var_name
= XALLOCAVEC (char, len
);
3213 strcpy (var_name
, sym
->name
);
3215 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3217 if (ref
->type
== REF_ARRAY
&& &ref
->u
.ar
== ar
)
3219 if (ref
->type
== REF_COMPONENT
)
3221 strcat (var_name
, "%%");
3222 strcat (var_name
, ref
->u
.c
.component
->name
);
3227 cst_offset
= offset
= gfc_index_zero_node
;
3228 add_to_offset (&cst_offset
, &offset
, gfc_conv_array_offset (se
->expr
));
3230 /* Calculate the offsets from all the dimensions. Make sure to associate
3231 the final offset so that we form a chain of loop invariant summands. */
3232 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
3234 /* Calculate the index for this dimension. */
3235 gfc_init_se (&indexse
, se
);
3236 gfc_conv_expr_type (&indexse
, ar
->start
[n
], gfc_array_index_type
);
3237 gfc_add_block_to_block (&se
->pre
, &indexse
.pre
);
3239 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3241 /* Check array bounds. */
3245 /* Evaluate the indexse.expr only once. */
3246 indexse
.expr
= save_expr (indexse
.expr
);
3249 tmp
= gfc_conv_array_lbound (se
->expr
, n
);
3250 if (sym
->attr
.temporary
)
3252 gfc_init_se (&tmpse
, se
);
3253 gfc_conv_expr_type (&tmpse
, ar
->as
->lower
[n
],
3254 gfc_array_index_type
);
3255 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3259 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
3261 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
3262 "below lower bound of %%ld", n
+1, var_name
);
3263 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3264 fold_convert (long_integer_type_node
,
3266 fold_convert (long_integer_type_node
, tmp
));
3269 /* Upper bound, but not for the last dimension of assumed-size
3271 if (n
< ar
->dimen
- 1 || ar
->as
->type
!= AS_ASSUMED_SIZE
)
3273 tmp
= gfc_conv_array_ubound (se
->expr
, n
);
3274 if (sym
->attr
.temporary
)
3276 gfc_init_se (&tmpse
, se
);
3277 gfc_conv_expr_type (&tmpse
, ar
->as
->upper
[n
],
3278 gfc_array_index_type
);
3279 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3283 cond
= fold_build2_loc (input_location
, GT_EXPR
,
3284 boolean_type_node
, indexse
.expr
, tmp
);
3285 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
3286 "above upper bound of %%ld", n
+1, var_name
);
3287 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3288 fold_convert (long_integer_type_node
,
3290 fold_convert (long_integer_type_node
, tmp
));
3295 /* Multiply the index by the stride. */
3296 stride
= gfc_conv_array_stride (se
->expr
, n
);
3297 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3298 indexse
.expr
, stride
);
3300 /* And add it to the total. */
3301 add_to_offset (&cst_offset
, &offset
, tmp
);
3304 if (!integer_zerop (cst_offset
))
3305 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3306 gfc_array_index_type
, offset
, cst_offset
);
3308 se
->expr
= build_array_ref (se
->expr
, offset
, sym
->backend_decl
);
3312 /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
3313 LOOP_DIM dimension (if any) to array's offset. */
3316 add_array_offset (stmtblock_t
*pblock
, gfc_loopinfo
*loop
, gfc_ss
*ss
,
3317 gfc_array_ref
*ar
, int array_dim
, int loop_dim
)
3320 gfc_array_info
*info
;
3323 info
= &ss
->info
->data
.array
;
3325 gfc_init_se (&se
, NULL
);
3327 se
.expr
= info
->descriptor
;
3328 stride
= gfc_conv_array_stride (info
->descriptor
, array_dim
);
3329 index
= conv_array_index_offset (&se
, ss
, array_dim
, loop_dim
, ar
, stride
);
3330 gfc_add_block_to_block (pblock
, &se
.pre
);
3332 info
->offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3333 gfc_array_index_type
,
3334 info
->offset
, index
);
3335 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
3339 /* Generate the code to be executed immediately before entering a
3340 scalarization loop. */
3343 gfc_trans_preloop_setup (gfc_loopinfo
* loop
, int dim
, int flag
,
3344 stmtblock_t
* pblock
)
3347 gfc_ss_info
*ss_info
;
3348 gfc_array_info
*info
;
3349 gfc_ss_type ss_type
;
3351 gfc_loopinfo
*ploop
;
3355 /* This code will be executed before entering the scalarization loop
3356 for this dimension. */
3357 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3361 if ((ss_info
->useflags
& flag
) == 0)
3364 ss_type
= ss_info
->type
;
3365 if (ss_type
!= GFC_SS_SECTION
3366 && ss_type
!= GFC_SS_FUNCTION
3367 && ss_type
!= GFC_SS_CONSTRUCTOR
3368 && ss_type
!= GFC_SS_COMPONENT
)
3371 info
= &ss_info
->data
.array
;
3373 gcc_assert (dim
< ss
->dimen
);
3374 gcc_assert (ss
->dimen
== loop
->dimen
);
3377 ar
= &info
->ref
->u
.ar
;
3381 if (dim
== loop
->dimen
- 1 && loop
->parent
!= NULL
)
3383 /* If we are in the outermost dimension of this loop, the previous
3384 dimension shall be in the parent loop. */
3385 gcc_assert (ss
->parent
!= NULL
);
3388 ploop
= loop
->parent
;
3390 /* ss and ss->parent are about the same array. */
3391 gcc_assert (ss_info
== pss
->info
);
3399 if (dim
== loop
->dimen
- 1)
3404 /* For the time being, there is no loop reordering. */
3405 gcc_assert (i
== ploop
->order
[i
]);
3406 i
= ploop
->order
[i
];
3408 if (dim
== loop
->dimen
- 1 && loop
->parent
== NULL
)
3410 stride
= gfc_conv_array_stride (info
->descriptor
,
3411 innermost_ss (ss
)->dim
[i
]);
3413 /* Calculate the stride of the innermost loop. Hopefully this will
3414 allow the backend optimizers to do their stuff more effectively.
3416 info
->stride0
= gfc_evaluate_now (stride
, pblock
);
3418 /* For the outermost loop calculate the offset due to any
3419 elemental dimensions. It will have been initialized with the
3420 base offset of the array. */
3423 for (i
= 0; i
< ar
->dimen
; i
++)
3425 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
3428 add_array_offset (pblock
, loop
, ss
, ar
, i
, /* unused */ -1);
3433 /* Add the offset for the previous loop dimension. */
3434 add_array_offset (pblock
, ploop
, ss
, ar
, pss
->dim
[i
], i
);
3436 /* Remember this offset for the second loop. */
3437 if (dim
== loop
->temp_dim
- 1 && loop
->parent
== NULL
)
3438 info
->saved_offset
= info
->offset
;
3443 /* Start a scalarized expression. Creates a scope and declares loop
3447 gfc_start_scalarized_body (gfc_loopinfo
* loop
, stmtblock_t
* pbody
)
3453 gcc_assert (!loop
->array_parameter
);
3455 for (dim
= loop
->dimen
- 1; dim
>= 0; dim
--)
3457 n
= loop
->order
[dim
];
3459 gfc_start_block (&loop
->code
[n
]);
3461 /* Create the loop variable. */
3462 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "S");
3464 if (dim
< loop
->temp_dim
)
3468 /* Calculate values that will be constant within this loop. */
3469 gfc_trans_preloop_setup (loop
, dim
, flags
, &loop
->code
[n
]);
3471 gfc_start_block (pbody
);
3475 /* Generates the actual loop code for a scalarization loop. */
3478 gfc_trans_scalarized_loop_end (gfc_loopinfo
* loop
, int n
,
3479 stmtblock_t
* pbody
)
3490 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
))
3491 == (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
)
3492 && n
== loop
->dimen
- 1)
3494 /* We create an OMP_FOR construct for the outermost scalarized loop. */
3495 init
= make_tree_vec (1);
3496 cond
= make_tree_vec (1);
3497 incr
= make_tree_vec (1);
3499 /* Cycle statement is implemented with a goto. Exit statement must not
3500 be present for this loop. */
3501 exit_label
= gfc_build_label_decl (NULL_TREE
);
3502 TREE_USED (exit_label
) = 1;
3504 /* Label for cycle statements (if needed). */
3505 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3506 gfc_add_expr_to_block (pbody
, tmp
);
3508 stmt
= make_node (OMP_FOR
);
3510 TREE_TYPE (stmt
) = void_type_node
;
3511 OMP_FOR_BODY (stmt
) = loopbody
= gfc_finish_block (pbody
);
3513 OMP_FOR_CLAUSES (stmt
) = build_omp_clause (input_location
,
3514 OMP_CLAUSE_SCHEDULE
);
3515 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt
))
3516 = OMP_CLAUSE_SCHEDULE_STATIC
;
3517 if (ompws_flags
& OMPWS_NOWAIT
)
3518 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt
))
3519 = build_omp_clause (input_location
, OMP_CLAUSE_NOWAIT
);
3521 /* Initialize the loopvar. */
3522 TREE_VEC_ELT (init
, 0) = build2_v (MODIFY_EXPR
, loop
->loopvar
[n
],
3524 OMP_FOR_INIT (stmt
) = init
;
3525 /* The exit condition. */
3526 TREE_VEC_ELT (cond
, 0) = build2_loc (input_location
, LE_EXPR
,
3528 loop
->loopvar
[n
], loop
->to
[n
]);
3529 SET_EXPR_LOCATION (TREE_VEC_ELT (cond
, 0), input_location
);
3530 OMP_FOR_COND (stmt
) = cond
;
3531 /* Increment the loopvar. */
3532 tmp
= build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3533 loop
->loopvar
[n
], gfc_index_one_node
);
3534 TREE_VEC_ELT (incr
, 0) = fold_build2_loc (input_location
, MODIFY_EXPR
,
3535 void_type_node
, loop
->loopvar
[n
], tmp
);
3536 OMP_FOR_INCR (stmt
) = incr
;
3538 ompws_flags
&= ~OMPWS_CURR_SINGLEUNIT
;
3539 gfc_add_expr_to_block (&loop
->code
[n
], stmt
);
3543 bool reverse_loop
= (loop
->reverse
[n
] == GFC_REVERSE_SET
)
3544 && (loop
->temp_ss
== NULL
);
3546 loopbody
= gfc_finish_block (pbody
);
3550 tmp
= loop
->from
[n
];
3551 loop
->from
[n
] = loop
->to
[n
];
3555 /* Initialize the loopvar. */
3556 if (loop
->loopvar
[n
] != loop
->from
[n
])
3557 gfc_add_modify (&loop
->code
[n
], loop
->loopvar
[n
], loop
->from
[n
]);
3559 exit_label
= gfc_build_label_decl (NULL_TREE
);
3561 /* Generate the loop body. */
3562 gfc_init_block (&block
);
3564 /* The exit condition. */
3565 cond
= fold_build2_loc (input_location
, reverse_loop
? LT_EXPR
: GT_EXPR
,
3566 boolean_type_node
, loop
->loopvar
[n
], loop
->to
[n
]);
3567 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3568 TREE_USED (exit_label
) = 1;
3569 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3570 gfc_add_expr_to_block (&block
, tmp
);
3572 /* The main body. */
3573 gfc_add_expr_to_block (&block
, loopbody
);
3575 /* Increment the loopvar. */
3576 tmp
= fold_build2_loc (input_location
,
3577 reverse_loop
? MINUS_EXPR
: PLUS_EXPR
,
3578 gfc_array_index_type
, loop
->loopvar
[n
],
3579 gfc_index_one_node
);
3581 gfc_add_modify (&block
, loop
->loopvar
[n
], tmp
);
3583 /* Build the loop. */
3584 tmp
= gfc_finish_block (&block
);
3585 tmp
= build1_v (LOOP_EXPR
, tmp
);
3586 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
3588 /* Add the exit label. */
3589 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3590 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
3596 /* Finishes and generates the loops for a scalarized expression. */
3599 gfc_trans_scalarizing_loops (gfc_loopinfo
* loop
, stmtblock_t
* body
)
3604 stmtblock_t
*pblock
;
3608 /* Generate the loops. */
3609 for (dim
= 0; dim
< loop
->dimen
; dim
++)
3611 n
= loop
->order
[dim
];
3612 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
3613 loop
->loopvar
[n
] = NULL_TREE
;
3614 pblock
= &loop
->code
[n
];
3617 tmp
= gfc_finish_block (pblock
);
3618 gfc_add_expr_to_block (&loop
->pre
, tmp
);
3620 /* Clear all the used flags. */
3621 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3622 if (ss
->parent
== NULL
)
3623 ss
->info
->useflags
= 0;
3627 /* Finish the main body of a scalarized expression, and start the secondary
3631 gfc_trans_scalarized_loop_boundary (gfc_loopinfo
* loop
, stmtblock_t
* body
)
3635 stmtblock_t
*pblock
;
3639 /* We finish as many loops as are used by the temporary. */
3640 for (dim
= 0; dim
< loop
->temp_dim
- 1; dim
++)
3642 n
= loop
->order
[dim
];
3643 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
3644 loop
->loopvar
[n
] = NULL_TREE
;
3645 pblock
= &loop
->code
[n
];
3648 /* We don't want to finish the outermost loop entirely. */
3649 n
= loop
->order
[loop
->temp_dim
- 1];
3650 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
3652 /* Restore the initial offsets. */
3653 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3655 gfc_ss_type ss_type
;
3656 gfc_ss_info
*ss_info
;
3660 if ((ss_info
->useflags
& 2) == 0)
3663 ss_type
= ss_info
->type
;
3664 if (ss_type
!= GFC_SS_SECTION
3665 && ss_type
!= GFC_SS_FUNCTION
3666 && ss_type
!= GFC_SS_CONSTRUCTOR
3667 && ss_type
!= GFC_SS_COMPONENT
)
3670 ss_info
->data
.array
.offset
= ss_info
->data
.array
.saved_offset
;
3673 /* Restart all the inner loops we just finished. */
3674 for (dim
= loop
->temp_dim
- 2; dim
>= 0; dim
--)
3676 n
= loop
->order
[dim
];
3678 gfc_start_block (&loop
->code
[n
]);
3680 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "Q");
3682 gfc_trans_preloop_setup (loop
, dim
, 2, &loop
->code
[n
]);
3685 /* Start a block for the secondary copying code. */
3686 gfc_start_block (body
);
3690 /* Precalculate (either lower or upper) bound of an array section.
3691 BLOCK: Block in which the (pre)calculation code will go.
3692 BOUNDS[DIM]: Where the bound value will be stored once evaluated.
3693 VALUES[DIM]: Specified bound (NULL <=> unspecified).
3694 DESC: Array descriptor from which the bound will be picked if unspecified
3695 (either lower or upper bound according to LBOUND). */
3698 evaluate_bound (stmtblock_t
*block
, tree
*bounds
, gfc_expr
** values
,
3699 tree desc
, int dim
, bool lbound
)
3702 gfc_expr
* input_val
= values
[dim
];
3703 tree
*output
= &bounds
[dim
];
3708 /* Specified section bound. */
3709 gfc_init_se (&se
, NULL
);
3710 gfc_conv_expr_type (&se
, input_val
, gfc_array_index_type
);
3711 gfc_add_block_to_block (block
, &se
.pre
);
3716 /* No specific bound specified so use the bound of the array. */
3717 *output
= lbound
? gfc_conv_array_lbound (desc
, dim
) :
3718 gfc_conv_array_ubound (desc
, dim
);
3720 *output
= gfc_evaluate_now (*output
, block
);
3724 /* Calculate the lower bound of an array section. */
3727 gfc_conv_section_startstride (stmtblock_t
* block
, gfc_ss
* ss
, int dim
)
3729 gfc_expr
*stride
= NULL
;
3732 gfc_array_info
*info
;
3735 gcc_assert (ss
->info
->type
== GFC_SS_SECTION
);
3737 info
= &ss
->info
->data
.array
;
3738 ar
= &info
->ref
->u
.ar
;
3740 if (ar
->dimen_type
[dim
] == DIMEN_VECTOR
)
3742 /* We use a zero-based index to access the vector. */
3743 info
->start
[dim
] = gfc_index_zero_node
;
3744 info
->end
[dim
] = NULL
;
3745 info
->stride
[dim
] = gfc_index_one_node
;
3749 gcc_assert (ar
->dimen_type
[dim
] == DIMEN_RANGE
3750 || ar
->dimen_type
[dim
] == DIMEN_THIS_IMAGE
);
3751 desc
= info
->descriptor
;
3752 stride
= ar
->stride
[dim
];
3754 /* Calculate the start of the range. For vector subscripts this will
3755 be the range of the vector. */
3756 evaluate_bound (block
, info
->start
, ar
->start
, desc
, dim
, true);
3758 /* Similarly calculate the end. Although this is not used in the
3759 scalarizer, it is needed when checking bounds and where the end
3760 is an expression with side-effects. */
3761 evaluate_bound (block
, info
->end
, ar
->end
, desc
, dim
, false);
3763 /* Calculate the stride. */
3765 info
->stride
[dim
] = gfc_index_one_node
;
3768 gfc_init_se (&se
, NULL
);
3769 gfc_conv_expr_type (&se
, stride
, gfc_array_index_type
);
3770 gfc_add_block_to_block (block
, &se
.pre
);
3771 info
->stride
[dim
] = gfc_evaluate_now (se
.expr
, block
);
3776 /* Calculates the range start and stride for a SS chain. Also gets the
3777 descriptor and data pointer. The range of vector subscripts is the size
3778 of the vector. Array bounds are also checked. */
3781 gfc_conv_ss_startstride (gfc_loopinfo
* loop
)
3788 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
3791 /* Determine the rank of the loop. */
3792 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3794 switch (ss
->info
->type
)
3796 case GFC_SS_SECTION
:
3797 case GFC_SS_CONSTRUCTOR
:
3798 case GFC_SS_FUNCTION
:
3799 case GFC_SS_COMPONENT
:
3800 loop
->dimen
= ss
->dimen
;
3803 /* As usual, lbound and ubound are exceptions!. */
3804 case GFC_SS_INTRINSIC
:
3805 switch (ss
->info
->expr
->value
.function
.isym
->id
)
3807 case GFC_ISYM_LBOUND
:
3808 case GFC_ISYM_UBOUND
:
3809 case GFC_ISYM_LCOBOUND
:
3810 case GFC_ISYM_UCOBOUND
:
3811 case GFC_ISYM_THIS_IMAGE
:
3812 loop
->dimen
= ss
->dimen
;
3824 /* We should have determined the rank of the expression by now. If
3825 not, that's bad news. */
3829 /* Loop over all the SS in the chain. */
3830 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3832 gfc_ss_info
*ss_info
;
3833 gfc_array_info
*info
;
3837 expr
= ss_info
->expr
;
3838 info
= &ss_info
->data
.array
;
3840 if (expr
&& expr
->shape
&& !info
->shape
)
3841 info
->shape
= expr
->shape
;
3843 switch (ss_info
->type
)
3845 case GFC_SS_SECTION
:
3846 /* Get the descriptor for the array. If it is a cross loops array,
3847 we got the descriptor already in the outermost loop. */
3848 if (ss
->parent
== NULL
)
3849 gfc_conv_ss_descriptor (&outer_loop
->pre
, ss
,
3850 !loop
->array_parameter
);
3852 for (n
= 0; n
< ss
->dimen
; n
++)
3853 gfc_conv_section_startstride (&outer_loop
->pre
, ss
, ss
->dim
[n
]);
3856 case GFC_SS_INTRINSIC
:
3857 switch (expr
->value
.function
.isym
->id
)
3859 /* Fall through to supply start and stride. */
3860 case GFC_ISYM_LBOUND
:
3861 case GFC_ISYM_UBOUND
:
3865 /* This is the variant without DIM=... */
3866 gcc_assert (expr
->value
.function
.actual
->next
->expr
== NULL
);
3868 arg
= expr
->value
.function
.actual
->expr
;
3869 if (arg
->rank
== -1)
3874 /* The rank (hence the return value's shape) is unknown,
3875 we have to retrieve it. */
3876 gfc_init_se (&se
, NULL
);
3877 se
.descriptor_only
= 1;
3878 gfc_conv_expr (&se
, arg
);
3879 /* This is a bare variable, so there is no preliminary
3881 gcc_assert (se
.pre
.head
== NULL_TREE
3882 && se
.post
.head
== NULL_TREE
);
3883 rank
= gfc_conv_descriptor_rank (se
.expr
);
3884 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3885 gfc_array_index_type
,
3886 fold_convert (gfc_array_index_type
,
3888 gfc_index_one_node
);
3889 info
->end
[0] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
3890 info
->start
[0] = gfc_index_zero_node
;
3891 info
->stride
[0] = gfc_index_one_node
;
3894 /* Otherwise fall through GFC_SS_FUNCTION. */
3896 case GFC_ISYM_LCOBOUND
:
3897 case GFC_ISYM_UCOBOUND
:
3898 case GFC_ISYM_THIS_IMAGE
:
3905 case GFC_SS_CONSTRUCTOR
:
3906 case GFC_SS_FUNCTION
:
3907 for (n
= 0; n
< ss
->dimen
; n
++)
3909 int dim
= ss
->dim
[n
];
3911 info
->start
[dim
] = gfc_index_zero_node
;
3912 info
->end
[dim
] = gfc_index_zero_node
;
3913 info
->stride
[dim
] = gfc_index_one_node
;
3922 /* The rest is just runtime bound checking. */
3923 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3926 tree lbound
, ubound
;
3928 tree size
[GFC_MAX_DIMENSIONS
];
3929 tree stride_pos
, stride_neg
, non_zerosized
, tmp2
, tmp3
;
3930 gfc_array_info
*info
;
3934 gfc_start_block (&block
);
3936 for (n
= 0; n
< loop
->dimen
; n
++)
3937 size
[n
] = NULL_TREE
;
3939 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3942 gfc_ss_info
*ss_info
;
3945 const char *expr_name
;
3948 if (ss_info
->type
!= GFC_SS_SECTION
)
3951 /* Catch allocatable lhs in f2003. */
3952 if (gfc_option
.flag_realloc_lhs
&& ss
->is_alloc_lhs
)
3955 expr
= ss_info
->expr
;
3956 expr_loc
= &expr
->where
;
3957 expr_name
= expr
->symtree
->name
;
3959 gfc_start_block (&inner
);
3961 /* TODO: range checking for mapped dimensions. */
3962 info
= &ss_info
->data
.array
;
3964 /* This code only checks ranges. Elemental and vector
3965 dimensions are checked later. */
3966 for (n
= 0; n
< loop
->dimen
; n
++)
3971 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
3974 if (dim
== info
->ref
->u
.ar
.dimen
- 1
3975 && info
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
3976 check_upper
= false;
3980 /* Zero stride is not allowed. */
3981 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
3982 info
->stride
[dim
], gfc_index_zero_node
);
3983 asprintf (&msg
, "Zero stride is not allowed, for dimension %d "
3984 "of array '%s'", dim
+ 1, expr_name
);
3985 gfc_trans_runtime_check (true, false, tmp
, &inner
,
3989 desc
= info
->descriptor
;
3991 /* This is the run-time equivalent of resolve.c's
3992 check_dimension(). The logical is more readable there
3993 than it is here, with all the trees. */
3994 lbound
= gfc_conv_array_lbound (desc
, dim
);
3995 end
= info
->end
[dim
];
3997 ubound
= gfc_conv_array_ubound (desc
, dim
);
4001 /* non_zerosized is true when the selected range is not
4003 stride_pos
= fold_build2_loc (input_location
, GT_EXPR
,
4004 boolean_type_node
, info
->stride
[dim
],
4005 gfc_index_zero_node
);
4006 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
4007 info
->start
[dim
], end
);
4008 stride_pos
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4009 boolean_type_node
, stride_pos
, tmp
);
4011 stride_neg
= fold_build2_loc (input_location
, LT_EXPR
,
4013 info
->stride
[dim
], gfc_index_zero_node
);
4014 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
4015 info
->start
[dim
], end
);
4016 stride_neg
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4019 non_zerosized
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
4021 stride_pos
, stride_neg
);
4023 /* Check the start of the range against the lower and upper
4024 bounds of the array, if the range is not empty.
4025 If upper bound is present, include both bounds in the
4029 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
4031 info
->start
[dim
], lbound
);
4032 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4034 non_zerosized
, tmp
);
4035 tmp2
= fold_build2_loc (input_location
, GT_EXPR
,
4037 info
->start
[dim
], ubound
);
4038 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4040 non_zerosized
, tmp2
);
4041 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
4042 "outside of expected range (%%ld:%%ld)",
4043 dim
+ 1, expr_name
);
4044 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4046 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4047 fold_convert (long_integer_type_node
, lbound
),
4048 fold_convert (long_integer_type_node
, ubound
));
4049 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4051 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4052 fold_convert (long_integer_type_node
, lbound
),
4053 fold_convert (long_integer_type_node
, ubound
));
4058 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
4060 info
->start
[dim
], lbound
);
4061 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4062 boolean_type_node
, non_zerosized
, tmp
);
4063 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
4064 "below lower bound of %%ld",
4065 dim
+ 1, expr_name
);
4066 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4068 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4069 fold_convert (long_integer_type_node
, lbound
));
4073 /* Compute the last element of the range, which is not
4074 necessarily "end" (think 0:5:3, which doesn't contain 5)
4075 and check it against both lower and upper bounds. */
4077 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4078 gfc_array_index_type
, end
,
4080 tmp
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
,
4081 gfc_array_index_type
, tmp
,
4083 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4084 gfc_array_index_type
, end
, tmp
);
4085 tmp2
= fold_build2_loc (input_location
, LT_EXPR
,
4086 boolean_type_node
, tmp
, lbound
);
4087 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4088 boolean_type_node
, non_zerosized
, tmp2
);
4091 tmp3
= fold_build2_loc (input_location
, GT_EXPR
,
4092 boolean_type_node
, tmp
, ubound
);
4093 tmp3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4094 boolean_type_node
, non_zerosized
, tmp3
);
4095 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
4096 "outside of expected range (%%ld:%%ld)",
4097 dim
+ 1, expr_name
);
4098 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4100 fold_convert (long_integer_type_node
, tmp
),
4101 fold_convert (long_integer_type_node
, ubound
),
4102 fold_convert (long_integer_type_node
, lbound
));
4103 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4105 fold_convert (long_integer_type_node
, tmp
),
4106 fold_convert (long_integer_type_node
, ubound
),
4107 fold_convert (long_integer_type_node
, lbound
));
4112 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
4113 "below lower bound of %%ld",
4114 dim
+ 1, expr_name
);
4115 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4117 fold_convert (long_integer_type_node
, tmp
),
4118 fold_convert (long_integer_type_node
, lbound
));
4122 /* Check the section sizes match. */
4123 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4124 gfc_array_index_type
, end
,
4126 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
4127 gfc_array_index_type
, tmp
,
4129 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4130 gfc_array_index_type
,
4131 gfc_index_one_node
, tmp
);
4132 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
4133 gfc_array_index_type
, tmp
,
4134 build_int_cst (gfc_array_index_type
, 0));
4135 /* We remember the size of the first section, and check all the
4136 others against this. */
4139 tmp3
= fold_build2_loc (input_location
, NE_EXPR
,
4140 boolean_type_node
, tmp
, size
[n
]);
4141 asprintf (&msg
, "Array bound mismatch for dimension %d "
4142 "of array '%s' (%%ld/%%ld)",
4143 dim
+ 1, expr_name
);
4145 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4147 fold_convert (long_integer_type_node
, tmp
),
4148 fold_convert (long_integer_type_node
, size
[n
]));
4153 size
[n
] = gfc_evaluate_now (tmp
, &inner
);
4156 tmp
= gfc_finish_block (&inner
);
4158 /* For optional arguments, only check bounds if the argument is
4160 if (expr
->symtree
->n
.sym
->attr
.optional
4161 || expr
->symtree
->n
.sym
->attr
.not_always_present
)
4162 tmp
= build3_v (COND_EXPR
,
4163 gfc_conv_expr_present (expr
->symtree
->n
.sym
),
4164 tmp
, build_empty_stmt (input_location
));
4166 gfc_add_expr_to_block (&block
, tmp
);
4170 tmp
= gfc_finish_block (&block
);
4171 gfc_add_expr_to_block (&outer_loop
->pre
, tmp
);
4174 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4175 gfc_conv_ss_startstride (loop
);
4178 /* Return true if both symbols could refer to the same data object. Does
4179 not take account of aliasing due to equivalence statements. */
4182 symbols_could_alias (gfc_symbol
*lsym
, gfc_symbol
*rsym
, bool lsym_pointer
,
4183 bool lsym_target
, bool rsym_pointer
, bool rsym_target
)
4185 /* Aliasing isn't possible if the symbols have different base types. */
4186 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
4189 /* Pointers can point to other pointers and target objects. */
4191 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4192 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4195 /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
4196 and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
4198 if (lsym_target
&& rsym_target
4199 && ((lsym
->attr
.dummy
&& !lsym
->attr
.contiguous
4200 && (!lsym
->attr
.dimension
|| lsym
->as
->type
== AS_ASSUMED_SHAPE
))
4201 || (rsym
->attr
.dummy
&& !rsym
->attr
.contiguous
4202 && (!rsym
->attr
.dimension
4203 || rsym
->as
->type
== AS_ASSUMED_SHAPE
))))
4210 /* Return true if the two SS could be aliased, i.e. both point to the same data
4212 /* TODO: resolve aliases based on frontend expressions. */
4215 gfc_could_be_alias (gfc_ss
* lss
, gfc_ss
* rss
)
4219 gfc_expr
*lexpr
, *rexpr
;
4222 bool lsym_pointer
, lsym_target
, rsym_pointer
, rsym_target
;
4224 lexpr
= lss
->info
->expr
;
4225 rexpr
= rss
->info
->expr
;
4227 lsym
= lexpr
->symtree
->n
.sym
;
4228 rsym
= rexpr
->symtree
->n
.sym
;
4230 lsym_pointer
= lsym
->attr
.pointer
;
4231 lsym_target
= lsym
->attr
.target
;
4232 rsym_pointer
= rsym
->attr
.pointer
;
4233 rsym_target
= rsym
->attr
.target
;
4235 if (symbols_could_alias (lsym
, rsym
, lsym_pointer
, lsym_target
,
4236 rsym_pointer
, rsym_target
))
4239 if (rsym
->ts
.type
!= BT_DERIVED
&& rsym
->ts
.type
!= BT_CLASS
4240 && lsym
->ts
.type
!= BT_DERIVED
&& lsym
->ts
.type
!= BT_CLASS
)
4243 /* For derived types we must check all the component types. We can ignore
4244 array references as these will have the same base type as the previous
4246 for (lref
= lexpr
->ref
; lref
!= lss
->info
->data
.array
.ref
; lref
= lref
->next
)
4248 if (lref
->type
!= REF_COMPONENT
)
4251 lsym_pointer
= lsym_pointer
|| lref
->u
.c
.sym
->attr
.pointer
;
4252 lsym_target
= lsym_target
|| lref
->u
.c
.sym
->attr
.target
;
4254 if (symbols_could_alias (lref
->u
.c
.sym
, rsym
, lsym_pointer
, lsym_target
,
4255 rsym_pointer
, rsym_target
))
4258 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4259 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4261 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4266 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
;
4269 if (rref
->type
!= REF_COMPONENT
)
4272 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4273 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4275 if (symbols_could_alias (lref
->u
.c
.sym
, rref
->u
.c
.sym
,
4276 lsym_pointer
, lsym_target
,
4277 rsym_pointer
, rsym_target
))
4280 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4281 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4283 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4284 &rref
->u
.c
.sym
->ts
))
4286 if (gfc_compare_types (&lref
->u
.c
.sym
->ts
,
4287 &rref
->u
.c
.component
->ts
))
4289 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4290 &rref
->u
.c
.component
->ts
))
4296 lsym_pointer
= lsym
->attr
.pointer
;
4297 lsym_target
= lsym
->attr
.target
;
4298 lsym_pointer
= lsym
->attr
.pointer
;
4299 lsym_target
= lsym
->attr
.target
;
4301 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
; rref
= rref
->next
)
4303 if (rref
->type
!= REF_COMPONENT
)
4306 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4307 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4309 if (symbols_could_alias (rref
->u
.c
.sym
, lsym
,
4310 lsym_pointer
, lsym_target
,
4311 rsym_pointer
, rsym_target
))
4314 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4315 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4317 if (gfc_compare_types (&lsym
->ts
, &rref
->u
.c
.component
->ts
))
4326 /* Resolve array data dependencies. Creates a temporary if required. */
4327 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
4331 gfc_conv_resolve_dependencies (gfc_loopinfo
* loop
, gfc_ss
* dest
,
4337 gfc_expr
*dest_expr
;
4342 loop
->temp_ss
= NULL
;
4343 dest_expr
= dest
->info
->expr
;
4345 for (ss
= rss
; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
4347 ss_expr
= ss
->info
->expr
;
4349 if (ss
->info
->type
!= GFC_SS_SECTION
)
4351 if (gfc_option
.flag_realloc_lhs
4352 && dest_expr
!= ss_expr
4353 && gfc_is_reallocatable_lhs (dest_expr
)
4355 nDepend
= gfc_check_dependency (dest_expr
, ss_expr
, true);
4360 if (dest_expr
->symtree
->n
.sym
!= ss_expr
->symtree
->n
.sym
)
4362 if (gfc_could_be_alias (dest
, ss
)
4363 || gfc_are_equivalenced_arrays (dest_expr
, ss_expr
))
4371 lref
= dest_expr
->ref
;
4372 rref
= ss_expr
->ref
;
4374 nDepend
= gfc_dep_resolver (lref
, rref
, &loop
->reverse
[0]);
4379 for (i
= 0; i
< dest
->dimen
; i
++)
4380 for (j
= 0; j
< ss
->dimen
; j
++)
4382 && dest
->dim
[i
] == ss
->dim
[j
])
4384 /* If we don't access array elements in the same order,
4385 there is a dependency. */
4390 /* TODO : loop shifting. */
4393 /* Mark the dimensions for LOOP SHIFTING */
4394 for (n
= 0; n
< loop
->dimen
; n
++)
4396 int dim
= dest
->data
.info
.dim
[n
];
4398 if (lref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
4400 else if (! gfc_is_same_range (&lref
->u
.ar
,
4401 &rref
->u
.ar
, dim
, 0))
4405 /* Put all the dimensions with dependencies in the
4408 for (n
= 0; n
< loop
->dimen
; n
++)
4410 gcc_assert (loop
->order
[n
] == n
);
4412 loop
->order
[dim
++] = n
;
4414 for (n
= 0; n
< loop
->dimen
; n
++)
4417 loop
->order
[dim
++] = n
;
4420 gcc_assert (dim
== loop
->dimen
);
4431 tree base_type
= gfc_typenode_for_spec (&dest_expr
->ts
);
4432 if (GFC_ARRAY_TYPE_P (base_type
)
4433 || GFC_DESCRIPTOR_TYPE_P (base_type
))
4434 base_type
= gfc_get_element_type (base_type
);
4435 loop
->temp_ss
= gfc_get_temp_ss (base_type
, dest
->info
->string_length
,
4437 gfc_add_ss_to_loop (loop
, loop
->temp_ss
);
4440 loop
->temp_ss
= NULL
;
4444 /* Browse through each array's information from the scalarizer and set the loop
4445 bounds according to the "best" one (per dimension), i.e. the one which
4446 provides the most information (constant bounds, shape, etc.). */
4449 set_loop_bounds (gfc_loopinfo
*loop
)
4451 int n
, dim
, spec_dim
;
4452 gfc_array_info
*info
;
4453 gfc_array_info
*specinfo
;
4457 bool dynamic
[GFC_MAX_DIMENSIONS
];
4460 bool nonoptional_arr
;
4462 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
4464 loopspec
= loop
->specloop
;
4467 for (n
= 0; n
< loop
->dimen
; n
++)
4472 /* If there are both optional and nonoptional array arguments, scalarize
4473 over the nonoptional; otherwise, it does not matter as then all
4474 (optional) arrays have to be present per F2008, 125.2.12p3(6). */
4476 nonoptional_arr
= false;
4478 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4479 if (ss
->info
->type
!= GFC_SS_SCALAR
&& ss
->info
->type
!= GFC_SS_TEMP
4480 && ss
->info
->type
!= GFC_SS_REFERENCE
&& !ss
->info
->can_be_null_ref
)
4482 nonoptional_arr
= true;
4486 /* We use one SS term, and use that to determine the bounds of the
4487 loop for this dimension. We try to pick the simplest term. */
4488 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4490 gfc_ss_type ss_type
;
4492 ss_type
= ss
->info
->type
;
4493 if (ss_type
== GFC_SS_SCALAR
4494 || ss_type
== GFC_SS_TEMP
4495 || ss_type
== GFC_SS_REFERENCE
4496 || (ss
->info
->can_be_null_ref
&& nonoptional_arr
))
4499 info
= &ss
->info
->data
.array
;
4502 if (loopspec
[n
] != NULL
)
4504 specinfo
= &loopspec
[n
]->info
->data
.array
;
4505 spec_dim
= loopspec
[n
]->dim
[n
];
4509 /* Silence uninitialized warnings. */
4516 gcc_assert (info
->shape
[dim
]);
4517 /* The frontend has worked out the size for us. */
4520 || !integer_zerop (specinfo
->start
[spec_dim
]))
4521 /* Prefer zero-based descriptors if possible. */
4526 if (ss_type
== GFC_SS_CONSTRUCTOR
)
4528 gfc_constructor_base base
;
4529 /* An unknown size constructor will always be rank one.
4530 Higher rank constructors will either have known shape,
4531 or still be wrapped in a call to reshape. */
4532 gcc_assert (loop
->dimen
== 1);
4534 /* Always prefer to use the constructor bounds if the size
4535 can be determined at compile time. Prefer not to otherwise,
4536 since the general case involves realloc, and it's better to
4537 avoid that overhead if possible. */
4538 base
= ss
->info
->expr
->value
.constructor
;
4539 dynamic
[n
] = gfc_get_array_constructor_size (&i
, base
);
4540 if (!dynamic
[n
] || !loopspec
[n
])
4545 /* Avoid using an allocatable lhs in an assignment, since
4546 there might be a reallocation coming. */
4547 if (loopspec
[n
] && ss
->is_alloc_lhs
)
4552 /* Criteria for choosing a loop specifier (most important first):
4553 doesn't need realloc
4559 else if (loopspec
[n
]->info
->type
== GFC_SS_CONSTRUCTOR
&& dynamic
[n
])
4561 else if (integer_onep (info
->stride
[dim
])
4562 && !integer_onep (specinfo
->stride
[spec_dim
]))
4564 else if (INTEGER_CST_P (info
->stride
[dim
])
4565 && !INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
4567 else if (INTEGER_CST_P (info
->start
[dim
])
4568 && !INTEGER_CST_P (specinfo
->start
[spec_dim
])
4569 && integer_onep (info
->stride
[dim
])
4570 == integer_onep (specinfo
->stride
[spec_dim
])
4571 && INTEGER_CST_P (info
->stride
[dim
])
4572 == INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
4574 /* We don't work out the upper bound.
4575 else if (INTEGER_CST_P (info->finish[n])
4576 && ! INTEGER_CST_P (specinfo->finish[n]))
4577 loopspec[n] = ss; */
4580 /* We should have found the scalarization loop specifier. If not,
4582 gcc_assert (loopspec
[n
]);
4584 info
= &loopspec
[n
]->info
->data
.array
;
4585 dim
= loopspec
[n
]->dim
[n
];
4587 /* Set the extents of this range. */
4588 cshape
= info
->shape
;
4589 if (cshape
&& INTEGER_CST_P (info
->start
[dim
])
4590 && INTEGER_CST_P (info
->stride
[dim
]))
4592 loop
->from
[n
] = info
->start
[dim
];
4593 mpz_set (i
, cshape
[get_array_ref_dim_for_loop_dim (loopspec
[n
], n
)]);
4594 mpz_sub_ui (i
, i
, 1);
4595 /* To = from + (size - 1) * stride. */
4596 tmp
= gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
4597 if (!integer_onep (info
->stride
[dim
]))
4598 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
4599 gfc_array_index_type
, tmp
,
4601 loop
->to
[n
] = fold_build2_loc (input_location
, PLUS_EXPR
,
4602 gfc_array_index_type
,
4603 loop
->from
[n
], tmp
);
4607 loop
->from
[n
] = info
->start
[dim
];
4608 switch (loopspec
[n
]->info
->type
)
4610 case GFC_SS_CONSTRUCTOR
:
4611 /* The upper bound is calculated when we expand the
4613 gcc_assert (loop
->to
[n
] == NULL_TREE
);
4616 case GFC_SS_SECTION
:
4617 /* Use the end expression if it exists and is not constant,
4618 so that it is only evaluated once. */
4619 loop
->to
[n
] = info
->end
[dim
];
4622 case GFC_SS_FUNCTION
:
4623 /* The loop bound will be set when we generate the call. */
4624 gcc_assert (loop
->to
[n
] == NULL_TREE
);
4627 case GFC_SS_INTRINSIC
:
4629 gfc_expr
*expr
= loopspec
[n
]->info
->expr
;
4631 /* The {l,u}bound of an assumed rank. */
4632 gcc_assert ((expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
4633 || expr
->value
.function
.isym
->id
== GFC_ISYM_UBOUND
)
4634 && expr
->value
.function
.actual
->next
->expr
== NULL
4635 && expr
->value
.function
.actual
->expr
->rank
== -1);
4637 loop
->to
[n
] = info
->end
[dim
];
4646 /* Transform everything so we have a simple incrementing variable. */
4647 if (integer_onep (info
->stride
[dim
]))
4648 info
->delta
[dim
] = gfc_index_zero_node
;
4651 /* Set the delta for this section. */
4652 info
->delta
[dim
] = gfc_evaluate_now (loop
->from
[n
], &outer_loop
->pre
);
4653 /* Number of iterations is (end - start + step) / step.
4654 with start = 0, this simplifies to
4656 for (i = 0; i<=last; i++){...}; */
4657 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4658 gfc_array_index_type
, loop
->to
[n
],
4660 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
4661 gfc_array_index_type
, tmp
, info
->stride
[dim
]);
4662 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
4663 tmp
, build_int_cst (gfc_array_index_type
, -1));
4664 loop
->to
[n
] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
4665 /* Make the loop variable start at 0. */
4666 loop
->from
[n
] = gfc_index_zero_node
;
4671 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4672 set_loop_bounds (loop
);
4676 /* Initialize the scalarization loop. Creates the loop variables. Determines
4677 the range of the loop variables. Creates a temporary if required.
4678 Also generates code for scalar expressions which have been
4679 moved outside the loop. */
4682 gfc_conv_loop_setup (gfc_loopinfo
* loop
, locus
* where
)
4687 set_loop_bounds (loop
);
4689 /* Add all the scalar code that can be taken out of the loops.
4690 This may include calculating the loop bounds, so do it before
4691 allocating the temporary. */
4692 gfc_add_loop_ss_code (loop
, loop
->ss
, false, where
);
4694 tmp_ss
= loop
->temp_ss
;
4695 /* If we want a temporary then create it. */
4698 gfc_ss_info
*tmp_ss_info
;
4700 tmp_ss_info
= tmp_ss
->info
;
4701 gcc_assert (tmp_ss_info
->type
== GFC_SS_TEMP
);
4702 gcc_assert (loop
->parent
== NULL
);
4704 /* Make absolutely sure that this is a complete type. */
4705 if (tmp_ss_info
->string_length
)
4706 tmp_ss_info
->data
.temp
.type
4707 = gfc_get_character_type_len_for_eltype
4708 (TREE_TYPE (tmp_ss_info
->data
.temp
.type
),
4709 tmp_ss_info
->string_length
);
4711 tmp
= tmp_ss_info
->data
.temp
.type
;
4712 memset (&tmp_ss_info
->data
.array
, 0, sizeof (gfc_array_info
));
4713 tmp_ss_info
->type
= GFC_SS_SECTION
;
4715 gcc_assert (tmp_ss
->dimen
!= 0);
4717 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, tmp_ss
, tmp
,
4718 NULL_TREE
, false, true, false, where
);
4721 /* For array parameters we don't have loop variables, so don't calculate the
4723 if (!loop
->array_parameter
)
4724 gfc_set_delta (loop
);
4728 /* Calculates how to transform from loop variables to array indices for each
4729 array: once loop bounds are chosen, sets the difference (DELTA field) between
4730 loop bounds and array reference bounds, for each array info. */
4733 gfc_set_delta (gfc_loopinfo
*loop
)
4735 gfc_ss
*ss
, **loopspec
;
4736 gfc_array_info
*info
;
4740 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
4742 loopspec
= loop
->specloop
;
4744 /* Calculate the translation from loop variables to array indices. */
4745 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4747 gfc_ss_type ss_type
;
4749 ss_type
= ss
->info
->type
;
4750 if (ss_type
!= GFC_SS_SECTION
4751 && ss_type
!= GFC_SS_COMPONENT
4752 && ss_type
!= GFC_SS_CONSTRUCTOR
)
4755 info
= &ss
->info
->data
.array
;
4757 for (n
= 0; n
< ss
->dimen
; n
++)
4759 /* If we are specifying the range the delta is already set. */
4760 if (loopspec
[n
] != ss
)
4764 /* Calculate the offset relative to the loop variable.
4765 First multiply by the stride. */
4766 tmp
= loop
->from
[n
];
4767 if (!integer_onep (info
->stride
[dim
]))
4768 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
4769 gfc_array_index_type
,
4770 tmp
, info
->stride
[dim
]);
4772 /* Then subtract this from our starting value. */
4773 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4774 gfc_array_index_type
,
4775 info
->start
[dim
], tmp
);
4777 info
->delta
[dim
] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
4782 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4783 gfc_set_delta (loop
);
4787 /* Calculate the size of a given array dimension from the bounds. This
4788 is simply (ubound - lbound + 1) if this expression is positive
4789 or 0 if it is negative (pick either one if it is zero). Optionally
4790 (if or_expr is present) OR the (expression != 0) condition to it. */
4793 gfc_conv_array_extent_dim (tree lbound
, tree ubound
, tree
* or_expr
)
4798 /* Calculate (ubound - lbound + 1). */
4799 res
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4801 res
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
, res
,
4802 gfc_index_one_node
);
4804 /* Check whether the size for this dimension is negative. */
4805 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, res
,
4806 gfc_index_zero_node
);
4807 res
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
, cond
,
4808 gfc_index_zero_node
, res
);
4810 /* Build OR expression. */
4812 *or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
4813 boolean_type_node
, *or_expr
, cond
);
4819 /* For an array descriptor, get the total number of elements. This is just
4820 the product of the extents along from_dim to to_dim. */
4823 gfc_conv_descriptor_size_1 (tree desc
, int from_dim
, int to_dim
)
4828 res
= gfc_index_one_node
;
4830 for (dim
= from_dim
; dim
< to_dim
; ++dim
)
4836 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]);
4837 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]);
4839 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
4840 res
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4848 /* Full size of an array. */
4851 gfc_conv_descriptor_size (tree desc
, int rank
)
4853 return gfc_conv_descriptor_size_1 (desc
, 0, rank
);
4857 /* Size of a coarray for all dimensions but the last. */
4860 gfc_conv_descriptor_cosize (tree desc
, int rank
, int corank
)
4862 return gfc_conv_descriptor_size_1 (desc
, rank
, rank
+ corank
- 1);
4866 /* Fills in an array descriptor, and returns the size of the array.
4867 The size will be a simple_val, ie a variable or a constant. Also
4868 calculates the offset of the base. The pointer argument overflow,
4869 which should be of integer type, will increase in value if overflow
4870 occurs during the size calculation. Returns the size of the array.
4874 for (n = 0; n < rank; n++)
4876 a.lbound[n] = specified_lower_bound;
4877 offset = offset + a.lbond[n] * stride;
4879 a.ubound[n] = specified_upper_bound;
4880 a.stride[n] = stride;
4881 size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
4882 overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
4883 stride = stride * size;
4885 for (n = rank; n < rank+corank; n++)
4886 (Set lcobound/ucobound as above.)
4887 element_size = sizeof (array element);
4890 stride = (size_t) stride;
4891 overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
4892 stride = stride * element_size;
4898 gfc_array_init_size (tree descriptor
, int rank
, int corank
, tree
* poffset
,
4899 gfc_expr
** lower
, gfc_expr
** upper
, stmtblock_t
* pblock
,
4900 stmtblock_t
* descriptor_block
, tree
* overflow
,
4901 tree expr3_elem_size
, tree
*nelems
, gfc_expr
*expr3
,
4915 stmtblock_t thenblock
;
4916 stmtblock_t elseblock
;
4921 type
= TREE_TYPE (descriptor
);
4923 stride
= gfc_index_one_node
;
4924 offset
= gfc_index_zero_node
;
4926 /* Set the dtype. */
4927 tmp
= gfc_conv_descriptor_dtype (descriptor
);
4928 gfc_add_modify (descriptor_block
, tmp
, gfc_get_dtype (TREE_TYPE (descriptor
)));
4930 or_expr
= boolean_false_node
;
4932 for (n
= 0; n
< rank
; n
++)
4937 /* We have 3 possibilities for determining the size of the array:
4938 lower == NULL => lbound = 1, ubound = upper[n]
4939 upper[n] = NULL => lbound = 1, ubound = lower[n]
4940 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
4943 /* Set lower bound. */
4944 gfc_init_se (&se
, NULL
);
4946 se
.expr
= gfc_index_one_node
;
4949 gcc_assert (lower
[n
]);
4952 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
4953 gfc_add_block_to_block (pblock
, &se
.pre
);
4957 se
.expr
= gfc_index_one_node
;
4961 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
4962 gfc_rank_cst
[n
], se
.expr
);
4963 conv_lbound
= se
.expr
;
4965 /* Work out the offset for this component. */
4966 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4968 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
4969 gfc_array_index_type
, offset
, tmp
);
4971 /* Set upper bound. */
4972 gfc_init_se (&se
, NULL
);
4973 gcc_assert (ubound
);
4974 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
4975 gfc_add_block_to_block (pblock
, &se
.pre
);
4977 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
4978 gfc_rank_cst
[n
], se
.expr
);
4979 conv_ubound
= se
.expr
;
4981 /* Store the stride. */
4982 gfc_conv_descriptor_stride_set (descriptor_block
, descriptor
,
4983 gfc_rank_cst
[n
], stride
);
4985 /* Calculate size and check whether extent is negative. */
4986 size
= gfc_conv_array_extent_dim (conv_lbound
, conv_ubound
, &or_expr
);
4987 size
= gfc_evaluate_now (size
, pblock
);
4989 /* Check whether multiplying the stride by the number of
4990 elements in this dimension would overflow. We must also check
4991 whether the current dimension has zero size in order to avoid
4994 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
4995 gfc_array_index_type
,
4996 fold_convert (gfc_array_index_type
,
4997 TYPE_MAX_VALUE (gfc_array_index_type
)),
4999 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
5000 boolean_type_node
, tmp
, stride
),
5001 PRED_FORTRAN_OVERFLOW
);
5002 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5003 integer_one_node
, integer_zero_node
);
5004 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
5005 boolean_type_node
, size
,
5006 gfc_index_zero_node
),
5007 PRED_FORTRAN_SIZE_ZERO
);
5008 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5009 integer_zero_node
, tmp
);
5010 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
5012 *overflow
= gfc_evaluate_now (tmp
, pblock
);
5014 /* Multiply the stride by the number of elements in this dimension. */
5015 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
5016 gfc_array_index_type
, stride
, size
);
5017 stride
= gfc_evaluate_now (stride
, pblock
);
5020 for (n
= rank
; n
< rank
+ corank
; n
++)
5024 /* Set lower bound. */
5025 gfc_init_se (&se
, NULL
);
5026 if (lower
== NULL
|| lower
[n
] == NULL
)
5028 gcc_assert (n
== rank
+ corank
- 1);
5029 se
.expr
= gfc_index_one_node
;
5033 if (ubound
|| n
== rank
+ corank
- 1)
5035 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
5036 gfc_add_block_to_block (pblock
, &se
.pre
);
5040 se
.expr
= gfc_index_one_node
;
5044 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
5045 gfc_rank_cst
[n
], se
.expr
);
5047 if (n
< rank
+ corank
- 1)
5049 gfc_init_se (&se
, NULL
);
5050 gcc_assert (ubound
);
5051 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
5052 gfc_add_block_to_block (pblock
, &se
.pre
);
5053 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
5054 gfc_rank_cst
[n
], se
.expr
);
5058 /* The stride is the number of elements in the array, so multiply by the
5059 size of an element to get the total size. Obviously, if there is a
5060 SOURCE expression (expr3) we must use its element size. */
5061 if (expr3_elem_size
!= NULL_TREE
)
5062 tmp
= expr3_elem_size
;
5063 else if (expr3
!= NULL
)
5065 if (expr3
->ts
.type
== BT_CLASS
)
5068 gfc_expr
*sz
= gfc_copy_expr (expr3
);
5069 gfc_add_vptr_component (sz
);
5070 gfc_add_size_component (sz
);
5071 gfc_init_se (&se_sz
, NULL
);
5072 gfc_conv_expr (&se_sz
, sz
);
5078 tmp
= gfc_typenode_for_spec (&expr3
->ts
);
5079 tmp
= TYPE_SIZE_UNIT (tmp
);
5082 else if (ts
->type
!= BT_UNKNOWN
&& ts
->type
!= BT_CHARACTER
)
5083 /* FIXME: Properly handle characters. See PR 57456. */
5084 tmp
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (ts
));
5086 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
5088 /* Convert to size_t. */
5089 element_size
= fold_convert (size_type_node
, tmp
);
5092 return element_size
;
5094 *nelems
= gfc_evaluate_now (stride
, pblock
);
5095 stride
= fold_convert (size_type_node
, stride
);
5097 /* First check for overflow. Since an array of type character can
5098 have zero element_size, we must check for that before
5100 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
5102 TYPE_MAX_VALUE (size_type_node
), element_size
);
5103 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
5104 boolean_type_node
, tmp
, stride
),
5105 PRED_FORTRAN_OVERFLOW
);
5106 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5107 integer_one_node
, integer_zero_node
);
5108 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
5109 boolean_type_node
, element_size
,
5110 build_int_cst (size_type_node
, 0)),
5111 PRED_FORTRAN_SIZE_ZERO
);
5112 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5113 integer_zero_node
, tmp
);
5114 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
5116 *overflow
= gfc_evaluate_now (tmp
, pblock
);
5118 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5119 stride
, element_size
);
5121 if (poffset
!= NULL
)
5123 offset
= gfc_evaluate_now (offset
, pblock
);
5127 if (integer_zerop (or_expr
))
5129 if (integer_onep (or_expr
))
5130 return build_int_cst (size_type_node
, 0);
5132 var
= gfc_create_var (TREE_TYPE (size
), "size");
5133 gfc_start_block (&thenblock
);
5134 gfc_add_modify (&thenblock
, var
, build_int_cst (size_type_node
, 0));
5135 thencase
= gfc_finish_block (&thenblock
);
5137 gfc_start_block (&elseblock
);
5138 gfc_add_modify (&elseblock
, var
, size
);
5139 elsecase
= gfc_finish_block (&elseblock
);
5141 tmp
= gfc_evaluate_now (or_expr
, pblock
);
5142 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
5143 gfc_add_expr_to_block (pblock
, tmp
);
5149 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
5150 the work for an ALLOCATE statement. */
5154 gfc_array_allocate (gfc_se
* se
, gfc_expr
* expr
, tree status
, tree errmsg
,
5155 tree errlen
, tree label_finish
, tree expr3_elem_size
,
5156 tree
*nelems
, gfc_expr
*expr3
, gfc_typespec
*ts
)
5160 tree offset
= NULL_TREE
;
5161 tree token
= NULL_TREE
;
5164 tree error
= NULL_TREE
;
5165 tree overflow
; /* Boolean storing whether size calculation overflows. */
5166 tree var_overflow
= NULL_TREE
;
5168 tree set_descriptor
;
5169 stmtblock_t set_descriptor_block
;
5170 stmtblock_t elseblock
;
5173 gfc_ref
*ref
, *prev_ref
= NULL
;
5174 bool allocatable
, coarray
, dimension
;
5178 /* Find the last reference in the chain. */
5179 while (ref
&& ref
->next
!= NULL
)
5181 gcc_assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
5182 || (ref
->u
.ar
.dimen
== 0 && ref
->u
.ar
.codimen
> 0));
5187 if (ref
== NULL
|| ref
->type
!= REF_ARRAY
)
5192 allocatable
= expr
->symtree
->n
.sym
->attr
.allocatable
;
5193 coarray
= expr
->symtree
->n
.sym
->attr
.codimension
;
5194 dimension
= expr
->symtree
->n
.sym
->attr
.dimension
;
5198 allocatable
= prev_ref
->u
.c
.component
->attr
.allocatable
;
5199 coarray
= prev_ref
->u
.c
.component
->attr
.codimension
;
5200 dimension
= prev_ref
->u
.c
.component
->attr
.dimension
;
5204 gcc_assert (coarray
);
5206 /* Figure out the size of the array. */
5207 switch (ref
->u
.ar
.type
)
5213 upper
= ref
->u
.ar
.start
;
5219 lower
= ref
->u
.ar
.start
;
5220 upper
= ref
->u
.ar
.end
;
5224 gcc_assert (ref
->u
.ar
.as
->type
== AS_EXPLICIT
);
5226 lower
= ref
->u
.ar
.as
->lower
;
5227 upper
= ref
->u
.ar
.as
->upper
;
5235 overflow
= integer_zero_node
;
5237 gfc_init_block (&set_descriptor_block
);
5238 size
= gfc_array_init_size (se
->expr
, ref
->u
.ar
.as
->rank
,
5239 ref
->u
.ar
.as
->corank
, &offset
, lower
, upper
,
5240 &se
->pre
, &set_descriptor_block
, &overflow
,
5241 expr3_elem_size
, nelems
, expr3
, ts
);
5245 var_overflow
= gfc_create_var (integer_type_node
, "overflow");
5246 gfc_add_modify (&se
->pre
, var_overflow
, overflow
);
5248 if (status
== NULL_TREE
)
5250 /* Generate the block of code handling overflow. */
5251 msg
= gfc_build_addr_expr (pchar_type_node
,
5252 gfc_build_localized_cstring_const
5253 ("Integer overflow when calculating the amount of "
5254 "memory to allocate"));
5255 error
= build_call_expr_loc (input_location
,
5256 gfor_fndecl_runtime_error
, 1, msg
);
5260 tree status_type
= TREE_TYPE (status
);
5261 stmtblock_t set_status_block
;
5263 gfc_start_block (&set_status_block
);
5264 gfc_add_modify (&set_status_block
, status
,
5265 build_int_cst (status_type
, LIBERROR_ALLOCATION
));
5266 error
= gfc_finish_block (&set_status_block
);
5270 gfc_start_block (&elseblock
);
5272 /* Allocate memory to store the data. */
5273 if (POINTER_TYPE_P (TREE_TYPE (se
->expr
)))
5274 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
5276 pointer
= gfc_conv_descriptor_data_get (se
->expr
);
5277 STRIP_NOPS (pointer
);
5279 if (coarray
&& gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
5280 token
= gfc_build_addr_expr (NULL_TREE
,
5281 gfc_conv_descriptor_token (se
->expr
));
5283 /* The allocatable variant takes the old pointer as first argument. */
5285 gfc_allocate_allocatable (&elseblock
, pointer
, size
, token
,
5286 status
, errmsg
, errlen
, label_finish
, expr
);
5288 gfc_allocate_using_malloc (&elseblock
, pointer
, size
, status
);
5292 cond
= gfc_unlikely (fold_build2_loc (input_location
, NE_EXPR
,
5293 boolean_type_node
, var_overflow
, integer_zero_node
),
5294 PRED_FORTRAN_OVERFLOW
);
5295 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
5296 error
, gfc_finish_block (&elseblock
));
5299 tmp
= gfc_finish_block (&elseblock
);
5301 gfc_add_expr_to_block (&se
->pre
, tmp
);
5303 /* Update the array descriptors. */
5305 gfc_conv_descriptor_offset_set (&set_descriptor_block
, se
->expr
, offset
);
5307 set_descriptor
= gfc_finish_block (&set_descriptor_block
);
5308 if (status
!= NULL_TREE
)
5310 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
5311 boolean_type_node
, status
,
5312 build_int_cst (TREE_TYPE (status
), 0));
5313 gfc_add_expr_to_block (&se
->pre
,
5314 fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5315 gfc_likely (cond
, PRED_FORTRAN_FAIL_ALLOC
),
5317 build_empty_stmt (input_location
)));
5320 gfc_add_expr_to_block (&se
->pre
, set_descriptor
);
5322 if ((expr
->ts
.type
== BT_DERIVED
)
5323 && expr
->ts
.u
.derived
->attr
.alloc_comp
)
5325 tmp
= gfc_nullify_alloc_comp (expr
->ts
.u
.derived
, se
->expr
,
5326 ref
->u
.ar
.as
->rank
);
5327 gfc_add_expr_to_block (&se
->pre
, tmp
);
5334 /* Deallocate an array variable. Also used when an allocated variable goes
5339 gfc_array_deallocate (tree descriptor
, tree pstat
, tree errmsg
, tree errlen
,
5340 tree label_finish
, gfc_expr
* expr
)
5345 bool coarray
= gfc_is_coarray (expr
);
5347 gfc_start_block (&block
);
5349 /* Get a pointer to the data. */
5350 var
= gfc_conv_descriptor_data_get (descriptor
);
5353 /* Parameter is the address of the data component. */
5354 tmp
= gfc_deallocate_with_status (coarray
? descriptor
: var
, pstat
, errmsg
,
5355 errlen
, label_finish
, false, expr
, coarray
);
5356 gfc_add_expr_to_block (&block
, tmp
);
5358 /* Zero the data pointer; only for coarrays an error can occur and then
5359 the allocation status may not be changed. */
5360 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
5361 var
, build_int_cst (TREE_TYPE (var
), 0));
5362 if (pstat
!= NULL_TREE
&& coarray
&& gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
5365 tree stat
= build_fold_indirect_ref_loc (input_location
, pstat
);
5367 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5368 stat
, build_int_cst (TREE_TYPE (stat
), 0));
5369 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5370 cond
, tmp
, build_empty_stmt (input_location
));
5373 gfc_add_expr_to_block (&block
, tmp
);
5375 return gfc_finish_block (&block
);
5379 /* Create an array constructor from an initialization expression.
5380 We assume the frontend already did any expansions and conversions. */
5383 gfc_conv_array_initializer (tree type
, gfc_expr
* expr
)
5390 vec
<constructor_elt
, va_gc
> *v
= NULL
;
5392 if (expr
->expr_type
== EXPR_VARIABLE
5393 && expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
5394 && expr
->symtree
->n
.sym
->value
)
5395 expr
= expr
->symtree
->n
.sym
->value
;
5397 switch (expr
->expr_type
)
5400 case EXPR_STRUCTURE
:
5401 /* A single scalar or derived type value. Create an array with all
5402 elements equal to that value. */
5403 gfc_init_se (&se
, NULL
);
5405 if (expr
->expr_type
== EXPR_CONSTANT
)
5406 gfc_conv_constant (&se
, expr
);
5408 gfc_conv_structure (&se
, expr
, 1);
5410 wtmp
= wi::to_offset (TYPE_MAX_VALUE (TYPE_DOMAIN (type
))) + 1;
5411 /* This will probably eat buckets of memory for large arrays. */
5414 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
, se
.expr
);
5420 /* Create a vector of all the elements. */
5421 for (c
= gfc_constructor_first (expr
->value
.constructor
);
5422 c
; c
= gfc_constructor_next (c
))
5426 /* Problems occur when we get something like
5427 integer :: a(lots) = (/(i, i=1, lots)/) */
5428 gfc_fatal_error_1 ("The number of elements in the array "
5429 "constructor at %L requires an increase of "
5430 "the allowed %d upper limit. See "
5431 "-fmax-array-constructor option", &expr
->where
,
5432 gfc_option
.flag_max_array_constructor
);
5435 if (mpz_cmp_si (c
->offset
, 0) != 0)
5436 index
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
5440 if (mpz_cmp_si (c
->repeat
, 1) > 0)
5446 mpz_add (maxval
, c
->offset
, c
->repeat
);
5447 mpz_sub_ui (maxval
, maxval
, 1);
5448 tmp2
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
5449 if (mpz_cmp_si (c
->offset
, 0) != 0)
5451 mpz_add_ui (maxval
, c
->offset
, 1);
5452 tmp1
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
5455 tmp1
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
5457 range
= fold_build2 (RANGE_EXPR
, gfc_array_index_type
, tmp1
, tmp2
);
5463 gfc_init_se (&se
, NULL
);
5464 switch (c
->expr
->expr_type
)
5467 gfc_conv_constant (&se
, c
->expr
);
5470 case EXPR_STRUCTURE
:
5471 gfc_conv_structure (&se
, c
->expr
, 1);
5475 /* Catch those occasional beasts that do not simplify
5476 for one reason or another, assuming that if they are
5477 standard defying the frontend will catch them. */
5478 gfc_conv_expr (&se
, c
->expr
);
5482 if (range
== NULL_TREE
)
5483 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
5486 if (index
!= NULL_TREE
)
5487 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
5488 CONSTRUCTOR_APPEND_ELT (v
, range
, se
.expr
);
5494 return gfc_build_null_descriptor (type
);
5500 /* Create a constructor from the list of elements. */
5501 tmp
= build_constructor (type
, v
);
5502 TREE_CONSTANT (tmp
) = 1;
5507 /* Generate code to evaluate non-constant coarray cobounds. */
5510 gfc_trans_array_cobounds (tree type
, stmtblock_t
* pblock
,
5511 const gfc_symbol
*sym
)
5521 for (dim
= as
->rank
; dim
< as
->rank
+ as
->corank
; dim
++)
5523 /* Evaluate non-constant array bound expressions. */
5524 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
5525 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
5527 gfc_init_se (&se
, NULL
);
5528 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
5529 gfc_add_block_to_block (pblock
, &se
.pre
);
5530 gfc_add_modify (pblock
, lbound
, se
.expr
);
5532 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
5533 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
5535 gfc_init_se (&se
, NULL
);
5536 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
5537 gfc_add_block_to_block (pblock
, &se
.pre
);
5538 gfc_add_modify (pblock
, ubound
, se
.expr
);
5544 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
5545 returns the size (in elements) of the array. */
5548 gfc_trans_array_bounds (tree type
, gfc_symbol
* sym
, tree
* poffset
,
5549 stmtblock_t
* pblock
)
5564 size
= gfc_index_one_node
;
5565 offset
= gfc_index_zero_node
;
5566 for (dim
= 0; dim
< as
->rank
; dim
++)
5568 /* Evaluate non-constant array bound expressions. */
5569 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
5570 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
5572 gfc_init_se (&se
, NULL
);
5573 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
5574 gfc_add_block_to_block (pblock
, &se
.pre
);
5575 gfc_add_modify (pblock
, lbound
, se
.expr
);
5577 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
5578 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
5580 gfc_init_se (&se
, NULL
);
5581 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
5582 gfc_add_block_to_block (pblock
, &se
.pre
);
5583 gfc_add_modify (pblock
, ubound
, se
.expr
);
5585 /* The offset of this dimension. offset = offset - lbound * stride. */
5586 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5588 offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5591 /* The size of this dimension, and the stride of the next. */
5592 if (dim
+ 1 < as
->rank
)
5593 stride
= GFC_TYPE_ARRAY_STRIDE (type
, dim
+ 1);
5595 stride
= GFC_TYPE_ARRAY_SIZE (type
);
5597 if (ubound
!= NULL_TREE
&& !(stride
&& INTEGER_CST_P (stride
)))
5599 /* Calculate stride = size * (ubound + 1 - lbound). */
5600 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5601 gfc_array_index_type
,
5602 gfc_index_one_node
, lbound
);
5603 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5604 gfc_array_index_type
, ubound
, tmp
);
5605 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5606 gfc_array_index_type
, size
, tmp
);
5608 gfc_add_modify (pblock
, stride
, tmp
);
5610 stride
= gfc_evaluate_now (tmp
, pblock
);
5612 /* Make sure that negative size arrays are translated
5613 to being zero size. */
5614 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
5615 stride
, gfc_index_zero_node
);
5616 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5617 gfc_array_index_type
, tmp
,
5618 stride
, gfc_index_zero_node
);
5619 gfc_add_modify (pblock
, stride
, tmp
);
5625 gfc_trans_array_cobounds (type
, pblock
, sym
);
5626 gfc_trans_vla_type_sizes (sym
, pblock
);
5633 /* Generate code to initialize/allocate an array variable. */
5636 gfc_trans_auto_array_allocation (tree decl
, gfc_symbol
* sym
,
5637 gfc_wrapped_block
* block
)
5641 tree tmp
= NULL_TREE
;
5648 gcc_assert (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
));
5650 /* Do nothing for USEd variables. */
5651 if (sym
->attr
.use_assoc
)
5654 type
= TREE_TYPE (decl
);
5655 gcc_assert (GFC_ARRAY_TYPE_P (type
));
5656 onstack
= TREE_CODE (type
) != POINTER_TYPE
;
5658 gfc_init_block (&init
);
5660 /* Evaluate character string length. */
5661 if (sym
->ts
.type
== BT_CHARACTER
5662 && onstack
&& !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
5664 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
5666 gfc_trans_vla_type_sizes (sym
, &init
);
5668 /* Emit a DECL_EXPR for this variable, which will cause the
5669 gimplifier to allocate storage, and all that good stuff. */
5670 tmp
= fold_build1_loc (input_location
, DECL_EXPR
, TREE_TYPE (decl
), decl
);
5671 gfc_add_expr_to_block (&init
, tmp
);
5676 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
5680 type
= TREE_TYPE (type
);
5682 gcc_assert (!sym
->attr
.use_assoc
);
5683 gcc_assert (!TREE_STATIC (decl
));
5684 gcc_assert (!sym
->module
);
5686 if (sym
->ts
.type
== BT_CHARACTER
5687 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
5688 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
5690 size
= gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
5692 /* Don't actually allocate space for Cray Pointees. */
5693 if (sym
->attr
.cray_pointee
)
5695 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
5696 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
5698 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
5702 if (gfc_option
.flag_stack_arrays
)
5704 gcc_assert (TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
);
5705 space
= build_decl (sym
->declared_at
.lb
->location
,
5706 VAR_DECL
, create_tmp_var_name ("A"),
5707 TREE_TYPE (TREE_TYPE (decl
)));
5708 gfc_trans_vla_type_sizes (sym
, &init
);
5712 /* The size is the number of elements in the array, so multiply by the
5713 size of an element to get the total size. */
5714 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
5715 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5716 size
, fold_convert (gfc_array_index_type
, tmp
));
5718 /* Allocate memory to hold the data. */
5719 tmp
= gfc_call_malloc (&init
, TREE_TYPE (decl
), size
);
5720 gfc_add_modify (&init
, decl
, tmp
);
5722 /* Free the temporary. */
5723 tmp
= gfc_call_free (convert (pvoid_type_node
, decl
));
5727 /* Set offset of the array. */
5728 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
5729 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
5731 /* Automatic arrays should not have initializers. */
5732 gcc_assert (!sym
->value
);
5734 inittree
= gfc_finish_block (&init
);
5741 /* Don't create new scope, emit the DECL_EXPR in exactly the scope
5742 where also space is located. */
5743 gfc_init_block (&init
);
5744 tmp
= fold_build1_loc (input_location
, DECL_EXPR
,
5745 TREE_TYPE (space
), space
);
5746 gfc_add_expr_to_block (&init
, tmp
);
5747 addr
= fold_build1_loc (sym
->declared_at
.lb
->location
,
5748 ADDR_EXPR
, TREE_TYPE (decl
), space
);
5749 gfc_add_modify (&init
, decl
, addr
);
5750 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
5753 gfc_add_init_cleanup (block
, inittree
, tmp
);
5757 /* Generate entry and exit code for g77 calling convention arrays. */
5760 gfc_trans_g77_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
5770 gfc_save_backend_locus (&loc
);
5771 gfc_set_backend_locus (&sym
->declared_at
);
5773 /* Descriptor type. */
5774 parm
= sym
->backend_decl
;
5775 type
= TREE_TYPE (parm
);
5776 gcc_assert (GFC_ARRAY_TYPE_P (type
));
5778 gfc_start_block (&init
);
5780 if (sym
->ts
.type
== BT_CHARACTER
5781 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
5782 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
5784 /* Evaluate the bounds of the array. */
5785 gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
5787 /* Set the offset. */
5788 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
5789 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
5791 /* Set the pointer itself if we aren't using the parameter directly. */
5792 if (TREE_CODE (parm
) != PARM_DECL
)
5794 tmp
= convert (TREE_TYPE (parm
), GFC_DECL_SAVED_DESCRIPTOR (parm
));
5795 gfc_add_modify (&init
, parm
, tmp
);
5797 stmt
= gfc_finish_block (&init
);
5799 gfc_restore_backend_locus (&loc
);
5801 /* Add the initialization code to the start of the function. */
5803 if (sym
->attr
.optional
|| sym
->attr
.not_always_present
)
5805 tmp
= gfc_conv_expr_present (sym
);
5806 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
5809 gfc_add_init_cleanup (block
, stmt
, NULL_TREE
);
5813 /* Modify the descriptor of an array parameter so that it has the
5814 correct lower bound. Also move the upper bound accordingly.
5815 If the array is not packed, it will be copied into a temporary.
5816 For each dimension we set the new lower and upper bounds. Then we copy the
5817 stride and calculate the offset for this dimension. We also work out
5818 what the stride of a packed array would be, and see it the two match.
5819 If the array need repacking, we set the stride to the values we just
5820 calculated, recalculate the offset and copy the array data.
5821 Code is also added to copy the data back at the end of the function.
5825 gfc_trans_dummy_array_bias (gfc_symbol
* sym
, tree tmpdesc
,
5826 gfc_wrapped_block
* block
)
5833 tree stmtInit
, stmtCleanup
;
5840 tree stride
, stride2
;
5850 /* Do nothing for pointer and allocatable arrays. */
5851 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
5854 if (sym
->attr
.dummy
&& gfc_is_nodesc_array (sym
))
5856 gfc_trans_g77_array (sym
, block
);
5860 gfc_save_backend_locus (&loc
);
5861 gfc_set_backend_locus (&sym
->declared_at
);
5863 /* Descriptor type. */
5864 type
= TREE_TYPE (tmpdesc
);
5865 gcc_assert (GFC_ARRAY_TYPE_P (type
));
5866 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
5867 dumdesc
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
5868 gfc_start_block (&init
);
5870 if (sym
->ts
.type
== BT_CHARACTER
5871 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
5872 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
5874 checkparm
= (sym
->as
->type
== AS_EXPLICIT
5875 && (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
));
5877 no_repack
= !(GFC_DECL_PACKED_ARRAY (tmpdesc
)
5878 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
));
5880 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
))
5882 /* For non-constant shape arrays we only check if the first dimension
5883 is contiguous. Repacking higher dimensions wouldn't gain us
5884 anything as we still don't know the array stride. */
5885 partial
= gfc_create_var (boolean_type_node
, "partial");
5886 TREE_USED (partial
) = 1;
5887 tmp
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
5888 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, tmp
,
5889 gfc_index_one_node
);
5890 gfc_add_modify (&init
, partial
, tmp
);
5893 partial
= NULL_TREE
;
5895 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
5896 here, however I think it does the right thing. */
5899 /* Set the first stride. */
5900 stride
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
5901 stride
= gfc_evaluate_now (stride
, &init
);
5903 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5904 stride
, gfc_index_zero_node
);
5905 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
5906 tmp
, gfc_index_one_node
, stride
);
5907 stride
= GFC_TYPE_ARRAY_STRIDE (type
, 0);
5908 gfc_add_modify (&init
, stride
, tmp
);
5910 /* Allow the user to disable array repacking. */
5911 stmt_unpacked
= NULL_TREE
;
5915 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type
, 0)));
5916 /* A library call to repack the array if necessary. */
5917 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
5918 stmt_unpacked
= build_call_expr_loc (input_location
,
5919 gfor_fndecl_in_pack
, 1, tmp
);
5921 stride
= gfc_index_one_node
;
5923 if (gfc_option
.warn_array_temp
)
5924 gfc_warning ("Creating array temporary at %L", &loc
);
5927 /* This is for the case where the array data is used directly without
5928 calling the repack function. */
5929 if (no_repack
|| partial
!= NULL_TREE
)
5930 stmt_packed
= gfc_conv_descriptor_data_get (dumdesc
);
5932 stmt_packed
= NULL_TREE
;
5934 /* Assign the data pointer. */
5935 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
5937 /* Don't repack unknown shape arrays when the first stride is 1. */
5938 tmp
= fold_build3_loc (input_location
, COND_EXPR
, TREE_TYPE (stmt_packed
),
5939 partial
, stmt_packed
, stmt_unpacked
);
5942 tmp
= stmt_packed
!= NULL_TREE
? stmt_packed
: stmt_unpacked
;
5943 gfc_add_modify (&init
, tmpdesc
, fold_convert (type
, tmp
));
5945 offset
= gfc_index_zero_node
;
5946 size
= gfc_index_one_node
;
5948 /* Evaluate the bounds of the array. */
5949 for (n
= 0; n
< sym
->as
->rank
; n
++)
5951 if (checkparm
|| !sym
->as
->upper
[n
])
5953 /* Get the bounds of the actual parameter. */
5954 dubound
= gfc_conv_descriptor_ubound_get (dumdesc
, gfc_rank_cst
[n
]);
5955 dlbound
= gfc_conv_descriptor_lbound_get (dumdesc
, gfc_rank_cst
[n
]);
5959 dubound
= NULL_TREE
;
5960 dlbound
= NULL_TREE
;
5963 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, n
);
5964 if (!INTEGER_CST_P (lbound
))
5966 gfc_init_se (&se
, NULL
);
5967 gfc_conv_expr_type (&se
, sym
->as
->lower
[n
],
5968 gfc_array_index_type
);
5969 gfc_add_block_to_block (&init
, &se
.pre
);
5970 gfc_add_modify (&init
, lbound
, se
.expr
);
5973 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, n
);
5974 /* Set the desired upper bound. */
5975 if (sym
->as
->upper
[n
])
5977 /* We know what we want the upper bound to be. */
5978 if (!INTEGER_CST_P (ubound
))
5980 gfc_init_se (&se
, NULL
);
5981 gfc_conv_expr_type (&se
, sym
->as
->upper
[n
],
5982 gfc_array_index_type
);
5983 gfc_add_block_to_block (&init
, &se
.pre
);
5984 gfc_add_modify (&init
, ubound
, se
.expr
);
5987 /* Check the sizes match. */
5990 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
5994 temp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5995 gfc_array_index_type
, ubound
, lbound
);
5996 temp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5997 gfc_array_index_type
,
5998 gfc_index_one_node
, temp
);
5999 stride2
= fold_build2_loc (input_location
, MINUS_EXPR
,
6000 gfc_array_index_type
, dubound
,
6002 stride2
= fold_build2_loc (input_location
, PLUS_EXPR
,
6003 gfc_array_index_type
,
6004 gfc_index_one_node
, stride2
);
6005 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6006 gfc_array_index_type
, temp
, stride2
);
6007 asprintf (&msg
, "Dimension %d of array '%s' has extent "
6008 "%%ld instead of %%ld", n
+1, sym
->name
);
6010 gfc_trans_runtime_check (true, false, tmp
, &init
, &loc
, msg
,
6011 fold_convert (long_integer_type_node
, temp
),
6012 fold_convert (long_integer_type_node
, stride2
));
6019 /* For assumed shape arrays move the upper bound by the same amount
6020 as the lower bound. */
6021 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6022 gfc_array_index_type
, dubound
, dlbound
);
6023 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6024 gfc_array_index_type
, tmp
, lbound
);
6025 gfc_add_modify (&init
, ubound
, tmp
);
6027 /* The offset of this dimension. offset = offset - lbound * stride. */
6028 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6030 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
6031 gfc_array_index_type
, offset
, tmp
);
6033 /* The size of this dimension, and the stride of the next. */
6034 if (n
+ 1 < sym
->as
->rank
)
6036 stride
= GFC_TYPE_ARRAY_STRIDE (type
, n
+ 1);
6038 if (no_repack
|| partial
!= NULL_TREE
)
6040 gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[n
+1]);
6042 /* Figure out the stride if not a known constant. */
6043 if (!INTEGER_CST_P (stride
))
6046 stmt_packed
= NULL_TREE
;
6049 /* Calculate stride = size * (ubound + 1 - lbound). */
6050 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6051 gfc_array_index_type
,
6052 gfc_index_one_node
, lbound
);
6053 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6054 gfc_array_index_type
, ubound
, tmp
);
6055 size
= fold_build2_loc (input_location
, MULT_EXPR
,
6056 gfc_array_index_type
, size
, tmp
);
6060 /* Assign the stride. */
6061 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
6062 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6063 gfc_array_index_type
, partial
,
6064 stmt_unpacked
, stmt_packed
);
6066 tmp
= (stmt_packed
!= NULL_TREE
) ? stmt_packed
: stmt_unpacked
;
6067 gfc_add_modify (&init
, stride
, tmp
);
6072 stride
= GFC_TYPE_ARRAY_SIZE (type
);
6074 if (stride
&& !INTEGER_CST_P (stride
))
6076 /* Calculate size = stride * (ubound + 1 - lbound). */
6077 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6078 gfc_array_index_type
,
6079 gfc_index_one_node
, lbound
);
6080 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6081 gfc_array_index_type
,
6083 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6084 gfc_array_index_type
,
6085 GFC_TYPE_ARRAY_STRIDE (type
, n
), tmp
);
6086 gfc_add_modify (&init
, stride
, tmp
);
6091 gfc_trans_array_cobounds (type
, &init
, sym
);
6093 /* Set the offset. */
6094 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
6095 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6097 gfc_trans_vla_type_sizes (sym
, &init
);
6099 stmtInit
= gfc_finish_block (&init
);
6101 /* Only do the entry/initialization code if the arg is present. */
6102 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6103 optional_arg
= (sym
->attr
.optional
6104 || (sym
->ns
->proc_name
->attr
.entry_master
6105 && sym
->attr
.dummy
));
6108 tmp
= gfc_conv_expr_present (sym
);
6109 stmtInit
= build3_v (COND_EXPR
, tmp
, stmtInit
,
6110 build_empty_stmt (input_location
));
6115 stmtCleanup
= NULL_TREE
;
6118 stmtblock_t cleanup
;
6119 gfc_start_block (&cleanup
);
6121 if (sym
->attr
.intent
!= INTENT_IN
)
6123 /* Copy the data back. */
6124 tmp
= build_call_expr_loc (input_location
,
6125 gfor_fndecl_in_unpack
, 2, dumdesc
, tmpdesc
);
6126 gfc_add_expr_to_block (&cleanup
, tmp
);
6129 /* Free the temporary. */
6130 tmp
= gfc_call_free (tmpdesc
);
6131 gfc_add_expr_to_block (&cleanup
, tmp
);
6133 stmtCleanup
= gfc_finish_block (&cleanup
);
6135 /* Only do the cleanup if the array was repacked. */
6136 tmp
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
6137 tmp
= gfc_conv_descriptor_data_get (tmp
);
6138 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6140 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6141 build_empty_stmt (input_location
));
6145 tmp
= gfc_conv_expr_present (sym
);
6146 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6147 build_empty_stmt (input_location
));
6151 /* We don't need to free any memory allocated by internal_pack as it will
6152 be freed at the end of the function by pop_context. */
6153 gfc_add_init_cleanup (block
, stmtInit
, stmtCleanup
);
6155 gfc_restore_backend_locus (&loc
);
6159 /* Calculate the overall offset, including subreferences. */
6161 gfc_get_dataptr_offset (stmtblock_t
*block
, tree parm
, tree desc
, tree offset
,
6162 bool subref
, gfc_expr
*expr
)
6172 /* If offset is NULL and this is not a subreferenced array, there is
6174 if (offset
== NULL_TREE
)
6177 offset
= gfc_index_zero_node
;
6182 tmp
= build_array_ref (desc
, offset
, NULL
);
6184 /* Offset the data pointer for pointer assignments from arrays with
6185 subreferences; e.g. my_integer => my_type(:)%integer_component. */
6188 /* Go past the array reference. */
6189 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6190 if (ref
->type
== REF_ARRAY
&&
6191 ref
->u
.ar
.type
!= AR_ELEMENT
)
6197 /* Calculate the offset for each subsequent subreference. */
6198 for (; ref
; ref
= ref
->next
)
6203 field
= ref
->u
.c
.component
->backend_decl
;
6204 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
6205 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
6207 tmp
, field
, NULL_TREE
);
6211 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
6212 gfc_init_se (&start
, NULL
);
6213 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
6214 gfc_add_block_to_block (block
, &start
.pre
);
6215 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
6219 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
6220 && ref
->u
.ar
.type
== AR_ELEMENT
);
6222 /* TODO - Add bounds checking. */
6223 stride
= gfc_index_one_node
;
6224 index
= gfc_index_zero_node
;
6225 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
6230 /* Update the index. */
6231 gfc_init_se (&start
, NULL
);
6232 gfc_conv_expr_type (&start
, ref
->u
.ar
.start
[n
], gfc_array_index_type
);
6233 itmp
= gfc_evaluate_now (start
.expr
, block
);
6234 gfc_init_se (&start
, NULL
);
6235 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->lower
[n
], gfc_array_index_type
);
6236 jtmp
= gfc_evaluate_now (start
.expr
, block
);
6237 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6238 gfc_array_index_type
, itmp
, jtmp
);
6239 itmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6240 gfc_array_index_type
, itmp
, stride
);
6241 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
6242 gfc_array_index_type
, itmp
, index
);
6243 index
= gfc_evaluate_now (index
, block
);
6245 /* Update the stride. */
6246 gfc_init_se (&start
, NULL
);
6247 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->upper
[n
], gfc_array_index_type
);
6248 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6249 gfc_array_index_type
, start
.expr
,
6251 itmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6252 gfc_array_index_type
,
6253 gfc_index_one_node
, itmp
);
6254 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
6255 gfc_array_index_type
, stride
, itmp
);
6256 stride
= gfc_evaluate_now (stride
, block
);
6259 /* Apply the index to obtain the array element. */
6260 tmp
= gfc_build_array_ref (tmp
, index
, NULL
);
6270 /* Set the target data pointer. */
6271 offset
= gfc_build_addr_expr (gfc_array_dataptr_type (desc
), tmp
);
6272 gfc_conv_descriptor_data_set (block
, parm
, offset
);
6276 /* gfc_conv_expr_descriptor needs the string length an expression
6277 so that the size of the temporary can be obtained. This is done
6278 by adding up the string lengths of all the elements in the
6279 expression. Function with non-constant expressions have their
6280 string lengths mapped onto the actual arguments using the
6281 interface mapping machinery in trans-expr.c. */
6283 get_array_charlen (gfc_expr
*expr
, gfc_se
*se
)
6285 gfc_interface_mapping mapping
;
6286 gfc_formal_arglist
*formal
;
6287 gfc_actual_arglist
*arg
;
6290 if (expr
->ts
.u
.cl
->length
6291 && gfc_is_constant_expr (expr
->ts
.u
.cl
->length
))
6293 if (!expr
->ts
.u
.cl
->backend_decl
)
6294 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6298 switch (expr
->expr_type
)
6301 get_array_charlen (expr
->value
.op
.op1
, se
);
6303 /* For parentheses the expression ts.u.cl is identical. */
6304 if (expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
6307 expr
->ts
.u
.cl
->backend_decl
=
6308 gfc_create_var (gfc_charlen_type_node
, "sln");
6310 if (expr
->value
.op
.op2
)
6312 get_array_charlen (expr
->value
.op
.op2
, se
);
6314 gcc_assert (expr
->value
.op
.op
== INTRINSIC_CONCAT
);
6316 /* Add the string lengths and assign them to the expression
6317 string length backend declaration. */
6318 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
6319 fold_build2_loc (input_location
, PLUS_EXPR
,
6320 gfc_charlen_type_node
,
6321 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
,
6322 expr
->value
.op
.op2
->ts
.u
.cl
->backend_decl
));
6325 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
6326 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
);
6330 if (expr
->value
.function
.esym
== NULL
6331 || expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6333 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6337 /* Map expressions involving the dummy arguments onto the actual
6338 argument expressions. */
6339 gfc_init_interface_mapping (&mapping
);
6340 formal
= gfc_sym_get_dummy_args (expr
->symtree
->n
.sym
);
6341 arg
= expr
->value
.function
.actual
;
6343 /* Set se = NULL in the calls to the interface mapping, to suppress any
6345 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
6350 gfc_add_interface_mapping (&mapping
, formal
->sym
, NULL
, arg
->expr
);
6353 gfc_init_se (&tse
, NULL
);
6355 /* Build the expression for the character length and convert it. */
6356 gfc_apply_interface_mapping (&mapping
, &tse
, expr
->ts
.u
.cl
->length
);
6358 gfc_add_block_to_block (&se
->pre
, &tse
.pre
);
6359 gfc_add_block_to_block (&se
->post
, &tse
.post
);
6360 tse
.expr
= fold_convert (gfc_charlen_type_node
, tse
.expr
);
6361 tse
.expr
= fold_build2_loc (input_location
, MAX_EXPR
,
6362 gfc_charlen_type_node
, tse
.expr
,
6363 build_int_cst (gfc_charlen_type_node
, 0));
6364 expr
->ts
.u
.cl
->backend_decl
= tse
.expr
;
6365 gfc_free_interface_mapping (&mapping
);
6369 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6375 /* Helper function to check dimensions. */
6377 transposed_dims (gfc_ss
*ss
)
6381 for (n
= 0; n
< ss
->dimen
; n
++)
6382 if (ss
->dim
[n
] != n
)
6388 /* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
6389 AR_FULL, suitable for the scalarizer. */
6392 walk_coarray (gfc_expr
*e
)
6396 gcc_assert (gfc_get_corank (e
) > 0);
6398 ss
= gfc_walk_expr (e
);
6400 /* Fix scalar coarray. */
6401 if (ss
== gfc_ss_terminator
)
6408 if (ref
->type
== REF_ARRAY
6409 && ref
->u
.ar
.codimen
> 0)
6415 gcc_assert (ref
!= NULL
);
6416 if (ref
->u
.ar
.type
== AR_ELEMENT
)
6417 ref
->u
.ar
.type
= AR_SECTION
;
6418 ss
= gfc_reverse_ss (gfc_walk_array_ref (ss
, e
, ref
));
6425 /* Convert an array for passing as an actual argument. Expressions and
6426 vector subscripts are evaluated and stored in a temporary, which is then
6427 passed. For whole arrays the descriptor is passed. For array sections
6428 a modified copy of the descriptor is passed, but using the original data.
6430 This function is also used for array pointer assignments, and there
6433 - se->want_pointer && !se->direct_byref
6434 EXPR is an actual argument. On exit, se->expr contains a
6435 pointer to the array descriptor.
6437 - !se->want_pointer && !se->direct_byref
6438 EXPR is an actual argument to an intrinsic function or the
6439 left-hand side of a pointer assignment. On exit, se->expr
6440 contains the descriptor for EXPR.
6442 - !se->want_pointer && se->direct_byref
6443 EXPR is the right-hand side of a pointer assignment and
6444 se->expr is the descriptor for the previously-evaluated
6445 left-hand side. The function creates an assignment from
6449 The se->force_tmp flag disables the non-copying descriptor optimization
6450 that is used for transpose. It may be used in cases where there is an
6451 alias between the transpose argument and another argument in the same
6455 gfc_conv_expr_descriptor (gfc_se
*se
, gfc_expr
*expr
)
6458 gfc_ss_type ss_type
;
6459 gfc_ss_info
*ss_info
;
6461 gfc_array_info
*info
;
6470 bool subref_array_target
= false;
6471 gfc_expr
*arg
, *ss_expr
;
6473 if (se
->want_coarray
)
6474 ss
= walk_coarray (expr
);
6476 ss
= gfc_walk_expr (expr
);
6478 gcc_assert (ss
!= NULL
);
6479 gcc_assert (ss
!= gfc_ss_terminator
);
6482 ss_type
= ss_info
->type
;
6483 ss_expr
= ss_info
->expr
;
6485 /* Special case: TRANSPOSE which needs no temporary. */
6486 while (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
6487 && NULL
!= (arg
= gfc_get_noncopying_intrinsic_argument (expr
)))
6489 /* This is a call to transpose which has already been handled by the
6490 scalarizer, so that we just need to get its argument's descriptor. */
6491 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
6492 expr
= expr
->value
.function
.actual
->expr
;
6495 /* Special case things we know we can pass easily. */
6496 switch (expr
->expr_type
)
6499 /* If we have a linear array section, we can pass it directly.
6500 Otherwise we need to copy it into a temporary. */
6502 gcc_assert (ss_type
== GFC_SS_SECTION
);
6503 gcc_assert (ss_expr
== expr
);
6504 info
= &ss_info
->data
.array
;
6506 /* Get the descriptor for the array. */
6507 gfc_conv_ss_descriptor (&se
->pre
, ss
, 0);
6508 desc
= info
->descriptor
;
6510 subref_array_target
= se
->direct_byref
&& is_subref_array (expr
);
6511 need_tmp
= gfc_ref_needs_temporary_p (expr
->ref
)
6512 && !subref_array_target
;
6519 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
6521 /* Create a new descriptor if the array doesn't have one. */
6524 else if (info
->ref
->u
.ar
.type
== AR_FULL
|| se
->descriptor_only
)
6526 else if (se
->direct_byref
)
6529 full
= gfc_full_array_ref_p (info
->ref
, NULL
);
6531 if (full
&& !transposed_dims (ss
))
6533 if (se
->direct_byref
&& !se
->byref_noassign
)
6535 /* Copy the descriptor for pointer assignments. */
6536 gfc_add_modify (&se
->pre
, se
->expr
, desc
);
6538 /* Add any offsets from subreferences. */
6539 gfc_get_dataptr_offset (&se
->pre
, se
->expr
, desc
, NULL_TREE
,
6540 subref_array_target
, expr
);
6542 else if (se
->want_pointer
)
6544 /* We pass full arrays directly. This means that pointers and
6545 allocatable arrays should also work. */
6546 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
6553 if (expr
->ts
.type
== BT_CHARACTER
)
6554 se
->string_length
= gfc_get_expr_charlen (expr
);
6556 gfc_free_ss_chain (ss
);
6562 /* A transformational function return value will be a temporary
6563 array descriptor. We still need to go through the scalarizer
6564 to create the descriptor. Elemental functions are handled as
6565 arbitrary expressions, i.e. copy to a temporary. */
6567 if (se
->direct_byref
)
6569 gcc_assert (ss_type
== GFC_SS_FUNCTION
&& ss_expr
== expr
);
6571 /* For pointer assignments pass the descriptor directly. */
6575 gcc_assert (se
->ss
== ss
);
6576 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
6577 gfc_conv_expr (se
, expr
);
6578 gfc_free_ss_chain (ss
);
6582 if (ss_expr
!= expr
|| ss_type
!= GFC_SS_FUNCTION
)
6584 if (ss_expr
!= expr
)
6585 /* Elemental function. */
6586 gcc_assert ((expr
->value
.function
.esym
!= NULL
6587 && expr
->value
.function
.esym
->attr
.elemental
)
6588 || (expr
->value
.function
.isym
!= NULL
6589 && expr
->value
.function
.isym
->elemental
)
6590 || gfc_inline_intrinsic_function_p (expr
));
6592 gcc_assert (ss_type
== GFC_SS_INTRINSIC
);
6595 if (expr
->ts
.type
== BT_CHARACTER
6596 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
6597 get_array_charlen (expr
, se
);
6603 /* Transformational function. */
6604 info
= &ss_info
->data
.array
;
6610 /* Constant array constructors don't need a temporary. */
6611 if (ss_type
== GFC_SS_CONSTRUCTOR
6612 && expr
->ts
.type
!= BT_CHARACTER
6613 && gfc_constant_array_constructor_p (expr
->value
.constructor
))
6616 info
= &ss_info
->data
.array
;
6626 /* Something complicated. Copy it into a temporary. */
6632 /* If we are creating a temporary, we don't need to bother about aliases
6637 gfc_init_loopinfo (&loop
);
6639 /* Associate the SS with the loop. */
6640 gfc_add_ss_to_loop (&loop
, ss
);
6642 /* Tell the scalarizer not to bother creating loop variables, etc. */
6644 loop
.array_parameter
= 1;
6646 /* The right-hand side of a pointer assignment mustn't use a temporary. */
6647 gcc_assert (!se
->direct_byref
);
6649 /* Setup the scalarizing loops and bounds. */
6650 gfc_conv_ss_startstride (&loop
);
6654 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
6655 get_array_charlen (expr
, se
);
6657 /* Tell the scalarizer to make a temporary. */
6658 loop
.temp_ss
= gfc_get_temp_ss (gfc_typenode_for_spec (&expr
->ts
),
6659 ((expr
->ts
.type
== BT_CHARACTER
)
6660 ? expr
->ts
.u
.cl
->backend_decl
6664 se
->string_length
= loop
.temp_ss
->info
->string_length
;
6665 gcc_assert (loop
.temp_ss
->dimen
== loop
.dimen
);
6666 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
6669 gfc_conv_loop_setup (&loop
, & expr
->where
);
6673 /* Copy into a temporary and pass that. We don't need to copy the data
6674 back because expressions and vector subscripts must be INTENT_IN. */
6675 /* TODO: Optimize passing function return values. */
6679 /* Start the copying loops. */
6680 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
6681 gfc_mark_ss_chain_used (ss
, 1);
6682 gfc_start_scalarized_body (&loop
, &block
);
6684 /* Copy each data element. */
6685 gfc_init_se (&lse
, NULL
);
6686 gfc_copy_loopinfo_to_se (&lse
, &loop
);
6687 gfc_init_se (&rse
, NULL
);
6688 gfc_copy_loopinfo_to_se (&rse
, &loop
);
6690 lse
.ss
= loop
.temp_ss
;
6693 gfc_conv_scalarized_array_ref (&lse
, NULL
);
6694 if (expr
->ts
.type
== BT_CHARACTER
)
6696 gfc_conv_expr (&rse
, expr
);
6697 if (POINTER_TYPE_P (TREE_TYPE (rse
.expr
)))
6698 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
6702 gfc_conv_expr_val (&rse
, expr
);
6704 gfc_add_block_to_block (&block
, &rse
.pre
);
6705 gfc_add_block_to_block (&block
, &lse
.pre
);
6707 lse
.string_length
= rse
.string_length
;
6708 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true,
6709 expr
->expr_type
== EXPR_VARIABLE
6710 || expr
->expr_type
== EXPR_ARRAY
, true);
6711 gfc_add_expr_to_block (&block
, tmp
);
6713 /* Finish the copying loops. */
6714 gfc_trans_scalarizing_loops (&loop
, &block
);
6716 desc
= loop
.temp_ss
->info
->data
.array
.descriptor
;
6718 else if (expr
->expr_type
== EXPR_FUNCTION
&& !transposed_dims (ss
))
6720 desc
= info
->descriptor
;
6721 se
->string_length
= ss_info
->string_length
;
6725 /* We pass sections without copying to a temporary. Make a new
6726 descriptor and point it at the section we want. The loop variable
6727 limits will be the limits of the section.
6728 A function may decide to repack the array to speed up access, but
6729 we're not bothered about that here. */
6730 int dim
, ndim
, codim
;
6738 ndim
= info
->ref
? info
->ref
->u
.ar
.dimen
: ss
->dimen
;
6740 if (se
->want_coarray
)
6742 gfc_array_ref
*ar
= &info
->ref
->u
.ar
;
6744 codim
= gfc_get_corank (expr
);
6745 for (n
= 0; n
< codim
- 1; n
++)
6747 /* Make sure we are not lost somehow. */
6748 gcc_assert (ar
->dimen_type
[n
+ ndim
] == DIMEN_THIS_IMAGE
);
6750 /* Make sure the call to gfc_conv_section_startstride won't
6751 generate unnecessary code to calculate stride. */
6752 gcc_assert (ar
->stride
[n
+ ndim
] == NULL
);
6754 gfc_conv_section_startstride (&loop
.pre
, ss
, n
+ ndim
);
6755 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
6756 loop
.to
[n
+ loop
.dimen
] = info
->end
[n
+ ndim
];
6759 gcc_assert (n
== codim
- 1);
6760 evaluate_bound (&loop
.pre
, info
->start
, ar
->start
,
6761 info
->descriptor
, n
+ ndim
, true);
6762 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
6767 /* Set the string_length for a character array. */
6768 if (expr
->ts
.type
== BT_CHARACTER
)
6769 se
->string_length
= gfc_get_expr_charlen (expr
);
6771 desc
= info
->descriptor
;
6772 if (se
->direct_byref
&& !se
->byref_noassign
)
6774 /* For pointer assignments we fill in the destination. */
6776 parmtype
= TREE_TYPE (parm
);
6780 /* Otherwise make a new one. */
6781 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
6782 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
, codim
,
6783 loop
.from
, loop
.to
, 0,
6784 GFC_ARRAY_UNKNOWN
, false);
6785 parm
= gfc_create_var (parmtype
, "parm");
6788 offset
= gfc_index_zero_node
;
6790 /* The following can be somewhat confusing. We have two
6791 descriptors, a new one and the original array.
6792 {parm, parmtype, dim} refer to the new one.
6793 {desc, type, n, loop} refer to the original, which maybe
6794 a descriptorless array.
6795 The bounds of the scalarization are the bounds of the section.
6796 We don't have to worry about numeric overflows when calculating
6797 the offsets because all elements are within the array data. */
6799 /* Set the dtype. */
6800 tmp
= gfc_conv_descriptor_dtype (parm
);
6801 gfc_add_modify (&loop
.pre
, tmp
, gfc_get_dtype (parmtype
));
6803 /* Set offset for assignments to pointer only to zero if it is not
6805 if ((se
->direct_byref
|| se
->use_offset
)
6806 && ((info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
6807 || (expr
->expr_type
== EXPR_ARRAY
&& se
->use_offset
)))
6808 base
= gfc_index_zero_node
;
6809 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
6810 base
= gfc_evaluate_now (gfc_conv_array_offset (desc
), &loop
.pre
);
6814 for (n
= 0; n
< ndim
; n
++)
6816 stride
= gfc_conv_array_stride (desc
, n
);
6818 /* Work out the offset. */
6820 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
6822 gcc_assert (info
->subscript
[n
]
6823 && info
->subscript
[n
]->info
->type
== GFC_SS_SCALAR
);
6824 start
= info
->subscript
[n
]->info
->data
.scalar
.value
;
6828 /* Evaluate and remember the start of the section. */
6829 start
= info
->start
[n
];
6830 stride
= gfc_evaluate_now (stride
, &loop
.pre
);
6833 tmp
= gfc_conv_array_lbound (desc
, n
);
6834 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
6836 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
6838 offset
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (tmp
),
6842 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
6844 /* For elemental dimensions, we only need the offset. */
6848 /* Vector subscripts need copying and are handled elsewhere. */
6850 gcc_assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
6852 /* look for the corresponding scalarizer dimension: dim. */
6853 for (dim
= 0; dim
< ndim
; dim
++)
6854 if (ss
->dim
[dim
] == n
)
6857 /* loop exited early: the DIM being looked for has been found. */
6858 gcc_assert (dim
< ndim
);
6860 /* Set the new lower bound. */
6861 from
= loop
.from
[dim
];
6864 /* If we have an array section or are assigning make sure that
6865 the lower bound is 1. References to the full
6866 array should otherwise keep the original bounds. */
6868 || info
->ref
->u
.ar
.type
!= AR_FULL
)
6869 && !integer_onep (from
))
6871 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6872 gfc_array_index_type
, gfc_index_one_node
,
6874 to
= fold_build2_loc (input_location
, PLUS_EXPR
,
6875 gfc_array_index_type
, to
, tmp
);
6876 from
= gfc_index_one_node
;
6878 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
6879 gfc_rank_cst
[dim
], from
);
6881 /* Set the new upper bound. */
6882 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
6883 gfc_rank_cst
[dim
], to
);
6885 /* Multiply the stride by the section stride to get the
6887 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
6888 gfc_array_index_type
,
6889 stride
, info
->stride
[n
]);
6891 if (se
->direct_byref
6892 && ((info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
6893 || (expr
->expr_type
== EXPR_ARRAY
&& se
->use_offset
)))
6895 base
= fold_build2_loc (input_location
, MINUS_EXPR
,
6896 TREE_TYPE (base
), base
, stride
);
6898 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)) || se
->use_offset
)
6900 tmp
= gfc_conv_array_lbound (desc
, n
);
6901 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6902 TREE_TYPE (base
), tmp
, loop
.from
[dim
]);
6903 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6904 TREE_TYPE (base
), tmp
,
6905 gfc_conv_array_stride (desc
, n
));
6906 base
= fold_build2_loc (input_location
, PLUS_EXPR
,
6907 TREE_TYPE (base
), tmp
, base
);
6910 /* Store the new stride. */
6911 gfc_conv_descriptor_stride_set (&loop
.pre
, parm
,
6912 gfc_rank_cst
[dim
], stride
);
6915 for (n
= loop
.dimen
; n
< loop
.dimen
+ codim
; n
++)
6917 from
= loop
.from
[n
];
6919 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
6920 gfc_rank_cst
[n
], from
);
6921 if (n
< loop
.dimen
+ codim
- 1)
6922 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
6923 gfc_rank_cst
[n
], to
);
6926 if (se
->data_not_needed
)
6927 gfc_conv_descriptor_data_set (&loop
.pre
, parm
,
6928 gfc_index_zero_node
);
6930 /* Point the data pointer at the 1st element in the section. */
6931 gfc_get_dataptr_offset (&loop
.pre
, parm
, desc
, offset
,
6932 subref_array_target
, expr
);
6934 if (((se
->direct_byref
|| GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
6935 && !se
->data_not_needed
)
6936 || (se
->use_offset
&& base
!= NULL_TREE
))
6938 /* Set the offset. */
6939 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, base
);
6943 /* Only the callee knows what the correct offset it, so just set
6945 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, gfc_index_zero_node
);
6950 if (!se
->direct_byref
|| se
->byref_noassign
)
6952 /* Get a pointer to the new descriptor. */
6953 if (se
->want_pointer
)
6954 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
6959 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
6960 gfc_add_block_to_block (&se
->post
, &loop
.post
);
6962 /* Cleanup the scalarizer. */
6963 gfc_cleanup_loop (&loop
);
6966 /* Helper function for gfc_conv_array_parameter if array size needs to be
6970 array_parameter_size (tree desc
, gfc_expr
*expr
, tree
*size
)
6973 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
6974 *size
= GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc
));
6975 else if (expr
->rank
> 1)
6976 *size
= build_call_expr_loc (input_location
,
6977 gfor_fndecl_size0
, 1,
6978 gfc_build_addr_expr (NULL
, desc
));
6981 tree ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_index_zero_node
);
6982 tree lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_index_zero_node
);
6984 *size
= fold_build2_loc (input_location
, MINUS_EXPR
,
6985 gfc_array_index_type
, ubound
, lbound
);
6986 *size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
6987 *size
, gfc_index_one_node
);
6988 *size
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
6989 *size
, gfc_index_zero_node
);
6991 elem
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
6992 *size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6993 *size
, fold_convert (gfc_array_index_type
, elem
));
6996 /* Convert an array for passing as an actual parameter. */
6997 /* TODO: Optimize passing g77 arrays. */
7000 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, bool g77
,
7001 const gfc_symbol
*fsym
, const char *proc_name
,
7006 tree tmp
= NULL_TREE
;
7008 tree parent
= DECL_CONTEXT (current_function_decl
);
7009 bool full_array_var
;
7010 bool this_array_result
;
7013 bool array_constructor
;
7014 bool good_allocatable
;
7015 bool ultimate_ptr_comp
;
7016 bool ultimate_alloc_comp
;
7021 ultimate_ptr_comp
= false;
7022 ultimate_alloc_comp
= false;
7024 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7026 if (ref
->next
== NULL
)
7029 if (ref
->type
== REF_COMPONENT
)
7031 ultimate_ptr_comp
= ref
->u
.c
.component
->attr
.pointer
;
7032 ultimate_alloc_comp
= ref
->u
.c
.component
->attr
.allocatable
;
7036 full_array_var
= false;
7039 if (expr
->expr_type
== EXPR_VARIABLE
&& ref
&& !ultimate_ptr_comp
)
7040 full_array_var
= gfc_full_array_ref_p (ref
, &contiguous
);
7042 sym
= full_array_var
? expr
->symtree
->n
.sym
: NULL
;
7044 /* The symbol should have an array specification. */
7045 gcc_assert (!sym
|| sym
->as
|| ref
->u
.ar
.as
);
7047 if (expr
->expr_type
== EXPR_ARRAY
&& expr
->ts
.type
== BT_CHARACTER
)
7049 get_array_ctor_strlen (&se
->pre
, expr
->value
.constructor
, &tmp
);
7050 expr
->ts
.u
.cl
->backend_decl
= tmp
;
7051 se
->string_length
= tmp
;
7054 /* Is this the result of the enclosing procedure? */
7055 this_array_result
= (full_array_var
&& sym
->attr
.flavor
== FL_PROCEDURE
);
7056 if (this_array_result
7057 && (sym
->backend_decl
!= current_function_decl
)
7058 && (sym
->backend_decl
!= parent
))
7059 this_array_result
= false;
7061 /* Passing address of the array if it is not pointer or assumed-shape. */
7062 if (full_array_var
&& g77
&& !this_array_result
7063 && sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
7065 tmp
= gfc_get_symbol_decl (sym
);
7067 if (sym
->ts
.type
== BT_CHARACTER
)
7068 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
7070 if (!sym
->attr
.pointer
7072 && sym
->as
->type
!= AS_ASSUMED_SHAPE
7073 && sym
->as
->type
!= AS_DEFERRED
7074 && sym
->as
->type
!= AS_ASSUMED_RANK
7075 && !sym
->attr
.allocatable
)
7077 /* Some variables are declared directly, others are declared as
7078 pointers and allocated on the heap. */
7079 if (sym
->attr
.dummy
|| POINTER_TYPE_P (TREE_TYPE (tmp
)))
7082 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
7084 array_parameter_size (tmp
, expr
, size
);
7088 if (sym
->attr
.allocatable
)
7090 if (sym
->attr
.dummy
|| sym
->attr
.result
)
7092 gfc_conv_expr_descriptor (se
, expr
);
7096 array_parameter_size (tmp
, expr
, size
);
7097 se
->expr
= gfc_conv_array_data (tmp
);
7102 /* A convenient reduction in scope. */
7103 contiguous
= g77
&& !this_array_result
&& contiguous
;
7105 /* There is no need to pack and unpack the array, if it is contiguous
7106 and not a deferred- or assumed-shape array, or if it is simply
7108 no_pack
= ((sym
&& sym
->as
7109 && !sym
->attr
.pointer
7110 && sym
->as
->type
!= AS_DEFERRED
7111 && sym
->as
->type
!= AS_ASSUMED_RANK
7112 && sym
->as
->type
!= AS_ASSUMED_SHAPE
)
7114 (ref
&& ref
->u
.ar
.as
7115 && ref
->u
.ar
.as
->type
!= AS_DEFERRED
7116 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_RANK
7117 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_SHAPE
)
7119 gfc_is_simply_contiguous (expr
, false));
7121 no_pack
= contiguous
&& no_pack
;
7123 /* Array constructors are always contiguous and do not need packing. */
7124 array_constructor
= g77
&& !this_array_result
&& expr
->expr_type
== EXPR_ARRAY
;
7126 /* Same is true of contiguous sections from allocatable variables. */
7127 good_allocatable
= contiguous
7129 && expr
->symtree
->n
.sym
->attr
.allocatable
;
7131 /* Or ultimate allocatable components. */
7132 ultimate_alloc_comp
= contiguous
&& ultimate_alloc_comp
;
7134 if (no_pack
|| array_constructor
|| good_allocatable
|| ultimate_alloc_comp
)
7136 gfc_conv_expr_descriptor (se
, expr
);
7137 if (expr
->ts
.type
== BT_CHARACTER
)
7138 se
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
7140 array_parameter_size (se
->expr
, expr
, size
);
7141 se
->expr
= gfc_conv_array_data (se
->expr
);
7145 if (this_array_result
)
7147 /* Result of the enclosing function. */
7148 gfc_conv_expr_descriptor (se
, expr
);
7150 array_parameter_size (se
->expr
, expr
, size
);
7151 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7153 if (g77
&& TREE_TYPE (TREE_TYPE (se
->expr
)) != NULL_TREE
7154 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
7155 se
->expr
= gfc_conv_array_data (build_fold_indirect_ref_loc (input_location
,
7162 /* Every other type of array. */
7163 se
->want_pointer
= 1;
7164 gfc_conv_expr_descriptor (se
, expr
);
7166 array_parameter_size (build_fold_indirect_ref_loc (input_location
,
7171 /* Deallocate the allocatable components of structures that are
7173 if ((expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
)
7174 && expr
->ts
.u
.derived
->attr
.alloc_comp
7175 && expr
->expr_type
!= EXPR_VARIABLE
)
7177 tmp
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7178 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
, expr
->rank
);
7180 /* The components shall be deallocated before their containing entity. */
7181 gfc_prepend_expr_to_block (&se
->post
, tmp
);
7184 if (g77
|| (fsym
&& fsym
->attr
.contiguous
7185 && !gfc_is_simply_contiguous (expr
, false)))
7187 tree origptr
= NULL_TREE
;
7191 /* For contiguous arrays, save the original value of the descriptor. */
7194 origptr
= gfc_create_var (pvoid_type_node
, "origptr");
7195 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7196 tmp
= gfc_conv_array_data (tmp
);
7197 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7198 TREE_TYPE (origptr
), origptr
,
7199 fold_convert (TREE_TYPE (origptr
), tmp
));
7200 gfc_add_expr_to_block (&se
->pre
, tmp
);
7203 /* Repack the array. */
7204 if (gfc_option
.warn_array_temp
)
7207 gfc_warning ("Creating array temporary at %L for argument '%s'",
7208 &expr
->where
, fsym
->name
);
7210 gfc_warning ("Creating array temporary at %L", &expr
->where
);
7213 ptr
= build_call_expr_loc (input_location
,
7214 gfor_fndecl_in_pack
, 1, desc
);
7216 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7218 tmp
= gfc_conv_expr_present (sym
);
7219 ptr
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
7220 tmp
, fold_convert (TREE_TYPE (se
->expr
), ptr
),
7221 fold_convert (TREE_TYPE (se
->expr
), null_pointer_node
));
7224 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
7226 /* Use the packed data for the actual argument, except for contiguous arrays,
7227 where the descriptor's data component is set. */
7232 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7234 gfc_ss
* ss
= gfc_walk_expr (expr
);
7235 if (!transposed_dims (ss
))
7236 gfc_conv_descriptor_data_set (&se
->pre
, tmp
, ptr
);
7239 tree old_field
, new_field
;
7241 /* The original descriptor has transposed dims so we can't reuse
7242 it directly; we have to create a new one. */
7243 tree old_desc
= tmp
;
7244 tree new_desc
= gfc_create_var (TREE_TYPE (old_desc
), "arg_desc");
7246 old_field
= gfc_conv_descriptor_dtype (old_desc
);
7247 new_field
= gfc_conv_descriptor_dtype (new_desc
);
7248 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7250 old_field
= gfc_conv_descriptor_offset (old_desc
);
7251 new_field
= gfc_conv_descriptor_offset (new_desc
);
7252 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7254 for (int i
= 0; i
< expr
->rank
; i
++)
7256 old_field
= gfc_conv_descriptor_dimension (old_desc
,
7257 gfc_rank_cst
[get_array_ref_dim_for_loop_dim (ss
, i
)]);
7258 new_field
= gfc_conv_descriptor_dimension (new_desc
,
7260 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7263 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
7264 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (old_desc
))
7265 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (old_desc
))
7266 == GFC_ARRAY_ALLOCATABLE
)
7268 old_field
= gfc_conv_descriptor_token (old_desc
);
7269 new_field
= gfc_conv_descriptor_token (new_desc
);
7270 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7273 gfc_conv_descriptor_data_set (&se
->pre
, new_desc
, ptr
);
7274 se
->expr
= gfc_build_addr_expr (NULL_TREE
, new_desc
);
7279 if (gfc_option
.rtcheck
& GFC_RTCHECK_ARRAY_TEMPS
)
7283 if (fsym
&& proc_name
)
7284 asprintf (&msg
, "An array temporary was created for argument "
7285 "'%s' of procedure '%s'", fsym
->name
, proc_name
);
7287 asprintf (&msg
, "An array temporary was created");
7289 tmp
= build_fold_indirect_ref_loc (input_location
,
7291 tmp
= gfc_conv_array_data (tmp
);
7292 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7293 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
7295 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7296 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7298 gfc_conv_expr_present (sym
), tmp
);
7300 gfc_trans_runtime_check (false, true, tmp
, &se
->pre
,
7305 gfc_start_block (&block
);
7307 /* Copy the data back. */
7308 if (fsym
== NULL
|| fsym
->attr
.intent
!= INTENT_IN
)
7310 tmp
= build_call_expr_loc (input_location
,
7311 gfor_fndecl_in_unpack
, 2, desc
, ptr
);
7312 gfc_add_expr_to_block (&block
, tmp
);
7315 /* Free the temporary. */
7316 tmp
= gfc_call_free (convert (pvoid_type_node
, ptr
));
7317 gfc_add_expr_to_block (&block
, tmp
);
7319 stmt
= gfc_finish_block (&block
);
7321 gfc_init_block (&block
);
7322 /* Only if it was repacked. This code needs to be executed before the
7323 loop cleanup code. */
7324 tmp
= build_fold_indirect_ref_loc (input_location
,
7326 tmp
= gfc_conv_array_data (tmp
);
7327 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7328 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
7330 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7331 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7333 gfc_conv_expr_present (sym
), tmp
);
7335 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
7337 gfc_add_expr_to_block (&block
, tmp
);
7338 gfc_add_block_to_block (&block
, &se
->post
);
7340 gfc_init_block (&se
->post
);
7342 /* Reset the descriptor pointer. */
7345 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7346 gfc_conv_descriptor_data_set (&se
->post
, tmp
, origptr
);
7349 gfc_add_block_to_block (&se
->post
, &block
);
7354 /* Generate code to deallocate an array, if it is allocated. */
7357 gfc_trans_dealloc_allocated (tree descriptor
, bool coarray
, gfc_expr
*expr
)
7363 gfc_start_block (&block
);
7365 var
= gfc_conv_descriptor_data_get (descriptor
);
7368 /* Call array_deallocate with an int * present in the second argument.
7369 Although it is ignored here, it's presence ensures that arrays that
7370 are already deallocated are ignored. */
7371 tmp
= gfc_deallocate_with_status (coarray
? descriptor
: var
, NULL_TREE
,
7372 NULL_TREE
, NULL_TREE
, NULL_TREE
, true,
7374 gfc_add_expr_to_block (&block
, tmp
);
7376 /* Zero the data pointer. */
7377 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
7378 var
, build_int_cst (TREE_TYPE (var
), 0));
7379 gfc_add_expr_to_block (&block
, tmp
);
7381 return gfc_finish_block (&block
);
7385 /* This helper function calculates the size in words of a full array. */
7388 gfc_full_array_size (stmtblock_t
*block
, tree decl
, int rank
)
7393 idx
= gfc_rank_cst
[rank
- 1];
7394 nelems
= gfc_conv_descriptor_ubound_get (decl
, idx
);
7395 tmp
= gfc_conv_descriptor_lbound_get (decl
, idx
);
7396 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7398 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7399 tmp
, gfc_index_one_node
);
7400 tmp
= gfc_evaluate_now (tmp
, block
);
7402 nelems
= gfc_conv_descriptor_stride_get (decl
, idx
);
7403 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7405 return gfc_evaluate_now (tmp
, block
);
7409 /* Allocate dest to the same size as src, and copy src -> dest.
7410 If no_malloc is set, only the copy is done. */
7413 duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
7414 bool no_malloc
, bool no_memcpy
, tree str_sz
)
7423 /* If the source is null, set the destination to null. Then,
7424 allocate memory to the destination. */
7425 gfc_init_block (&block
);
7427 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
7429 tmp
= null_pointer_node
;
7430 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, type
, dest
, tmp
);
7431 gfc_add_expr_to_block (&block
, tmp
);
7432 null_data
= gfc_finish_block (&block
);
7434 gfc_init_block (&block
);
7435 if (str_sz
!= NULL_TREE
)
7438 size
= TYPE_SIZE_UNIT (TREE_TYPE (type
));
7442 tmp
= gfc_call_malloc (&block
, type
, size
);
7443 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
7444 dest
, fold_convert (type
, tmp
));
7445 gfc_add_expr_to_block (&block
, tmp
);
7450 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
7451 tmp
= build_call_expr_loc (input_location
, tmp
, 3, dest
, src
,
7452 fold_convert (size_type_node
, size
));
7453 gfc_add_expr_to_block (&block
, tmp
);
7458 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
7459 null_data
= gfc_finish_block (&block
);
7461 gfc_init_block (&block
);
7463 nelems
= gfc_full_array_size (&block
, src
, rank
);
7465 nelems
= gfc_index_one_node
;
7467 if (str_sz
!= NULL_TREE
)
7468 tmp
= fold_convert (gfc_array_index_type
, str_sz
);
7470 tmp
= fold_convert (gfc_array_index_type
,
7471 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
7472 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7476 tmp
= TREE_TYPE (gfc_conv_descriptor_data_get (src
));
7477 tmp
= gfc_call_malloc (&block
, tmp
, size
);
7478 gfc_conv_descriptor_data_set (&block
, dest
, tmp
);
7481 /* We know the temporary and the value will be the same length,
7482 so can use memcpy. */
7485 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
7486 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
7487 gfc_conv_descriptor_data_get (dest
),
7488 gfc_conv_descriptor_data_get (src
),
7489 fold_convert (size_type_node
, size
));
7490 gfc_add_expr_to_block (&block
, tmp
);
7494 tmp
= gfc_finish_block (&block
);
7496 /* Null the destination if the source is null; otherwise do
7497 the allocate and copy. */
7498 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src
)))
7501 null_cond
= gfc_conv_descriptor_data_get (src
);
7503 null_cond
= convert (pvoid_type_node
, null_cond
);
7504 null_cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7505 null_cond
, null_pointer_node
);
7506 return build3_v (COND_EXPR
, null_cond
, tmp
, null_data
);
7510 /* Allocate dest to the same size as src, and copy data src -> dest. */
7513 gfc_duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
)
7515 return duplicate_allocatable (dest
, src
, type
, rank
, false, false,
7520 /* Copy data src -> dest. */
7523 gfc_copy_allocatable_data (tree dest
, tree src
, tree type
, int rank
)
7525 return duplicate_allocatable (dest
, src
, type
, rank
, true, false,
7529 /* Allocate dest to the same size as src, but don't copy anything. */
7532 gfc_duplicate_allocatable_nocopy (tree dest
, tree src
, tree type
, int rank
)
7534 return duplicate_allocatable (dest
, src
, type
, rank
, false, true, NULL_TREE
);
7538 /* Recursively traverse an object of derived type, generating code to
7539 deallocate, nullify or copy allocatable components. This is the work horse
7540 function for the functions named in this enum. */
7542 enum {DEALLOCATE_ALLOC_COMP
= 1, DEALLOCATE_ALLOC_COMP_NO_CAF
,
7543 NULLIFY_ALLOC_COMP
, COPY_ALLOC_COMP
, COPY_ONLY_ALLOC_COMP
,
7544 COPY_ALLOC_COMP_CAF
};
7547 structure_alloc_comps (gfc_symbol
* der_type
, tree decl
,
7548 tree dest
, int rank
, int purpose
)
7552 stmtblock_t fnblock
;
7553 stmtblock_t loopbody
;
7554 stmtblock_t tmpblock
;
7565 tree null_cond
= NULL_TREE
;
7566 bool called_dealloc_with_status
;
7568 gfc_init_block (&fnblock
);
7570 decl_type
= TREE_TYPE (decl
);
7572 if ((POINTER_TYPE_P (decl_type
) && rank
!= 0)
7573 || (TREE_CODE (decl_type
) == REFERENCE_TYPE
&& rank
== 0))
7574 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
7576 /* Just in case in gets dereferenced. */
7577 decl_type
= TREE_TYPE (decl
);
7579 /* If this an array of derived types with allocatable components
7580 build a loop and recursively call this function. */
7581 if (TREE_CODE (decl_type
) == ARRAY_TYPE
7582 || (GFC_DESCRIPTOR_TYPE_P (decl_type
) && rank
!= 0))
7584 tmp
= gfc_conv_array_data (decl
);
7585 var
= build_fold_indirect_ref_loc (input_location
,
7588 /* Get the number of elements - 1 and set the counter. */
7589 if (GFC_DESCRIPTOR_TYPE_P (decl_type
))
7591 /* Use the descriptor for an allocatable array. Since this
7592 is a full array reference, we only need the descriptor
7593 information from dimension = rank. */
7594 tmp
= gfc_full_array_size (&fnblock
, decl
, rank
);
7595 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7596 gfc_array_index_type
, tmp
,
7597 gfc_index_one_node
);
7599 null_cond
= gfc_conv_descriptor_data_get (decl
);
7600 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
7601 boolean_type_node
, null_cond
,
7602 build_int_cst (TREE_TYPE (null_cond
), 0));
7606 /* Otherwise use the TYPE_DOMAIN information. */
7607 tmp
= array_type_nelts (decl_type
);
7608 tmp
= fold_convert (gfc_array_index_type
, tmp
);
7611 /* Remember that this is, in fact, the no. of elements - 1. */
7612 nelems
= gfc_evaluate_now (tmp
, &fnblock
);
7613 index
= gfc_create_var (gfc_array_index_type
, "S");
7615 /* Build the body of the loop. */
7616 gfc_init_block (&loopbody
);
7618 vref
= gfc_build_array_ref (var
, index
, NULL
);
7620 if (purpose
== COPY_ALLOC_COMP
)
7622 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
7624 tmp
= gfc_duplicate_allocatable (dest
, decl
, decl_type
, rank
);
7625 gfc_add_expr_to_block (&fnblock
, tmp
);
7627 tmp
= build_fold_indirect_ref_loc (input_location
,
7628 gfc_conv_array_data (dest
));
7629 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
7630 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
, purpose
);
7632 else if (purpose
== COPY_ONLY_ALLOC_COMP
)
7634 tmp
= build_fold_indirect_ref_loc (input_location
,
7635 gfc_conv_array_data (dest
));
7636 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
7637 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
,
7641 tmp
= structure_alloc_comps (der_type
, vref
, NULL_TREE
, rank
, purpose
);
7643 gfc_add_expr_to_block (&loopbody
, tmp
);
7645 /* Build the loop and return. */
7646 gfc_init_loopinfo (&loop
);
7648 loop
.from
[0] = gfc_index_zero_node
;
7649 loop
.loopvar
[0] = index
;
7650 loop
.to
[0] = nelems
;
7651 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
7652 gfc_add_block_to_block (&fnblock
, &loop
.pre
);
7654 tmp
= gfc_finish_block (&fnblock
);
7655 if (null_cond
!= NULL_TREE
)
7656 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
7657 build_empty_stmt (input_location
));
7662 /* Otherwise, act on the components or recursively call self to
7663 act on a chain of components. */
7664 for (c
= der_type
->components
; c
; c
= c
->next
)
7666 bool cmp_has_alloc_comps
= (c
->ts
.type
== BT_DERIVED
7667 || c
->ts
.type
== BT_CLASS
)
7668 && c
->ts
.u
.derived
->attr
.alloc_comp
;
7669 cdecl = c
->backend_decl
;
7670 ctype
= TREE_TYPE (cdecl);
7674 case DEALLOCATE_ALLOC_COMP
:
7675 case DEALLOCATE_ALLOC_COMP_NO_CAF
:
7677 /* gfc_deallocate_scalar_with_status calls gfc_deallocate_alloc_comp
7678 (i.e. this function) so generate all the calls and suppress the
7679 recursion from here, if necessary. */
7680 called_dealloc_with_status
= false;
7681 gfc_init_block (&tmpblock
);
7683 if ((c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
)
7684 || (c
->ts
.type
== BT_CLASS
&& !CLASS_DATA (c
)->attr
.class_pointer
))
7686 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7687 decl
, cdecl, NULL_TREE
);
7689 /* The finalizer frees allocatable components. */
7690 called_dealloc_with_status
7691 = gfc_add_comp_finalizer_call (&tmpblock
, comp
, c
,
7692 purpose
== DEALLOCATE_ALLOC_COMP
);
7697 if (c
->attr
.allocatable
&& !c
->attr
.proc_pointer
7698 && (c
->attr
.dimension
7699 || (c
->attr
.codimension
7700 && purpose
!= DEALLOCATE_ALLOC_COMP_NO_CAF
)))
7702 if (comp
== NULL_TREE
)
7703 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7704 decl
, cdecl, NULL_TREE
);
7705 tmp
= gfc_trans_dealloc_allocated (comp
, c
->attr
.codimension
, NULL
);
7706 gfc_add_expr_to_block (&tmpblock
, tmp
);
7708 else if (c
->attr
.allocatable
&& !c
->attr
.codimension
)
7710 /* Allocatable scalar components. */
7711 if (comp
== NULL_TREE
)
7712 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7713 decl
, cdecl, NULL_TREE
);
7715 tmp
= gfc_deallocate_scalar_with_status (comp
, NULL
, true, NULL
,
7717 gfc_add_expr_to_block (&tmpblock
, tmp
);
7718 called_dealloc_with_status
= true;
7720 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7721 void_type_node
, comp
,
7722 build_int_cst (TREE_TYPE (comp
), 0));
7723 gfc_add_expr_to_block (&tmpblock
, tmp
);
7725 else if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
7726 && (!CLASS_DATA (c
)->attr
.codimension
7727 || purpose
!= DEALLOCATE_ALLOC_COMP_NO_CAF
))
7729 /* Allocatable CLASS components. */
7731 /* Add reference to '_data' component. */
7732 tmp
= CLASS_DATA (c
)->backend_decl
;
7733 comp
= fold_build3_loc (input_location
, COMPONENT_REF
,
7734 TREE_TYPE (tmp
), comp
, tmp
, NULL_TREE
);
7736 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp
)))
7737 tmp
= gfc_trans_dealloc_allocated (comp
,
7738 CLASS_DATA (c
)->attr
.codimension
, NULL
);
7741 tmp
= gfc_deallocate_scalar_with_status (comp
, NULL_TREE
, true, NULL
,
7742 CLASS_DATA (c
)->ts
);
7743 gfc_add_expr_to_block (&tmpblock
, tmp
);
7744 called_dealloc_with_status
= true;
7746 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7747 void_type_node
, comp
,
7748 build_int_cst (TREE_TYPE (comp
), 0));
7750 gfc_add_expr_to_block (&tmpblock
, tmp
);
7753 if (cmp_has_alloc_comps
7755 && !called_dealloc_with_status
)
7757 /* Do not deallocate the components of ultimate pointer
7758 components or iteratively call self if call has been made
7759 to gfc_trans_dealloc_allocated */
7760 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7761 decl
, cdecl, NULL_TREE
);
7762 rank
= c
->as
? c
->as
->rank
: 0;
7763 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
7765 gfc_add_expr_to_block (&fnblock
, tmp
);
7768 /* Now add the deallocation of this component. */
7769 gfc_add_block_to_block (&fnblock
, &tmpblock
);
7772 case NULLIFY_ALLOC_COMP
:
7773 if (c
->attr
.pointer
)
7775 else if (c
->attr
.allocatable
7776 && (c
->attr
.dimension
|| c
->attr
.codimension
))
7778 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7779 decl
, cdecl, NULL_TREE
);
7780 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
7782 else if (c
->attr
.allocatable
)
7784 /* Allocatable scalar components. */
7785 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7786 decl
, cdecl, NULL_TREE
);
7787 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7788 void_type_node
, comp
,
7789 build_int_cst (TREE_TYPE (comp
), 0));
7790 gfc_add_expr_to_block (&fnblock
, tmp
);
7791 if (gfc_deferred_strlen (c
, &comp
))
7793 comp
= fold_build3_loc (input_location
, COMPONENT_REF
,
7795 decl
, comp
, NULL_TREE
);
7796 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7797 TREE_TYPE (comp
), comp
,
7798 build_int_cst (TREE_TYPE (comp
), 0));
7799 gfc_add_expr_to_block (&fnblock
, tmp
);
7802 else if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
7804 /* Allocatable CLASS components. */
7805 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7806 decl
, cdecl, NULL_TREE
);
7807 /* Add reference to '_data' component. */
7808 tmp
= CLASS_DATA (c
)->backend_decl
;
7809 comp
= fold_build3_loc (input_location
, COMPONENT_REF
,
7810 TREE_TYPE (tmp
), comp
, tmp
, NULL_TREE
);
7811 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp
)))
7812 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
7815 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7816 void_type_node
, comp
,
7817 build_int_cst (TREE_TYPE (comp
), 0));
7818 gfc_add_expr_to_block (&fnblock
, tmp
);
7821 else if (cmp_has_alloc_comps
)
7823 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7824 decl
, cdecl, NULL_TREE
);
7825 rank
= c
->as
? c
->as
->rank
: 0;
7826 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
7828 gfc_add_expr_to_block (&fnblock
, tmp
);
7832 case COPY_ALLOC_COMP_CAF
:
7833 if (!c
->attr
.codimension
7834 && (c
->ts
.type
!= BT_CLASS
|| CLASS_DATA (c
)->attr
.coarray_comp
)
7835 && (c
->ts
.type
!= BT_DERIVED
7836 || !c
->ts
.u
.derived
->attr
.coarray_comp
))
7839 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, decl
,
7841 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, dest
,
7844 if (c
->attr
.codimension
)
7846 if (c
->ts
.type
== BT_CLASS
)
7848 comp
= gfc_class_data_get (comp
);
7849 dcmp
= gfc_class_data_get (dcmp
);
7851 gfc_conv_descriptor_data_set (&fnblock
, dcmp
,
7852 gfc_conv_descriptor_data_get (comp
));
7856 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, dcmp
,
7858 gfc_add_expr_to_block (&fnblock
, tmp
);
7863 case COPY_ALLOC_COMP
:
7864 if (c
->attr
.pointer
)
7867 /* We need source and destination components. */
7868 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, decl
,
7870 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, dest
,
7872 dcmp
= fold_convert (TREE_TYPE (comp
), dcmp
);
7874 if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
7882 dst_data
= gfc_class_data_get (dcmp
);
7883 src_data
= gfc_class_data_get (comp
);
7884 size
= fold_convert (size_type_node
, gfc_vtable_size_get (comp
));
7886 if (CLASS_DATA (c
)->attr
.dimension
)
7888 nelems
= gfc_conv_descriptor_size (src_data
,
7889 CLASS_DATA (c
)->as
->rank
);
7890 size
= fold_build2_loc (input_location
, MULT_EXPR
,
7891 size_type_node
, size
,
7892 fold_convert (size_type_node
,
7896 nelems
= build_int_cst (size_type_node
, 1);
7898 if (CLASS_DATA (c
)->attr
.dimension
7899 || CLASS_DATA (c
)->attr
.codimension
)
7901 src_data
= gfc_conv_descriptor_data_get (src_data
);
7902 dst_data
= gfc_conv_descriptor_data_get (dst_data
);
7905 gfc_init_block (&tmpblock
);
7907 /* Coarray component have to have the same allocation status and
7908 shape/type-parameter/effective-type on the LHS and RHS of an
7909 intrinsic assignment. Hence, we did not deallocated them - and
7910 do not allocate them here. */
7911 if (!CLASS_DATA (c
)->attr
.codimension
)
7913 ftn_tree
= builtin_decl_explicit (BUILT_IN_MALLOC
);
7914 tmp
= build_call_expr_loc (input_location
, ftn_tree
, 1, size
);
7915 gfc_add_modify (&tmpblock
, dst_data
,
7916 fold_convert (TREE_TYPE (dst_data
), tmp
));
7919 tmp
= gfc_copy_class_to_class (comp
, dcmp
, nelems
);
7920 gfc_add_expr_to_block (&tmpblock
, tmp
);
7921 tmp
= gfc_finish_block (&tmpblock
);
7923 gfc_init_block (&tmpblock
);
7924 gfc_add_modify (&tmpblock
, dst_data
,
7925 fold_convert (TREE_TYPE (dst_data
),
7926 null_pointer_node
));
7927 null_data
= gfc_finish_block (&tmpblock
);
7929 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
7930 boolean_type_node
, src_data
,
7933 gfc_add_expr_to_block (&fnblock
, build3_v (COND_EXPR
, null_cond
,
7938 if (gfc_deferred_strlen (c
, &tmp
))
7942 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
7944 decl
, len
, NULL_TREE
);
7945 len
= fold_build3_loc (input_location
, COMPONENT_REF
,
7947 dest
, len
, NULL_TREE
);
7948 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7949 TREE_TYPE (len
), len
, tmp
);
7950 gfc_add_expr_to_block (&fnblock
, tmp
);
7951 size
= size_of_string_in_bytes (c
->ts
.kind
, len
);
7952 tmp
= duplicate_allocatable (dcmp
, comp
, ctype
, rank
,
7953 false, false, size
);
7954 gfc_add_expr_to_block (&fnblock
, tmp
);
7956 else if (c
->attr
.allocatable
&& !c
->attr
.proc_pointer
7957 && !cmp_has_alloc_comps
)
7959 rank
= c
->as
? c
->as
->rank
: 0;
7960 if (c
->attr
.codimension
)
7961 tmp
= gfc_copy_allocatable_data (dcmp
, comp
, ctype
, rank
);
7963 tmp
= gfc_duplicate_allocatable (dcmp
, comp
, ctype
, rank
);
7964 gfc_add_expr_to_block (&fnblock
, tmp
);
7967 if (cmp_has_alloc_comps
)
7969 rank
= c
->as
? c
->as
->rank
: 0;
7970 tmp
= fold_convert (TREE_TYPE (dcmp
), comp
);
7971 gfc_add_modify (&fnblock
, dcmp
, tmp
);
7972 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, dcmp
,
7974 gfc_add_expr_to_block (&fnblock
, tmp
);
7984 return gfc_finish_block (&fnblock
);
7987 /* Recursively traverse an object of derived type, generating code to
7988 nullify allocatable components. */
7991 gfc_nullify_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
7993 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
7994 NULLIFY_ALLOC_COMP
);
7998 /* Recursively traverse an object of derived type, generating code to
7999 deallocate allocatable components. */
8002 gfc_deallocate_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
8004 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
8005 DEALLOCATE_ALLOC_COMP
);
8009 /* Recursively traverse an object of derived type, generating code to
8010 deallocate allocatable components. But do not deallocate coarrays.
8011 To be used for intrinsic assignment, which may not change the allocation
8012 status of coarrays. */
8015 gfc_deallocate_alloc_comp_no_caf (gfc_symbol
* der_type
, tree decl
, int rank
)
8017 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
8018 DEALLOCATE_ALLOC_COMP_NO_CAF
);
8023 gfc_reassign_alloc_comp_caf (gfc_symbol
*der_type
, tree decl
, tree dest
)
8025 return structure_alloc_comps (der_type
, decl
, dest
, 0, COPY_ALLOC_COMP_CAF
);
8029 /* Recursively traverse an object of derived type, generating code to
8030 copy it and its allocatable components. */
8033 gfc_copy_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
8035 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ALLOC_COMP
);
8039 /* Recursively traverse an object of derived type, generating code to
8040 copy only its allocatable components. */
8043 gfc_copy_only_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
8045 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ONLY_ALLOC_COMP
);
8049 /* Returns the value of LBOUND for an expression. This could be broken out
8050 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
8051 called by gfc_alloc_allocatable_for_assignment. */
8053 get_std_lbound (gfc_expr
*expr
, tree desc
, int dim
, bool assumed_size
)
8058 tree cond
, cond1
, cond3
, cond4
;
8062 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
8064 tmp
= gfc_rank_cst
[dim
];
8065 lbound
= gfc_conv_descriptor_lbound_get (desc
, tmp
);
8066 ubound
= gfc_conv_descriptor_ubound_get (desc
, tmp
);
8067 stride
= gfc_conv_descriptor_stride_get (desc
, tmp
);
8068 cond1
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
8070 cond3
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
8071 stride
, gfc_index_zero_node
);
8072 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8073 boolean_type_node
, cond3
, cond1
);
8074 cond4
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
8075 stride
, gfc_index_zero_node
);
8077 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
8078 tmp
, build_int_cst (gfc_array_index_type
,
8081 cond
= boolean_false_node
;
8083 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
8084 boolean_type_node
, cond3
, cond4
);
8085 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
8086 boolean_type_node
, cond
, cond1
);
8088 return fold_build3_loc (input_location
, COND_EXPR
,
8089 gfc_array_index_type
, cond
,
8090 lbound
, gfc_index_one_node
);
8093 if (expr
->expr_type
== EXPR_FUNCTION
)
8095 /* A conversion function, so use the argument. */
8096 gcc_assert (expr
->value
.function
.isym
8097 && expr
->value
.function
.isym
->conversion
);
8098 expr
= expr
->value
.function
.actual
->expr
;
8101 if (expr
->expr_type
== EXPR_VARIABLE
)
8103 tmp
= TREE_TYPE (expr
->symtree
->n
.sym
->backend_decl
);
8104 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
8106 if (ref
->type
== REF_COMPONENT
8107 && ref
->u
.c
.component
->as
8109 && ref
->next
->u
.ar
.type
== AR_FULL
)
8110 tmp
= TREE_TYPE (ref
->u
.c
.component
->backend_decl
);
8112 return GFC_TYPE_ARRAY_LBOUND(tmp
, dim
);
8115 return gfc_index_one_node
;
8119 /* Returns true if an expression represents an lhs that can be reallocated
8123 gfc_is_reallocatable_lhs (gfc_expr
*expr
)
8130 /* An allocatable variable. */
8131 if (expr
->symtree
->n
.sym
->attr
.allocatable
8133 && expr
->ref
->type
== REF_ARRAY
8134 && expr
->ref
->u
.ar
.type
== AR_FULL
)
8137 /* All that can be left are allocatable components. */
8138 if ((expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
8139 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
8140 || !expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
8143 /* Find a component ref followed by an array reference. */
8144 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
8146 && ref
->type
== REF_COMPONENT
8147 && ref
->next
->type
== REF_ARRAY
8148 && !ref
->next
->next
)
8154 /* Return true if valid reallocatable lhs. */
8155 if (ref
->u
.c
.component
->attr
.allocatable
8156 && ref
->next
->u
.ar
.type
== AR_FULL
)
8163 /* Allocate the lhs of an assignment to an allocatable array, otherwise
8167 gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop
,
8171 stmtblock_t realloc_block
;
8172 stmtblock_t alloc_block
;
8176 gfc_array_info
*linfo
;
8198 gfc_array_spec
* as
;
8200 /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
8201 Find the lhs expression in the loop chain and set expr1 and
8202 expr2 accordingly. */
8203 if (expr1
->expr_type
== EXPR_FUNCTION
&& expr2
== NULL
)
8206 /* Find the ss for the lhs. */
8208 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
8209 if (lss
->info
->expr
&& lss
->info
->expr
->expr_type
== EXPR_VARIABLE
)
8211 if (lss
== gfc_ss_terminator
)
8213 expr1
= lss
->info
->expr
;
8216 /* Bail out if this is not a valid allocate on assignment. */
8217 if (!gfc_is_reallocatable_lhs (expr1
)
8218 || (expr2
&& !expr2
->rank
))
8221 /* Find the ss for the lhs. */
8223 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
8224 if (lss
->info
->expr
== expr1
)
8227 if (lss
== gfc_ss_terminator
)
8230 linfo
= &lss
->info
->data
.array
;
8232 /* Find an ss for the rhs. For operator expressions, we see the
8233 ss's for the operands. Any one of these will do. */
8235 for (; rss
&& rss
!= gfc_ss_terminator
; rss
= rss
->loop_chain
)
8236 if (rss
->info
->expr
!= expr1
&& rss
!= loop
->temp_ss
)
8239 if (expr2
&& rss
== gfc_ss_terminator
)
8242 gfc_start_block (&fblock
);
8244 /* Since the lhs is allocatable, this must be a descriptor type.
8245 Get the data and array size. */
8246 desc
= linfo
->descriptor
;
8247 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)));
8248 array1
= gfc_conv_descriptor_data_get (desc
);
8250 /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
8251 deallocated if expr is an array of different shape or any of the
8252 corresponding length type parameter values of variable and expr
8253 differ." This assures F95 compatibility. */
8254 jump_label1
= gfc_build_label_decl (NULL_TREE
);
8255 jump_label2
= gfc_build_label_decl (NULL_TREE
);
8257 /* Allocate if data is NULL. */
8258 cond_null
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
8259 array1
, build_int_cst (TREE_TYPE (array1
), 0));
8260 tmp
= build3_v (COND_EXPR
, cond_null
,
8261 build1_v (GOTO_EXPR
, jump_label1
),
8262 build_empty_stmt (input_location
));
8263 gfc_add_expr_to_block (&fblock
, tmp
);
8265 /* Get arrayspec if expr is a full array. */
8266 if (expr2
&& expr2
->expr_type
== EXPR_FUNCTION
8267 && expr2
->value
.function
.isym
8268 && expr2
->value
.function
.isym
->conversion
)
8270 /* For conversion functions, take the arg. */
8271 gfc_expr
*arg
= expr2
->value
.function
.actual
->expr
;
8272 as
= gfc_get_full_arrayspec_from_expr (arg
);
8275 as
= gfc_get_full_arrayspec_from_expr (expr2
);
8279 /* If the lhs shape is not the same as the rhs jump to setting the
8280 bounds and doing the reallocation....... */
8281 for (n
= 0; n
< expr1
->rank
; n
++)
8283 /* Check the shape. */
8284 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
8285 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
8286 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8287 gfc_array_index_type
,
8288 loop
->to
[n
], loop
->from
[n
]);
8289 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8290 gfc_array_index_type
,
8292 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8293 gfc_array_index_type
,
8295 cond
= fold_build2_loc (input_location
, NE_EXPR
,
8297 tmp
, gfc_index_zero_node
);
8298 tmp
= build3_v (COND_EXPR
, cond
,
8299 build1_v (GOTO_EXPR
, jump_label1
),
8300 build_empty_stmt (input_location
));
8301 gfc_add_expr_to_block (&fblock
, tmp
);
8304 /* ....else jump past the (re)alloc code. */
8305 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
8306 gfc_add_expr_to_block (&fblock
, tmp
);
8308 /* Add the label to start automatic (re)allocation. */
8309 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
8310 gfc_add_expr_to_block (&fblock
, tmp
);
8312 /* If the lhs has not been allocated, its bounds will not have been
8313 initialized and so its size is set to zero. */
8314 size1
= gfc_create_var (gfc_array_index_type
, NULL
);
8315 gfc_init_block (&alloc_block
);
8316 gfc_add_modify (&alloc_block
, size1
, gfc_index_zero_node
);
8317 gfc_init_block (&realloc_block
);
8318 gfc_add_modify (&realloc_block
, size1
,
8319 gfc_conv_descriptor_size (desc
, expr1
->rank
));
8320 tmp
= build3_v (COND_EXPR
, cond_null
,
8321 gfc_finish_block (&alloc_block
),
8322 gfc_finish_block (&realloc_block
));
8323 gfc_add_expr_to_block (&fblock
, tmp
);
8325 /* Get the rhs size and fix it. */
8327 desc2
= rss
->info
->data
.array
.descriptor
;
8331 size2
= gfc_index_one_node
;
8332 for (n
= 0; n
< expr2
->rank
; n
++)
8334 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8335 gfc_array_index_type
,
8336 loop
->to
[n
], loop
->from
[n
]);
8337 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8338 gfc_array_index_type
,
8339 tmp
, gfc_index_one_node
);
8340 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
8341 gfc_array_index_type
,
8344 size2
= gfc_evaluate_now (size2
, &fblock
);
8346 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
8348 neq_size
= gfc_evaluate_now (cond
, &fblock
);
8350 /* Deallocation of allocatable components will have to occur on
8351 reallocation. Fix the old descriptor now. */
8352 if ((expr1
->ts
.type
== BT_DERIVED
)
8353 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
8354 old_desc
= gfc_evaluate_now (desc
, &fblock
);
8356 old_desc
= NULL_TREE
;
8358 /* Now modify the lhs descriptor and the associated scalarizer
8359 variables. F2003 7.4.1.3: "If variable is or becomes an
8360 unallocated allocatable variable, then it is allocated with each
8361 deferred type parameter equal to the corresponding type parameters
8362 of expr , with the shape of expr , and with each lower bound equal
8363 to the corresponding element of LBOUND(expr)."
8364 Reuse size1 to keep a dimension-by-dimension track of the
8365 stride of the new array. */
8366 size1
= gfc_index_one_node
;
8367 offset
= gfc_index_zero_node
;
8369 for (n
= 0; n
< expr2
->rank
; n
++)
8371 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8372 gfc_array_index_type
,
8373 loop
->to
[n
], loop
->from
[n
]);
8374 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8375 gfc_array_index_type
,
8376 tmp
, gfc_index_one_node
);
8378 lbound
= gfc_index_one_node
;
8383 lbd
= get_std_lbound (expr2
, desc2
, n
,
8384 as
->type
== AS_ASSUMED_SIZE
);
8385 ubound
= fold_build2_loc (input_location
,
8387 gfc_array_index_type
,
8389 ubound
= fold_build2_loc (input_location
,
8391 gfc_array_index_type
,
8396 gfc_conv_descriptor_lbound_set (&fblock
, desc
,
8399 gfc_conv_descriptor_ubound_set (&fblock
, desc
,
8402 gfc_conv_descriptor_stride_set (&fblock
, desc
,
8405 lbound
= gfc_conv_descriptor_lbound_get (desc
,
8407 tmp2
= fold_build2_loc (input_location
, MULT_EXPR
,
8408 gfc_array_index_type
,
8410 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
8411 gfc_array_index_type
,
8413 size1
= fold_build2_loc (input_location
, MULT_EXPR
,
8414 gfc_array_index_type
,
8418 /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
8419 the array offset is saved and the info.offset is used for a
8420 running offset. Use the saved_offset instead. */
8421 tmp
= gfc_conv_descriptor_offset (desc
);
8422 gfc_add_modify (&fblock
, tmp
, offset
);
8423 if (linfo
->saved_offset
8424 && TREE_CODE (linfo
->saved_offset
) == VAR_DECL
)
8425 gfc_add_modify (&fblock
, linfo
->saved_offset
, tmp
);
8427 /* Now set the deltas for the lhs. */
8428 for (n
= 0; n
< expr1
->rank
; n
++)
8430 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
8432 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8433 gfc_array_index_type
, tmp
,
8435 if (linfo
->delta
[dim
]
8436 && TREE_CODE (linfo
->delta
[dim
]) == VAR_DECL
)
8437 gfc_add_modify (&fblock
, linfo
->delta
[dim
], tmp
);
8440 /* Get the new lhs size in bytes. */
8441 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
8443 if (expr2
->ts
.deferred
)
8445 if (TREE_CODE (expr2
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
8446 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
8448 tmp
= rss
->info
->string_length
;
8452 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
8453 tmp
= fold_convert (TREE_TYPE (expr1
->ts
.u
.cl
->backend_decl
), tmp
);
8456 if (expr1
->ts
.u
.cl
->backend_decl
8457 && TREE_CODE (expr1
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
8458 gfc_add_modify (&fblock
, expr1
->ts
.u
.cl
->backend_decl
, tmp
);
8460 gfc_add_modify (&fblock
, lss
->info
->string_length
, tmp
);
8462 else if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.u
.cl
->backend_decl
)
8464 tmp
= TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
)));
8465 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8466 gfc_array_index_type
, tmp
,
8467 expr1
->ts
.u
.cl
->backend_decl
);
8470 tmp
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
8471 tmp
= fold_convert (gfc_array_index_type
, tmp
);
8472 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
8473 gfc_array_index_type
,
8475 size2
= fold_convert (size_type_node
, size2
);
8476 size2
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
8477 size2
, size_one_node
);
8478 size2
= gfc_evaluate_now (size2
, &fblock
);
8480 /* Realloc expression. Note that the scalarizer uses desc.data
8481 in the array reference - (*desc.data)[<element>]. */
8482 gfc_init_block (&realloc_block
);
8484 if ((expr1
->ts
.type
== BT_DERIVED
)
8485 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
8487 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, old_desc
,
8489 gfc_add_expr_to_block (&realloc_block
, tmp
);
8492 tmp
= build_call_expr_loc (input_location
,
8493 builtin_decl_explicit (BUILT_IN_REALLOC
), 2,
8494 fold_convert (pvoid_type_node
, array1
),
8496 gfc_conv_descriptor_data_set (&realloc_block
,
8499 if ((expr1
->ts
.type
== BT_DERIVED
)
8500 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
8502 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, desc
,
8504 gfc_add_expr_to_block (&realloc_block
, tmp
);
8507 realloc_expr
= gfc_finish_block (&realloc_block
);
8509 /* Only reallocate if sizes are different. */
8510 tmp
= build3_v (COND_EXPR
, neq_size
, realloc_expr
,
8511 build_empty_stmt (input_location
));
8515 /* Malloc expression. */
8516 gfc_init_block (&alloc_block
);
8517 tmp
= build_call_expr_loc (input_location
,
8518 builtin_decl_explicit (BUILT_IN_MALLOC
),
8520 gfc_conv_descriptor_data_set (&alloc_block
,
8522 tmp
= gfc_conv_descriptor_dtype (desc
);
8523 gfc_add_modify (&alloc_block
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
8524 if ((expr1
->ts
.type
== BT_DERIVED
)
8525 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
8527 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, desc
,
8529 gfc_add_expr_to_block (&alloc_block
, tmp
);
8531 alloc_expr
= gfc_finish_block (&alloc_block
);
8533 /* Malloc if not allocated; realloc otherwise. */
8534 tmp
= build_int_cst (TREE_TYPE (array1
), 0);
8535 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
8538 tmp
= build3_v (COND_EXPR
, cond
, alloc_expr
, realloc_expr
);
8539 gfc_add_expr_to_block (&fblock
, tmp
);
8541 /* Make sure that the scalarizer data pointer is updated. */
8543 && TREE_CODE (linfo
->data
) == VAR_DECL
)
8545 tmp
= gfc_conv_descriptor_data_get (desc
);
8546 gfc_add_modify (&fblock
, linfo
->data
, tmp
);
8549 /* Add the exit label. */
8550 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
8551 gfc_add_expr_to_block (&fblock
, tmp
);
8553 return gfc_finish_block (&fblock
);
8557 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
8558 Do likewise, recursively if necessary, with the allocatable components of
8562 gfc_trans_deferred_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
8568 stmtblock_t cleanup
;
8571 bool sym_has_alloc_comp
, has_finalizer
;
8573 sym_has_alloc_comp
= (sym
->ts
.type
== BT_DERIVED
8574 || sym
->ts
.type
== BT_CLASS
)
8575 && sym
->ts
.u
.derived
->attr
.alloc_comp
;
8576 has_finalizer
= sym
->ts
.type
== BT_CLASS
|| sym
->ts
.type
== BT_DERIVED
8577 ? gfc_is_finalizable (sym
->ts
.u
.derived
, NULL
) : false;
8579 /* Make sure the frontend gets these right. */
8580 gcc_assert (sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym_has_alloc_comp
8583 gfc_save_backend_locus (&loc
);
8584 gfc_set_backend_locus (&sym
->declared_at
);
8585 gfc_init_block (&init
);
8587 gcc_assert (TREE_CODE (sym
->backend_decl
) == VAR_DECL
8588 || TREE_CODE (sym
->backend_decl
) == PARM_DECL
);
8590 if (sym
->ts
.type
== BT_CHARACTER
8591 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
8593 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
8594 gfc_trans_vla_type_sizes (sym
, &init
);
8597 /* Dummy, use associated and result variables don't need anything special. */
8598 if (sym
->attr
.dummy
|| sym
->attr
.use_assoc
|| sym
->attr
.result
)
8600 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
8601 gfc_restore_backend_locus (&loc
);
8605 descriptor
= sym
->backend_decl
;
8607 /* Although static, derived types with default initializers and
8608 allocatable components must not be nulled wholesale; instead they
8609 are treated component by component. */
8610 if (TREE_STATIC (descriptor
) && !sym_has_alloc_comp
&& !has_finalizer
)
8612 /* SAVEd variables are not freed on exit. */
8613 gfc_trans_static_array_pointer (sym
);
8615 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
8616 gfc_restore_backend_locus (&loc
);
8620 /* Get the descriptor type. */
8621 type
= TREE_TYPE (sym
->backend_decl
);
8623 if ((sym_has_alloc_comp
|| (has_finalizer
&& sym
->ts
.type
!= BT_CLASS
))
8624 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
8627 && !(TREE_STATIC (sym
->backend_decl
) && sym
->attr
.is_main_program
))
8629 if (sym
->value
== NULL
8630 || !gfc_has_default_initializer (sym
->ts
.u
.derived
))
8632 rank
= sym
->as
? sym
->as
->rank
: 0;
8633 tmp
= gfc_nullify_alloc_comp (sym
->ts
.u
.derived
,
8635 gfc_add_expr_to_block (&init
, tmp
);
8638 gfc_init_default_dt (sym
, &init
, false);
8641 else if (!GFC_DESCRIPTOR_TYPE_P (type
))
8643 /* If the backend_decl is not a descriptor, we must have a pointer
8645 descriptor
= build_fold_indirect_ref_loc (input_location
,
8647 type
= TREE_TYPE (descriptor
);
8650 /* NULLIFY the data pointer, for non-saved allocatables. */
8651 if (GFC_DESCRIPTOR_TYPE_P (type
) && !sym
->attr
.save
&& sym
->attr
.allocatable
)
8652 gfc_conv_descriptor_data_set (&init
, descriptor
, null_pointer_node
);
8654 gfc_restore_backend_locus (&loc
);
8655 gfc_init_block (&cleanup
);
8657 /* Allocatable arrays need to be freed when they go out of scope.
8658 The allocatable components of pointers must not be touched. */
8659 if (!sym
->attr
.allocatable
&& has_finalizer
&& sym
->ts
.type
!= BT_CLASS
8660 && !sym
->attr
.pointer
&& !sym
->attr
.artificial
&& !sym
->attr
.save
8661 && !sym
->ns
->proc_name
->attr
.is_main_program
)
8664 sym
->attr
.referenced
= 1;
8665 e
= gfc_lval_expr_from_sym (sym
);
8666 gfc_add_finalizer_call (&cleanup
, e
);
8669 else if ((!sym
->attr
.allocatable
|| !has_finalizer
)
8670 && sym_has_alloc_comp
&& !(sym
->attr
.function
|| sym
->attr
.result
)
8671 && !sym
->attr
.pointer
&& !sym
->attr
.save
8672 && !sym
->ns
->proc_name
->attr
.is_main_program
)
8675 rank
= sym
->as
? sym
->as
->rank
: 0;
8676 tmp
= gfc_deallocate_alloc_comp (sym
->ts
.u
.derived
, descriptor
, rank
);
8677 gfc_add_expr_to_block (&cleanup
, tmp
);
8680 if (sym
->attr
.allocatable
&& (sym
->attr
.dimension
|| sym
->attr
.codimension
)
8681 && !sym
->attr
.save
&& !sym
->attr
.result
8682 && !sym
->ns
->proc_name
->attr
.is_main_program
)
8685 e
= has_finalizer
? gfc_lval_expr_from_sym (sym
) : NULL
;
8686 tmp
= gfc_trans_dealloc_allocated (sym
->backend_decl
,
8687 sym
->attr
.codimension
, e
);
8690 gfc_add_expr_to_block (&cleanup
, tmp
);
8693 gfc_add_init_cleanup (block
, gfc_finish_block (&init
),
8694 gfc_finish_block (&cleanup
));
8697 /************ Expression Walking Functions ******************/
8699 /* Walk a variable reference.
8701 Possible extension - multiple component subscripts.
8702 x(:,:) = foo%a(:)%b(:)
8704 forall (i=..., j=...)
8705 x(i,j) = foo%a(j)%b(i)
8707 This adds a fair amount of complexity because you need to deal with more
8708 than one ref. Maybe handle in a similar manner to vector subscripts.
8709 Maybe not worth the effort. */
8713 gfc_walk_variable_expr (gfc_ss
* ss
, gfc_expr
* expr
)
8717 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
8718 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
8721 return gfc_walk_array_ref (ss
, expr
, ref
);
8726 gfc_walk_array_ref (gfc_ss
* ss
, gfc_expr
* expr
, gfc_ref
* ref
)
8732 for (; ref
; ref
= ref
->next
)
8734 if (ref
->type
== REF_SUBSTRING
)
8736 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.start
);
8737 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.end
);
8740 /* We're only interested in array sections from now on. */
8741 if (ref
->type
!= REF_ARRAY
)
8749 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
8750 ss
= gfc_get_scalar_ss (ss
, ar
->start
[n
]);
8754 newss
= gfc_get_array_ss (ss
, expr
, ar
->as
->rank
, GFC_SS_SECTION
);
8755 newss
->info
->data
.array
.ref
= ref
;
8757 /* Make sure array is the same as array(:,:), this way
8758 we don't need to special case all the time. */
8759 ar
->dimen
= ar
->as
->rank
;
8760 for (n
= 0; n
< ar
->dimen
; n
++)
8762 ar
->dimen_type
[n
] = DIMEN_RANGE
;
8764 gcc_assert (ar
->start
[n
] == NULL
);
8765 gcc_assert (ar
->end
[n
] == NULL
);
8766 gcc_assert (ar
->stride
[n
] == NULL
);
8772 newss
= gfc_get_array_ss (ss
, expr
, 0, GFC_SS_SECTION
);
8773 newss
->info
->data
.array
.ref
= ref
;
8775 /* We add SS chains for all the subscripts in the section. */
8776 for (n
= 0; n
< ar
->dimen
; n
++)
8780 switch (ar
->dimen_type
[n
])
8783 /* Add SS for elemental (scalar) subscripts. */
8784 gcc_assert (ar
->start
[n
]);
8785 indexss
= gfc_get_scalar_ss (gfc_ss_terminator
, ar
->start
[n
]);
8786 indexss
->loop_chain
= gfc_ss_terminator
;
8787 newss
->info
->data
.array
.subscript
[n
] = indexss
;
8791 /* We don't add anything for sections, just remember this
8792 dimension for later. */
8793 newss
->dim
[newss
->dimen
] = n
;
8798 /* Create a GFC_SS_VECTOR index in which we can store
8799 the vector's descriptor. */
8800 indexss
= gfc_get_array_ss (gfc_ss_terminator
, ar
->start
[n
],
8802 indexss
->loop_chain
= gfc_ss_terminator
;
8803 newss
->info
->data
.array
.subscript
[n
] = indexss
;
8804 newss
->dim
[newss
->dimen
] = n
;
8809 /* We should know what sort of section it is by now. */
8813 /* We should have at least one non-elemental dimension,
8814 unless we are creating a descriptor for a (scalar) coarray. */
8815 gcc_assert (newss
->dimen
> 0
8816 || newss
->info
->data
.array
.ref
->u
.ar
.as
->corank
> 0);
8821 /* We should know what sort of section it is by now. */
8830 /* Walk an expression operator. If only one operand of a binary expression is
8831 scalar, we must also add the scalar term to the SS chain. */
8834 gfc_walk_op_expr (gfc_ss
* ss
, gfc_expr
* expr
)
8839 head
= gfc_walk_subexpr (ss
, expr
->value
.op
.op1
);
8840 if (expr
->value
.op
.op2
== NULL
)
8843 head2
= gfc_walk_subexpr (head
, expr
->value
.op
.op2
);
8845 /* All operands are scalar. Pass back and let the caller deal with it. */
8849 /* All operands require scalarization. */
8850 if (head
!= ss
&& (expr
->value
.op
.op2
== NULL
|| head2
!= head
))
8853 /* One of the operands needs scalarization, the other is scalar.
8854 Create a gfc_ss for the scalar expression. */
8857 /* First operand is scalar. We build the chain in reverse order, so
8858 add the scalar SS after the second operand. */
8860 while (head
&& head
->next
!= ss
)
8862 /* Check we haven't somehow broken the chain. */
8864 head
->next
= gfc_get_scalar_ss (ss
, expr
->value
.op
.op1
);
8866 else /* head2 == head */
8868 gcc_assert (head2
== head
);
8869 /* Second operand is scalar. */
8870 head2
= gfc_get_scalar_ss (head2
, expr
->value
.op
.op2
);
8877 /* Reverse a SS chain. */
8880 gfc_reverse_ss (gfc_ss
* ss
)
8885 gcc_assert (ss
!= NULL
);
8887 head
= gfc_ss_terminator
;
8888 while (ss
!= gfc_ss_terminator
)
8891 /* Check we didn't somehow break the chain. */
8892 gcc_assert (next
!= NULL
);
8902 /* Given an expression referring to a procedure, return the symbol of its
8903 interface. We can't get the procedure symbol directly as we have to handle
8904 the case of (deferred) type-bound procedures. */
8907 gfc_get_proc_ifc_for_expr (gfc_expr
*procedure_ref
)
8912 if (procedure_ref
== NULL
)
8915 /* Normal procedure case. */
8916 sym
= procedure_ref
->symtree
->n
.sym
;
8918 /* Typebound procedure case. */
8919 for (ref
= procedure_ref
->ref
; ref
; ref
= ref
->next
)
8921 if (ref
->type
== REF_COMPONENT
8922 && ref
->u
.c
.component
->attr
.proc_pointer
)
8923 sym
= ref
->u
.c
.component
->ts
.interface
;
8932 /* Walk the arguments of an elemental function.
8933 PROC_EXPR is used to check whether an argument is permitted to be absent. If
8934 it is NULL, we don't do the check and the argument is assumed to be present.
8938 gfc_walk_elemental_function_args (gfc_ss
* ss
, gfc_actual_arglist
*arg
,
8939 gfc_symbol
*proc_ifc
, gfc_ss_type type
)
8941 gfc_formal_arglist
*dummy_arg
;
8947 head
= gfc_ss_terminator
;
8951 dummy_arg
= gfc_sym_get_dummy_args (proc_ifc
);
8956 for (; arg
; arg
= arg
->next
)
8958 if (!arg
->expr
|| arg
->expr
->expr_type
== EXPR_NULL
)
8961 newss
= gfc_walk_subexpr (head
, arg
->expr
);
8964 /* Scalar argument. */
8965 gcc_assert (type
== GFC_SS_SCALAR
|| type
== GFC_SS_REFERENCE
);
8966 newss
= gfc_get_scalar_ss (head
, arg
->expr
);
8967 newss
->info
->type
= type
;
8973 if (dummy_arg
!= NULL
8974 && dummy_arg
->sym
->attr
.optional
8975 && arg
->expr
->expr_type
== EXPR_VARIABLE
8976 && (gfc_expr_attr (arg
->expr
).optional
8977 || gfc_expr_attr (arg
->expr
).allocatable
8978 || gfc_expr_attr (arg
->expr
).pointer
))
8979 newss
->info
->can_be_null_ref
= true;
8985 while (tail
->next
!= gfc_ss_terminator
)
8989 if (dummy_arg
!= NULL
)
8990 dummy_arg
= dummy_arg
->next
;
8995 /* If all the arguments are scalar we don't need the argument SS. */
8996 gfc_free_ss_chain (head
);
9001 /* Add it onto the existing chain. */
9007 /* Walk a function call. Scalar functions are passed back, and taken out of
9008 scalarization loops. For elemental functions we walk their arguments.
9009 The result of functions returning arrays is stored in a temporary outside
9010 the loop, so that the function is only called once. Hence we do not need
9011 to walk their arguments. */
9014 gfc_walk_function_expr (gfc_ss
* ss
, gfc_expr
* expr
)
9016 gfc_intrinsic_sym
*isym
;
9018 gfc_component
*comp
= NULL
;
9020 isym
= expr
->value
.function
.isym
;
9022 /* Handle intrinsic functions separately. */
9024 return gfc_walk_intrinsic_function (ss
, expr
, isym
);
9026 sym
= expr
->value
.function
.esym
;
9028 sym
= expr
->symtree
->n
.sym
;
9030 /* A function that returns arrays. */
9031 comp
= gfc_get_proc_ptr_comp (expr
);
9032 if ((!comp
&& gfc_return_by_reference (sym
) && sym
->result
->attr
.dimension
)
9033 || (comp
&& comp
->attr
.dimension
))
9034 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
9036 /* Walk the parameters of an elemental function. For now we always pass
9038 if (sym
->attr
.elemental
|| (comp
&& comp
->attr
.elemental
))
9039 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
9040 gfc_get_proc_ifc_for_expr (expr
),
9043 /* Scalar functions are OK as these are evaluated outside the scalarization
9044 loop. Pass back and let the caller deal with it. */
9049 /* An array temporary is constructed for array constructors. */
9052 gfc_walk_array_constructor (gfc_ss
* ss
, gfc_expr
* expr
)
9054 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_CONSTRUCTOR
);
9058 /* Walk an expression. Add walked expressions to the head of the SS chain.
9059 A wholly scalar expression will not be added. */
9062 gfc_walk_subexpr (gfc_ss
* ss
, gfc_expr
* expr
)
9066 switch (expr
->expr_type
)
9069 head
= gfc_walk_variable_expr (ss
, expr
);
9073 head
= gfc_walk_op_expr (ss
, expr
);
9077 head
= gfc_walk_function_expr (ss
, expr
);
9082 case EXPR_STRUCTURE
:
9083 /* Pass back and let the caller deal with it. */
9087 head
= gfc_walk_array_constructor (ss
, expr
);
9090 case EXPR_SUBSTRING
:
9091 /* Pass back and let the caller deal with it. */
9095 internal_error ("bad expression type during walk (%d)",
9102 /* Entry point for expression walking.
9103 A return value equal to the passed chain means this is
9104 a scalar expression. It is up to the caller to take whatever action is
9105 necessary to translate these. */
9108 gfc_walk_expr (gfc_expr
* expr
)
9112 res
= gfc_walk_subexpr (gfc_ss_terminator
, expr
);
9113 return gfc_reverse_ss (res
);