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 if (TREE_CODE (*loop_ubound0
) == VAR_DECL
)
2313 gfc_trans_create_temp_array (&outer_loop
->pre
, &outer_loop
->post
, ss
, type
,
2314 NULL_TREE
, dynamic
, true, false, where
);
2316 desc
= ss_info
->data
.array
.descriptor
;
2317 offset
= gfc_index_zero_node
;
2318 offsetvar
= gfc_create_var_np (gfc_array_index_type
, "offset");
2319 TREE_NO_WARNING (offsetvar
) = 1;
2320 TREE_USED (offsetvar
) = 0;
2321 gfc_trans_array_constructor_value (&outer_loop
->pre
, type
, desc
, c
,
2322 &offset
, &offsetvar
, dynamic
);
2324 /* If the array grows dynamically, the upper bound of the loop variable
2325 is determined by the array's final upper bound. */
2328 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2329 gfc_array_index_type
,
2330 offsetvar
, gfc_index_one_node
);
2331 tmp
= gfc_evaluate_now (tmp
, &outer_loop
->pre
);
2332 gfc_conv_descriptor_ubound_set (&loop
->pre
, desc
, gfc_rank_cst
[0], tmp
);
2333 if (*loop_ubound0
&& TREE_CODE (*loop_ubound0
) == VAR_DECL
)
2334 gfc_add_modify (&outer_loop
->pre
, *loop_ubound0
, tmp
);
2336 *loop_ubound0
= tmp
;
2339 if (TREE_USED (offsetvar
))
2340 pushdecl (offsetvar
);
2342 gcc_assert (INTEGER_CST_P (offset
));
2345 /* Disable bound checking for now because it's probably broken. */
2346 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2353 /* Restore old values of globals. */
2354 first_len
= old_first_len
;
2355 first_len_val
= old_first_len_val
;
2356 typespec_chararray_ctor
= old_typespec_chararray_ctor
;
2360 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
2361 called after evaluating all of INFO's vector dimensions. Go through
2362 each such vector dimension and see if we can now fill in any missing
2366 set_vector_loop_bounds (gfc_ss
* ss
)
2368 gfc_loopinfo
*loop
, *outer_loop
;
2369 gfc_array_info
*info
;
2377 outer_loop
= outermost_loop (ss
->loop
);
2379 info
= &ss
->info
->data
.array
;
2381 for (; ss
; ss
= ss
->parent
)
2385 for (n
= 0; n
< loop
->dimen
; n
++)
2388 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_VECTOR
2389 || loop
->to
[n
] != NULL
)
2392 /* Loop variable N indexes vector dimension DIM, and we don't
2393 yet know the upper bound of loop variable N. Set it to the
2394 difference between the vector's upper and lower bounds. */
2395 gcc_assert (loop
->from
[n
] == gfc_index_zero_node
);
2396 gcc_assert (info
->subscript
[dim
]
2397 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
2399 gfc_init_se (&se
, NULL
);
2400 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
2401 zero
= gfc_rank_cst
[0];
2402 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2403 gfc_array_index_type
,
2404 gfc_conv_descriptor_ubound_get (desc
, zero
),
2405 gfc_conv_descriptor_lbound_get (desc
, zero
));
2406 tmp
= gfc_evaluate_now (tmp
, &outer_loop
->pre
);
2413 /* Add the pre and post chains for all the scalar expressions in a SS chain
2414 to loop. This is called after the loop parameters have been calculated,
2415 but before the actual scalarizing loops. */
2418 gfc_add_loop_ss_code (gfc_loopinfo
* loop
, gfc_ss
* ss
, bool subscript
,
2421 gfc_loopinfo
*nested_loop
, *outer_loop
;
2423 gfc_ss_info
*ss_info
;
2424 gfc_array_info
*info
;
2428 /* Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise,
2429 arguments could get evaluated multiple times. */
2430 if (ss
->is_alloc_lhs
)
2433 outer_loop
= outermost_loop (loop
);
2435 /* TODO: This can generate bad code if there are ordering dependencies,
2436 e.g., a callee allocated function and an unknown size constructor. */
2437 gcc_assert (ss
!= NULL
);
2439 for (; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2443 /* Cross loop arrays are handled from within the most nested loop. */
2444 if (ss
->nested_ss
!= NULL
)
2448 expr
= ss_info
->expr
;
2449 info
= &ss_info
->data
.array
;
2451 switch (ss_info
->type
)
2454 /* Scalar expression. Evaluate this now. This includes elemental
2455 dimension indices, but not array section bounds. */
2456 gfc_init_se (&se
, NULL
);
2457 gfc_conv_expr (&se
, expr
);
2458 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2460 if (expr
->ts
.type
!= BT_CHARACTER
)
2462 /* Move the evaluation of scalar expressions outside the
2463 scalarization loop, except for WHERE assignments. */
2465 se
.expr
= convert(gfc_array_index_type
, se
.expr
);
2466 if (!ss_info
->where
)
2467 se
.expr
= gfc_evaluate_now (se
.expr
, &outer_loop
->pre
);
2468 gfc_add_block_to_block (&outer_loop
->pre
, &se
.post
);
2471 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2473 ss_info
->data
.scalar
.value
= se
.expr
;
2474 ss_info
->string_length
= se
.string_length
;
2477 case GFC_SS_REFERENCE
:
2478 /* Scalar argument to elemental procedure. */
2479 gfc_init_se (&se
, NULL
);
2480 if (ss_info
->can_be_null_ref
)
2482 /* If the actual argument can be absent (in other words, it can
2483 be a NULL reference), don't try to evaluate it; pass instead
2484 the reference directly. */
2485 gfc_conv_expr_reference (&se
, expr
);
2489 /* Otherwise, evaluate the argument outside the loop and pass
2490 a reference to the value. */
2491 gfc_conv_expr (&se
, expr
);
2493 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2494 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2495 if (gfc_is_class_scalar_expr (expr
))
2496 /* This is necessary because the dynamic type will always be
2497 large than the declared type. In consequence, assigning
2498 the value to a temporary could segfault.
2499 OOP-TODO: see if this is generally correct or is the value
2500 has to be written to an allocated temporary, whose address
2501 is passed via ss_info. */
2502 ss_info
->data
.scalar
.value
= se
.expr
;
2504 ss_info
->data
.scalar
.value
= gfc_evaluate_now (se
.expr
,
2507 ss_info
->string_length
= se
.string_length
;
2510 case GFC_SS_SECTION
:
2511 /* Add the expressions for scalar and vector subscripts. */
2512 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2513 if (info
->subscript
[n
])
2514 gfc_add_loop_ss_code (loop
, info
->subscript
[n
], true, where
);
2516 set_vector_loop_bounds (ss
);
2520 /* Get the vector's descriptor and store it in SS. */
2521 gfc_init_se (&se
, NULL
);
2522 gfc_conv_expr_descriptor (&se
, expr
);
2523 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2524 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2525 info
->descriptor
= se
.expr
;
2528 case GFC_SS_INTRINSIC
:
2529 gfc_add_intrinsic_ss_code (loop
, ss
);
2532 case GFC_SS_FUNCTION
:
2533 /* Array function return value. We call the function and save its
2534 result in a temporary for use inside the loop. */
2535 gfc_init_se (&se
, NULL
);
2538 gfc_conv_expr (&se
, expr
);
2539 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2540 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2541 ss_info
->string_length
= se
.string_length
;
2544 case GFC_SS_CONSTRUCTOR
:
2545 if (expr
->ts
.type
== BT_CHARACTER
2546 && ss_info
->string_length
== NULL
2548 && expr
->ts
.u
.cl
->length
)
2550 gfc_init_se (&se
, NULL
);
2551 gfc_conv_expr_type (&se
, expr
->ts
.u
.cl
->length
,
2552 gfc_charlen_type_node
);
2553 ss_info
->string_length
= se
.expr
;
2554 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2555 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2557 trans_array_constructor (ss
, where
);
2561 case GFC_SS_COMPONENT
:
2562 /* Do nothing. These are handled elsewhere. */
2571 for (nested_loop
= loop
->nested
; nested_loop
;
2572 nested_loop
= nested_loop
->next
)
2573 gfc_add_loop_ss_code (nested_loop
, nested_loop
->ss
, subscript
, where
);
2577 /* Translate expressions for the descriptor and data pointer of a SS. */
2581 gfc_conv_ss_descriptor (stmtblock_t
* block
, gfc_ss
* ss
, int base
)
2584 gfc_ss_info
*ss_info
;
2585 gfc_array_info
*info
;
2589 info
= &ss_info
->data
.array
;
2591 /* Get the descriptor for the array to be scalarized. */
2592 gcc_assert (ss_info
->expr
->expr_type
== EXPR_VARIABLE
);
2593 gfc_init_se (&se
, NULL
);
2594 se
.descriptor_only
= 1;
2595 gfc_conv_expr_lhs (&se
, ss_info
->expr
);
2596 gfc_add_block_to_block (block
, &se
.pre
);
2597 info
->descriptor
= se
.expr
;
2598 ss_info
->string_length
= se
.string_length
;
2602 /* Also the data pointer. */
2603 tmp
= gfc_conv_array_data (se
.expr
);
2604 /* If this is a variable or address of a variable we use it directly.
2605 Otherwise we must evaluate it now to avoid breaking dependency
2606 analysis by pulling the expressions for elemental array indices
2609 || (TREE_CODE (tmp
) == ADDR_EXPR
2610 && DECL_P (TREE_OPERAND (tmp
, 0)))))
2611 tmp
= gfc_evaluate_now (tmp
, block
);
2614 tmp
= gfc_conv_array_offset (se
.expr
);
2615 info
->offset
= gfc_evaluate_now (tmp
, block
);
2617 /* Make absolutely sure that the saved_offset is indeed saved
2618 so that the variable is still accessible after the loops
2620 info
->saved_offset
= info
->offset
;
2625 /* Initialize a gfc_loopinfo structure. */
2628 gfc_init_loopinfo (gfc_loopinfo
* loop
)
2632 memset (loop
, 0, sizeof (gfc_loopinfo
));
2633 gfc_init_block (&loop
->pre
);
2634 gfc_init_block (&loop
->post
);
2636 /* Initially scalarize in order and default to no loop reversal. */
2637 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2640 loop
->reverse
[n
] = GFC_INHIBIT_REVERSE
;
2643 loop
->ss
= gfc_ss_terminator
;
2647 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2651 gfc_copy_loopinfo_to_se (gfc_se
* se
, gfc_loopinfo
* loop
)
2657 /* Return an expression for the data pointer of an array. */
2660 gfc_conv_array_data (tree descriptor
)
2664 type
= TREE_TYPE (descriptor
);
2665 if (GFC_ARRAY_TYPE_P (type
))
2667 if (TREE_CODE (type
) == POINTER_TYPE
)
2671 /* Descriptorless arrays. */
2672 return gfc_build_addr_expr (NULL_TREE
, descriptor
);
2676 return gfc_conv_descriptor_data_get (descriptor
);
2680 /* Return an expression for the base offset of an array. */
2683 gfc_conv_array_offset (tree descriptor
)
2687 type
= TREE_TYPE (descriptor
);
2688 if (GFC_ARRAY_TYPE_P (type
))
2689 return GFC_TYPE_ARRAY_OFFSET (type
);
2691 return gfc_conv_descriptor_offset_get (descriptor
);
2695 /* Get an expression for the array stride. */
2698 gfc_conv_array_stride (tree descriptor
, int dim
)
2703 type
= TREE_TYPE (descriptor
);
2705 /* For descriptorless arrays use the array size. */
2706 tmp
= GFC_TYPE_ARRAY_STRIDE (type
, dim
);
2707 if (tmp
!= NULL_TREE
)
2710 tmp
= gfc_conv_descriptor_stride_get (descriptor
, gfc_rank_cst
[dim
]);
2715 /* Like gfc_conv_array_stride, but for the lower bound. */
2718 gfc_conv_array_lbound (tree descriptor
, int dim
)
2723 type
= TREE_TYPE (descriptor
);
2725 tmp
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
2726 if (tmp
!= NULL_TREE
)
2729 tmp
= gfc_conv_descriptor_lbound_get (descriptor
, gfc_rank_cst
[dim
]);
2734 /* Like gfc_conv_array_stride, but for the upper bound. */
2737 gfc_conv_array_ubound (tree descriptor
, int dim
)
2742 type
= TREE_TYPE (descriptor
);
2744 tmp
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
2745 if (tmp
!= NULL_TREE
)
2748 /* This should only ever happen when passing an assumed shape array
2749 as an actual parameter. The value will never be used. */
2750 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor
)))
2751 return gfc_index_zero_node
;
2753 tmp
= gfc_conv_descriptor_ubound_get (descriptor
, gfc_rank_cst
[dim
]);
2758 /* Generate code to perform an array index bound check. */
2761 trans_array_bound_check (gfc_se
* se
, gfc_ss
*ss
, tree index
, int n
,
2762 locus
* where
, bool check_upper
)
2765 tree tmp_lo
, tmp_up
;
2768 const char * name
= NULL
;
2770 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
2773 descriptor
= ss
->info
->data
.array
.descriptor
;
2775 index
= gfc_evaluate_now (index
, &se
->pre
);
2777 /* We find a name for the error message. */
2778 name
= ss
->info
->expr
->symtree
->n
.sym
->name
;
2779 gcc_assert (name
!= NULL
);
2781 if (TREE_CODE (descriptor
) == VAR_DECL
)
2782 name
= IDENTIFIER_POINTER (DECL_NAME (descriptor
));
2784 /* If upper bound is present, include both bounds in the error message. */
2787 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
2788 tmp_up
= gfc_conv_array_ubound (descriptor
, n
);
2791 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
2792 "outside of expected range (%%ld:%%ld)", n
+1, name
);
2794 asprintf (&msg
, "Index '%%ld' of dimension %d "
2795 "outside of expected range (%%ld:%%ld)", n
+1);
2797 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2799 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2800 fold_convert (long_integer_type_node
, index
),
2801 fold_convert (long_integer_type_node
, tmp_lo
),
2802 fold_convert (long_integer_type_node
, tmp_up
));
2803 fault
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2805 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2806 fold_convert (long_integer_type_node
, index
),
2807 fold_convert (long_integer_type_node
, tmp_lo
),
2808 fold_convert (long_integer_type_node
, tmp_up
));
2813 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
2816 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
2817 "below lower bound of %%ld", n
+1, name
);
2819 asprintf (&msg
, "Index '%%ld' of dimension %d "
2820 "below lower bound of %%ld", n
+1);
2822 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2824 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2825 fold_convert (long_integer_type_node
, index
),
2826 fold_convert (long_integer_type_node
, tmp_lo
));
2834 /* Return the offset for an index. Performs bound checking for elemental
2835 dimensions. Single element references are processed separately.
2836 DIM is the array dimension, I is the loop dimension. */
2839 conv_array_index_offset (gfc_se
* se
, gfc_ss
* ss
, int dim
, int i
,
2840 gfc_array_ref
* ar
, tree stride
)
2842 gfc_array_info
*info
;
2847 info
= &ss
->info
->data
.array
;
2849 /* Get the index into the array for this dimension. */
2852 gcc_assert (ar
->type
!= AR_ELEMENT
);
2853 switch (ar
->dimen_type
[dim
])
2855 case DIMEN_THIS_IMAGE
:
2859 /* Elemental dimension. */
2860 gcc_assert (info
->subscript
[dim
]
2861 && info
->subscript
[dim
]->info
->type
== GFC_SS_SCALAR
);
2862 /* We've already translated this value outside the loop. */
2863 index
= info
->subscript
[dim
]->info
->data
.scalar
.value
;
2865 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
2866 ar
->as
->type
!= AS_ASSUMED_SIZE
2867 || dim
< ar
->dimen
- 1);
2871 gcc_assert (info
&& se
->loop
);
2872 gcc_assert (info
->subscript
[dim
]
2873 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
2874 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
2876 /* Get a zero-based index into the vector. */
2877 index
= fold_build2_loc (input_location
, MINUS_EXPR
,
2878 gfc_array_index_type
,
2879 se
->loop
->loopvar
[i
], se
->loop
->from
[i
]);
2881 /* Multiply the index by the stride. */
2882 index
= fold_build2_loc (input_location
, MULT_EXPR
,
2883 gfc_array_index_type
,
2884 index
, gfc_conv_array_stride (desc
, 0));
2886 /* Read the vector to get an index into info->descriptor. */
2887 data
= build_fold_indirect_ref_loc (input_location
,
2888 gfc_conv_array_data (desc
));
2889 index
= gfc_build_array_ref (data
, index
, NULL
);
2890 index
= gfc_evaluate_now (index
, &se
->pre
);
2891 index
= fold_convert (gfc_array_index_type
, index
);
2893 /* Do any bounds checking on the final info->descriptor index. */
2894 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
2895 ar
->as
->type
!= AS_ASSUMED_SIZE
2896 || dim
< ar
->dimen
- 1);
2900 /* Scalarized dimension. */
2901 gcc_assert (info
&& se
->loop
);
2903 /* Multiply the loop variable by the stride and delta. */
2904 index
= se
->loop
->loopvar
[i
];
2905 if (!integer_onep (info
->stride
[dim
]))
2906 index
= fold_build2_loc (input_location
, MULT_EXPR
,
2907 gfc_array_index_type
, index
,
2909 if (!integer_zerop (info
->delta
[dim
]))
2910 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
2911 gfc_array_index_type
, index
,
2921 /* Temporary array or derived type component. */
2922 gcc_assert (se
->loop
);
2923 index
= se
->loop
->loopvar
[se
->loop
->order
[i
]];
2925 /* Pointer functions can have stride[0] different from unity.
2926 Use the stride returned by the function call and stored in
2927 the descriptor for the temporary. */
2928 if (se
->ss
&& se
->ss
->info
->type
== GFC_SS_FUNCTION
2929 && se
->ss
->info
->expr
2930 && se
->ss
->info
->expr
->symtree
2931 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
2932 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
->attr
.pointer
)
2933 stride
= gfc_conv_descriptor_stride_get (info
->descriptor
,
2936 if (!integer_zerop (info
->delta
[dim
]))
2937 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
2938 gfc_array_index_type
, index
, info
->delta
[dim
]);
2941 /* Multiply by the stride. */
2942 if (!integer_onep (stride
))
2943 index
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
2950 /* Build a scalarized array reference using the vptr 'size'. */
2953 build_class_array_ref (gfc_se
*se
, tree base
, tree index
)
2960 gfc_expr
*expr
= se
->ss
->info
->expr
;
2965 if (expr
== NULL
|| expr
->ts
.type
!= BT_CLASS
)
2968 if (expr
->symtree
&& expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
2969 ts
= &expr
->symtree
->n
.sym
->ts
;
2974 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2976 if (ref
->type
== REF_COMPONENT
2977 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
2978 && ref
->next
&& ref
->next
->type
== REF_COMPONENT
2979 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0
2981 && ref
->next
->next
->type
== REF_ARRAY
2982 && ref
->next
->next
->u
.ar
.type
!= AR_ELEMENT
)
2984 ts
= &ref
->u
.c
.component
->ts
;
2993 if (class_ref
== NULL
)
2994 decl
= expr
->symtree
->n
.sym
->backend_decl
;
2997 /* Remove everything after the last class reference, convert the
2998 expression and then recover its tailend once more. */
3000 ref
= class_ref
->next
;
3001 class_ref
->next
= NULL
;
3002 gfc_init_se (&tmpse
, NULL
);
3003 gfc_conv_expr (&tmpse
, expr
);
3005 class_ref
->next
= ref
;
3008 size
= gfc_vtable_size_get (decl
);
3010 /* Build the address of the element. */
3011 type
= TREE_TYPE (TREE_TYPE (base
));
3012 size
= fold_convert (TREE_TYPE (index
), size
);
3013 offset
= fold_build2_loc (input_location
, MULT_EXPR
,
3014 gfc_array_index_type
,
3016 tmp
= gfc_build_addr_expr (pvoid_type_node
, base
);
3017 tmp
= fold_build_pointer_plus_loc (input_location
, tmp
, offset
);
3018 tmp
= fold_convert (build_pointer_type (type
), tmp
);
3020 /* Return the element in the se expression. */
3021 se
->expr
= build_fold_indirect_ref_loc (input_location
, tmp
);
3026 /* Build a scalarized reference to an array. */
3029 gfc_conv_scalarized_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
3031 gfc_array_info
*info
;
3032 tree decl
= NULL_TREE
;
3040 expr
= ss
->info
->expr
;
3041 info
= &ss
->info
->data
.array
;
3043 n
= se
->loop
->order
[0];
3047 index
= conv_array_index_offset (se
, ss
, ss
->dim
[n
], n
, ar
, info
->stride0
);
3048 /* Add the offset for this dimension to the stored offset for all other
3050 if (!integer_zerop (info
->offset
))
3051 index
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3052 index
, info
->offset
);
3054 if (expr
&& is_subref_array (expr
))
3055 decl
= expr
->symtree
->n
.sym
->backend_decl
;
3057 tmp
= build_fold_indirect_ref_loc (input_location
, info
->data
);
3059 /* Use the vptr 'size' field to access a class the element of a class
3061 if (build_class_array_ref (se
, tmp
, index
))
3064 se
->expr
= gfc_build_array_ref (tmp
, index
, decl
);
3068 /* Translate access of temporary array. */
3071 gfc_conv_tmp_array_ref (gfc_se
* se
)
3073 se
->string_length
= se
->ss
->info
->string_length
;
3074 gfc_conv_scalarized_array_ref (se
, NULL
);
3075 gfc_advance_se_ss_chain (se
);
3078 /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
3081 add_to_offset (tree
*cst_offset
, tree
*offset
, tree t
)
3083 if (TREE_CODE (t
) == INTEGER_CST
)
3084 *cst_offset
= int_const_binop (PLUS_EXPR
, *cst_offset
, t
);
3087 if (!integer_zerop (*offset
))
3088 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3089 gfc_array_index_type
, *offset
, t
);
3097 build_array_ref (tree desc
, tree offset
, tree decl
)
3102 /* Class container types do not always have the GFC_CLASS_TYPE_P
3103 but the canonical type does. */
3104 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
3105 && TREE_CODE (desc
) == COMPONENT_REF
)
3107 type
= TREE_TYPE (TREE_OPERAND (desc
, 0));
3108 if (TYPE_CANONICAL (type
)
3109 && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type
)))
3110 type
= TYPE_CANONICAL (type
);
3115 /* Class array references need special treatment because the assigned
3116 type size needs to be used to point to the element. */
3117 if (type
&& GFC_CLASS_TYPE_P (type
))
3119 type
= gfc_get_element_type (TREE_TYPE (desc
));
3120 tmp
= TREE_OPERAND (desc
, 0);
3121 tmp
= gfc_get_class_array_ref (offset
, tmp
);
3122 tmp
= fold_convert (build_pointer_type (type
), tmp
);
3123 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3127 tmp
= gfc_conv_array_data (desc
);
3128 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3129 tmp
= gfc_build_array_ref (tmp
, offset
, decl
);
3134 /* Build an array reference. se->expr already holds the array descriptor.
3135 This should be either a variable, indirect variable reference or component
3136 reference. For arrays which do not have a descriptor, se->expr will be
3138 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
3141 gfc_conv_array_ref (gfc_se
* se
, gfc_array_ref
* ar
, gfc_symbol
* sym
,
3145 tree offset
, cst_offset
;
3153 gcc_assert (ar
->codimen
);
3155 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
->expr
)))
3156 se
->expr
= build_fold_indirect_ref (gfc_conv_array_data (se
->expr
));
3159 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se
->expr
))
3160 && TREE_CODE (TREE_TYPE (se
->expr
)) == POINTER_TYPE
)
3161 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3163 /* Use the actual tree type and not the wrapped coarray. */
3164 if (!se
->want_pointer
)
3165 se
->expr
= fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se
->expr
)),
3172 /* Handle scalarized references separately. */
3173 if (ar
->type
!= AR_ELEMENT
)
3175 gfc_conv_scalarized_array_ref (se
, ar
);
3176 gfc_advance_se_ss_chain (se
);
3180 cst_offset
= offset
= gfc_index_zero_node
;
3181 add_to_offset (&cst_offset
, &offset
, gfc_conv_array_offset (se
->expr
));
3183 /* Calculate the offsets from all the dimensions. Make sure to associate
3184 the final offset so that we form a chain of loop invariant summands. */
3185 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
3187 /* Calculate the index for this dimension. */
3188 gfc_init_se (&indexse
, se
);
3189 gfc_conv_expr_type (&indexse
, ar
->start
[n
], gfc_array_index_type
);
3190 gfc_add_block_to_block (&se
->pre
, &indexse
.pre
);
3192 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3194 /* Check array bounds. */
3198 /* Evaluate the indexse.expr only once. */
3199 indexse
.expr
= save_expr (indexse
.expr
);
3202 tmp
= gfc_conv_array_lbound (se
->expr
, n
);
3203 if (sym
->attr
.temporary
)
3205 gfc_init_se (&tmpse
, se
);
3206 gfc_conv_expr_type (&tmpse
, ar
->as
->lower
[n
],
3207 gfc_array_index_type
);
3208 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3212 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
3214 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
3215 "below lower bound of %%ld", n
+1, sym
->name
);
3216 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3217 fold_convert (long_integer_type_node
,
3219 fold_convert (long_integer_type_node
, tmp
));
3222 /* Upper bound, but not for the last dimension of assumed-size
3224 if (n
< ar
->dimen
- 1 || ar
->as
->type
!= AS_ASSUMED_SIZE
)
3226 tmp
= gfc_conv_array_ubound (se
->expr
, n
);
3227 if (sym
->attr
.temporary
)
3229 gfc_init_se (&tmpse
, se
);
3230 gfc_conv_expr_type (&tmpse
, ar
->as
->upper
[n
],
3231 gfc_array_index_type
);
3232 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3236 cond
= fold_build2_loc (input_location
, GT_EXPR
,
3237 boolean_type_node
, indexse
.expr
, tmp
);
3238 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
3239 "above upper bound of %%ld", n
+1, sym
->name
);
3240 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3241 fold_convert (long_integer_type_node
,
3243 fold_convert (long_integer_type_node
, tmp
));
3248 /* Multiply the index by the stride. */
3249 stride
= gfc_conv_array_stride (se
->expr
, n
);
3250 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3251 indexse
.expr
, stride
);
3253 /* And add it to the total. */
3254 add_to_offset (&cst_offset
, &offset
, tmp
);
3257 if (!integer_zerop (cst_offset
))
3258 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3259 gfc_array_index_type
, offset
, cst_offset
);
3261 se
->expr
= build_array_ref (se
->expr
, offset
, sym
->backend_decl
);
3265 /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
3266 LOOP_DIM dimension (if any) to array's offset. */
3269 add_array_offset (stmtblock_t
*pblock
, gfc_loopinfo
*loop
, gfc_ss
*ss
,
3270 gfc_array_ref
*ar
, int array_dim
, int loop_dim
)
3273 gfc_array_info
*info
;
3276 info
= &ss
->info
->data
.array
;
3278 gfc_init_se (&se
, NULL
);
3280 se
.expr
= info
->descriptor
;
3281 stride
= gfc_conv_array_stride (info
->descriptor
, array_dim
);
3282 index
= conv_array_index_offset (&se
, ss
, array_dim
, loop_dim
, ar
, stride
);
3283 gfc_add_block_to_block (pblock
, &se
.pre
);
3285 info
->offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3286 gfc_array_index_type
,
3287 info
->offset
, index
);
3288 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
3292 /* Generate the code to be executed immediately before entering a
3293 scalarization loop. */
3296 gfc_trans_preloop_setup (gfc_loopinfo
* loop
, int dim
, int flag
,
3297 stmtblock_t
* pblock
)
3300 gfc_ss_info
*ss_info
;
3301 gfc_array_info
*info
;
3302 gfc_ss_type ss_type
;
3304 gfc_loopinfo
*ploop
;
3308 /* This code will be executed before entering the scalarization loop
3309 for this dimension. */
3310 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3314 if ((ss_info
->useflags
& flag
) == 0)
3317 ss_type
= ss_info
->type
;
3318 if (ss_type
!= GFC_SS_SECTION
3319 && ss_type
!= GFC_SS_FUNCTION
3320 && ss_type
!= GFC_SS_CONSTRUCTOR
3321 && ss_type
!= GFC_SS_COMPONENT
)
3324 info
= &ss_info
->data
.array
;
3326 gcc_assert (dim
< ss
->dimen
);
3327 gcc_assert (ss
->dimen
== loop
->dimen
);
3330 ar
= &info
->ref
->u
.ar
;
3334 if (dim
== loop
->dimen
- 1 && loop
->parent
!= NULL
)
3336 /* If we are in the outermost dimension of this loop, the previous
3337 dimension shall be in the parent loop. */
3338 gcc_assert (ss
->parent
!= NULL
);
3341 ploop
= loop
->parent
;
3343 /* ss and ss->parent are about the same array. */
3344 gcc_assert (ss_info
== pss
->info
);
3352 if (dim
== loop
->dimen
- 1)
3357 /* For the time being, there is no loop reordering. */
3358 gcc_assert (i
== ploop
->order
[i
]);
3359 i
= ploop
->order
[i
];
3361 if (dim
== loop
->dimen
- 1 && loop
->parent
== NULL
)
3363 stride
= gfc_conv_array_stride (info
->descriptor
,
3364 innermost_ss (ss
)->dim
[i
]);
3366 /* Calculate the stride of the innermost loop. Hopefully this will
3367 allow the backend optimizers to do their stuff more effectively.
3369 info
->stride0
= gfc_evaluate_now (stride
, pblock
);
3371 /* For the outermost loop calculate the offset due to any
3372 elemental dimensions. It will have been initialized with the
3373 base offset of the array. */
3376 for (i
= 0; i
< ar
->dimen
; i
++)
3378 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
3381 add_array_offset (pblock
, loop
, ss
, ar
, i
, /* unused */ -1);
3386 /* Add the offset for the previous loop dimension. */
3387 add_array_offset (pblock
, ploop
, ss
, ar
, pss
->dim
[i
], i
);
3389 /* Remember this offset for the second loop. */
3390 if (dim
== loop
->temp_dim
- 1 && loop
->parent
== NULL
)
3391 info
->saved_offset
= info
->offset
;
3396 /* Start a scalarized expression. Creates a scope and declares loop
3400 gfc_start_scalarized_body (gfc_loopinfo
* loop
, stmtblock_t
* pbody
)
3406 gcc_assert (!loop
->array_parameter
);
3408 for (dim
= loop
->dimen
- 1; dim
>= 0; dim
--)
3410 n
= loop
->order
[dim
];
3412 gfc_start_block (&loop
->code
[n
]);
3414 /* Create the loop variable. */
3415 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "S");
3417 if (dim
< loop
->temp_dim
)
3421 /* Calculate values that will be constant within this loop. */
3422 gfc_trans_preloop_setup (loop
, dim
, flags
, &loop
->code
[n
]);
3424 gfc_start_block (pbody
);
3428 /* Generates the actual loop code for a scalarization loop. */
3431 gfc_trans_scalarized_loop_end (gfc_loopinfo
* loop
, int n
,
3432 stmtblock_t
* pbody
)
3443 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
))
3444 == (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
)
3445 && n
== loop
->dimen
- 1)
3447 /* We create an OMP_FOR construct for the outermost scalarized loop. */
3448 init
= make_tree_vec (1);
3449 cond
= make_tree_vec (1);
3450 incr
= make_tree_vec (1);
3452 /* Cycle statement is implemented with a goto. Exit statement must not
3453 be present for this loop. */
3454 exit_label
= gfc_build_label_decl (NULL_TREE
);
3455 TREE_USED (exit_label
) = 1;
3457 /* Label for cycle statements (if needed). */
3458 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3459 gfc_add_expr_to_block (pbody
, tmp
);
3461 stmt
= make_node (OMP_FOR
);
3463 TREE_TYPE (stmt
) = void_type_node
;
3464 OMP_FOR_BODY (stmt
) = loopbody
= gfc_finish_block (pbody
);
3466 OMP_FOR_CLAUSES (stmt
) = build_omp_clause (input_location
,
3467 OMP_CLAUSE_SCHEDULE
);
3468 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt
))
3469 = OMP_CLAUSE_SCHEDULE_STATIC
;
3470 if (ompws_flags
& OMPWS_NOWAIT
)
3471 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt
))
3472 = build_omp_clause (input_location
, OMP_CLAUSE_NOWAIT
);
3474 /* Initialize the loopvar. */
3475 TREE_VEC_ELT (init
, 0) = build2_v (MODIFY_EXPR
, loop
->loopvar
[n
],
3477 OMP_FOR_INIT (stmt
) = init
;
3478 /* The exit condition. */
3479 TREE_VEC_ELT (cond
, 0) = build2_loc (input_location
, LE_EXPR
,
3481 loop
->loopvar
[n
], loop
->to
[n
]);
3482 SET_EXPR_LOCATION (TREE_VEC_ELT (cond
, 0), input_location
);
3483 OMP_FOR_COND (stmt
) = cond
;
3484 /* Increment the loopvar. */
3485 tmp
= build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3486 loop
->loopvar
[n
], gfc_index_one_node
);
3487 TREE_VEC_ELT (incr
, 0) = fold_build2_loc (input_location
, MODIFY_EXPR
,
3488 void_type_node
, loop
->loopvar
[n
], tmp
);
3489 OMP_FOR_INCR (stmt
) = incr
;
3491 ompws_flags
&= ~OMPWS_CURR_SINGLEUNIT
;
3492 gfc_add_expr_to_block (&loop
->code
[n
], stmt
);
3496 bool reverse_loop
= (loop
->reverse
[n
] == GFC_REVERSE_SET
)
3497 && (loop
->temp_ss
== NULL
);
3499 loopbody
= gfc_finish_block (pbody
);
3503 tmp
= loop
->from
[n
];
3504 loop
->from
[n
] = loop
->to
[n
];
3508 /* Initialize the loopvar. */
3509 if (loop
->loopvar
[n
] != loop
->from
[n
])
3510 gfc_add_modify (&loop
->code
[n
], loop
->loopvar
[n
], loop
->from
[n
]);
3512 exit_label
= gfc_build_label_decl (NULL_TREE
);
3514 /* Generate the loop body. */
3515 gfc_init_block (&block
);
3517 /* The exit condition. */
3518 cond
= fold_build2_loc (input_location
, reverse_loop
? LT_EXPR
: GT_EXPR
,
3519 boolean_type_node
, loop
->loopvar
[n
], loop
->to
[n
]);
3520 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3521 TREE_USED (exit_label
) = 1;
3522 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3523 gfc_add_expr_to_block (&block
, tmp
);
3525 /* The main body. */
3526 gfc_add_expr_to_block (&block
, loopbody
);
3528 /* Increment the loopvar. */
3529 tmp
= fold_build2_loc (input_location
,
3530 reverse_loop
? MINUS_EXPR
: PLUS_EXPR
,
3531 gfc_array_index_type
, loop
->loopvar
[n
],
3532 gfc_index_one_node
);
3534 gfc_add_modify (&block
, loop
->loopvar
[n
], tmp
);
3536 /* Build the loop. */
3537 tmp
= gfc_finish_block (&block
);
3538 tmp
= build1_v (LOOP_EXPR
, tmp
);
3539 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
3541 /* Add the exit label. */
3542 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3543 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
3549 /* Finishes and generates the loops for a scalarized expression. */
3552 gfc_trans_scalarizing_loops (gfc_loopinfo
* loop
, stmtblock_t
* body
)
3557 stmtblock_t
*pblock
;
3561 /* Generate the loops. */
3562 for (dim
= 0; dim
< loop
->dimen
; dim
++)
3564 n
= loop
->order
[dim
];
3565 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
3566 loop
->loopvar
[n
] = NULL_TREE
;
3567 pblock
= &loop
->code
[n
];
3570 tmp
= gfc_finish_block (pblock
);
3571 gfc_add_expr_to_block (&loop
->pre
, tmp
);
3573 /* Clear all the used flags. */
3574 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3575 if (ss
->parent
== NULL
)
3576 ss
->info
->useflags
= 0;
3580 /* Finish the main body of a scalarized expression, and start the secondary
3584 gfc_trans_scalarized_loop_boundary (gfc_loopinfo
* loop
, stmtblock_t
* body
)
3588 stmtblock_t
*pblock
;
3592 /* We finish as many loops as are used by the temporary. */
3593 for (dim
= 0; dim
< loop
->temp_dim
- 1; dim
++)
3595 n
= loop
->order
[dim
];
3596 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
3597 loop
->loopvar
[n
] = NULL_TREE
;
3598 pblock
= &loop
->code
[n
];
3601 /* We don't want to finish the outermost loop entirely. */
3602 n
= loop
->order
[loop
->temp_dim
- 1];
3603 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
3605 /* Restore the initial offsets. */
3606 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3608 gfc_ss_type ss_type
;
3609 gfc_ss_info
*ss_info
;
3613 if ((ss_info
->useflags
& 2) == 0)
3616 ss_type
= ss_info
->type
;
3617 if (ss_type
!= GFC_SS_SECTION
3618 && ss_type
!= GFC_SS_FUNCTION
3619 && ss_type
!= GFC_SS_CONSTRUCTOR
3620 && ss_type
!= GFC_SS_COMPONENT
)
3623 ss_info
->data
.array
.offset
= ss_info
->data
.array
.saved_offset
;
3626 /* Restart all the inner loops we just finished. */
3627 for (dim
= loop
->temp_dim
- 2; dim
>= 0; dim
--)
3629 n
= loop
->order
[dim
];
3631 gfc_start_block (&loop
->code
[n
]);
3633 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "Q");
3635 gfc_trans_preloop_setup (loop
, dim
, 2, &loop
->code
[n
]);
3638 /* Start a block for the secondary copying code. */
3639 gfc_start_block (body
);
3643 /* Precalculate (either lower or upper) bound of an array section.
3644 BLOCK: Block in which the (pre)calculation code will go.
3645 BOUNDS[DIM]: Where the bound value will be stored once evaluated.
3646 VALUES[DIM]: Specified bound (NULL <=> unspecified).
3647 DESC: Array descriptor from which the bound will be picked if unspecified
3648 (either lower or upper bound according to LBOUND). */
3651 evaluate_bound (stmtblock_t
*block
, tree
*bounds
, gfc_expr
** values
,
3652 tree desc
, int dim
, bool lbound
)
3655 gfc_expr
* input_val
= values
[dim
];
3656 tree
*output
= &bounds
[dim
];
3661 /* Specified section bound. */
3662 gfc_init_se (&se
, NULL
);
3663 gfc_conv_expr_type (&se
, input_val
, gfc_array_index_type
);
3664 gfc_add_block_to_block (block
, &se
.pre
);
3669 /* No specific bound specified so use the bound of the array. */
3670 *output
= lbound
? gfc_conv_array_lbound (desc
, dim
) :
3671 gfc_conv_array_ubound (desc
, dim
);
3673 *output
= gfc_evaluate_now (*output
, block
);
3677 /* Calculate the lower bound of an array section. */
3680 gfc_conv_section_startstride (gfc_loopinfo
* loop
, gfc_ss
* ss
, int dim
)
3682 gfc_expr
*stride
= NULL
;
3685 gfc_array_info
*info
;
3688 gcc_assert (ss
->info
->type
== GFC_SS_SECTION
);
3690 info
= &ss
->info
->data
.array
;
3691 ar
= &info
->ref
->u
.ar
;
3693 if (ar
->dimen_type
[dim
] == DIMEN_VECTOR
)
3695 /* We use a zero-based index to access the vector. */
3696 info
->start
[dim
] = gfc_index_zero_node
;
3697 info
->end
[dim
] = NULL
;
3698 info
->stride
[dim
] = gfc_index_one_node
;
3702 gcc_assert (ar
->dimen_type
[dim
] == DIMEN_RANGE
3703 || ar
->dimen_type
[dim
] == DIMEN_THIS_IMAGE
);
3704 desc
= info
->descriptor
;
3705 stride
= ar
->stride
[dim
];
3707 /* Calculate the start of the range. For vector subscripts this will
3708 be the range of the vector. */
3709 evaluate_bound (&loop
->pre
, info
->start
, ar
->start
, desc
, dim
, true);
3711 /* Similarly calculate the end. Although this is not used in the
3712 scalarizer, it is needed when checking bounds and where the end
3713 is an expression with side-effects. */
3714 evaluate_bound (&loop
->pre
, info
->end
, ar
->end
, desc
, dim
, false);
3716 /* Calculate the stride. */
3718 info
->stride
[dim
] = gfc_index_one_node
;
3721 gfc_init_se (&se
, NULL
);
3722 gfc_conv_expr_type (&se
, stride
, gfc_array_index_type
);
3723 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
3724 info
->stride
[dim
] = gfc_evaluate_now (se
.expr
, &loop
->pre
);
3729 /* Calculates the range start and stride for a SS chain. Also gets the
3730 descriptor and data pointer. The range of vector subscripts is the size
3731 of the vector. Array bounds are also checked. */
3734 gfc_conv_ss_startstride (gfc_loopinfo
* loop
)
3742 /* Determine the rank of the loop. */
3743 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3745 switch (ss
->info
->type
)
3747 case GFC_SS_SECTION
:
3748 case GFC_SS_CONSTRUCTOR
:
3749 case GFC_SS_FUNCTION
:
3750 case GFC_SS_COMPONENT
:
3751 loop
->dimen
= ss
->dimen
;
3754 /* As usual, lbound and ubound are exceptions!. */
3755 case GFC_SS_INTRINSIC
:
3756 switch (ss
->info
->expr
->value
.function
.isym
->id
)
3758 case GFC_ISYM_LBOUND
:
3759 case GFC_ISYM_UBOUND
:
3760 case GFC_ISYM_LCOBOUND
:
3761 case GFC_ISYM_UCOBOUND
:
3762 case GFC_ISYM_THIS_IMAGE
:
3763 loop
->dimen
= ss
->dimen
;
3775 /* We should have determined the rank of the expression by now. If
3776 not, that's bad news. */
3780 /* Loop over all the SS in the chain. */
3781 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3783 gfc_ss_info
*ss_info
;
3784 gfc_array_info
*info
;
3788 expr
= ss_info
->expr
;
3789 info
= &ss_info
->data
.array
;
3791 if (expr
&& expr
->shape
&& !info
->shape
)
3792 info
->shape
= expr
->shape
;
3794 switch (ss_info
->type
)
3796 case GFC_SS_SECTION
:
3797 /* Get the descriptor for the array. If it is a cross loops array,
3798 we got the descriptor already in the outermost loop. */
3799 if (ss
->parent
== NULL
)
3800 gfc_conv_ss_descriptor (&loop
->pre
, ss
, !loop
->array_parameter
);
3802 for (n
= 0; n
< ss
->dimen
; n
++)
3803 gfc_conv_section_startstride (loop
, ss
, ss
->dim
[n
]);
3806 case GFC_SS_INTRINSIC
:
3807 switch (expr
->value
.function
.isym
->id
)
3809 /* Fall through to supply start and stride. */
3810 case GFC_ISYM_LBOUND
:
3811 case GFC_ISYM_UBOUND
:
3815 /* This is the variant without DIM=... */
3816 gcc_assert (expr
->value
.function
.actual
->next
->expr
== NULL
);
3818 arg
= expr
->value
.function
.actual
->expr
;
3819 if (arg
->rank
== -1)
3824 /* The rank (hence the return value's shape) is unknown,
3825 we have to retrieve it. */
3826 gfc_init_se (&se
, NULL
);
3827 se
.descriptor_only
= 1;
3828 gfc_conv_expr (&se
, arg
);
3829 /* This is a bare variable, so there is no preliminary
3831 gcc_assert (se
.pre
.head
== NULL_TREE
3832 && se
.post
.head
== NULL_TREE
);
3833 rank
= gfc_conv_descriptor_rank (se
.expr
);
3834 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3835 gfc_array_index_type
,
3836 fold_convert (gfc_array_index_type
,
3838 gfc_index_one_node
);
3839 info
->end
[0] = gfc_evaluate_now (tmp
, &loop
->pre
);
3840 info
->start
[0] = gfc_index_zero_node
;
3841 info
->stride
[0] = gfc_index_one_node
;
3844 /* Otherwise fall through GFC_SS_FUNCTION. */
3846 case GFC_ISYM_LCOBOUND
:
3847 case GFC_ISYM_UCOBOUND
:
3848 case GFC_ISYM_THIS_IMAGE
:
3855 case GFC_SS_CONSTRUCTOR
:
3856 case GFC_SS_FUNCTION
:
3857 for (n
= 0; n
< ss
->dimen
; n
++)
3859 int dim
= ss
->dim
[n
];
3861 info
->start
[dim
] = gfc_index_zero_node
;
3862 info
->end
[dim
] = gfc_index_zero_node
;
3863 info
->stride
[dim
] = gfc_index_one_node
;
3872 /* The rest is just runtime bound checking. */
3873 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3876 tree lbound
, ubound
;
3878 tree size
[GFC_MAX_DIMENSIONS
];
3879 tree stride_pos
, stride_neg
, non_zerosized
, tmp2
, tmp3
;
3880 gfc_array_info
*info
;
3884 gfc_start_block (&block
);
3886 for (n
= 0; n
< loop
->dimen
; n
++)
3887 size
[n
] = NULL_TREE
;
3889 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3892 gfc_ss_info
*ss_info
;
3895 const char *expr_name
;
3898 if (ss_info
->type
!= GFC_SS_SECTION
)
3901 /* Catch allocatable lhs in f2003. */
3902 if (gfc_option
.flag_realloc_lhs
&& ss
->is_alloc_lhs
)
3905 expr
= ss_info
->expr
;
3906 expr_loc
= &expr
->where
;
3907 expr_name
= expr
->symtree
->name
;
3909 gfc_start_block (&inner
);
3911 /* TODO: range checking for mapped dimensions. */
3912 info
= &ss_info
->data
.array
;
3914 /* This code only checks ranges. Elemental and vector
3915 dimensions are checked later. */
3916 for (n
= 0; n
< loop
->dimen
; n
++)
3921 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
3924 if (dim
== info
->ref
->u
.ar
.dimen
- 1
3925 && info
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
3926 check_upper
= false;
3930 /* Zero stride is not allowed. */
3931 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
3932 info
->stride
[dim
], gfc_index_zero_node
);
3933 asprintf (&msg
, "Zero stride is not allowed, for dimension %d "
3934 "of array '%s'", dim
+ 1, expr_name
);
3935 gfc_trans_runtime_check (true, false, tmp
, &inner
,
3939 desc
= info
->descriptor
;
3941 /* This is the run-time equivalent of resolve.c's
3942 check_dimension(). The logical is more readable there
3943 than it is here, with all the trees. */
3944 lbound
= gfc_conv_array_lbound (desc
, dim
);
3945 end
= info
->end
[dim
];
3947 ubound
= gfc_conv_array_ubound (desc
, dim
);
3951 /* non_zerosized is true when the selected range is not
3953 stride_pos
= fold_build2_loc (input_location
, GT_EXPR
,
3954 boolean_type_node
, info
->stride
[dim
],
3955 gfc_index_zero_node
);
3956 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
3957 info
->start
[dim
], end
);
3958 stride_pos
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3959 boolean_type_node
, stride_pos
, tmp
);
3961 stride_neg
= fold_build2_loc (input_location
, LT_EXPR
,
3963 info
->stride
[dim
], gfc_index_zero_node
);
3964 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
3965 info
->start
[dim
], end
);
3966 stride_neg
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3969 non_zerosized
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
3971 stride_pos
, stride_neg
);
3973 /* Check the start of the range against the lower and upper
3974 bounds of the array, if the range is not empty.
3975 If upper bound is present, include both bounds in the
3979 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
3981 info
->start
[dim
], lbound
);
3982 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3984 non_zerosized
, tmp
);
3985 tmp2
= fold_build2_loc (input_location
, GT_EXPR
,
3987 info
->start
[dim
], ubound
);
3988 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3990 non_zerosized
, tmp2
);
3991 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
3992 "outside of expected range (%%ld:%%ld)",
3993 dim
+ 1, expr_name
);
3994 gfc_trans_runtime_check (true, false, tmp
, &inner
,
3996 fold_convert (long_integer_type_node
, info
->start
[dim
]),
3997 fold_convert (long_integer_type_node
, lbound
),
3998 fold_convert (long_integer_type_node
, ubound
));
3999 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4001 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4002 fold_convert (long_integer_type_node
, lbound
),
4003 fold_convert (long_integer_type_node
, ubound
));
4008 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
4010 info
->start
[dim
], lbound
);
4011 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4012 boolean_type_node
, non_zerosized
, tmp
);
4013 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
4014 "below lower bound of %%ld",
4015 dim
+ 1, expr_name
);
4016 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4018 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4019 fold_convert (long_integer_type_node
, lbound
));
4023 /* Compute the last element of the range, which is not
4024 necessarily "end" (think 0:5:3, which doesn't contain 5)
4025 and check it against both lower and upper bounds. */
4027 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4028 gfc_array_index_type
, end
,
4030 tmp
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
,
4031 gfc_array_index_type
, tmp
,
4033 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4034 gfc_array_index_type
, end
, tmp
);
4035 tmp2
= fold_build2_loc (input_location
, LT_EXPR
,
4036 boolean_type_node
, tmp
, lbound
);
4037 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4038 boolean_type_node
, non_zerosized
, tmp2
);
4041 tmp3
= fold_build2_loc (input_location
, GT_EXPR
,
4042 boolean_type_node
, tmp
, ubound
);
4043 tmp3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4044 boolean_type_node
, non_zerosized
, tmp3
);
4045 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
4046 "outside of expected range (%%ld:%%ld)",
4047 dim
+ 1, expr_name
);
4048 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4050 fold_convert (long_integer_type_node
, tmp
),
4051 fold_convert (long_integer_type_node
, ubound
),
4052 fold_convert (long_integer_type_node
, lbound
));
4053 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4055 fold_convert (long_integer_type_node
, tmp
),
4056 fold_convert (long_integer_type_node
, ubound
),
4057 fold_convert (long_integer_type_node
, lbound
));
4062 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
4063 "below lower bound of %%ld",
4064 dim
+ 1, expr_name
);
4065 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4067 fold_convert (long_integer_type_node
, tmp
),
4068 fold_convert (long_integer_type_node
, lbound
));
4072 /* Check the section sizes match. */
4073 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4074 gfc_array_index_type
, end
,
4076 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
4077 gfc_array_index_type
, tmp
,
4079 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4080 gfc_array_index_type
,
4081 gfc_index_one_node
, tmp
);
4082 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
4083 gfc_array_index_type
, tmp
,
4084 build_int_cst (gfc_array_index_type
, 0));
4085 /* We remember the size of the first section, and check all the
4086 others against this. */
4089 tmp3
= fold_build2_loc (input_location
, NE_EXPR
,
4090 boolean_type_node
, tmp
, size
[n
]);
4091 asprintf (&msg
, "Array bound mismatch for dimension %d "
4092 "of array '%s' (%%ld/%%ld)",
4093 dim
+ 1, expr_name
);
4095 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4097 fold_convert (long_integer_type_node
, tmp
),
4098 fold_convert (long_integer_type_node
, size
[n
]));
4103 size
[n
] = gfc_evaluate_now (tmp
, &inner
);
4106 tmp
= gfc_finish_block (&inner
);
4108 /* For optional arguments, only check bounds if the argument is
4110 if (expr
->symtree
->n
.sym
->attr
.optional
4111 || expr
->symtree
->n
.sym
->attr
.not_always_present
)
4112 tmp
= build3_v (COND_EXPR
,
4113 gfc_conv_expr_present (expr
->symtree
->n
.sym
),
4114 tmp
, build_empty_stmt (input_location
));
4116 gfc_add_expr_to_block (&block
, tmp
);
4120 tmp
= gfc_finish_block (&block
);
4121 gfc_add_expr_to_block (&loop
->pre
, tmp
);
4124 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4125 gfc_conv_ss_startstride (loop
);
4128 /* Return true if both symbols could refer to the same data object. Does
4129 not take account of aliasing due to equivalence statements. */
4132 symbols_could_alias (gfc_symbol
*lsym
, gfc_symbol
*rsym
, bool lsym_pointer
,
4133 bool lsym_target
, bool rsym_pointer
, bool rsym_target
)
4135 /* Aliasing isn't possible if the symbols have different base types. */
4136 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
4139 /* Pointers can point to other pointers and target objects. */
4141 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4142 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4145 /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
4146 and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
4148 if (lsym_target
&& rsym_target
4149 && ((lsym
->attr
.dummy
&& !lsym
->attr
.contiguous
4150 && (!lsym
->attr
.dimension
|| lsym
->as
->type
== AS_ASSUMED_SHAPE
))
4151 || (rsym
->attr
.dummy
&& !rsym
->attr
.contiguous
4152 && (!rsym
->attr
.dimension
4153 || rsym
->as
->type
== AS_ASSUMED_SHAPE
))))
4160 /* Return true if the two SS could be aliased, i.e. both point to the same data
4162 /* TODO: resolve aliases based on frontend expressions. */
4165 gfc_could_be_alias (gfc_ss
* lss
, gfc_ss
* rss
)
4169 gfc_expr
*lexpr
, *rexpr
;
4172 bool lsym_pointer
, lsym_target
, rsym_pointer
, rsym_target
;
4174 lexpr
= lss
->info
->expr
;
4175 rexpr
= rss
->info
->expr
;
4177 lsym
= lexpr
->symtree
->n
.sym
;
4178 rsym
= rexpr
->symtree
->n
.sym
;
4180 lsym_pointer
= lsym
->attr
.pointer
;
4181 lsym_target
= lsym
->attr
.target
;
4182 rsym_pointer
= rsym
->attr
.pointer
;
4183 rsym_target
= rsym
->attr
.target
;
4185 if (symbols_could_alias (lsym
, rsym
, lsym_pointer
, lsym_target
,
4186 rsym_pointer
, rsym_target
))
4189 if (rsym
->ts
.type
!= BT_DERIVED
&& rsym
->ts
.type
!= BT_CLASS
4190 && lsym
->ts
.type
!= BT_DERIVED
&& lsym
->ts
.type
!= BT_CLASS
)
4193 /* For derived types we must check all the component types. We can ignore
4194 array references as these will have the same base type as the previous
4196 for (lref
= lexpr
->ref
; lref
!= lss
->info
->data
.array
.ref
; lref
= lref
->next
)
4198 if (lref
->type
!= REF_COMPONENT
)
4201 lsym_pointer
= lsym_pointer
|| lref
->u
.c
.sym
->attr
.pointer
;
4202 lsym_target
= lsym_target
|| lref
->u
.c
.sym
->attr
.target
;
4204 if (symbols_could_alias (lref
->u
.c
.sym
, rsym
, lsym_pointer
, lsym_target
,
4205 rsym_pointer
, rsym_target
))
4208 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4209 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4211 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4216 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
;
4219 if (rref
->type
!= REF_COMPONENT
)
4222 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4223 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4225 if (symbols_could_alias (lref
->u
.c
.sym
, rref
->u
.c
.sym
,
4226 lsym_pointer
, lsym_target
,
4227 rsym_pointer
, rsym_target
))
4230 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4231 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4233 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4234 &rref
->u
.c
.sym
->ts
))
4236 if (gfc_compare_types (&lref
->u
.c
.sym
->ts
,
4237 &rref
->u
.c
.component
->ts
))
4239 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4240 &rref
->u
.c
.component
->ts
))
4246 lsym_pointer
= lsym
->attr
.pointer
;
4247 lsym_target
= lsym
->attr
.target
;
4248 lsym_pointer
= lsym
->attr
.pointer
;
4249 lsym_target
= lsym
->attr
.target
;
4251 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
; rref
= rref
->next
)
4253 if (rref
->type
!= REF_COMPONENT
)
4256 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4257 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4259 if (symbols_could_alias (rref
->u
.c
.sym
, lsym
,
4260 lsym_pointer
, lsym_target
,
4261 rsym_pointer
, rsym_target
))
4264 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4265 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4267 if (gfc_compare_types (&lsym
->ts
, &rref
->u
.c
.component
->ts
))
4276 /* Resolve array data dependencies. Creates a temporary if required. */
4277 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
4281 gfc_conv_resolve_dependencies (gfc_loopinfo
* loop
, gfc_ss
* dest
,
4287 gfc_expr
*dest_expr
;
4292 loop
->temp_ss
= NULL
;
4293 dest_expr
= dest
->info
->expr
;
4295 for (ss
= rss
; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
4297 if (ss
->info
->type
!= GFC_SS_SECTION
)
4300 ss_expr
= ss
->info
->expr
;
4302 if (dest_expr
->symtree
->n
.sym
!= ss_expr
->symtree
->n
.sym
)
4304 if (gfc_could_be_alias (dest
, ss
)
4305 || gfc_are_equivalenced_arrays (dest_expr
, ss_expr
))
4313 lref
= dest_expr
->ref
;
4314 rref
= ss_expr
->ref
;
4316 nDepend
= gfc_dep_resolver (lref
, rref
, &loop
->reverse
[0]);
4321 for (i
= 0; i
< dest
->dimen
; i
++)
4322 for (j
= 0; j
< ss
->dimen
; j
++)
4324 && dest
->dim
[i
] == ss
->dim
[j
])
4326 /* If we don't access array elements in the same order,
4327 there is a dependency. */
4332 /* TODO : loop shifting. */
4335 /* Mark the dimensions for LOOP SHIFTING */
4336 for (n
= 0; n
< loop
->dimen
; n
++)
4338 int dim
= dest
->data
.info
.dim
[n
];
4340 if (lref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
4342 else if (! gfc_is_same_range (&lref
->u
.ar
,
4343 &rref
->u
.ar
, dim
, 0))
4347 /* Put all the dimensions with dependencies in the
4350 for (n
= 0; n
< loop
->dimen
; n
++)
4352 gcc_assert (loop
->order
[n
] == n
);
4354 loop
->order
[dim
++] = n
;
4356 for (n
= 0; n
< loop
->dimen
; n
++)
4359 loop
->order
[dim
++] = n
;
4362 gcc_assert (dim
== loop
->dimen
);
4373 tree base_type
= gfc_typenode_for_spec (&dest_expr
->ts
);
4374 if (GFC_ARRAY_TYPE_P (base_type
)
4375 || GFC_DESCRIPTOR_TYPE_P (base_type
))
4376 base_type
= gfc_get_element_type (base_type
);
4377 loop
->temp_ss
= gfc_get_temp_ss (base_type
, dest
->info
->string_length
,
4379 gfc_add_ss_to_loop (loop
, loop
->temp_ss
);
4382 loop
->temp_ss
= NULL
;
4386 /* Browse through each array's information from the scalarizer and set the loop
4387 bounds according to the "best" one (per dimension), i.e. the one which
4388 provides the most information (constant bounds, shape, etc.). */
4391 set_loop_bounds (gfc_loopinfo
*loop
)
4393 int n
, dim
, spec_dim
;
4394 gfc_array_info
*info
;
4395 gfc_array_info
*specinfo
;
4399 bool dynamic
[GFC_MAX_DIMENSIONS
];
4402 bool nonoptional_arr
;
4404 loopspec
= loop
->specloop
;
4407 for (n
= 0; n
< loop
->dimen
; n
++)
4412 /* If there are both optional and nonoptional array arguments, scalarize
4413 over the nonoptional; otherwise, it does not matter as then all
4414 (optional) arrays have to be present per F2008, 125.2.12p3(6). */
4416 nonoptional_arr
= false;
4418 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4419 if (ss
->info
->type
!= GFC_SS_SCALAR
&& ss
->info
->type
!= GFC_SS_TEMP
4420 && ss
->info
->type
!= GFC_SS_REFERENCE
&& !ss
->info
->can_be_null_ref
)
4421 nonoptional_arr
= true;
4423 /* We use one SS term, and use that to determine the bounds of the
4424 loop for this dimension. We try to pick the simplest term. */
4425 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4427 gfc_ss_type ss_type
;
4429 ss_type
= ss
->info
->type
;
4430 if (ss_type
== GFC_SS_SCALAR
4431 || ss_type
== GFC_SS_TEMP
4432 || ss_type
== GFC_SS_REFERENCE
4433 || (ss
->info
->can_be_null_ref
&& nonoptional_arr
))
4436 info
= &ss
->info
->data
.array
;
4439 if (loopspec
[n
] != NULL
)
4441 specinfo
= &loopspec
[n
]->info
->data
.array
;
4442 spec_dim
= loopspec
[n
]->dim
[n
];
4446 /* Silence uninitialized warnings. */
4453 gcc_assert (info
->shape
[dim
]);
4454 /* The frontend has worked out the size for us. */
4457 || !integer_zerop (specinfo
->start
[spec_dim
]))
4458 /* Prefer zero-based descriptors if possible. */
4463 if (ss_type
== GFC_SS_CONSTRUCTOR
)
4465 gfc_constructor_base base
;
4466 /* An unknown size constructor will always be rank one.
4467 Higher rank constructors will either have known shape,
4468 or still be wrapped in a call to reshape. */
4469 gcc_assert (loop
->dimen
== 1);
4471 /* Always prefer to use the constructor bounds if the size
4472 can be determined at compile time. Prefer not to otherwise,
4473 since the general case involves realloc, and it's better to
4474 avoid that overhead if possible. */
4475 base
= ss
->info
->expr
->value
.constructor
;
4476 dynamic
[n
] = gfc_get_array_constructor_size (&i
, base
);
4477 if (!dynamic
[n
] || !loopspec
[n
])
4482 /* Avoid using an allocatable lhs in an assignment, since
4483 there might be a reallocation coming. */
4484 if (loopspec
[n
] && ss
->is_alloc_lhs
)
4489 /* Criteria for choosing a loop specifier (most important first):
4490 doesn't need realloc
4496 else if (loopspec
[n
]->info
->type
== GFC_SS_CONSTRUCTOR
&& dynamic
[n
])
4498 else if (integer_onep (info
->stride
[dim
])
4499 && !integer_onep (specinfo
->stride
[spec_dim
]))
4501 else if (INTEGER_CST_P (info
->stride
[dim
])
4502 && !INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
4504 else if (INTEGER_CST_P (info
->start
[dim
])
4505 && !INTEGER_CST_P (specinfo
->start
[spec_dim
])
4506 && integer_onep (info
->stride
[dim
])
4507 == integer_onep (specinfo
->stride
[spec_dim
])
4508 && INTEGER_CST_P (info
->stride
[dim
])
4509 == INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
4511 /* We don't work out the upper bound.
4512 else if (INTEGER_CST_P (info->finish[n])
4513 && ! INTEGER_CST_P (specinfo->finish[n]))
4514 loopspec[n] = ss; */
4517 /* We should have found the scalarization loop specifier. If not,
4519 gcc_assert (loopspec
[n
]);
4521 info
= &loopspec
[n
]->info
->data
.array
;
4522 dim
= loopspec
[n
]->dim
[n
];
4524 /* Set the extents of this range. */
4525 cshape
= info
->shape
;
4526 if (cshape
&& INTEGER_CST_P (info
->start
[dim
])
4527 && INTEGER_CST_P (info
->stride
[dim
]))
4529 loop
->from
[n
] = info
->start
[dim
];
4530 mpz_set (i
, cshape
[get_array_ref_dim_for_loop_dim (loopspec
[n
], n
)]);
4531 mpz_sub_ui (i
, i
, 1);
4532 /* To = from + (size - 1) * stride. */
4533 tmp
= gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
4534 if (!integer_onep (info
->stride
[dim
]))
4535 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
4536 gfc_array_index_type
, tmp
,
4538 loop
->to
[n
] = fold_build2_loc (input_location
, PLUS_EXPR
,
4539 gfc_array_index_type
,
4540 loop
->from
[n
], tmp
);
4544 loop
->from
[n
] = info
->start
[dim
];
4545 switch (loopspec
[n
]->info
->type
)
4547 case GFC_SS_CONSTRUCTOR
:
4548 /* The upper bound is calculated when we expand the
4550 gcc_assert (loop
->to
[n
] == NULL_TREE
);
4553 case GFC_SS_SECTION
:
4554 /* Use the end expression if it exists and is not constant,
4555 so that it is only evaluated once. */
4556 loop
->to
[n
] = info
->end
[dim
];
4559 case GFC_SS_FUNCTION
:
4560 /* The loop bound will be set when we generate the call. */
4561 gcc_assert (loop
->to
[n
] == NULL_TREE
);
4564 case GFC_SS_INTRINSIC
:
4566 gfc_expr
*expr
= loopspec
[n
]->info
->expr
;
4568 /* The {l,u}bound of an assumed rank. */
4569 gcc_assert ((expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
4570 || expr
->value
.function
.isym
->id
== GFC_ISYM_UBOUND
)
4571 && expr
->value
.function
.actual
->next
->expr
== NULL
4572 && expr
->value
.function
.actual
->expr
->rank
== -1);
4574 loop
->to
[n
] = info
->end
[dim
];
4583 /* Transform everything so we have a simple incrementing variable. */
4584 if (integer_onep (info
->stride
[dim
]))
4585 info
->delta
[dim
] = gfc_index_zero_node
;
4588 /* Set the delta for this section. */
4589 info
->delta
[dim
] = gfc_evaluate_now (loop
->from
[n
], &loop
->pre
);
4590 /* Number of iterations is (end - start + step) / step.
4591 with start = 0, this simplifies to
4593 for (i = 0; i<=last; i++){...}; */
4594 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4595 gfc_array_index_type
, loop
->to
[n
],
4597 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
4598 gfc_array_index_type
, tmp
, info
->stride
[dim
]);
4599 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
4600 tmp
, build_int_cst (gfc_array_index_type
, -1));
4601 loop
->to
[n
] = gfc_evaluate_now (tmp
, &loop
->pre
);
4602 /* Make the loop variable start at 0. */
4603 loop
->from
[n
] = gfc_index_zero_node
;
4608 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4609 set_loop_bounds (loop
);
4613 /* Initialize the scalarization loop. Creates the loop variables. Determines
4614 the range of the loop variables. Creates a temporary if required.
4615 Also generates code for scalar expressions which have been
4616 moved outside the loop. */
4619 gfc_conv_loop_setup (gfc_loopinfo
* loop
, locus
* where
)
4624 set_loop_bounds (loop
);
4626 /* Add all the scalar code that can be taken out of the loops.
4627 This may include calculating the loop bounds, so do it before
4628 allocating the temporary. */
4629 gfc_add_loop_ss_code (loop
, loop
->ss
, false, where
);
4631 tmp_ss
= loop
->temp_ss
;
4632 /* If we want a temporary then create it. */
4635 gfc_ss_info
*tmp_ss_info
;
4637 tmp_ss_info
= tmp_ss
->info
;
4638 gcc_assert (tmp_ss_info
->type
== GFC_SS_TEMP
);
4639 gcc_assert (loop
->parent
== NULL
);
4641 /* Make absolutely sure that this is a complete type. */
4642 if (tmp_ss_info
->string_length
)
4643 tmp_ss_info
->data
.temp
.type
4644 = gfc_get_character_type_len_for_eltype
4645 (TREE_TYPE (tmp_ss_info
->data
.temp
.type
),
4646 tmp_ss_info
->string_length
);
4648 tmp
= tmp_ss_info
->data
.temp
.type
;
4649 memset (&tmp_ss_info
->data
.array
, 0, sizeof (gfc_array_info
));
4650 tmp_ss_info
->type
= GFC_SS_SECTION
;
4652 gcc_assert (tmp_ss
->dimen
!= 0);
4654 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, tmp_ss
, tmp
,
4655 NULL_TREE
, false, true, false, where
);
4658 /* For array parameters we don't have loop variables, so don't calculate the
4660 if (!loop
->array_parameter
)
4661 gfc_set_delta (loop
);
4665 /* Calculates how to transform from loop variables to array indices for each
4666 array: once loop bounds are chosen, sets the difference (DELTA field) between
4667 loop bounds and array reference bounds, for each array info. */
4670 gfc_set_delta (gfc_loopinfo
*loop
)
4672 gfc_ss
*ss
, **loopspec
;
4673 gfc_array_info
*info
;
4677 loopspec
= loop
->specloop
;
4679 /* Calculate the translation from loop variables to array indices. */
4680 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4682 gfc_ss_type ss_type
;
4684 ss_type
= ss
->info
->type
;
4685 if (ss_type
!= GFC_SS_SECTION
4686 && ss_type
!= GFC_SS_COMPONENT
4687 && ss_type
!= GFC_SS_CONSTRUCTOR
)
4690 info
= &ss
->info
->data
.array
;
4692 for (n
= 0; n
< ss
->dimen
; n
++)
4694 /* If we are specifying the range the delta is already set. */
4695 if (loopspec
[n
] != ss
)
4699 /* Calculate the offset relative to the loop variable.
4700 First multiply by the stride. */
4701 tmp
= loop
->from
[n
];
4702 if (!integer_onep (info
->stride
[dim
]))
4703 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
4704 gfc_array_index_type
,
4705 tmp
, info
->stride
[dim
]);
4707 /* Then subtract this from our starting value. */
4708 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4709 gfc_array_index_type
,
4710 info
->start
[dim
], tmp
);
4712 info
->delta
[dim
] = gfc_evaluate_now (tmp
, &loop
->pre
);
4717 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4718 gfc_set_delta (loop
);
4722 /* Calculate the size of a given array dimension from the bounds. This
4723 is simply (ubound - lbound + 1) if this expression is positive
4724 or 0 if it is negative (pick either one if it is zero). Optionally
4725 (if or_expr is present) OR the (expression != 0) condition to it. */
4728 gfc_conv_array_extent_dim (tree lbound
, tree ubound
, tree
* or_expr
)
4733 /* Calculate (ubound - lbound + 1). */
4734 res
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4736 res
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
, res
,
4737 gfc_index_one_node
);
4739 /* Check whether the size for this dimension is negative. */
4740 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, res
,
4741 gfc_index_zero_node
);
4742 res
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
, cond
,
4743 gfc_index_zero_node
, res
);
4745 /* Build OR expression. */
4747 *or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
4748 boolean_type_node
, *or_expr
, cond
);
4754 /* For an array descriptor, get the total number of elements. This is just
4755 the product of the extents along from_dim to to_dim. */
4758 gfc_conv_descriptor_size_1 (tree desc
, int from_dim
, int to_dim
)
4763 res
= gfc_index_one_node
;
4765 for (dim
= from_dim
; dim
< to_dim
; ++dim
)
4771 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]);
4772 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]);
4774 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
4775 res
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4783 /* Full size of an array. */
4786 gfc_conv_descriptor_size (tree desc
, int rank
)
4788 return gfc_conv_descriptor_size_1 (desc
, 0, rank
);
4792 /* Size of a coarray for all dimensions but the last. */
4795 gfc_conv_descriptor_cosize (tree desc
, int rank
, int corank
)
4797 return gfc_conv_descriptor_size_1 (desc
, rank
, rank
+ corank
- 1);
4801 /* Fills in an array descriptor, and returns the size of the array.
4802 The size will be a simple_val, ie a variable or a constant. Also
4803 calculates the offset of the base. The pointer argument overflow,
4804 which should be of integer type, will increase in value if overflow
4805 occurs during the size calculation. Returns the size of the array.
4809 for (n = 0; n < rank; n++)
4811 a.lbound[n] = specified_lower_bound;
4812 offset = offset + a.lbond[n] * stride;
4814 a.ubound[n] = specified_upper_bound;
4815 a.stride[n] = stride;
4816 size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
4817 overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
4818 stride = stride * size;
4820 for (n = rank; n < rank+corank; n++)
4821 (Set lcobound/ucobound as above.)
4822 element_size = sizeof (array element);
4825 stride = (size_t) stride;
4826 overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
4827 stride = stride * element_size;
4833 gfc_array_init_size (tree descriptor
, int rank
, int corank
, tree
* poffset
,
4834 gfc_expr
** lower
, gfc_expr
** upper
, stmtblock_t
* pblock
,
4835 stmtblock_t
* descriptor_block
, tree
* overflow
,
4836 tree expr3_elem_size
, tree
*nelems
, gfc_expr
*expr3
)
4849 stmtblock_t thenblock
;
4850 stmtblock_t elseblock
;
4855 type
= TREE_TYPE (descriptor
);
4857 stride
= gfc_index_one_node
;
4858 offset
= gfc_index_zero_node
;
4860 /* Set the dtype. */
4861 tmp
= gfc_conv_descriptor_dtype (descriptor
);
4862 gfc_add_modify (descriptor_block
, tmp
, gfc_get_dtype (TREE_TYPE (descriptor
)));
4864 or_expr
= boolean_false_node
;
4866 for (n
= 0; n
< rank
; n
++)
4871 /* We have 3 possibilities for determining the size of the array:
4872 lower == NULL => lbound = 1, ubound = upper[n]
4873 upper[n] = NULL => lbound = 1, ubound = lower[n]
4874 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
4877 /* Set lower bound. */
4878 gfc_init_se (&se
, NULL
);
4880 se
.expr
= gfc_index_one_node
;
4883 gcc_assert (lower
[n
]);
4886 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
4887 gfc_add_block_to_block (pblock
, &se
.pre
);
4891 se
.expr
= gfc_index_one_node
;
4895 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
4896 gfc_rank_cst
[n
], se
.expr
);
4897 conv_lbound
= se
.expr
;
4899 /* Work out the offset for this component. */
4900 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4902 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
4903 gfc_array_index_type
, offset
, tmp
);
4905 /* Set upper bound. */
4906 gfc_init_se (&se
, NULL
);
4907 gcc_assert (ubound
);
4908 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
4909 gfc_add_block_to_block (pblock
, &se
.pre
);
4911 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
4912 gfc_rank_cst
[n
], se
.expr
);
4913 conv_ubound
= se
.expr
;
4915 /* Store the stride. */
4916 gfc_conv_descriptor_stride_set (descriptor_block
, descriptor
,
4917 gfc_rank_cst
[n
], stride
);
4919 /* Calculate size and check whether extent is negative. */
4920 size
= gfc_conv_array_extent_dim (conv_lbound
, conv_ubound
, &or_expr
);
4921 size
= gfc_evaluate_now (size
, pblock
);
4923 /* Check whether multiplying the stride by the number of
4924 elements in this dimension would overflow. We must also check
4925 whether the current dimension has zero size in order to avoid
4928 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
4929 gfc_array_index_type
,
4930 fold_convert (gfc_array_index_type
,
4931 TYPE_MAX_VALUE (gfc_array_index_type
)),
4933 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
4934 boolean_type_node
, tmp
, stride
));
4935 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
4936 integer_one_node
, integer_zero_node
);
4937 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
4938 boolean_type_node
, size
,
4939 gfc_index_zero_node
));
4940 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
4941 integer_zero_node
, tmp
);
4942 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
4944 *overflow
= gfc_evaluate_now (tmp
, pblock
);
4946 /* Multiply the stride by the number of elements in this dimension. */
4947 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
4948 gfc_array_index_type
, stride
, size
);
4949 stride
= gfc_evaluate_now (stride
, pblock
);
4952 for (n
= rank
; n
< rank
+ corank
; n
++)
4956 /* Set lower bound. */
4957 gfc_init_se (&se
, NULL
);
4958 if (lower
== NULL
|| lower
[n
] == NULL
)
4960 gcc_assert (n
== rank
+ corank
- 1);
4961 se
.expr
= gfc_index_one_node
;
4965 if (ubound
|| n
== rank
+ corank
- 1)
4967 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
4968 gfc_add_block_to_block (pblock
, &se
.pre
);
4972 se
.expr
= gfc_index_one_node
;
4976 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
4977 gfc_rank_cst
[n
], se
.expr
);
4979 if (n
< rank
+ corank
- 1)
4981 gfc_init_se (&se
, NULL
);
4982 gcc_assert (ubound
);
4983 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
4984 gfc_add_block_to_block (pblock
, &se
.pre
);
4985 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
4986 gfc_rank_cst
[n
], se
.expr
);
4990 /* The stride is the number of elements in the array, so multiply by the
4991 size of an element to get the total size. Obviously, if there is a
4992 SOURCE expression (expr3) we must use its element size. */
4993 if (expr3_elem_size
!= NULL_TREE
)
4994 tmp
= expr3_elem_size
;
4995 else if (expr3
!= NULL
)
4997 if (expr3
->ts
.type
== BT_CLASS
)
5000 gfc_expr
*sz
= gfc_copy_expr (expr3
);
5001 gfc_add_vptr_component (sz
);
5002 gfc_add_size_component (sz
);
5003 gfc_init_se (&se_sz
, NULL
);
5004 gfc_conv_expr (&se_sz
, sz
);
5010 tmp
= gfc_typenode_for_spec (&expr3
->ts
);
5011 tmp
= TYPE_SIZE_UNIT (tmp
);
5015 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
5017 /* Convert to size_t. */
5018 element_size
= fold_convert (size_type_node
, tmp
);
5021 return element_size
;
5023 *nelems
= gfc_evaluate_now (stride
, pblock
);
5024 stride
= fold_convert (size_type_node
, stride
);
5026 /* First check for overflow. Since an array of type character can
5027 have zero element_size, we must check for that before
5029 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
5031 TYPE_MAX_VALUE (size_type_node
), element_size
);
5032 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
5033 boolean_type_node
, tmp
, stride
));
5034 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5035 integer_one_node
, integer_zero_node
);
5036 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
5037 boolean_type_node
, element_size
,
5038 build_int_cst (size_type_node
, 0)));
5039 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5040 integer_zero_node
, tmp
);
5041 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
5043 *overflow
= gfc_evaluate_now (tmp
, pblock
);
5045 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5046 stride
, element_size
);
5048 if (poffset
!= NULL
)
5050 offset
= gfc_evaluate_now (offset
, pblock
);
5054 if (integer_zerop (or_expr
))
5056 if (integer_onep (or_expr
))
5057 return build_int_cst (size_type_node
, 0);
5059 var
= gfc_create_var (TREE_TYPE (size
), "size");
5060 gfc_start_block (&thenblock
);
5061 gfc_add_modify (&thenblock
, var
, build_int_cst (size_type_node
, 0));
5062 thencase
= gfc_finish_block (&thenblock
);
5064 gfc_start_block (&elseblock
);
5065 gfc_add_modify (&elseblock
, var
, size
);
5066 elsecase
= gfc_finish_block (&elseblock
);
5068 tmp
= gfc_evaluate_now (or_expr
, pblock
);
5069 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
5070 gfc_add_expr_to_block (pblock
, tmp
);
5076 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
5077 the work for an ALLOCATE statement. */
5081 gfc_array_allocate (gfc_se
* se
, gfc_expr
* expr
, tree status
, tree errmsg
,
5082 tree errlen
, tree label_finish
, tree expr3_elem_size
,
5083 tree
*nelems
, gfc_expr
*expr3
)
5087 tree offset
= NULL_TREE
;
5088 tree token
= NULL_TREE
;
5091 tree error
= NULL_TREE
;
5092 tree overflow
; /* Boolean storing whether size calculation overflows. */
5093 tree var_overflow
= NULL_TREE
;
5095 tree set_descriptor
;
5096 stmtblock_t set_descriptor_block
;
5097 stmtblock_t elseblock
;
5100 gfc_ref
*ref
, *prev_ref
= NULL
;
5101 bool allocatable
, coarray
, dimension
;
5105 /* Find the last reference in the chain. */
5106 while (ref
&& ref
->next
!= NULL
)
5108 gcc_assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
5109 || (ref
->u
.ar
.dimen
== 0 && ref
->u
.ar
.codimen
> 0));
5114 if (ref
== NULL
|| ref
->type
!= REF_ARRAY
)
5119 allocatable
= expr
->symtree
->n
.sym
->attr
.allocatable
;
5120 coarray
= expr
->symtree
->n
.sym
->attr
.codimension
;
5121 dimension
= expr
->symtree
->n
.sym
->attr
.dimension
;
5125 allocatable
= prev_ref
->u
.c
.component
->attr
.allocatable
;
5126 coarray
= prev_ref
->u
.c
.component
->attr
.codimension
;
5127 dimension
= prev_ref
->u
.c
.component
->attr
.dimension
;
5131 gcc_assert (coarray
);
5133 /* Figure out the size of the array. */
5134 switch (ref
->u
.ar
.type
)
5140 upper
= ref
->u
.ar
.start
;
5146 lower
= ref
->u
.ar
.start
;
5147 upper
= ref
->u
.ar
.end
;
5151 gcc_assert (ref
->u
.ar
.as
->type
== AS_EXPLICIT
);
5153 lower
= ref
->u
.ar
.as
->lower
;
5154 upper
= ref
->u
.ar
.as
->upper
;
5162 overflow
= integer_zero_node
;
5164 gfc_init_block (&set_descriptor_block
);
5165 size
= gfc_array_init_size (se
->expr
, ref
->u
.ar
.as
->rank
,
5166 ref
->u
.ar
.as
->corank
, &offset
, lower
, upper
,
5167 &se
->pre
, &set_descriptor_block
, &overflow
,
5168 expr3_elem_size
, nelems
, expr3
);
5173 var_overflow
= gfc_create_var (integer_type_node
, "overflow");
5174 gfc_add_modify (&se
->pre
, var_overflow
, overflow
);
5176 /* Generate the block of code handling overflow. */
5177 msg
= gfc_build_addr_expr (pchar_type_node
,
5178 gfc_build_localized_cstring_const
5179 ("Integer overflow when calculating the amount of "
5180 "memory to allocate"));
5181 error
= build_call_expr_loc (input_location
, gfor_fndecl_runtime_error
,
5185 if (status
!= NULL_TREE
)
5187 tree status_type
= TREE_TYPE (status
);
5188 stmtblock_t set_status_block
;
5190 gfc_start_block (&set_status_block
);
5191 gfc_add_modify (&set_status_block
, status
,
5192 build_int_cst (status_type
, LIBERROR_ALLOCATION
));
5193 error
= gfc_finish_block (&set_status_block
);
5196 gfc_start_block (&elseblock
);
5198 /* Allocate memory to store the data. */
5199 if (POINTER_TYPE_P (TREE_TYPE (se
->expr
)))
5200 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
5202 pointer
= gfc_conv_descriptor_data_get (se
->expr
);
5203 STRIP_NOPS (pointer
);
5205 if (coarray
&& gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
5206 token
= gfc_build_addr_expr (NULL_TREE
,
5207 gfc_conv_descriptor_token (se
->expr
));
5209 /* The allocatable variant takes the old pointer as first argument. */
5211 gfc_allocate_allocatable (&elseblock
, pointer
, size
, token
,
5212 status
, errmsg
, errlen
, label_finish
, expr
);
5214 gfc_allocate_using_malloc (&elseblock
, pointer
, size
, status
);
5218 cond
= gfc_unlikely (fold_build2_loc (input_location
, NE_EXPR
,
5219 boolean_type_node
, var_overflow
, integer_zero_node
));
5220 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
5221 error
, gfc_finish_block (&elseblock
));
5224 tmp
= gfc_finish_block (&elseblock
);
5226 gfc_add_expr_to_block (&se
->pre
, tmp
);
5228 if (expr
->ts
.type
== BT_CLASS
)
5230 tmp
= build_int_cst (unsigned_char_type_node
, 0);
5231 /* With class objects, it is best to play safe and null the
5232 memory because we cannot know if dynamic types have allocatable
5233 components or not. */
5234 tmp
= build_call_expr_loc (input_location
,
5235 builtin_decl_explicit (BUILT_IN_MEMSET
),
5236 3, pointer
, tmp
, size
);
5237 gfc_add_expr_to_block (&se
->pre
, tmp
);
5240 /* Update the array descriptors. */
5242 gfc_conv_descriptor_offset_set (&set_descriptor_block
, se
->expr
, offset
);
5244 set_descriptor
= gfc_finish_block (&set_descriptor_block
);
5245 if (status
!= NULL_TREE
)
5247 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
5248 boolean_type_node
, status
,
5249 build_int_cst (TREE_TYPE (status
), 0));
5250 gfc_add_expr_to_block (&se
->pre
,
5251 fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5252 gfc_likely (cond
), set_descriptor
,
5253 build_empty_stmt (input_location
)));
5256 gfc_add_expr_to_block (&se
->pre
, set_descriptor
);
5258 if ((expr
->ts
.type
== BT_DERIVED
)
5259 && expr
->ts
.u
.derived
->attr
.alloc_comp
)
5261 tmp
= gfc_nullify_alloc_comp (expr
->ts
.u
.derived
, se
->expr
,
5262 ref
->u
.ar
.as
->rank
);
5263 gfc_add_expr_to_block (&se
->pre
, tmp
);
5270 /* Deallocate an array variable. Also used when an allocated variable goes
5275 gfc_array_deallocate (tree descriptor
, tree pstat
, tree errmsg
, tree errlen
,
5276 tree label_finish
, gfc_expr
* expr
)
5281 bool coarray
= gfc_is_coarray (expr
);
5283 gfc_start_block (&block
);
5285 /* Get a pointer to the data. */
5286 var
= gfc_conv_descriptor_data_get (descriptor
);
5289 /* Parameter is the address of the data component. */
5290 tmp
= gfc_deallocate_with_status (coarray
? descriptor
: var
, pstat
, errmsg
,
5291 errlen
, label_finish
, false, expr
, coarray
);
5292 gfc_add_expr_to_block (&block
, tmp
);
5294 /* Zero the data pointer; only for coarrays an error can occur and then
5295 the allocation status may not be changed. */
5296 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
5297 var
, build_int_cst (TREE_TYPE (var
), 0));
5298 if (pstat
!= NULL_TREE
&& coarray
&& gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
5301 tree stat
= build_fold_indirect_ref_loc (input_location
, pstat
);
5303 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5304 stat
, build_int_cst (TREE_TYPE (stat
), 0));
5305 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5306 cond
, tmp
, build_empty_stmt (input_location
));
5309 gfc_add_expr_to_block (&block
, tmp
);
5311 return gfc_finish_block (&block
);
5315 /* Create an array constructor from an initialization expression.
5316 We assume the frontend already did any expansions and conversions. */
5319 gfc_conv_array_initializer (tree type
, gfc_expr
* expr
)
5325 unsigned HOST_WIDE_INT lo
;
5327 vec
<constructor_elt
, va_gc
> *v
= NULL
;
5329 if (expr
->expr_type
== EXPR_VARIABLE
5330 && expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
5331 && expr
->symtree
->n
.sym
->value
)
5332 expr
= expr
->symtree
->n
.sym
->value
;
5334 switch (expr
->expr_type
)
5337 case EXPR_STRUCTURE
:
5338 /* A single scalar or derived type value. Create an array with all
5339 elements equal to that value. */
5340 gfc_init_se (&se
, NULL
);
5342 if (expr
->expr_type
== EXPR_CONSTANT
)
5343 gfc_conv_constant (&se
, expr
);
5345 gfc_conv_structure (&se
, expr
, 1);
5347 tmp
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
5348 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
5349 hi
= TREE_INT_CST_HIGH (tmp
);
5350 lo
= TREE_INT_CST_LOW (tmp
);
5354 /* This will probably eat buckets of memory for large arrays. */
5355 while (hi
!= 0 || lo
!= 0)
5357 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
, se
.expr
);
5365 /* Create a vector of all the elements. */
5366 for (c
= gfc_constructor_first (expr
->value
.constructor
);
5367 c
; c
= gfc_constructor_next (c
))
5371 /* Problems occur when we get something like
5372 integer :: a(lots) = (/(i, i=1, lots)/) */
5373 gfc_fatal_error ("The number of elements in the array constructor "
5374 "at %L requires an increase of the allowed %d "
5375 "upper limit. See -fmax-array-constructor "
5376 "option", &expr
->where
,
5377 gfc_option
.flag_max_array_constructor
);
5380 if (mpz_cmp_si (c
->offset
, 0) != 0)
5381 index
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
5385 if (mpz_cmp_si (c
->repeat
, 1) > 0)
5391 mpz_add (maxval
, c
->offset
, c
->repeat
);
5392 mpz_sub_ui (maxval
, maxval
, 1);
5393 tmp2
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
5394 if (mpz_cmp_si (c
->offset
, 0) != 0)
5396 mpz_add_ui (maxval
, c
->offset
, 1);
5397 tmp1
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
5400 tmp1
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
5402 range
= fold_build2 (RANGE_EXPR
, gfc_array_index_type
, tmp1
, tmp2
);
5408 gfc_init_se (&se
, NULL
);
5409 switch (c
->expr
->expr_type
)
5412 gfc_conv_constant (&se
, c
->expr
);
5415 case EXPR_STRUCTURE
:
5416 gfc_conv_structure (&se
, c
->expr
, 1);
5420 /* Catch those occasional beasts that do not simplify
5421 for one reason or another, assuming that if they are
5422 standard defying the frontend will catch them. */
5423 gfc_conv_expr (&se
, c
->expr
);
5427 if (range
== NULL_TREE
)
5428 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
5431 if (index
!= NULL_TREE
)
5432 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
5433 CONSTRUCTOR_APPEND_ELT (v
, range
, se
.expr
);
5439 return gfc_build_null_descriptor (type
);
5445 /* Create a constructor from the list of elements. */
5446 tmp
= build_constructor (type
, v
);
5447 TREE_CONSTANT (tmp
) = 1;
5452 /* Generate code to evaluate non-constant coarray cobounds. */
5455 gfc_trans_array_cobounds (tree type
, stmtblock_t
* pblock
,
5456 const gfc_symbol
*sym
)
5466 for (dim
= as
->rank
; dim
< as
->rank
+ as
->corank
; dim
++)
5468 /* Evaluate non-constant array bound expressions. */
5469 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
5470 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
5472 gfc_init_se (&se
, NULL
);
5473 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
5474 gfc_add_block_to_block (pblock
, &se
.pre
);
5475 gfc_add_modify (pblock
, lbound
, se
.expr
);
5477 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
5478 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
5480 gfc_init_se (&se
, NULL
);
5481 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
5482 gfc_add_block_to_block (pblock
, &se
.pre
);
5483 gfc_add_modify (pblock
, ubound
, se
.expr
);
5489 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
5490 returns the size (in elements) of the array. */
5493 gfc_trans_array_bounds (tree type
, gfc_symbol
* sym
, tree
* poffset
,
5494 stmtblock_t
* pblock
)
5509 size
= gfc_index_one_node
;
5510 offset
= gfc_index_zero_node
;
5511 for (dim
= 0; dim
< as
->rank
; dim
++)
5513 /* Evaluate non-constant array bound expressions. */
5514 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
5515 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
5517 gfc_init_se (&se
, NULL
);
5518 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
5519 gfc_add_block_to_block (pblock
, &se
.pre
);
5520 gfc_add_modify (pblock
, lbound
, se
.expr
);
5522 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
5523 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
5525 gfc_init_se (&se
, NULL
);
5526 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
5527 gfc_add_block_to_block (pblock
, &se
.pre
);
5528 gfc_add_modify (pblock
, ubound
, se
.expr
);
5530 /* The offset of this dimension. offset = offset - lbound * stride. */
5531 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5533 offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5536 /* The size of this dimension, and the stride of the next. */
5537 if (dim
+ 1 < as
->rank
)
5538 stride
= GFC_TYPE_ARRAY_STRIDE (type
, dim
+ 1);
5540 stride
= GFC_TYPE_ARRAY_SIZE (type
);
5542 if (ubound
!= NULL_TREE
&& !(stride
&& INTEGER_CST_P (stride
)))
5544 /* Calculate stride = size * (ubound + 1 - lbound). */
5545 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5546 gfc_array_index_type
,
5547 gfc_index_one_node
, lbound
);
5548 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5549 gfc_array_index_type
, ubound
, tmp
);
5550 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5551 gfc_array_index_type
, size
, tmp
);
5553 gfc_add_modify (pblock
, stride
, tmp
);
5555 stride
= gfc_evaluate_now (tmp
, pblock
);
5557 /* Make sure that negative size arrays are translated
5558 to being zero size. */
5559 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
5560 stride
, gfc_index_zero_node
);
5561 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5562 gfc_array_index_type
, tmp
,
5563 stride
, gfc_index_zero_node
);
5564 gfc_add_modify (pblock
, stride
, tmp
);
5570 gfc_trans_array_cobounds (type
, pblock
, sym
);
5571 gfc_trans_vla_type_sizes (sym
, pblock
);
5578 /* Generate code to initialize/allocate an array variable. */
5581 gfc_trans_auto_array_allocation (tree decl
, gfc_symbol
* sym
,
5582 gfc_wrapped_block
* block
)
5586 tree tmp
= NULL_TREE
;
5593 gcc_assert (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
));
5595 /* Do nothing for USEd variables. */
5596 if (sym
->attr
.use_assoc
)
5599 type
= TREE_TYPE (decl
);
5600 gcc_assert (GFC_ARRAY_TYPE_P (type
));
5601 onstack
= TREE_CODE (type
) != POINTER_TYPE
;
5603 gfc_init_block (&init
);
5605 /* Evaluate character string length. */
5606 if (sym
->ts
.type
== BT_CHARACTER
5607 && onstack
&& !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
5609 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
5611 gfc_trans_vla_type_sizes (sym
, &init
);
5613 /* Emit a DECL_EXPR for this variable, which will cause the
5614 gimplifier to allocate storage, and all that good stuff. */
5615 tmp
= fold_build1_loc (input_location
, DECL_EXPR
, TREE_TYPE (decl
), decl
);
5616 gfc_add_expr_to_block (&init
, tmp
);
5621 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
5625 type
= TREE_TYPE (type
);
5627 gcc_assert (!sym
->attr
.use_assoc
);
5628 gcc_assert (!TREE_STATIC (decl
));
5629 gcc_assert (!sym
->module
);
5631 if (sym
->ts
.type
== BT_CHARACTER
5632 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
5633 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
5635 size
= gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
5637 /* Don't actually allocate space for Cray Pointees. */
5638 if (sym
->attr
.cray_pointee
)
5640 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
5641 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
5643 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
5647 if (gfc_option
.flag_stack_arrays
)
5649 gcc_assert (TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
);
5650 space
= build_decl (sym
->declared_at
.lb
->location
,
5651 VAR_DECL
, create_tmp_var_name ("A"),
5652 TREE_TYPE (TREE_TYPE (decl
)));
5653 gfc_trans_vla_type_sizes (sym
, &init
);
5657 /* The size is the number of elements in the array, so multiply by the
5658 size of an element to get the total size. */
5659 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
5660 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5661 size
, fold_convert (gfc_array_index_type
, tmp
));
5663 /* Allocate memory to hold the data. */
5664 tmp
= gfc_call_malloc (&init
, TREE_TYPE (decl
), size
);
5665 gfc_add_modify (&init
, decl
, tmp
);
5667 /* Free the temporary. */
5668 tmp
= gfc_call_free (convert (pvoid_type_node
, decl
));
5672 /* Set offset of the array. */
5673 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
5674 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
5676 /* Automatic arrays should not have initializers. */
5677 gcc_assert (!sym
->value
);
5679 inittree
= gfc_finish_block (&init
);
5686 /* Don't create new scope, emit the DECL_EXPR in exactly the scope
5687 where also space is located. */
5688 gfc_init_block (&init
);
5689 tmp
= fold_build1_loc (input_location
, DECL_EXPR
,
5690 TREE_TYPE (space
), space
);
5691 gfc_add_expr_to_block (&init
, tmp
);
5692 addr
= fold_build1_loc (sym
->declared_at
.lb
->location
,
5693 ADDR_EXPR
, TREE_TYPE (decl
), space
);
5694 gfc_add_modify (&init
, decl
, addr
);
5695 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
5698 gfc_add_init_cleanup (block
, inittree
, tmp
);
5702 /* Generate entry and exit code for g77 calling convention arrays. */
5705 gfc_trans_g77_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
5715 gfc_save_backend_locus (&loc
);
5716 gfc_set_backend_locus (&sym
->declared_at
);
5718 /* Descriptor type. */
5719 parm
= sym
->backend_decl
;
5720 type
= TREE_TYPE (parm
);
5721 gcc_assert (GFC_ARRAY_TYPE_P (type
));
5723 gfc_start_block (&init
);
5725 if (sym
->ts
.type
== BT_CHARACTER
5726 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
5727 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
5729 /* Evaluate the bounds of the array. */
5730 gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
5732 /* Set the offset. */
5733 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
5734 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
5736 /* Set the pointer itself if we aren't using the parameter directly. */
5737 if (TREE_CODE (parm
) != PARM_DECL
)
5739 tmp
= convert (TREE_TYPE (parm
), GFC_DECL_SAVED_DESCRIPTOR (parm
));
5740 gfc_add_modify (&init
, parm
, tmp
);
5742 stmt
= gfc_finish_block (&init
);
5744 gfc_restore_backend_locus (&loc
);
5746 /* Add the initialization code to the start of the function. */
5748 if (sym
->attr
.optional
|| sym
->attr
.not_always_present
)
5750 tmp
= gfc_conv_expr_present (sym
);
5751 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
5754 gfc_add_init_cleanup (block
, stmt
, NULL_TREE
);
5758 /* Modify the descriptor of an array parameter so that it has the
5759 correct lower bound. Also move the upper bound accordingly.
5760 If the array is not packed, it will be copied into a temporary.
5761 For each dimension we set the new lower and upper bounds. Then we copy the
5762 stride and calculate the offset for this dimension. We also work out
5763 what the stride of a packed array would be, and see it the two match.
5764 If the array need repacking, we set the stride to the values we just
5765 calculated, recalculate the offset and copy the array data.
5766 Code is also added to copy the data back at the end of the function.
5770 gfc_trans_dummy_array_bias (gfc_symbol
* sym
, tree tmpdesc
,
5771 gfc_wrapped_block
* block
)
5778 tree stmtInit
, stmtCleanup
;
5785 tree stride
, stride2
;
5795 /* Do nothing for pointer and allocatable arrays. */
5796 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
5799 if (sym
->attr
.dummy
&& gfc_is_nodesc_array (sym
))
5801 gfc_trans_g77_array (sym
, block
);
5805 gfc_save_backend_locus (&loc
);
5806 gfc_set_backend_locus (&sym
->declared_at
);
5808 /* Descriptor type. */
5809 type
= TREE_TYPE (tmpdesc
);
5810 gcc_assert (GFC_ARRAY_TYPE_P (type
));
5811 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
5812 dumdesc
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
5813 gfc_start_block (&init
);
5815 if (sym
->ts
.type
== BT_CHARACTER
5816 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
5817 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
5819 checkparm
= (sym
->as
->type
== AS_EXPLICIT
5820 && (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
));
5822 no_repack
= !(GFC_DECL_PACKED_ARRAY (tmpdesc
)
5823 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
));
5825 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
))
5827 /* For non-constant shape arrays we only check if the first dimension
5828 is contiguous. Repacking higher dimensions wouldn't gain us
5829 anything as we still don't know the array stride. */
5830 partial
= gfc_create_var (boolean_type_node
, "partial");
5831 TREE_USED (partial
) = 1;
5832 tmp
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
5833 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, tmp
,
5834 gfc_index_one_node
);
5835 gfc_add_modify (&init
, partial
, tmp
);
5838 partial
= NULL_TREE
;
5840 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
5841 here, however I think it does the right thing. */
5844 /* Set the first stride. */
5845 stride
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
5846 stride
= gfc_evaluate_now (stride
, &init
);
5848 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5849 stride
, gfc_index_zero_node
);
5850 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
5851 tmp
, gfc_index_one_node
, stride
);
5852 stride
= GFC_TYPE_ARRAY_STRIDE (type
, 0);
5853 gfc_add_modify (&init
, stride
, tmp
);
5855 /* Allow the user to disable array repacking. */
5856 stmt_unpacked
= NULL_TREE
;
5860 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type
, 0)));
5861 /* A library call to repack the array if necessary. */
5862 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
5863 stmt_unpacked
= build_call_expr_loc (input_location
,
5864 gfor_fndecl_in_pack
, 1, tmp
);
5866 stride
= gfc_index_one_node
;
5868 if (gfc_option
.warn_array_temp
)
5869 gfc_warning ("Creating array temporary at %L", &loc
);
5872 /* This is for the case where the array data is used directly without
5873 calling the repack function. */
5874 if (no_repack
|| partial
!= NULL_TREE
)
5875 stmt_packed
= gfc_conv_descriptor_data_get (dumdesc
);
5877 stmt_packed
= NULL_TREE
;
5879 /* Assign the data pointer. */
5880 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
5882 /* Don't repack unknown shape arrays when the first stride is 1. */
5883 tmp
= fold_build3_loc (input_location
, COND_EXPR
, TREE_TYPE (stmt_packed
),
5884 partial
, stmt_packed
, stmt_unpacked
);
5887 tmp
= stmt_packed
!= NULL_TREE
? stmt_packed
: stmt_unpacked
;
5888 gfc_add_modify (&init
, tmpdesc
, fold_convert (type
, tmp
));
5890 offset
= gfc_index_zero_node
;
5891 size
= gfc_index_one_node
;
5893 /* Evaluate the bounds of the array. */
5894 for (n
= 0; n
< sym
->as
->rank
; n
++)
5896 if (checkparm
|| !sym
->as
->upper
[n
])
5898 /* Get the bounds of the actual parameter. */
5899 dubound
= gfc_conv_descriptor_ubound_get (dumdesc
, gfc_rank_cst
[n
]);
5900 dlbound
= gfc_conv_descriptor_lbound_get (dumdesc
, gfc_rank_cst
[n
]);
5904 dubound
= NULL_TREE
;
5905 dlbound
= NULL_TREE
;
5908 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, n
);
5909 if (!INTEGER_CST_P (lbound
))
5911 gfc_init_se (&se
, NULL
);
5912 gfc_conv_expr_type (&se
, sym
->as
->lower
[n
],
5913 gfc_array_index_type
);
5914 gfc_add_block_to_block (&init
, &se
.pre
);
5915 gfc_add_modify (&init
, lbound
, se
.expr
);
5918 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, n
);
5919 /* Set the desired upper bound. */
5920 if (sym
->as
->upper
[n
])
5922 /* We know what we want the upper bound to be. */
5923 if (!INTEGER_CST_P (ubound
))
5925 gfc_init_se (&se
, NULL
);
5926 gfc_conv_expr_type (&se
, sym
->as
->upper
[n
],
5927 gfc_array_index_type
);
5928 gfc_add_block_to_block (&init
, &se
.pre
);
5929 gfc_add_modify (&init
, ubound
, se
.expr
);
5932 /* Check the sizes match. */
5935 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
5939 temp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5940 gfc_array_index_type
, ubound
, lbound
);
5941 temp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5942 gfc_array_index_type
,
5943 gfc_index_one_node
, temp
);
5944 stride2
= fold_build2_loc (input_location
, MINUS_EXPR
,
5945 gfc_array_index_type
, dubound
,
5947 stride2
= fold_build2_loc (input_location
, PLUS_EXPR
,
5948 gfc_array_index_type
,
5949 gfc_index_one_node
, stride2
);
5950 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
5951 gfc_array_index_type
, temp
, stride2
);
5952 asprintf (&msg
, "Dimension %d of array '%s' has extent "
5953 "%%ld instead of %%ld", n
+1, sym
->name
);
5955 gfc_trans_runtime_check (true, false, tmp
, &init
, &loc
, msg
,
5956 fold_convert (long_integer_type_node
, temp
),
5957 fold_convert (long_integer_type_node
, stride2
));
5964 /* For assumed shape arrays move the upper bound by the same amount
5965 as the lower bound. */
5966 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5967 gfc_array_index_type
, dubound
, dlbound
);
5968 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5969 gfc_array_index_type
, tmp
, lbound
);
5970 gfc_add_modify (&init
, ubound
, tmp
);
5972 /* The offset of this dimension. offset = offset - lbound * stride. */
5973 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5975 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
5976 gfc_array_index_type
, offset
, tmp
);
5978 /* The size of this dimension, and the stride of the next. */
5979 if (n
+ 1 < sym
->as
->rank
)
5981 stride
= GFC_TYPE_ARRAY_STRIDE (type
, n
+ 1);
5983 if (no_repack
|| partial
!= NULL_TREE
)
5985 gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[n
+1]);
5987 /* Figure out the stride if not a known constant. */
5988 if (!INTEGER_CST_P (stride
))
5991 stmt_packed
= NULL_TREE
;
5994 /* Calculate stride = size * (ubound + 1 - lbound). */
5995 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5996 gfc_array_index_type
,
5997 gfc_index_one_node
, lbound
);
5998 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5999 gfc_array_index_type
, ubound
, tmp
);
6000 size
= fold_build2_loc (input_location
, MULT_EXPR
,
6001 gfc_array_index_type
, size
, tmp
);
6005 /* Assign the stride. */
6006 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
6007 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6008 gfc_array_index_type
, partial
,
6009 stmt_unpacked
, stmt_packed
);
6011 tmp
= (stmt_packed
!= NULL_TREE
) ? stmt_packed
: stmt_unpacked
;
6012 gfc_add_modify (&init
, stride
, tmp
);
6017 stride
= GFC_TYPE_ARRAY_SIZE (type
);
6019 if (stride
&& !INTEGER_CST_P (stride
))
6021 /* Calculate size = stride * (ubound + 1 - lbound). */
6022 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6023 gfc_array_index_type
,
6024 gfc_index_one_node
, lbound
);
6025 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6026 gfc_array_index_type
,
6028 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6029 gfc_array_index_type
,
6030 GFC_TYPE_ARRAY_STRIDE (type
, n
), tmp
);
6031 gfc_add_modify (&init
, stride
, tmp
);
6036 gfc_trans_array_cobounds (type
, &init
, sym
);
6038 /* Set the offset. */
6039 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
6040 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6042 gfc_trans_vla_type_sizes (sym
, &init
);
6044 stmtInit
= gfc_finish_block (&init
);
6046 /* Only do the entry/initialization code if the arg is present. */
6047 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6048 optional_arg
= (sym
->attr
.optional
6049 || (sym
->ns
->proc_name
->attr
.entry_master
6050 && sym
->attr
.dummy
));
6053 tmp
= gfc_conv_expr_present (sym
);
6054 stmtInit
= build3_v (COND_EXPR
, tmp
, stmtInit
,
6055 build_empty_stmt (input_location
));
6060 stmtCleanup
= NULL_TREE
;
6063 stmtblock_t cleanup
;
6064 gfc_start_block (&cleanup
);
6066 if (sym
->attr
.intent
!= INTENT_IN
)
6068 /* Copy the data back. */
6069 tmp
= build_call_expr_loc (input_location
,
6070 gfor_fndecl_in_unpack
, 2, dumdesc
, tmpdesc
);
6071 gfc_add_expr_to_block (&cleanup
, tmp
);
6074 /* Free the temporary. */
6075 tmp
= gfc_call_free (tmpdesc
);
6076 gfc_add_expr_to_block (&cleanup
, tmp
);
6078 stmtCleanup
= gfc_finish_block (&cleanup
);
6080 /* Only do the cleanup if the array was repacked. */
6081 tmp
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
6082 tmp
= gfc_conv_descriptor_data_get (tmp
);
6083 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6085 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6086 build_empty_stmt (input_location
));
6090 tmp
= gfc_conv_expr_present (sym
);
6091 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6092 build_empty_stmt (input_location
));
6096 /* We don't need to free any memory allocated by internal_pack as it will
6097 be freed at the end of the function by pop_context. */
6098 gfc_add_init_cleanup (block
, stmtInit
, stmtCleanup
);
6100 gfc_restore_backend_locus (&loc
);
6104 /* Calculate the overall offset, including subreferences. */
6106 gfc_get_dataptr_offset (stmtblock_t
*block
, tree parm
, tree desc
, tree offset
,
6107 bool subref
, gfc_expr
*expr
)
6117 /* If offset is NULL and this is not a subreferenced array, there is
6119 if (offset
== NULL_TREE
)
6122 offset
= gfc_index_zero_node
;
6127 tmp
= build_array_ref (desc
, offset
, NULL
);
6129 /* Offset the data pointer for pointer assignments from arrays with
6130 subreferences; e.g. my_integer => my_type(:)%integer_component. */
6133 /* Go past the array reference. */
6134 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6135 if (ref
->type
== REF_ARRAY
&&
6136 ref
->u
.ar
.type
!= AR_ELEMENT
)
6142 /* Calculate the offset for each subsequent subreference. */
6143 for (; ref
; ref
= ref
->next
)
6148 field
= ref
->u
.c
.component
->backend_decl
;
6149 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
6150 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
6152 tmp
, field
, NULL_TREE
);
6156 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
6157 gfc_init_se (&start
, NULL
);
6158 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
6159 gfc_add_block_to_block (block
, &start
.pre
);
6160 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
6164 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
6165 && ref
->u
.ar
.type
== AR_ELEMENT
);
6167 /* TODO - Add bounds checking. */
6168 stride
= gfc_index_one_node
;
6169 index
= gfc_index_zero_node
;
6170 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
6175 /* Update the index. */
6176 gfc_init_se (&start
, NULL
);
6177 gfc_conv_expr_type (&start
, ref
->u
.ar
.start
[n
], gfc_array_index_type
);
6178 itmp
= gfc_evaluate_now (start
.expr
, block
);
6179 gfc_init_se (&start
, NULL
);
6180 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->lower
[n
], gfc_array_index_type
);
6181 jtmp
= gfc_evaluate_now (start
.expr
, block
);
6182 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6183 gfc_array_index_type
, itmp
, jtmp
);
6184 itmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6185 gfc_array_index_type
, itmp
, stride
);
6186 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
6187 gfc_array_index_type
, itmp
, index
);
6188 index
= gfc_evaluate_now (index
, block
);
6190 /* Update the stride. */
6191 gfc_init_se (&start
, NULL
);
6192 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->upper
[n
], gfc_array_index_type
);
6193 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6194 gfc_array_index_type
, start
.expr
,
6196 itmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6197 gfc_array_index_type
,
6198 gfc_index_one_node
, itmp
);
6199 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
6200 gfc_array_index_type
, stride
, itmp
);
6201 stride
= gfc_evaluate_now (stride
, block
);
6204 /* Apply the index to obtain the array element. */
6205 tmp
= gfc_build_array_ref (tmp
, index
, NULL
);
6215 /* Set the target data pointer. */
6216 offset
= gfc_build_addr_expr (gfc_array_dataptr_type (desc
), tmp
);
6217 gfc_conv_descriptor_data_set (block
, parm
, offset
);
6221 /* gfc_conv_expr_descriptor needs the string length an expression
6222 so that the size of the temporary can be obtained. This is done
6223 by adding up the string lengths of all the elements in the
6224 expression. Function with non-constant expressions have their
6225 string lengths mapped onto the actual arguments using the
6226 interface mapping machinery in trans-expr.c. */
6228 get_array_charlen (gfc_expr
*expr
, gfc_se
*se
)
6230 gfc_interface_mapping mapping
;
6231 gfc_formal_arglist
*formal
;
6232 gfc_actual_arglist
*arg
;
6235 if (expr
->ts
.u
.cl
->length
6236 && gfc_is_constant_expr (expr
->ts
.u
.cl
->length
))
6238 if (!expr
->ts
.u
.cl
->backend_decl
)
6239 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6243 switch (expr
->expr_type
)
6246 get_array_charlen (expr
->value
.op
.op1
, se
);
6248 /* For parentheses the expression ts.u.cl is identical. */
6249 if (expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
6252 expr
->ts
.u
.cl
->backend_decl
=
6253 gfc_create_var (gfc_charlen_type_node
, "sln");
6255 if (expr
->value
.op
.op2
)
6257 get_array_charlen (expr
->value
.op
.op2
, se
);
6259 gcc_assert (expr
->value
.op
.op
== INTRINSIC_CONCAT
);
6261 /* Add the string lengths and assign them to the expression
6262 string length backend declaration. */
6263 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
6264 fold_build2_loc (input_location
, PLUS_EXPR
,
6265 gfc_charlen_type_node
,
6266 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
,
6267 expr
->value
.op
.op2
->ts
.u
.cl
->backend_decl
));
6270 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
6271 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
);
6275 if (expr
->value
.function
.esym
== NULL
6276 || expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6278 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6282 /* Map expressions involving the dummy arguments onto the actual
6283 argument expressions. */
6284 gfc_init_interface_mapping (&mapping
);
6285 formal
= gfc_sym_get_dummy_args (expr
->symtree
->n
.sym
);
6286 arg
= expr
->value
.function
.actual
;
6288 /* Set se = NULL in the calls to the interface mapping, to suppress any
6290 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
6295 gfc_add_interface_mapping (&mapping
, formal
->sym
, NULL
, arg
->expr
);
6298 gfc_init_se (&tse
, NULL
);
6300 /* Build the expression for the character length and convert it. */
6301 gfc_apply_interface_mapping (&mapping
, &tse
, expr
->ts
.u
.cl
->length
);
6303 gfc_add_block_to_block (&se
->pre
, &tse
.pre
);
6304 gfc_add_block_to_block (&se
->post
, &tse
.post
);
6305 tse
.expr
= fold_convert (gfc_charlen_type_node
, tse
.expr
);
6306 tse
.expr
= fold_build2_loc (input_location
, MAX_EXPR
,
6307 gfc_charlen_type_node
, tse
.expr
,
6308 build_int_cst (gfc_charlen_type_node
, 0));
6309 expr
->ts
.u
.cl
->backend_decl
= tse
.expr
;
6310 gfc_free_interface_mapping (&mapping
);
6314 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6320 /* Helper function to check dimensions. */
6322 transposed_dims (gfc_ss
*ss
)
6326 for (n
= 0; n
< ss
->dimen
; n
++)
6327 if (ss
->dim
[n
] != n
)
6333 /* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
6334 AR_FULL, suitable for the scalarizer. */
6337 walk_coarray (gfc_expr
*e
)
6341 gcc_assert (gfc_get_corank (e
) > 0);
6343 ss
= gfc_walk_expr (e
);
6345 /* Fix scalar coarray. */
6346 if (ss
== gfc_ss_terminator
)
6353 if (ref
->type
== REF_ARRAY
6354 && ref
->u
.ar
.codimen
> 0)
6360 gcc_assert (ref
!= NULL
);
6361 if (ref
->u
.ar
.type
== AR_ELEMENT
)
6362 ref
->u
.ar
.type
= AR_SECTION
;
6363 ss
= gfc_reverse_ss (gfc_walk_array_ref (ss
, e
, ref
));
6370 /* Convert an array for passing as an actual argument. Expressions and
6371 vector subscripts are evaluated and stored in a temporary, which is then
6372 passed. For whole arrays the descriptor is passed. For array sections
6373 a modified copy of the descriptor is passed, but using the original data.
6375 This function is also used for array pointer assignments, and there
6378 - se->want_pointer && !se->direct_byref
6379 EXPR is an actual argument. On exit, se->expr contains a
6380 pointer to the array descriptor.
6382 - !se->want_pointer && !se->direct_byref
6383 EXPR is an actual argument to an intrinsic function or the
6384 left-hand side of a pointer assignment. On exit, se->expr
6385 contains the descriptor for EXPR.
6387 - !se->want_pointer && se->direct_byref
6388 EXPR is the right-hand side of a pointer assignment and
6389 se->expr is the descriptor for the previously-evaluated
6390 left-hand side. The function creates an assignment from
6394 The se->force_tmp flag disables the non-copying descriptor optimization
6395 that is used for transpose. It may be used in cases where there is an
6396 alias between the transpose argument and another argument in the same
6400 gfc_conv_expr_descriptor (gfc_se
*se
, gfc_expr
*expr
)
6403 gfc_ss_type ss_type
;
6404 gfc_ss_info
*ss_info
;
6406 gfc_array_info
*info
;
6415 bool subref_array_target
= false;
6416 gfc_expr
*arg
, *ss_expr
;
6418 if (se
->want_coarray
)
6419 ss
= walk_coarray (expr
);
6421 ss
= gfc_walk_expr (expr
);
6423 gcc_assert (ss
!= NULL
);
6424 gcc_assert (ss
!= gfc_ss_terminator
);
6427 ss_type
= ss_info
->type
;
6428 ss_expr
= ss_info
->expr
;
6430 /* Special case: TRANSPOSE which needs no temporary. */
6431 while (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
6432 && NULL
!= (arg
= gfc_get_noncopying_intrinsic_argument (expr
)))
6434 /* This is a call to transpose which has already been handled by the
6435 scalarizer, so that we just need to get its argument's descriptor. */
6436 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
6437 expr
= expr
->value
.function
.actual
->expr
;
6440 /* Special case things we know we can pass easily. */
6441 switch (expr
->expr_type
)
6444 /* If we have a linear array section, we can pass it directly.
6445 Otherwise we need to copy it into a temporary. */
6447 gcc_assert (ss_type
== GFC_SS_SECTION
);
6448 gcc_assert (ss_expr
== expr
);
6449 info
= &ss_info
->data
.array
;
6451 /* Get the descriptor for the array. */
6452 gfc_conv_ss_descriptor (&se
->pre
, ss
, 0);
6453 desc
= info
->descriptor
;
6455 subref_array_target
= se
->direct_byref
&& is_subref_array (expr
);
6456 need_tmp
= gfc_ref_needs_temporary_p (expr
->ref
)
6457 && !subref_array_target
;
6464 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
6466 /* Create a new descriptor if the array doesn't have one. */
6469 else if (info
->ref
->u
.ar
.type
== AR_FULL
|| se
->descriptor_only
)
6471 else if (se
->direct_byref
)
6474 full
= gfc_full_array_ref_p (info
->ref
, NULL
);
6476 if (full
&& !transposed_dims (ss
))
6478 if (se
->direct_byref
&& !se
->byref_noassign
)
6480 /* Copy the descriptor for pointer assignments. */
6481 gfc_add_modify (&se
->pre
, se
->expr
, desc
);
6483 /* Add any offsets from subreferences. */
6484 gfc_get_dataptr_offset (&se
->pre
, se
->expr
, desc
, NULL_TREE
,
6485 subref_array_target
, expr
);
6487 else if (se
->want_pointer
)
6489 /* We pass full arrays directly. This means that pointers and
6490 allocatable arrays should also work. */
6491 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
6498 if (expr
->ts
.type
== BT_CHARACTER
)
6499 se
->string_length
= gfc_get_expr_charlen (expr
);
6501 gfc_free_ss_chain (ss
);
6507 /* A transformational function return value will be a temporary
6508 array descriptor. We still need to go through the scalarizer
6509 to create the descriptor. Elemental functions are handled as
6510 arbitrary expressions, i.e. copy to a temporary. */
6512 if (se
->direct_byref
)
6514 gcc_assert (ss_type
== GFC_SS_FUNCTION
&& ss_expr
== expr
);
6516 /* For pointer assignments pass the descriptor directly. */
6520 gcc_assert (se
->ss
== ss
);
6521 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
6522 gfc_conv_expr (se
, expr
);
6523 gfc_free_ss_chain (ss
);
6527 if (ss_expr
!= expr
|| ss_type
!= GFC_SS_FUNCTION
)
6529 if (ss_expr
!= expr
)
6530 /* Elemental function. */
6531 gcc_assert ((expr
->value
.function
.esym
!= NULL
6532 && expr
->value
.function
.esym
->attr
.elemental
)
6533 || (expr
->value
.function
.isym
!= NULL
6534 && expr
->value
.function
.isym
->elemental
)
6535 || gfc_inline_intrinsic_function_p (expr
));
6537 gcc_assert (ss_type
== GFC_SS_INTRINSIC
);
6540 if (expr
->ts
.type
== BT_CHARACTER
6541 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
6542 get_array_charlen (expr
, se
);
6548 /* Transformational function. */
6549 info
= &ss_info
->data
.array
;
6555 /* Constant array constructors don't need a temporary. */
6556 if (ss_type
== GFC_SS_CONSTRUCTOR
6557 && expr
->ts
.type
!= BT_CHARACTER
6558 && gfc_constant_array_constructor_p (expr
->value
.constructor
))
6561 info
= &ss_info
->data
.array
;
6571 /* Something complicated. Copy it into a temporary. */
6577 /* If we are creating a temporary, we don't need to bother about aliases
6582 gfc_init_loopinfo (&loop
);
6584 /* Associate the SS with the loop. */
6585 gfc_add_ss_to_loop (&loop
, ss
);
6587 /* Tell the scalarizer not to bother creating loop variables, etc. */
6589 loop
.array_parameter
= 1;
6591 /* The right-hand side of a pointer assignment mustn't use a temporary. */
6592 gcc_assert (!se
->direct_byref
);
6594 /* Setup the scalarizing loops and bounds. */
6595 gfc_conv_ss_startstride (&loop
);
6599 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
6600 get_array_charlen (expr
, se
);
6602 /* Tell the scalarizer to make a temporary. */
6603 loop
.temp_ss
= gfc_get_temp_ss (gfc_typenode_for_spec (&expr
->ts
),
6604 ((expr
->ts
.type
== BT_CHARACTER
)
6605 ? expr
->ts
.u
.cl
->backend_decl
6609 se
->string_length
= loop
.temp_ss
->info
->string_length
;
6610 gcc_assert (loop
.temp_ss
->dimen
== loop
.dimen
);
6611 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
6614 gfc_conv_loop_setup (&loop
, & expr
->where
);
6618 /* Copy into a temporary and pass that. We don't need to copy the data
6619 back because expressions and vector subscripts must be INTENT_IN. */
6620 /* TODO: Optimize passing function return values. */
6624 /* Start the copying loops. */
6625 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
6626 gfc_mark_ss_chain_used (ss
, 1);
6627 gfc_start_scalarized_body (&loop
, &block
);
6629 /* Copy each data element. */
6630 gfc_init_se (&lse
, NULL
);
6631 gfc_copy_loopinfo_to_se (&lse
, &loop
);
6632 gfc_init_se (&rse
, NULL
);
6633 gfc_copy_loopinfo_to_se (&rse
, &loop
);
6635 lse
.ss
= loop
.temp_ss
;
6638 gfc_conv_scalarized_array_ref (&lse
, NULL
);
6639 if (expr
->ts
.type
== BT_CHARACTER
)
6641 gfc_conv_expr (&rse
, expr
);
6642 if (POINTER_TYPE_P (TREE_TYPE (rse
.expr
)))
6643 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
6647 gfc_conv_expr_val (&rse
, expr
);
6649 gfc_add_block_to_block (&block
, &rse
.pre
);
6650 gfc_add_block_to_block (&block
, &lse
.pre
);
6652 lse
.string_length
= rse
.string_length
;
6653 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true,
6654 expr
->expr_type
== EXPR_VARIABLE
6655 || expr
->expr_type
== EXPR_ARRAY
, true);
6656 gfc_add_expr_to_block (&block
, tmp
);
6658 /* Finish the copying loops. */
6659 gfc_trans_scalarizing_loops (&loop
, &block
);
6661 desc
= loop
.temp_ss
->info
->data
.array
.descriptor
;
6663 else if (expr
->expr_type
== EXPR_FUNCTION
&& !transposed_dims (ss
))
6665 desc
= info
->descriptor
;
6666 se
->string_length
= ss_info
->string_length
;
6670 /* We pass sections without copying to a temporary. Make a new
6671 descriptor and point it at the section we want. The loop variable
6672 limits will be the limits of the section.
6673 A function may decide to repack the array to speed up access, but
6674 we're not bothered about that here. */
6675 int dim
, ndim
, codim
;
6683 ndim
= info
->ref
? info
->ref
->u
.ar
.dimen
: ss
->dimen
;
6685 if (se
->want_coarray
)
6687 gfc_array_ref
*ar
= &info
->ref
->u
.ar
;
6689 codim
= gfc_get_corank (expr
);
6690 for (n
= 0; n
< codim
- 1; n
++)
6692 /* Make sure we are not lost somehow. */
6693 gcc_assert (ar
->dimen_type
[n
+ ndim
] == DIMEN_THIS_IMAGE
);
6695 /* Make sure the call to gfc_conv_section_startstride won't
6696 generate unnecessary code to calculate stride. */
6697 gcc_assert (ar
->stride
[n
+ ndim
] == NULL
);
6699 gfc_conv_section_startstride (&loop
, ss
, n
+ ndim
);
6700 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
6701 loop
.to
[n
+ loop
.dimen
] = info
->end
[n
+ ndim
];
6704 gcc_assert (n
== codim
- 1);
6705 evaluate_bound (&loop
.pre
, info
->start
, ar
->start
,
6706 info
->descriptor
, n
+ ndim
, true);
6707 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
6712 /* Set the string_length for a character array. */
6713 if (expr
->ts
.type
== BT_CHARACTER
)
6714 se
->string_length
= gfc_get_expr_charlen (expr
);
6716 desc
= info
->descriptor
;
6717 if (se
->direct_byref
&& !se
->byref_noassign
)
6719 /* For pointer assignments we fill in the destination. */
6721 parmtype
= TREE_TYPE (parm
);
6725 /* Otherwise make a new one. */
6726 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
6727 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
, codim
,
6728 loop
.from
, loop
.to
, 0,
6729 GFC_ARRAY_UNKNOWN
, false);
6730 parm
= gfc_create_var (parmtype
, "parm");
6733 offset
= gfc_index_zero_node
;
6735 /* The following can be somewhat confusing. We have two
6736 descriptors, a new one and the original array.
6737 {parm, parmtype, dim} refer to the new one.
6738 {desc, type, n, loop} refer to the original, which maybe
6739 a descriptorless array.
6740 The bounds of the scalarization are the bounds of the section.
6741 We don't have to worry about numeric overflows when calculating
6742 the offsets because all elements are within the array data. */
6744 /* Set the dtype. */
6745 tmp
= gfc_conv_descriptor_dtype (parm
);
6746 gfc_add_modify (&loop
.pre
, tmp
, gfc_get_dtype (parmtype
));
6748 /* Set offset for assignments to pointer only to zero if it is not
6750 if (se
->direct_byref
6751 && info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
6752 base
= gfc_index_zero_node
;
6753 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
6754 base
= gfc_evaluate_now (gfc_conv_array_offset (desc
), &loop
.pre
);
6758 for (n
= 0; n
< ndim
; n
++)
6760 stride
= gfc_conv_array_stride (desc
, n
);
6762 /* Work out the offset. */
6764 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
6766 gcc_assert (info
->subscript
[n
]
6767 && info
->subscript
[n
]->info
->type
== GFC_SS_SCALAR
);
6768 start
= info
->subscript
[n
]->info
->data
.scalar
.value
;
6772 /* Evaluate and remember the start of the section. */
6773 start
= info
->start
[n
];
6774 stride
= gfc_evaluate_now (stride
, &loop
.pre
);
6777 tmp
= gfc_conv_array_lbound (desc
, n
);
6778 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
6780 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
6782 offset
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (tmp
),
6786 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
6788 /* For elemental dimensions, we only need the offset. */
6792 /* Vector subscripts need copying and are handled elsewhere. */
6794 gcc_assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
6796 /* look for the corresponding scalarizer dimension: dim. */
6797 for (dim
= 0; dim
< ndim
; dim
++)
6798 if (ss
->dim
[dim
] == n
)
6801 /* loop exited early: the DIM being looked for has been found. */
6802 gcc_assert (dim
< ndim
);
6804 /* Set the new lower bound. */
6805 from
= loop
.from
[dim
];
6808 /* If we have an array section or are assigning make sure that
6809 the lower bound is 1. References to the full
6810 array should otherwise keep the original bounds. */
6812 || info
->ref
->u
.ar
.type
!= AR_FULL
)
6813 && !integer_onep (from
))
6815 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6816 gfc_array_index_type
, gfc_index_one_node
,
6818 to
= fold_build2_loc (input_location
, PLUS_EXPR
,
6819 gfc_array_index_type
, to
, tmp
);
6820 from
= gfc_index_one_node
;
6822 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
6823 gfc_rank_cst
[dim
], from
);
6825 /* Set the new upper bound. */
6826 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
6827 gfc_rank_cst
[dim
], to
);
6829 /* Multiply the stride by the section stride to get the
6831 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
6832 gfc_array_index_type
,
6833 stride
, info
->stride
[n
]);
6835 if (se
->direct_byref
6837 && info
->ref
->u
.ar
.type
!= AR_FULL
)
6839 base
= fold_build2_loc (input_location
, MINUS_EXPR
,
6840 TREE_TYPE (base
), base
, stride
);
6842 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
6844 tmp
= gfc_conv_array_lbound (desc
, n
);
6845 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6846 TREE_TYPE (base
), tmp
, loop
.from
[dim
]);
6847 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6848 TREE_TYPE (base
), tmp
,
6849 gfc_conv_array_stride (desc
, n
));
6850 base
= fold_build2_loc (input_location
, PLUS_EXPR
,
6851 TREE_TYPE (base
), tmp
, base
);
6854 /* Store the new stride. */
6855 gfc_conv_descriptor_stride_set (&loop
.pre
, parm
,
6856 gfc_rank_cst
[dim
], stride
);
6859 for (n
= loop
.dimen
; n
< loop
.dimen
+ codim
; n
++)
6861 from
= loop
.from
[n
];
6863 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
6864 gfc_rank_cst
[n
], from
);
6865 if (n
< loop
.dimen
+ codim
- 1)
6866 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
6867 gfc_rank_cst
[n
], to
);
6870 if (se
->data_not_needed
)
6871 gfc_conv_descriptor_data_set (&loop
.pre
, parm
,
6872 gfc_index_zero_node
);
6874 /* Point the data pointer at the 1st element in the section. */
6875 gfc_get_dataptr_offset (&loop
.pre
, parm
, desc
, offset
,
6876 subref_array_target
, expr
);
6878 if ((se
->direct_byref
|| GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
6879 && !se
->data_not_needed
)
6881 /* Set the offset. */
6882 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, base
);
6886 /* Only the callee knows what the correct offset it, so just set
6888 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, gfc_index_zero_node
);
6893 if (!se
->direct_byref
|| se
->byref_noassign
)
6895 /* Get a pointer to the new descriptor. */
6896 if (se
->want_pointer
)
6897 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
6902 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
6903 gfc_add_block_to_block (&se
->post
, &loop
.post
);
6905 /* Cleanup the scalarizer. */
6906 gfc_cleanup_loop (&loop
);
6909 /* Helper function for gfc_conv_array_parameter if array size needs to be
6913 array_parameter_size (tree desc
, gfc_expr
*expr
, tree
*size
)
6916 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
6917 *size
= GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc
));
6918 else if (expr
->rank
> 1)
6919 *size
= build_call_expr_loc (input_location
,
6920 gfor_fndecl_size0
, 1,
6921 gfc_build_addr_expr (NULL
, desc
));
6924 tree ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_index_zero_node
);
6925 tree lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_index_zero_node
);
6927 *size
= fold_build2_loc (input_location
, MINUS_EXPR
,
6928 gfc_array_index_type
, ubound
, lbound
);
6929 *size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
6930 *size
, gfc_index_one_node
);
6931 *size
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
6932 *size
, gfc_index_zero_node
);
6934 elem
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
6935 *size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6936 *size
, fold_convert (gfc_array_index_type
, elem
));
6939 /* Convert an array for passing as an actual parameter. */
6940 /* TODO: Optimize passing g77 arrays. */
6943 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, bool g77
,
6944 const gfc_symbol
*fsym
, const char *proc_name
,
6949 tree tmp
= NULL_TREE
;
6951 tree parent
= DECL_CONTEXT (current_function_decl
);
6952 bool full_array_var
;
6953 bool this_array_result
;
6956 bool array_constructor
;
6957 bool good_allocatable
;
6958 bool ultimate_ptr_comp
;
6959 bool ultimate_alloc_comp
;
6964 ultimate_ptr_comp
= false;
6965 ultimate_alloc_comp
= false;
6967 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6969 if (ref
->next
== NULL
)
6972 if (ref
->type
== REF_COMPONENT
)
6974 ultimate_ptr_comp
= ref
->u
.c
.component
->attr
.pointer
;
6975 ultimate_alloc_comp
= ref
->u
.c
.component
->attr
.allocatable
;
6979 full_array_var
= false;
6982 if (expr
->expr_type
== EXPR_VARIABLE
&& ref
&& !ultimate_ptr_comp
)
6983 full_array_var
= gfc_full_array_ref_p (ref
, &contiguous
);
6985 sym
= full_array_var
? expr
->symtree
->n
.sym
: NULL
;
6987 /* The symbol should have an array specification. */
6988 gcc_assert (!sym
|| sym
->as
|| ref
->u
.ar
.as
);
6990 if (expr
->expr_type
== EXPR_ARRAY
&& expr
->ts
.type
== BT_CHARACTER
)
6992 get_array_ctor_strlen (&se
->pre
, expr
->value
.constructor
, &tmp
);
6993 expr
->ts
.u
.cl
->backend_decl
= tmp
;
6994 se
->string_length
= tmp
;
6997 /* Is this the result of the enclosing procedure? */
6998 this_array_result
= (full_array_var
&& sym
->attr
.flavor
== FL_PROCEDURE
);
6999 if (this_array_result
7000 && (sym
->backend_decl
!= current_function_decl
)
7001 && (sym
->backend_decl
!= parent
))
7002 this_array_result
= false;
7004 /* Passing address of the array if it is not pointer or assumed-shape. */
7005 if (full_array_var
&& g77
&& !this_array_result
7006 && sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
7008 tmp
= gfc_get_symbol_decl (sym
);
7010 if (sym
->ts
.type
== BT_CHARACTER
)
7011 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
7013 if (!sym
->attr
.pointer
7015 && sym
->as
->type
!= AS_ASSUMED_SHAPE
7016 && sym
->as
->type
!= AS_DEFERRED
7017 && sym
->as
->type
!= AS_ASSUMED_RANK
7018 && !sym
->attr
.allocatable
)
7020 /* Some variables are declared directly, others are declared as
7021 pointers and allocated on the heap. */
7022 if (sym
->attr
.dummy
|| POINTER_TYPE_P (TREE_TYPE (tmp
)))
7025 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
7027 array_parameter_size (tmp
, expr
, size
);
7031 if (sym
->attr
.allocatable
)
7033 if (sym
->attr
.dummy
|| sym
->attr
.result
)
7035 gfc_conv_expr_descriptor (se
, expr
);
7039 array_parameter_size (tmp
, expr
, size
);
7040 se
->expr
= gfc_conv_array_data (tmp
);
7045 /* A convenient reduction in scope. */
7046 contiguous
= g77
&& !this_array_result
&& contiguous
;
7048 /* There is no need to pack and unpack the array, if it is contiguous
7049 and not a deferred- or assumed-shape array, or if it is simply
7051 no_pack
= ((sym
&& sym
->as
7052 && !sym
->attr
.pointer
7053 && sym
->as
->type
!= AS_DEFERRED
7054 && sym
->as
->type
!= AS_ASSUMED_RANK
7055 && sym
->as
->type
!= AS_ASSUMED_SHAPE
)
7057 (ref
&& ref
->u
.ar
.as
7058 && ref
->u
.ar
.as
->type
!= AS_DEFERRED
7059 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_RANK
7060 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_SHAPE
)
7062 gfc_is_simply_contiguous (expr
, false));
7064 no_pack
= contiguous
&& no_pack
;
7066 /* Array constructors are always contiguous and do not need packing. */
7067 array_constructor
= g77
&& !this_array_result
&& expr
->expr_type
== EXPR_ARRAY
;
7069 /* Same is true of contiguous sections from allocatable variables. */
7070 good_allocatable
= contiguous
7072 && expr
->symtree
->n
.sym
->attr
.allocatable
;
7074 /* Or ultimate allocatable components. */
7075 ultimate_alloc_comp
= contiguous
&& ultimate_alloc_comp
;
7077 if (no_pack
|| array_constructor
|| good_allocatable
|| ultimate_alloc_comp
)
7079 gfc_conv_expr_descriptor (se
, expr
);
7080 if (expr
->ts
.type
== BT_CHARACTER
)
7081 se
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
7083 array_parameter_size (se
->expr
, expr
, size
);
7084 se
->expr
= gfc_conv_array_data (se
->expr
);
7088 if (this_array_result
)
7090 /* Result of the enclosing function. */
7091 gfc_conv_expr_descriptor (se
, expr
);
7093 array_parameter_size (se
->expr
, expr
, size
);
7094 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7096 if (g77
&& TREE_TYPE (TREE_TYPE (se
->expr
)) != NULL_TREE
7097 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
7098 se
->expr
= gfc_conv_array_data (build_fold_indirect_ref_loc (input_location
,
7105 /* Every other type of array. */
7106 se
->want_pointer
= 1;
7107 gfc_conv_expr_descriptor (se
, expr
);
7109 array_parameter_size (build_fold_indirect_ref_loc (input_location
,
7114 /* Deallocate the allocatable components of structures that are
7116 if ((expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
)
7117 && expr
->ts
.u
.derived
->attr
.alloc_comp
7118 && expr
->expr_type
!= EXPR_VARIABLE
)
7120 tmp
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7121 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
, expr
->rank
);
7123 /* The components shall be deallocated before their containing entity. */
7124 gfc_prepend_expr_to_block (&se
->post
, tmp
);
7127 if (g77
|| (fsym
&& fsym
->attr
.contiguous
7128 && !gfc_is_simply_contiguous (expr
, false)))
7130 tree origptr
= NULL_TREE
;
7134 /* For contiguous arrays, save the original value of the descriptor. */
7137 origptr
= gfc_create_var (pvoid_type_node
, "origptr");
7138 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7139 tmp
= gfc_conv_array_data (tmp
);
7140 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7141 TREE_TYPE (origptr
), origptr
,
7142 fold_convert (TREE_TYPE (origptr
), tmp
));
7143 gfc_add_expr_to_block (&se
->pre
, tmp
);
7146 /* Repack the array. */
7147 if (gfc_option
.warn_array_temp
)
7150 gfc_warning ("Creating array temporary at %L for argument '%s'",
7151 &expr
->where
, fsym
->name
);
7153 gfc_warning ("Creating array temporary at %L", &expr
->where
);
7156 ptr
= build_call_expr_loc (input_location
,
7157 gfor_fndecl_in_pack
, 1, desc
);
7159 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7161 tmp
= gfc_conv_expr_present (sym
);
7162 ptr
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
7163 tmp
, fold_convert (TREE_TYPE (se
->expr
), ptr
),
7164 fold_convert (TREE_TYPE (se
->expr
), null_pointer_node
));
7167 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
7169 /* Use the packed data for the actual argument, except for contiguous arrays,
7170 where the descriptor's data component is set. */
7175 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7176 gfc_conv_descriptor_data_set (&se
->pre
, tmp
, ptr
);
7179 if (gfc_option
.rtcheck
& GFC_RTCHECK_ARRAY_TEMPS
)
7183 if (fsym
&& proc_name
)
7184 asprintf (&msg
, "An array temporary was created for argument "
7185 "'%s' of procedure '%s'", fsym
->name
, proc_name
);
7187 asprintf (&msg
, "An array temporary was created");
7189 tmp
= build_fold_indirect_ref_loc (input_location
,
7191 tmp
= gfc_conv_array_data (tmp
);
7192 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7193 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
7195 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7196 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7198 gfc_conv_expr_present (sym
), tmp
);
7200 gfc_trans_runtime_check (false, true, tmp
, &se
->pre
,
7205 gfc_start_block (&block
);
7207 /* Copy the data back. */
7208 if (fsym
== NULL
|| fsym
->attr
.intent
!= INTENT_IN
)
7210 tmp
= build_call_expr_loc (input_location
,
7211 gfor_fndecl_in_unpack
, 2, desc
, ptr
);
7212 gfc_add_expr_to_block (&block
, tmp
);
7215 /* Free the temporary. */
7216 tmp
= gfc_call_free (convert (pvoid_type_node
, ptr
));
7217 gfc_add_expr_to_block (&block
, tmp
);
7219 stmt
= gfc_finish_block (&block
);
7221 gfc_init_block (&block
);
7222 /* Only if it was repacked. This code needs to be executed before the
7223 loop cleanup code. */
7224 tmp
= build_fold_indirect_ref_loc (input_location
,
7226 tmp
= gfc_conv_array_data (tmp
);
7227 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7228 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
7230 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7231 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7233 gfc_conv_expr_present (sym
), tmp
);
7235 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
7237 gfc_add_expr_to_block (&block
, tmp
);
7238 gfc_add_block_to_block (&block
, &se
->post
);
7240 gfc_init_block (&se
->post
);
7242 /* Reset the descriptor pointer. */
7245 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7246 gfc_conv_descriptor_data_set (&se
->post
, tmp
, origptr
);
7249 gfc_add_block_to_block (&se
->post
, &block
);
7254 /* Generate code to deallocate an array, if it is allocated. */
7257 gfc_trans_dealloc_allocated (tree descriptor
, bool coarray
)
7263 gfc_start_block (&block
);
7265 var
= gfc_conv_descriptor_data_get (descriptor
);
7268 /* Call array_deallocate with an int * present in the second argument.
7269 Although it is ignored here, it's presence ensures that arrays that
7270 are already deallocated are ignored. */
7271 tmp
= gfc_deallocate_with_status (coarray
? descriptor
: var
, NULL_TREE
,
7272 NULL_TREE
, NULL_TREE
, NULL_TREE
, true,
7274 gfc_add_expr_to_block (&block
, tmp
);
7276 /* Zero the data pointer. */
7277 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
7278 var
, build_int_cst (TREE_TYPE (var
), 0));
7279 gfc_add_expr_to_block (&block
, tmp
);
7281 return gfc_finish_block (&block
);
7285 /* This helper function calculates the size in words of a full array. */
7288 get_full_array_size (stmtblock_t
*block
, tree decl
, int rank
)
7293 idx
= gfc_rank_cst
[rank
- 1];
7294 nelems
= gfc_conv_descriptor_ubound_get (decl
, idx
);
7295 tmp
= gfc_conv_descriptor_lbound_get (decl
, idx
);
7296 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7298 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7299 tmp
, gfc_index_one_node
);
7300 tmp
= gfc_evaluate_now (tmp
, block
);
7302 nelems
= gfc_conv_descriptor_stride_get (decl
, idx
);
7303 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7305 return gfc_evaluate_now (tmp
, block
);
7309 /* Allocate dest to the same size as src, and copy src -> dest.
7310 If no_malloc is set, only the copy is done. */
7313 duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
7323 /* If the source is null, set the destination to null. Then,
7324 allocate memory to the destination. */
7325 gfc_init_block (&block
);
7329 tmp
= null_pointer_node
;
7330 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, type
, dest
, tmp
);
7331 gfc_add_expr_to_block (&block
, tmp
);
7332 null_data
= gfc_finish_block (&block
);
7334 gfc_init_block (&block
);
7335 size
= TYPE_SIZE_UNIT (TREE_TYPE (type
));
7338 tmp
= gfc_call_malloc (&block
, type
, size
);
7339 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
7340 dest
, fold_convert (type
, tmp
));
7341 gfc_add_expr_to_block (&block
, tmp
);
7344 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
7345 tmp
= build_call_expr_loc (input_location
, tmp
, 3, dest
, src
,
7346 fold_convert (size_type_node
, size
));
7350 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
7351 null_data
= gfc_finish_block (&block
);
7353 gfc_init_block (&block
);
7354 nelems
= get_full_array_size (&block
, src
, rank
);
7355 tmp
= fold_convert (gfc_array_index_type
,
7356 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
7357 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7361 tmp
= TREE_TYPE (gfc_conv_descriptor_data_get (src
));
7362 tmp
= gfc_call_malloc (&block
, tmp
, size
);
7363 gfc_conv_descriptor_data_set (&block
, dest
, tmp
);
7366 /* We know the temporary and the value will be the same length,
7367 so can use memcpy. */
7368 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
7369 tmp
= build_call_expr_loc (input_location
,
7370 tmp
, 3, gfc_conv_descriptor_data_get (dest
),
7371 gfc_conv_descriptor_data_get (src
),
7372 fold_convert (size_type_node
, size
));
7375 gfc_add_expr_to_block (&block
, tmp
);
7376 tmp
= gfc_finish_block (&block
);
7378 /* Null the destination if the source is null; otherwise do
7379 the allocate and copy. */
7383 null_cond
= gfc_conv_descriptor_data_get (src
);
7385 null_cond
= convert (pvoid_type_node
, null_cond
);
7386 null_cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7387 null_cond
, null_pointer_node
);
7388 return build3_v (COND_EXPR
, null_cond
, tmp
, null_data
);
7392 /* Allocate dest to the same size as src, and copy data src -> dest. */
7395 gfc_duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
)
7397 return duplicate_allocatable (dest
, src
, type
, rank
, false);
7401 /* Copy data src -> dest. */
7404 gfc_copy_allocatable_data (tree dest
, tree src
, tree type
, int rank
)
7406 return duplicate_allocatable (dest
, src
, type
, rank
, true);
7410 /* Recursively traverse an object of derived type, generating code to
7411 deallocate, nullify or copy allocatable components. This is the work horse
7412 function for the functions named in this enum. */
7414 enum {DEALLOCATE_ALLOC_COMP
= 1, NULLIFY_ALLOC_COMP
, COPY_ALLOC_COMP
,
7415 COPY_ONLY_ALLOC_COMP
};
7418 structure_alloc_comps (gfc_symbol
* der_type
, tree decl
,
7419 tree dest
, int rank
, int purpose
)
7423 stmtblock_t fnblock
;
7424 stmtblock_t loopbody
;
7425 stmtblock_t tmpblock
;
7436 tree null_cond
= NULL_TREE
;
7437 bool called_dealloc_with_status
;
7439 gfc_init_block (&fnblock
);
7441 decl_type
= TREE_TYPE (decl
);
7443 if ((POINTER_TYPE_P (decl_type
) && rank
!= 0)
7444 || (TREE_CODE (decl_type
) == REFERENCE_TYPE
&& rank
== 0))
7445 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
7447 /* Just in case in gets dereferenced. */
7448 decl_type
= TREE_TYPE (decl
);
7450 /* If this an array of derived types with allocatable components
7451 build a loop and recursively call this function. */
7452 if (TREE_CODE (decl_type
) == ARRAY_TYPE
7453 || (GFC_DESCRIPTOR_TYPE_P (decl_type
) && rank
!= 0))
7455 tmp
= gfc_conv_array_data (decl
);
7456 var
= build_fold_indirect_ref_loc (input_location
,
7459 /* Get the number of elements - 1 and set the counter. */
7460 if (GFC_DESCRIPTOR_TYPE_P (decl_type
))
7462 /* Use the descriptor for an allocatable array. Since this
7463 is a full array reference, we only need the descriptor
7464 information from dimension = rank. */
7465 tmp
= get_full_array_size (&fnblock
, decl
, rank
);
7466 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7467 gfc_array_index_type
, tmp
,
7468 gfc_index_one_node
);
7470 null_cond
= gfc_conv_descriptor_data_get (decl
);
7471 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
7472 boolean_type_node
, null_cond
,
7473 build_int_cst (TREE_TYPE (null_cond
), 0));
7477 /* Otherwise use the TYPE_DOMAIN information. */
7478 tmp
= array_type_nelts (decl_type
);
7479 tmp
= fold_convert (gfc_array_index_type
, tmp
);
7482 /* Remember that this is, in fact, the no. of elements - 1. */
7483 nelems
= gfc_evaluate_now (tmp
, &fnblock
);
7484 index
= gfc_create_var (gfc_array_index_type
, "S");
7486 /* Build the body of the loop. */
7487 gfc_init_block (&loopbody
);
7489 vref
= gfc_build_array_ref (var
, index
, NULL
);
7491 if (purpose
== COPY_ALLOC_COMP
)
7493 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
7495 tmp
= gfc_duplicate_allocatable (dest
, decl
, decl_type
, rank
);
7496 gfc_add_expr_to_block (&fnblock
, tmp
);
7498 tmp
= build_fold_indirect_ref_loc (input_location
,
7499 gfc_conv_array_data (dest
));
7500 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
7501 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
, purpose
);
7503 else if (purpose
== COPY_ONLY_ALLOC_COMP
)
7505 tmp
= build_fold_indirect_ref_loc (input_location
,
7506 gfc_conv_array_data (dest
));
7507 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
7508 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
,
7512 tmp
= structure_alloc_comps (der_type
, vref
, NULL_TREE
, rank
, purpose
);
7514 gfc_add_expr_to_block (&loopbody
, tmp
);
7516 /* Build the loop and return. */
7517 gfc_init_loopinfo (&loop
);
7519 loop
.from
[0] = gfc_index_zero_node
;
7520 loop
.loopvar
[0] = index
;
7521 loop
.to
[0] = nelems
;
7522 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
7523 gfc_add_block_to_block (&fnblock
, &loop
.pre
);
7525 tmp
= gfc_finish_block (&fnblock
);
7526 if (null_cond
!= NULL_TREE
)
7527 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
7528 build_empty_stmt (input_location
));
7533 /* Otherwise, act on the components or recursively call self to
7534 act on a chain of components. */
7535 for (c
= der_type
->components
; c
; c
= c
->next
)
7537 bool cmp_has_alloc_comps
= (c
->ts
.type
== BT_DERIVED
7538 || c
->ts
.type
== BT_CLASS
)
7539 && c
->ts
.u
.derived
->attr
.alloc_comp
;
7540 cdecl = c
->backend_decl
;
7541 ctype
= TREE_TYPE (cdecl);
7545 case DEALLOCATE_ALLOC_COMP
:
7547 /* gfc_deallocate_scalar_with_status calls gfc_deallocate_alloc_comp
7548 (i.e. this function) so generate all the calls and suppress the
7549 recursion from here, if necessary. */
7550 called_dealloc_with_status
= false;
7551 gfc_init_block (&tmpblock
);
7553 if (c
->attr
.allocatable
7554 && (c
->attr
.dimension
|| c
->attr
.codimension
))
7556 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7557 decl
, cdecl, NULL_TREE
);
7558 tmp
= gfc_trans_dealloc_allocated (comp
, c
->attr
.codimension
);
7559 gfc_add_expr_to_block (&tmpblock
, tmp
);
7561 else if (c
->attr
.allocatable
)
7563 /* Allocatable scalar components. */
7564 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7565 decl
, cdecl, NULL_TREE
);
7567 tmp
= gfc_deallocate_scalar_with_status (comp
, NULL
, true, NULL
,
7569 gfc_add_expr_to_block (&tmpblock
, tmp
);
7570 called_dealloc_with_status
= true;
7572 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7573 void_type_node
, comp
,
7574 build_int_cst (TREE_TYPE (comp
), 0));
7575 gfc_add_expr_to_block (&tmpblock
, tmp
);
7577 else if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
7579 /* Allocatable CLASS components. */
7580 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7581 decl
, cdecl, NULL_TREE
);
7583 /* Add reference to '_data' component. */
7584 tmp
= CLASS_DATA (c
)->backend_decl
;
7585 comp
= fold_build3_loc (input_location
, COMPONENT_REF
,
7586 TREE_TYPE (tmp
), comp
, tmp
, NULL_TREE
);
7588 if (GFC_DESCRIPTOR_TYPE_P(TREE_TYPE (comp
)))
7589 tmp
= gfc_trans_dealloc_allocated (comp
,
7590 CLASS_DATA (c
)->attr
.codimension
);
7593 tmp
= gfc_deallocate_scalar_with_status (comp
, NULL_TREE
, true, NULL
,
7594 CLASS_DATA (c
)->ts
);
7595 gfc_add_expr_to_block (&tmpblock
, tmp
);
7596 called_dealloc_with_status
= true;
7598 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7599 void_type_node
, comp
,
7600 build_int_cst (TREE_TYPE (comp
), 0));
7602 gfc_add_expr_to_block (&tmpblock
, tmp
);
7605 if (cmp_has_alloc_comps
7607 && !called_dealloc_with_status
)
7609 /* Do not deallocate the components of ultimate pointer
7610 components or iteratively call self if call has been made
7611 to gfc_trans_dealloc_allocated */
7612 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7613 decl
, cdecl, NULL_TREE
);
7614 rank
= c
->as
? c
->as
->rank
: 0;
7615 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
7617 gfc_add_expr_to_block (&fnblock
, tmp
);
7620 /* Now add the deallocation of this component. */
7621 gfc_add_block_to_block (&fnblock
, &tmpblock
);
7624 case NULLIFY_ALLOC_COMP
:
7625 if (c
->attr
.pointer
)
7627 else if (c
->attr
.allocatable
7628 && (c
->attr
.dimension
|| c
->attr
.codimension
))
7630 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7631 decl
, cdecl, NULL_TREE
);
7632 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
7634 else if (c
->attr
.allocatable
)
7636 /* Allocatable scalar components. */
7637 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7638 decl
, cdecl, NULL_TREE
);
7639 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7640 void_type_node
, comp
,
7641 build_int_cst (TREE_TYPE (comp
), 0));
7642 gfc_add_expr_to_block (&fnblock
, tmp
);
7644 else if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
7646 /* Allocatable CLASS components. */
7647 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7648 decl
, cdecl, NULL_TREE
);
7649 /* Add reference to '_data' component. */
7650 tmp
= CLASS_DATA (c
)->backend_decl
;
7651 comp
= fold_build3_loc (input_location
, COMPONENT_REF
,
7652 TREE_TYPE (tmp
), comp
, tmp
, NULL_TREE
);
7653 if (GFC_DESCRIPTOR_TYPE_P(TREE_TYPE (comp
)))
7654 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
7657 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7658 void_type_node
, comp
,
7659 build_int_cst (TREE_TYPE (comp
), 0));
7660 gfc_add_expr_to_block (&fnblock
, tmp
);
7663 else if (cmp_has_alloc_comps
)
7665 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7666 decl
, cdecl, NULL_TREE
);
7667 rank
= c
->as
? c
->as
->rank
: 0;
7668 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
7670 gfc_add_expr_to_block (&fnblock
, tmp
);
7674 case COPY_ALLOC_COMP
:
7675 if (c
->attr
.pointer
)
7678 /* We need source and destination components. */
7679 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, decl
,
7681 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, dest
,
7683 dcmp
= fold_convert (TREE_TYPE (comp
), dcmp
);
7685 if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
7693 dst_data
= gfc_class_data_get (dcmp
);
7694 src_data
= gfc_class_data_get (comp
);
7695 size
= fold_convert (size_type_node
, gfc_vtable_size_get (comp
));
7697 if (CLASS_DATA (c
)->attr
.dimension
)
7699 nelems
= gfc_conv_descriptor_size (src_data
,
7700 CLASS_DATA (c
)->as
->rank
);
7701 src_data
= gfc_conv_descriptor_data_get (src_data
);
7702 dst_data
= gfc_conv_descriptor_data_get (dst_data
);
7705 nelems
= build_int_cst (size_type_node
, 1);
7707 gfc_init_block (&tmpblock
);
7709 /* We need to use CALLOC as _copy might try to free allocatable
7710 components of the destination. */
7711 ftn_tree
= builtin_decl_explicit (BUILT_IN_CALLOC
);
7712 tmp
= build_call_expr_loc (input_location
, ftn_tree
, 2, nelems
,
7714 gfc_add_modify (&tmpblock
, dst_data
,
7715 fold_convert (TREE_TYPE (dst_data
), tmp
));
7717 tmp
= gfc_copy_class_to_class (comp
, dcmp
, nelems
);
7718 gfc_add_expr_to_block (&tmpblock
, tmp
);
7719 tmp
= gfc_finish_block (&tmpblock
);
7721 gfc_init_block (&tmpblock
);
7722 gfc_add_modify (&tmpblock
, dst_data
,
7723 fold_convert (TREE_TYPE (dst_data
),
7724 null_pointer_node
));
7725 null_data
= gfc_finish_block (&tmpblock
);
7727 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
7728 boolean_type_node
, src_data
,
7731 gfc_add_expr_to_block (&fnblock
, build3_v (COND_EXPR
, null_cond
,
7736 if (c
->attr
.allocatable
&& !cmp_has_alloc_comps
)
7738 rank
= c
->as
? c
->as
->rank
: 0;
7739 tmp
= gfc_duplicate_allocatable (dcmp
, comp
, ctype
, rank
);
7740 gfc_add_expr_to_block (&fnblock
, tmp
);
7743 if (cmp_has_alloc_comps
)
7745 rank
= c
->as
? c
->as
->rank
: 0;
7746 tmp
= fold_convert (TREE_TYPE (dcmp
), comp
);
7747 gfc_add_modify (&fnblock
, dcmp
, tmp
);
7748 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, dcmp
,
7750 gfc_add_expr_to_block (&fnblock
, tmp
);
7760 return gfc_finish_block (&fnblock
);
7763 /* Recursively traverse an object of derived type, generating code to
7764 nullify allocatable components. */
7767 gfc_nullify_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
7769 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
7770 NULLIFY_ALLOC_COMP
);
7774 /* Recursively traverse an object of derived type, generating code to
7775 deallocate allocatable components. */
7778 gfc_deallocate_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
7780 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
7781 DEALLOCATE_ALLOC_COMP
);
7785 /* Recursively traverse an object of derived type, generating code to
7786 copy it and its allocatable components. */
7789 gfc_copy_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
7791 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ALLOC_COMP
);
7795 /* Recursively traverse an object of derived type, generating code to
7796 copy only its allocatable components. */
7799 gfc_copy_only_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
7801 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ONLY_ALLOC_COMP
);
7805 /* Returns the value of LBOUND for an expression. This could be broken out
7806 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
7807 called by gfc_alloc_allocatable_for_assignment. */
7809 get_std_lbound (gfc_expr
*expr
, tree desc
, int dim
, bool assumed_size
)
7814 tree cond
, cond1
, cond3
, cond4
;
7818 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
7820 tmp
= gfc_rank_cst
[dim
];
7821 lbound
= gfc_conv_descriptor_lbound_get (desc
, tmp
);
7822 ubound
= gfc_conv_descriptor_ubound_get (desc
, tmp
);
7823 stride
= gfc_conv_descriptor_stride_get (desc
, tmp
);
7824 cond1
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
7826 cond3
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
7827 stride
, gfc_index_zero_node
);
7828 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7829 boolean_type_node
, cond3
, cond1
);
7830 cond4
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
7831 stride
, gfc_index_zero_node
);
7833 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
7834 tmp
, build_int_cst (gfc_array_index_type
,
7837 cond
= boolean_false_node
;
7839 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
7840 boolean_type_node
, cond3
, cond4
);
7841 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
7842 boolean_type_node
, cond
, cond1
);
7844 return fold_build3_loc (input_location
, COND_EXPR
,
7845 gfc_array_index_type
, cond
,
7846 lbound
, gfc_index_one_node
);
7849 if (expr
->expr_type
== EXPR_FUNCTION
)
7851 /* A conversion function, so use the argument. */
7852 gcc_assert (expr
->value
.function
.isym
7853 && expr
->value
.function
.isym
->conversion
);
7854 expr
= expr
->value
.function
.actual
->expr
;
7857 if (expr
->expr_type
== EXPR_VARIABLE
)
7859 tmp
= TREE_TYPE (expr
->symtree
->n
.sym
->backend_decl
);
7860 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7862 if (ref
->type
== REF_COMPONENT
7863 && ref
->u
.c
.component
->as
7865 && ref
->next
->u
.ar
.type
== AR_FULL
)
7866 tmp
= TREE_TYPE (ref
->u
.c
.component
->backend_decl
);
7868 return GFC_TYPE_ARRAY_LBOUND(tmp
, dim
);
7871 return gfc_index_one_node
;
7875 /* Returns true if an expression represents an lhs that can be reallocated
7879 gfc_is_reallocatable_lhs (gfc_expr
*expr
)
7886 /* An allocatable variable. */
7887 if (expr
->symtree
->n
.sym
->attr
.allocatable
7889 && expr
->ref
->type
== REF_ARRAY
7890 && expr
->ref
->u
.ar
.type
== AR_FULL
)
7893 /* All that can be left are allocatable components. */
7894 if ((expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
7895 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
7896 || !expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
7899 /* Find a component ref followed by an array reference. */
7900 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7902 && ref
->type
== REF_COMPONENT
7903 && ref
->next
->type
== REF_ARRAY
7904 && !ref
->next
->next
)
7910 /* Return true if valid reallocatable lhs. */
7911 if (ref
->u
.c
.component
->attr
.allocatable
7912 && ref
->next
->u
.ar
.type
== AR_FULL
)
7919 /* Allocate the lhs of an assignment to an allocatable array, otherwise
7923 gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop
,
7927 stmtblock_t realloc_block
;
7928 stmtblock_t alloc_block
;
7932 gfc_array_info
*linfo
;
7952 gfc_array_spec
* as
;
7954 /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
7955 Find the lhs expression in the loop chain and set expr1 and
7956 expr2 accordingly. */
7957 if (expr1
->expr_type
== EXPR_FUNCTION
&& expr2
== NULL
)
7960 /* Find the ss for the lhs. */
7962 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
7963 if (lss
->info
->expr
&& lss
->info
->expr
->expr_type
== EXPR_VARIABLE
)
7965 if (lss
== gfc_ss_terminator
)
7967 expr1
= lss
->info
->expr
;
7970 /* Bail out if this is not a valid allocate on assignment. */
7971 if (!gfc_is_reallocatable_lhs (expr1
)
7972 || (expr2
&& !expr2
->rank
))
7975 /* Find the ss for the lhs. */
7977 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
7978 if (lss
->info
->expr
== expr1
)
7981 if (lss
== gfc_ss_terminator
)
7984 linfo
= &lss
->info
->data
.array
;
7986 /* Find an ss for the rhs. For operator expressions, we see the
7987 ss's for the operands. Any one of these will do. */
7989 for (; rss
&& rss
!= gfc_ss_terminator
; rss
= rss
->loop_chain
)
7990 if (rss
->info
->expr
!= expr1
&& rss
!= loop
->temp_ss
)
7993 if (expr2
&& rss
== gfc_ss_terminator
)
7996 gfc_start_block (&fblock
);
7998 /* Since the lhs is allocatable, this must be a descriptor type.
7999 Get the data and array size. */
8000 desc
= linfo
->descriptor
;
8001 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)));
8002 array1
= gfc_conv_descriptor_data_get (desc
);
8004 /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
8005 deallocated if expr is an array of different shape or any of the
8006 corresponding length type parameter values of variable and expr
8007 differ." This assures F95 compatibility. */
8008 jump_label1
= gfc_build_label_decl (NULL_TREE
);
8009 jump_label2
= gfc_build_label_decl (NULL_TREE
);
8011 /* Allocate if data is NULL. */
8012 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
8013 array1
, build_int_cst (TREE_TYPE (array1
), 0));
8014 tmp
= build3_v (COND_EXPR
, cond
,
8015 build1_v (GOTO_EXPR
, jump_label1
),
8016 build_empty_stmt (input_location
));
8017 gfc_add_expr_to_block (&fblock
, tmp
);
8019 /* Get arrayspec if expr is a full array. */
8020 if (expr2
&& expr2
->expr_type
== EXPR_FUNCTION
8021 && expr2
->value
.function
.isym
8022 && expr2
->value
.function
.isym
->conversion
)
8024 /* For conversion functions, take the arg. */
8025 gfc_expr
*arg
= expr2
->value
.function
.actual
->expr
;
8026 as
= gfc_get_full_arrayspec_from_expr (arg
);
8029 as
= gfc_get_full_arrayspec_from_expr (expr2
);
8033 /* If the lhs shape is not the same as the rhs jump to setting the
8034 bounds and doing the reallocation....... */
8035 for (n
= 0; n
< expr1
->rank
; n
++)
8037 /* Check the shape. */
8038 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
8039 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
8040 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8041 gfc_array_index_type
,
8042 loop
->to
[n
], loop
->from
[n
]);
8043 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8044 gfc_array_index_type
,
8046 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8047 gfc_array_index_type
,
8049 cond
= fold_build2_loc (input_location
, NE_EXPR
,
8051 tmp
, gfc_index_zero_node
);
8052 tmp
= build3_v (COND_EXPR
, cond
,
8053 build1_v (GOTO_EXPR
, jump_label1
),
8054 build_empty_stmt (input_location
));
8055 gfc_add_expr_to_block (&fblock
, tmp
);
8058 /* ....else jump past the (re)alloc code. */
8059 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
8060 gfc_add_expr_to_block (&fblock
, tmp
);
8062 /* Add the label to start automatic (re)allocation. */
8063 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
8064 gfc_add_expr_to_block (&fblock
, tmp
);
8066 size1
= gfc_conv_descriptor_size (desc
, expr1
->rank
);
8068 /* Get the rhs size. Fix both sizes. */
8070 desc2
= rss
->info
->data
.array
.descriptor
;
8073 size2
= gfc_index_one_node
;
8074 for (n
= 0; n
< expr2
->rank
; n
++)
8076 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8077 gfc_array_index_type
,
8078 loop
->to
[n
], loop
->from
[n
]);
8079 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8080 gfc_array_index_type
,
8081 tmp
, gfc_index_one_node
);
8082 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
8083 gfc_array_index_type
,
8087 size1
= gfc_evaluate_now (size1
, &fblock
);
8088 size2
= gfc_evaluate_now (size2
, &fblock
);
8090 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
8092 neq_size
= gfc_evaluate_now (cond
, &fblock
);
8095 /* Now modify the lhs descriptor and the associated scalarizer
8096 variables. F2003 7.4.1.3: "If variable is or becomes an
8097 unallocated allocatable variable, then it is allocated with each
8098 deferred type parameter equal to the corresponding type parameters
8099 of expr , with the shape of expr , and with each lower bound equal
8100 to the corresponding element of LBOUND(expr)."
8101 Reuse size1 to keep a dimension-by-dimension track of the
8102 stride of the new array. */
8103 size1
= gfc_index_one_node
;
8104 offset
= gfc_index_zero_node
;
8106 for (n
= 0; n
< expr2
->rank
; n
++)
8108 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8109 gfc_array_index_type
,
8110 loop
->to
[n
], loop
->from
[n
]);
8111 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8112 gfc_array_index_type
,
8113 tmp
, gfc_index_one_node
);
8115 lbound
= gfc_index_one_node
;
8120 lbd
= get_std_lbound (expr2
, desc2
, n
,
8121 as
->type
== AS_ASSUMED_SIZE
);
8122 ubound
= fold_build2_loc (input_location
,
8124 gfc_array_index_type
,
8126 ubound
= fold_build2_loc (input_location
,
8128 gfc_array_index_type
,
8133 gfc_conv_descriptor_lbound_set (&fblock
, desc
,
8136 gfc_conv_descriptor_ubound_set (&fblock
, desc
,
8139 gfc_conv_descriptor_stride_set (&fblock
, desc
,
8142 lbound
= gfc_conv_descriptor_lbound_get (desc
,
8144 tmp2
= fold_build2_loc (input_location
, MULT_EXPR
,
8145 gfc_array_index_type
,
8147 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
8148 gfc_array_index_type
,
8150 size1
= fold_build2_loc (input_location
, MULT_EXPR
,
8151 gfc_array_index_type
,
8155 /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
8156 the array offset is saved and the info.offset is used for a
8157 running offset. Use the saved_offset instead. */
8158 tmp
= gfc_conv_descriptor_offset (desc
);
8159 gfc_add_modify (&fblock
, tmp
, offset
);
8160 if (linfo
->saved_offset
8161 && TREE_CODE (linfo
->saved_offset
) == VAR_DECL
)
8162 gfc_add_modify (&fblock
, linfo
->saved_offset
, tmp
);
8164 /* Now set the deltas for the lhs. */
8165 for (n
= 0; n
< expr1
->rank
; n
++)
8167 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
8169 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8170 gfc_array_index_type
, tmp
,
8172 if (linfo
->delta
[dim
]
8173 && TREE_CODE (linfo
->delta
[dim
]) == VAR_DECL
)
8174 gfc_add_modify (&fblock
, linfo
->delta
[dim
], tmp
);
8177 /* Get the new lhs size in bytes. */
8178 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
8180 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
8181 gcc_assert (expr1
->ts
.u
.cl
->backend_decl
);
8182 tmp
= fold_convert (TREE_TYPE (expr1
->ts
.u
.cl
->backend_decl
), tmp
);
8183 gfc_add_modify (&fblock
, expr1
->ts
.u
.cl
->backend_decl
, tmp
);
8185 else if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.u
.cl
->backend_decl
)
8187 tmp
= TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
)));
8188 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8189 gfc_array_index_type
, tmp
,
8190 expr1
->ts
.u
.cl
->backend_decl
);
8193 tmp
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
8194 tmp
= fold_convert (gfc_array_index_type
, tmp
);
8195 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
8196 gfc_array_index_type
,
8198 size2
= fold_convert (size_type_node
, size2
);
8199 size2
= gfc_evaluate_now (size2
, &fblock
);
8201 /* Realloc expression. Note that the scalarizer uses desc.data
8202 in the array reference - (*desc.data)[<element>]. */
8203 gfc_init_block (&realloc_block
);
8204 tmp
= build_call_expr_loc (input_location
,
8205 builtin_decl_explicit (BUILT_IN_REALLOC
), 2,
8206 fold_convert (pvoid_type_node
, array1
),
8208 gfc_conv_descriptor_data_set (&realloc_block
,
8210 realloc_expr
= gfc_finish_block (&realloc_block
);
8212 /* Only reallocate if sizes are different. */
8213 tmp
= build3_v (COND_EXPR
, neq_size
, realloc_expr
,
8214 build_empty_stmt (input_location
));
8218 /* Malloc expression. */
8219 gfc_init_block (&alloc_block
);
8220 tmp
= build_call_expr_loc (input_location
,
8221 builtin_decl_explicit (BUILT_IN_MALLOC
),
8223 gfc_conv_descriptor_data_set (&alloc_block
,
8225 tmp
= gfc_conv_descriptor_dtype (desc
);
8226 gfc_add_modify (&alloc_block
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
8227 alloc_expr
= gfc_finish_block (&alloc_block
);
8229 /* Malloc if not allocated; realloc otherwise. */
8230 tmp
= build_int_cst (TREE_TYPE (array1
), 0);
8231 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
8234 tmp
= build3_v (COND_EXPR
, cond
, alloc_expr
, realloc_expr
);
8235 gfc_add_expr_to_block (&fblock
, tmp
);
8237 /* Make sure that the scalarizer data pointer is updated. */
8239 && TREE_CODE (linfo
->data
) == VAR_DECL
)
8241 tmp
= gfc_conv_descriptor_data_get (desc
);
8242 gfc_add_modify (&fblock
, linfo
->data
, tmp
);
8245 /* Add the exit label. */
8246 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
8247 gfc_add_expr_to_block (&fblock
, tmp
);
8249 return gfc_finish_block (&fblock
);
8253 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
8254 Do likewise, recursively if necessary, with the allocatable components of
8258 gfc_trans_deferred_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
8264 stmtblock_t cleanup
;
8267 bool sym_has_alloc_comp
;
8269 sym_has_alloc_comp
= (sym
->ts
.type
== BT_DERIVED
8270 || sym
->ts
.type
== BT_CLASS
)
8271 && sym
->ts
.u
.derived
->attr
.alloc_comp
;
8273 /* Make sure the frontend gets these right. */
8274 if (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym_has_alloc_comp
))
8275 fatal_error ("Possible front-end bug: Deferred array size without pointer, "
8276 "allocatable attribute or derived type without allocatable "
8279 gfc_save_backend_locus (&loc
);
8280 gfc_set_backend_locus (&sym
->declared_at
);
8281 gfc_init_block (&init
);
8283 gcc_assert (TREE_CODE (sym
->backend_decl
) == VAR_DECL
8284 || TREE_CODE (sym
->backend_decl
) == PARM_DECL
);
8286 if (sym
->ts
.type
== BT_CHARACTER
8287 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
8289 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
8290 gfc_trans_vla_type_sizes (sym
, &init
);
8293 /* Dummy, use associated and result variables don't need anything special. */
8294 if (sym
->attr
.dummy
|| sym
->attr
.use_assoc
|| sym
->attr
.result
)
8296 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
8297 gfc_restore_backend_locus (&loc
);
8301 descriptor
= sym
->backend_decl
;
8303 /* Although static, derived types with default initializers and
8304 allocatable components must not be nulled wholesale; instead they
8305 are treated component by component. */
8306 if (TREE_STATIC (descriptor
) && !sym_has_alloc_comp
)
8308 /* SAVEd variables are not freed on exit. */
8309 gfc_trans_static_array_pointer (sym
);
8311 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
8312 gfc_restore_backend_locus (&loc
);
8316 /* Get the descriptor type. */
8317 type
= TREE_TYPE (sym
->backend_decl
);
8319 if (sym_has_alloc_comp
&& !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
8322 && !(TREE_STATIC (sym
->backend_decl
) && sym
->attr
.is_main_program
))
8324 if (sym
->value
== NULL
8325 || !gfc_has_default_initializer (sym
->ts
.u
.derived
))
8327 rank
= sym
->as
? sym
->as
->rank
: 0;
8328 tmp
= gfc_nullify_alloc_comp (sym
->ts
.u
.derived
,
8330 gfc_add_expr_to_block (&init
, tmp
);
8333 gfc_init_default_dt (sym
, &init
, false);
8336 else if (!GFC_DESCRIPTOR_TYPE_P (type
))
8338 /* If the backend_decl is not a descriptor, we must have a pointer
8340 descriptor
= build_fold_indirect_ref_loc (input_location
,
8342 type
= TREE_TYPE (descriptor
);
8345 /* NULLIFY the data pointer. */
8346 if (GFC_DESCRIPTOR_TYPE_P (type
) && !sym
->attr
.save
)
8347 gfc_conv_descriptor_data_set (&init
, descriptor
, null_pointer_node
);
8349 gfc_restore_backend_locus (&loc
);
8350 gfc_init_block (&cleanup
);
8352 /* Allocatable arrays need to be freed when they go out of scope.
8353 The allocatable components of pointers must not be touched. */
8354 if (sym_has_alloc_comp
&& !(sym
->attr
.function
|| sym
->attr
.result
)
8355 && !sym
->attr
.pointer
&& !sym
->attr
.save
)
8358 rank
= sym
->as
? sym
->as
->rank
: 0;
8359 tmp
= gfc_deallocate_alloc_comp (sym
->ts
.u
.derived
, descriptor
, rank
);
8360 gfc_add_expr_to_block (&cleanup
, tmp
);
8363 if (sym
->attr
.allocatable
&& (sym
->attr
.dimension
|| sym
->attr
.codimension
)
8364 && !sym
->attr
.save
&& !sym
->attr
.result
)
8366 tmp
= gfc_trans_dealloc_allocated (sym
->backend_decl
,
8367 sym
->attr
.codimension
);
8368 gfc_add_expr_to_block (&cleanup
, tmp
);
8371 gfc_add_init_cleanup (block
, gfc_finish_block (&init
),
8372 gfc_finish_block (&cleanup
));
8375 /************ Expression Walking Functions ******************/
8377 /* Walk a variable reference.
8379 Possible extension - multiple component subscripts.
8380 x(:,:) = foo%a(:)%b(:)
8382 forall (i=..., j=...)
8383 x(i,j) = foo%a(j)%b(i)
8385 This adds a fair amount of complexity because you need to deal with more
8386 than one ref. Maybe handle in a similar manner to vector subscripts.
8387 Maybe not worth the effort. */
8391 gfc_walk_variable_expr (gfc_ss
* ss
, gfc_expr
* expr
)
8395 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
8396 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
8399 return gfc_walk_array_ref (ss
, expr
, ref
);
8404 gfc_walk_array_ref (gfc_ss
* ss
, gfc_expr
* expr
, gfc_ref
* ref
)
8410 for (; ref
; ref
= ref
->next
)
8412 if (ref
->type
== REF_SUBSTRING
)
8414 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.start
);
8415 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.end
);
8418 /* We're only interested in array sections from now on. */
8419 if (ref
->type
!= REF_ARRAY
)
8427 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
8428 ss
= gfc_get_scalar_ss (ss
, ar
->start
[n
]);
8432 newss
= gfc_get_array_ss (ss
, expr
, ar
->as
->rank
, GFC_SS_SECTION
);
8433 newss
->info
->data
.array
.ref
= ref
;
8435 /* Make sure array is the same as array(:,:), this way
8436 we don't need to special case all the time. */
8437 ar
->dimen
= ar
->as
->rank
;
8438 for (n
= 0; n
< ar
->dimen
; n
++)
8440 ar
->dimen_type
[n
] = DIMEN_RANGE
;
8442 gcc_assert (ar
->start
[n
] == NULL
);
8443 gcc_assert (ar
->end
[n
] == NULL
);
8444 gcc_assert (ar
->stride
[n
] == NULL
);
8450 newss
= gfc_get_array_ss (ss
, expr
, 0, GFC_SS_SECTION
);
8451 newss
->info
->data
.array
.ref
= ref
;
8453 /* We add SS chains for all the subscripts in the section. */
8454 for (n
= 0; n
< ar
->dimen
; n
++)
8458 switch (ar
->dimen_type
[n
])
8461 /* Add SS for elemental (scalar) subscripts. */
8462 gcc_assert (ar
->start
[n
]);
8463 indexss
= gfc_get_scalar_ss (gfc_ss_terminator
, ar
->start
[n
]);
8464 indexss
->loop_chain
= gfc_ss_terminator
;
8465 newss
->info
->data
.array
.subscript
[n
] = indexss
;
8469 /* We don't add anything for sections, just remember this
8470 dimension for later. */
8471 newss
->dim
[newss
->dimen
] = n
;
8476 /* Create a GFC_SS_VECTOR index in which we can store
8477 the vector's descriptor. */
8478 indexss
= gfc_get_array_ss (gfc_ss_terminator
, ar
->start
[n
],
8480 indexss
->loop_chain
= gfc_ss_terminator
;
8481 newss
->info
->data
.array
.subscript
[n
] = indexss
;
8482 newss
->dim
[newss
->dimen
] = n
;
8487 /* We should know what sort of section it is by now. */
8491 /* We should have at least one non-elemental dimension,
8492 unless we are creating a descriptor for a (scalar) coarray. */
8493 gcc_assert (newss
->dimen
> 0
8494 || newss
->info
->data
.array
.ref
->u
.ar
.as
->corank
> 0);
8499 /* We should know what sort of section it is by now. */
8508 /* Walk an expression operator. If only one operand of a binary expression is
8509 scalar, we must also add the scalar term to the SS chain. */
8512 gfc_walk_op_expr (gfc_ss
* ss
, gfc_expr
* expr
)
8517 head
= gfc_walk_subexpr (ss
, expr
->value
.op
.op1
);
8518 if (expr
->value
.op
.op2
== NULL
)
8521 head2
= gfc_walk_subexpr (head
, expr
->value
.op
.op2
);
8523 /* All operands are scalar. Pass back and let the caller deal with it. */
8527 /* All operands require scalarization. */
8528 if (head
!= ss
&& (expr
->value
.op
.op2
== NULL
|| head2
!= head
))
8531 /* One of the operands needs scalarization, the other is scalar.
8532 Create a gfc_ss for the scalar expression. */
8535 /* First operand is scalar. We build the chain in reverse order, so
8536 add the scalar SS after the second operand. */
8538 while (head
&& head
->next
!= ss
)
8540 /* Check we haven't somehow broken the chain. */
8542 head
->next
= gfc_get_scalar_ss (ss
, expr
->value
.op
.op1
);
8544 else /* head2 == head */
8546 gcc_assert (head2
== head
);
8547 /* Second operand is scalar. */
8548 head2
= gfc_get_scalar_ss (head2
, expr
->value
.op
.op2
);
8555 /* Reverse a SS chain. */
8558 gfc_reverse_ss (gfc_ss
* ss
)
8563 gcc_assert (ss
!= NULL
);
8565 head
= gfc_ss_terminator
;
8566 while (ss
!= gfc_ss_terminator
)
8569 /* Check we didn't somehow break the chain. */
8570 gcc_assert (next
!= NULL
);
8580 /* Given an expression referring to a procedure, return the symbol of its
8581 interface. We can't get the procedure symbol directly as we have to handle
8582 the case of (deferred) type-bound procedures. */
8585 gfc_get_proc_ifc_for_expr (gfc_expr
*procedure_ref
)
8590 if (procedure_ref
== NULL
)
8593 /* Normal procedure case. */
8594 sym
= procedure_ref
->symtree
->n
.sym
;
8596 /* Typebound procedure case. */
8597 for (ref
= procedure_ref
->ref
; ref
; ref
= ref
->next
)
8599 if (ref
->type
== REF_COMPONENT
8600 && ref
->u
.c
.component
->attr
.proc_pointer
)
8601 sym
= ref
->u
.c
.component
->ts
.interface
;
8610 /* Walk the arguments of an elemental function.
8611 PROC_EXPR is used to check whether an argument is permitted to be absent. If
8612 it is NULL, we don't do the check and the argument is assumed to be present.
8616 gfc_walk_elemental_function_args (gfc_ss
* ss
, gfc_actual_arglist
*arg
,
8617 gfc_symbol
*proc_ifc
, gfc_ss_type type
)
8619 gfc_formal_arglist
*dummy_arg
;
8625 head
= gfc_ss_terminator
;
8629 dummy_arg
= gfc_sym_get_dummy_args (proc_ifc
);
8634 for (; arg
; arg
= arg
->next
)
8636 if (!arg
->expr
|| arg
->expr
->expr_type
== EXPR_NULL
)
8639 newss
= gfc_walk_subexpr (head
, arg
->expr
);
8642 /* Scalar argument. */
8643 gcc_assert (type
== GFC_SS_SCALAR
|| type
== GFC_SS_REFERENCE
);
8644 newss
= gfc_get_scalar_ss (head
, arg
->expr
);
8645 newss
->info
->type
= type
;
8651 if (dummy_arg
!= NULL
8652 && dummy_arg
->sym
->attr
.optional
8653 && arg
->expr
->expr_type
== EXPR_VARIABLE
8654 && (gfc_expr_attr (arg
->expr
).optional
8655 || gfc_expr_attr (arg
->expr
).allocatable
8656 || gfc_expr_attr (arg
->expr
).pointer
))
8657 newss
->info
->can_be_null_ref
= true;
8663 while (tail
->next
!= gfc_ss_terminator
)
8667 if (dummy_arg
!= NULL
)
8668 dummy_arg
= dummy_arg
->next
;
8673 /* If all the arguments are scalar we don't need the argument SS. */
8674 gfc_free_ss_chain (head
);
8679 /* Add it onto the existing chain. */
8685 /* Walk a function call. Scalar functions are passed back, and taken out of
8686 scalarization loops. For elemental functions we walk their arguments.
8687 The result of functions returning arrays is stored in a temporary outside
8688 the loop, so that the function is only called once. Hence we do not need
8689 to walk their arguments. */
8692 gfc_walk_function_expr (gfc_ss
* ss
, gfc_expr
* expr
)
8694 gfc_intrinsic_sym
*isym
;
8696 gfc_component
*comp
= NULL
;
8698 isym
= expr
->value
.function
.isym
;
8700 /* Handle intrinsic functions separately. */
8702 return gfc_walk_intrinsic_function (ss
, expr
, isym
);
8704 sym
= expr
->value
.function
.esym
;
8706 sym
= expr
->symtree
->n
.sym
;
8708 /* A function that returns arrays. */
8709 comp
= gfc_get_proc_ptr_comp (expr
);
8710 if ((!comp
&& gfc_return_by_reference (sym
) && sym
->result
->attr
.dimension
)
8711 || (comp
&& comp
->attr
.dimension
))
8712 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
8714 /* Walk the parameters of an elemental function. For now we always pass
8716 if (sym
->attr
.elemental
|| (comp
&& comp
->attr
.elemental
))
8717 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
8718 gfc_get_proc_ifc_for_expr (expr
),
8721 /* Scalar functions are OK as these are evaluated outside the scalarization
8722 loop. Pass back and let the caller deal with it. */
8727 /* An array temporary is constructed for array constructors. */
8730 gfc_walk_array_constructor (gfc_ss
* ss
, gfc_expr
* expr
)
8732 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_CONSTRUCTOR
);
8736 /* Walk an expression. Add walked expressions to the head of the SS chain.
8737 A wholly scalar expression will not be added. */
8740 gfc_walk_subexpr (gfc_ss
* ss
, gfc_expr
* expr
)
8744 switch (expr
->expr_type
)
8747 head
= gfc_walk_variable_expr (ss
, expr
);
8751 head
= gfc_walk_op_expr (ss
, expr
);
8755 head
= gfc_walk_function_expr (ss
, expr
);
8760 case EXPR_STRUCTURE
:
8761 /* Pass back and let the caller deal with it. */
8765 head
= gfc_walk_array_constructor (ss
, expr
);
8768 case EXPR_SUBSTRING
:
8769 /* Pass back and let the caller deal with it. */
8773 internal_error ("bad expression type during walk (%d)",
8780 /* Entry point for expression walking.
8781 A return value equal to the passed chain means this is
8782 a scalar expression. It is up to the caller to take whatever action is
8783 necessary to translate these. */
8786 gfc_walk_expr (gfc_expr
* expr
)
8790 res
= gfc_walk_subexpr (gfc_ss_terminator
, expr
);
8791 return gfc_reverse_ss (res
);