1 /* Array translation routines
2 Copyright (C) 2002-2013 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-array.c-- Various array related code, including scalarization,
23 allocation, initialization and other support routines. */
25 /* How the scalarizer works.
26 In gfortran, array expressions use the same core routines as scalar
28 First, a Scalarization State (SS) chain is built. This is done by walking
29 the expression tree, and building a linear list of the terms in the
30 expression. As the tree is walked, scalar subexpressions are translated.
32 The scalarization parameters are stored in a gfc_loopinfo structure.
33 First the start and stride of each term is calculated by
34 gfc_conv_ss_startstride. During this process the expressions for the array
35 descriptors and data pointers are also translated.
37 If the expression is an assignment, we must then resolve any dependencies.
38 In Fortran all the rhs values of an assignment must be evaluated before
39 any assignments take place. This can require a temporary array to store the
40 values. We also require a temporary when we are passing array expressions
41 or vector subscripts as procedure parameters.
43 Array sections are passed without copying to a temporary. These use the
44 scalarizer to determine the shape of the section. The flag
45 loop->array_parameter tells the scalarizer that the actual values and loop
46 variables will not be required.
48 The function gfc_conv_loop_setup generates the scalarization setup code.
49 It determines the range of the scalarizing loop variables. If a temporary
50 is required, this is created and initialized. Code for scalar expressions
51 taken outside the loop is also generated at this time. Next the offset and
52 scaling required to translate from loop variables to array indices for each
55 A call to gfc_start_scalarized_body marks the start of the scalarized
56 expression. This creates a scope and declares the loop variables. Before
57 calling this gfc_make_ss_chain_used must be used to indicate which terms
58 will be used inside this loop.
60 The scalar gfc_conv_* functions are then used to build the main body of the
61 scalarization loop. Scalarization loop variables and precalculated scalar
62 values are automatically substituted. Note that gfc_advance_se_ss_chain
63 must be used, rather than changing the se->ss directly.
65 For assignment expressions requiring a temporary two sub loops are
66 generated. The first stores the result of the expression in the temporary,
67 the second copies it to the result. A call to
68 gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
69 the start of the copying loop. The temporary may be less than full rank.
71 Finally gfc_trans_scalarizing_loops is called to generate the implicit do
72 loops. The loops are added to the pre chain of the loopinfo. The post
73 chain may still contain cleanup code.
75 After the loop code has been added into its parent scope gfc_cleanup_loop
76 is called to free all the SS allocated by the scalarizer. */
80 #include "coretypes.h"
82 #include "gimple.h" /* For create_tmp_var_name. */
83 #include "diagnostic-core.h" /* For internal_error/fatal_error. */
86 #include "constructor.h"
88 #include "trans-stmt.h"
89 #include "trans-types.h"
90 #include "trans-array.h"
91 #include "trans-const.h"
92 #include "dependency.h"
94 static bool gfc_get_array_constructor_size (mpz_t
*, gfc_constructor_base
);
96 /* The contents of this structure aren't actually used, just the address. */
97 static gfc_ss gfc_ss_terminator_var
;
98 gfc_ss
* const gfc_ss_terminator
= &gfc_ss_terminator_var
;
102 gfc_array_dataptr_type (tree desc
)
104 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
)));
108 /* Build expressions to access the members of an array descriptor.
109 It's surprisingly easy to mess up here, so never access
110 an array descriptor by "brute force", always use these
111 functions. This also avoids problems if we change the format
112 of an array descriptor.
114 To understand these magic numbers, look at the comments
115 before gfc_build_array_type() in trans-types.c.
117 The code within these defines should be the only code which knows the format
118 of an array descriptor.
120 Any code just needing to read obtain the bounds of an array should use
121 gfc_conv_array_* rather than the following functions as these will return
122 know constant values, and work with arrays which do not have descriptors.
124 Don't forget to #undef these! */
127 #define OFFSET_FIELD 1
128 #define DTYPE_FIELD 2
129 #define DIMENSION_FIELD 3
130 #define CAF_TOKEN_FIELD 4
132 #define STRIDE_SUBFIELD 0
133 #define LBOUND_SUBFIELD 1
134 #define UBOUND_SUBFIELD 2
136 /* This provides READ-ONLY access to the data field. The field itself
137 doesn't have the proper type. */
140 gfc_conv_descriptor_data_get (tree desc
)
144 type
= TREE_TYPE (desc
);
145 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
147 field
= TYPE_FIELDS (type
);
148 gcc_assert (DATA_FIELD
== 0);
150 t
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
), desc
,
152 t
= fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type
), t
);
157 /* This provides WRITE access to the data field.
159 TUPLES_P is true if we are generating tuples.
161 This function gets called through the following macros:
162 gfc_conv_descriptor_data_set
163 gfc_conv_descriptor_data_set. */
166 gfc_conv_descriptor_data_set (stmtblock_t
*block
, tree desc
, tree value
)
170 type
= TREE_TYPE (desc
);
171 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
173 field
= TYPE_FIELDS (type
);
174 gcc_assert (DATA_FIELD
== 0);
176 t
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
), desc
,
178 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (field
), value
));
182 /* This provides address access to the data field. This should only be
183 used by array allocation, passing this on to the runtime. */
186 gfc_conv_descriptor_data_addr (tree desc
)
190 type
= TREE_TYPE (desc
);
191 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
193 field
= TYPE_FIELDS (type
);
194 gcc_assert (DATA_FIELD
== 0);
196 t
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
), desc
,
198 return gfc_build_addr_expr (NULL_TREE
, t
);
202 gfc_conv_descriptor_offset (tree desc
)
207 type
= TREE_TYPE (desc
);
208 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
210 field
= gfc_advance_chain (TYPE_FIELDS (type
), OFFSET_FIELD
);
211 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
213 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
214 desc
, field
, NULL_TREE
);
218 gfc_conv_descriptor_offset_get (tree desc
)
220 return gfc_conv_descriptor_offset (desc
);
224 gfc_conv_descriptor_offset_set (stmtblock_t
*block
, tree desc
,
227 tree t
= gfc_conv_descriptor_offset (desc
);
228 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
233 gfc_conv_descriptor_dtype (tree desc
)
238 type
= TREE_TYPE (desc
);
239 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
241 field
= gfc_advance_chain (TYPE_FIELDS (type
), DTYPE_FIELD
);
242 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
244 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
245 desc
, field
, NULL_TREE
);
250 gfc_conv_descriptor_rank (tree desc
)
255 dtype
= gfc_conv_descriptor_dtype (desc
);
256 tmp
= build_int_cst (TREE_TYPE (dtype
), GFC_DTYPE_RANK_MASK
);
257 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, TREE_TYPE (dtype
),
259 return fold_convert (gfc_get_int_type (gfc_default_integer_kind
), tmp
);
264 gfc_get_descriptor_dimension (tree desc
)
268 type
= TREE_TYPE (desc
);
269 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
271 field
= gfc_advance_chain (TYPE_FIELDS (type
), DIMENSION_FIELD
);
272 gcc_assert (field
!= NULL_TREE
273 && TREE_CODE (TREE_TYPE (field
)) == ARRAY_TYPE
274 && TREE_CODE (TREE_TYPE (TREE_TYPE (field
))) == RECORD_TYPE
);
276 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
277 desc
, field
, NULL_TREE
);
282 gfc_conv_descriptor_dimension (tree desc
, tree dim
)
286 tmp
= gfc_get_descriptor_dimension (desc
);
288 return gfc_build_array_ref (tmp
, dim
, NULL
);
293 gfc_conv_descriptor_token (tree desc
)
298 type
= TREE_TYPE (desc
);
299 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
300 gcc_assert (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ALLOCATABLE
);
301 gcc_assert (gfc_option
.coarray
== GFC_FCOARRAY_LIB
);
302 field
= gfc_advance_chain (TYPE_FIELDS (type
), CAF_TOKEN_FIELD
);
303 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == prvoid_type_node
);
305 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
306 desc
, field
, NULL_TREE
);
311 gfc_conv_descriptor_stride (tree desc
, tree dim
)
316 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
317 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
318 field
= gfc_advance_chain (field
, STRIDE_SUBFIELD
);
319 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
321 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
322 tmp
, field
, NULL_TREE
);
327 gfc_conv_descriptor_stride_get (tree desc
, tree dim
)
329 tree type
= TREE_TYPE (desc
);
330 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
331 if (integer_zerop (dim
)
332 && (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ALLOCATABLE
333 ||GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE_CONT
334 ||GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_RANK_CONT
335 ||GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER_CONT
))
336 return gfc_index_one_node
;
338 return gfc_conv_descriptor_stride (desc
, dim
);
342 gfc_conv_descriptor_stride_set (stmtblock_t
*block
, tree desc
,
343 tree dim
, tree value
)
345 tree t
= gfc_conv_descriptor_stride (desc
, dim
);
346 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
350 gfc_conv_descriptor_lbound (tree desc
, tree dim
)
355 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
356 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
357 field
= gfc_advance_chain (field
, LBOUND_SUBFIELD
);
358 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
360 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
361 tmp
, field
, NULL_TREE
);
366 gfc_conv_descriptor_lbound_get (tree desc
, tree dim
)
368 return gfc_conv_descriptor_lbound (desc
, dim
);
372 gfc_conv_descriptor_lbound_set (stmtblock_t
*block
, tree desc
,
373 tree dim
, tree value
)
375 tree t
= gfc_conv_descriptor_lbound (desc
, dim
);
376 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
380 gfc_conv_descriptor_ubound (tree desc
, tree dim
)
385 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
386 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
387 field
= gfc_advance_chain (field
, UBOUND_SUBFIELD
);
388 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
390 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
391 tmp
, field
, NULL_TREE
);
396 gfc_conv_descriptor_ubound_get (tree desc
, tree dim
)
398 return gfc_conv_descriptor_ubound (desc
, dim
);
402 gfc_conv_descriptor_ubound_set (stmtblock_t
*block
, tree desc
,
403 tree dim
, tree value
)
405 tree t
= gfc_conv_descriptor_ubound (desc
, dim
);
406 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
409 /* Build a null array descriptor constructor. */
412 gfc_build_null_descriptor (tree type
)
417 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
418 gcc_assert (DATA_FIELD
== 0);
419 field
= TYPE_FIELDS (type
);
421 /* Set a NULL data pointer. */
422 tmp
= build_constructor_single (type
, field
, null_pointer_node
);
423 TREE_CONSTANT (tmp
) = 1;
424 /* All other fields are ignored. */
430 /* Modify a descriptor such that the lbound of a given dimension is the value
431 specified. This also updates ubound and offset accordingly. */
434 gfc_conv_shift_descriptor_lbound (stmtblock_t
* block
, tree desc
,
435 int dim
, tree new_lbound
)
437 tree offs
, ubound
, lbound
, stride
;
438 tree diff
, offs_diff
;
440 new_lbound
= fold_convert (gfc_array_index_type
, new_lbound
);
442 offs
= gfc_conv_descriptor_offset_get (desc
);
443 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]);
444 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]);
445 stride
= gfc_conv_descriptor_stride_get (desc
, gfc_rank_cst
[dim
]);
447 /* Get difference (new - old) by which to shift stuff. */
448 diff
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
451 /* Shift ubound and offset accordingly. This has to be done before
452 updating the lbound, as they depend on the lbound expression! */
453 ubound
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
455 gfc_conv_descriptor_ubound_set (block
, desc
, gfc_rank_cst
[dim
], ubound
);
456 offs_diff
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
458 offs
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
460 gfc_conv_descriptor_offset_set (block
, desc
, offs
);
462 /* Finally set lbound to value we want. */
463 gfc_conv_descriptor_lbound_set (block
, desc
, gfc_rank_cst
[dim
], new_lbound
);
467 /* Cleanup those #defines. */
472 #undef DIMENSION_FIELD
473 #undef CAF_TOKEN_FIELD
474 #undef STRIDE_SUBFIELD
475 #undef LBOUND_SUBFIELD
476 #undef UBOUND_SUBFIELD
479 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
480 flags & 1 = Main loop body.
481 flags & 2 = temp copy loop. */
484 gfc_mark_ss_chain_used (gfc_ss
* ss
, unsigned flags
)
486 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
487 ss
->info
->useflags
= flags
;
491 /* Free a gfc_ss chain. */
494 gfc_free_ss_chain (gfc_ss
* ss
)
498 while (ss
!= gfc_ss_terminator
)
500 gcc_assert (ss
!= NULL
);
509 free_ss_info (gfc_ss_info
*ss_info
)
514 if (ss_info
->refcount
> 0)
517 gcc_assert (ss_info
->refcount
== 0);
519 switch (ss_info
->type
)
522 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
523 if (ss_info
->data
.array
.subscript
[n
])
524 gfc_free_ss_chain (ss_info
->data
.array
.subscript
[n
]);
538 gfc_free_ss (gfc_ss
* ss
)
540 free_ss_info (ss
->info
);
545 /* Creates and initializes an array type gfc_ss struct. */
548 gfc_get_array_ss (gfc_ss
*next
, gfc_expr
*expr
, int dimen
, gfc_ss_type type
)
551 gfc_ss_info
*ss_info
;
554 ss_info
= gfc_get_ss_info ();
556 ss_info
->type
= type
;
557 ss_info
->expr
= expr
;
563 for (i
= 0; i
< ss
->dimen
; i
++)
570 /* Creates and initializes a temporary type gfc_ss struct. */
573 gfc_get_temp_ss (tree type
, tree string_length
, int dimen
)
576 gfc_ss_info
*ss_info
;
579 ss_info
= gfc_get_ss_info ();
581 ss_info
->type
= GFC_SS_TEMP
;
582 ss_info
->string_length
= string_length
;
583 ss_info
->data
.temp
.type
= type
;
587 ss
->next
= gfc_ss_terminator
;
589 for (i
= 0; i
< ss
->dimen
; i
++)
596 /* Creates and initializes a scalar type gfc_ss struct. */
599 gfc_get_scalar_ss (gfc_ss
*next
, gfc_expr
*expr
)
602 gfc_ss_info
*ss_info
;
604 ss_info
= gfc_get_ss_info ();
606 ss_info
->type
= GFC_SS_SCALAR
;
607 ss_info
->expr
= expr
;
617 /* Free all the SS associated with a loop. */
620 gfc_cleanup_loop (gfc_loopinfo
* loop
)
622 gfc_loopinfo
*loop_next
, **ploop
;
627 while (ss
!= gfc_ss_terminator
)
629 gcc_assert (ss
!= NULL
);
630 next
= ss
->loop_chain
;
635 /* Remove reference to self in the parent loop. */
637 for (ploop
= &loop
->parent
->nested
; *ploop
; ploop
= &(*ploop
)->next
)
644 /* Free non-freed nested loops. */
645 for (loop
= loop
->nested
; loop
; loop
= loop_next
)
647 loop_next
= loop
->next
;
648 gfc_cleanup_loop (loop
);
655 set_ss_loop (gfc_ss
*ss
, gfc_loopinfo
*loop
)
659 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
663 if (ss
->info
->type
== GFC_SS_SCALAR
664 || ss
->info
->type
== GFC_SS_REFERENCE
665 || ss
->info
->type
== GFC_SS_TEMP
)
668 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
669 if (ss
->info
->data
.array
.subscript
[n
] != NULL
)
670 set_ss_loop (ss
->info
->data
.array
.subscript
[n
], loop
);
675 /* Associate a SS chain with a loop. */
678 gfc_add_ss_to_loop (gfc_loopinfo
* loop
, gfc_ss
* head
)
681 gfc_loopinfo
*nested_loop
;
683 if (head
== gfc_ss_terminator
)
686 set_ss_loop (head
, loop
);
689 for (; ss
&& ss
!= gfc_ss_terminator
; ss
= ss
->next
)
693 nested_loop
= ss
->nested_ss
->loop
;
695 /* More than one ss can belong to the same loop. Hence, we add the
696 loop to the chain only if it is different from the previously
697 added one, to avoid duplicate nested loops. */
698 if (nested_loop
!= loop
->nested
)
700 gcc_assert (nested_loop
->parent
== NULL
);
701 nested_loop
->parent
= loop
;
703 gcc_assert (nested_loop
->next
== NULL
);
704 nested_loop
->next
= loop
->nested
;
705 loop
->nested
= nested_loop
;
708 gcc_assert (nested_loop
->parent
== loop
);
711 if (ss
->next
== gfc_ss_terminator
)
712 ss
->loop_chain
= loop
->ss
;
714 ss
->loop_chain
= ss
->next
;
716 gcc_assert (ss
== gfc_ss_terminator
);
721 /* Generate an initializer for a static pointer or allocatable array. */
724 gfc_trans_static_array_pointer (gfc_symbol
* sym
)
728 gcc_assert (TREE_STATIC (sym
->backend_decl
));
729 /* Just zero the data member. */
730 type
= TREE_TYPE (sym
->backend_decl
);
731 DECL_INITIAL (sym
->backend_decl
) = gfc_build_null_descriptor (type
);
735 /* If the bounds of SE's loop have not yet been set, see if they can be
736 determined from array spec AS, which is the array spec of a called
737 function. MAPPING maps the callee's dummy arguments to the values
738 that the caller is passing. Add any initialization and finalization
742 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping
* mapping
,
743 gfc_se
* se
, gfc_array_spec
* as
)
745 int n
, dim
, total_dim
;
754 if (!as
|| as
->type
!= AS_EXPLICIT
)
757 for (ss
= se
->ss
; ss
; ss
= ss
->parent
)
759 total_dim
+= ss
->loop
->dimen
;
760 for (n
= 0; n
< ss
->loop
->dimen
; n
++)
762 /* The bound is known, nothing to do. */
763 if (ss
->loop
->to
[n
] != NULL_TREE
)
767 gcc_assert (dim
< as
->rank
);
768 gcc_assert (ss
->loop
->dimen
<= as
->rank
);
770 /* Evaluate the lower bound. */
771 gfc_init_se (&tmpse
, NULL
);
772 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->lower
[dim
]);
773 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
774 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
775 lower
= fold_convert (gfc_array_index_type
, tmpse
.expr
);
777 /* ...and the upper bound. */
778 gfc_init_se (&tmpse
, NULL
);
779 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->upper
[dim
]);
780 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
781 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
782 upper
= fold_convert (gfc_array_index_type
, tmpse
.expr
);
784 /* Set the upper bound of the loop to UPPER - LOWER. */
785 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
786 gfc_array_index_type
, upper
, lower
);
787 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
788 ss
->loop
->to
[n
] = tmp
;
792 gcc_assert (total_dim
== as
->rank
);
796 /* Generate code to allocate an array temporary, or create a variable to
797 hold the data. If size is NULL, zero the descriptor so that the
798 callee will allocate the array. If DEALLOC is true, also generate code to
799 free the array afterwards.
801 If INITIAL is not NULL, it is packed using internal_pack and the result used
802 as data instead of allocating a fresh, unitialized area of memory.
804 Initialization code is added to PRE and finalization code to POST.
805 DYNAMIC is true if the caller may want to extend the array later
806 using realloc. This prevents us from putting the array on the stack. */
809 gfc_trans_allocate_array_storage (stmtblock_t
* pre
, stmtblock_t
* post
,
810 gfc_array_info
* info
, tree size
, tree nelem
,
811 tree initial
, bool dynamic
, bool dealloc
)
817 desc
= info
->descriptor
;
818 info
->offset
= gfc_index_zero_node
;
819 if (size
== NULL_TREE
|| integer_zerop (size
))
821 /* A callee allocated array. */
822 gfc_conv_descriptor_data_set (pre
, desc
, null_pointer_node
);
827 /* Allocate the temporary. */
828 onstack
= !dynamic
&& initial
== NULL_TREE
829 && (gfc_option
.flag_stack_arrays
830 || gfc_can_put_var_on_stack (size
));
834 /* Make a temporary variable to hold the data. */
835 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (nelem
),
836 nelem
, gfc_index_one_node
);
837 tmp
= gfc_evaluate_now (tmp
, pre
);
838 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
840 tmp
= build_array_type (gfc_get_element_type (TREE_TYPE (desc
)),
842 tmp
= gfc_create_var (tmp
, "A");
843 /* If we're here only because of -fstack-arrays we have to
844 emit a DECL_EXPR to make the gimplifier emit alloca calls. */
845 if (!gfc_can_put_var_on_stack (size
))
846 gfc_add_expr_to_block (pre
,
847 fold_build1_loc (input_location
,
848 DECL_EXPR
, TREE_TYPE (tmp
),
850 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
851 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
855 /* Allocate memory to hold the data or call internal_pack. */
856 if (initial
== NULL_TREE
)
858 tmp
= gfc_call_malloc (pre
, NULL
, size
);
859 tmp
= gfc_evaluate_now (tmp
, pre
);
866 stmtblock_t do_copying
;
868 tmp
= TREE_TYPE (initial
); /* Pointer to descriptor. */
869 gcc_assert (TREE_CODE (tmp
) == POINTER_TYPE
);
870 tmp
= TREE_TYPE (tmp
); /* The descriptor itself. */
871 tmp
= gfc_get_element_type (tmp
);
872 gcc_assert (tmp
== gfc_get_element_type (TREE_TYPE (desc
)));
873 packed
= gfc_create_var (build_pointer_type (tmp
), "data");
875 tmp
= build_call_expr_loc (input_location
,
876 gfor_fndecl_in_pack
, 1, initial
);
877 tmp
= fold_convert (TREE_TYPE (packed
), tmp
);
878 gfc_add_modify (pre
, packed
, tmp
);
880 tmp
= build_fold_indirect_ref_loc (input_location
,
882 source_data
= gfc_conv_descriptor_data_get (tmp
);
884 /* internal_pack may return source->data without any allocation
885 or copying if it is already packed. If that's the case, we
886 need to allocate and copy manually. */
888 gfc_start_block (&do_copying
);
889 tmp
= gfc_call_malloc (&do_copying
, NULL
, size
);
890 tmp
= fold_convert (TREE_TYPE (packed
), tmp
);
891 gfc_add_modify (&do_copying
, packed
, tmp
);
892 tmp
= gfc_build_memcpy_call (packed
, source_data
, size
);
893 gfc_add_expr_to_block (&do_copying
, tmp
);
895 was_packed
= fold_build2_loc (input_location
, EQ_EXPR
,
896 boolean_type_node
, packed
,
898 tmp
= gfc_finish_block (&do_copying
);
899 tmp
= build3_v (COND_EXPR
, was_packed
, tmp
,
900 build_empty_stmt (input_location
));
901 gfc_add_expr_to_block (pre
, tmp
);
903 tmp
= fold_convert (pvoid_type_node
, packed
);
906 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
909 info
->data
= gfc_conv_descriptor_data_get (desc
);
911 /* The offset is zero because we create temporaries with a zero
913 gfc_conv_descriptor_offset_set (pre
, desc
, gfc_index_zero_node
);
915 if (dealloc
&& !onstack
)
917 /* Free the temporary. */
918 tmp
= gfc_conv_descriptor_data_get (desc
);
919 tmp
= gfc_call_free (fold_convert (pvoid_type_node
, tmp
));
920 gfc_add_expr_to_block (post
, tmp
);
925 /* Get the scalarizer array dimension corresponding to actual array dimension
928 For example, if SS represents the array ref a(1,:,:,1), it is a
929 bidimensional scalarizer array, and the result would be 0 for ARRAY_DIM=1,
930 and 1 for ARRAY_DIM=2.
931 If SS represents transpose(a(:,1,1,:)), it is again a bidimensional
932 scalarizer array, and the result would be 1 for ARRAY_DIM=0 and 0 for
934 If SS represents sum(a(:,:,:,1), dim=1), it is a 2+1-dimensional scalarizer
935 array. If called on the inner ss, the result would be respectively 0,1,2 for
936 ARRAY_DIM=0,1,2. If called on the outer ss, the result would be 0,1
937 for ARRAY_DIM=1,2. */
940 get_scalarizer_dim_for_array_dim (gfc_ss
*ss
, int array_dim
)
947 for (; ss
; ss
= ss
->parent
)
948 for (n
= 0; n
< ss
->dimen
; n
++)
949 if (ss
->dim
[n
] < array_dim
)
952 return array_ref_dim
;
957 innermost_ss (gfc_ss
*ss
)
959 while (ss
->nested_ss
!= NULL
)
967 /* Get the array reference dimension corresponding to the given loop dimension.
968 It is different from the true array dimension given by the dim array in
969 the case of a partial array reference (i.e. a(:,:,1,:) for example)
970 It is different from the loop dimension in the case of a transposed array.
974 get_array_ref_dim_for_loop_dim (gfc_ss
*ss
, int loop_dim
)
976 return get_scalarizer_dim_for_array_dim (innermost_ss (ss
),
981 /* Generate code to create and initialize the descriptor for a temporary
982 array. This is used for both temporaries needed by the scalarizer, and
983 functions returning arrays. Adjusts the loop variables to be
984 zero-based, and calculates the loop bounds for callee allocated arrays.
985 Allocate the array unless it's callee allocated (we have a callee
986 allocated array if 'callee_alloc' is true, or if loop->to[n] is
987 NULL_TREE for any n). Also fills in the descriptor, data and offset
988 fields of info if known. Returns the size of the array, or NULL for a
989 callee allocated array.
991 'eltype' == NULL signals that the temporary should be a class object.
992 The 'initial' expression is used to obtain the size of the dynamic
993 type; otherwise the allocation and initialisation proceeds as for any
996 PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
997 gfc_trans_allocate_array_storage. */
1000 gfc_trans_create_temp_array (stmtblock_t
* pre
, stmtblock_t
* post
, gfc_ss
* ss
,
1001 tree eltype
, tree initial
, bool dynamic
,
1002 bool dealloc
, bool callee_alloc
, locus
* where
)
1006 gfc_array_info
*info
;
1007 tree from
[GFC_MAX_DIMENSIONS
], to
[GFC_MAX_DIMENSIONS
];
1015 tree class_expr
= NULL_TREE
;
1016 int n
, dim
, tmp_dim
;
1019 /* This signals a class array for which we need the size of the
1020 dynamic type. Generate an eltype and then the class expression. */
1021 if (eltype
== NULL_TREE
&& initial
)
1023 gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial
)));
1024 class_expr
= build_fold_indirect_ref_loc (input_location
, initial
);
1025 eltype
= TREE_TYPE (class_expr
);
1026 eltype
= gfc_get_element_type (eltype
);
1027 /* Obtain the structure (class) expression. */
1028 class_expr
= TREE_OPERAND (class_expr
, 0);
1029 gcc_assert (class_expr
);
1032 memset (from
, 0, sizeof (from
));
1033 memset (to
, 0, sizeof (to
));
1035 info
= &ss
->info
->data
.array
;
1037 gcc_assert (ss
->dimen
> 0);
1038 gcc_assert (ss
->loop
->dimen
== ss
->dimen
);
1040 if (gfc_option
.warn_array_temp
&& where
)
1041 gfc_warning ("Creating array temporary at %L", where
);
1043 /* Set the lower bound to zero. */
1044 for (s
= ss
; s
; s
= s
->parent
)
1048 total_dim
+= loop
->dimen
;
1049 for (n
= 0; n
< loop
->dimen
; n
++)
1053 /* Callee allocated arrays may not have a known bound yet. */
1055 loop
->to
[n
] = gfc_evaluate_now (
1056 fold_build2_loc (input_location
, MINUS_EXPR
,
1057 gfc_array_index_type
,
1058 loop
->to
[n
], loop
->from
[n
]),
1060 loop
->from
[n
] = gfc_index_zero_node
;
1062 /* We have just changed the loop bounds, we must clear the
1063 corresponding specloop, so that delta calculation is not skipped
1064 later in gfc_set_delta. */
1065 loop
->specloop
[n
] = NULL
;
1067 /* We are constructing the temporary's descriptor based on the loop
1068 dimensions. As the dimensions may be accessed in arbitrary order
1069 (think of transpose) the size taken from the n'th loop may not map
1070 to the n'th dimension of the array. We need to reconstruct loop
1071 infos in the right order before using it to set the descriptor
1073 tmp_dim
= get_scalarizer_dim_for_array_dim (ss
, dim
);
1074 from
[tmp_dim
] = loop
->from
[n
];
1075 to
[tmp_dim
] = loop
->to
[n
];
1077 info
->delta
[dim
] = gfc_index_zero_node
;
1078 info
->start
[dim
] = gfc_index_zero_node
;
1079 info
->end
[dim
] = gfc_index_zero_node
;
1080 info
->stride
[dim
] = gfc_index_one_node
;
1084 /* Initialize the descriptor. */
1086 gfc_get_array_type_bounds (eltype
, total_dim
, 0, from
, to
, 1,
1087 GFC_ARRAY_UNKNOWN
, true);
1088 desc
= gfc_create_var (type
, "atmp");
1089 GFC_DECL_PACKED_ARRAY (desc
) = 1;
1091 info
->descriptor
= desc
;
1092 size
= gfc_index_one_node
;
1094 /* Fill in the array dtype. */
1095 tmp
= gfc_conv_descriptor_dtype (desc
);
1096 gfc_add_modify (pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
1099 Fill in the bounds and stride. This is a packed array, so:
1102 for (n = 0; n < rank; n++)
1105 delta = ubound[n] + 1 - lbound[n];
1106 size = size * delta;
1108 size = size * sizeof(element);
1111 or_expr
= NULL_TREE
;
1113 /* If there is at least one null loop->to[n], it is a callee allocated
1115 for (n
= 0; n
< total_dim
; n
++)
1116 if (to
[n
] == NULL_TREE
)
1122 if (size
== NULL_TREE
)
1123 for (s
= ss
; s
; s
= s
->parent
)
1124 for (n
= 0; n
< s
->loop
->dimen
; n
++)
1126 dim
= get_scalarizer_dim_for_array_dim (ss
, s
->dim
[n
]);
1128 /* For a callee allocated array express the loop bounds in terms
1129 of the descriptor fields. */
1130 tmp
= fold_build2_loc (input_location
,
1131 MINUS_EXPR
, gfc_array_index_type
,
1132 gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]),
1133 gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]));
1134 s
->loop
->to
[n
] = tmp
;
1138 for (n
= 0; n
< total_dim
; n
++)
1140 /* Store the stride and bound components in the descriptor. */
1141 gfc_conv_descriptor_stride_set (pre
, desc
, gfc_rank_cst
[n
], size
);
1143 gfc_conv_descriptor_lbound_set (pre
, desc
, gfc_rank_cst
[n
],
1144 gfc_index_zero_node
);
1146 gfc_conv_descriptor_ubound_set (pre
, desc
, gfc_rank_cst
[n
], to
[n
]);
1148 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1149 gfc_array_index_type
,
1150 to
[n
], gfc_index_one_node
);
1152 /* Check whether the size for this dimension is negative. */
1153 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
1154 tmp
, gfc_index_zero_node
);
1155 cond
= gfc_evaluate_now (cond
, pre
);
1160 or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1161 boolean_type_node
, or_expr
, cond
);
1163 size
= fold_build2_loc (input_location
, MULT_EXPR
,
1164 gfc_array_index_type
, size
, tmp
);
1165 size
= gfc_evaluate_now (size
, pre
);
1169 /* Get the size of the array. */
1170 if (size
&& !callee_alloc
)
1173 /* If or_expr is true, then the extent in at least one
1174 dimension is zero and the size is set to zero. */
1175 size
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
1176 or_expr
, gfc_index_zero_node
, size
);
1179 if (class_expr
== NULL_TREE
)
1180 elemsize
= fold_convert (gfc_array_index_type
,
1181 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
1183 elemsize
= gfc_vtable_size_get (class_expr
);
1185 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
1194 gfc_trans_allocate_array_storage (pre
, post
, info
, size
, nelem
, initial
,
1200 if (ss
->dimen
> ss
->loop
->temp_dim
)
1201 ss
->loop
->temp_dim
= ss
->dimen
;
1207 /* Return the number of iterations in a loop that starts at START,
1208 ends at END, and has step STEP. */
1211 gfc_get_iteration_count (tree start
, tree end
, tree step
)
1216 type
= TREE_TYPE (step
);
1217 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, end
, start
);
1218 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
, type
, tmp
, step
);
1219 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
,
1220 build_int_cst (type
, 1));
1221 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, type
, tmp
,
1222 build_int_cst (type
, 0));
1223 return fold_convert (gfc_array_index_type
, tmp
);
1227 /* Extend the data in array DESC by EXTRA elements. */
1230 gfc_grow_array (stmtblock_t
* pblock
, tree desc
, tree extra
)
1237 if (integer_zerop (extra
))
1240 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[0]);
1242 /* Add EXTRA to the upper bound. */
1243 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1245 gfc_conv_descriptor_ubound_set (pblock
, desc
, gfc_rank_cst
[0], tmp
);
1247 /* Get the value of the current data pointer. */
1248 arg0
= gfc_conv_descriptor_data_get (desc
);
1250 /* Calculate the new array size. */
1251 size
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
1252 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1253 ubound
, gfc_index_one_node
);
1254 arg1
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
1255 fold_convert (size_type_node
, tmp
),
1256 fold_convert (size_type_node
, size
));
1258 /* Call the realloc() function. */
1259 tmp
= gfc_call_realloc (pblock
, arg0
, arg1
);
1260 gfc_conv_descriptor_data_set (pblock
, desc
, tmp
);
1264 /* Return true if the bounds of iterator I can only be determined
1268 gfc_iterator_has_dynamic_bounds (gfc_iterator
* i
)
1270 return (i
->start
->expr_type
!= EXPR_CONSTANT
1271 || i
->end
->expr_type
!= EXPR_CONSTANT
1272 || i
->step
->expr_type
!= EXPR_CONSTANT
);
1276 /* Split the size of constructor element EXPR into the sum of two terms,
1277 one of which can be determined at compile time and one of which must
1278 be calculated at run time. Set *SIZE to the former and return true
1279 if the latter might be nonzero. */
1282 gfc_get_array_constructor_element_size (mpz_t
* size
, gfc_expr
* expr
)
1284 if (expr
->expr_type
== EXPR_ARRAY
)
1285 return gfc_get_array_constructor_size (size
, expr
->value
.constructor
);
1286 else if (expr
->rank
> 0)
1288 /* Calculate everything at run time. */
1289 mpz_set_ui (*size
, 0);
1294 /* A single element. */
1295 mpz_set_ui (*size
, 1);
1301 /* Like gfc_get_array_constructor_element_size, but applied to the whole
1302 of array constructor C. */
1305 gfc_get_array_constructor_size (mpz_t
* size
, gfc_constructor_base base
)
1313 mpz_set_ui (*size
, 0);
1318 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1321 if (i
&& gfc_iterator_has_dynamic_bounds (i
))
1325 dynamic
|= gfc_get_array_constructor_element_size (&len
, c
->expr
);
1328 /* Multiply the static part of the element size by the
1329 number of iterations. */
1330 mpz_sub (val
, i
->end
->value
.integer
, i
->start
->value
.integer
);
1331 mpz_fdiv_q (val
, val
, i
->step
->value
.integer
);
1332 mpz_add_ui (val
, val
, 1);
1333 if (mpz_sgn (val
) > 0)
1334 mpz_mul (len
, len
, val
);
1336 mpz_set_ui (len
, 0);
1338 mpz_add (*size
, *size
, len
);
1347 /* Make sure offset is a variable. */
1350 gfc_put_offset_into_var (stmtblock_t
* pblock
, tree
* poffset
,
1353 /* We should have already created the offset variable. We cannot
1354 create it here because we may be in an inner scope. */
1355 gcc_assert (*offsetvar
!= NULL_TREE
);
1356 gfc_add_modify (pblock
, *offsetvar
, *poffset
);
1357 *poffset
= *offsetvar
;
1358 TREE_USED (*offsetvar
) = 1;
1362 /* Variables needed for bounds-checking. */
1363 static bool first_len
;
1364 static tree first_len_val
;
1365 static bool typespec_chararray_ctor
;
1368 gfc_trans_array_ctor_element (stmtblock_t
* pblock
, tree desc
,
1369 tree offset
, gfc_se
* se
, gfc_expr
* expr
)
1373 gfc_conv_expr (se
, expr
);
1375 /* Store the value. */
1376 tmp
= build_fold_indirect_ref_loc (input_location
,
1377 gfc_conv_descriptor_data_get (desc
));
1378 tmp
= gfc_build_array_ref (tmp
, offset
, NULL
);
1380 if (expr
->ts
.type
== BT_CHARACTER
)
1382 int i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
1385 esize
= size_in_bytes (gfc_get_element_type (TREE_TYPE (desc
)));
1386 esize
= fold_convert (gfc_charlen_type_node
, esize
);
1387 esize
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1388 gfc_charlen_type_node
, esize
,
1389 build_int_cst (gfc_charlen_type_node
,
1390 gfc_character_kinds
[i
].bit_size
/ 8));
1392 gfc_conv_string_parameter (se
);
1393 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
1395 /* The temporary is an array of pointers. */
1396 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1397 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1401 /* The temporary is an array of string values. */
1402 tmp
= gfc_build_addr_expr (gfc_get_pchar_type (expr
->ts
.kind
), tmp
);
1403 /* We know the temporary and the value will be the same length,
1404 so can use memcpy. */
1405 gfc_trans_string_copy (&se
->pre
, esize
, tmp
, expr
->ts
.kind
,
1406 se
->string_length
, se
->expr
, expr
->ts
.kind
);
1408 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && !typespec_chararray_ctor
)
1412 gfc_add_modify (&se
->pre
, first_len_val
,
1418 /* Verify that all constructor elements are of the same
1420 tree cond
= fold_build2_loc (input_location
, NE_EXPR
,
1421 boolean_type_node
, first_len_val
,
1423 gfc_trans_runtime_check
1424 (true, false, cond
, &se
->pre
, &expr
->where
,
1425 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1426 fold_convert (long_integer_type_node
, first_len_val
),
1427 fold_convert (long_integer_type_node
, se
->string_length
));
1433 /* TODO: Should the frontend already have done this conversion? */
1434 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1435 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1438 gfc_add_block_to_block (pblock
, &se
->pre
);
1439 gfc_add_block_to_block (pblock
, &se
->post
);
1443 /* Add the contents of an array to the constructor. DYNAMIC is as for
1444 gfc_trans_array_constructor_value. */
1447 gfc_trans_array_constructor_subarray (stmtblock_t
* pblock
,
1448 tree type ATTRIBUTE_UNUSED
,
1449 tree desc
, gfc_expr
* expr
,
1450 tree
* poffset
, tree
* offsetvar
,
1461 /* We need this to be a variable so we can increment it. */
1462 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1464 gfc_init_se (&se
, NULL
);
1466 /* Walk the array expression. */
1467 ss
= gfc_walk_expr (expr
);
1468 gcc_assert (ss
!= gfc_ss_terminator
);
1470 /* Initialize the scalarizer. */
1471 gfc_init_loopinfo (&loop
);
1472 gfc_add_ss_to_loop (&loop
, ss
);
1474 /* Initialize the loop. */
1475 gfc_conv_ss_startstride (&loop
);
1476 gfc_conv_loop_setup (&loop
, &expr
->where
);
1478 /* Make sure the constructed array has room for the new data. */
1481 /* Set SIZE to the total number of elements in the subarray. */
1482 size
= gfc_index_one_node
;
1483 for (n
= 0; n
< loop
.dimen
; n
++)
1485 tmp
= gfc_get_iteration_count (loop
.from
[n
], loop
.to
[n
],
1486 gfc_index_one_node
);
1487 size
= fold_build2_loc (input_location
, MULT_EXPR
,
1488 gfc_array_index_type
, size
, tmp
);
1491 /* Grow the constructed array by SIZE elements. */
1492 gfc_grow_array (&loop
.pre
, desc
, size
);
1495 /* Make the loop body. */
1496 gfc_mark_ss_chain_used (ss
, 1);
1497 gfc_start_scalarized_body (&loop
, &body
);
1498 gfc_copy_loopinfo_to_se (&se
, &loop
);
1501 gfc_trans_array_ctor_element (&body
, desc
, *poffset
, &se
, expr
);
1502 gcc_assert (se
.ss
== gfc_ss_terminator
);
1504 /* Increment the offset. */
1505 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1506 *poffset
, gfc_index_one_node
);
1507 gfc_add_modify (&body
, *poffset
, tmp
);
1509 /* Finish the loop. */
1510 gfc_trans_scalarizing_loops (&loop
, &body
);
1511 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
1512 tmp
= gfc_finish_block (&loop
.pre
);
1513 gfc_add_expr_to_block (pblock
, tmp
);
1515 gfc_cleanup_loop (&loop
);
1519 /* Assign the values to the elements of an array constructor. DYNAMIC
1520 is true if descriptor DESC only contains enough data for the static
1521 size calculated by gfc_get_array_constructor_size. When true, memory
1522 for the dynamic parts must be allocated using realloc. */
1525 gfc_trans_array_constructor_value (stmtblock_t
* pblock
, tree type
,
1526 tree desc
, gfc_constructor_base base
,
1527 tree
* poffset
, tree
* offsetvar
,
1531 tree start
= NULL_TREE
;
1532 tree end
= NULL_TREE
;
1533 tree step
= NULL_TREE
;
1539 tree shadow_loopvar
= NULL_TREE
;
1540 gfc_saved_var saved_loopvar
;
1543 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1545 /* If this is an iterator or an array, the offset must be a variable. */
1546 if ((c
->iterator
|| c
->expr
->rank
> 0) && INTEGER_CST_P (*poffset
))
1547 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1549 /* Shadowing the iterator avoids changing its value and saves us from
1550 keeping track of it. Further, it makes sure that there's always a
1551 backend-decl for the symbol, even if there wasn't one before,
1552 e.g. in the case of an iterator that appears in a specification
1553 expression in an interface mapping. */
1559 /* Evaluate loop bounds before substituting the loop variable
1560 in case they depend on it. Such a case is invalid, but it is
1561 not more expensive to do the right thing here.
1563 gfc_init_se (&se
, NULL
);
1564 gfc_conv_expr_val (&se
, c
->iterator
->start
);
1565 gfc_add_block_to_block (pblock
, &se
.pre
);
1566 start
= gfc_evaluate_now (se
.expr
, pblock
);
1568 gfc_init_se (&se
, NULL
);
1569 gfc_conv_expr_val (&se
, c
->iterator
->end
);
1570 gfc_add_block_to_block (pblock
, &se
.pre
);
1571 end
= gfc_evaluate_now (se
.expr
, pblock
);
1573 gfc_init_se (&se
, NULL
);
1574 gfc_conv_expr_val (&se
, c
->iterator
->step
);
1575 gfc_add_block_to_block (pblock
, &se
.pre
);
1576 step
= gfc_evaluate_now (se
.expr
, pblock
);
1578 sym
= c
->iterator
->var
->symtree
->n
.sym
;
1579 type
= gfc_typenode_for_spec (&sym
->ts
);
1581 shadow_loopvar
= gfc_create_var (type
, "shadow_loopvar");
1582 gfc_shadow_sym (sym
, shadow_loopvar
, &saved_loopvar
);
1585 gfc_start_block (&body
);
1587 if (c
->expr
->expr_type
== EXPR_ARRAY
)
1589 /* Array constructors can be nested. */
1590 gfc_trans_array_constructor_value (&body
, type
, desc
,
1591 c
->expr
->value
.constructor
,
1592 poffset
, offsetvar
, dynamic
);
1594 else if (c
->expr
->rank
> 0)
1596 gfc_trans_array_constructor_subarray (&body
, type
, desc
, c
->expr
,
1597 poffset
, offsetvar
, dynamic
);
1601 /* This code really upsets the gimplifier so don't bother for now. */
1608 while (p
&& !(p
->iterator
|| p
->expr
->expr_type
!= EXPR_CONSTANT
))
1610 p
= gfc_constructor_next (p
);
1615 /* Scalar values. */
1616 gfc_init_se (&se
, NULL
);
1617 gfc_trans_array_ctor_element (&body
, desc
, *poffset
,
1620 *poffset
= fold_build2_loc (input_location
, PLUS_EXPR
,
1621 gfc_array_index_type
,
1622 *poffset
, gfc_index_one_node
);
1626 /* Collect multiple scalar constants into a constructor. */
1627 vec
<constructor_elt
, va_gc
> *v
= NULL
;
1631 HOST_WIDE_INT idx
= 0;
1634 /* Count the number of consecutive scalar constants. */
1635 while (p
&& !(p
->iterator
1636 || p
->expr
->expr_type
!= EXPR_CONSTANT
))
1638 gfc_init_se (&se
, NULL
);
1639 gfc_conv_constant (&se
, p
->expr
);
1641 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
1642 se
.expr
= fold_convert (type
, se
.expr
);
1643 /* For constant character array constructors we build
1644 an array of pointers. */
1645 else if (POINTER_TYPE_P (type
))
1646 se
.expr
= gfc_build_addr_expr
1647 (gfc_get_pchar_type (p
->expr
->ts
.kind
),
1650 CONSTRUCTOR_APPEND_ELT (v
,
1651 build_int_cst (gfc_array_index_type
,
1655 p
= gfc_constructor_next (p
);
1658 bound
= size_int (n
- 1);
1659 /* Create an array type to hold them. */
1660 tmptype
= build_range_type (gfc_array_index_type
,
1661 gfc_index_zero_node
, bound
);
1662 tmptype
= build_array_type (type
, tmptype
);
1664 init
= build_constructor (tmptype
, v
);
1665 TREE_CONSTANT (init
) = 1;
1666 TREE_STATIC (init
) = 1;
1667 /* Create a static variable to hold the data. */
1668 tmp
= gfc_create_var (tmptype
, "data");
1669 TREE_STATIC (tmp
) = 1;
1670 TREE_CONSTANT (tmp
) = 1;
1671 TREE_READONLY (tmp
) = 1;
1672 DECL_INITIAL (tmp
) = init
;
1675 /* Use BUILTIN_MEMCPY to assign the values. */
1676 tmp
= gfc_conv_descriptor_data_get (desc
);
1677 tmp
= build_fold_indirect_ref_loc (input_location
,
1679 tmp
= gfc_build_array_ref (tmp
, *poffset
, NULL
);
1680 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1681 init
= gfc_build_addr_expr (NULL_TREE
, init
);
1683 size
= TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type
));
1684 bound
= build_int_cst (size_type_node
, n
* size
);
1685 tmp
= build_call_expr_loc (input_location
,
1686 builtin_decl_explicit (BUILT_IN_MEMCPY
),
1687 3, tmp
, init
, bound
);
1688 gfc_add_expr_to_block (&body
, tmp
);
1690 *poffset
= fold_build2_loc (input_location
, PLUS_EXPR
,
1691 gfc_array_index_type
, *poffset
,
1692 build_int_cst (gfc_array_index_type
, n
));
1694 if (!INTEGER_CST_P (*poffset
))
1696 gfc_add_modify (&body
, *offsetvar
, *poffset
);
1697 *poffset
= *offsetvar
;
1701 /* The frontend should already have done any expansions
1705 /* Pass the code as is. */
1706 tmp
= gfc_finish_block (&body
);
1707 gfc_add_expr_to_block (pblock
, tmp
);
1711 /* Build the implied do-loop. */
1712 stmtblock_t implied_do_block
;
1718 loopbody
= gfc_finish_block (&body
);
1720 /* Create a new block that holds the implied-do loop. A temporary
1721 loop-variable is used. */
1722 gfc_start_block(&implied_do_block
);
1724 /* Initialize the loop. */
1725 gfc_add_modify (&implied_do_block
, shadow_loopvar
, start
);
1727 /* If this array expands dynamically, and the number of iterations
1728 is not constant, we won't have allocated space for the static
1729 part of C->EXPR's size. Do that now. */
1730 if (dynamic
&& gfc_iterator_has_dynamic_bounds (c
->iterator
))
1732 /* Get the number of iterations. */
1733 tmp
= gfc_get_iteration_count (shadow_loopvar
, end
, step
);
1735 /* Get the static part of C->EXPR's size. */
1736 gfc_get_array_constructor_element_size (&size
, c
->expr
);
1737 tmp2
= gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
1739 /* Grow the array by TMP * TMP2 elements. */
1740 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
1741 gfc_array_index_type
, tmp
, tmp2
);
1742 gfc_grow_array (&implied_do_block
, desc
, tmp
);
1745 /* Generate the loop body. */
1746 exit_label
= gfc_build_label_decl (NULL_TREE
);
1747 gfc_start_block (&body
);
1749 /* Generate the exit condition. Depending on the sign of
1750 the step variable we have to generate the correct
1752 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1753 step
, build_int_cst (TREE_TYPE (step
), 0));
1754 cond
= fold_build3_loc (input_location
, COND_EXPR
,
1755 boolean_type_node
, tmp
,
1756 fold_build2_loc (input_location
, GT_EXPR
,
1757 boolean_type_node
, shadow_loopvar
, end
),
1758 fold_build2_loc (input_location
, LT_EXPR
,
1759 boolean_type_node
, shadow_loopvar
, end
));
1760 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1761 TREE_USED (exit_label
) = 1;
1762 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
1763 build_empty_stmt (input_location
));
1764 gfc_add_expr_to_block (&body
, tmp
);
1766 /* The main loop body. */
1767 gfc_add_expr_to_block (&body
, loopbody
);
1769 /* Increase loop variable by step. */
1770 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1771 TREE_TYPE (shadow_loopvar
), shadow_loopvar
,
1773 gfc_add_modify (&body
, shadow_loopvar
, tmp
);
1775 /* Finish the loop. */
1776 tmp
= gfc_finish_block (&body
);
1777 tmp
= build1_v (LOOP_EXPR
, tmp
);
1778 gfc_add_expr_to_block (&implied_do_block
, tmp
);
1780 /* Add the exit label. */
1781 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1782 gfc_add_expr_to_block (&implied_do_block
, tmp
);
1784 /* Finish the implied-do loop. */
1785 tmp
= gfc_finish_block(&implied_do_block
);
1786 gfc_add_expr_to_block(pblock
, tmp
);
1788 gfc_restore_sym (c
->iterator
->var
->symtree
->n
.sym
, &saved_loopvar
);
1795 /* A catch-all to obtain the string length for anything that is not
1796 a substring of non-constant length, a constant, array or variable. */
1799 get_array_ctor_all_strlen (stmtblock_t
*block
, gfc_expr
*e
, tree
*len
)
1803 /* Don't bother if we already know the length is a constant. */
1804 if (*len
&& INTEGER_CST_P (*len
))
1807 if (!e
->ref
&& e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
1808 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1811 gfc_conv_const_charlen (e
->ts
.u
.cl
);
1812 *len
= e
->ts
.u
.cl
->backend_decl
;
1816 /* Otherwise, be brutal even if inefficient. */
1817 gfc_init_se (&se
, NULL
);
1819 /* No function call, in case of side effects. */
1820 se
.no_function_call
= 1;
1822 gfc_conv_expr (&se
, e
);
1824 gfc_conv_expr_descriptor (&se
, e
);
1826 /* Fix the value. */
1827 *len
= gfc_evaluate_now (se
.string_length
, &se
.pre
);
1829 gfc_add_block_to_block (block
, &se
.pre
);
1830 gfc_add_block_to_block (block
, &se
.post
);
1832 e
->ts
.u
.cl
->backend_decl
= *len
;
1837 /* Figure out the string length of a variable reference expression.
1838 Used by get_array_ctor_strlen. */
1841 get_array_ctor_var_strlen (stmtblock_t
*block
, gfc_expr
* expr
, tree
* len
)
1847 /* Don't bother if we already know the length is a constant. */
1848 if (*len
&& INTEGER_CST_P (*len
))
1851 ts
= &expr
->symtree
->n
.sym
->ts
;
1852 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1857 /* Array references don't change the string length. */
1861 /* Use the length of the component. */
1862 ts
= &ref
->u
.c
.component
->ts
;
1866 if (ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1867 || ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1869 /* Note that this might evaluate expr. */
1870 get_array_ctor_all_strlen (block
, expr
, len
);
1873 mpz_init_set_ui (char_len
, 1);
1874 mpz_add (char_len
, char_len
, ref
->u
.ss
.end
->value
.integer
);
1875 mpz_sub (char_len
, char_len
, ref
->u
.ss
.start
->value
.integer
);
1876 *len
= gfc_conv_mpz_to_tree (char_len
, gfc_default_integer_kind
);
1877 *len
= convert (gfc_charlen_type_node
, *len
);
1878 mpz_clear (char_len
);
1886 *len
= ts
->u
.cl
->backend_decl
;
1890 /* Figure out the string length of a character array constructor.
1891 If len is NULL, don't calculate the length; this happens for recursive calls
1892 when a sub-array-constructor is an element but not at the first position,
1893 so when we're not interested in the length.
1894 Returns TRUE if all elements are character constants. */
1897 get_array_ctor_strlen (stmtblock_t
*block
, gfc_constructor_base base
, tree
* len
)
1904 if (gfc_constructor_first (base
) == NULL
)
1907 *len
= build_int_cstu (gfc_charlen_type_node
, 0);
1911 /* Loop over all constructor elements to find out is_const, but in len we
1912 want to store the length of the first, not the last, element. We can
1913 of course exit the loop as soon as is_const is found to be false. */
1914 for (c
= gfc_constructor_first (base
);
1915 c
&& is_const
; c
= gfc_constructor_next (c
))
1917 switch (c
->expr
->expr_type
)
1920 if (len
&& !(*len
&& INTEGER_CST_P (*len
)))
1921 *len
= build_int_cstu (gfc_charlen_type_node
,
1922 c
->expr
->value
.character
.length
);
1926 if (!get_array_ctor_strlen (block
, c
->expr
->value
.constructor
, len
))
1933 get_array_ctor_var_strlen (block
, c
->expr
, len
);
1939 get_array_ctor_all_strlen (block
, c
->expr
, len
);
1943 /* After the first iteration, we don't want the length modified. */
1950 /* Check whether the array constructor C consists entirely of constant
1951 elements, and if so returns the number of those elements, otherwise
1952 return zero. Note, an empty or NULL array constructor returns zero. */
1954 unsigned HOST_WIDE_INT
1955 gfc_constant_array_constructor_p (gfc_constructor_base base
)
1957 unsigned HOST_WIDE_INT nelem
= 0;
1959 gfc_constructor
*c
= gfc_constructor_first (base
);
1963 || c
->expr
->rank
> 0
1964 || c
->expr
->expr_type
!= EXPR_CONSTANT
)
1966 c
= gfc_constructor_next (c
);
1973 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1974 and the tree type of it's elements, TYPE, return a static constant
1975 variable that is compile-time initialized. */
1978 gfc_build_constant_array_constructor (gfc_expr
* expr
, tree type
)
1980 tree tmptype
, init
, tmp
;
1981 HOST_WIDE_INT nelem
;
1986 vec
<constructor_elt
, va_gc
> *v
= NULL
;
1988 /* First traverse the constructor list, converting the constants
1989 to tree to build an initializer. */
1991 c
= gfc_constructor_first (expr
->value
.constructor
);
1994 gfc_init_se (&se
, NULL
);
1995 gfc_conv_constant (&se
, c
->expr
);
1996 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
1997 se
.expr
= fold_convert (type
, se
.expr
);
1998 else if (POINTER_TYPE_P (type
))
1999 se
.expr
= gfc_build_addr_expr (gfc_get_pchar_type (c
->expr
->ts
.kind
),
2001 CONSTRUCTOR_APPEND_ELT (v
, build_int_cst (gfc_array_index_type
, nelem
),
2003 c
= gfc_constructor_next (c
);
2007 /* Next determine the tree type for the array. We use the gfortran
2008 front-end's gfc_get_nodesc_array_type in order to create a suitable
2009 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
2011 memset (&as
, 0, sizeof (gfc_array_spec
));
2013 as
.rank
= expr
->rank
;
2014 as
.type
= AS_EXPLICIT
;
2017 as
.lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2018 as
.upper
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
2022 for (i
= 0; i
< expr
->rank
; i
++)
2024 int tmp
= (int) mpz_get_si (expr
->shape
[i
]);
2025 as
.lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2026 as
.upper
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
2030 tmptype
= gfc_get_nodesc_array_type (type
, &as
, PACKED_STATIC
, true);
2032 /* as is not needed anymore. */
2033 for (i
= 0; i
< as
.rank
+ as
.corank
; i
++)
2035 gfc_free_expr (as
.lower
[i
]);
2036 gfc_free_expr (as
.upper
[i
]);
2039 init
= build_constructor (tmptype
, v
);
2041 TREE_CONSTANT (init
) = 1;
2042 TREE_STATIC (init
) = 1;
2044 tmp
= gfc_create_var (tmptype
, "A");
2045 TREE_STATIC (tmp
) = 1;
2046 TREE_CONSTANT (tmp
) = 1;
2047 TREE_READONLY (tmp
) = 1;
2048 DECL_INITIAL (tmp
) = init
;
2054 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
2055 This mostly initializes the scalarizer state info structure with the
2056 appropriate values to directly use the array created by the function
2057 gfc_build_constant_array_constructor. */
2060 trans_constant_array_constructor (gfc_ss
* ss
, tree type
)
2062 gfc_array_info
*info
;
2066 tmp
= gfc_build_constant_array_constructor (ss
->info
->expr
, type
);
2068 info
= &ss
->info
->data
.array
;
2070 info
->descriptor
= tmp
;
2071 info
->data
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2072 info
->offset
= gfc_index_zero_node
;
2074 for (i
= 0; i
< ss
->dimen
; i
++)
2076 info
->delta
[i
] = gfc_index_zero_node
;
2077 info
->start
[i
] = gfc_index_zero_node
;
2078 info
->end
[i
] = gfc_index_zero_node
;
2079 info
->stride
[i
] = gfc_index_one_node
;
2085 get_rank (gfc_loopinfo
*loop
)
2090 for (; loop
; loop
= loop
->parent
)
2091 rank
+= loop
->dimen
;
2097 /* Helper routine of gfc_trans_array_constructor to determine if the
2098 bounds of the loop specified by LOOP are constant and simple enough
2099 to use with trans_constant_array_constructor. Returns the
2100 iteration count of the loop if suitable, and NULL_TREE otherwise. */
2103 constant_array_constructor_loop_size (gfc_loopinfo
* l
)
2106 tree size
= gfc_index_one_node
;
2110 total_dim
= get_rank (l
);
2112 for (loop
= l
; loop
; loop
= loop
->parent
)
2114 for (i
= 0; i
< loop
->dimen
; i
++)
2116 /* If the bounds aren't constant, return NULL_TREE. */
2117 if (!INTEGER_CST_P (loop
->from
[i
]) || !INTEGER_CST_P (loop
->to
[i
]))
2119 if (!integer_zerop (loop
->from
[i
]))
2121 /* Only allow nonzero "from" in one-dimensional arrays. */
2124 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2125 gfc_array_index_type
,
2126 loop
->to
[i
], loop
->from
[i
]);
2130 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2131 gfc_array_index_type
, tmp
, gfc_index_one_node
);
2132 size
= fold_build2_loc (input_location
, MULT_EXPR
,
2133 gfc_array_index_type
, size
, tmp
);
2142 get_loop_upper_bound_for_array (gfc_ss
*array
, int array_dim
)
2147 gcc_assert (array
->nested_ss
== NULL
);
2149 for (ss
= array
; ss
; ss
= ss
->parent
)
2150 for (n
= 0; n
< ss
->loop
->dimen
; n
++)
2151 if (array_dim
== get_array_ref_dim_for_loop_dim (ss
, n
))
2152 return &(ss
->loop
->to
[n
]);
2158 static gfc_loopinfo
*
2159 outermost_loop (gfc_loopinfo
* loop
)
2161 while (loop
->parent
!= NULL
)
2162 loop
= loop
->parent
;
2168 /* Array constructors are handled by constructing a temporary, then using that
2169 within the scalarization loop. This is not optimal, but seems by far the
2173 trans_array_constructor (gfc_ss
* ss
, locus
* where
)
2175 gfc_constructor_base c
;
2183 bool old_first_len
, old_typespec_chararray_ctor
;
2184 tree old_first_len_val
;
2185 gfc_loopinfo
*loop
, *outer_loop
;
2186 gfc_ss_info
*ss_info
;
2190 /* Save the old values for nested checking. */
2191 old_first_len
= first_len
;
2192 old_first_len_val
= first_len_val
;
2193 old_typespec_chararray_ctor
= typespec_chararray_ctor
;
2196 outer_loop
= outermost_loop (loop
);
2198 expr
= ss_info
->expr
;
2200 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
2201 typespec was given for the array constructor. */
2202 typespec_chararray_ctor
= (expr
->ts
.u
.cl
2203 && expr
->ts
.u
.cl
->length_from_typespec
);
2205 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2206 && expr
->ts
.type
== BT_CHARACTER
&& !typespec_chararray_ctor
)
2208 first_len_val
= gfc_create_var (gfc_charlen_type_node
, "len");
2212 gcc_assert (ss
->dimen
== ss
->loop
->dimen
);
2214 c
= expr
->value
.constructor
;
2215 if (expr
->ts
.type
== BT_CHARACTER
)
2219 /* get_array_ctor_strlen walks the elements of the constructor, if a
2220 typespec was given, we already know the string length and want the one
2222 if (typespec_chararray_ctor
&& expr
->ts
.u
.cl
->length
2223 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
2227 const_string
= false;
2228 gfc_init_se (&length_se
, NULL
);
2229 gfc_conv_expr_type (&length_se
, expr
->ts
.u
.cl
->length
,
2230 gfc_charlen_type_node
);
2231 ss_info
->string_length
= length_se
.expr
;
2232 gfc_add_block_to_block (&outer_loop
->pre
, &length_se
.pre
);
2233 gfc_add_block_to_block (&outer_loop
->post
, &length_se
.post
);
2236 const_string
= get_array_ctor_strlen (&outer_loop
->pre
, c
,
2237 &ss_info
->string_length
);
2239 /* Complex character array constructors should have been taken care of
2240 and not end up here. */
2241 gcc_assert (ss_info
->string_length
);
2243 expr
->ts
.u
.cl
->backend_decl
= ss_info
->string_length
;
2245 type
= gfc_get_character_type_len (expr
->ts
.kind
, ss_info
->string_length
);
2247 type
= build_pointer_type (type
);
2250 type
= gfc_typenode_for_spec (&expr
->ts
);
2252 /* See if the constructor determines the loop bounds. */
2255 loop_ubound0
= get_loop_upper_bound_for_array (ss
, 0);
2257 if (expr
->shape
&& get_rank (loop
) > 1 && *loop_ubound0
== NULL_TREE
)
2259 /* We have a multidimensional parameter. */
2260 for (s
= ss
; s
; s
= s
->parent
)
2263 for (n
= 0; n
< s
->loop
->dimen
; n
++)
2265 s
->loop
->from
[n
] = gfc_index_zero_node
;
2266 s
->loop
->to
[n
] = gfc_conv_mpz_to_tree (expr
->shape
[s
->dim
[n
]],
2267 gfc_index_integer_kind
);
2268 s
->loop
->to
[n
] = fold_build2_loc (input_location
, MINUS_EXPR
,
2269 gfc_array_index_type
,
2271 gfc_index_one_node
);
2276 if (*loop_ubound0
== NULL_TREE
)
2280 /* We should have a 1-dimensional, zero-based loop. */
2281 gcc_assert (loop
->parent
== NULL
&& loop
->nested
== NULL
);
2282 gcc_assert (loop
->dimen
== 1);
2283 gcc_assert (integer_zerop (loop
->from
[0]));
2285 /* Split the constructor size into a static part and a dynamic part.
2286 Allocate the static size up-front and record whether the dynamic
2287 size might be nonzero. */
2289 dynamic
= gfc_get_array_constructor_size (&size
, c
);
2290 mpz_sub_ui (size
, size
, 1);
2291 loop
->to
[0] = gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
2295 /* Special case constant array constructors. */
2298 unsigned HOST_WIDE_INT nelem
= gfc_constant_array_constructor_p (c
);
2301 tree size
= constant_array_constructor_loop_size (loop
);
2302 if (size
&& compare_tree_int (size
, nelem
) == 0)
2304 trans_constant_array_constructor (ss
, type
);
2310 gfc_trans_create_temp_array (&outer_loop
->pre
, &outer_loop
->post
, ss
, type
,
2311 NULL_TREE
, dynamic
, true, false, where
);
2313 desc
= ss_info
->data
.array
.descriptor
;
2314 offset
= gfc_index_zero_node
;
2315 offsetvar
= gfc_create_var_np (gfc_array_index_type
, "offset");
2316 TREE_NO_WARNING (offsetvar
) = 1;
2317 TREE_USED (offsetvar
) = 0;
2318 gfc_trans_array_constructor_value (&outer_loop
->pre
, type
, desc
, c
,
2319 &offset
, &offsetvar
, dynamic
);
2321 /* If the array grows dynamically, the upper bound of the loop variable
2322 is determined by the array's final upper bound. */
2325 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2326 gfc_array_index_type
,
2327 offsetvar
, gfc_index_one_node
);
2328 tmp
= gfc_evaluate_now (tmp
, &outer_loop
->pre
);
2329 gfc_conv_descriptor_ubound_set (&loop
->pre
, desc
, gfc_rank_cst
[0], tmp
);
2330 if (*loop_ubound0
&& TREE_CODE (*loop_ubound0
) == VAR_DECL
)
2331 gfc_add_modify (&outer_loop
->pre
, *loop_ubound0
, tmp
);
2333 *loop_ubound0
= tmp
;
2336 if (TREE_USED (offsetvar
))
2337 pushdecl (offsetvar
);
2339 gcc_assert (INTEGER_CST_P (offset
));
2342 /* Disable bound checking for now because it's probably broken. */
2343 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2350 /* Restore old values of globals. */
2351 first_len
= old_first_len
;
2352 first_len_val
= old_first_len_val
;
2353 typespec_chararray_ctor
= old_typespec_chararray_ctor
;
2357 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
2358 called after evaluating all of INFO's vector dimensions. Go through
2359 each such vector dimension and see if we can now fill in any missing
2363 set_vector_loop_bounds (gfc_ss
* ss
)
2365 gfc_loopinfo
*loop
, *outer_loop
;
2366 gfc_array_info
*info
;
2374 outer_loop
= outermost_loop (ss
->loop
);
2376 info
= &ss
->info
->data
.array
;
2378 for (; ss
; ss
= ss
->parent
)
2382 for (n
= 0; n
< loop
->dimen
; n
++)
2385 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_VECTOR
2386 || loop
->to
[n
] != NULL
)
2389 /* Loop variable N indexes vector dimension DIM, and we don't
2390 yet know the upper bound of loop variable N. Set it to the
2391 difference between the vector's upper and lower bounds. */
2392 gcc_assert (loop
->from
[n
] == gfc_index_zero_node
);
2393 gcc_assert (info
->subscript
[dim
]
2394 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
2396 gfc_init_se (&se
, NULL
);
2397 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
2398 zero
= gfc_rank_cst
[0];
2399 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2400 gfc_array_index_type
,
2401 gfc_conv_descriptor_ubound_get (desc
, zero
),
2402 gfc_conv_descriptor_lbound_get (desc
, zero
));
2403 tmp
= gfc_evaluate_now (tmp
, &outer_loop
->pre
);
2410 /* Add the pre and post chains for all the scalar expressions in a SS chain
2411 to loop. This is called after the loop parameters have been calculated,
2412 but before the actual scalarizing loops. */
2415 gfc_add_loop_ss_code (gfc_loopinfo
* loop
, gfc_ss
* ss
, bool subscript
,
2418 gfc_loopinfo
*nested_loop
, *outer_loop
;
2420 gfc_ss_info
*ss_info
;
2421 gfc_array_info
*info
;
2425 /* Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise,
2426 arguments could get evaluated multiple times. */
2427 if (ss
->is_alloc_lhs
)
2430 outer_loop
= outermost_loop (loop
);
2432 /* TODO: This can generate bad code if there are ordering dependencies,
2433 e.g., a callee allocated function and an unknown size constructor. */
2434 gcc_assert (ss
!= NULL
);
2436 for (; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2440 /* Cross loop arrays are handled from within the most nested loop. */
2441 if (ss
->nested_ss
!= NULL
)
2445 expr
= ss_info
->expr
;
2446 info
= &ss_info
->data
.array
;
2448 switch (ss_info
->type
)
2451 /* Scalar expression. Evaluate this now. This includes elemental
2452 dimension indices, but not array section bounds. */
2453 gfc_init_se (&se
, NULL
);
2454 gfc_conv_expr (&se
, expr
);
2455 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2457 if (expr
->ts
.type
!= BT_CHARACTER
)
2459 /* Move the evaluation of scalar expressions outside the
2460 scalarization loop, except for WHERE assignments. */
2462 se
.expr
= convert(gfc_array_index_type
, se
.expr
);
2463 if (!ss_info
->where
)
2464 se
.expr
= gfc_evaluate_now (se
.expr
, &outer_loop
->pre
);
2465 gfc_add_block_to_block (&outer_loop
->pre
, &se
.post
);
2468 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2470 ss_info
->data
.scalar
.value
= se
.expr
;
2471 ss_info
->string_length
= se
.string_length
;
2474 case GFC_SS_REFERENCE
:
2475 /* Scalar argument to elemental procedure. */
2476 gfc_init_se (&se
, NULL
);
2477 if (ss_info
->can_be_null_ref
)
2479 /* If the actual argument can be absent (in other words, it can
2480 be a NULL reference), don't try to evaluate it; pass instead
2481 the reference directly. */
2482 gfc_conv_expr_reference (&se
, expr
);
2486 /* Otherwise, evaluate the argument outside the loop and pass
2487 a reference to the value. */
2488 gfc_conv_expr (&se
, expr
);
2490 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2491 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2492 if (gfc_is_class_scalar_expr (expr
))
2493 /* This is necessary because the dynamic type will always be
2494 large than the declared type. In consequence, assigning
2495 the value to a temporary could segfault.
2496 OOP-TODO: see if this is generally correct or is the value
2497 has to be written to an allocated temporary, whose address
2498 is passed via ss_info. */
2499 ss_info
->data
.scalar
.value
= se
.expr
;
2501 ss_info
->data
.scalar
.value
= gfc_evaluate_now (se
.expr
,
2504 ss_info
->string_length
= se
.string_length
;
2507 case GFC_SS_SECTION
:
2508 /* Add the expressions for scalar and vector subscripts. */
2509 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2510 if (info
->subscript
[n
])
2511 gfc_add_loop_ss_code (loop
, info
->subscript
[n
], true, where
);
2513 set_vector_loop_bounds (ss
);
2517 /* Get the vector's descriptor and store it in SS. */
2518 gfc_init_se (&se
, NULL
);
2519 gfc_conv_expr_descriptor (&se
, expr
);
2520 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2521 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2522 info
->descriptor
= se
.expr
;
2525 case GFC_SS_INTRINSIC
:
2526 gfc_add_intrinsic_ss_code (loop
, ss
);
2529 case GFC_SS_FUNCTION
:
2530 /* Array function return value. We call the function and save its
2531 result in a temporary for use inside the loop. */
2532 gfc_init_se (&se
, NULL
);
2535 gfc_conv_expr (&se
, expr
);
2536 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2537 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2538 ss_info
->string_length
= se
.string_length
;
2541 case GFC_SS_CONSTRUCTOR
:
2542 if (expr
->ts
.type
== BT_CHARACTER
2543 && ss_info
->string_length
== NULL
2545 && expr
->ts
.u
.cl
->length
)
2547 gfc_init_se (&se
, NULL
);
2548 gfc_conv_expr_type (&se
, expr
->ts
.u
.cl
->length
,
2549 gfc_charlen_type_node
);
2550 ss_info
->string_length
= se
.expr
;
2551 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2552 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2554 trans_array_constructor (ss
, where
);
2558 case GFC_SS_COMPONENT
:
2559 /* Do nothing. These are handled elsewhere. */
2568 for (nested_loop
= loop
->nested
; nested_loop
;
2569 nested_loop
= nested_loop
->next
)
2570 gfc_add_loop_ss_code (nested_loop
, nested_loop
->ss
, subscript
, where
);
2574 /* Translate expressions for the descriptor and data pointer of a SS. */
2578 gfc_conv_ss_descriptor (stmtblock_t
* block
, gfc_ss
* ss
, int base
)
2581 gfc_ss_info
*ss_info
;
2582 gfc_array_info
*info
;
2586 info
= &ss_info
->data
.array
;
2588 /* Get the descriptor for the array to be scalarized. */
2589 gcc_assert (ss_info
->expr
->expr_type
== EXPR_VARIABLE
);
2590 gfc_init_se (&se
, NULL
);
2591 se
.descriptor_only
= 1;
2592 gfc_conv_expr_lhs (&se
, ss_info
->expr
);
2593 gfc_add_block_to_block (block
, &se
.pre
);
2594 info
->descriptor
= se
.expr
;
2595 ss_info
->string_length
= se
.string_length
;
2599 /* Also the data pointer. */
2600 tmp
= gfc_conv_array_data (se
.expr
);
2601 /* If this is a variable or address of a variable we use it directly.
2602 Otherwise we must evaluate it now to avoid breaking dependency
2603 analysis by pulling the expressions for elemental array indices
2606 || (TREE_CODE (tmp
) == ADDR_EXPR
2607 && DECL_P (TREE_OPERAND (tmp
, 0)))))
2608 tmp
= gfc_evaluate_now (tmp
, block
);
2611 tmp
= gfc_conv_array_offset (se
.expr
);
2612 info
->offset
= gfc_evaluate_now (tmp
, block
);
2614 /* Make absolutely sure that the saved_offset is indeed saved
2615 so that the variable is still accessible after the loops
2617 info
->saved_offset
= info
->offset
;
2622 /* Initialize a gfc_loopinfo structure. */
2625 gfc_init_loopinfo (gfc_loopinfo
* loop
)
2629 memset (loop
, 0, sizeof (gfc_loopinfo
));
2630 gfc_init_block (&loop
->pre
);
2631 gfc_init_block (&loop
->post
);
2633 /* Initially scalarize in order and default to no loop reversal. */
2634 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2637 loop
->reverse
[n
] = GFC_INHIBIT_REVERSE
;
2640 loop
->ss
= gfc_ss_terminator
;
2644 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2648 gfc_copy_loopinfo_to_se (gfc_se
* se
, gfc_loopinfo
* loop
)
2654 /* Return an expression for the data pointer of an array. */
2657 gfc_conv_array_data (tree descriptor
)
2661 type
= TREE_TYPE (descriptor
);
2662 if (GFC_ARRAY_TYPE_P (type
))
2664 if (TREE_CODE (type
) == POINTER_TYPE
)
2668 /* Descriptorless arrays. */
2669 return gfc_build_addr_expr (NULL_TREE
, descriptor
);
2673 return gfc_conv_descriptor_data_get (descriptor
);
2677 /* Return an expression for the base offset of an array. */
2680 gfc_conv_array_offset (tree descriptor
)
2684 type
= TREE_TYPE (descriptor
);
2685 if (GFC_ARRAY_TYPE_P (type
))
2686 return GFC_TYPE_ARRAY_OFFSET (type
);
2688 return gfc_conv_descriptor_offset_get (descriptor
);
2692 /* Get an expression for the array stride. */
2695 gfc_conv_array_stride (tree descriptor
, int dim
)
2700 type
= TREE_TYPE (descriptor
);
2702 /* For descriptorless arrays use the array size. */
2703 tmp
= GFC_TYPE_ARRAY_STRIDE (type
, dim
);
2704 if (tmp
!= NULL_TREE
)
2707 tmp
= gfc_conv_descriptor_stride_get (descriptor
, gfc_rank_cst
[dim
]);
2712 /* Like gfc_conv_array_stride, but for the lower bound. */
2715 gfc_conv_array_lbound (tree descriptor
, int dim
)
2720 type
= TREE_TYPE (descriptor
);
2722 tmp
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
2723 if (tmp
!= NULL_TREE
)
2726 tmp
= gfc_conv_descriptor_lbound_get (descriptor
, gfc_rank_cst
[dim
]);
2731 /* Like gfc_conv_array_stride, but for the upper bound. */
2734 gfc_conv_array_ubound (tree descriptor
, int dim
)
2739 type
= TREE_TYPE (descriptor
);
2741 tmp
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
2742 if (tmp
!= NULL_TREE
)
2745 /* This should only ever happen when passing an assumed shape array
2746 as an actual parameter. The value will never be used. */
2747 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor
)))
2748 return gfc_index_zero_node
;
2750 tmp
= gfc_conv_descriptor_ubound_get (descriptor
, gfc_rank_cst
[dim
]);
2755 /* Generate code to perform an array index bound check. */
2758 trans_array_bound_check (gfc_se
* se
, gfc_ss
*ss
, tree index
, int n
,
2759 locus
* where
, bool check_upper
)
2762 tree tmp_lo
, tmp_up
;
2765 const char * name
= NULL
;
2767 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
2770 descriptor
= ss
->info
->data
.array
.descriptor
;
2772 index
= gfc_evaluate_now (index
, &se
->pre
);
2774 /* We find a name for the error message. */
2775 name
= ss
->info
->expr
->symtree
->n
.sym
->name
;
2776 gcc_assert (name
!= NULL
);
2778 if (TREE_CODE (descriptor
) == VAR_DECL
)
2779 name
= IDENTIFIER_POINTER (DECL_NAME (descriptor
));
2781 /* If upper bound is present, include both bounds in the error message. */
2784 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
2785 tmp_up
= gfc_conv_array_ubound (descriptor
, n
);
2788 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
2789 "outside of expected range (%%ld:%%ld)", n
+1, name
);
2791 asprintf (&msg
, "Index '%%ld' of dimension %d "
2792 "outside of expected range (%%ld:%%ld)", n
+1);
2794 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2796 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2797 fold_convert (long_integer_type_node
, index
),
2798 fold_convert (long_integer_type_node
, tmp_lo
),
2799 fold_convert (long_integer_type_node
, tmp_up
));
2800 fault
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2802 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2803 fold_convert (long_integer_type_node
, index
),
2804 fold_convert (long_integer_type_node
, tmp_lo
),
2805 fold_convert (long_integer_type_node
, tmp_up
));
2810 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
2813 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
2814 "below lower bound of %%ld", n
+1, name
);
2816 asprintf (&msg
, "Index '%%ld' of dimension %d "
2817 "below lower bound of %%ld", n
+1);
2819 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2821 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2822 fold_convert (long_integer_type_node
, index
),
2823 fold_convert (long_integer_type_node
, tmp_lo
));
2831 /* Return the offset for an index. Performs bound checking for elemental
2832 dimensions. Single element references are processed separately.
2833 DIM is the array dimension, I is the loop dimension. */
2836 conv_array_index_offset (gfc_se
* se
, gfc_ss
* ss
, int dim
, int i
,
2837 gfc_array_ref
* ar
, tree stride
)
2839 gfc_array_info
*info
;
2844 info
= &ss
->info
->data
.array
;
2846 /* Get the index into the array for this dimension. */
2849 gcc_assert (ar
->type
!= AR_ELEMENT
);
2850 switch (ar
->dimen_type
[dim
])
2852 case DIMEN_THIS_IMAGE
:
2856 /* Elemental dimension. */
2857 gcc_assert (info
->subscript
[dim
]
2858 && info
->subscript
[dim
]->info
->type
== GFC_SS_SCALAR
);
2859 /* We've already translated this value outside the loop. */
2860 index
= info
->subscript
[dim
]->info
->data
.scalar
.value
;
2862 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
2863 ar
->as
->type
!= AS_ASSUMED_SIZE
2864 || dim
< ar
->dimen
- 1);
2868 gcc_assert (info
&& se
->loop
);
2869 gcc_assert (info
->subscript
[dim
]
2870 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
2871 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
2873 /* Get a zero-based index into the vector. */
2874 index
= fold_build2_loc (input_location
, MINUS_EXPR
,
2875 gfc_array_index_type
,
2876 se
->loop
->loopvar
[i
], se
->loop
->from
[i
]);
2878 /* Multiply the index by the stride. */
2879 index
= fold_build2_loc (input_location
, MULT_EXPR
,
2880 gfc_array_index_type
,
2881 index
, gfc_conv_array_stride (desc
, 0));
2883 /* Read the vector to get an index into info->descriptor. */
2884 data
= build_fold_indirect_ref_loc (input_location
,
2885 gfc_conv_array_data (desc
));
2886 index
= gfc_build_array_ref (data
, index
, NULL
);
2887 index
= gfc_evaluate_now (index
, &se
->pre
);
2888 index
= fold_convert (gfc_array_index_type
, index
);
2890 /* Do any bounds checking on the final info->descriptor index. */
2891 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
2892 ar
->as
->type
!= AS_ASSUMED_SIZE
2893 || dim
< ar
->dimen
- 1);
2897 /* Scalarized dimension. */
2898 gcc_assert (info
&& se
->loop
);
2900 /* Multiply the loop variable by the stride and delta. */
2901 index
= se
->loop
->loopvar
[i
];
2902 if (!integer_onep (info
->stride
[dim
]))
2903 index
= fold_build2_loc (input_location
, MULT_EXPR
,
2904 gfc_array_index_type
, index
,
2906 if (!integer_zerop (info
->delta
[dim
]))
2907 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
2908 gfc_array_index_type
, index
,
2918 /* Temporary array or derived type component. */
2919 gcc_assert (se
->loop
);
2920 index
= se
->loop
->loopvar
[se
->loop
->order
[i
]];
2922 /* Pointer functions can have stride[0] different from unity.
2923 Use the stride returned by the function call and stored in
2924 the descriptor for the temporary. */
2925 if (se
->ss
&& se
->ss
->info
->type
== GFC_SS_FUNCTION
2926 && se
->ss
->info
->expr
2927 && se
->ss
->info
->expr
->symtree
2928 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
2929 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
->attr
.pointer
)
2930 stride
= gfc_conv_descriptor_stride_get (info
->descriptor
,
2933 if (!integer_zerop (info
->delta
[dim
]))
2934 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
2935 gfc_array_index_type
, index
, info
->delta
[dim
]);
2938 /* Multiply by the stride. */
2939 if (!integer_onep (stride
))
2940 index
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
2947 /* Build a scalarized array reference using the vptr 'size'. */
2950 build_class_array_ref (gfc_se
*se
, tree base
, tree index
)
2957 gfc_expr
*expr
= se
->ss
->info
->expr
;
2962 if (expr
== NULL
|| expr
->ts
.type
!= BT_CLASS
)
2965 if (expr
->symtree
&& expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
2966 ts
= &expr
->symtree
->n
.sym
->ts
;
2971 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2973 if (ref
->type
== REF_COMPONENT
2974 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
2975 && ref
->next
&& ref
->next
->type
== REF_COMPONENT
2976 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0
2978 && ref
->next
->next
->type
== REF_ARRAY
2979 && ref
->next
->next
->u
.ar
.type
!= AR_ELEMENT
)
2981 ts
= &ref
->u
.c
.component
->ts
;
2990 if (class_ref
== NULL
)
2991 decl
= expr
->symtree
->n
.sym
->backend_decl
;
2994 /* Remove everything after the last class reference, convert the
2995 expression and then recover its tailend once more. */
2997 ref
= class_ref
->next
;
2998 class_ref
->next
= NULL
;
2999 gfc_init_se (&tmpse
, NULL
);
3000 gfc_conv_expr (&tmpse
, expr
);
3002 class_ref
->next
= ref
;
3005 size
= gfc_vtable_size_get (decl
);
3007 /* Build the address of the element. */
3008 type
= TREE_TYPE (TREE_TYPE (base
));
3009 size
= fold_convert (TREE_TYPE (index
), size
);
3010 offset
= fold_build2_loc (input_location
, MULT_EXPR
,
3011 gfc_array_index_type
,
3013 tmp
= gfc_build_addr_expr (pvoid_type_node
, base
);
3014 tmp
= fold_build_pointer_plus_loc (input_location
, tmp
, offset
);
3015 tmp
= fold_convert (build_pointer_type (type
), tmp
);
3017 /* Return the element in the se expression. */
3018 se
->expr
= build_fold_indirect_ref_loc (input_location
, tmp
);
3023 /* Build a scalarized reference to an array. */
3026 gfc_conv_scalarized_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
3028 gfc_array_info
*info
;
3029 tree decl
= NULL_TREE
;
3037 expr
= ss
->info
->expr
;
3038 info
= &ss
->info
->data
.array
;
3040 n
= se
->loop
->order
[0];
3044 index
= conv_array_index_offset (se
, ss
, ss
->dim
[n
], n
, ar
, info
->stride0
);
3045 /* Add the offset for this dimension to the stored offset for all other
3047 if (!integer_zerop (info
->offset
))
3048 index
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3049 index
, info
->offset
);
3051 if (expr
&& is_subref_array (expr
))
3052 decl
= expr
->symtree
->n
.sym
->backend_decl
;
3054 tmp
= build_fold_indirect_ref_loc (input_location
, info
->data
);
3056 /* Use the vptr 'size' field to access a class the element of a class
3058 if (build_class_array_ref (se
, tmp
, index
))
3061 se
->expr
= gfc_build_array_ref (tmp
, index
, decl
);
3065 /* Translate access of temporary array. */
3068 gfc_conv_tmp_array_ref (gfc_se
* se
)
3070 se
->string_length
= se
->ss
->info
->string_length
;
3071 gfc_conv_scalarized_array_ref (se
, NULL
);
3072 gfc_advance_se_ss_chain (se
);
3075 /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
3078 add_to_offset (tree
*cst_offset
, tree
*offset
, tree t
)
3080 if (TREE_CODE (t
) == INTEGER_CST
)
3081 *cst_offset
= int_const_binop (PLUS_EXPR
, *cst_offset
, t
);
3084 if (!integer_zerop (*offset
))
3085 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3086 gfc_array_index_type
, *offset
, t
);
3094 build_array_ref (tree desc
, tree offset
, tree decl
)
3099 /* Class container types do not always have the GFC_CLASS_TYPE_P
3100 but the canonical type does. */
3101 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
3102 && TREE_CODE (desc
) == COMPONENT_REF
)
3104 type
= TREE_TYPE (TREE_OPERAND (desc
, 0));
3105 if (TYPE_CANONICAL (type
)
3106 && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type
)))
3107 type
= TYPE_CANONICAL (type
);
3112 /* Class array references need special treatment because the assigned
3113 type size needs to be used to point to the element. */
3114 if (type
&& GFC_CLASS_TYPE_P (type
))
3116 type
= gfc_get_element_type (TREE_TYPE (desc
));
3117 tmp
= TREE_OPERAND (desc
, 0);
3118 tmp
= gfc_get_class_array_ref (offset
, tmp
);
3119 tmp
= fold_convert (build_pointer_type (type
), tmp
);
3120 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3124 tmp
= gfc_conv_array_data (desc
);
3125 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3126 tmp
= gfc_build_array_ref (tmp
, offset
, decl
);
3131 /* Build an array reference. se->expr already holds the array descriptor.
3132 This should be either a variable, indirect variable reference or component
3133 reference. For arrays which do not have a descriptor, se->expr will be
3135 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
3138 gfc_conv_array_ref (gfc_se
* se
, gfc_array_ref
* ar
, gfc_symbol
* sym
,
3142 tree offset
, cst_offset
;
3150 gcc_assert (ar
->codimen
);
3152 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
->expr
)))
3153 se
->expr
= build_fold_indirect_ref (gfc_conv_array_data (se
->expr
));
3156 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se
->expr
))
3157 && TREE_CODE (TREE_TYPE (se
->expr
)) == POINTER_TYPE
)
3158 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3160 /* Use the actual tree type and not the wrapped coarray. */
3161 if (!se
->want_pointer
)
3162 se
->expr
= fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se
->expr
)),
3169 /* Handle scalarized references separately. */
3170 if (ar
->type
!= AR_ELEMENT
)
3172 gfc_conv_scalarized_array_ref (se
, ar
);
3173 gfc_advance_se_ss_chain (se
);
3177 cst_offset
= offset
= gfc_index_zero_node
;
3178 add_to_offset (&cst_offset
, &offset
, gfc_conv_array_offset (se
->expr
));
3180 /* Calculate the offsets from all the dimensions. Make sure to associate
3181 the final offset so that we form a chain of loop invariant summands. */
3182 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
3184 /* Calculate the index for this dimension. */
3185 gfc_init_se (&indexse
, se
);
3186 gfc_conv_expr_type (&indexse
, ar
->start
[n
], gfc_array_index_type
);
3187 gfc_add_block_to_block (&se
->pre
, &indexse
.pre
);
3189 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3191 /* Check array bounds. */
3195 /* Evaluate the indexse.expr only once. */
3196 indexse
.expr
= save_expr (indexse
.expr
);
3199 tmp
= gfc_conv_array_lbound (se
->expr
, n
);
3200 if (sym
->attr
.temporary
)
3202 gfc_init_se (&tmpse
, se
);
3203 gfc_conv_expr_type (&tmpse
, ar
->as
->lower
[n
],
3204 gfc_array_index_type
);
3205 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3209 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
3211 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
3212 "below lower bound of %%ld", n
+1, sym
->name
);
3213 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3214 fold_convert (long_integer_type_node
,
3216 fold_convert (long_integer_type_node
, tmp
));
3219 /* Upper bound, but not for the last dimension of assumed-size
3221 if (n
< ar
->dimen
- 1 || ar
->as
->type
!= AS_ASSUMED_SIZE
)
3223 tmp
= gfc_conv_array_ubound (se
->expr
, n
);
3224 if (sym
->attr
.temporary
)
3226 gfc_init_se (&tmpse
, se
);
3227 gfc_conv_expr_type (&tmpse
, ar
->as
->upper
[n
],
3228 gfc_array_index_type
);
3229 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3233 cond
= fold_build2_loc (input_location
, GT_EXPR
,
3234 boolean_type_node
, indexse
.expr
, tmp
);
3235 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
3236 "above upper bound of %%ld", n
+1, sym
->name
);
3237 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3238 fold_convert (long_integer_type_node
,
3240 fold_convert (long_integer_type_node
, tmp
));
3245 /* Multiply the index by the stride. */
3246 stride
= gfc_conv_array_stride (se
->expr
, n
);
3247 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3248 indexse
.expr
, stride
);
3250 /* And add it to the total. */
3251 add_to_offset (&cst_offset
, &offset
, tmp
);
3254 if (!integer_zerop (cst_offset
))
3255 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3256 gfc_array_index_type
, offset
, cst_offset
);
3258 se
->expr
= build_array_ref (se
->expr
, offset
, sym
->backend_decl
);
3262 /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
3263 LOOP_DIM dimension (if any) to array's offset. */
3266 add_array_offset (stmtblock_t
*pblock
, gfc_loopinfo
*loop
, gfc_ss
*ss
,
3267 gfc_array_ref
*ar
, int array_dim
, int loop_dim
)
3270 gfc_array_info
*info
;
3273 info
= &ss
->info
->data
.array
;
3275 gfc_init_se (&se
, NULL
);
3277 se
.expr
= info
->descriptor
;
3278 stride
= gfc_conv_array_stride (info
->descriptor
, array_dim
);
3279 index
= conv_array_index_offset (&se
, ss
, array_dim
, loop_dim
, ar
, stride
);
3280 gfc_add_block_to_block (pblock
, &se
.pre
);
3282 info
->offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3283 gfc_array_index_type
,
3284 info
->offset
, index
);
3285 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
3289 /* Generate the code to be executed immediately before entering a
3290 scalarization loop. */
3293 gfc_trans_preloop_setup (gfc_loopinfo
* loop
, int dim
, int flag
,
3294 stmtblock_t
* pblock
)
3297 gfc_ss_info
*ss_info
;
3298 gfc_array_info
*info
;
3299 gfc_ss_type ss_type
;
3301 gfc_loopinfo
*ploop
;
3305 /* This code will be executed before entering the scalarization loop
3306 for this dimension. */
3307 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3311 if ((ss_info
->useflags
& flag
) == 0)
3314 ss_type
= ss_info
->type
;
3315 if (ss_type
!= GFC_SS_SECTION
3316 && ss_type
!= GFC_SS_FUNCTION
3317 && ss_type
!= GFC_SS_CONSTRUCTOR
3318 && ss_type
!= GFC_SS_COMPONENT
)
3321 info
= &ss_info
->data
.array
;
3323 gcc_assert (dim
< ss
->dimen
);
3324 gcc_assert (ss
->dimen
== loop
->dimen
);
3327 ar
= &info
->ref
->u
.ar
;
3331 if (dim
== loop
->dimen
- 1 && loop
->parent
!= NULL
)
3333 /* If we are in the outermost dimension of this loop, the previous
3334 dimension shall be in the parent loop. */
3335 gcc_assert (ss
->parent
!= NULL
);
3338 ploop
= loop
->parent
;
3340 /* ss and ss->parent are about the same array. */
3341 gcc_assert (ss_info
== pss
->info
);
3349 if (dim
== loop
->dimen
- 1)
3354 /* For the time being, there is no loop reordering. */
3355 gcc_assert (i
== ploop
->order
[i
]);
3356 i
= ploop
->order
[i
];
3358 if (dim
== loop
->dimen
- 1 && loop
->parent
== NULL
)
3360 stride
= gfc_conv_array_stride (info
->descriptor
,
3361 innermost_ss (ss
)->dim
[i
]);
3363 /* Calculate the stride of the innermost loop. Hopefully this will
3364 allow the backend optimizers to do their stuff more effectively.
3366 info
->stride0
= gfc_evaluate_now (stride
, pblock
);
3368 /* For the outermost loop calculate the offset due to any
3369 elemental dimensions. It will have been initialized with the
3370 base offset of the array. */
3373 for (i
= 0; i
< ar
->dimen
; i
++)
3375 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
3378 add_array_offset (pblock
, loop
, ss
, ar
, i
, /* unused */ -1);
3383 /* Add the offset for the previous loop dimension. */
3384 add_array_offset (pblock
, ploop
, ss
, ar
, pss
->dim
[i
], i
);
3386 /* Remember this offset for the second loop. */
3387 if (dim
== loop
->temp_dim
- 1 && loop
->parent
== NULL
)
3388 info
->saved_offset
= info
->offset
;
3393 /* Start a scalarized expression. Creates a scope and declares loop
3397 gfc_start_scalarized_body (gfc_loopinfo
* loop
, stmtblock_t
* pbody
)
3403 gcc_assert (!loop
->array_parameter
);
3405 for (dim
= loop
->dimen
- 1; dim
>= 0; dim
--)
3407 n
= loop
->order
[dim
];
3409 gfc_start_block (&loop
->code
[n
]);
3411 /* Create the loop variable. */
3412 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "S");
3414 if (dim
< loop
->temp_dim
)
3418 /* Calculate values that will be constant within this loop. */
3419 gfc_trans_preloop_setup (loop
, dim
, flags
, &loop
->code
[n
]);
3421 gfc_start_block (pbody
);
3425 /* Generates the actual loop code for a scalarization loop. */
3428 gfc_trans_scalarized_loop_end (gfc_loopinfo
* loop
, int n
,
3429 stmtblock_t
* pbody
)
3440 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
))
3441 == (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
)
3442 && n
== loop
->dimen
- 1)
3444 /* We create an OMP_FOR construct for the outermost scalarized loop. */
3445 init
= make_tree_vec (1);
3446 cond
= make_tree_vec (1);
3447 incr
= make_tree_vec (1);
3449 /* Cycle statement is implemented with a goto. Exit statement must not
3450 be present for this loop. */
3451 exit_label
= gfc_build_label_decl (NULL_TREE
);
3452 TREE_USED (exit_label
) = 1;
3454 /* Label for cycle statements (if needed). */
3455 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3456 gfc_add_expr_to_block (pbody
, tmp
);
3458 stmt
= make_node (OMP_FOR
);
3460 TREE_TYPE (stmt
) = void_type_node
;
3461 OMP_FOR_BODY (stmt
) = loopbody
= gfc_finish_block (pbody
);
3463 OMP_FOR_CLAUSES (stmt
) = build_omp_clause (input_location
,
3464 OMP_CLAUSE_SCHEDULE
);
3465 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt
))
3466 = OMP_CLAUSE_SCHEDULE_STATIC
;
3467 if (ompws_flags
& OMPWS_NOWAIT
)
3468 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt
))
3469 = build_omp_clause (input_location
, OMP_CLAUSE_NOWAIT
);
3471 /* Initialize the loopvar. */
3472 TREE_VEC_ELT (init
, 0) = build2_v (MODIFY_EXPR
, loop
->loopvar
[n
],
3474 OMP_FOR_INIT (stmt
) = init
;
3475 /* The exit condition. */
3476 TREE_VEC_ELT (cond
, 0) = build2_loc (input_location
, LE_EXPR
,
3478 loop
->loopvar
[n
], loop
->to
[n
]);
3479 SET_EXPR_LOCATION (TREE_VEC_ELT (cond
, 0), input_location
);
3480 OMP_FOR_COND (stmt
) = cond
;
3481 /* Increment the loopvar. */
3482 tmp
= build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3483 loop
->loopvar
[n
], gfc_index_one_node
);
3484 TREE_VEC_ELT (incr
, 0) = fold_build2_loc (input_location
, MODIFY_EXPR
,
3485 void_type_node
, loop
->loopvar
[n
], tmp
);
3486 OMP_FOR_INCR (stmt
) = incr
;
3488 ompws_flags
&= ~OMPWS_CURR_SINGLEUNIT
;
3489 gfc_add_expr_to_block (&loop
->code
[n
], stmt
);
3493 bool reverse_loop
= (loop
->reverse
[n
] == GFC_REVERSE_SET
)
3494 && (loop
->temp_ss
== NULL
);
3496 loopbody
= gfc_finish_block (pbody
);
3500 tmp
= loop
->from
[n
];
3501 loop
->from
[n
] = loop
->to
[n
];
3505 /* Initialize the loopvar. */
3506 if (loop
->loopvar
[n
] != loop
->from
[n
])
3507 gfc_add_modify (&loop
->code
[n
], loop
->loopvar
[n
], loop
->from
[n
]);
3509 exit_label
= gfc_build_label_decl (NULL_TREE
);
3511 /* Generate the loop body. */
3512 gfc_init_block (&block
);
3514 /* The exit condition. */
3515 cond
= fold_build2_loc (input_location
, reverse_loop
? LT_EXPR
: GT_EXPR
,
3516 boolean_type_node
, loop
->loopvar
[n
], loop
->to
[n
]);
3517 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3518 TREE_USED (exit_label
) = 1;
3519 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3520 gfc_add_expr_to_block (&block
, tmp
);
3522 /* The main body. */
3523 gfc_add_expr_to_block (&block
, loopbody
);
3525 /* Increment the loopvar. */
3526 tmp
= fold_build2_loc (input_location
,
3527 reverse_loop
? MINUS_EXPR
: PLUS_EXPR
,
3528 gfc_array_index_type
, loop
->loopvar
[n
],
3529 gfc_index_one_node
);
3531 gfc_add_modify (&block
, loop
->loopvar
[n
], tmp
);
3533 /* Build the loop. */
3534 tmp
= gfc_finish_block (&block
);
3535 tmp
= build1_v (LOOP_EXPR
, tmp
);
3536 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
3538 /* Add the exit label. */
3539 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3540 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
3546 /* Finishes and generates the loops for a scalarized expression. */
3549 gfc_trans_scalarizing_loops (gfc_loopinfo
* loop
, stmtblock_t
* body
)
3554 stmtblock_t
*pblock
;
3558 /* Generate the loops. */
3559 for (dim
= 0; dim
< loop
->dimen
; dim
++)
3561 n
= loop
->order
[dim
];
3562 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
3563 loop
->loopvar
[n
] = NULL_TREE
;
3564 pblock
= &loop
->code
[n
];
3567 tmp
= gfc_finish_block (pblock
);
3568 gfc_add_expr_to_block (&loop
->pre
, tmp
);
3570 /* Clear all the used flags. */
3571 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3572 if (ss
->parent
== NULL
)
3573 ss
->info
->useflags
= 0;
3577 /* Finish the main body of a scalarized expression, and start the secondary
3581 gfc_trans_scalarized_loop_boundary (gfc_loopinfo
* loop
, stmtblock_t
* body
)
3585 stmtblock_t
*pblock
;
3589 /* We finish as many loops as are used by the temporary. */
3590 for (dim
= 0; dim
< loop
->temp_dim
- 1; dim
++)
3592 n
= loop
->order
[dim
];
3593 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
3594 loop
->loopvar
[n
] = NULL_TREE
;
3595 pblock
= &loop
->code
[n
];
3598 /* We don't want to finish the outermost loop entirely. */
3599 n
= loop
->order
[loop
->temp_dim
- 1];
3600 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
3602 /* Restore the initial offsets. */
3603 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3605 gfc_ss_type ss_type
;
3606 gfc_ss_info
*ss_info
;
3610 if ((ss_info
->useflags
& 2) == 0)
3613 ss_type
= ss_info
->type
;
3614 if (ss_type
!= GFC_SS_SECTION
3615 && ss_type
!= GFC_SS_FUNCTION
3616 && ss_type
!= GFC_SS_CONSTRUCTOR
3617 && ss_type
!= GFC_SS_COMPONENT
)
3620 ss_info
->data
.array
.offset
= ss_info
->data
.array
.saved_offset
;
3623 /* Restart all the inner loops we just finished. */
3624 for (dim
= loop
->temp_dim
- 2; dim
>= 0; dim
--)
3626 n
= loop
->order
[dim
];
3628 gfc_start_block (&loop
->code
[n
]);
3630 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "Q");
3632 gfc_trans_preloop_setup (loop
, dim
, 2, &loop
->code
[n
]);
3635 /* Start a block for the secondary copying code. */
3636 gfc_start_block (body
);
3640 /* Precalculate (either lower or upper) bound of an array section.
3641 BLOCK: Block in which the (pre)calculation code will go.
3642 BOUNDS[DIM]: Where the bound value will be stored once evaluated.
3643 VALUES[DIM]: Specified bound (NULL <=> unspecified).
3644 DESC: Array descriptor from which the bound will be picked if unspecified
3645 (either lower or upper bound according to LBOUND). */
3648 evaluate_bound (stmtblock_t
*block
, tree
*bounds
, gfc_expr
** values
,
3649 tree desc
, int dim
, bool lbound
)
3652 gfc_expr
* input_val
= values
[dim
];
3653 tree
*output
= &bounds
[dim
];
3658 /* Specified section bound. */
3659 gfc_init_se (&se
, NULL
);
3660 gfc_conv_expr_type (&se
, input_val
, gfc_array_index_type
);
3661 gfc_add_block_to_block (block
, &se
.pre
);
3666 /* No specific bound specified so use the bound of the array. */
3667 *output
= lbound
? gfc_conv_array_lbound (desc
, dim
) :
3668 gfc_conv_array_ubound (desc
, dim
);
3670 *output
= gfc_evaluate_now (*output
, block
);
3674 /* Calculate the lower bound of an array section. */
3677 gfc_conv_section_startstride (gfc_loopinfo
* loop
, gfc_ss
* ss
, int dim
)
3679 gfc_expr
*stride
= NULL
;
3682 gfc_array_info
*info
;
3685 gcc_assert (ss
->info
->type
== GFC_SS_SECTION
);
3687 info
= &ss
->info
->data
.array
;
3688 ar
= &info
->ref
->u
.ar
;
3690 if (ar
->dimen_type
[dim
] == DIMEN_VECTOR
)
3692 /* We use a zero-based index to access the vector. */
3693 info
->start
[dim
] = gfc_index_zero_node
;
3694 info
->end
[dim
] = NULL
;
3695 info
->stride
[dim
] = gfc_index_one_node
;
3699 gcc_assert (ar
->dimen_type
[dim
] == DIMEN_RANGE
3700 || ar
->dimen_type
[dim
] == DIMEN_THIS_IMAGE
);
3701 desc
= info
->descriptor
;
3702 stride
= ar
->stride
[dim
];
3704 /* Calculate the start of the range. For vector subscripts this will
3705 be the range of the vector. */
3706 evaluate_bound (&loop
->pre
, info
->start
, ar
->start
, desc
, dim
, true);
3708 /* Similarly calculate the end. Although this is not used in the
3709 scalarizer, it is needed when checking bounds and where the end
3710 is an expression with side-effects. */
3711 evaluate_bound (&loop
->pre
, info
->end
, ar
->end
, desc
, dim
, false);
3713 /* Calculate the stride. */
3715 info
->stride
[dim
] = gfc_index_one_node
;
3718 gfc_init_se (&se
, NULL
);
3719 gfc_conv_expr_type (&se
, stride
, gfc_array_index_type
);
3720 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
3721 info
->stride
[dim
] = gfc_evaluate_now (se
.expr
, &loop
->pre
);
3726 /* Calculates the range start and stride for a SS chain. Also gets the
3727 descriptor and data pointer. The range of vector subscripts is the size
3728 of the vector. Array bounds are also checked. */
3731 gfc_conv_ss_startstride (gfc_loopinfo
* loop
)
3739 /* Determine the rank of the loop. */
3740 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3742 switch (ss
->info
->type
)
3744 case GFC_SS_SECTION
:
3745 case GFC_SS_CONSTRUCTOR
:
3746 case GFC_SS_FUNCTION
:
3747 case GFC_SS_COMPONENT
:
3748 loop
->dimen
= ss
->dimen
;
3751 /* As usual, lbound and ubound are exceptions!. */
3752 case GFC_SS_INTRINSIC
:
3753 switch (ss
->info
->expr
->value
.function
.isym
->id
)
3755 case GFC_ISYM_LBOUND
:
3756 case GFC_ISYM_UBOUND
:
3757 case GFC_ISYM_LCOBOUND
:
3758 case GFC_ISYM_UCOBOUND
:
3759 case GFC_ISYM_THIS_IMAGE
:
3760 loop
->dimen
= ss
->dimen
;
3772 /* We should have determined the rank of the expression by now. If
3773 not, that's bad news. */
3777 /* Loop over all the SS in the chain. */
3778 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3780 gfc_ss_info
*ss_info
;
3781 gfc_array_info
*info
;
3785 expr
= ss_info
->expr
;
3786 info
= &ss_info
->data
.array
;
3788 if (expr
&& expr
->shape
&& !info
->shape
)
3789 info
->shape
= expr
->shape
;
3791 switch (ss_info
->type
)
3793 case GFC_SS_SECTION
:
3794 /* Get the descriptor for the array. If it is a cross loops array,
3795 we got the descriptor already in the outermost loop. */
3796 if (ss
->parent
== NULL
)
3797 gfc_conv_ss_descriptor (&loop
->pre
, ss
, !loop
->array_parameter
);
3799 for (n
= 0; n
< ss
->dimen
; n
++)
3800 gfc_conv_section_startstride (loop
, ss
, ss
->dim
[n
]);
3803 case GFC_SS_INTRINSIC
:
3804 switch (expr
->value
.function
.isym
->id
)
3806 /* Fall through to supply start and stride. */
3807 case GFC_ISYM_LBOUND
:
3808 case GFC_ISYM_UBOUND
:
3812 /* This is the variant without DIM=... */
3813 gcc_assert (expr
->value
.function
.actual
->next
->expr
== NULL
);
3815 arg
= expr
->value
.function
.actual
->expr
;
3816 if (arg
->rank
== -1)
3821 /* The rank (hence the return value's shape) is unknown,
3822 we have to retrieve it. */
3823 gfc_init_se (&se
, NULL
);
3824 se
.descriptor_only
= 1;
3825 gfc_conv_expr (&se
, arg
);
3826 /* This is a bare variable, so there is no preliminary
3828 gcc_assert (se
.pre
.head
== NULL_TREE
3829 && se
.post
.head
== NULL_TREE
);
3830 rank
= gfc_conv_descriptor_rank (se
.expr
);
3831 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3832 gfc_array_index_type
,
3833 fold_convert (gfc_array_index_type
,
3835 gfc_index_one_node
);
3836 info
->end
[0] = gfc_evaluate_now (tmp
, &loop
->pre
);
3837 info
->start
[0] = gfc_index_zero_node
;
3838 info
->stride
[0] = gfc_index_one_node
;
3841 /* Otherwise fall through GFC_SS_FUNCTION. */
3843 case GFC_ISYM_LCOBOUND
:
3844 case GFC_ISYM_UCOBOUND
:
3845 case GFC_ISYM_THIS_IMAGE
:
3852 case GFC_SS_CONSTRUCTOR
:
3853 case GFC_SS_FUNCTION
:
3854 for (n
= 0; n
< ss
->dimen
; n
++)
3856 int dim
= ss
->dim
[n
];
3858 info
->start
[dim
] = gfc_index_zero_node
;
3859 info
->end
[dim
] = gfc_index_zero_node
;
3860 info
->stride
[dim
] = gfc_index_one_node
;
3869 /* The rest is just runtime bound checking. */
3870 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3873 tree lbound
, ubound
;
3875 tree size
[GFC_MAX_DIMENSIONS
];
3876 tree stride_pos
, stride_neg
, non_zerosized
, tmp2
, tmp3
;
3877 gfc_array_info
*info
;
3881 gfc_start_block (&block
);
3883 for (n
= 0; n
< loop
->dimen
; n
++)
3884 size
[n
] = NULL_TREE
;
3886 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3889 gfc_ss_info
*ss_info
;
3892 const char *expr_name
;
3895 if (ss_info
->type
!= GFC_SS_SECTION
)
3898 /* Catch allocatable lhs in f2003. */
3899 if (gfc_option
.flag_realloc_lhs
&& ss
->is_alloc_lhs
)
3902 expr
= ss_info
->expr
;
3903 expr_loc
= &expr
->where
;
3904 expr_name
= expr
->symtree
->name
;
3906 gfc_start_block (&inner
);
3908 /* TODO: range checking for mapped dimensions. */
3909 info
= &ss_info
->data
.array
;
3911 /* This code only checks ranges. Elemental and vector
3912 dimensions are checked later. */
3913 for (n
= 0; n
< loop
->dimen
; n
++)
3918 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
3921 if (dim
== info
->ref
->u
.ar
.dimen
- 1
3922 && info
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
3923 check_upper
= false;
3927 /* Zero stride is not allowed. */
3928 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
3929 info
->stride
[dim
], gfc_index_zero_node
);
3930 asprintf (&msg
, "Zero stride is not allowed, for dimension %d "
3931 "of array '%s'", dim
+ 1, expr_name
);
3932 gfc_trans_runtime_check (true, false, tmp
, &inner
,
3936 desc
= info
->descriptor
;
3938 /* This is the run-time equivalent of resolve.c's
3939 check_dimension(). The logical is more readable there
3940 than it is here, with all the trees. */
3941 lbound
= gfc_conv_array_lbound (desc
, dim
);
3942 end
= info
->end
[dim
];
3944 ubound
= gfc_conv_array_ubound (desc
, dim
);
3948 /* non_zerosized is true when the selected range is not
3950 stride_pos
= fold_build2_loc (input_location
, GT_EXPR
,
3951 boolean_type_node
, info
->stride
[dim
],
3952 gfc_index_zero_node
);
3953 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
3954 info
->start
[dim
], end
);
3955 stride_pos
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3956 boolean_type_node
, stride_pos
, tmp
);
3958 stride_neg
= fold_build2_loc (input_location
, LT_EXPR
,
3960 info
->stride
[dim
], gfc_index_zero_node
);
3961 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
3962 info
->start
[dim
], end
);
3963 stride_neg
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3966 non_zerosized
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
3968 stride_pos
, stride_neg
);
3970 /* Check the start of the range against the lower and upper
3971 bounds of the array, if the range is not empty.
3972 If upper bound is present, include both bounds in the
3976 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
3978 info
->start
[dim
], lbound
);
3979 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3981 non_zerosized
, tmp
);
3982 tmp2
= fold_build2_loc (input_location
, GT_EXPR
,
3984 info
->start
[dim
], ubound
);
3985 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3987 non_zerosized
, tmp2
);
3988 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
3989 "outside of expected range (%%ld:%%ld)",
3990 dim
+ 1, expr_name
);
3991 gfc_trans_runtime_check (true, false, tmp
, &inner
,
3993 fold_convert (long_integer_type_node
, info
->start
[dim
]),
3994 fold_convert (long_integer_type_node
, lbound
),
3995 fold_convert (long_integer_type_node
, ubound
));
3996 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
3998 fold_convert (long_integer_type_node
, info
->start
[dim
]),
3999 fold_convert (long_integer_type_node
, lbound
),
4000 fold_convert (long_integer_type_node
, ubound
));
4005 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
4007 info
->start
[dim
], lbound
);
4008 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4009 boolean_type_node
, non_zerosized
, tmp
);
4010 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
4011 "below lower bound of %%ld",
4012 dim
+ 1, expr_name
);
4013 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4015 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4016 fold_convert (long_integer_type_node
, lbound
));
4020 /* Compute the last element of the range, which is not
4021 necessarily "end" (think 0:5:3, which doesn't contain 5)
4022 and check it against both lower and upper bounds. */
4024 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4025 gfc_array_index_type
, end
,
4027 tmp
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
,
4028 gfc_array_index_type
, tmp
,
4030 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4031 gfc_array_index_type
, end
, tmp
);
4032 tmp2
= fold_build2_loc (input_location
, LT_EXPR
,
4033 boolean_type_node
, tmp
, lbound
);
4034 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4035 boolean_type_node
, non_zerosized
, tmp2
);
4038 tmp3
= fold_build2_loc (input_location
, GT_EXPR
,
4039 boolean_type_node
, tmp
, ubound
);
4040 tmp3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4041 boolean_type_node
, non_zerosized
, tmp3
);
4042 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
4043 "outside of expected range (%%ld:%%ld)",
4044 dim
+ 1, expr_name
);
4045 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4047 fold_convert (long_integer_type_node
, tmp
),
4048 fold_convert (long_integer_type_node
, ubound
),
4049 fold_convert (long_integer_type_node
, lbound
));
4050 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4052 fold_convert (long_integer_type_node
, tmp
),
4053 fold_convert (long_integer_type_node
, ubound
),
4054 fold_convert (long_integer_type_node
, lbound
));
4059 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
4060 "below lower bound of %%ld",
4061 dim
+ 1, expr_name
);
4062 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4064 fold_convert (long_integer_type_node
, tmp
),
4065 fold_convert (long_integer_type_node
, lbound
));
4069 /* Check the section sizes match. */
4070 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4071 gfc_array_index_type
, end
,
4073 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
4074 gfc_array_index_type
, tmp
,
4076 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4077 gfc_array_index_type
,
4078 gfc_index_one_node
, tmp
);
4079 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
4080 gfc_array_index_type
, tmp
,
4081 build_int_cst (gfc_array_index_type
, 0));
4082 /* We remember the size of the first section, and check all the
4083 others against this. */
4086 tmp3
= fold_build2_loc (input_location
, NE_EXPR
,
4087 boolean_type_node
, tmp
, size
[n
]);
4088 asprintf (&msg
, "Array bound mismatch for dimension %d "
4089 "of array '%s' (%%ld/%%ld)",
4090 dim
+ 1, expr_name
);
4092 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4094 fold_convert (long_integer_type_node
, tmp
),
4095 fold_convert (long_integer_type_node
, size
[n
]));
4100 size
[n
] = gfc_evaluate_now (tmp
, &inner
);
4103 tmp
= gfc_finish_block (&inner
);
4105 /* For optional arguments, only check bounds if the argument is
4107 if (expr
->symtree
->n
.sym
->attr
.optional
4108 || expr
->symtree
->n
.sym
->attr
.not_always_present
)
4109 tmp
= build3_v (COND_EXPR
,
4110 gfc_conv_expr_present (expr
->symtree
->n
.sym
),
4111 tmp
, build_empty_stmt (input_location
));
4113 gfc_add_expr_to_block (&block
, tmp
);
4117 tmp
= gfc_finish_block (&block
);
4118 gfc_add_expr_to_block (&loop
->pre
, tmp
);
4121 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4122 gfc_conv_ss_startstride (loop
);
4125 /* Return true if both symbols could refer to the same data object. Does
4126 not take account of aliasing due to equivalence statements. */
4129 symbols_could_alias (gfc_symbol
*lsym
, gfc_symbol
*rsym
, bool lsym_pointer
,
4130 bool lsym_target
, bool rsym_pointer
, bool rsym_target
)
4132 /* Aliasing isn't possible if the symbols have different base types. */
4133 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
4136 /* Pointers can point to other pointers and target objects. */
4138 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4139 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4142 /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
4143 and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
4145 if (lsym_target
&& rsym_target
4146 && ((lsym
->attr
.dummy
&& !lsym
->attr
.contiguous
4147 && (!lsym
->attr
.dimension
|| lsym
->as
->type
== AS_ASSUMED_SHAPE
))
4148 || (rsym
->attr
.dummy
&& !rsym
->attr
.contiguous
4149 && (!rsym
->attr
.dimension
4150 || rsym
->as
->type
== AS_ASSUMED_SHAPE
))))
4157 /* Return true if the two SS could be aliased, i.e. both point to the same data
4159 /* TODO: resolve aliases based on frontend expressions. */
4162 gfc_could_be_alias (gfc_ss
* lss
, gfc_ss
* rss
)
4166 gfc_expr
*lexpr
, *rexpr
;
4169 bool lsym_pointer
, lsym_target
, rsym_pointer
, rsym_target
;
4171 lexpr
= lss
->info
->expr
;
4172 rexpr
= rss
->info
->expr
;
4174 lsym
= lexpr
->symtree
->n
.sym
;
4175 rsym
= rexpr
->symtree
->n
.sym
;
4177 lsym_pointer
= lsym
->attr
.pointer
;
4178 lsym_target
= lsym
->attr
.target
;
4179 rsym_pointer
= rsym
->attr
.pointer
;
4180 rsym_target
= rsym
->attr
.target
;
4182 if (symbols_could_alias (lsym
, rsym
, lsym_pointer
, lsym_target
,
4183 rsym_pointer
, rsym_target
))
4186 if (rsym
->ts
.type
!= BT_DERIVED
&& rsym
->ts
.type
!= BT_CLASS
4187 && lsym
->ts
.type
!= BT_DERIVED
&& lsym
->ts
.type
!= BT_CLASS
)
4190 /* For derived types we must check all the component types. We can ignore
4191 array references as these will have the same base type as the previous
4193 for (lref
= lexpr
->ref
; lref
!= lss
->info
->data
.array
.ref
; lref
= lref
->next
)
4195 if (lref
->type
!= REF_COMPONENT
)
4198 lsym_pointer
= lsym_pointer
|| lref
->u
.c
.sym
->attr
.pointer
;
4199 lsym_target
= lsym_target
|| lref
->u
.c
.sym
->attr
.target
;
4201 if (symbols_could_alias (lref
->u
.c
.sym
, rsym
, lsym_pointer
, lsym_target
,
4202 rsym_pointer
, rsym_target
))
4205 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4206 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4208 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4213 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
;
4216 if (rref
->type
!= REF_COMPONENT
)
4219 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4220 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4222 if (symbols_could_alias (lref
->u
.c
.sym
, rref
->u
.c
.sym
,
4223 lsym_pointer
, lsym_target
,
4224 rsym_pointer
, rsym_target
))
4227 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4228 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4230 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4231 &rref
->u
.c
.sym
->ts
))
4233 if (gfc_compare_types (&lref
->u
.c
.sym
->ts
,
4234 &rref
->u
.c
.component
->ts
))
4236 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4237 &rref
->u
.c
.component
->ts
))
4243 lsym_pointer
= lsym
->attr
.pointer
;
4244 lsym_target
= lsym
->attr
.target
;
4245 lsym_pointer
= lsym
->attr
.pointer
;
4246 lsym_target
= lsym
->attr
.target
;
4248 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
; rref
= rref
->next
)
4250 if (rref
->type
!= REF_COMPONENT
)
4253 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4254 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4256 if (symbols_could_alias (rref
->u
.c
.sym
, lsym
,
4257 lsym_pointer
, lsym_target
,
4258 rsym_pointer
, rsym_target
))
4261 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4262 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4264 if (gfc_compare_types (&lsym
->ts
, &rref
->u
.c
.component
->ts
))
4273 /* Resolve array data dependencies. Creates a temporary if required. */
4274 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
4278 gfc_conv_resolve_dependencies (gfc_loopinfo
* loop
, gfc_ss
* dest
,
4284 gfc_expr
*dest_expr
;
4289 loop
->temp_ss
= NULL
;
4290 dest_expr
= dest
->info
->expr
;
4292 for (ss
= rss
; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
4294 if (ss
->info
->type
!= GFC_SS_SECTION
)
4297 ss_expr
= ss
->info
->expr
;
4299 if (dest_expr
->symtree
->n
.sym
!= ss_expr
->symtree
->n
.sym
)
4301 if (gfc_could_be_alias (dest
, ss
)
4302 || gfc_are_equivalenced_arrays (dest_expr
, ss_expr
))
4310 lref
= dest_expr
->ref
;
4311 rref
= ss_expr
->ref
;
4313 nDepend
= gfc_dep_resolver (lref
, rref
, &loop
->reverse
[0]);
4318 for (i
= 0; i
< dest
->dimen
; i
++)
4319 for (j
= 0; j
< ss
->dimen
; j
++)
4321 && dest
->dim
[i
] == ss
->dim
[j
])
4323 /* If we don't access array elements in the same order,
4324 there is a dependency. */
4329 /* TODO : loop shifting. */
4332 /* Mark the dimensions for LOOP SHIFTING */
4333 for (n
= 0; n
< loop
->dimen
; n
++)
4335 int dim
= dest
->data
.info
.dim
[n
];
4337 if (lref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
4339 else if (! gfc_is_same_range (&lref
->u
.ar
,
4340 &rref
->u
.ar
, dim
, 0))
4344 /* Put all the dimensions with dependencies in the
4347 for (n
= 0; n
< loop
->dimen
; n
++)
4349 gcc_assert (loop
->order
[n
] == n
);
4351 loop
->order
[dim
++] = n
;
4353 for (n
= 0; n
< loop
->dimen
; n
++)
4356 loop
->order
[dim
++] = n
;
4359 gcc_assert (dim
== loop
->dimen
);
4370 tree base_type
= gfc_typenode_for_spec (&dest_expr
->ts
);
4371 if (GFC_ARRAY_TYPE_P (base_type
)
4372 || GFC_DESCRIPTOR_TYPE_P (base_type
))
4373 base_type
= gfc_get_element_type (base_type
);
4374 loop
->temp_ss
= gfc_get_temp_ss (base_type
, dest
->info
->string_length
,
4376 gfc_add_ss_to_loop (loop
, loop
->temp_ss
);
4379 loop
->temp_ss
= NULL
;
4383 /* Browse through each array's information from the scalarizer and set the loop
4384 bounds according to the "best" one (per dimension), i.e. the one which
4385 provides the most information (constant bounds, shape, etc.). */
4388 set_loop_bounds (gfc_loopinfo
*loop
)
4390 int n
, dim
, spec_dim
;
4391 gfc_array_info
*info
;
4392 gfc_array_info
*specinfo
;
4396 bool dynamic
[GFC_MAX_DIMENSIONS
];
4399 bool nonoptional_arr
;
4401 loopspec
= loop
->specloop
;
4404 for (n
= 0; n
< loop
->dimen
; n
++)
4409 /* If there are both optional and nonoptional array arguments, scalarize
4410 over the nonoptional; otherwise, it does not matter as then all
4411 (optional) arrays have to be present per F2008, 125.2.12p3(6). */
4413 nonoptional_arr
= false;
4415 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4416 if (ss
->info
->type
!= GFC_SS_SCALAR
&& ss
->info
->type
!= GFC_SS_TEMP
4417 && ss
->info
->type
!= GFC_SS_REFERENCE
&& !ss
->info
->can_be_null_ref
)
4418 nonoptional_arr
= true;
4420 /* We use one SS term, and use that to determine the bounds of the
4421 loop for this dimension. We try to pick the simplest term. */
4422 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4424 gfc_ss_type ss_type
;
4426 ss_type
= ss
->info
->type
;
4427 if (ss_type
== GFC_SS_SCALAR
4428 || ss_type
== GFC_SS_TEMP
4429 || ss_type
== GFC_SS_REFERENCE
4430 || (ss
->info
->can_be_null_ref
&& nonoptional_arr
))
4433 info
= &ss
->info
->data
.array
;
4436 if (loopspec
[n
] != NULL
)
4438 specinfo
= &loopspec
[n
]->info
->data
.array
;
4439 spec_dim
= loopspec
[n
]->dim
[n
];
4443 /* Silence uninitialized warnings. */
4450 gcc_assert (info
->shape
[dim
]);
4451 /* The frontend has worked out the size for us. */
4454 || !integer_zerop (specinfo
->start
[spec_dim
]))
4455 /* Prefer zero-based descriptors if possible. */
4460 if (ss_type
== GFC_SS_CONSTRUCTOR
)
4462 gfc_constructor_base base
;
4463 /* An unknown size constructor will always be rank one.
4464 Higher rank constructors will either have known shape,
4465 or still be wrapped in a call to reshape. */
4466 gcc_assert (loop
->dimen
== 1);
4468 /* Always prefer to use the constructor bounds if the size
4469 can be determined at compile time. Prefer not to otherwise,
4470 since the general case involves realloc, and it's better to
4471 avoid that overhead if possible. */
4472 base
= ss
->info
->expr
->value
.constructor
;
4473 dynamic
[n
] = gfc_get_array_constructor_size (&i
, base
);
4474 if (!dynamic
[n
] || !loopspec
[n
])
4479 /* Avoid using an allocatable lhs in an assignment, since
4480 there might be a reallocation coming. */
4481 if (loopspec
[n
] && ss
->is_alloc_lhs
)
4486 /* Criteria for choosing a loop specifier (most important first):
4487 doesn't need realloc
4493 else if (loopspec
[n
]->info
->type
== GFC_SS_CONSTRUCTOR
&& dynamic
[n
])
4495 else if (integer_onep (info
->stride
[dim
])
4496 && !integer_onep (specinfo
->stride
[spec_dim
]))
4498 else if (INTEGER_CST_P (info
->stride
[dim
])
4499 && !INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
4501 else if (INTEGER_CST_P (info
->start
[dim
])
4502 && !INTEGER_CST_P (specinfo
->start
[spec_dim
])
4503 && integer_onep (info
->stride
[dim
])
4504 == integer_onep (specinfo
->stride
[spec_dim
])
4505 && INTEGER_CST_P (info
->stride
[dim
])
4506 == INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
4508 /* We don't work out the upper bound.
4509 else if (INTEGER_CST_P (info->finish[n])
4510 && ! INTEGER_CST_P (specinfo->finish[n]))
4511 loopspec[n] = ss; */
4514 /* We should have found the scalarization loop specifier. If not,
4516 gcc_assert (loopspec
[n
]);
4518 info
= &loopspec
[n
]->info
->data
.array
;
4519 dim
= loopspec
[n
]->dim
[n
];
4521 /* Set the extents of this range. */
4522 cshape
= info
->shape
;
4523 if (cshape
&& INTEGER_CST_P (info
->start
[dim
])
4524 && INTEGER_CST_P (info
->stride
[dim
]))
4526 loop
->from
[n
] = info
->start
[dim
];
4527 mpz_set (i
, cshape
[get_array_ref_dim_for_loop_dim (loopspec
[n
], n
)]);
4528 mpz_sub_ui (i
, i
, 1);
4529 /* To = from + (size - 1) * stride. */
4530 tmp
= gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
4531 if (!integer_onep (info
->stride
[dim
]))
4532 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
4533 gfc_array_index_type
, tmp
,
4535 loop
->to
[n
] = fold_build2_loc (input_location
, PLUS_EXPR
,
4536 gfc_array_index_type
,
4537 loop
->from
[n
], tmp
);
4541 loop
->from
[n
] = info
->start
[dim
];
4542 switch (loopspec
[n
]->info
->type
)
4544 case GFC_SS_CONSTRUCTOR
:
4545 /* The upper bound is calculated when we expand the
4547 gcc_assert (loop
->to
[n
] == NULL_TREE
);
4550 case GFC_SS_SECTION
:
4551 /* Use the end expression if it exists and is not constant,
4552 so that it is only evaluated once. */
4553 loop
->to
[n
] = info
->end
[dim
];
4556 case GFC_SS_FUNCTION
:
4557 /* The loop bound will be set when we generate the call. */
4558 gcc_assert (loop
->to
[n
] == NULL_TREE
);
4561 case GFC_SS_INTRINSIC
:
4563 gfc_expr
*expr
= loopspec
[n
]->info
->expr
;
4565 /* The {l,u}bound of an assumed rank. */
4566 gcc_assert ((expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
4567 || expr
->value
.function
.isym
->id
== GFC_ISYM_UBOUND
)
4568 && expr
->value
.function
.actual
->next
->expr
== NULL
4569 && expr
->value
.function
.actual
->expr
->rank
== -1);
4571 loop
->to
[n
] = info
->end
[dim
];
4580 /* Transform everything so we have a simple incrementing variable. */
4581 if (integer_onep (info
->stride
[dim
]))
4582 info
->delta
[dim
] = gfc_index_zero_node
;
4585 /* Set the delta for this section. */
4586 info
->delta
[dim
] = gfc_evaluate_now (loop
->from
[n
], &loop
->pre
);
4587 /* Number of iterations is (end - start + step) / step.
4588 with start = 0, this simplifies to
4590 for (i = 0; i<=last; i++){...}; */
4591 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4592 gfc_array_index_type
, loop
->to
[n
],
4594 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
4595 gfc_array_index_type
, tmp
, info
->stride
[dim
]);
4596 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
4597 tmp
, build_int_cst (gfc_array_index_type
, -1));
4598 loop
->to
[n
] = gfc_evaluate_now (tmp
, &loop
->pre
);
4599 /* Make the loop variable start at 0. */
4600 loop
->from
[n
] = gfc_index_zero_node
;
4605 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4606 set_loop_bounds (loop
);
4610 /* Initialize the scalarization loop. Creates the loop variables. Determines
4611 the range of the loop variables. Creates a temporary if required.
4612 Also generates code for scalar expressions which have been
4613 moved outside the loop. */
4616 gfc_conv_loop_setup (gfc_loopinfo
* loop
, locus
* where
)
4621 set_loop_bounds (loop
);
4623 /* Add all the scalar code that can be taken out of the loops.
4624 This may include calculating the loop bounds, so do it before
4625 allocating the temporary. */
4626 gfc_add_loop_ss_code (loop
, loop
->ss
, false, where
);
4628 tmp_ss
= loop
->temp_ss
;
4629 /* If we want a temporary then create it. */
4632 gfc_ss_info
*tmp_ss_info
;
4634 tmp_ss_info
= tmp_ss
->info
;
4635 gcc_assert (tmp_ss_info
->type
== GFC_SS_TEMP
);
4636 gcc_assert (loop
->parent
== NULL
);
4638 /* Make absolutely sure that this is a complete type. */
4639 if (tmp_ss_info
->string_length
)
4640 tmp_ss_info
->data
.temp
.type
4641 = gfc_get_character_type_len_for_eltype
4642 (TREE_TYPE (tmp_ss_info
->data
.temp
.type
),
4643 tmp_ss_info
->string_length
);
4645 tmp
= tmp_ss_info
->data
.temp
.type
;
4646 memset (&tmp_ss_info
->data
.array
, 0, sizeof (gfc_array_info
));
4647 tmp_ss_info
->type
= GFC_SS_SECTION
;
4649 gcc_assert (tmp_ss
->dimen
!= 0);
4651 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, tmp_ss
, tmp
,
4652 NULL_TREE
, false, true, false, where
);
4655 /* For array parameters we don't have loop variables, so don't calculate the
4657 if (!loop
->array_parameter
)
4658 gfc_set_delta (loop
);
4662 /* Calculates how to transform from loop variables to array indices for each
4663 array: once loop bounds are chosen, sets the difference (DELTA field) between
4664 loop bounds and array reference bounds, for each array info. */
4667 gfc_set_delta (gfc_loopinfo
*loop
)
4669 gfc_ss
*ss
, **loopspec
;
4670 gfc_array_info
*info
;
4674 loopspec
= loop
->specloop
;
4676 /* Calculate the translation from loop variables to array indices. */
4677 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4679 gfc_ss_type ss_type
;
4681 ss_type
= ss
->info
->type
;
4682 if (ss_type
!= GFC_SS_SECTION
4683 && ss_type
!= GFC_SS_COMPONENT
4684 && ss_type
!= GFC_SS_CONSTRUCTOR
)
4687 info
= &ss
->info
->data
.array
;
4689 for (n
= 0; n
< ss
->dimen
; n
++)
4691 /* If we are specifying the range the delta is already set. */
4692 if (loopspec
[n
] != ss
)
4696 /* Calculate the offset relative to the loop variable.
4697 First multiply by the stride. */
4698 tmp
= loop
->from
[n
];
4699 if (!integer_onep (info
->stride
[dim
]))
4700 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
4701 gfc_array_index_type
,
4702 tmp
, info
->stride
[dim
]);
4704 /* Then subtract this from our starting value. */
4705 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4706 gfc_array_index_type
,
4707 info
->start
[dim
], tmp
);
4709 info
->delta
[dim
] = gfc_evaluate_now (tmp
, &loop
->pre
);
4714 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4715 gfc_set_delta (loop
);
4719 /* Calculate the size of a given array dimension from the bounds. This
4720 is simply (ubound - lbound + 1) if this expression is positive
4721 or 0 if it is negative (pick either one if it is zero). Optionally
4722 (if or_expr is present) OR the (expression != 0) condition to it. */
4725 gfc_conv_array_extent_dim (tree lbound
, tree ubound
, tree
* or_expr
)
4730 /* Calculate (ubound - lbound + 1). */
4731 res
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4733 res
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
, res
,
4734 gfc_index_one_node
);
4736 /* Check whether the size for this dimension is negative. */
4737 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, res
,
4738 gfc_index_zero_node
);
4739 res
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
, cond
,
4740 gfc_index_zero_node
, res
);
4742 /* Build OR expression. */
4744 *or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
4745 boolean_type_node
, *or_expr
, cond
);
4751 /* For an array descriptor, get the total number of elements. This is just
4752 the product of the extents along from_dim to to_dim. */
4755 gfc_conv_descriptor_size_1 (tree desc
, int from_dim
, int to_dim
)
4760 res
= gfc_index_one_node
;
4762 for (dim
= from_dim
; dim
< to_dim
; ++dim
)
4768 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]);
4769 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]);
4771 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
4772 res
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4780 /* Full size of an array. */
4783 gfc_conv_descriptor_size (tree desc
, int rank
)
4785 return gfc_conv_descriptor_size_1 (desc
, 0, rank
);
4789 /* Size of a coarray for all dimensions but the last. */
4792 gfc_conv_descriptor_cosize (tree desc
, int rank
, int corank
)
4794 return gfc_conv_descriptor_size_1 (desc
, rank
, rank
+ corank
- 1);
4798 /* Fills in an array descriptor, and returns the size of the array.
4799 The size will be a simple_val, ie a variable or a constant. Also
4800 calculates the offset of the base. The pointer argument overflow,
4801 which should be of integer type, will increase in value if overflow
4802 occurs during the size calculation. Returns the size of the array.
4806 for (n = 0; n < rank; n++)
4808 a.lbound[n] = specified_lower_bound;
4809 offset = offset + a.lbond[n] * stride;
4811 a.ubound[n] = specified_upper_bound;
4812 a.stride[n] = stride;
4813 size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
4814 overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
4815 stride = stride * size;
4817 for (n = rank; n < rank+corank; n++)
4818 (Set lcobound/ucobound as above.)
4819 element_size = sizeof (array element);
4822 stride = (size_t) stride;
4823 overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
4824 stride = stride * element_size;
4830 gfc_array_init_size (tree descriptor
, int rank
, int corank
, tree
* poffset
,
4831 gfc_expr
** lower
, gfc_expr
** upper
, stmtblock_t
* pblock
,
4832 stmtblock_t
* descriptor_block
, tree
* overflow
,
4833 tree expr3_elem_size
, tree
*nelems
, gfc_expr
*expr3
)
4846 stmtblock_t thenblock
;
4847 stmtblock_t elseblock
;
4852 type
= TREE_TYPE (descriptor
);
4854 stride
= gfc_index_one_node
;
4855 offset
= gfc_index_zero_node
;
4857 /* Set the dtype. */
4858 tmp
= gfc_conv_descriptor_dtype (descriptor
);
4859 gfc_add_modify (descriptor_block
, tmp
, gfc_get_dtype (TREE_TYPE (descriptor
)));
4861 or_expr
= boolean_false_node
;
4863 for (n
= 0; n
< rank
; n
++)
4868 /* We have 3 possibilities for determining the size of the array:
4869 lower == NULL => lbound = 1, ubound = upper[n]
4870 upper[n] = NULL => lbound = 1, ubound = lower[n]
4871 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
4874 /* Set lower bound. */
4875 gfc_init_se (&se
, NULL
);
4877 se
.expr
= gfc_index_one_node
;
4880 gcc_assert (lower
[n
]);
4883 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
4884 gfc_add_block_to_block (pblock
, &se
.pre
);
4888 se
.expr
= gfc_index_one_node
;
4892 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
4893 gfc_rank_cst
[n
], se
.expr
);
4894 conv_lbound
= se
.expr
;
4896 /* Work out the offset for this component. */
4897 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4899 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
4900 gfc_array_index_type
, offset
, tmp
);
4902 /* Set upper bound. */
4903 gfc_init_se (&se
, NULL
);
4904 gcc_assert (ubound
);
4905 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
4906 gfc_add_block_to_block (pblock
, &se
.pre
);
4908 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
4909 gfc_rank_cst
[n
], se
.expr
);
4910 conv_ubound
= se
.expr
;
4912 /* Store the stride. */
4913 gfc_conv_descriptor_stride_set (descriptor_block
, descriptor
,
4914 gfc_rank_cst
[n
], stride
);
4916 /* Calculate size and check whether extent is negative. */
4917 size
= gfc_conv_array_extent_dim (conv_lbound
, conv_ubound
, &or_expr
);
4918 size
= gfc_evaluate_now (size
, pblock
);
4920 /* Check whether multiplying the stride by the number of
4921 elements in this dimension would overflow. We must also check
4922 whether the current dimension has zero size in order to avoid
4925 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
4926 gfc_array_index_type
,
4927 fold_convert (gfc_array_index_type
,
4928 TYPE_MAX_VALUE (gfc_array_index_type
)),
4930 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
4931 boolean_type_node
, tmp
, stride
));
4932 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
4933 integer_one_node
, integer_zero_node
);
4934 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
4935 boolean_type_node
, size
,
4936 gfc_index_zero_node
));
4937 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
4938 integer_zero_node
, tmp
);
4939 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
4941 *overflow
= gfc_evaluate_now (tmp
, pblock
);
4943 /* Multiply the stride by the number of elements in this dimension. */
4944 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
4945 gfc_array_index_type
, stride
, size
);
4946 stride
= gfc_evaluate_now (stride
, pblock
);
4949 for (n
= rank
; n
< rank
+ corank
; n
++)
4953 /* Set lower bound. */
4954 gfc_init_se (&se
, NULL
);
4955 if (lower
== NULL
|| lower
[n
] == NULL
)
4957 gcc_assert (n
== rank
+ corank
- 1);
4958 se
.expr
= gfc_index_one_node
;
4962 if (ubound
|| n
== rank
+ corank
- 1)
4964 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
4965 gfc_add_block_to_block (pblock
, &se
.pre
);
4969 se
.expr
= gfc_index_one_node
;
4973 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
4974 gfc_rank_cst
[n
], se
.expr
);
4976 if (n
< rank
+ corank
- 1)
4978 gfc_init_se (&se
, NULL
);
4979 gcc_assert (ubound
);
4980 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
4981 gfc_add_block_to_block (pblock
, &se
.pre
);
4982 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
4983 gfc_rank_cst
[n
], se
.expr
);
4987 /* The stride is the number of elements in the array, so multiply by the
4988 size of an element to get the total size. Obviously, if there is a
4989 SOURCE expression (expr3) we must use its element size. */
4990 if (expr3_elem_size
!= NULL_TREE
)
4991 tmp
= expr3_elem_size
;
4992 else if (expr3
!= NULL
)
4994 if (expr3
->ts
.type
== BT_CLASS
)
4997 gfc_expr
*sz
= gfc_copy_expr (expr3
);
4998 gfc_add_vptr_component (sz
);
4999 gfc_add_size_component (sz
);
5000 gfc_init_se (&se_sz
, NULL
);
5001 gfc_conv_expr (&se_sz
, sz
);
5007 tmp
= gfc_typenode_for_spec (&expr3
->ts
);
5008 tmp
= TYPE_SIZE_UNIT (tmp
);
5012 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
5014 /* Convert to size_t. */
5015 element_size
= fold_convert (size_type_node
, tmp
);
5018 return element_size
;
5020 *nelems
= gfc_evaluate_now (stride
, pblock
);
5021 stride
= fold_convert (size_type_node
, stride
);
5023 /* First check for overflow. Since an array of type character can
5024 have zero element_size, we must check for that before
5026 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
5028 TYPE_MAX_VALUE (size_type_node
), element_size
);
5029 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
5030 boolean_type_node
, tmp
, stride
));
5031 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5032 integer_one_node
, integer_zero_node
);
5033 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
5034 boolean_type_node
, element_size
,
5035 build_int_cst (size_type_node
, 0)));
5036 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5037 integer_zero_node
, tmp
);
5038 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
5040 *overflow
= gfc_evaluate_now (tmp
, pblock
);
5042 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5043 stride
, element_size
);
5045 if (poffset
!= NULL
)
5047 offset
= gfc_evaluate_now (offset
, pblock
);
5051 if (integer_zerop (or_expr
))
5053 if (integer_onep (or_expr
))
5054 return build_int_cst (size_type_node
, 0);
5056 var
= gfc_create_var (TREE_TYPE (size
), "size");
5057 gfc_start_block (&thenblock
);
5058 gfc_add_modify (&thenblock
, var
, build_int_cst (size_type_node
, 0));
5059 thencase
= gfc_finish_block (&thenblock
);
5061 gfc_start_block (&elseblock
);
5062 gfc_add_modify (&elseblock
, var
, size
);
5063 elsecase
= gfc_finish_block (&elseblock
);
5065 tmp
= gfc_evaluate_now (or_expr
, pblock
);
5066 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
5067 gfc_add_expr_to_block (pblock
, tmp
);
5073 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
5074 the work for an ALLOCATE statement. */
5078 gfc_array_allocate (gfc_se
* se
, gfc_expr
* expr
, tree status
, tree errmsg
,
5079 tree errlen
, tree label_finish
, tree expr3_elem_size
,
5080 tree
*nelems
, gfc_expr
*expr3
)
5084 tree offset
= NULL_TREE
;
5085 tree token
= NULL_TREE
;
5088 tree error
= NULL_TREE
;
5089 tree overflow
; /* Boolean storing whether size calculation overflows. */
5090 tree var_overflow
= NULL_TREE
;
5092 tree set_descriptor
;
5093 stmtblock_t set_descriptor_block
;
5094 stmtblock_t elseblock
;
5097 gfc_ref
*ref
, *prev_ref
= NULL
;
5098 bool allocatable
, coarray
, dimension
;
5102 /* Find the last reference in the chain. */
5103 while (ref
&& ref
->next
!= NULL
)
5105 gcc_assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
5106 || (ref
->u
.ar
.dimen
== 0 && ref
->u
.ar
.codimen
> 0));
5111 if (ref
== NULL
|| ref
->type
!= REF_ARRAY
)
5116 allocatable
= expr
->symtree
->n
.sym
->attr
.allocatable
;
5117 coarray
= expr
->symtree
->n
.sym
->attr
.codimension
;
5118 dimension
= expr
->symtree
->n
.sym
->attr
.dimension
;
5122 allocatable
= prev_ref
->u
.c
.component
->attr
.allocatable
;
5123 coarray
= prev_ref
->u
.c
.component
->attr
.codimension
;
5124 dimension
= prev_ref
->u
.c
.component
->attr
.dimension
;
5128 gcc_assert (coarray
);
5130 /* Figure out the size of the array. */
5131 switch (ref
->u
.ar
.type
)
5137 upper
= ref
->u
.ar
.start
;
5143 lower
= ref
->u
.ar
.start
;
5144 upper
= ref
->u
.ar
.end
;
5148 gcc_assert (ref
->u
.ar
.as
->type
== AS_EXPLICIT
);
5150 lower
= ref
->u
.ar
.as
->lower
;
5151 upper
= ref
->u
.ar
.as
->upper
;
5159 overflow
= integer_zero_node
;
5161 gfc_init_block (&set_descriptor_block
);
5162 size
= gfc_array_init_size (se
->expr
, ref
->u
.ar
.as
->rank
,
5163 ref
->u
.ar
.as
->corank
, &offset
, lower
, upper
,
5164 &se
->pre
, &set_descriptor_block
, &overflow
,
5165 expr3_elem_size
, nelems
, expr3
);
5170 var_overflow
= gfc_create_var (integer_type_node
, "overflow");
5171 gfc_add_modify (&se
->pre
, var_overflow
, overflow
);
5173 /* Generate the block of code handling overflow. */
5174 msg
= gfc_build_addr_expr (pchar_type_node
,
5175 gfc_build_localized_cstring_const
5176 ("Integer overflow when calculating the amount of "
5177 "memory to allocate"));
5178 error
= build_call_expr_loc (input_location
, gfor_fndecl_runtime_error
,
5182 if (status
!= NULL_TREE
)
5184 tree status_type
= TREE_TYPE (status
);
5185 stmtblock_t set_status_block
;
5187 gfc_start_block (&set_status_block
);
5188 gfc_add_modify (&set_status_block
, status
,
5189 build_int_cst (status_type
, LIBERROR_ALLOCATION
));
5190 error
= gfc_finish_block (&set_status_block
);
5193 gfc_start_block (&elseblock
);
5195 /* Allocate memory to store the data. */
5196 if (POINTER_TYPE_P (TREE_TYPE (se
->expr
)))
5197 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
5199 pointer
= gfc_conv_descriptor_data_get (se
->expr
);
5200 STRIP_NOPS (pointer
);
5202 if (coarray
&& gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
5203 token
= gfc_build_addr_expr (NULL_TREE
,
5204 gfc_conv_descriptor_token (se
->expr
));
5206 /* The allocatable variant takes the old pointer as first argument. */
5208 gfc_allocate_allocatable (&elseblock
, pointer
, size
, token
,
5209 status
, errmsg
, errlen
, label_finish
, expr
);
5211 gfc_allocate_using_malloc (&elseblock
, pointer
, size
, status
);
5215 cond
= gfc_unlikely (fold_build2_loc (input_location
, NE_EXPR
,
5216 boolean_type_node
, var_overflow
, integer_zero_node
));
5217 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
5218 error
, gfc_finish_block (&elseblock
));
5221 tmp
= gfc_finish_block (&elseblock
);
5223 gfc_add_expr_to_block (&se
->pre
, tmp
);
5225 if (expr
->ts
.type
== BT_CLASS
)
5227 tmp
= build_int_cst (unsigned_char_type_node
, 0);
5228 /* With class objects, it is best to play safe and null the
5229 memory because we cannot know if dynamic types have allocatable
5230 components or not. */
5231 tmp
= build_call_expr_loc (input_location
,
5232 builtin_decl_explicit (BUILT_IN_MEMSET
),
5233 3, pointer
, tmp
, size
);
5234 gfc_add_expr_to_block (&se
->pre
, tmp
);
5237 /* Update the array descriptors. */
5239 gfc_conv_descriptor_offset_set (&set_descriptor_block
, se
->expr
, offset
);
5241 set_descriptor
= gfc_finish_block (&set_descriptor_block
);
5242 if (status
!= NULL_TREE
)
5244 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
5245 boolean_type_node
, status
,
5246 build_int_cst (TREE_TYPE (status
), 0));
5247 gfc_add_expr_to_block (&se
->pre
,
5248 fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5249 gfc_likely (cond
), set_descriptor
,
5250 build_empty_stmt (input_location
)));
5253 gfc_add_expr_to_block (&se
->pre
, set_descriptor
);
5255 if ((expr
->ts
.type
== BT_DERIVED
)
5256 && expr
->ts
.u
.derived
->attr
.alloc_comp
)
5258 tmp
= gfc_nullify_alloc_comp (expr
->ts
.u
.derived
, se
->expr
,
5259 ref
->u
.ar
.as
->rank
);
5260 gfc_add_expr_to_block (&se
->pre
, tmp
);
5267 /* Deallocate an array variable. Also used when an allocated variable goes
5272 gfc_array_deallocate (tree descriptor
, tree pstat
, tree errmsg
, tree errlen
,
5273 tree label_finish
, gfc_expr
* expr
)
5278 bool coarray
= gfc_is_coarray (expr
);
5280 gfc_start_block (&block
);
5282 /* Get a pointer to the data. */
5283 var
= gfc_conv_descriptor_data_get (descriptor
);
5286 /* Parameter is the address of the data component. */
5287 tmp
= gfc_deallocate_with_status (coarray
? descriptor
: var
, pstat
, errmsg
,
5288 errlen
, label_finish
, false, expr
, coarray
);
5289 gfc_add_expr_to_block (&block
, tmp
);
5291 /* Zero the data pointer; only for coarrays an error can occur and then
5292 the allocation status may not be changed. */
5293 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
5294 var
, build_int_cst (TREE_TYPE (var
), 0));
5295 if (pstat
!= NULL_TREE
&& coarray
&& gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
5298 tree stat
= build_fold_indirect_ref_loc (input_location
, pstat
);
5300 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5301 stat
, build_int_cst (TREE_TYPE (stat
), 0));
5302 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5303 cond
, tmp
, build_empty_stmt (input_location
));
5306 gfc_add_expr_to_block (&block
, tmp
);
5308 return gfc_finish_block (&block
);
5312 /* Create an array constructor from an initialization expression.
5313 We assume the frontend already did any expansions and conversions. */
5316 gfc_conv_array_initializer (tree type
, gfc_expr
* expr
)
5322 unsigned HOST_WIDE_INT lo
;
5324 vec
<constructor_elt
, va_gc
> *v
= NULL
;
5326 if (expr
->expr_type
== EXPR_VARIABLE
5327 && expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
5328 && expr
->symtree
->n
.sym
->value
)
5329 expr
= expr
->symtree
->n
.sym
->value
;
5331 switch (expr
->expr_type
)
5334 case EXPR_STRUCTURE
:
5335 /* A single scalar or derived type value. Create an array with all
5336 elements equal to that value. */
5337 gfc_init_se (&se
, NULL
);
5339 if (expr
->expr_type
== EXPR_CONSTANT
)
5340 gfc_conv_constant (&se
, expr
);
5342 gfc_conv_structure (&se
, expr
, 1);
5344 tmp
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
5345 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
5346 hi
= TREE_INT_CST_HIGH (tmp
);
5347 lo
= TREE_INT_CST_LOW (tmp
);
5351 /* This will probably eat buckets of memory for large arrays. */
5352 while (hi
!= 0 || lo
!= 0)
5354 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
, se
.expr
);
5362 /* Create a vector of all the elements. */
5363 for (c
= gfc_constructor_first (expr
->value
.constructor
);
5364 c
; c
= gfc_constructor_next (c
))
5368 /* Problems occur when we get something like
5369 integer :: a(lots) = (/(i, i=1, lots)/) */
5370 gfc_fatal_error ("The number of elements in the array constructor "
5371 "at %L requires an increase of the allowed %d "
5372 "upper limit. See -fmax-array-constructor "
5373 "option", &expr
->where
,
5374 gfc_option
.flag_max_array_constructor
);
5377 if (mpz_cmp_si (c
->offset
, 0) != 0)
5378 index
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
5382 if (mpz_cmp_si (c
->repeat
, 1) > 0)
5388 mpz_add (maxval
, c
->offset
, c
->repeat
);
5389 mpz_sub_ui (maxval
, maxval
, 1);
5390 tmp2
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
5391 if (mpz_cmp_si (c
->offset
, 0) != 0)
5393 mpz_add_ui (maxval
, c
->offset
, 1);
5394 tmp1
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
5397 tmp1
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
5399 range
= fold_build2 (RANGE_EXPR
, gfc_array_index_type
, tmp1
, tmp2
);
5405 gfc_init_se (&se
, NULL
);
5406 switch (c
->expr
->expr_type
)
5409 gfc_conv_constant (&se
, c
->expr
);
5412 case EXPR_STRUCTURE
:
5413 gfc_conv_structure (&se
, c
->expr
, 1);
5417 /* Catch those occasional beasts that do not simplify
5418 for one reason or another, assuming that if they are
5419 standard defying the frontend will catch them. */
5420 gfc_conv_expr (&se
, c
->expr
);
5424 if (range
== NULL_TREE
)
5425 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
5428 if (index
!= NULL_TREE
)
5429 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
5430 CONSTRUCTOR_APPEND_ELT (v
, range
, se
.expr
);
5436 return gfc_build_null_descriptor (type
);
5442 /* Create a constructor from the list of elements. */
5443 tmp
= build_constructor (type
, v
);
5444 TREE_CONSTANT (tmp
) = 1;
5449 /* Generate code to evaluate non-constant coarray cobounds. */
5452 gfc_trans_array_cobounds (tree type
, stmtblock_t
* pblock
,
5453 const gfc_symbol
*sym
)
5463 for (dim
= as
->rank
; dim
< as
->rank
+ as
->corank
; dim
++)
5465 /* Evaluate non-constant array bound expressions. */
5466 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
5467 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
5469 gfc_init_se (&se
, NULL
);
5470 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
5471 gfc_add_block_to_block (pblock
, &se
.pre
);
5472 gfc_add_modify (pblock
, lbound
, se
.expr
);
5474 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
5475 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
5477 gfc_init_se (&se
, NULL
);
5478 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
5479 gfc_add_block_to_block (pblock
, &se
.pre
);
5480 gfc_add_modify (pblock
, ubound
, se
.expr
);
5486 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
5487 returns the size (in elements) of the array. */
5490 gfc_trans_array_bounds (tree type
, gfc_symbol
* sym
, tree
* poffset
,
5491 stmtblock_t
* pblock
)
5506 size
= gfc_index_one_node
;
5507 offset
= gfc_index_zero_node
;
5508 for (dim
= 0; dim
< as
->rank
; dim
++)
5510 /* Evaluate non-constant array bound expressions. */
5511 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
5512 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
5514 gfc_init_se (&se
, NULL
);
5515 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
5516 gfc_add_block_to_block (pblock
, &se
.pre
);
5517 gfc_add_modify (pblock
, lbound
, se
.expr
);
5519 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
5520 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
5522 gfc_init_se (&se
, NULL
);
5523 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
5524 gfc_add_block_to_block (pblock
, &se
.pre
);
5525 gfc_add_modify (pblock
, ubound
, se
.expr
);
5527 /* The offset of this dimension. offset = offset - lbound * stride. */
5528 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5530 offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5533 /* The size of this dimension, and the stride of the next. */
5534 if (dim
+ 1 < as
->rank
)
5535 stride
= GFC_TYPE_ARRAY_STRIDE (type
, dim
+ 1);
5537 stride
= GFC_TYPE_ARRAY_SIZE (type
);
5539 if (ubound
!= NULL_TREE
&& !(stride
&& INTEGER_CST_P (stride
)))
5541 /* Calculate stride = size * (ubound + 1 - lbound). */
5542 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5543 gfc_array_index_type
,
5544 gfc_index_one_node
, lbound
);
5545 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5546 gfc_array_index_type
, ubound
, tmp
);
5547 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5548 gfc_array_index_type
, size
, tmp
);
5550 gfc_add_modify (pblock
, stride
, tmp
);
5552 stride
= gfc_evaluate_now (tmp
, pblock
);
5554 /* Make sure that negative size arrays are translated
5555 to being zero size. */
5556 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
5557 stride
, gfc_index_zero_node
);
5558 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5559 gfc_array_index_type
, tmp
,
5560 stride
, gfc_index_zero_node
);
5561 gfc_add_modify (pblock
, stride
, tmp
);
5567 gfc_trans_array_cobounds (type
, pblock
, sym
);
5568 gfc_trans_vla_type_sizes (sym
, pblock
);
5575 /* Generate code to initialize/allocate an array variable. */
5578 gfc_trans_auto_array_allocation (tree decl
, gfc_symbol
* sym
,
5579 gfc_wrapped_block
* block
)
5583 tree tmp
= NULL_TREE
;
5590 gcc_assert (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
));
5592 /* Do nothing for USEd variables. */
5593 if (sym
->attr
.use_assoc
)
5596 type
= TREE_TYPE (decl
);
5597 gcc_assert (GFC_ARRAY_TYPE_P (type
));
5598 onstack
= TREE_CODE (type
) != POINTER_TYPE
;
5600 gfc_init_block (&init
);
5602 /* Evaluate character string length. */
5603 if (sym
->ts
.type
== BT_CHARACTER
5604 && onstack
&& !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
5606 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
5608 gfc_trans_vla_type_sizes (sym
, &init
);
5610 /* Emit a DECL_EXPR for this variable, which will cause the
5611 gimplifier to allocate storage, and all that good stuff. */
5612 tmp
= fold_build1_loc (input_location
, DECL_EXPR
, TREE_TYPE (decl
), decl
);
5613 gfc_add_expr_to_block (&init
, tmp
);
5618 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
5622 type
= TREE_TYPE (type
);
5624 gcc_assert (!sym
->attr
.use_assoc
);
5625 gcc_assert (!TREE_STATIC (decl
));
5626 gcc_assert (!sym
->module
);
5628 if (sym
->ts
.type
== BT_CHARACTER
5629 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
5630 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
5632 size
= gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
5634 /* Don't actually allocate space for Cray Pointees. */
5635 if (sym
->attr
.cray_pointee
)
5637 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
5638 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
5640 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
5644 if (gfc_option
.flag_stack_arrays
)
5646 gcc_assert (TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
);
5647 space
= build_decl (sym
->declared_at
.lb
->location
,
5648 VAR_DECL
, create_tmp_var_name ("A"),
5649 TREE_TYPE (TREE_TYPE (decl
)));
5650 gfc_trans_vla_type_sizes (sym
, &init
);
5654 /* The size is the number of elements in the array, so multiply by the
5655 size of an element to get the total size. */
5656 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
5657 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5658 size
, fold_convert (gfc_array_index_type
, tmp
));
5660 /* Allocate memory to hold the data. */
5661 tmp
= gfc_call_malloc (&init
, TREE_TYPE (decl
), size
);
5662 gfc_add_modify (&init
, decl
, tmp
);
5664 /* Free the temporary. */
5665 tmp
= gfc_call_free (convert (pvoid_type_node
, decl
));
5669 /* Set offset of the array. */
5670 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
5671 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
5673 /* Automatic arrays should not have initializers. */
5674 gcc_assert (!sym
->value
);
5676 inittree
= gfc_finish_block (&init
);
5683 /* Don't create new scope, emit the DECL_EXPR in exactly the scope
5684 where also space is located. */
5685 gfc_init_block (&init
);
5686 tmp
= fold_build1_loc (input_location
, DECL_EXPR
,
5687 TREE_TYPE (space
), space
);
5688 gfc_add_expr_to_block (&init
, tmp
);
5689 addr
= fold_build1_loc (sym
->declared_at
.lb
->location
,
5690 ADDR_EXPR
, TREE_TYPE (decl
), space
);
5691 gfc_add_modify (&init
, decl
, addr
);
5692 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
5695 gfc_add_init_cleanup (block
, inittree
, tmp
);
5699 /* Generate entry and exit code for g77 calling convention arrays. */
5702 gfc_trans_g77_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
5712 gfc_save_backend_locus (&loc
);
5713 gfc_set_backend_locus (&sym
->declared_at
);
5715 /* Descriptor type. */
5716 parm
= sym
->backend_decl
;
5717 type
= TREE_TYPE (parm
);
5718 gcc_assert (GFC_ARRAY_TYPE_P (type
));
5720 gfc_start_block (&init
);
5722 if (sym
->ts
.type
== BT_CHARACTER
5723 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
5724 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
5726 /* Evaluate the bounds of the array. */
5727 gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
5729 /* Set the offset. */
5730 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
5731 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
5733 /* Set the pointer itself if we aren't using the parameter directly. */
5734 if (TREE_CODE (parm
) != PARM_DECL
)
5736 tmp
= convert (TREE_TYPE (parm
), GFC_DECL_SAVED_DESCRIPTOR (parm
));
5737 gfc_add_modify (&init
, parm
, tmp
);
5739 stmt
= gfc_finish_block (&init
);
5741 gfc_restore_backend_locus (&loc
);
5743 /* Add the initialization code to the start of the function. */
5745 if (sym
->attr
.optional
|| sym
->attr
.not_always_present
)
5747 tmp
= gfc_conv_expr_present (sym
);
5748 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
5751 gfc_add_init_cleanup (block
, stmt
, NULL_TREE
);
5755 /* Modify the descriptor of an array parameter so that it has the
5756 correct lower bound. Also move the upper bound accordingly.
5757 If the array is not packed, it will be copied into a temporary.
5758 For each dimension we set the new lower and upper bounds. Then we copy the
5759 stride and calculate the offset for this dimension. We also work out
5760 what the stride of a packed array would be, and see it the two match.
5761 If the array need repacking, we set the stride to the values we just
5762 calculated, recalculate the offset and copy the array data.
5763 Code is also added to copy the data back at the end of the function.
5767 gfc_trans_dummy_array_bias (gfc_symbol
* sym
, tree tmpdesc
,
5768 gfc_wrapped_block
* block
)
5775 tree stmtInit
, stmtCleanup
;
5782 tree stride
, stride2
;
5792 /* Do nothing for pointer and allocatable arrays. */
5793 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
5796 if (sym
->attr
.dummy
&& gfc_is_nodesc_array (sym
))
5798 gfc_trans_g77_array (sym
, block
);
5802 gfc_save_backend_locus (&loc
);
5803 gfc_set_backend_locus (&sym
->declared_at
);
5805 /* Descriptor type. */
5806 type
= TREE_TYPE (tmpdesc
);
5807 gcc_assert (GFC_ARRAY_TYPE_P (type
));
5808 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
5809 dumdesc
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
5810 gfc_start_block (&init
);
5812 if (sym
->ts
.type
== BT_CHARACTER
5813 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
5814 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
5816 checkparm
= (sym
->as
->type
== AS_EXPLICIT
5817 && (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
));
5819 no_repack
= !(GFC_DECL_PACKED_ARRAY (tmpdesc
)
5820 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
));
5822 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
))
5824 /* For non-constant shape arrays we only check if the first dimension
5825 is contiguous. Repacking higher dimensions wouldn't gain us
5826 anything as we still don't know the array stride. */
5827 partial
= gfc_create_var (boolean_type_node
, "partial");
5828 TREE_USED (partial
) = 1;
5829 tmp
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
5830 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, tmp
,
5831 gfc_index_one_node
);
5832 gfc_add_modify (&init
, partial
, tmp
);
5835 partial
= NULL_TREE
;
5837 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
5838 here, however I think it does the right thing. */
5841 /* Set the first stride. */
5842 stride
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
5843 stride
= gfc_evaluate_now (stride
, &init
);
5845 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5846 stride
, gfc_index_zero_node
);
5847 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
5848 tmp
, gfc_index_one_node
, stride
);
5849 stride
= GFC_TYPE_ARRAY_STRIDE (type
, 0);
5850 gfc_add_modify (&init
, stride
, tmp
);
5852 /* Allow the user to disable array repacking. */
5853 stmt_unpacked
= NULL_TREE
;
5857 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type
, 0)));
5858 /* A library call to repack the array if necessary. */
5859 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
5860 stmt_unpacked
= build_call_expr_loc (input_location
,
5861 gfor_fndecl_in_pack
, 1, tmp
);
5863 stride
= gfc_index_one_node
;
5865 if (gfc_option
.warn_array_temp
)
5866 gfc_warning ("Creating array temporary at %L", &loc
);
5869 /* This is for the case where the array data is used directly without
5870 calling the repack function. */
5871 if (no_repack
|| partial
!= NULL_TREE
)
5872 stmt_packed
= gfc_conv_descriptor_data_get (dumdesc
);
5874 stmt_packed
= NULL_TREE
;
5876 /* Assign the data pointer. */
5877 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
5879 /* Don't repack unknown shape arrays when the first stride is 1. */
5880 tmp
= fold_build3_loc (input_location
, COND_EXPR
, TREE_TYPE (stmt_packed
),
5881 partial
, stmt_packed
, stmt_unpacked
);
5884 tmp
= stmt_packed
!= NULL_TREE
? stmt_packed
: stmt_unpacked
;
5885 gfc_add_modify (&init
, tmpdesc
, fold_convert (type
, tmp
));
5887 offset
= gfc_index_zero_node
;
5888 size
= gfc_index_one_node
;
5890 /* Evaluate the bounds of the array. */
5891 for (n
= 0; n
< sym
->as
->rank
; n
++)
5893 if (checkparm
|| !sym
->as
->upper
[n
])
5895 /* Get the bounds of the actual parameter. */
5896 dubound
= gfc_conv_descriptor_ubound_get (dumdesc
, gfc_rank_cst
[n
]);
5897 dlbound
= gfc_conv_descriptor_lbound_get (dumdesc
, gfc_rank_cst
[n
]);
5901 dubound
= NULL_TREE
;
5902 dlbound
= NULL_TREE
;
5905 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, n
);
5906 if (!INTEGER_CST_P (lbound
))
5908 gfc_init_se (&se
, NULL
);
5909 gfc_conv_expr_type (&se
, sym
->as
->lower
[n
],
5910 gfc_array_index_type
);
5911 gfc_add_block_to_block (&init
, &se
.pre
);
5912 gfc_add_modify (&init
, lbound
, se
.expr
);
5915 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, n
);
5916 /* Set the desired upper bound. */
5917 if (sym
->as
->upper
[n
])
5919 /* We know what we want the upper bound to be. */
5920 if (!INTEGER_CST_P (ubound
))
5922 gfc_init_se (&se
, NULL
);
5923 gfc_conv_expr_type (&se
, sym
->as
->upper
[n
],
5924 gfc_array_index_type
);
5925 gfc_add_block_to_block (&init
, &se
.pre
);
5926 gfc_add_modify (&init
, ubound
, se
.expr
);
5929 /* Check the sizes match. */
5932 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
5936 temp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5937 gfc_array_index_type
, ubound
, lbound
);
5938 temp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5939 gfc_array_index_type
,
5940 gfc_index_one_node
, temp
);
5941 stride2
= fold_build2_loc (input_location
, MINUS_EXPR
,
5942 gfc_array_index_type
, dubound
,
5944 stride2
= fold_build2_loc (input_location
, PLUS_EXPR
,
5945 gfc_array_index_type
,
5946 gfc_index_one_node
, stride2
);
5947 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
5948 gfc_array_index_type
, temp
, stride2
);
5949 asprintf (&msg
, "Dimension %d of array '%s' has extent "
5950 "%%ld instead of %%ld", n
+1, sym
->name
);
5952 gfc_trans_runtime_check (true, false, tmp
, &init
, &loc
, msg
,
5953 fold_convert (long_integer_type_node
, temp
),
5954 fold_convert (long_integer_type_node
, stride2
));
5961 /* For assumed shape arrays move the upper bound by the same amount
5962 as the lower bound. */
5963 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5964 gfc_array_index_type
, dubound
, dlbound
);
5965 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5966 gfc_array_index_type
, tmp
, lbound
);
5967 gfc_add_modify (&init
, ubound
, tmp
);
5969 /* The offset of this dimension. offset = offset - lbound * stride. */
5970 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5972 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
5973 gfc_array_index_type
, offset
, tmp
);
5975 /* The size of this dimension, and the stride of the next. */
5976 if (n
+ 1 < sym
->as
->rank
)
5978 stride
= GFC_TYPE_ARRAY_STRIDE (type
, n
+ 1);
5980 if (no_repack
|| partial
!= NULL_TREE
)
5982 gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[n
+1]);
5984 /* Figure out the stride if not a known constant. */
5985 if (!INTEGER_CST_P (stride
))
5988 stmt_packed
= NULL_TREE
;
5991 /* Calculate stride = size * (ubound + 1 - lbound). */
5992 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5993 gfc_array_index_type
,
5994 gfc_index_one_node
, lbound
);
5995 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5996 gfc_array_index_type
, ubound
, tmp
);
5997 size
= fold_build2_loc (input_location
, MULT_EXPR
,
5998 gfc_array_index_type
, size
, tmp
);
6002 /* Assign the stride. */
6003 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
6004 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6005 gfc_array_index_type
, partial
,
6006 stmt_unpacked
, stmt_packed
);
6008 tmp
= (stmt_packed
!= NULL_TREE
) ? stmt_packed
: stmt_unpacked
;
6009 gfc_add_modify (&init
, stride
, tmp
);
6014 stride
= GFC_TYPE_ARRAY_SIZE (type
);
6016 if (stride
&& !INTEGER_CST_P (stride
))
6018 /* Calculate size = stride * (ubound + 1 - lbound). */
6019 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6020 gfc_array_index_type
,
6021 gfc_index_one_node
, lbound
);
6022 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6023 gfc_array_index_type
,
6025 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6026 gfc_array_index_type
,
6027 GFC_TYPE_ARRAY_STRIDE (type
, n
), tmp
);
6028 gfc_add_modify (&init
, stride
, tmp
);
6033 gfc_trans_array_cobounds (type
, &init
, sym
);
6035 /* Set the offset. */
6036 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
6037 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6039 gfc_trans_vla_type_sizes (sym
, &init
);
6041 stmtInit
= gfc_finish_block (&init
);
6043 /* Only do the entry/initialization code if the arg is present. */
6044 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6045 optional_arg
= (sym
->attr
.optional
6046 || (sym
->ns
->proc_name
->attr
.entry_master
6047 && sym
->attr
.dummy
));
6050 tmp
= gfc_conv_expr_present (sym
);
6051 stmtInit
= build3_v (COND_EXPR
, tmp
, stmtInit
,
6052 build_empty_stmt (input_location
));
6057 stmtCleanup
= NULL_TREE
;
6060 stmtblock_t cleanup
;
6061 gfc_start_block (&cleanup
);
6063 if (sym
->attr
.intent
!= INTENT_IN
)
6065 /* Copy the data back. */
6066 tmp
= build_call_expr_loc (input_location
,
6067 gfor_fndecl_in_unpack
, 2, dumdesc
, tmpdesc
);
6068 gfc_add_expr_to_block (&cleanup
, tmp
);
6071 /* Free the temporary. */
6072 tmp
= gfc_call_free (tmpdesc
);
6073 gfc_add_expr_to_block (&cleanup
, tmp
);
6075 stmtCleanup
= gfc_finish_block (&cleanup
);
6077 /* Only do the cleanup if the array was repacked. */
6078 tmp
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
6079 tmp
= gfc_conv_descriptor_data_get (tmp
);
6080 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6082 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6083 build_empty_stmt (input_location
));
6087 tmp
= gfc_conv_expr_present (sym
);
6088 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6089 build_empty_stmt (input_location
));
6093 /* We don't need to free any memory allocated by internal_pack as it will
6094 be freed at the end of the function by pop_context. */
6095 gfc_add_init_cleanup (block
, stmtInit
, stmtCleanup
);
6097 gfc_restore_backend_locus (&loc
);
6101 /* Calculate the overall offset, including subreferences. */
6103 gfc_get_dataptr_offset (stmtblock_t
*block
, tree parm
, tree desc
, tree offset
,
6104 bool subref
, gfc_expr
*expr
)
6114 /* If offset is NULL and this is not a subreferenced array, there is
6116 if (offset
== NULL_TREE
)
6119 offset
= gfc_index_zero_node
;
6124 tmp
= build_array_ref (desc
, offset
, NULL
);
6126 /* Offset the data pointer for pointer assignments from arrays with
6127 subreferences; e.g. my_integer => my_type(:)%integer_component. */
6130 /* Go past the array reference. */
6131 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6132 if (ref
->type
== REF_ARRAY
&&
6133 ref
->u
.ar
.type
!= AR_ELEMENT
)
6139 /* Calculate the offset for each subsequent subreference. */
6140 for (; ref
; ref
= ref
->next
)
6145 field
= ref
->u
.c
.component
->backend_decl
;
6146 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
6147 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
6149 tmp
, field
, NULL_TREE
);
6153 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
6154 gfc_init_se (&start
, NULL
);
6155 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
6156 gfc_add_block_to_block (block
, &start
.pre
);
6157 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
6161 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
6162 && ref
->u
.ar
.type
== AR_ELEMENT
);
6164 /* TODO - Add bounds checking. */
6165 stride
= gfc_index_one_node
;
6166 index
= gfc_index_zero_node
;
6167 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
6172 /* Update the index. */
6173 gfc_init_se (&start
, NULL
);
6174 gfc_conv_expr_type (&start
, ref
->u
.ar
.start
[n
], gfc_array_index_type
);
6175 itmp
= gfc_evaluate_now (start
.expr
, block
);
6176 gfc_init_se (&start
, NULL
);
6177 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->lower
[n
], gfc_array_index_type
);
6178 jtmp
= gfc_evaluate_now (start
.expr
, block
);
6179 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6180 gfc_array_index_type
, itmp
, jtmp
);
6181 itmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6182 gfc_array_index_type
, itmp
, stride
);
6183 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
6184 gfc_array_index_type
, itmp
, index
);
6185 index
= gfc_evaluate_now (index
, block
);
6187 /* Update the stride. */
6188 gfc_init_se (&start
, NULL
);
6189 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->upper
[n
], gfc_array_index_type
);
6190 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6191 gfc_array_index_type
, start
.expr
,
6193 itmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6194 gfc_array_index_type
,
6195 gfc_index_one_node
, itmp
);
6196 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
6197 gfc_array_index_type
, stride
, itmp
);
6198 stride
= gfc_evaluate_now (stride
, block
);
6201 /* Apply the index to obtain the array element. */
6202 tmp
= gfc_build_array_ref (tmp
, index
, NULL
);
6212 /* Set the target data pointer. */
6213 offset
= gfc_build_addr_expr (gfc_array_dataptr_type (desc
), tmp
);
6214 gfc_conv_descriptor_data_set (block
, parm
, offset
);
6218 /* gfc_conv_expr_descriptor needs the string length an expression
6219 so that the size of the temporary can be obtained. This is done
6220 by adding up the string lengths of all the elements in the
6221 expression. Function with non-constant expressions have their
6222 string lengths mapped onto the actual arguments using the
6223 interface mapping machinery in trans-expr.c. */
6225 get_array_charlen (gfc_expr
*expr
, gfc_se
*se
)
6227 gfc_interface_mapping mapping
;
6228 gfc_formal_arglist
*formal
;
6229 gfc_actual_arglist
*arg
;
6232 if (expr
->ts
.u
.cl
->length
6233 && gfc_is_constant_expr (expr
->ts
.u
.cl
->length
))
6235 if (!expr
->ts
.u
.cl
->backend_decl
)
6236 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6240 switch (expr
->expr_type
)
6243 get_array_charlen (expr
->value
.op
.op1
, se
);
6245 /* For parentheses the expression ts.u.cl is identical. */
6246 if (expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
6249 expr
->ts
.u
.cl
->backend_decl
=
6250 gfc_create_var (gfc_charlen_type_node
, "sln");
6252 if (expr
->value
.op
.op2
)
6254 get_array_charlen (expr
->value
.op
.op2
, se
);
6256 gcc_assert (expr
->value
.op
.op
== INTRINSIC_CONCAT
);
6258 /* Add the string lengths and assign them to the expression
6259 string length backend declaration. */
6260 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
6261 fold_build2_loc (input_location
, PLUS_EXPR
,
6262 gfc_charlen_type_node
,
6263 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
,
6264 expr
->value
.op
.op2
->ts
.u
.cl
->backend_decl
));
6267 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
6268 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
);
6272 if (expr
->value
.function
.esym
== NULL
6273 || expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6275 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6279 /* Map expressions involving the dummy arguments onto the actual
6280 argument expressions. */
6281 gfc_init_interface_mapping (&mapping
);
6282 formal
= gfc_sym_get_dummy_args (expr
->symtree
->n
.sym
);
6283 arg
= expr
->value
.function
.actual
;
6285 /* Set se = NULL in the calls to the interface mapping, to suppress any
6287 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
6292 gfc_add_interface_mapping (&mapping
, formal
->sym
, NULL
, arg
->expr
);
6295 gfc_init_se (&tse
, NULL
);
6297 /* Build the expression for the character length and convert it. */
6298 gfc_apply_interface_mapping (&mapping
, &tse
, expr
->ts
.u
.cl
->length
);
6300 gfc_add_block_to_block (&se
->pre
, &tse
.pre
);
6301 gfc_add_block_to_block (&se
->post
, &tse
.post
);
6302 tse
.expr
= fold_convert (gfc_charlen_type_node
, tse
.expr
);
6303 tse
.expr
= fold_build2_loc (input_location
, MAX_EXPR
,
6304 gfc_charlen_type_node
, tse
.expr
,
6305 build_int_cst (gfc_charlen_type_node
, 0));
6306 expr
->ts
.u
.cl
->backend_decl
= tse
.expr
;
6307 gfc_free_interface_mapping (&mapping
);
6311 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6317 /* Helper function to check dimensions. */
6319 transposed_dims (gfc_ss
*ss
)
6323 for (n
= 0; n
< ss
->dimen
; n
++)
6324 if (ss
->dim
[n
] != n
)
6330 /* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
6331 AR_FULL, suitable for the scalarizer. */
6334 walk_coarray (gfc_expr
*e
)
6338 gcc_assert (gfc_get_corank (e
) > 0);
6340 ss
= gfc_walk_expr (e
);
6342 /* Fix scalar coarray. */
6343 if (ss
== gfc_ss_terminator
)
6350 if (ref
->type
== REF_ARRAY
6351 && ref
->u
.ar
.codimen
> 0)
6357 gcc_assert (ref
!= NULL
);
6358 if (ref
->u
.ar
.type
== AR_ELEMENT
)
6359 ref
->u
.ar
.type
= AR_SECTION
;
6360 ss
= gfc_reverse_ss (gfc_walk_array_ref (ss
, e
, ref
));
6367 /* Convert an array for passing as an actual argument. Expressions and
6368 vector subscripts are evaluated and stored in a temporary, which is then
6369 passed. For whole arrays the descriptor is passed. For array sections
6370 a modified copy of the descriptor is passed, but using the original data.
6372 This function is also used for array pointer assignments, and there
6375 - se->want_pointer && !se->direct_byref
6376 EXPR is an actual argument. On exit, se->expr contains a
6377 pointer to the array descriptor.
6379 - !se->want_pointer && !se->direct_byref
6380 EXPR is an actual argument to an intrinsic function or the
6381 left-hand side of a pointer assignment. On exit, se->expr
6382 contains the descriptor for EXPR.
6384 - !se->want_pointer && se->direct_byref
6385 EXPR is the right-hand side of a pointer assignment and
6386 se->expr is the descriptor for the previously-evaluated
6387 left-hand side. The function creates an assignment from
6391 The se->force_tmp flag disables the non-copying descriptor optimization
6392 that is used for transpose. It may be used in cases where there is an
6393 alias between the transpose argument and another argument in the same
6397 gfc_conv_expr_descriptor (gfc_se
*se
, gfc_expr
*expr
)
6400 gfc_ss_type ss_type
;
6401 gfc_ss_info
*ss_info
;
6403 gfc_array_info
*info
;
6412 bool subref_array_target
= false;
6413 gfc_expr
*arg
, *ss_expr
;
6415 if (se
->want_coarray
)
6416 ss
= walk_coarray (expr
);
6418 ss
= gfc_walk_expr (expr
);
6420 gcc_assert (ss
!= NULL
);
6421 gcc_assert (ss
!= gfc_ss_terminator
);
6424 ss_type
= ss_info
->type
;
6425 ss_expr
= ss_info
->expr
;
6427 /* Special case: TRANSPOSE which needs no temporary. */
6428 while (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
6429 && NULL
!= (arg
= gfc_get_noncopying_intrinsic_argument (expr
)))
6431 /* This is a call to transpose which has already been handled by the
6432 scalarizer, so that we just need to get its argument's descriptor. */
6433 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
6434 expr
= expr
->value
.function
.actual
->expr
;
6437 /* Special case things we know we can pass easily. */
6438 switch (expr
->expr_type
)
6441 /* If we have a linear array section, we can pass it directly.
6442 Otherwise we need to copy it into a temporary. */
6444 gcc_assert (ss_type
== GFC_SS_SECTION
);
6445 gcc_assert (ss_expr
== expr
);
6446 info
= &ss_info
->data
.array
;
6448 /* Get the descriptor for the array. */
6449 gfc_conv_ss_descriptor (&se
->pre
, ss
, 0);
6450 desc
= info
->descriptor
;
6452 subref_array_target
= se
->direct_byref
&& is_subref_array (expr
);
6453 need_tmp
= gfc_ref_needs_temporary_p (expr
->ref
)
6454 && !subref_array_target
;
6461 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
6463 /* Create a new descriptor if the array doesn't have one. */
6466 else if (info
->ref
->u
.ar
.type
== AR_FULL
|| se
->descriptor_only
)
6468 else if (se
->direct_byref
)
6471 full
= gfc_full_array_ref_p (info
->ref
, NULL
);
6473 if (full
&& !transposed_dims (ss
))
6475 if (se
->direct_byref
&& !se
->byref_noassign
)
6477 /* Copy the descriptor for pointer assignments. */
6478 gfc_add_modify (&se
->pre
, se
->expr
, desc
);
6480 /* Add any offsets from subreferences. */
6481 gfc_get_dataptr_offset (&se
->pre
, se
->expr
, desc
, NULL_TREE
,
6482 subref_array_target
, expr
);
6484 else if (se
->want_pointer
)
6486 /* We pass full arrays directly. This means that pointers and
6487 allocatable arrays should also work. */
6488 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
6495 if (expr
->ts
.type
== BT_CHARACTER
)
6496 se
->string_length
= gfc_get_expr_charlen (expr
);
6498 gfc_free_ss_chain (ss
);
6504 /* A transformational function return value will be a temporary
6505 array descriptor. We still need to go through the scalarizer
6506 to create the descriptor. Elemental functions are handled as
6507 arbitrary expressions, i.e. copy to a temporary. */
6509 if (se
->direct_byref
)
6511 gcc_assert (ss_type
== GFC_SS_FUNCTION
&& ss_expr
== expr
);
6513 /* For pointer assignments pass the descriptor directly. */
6517 gcc_assert (se
->ss
== ss
);
6518 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
6519 gfc_conv_expr (se
, expr
);
6520 gfc_free_ss_chain (ss
);
6524 if (ss_expr
!= expr
|| ss_type
!= GFC_SS_FUNCTION
)
6526 if (ss_expr
!= expr
)
6527 /* Elemental function. */
6528 gcc_assert ((expr
->value
.function
.esym
!= NULL
6529 && expr
->value
.function
.esym
->attr
.elemental
)
6530 || (expr
->value
.function
.isym
!= NULL
6531 && expr
->value
.function
.isym
->elemental
)
6532 || gfc_inline_intrinsic_function_p (expr
));
6534 gcc_assert (ss_type
== GFC_SS_INTRINSIC
);
6537 if (expr
->ts
.type
== BT_CHARACTER
6538 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
6539 get_array_charlen (expr
, se
);
6545 /* Transformational function. */
6546 info
= &ss_info
->data
.array
;
6552 /* Constant array constructors don't need a temporary. */
6553 if (ss_type
== GFC_SS_CONSTRUCTOR
6554 && expr
->ts
.type
!= BT_CHARACTER
6555 && gfc_constant_array_constructor_p (expr
->value
.constructor
))
6558 info
= &ss_info
->data
.array
;
6568 /* Something complicated. Copy it into a temporary. */
6574 /* If we are creating a temporary, we don't need to bother about aliases
6579 gfc_init_loopinfo (&loop
);
6581 /* Associate the SS with the loop. */
6582 gfc_add_ss_to_loop (&loop
, ss
);
6584 /* Tell the scalarizer not to bother creating loop variables, etc. */
6586 loop
.array_parameter
= 1;
6588 /* The right-hand side of a pointer assignment mustn't use a temporary. */
6589 gcc_assert (!se
->direct_byref
);
6591 /* Setup the scalarizing loops and bounds. */
6592 gfc_conv_ss_startstride (&loop
);
6596 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
6597 get_array_charlen (expr
, se
);
6599 /* Tell the scalarizer to make a temporary. */
6600 loop
.temp_ss
= gfc_get_temp_ss (gfc_typenode_for_spec (&expr
->ts
),
6601 ((expr
->ts
.type
== BT_CHARACTER
)
6602 ? expr
->ts
.u
.cl
->backend_decl
6606 se
->string_length
= loop
.temp_ss
->info
->string_length
;
6607 gcc_assert (loop
.temp_ss
->dimen
== loop
.dimen
);
6608 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
6611 gfc_conv_loop_setup (&loop
, & expr
->where
);
6615 /* Copy into a temporary and pass that. We don't need to copy the data
6616 back because expressions and vector subscripts must be INTENT_IN. */
6617 /* TODO: Optimize passing function return values. */
6621 /* Start the copying loops. */
6622 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
6623 gfc_mark_ss_chain_used (ss
, 1);
6624 gfc_start_scalarized_body (&loop
, &block
);
6626 /* Copy each data element. */
6627 gfc_init_se (&lse
, NULL
);
6628 gfc_copy_loopinfo_to_se (&lse
, &loop
);
6629 gfc_init_se (&rse
, NULL
);
6630 gfc_copy_loopinfo_to_se (&rse
, &loop
);
6632 lse
.ss
= loop
.temp_ss
;
6635 gfc_conv_scalarized_array_ref (&lse
, NULL
);
6636 if (expr
->ts
.type
== BT_CHARACTER
)
6638 gfc_conv_expr (&rse
, expr
);
6639 if (POINTER_TYPE_P (TREE_TYPE (rse
.expr
)))
6640 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
6644 gfc_conv_expr_val (&rse
, expr
);
6646 gfc_add_block_to_block (&block
, &rse
.pre
);
6647 gfc_add_block_to_block (&block
, &lse
.pre
);
6649 lse
.string_length
= rse
.string_length
;
6650 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true,
6651 expr
->expr_type
== EXPR_VARIABLE
6652 || expr
->expr_type
== EXPR_ARRAY
, true);
6653 gfc_add_expr_to_block (&block
, tmp
);
6655 /* Finish the copying loops. */
6656 gfc_trans_scalarizing_loops (&loop
, &block
);
6658 desc
= loop
.temp_ss
->info
->data
.array
.descriptor
;
6660 else if (expr
->expr_type
== EXPR_FUNCTION
&& !transposed_dims (ss
))
6662 desc
= info
->descriptor
;
6663 se
->string_length
= ss_info
->string_length
;
6667 /* We pass sections without copying to a temporary. Make a new
6668 descriptor and point it at the section we want. The loop variable
6669 limits will be the limits of the section.
6670 A function may decide to repack the array to speed up access, but
6671 we're not bothered about that here. */
6672 int dim
, ndim
, codim
;
6680 ndim
= info
->ref
? info
->ref
->u
.ar
.dimen
: ss
->dimen
;
6682 if (se
->want_coarray
)
6684 gfc_array_ref
*ar
= &info
->ref
->u
.ar
;
6686 codim
= gfc_get_corank (expr
);
6687 for (n
= 0; n
< codim
- 1; n
++)
6689 /* Make sure we are not lost somehow. */
6690 gcc_assert (ar
->dimen_type
[n
+ ndim
] == DIMEN_THIS_IMAGE
);
6692 /* Make sure the call to gfc_conv_section_startstride won't
6693 generate unnecessary code to calculate stride. */
6694 gcc_assert (ar
->stride
[n
+ ndim
] == NULL
);
6696 gfc_conv_section_startstride (&loop
, ss
, n
+ ndim
);
6697 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
6698 loop
.to
[n
+ loop
.dimen
] = info
->end
[n
+ ndim
];
6701 gcc_assert (n
== codim
- 1);
6702 evaluate_bound (&loop
.pre
, info
->start
, ar
->start
,
6703 info
->descriptor
, n
+ ndim
, true);
6704 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
6709 /* Set the string_length for a character array. */
6710 if (expr
->ts
.type
== BT_CHARACTER
)
6711 se
->string_length
= gfc_get_expr_charlen (expr
);
6713 desc
= info
->descriptor
;
6714 if (se
->direct_byref
&& !se
->byref_noassign
)
6716 /* For pointer assignments we fill in the destination. */
6718 parmtype
= TREE_TYPE (parm
);
6722 /* Otherwise make a new one. */
6723 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
6724 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
, codim
,
6725 loop
.from
, loop
.to
, 0,
6726 GFC_ARRAY_UNKNOWN
, false);
6727 parm
= gfc_create_var (parmtype
, "parm");
6730 offset
= gfc_index_zero_node
;
6732 /* The following can be somewhat confusing. We have two
6733 descriptors, a new one and the original array.
6734 {parm, parmtype, dim} refer to the new one.
6735 {desc, type, n, loop} refer to the original, which maybe
6736 a descriptorless array.
6737 The bounds of the scalarization are the bounds of the section.
6738 We don't have to worry about numeric overflows when calculating
6739 the offsets because all elements are within the array data. */
6741 /* Set the dtype. */
6742 tmp
= gfc_conv_descriptor_dtype (parm
);
6743 gfc_add_modify (&loop
.pre
, tmp
, gfc_get_dtype (parmtype
));
6745 /* Set offset for assignments to pointer only to zero if it is not
6747 if (se
->direct_byref
6748 && info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
6749 base
= gfc_index_zero_node
;
6750 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
6751 base
= gfc_evaluate_now (gfc_conv_array_offset (desc
), &loop
.pre
);
6755 for (n
= 0; n
< ndim
; n
++)
6757 stride
= gfc_conv_array_stride (desc
, n
);
6759 /* Work out the offset. */
6761 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
6763 gcc_assert (info
->subscript
[n
]
6764 && info
->subscript
[n
]->info
->type
== GFC_SS_SCALAR
);
6765 start
= info
->subscript
[n
]->info
->data
.scalar
.value
;
6769 /* Evaluate and remember the start of the section. */
6770 start
= info
->start
[n
];
6771 stride
= gfc_evaluate_now (stride
, &loop
.pre
);
6774 tmp
= gfc_conv_array_lbound (desc
, n
);
6775 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
6777 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
6779 offset
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (tmp
),
6783 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
6785 /* For elemental dimensions, we only need the offset. */
6789 /* Vector subscripts need copying and are handled elsewhere. */
6791 gcc_assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
6793 /* look for the corresponding scalarizer dimension: dim. */
6794 for (dim
= 0; dim
< ndim
; dim
++)
6795 if (ss
->dim
[dim
] == n
)
6798 /* loop exited early: the DIM being looked for has been found. */
6799 gcc_assert (dim
< ndim
);
6801 /* Set the new lower bound. */
6802 from
= loop
.from
[dim
];
6805 /* If we have an array section or are assigning make sure that
6806 the lower bound is 1. References to the full
6807 array should otherwise keep the original bounds. */
6809 || info
->ref
->u
.ar
.type
!= AR_FULL
)
6810 && !integer_onep (from
))
6812 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6813 gfc_array_index_type
, gfc_index_one_node
,
6815 to
= fold_build2_loc (input_location
, PLUS_EXPR
,
6816 gfc_array_index_type
, to
, tmp
);
6817 from
= gfc_index_one_node
;
6819 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
6820 gfc_rank_cst
[dim
], from
);
6822 /* Set the new upper bound. */
6823 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
6824 gfc_rank_cst
[dim
], to
);
6826 /* Multiply the stride by the section stride to get the
6828 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
6829 gfc_array_index_type
,
6830 stride
, info
->stride
[n
]);
6832 if (se
->direct_byref
6834 && info
->ref
->u
.ar
.type
!= AR_FULL
)
6836 base
= fold_build2_loc (input_location
, MINUS_EXPR
,
6837 TREE_TYPE (base
), base
, stride
);
6839 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
6841 tmp
= gfc_conv_array_lbound (desc
, n
);
6842 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6843 TREE_TYPE (base
), tmp
, loop
.from
[dim
]);
6844 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6845 TREE_TYPE (base
), tmp
,
6846 gfc_conv_array_stride (desc
, n
));
6847 base
= fold_build2_loc (input_location
, PLUS_EXPR
,
6848 TREE_TYPE (base
), tmp
, base
);
6851 /* Store the new stride. */
6852 gfc_conv_descriptor_stride_set (&loop
.pre
, parm
,
6853 gfc_rank_cst
[dim
], stride
);
6856 for (n
= loop
.dimen
; n
< loop
.dimen
+ codim
; n
++)
6858 from
= loop
.from
[n
];
6860 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
6861 gfc_rank_cst
[n
], from
);
6862 if (n
< loop
.dimen
+ codim
- 1)
6863 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
6864 gfc_rank_cst
[n
], to
);
6867 if (se
->data_not_needed
)
6868 gfc_conv_descriptor_data_set (&loop
.pre
, parm
,
6869 gfc_index_zero_node
);
6871 /* Point the data pointer at the 1st element in the section. */
6872 gfc_get_dataptr_offset (&loop
.pre
, parm
, desc
, offset
,
6873 subref_array_target
, expr
);
6875 if ((se
->direct_byref
|| GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
6876 && !se
->data_not_needed
)
6878 /* Set the offset. */
6879 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, base
);
6883 /* Only the callee knows what the correct offset it, so just set
6885 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, gfc_index_zero_node
);
6890 if (!se
->direct_byref
|| se
->byref_noassign
)
6892 /* Get a pointer to the new descriptor. */
6893 if (se
->want_pointer
)
6894 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
6899 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
6900 gfc_add_block_to_block (&se
->post
, &loop
.post
);
6902 /* Cleanup the scalarizer. */
6903 gfc_cleanup_loop (&loop
);
6906 /* Helper function for gfc_conv_array_parameter if array size needs to be
6910 array_parameter_size (tree desc
, gfc_expr
*expr
, tree
*size
)
6913 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
6914 *size
= GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc
));
6915 else if (expr
->rank
> 1)
6916 *size
= build_call_expr_loc (input_location
,
6917 gfor_fndecl_size0
, 1,
6918 gfc_build_addr_expr (NULL
, desc
));
6921 tree ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_index_zero_node
);
6922 tree lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_index_zero_node
);
6924 *size
= fold_build2_loc (input_location
, MINUS_EXPR
,
6925 gfc_array_index_type
, ubound
, lbound
);
6926 *size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
6927 *size
, gfc_index_one_node
);
6928 *size
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
6929 *size
, gfc_index_zero_node
);
6931 elem
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
6932 *size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6933 *size
, fold_convert (gfc_array_index_type
, elem
));
6936 /* Convert an array for passing as an actual parameter. */
6937 /* TODO: Optimize passing g77 arrays. */
6940 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, bool g77
,
6941 const gfc_symbol
*fsym
, const char *proc_name
,
6946 tree tmp
= NULL_TREE
;
6948 tree parent
= DECL_CONTEXT (current_function_decl
);
6949 bool full_array_var
;
6950 bool this_array_result
;
6953 bool array_constructor
;
6954 bool good_allocatable
;
6955 bool ultimate_ptr_comp
;
6956 bool ultimate_alloc_comp
;
6961 ultimate_ptr_comp
= false;
6962 ultimate_alloc_comp
= false;
6964 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6966 if (ref
->next
== NULL
)
6969 if (ref
->type
== REF_COMPONENT
)
6971 ultimate_ptr_comp
= ref
->u
.c
.component
->attr
.pointer
;
6972 ultimate_alloc_comp
= ref
->u
.c
.component
->attr
.allocatable
;
6976 full_array_var
= false;
6979 if (expr
->expr_type
== EXPR_VARIABLE
&& ref
&& !ultimate_ptr_comp
)
6980 full_array_var
= gfc_full_array_ref_p (ref
, &contiguous
);
6982 sym
= full_array_var
? expr
->symtree
->n
.sym
: NULL
;
6984 /* The symbol should have an array specification. */
6985 gcc_assert (!sym
|| sym
->as
|| ref
->u
.ar
.as
);
6987 if (expr
->expr_type
== EXPR_ARRAY
&& expr
->ts
.type
== BT_CHARACTER
)
6989 get_array_ctor_strlen (&se
->pre
, expr
->value
.constructor
, &tmp
);
6990 expr
->ts
.u
.cl
->backend_decl
= tmp
;
6991 se
->string_length
= tmp
;
6994 /* Is this the result of the enclosing procedure? */
6995 this_array_result
= (full_array_var
&& sym
->attr
.flavor
== FL_PROCEDURE
);
6996 if (this_array_result
6997 && (sym
->backend_decl
!= current_function_decl
)
6998 && (sym
->backend_decl
!= parent
))
6999 this_array_result
= false;
7001 /* Passing address of the array if it is not pointer or assumed-shape. */
7002 if (full_array_var
&& g77
&& !this_array_result
7003 && sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
7005 tmp
= gfc_get_symbol_decl (sym
);
7007 if (sym
->ts
.type
== BT_CHARACTER
)
7008 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
7010 if (!sym
->attr
.pointer
7012 && sym
->as
->type
!= AS_ASSUMED_SHAPE
7013 && sym
->as
->type
!= AS_DEFERRED
7014 && sym
->as
->type
!= AS_ASSUMED_RANK
7015 && !sym
->attr
.allocatable
)
7017 /* Some variables are declared directly, others are declared as
7018 pointers and allocated on the heap. */
7019 if (sym
->attr
.dummy
|| POINTER_TYPE_P (TREE_TYPE (tmp
)))
7022 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
7024 array_parameter_size (tmp
, expr
, size
);
7028 if (sym
->attr
.allocatable
)
7030 if (sym
->attr
.dummy
|| sym
->attr
.result
)
7032 gfc_conv_expr_descriptor (se
, expr
);
7036 array_parameter_size (tmp
, expr
, size
);
7037 se
->expr
= gfc_conv_array_data (tmp
);
7042 /* A convenient reduction in scope. */
7043 contiguous
= g77
&& !this_array_result
&& contiguous
;
7045 /* There is no need to pack and unpack the array, if it is contiguous
7046 and not a deferred- or assumed-shape array, or if it is simply
7048 no_pack
= ((sym
&& sym
->as
7049 && !sym
->attr
.pointer
7050 && sym
->as
->type
!= AS_DEFERRED
7051 && sym
->as
->type
!= AS_ASSUMED_RANK
7052 && sym
->as
->type
!= AS_ASSUMED_SHAPE
)
7054 (ref
&& ref
->u
.ar
.as
7055 && ref
->u
.ar
.as
->type
!= AS_DEFERRED
7056 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_RANK
7057 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_SHAPE
)
7059 gfc_is_simply_contiguous (expr
, false));
7061 no_pack
= contiguous
&& no_pack
;
7063 /* Array constructors are always contiguous and do not need packing. */
7064 array_constructor
= g77
&& !this_array_result
&& expr
->expr_type
== EXPR_ARRAY
;
7066 /* Same is true of contiguous sections from allocatable variables. */
7067 good_allocatable
= contiguous
7069 && expr
->symtree
->n
.sym
->attr
.allocatable
;
7071 /* Or ultimate allocatable components. */
7072 ultimate_alloc_comp
= contiguous
&& ultimate_alloc_comp
;
7074 if (no_pack
|| array_constructor
|| good_allocatable
|| ultimate_alloc_comp
)
7076 gfc_conv_expr_descriptor (se
, expr
);
7077 if (expr
->ts
.type
== BT_CHARACTER
)
7078 se
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
7080 array_parameter_size (se
->expr
, expr
, size
);
7081 se
->expr
= gfc_conv_array_data (se
->expr
);
7085 if (this_array_result
)
7087 /* Result of the enclosing function. */
7088 gfc_conv_expr_descriptor (se
, expr
);
7090 array_parameter_size (se
->expr
, expr
, size
);
7091 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7093 if (g77
&& TREE_TYPE (TREE_TYPE (se
->expr
)) != NULL_TREE
7094 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
7095 se
->expr
= gfc_conv_array_data (build_fold_indirect_ref_loc (input_location
,
7102 /* Every other type of array. */
7103 se
->want_pointer
= 1;
7104 gfc_conv_expr_descriptor (se
, expr
);
7106 array_parameter_size (build_fold_indirect_ref_loc (input_location
,
7111 /* Deallocate the allocatable components of structures that are
7113 if ((expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
)
7114 && expr
->ts
.u
.derived
->attr
.alloc_comp
7115 && expr
->expr_type
!= EXPR_VARIABLE
)
7117 tmp
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7118 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
, expr
->rank
);
7120 /* The components shall be deallocated before their containing entity. */
7121 gfc_prepend_expr_to_block (&se
->post
, tmp
);
7124 if (g77
|| (fsym
&& fsym
->attr
.contiguous
7125 && !gfc_is_simply_contiguous (expr
, false)))
7127 tree origptr
= NULL_TREE
;
7131 /* For contiguous arrays, save the original value of the descriptor. */
7134 origptr
= gfc_create_var (pvoid_type_node
, "origptr");
7135 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7136 tmp
= gfc_conv_array_data (tmp
);
7137 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7138 TREE_TYPE (origptr
), origptr
,
7139 fold_convert (TREE_TYPE (origptr
), tmp
));
7140 gfc_add_expr_to_block (&se
->pre
, tmp
);
7143 /* Repack the array. */
7144 if (gfc_option
.warn_array_temp
)
7147 gfc_warning ("Creating array temporary at %L for argument '%s'",
7148 &expr
->where
, fsym
->name
);
7150 gfc_warning ("Creating array temporary at %L", &expr
->where
);
7153 ptr
= build_call_expr_loc (input_location
,
7154 gfor_fndecl_in_pack
, 1, desc
);
7156 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7158 tmp
= gfc_conv_expr_present (sym
);
7159 ptr
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
7160 tmp
, fold_convert (TREE_TYPE (se
->expr
), ptr
),
7161 fold_convert (TREE_TYPE (se
->expr
), null_pointer_node
));
7164 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
7166 /* Use the packed data for the actual argument, except for contiguous arrays,
7167 where the descriptor's data component is set. */
7172 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7173 gfc_conv_descriptor_data_set (&se
->pre
, tmp
, ptr
);
7176 if (gfc_option
.rtcheck
& GFC_RTCHECK_ARRAY_TEMPS
)
7180 if (fsym
&& proc_name
)
7181 asprintf (&msg
, "An array temporary was created for argument "
7182 "'%s' of procedure '%s'", fsym
->name
, proc_name
);
7184 asprintf (&msg
, "An array temporary was created");
7186 tmp
= build_fold_indirect_ref_loc (input_location
,
7188 tmp
= gfc_conv_array_data (tmp
);
7189 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7190 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
7192 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7193 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7195 gfc_conv_expr_present (sym
), tmp
);
7197 gfc_trans_runtime_check (false, true, tmp
, &se
->pre
,
7202 gfc_start_block (&block
);
7204 /* Copy the data back. */
7205 if (fsym
== NULL
|| fsym
->attr
.intent
!= INTENT_IN
)
7207 tmp
= build_call_expr_loc (input_location
,
7208 gfor_fndecl_in_unpack
, 2, desc
, ptr
);
7209 gfc_add_expr_to_block (&block
, tmp
);
7212 /* Free the temporary. */
7213 tmp
= gfc_call_free (convert (pvoid_type_node
, ptr
));
7214 gfc_add_expr_to_block (&block
, tmp
);
7216 stmt
= gfc_finish_block (&block
);
7218 gfc_init_block (&block
);
7219 /* Only if it was repacked. This code needs to be executed before the
7220 loop cleanup code. */
7221 tmp
= build_fold_indirect_ref_loc (input_location
,
7223 tmp
= gfc_conv_array_data (tmp
);
7224 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7225 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
7227 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7228 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7230 gfc_conv_expr_present (sym
), tmp
);
7232 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
7234 gfc_add_expr_to_block (&block
, tmp
);
7235 gfc_add_block_to_block (&block
, &se
->post
);
7237 gfc_init_block (&se
->post
);
7239 /* Reset the descriptor pointer. */
7242 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7243 gfc_conv_descriptor_data_set (&se
->post
, tmp
, origptr
);
7246 gfc_add_block_to_block (&se
->post
, &block
);
7251 /* Generate code to deallocate an array, if it is allocated. */
7254 gfc_trans_dealloc_allocated (tree descriptor
, bool coarray
)
7260 gfc_start_block (&block
);
7262 var
= gfc_conv_descriptor_data_get (descriptor
);
7265 /* Call array_deallocate with an int * present in the second argument.
7266 Although it is ignored here, it's presence ensures that arrays that
7267 are already deallocated are ignored. */
7268 tmp
= gfc_deallocate_with_status (coarray
? descriptor
: var
, NULL_TREE
,
7269 NULL_TREE
, NULL_TREE
, NULL_TREE
, true,
7271 gfc_add_expr_to_block (&block
, tmp
);
7273 /* Zero the data pointer. */
7274 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
7275 var
, build_int_cst (TREE_TYPE (var
), 0));
7276 gfc_add_expr_to_block (&block
, tmp
);
7278 return gfc_finish_block (&block
);
7282 /* This helper function calculates the size in words of a full array. */
7285 get_full_array_size (stmtblock_t
*block
, tree decl
, int rank
)
7290 idx
= gfc_rank_cst
[rank
- 1];
7291 nelems
= gfc_conv_descriptor_ubound_get (decl
, idx
);
7292 tmp
= gfc_conv_descriptor_lbound_get (decl
, idx
);
7293 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7295 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7296 tmp
, gfc_index_one_node
);
7297 tmp
= gfc_evaluate_now (tmp
, block
);
7299 nelems
= gfc_conv_descriptor_stride_get (decl
, idx
);
7300 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7302 return gfc_evaluate_now (tmp
, block
);
7306 /* Allocate dest to the same size as src, and copy src -> dest.
7307 If no_malloc is set, only the copy is done. */
7310 duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
7320 /* If the source is null, set the destination to null. Then,
7321 allocate memory to the destination. */
7322 gfc_init_block (&block
);
7324 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
7326 tmp
= null_pointer_node
;
7327 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, type
, dest
, tmp
);
7328 gfc_add_expr_to_block (&block
, tmp
);
7329 null_data
= gfc_finish_block (&block
);
7331 gfc_init_block (&block
);
7332 size
= TYPE_SIZE_UNIT (TREE_TYPE (type
));
7335 tmp
= gfc_call_malloc (&block
, type
, size
);
7336 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
7337 dest
, fold_convert (type
, tmp
));
7338 gfc_add_expr_to_block (&block
, tmp
);
7341 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
7342 tmp
= build_call_expr_loc (input_location
, tmp
, 3, dest
, src
,
7343 fold_convert (size_type_node
, size
));
7347 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
7348 null_data
= gfc_finish_block (&block
);
7350 gfc_init_block (&block
);
7352 nelems
= get_full_array_size (&block
, src
, rank
);
7354 nelems
= gfc_index_one_node
;
7356 tmp
= fold_convert (gfc_array_index_type
,
7357 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
7358 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7362 tmp
= TREE_TYPE (gfc_conv_descriptor_data_get (src
));
7363 tmp
= gfc_call_malloc (&block
, tmp
, size
);
7364 gfc_conv_descriptor_data_set (&block
, dest
, tmp
);
7367 /* We know the temporary and the value will be the same length,
7368 so can use memcpy. */
7369 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
7370 tmp
= build_call_expr_loc (input_location
,
7371 tmp
, 3, gfc_conv_descriptor_data_get (dest
),
7372 gfc_conv_descriptor_data_get (src
),
7373 fold_convert (size_type_node
, size
));
7376 gfc_add_expr_to_block (&block
, tmp
);
7377 tmp
= gfc_finish_block (&block
);
7379 /* Null the destination if the source is null; otherwise do
7380 the allocate and copy. */
7381 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src
)))
7384 null_cond
= gfc_conv_descriptor_data_get (src
);
7386 null_cond
= convert (pvoid_type_node
, null_cond
);
7387 null_cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7388 null_cond
, null_pointer_node
);
7389 return build3_v (COND_EXPR
, null_cond
, tmp
, null_data
);
7393 /* Allocate dest to the same size as src, and copy data src -> dest. */
7396 gfc_duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
)
7398 return duplicate_allocatable (dest
, src
, type
, rank
, false);
7402 /* Copy data src -> dest. */
7405 gfc_copy_allocatable_data (tree dest
, tree src
, tree type
, int rank
)
7407 return duplicate_allocatable (dest
, src
, type
, rank
, true);
7411 /* Recursively traverse an object of derived type, generating code to
7412 deallocate, nullify or copy allocatable components. This is the work horse
7413 function for the functions named in this enum. */
7415 enum {DEALLOCATE_ALLOC_COMP
= 1, NULLIFY_ALLOC_COMP
, COPY_ALLOC_COMP
,
7416 COPY_ONLY_ALLOC_COMP
};
7419 structure_alloc_comps (gfc_symbol
* der_type
, tree decl
,
7420 tree dest
, int rank
, int purpose
)
7424 stmtblock_t fnblock
;
7425 stmtblock_t loopbody
;
7426 stmtblock_t tmpblock
;
7437 tree null_cond
= NULL_TREE
;
7438 bool called_dealloc_with_status
;
7440 gfc_init_block (&fnblock
);
7442 decl_type
= TREE_TYPE (decl
);
7444 if ((POINTER_TYPE_P (decl_type
) && rank
!= 0)
7445 || (TREE_CODE (decl_type
) == REFERENCE_TYPE
&& rank
== 0))
7446 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
7448 /* Just in case in gets dereferenced. */
7449 decl_type
= TREE_TYPE (decl
);
7451 /* If this an array of derived types with allocatable components
7452 build a loop and recursively call this function. */
7453 if (TREE_CODE (decl_type
) == ARRAY_TYPE
7454 || (GFC_DESCRIPTOR_TYPE_P (decl_type
) && rank
!= 0))
7456 tmp
= gfc_conv_array_data (decl
);
7457 var
= build_fold_indirect_ref_loc (input_location
,
7460 /* Get the number of elements - 1 and set the counter. */
7461 if (GFC_DESCRIPTOR_TYPE_P (decl_type
))
7463 /* Use the descriptor for an allocatable array. Since this
7464 is a full array reference, we only need the descriptor
7465 information from dimension = rank. */
7466 tmp
= get_full_array_size (&fnblock
, decl
, rank
);
7467 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7468 gfc_array_index_type
, tmp
,
7469 gfc_index_one_node
);
7471 null_cond
= gfc_conv_descriptor_data_get (decl
);
7472 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
7473 boolean_type_node
, null_cond
,
7474 build_int_cst (TREE_TYPE (null_cond
), 0));
7478 /* Otherwise use the TYPE_DOMAIN information. */
7479 tmp
= array_type_nelts (decl_type
);
7480 tmp
= fold_convert (gfc_array_index_type
, tmp
);
7483 /* Remember that this is, in fact, the no. of elements - 1. */
7484 nelems
= gfc_evaluate_now (tmp
, &fnblock
);
7485 index
= gfc_create_var (gfc_array_index_type
, "S");
7487 /* Build the body of the loop. */
7488 gfc_init_block (&loopbody
);
7490 vref
= gfc_build_array_ref (var
, index
, NULL
);
7492 if (purpose
== COPY_ALLOC_COMP
)
7494 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
7496 tmp
= gfc_duplicate_allocatable (dest
, decl
, decl_type
, rank
);
7497 gfc_add_expr_to_block (&fnblock
, tmp
);
7499 tmp
= build_fold_indirect_ref_loc (input_location
,
7500 gfc_conv_array_data (dest
));
7501 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
7502 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
, purpose
);
7504 else if (purpose
== COPY_ONLY_ALLOC_COMP
)
7506 tmp
= build_fold_indirect_ref_loc (input_location
,
7507 gfc_conv_array_data (dest
));
7508 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
7509 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
,
7513 tmp
= structure_alloc_comps (der_type
, vref
, NULL_TREE
, rank
, purpose
);
7515 gfc_add_expr_to_block (&loopbody
, tmp
);
7517 /* Build the loop and return. */
7518 gfc_init_loopinfo (&loop
);
7520 loop
.from
[0] = gfc_index_zero_node
;
7521 loop
.loopvar
[0] = index
;
7522 loop
.to
[0] = nelems
;
7523 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
7524 gfc_add_block_to_block (&fnblock
, &loop
.pre
);
7526 tmp
= gfc_finish_block (&fnblock
);
7527 if (null_cond
!= NULL_TREE
)
7528 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
7529 build_empty_stmt (input_location
));
7534 /* Otherwise, act on the components or recursively call self to
7535 act on a chain of components. */
7536 for (c
= der_type
->components
; c
; c
= c
->next
)
7538 bool cmp_has_alloc_comps
= (c
->ts
.type
== BT_DERIVED
7539 || c
->ts
.type
== BT_CLASS
)
7540 && c
->ts
.u
.derived
->attr
.alloc_comp
;
7541 cdecl = c
->backend_decl
;
7542 ctype
= TREE_TYPE (cdecl);
7546 case DEALLOCATE_ALLOC_COMP
:
7548 /* gfc_deallocate_scalar_with_status calls gfc_deallocate_alloc_comp
7549 (i.e. this function) so generate all the calls and suppress the
7550 recursion from here, if necessary. */
7551 called_dealloc_with_status
= false;
7552 gfc_init_block (&tmpblock
);
7554 if (c
->attr
.allocatable
&& (c
->attr
.dimension
|| c
->attr
.codimension
)
7555 && !c
->attr
.proc_pointer
)
7557 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7558 decl
, cdecl, NULL_TREE
);
7559 tmp
= gfc_trans_dealloc_allocated (comp
, c
->attr
.codimension
);
7560 gfc_add_expr_to_block (&tmpblock
, tmp
);
7562 else if (c
->attr
.allocatable
)
7564 /* Allocatable scalar components. */
7565 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7566 decl
, cdecl, NULL_TREE
);
7568 tmp
= gfc_deallocate_scalar_with_status (comp
, NULL
, true, NULL
,
7570 gfc_add_expr_to_block (&tmpblock
, tmp
);
7571 called_dealloc_with_status
= true;
7573 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7574 void_type_node
, comp
,
7575 build_int_cst (TREE_TYPE (comp
), 0));
7576 gfc_add_expr_to_block (&tmpblock
, tmp
);
7578 else if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
7580 /* Allocatable CLASS components. */
7581 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7582 decl
, cdecl, NULL_TREE
);
7584 /* Add reference to '_data' component. */
7585 tmp
= CLASS_DATA (c
)->backend_decl
;
7586 comp
= fold_build3_loc (input_location
, COMPONENT_REF
,
7587 TREE_TYPE (tmp
), comp
, tmp
, NULL_TREE
);
7589 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp
)))
7590 tmp
= gfc_trans_dealloc_allocated (comp
,
7591 CLASS_DATA (c
)->attr
.codimension
);
7594 tmp
= gfc_deallocate_scalar_with_status (comp
, NULL_TREE
, true, NULL
,
7595 CLASS_DATA (c
)->ts
);
7596 gfc_add_expr_to_block (&tmpblock
, tmp
);
7597 called_dealloc_with_status
= true;
7599 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7600 void_type_node
, comp
,
7601 build_int_cst (TREE_TYPE (comp
), 0));
7603 gfc_add_expr_to_block (&tmpblock
, tmp
);
7606 if (cmp_has_alloc_comps
7608 && !called_dealloc_with_status
)
7610 /* Do not deallocate the components of ultimate pointer
7611 components or iteratively call self if call has been made
7612 to gfc_trans_dealloc_allocated */
7613 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7614 decl
, cdecl, NULL_TREE
);
7615 rank
= c
->as
? c
->as
->rank
: 0;
7616 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
7618 gfc_add_expr_to_block (&fnblock
, tmp
);
7621 /* Now add the deallocation of this component. */
7622 gfc_add_block_to_block (&fnblock
, &tmpblock
);
7625 case NULLIFY_ALLOC_COMP
:
7626 if (c
->attr
.pointer
)
7628 else if (c
->attr
.allocatable
7629 && (c
->attr
.dimension
|| c
->attr
.codimension
))
7631 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7632 decl
, cdecl, NULL_TREE
);
7633 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
7635 else if (c
->attr
.allocatable
)
7637 /* Allocatable scalar components. */
7638 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7639 decl
, cdecl, NULL_TREE
);
7640 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7641 void_type_node
, comp
,
7642 build_int_cst (TREE_TYPE (comp
), 0));
7643 gfc_add_expr_to_block (&fnblock
, tmp
);
7645 else if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
7647 /* Allocatable CLASS components. */
7648 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7649 decl
, cdecl, NULL_TREE
);
7650 /* Add reference to '_data' component. */
7651 tmp
= CLASS_DATA (c
)->backend_decl
;
7652 comp
= fold_build3_loc (input_location
, COMPONENT_REF
,
7653 TREE_TYPE (tmp
), comp
, tmp
, NULL_TREE
);
7654 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp
)))
7655 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
7658 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7659 void_type_node
, comp
,
7660 build_int_cst (TREE_TYPE (comp
), 0));
7661 gfc_add_expr_to_block (&fnblock
, tmp
);
7664 else if (cmp_has_alloc_comps
)
7666 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7667 decl
, cdecl, NULL_TREE
);
7668 rank
= c
->as
? c
->as
->rank
: 0;
7669 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
7671 gfc_add_expr_to_block (&fnblock
, tmp
);
7675 case COPY_ALLOC_COMP
:
7676 if (c
->attr
.pointer
)
7679 /* We need source and destination components. */
7680 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, decl
,
7682 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, dest
,
7684 dcmp
= fold_convert (TREE_TYPE (comp
), dcmp
);
7686 if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
7694 dst_data
= gfc_class_data_get (dcmp
);
7695 src_data
= gfc_class_data_get (comp
);
7696 size
= fold_convert (size_type_node
, gfc_vtable_size_get (comp
));
7698 if (CLASS_DATA (c
)->attr
.dimension
)
7700 nelems
= gfc_conv_descriptor_size (src_data
,
7701 CLASS_DATA (c
)->as
->rank
);
7702 src_data
= gfc_conv_descriptor_data_get (src_data
);
7703 dst_data
= gfc_conv_descriptor_data_get (dst_data
);
7706 nelems
= build_int_cst (size_type_node
, 1);
7708 gfc_init_block (&tmpblock
);
7710 /* We need to use CALLOC as _copy might try to free allocatable
7711 components of the destination. */
7712 ftn_tree
= builtin_decl_explicit (BUILT_IN_CALLOC
);
7713 tmp
= build_call_expr_loc (input_location
, ftn_tree
, 2, nelems
,
7715 gfc_add_modify (&tmpblock
, dst_data
,
7716 fold_convert (TREE_TYPE (dst_data
), tmp
));
7718 tmp
= gfc_copy_class_to_class (comp
, dcmp
, nelems
);
7719 gfc_add_expr_to_block (&tmpblock
, tmp
);
7720 tmp
= gfc_finish_block (&tmpblock
);
7722 gfc_init_block (&tmpblock
);
7723 gfc_add_modify (&tmpblock
, dst_data
,
7724 fold_convert (TREE_TYPE (dst_data
),
7725 null_pointer_node
));
7726 null_data
= gfc_finish_block (&tmpblock
);
7728 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
7729 boolean_type_node
, src_data
,
7732 gfc_add_expr_to_block (&fnblock
, build3_v (COND_EXPR
, null_cond
,
7737 if (c
->attr
.allocatable
&& !c
->attr
.proc_pointer
7738 && !cmp_has_alloc_comps
)
7740 rank
= c
->as
? c
->as
->rank
: 0;
7741 tmp
= gfc_duplicate_allocatable (dcmp
, comp
, ctype
, rank
);
7742 gfc_add_expr_to_block (&fnblock
, tmp
);
7745 if (cmp_has_alloc_comps
)
7747 rank
= c
->as
? c
->as
->rank
: 0;
7748 tmp
= fold_convert (TREE_TYPE (dcmp
), comp
);
7749 gfc_add_modify (&fnblock
, dcmp
, tmp
);
7750 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, dcmp
,
7752 gfc_add_expr_to_block (&fnblock
, tmp
);
7762 return gfc_finish_block (&fnblock
);
7765 /* Recursively traverse an object of derived type, generating code to
7766 nullify allocatable components. */
7769 gfc_nullify_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
7771 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
7772 NULLIFY_ALLOC_COMP
);
7776 /* Recursively traverse an object of derived type, generating code to
7777 deallocate allocatable components. */
7780 gfc_deallocate_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
7782 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
7783 DEALLOCATE_ALLOC_COMP
);
7787 /* Recursively traverse an object of derived type, generating code to
7788 copy it and its allocatable components. */
7791 gfc_copy_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
7793 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ALLOC_COMP
);
7797 /* Recursively traverse an object of derived type, generating code to
7798 copy only its allocatable components. */
7801 gfc_copy_only_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
7803 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ONLY_ALLOC_COMP
);
7807 /* Returns the value of LBOUND for an expression. This could be broken out
7808 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
7809 called by gfc_alloc_allocatable_for_assignment. */
7811 get_std_lbound (gfc_expr
*expr
, tree desc
, int dim
, bool assumed_size
)
7816 tree cond
, cond1
, cond3
, cond4
;
7820 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
7822 tmp
= gfc_rank_cst
[dim
];
7823 lbound
= gfc_conv_descriptor_lbound_get (desc
, tmp
);
7824 ubound
= gfc_conv_descriptor_ubound_get (desc
, tmp
);
7825 stride
= gfc_conv_descriptor_stride_get (desc
, tmp
);
7826 cond1
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
7828 cond3
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
7829 stride
, gfc_index_zero_node
);
7830 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7831 boolean_type_node
, cond3
, cond1
);
7832 cond4
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
7833 stride
, gfc_index_zero_node
);
7835 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
7836 tmp
, build_int_cst (gfc_array_index_type
,
7839 cond
= boolean_false_node
;
7841 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
7842 boolean_type_node
, cond3
, cond4
);
7843 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
7844 boolean_type_node
, cond
, cond1
);
7846 return fold_build3_loc (input_location
, COND_EXPR
,
7847 gfc_array_index_type
, cond
,
7848 lbound
, gfc_index_one_node
);
7851 if (expr
->expr_type
== EXPR_FUNCTION
)
7853 /* A conversion function, so use the argument. */
7854 gcc_assert (expr
->value
.function
.isym
7855 && expr
->value
.function
.isym
->conversion
);
7856 expr
= expr
->value
.function
.actual
->expr
;
7859 if (expr
->expr_type
== EXPR_VARIABLE
)
7861 tmp
= TREE_TYPE (expr
->symtree
->n
.sym
->backend_decl
);
7862 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7864 if (ref
->type
== REF_COMPONENT
7865 && ref
->u
.c
.component
->as
7867 && ref
->next
->u
.ar
.type
== AR_FULL
)
7868 tmp
= TREE_TYPE (ref
->u
.c
.component
->backend_decl
);
7870 return GFC_TYPE_ARRAY_LBOUND(tmp
, dim
);
7873 return gfc_index_one_node
;
7877 /* Returns true if an expression represents an lhs that can be reallocated
7881 gfc_is_reallocatable_lhs (gfc_expr
*expr
)
7888 /* An allocatable variable. */
7889 if (expr
->symtree
->n
.sym
->attr
.allocatable
7891 && expr
->ref
->type
== REF_ARRAY
7892 && expr
->ref
->u
.ar
.type
== AR_FULL
)
7895 /* All that can be left are allocatable components. */
7896 if ((expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
7897 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
7898 || !expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
7901 /* Find a component ref followed by an array reference. */
7902 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7904 && ref
->type
== REF_COMPONENT
7905 && ref
->next
->type
== REF_ARRAY
7906 && !ref
->next
->next
)
7912 /* Return true if valid reallocatable lhs. */
7913 if (ref
->u
.c
.component
->attr
.allocatable
7914 && ref
->next
->u
.ar
.type
== AR_FULL
)
7921 /* Allocate the lhs of an assignment to an allocatable array, otherwise
7925 gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop
,
7929 stmtblock_t realloc_block
;
7930 stmtblock_t alloc_block
;
7934 gfc_array_info
*linfo
;
7955 gfc_array_spec
* as
;
7957 /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
7958 Find the lhs expression in the loop chain and set expr1 and
7959 expr2 accordingly. */
7960 if (expr1
->expr_type
== EXPR_FUNCTION
&& expr2
== NULL
)
7963 /* Find the ss for the lhs. */
7965 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
7966 if (lss
->info
->expr
&& lss
->info
->expr
->expr_type
== EXPR_VARIABLE
)
7968 if (lss
== gfc_ss_terminator
)
7970 expr1
= lss
->info
->expr
;
7973 /* Bail out if this is not a valid allocate on assignment. */
7974 if (!gfc_is_reallocatable_lhs (expr1
)
7975 || (expr2
&& !expr2
->rank
))
7978 /* Find the ss for the lhs. */
7980 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
7981 if (lss
->info
->expr
== expr1
)
7984 if (lss
== gfc_ss_terminator
)
7987 linfo
= &lss
->info
->data
.array
;
7989 /* Find an ss for the rhs. For operator expressions, we see the
7990 ss's for the operands. Any one of these will do. */
7992 for (; rss
&& rss
!= gfc_ss_terminator
; rss
= rss
->loop_chain
)
7993 if (rss
->info
->expr
!= expr1
&& rss
!= loop
->temp_ss
)
7996 if (expr2
&& rss
== gfc_ss_terminator
)
7999 gfc_start_block (&fblock
);
8001 /* Since the lhs is allocatable, this must be a descriptor type.
8002 Get the data and array size. */
8003 desc
= linfo
->descriptor
;
8004 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)));
8005 array1
= gfc_conv_descriptor_data_get (desc
);
8007 /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
8008 deallocated if expr is an array of different shape or any of the
8009 corresponding length type parameter values of variable and expr
8010 differ." This assures F95 compatibility. */
8011 jump_label1
= gfc_build_label_decl (NULL_TREE
);
8012 jump_label2
= gfc_build_label_decl (NULL_TREE
);
8014 /* Allocate if data is NULL. */
8015 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
8016 array1
, build_int_cst (TREE_TYPE (array1
), 0));
8017 tmp
= build3_v (COND_EXPR
, cond
,
8018 build1_v (GOTO_EXPR
, jump_label1
),
8019 build_empty_stmt (input_location
));
8020 gfc_add_expr_to_block (&fblock
, tmp
);
8022 /* Get arrayspec if expr is a full array. */
8023 if (expr2
&& expr2
->expr_type
== EXPR_FUNCTION
8024 && expr2
->value
.function
.isym
8025 && expr2
->value
.function
.isym
->conversion
)
8027 /* For conversion functions, take the arg. */
8028 gfc_expr
*arg
= expr2
->value
.function
.actual
->expr
;
8029 as
= gfc_get_full_arrayspec_from_expr (arg
);
8032 as
= gfc_get_full_arrayspec_from_expr (expr2
);
8036 /* If the lhs shape is not the same as the rhs jump to setting the
8037 bounds and doing the reallocation....... */
8038 for (n
= 0; n
< expr1
->rank
; n
++)
8040 /* Check the shape. */
8041 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
8042 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
8043 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8044 gfc_array_index_type
,
8045 loop
->to
[n
], loop
->from
[n
]);
8046 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8047 gfc_array_index_type
,
8049 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8050 gfc_array_index_type
,
8052 cond
= fold_build2_loc (input_location
, NE_EXPR
,
8054 tmp
, gfc_index_zero_node
);
8055 tmp
= build3_v (COND_EXPR
, cond
,
8056 build1_v (GOTO_EXPR
, jump_label1
),
8057 build_empty_stmt (input_location
));
8058 gfc_add_expr_to_block (&fblock
, tmp
);
8061 /* ....else jump past the (re)alloc code. */
8062 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
8063 gfc_add_expr_to_block (&fblock
, tmp
);
8065 /* Add the label to start automatic (re)allocation. */
8066 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
8067 gfc_add_expr_to_block (&fblock
, tmp
);
8069 size1
= gfc_conv_descriptor_size (desc
, expr1
->rank
);
8071 /* Get the rhs size. Fix both sizes. */
8073 desc2
= rss
->info
->data
.array
.descriptor
;
8076 size2
= gfc_index_one_node
;
8077 for (n
= 0; n
< expr2
->rank
; n
++)
8079 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8080 gfc_array_index_type
,
8081 loop
->to
[n
], loop
->from
[n
]);
8082 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8083 gfc_array_index_type
,
8084 tmp
, gfc_index_one_node
);
8085 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
8086 gfc_array_index_type
,
8090 size1
= gfc_evaluate_now (size1
, &fblock
);
8091 size2
= gfc_evaluate_now (size2
, &fblock
);
8093 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
8095 neq_size
= gfc_evaluate_now (cond
, &fblock
);
8097 /* Deallocation of allocatable components will have to occur on
8098 reallocation. Fix the old descriptor now. */
8099 if ((expr1
->ts
.type
== BT_DERIVED
)
8100 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
8101 old_desc
= gfc_evaluate_now (desc
, &fblock
);
8103 old_desc
= NULL_TREE
;
8105 /* Now modify the lhs descriptor and the associated scalarizer
8106 variables. F2003 7.4.1.3: "If variable is or becomes an
8107 unallocated allocatable variable, then it is allocated with each
8108 deferred type parameter equal to the corresponding type parameters
8109 of expr , with the shape of expr , and with each lower bound equal
8110 to the corresponding element of LBOUND(expr)."
8111 Reuse size1 to keep a dimension-by-dimension track of the
8112 stride of the new array. */
8113 size1
= gfc_index_one_node
;
8114 offset
= gfc_index_zero_node
;
8116 for (n
= 0; n
< expr2
->rank
; n
++)
8118 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8119 gfc_array_index_type
,
8120 loop
->to
[n
], loop
->from
[n
]);
8121 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8122 gfc_array_index_type
,
8123 tmp
, gfc_index_one_node
);
8125 lbound
= gfc_index_one_node
;
8130 lbd
= get_std_lbound (expr2
, desc2
, n
,
8131 as
->type
== AS_ASSUMED_SIZE
);
8132 ubound
= fold_build2_loc (input_location
,
8134 gfc_array_index_type
,
8136 ubound
= fold_build2_loc (input_location
,
8138 gfc_array_index_type
,
8143 gfc_conv_descriptor_lbound_set (&fblock
, desc
,
8146 gfc_conv_descriptor_ubound_set (&fblock
, desc
,
8149 gfc_conv_descriptor_stride_set (&fblock
, desc
,
8152 lbound
= gfc_conv_descriptor_lbound_get (desc
,
8154 tmp2
= fold_build2_loc (input_location
, MULT_EXPR
,
8155 gfc_array_index_type
,
8157 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
8158 gfc_array_index_type
,
8160 size1
= fold_build2_loc (input_location
, MULT_EXPR
,
8161 gfc_array_index_type
,
8165 /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
8166 the array offset is saved and the info.offset is used for a
8167 running offset. Use the saved_offset instead. */
8168 tmp
= gfc_conv_descriptor_offset (desc
);
8169 gfc_add_modify (&fblock
, tmp
, offset
);
8170 if (linfo
->saved_offset
8171 && TREE_CODE (linfo
->saved_offset
) == VAR_DECL
)
8172 gfc_add_modify (&fblock
, linfo
->saved_offset
, tmp
);
8174 /* Now set the deltas for the lhs. */
8175 for (n
= 0; n
< expr1
->rank
; n
++)
8177 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
8179 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8180 gfc_array_index_type
, tmp
,
8182 if (linfo
->delta
[dim
]
8183 && TREE_CODE (linfo
->delta
[dim
]) == VAR_DECL
)
8184 gfc_add_modify (&fblock
, linfo
->delta
[dim
], tmp
);
8187 /* Get the new lhs size in bytes. */
8188 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
8190 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
8191 gcc_assert (expr1
->ts
.u
.cl
->backend_decl
);
8192 tmp
= fold_convert (TREE_TYPE (expr1
->ts
.u
.cl
->backend_decl
), tmp
);
8193 gfc_add_modify (&fblock
, expr1
->ts
.u
.cl
->backend_decl
, tmp
);
8195 else if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.u
.cl
->backend_decl
)
8197 tmp
= TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
)));
8198 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8199 gfc_array_index_type
, tmp
,
8200 expr1
->ts
.u
.cl
->backend_decl
);
8203 tmp
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
8204 tmp
= fold_convert (gfc_array_index_type
, tmp
);
8205 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
8206 gfc_array_index_type
,
8208 size2
= fold_convert (size_type_node
, size2
);
8209 size2
= gfc_evaluate_now (size2
, &fblock
);
8211 /* Realloc expression. Note that the scalarizer uses desc.data
8212 in the array reference - (*desc.data)[<element>]. */
8213 gfc_init_block (&realloc_block
);
8215 if ((expr1
->ts
.type
== BT_DERIVED
)
8216 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
8218 tmp
= gfc_deallocate_alloc_comp (expr1
->ts
.u
.derived
, old_desc
,
8220 gfc_add_expr_to_block (&realloc_block
, tmp
);
8223 tmp
= build_call_expr_loc (input_location
,
8224 builtin_decl_explicit (BUILT_IN_REALLOC
), 2,
8225 fold_convert (pvoid_type_node
, array1
),
8227 gfc_conv_descriptor_data_set (&realloc_block
,
8230 if ((expr1
->ts
.type
== BT_DERIVED
)
8231 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
8233 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, desc
,
8235 gfc_add_expr_to_block (&realloc_block
, tmp
);
8238 realloc_expr
= gfc_finish_block (&realloc_block
);
8240 /* Only reallocate if sizes are different. */
8241 tmp
= build3_v (COND_EXPR
, neq_size
, realloc_expr
,
8242 build_empty_stmt (input_location
));
8246 /* Malloc expression. */
8247 gfc_init_block (&alloc_block
);
8248 tmp
= build_call_expr_loc (input_location
,
8249 builtin_decl_explicit (BUILT_IN_MALLOC
),
8251 gfc_conv_descriptor_data_set (&alloc_block
,
8253 tmp
= gfc_conv_descriptor_dtype (desc
);
8254 gfc_add_modify (&alloc_block
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
8255 if ((expr1
->ts
.type
== BT_DERIVED
)
8256 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
8258 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, desc
,
8260 gfc_add_expr_to_block (&alloc_block
, tmp
);
8262 alloc_expr
= gfc_finish_block (&alloc_block
);
8264 /* Malloc if not allocated; realloc otherwise. */
8265 tmp
= build_int_cst (TREE_TYPE (array1
), 0);
8266 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
8269 tmp
= build3_v (COND_EXPR
, cond
, alloc_expr
, realloc_expr
);
8270 gfc_add_expr_to_block (&fblock
, tmp
);
8272 /* Make sure that the scalarizer data pointer is updated. */
8274 && TREE_CODE (linfo
->data
) == VAR_DECL
)
8276 tmp
= gfc_conv_descriptor_data_get (desc
);
8277 gfc_add_modify (&fblock
, linfo
->data
, tmp
);
8280 /* Add the exit label. */
8281 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
8282 gfc_add_expr_to_block (&fblock
, tmp
);
8284 return gfc_finish_block (&fblock
);
8288 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
8289 Do likewise, recursively if necessary, with the allocatable components of
8293 gfc_trans_deferred_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
8299 stmtblock_t cleanup
;
8302 bool sym_has_alloc_comp
;
8304 sym_has_alloc_comp
= (sym
->ts
.type
== BT_DERIVED
8305 || sym
->ts
.type
== BT_CLASS
)
8306 && sym
->ts
.u
.derived
->attr
.alloc_comp
;
8308 /* Make sure the frontend gets these right. */
8309 if (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym_has_alloc_comp
))
8310 fatal_error ("Possible front-end bug: Deferred array size without pointer, "
8311 "allocatable attribute or derived type without allocatable "
8314 gfc_save_backend_locus (&loc
);
8315 gfc_set_backend_locus (&sym
->declared_at
);
8316 gfc_init_block (&init
);
8318 gcc_assert (TREE_CODE (sym
->backend_decl
) == VAR_DECL
8319 || TREE_CODE (sym
->backend_decl
) == PARM_DECL
);
8321 if (sym
->ts
.type
== BT_CHARACTER
8322 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
8324 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
8325 gfc_trans_vla_type_sizes (sym
, &init
);
8328 /* Dummy, use associated and result variables don't need anything special. */
8329 if (sym
->attr
.dummy
|| sym
->attr
.use_assoc
|| sym
->attr
.result
)
8331 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
8332 gfc_restore_backend_locus (&loc
);
8336 descriptor
= sym
->backend_decl
;
8338 /* Although static, derived types with default initializers and
8339 allocatable components must not be nulled wholesale; instead they
8340 are treated component by component. */
8341 if (TREE_STATIC (descriptor
) && !sym_has_alloc_comp
)
8343 /* SAVEd variables are not freed on exit. */
8344 gfc_trans_static_array_pointer (sym
);
8346 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
8347 gfc_restore_backend_locus (&loc
);
8351 /* Get the descriptor type. */
8352 type
= TREE_TYPE (sym
->backend_decl
);
8354 if (sym_has_alloc_comp
&& !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
8357 && !(TREE_STATIC (sym
->backend_decl
) && sym
->attr
.is_main_program
))
8359 if (sym
->value
== NULL
8360 || !gfc_has_default_initializer (sym
->ts
.u
.derived
))
8362 rank
= sym
->as
? sym
->as
->rank
: 0;
8363 tmp
= gfc_nullify_alloc_comp (sym
->ts
.u
.derived
,
8365 gfc_add_expr_to_block (&init
, tmp
);
8368 gfc_init_default_dt (sym
, &init
, false);
8371 else if (!GFC_DESCRIPTOR_TYPE_P (type
))
8373 /* If the backend_decl is not a descriptor, we must have a pointer
8375 descriptor
= build_fold_indirect_ref_loc (input_location
,
8377 type
= TREE_TYPE (descriptor
);
8380 /* NULLIFY the data pointer. */
8381 if (GFC_DESCRIPTOR_TYPE_P (type
) && !sym
->attr
.save
)
8382 gfc_conv_descriptor_data_set (&init
, descriptor
, null_pointer_node
);
8384 gfc_restore_backend_locus (&loc
);
8385 gfc_init_block (&cleanup
);
8387 /* Allocatable arrays need to be freed when they go out of scope.
8388 The allocatable components of pointers must not be touched. */
8389 if (sym_has_alloc_comp
&& !(sym
->attr
.function
|| sym
->attr
.result
)
8390 && !sym
->attr
.pointer
&& !sym
->attr
.save
)
8393 rank
= sym
->as
? sym
->as
->rank
: 0;
8394 tmp
= gfc_deallocate_alloc_comp (sym
->ts
.u
.derived
, descriptor
, rank
);
8395 gfc_add_expr_to_block (&cleanup
, tmp
);
8398 if (sym
->attr
.allocatable
&& (sym
->attr
.dimension
|| sym
->attr
.codimension
)
8399 && !sym
->attr
.save
&& !sym
->attr
.result
)
8401 tmp
= gfc_trans_dealloc_allocated (sym
->backend_decl
,
8402 sym
->attr
.codimension
);
8403 gfc_add_expr_to_block (&cleanup
, tmp
);
8406 gfc_add_init_cleanup (block
, gfc_finish_block (&init
),
8407 gfc_finish_block (&cleanup
));
8410 /************ Expression Walking Functions ******************/
8412 /* Walk a variable reference.
8414 Possible extension - multiple component subscripts.
8415 x(:,:) = foo%a(:)%b(:)
8417 forall (i=..., j=...)
8418 x(i,j) = foo%a(j)%b(i)
8420 This adds a fair amount of complexity because you need to deal with more
8421 than one ref. Maybe handle in a similar manner to vector subscripts.
8422 Maybe not worth the effort. */
8426 gfc_walk_variable_expr (gfc_ss
* ss
, gfc_expr
* expr
)
8430 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
8431 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
8434 return gfc_walk_array_ref (ss
, expr
, ref
);
8439 gfc_walk_array_ref (gfc_ss
* ss
, gfc_expr
* expr
, gfc_ref
* ref
)
8445 for (; ref
; ref
= ref
->next
)
8447 if (ref
->type
== REF_SUBSTRING
)
8449 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.start
);
8450 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.end
);
8453 /* We're only interested in array sections from now on. */
8454 if (ref
->type
!= REF_ARRAY
)
8462 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
8463 ss
= gfc_get_scalar_ss (ss
, ar
->start
[n
]);
8467 newss
= gfc_get_array_ss (ss
, expr
, ar
->as
->rank
, GFC_SS_SECTION
);
8468 newss
->info
->data
.array
.ref
= ref
;
8470 /* Make sure array is the same as array(:,:), this way
8471 we don't need to special case all the time. */
8472 ar
->dimen
= ar
->as
->rank
;
8473 for (n
= 0; n
< ar
->dimen
; n
++)
8475 ar
->dimen_type
[n
] = DIMEN_RANGE
;
8477 gcc_assert (ar
->start
[n
] == NULL
);
8478 gcc_assert (ar
->end
[n
] == NULL
);
8479 gcc_assert (ar
->stride
[n
] == NULL
);
8485 newss
= gfc_get_array_ss (ss
, expr
, 0, GFC_SS_SECTION
);
8486 newss
->info
->data
.array
.ref
= ref
;
8488 /* We add SS chains for all the subscripts in the section. */
8489 for (n
= 0; n
< ar
->dimen
; n
++)
8493 switch (ar
->dimen_type
[n
])
8496 /* Add SS for elemental (scalar) subscripts. */
8497 gcc_assert (ar
->start
[n
]);
8498 indexss
= gfc_get_scalar_ss (gfc_ss_terminator
, ar
->start
[n
]);
8499 indexss
->loop_chain
= gfc_ss_terminator
;
8500 newss
->info
->data
.array
.subscript
[n
] = indexss
;
8504 /* We don't add anything for sections, just remember this
8505 dimension for later. */
8506 newss
->dim
[newss
->dimen
] = n
;
8511 /* Create a GFC_SS_VECTOR index in which we can store
8512 the vector's descriptor. */
8513 indexss
= gfc_get_array_ss (gfc_ss_terminator
, ar
->start
[n
],
8515 indexss
->loop_chain
= gfc_ss_terminator
;
8516 newss
->info
->data
.array
.subscript
[n
] = indexss
;
8517 newss
->dim
[newss
->dimen
] = n
;
8522 /* We should know what sort of section it is by now. */
8526 /* We should have at least one non-elemental dimension,
8527 unless we are creating a descriptor for a (scalar) coarray. */
8528 gcc_assert (newss
->dimen
> 0
8529 || newss
->info
->data
.array
.ref
->u
.ar
.as
->corank
> 0);
8534 /* We should know what sort of section it is by now. */
8543 /* Walk an expression operator. If only one operand of a binary expression is
8544 scalar, we must also add the scalar term to the SS chain. */
8547 gfc_walk_op_expr (gfc_ss
* ss
, gfc_expr
* expr
)
8552 head
= gfc_walk_subexpr (ss
, expr
->value
.op
.op1
);
8553 if (expr
->value
.op
.op2
== NULL
)
8556 head2
= gfc_walk_subexpr (head
, expr
->value
.op
.op2
);
8558 /* All operands are scalar. Pass back and let the caller deal with it. */
8562 /* All operands require scalarization. */
8563 if (head
!= ss
&& (expr
->value
.op
.op2
== NULL
|| head2
!= head
))
8566 /* One of the operands needs scalarization, the other is scalar.
8567 Create a gfc_ss for the scalar expression. */
8570 /* First operand is scalar. We build the chain in reverse order, so
8571 add the scalar SS after the second operand. */
8573 while (head
&& head
->next
!= ss
)
8575 /* Check we haven't somehow broken the chain. */
8577 head
->next
= gfc_get_scalar_ss (ss
, expr
->value
.op
.op1
);
8579 else /* head2 == head */
8581 gcc_assert (head2
== head
);
8582 /* Second operand is scalar. */
8583 head2
= gfc_get_scalar_ss (head2
, expr
->value
.op
.op2
);
8590 /* Reverse a SS chain. */
8593 gfc_reverse_ss (gfc_ss
* ss
)
8598 gcc_assert (ss
!= NULL
);
8600 head
= gfc_ss_terminator
;
8601 while (ss
!= gfc_ss_terminator
)
8604 /* Check we didn't somehow break the chain. */
8605 gcc_assert (next
!= NULL
);
8615 /* Given an expression referring to a procedure, return the symbol of its
8616 interface. We can't get the procedure symbol directly as we have to handle
8617 the case of (deferred) type-bound procedures. */
8620 gfc_get_proc_ifc_for_expr (gfc_expr
*procedure_ref
)
8625 if (procedure_ref
== NULL
)
8628 /* Normal procedure case. */
8629 sym
= procedure_ref
->symtree
->n
.sym
;
8631 /* Typebound procedure case. */
8632 for (ref
= procedure_ref
->ref
; ref
; ref
= ref
->next
)
8634 if (ref
->type
== REF_COMPONENT
8635 && ref
->u
.c
.component
->attr
.proc_pointer
)
8636 sym
= ref
->u
.c
.component
->ts
.interface
;
8645 /* Walk the arguments of an elemental function.
8646 PROC_EXPR is used to check whether an argument is permitted to be absent. If
8647 it is NULL, we don't do the check and the argument is assumed to be present.
8651 gfc_walk_elemental_function_args (gfc_ss
* ss
, gfc_actual_arglist
*arg
,
8652 gfc_symbol
*proc_ifc
, gfc_ss_type type
)
8654 gfc_formal_arglist
*dummy_arg
;
8660 head
= gfc_ss_terminator
;
8664 dummy_arg
= gfc_sym_get_dummy_args (proc_ifc
);
8669 for (; arg
; arg
= arg
->next
)
8671 if (!arg
->expr
|| arg
->expr
->expr_type
== EXPR_NULL
)
8674 newss
= gfc_walk_subexpr (head
, arg
->expr
);
8677 /* Scalar argument. */
8678 gcc_assert (type
== GFC_SS_SCALAR
|| type
== GFC_SS_REFERENCE
);
8679 newss
= gfc_get_scalar_ss (head
, arg
->expr
);
8680 newss
->info
->type
= type
;
8686 if (dummy_arg
!= NULL
8687 && dummy_arg
->sym
->attr
.optional
8688 && arg
->expr
->expr_type
== EXPR_VARIABLE
8689 && (gfc_expr_attr (arg
->expr
).optional
8690 || gfc_expr_attr (arg
->expr
).allocatable
8691 || gfc_expr_attr (arg
->expr
).pointer
))
8692 newss
->info
->can_be_null_ref
= true;
8698 while (tail
->next
!= gfc_ss_terminator
)
8702 if (dummy_arg
!= NULL
)
8703 dummy_arg
= dummy_arg
->next
;
8708 /* If all the arguments are scalar we don't need the argument SS. */
8709 gfc_free_ss_chain (head
);
8714 /* Add it onto the existing chain. */
8720 /* Walk a function call. Scalar functions are passed back, and taken out of
8721 scalarization loops. For elemental functions we walk their arguments.
8722 The result of functions returning arrays is stored in a temporary outside
8723 the loop, so that the function is only called once. Hence we do not need
8724 to walk their arguments. */
8727 gfc_walk_function_expr (gfc_ss
* ss
, gfc_expr
* expr
)
8729 gfc_intrinsic_sym
*isym
;
8731 gfc_component
*comp
= NULL
;
8733 isym
= expr
->value
.function
.isym
;
8735 /* Handle intrinsic functions separately. */
8737 return gfc_walk_intrinsic_function (ss
, expr
, isym
);
8739 sym
= expr
->value
.function
.esym
;
8741 sym
= expr
->symtree
->n
.sym
;
8743 /* A function that returns arrays. */
8744 comp
= gfc_get_proc_ptr_comp (expr
);
8745 if ((!comp
&& gfc_return_by_reference (sym
) && sym
->result
->attr
.dimension
)
8746 || (comp
&& comp
->attr
.dimension
))
8747 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
8749 /* Walk the parameters of an elemental function. For now we always pass
8751 if (sym
->attr
.elemental
|| (comp
&& comp
->attr
.elemental
))
8752 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
8753 gfc_get_proc_ifc_for_expr (expr
),
8756 /* Scalar functions are OK as these are evaluated outside the scalarization
8757 loop. Pass back and let the caller deal with it. */
8762 /* An array temporary is constructed for array constructors. */
8765 gfc_walk_array_constructor (gfc_ss
* ss
, gfc_expr
* expr
)
8767 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_CONSTRUCTOR
);
8771 /* Walk an expression. Add walked expressions to the head of the SS chain.
8772 A wholly scalar expression will not be added. */
8775 gfc_walk_subexpr (gfc_ss
* ss
, gfc_expr
* expr
)
8779 switch (expr
->expr_type
)
8782 head
= gfc_walk_variable_expr (ss
, expr
);
8786 head
= gfc_walk_op_expr (ss
, expr
);
8790 head
= gfc_walk_function_expr (ss
, expr
);
8795 case EXPR_STRUCTURE
:
8796 /* Pass back and let the caller deal with it. */
8800 head
= gfc_walk_array_constructor (ss
, expr
);
8803 case EXPR_SUBSTRING
:
8804 /* Pass back and let the caller deal with it. */
8808 internal_error ("bad expression type during walk (%d)",
8815 /* Entry point for expression walking.
8816 A return value equal to the passed chain means this is
8817 a scalar expression. It is up to the caller to take whatever action is
8818 necessary to translate these. */
8821 gfc_walk_expr (gfc_expr
* expr
)
8825 res
= gfc_walk_subexpr (gfc_ss_terminator
, expr
);
8826 return gfc_reverse_ss (res
);