1 /* Array translation routines
2 Copyright (C) 2002-2016 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-array.c-- Various array related code, including scalarization,
23 allocation, initialization and other support routines. */
25 /* How the scalarizer works.
26 In gfortran, array expressions use the same core routines as scalar
28 First, a Scalarization State (SS) chain is built. This is done by walking
29 the expression tree, and building a linear list of the terms in the
30 expression. As the tree is walked, scalar subexpressions are translated.
32 The scalarization parameters are stored in a gfc_loopinfo structure.
33 First the start and stride of each term is calculated by
34 gfc_conv_ss_startstride. During this process the expressions for the array
35 descriptors and data pointers are also translated.
37 If the expression is an assignment, we must then resolve any dependencies.
38 In Fortran all the rhs values of an assignment must be evaluated before
39 any assignments take place. This can require a temporary array to store the
40 values. We also require a temporary when we are passing array expressions
41 or vector subscripts as procedure parameters.
43 Array sections are passed without copying to a temporary. These use the
44 scalarizer to determine the shape of the section. The flag
45 loop->array_parameter tells the scalarizer that the actual values and loop
46 variables will not be required.
48 The function gfc_conv_loop_setup generates the scalarization setup code.
49 It determines the range of the scalarizing loop variables. If a temporary
50 is required, this is created and initialized. Code for scalar expressions
51 taken outside the loop is also generated at this time. Next the offset and
52 scaling required to translate from loop variables to array indices for each
55 A call to gfc_start_scalarized_body marks the start of the scalarized
56 expression. This creates a scope and declares the loop variables. Before
57 calling this gfc_make_ss_chain_used must be used to indicate which terms
58 will be used inside this loop.
60 The scalar gfc_conv_* functions are then used to build the main body of the
61 scalarization loop. Scalarization loop variables and precalculated scalar
62 values are automatically substituted. Note that gfc_advance_se_ss_chain
63 must be used, rather than changing the se->ss directly.
65 For assignment expressions requiring a temporary two sub loops are
66 generated. The first stores the result of the expression in the temporary,
67 the second copies it to the result. A call to
68 gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
69 the start of the copying loop. The temporary may be less than full rank.
71 Finally gfc_trans_scalarizing_loops is called to generate the implicit do
72 loops. The loops are added to the pre chain of the loopinfo. The post
73 chain may still contain cleanup code.
75 After the loop code has been added into its parent scope gfc_cleanup_loop
76 is called to free all the SS allocated by the scalarizer. */
80 #include "coretypes.h"
84 #include "gimple-expr.h"
86 #include "fold-const.h"
87 #include "constructor.h"
88 #include "trans-types.h"
89 #include "trans-array.h"
90 #include "trans-const.h"
91 #include "dependency.h"
93 static bool gfc_get_array_constructor_size (mpz_t
*, gfc_constructor_base
);
95 /* The contents of this structure aren't actually used, just the address. */
96 static gfc_ss gfc_ss_terminator_var
;
97 gfc_ss
* const gfc_ss_terminator
= &gfc_ss_terminator_var
;
101 gfc_array_dataptr_type (tree desc
)
103 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
)));
107 /* Build expressions to access the members of an array descriptor.
108 It's surprisingly easy to mess up here, so never access
109 an array descriptor by "brute force", always use these
110 functions. This also avoids problems if we change the format
111 of an array descriptor.
113 To understand these magic numbers, look at the comments
114 before gfc_build_array_type() in trans-types.c.
116 The code within these defines should be the only code which knows the format
117 of an array descriptor.
119 Any code just needing to read obtain the bounds of an array should use
120 gfc_conv_array_* rather than the following functions as these will return
121 know constant values, and work with arrays which do not have descriptors.
123 Don't forget to #undef these! */
126 #define OFFSET_FIELD 1
127 #define DTYPE_FIELD 2
128 #define DIMENSION_FIELD 3
129 #define CAF_TOKEN_FIELD 4
131 #define STRIDE_SUBFIELD 0
132 #define LBOUND_SUBFIELD 1
133 #define UBOUND_SUBFIELD 2
135 /* This provides READ-ONLY access to the data field. The field itself
136 doesn't have the proper type. */
139 gfc_conv_descriptor_data_get (tree desc
)
143 type
= TREE_TYPE (desc
);
144 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
146 field
= TYPE_FIELDS (type
);
147 gcc_assert (DATA_FIELD
== 0);
149 t
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
), desc
,
151 t
= fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type
), t
);
156 /* This provides WRITE access to the data field.
158 TUPLES_P is true if we are generating tuples.
160 This function gets called through the following macros:
161 gfc_conv_descriptor_data_set
162 gfc_conv_descriptor_data_set. */
165 gfc_conv_descriptor_data_set (stmtblock_t
*block
, tree desc
, tree value
)
169 type
= TREE_TYPE (desc
);
170 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
172 field
= TYPE_FIELDS (type
);
173 gcc_assert (DATA_FIELD
== 0);
175 t
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
), desc
,
177 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (field
), value
));
181 /* This provides address access to the data field. This should only be
182 used by array allocation, passing this on to the runtime. */
185 gfc_conv_descriptor_data_addr (tree desc
)
189 type
= TREE_TYPE (desc
);
190 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
192 field
= TYPE_FIELDS (type
);
193 gcc_assert (DATA_FIELD
== 0);
195 t
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
), desc
,
197 return gfc_build_addr_expr (NULL_TREE
, t
);
201 gfc_conv_descriptor_offset (tree desc
)
206 type
= TREE_TYPE (desc
);
207 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
209 field
= gfc_advance_chain (TYPE_FIELDS (type
), OFFSET_FIELD
);
210 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
212 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
213 desc
, field
, NULL_TREE
);
217 gfc_conv_descriptor_offset_get (tree desc
)
219 return gfc_conv_descriptor_offset (desc
);
223 gfc_conv_descriptor_offset_set (stmtblock_t
*block
, tree desc
,
226 tree t
= gfc_conv_descriptor_offset (desc
);
227 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
232 gfc_conv_descriptor_dtype (tree desc
)
237 type
= TREE_TYPE (desc
);
238 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
240 field
= gfc_advance_chain (TYPE_FIELDS (type
), DTYPE_FIELD
);
241 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
243 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
244 desc
, field
, NULL_TREE
);
249 gfc_conv_descriptor_rank (tree desc
)
254 dtype
= gfc_conv_descriptor_dtype (desc
);
255 tmp
= build_int_cst (TREE_TYPE (dtype
), GFC_DTYPE_RANK_MASK
);
256 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, TREE_TYPE (dtype
),
258 return fold_convert (gfc_get_int_type (gfc_default_integer_kind
), tmp
);
263 gfc_get_descriptor_dimension (tree desc
)
267 type
= TREE_TYPE (desc
);
268 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
270 field
= gfc_advance_chain (TYPE_FIELDS (type
), DIMENSION_FIELD
);
271 gcc_assert (field
!= NULL_TREE
272 && TREE_CODE (TREE_TYPE (field
)) == ARRAY_TYPE
273 && TREE_CODE (TREE_TYPE (TREE_TYPE (field
))) == RECORD_TYPE
);
275 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
276 desc
, field
, NULL_TREE
);
281 gfc_conv_descriptor_dimension (tree desc
, tree dim
)
285 tmp
= gfc_get_descriptor_dimension (desc
);
287 return gfc_build_array_ref (tmp
, dim
, NULL
);
292 gfc_conv_descriptor_token (tree desc
)
297 type
= TREE_TYPE (desc
);
298 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
299 gcc_assert (flag_coarray
== GFC_FCOARRAY_LIB
);
300 field
= gfc_advance_chain (TYPE_FIELDS (type
), CAF_TOKEN_FIELD
);
302 /* Should be a restricted pointer - except in the finalization wrapper. */
303 gcc_assert (field
!= NULL_TREE
304 && (TREE_TYPE (field
) == prvoid_type_node
305 || TREE_TYPE (field
) == pvoid_type_node
));
307 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
308 desc
, field
, NULL_TREE
);
313 gfc_conv_descriptor_stride (tree desc
, tree dim
)
318 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
319 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
320 field
= gfc_advance_chain (field
, STRIDE_SUBFIELD
);
321 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
323 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
324 tmp
, field
, NULL_TREE
);
329 gfc_conv_descriptor_stride_get (tree desc
, tree dim
)
331 tree type
= TREE_TYPE (desc
);
332 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
333 if (integer_zerop (dim
)
334 && (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ALLOCATABLE
335 ||GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE_CONT
336 ||GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_RANK_CONT
337 ||GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER_CONT
))
338 return gfc_index_one_node
;
340 return gfc_conv_descriptor_stride (desc
, dim
);
344 gfc_conv_descriptor_stride_set (stmtblock_t
*block
, tree desc
,
345 tree dim
, tree value
)
347 tree t
= gfc_conv_descriptor_stride (desc
, dim
);
348 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
352 gfc_conv_descriptor_lbound (tree desc
, tree dim
)
357 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
358 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
359 field
= gfc_advance_chain (field
, LBOUND_SUBFIELD
);
360 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
362 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
363 tmp
, field
, NULL_TREE
);
368 gfc_conv_descriptor_lbound_get (tree desc
, tree dim
)
370 return gfc_conv_descriptor_lbound (desc
, dim
);
374 gfc_conv_descriptor_lbound_set (stmtblock_t
*block
, tree desc
,
375 tree dim
, tree value
)
377 tree t
= gfc_conv_descriptor_lbound (desc
, dim
);
378 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
382 gfc_conv_descriptor_ubound (tree desc
, tree dim
)
387 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
388 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
389 field
= gfc_advance_chain (field
, UBOUND_SUBFIELD
);
390 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
392 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
393 tmp
, field
, NULL_TREE
);
398 gfc_conv_descriptor_ubound_get (tree desc
, tree dim
)
400 return gfc_conv_descriptor_ubound (desc
, dim
);
404 gfc_conv_descriptor_ubound_set (stmtblock_t
*block
, tree desc
,
405 tree dim
, tree value
)
407 tree t
= gfc_conv_descriptor_ubound (desc
, dim
);
408 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
411 /* Build a null array descriptor constructor. */
414 gfc_build_null_descriptor (tree type
)
419 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
420 gcc_assert (DATA_FIELD
== 0);
421 field
= TYPE_FIELDS (type
);
423 /* Set a NULL data pointer. */
424 tmp
= build_constructor_single (type
, field
, null_pointer_node
);
425 TREE_CONSTANT (tmp
) = 1;
426 /* All other fields are ignored. */
432 /* Modify a descriptor such that the lbound of a given dimension is the value
433 specified. This also updates ubound and offset accordingly. */
436 gfc_conv_shift_descriptor_lbound (stmtblock_t
* block
, tree desc
,
437 int dim
, tree new_lbound
)
439 tree offs
, ubound
, lbound
, stride
;
440 tree diff
, offs_diff
;
442 new_lbound
= fold_convert (gfc_array_index_type
, new_lbound
);
444 offs
= gfc_conv_descriptor_offset_get (desc
);
445 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]);
446 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]);
447 stride
= gfc_conv_descriptor_stride_get (desc
, gfc_rank_cst
[dim
]);
449 /* Get difference (new - old) by which to shift stuff. */
450 diff
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
453 /* Shift ubound and offset accordingly. This has to be done before
454 updating the lbound, as they depend on the lbound expression! */
455 ubound
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
457 gfc_conv_descriptor_ubound_set (block
, desc
, gfc_rank_cst
[dim
], ubound
);
458 offs_diff
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
460 offs
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
462 gfc_conv_descriptor_offset_set (block
, desc
, offs
);
464 /* Finally set lbound to value we want. */
465 gfc_conv_descriptor_lbound_set (block
, desc
, gfc_rank_cst
[dim
], new_lbound
);
469 /* Cleanup those #defines. */
474 #undef DIMENSION_FIELD
475 #undef CAF_TOKEN_FIELD
476 #undef STRIDE_SUBFIELD
477 #undef LBOUND_SUBFIELD
478 #undef UBOUND_SUBFIELD
481 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
482 flags & 1 = Main loop body.
483 flags & 2 = temp copy loop. */
486 gfc_mark_ss_chain_used (gfc_ss
* ss
, unsigned flags
)
488 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
489 ss
->info
->useflags
= flags
;
493 /* Free a gfc_ss chain. */
496 gfc_free_ss_chain (gfc_ss
* ss
)
500 while (ss
!= gfc_ss_terminator
)
502 gcc_assert (ss
!= NULL
);
511 free_ss_info (gfc_ss_info
*ss_info
)
516 if (ss_info
->refcount
> 0)
519 gcc_assert (ss_info
->refcount
== 0);
521 switch (ss_info
->type
)
524 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
525 if (ss_info
->data
.array
.subscript
[n
])
526 gfc_free_ss_chain (ss_info
->data
.array
.subscript
[n
]);
540 gfc_free_ss (gfc_ss
* ss
)
542 free_ss_info (ss
->info
);
547 /* Creates and initializes an array type gfc_ss struct. */
550 gfc_get_array_ss (gfc_ss
*next
, gfc_expr
*expr
, int dimen
, gfc_ss_type type
)
553 gfc_ss_info
*ss_info
;
556 ss_info
= gfc_get_ss_info ();
558 ss_info
->type
= type
;
559 ss_info
->expr
= expr
;
565 for (i
= 0; i
< ss
->dimen
; i
++)
572 /* Creates and initializes a temporary type gfc_ss struct. */
575 gfc_get_temp_ss (tree type
, tree string_length
, int dimen
)
578 gfc_ss_info
*ss_info
;
581 ss_info
= gfc_get_ss_info ();
583 ss_info
->type
= GFC_SS_TEMP
;
584 ss_info
->string_length
= string_length
;
585 ss_info
->data
.temp
.type
= type
;
589 ss
->next
= gfc_ss_terminator
;
591 for (i
= 0; i
< ss
->dimen
; i
++)
598 /* Creates and initializes a scalar type gfc_ss struct. */
601 gfc_get_scalar_ss (gfc_ss
*next
, gfc_expr
*expr
)
604 gfc_ss_info
*ss_info
;
606 ss_info
= gfc_get_ss_info ();
608 ss_info
->type
= GFC_SS_SCALAR
;
609 ss_info
->expr
= expr
;
619 /* Free all the SS associated with a loop. */
622 gfc_cleanup_loop (gfc_loopinfo
* loop
)
624 gfc_loopinfo
*loop_next
, **ploop
;
629 while (ss
!= gfc_ss_terminator
)
631 gcc_assert (ss
!= NULL
);
632 next
= ss
->loop_chain
;
637 /* Remove reference to self in the parent loop. */
639 for (ploop
= &loop
->parent
->nested
; *ploop
; ploop
= &(*ploop
)->next
)
646 /* Free non-freed nested loops. */
647 for (loop
= loop
->nested
; loop
; loop
= loop_next
)
649 loop_next
= loop
->next
;
650 gfc_cleanup_loop (loop
);
657 set_ss_loop (gfc_ss
*ss
, gfc_loopinfo
*loop
)
661 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
665 if (ss
->info
->type
== GFC_SS_SCALAR
666 || ss
->info
->type
== GFC_SS_REFERENCE
667 || ss
->info
->type
== GFC_SS_TEMP
)
670 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
671 if (ss
->info
->data
.array
.subscript
[n
] != NULL
)
672 set_ss_loop (ss
->info
->data
.array
.subscript
[n
], loop
);
677 /* Associate a SS chain with a loop. */
680 gfc_add_ss_to_loop (gfc_loopinfo
* loop
, gfc_ss
* head
)
683 gfc_loopinfo
*nested_loop
;
685 if (head
== gfc_ss_terminator
)
688 set_ss_loop (head
, loop
);
691 for (; ss
&& ss
!= gfc_ss_terminator
; ss
= ss
->next
)
695 nested_loop
= ss
->nested_ss
->loop
;
697 /* More than one ss can belong to the same loop. Hence, we add the
698 loop to the chain only if it is different from the previously
699 added one, to avoid duplicate nested loops. */
700 if (nested_loop
!= loop
->nested
)
702 gcc_assert (nested_loop
->parent
== NULL
);
703 nested_loop
->parent
= loop
;
705 gcc_assert (nested_loop
->next
== NULL
);
706 nested_loop
->next
= loop
->nested
;
707 loop
->nested
= nested_loop
;
710 gcc_assert (nested_loop
->parent
== loop
);
713 if (ss
->next
== gfc_ss_terminator
)
714 ss
->loop_chain
= loop
->ss
;
716 ss
->loop_chain
= ss
->next
;
718 gcc_assert (ss
== gfc_ss_terminator
);
723 /* Generate an initializer for a static pointer or allocatable array. */
726 gfc_trans_static_array_pointer (gfc_symbol
* sym
)
730 gcc_assert (TREE_STATIC (sym
->backend_decl
));
731 /* Just zero the data member. */
732 type
= TREE_TYPE (sym
->backend_decl
);
733 DECL_INITIAL (sym
->backend_decl
) = gfc_build_null_descriptor (type
);
737 /* If the bounds of SE's loop have not yet been set, see if they can be
738 determined from array spec AS, which is the array spec of a called
739 function. MAPPING maps the callee's dummy arguments to the values
740 that the caller is passing. Add any initialization and finalization
744 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping
* mapping
,
745 gfc_se
* se
, gfc_array_spec
* as
)
747 int n
, dim
, total_dim
;
756 if (!as
|| as
->type
!= AS_EXPLICIT
)
759 for (ss
= se
->ss
; ss
; ss
= ss
->parent
)
761 total_dim
+= ss
->loop
->dimen
;
762 for (n
= 0; n
< ss
->loop
->dimen
; n
++)
764 /* The bound is known, nothing to do. */
765 if (ss
->loop
->to
[n
] != NULL_TREE
)
769 gcc_assert (dim
< as
->rank
);
770 gcc_assert (ss
->loop
->dimen
<= as
->rank
);
772 /* Evaluate the lower bound. */
773 gfc_init_se (&tmpse
, NULL
);
774 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->lower
[dim
]);
775 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
776 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
777 lower
= fold_convert (gfc_array_index_type
, tmpse
.expr
);
779 /* ...and the upper bound. */
780 gfc_init_se (&tmpse
, NULL
);
781 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->upper
[dim
]);
782 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
783 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
784 upper
= fold_convert (gfc_array_index_type
, tmpse
.expr
);
786 /* Set the upper bound of the loop to UPPER - LOWER. */
787 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
788 gfc_array_index_type
, upper
, lower
);
789 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
790 ss
->loop
->to
[n
] = tmp
;
794 gcc_assert (total_dim
== as
->rank
);
798 /* Generate code to allocate an array temporary, or create a variable to
799 hold the data. If size is NULL, zero the descriptor so that the
800 callee will allocate the array. If DEALLOC is true, also generate code to
801 free the array afterwards.
803 If INITIAL is not NULL, it is packed using internal_pack and the result used
804 as data instead of allocating a fresh, unitialized area of memory.
806 Initialization code is added to PRE and finalization code to POST.
807 DYNAMIC is true if the caller may want to extend the array later
808 using realloc. This prevents us from putting the array on the stack. */
811 gfc_trans_allocate_array_storage (stmtblock_t
* pre
, stmtblock_t
* post
,
812 gfc_array_info
* info
, tree size
, tree nelem
,
813 tree initial
, bool dynamic
, bool dealloc
)
819 desc
= info
->descriptor
;
820 info
->offset
= gfc_index_zero_node
;
821 if (size
== NULL_TREE
|| integer_zerop (size
))
823 /* A callee allocated array. */
824 gfc_conv_descriptor_data_set (pre
, desc
, null_pointer_node
);
829 /* Allocate the temporary. */
830 onstack
= !dynamic
&& initial
== NULL_TREE
831 && (flag_stack_arrays
832 || gfc_can_put_var_on_stack (size
));
836 /* Make a temporary variable to hold the data. */
837 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (nelem
),
838 nelem
, gfc_index_one_node
);
839 tmp
= gfc_evaluate_now (tmp
, pre
);
840 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
842 tmp
= build_array_type (gfc_get_element_type (TREE_TYPE (desc
)),
844 tmp
= gfc_create_var (tmp
, "A");
845 /* If we're here only because of -fstack-arrays we have to
846 emit a DECL_EXPR to make the gimplifier emit alloca calls. */
847 if (!gfc_can_put_var_on_stack (size
))
848 gfc_add_expr_to_block (pre
,
849 fold_build1_loc (input_location
,
850 DECL_EXPR
, TREE_TYPE (tmp
),
852 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
853 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
857 /* Allocate memory to hold the data or call internal_pack. */
858 if (initial
== NULL_TREE
)
860 tmp
= gfc_call_malloc (pre
, NULL
, size
);
861 tmp
= gfc_evaluate_now (tmp
, pre
);
868 stmtblock_t do_copying
;
870 tmp
= TREE_TYPE (initial
); /* Pointer to descriptor. */
871 gcc_assert (TREE_CODE (tmp
) == POINTER_TYPE
);
872 tmp
= TREE_TYPE (tmp
); /* The descriptor itself. */
873 tmp
= gfc_get_element_type (tmp
);
874 gcc_assert (tmp
== gfc_get_element_type (TREE_TYPE (desc
)));
875 packed
= gfc_create_var (build_pointer_type (tmp
), "data");
877 tmp
= build_call_expr_loc (input_location
,
878 gfor_fndecl_in_pack
, 1, initial
);
879 tmp
= fold_convert (TREE_TYPE (packed
), tmp
);
880 gfc_add_modify (pre
, packed
, tmp
);
882 tmp
= build_fold_indirect_ref_loc (input_location
,
884 source_data
= gfc_conv_descriptor_data_get (tmp
);
886 /* internal_pack may return source->data without any allocation
887 or copying if it is already packed. If that's the case, we
888 need to allocate and copy manually. */
890 gfc_start_block (&do_copying
);
891 tmp
= gfc_call_malloc (&do_copying
, NULL
, size
);
892 tmp
= fold_convert (TREE_TYPE (packed
), tmp
);
893 gfc_add_modify (&do_copying
, packed
, tmp
);
894 tmp
= gfc_build_memcpy_call (packed
, source_data
, size
);
895 gfc_add_expr_to_block (&do_copying
, tmp
);
897 was_packed
= fold_build2_loc (input_location
, EQ_EXPR
,
898 boolean_type_node
, packed
,
900 tmp
= gfc_finish_block (&do_copying
);
901 tmp
= build3_v (COND_EXPR
, was_packed
, tmp
,
902 build_empty_stmt (input_location
));
903 gfc_add_expr_to_block (pre
, tmp
);
905 tmp
= fold_convert (pvoid_type_node
, packed
);
908 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
911 info
->data
= gfc_conv_descriptor_data_get (desc
);
913 /* The offset is zero because we create temporaries with a zero
915 gfc_conv_descriptor_offset_set (pre
, desc
, gfc_index_zero_node
);
917 if (dealloc
&& !onstack
)
919 /* Free the temporary. */
920 tmp
= gfc_conv_descriptor_data_get (desc
);
921 tmp
= gfc_call_free (tmp
);
922 gfc_add_expr_to_block (post
, tmp
);
927 /* Get the scalarizer array dimension corresponding to actual array dimension
930 For example, if SS represents the array ref a(1,:,:,1), it is a
931 bidimensional scalarizer array, and the result would be 0 for ARRAY_DIM=1,
932 and 1 for ARRAY_DIM=2.
933 If SS represents transpose(a(:,1,1,:)), it is again a bidimensional
934 scalarizer array, and the result would be 1 for ARRAY_DIM=0 and 0 for
936 If SS represents sum(a(:,:,:,1), dim=1), it is a 2+1-dimensional scalarizer
937 array. If called on the inner ss, the result would be respectively 0,1,2 for
938 ARRAY_DIM=0,1,2. If called on the outer ss, the result would be 0,1
939 for ARRAY_DIM=1,2. */
942 get_scalarizer_dim_for_array_dim (gfc_ss
*ss
, int array_dim
)
949 for (; ss
; ss
= ss
->parent
)
950 for (n
= 0; n
< ss
->dimen
; n
++)
951 if (ss
->dim
[n
] < array_dim
)
954 return array_ref_dim
;
959 innermost_ss (gfc_ss
*ss
)
961 while (ss
->nested_ss
!= NULL
)
969 /* Get the array reference dimension corresponding to the given loop dimension.
970 It is different from the true array dimension given by the dim array in
971 the case of a partial array reference (i.e. a(:,:,1,:) for example)
972 It is different from the loop dimension in the case of a transposed array.
976 get_array_ref_dim_for_loop_dim (gfc_ss
*ss
, int loop_dim
)
978 return get_scalarizer_dim_for_array_dim (innermost_ss (ss
),
983 /* Generate code to create and initialize the descriptor for a temporary
984 array. This is used for both temporaries needed by the scalarizer, and
985 functions returning arrays. Adjusts the loop variables to be
986 zero-based, and calculates the loop bounds for callee allocated arrays.
987 Allocate the array unless it's callee allocated (we have a callee
988 allocated array if 'callee_alloc' is true, or if loop->to[n] is
989 NULL_TREE for any n). Also fills in the descriptor, data and offset
990 fields of info if known. Returns the size of the array, or NULL for a
991 callee allocated array.
993 'eltype' == NULL signals that the temporary should be a class object.
994 The 'initial' expression is used to obtain the size of the dynamic
995 type; otherwise the allocation and initialization proceeds as for any
998 PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
999 gfc_trans_allocate_array_storage. */
1002 gfc_trans_create_temp_array (stmtblock_t
* pre
, stmtblock_t
* post
, gfc_ss
* ss
,
1003 tree eltype
, tree initial
, bool dynamic
,
1004 bool dealloc
, bool callee_alloc
, locus
* where
)
1008 gfc_array_info
*info
;
1009 tree from
[GFC_MAX_DIMENSIONS
], to
[GFC_MAX_DIMENSIONS
];
1017 tree class_expr
= NULL_TREE
;
1018 int n
, dim
, tmp_dim
;
1021 /* This signals a class array for which we need the size of the
1022 dynamic type. Generate an eltype and then the class expression. */
1023 if (eltype
== NULL_TREE
&& initial
)
1025 gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial
)));
1026 class_expr
= build_fold_indirect_ref_loc (input_location
, initial
);
1027 eltype
= TREE_TYPE (class_expr
);
1028 eltype
= gfc_get_element_type (eltype
);
1029 /* Obtain the structure (class) expression. */
1030 class_expr
= TREE_OPERAND (class_expr
, 0);
1031 gcc_assert (class_expr
);
1034 memset (from
, 0, sizeof (from
));
1035 memset (to
, 0, sizeof (to
));
1037 info
= &ss
->info
->data
.array
;
1039 gcc_assert (ss
->dimen
> 0);
1040 gcc_assert (ss
->loop
->dimen
== ss
->dimen
);
1042 if (warn_array_temporaries
&& where
)
1043 gfc_warning (OPT_Warray_temporaries
,
1044 "Creating array temporary at %L", where
);
1046 /* Set the lower bound to zero. */
1047 for (s
= ss
; s
; s
= s
->parent
)
1051 total_dim
+= loop
->dimen
;
1052 for (n
= 0; n
< loop
->dimen
; n
++)
1056 /* Callee allocated arrays may not have a known bound yet. */
1058 loop
->to
[n
] = gfc_evaluate_now (
1059 fold_build2_loc (input_location
, MINUS_EXPR
,
1060 gfc_array_index_type
,
1061 loop
->to
[n
], loop
->from
[n
]),
1063 loop
->from
[n
] = gfc_index_zero_node
;
1065 /* We have just changed the loop bounds, we must clear the
1066 corresponding specloop, so that delta calculation is not skipped
1067 later in gfc_set_delta. */
1068 loop
->specloop
[n
] = NULL
;
1070 /* We are constructing the temporary's descriptor based on the loop
1071 dimensions. As the dimensions may be accessed in arbitrary order
1072 (think of transpose) the size taken from the n'th loop may not map
1073 to the n'th dimension of the array. We need to reconstruct loop
1074 infos in the right order before using it to set the descriptor
1076 tmp_dim
= get_scalarizer_dim_for_array_dim (ss
, dim
);
1077 from
[tmp_dim
] = loop
->from
[n
];
1078 to
[tmp_dim
] = loop
->to
[n
];
1080 info
->delta
[dim
] = gfc_index_zero_node
;
1081 info
->start
[dim
] = gfc_index_zero_node
;
1082 info
->end
[dim
] = gfc_index_zero_node
;
1083 info
->stride
[dim
] = gfc_index_one_node
;
1087 /* Initialize the descriptor. */
1089 gfc_get_array_type_bounds (eltype
, total_dim
, 0, from
, to
, 1,
1090 GFC_ARRAY_UNKNOWN
, true);
1091 desc
= gfc_create_var (type
, "atmp");
1092 GFC_DECL_PACKED_ARRAY (desc
) = 1;
1094 info
->descriptor
= desc
;
1095 size
= gfc_index_one_node
;
1097 /* Fill in the array dtype. */
1098 tmp
= gfc_conv_descriptor_dtype (desc
);
1099 gfc_add_modify (pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
1102 Fill in the bounds and stride. This is a packed array, so:
1105 for (n = 0; n < rank; n++)
1108 delta = ubound[n] + 1 - lbound[n];
1109 size = size * delta;
1111 size = size * sizeof(element);
1114 or_expr
= NULL_TREE
;
1116 /* If there is at least one null loop->to[n], it is a callee allocated
1118 for (n
= 0; n
< total_dim
; n
++)
1119 if (to
[n
] == NULL_TREE
)
1125 if (size
== NULL_TREE
)
1126 for (s
= ss
; s
; s
= s
->parent
)
1127 for (n
= 0; n
< s
->loop
->dimen
; n
++)
1129 dim
= get_scalarizer_dim_for_array_dim (ss
, s
->dim
[n
]);
1131 /* For a callee allocated array express the loop bounds in terms
1132 of the descriptor fields. */
1133 tmp
= fold_build2_loc (input_location
,
1134 MINUS_EXPR
, gfc_array_index_type
,
1135 gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]),
1136 gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]));
1137 s
->loop
->to
[n
] = tmp
;
1141 for (n
= 0; n
< total_dim
; n
++)
1143 /* Store the stride and bound components in the descriptor. */
1144 gfc_conv_descriptor_stride_set (pre
, desc
, gfc_rank_cst
[n
], size
);
1146 gfc_conv_descriptor_lbound_set (pre
, desc
, gfc_rank_cst
[n
],
1147 gfc_index_zero_node
);
1149 gfc_conv_descriptor_ubound_set (pre
, desc
, gfc_rank_cst
[n
], to
[n
]);
1151 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1152 gfc_array_index_type
,
1153 to
[n
], gfc_index_one_node
);
1155 /* Check whether the size for this dimension is negative. */
1156 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
1157 tmp
, gfc_index_zero_node
);
1158 cond
= gfc_evaluate_now (cond
, pre
);
1163 or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1164 boolean_type_node
, or_expr
, cond
);
1166 size
= fold_build2_loc (input_location
, MULT_EXPR
,
1167 gfc_array_index_type
, size
, tmp
);
1168 size
= gfc_evaluate_now (size
, pre
);
1172 /* Get the size of the array. */
1173 if (size
&& !callee_alloc
)
1176 /* If or_expr is true, then the extent in at least one
1177 dimension is zero and the size is set to zero. */
1178 size
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
1179 or_expr
, gfc_index_zero_node
, size
);
1182 if (class_expr
== NULL_TREE
)
1183 elemsize
= fold_convert (gfc_array_index_type
,
1184 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
1186 elemsize
= gfc_class_vtab_size_get (class_expr
);
1188 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
1197 gfc_trans_allocate_array_storage (pre
, post
, info
, size
, nelem
, initial
,
1203 if (ss
->dimen
> ss
->loop
->temp_dim
)
1204 ss
->loop
->temp_dim
= ss
->dimen
;
1210 /* Return the number of iterations in a loop that starts at START,
1211 ends at END, and has step STEP. */
1214 gfc_get_iteration_count (tree start
, tree end
, tree step
)
1219 type
= TREE_TYPE (step
);
1220 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, end
, start
);
1221 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
, type
, tmp
, step
);
1222 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
,
1223 build_int_cst (type
, 1));
1224 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, type
, tmp
,
1225 build_int_cst (type
, 0));
1226 return fold_convert (gfc_array_index_type
, tmp
);
1230 /* Extend the data in array DESC by EXTRA elements. */
1233 gfc_grow_array (stmtblock_t
* pblock
, tree desc
, tree extra
)
1240 if (integer_zerop (extra
))
1243 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[0]);
1245 /* Add EXTRA to the upper bound. */
1246 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1248 gfc_conv_descriptor_ubound_set (pblock
, desc
, gfc_rank_cst
[0], tmp
);
1250 /* Get the value of the current data pointer. */
1251 arg0
= gfc_conv_descriptor_data_get (desc
);
1253 /* Calculate the new array size. */
1254 size
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
1255 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1256 ubound
, gfc_index_one_node
);
1257 arg1
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
1258 fold_convert (size_type_node
, tmp
),
1259 fold_convert (size_type_node
, size
));
1261 /* Call the realloc() function. */
1262 tmp
= gfc_call_realloc (pblock
, arg0
, arg1
);
1263 gfc_conv_descriptor_data_set (pblock
, desc
, tmp
);
1267 /* Return true if the bounds of iterator I can only be determined
1271 gfc_iterator_has_dynamic_bounds (gfc_iterator
* i
)
1273 return (i
->start
->expr_type
!= EXPR_CONSTANT
1274 || i
->end
->expr_type
!= EXPR_CONSTANT
1275 || i
->step
->expr_type
!= EXPR_CONSTANT
);
1279 /* Split the size of constructor element EXPR into the sum of two terms,
1280 one of which can be determined at compile time and one of which must
1281 be calculated at run time. Set *SIZE to the former and return true
1282 if the latter might be nonzero. */
1285 gfc_get_array_constructor_element_size (mpz_t
* size
, gfc_expr
* expr
)
1287 if (expr
->expr_type
== EXPR_ARRAY
)
1288 return gfc_get_array_constructor_size (size
, expr
->value
.constructor
);
1289 else if (expr
->rank
> 0)
1291 /* Calculate everything at run time. */
1292 mpz_set_ui (*size
, 0);
1297 /* A single element. */
1298 mpz_set_ui (*size
, 1);
1304 /* Like gfc_get_array_constructor_element_size, but applied to the whole
1305 of array constructor C. */
1308 gfc_get_array_constructor_size (mpz_t
* size
, gfc_constructor_base base
)
1316 mpz_set_ui (*size
, 0);
1321 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1324 if (i
&& gfc_iterator_has_dynamic_bounds (i
))
1328 dynamic
|= gfc_get_array_constructor_element_size (&len
, c
->expr
);
1331 /* Multiply the static part of the element size by the
1332 number of iterations. */
1333 mpz_sub (val
, i
->end
->value
.integer
, i
->start
->value
.integer
);
1334 mpz_fdiv_q (val
, val
, i
->step
->value
.integer
);
1335 mpz_add_ui (val
, val
, 1);
1336 if (mpz_sgn (val
) > 0)
1337 mpz_mul (len
, len
, val
);
1339 mpz_set_ui (len
, 0);
1341 mpz_add (*size
, *size
, len
);
1350 /* Make sure offset is a variable. */
1353 gfc_put_offset_into_var (stmtblock_t
* pblock
, tree
* poffset
,
1356 /* We should have already created the offset variable. We cannot
1357 create it here because we may be in an inner scope. */
1358 gcc_assert (*offsetvar
!= NULL_TREE
);
1359 gfc_add_modify (pblock
, *offsetvar
, *poffset
);
1360 *poffset
= *offsetvar
;
1361 TREE_USED (*offsetvar
) = 1;
1365 /* Variables needed for bounds-checking. */
1366 static bool first_len
;
1367 static tree first_len_val
;
1368 static bool typespec_chararray_ctor
;
1371 gfc_trans_array_ctor_element (stmtblock_t
* pblock
, tree desc
,
1372 tree offset
, gfc_se
* se
, gfc_expr
* expr
)
1376 gfc_conv_expr (se
, expr
);
1378 /* Store the value. */
1379 tmp
= build_fold_indirect_ref_loc (input_location
,
1380 gfc_conv_descriptor_data_get (desc
));
1381 tmp
= gfc_build_array_ref (tmp
, offset
, NULL
);
1383 if (expr
->ts
.type
== BT_CHARACTER
)
1385 int i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
1388 esize
= size_in_bytes (gfc_get_element_type (TREE_TYPE (desc
)));
1389 esize
= fold_convert (gfc_charlen_type_node
, esize
);
1390 esize
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1391 gfc_charlen_type_node
, esize
,
1392 build_int_cst (gfc_charlen_type_node
,
1393 gfc_character_kinds
[i
].bit_size
/ 8));
1395 gfc_conv_string_parameter (se
);
1396 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
1398 /* The temporary is an array of pointers. */
1399 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1400 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1404 /* The temporary is an array of string values. */
1405 tmp
= gfc_build_addr_expr (gfc_get_pchar_type (expr
->ts
.kind
), tmp
);
1406 /* We know the temporary and the value will be the same length,
1407 so can use memcpy. */
1408 gfc_trans_string_copy (&se
->pre
, esize
, tmp
, expr
->ts
.kind
,
1409 se
->string_length
, se
->expr
, expr
->ts
.kind
);
1411 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && !typespec_chararray_ctor
)
1415 gfc_add_modify (&se
->pre
, first_len_val
,
1421 /* Verify that all constructor elements are of the same
1423 tree cond
= fold_build2_loc (input_location
, NE_EXPR
,
1424 boolean_type_node
, first_len_val
,
1426 gfc_trans_runtime_check
1427 (true, false, cond
, &se
->pre
, &expr
->where
,
1428 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1429 fold_convert (long_integer_type_node
, first_len_val
),
1430 fold_convert (long_integer_type_node
, se
->string_length
));
1436 /* TODO: Should the frontend already have done this conversion? */
1437 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1438 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1441 gfc_add_block_to_block (pblock
, &se
->pre
);
1442 gfc_add_block_to_block (pblock
, &se
->post
);
1446 /* Add the contents of an array to the constructor. DYNAMIC is as for
1447 gfc_trans_array_constructor_value. */
1450 gfc_trans_array_constructor_subarray (stmtblock_t
* pblock
,
1451 tree type ATTRIBUTE_UNUSED
,
1452 tree desc
, gfc_expr
* expr
,
1453 tree
* poffset
, tree
* offsetvar
,
1464 /* We need this to be a variable so we can increment it. */
1465 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1467 gfc_init_se (&se
, NULL
);
1469 /* Walk the array expression. */
1470 ss
= gfc_walk_expr (expr
);
1471 gcc_assert (ss
!= gfc_ss_terminator
);
1473 /* Initialize the scalarizer. */
1474 gfc_init_loopinfo (&loop
);
1475 gfc_add_ss_to_loop (&loop
, ss
);
1477 /* Initialize the loop. */
1478 gfc_conv_ss_startstride (&loop
);
1479 gfc_conv_loop_setup (&loop
, &expr
->where
);
1481 /* Make sure the constructed array has room for the new data. */
1484 /* Set SIZE to the total number of elements in the subarray. */
1485 size
= gfc_index_one_node
;
1486 for (n
= 0; n
< loop
.dimen
; n
++)
1488 tmp
= gfc_get_iteration_count (loop
.from
[n
], loop
.to
[n
],
1489 gfc_index_one_node
);
1490 size
= fold_build2_loc (input_location
, MULT_EXPR
,
1491 gfc_array_index_type
, size
, tmp
);
1494 /* Grow the constructed array by SIZE elements. */
1495 gfc_grow_array (&loop
.pre
, desc
, size
);
1498 /* Make the loop body. */
1499 gfc_mark_ss_chain_used (ss
, 1);
1500 gfc_start_scalarized_body (&loop
, &body
);
1501 gfc_copy_loopinfo_to_se (&se
, &loop
);
1504 gfc_trans_array_ctor_element (&body
, desc
, *poffset
, &se
, expr
);
1505 gcc_assert (se
.ss
== gfc_ss_terminator
);
1507 /* Increment the offset. */
1508 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1509 *poffset
, gfc_index_one_node
);
1510 gfc_add_modify (&body
, *poffset
, tmp
);
1512 /* Finish the loop. */
1513 gfc_trans_scalarizing_loops (&loop
, &body
);
1514 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
1515 tmp
= gfc_finish_block (&loop
.pre
);
1516 gfc_add_expr_to_block (pblock
, tmp
);
1518 gfc_cleanup_loop (&loop
);
1522 /* Assign the values to the elements of an array constructor. DYNAMIC
1523 is true if descriptor DESC only contains enough data for the static
1524 size calculated by gfc_get_array_constructor_size. When true, memory
1525 for the dynamic parts must be allocated using realloc. */
1528 gfc_trans_array_constructor_value (stmtblock_t
* pblock
, tree type
,
1529 tree desc
, gfc_constructor_base base
,
1530 tree
* poffset
, tree
* offsetvar
,
1534 tree start
= NULL_TREE
;
1535 tree end
= NULL_TREE
;
1536 tree step
= NULL_TREE
;
1542 tree shadow_loopvar
= NULL_TREE
;
1543 gfc_saved_var saved_loopvar
;
1546 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1548 /* If this is an iterator or an array, the offset must be a variable. */
1549 if ((c
->iterator
|| c
->expr
->rank
> 0) && INTEGER_CST_P (*poffset
))
1550 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1552 /* Shadowing the iterator avoids changing its value and saves us from
1553 keeping track of it. Further, it makes sure that there's always a
1554 backend-decl for the symbol, even if there wasn't one before,
1555 e.g. in the case of an iterator that appears in a specification
1556 expression in an interface mapping. */
1562 /* Evaluate loop bounds before substituting the loop variable
1563 in case they depend on it. Such a case is invalid, but it is
1564 not more expensive to do the right thing here.
1566 gfc_init_se (&se
, NULL
);
1567 gfc_conv_expr_val (&se
, c
->iterator
->start
);
1568 gfc_add_block_to_block (pblock
, &se
.pre
);
1569 start
= gfc_evaluate_now (se
.expr
, pblock
);
1571 gfc_init_se (&se
, NULL
);
1572 gfc_conv_expr_val (&se
, c
->iterator
->end
);
1573 gfc_add_block_to_block (pblock
, &se
.pre
);
1574 end
= gfc_evaluate_now (se
.expr
, pblock
);
1576 gfc_init_se (&se
, NULL
);
1577 gfc_conv_expr_val (&se
, c
->iterator
->step
);
1578 gfc_add_block_to_block (pblock
, &se
.pre
);
1579 step
= gfc_evaluate_now (se
.expr
, pblock
);
1581 sym
= c
->iterator
->var
->symtree
->n
.sym
;
1582 type
= gfc_typenode_for_spec (&sym
->ts
);
1584 shadow_loopvar
= gfc_create_var (type
, "shadow_loopvar");
1585 gfc_shadow_sym (sym
, shadow_loopvar
, &saved_loopvar
);
1588 gfc_start_block (&body
);
1590 if (c
->expr
->expr_type
== EXPR_ARRAY
)
1592 /* Array constructors can be nested. */
1593 gfc_trans_array_constructor_value (&body
, type
, desc
,
1594 c
->expr
->value
.constructor
,
1595 poffset
, offsetvar
, dynamic
);
1597 else if (c
->expr
->rank
> 0)
1599 gfc_trans_array_constructor_subarray (&body
, type
, desc
, c
->expr
,
1600 poffset
, offsetvar
, dynamic
);
1604 /* This code really upsets the gimplifier so don't bother for now. */
1611 while (p
&& !(p
->iterator
|| p
->expr
->expr_type
!= EXPR_CONSTANT
))
1613 p
= gfc_constructor_next (p
);
1618 /* Scalar values. */
1619 gfc_init_se (&se
, NULL
);
1620 gfc_trans_array_ctor_element (&body
, desc
, *poffset
,
1623 *poffset
= fold_build2_loc (input_location
, PLUS_EXPR
,
1624 gfc_array_index_type
,
1625 *poffset
, gfc_index_one_node
);
1629 /* Collect multiple scalar constants into a constructor. */
1630 vec
<constructor_elt
, va_gc
> *v
= NULL
;
1634 HOST_WIDE_INT idx
= 0;
1637 /* Count the number of consecutive scalar constants. */
1638 while (p
&& !(p
->iterator
1639 || p
->expr
->expr_type
!= EXPR_CONSTANT
))
1641 gfc_init_se (&se
, NULL
);
1642 gfc_conv_constant (&se
, p
->expr
);
1644 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
1645 se
.expr
= fold_convert (type
, se
.expr
);
1646 /* For constant character array constructors we build
1647 an array of pointers. */
1648 else if (POINTER_TYPE_P (type
))
1649 se
.expr
= gfc_build_addr_expr
1650 (gfc_get_pchar_type (p
->expr
->ts
.kind
),
1653 CONSTRUCTOR_APPEND_ELT (v
,
1654 build_int_cst (gfc_array_index_type
,
1658 p
= gfc_constructor_next (p
);
1661 bound
= size_int (n
- 1);
1662 /* Create an array type to hold them. */
1663 tmptype
= build_range_type (gfc_array_index_type
,
1664 gfc_index_zero_node
, bound
);
1665 tmptype
= build_array_type (type
, tmptype
);
1667 init
= build_constructor (tmptype
, v
);
1668 TREE_CONSTANT (init
) = 1;
1669 TREE_STATIC (init
) = 1;
1670 /* Create a static variable to hold the data. */
1671 tmp
= gfc_create_var (tmptype
, "data");
1672 TREE_STATIC (tmp
) = 1;
1673 TREE_CONSTANT (tmp
) = 1;
1674 TREE_READONLY (tmp
) = 1;
1675 DECL_INITIAL (tmp
) = init
;
1678 /* Use BUILTIN_MEMCPY to assign the values. */
1679 tmp
= gfc_conv_descriptor_data_get (desc
);
1680 tmp
= build_fold_indirect_ref_loc (input_location
,
1682 tmp
= gfc_build_array_ref (tmp
, *poffset
, NULL
);
1683 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1684 init
= gfc_build_addr_expr (NULL_TREE
, init
);
1686 size
= TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type
));
1687 bound
= build_int_cst (size_type_node
, n
* size
);
1688 tmp
= build_call_expr_loc (input_location
,
1689 builtin_decl_explicit (BUILT_IN_MEMCPY
),
1690 3, tmp
, init
, bound
);
1691 gfc_add_expr_to_block (&body
, tmp
);
1693 *poffset
= fold_build2_loc (input_location
, PLUS_EXPR
,
1694 gfc_array_index_type
, *poffset
,
1695 build_int_cst (gfc_array_index_type
, n
));
1697 if (!INTEGER_CST_P (*poffset
))
1699 gfc_add_modify (&body
, *offsetvar
, *poffset
);
1700 *poffset
= *offsetvar
;
1704 /* The frontend should already have done any expansions
1708 /* Pass the code as is. */
1709 tmp
= gfc_finish_block (&body
);
1710 gfc_add_expr_to_block (pblock
, tmp
);
1714 /* Build the implied do-loop. */
1715 stmtblock_t implied_do_block
;
1721 loopbody
= gfc_finish_block (&body
);
1723 /* Create a new block that holds the implied-do loop. A temporary
1724 loop-variable is used. */
1725 gfc_start_block(&implied_do_block
);
1727 /* Initialize the loop. */
1728 gfc_add_modify (&implied_do_block
, shadow_loopvar
, start
);
1730 /* If this array expands dynamically, and the number of iterations
1731 is not constant, we won't have allocated space for the static
1732 part of C->EXPR's size. Do that now. */
1733 if (dynamic
&& gfc_iterator_has_dynamic_bounds (c
->iterator
))
1735 /* Get the number of iterations. */
1736 tmp
= gfc_get_iteration_count (shadow_loopvar
, end
, step
);
1738 /* Get the static part of C->EXPR's size. */
1739 gfc_get_array_constructor_element_size (&size
, c
->expr
);
1740 tmp2
= gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
1742 /* Grow the array by TMP * TMP2 elements. */
1743 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
1744 gfc_array_index_type
, tmp
, tmp2
);
1745 gfc_grow_array (&implied_do_block
, desc
, tmp
);
1748 /* Generate the loop body. */
1749 exit_label
= gfc_build_label_decl (NULL_TREE
);
1750 gfc_start_block (&body
);
1752 /* Generate the exit condition. Depending on the sign of
1753 the step variable we have to generate the correct
1755 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1756 step
, build_int_cst (TREE_TYPE (step
), 0));
1757 cond
= fold_build3_loc (input_location
, COND_EXPR
,
1758 boolean_type_node
, tmp
,
1759 fold_build2_loc (input_location
, GT_EXPR
,
1760 boolean_type_node
, shadow_loopvar
, end
),
1761 fold_build2_loc (input_location
, LT_EXPR
,
1762 boolean_type_node
, shadow_loopvar
, end
));
1763 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1764 TREE_USED (exit_label
) = 1;
1765 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
1766 build_empty_stmt (input_location
));
1767 gfc_add_expr_to_block (&body
, tmp
);
1769 /* The main loop body. */
1770 gfc_add_expr_to_block (&body
, loopbody
);
1772 /* Increase loop variable by step. */
1773 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1774 TREE_TYPE (shadow_loopvar
), shadow_loopvar
,
1776 gfc_add_modify (&body
, shadow_loopvar
, tmp
);
1778 /* Finish the loop. */
1779 tmp
= gfc_finish_block (&body
);
1780 tmp
= build1_v (LOOP_EXPR
, tmp
);
1781 gfc_add_expr_to_block (&implied_do_block
, tmp
);
1783 /* Add the exit label. */
1784 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1785 gfc_add_expr_to_block (&implied_do_block
, tmp
);
1787 /* Finish the implied-do loop. */
1788 tmp
= gfc_finish_block(&implied_do_block
);
1789 gfc_add_expr_to_block(pblock
, tmp
);
1791 gfc_restore_sym (c
->iterator
->var
->symtree
->n
.sym
, &saved_loopvar
);
1798 /* The array constructor code can create a string length with an operand
1799 in the form of a temporary variable. This variable will retain its
1800 context (current_function_decl). If we store this length tree in a
1801 gfc_charlen structure which is shared by a variable in another
1802 context, the resulting gfc_charlen structure with a variable in a
1803 different context, we could trip the assertion in expand_expr_real_1
1804 when it sees that a variable has been created in one context and
1805 referenced in another.
1807 If this might be the case, we create a new gfc_charlen structure and
1808 link it into the current namespace. */
1811 store_backend_decl (gfc_charlen
**clp
, tree len
, bool force_new_cl
)
1815 gfc_charlen
*new_cl
= gfc_new_charlen (gfc_current_ns
, *clp
);
1818 (*clp
)->backend_decl
= len
;
1821 /* A catch-all to obtain the string length for anything that is not
1822 a substring of non-constant length, a constant, array or variable. */
1825 get_array_ctor_all_strlen (stmtblock_t
*block
, gfc_expr
*e
, tree
*len
)
1829 /* Don't bother if we already know the length is a constant. */
1830 if (*len
&& INTEGER_CST_P (*len
))
1833 if (!e
->ref
&& e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
1834 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1837 gfc_conv_const_charlen (e
->ts
.u
.cl
);
1838 *len
= e
->ts
.u
.cl
->backend_decl
;
1842 /* Otherwise, be brutal even if inefficient. */
1843 gfc_init_se (&se
, NULL
);
1845 /* No function call, in case of side effects. */
1846 se
.no_function_call
= 1;
1848 gfc_conv_expr (&se
, e
);
1850 gfc_conv_expr_descriptor (&se
, e
);
1852 /* Fix the value. */
1853 *len
= gfc_evaluate_now (se
.string_length
, &se
.pre
);
1855 gfc_add_block_to_block (block
, &se
.pre
);
1856 gfc_add_block_to_block (block
, &se
.post
);
1858 store_backend_decl (&e
->ts
.u
.cl
, *len
, true);
1863 /* Figure out the string length of a variable reference expression.
1864 Used by get_array_ctor_strlen. */
1867 get_array_ctor_var_strlen (stmtblock_t
*block
, gfc_expr
* expr
, tree
* len
)
1873 /* Don't bother if we already know the length is a constant. */
1874 if (*len
&& INTEGER_CST_P (*len
))
1877 ts
= &expr
->symtree
->n
.sym
->ts
;
1878 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1883 /* Array references don't change the string length. */
1887 /* Use the length of the component. */
1888 ts
= &ref
->u
.c
.component
->ts
;
1892 if (ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1893 || ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1895 /* Note that this might evaluate expr. */
1896 get_array_ctor_all_strlen (block
, expr
, len
);
1899 mpz_init_set_ui (char_len
, 1);
1900 mpz_add (char_len
, char_len
, ref
->u
.ss
.end
->value
.integer
);
1901 mpz_sub (char_len
, char_len
, ref
->u
.ss
.start
->value
.integer
);
1902 *len
= gfc_conv_mpz_to_tree (char_len
, gfc_default_integer_kind
);
1903 *len
= convert (gfc_charlen_type_node
, *len
);
1904 mpz_clear (char_len
);
1912 *len
= ts
->u
.cl
->backend_decl
;
1916 /* Figure out the string length of a character array constructor.
1917 If len is NULL, don't calculate the length; this happens for recursive calls
1918 when a sub-array-constructor is an element but not at the first position,
1919 so when we're not interested in the length.
1920 Returns TRUE if all elements are character constants. */
1923 get_array_ctor_strlen (stmtblock_t
*block
, gfc_constructor_base base
, tree
* len
)
1930 if (gfc_constructor_first (base
) == NULL
)
1933 *len
= build_int_cstu (gfc_charlen_type_node
, 0);
1937 /* Loop over all constructor elements to find out is_const, but in len we
1938 want to store the length of the first, not the last, element. We can
1939 of course exit the loop as soon as is_const is found to be false. */
1940 for (c
= gfc_constructor_first (base
);
1941 c
&& is_const
; c
= gfc_constructor_next (c
))
1943 switch (c
->expr
->expr_type
)
1946 if (len
&& !(*len
&& INTEGER_CST_P (*len
)))
1947 *len
= build_int_cstu (gfc_charlen_type_node
,
1948 c
->expr
->value
.character
.length
);
1952 if (!get_array_ctor_strlen (block
, c
->expr
->value
.constructor
, len
))
1959 get_array_ctor_var_strlen (block
, c
->expr
, len
);
1965 get_array_ctor_all_strlen (block
, c
->expr
, len
);
1969 /* After the first iteration, we don't want the length modified. */
1976 /* Check whether the array constructor C consists entirely of constant
1977 elements, and if so returns the number of those elements, otherwise
1978 return zero. Note, an empty or NULL array constructor returns zero. */
1980 unsigned HOST_WIDE_INT
1981 gfc_constant_array_constructor_p (gfc_constructor_base base
)
1983 unsigned HOST_WIDE_INT nelem
= 0;
1985 gfc_constructor
*c
= gfc_constructor_first (base
);
1989 || c
->expr
->rank
> 0
1990 || c
->expr
->expr_type
!= EXPR_CONSTANT
)
1992 c
= gfc_constructor_next (c
);
1999 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
2000 and the tree type of it's elements, TYPE, return a static constant
2001 variable that is compile-time initialized. */
2004 gfc_build_constant_array_constructor (gfc_expr
* expr
, tree type
)
2006 tree tmptype
, init
, tmp
;
2007 HOST_WIDE_INT nelem
;
2012 vec
<constructor_elt
, va_gc
> *v
= NULL
;
2014 /* First traverse the constructor list, converting the constants
2015 to tree to build an initializer. */
2017 c
= gfc_constructor_first (expr
->value
.constructor
);
2020 gfc_init_se (&se
, NULL
);
2021 gfc_conv_constant (&se
, c
->expr
);
2022 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
2023 se
.expr
= fold_convert (type
, se
.expr
);
2024 else if (POINTER_TYPE_P (type
))
2025 se
.expr
= gfc_build_addr_expr (gfc_get_pchar_type (c
->expr
->ts
.kind
),
2027 CONSTRUCTOR_APPEND_ELT (v
, build_int_cst (gfc_array_index_type
, nelem
),
2029 c
= gfc_constructor_next (c
);
2033 /* Next determine the tree type for the array. We use the gfortran
2034 front-end's gfc_get_nodesc_array_type in order to create a suitable
2035 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
2037 memset (&as
, 0, sizeof (gfc_array_spec
));
2039 as
.rank
= expr
->rank
;
2040 as
.type
= AS_EXPLICIT
;
2043 as
.lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2044 as
.upper
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
2048 for (i
= 0; i
< expr
->rank
; i
++)
2050 int tmp
= (int) mpz_get_si (expr
->shape
[i
]);
2051 as
.lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2052 as
.upper
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
2056 tmptype
= gfc_get_nodesc_array_type (type
, &as
, PACKED_STATIC
, true);
2058 /* as is not needed anymore. */
2059 for (i
= 0; i
< as
.rank
+ as
.corank
; i
++)
2061 gfc_free_expr (as
.lower
[i
]);
2062 gfc_free_expr (as
.upper
[i
]);
2065 init
= build_constructor (tmptype
, v
);
2067 TREE_CONSTANT (init
) = 1;
2068 TREE_STATIC (init
) = 1;
2070 tmp
= build_decl (input_location
, VAR_DECL
, create_tmp_var_name ("A"),
2072 DECL_ARTIFICIAL (tmp
) = 1;
2073 DECL_IGNORED_P (tmp
) = 1;
2074 TREE_STATIC (tmp
) = 1;
2075 TREE_CONSTANT (tmp
) = 1;
2076 TREE_READONLY (tmp
) = 1;
2077 DECL_INITIAL (tmp
) = init
;
2084 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
2085 This mostly initializes the scalarizer state info structure with the
2086 appropriate values to directly use the array created by the function
2087 gfc_build_constant_array_constructor. */
2090 trans_constant_array_constructor (gfc_ss
* ss
, tree type
)
2092 gfc_array_info
*info
;
2096 tmp
= gfc_build_constant_array_constructor (ss
->info
->expr
, type
);
2098 info
= &ss
->info
->data
.array
;
2100 info
->descriptor
= tmp
;
2101 info
->data
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2102 info
->offset
= gfc_index_zero_node
;
2104 for (i
= 0; i
< ss
->dimen
; i
++)
2106 info
->delta
[i
] = gfc_index_zero_node
;
2107 info
->start
[i
] = gfc_index_zero_node
;
2108 info
->end
[i
] = gfc_index_zero_node
;
2109 info
->stride
[i
] = gfc_index_one_node
;
2115 get_rank (gfc_loopinfo
*loop
)
2120 for (; loop
; loop
= loop
->parent
)
2121 rank
+= loop
->dimen
;
2127 /* Helper routine of gfc_trans_array_constructor to determine if the
2128 bounds of the loop specified by LOOP are constant and simple enough
2129 to use with trans_constant_array_constructor. Returns the
2130 iteration count of the loop if suitable, and NULL_TREE otherwise. */
2133 constant_array_constructor_loop_size (gfc_loopinfo
* l
)
2136 tree size
= gfc_index_one_node
;
2140 total_dim
= get_rank (l
);
2142 for (loop
= l
; loop
; loop
= loop
->parent
)
2144 for (i
= 0; i
< loop
->dimen
; i
++)
2146 /* If the bounds aren't constant, return NULL_TREE. */
2147 if (!INTEGER_CST_P (loop
->from
[i
]) || !INTEGER_CST_P (loop
->to
[i
]))
2149 if (!integer_zerop (loop
->from
[i
]))
2151 /* Only allow nonzero "from" in one-dimensional arrays. */
2154 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2155 gfc_array_index_type
,
2156 loop
->to
[i
], loop
->from
[i
]);
2160 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2161 gfc_array_index_type
, tmp
, gfc_index_one_node
);
2162 size
= fold_build2_loc (input_location
, MULT_EXPR
,
2163 gfc_array_index_type
, size
, tmp
);
2172 get_loop_upper_bound_for_array (gfc_ss
*array
, int array_dim
)
2177 gcc_assert (array
->nested_ss
== NULL
);
2179 for (ss
= array
; ss
; ss
= ss
->parent
)
2180 for (n
= 0; n
< ss
->loop
->dimen
; n
++)
2181 if (array_dim
== get_array_ref_dim_for_loop_dim (ss
, n
))
2182 return &(ss
->loop
->to
[n
]);
2188 static gfc_loopinfo
*
2189 outermost_loop (gfc_loopinfo
* loop
)
2191 while (loop
->parent
!= NULL
)
2192 loop
= loop
->parent
;
2198 /* Array constructors are handled by constructing a temporary, then using that
2199 within the scalarization loop. This is not optimal, but seems by far the
2203 trans_array_constructor (gfc_ss
* ss
, locus
* where
)
2205 gfc_constructor_base c
;
2213 bool old_first_len
, old_typespec_chararray_ctor
;
2214 tree old_first_len_val
;
2215 gfc_loopinfo
*loop
, *outer_loop
;
2216 gfc_ss_info
*ss_info
;
2220 /* Save the old values for nested checking. */
2221 old_first_len
= first_len
;
2222 old_first_len_val
= first_len_val
;
2223 old_typespec_chararray_ctor
= typespec_chararray_ctor
;
2226 outer_loop
= outermost_loop (loop
);
2228 expr
= ss_info
->expr
;
2230 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
2231 typespec was given for the array constructor. */
2232 typespec_chararray_ctor
= (expr
->ts
.u
.cl
2233 && expr
->ts
.u
.cl
->length_from_typespec
);
2235 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2236 && expr
->ts
.type
== BT_CHARACTER
&& !typespec_chararray_ctor
)
2238 first_len_val
= gfc_create_var (gfc_charlen_type_node
, "len");
2242 gcc_assert (ss
->dimen
== ss
->loop
->dimen
);
2244 c
= expr
->value
.constructor
;
2245 if (expr
->ts
.type
== BT_CHARACTER
)
2248 bool force_new_cl
= false;
2250 /* get_array_ctor_strlen walks the elements of the constructor, if a
2251 typespec was given, we already know the string length and want the one
2253 if (typespec_chararray_ctor
&& expr
->ts
.u
.cl
->length
2254 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
2258 const_string
= false;
2259 gfc_init_se (&length_se
, NULL
);
2260 gfc_conv_expr_type (&length_se
, expr
->ts
.u
.cl
->length
,
2261 gfc_charlen_type_node
);
2262 ss_info
->string_length
= length_se
.expr
;
2263 gfc_add_block_to_block (&outer_loop
->pre
, &length_se
.pre
);
2264 gfc_add_block_to_block (&outer_loop
->post
, &length_se
.post
);
2268 const_string
= get_array_ctor_strlen (&outer_loop
->pre
, c
,
2269 &ss_info
->string_length
);
2270 force_new_cl
= true;
2273 /* Complex character array constructors should have been taken care of
2274 and not end up here. */
2275 gcc_assert (ss_info
->string_length
);
2277 store_backend_decl (&expr
->ts
.u
.cl
, ss_info
->string_length
, force_new_cl
);
2279 type
= gfc_get_character_type_len (expr
->ts
.kind
, ss_info
->string_length
);
2281 type
= build_pointer_type (type
);
2284 type
= gfc_typenode_for_spec (&expr
->ts
);
2286 /* See if the constructor determines the loop bounds. */
2289 loop_ubound0
= get_loop_upper_bound_for_array (ss
, 0);
2291 if (expr
->shape
&& get_rank (loop
) > 1 && *loop_ubound0
== NULL_TREE
)
2293 /* We have a multidimensional parameter. */
2294 for (s
= ss
; s
; s
= s
->parent
)
2297 for (n
= 0; n
< s
->loop
->dimen
; n
++)
2299 s
->loop
->from
[n
] = gfc_index_zero_node
;
2300 s
->loop
->to
[n
] = gfc_conv_mpz_to_tree (expr
->shape
[s
->dim
[n
]],
2301 gfc_index_integer_kind
);
2302 s
->loop
->to
[n
] = fold_build2_loc (input_location
, MINUS_EXPR
,
2303 gfc_array_index_type
,
2305 gfc_index_one_node
);
2310 if (*loop_ubound0
== NULL_TREE
)
2314 /* We should have a 1-dimensional, zero-based loop. */
2315 gcc_assert (loop
->parent
== NULL
&& loop
->nested
== NULL
);
2316 gcc_assert (loop
->dimen
== 1);
2317 gcc_assert (integer_zerop (loop
->from
[0]));
2319 /* Split the constructor size into a static part and a dynamic part.
2320 Allocate the static size up-front and record whether the dynamic
2321 size might be nonzero. */
2323 dynamic
= gfc_get_array_constructor_size (&size
, c
);
2324 mpz_sub_ui (size
, size
, 1);
2325 loop
->to
[0] = gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
2329 /* Special case constant array constructors. */
2332 unsigned HOST_WIDE_INT nelem
= gfc_constant_array_constructor_p (c
);
2335 tree size
= constant_array_constructor_loop_size (loop
);
2336 if (size
&& compare_tree_int (size
, nelem
) == 0)
2338 trans_constant_array_constructor (ss
, type
);
2344 gfc_trans_create_temp_array (&outer_loop
->pre
, &outer_loop
->post
, ss
, type
,
2345 NULL_TREE
, dynamic
, true, false, where
);
2347 desc
= ss_info
->data
.array
.descriptor
;
2348 offset
= gfc_index_zero_node
;
2349 offsetvar
= gfc_create_var_np (gfc_array_index_type
, "offset");
2350 TREE_NO_WARNING (offsetvar
) = 1;
2351 TREE_USED (offsetvar
) = 0;
2352 gfc_trans_array_constructor_value (&outer_loop
->pre
, type
, desc
, c
,
2353 &offset
, &offsetvar
, dynamic
);
2355 /* If the array grows dynamically, the upper bound of the loop variable
2356 is determined by the array's final upper bound. */
2359 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2360 gfc_array_index_type
,
2361 offsetvar
, gfc_index_one_node
);
2362 tmp
= gfc_evaluate_now (tmp
, &outer_loop
->pre
);
2363 gfc_conv_descriptor_ubound_set (&loop
->pre
, desc
, gfc_rank_cst
[0], tmp
);
2364 if (*loop_ubound0
&& TREE_CODE (*loop_ubound0
) == VAR_DECL
)
2365 gfc_add_modify (&outer_loop
->pre
, *loop_ubound0
, tmp
);
2367 *loop_ubound0
= tmp
;
2370 if (TREE_USED (offsetvar
))
2371 pushdecl (offsetvar
);
2373 gcc_assert (INTEGER_CST_P (offset
));
2376 /* Disable bound checking for now because it's probably broken. */
2377 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2384 /* Restore old values of globals. */
2385 first_len
= old_first_len
;
2386 first_len_val
= old_first_len_val
;
2387 typespec_chararray_ctor
= old_typespec_chararray_ctor
;
2391 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
2392 called after evaluating all of INFO's vector dimensions. Go through
2393 each such vector dimension and see if we can now fill in any missing
2397 set_vector_loop_bounds (gfc_ss
* ss
)
2399 gfc_loopinfo
*loop
, *outer_loop
;
2400 gfc_array_info
*info
;
2408 outer_loop
= outermost_loop (ss
->loop
);
2410 info
= &ss
->info
->data
.array
;
2412 for (; ss
; ss
= ss
->parent
)
2416 for (n
= 0; n
< loop
->dimen
; n
++)
2419 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_VECTOR
2420 || loop
->to
[n
] != NULL
)
2423 /* Loop variable N indexes vector dimension DIM, and we don't
2424 yet know the upper bound of loop variable N. Set it to the
2425 difference between the vector's upper and lower bounds. */
2426 gcc_assert (loop
->from
[n
] == gfc_index_zero_node
);
2427 gcc_assert (info
->subscript
[dim
]
2428 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
2430 gfc_init_se (&se
, NULL
);
2431 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
2432 zero
= gfc_rank_cst
[0];
2433 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2434 gfc_array_index_type
,
2435 gfc_conv_descriptor_ubound_get (desc
, zero
),
2436 gfc_conv_descriptor_lbound_get (desc
, zero
));
2437 tmp
= gfc_evaluate_now (tmp
, &outer_loop
->pre
);
2444 /* Tells whether a scalar argument to an elemental procedure is saved out
2445 of a scalarization loop as a value or as a reference. */
2448 gfc_scalar_elemental_arg_saved_as_reference (gfc_ss_info
* ss_info
)
2450 if (ss_info
->type
!= GFC_SS_REFERENCE
)
2453 /* If the actual argument can be absent (in other words, it can
2454 be a NULL reference), don't try to evaluate it; pass instead
2455 the reference directly. */
2456 if (ss_info
->can_be_null_ref
)
2459 /* If the expression is of polymorphic type, it's actual size is not known,
2460 so we avoid copying it anywhere. */
2461 if (ss_info
->data
.scalar
.dummy_arg
2462 && ss_info
->data
.scalar
.dummy_arg
->ts
.type
== BT_CLASS
2463 && ss_info
->expr
->ts
.type
== BT_CLASS
)
2466 /* If the expression is a data reference of aggregate type,
2467 avoid a copy by saving a reference to the content. */
2468 if (ss_info
->expr
->expr_type
== EXPR_VARIABLE
2469 && (ss_info
->expr
->ts
.type
== BT_DERIVED
2470 || ss_info
->expr
->ts
.type
== BT_CLASS
))
2473 /* Otherwise the expression is evaluated to a temporary variable before the
2474 scalarization loop. */
2479 /* Add the pre and post chains for all the scalar expressions in a SS chain
2480 to loop. This is called after the loop parameters have been calculated,
2481 but before the actual scalarizing loops. */
2484 gfc_add_loop_ss_code (gfc_loopinfo
* loop
, gfc_ss
* ss
, bool subscript
,
2487 gfc_loopinfo
*nested_loop
, *outer_loop
;
2489 gfc_ss_info
*ss_info
;
2490 gfc_array_info
*info
;
2494 /* Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise,
2495 arguments could get evaluated multiple times. */
2496 if (ss
->is_alloc_lhs
)
2499 outer_loop
= outermost_loop (loop
);
2501 /* TODO: This can generate bad code if there are ordering dependencies,
2502 e.g., a callee allocated function and an unknown size constructor. */
2503 gcc_assert (ss
!= NULL
);
2505 for (; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2509 /* Cross loop arrays are handled from within the most nested loop. */
2510 if (ss
->nested_ss
!= NULL
)
2514 expr
= ss_info
->expr
;
2515 info
= &ss_info
->data
.array
;
2517 switch (ss_info
->type
)
2520 /* Scalar expression. Evaluate this now. This includes elemental
2521 dimension indices, but not array section bounds. */
2522 gfc_init_se (&se
, NULL
);
2523 gfc_conv_expr (&se
, expr
);
2524 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2526 if (expr
->ts
.type
!= BT_CHARACTER
2527 && !gfc_is_alloc_class_scalar_function (expr
))
2529 /* Move the evaluation of scalar expressions outside the
2530 scalarization loop, except for WHERE assignments. */
2532 se
.expr
= convert(gfc_array_index_type
, se
.expr
);
2533 if (!ss_info
->where
)
2534 se
.expr
= gfc_evaluate_now (se
.expr
, &outer_loop
->pre
);
2535 gfc_add_block_to_block (&outer_loop
->pre
, &se
.post
);
2538 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2540 ss_info
->data
.scalar
.value
= se
.expr
;
2541 ss_info
->string_length
= se
.string_length
;
2544 case GFC_SS_REFERENCE
:
2545 /* Scalar argument to elemental procedure. */
2546 gfc_init_se (&se
, NULL
);
2547 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info
))
2548 gfc_conv_expr_reference (&se
, expr
);
2551 /* Evaluate the argument outside the loop and pass
2552 a reference to the value. */
2553 gfc_conv_expr (&se
, expr
);
2556 /* Ensure that a pointer to the string is stored. */
2557 if (expr
->ts
.type
== BT_CHARACTER
)
2558 gfc_conv_string_parameter (&se
);
2560 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2561 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2562 if (gfc_is_class_scalar_expr (expr
))
2563 /* This is necessary because the dynamic type will always be
2564 large than the declared type. In consequence, assigning
2565 the value to a temporary could segfault.
2566 OOP-TODO: see if this is generally correct or is the value
2567 has to be written to an allocated temporary, whose address
2568 is passed via ss_info. */
2569 ss_info
->data
.scalar
.value
= se
.expr
;
2571 ss_info
->data
.scalar
.value
= gfc_evaluate_now (se
.expr
,
2574 ss_info
->string_length
= se
.string_length
;
2577 case GFC_SS_SECTION
:
2578 /* Add the expressions for scalar and vector subscripts. */
2579 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2580 if (info
->subscript
[n
])
2581 gfc_add_loop_ss_code (loop
, info
->subscript
[n
], true, where
);
2583 set_vector_loop_bounds (ss
);
2587 /* Get the vector's descriptor and store it in SS. */
2588 gfc_init_se (&se
, NULL
);
2589 gfc_conv_expr_descriptor (&se
, expr
);
2590 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2591 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2592 info
->descriptor
= se
.expr
;
2595 case GFC_SS_INTRINSIC
:
2596 gfc_add_intrinsic_ss_code (loop
, ss
);
2599 case GFC_SS_FUNCTION
:
2600 /* Array function return value. We call the function and save its
2601 result in a temporary for use inside the loop. */
2602 gfc_init_se (&se
, NULL
);
2605 gfc_conv_expr (&se
, expr
);
2606 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2607 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2608 ss_info
->string_length
= se
.string_length
;
2611 case GFC_SS_CONSTRUCTOR
:
2612 if (expr
->ts
.type
== BT_CHARACTER
2613 && ss_info
->string_length
== NULL
2615 && expr
->ts
.u
.cl
->length
2616 && expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2618 gfc_init_se (&se
, NULL
);
2619 gfc_conv_expr_type (&se
, expr
->ts
.u
.cl
->length
,
2620 gfc_charlen_type_node
);
2621 ss_info
->string_length
= se
.expr
;
2622 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2623 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2625 trans_array_constructor (ss
, where
);
2629 case GFC_SS_COMPONENT
:
2630 /* Do nothing. These are handled elsewhere. */
2639 for (nested_loop
= loop
->nested
; nested_loop
;
2640 nested_loop
= nested_loop
->next
)
2641 gfc_add_loop_ss_code (nested_loop
, nested_loop
->ss
, subscript
, where
);
2645 /* Translate expressions for the descriptor and data pointer of a SS. */
2649 gfc_conv_ss_descriptor (stmtblock_t
* block
, gfc_ss
* ss
, int base
)
2652 gfc_ss_info
*ss_info
;
2653 gfc_array_info
*info
;
2657 info
= &ss_info
->data
.array
;
2659 /* Get the descriptor for the array to be scalarized. */
2660 gcc_assert (ss_info
->expr
->expr_type
== EXPR_VARIABLE
);
2661 gfc_init_se (&se
, NULL
);
2662 se
.descriptor_only
= 1;
2663 gfc_conv_expr_lhs (&se
, ss_info
->expr
);
2664 gfc_add_block_to_block (block
, &se
.pre
);
2665 info
->descriptor
= se
.expr
;
2666 ss_info
->string_length
= se
.string_length
;
2670 /* Also the data pointer. */
2671 tmp
= gfc_conv_array_data (se
.expr
);
2672 /* If this is a variable or address of a variable we use it directly.
2673 Otherwise we must evaluate it now to avoid breaking dependency
2674 analysis by pulling the expressions for elemental array indices
2677 || (TREE_CODE (tmp
) == ADDR_EXPR
2678 && DECL_P (TREE_OPERAND (tmp
, 0)))))
2679 tmp
= gfc_evaluate_now (tmp
, block
);
2682 tmp
= gfc_conv_array_offset (se
.expr
);
2683 info
->offset
= gfc_evaluate_now (tmp
, block
);
2685 /* Make absolutely sure that the saved_offset is indeed saved
2686 so that the variable is still accessible after the loops
2688 info
->saved_offset
= info
->offset
;
2693 /* Initialize a gfc_loopinfo structure. */
2696 gfc_init_loopinfo (gfc_loopinfo
* loop
)
2700 memset (loop
, 0, sizeof (gfc_loopinfo
));
2701 gfc_init_block (&loop
->pre
);
2702 gfc_init_block (&loop
->post
);
2704 /* Initially scalarize in order and default to no loop reversal. */
2705 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2708 loop
->reverse
[n
] = GFC_INHIBIT_REVERSE
;
2711 loop
->ss
= gfc_ss_terminator
;
2715 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2719 gfc_copy_loopinfo_to_se (gfc_se
* se
, gfc_loopinfo
* loop
)
2725 /* Return an expression for the data pointer of an array. */
2728 gfc_conv_array_data (tree descriptor
)
2732 type
= TREE_TYPE (descriptor
);
2733 if (GFC_ARRAY_TYPE_P (type
))
2735 if (TREE_CODE (type
) == POINTER_TYPE
)
2739 /* Descriptorless arrays. */
2740 return gfc_build_addr_expr (NULL_TREE
, descriptor
);
2744 return gfc_conv_descriptor_data_get (descriptor
);
2748 /* Return an expression for the base offset of an array. */
2751 gfc_conv_array_offset (tree descriptor
)
2755 type
= TREE_TYPE (descriptor
);
2756 if (GFC_ARRAY_TYPE_P (type
))
2757 return GFC_TYPE_ARRAY_OFFSET (type
);
2759 return gfc_conv_descriptor_offset_get (descriptor
);
2763 /* Get an expression for the array stride. */
2766 gfc_conv_array_stride (tree descriptor
, int dim
)
2771 type
= TREE_TYPE (descriptor
);
2773 /* For descriptorless arrays use the array size. */
2774 tmp
= GFC_TYPE_ARRAY_STRIDE (type
, dim
);
2775 if (tmp
!= NULL_TREE
)
2778 tmp
= gfc_conv_descriptor_stride_get (descriptor
, gfc_rank_cst
[dim
]);
2783 /* Like gfc_conv_array_stride, but for the lower bound. */
2786 gfc_conv_array_lbound (tree descriptor
, int dim
)
2791 type
= TREE_TYPE (descriptor
);
2793 tmp
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
2794 if (tmp
!= NULL_TREE
)
2797 tmp
= gfc_conv_descriptor_lbound_get (descriptor
, gfc_rank_cst
[dim
]);
2802 /* Like gfc_conv_array_stride, but for the upper bound. */
2805 gfc_conv_array_ubound (tree descriptor
, int dim
)
2810 type
= TREE_TYPE (descriptor
);
2812 tmp
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
2813 if (tmp
!= NULL_TREE
)
2816 /* This should only ever happen when passing an assumed shape array
2817 as an actual parameter. The value will never be used. */
2818 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor
)))
2819 return gfc_index_zero_node
;
2821 tmp
= gfc_conv_descriptor_ubound_get (descriptor
, gfc_rank_cst
[dim
]);
2826 /* Generate code to perform an array index bound check. */
2829 trans_array_bound_check (gfc_se
* se
, gfc_ss
*ss
, tree index
, int n
,
2830 locus
* where
, bool check_upper
)
2833 tree tmp_lo
, tmp_up
;
2836 const char * name
= NULL
;
2838 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
2841 descriptor
= ss
->info
->data
.array
.descriptor
;
2843 index
= gfc_evaluate_now (index
, &se
->pre
);
2845 /* We find a name for the error message. */
2846 name
= ss
->info
->expr
->symtree
->n
.sym
->name
;
2847 gcc_assert (name
!= NULL
);
2849 if (TREE_CODE (descriptor
) == VAR_DECL
)
2850 name
= IDENTIFIER_POINTER (DECL_NAME (descriptor
));
2852 /* If upper bound is present, include both bounds in the error message. */
2855 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
2856 tmp_up
= gfc_conv_array_ubound (descriptor
, n
);
2859 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
2860 "outside of expected range (%%ld:%%ld)", n
+1, name
);
2862 msg
= xasprintf ("Index '%%ld' of dimension %d "
2863 "outside of expected range (%%ld:%%ld)", n
+1);
2865 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2867 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2868 fold_convert (long_integer_type_node
, index
),
2869 fold_convert (long_integer_type_node
, tmp_lo
),
2870 fold_convert (long_integer_type_node
, tmp_up
));
2871 fault
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2873 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2874 fold_convert (long_integer_type_node
, index
),
2875 fold_convert (long_integer_type_node
, tmp_lo
),
2876 fold_convert (long_integer_type_node
, tmp_up
));
2881 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
2884 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
2885 "below lower bound of %%ld", n
+1, name
);
2887 msg
= xasprintf ("Index '%%ld' of dimension %d "
2888 "below lower bound of %%ld", n
+1);
2890 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2892 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2893 fold_convert (long_integer_type_node
, index
),
2894 fold_convert (long_integer_type_node
, tmp_lo
));
2902 /* Return the offset for an index. Performs bound checking for elemental
2903 dimensions. Single element references are processed separately.
2904 DIM is the array dimension, I is the loop dimension. */
2907 conv_array_index_offset (gfc_se
* se
, gfc_ss
* ss
, int dim
, int i
,
2908 gfc_array_ref
* ar
, tree stride
)
2910 gfc_array_info
*info
;
2915 info
= &ss
->info
->data
.array
;
2917 /* Get the index into the array for this dimension. */
2920 gcc_assert (ar
->type
!= AR_ELEMENT
);
2921 switch (ar
->dimen_type
[dim
])
2923 case DIMEN_THIS_IMAGE
:
2927 /* Elemental dimension. */
2928 gcc_assert (info
->subscript
[dim
]
2929 && info
->subscript
[dim
]->info
->type
== GFC_SS_SCALAR
);
2930 /* We've already translated this value outside the loop. */
2931 index
= info
->subscript
[dim
]->info
->data
.scalar
.value
;
2933 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
2934 ar
->as
->type
!= AS_ASSUMED_SIZE
2935 || dim
< ar
->dimen
- 1);
2939 gcc_assert (info
&& se
->loop
);
2940 gcc_assert (info
->subscript
[dim
]
2941 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
2942 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
2944 /* Get a zero-based index into the vector. */
2945 index
= fold_build2_loc (input_location
, MINUS_EXPR
,
2946 gfc_array_index_type
,
2947 se
->loop
->loopvar
[i
], se
->loop
->from
[i
]);
2949 /* Multiply the index by the stride. */
2950 index
= fold_build2_loc (input_location
, MULT_EXPR
,
2951 gfc_array_index_type
,
2952 index
, gfc_conv_array_stride (desc
, 0));
2954 /* Read the vector to get an index into info->descriptor. */
2955 data
= build_fold_indirect_ref_loc (input_location
,
2956 gfc_conv_array_data (desc
));
2957 index
= gfc_build_array_ref (data
, index
, NULL
);
2958 index
= gfc_evaluate_now (index
, &se
->pre
);
2959 index
= fold_convert (gfc_array_index_type
, index
);
2961 /* Do any bounds checking on the final info->descriptor index. */
2962 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
2963 ar
->as
->type
!= AS_ASSUMED_SIZE
2964 || dim
< ar
->dimen
- 1);
2968 /* Scalarized dimension. */
2969 gcc_assert (info
&& se
->loop
);
2971 /* Multiply the loop variable by the stride and delta. */
2972 index
= se
->loop
->loopvar
[i
];
2973 if (!integer_onep (info
->stride
[dim
]))
2974 index
= fold_build2_loc (input_location
, MULT_EXPR
,
2975 gfc_array_index_type
, index
,
2977 if (!integer_zerop (info
->delta
[dim
]))
2978 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
2979 gfc_array_index_type
, index
,
2989 /* Temporary array or derived type component. */
2990 gcc_assert (se
->loop
);
2991 index
= se
->loop
->loopvar
[se
->loop
->order
[i
]];
2993 /* Pointer functions can have stride[0] different from unity.
2994 Use the stride returned by the function call and stored in
2995 the descriptor for the temporary. */
2996 if (se
->ss
&& se
->ss
->info
->type
== GFC_SS_FUNCTION
2997 && se
->ss
->info
->expr
2998 && se
->ss
->info
->expr
->symtree
2999 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
3000 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
->attr
.pointer
)
3001 stride
= gfc_conv_descriptor_stride_get (info
->descriptor
,
3004 if (info
->delta
[dim
] && !integer_zerop (info
->delta
[dim
]))
3005 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
3006 gfc_array_index_type
, index
, info
->delta
[dim
]);
3009 /* Multiply by the stride. */
3010 if (!integer_onep (stride
))
3011 index
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3018 /* Build a scalarized array reference using the vptr 'size'. */
3021 build_class_array_ref (gfc_se
*se
, tree base
, tree index
)
3028 gfc_expr
*expr
= se
->ss
->info
->expr
;
3034 || (expr
->ts
.type
!= BT_CLASS
3035 && !gfc_is_alloc_class_array_function (expr
)))
3038 if (expr
->symtree
&& expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
3039 ts
= &expr
->symtree
->n
.sym
->ts
;
3044 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3046 if (ref
->type
== REF_COMPONENT
3047 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
3048 && ref
->next
&& ref
->next
->type
== REF_COMPONENT
3049 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0
3051 && ref
->next
->next
->type
== REF_ARRAY
3052 && ref
->next
->next
->u
.ar
.type
!= AR_ELEMENT
)
3054 ts
= &ref
->u
.c
.component
->ts
;
3063 if (class_ref
== NULL
&& expr
->symtree
->n
.sym
->attr
.function
3064 && expr
->symtree
->n
.sym
== expr
->symtree
->n
.sym
->result
)
3066 gcc_assert (expr
->symtree
->n
.sym
->backend_decl
== current_function_decl
);
3067 decl
= gfc_get_fake_result_decl (expr
->symtree
->n
.sym
, 0);
3069 else if (gfc_is_alloc_class_array_function (expr
))
3073 for (tmp
= base
; tmp
; tmp
= TREE_OPERAND (tmp
, 0))
3076 type
= TREE_TYPE (tmp
);
3079 if (GFC_CLASS_TYPE_P (type
))
3081 if (type
!= TYPE_CANONICAL (type
))
3082 type
= TYPE_CANONICAL (type
);
3086 if (TREE_CODE (tmp
) == VAR_DECL
)
3090 if (decl
== NULL_TREE
)
3093 else if (class_ref
== NULL
)
3095 decl
= expr
->symtree
->n
.sym
->backend_decl
;
3096 /* For class arrays the tree containing the class is stored in
3097 GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl.
3098 For all others it's sym's backend_decl directly. */
3099 if (DECL_LANG_SPECIFIC (decl
) && GFC_DECL_SAVED_DESCRIPTOR (decl
))
3100 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
3104 /* Remove everything after the last class reference, convert the
3105 expression and then recover its tailend once more. */
3107 ref
= class_ref
->next
;
3108 class_ref
->next
= NULL
;
3109 gfc_init_se (&tmpse
, NULL
);
3110 gfc_conv_expr (&tmpse
, expr
);
3112 class_ref
->next
= ref
;
3115 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
3116 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
3118 if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl
)))
3121 size
= gfc_class_vtab_size_get (decl
);
3123 /* Build the address of the element. */
3124 type
= TREE_TYPE (TREE_TYPE (base
));
3125 size
= fold_convert (TREE_TYPE (index
), size
);
3126 offset
= fold_build2_loc (input_location
, MULT_EXPR
,
3127 gfc_array_index_type
,
3129 tmp
= gfc_build_addr_expr (pvoid_type_node
, base
);
3130 tmp
= fold_build_pointer_plus_loc (input_location
, tmp
, offset
);
3131 tmp
= fold_convert (build_pointer_type (type
), tmp
);
3133 /* Return the element in the se expression. */
3134 se
->expr
= build_fold_indirect_ref_loc (input_location
, tmp
);
3139 /* Build a scalarized reference to an array. */
3142 gfc_conv_scalarized_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
3144 gfc_array_info
*info
;
3145 tree decl
= NULL_TREE
;
3153 expr
= ss
->info
->expr
;
3154 info
= &ss
->info
->data
.array
;
3156 n
= se
->loop
->order
[0];
3160 index
= conv_array_index_offset (se
, ss
, ss
->dim
[n
], n
, ar
, info
->stride0
);
3161 /* Add the offset for this dimension to the stored offset for all other
3163 if (info
->offset
&& !integer_zerop (info
->offset
))
3164 index
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3165 index
, info
->offset
);
3167 if (expr
&& (is_subref_array (expr
)
3168 || (expr
->ts
.deferred
&& expr
->expr_type
== EXPR_VARIABLE
)))
3169 decl
= expr
->symtree
->n
.sym
->backend_decl
;
3171 tmp
= build_fold_indirect_ref_loc (input_location
, info
->data
);
3173 /* Use the vptr 'size' field to access a class the element of a class
3175 if (build_class_array_ref (se
, tmp
, index
))
3178 se
->expr
= gfc_build_array_ref (tmp
, index
, decl
);
3182 /* Translate access of temporary array. */
3185 gfc_conv_tmp_array_ref (gfc_se
* se
)
3187 se
->string_length
= se
->ss
->info
->string_length
;
3188 gfc_conv_scalarized_array_ref (se
, NULL
);
3189 gfc_advance_se_ss_chain (se
);
3192 /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
3195 add_to_offset (tree
*cst_offset
, tree
*offset
, tree t
)
3197 if (TREE_CODE (t
) == INTEGER_CST
)
3198 *cst_offset
= int_const_binop (PLUS_EXPR
, *cst_offset
, t
);
3201 if (!integer_zerop (*offset
))
3202 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3203 gfc_array_index_type
, *offset
, t
);
3211 build_array_ref (tree desc
, tree offset
, tree decl
, tree vptr
)
3216 bool classarray
= false;
3218 /* For class arrays the class declaration is stored in the saved
3220 if (INDIRECT_REF_P (desc
)
3221 && DECL_LANG_SPECIFIC (TREE_OPERAND (desc
, 0))
3222 && GFC_DECL_SAVED_DESCRIPTOR (TREE_OPERAND (desc
, 0)))
3223 cdecl = gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (
3224 TREE_OPERAND (desc
, 0)));
3228 /* Class container types do not always have the GFC_CLASS_TYPE_P
3229 but the canonical type does. */
3230 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdecl))
3231 && TREE_CODE (cdecl) == COMPONENT_REF
)
3233 type
= TREE_TYPE (TREE_OPERAND (cdecl, 0));
3234 if (TYPE_CANONICAL (type
)
3235 && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type
)))
3237 type
= TREE_TYPE (desc
);
3244 /* Class array references need special treatment because the assigned
3245 type size needs to be used to point to the element. */
3248 type
= gfc_get_element_type (type
);
3249 tmp
= TREE_OPERAND (cdecl, 0);
3250 tmp
= gfc_get_class_array_ref (offset
, tmp
, NULL_TREE
);
3251 tmp
= fold_convert (build_pointer_type (type
), tmp
);
3252 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3256 tmp
= gfc_conv_array_data (desc
);
3257 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3258 tmp
= gfc_build_array_ref (tmp
, offset
, decl
, vptr
);
3263 /* Build an array reference. se->expr already holds the array descriptor.
3264 This should be either a variable, indirect variable reference or component
3265 reference. For arrays which do not have a descriptor, se->expr will be
3267 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
3270 gfc_conv_array_ref (gfc_se
* se
, gfc_array_ref
* ar
, gfc_expr
*expr
,
3274 tree offset
, cst_offset
;
3279 gfc_symbol
* sym
= expr
->symtree
->n
.sym
;
3280 char *var_name
= NULL
;
3284 gcc_assert (ar
->codimen
);
3286 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
->expr
)))
3287 se
->expr
= build_fold_indirect_ref (gfc_conv_array_data (se
->expr
));
3290 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se
->expr
))
3291 && TREE_CODE (TREE_TYPE (se
->expr
)) == POINTER_TYPE
)
3292 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3294 /* Use the actual tree type and not the wrapped coarray. */
3295 if (!se
->want_pointer
)
3296 se
->expr
= fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se
->expr
)),
3303 /* Handle scalarized references separately. */
3304 if (ar
->type
!= AR_ELEMENT
)
3306 gfc_conv_scalarized_array_ref (se
, ar
);
3307 gfc_advance_se_ss_chain (se
);
3311 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3316 len
= strlen (sym
->name
) + 1;
3317 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3319 if (ref
->type
== REF_ARRAY
&& &ref
->u
.ar
== ar
)
3321 if (ref
->type
== REF_COMPONENT
)
3322 len
+= 1 + strlen (ref
->u
.c
.component
->name
);
3325 var_name
= XALLOCAVEC (char, len
);
3326 strcpy (var_name
, sym
->name
);
3328 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3330 if (ref
->type
== REF_ARRAY
&& &ref
->u
.ar
== ar
)
3332 if (ref
->type
== REF_COMPONENT
)
3334 strcat (var_name
, "%%");
3335 strcat (var_name
, ref
->u
.c
.component
->name
);
3340 cst_offset
= offset
= gfc_index_zero_node
;
3341 add_to_offset (&cst_offset
, &offset
, gfc_conv_array_offset (se
->expr
));
3343 /* Calculate the offsets from all the dimensions. Make sure to associate
3344 the final offset so that we form a chain of loop invariant summands. */
3345 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
3347 /* Calculate the index for this dimension. */
3348 gfc_init_se (&indexse
, se
);
3349 gfc_conv_expr_type (&indexse
, ar
->start
[n
], gfc_array_index_type
);
3350 gfc_add_block_to_block (&se
->pre
, &indexse
.pre
);
3352 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3354 /* Check array bounds. */
3358 /* Evaluate the indexse.expr only once. */
3359 indexse
.expr
= save_expr (indexse
.expr
);
3362 tmp
= gfc_conv_array_lbound (se
->expr
, n
);
3363 if (sym
->attr
.temporary
)
3365 gfc_init_se (&tmpse
, se
);
3366 gfc_conv_expr_type (&tmpse
, ar
->as
->lower
[n
],
3367 gfc_array_index_type
);
3368 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3372 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
3374 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3375 "below lower bound of %%ld", n
+1, var_name
);
3376 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3377 fold_convert (long_integer_type_node
,
3379 fold_convert (long_integer_type_node
, tmp
));
3382 /* Upper bound, but not for the last dimension of assumed-size
3384 if (n
< ar
->dimen
- 1 || ar
->as
->type
!= AS_ASSUMED_SIZE
)
3386 tmp
= gfc_conv_array_ubound (se
->expr
, n
);
3387 if (sym
->attr
.temporary
)
3389 gfc_init_se (&tmpse
, se
);
3390 gfc_conv_expr_type (&tmpse
, ar
->as
->upper
[n
],
3391 gfc_array_index_type
);
3392 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3396 cond
= fold_build2_loc (input_location
, GT_EXPR
,
3397 boolean_type_node
, indexse
.expr
, tmp
);
3398 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3399 "above upper bound of %%ld", n
+1, var_name
);
3400 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3401 fold_convert (long_integer_type_node
,
3403 fold_convert (long_integer_type_node
, tmp
));
3408 /* Multiply the index by the stride. */
3409 stride
= gfc_conv_array_stride (se
->expr
, n
);
3410 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3411 indexse
.expr
, stride
);
3413 /* And add it to the total. */
3414 add_to_offset (&cst_offset
, &offset
, tmp
);
3417 if (!integer_zerop (cst_offset
))
3418 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3419 gfc_array_index_type
, offset
, cst_offset
);
3421 se
->expr
= build_array_ref (se
->expr
, offset
, sym
->ts
.type
== BT_CLASS
?
3422 NULL_TREE
: sym
->backend_decl
, se
->class_vptr
);
3426 /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
3427 LOOP_DIM dimension (if any) to array's offset. */
3430 add_array_offset (stmtblock_t
*pblock
, gfc_loopinfo
*loop
, gfc_ss
*ss
,
3431 gfc_array_ref
*ar
, int array_dim
, int loop_dim
)
3434 gfc_array_info
*info
;
3437 info
= &ss
->info
->data
.array
;
3439 gfc_init_se (&se
, NULL
);
3441 se
.expr
= info
->descriptor
;
3442 stride
= gfc_conv_array_stride (info
->descriptor
, array_dim
);
3443 index
= conv_array_index_offset (&se
, ss
, array_dim
, loop_dim
, ar
, stride
);
3444 gfc_add_block_to_block (pblock
, &se
.pre
);
3446 info
->offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3447 gfc_array_index_type
,
3448 info
->offset
, index
);
3449 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
3453 /* Generate the code to be executed immediately before entering a
3454 scalarization loop. */
3457 gfc_trans_preloop_setup (gfc_loopinfo
* loop
, int dim
, int flag
,
3458 stmtblock_t
* pblock
)
3461 gfc_ss_info
*ss_info
;
3462 gfc_array_info
*info
;
3463 gfc_ss_type ss_type
;
3465 gfc_loopinfo
*ploop
;
3469 /* This code will be executed before entering the scalarization loop
3470 for this dimension. */
3471 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3475 if ((ss_info
->useflags
& flag
) == 0)
3478 ss_type
= ss_info
->type
;
3479 if (ss_type
!= GFC_SS_SECTION
3480 && ss_type
!= GFC_SS_FUNCTION
3481 && ss_type
!= GFC_SS_CONSTRUCTOR
3482 && ss_type
!= GFC_SS_COMPONENT
)
3485 info
= &ss_info
->data
.array
;
3487 gcc_assert (dim
< ss
->dimen
);
3488 gcc_assert (ss
->dimen
== loop
->dimen
);
3491 ar
= &info
->ref
->u
.ar
;
3495 if (dim
== loop
->dimen
- 1 && loop
->parent
!= NULL
)
3497 /* If we are in the outermost dimension of this loop, the previous
3498 dimension shall be in the parent loop. */
3499 gcc_assert (ss
->parent
!= NULL
);
3502 ploop
= loop
->parent
;
3504 /* ss and ss->parent are about the same array. */
3505 gcc_assert (ss_info
== pss
->info
);
3513 if (dim
== loop
->dimen
- 1)
3518 /* For the time being, there is no loop reordering. */
3519 gcc_assert (i
== ploop
->order
[i
]);
3520 i
= ploop
->order
[i
];
3522 if (dim
== loop
->dimen
- 1 && loop
->parent
== NULL
)
3524 stride
= gfc_conv_array_stride (info
->descriptor
,
3525 innermost_ss (ss
)->dim
[i
]);
3527 /* Calculate the stride of the innermost loop. Hopefully this will
3528 allow the backend optimizers to do their stuff more effectively.
3530 info
->stride0
= gfc_evaluate_now (stride
, pblock
);
3532 /* For the outermost loop calculate the offset due to any
3533 elemental dimensions. It will have been initialized with the
3534 base offset of the array. */
3537 for (i
= 0; i
< ar
->dimen
; i
++)
3539 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
3542 add_array_offset (pblock
, loop
, ss
, ar
, i
, /* unused */ -1);
3547 /* Add the offset for the previous loop dimension. */
3548 add_array_offset (pblock
, ploop
, ss
, ar
, pss
->dim
[i
], i
);
3550 /* Remember this offset for the second loop. */
3551 if (dim
== loop
->temp_dim
- 1 && loop
->parent
== NULL
)
3552 info
->saved_offset
= info
->offset
;
3557 /* Start a scalarized expression. Creates a scope and declares loop
3561 gfc_start_scalarized_body (gfc_loopinfo
* loop
, stmtblock_t
* pbody
)
3567 gcc_assert (!loop
->array_parameter
);
3569 for (dim
= loop
->dimen
- 1; dim
>= 0; dim
--)
3571 n
= loop
->order
[dim
];
3573 gfc_start_block (&loop
->code
[n
]);
3575 /* Create the loop variable. */
3576 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "S");
3578 if (dim
< loop
->temp_dim
)
3582 /* Calculate values that will be constant within this loop. */
3583 gfc_trans_preloop_setup (loop
, dim
, flags
, &loop
->code
[n
]);
3585 gfc_start_block (pbody
);
3589 /* Generates the actual loop code for a scalarization loop. */
3592 gfc_trans_scalarized_loop_end (gfc_loopinfo
* loop
, int n
,
3593 stmtblock_t
* pbody
)
3604 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
3605 | OMPWS_SCALARIZER_BODY
))
3606 == (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
)
3607 && n
== loop
->dimen
- 1)
3609 /* We create an OMP_FOR construct for the outermost scalarized loop. */
3610 init
= make_tree_vec (1);
3611 cond
= make_tree_vec (1);
3612 incr
= make_tree_vec (1);
3614 /* Cycle statement is implemented with a goto. Exit statement must not
3615 be present for this loop. */
3616 exit_label
= gfc_build_label_decl (NULL_TREE
);
3617 TREE_USED (exit_label
) = 1;
3619 /* Label for cycle statements (if needed). */
3620 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3621 gfc_add_expr_to_block (pbody
, tmp
);
3623 stmt
= make_node (OMP_FOR
);
3625 TREE_TYPE (stmt
) = void_type_node
;
3626 OMP_FOR_BODY (stmt
) = loopbody
= gfc_finish_block (pbody
);
3628 OMP_FOR_CLAUSES (stmt
) = build_omp_clause (input_location
,
3629 OMP_CLAUSE_SCHEDULE
);
3630 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt
))
3631 = OMP_CLAUSE_SCHEDULE_STATIC
;
3632 if (ompws_flags
& OMPWS_NOWAIT
)
3633 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt
))
3634 = build_omp_clause (input_location
, OMP_CLAUSE_NOWAIT
);
3636 /* Initialize the loopvar. */
3637 TREE_VEC_ELT (init
, 0) = build2_v (MODIFY_EXPR
, loop
->loopvar
[n
],
3639 OMP_FOR_INIT (stmt
) = init
;
3640 /* The exit condition. */
3641 TREE_VEC_ELT (cond
, 0) = build2_loc (input_location
, LE_EXPR
,
3643 loop
->loopvar
[n
], loop
->to
[n
]);
3644 SET_EXPR_LOCATION (TREE_VEC_ELT (cond
, 0), input_location
);
3645 OMP_FOR_COND (stmt
) = cond
;
3646 /* Increment the loopvar. */
3647 tmp
= build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3648 loop
->loopvar
[n
], gfc_index_one_node
);
3649 TREE_VEC_ELT (incr
, 0) = fold_build2_loc (input_location
, MODIFY_EXPR
,
3650 void_type_node
, loop
->loopvar
[n
], tmp
);
3651 OMP_FOR_INCR (stmt
) = incr
;
3653 ompws_flags
&= ~OMPWS_CURR_SINGLEUNIT
;
3654 gfc_add_expr_to_block (&loop
->code
[n
], stmt
);
3658 bool reverse_loop
= (loop
->reverse
[n
] == GFC_REVERSE_SET
)
3659 && (loop
->temp_ss
== NULL
);
3661 loopbody
= gfc_finish_block (pbody
);
3664 std::swap (loop
->from
[n
], loop
->to
[n
]);
3666 /* Initialize the loopvar. */
3667 if (loop
->loopvar
[n
] != loop
->from
[n
])
3668 gfc_add_modify (&loop
->code
[n
], loop
->loopvar
[n
], loop
->from
[n
]);
3670 exit_label
= gfc_build_label_decl (NULL_TREE
);
3672 /* Generate the loop body. */
3673 gfc_init_block (&block
);
3675 /* The exit condition. */
3676 cond
= fold_build2_loc (input_location
, reverse_loop
? LT_EXPR
: GT_EXPR
,
3677 boolean_type_node
, loop
->loopvar
[n
], loop
->to
[n
]);
3678 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3679 TREE_USED (exit_label
) = 1;
3680 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3681 gfc_add_expr_to_block (&block
, tmp
);
3683 /* The main body. */
3684 gfc_add_expr_to_block (&block
, loopbody
);
3686 /* Increment the loopvar. */
3687 tmp
= fold_build2_loc (input_location
,
3688 reverse_loop
? MINUS_EXPR
: PLUS_EXPR
,
3689 gfc_array_index_type
, loop
->loopvar
[n
],
3690 gfc_index_one_node
);
3692 gfc_add_modify (&block
, loop
->loopvar
[n
], tmp
);
3694 /* Build the loop. */
3695 tmp
= gfc_finish_block (&block
);
3696 tmp
= build1_v (LOOP_EXPR
, tmp
);
3697 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
3699 /* Add the exit label. */
3700 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3701 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
3707 /* Finishes and generates the loops for a scalarized expression. */
3710 gfc_trans_scalarizing_loops (gfc_loopinfo
* loop
, stmtblock_t
* body
)
3715 stmtblock_t
*pblock
;
3719 /* Generate the loops. */
3720 for (dim
= 0; dim
< loop
->dimen
; dim
++)
3722 n
= loop
->order
[dim
];
3723 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
3724 loop
->loopvar
[n
] = NULL_TREE
;
3725 pblock
= &loop
->code
[n
];
3728 tmp
= gfc_finish_block (pblock
);
3729 gfc_add_expr_to_block (&loop
->pre
, tmp
);
3731 /* Clear all the used flags. */
3732 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3733 if (ss
->parent
== NULL
)
3734 ss
->info
->useflags
= 0;
3738 /* Finish the main body of a scalarized expression, and start the secondary
3742 gfc_trans_scalarized_loop_boundary (gfc_loopinfo
* loop
, stmtblock_t
* body
)
3746 stmtblock_t
*pblock
;
3750 /* We finish as many loops as are used by the temporary. */
3751 for (dim
= 0; dim
< loop
->temp_dim
- 1; dim
++)
3753 n
= loop
->order
[dim
];
3754 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
3755 loop
->loopvar
[n
] = NULL_TREE
;
3756 pblock
= &loop
->code
[n
];
3759 /* We don't want to finish the outermost loop entirely. */
3760 n
= loop
->order
[loop
->temp_dim
- 1];
3761 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
3763 /* Restore the initial offsets. */
3764 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3766 gfc_ss_type ss_type
;
3767 gfc_ss_info
*ss_info
;
3771 if ((ss_info
->useflags
& 2) == 0)
3774 ss_type
= ss_info
->type
;
3775 if (ss_type
!= GFC_SS_SECTION
3776 && ss_type
!= GFC_SS_FUNCTION
3777 && ss_type
!= GFC_SS_CONSTRUCTOR
3778 && ss_type
!= GFC_SS_COMPONENT
)
3781 ss_info
->data
.array
.offset
= ss_info
->data
.array
.saved_offset
;
3784 /* Restart all the inner loops we just finished. */
3785 for (dim
= loop
->temp_dim
- 2; dim
>= 0; dim
--)
3787 n
= loop
->order
[dim
];
3789 gfc_start_block (&loop
->code
[n
]);
3791 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "Q");
3793 gfc_trans_preloop_setup (loop
, dim
, 2, &loop
->code
[n
]);
3796 /* Start a block for the secondary copying code. */
3797 gfc_start_block (body
);
3801 /* Precalculate (either lower or upper) bound of an array section.
3802 BLOCK: Block in which the (pre)calculation code will go.
3803 BOUNDS[DIM]: Where the bound value will be stored once evaluated.
3804 VALUES[DIM]: Specified bound (NULL <=> unspecified).
3805 DESC: Array descriptor from which the bound will be picked if unspecified
3806 (either lower or upper bound according to LBOUND). */
3809 evaluate_bound (stmtblock_t
*block
, tree
*bounds
, gfc_expr
** values
,
3810 tree desc
, int dim
, bool lbound
, bool deferred
)
3813 gfc_expr
* input_val
= values
[dim
];
3814 tree
*output
= &bounds
[dim
];
3819 /* Specified section bound. */
3820 gfc_init_se (&se
, NULL
);
3821 gfc_conv_expr_type (&se
, input_val
, gfc_array_index_type
);
3822 gfc_add_block_to_block (block
, &se
.pre
);
3825 else if (deferred
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
3827 /* The gfc_conv_array_lbound () routine returns a constant zero for
3828 deferred length arrays, which in the scalarizer wreaks havoc, when
3829 copying to a (newly allocated) one-based array.
3830 Keep returning the actual result in sync for both bounds. */
3831 *output
= lbound
? gfc_conv_descriptor_lbound_get (desc
,
3833 gfc_conv_descriptor_ubound_get (desc
,
3838 /* No specific bound specified so use the bound of the array. */
3839 *output
= lbound
? gfc_conv_array_lbound (desc
, dim
) :
3840 gfc_conv_array_ubound (desc
, dim
);
3842 *output
= gfc_evaluate_now (*output
, block
);
3846 /* Calculate the lower bound of an array section. */
3849 gfc_conv_section_startstride (stmtblock_t
* block
, gfc_ss
* ss
, int dim
)
3851 gfc_expr
*stride
= NULL
;
3854 gfc_array_info
*info
;
3857 gcc_assert (ss
->info
->type
== GFC_SS_SECTION
);
3859 info
= &ss
->info
->data
.array
;
3860 ar
= &info
->ref
->u
.ar
;
3862 if (ar
->dimen_type
[dim
] == DIMEN_VECTOR
)
3864 /* We use a zero-based index to access the vector. */
3865 info
->start
[dim
] = gfc_index_zero_node
;
3866 info
->end
[dim
] = NULL
;
3867 info
->stride
[dim
] = gfc_index_one_node
;
3871 gcc_assert (ar
->dimen_type
[dim
] == DIMEN_RANGE
3872 || ar
->dimen_type
[dim
] == DIMEN_THIS_IMAGE
);
3873 desc
= info
->descriptor
;
3874 stride
= ar
->stride
[dim
];
3877 /* Calculate the start of the range. For vector subscripts this will
3878 be the range of the vector. */
3879 evaluate_bound (block
, info
->start
, ar
->start
, desc
, dim
, true,
3880 ar
->as
->type
== AS_DEFERRED
);
3882 /* Similarly calculate the end. Although this is not used in the
3883 scalarizer, it is needed when checking bounds and where the end
3884 is an expression with side-effects. */
3885 evaluate_bound (block
, info
->end
, ar
->end
, desc
, dim
, false,
3886 ar
->as
->type
== AS_DEFERRED
);
3889 /* Calculate the stride. */
3891 info
->stride
[dim
] = gfc_index_one_node
;
3894 gfc_init_se (&se
, NULL
);
3895 gfc_conv_expr_type (&se
, stride
, gfc_array_index_type
);
3896 gfc_add_block_to_block (block
, &se
.pre
);
3897 info
->stride
[dim
] = gfc_evaluate_now (se
.expr
, block
);
3902 /* Calculates the range start and stride for a SS chain. Also gets the
3903 descriptor and data pointer. The range of vector subscripts is the size
3904 of the vector. Array bounds are also checked. */
3907 gfc_conv_ss_startstride (gfc_loopinfo
* loop
)
3914 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
3917 /* Determine the rank of the loop. */
3918 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3920 switch (ss
->info
->type
)
3922 case GFC_SS_SECTION
:
3923 case GFC_SS_CONSTRUCTOR
:
3924 case GFC_SS_FUNCTION
:
3925 case GFC_SS_COMPONENT
:
3926 loop
->dimen
= ss
->dimen
;
3929 /* As usual, lbound and ubound are exceptions!. */
3930 case GFC_SS_INTRINSIC
:
3931 switch (ss
->info
->expr
->value
.function
.isym
->id
)
3933 case GFC_ISYM_LBOUND
:
3934 case GFC_ISYM_UBOUND
:
3935 case GFC_ISYM_LCOBOUND
:
3936 case GFC_ISYM_UCOBOUND
:
3937 case GFC_ISYM_THIS_IMAGE
:
3938 loop
->dimen
= ss
->dimen
;
3950 /* We should have determined the rank of the expression by now. If
3951 not, that's bad news. */
3955 /* Loop over all the SS in the chain. */
3956 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3958 gfc_ss_info
*ss_info
;
3959 gfc_array_info
*info
;
3963 expr
= ss_info
->expr
;
3964 info
= &ss_info
->data
.array
;
3966 if (expr
&& expr
->shape
&& !info
->shape
)
3967 info
->shape
= expr
->shape
;
3969 switch (ss_info
->type
)
3971 case GFC_SS_SECTION
:
3972 /* Get the descriptor for the array. If it is a cross loops array,
3973 we got the descriptor already in the outermost loop. */
3974 if (ss
->parent
== NULL
)
3975 gfc_conv_ss_descriptor (&outer_loop
->pre
, ss
,
3976 !loop
->array_parameter
);
3978 for (n
= 0; n
< ss
->dimen
; n
++)
3979 gfc_conv_section_startstride (&outer_loop
->pre
, ss
, ss
->dim
[n
]);
3982 case GFC_SS_INTRINSIC
:
3983 switch (expr
->value
.function
.isym
->id
)
3985 /* Fall through to supply start and stride. */
3986 case GFC_ISYM_LBOUND
:
3987 case GFC_ISYM_UBOUND
:
3991 /* This is the variant without DIM=... */
3992 gcc_assert (expr
->value
.function
.actual
->next
->expr
== NULL
);
3994 arg
= expr
->value
.function
.actual
->expr
;
3995 if (arg
->rank
== -1)
4000 /* The rank (hence the return value's shape) is unknown,
4001 we have to retrieve it. */
4002 gfc_init_se (&se
, NULL
);
4003 se
.descriptor_only
= 1;
4004 gfc_conv_expr (&se
, arg
);
4005 /* This is a bare variable, so there is no preliminary
4007 gcc_assert (se
.pre
.head
== NULL_TREE
4008 && se
.post
.head
== NULL_TREE
);
4009 rank
= gfc_conv_descriptor_rank (se
.expr
);
4010 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4011 gfc_array_index_type
,
4012 fold_convert (gfc_array_index_type
,
4014 gfc_index_one_node
);
4015 info
->end
[0] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
4016 info
->start
[0] = gfc_index_zero_node
;
4017 info
->stride
[0] = gfc_index_one_node
;
4020 /* Otherwise fall through GFC_SS_FUNCTION. */
4022 case GFC_ISYM_LCOBOUND
:
4023 case GFC_ISYM_UCOBOUND
:
4024 case GFC_ISYM_THIS_IMAGE
:
4031 case GFC_SS_CONSTRUCTOR
:
4032 case GFC_SS_FUNCTION
:
4033 for (n
= 0; n
< ss
->dimen
; n
++)
4035 int dim
= ss
->dim
[n
];
4037 info
->start
[dim
] = gfc_index_zero_node
;
4038 info
->end
[dim
] = gfc_index_zero_node
;
4039 info
->stride
[dim
] = gfc_index_one_node
;
4048 /* The rest is just runtime bound checking. */
4049 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
4052 tree lbound
, ubound
;
4054 tree size
[GFC_MAX_DIMENSIONS
];
4055 tree stride_pos
, stride_neg
, non_zerosized
, tmp2
, tmp3
;
4056 gfc_array_info
*info
;
4060 gfc_start_block (&block
);
4062 for (n
= 0; n
< loop
->dimen
; n
++)
4063 size
[n
] = NULL_TREE
;
4065 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4068 gfc_ss_info
*ss_info
;
4071 const char *expr_name
;
4074 if (ss_info
->type
!= GFC_SS_SECTION
)
4077 /* Catch allocatable lhs in f2003. */
4078 if (flag_realloc_lhs
&& ss
->is_alloc_lhs
)
4081 expr
= ss_info
->expr
;
4082 expr_loc
= &expr
->where
;
4083 expr_name
= expr
->symtree
->name
;
4085 gfc_start_block (&inner
);
4087 /* TODO: range checking for mapped dimensions. */
4088 info
= &ss_info
->data
.array
;
4090 /* This code only checks ranges. Elemental and vector
4091 dimensions are checked later. */
4092 for (n
= 0; n
< loop
->dimen
; n
++)
4097 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
4100 if (dim
== info
->ref
->u
.ar
.dimen
- 1
4101 && info
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
4102 check_upper
= false;
4106 /* Zero stride is not allowed. */
4107 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4108 info
->stride
[dim
], gfc_index_zero_node
);
4109 msg
= xasprintf ("Zero stride is not allowed, for dimension %d "
4110 "of array '%s'", dim
+ 1, expr_name
);
4111 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4115 desc
= info
->descriptor
;
4117 /* This is the run-time equivalent of resolve.c's
4118 check_dimension(). The logical is more readable there
4119 than it is here, with all the trees. */
4120 lbound
= gfc_conv_array_lbound (desc
, dim
);
4121 end
= info
->end
[dim
];
4123 ubound
= gfc_conv_array_ubound (desc
, dim
);
4127 /* non_zerosized is true when the selected range is not
4129 stride_pos
= fold_build2_loc (input_location
, GT_EXPR
,
4130 boolean_type_node
, info
->stride
[dim
],
4131 gfc_index_zero_node
);
4132 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
4133 info
->start
[dim
], end
);
4134 stride_pos
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4135 boolean_type_node
, stride_pos
, tmp
);
4137 stride_neg
= fold_build2_loc (input_location
, LT_EXPR
,
4139 info
->stride
[dim
], gfc_index_zero_node
);
4140 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
4141 info
->start
[dim
], end
);
4142 stride_neg
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4145 non_zerosized
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
4147 stride_pos
, stride_neg
);
4149 /* Check the start of the range against the lower and upper
4150 bounds of the array, if the range is not empty.
4151 If upper bound is present, include both bounds in the
4155 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
4157 info
->start
[dim
], lbound
);
4158 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4160 non_zerosized
, tmp
);
4161 tmp2
= fold_build2_loc (input_location
, GT_EXPR
,
4163 info
->start
[dim
], ubound
);
4164 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4166 non_zerosized
, tmp2
);
4167 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4168 "outside of expected range (%%ld:%%ld)",
4169 dim
+ 1, expr_name
);
4170 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4172 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4173 fold_convert (long_integer_type_node
, lbound
),
4174 fold_convert (long_integer_type_node
, ubound
));
4175 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4177 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4178 fold_convert (long_integer_type_node
, lbound
),
4179 fold_convert (long_integer_type_node
, ubound
));
4184 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
4186 info
->start
[dim
], lbound
);
4187 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4188 boolean_type_node
, non_zerosized
, tmp
);
4189 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4190 "below lower bound of %%ld",
4191 dim
+ 1, expr_name
);
4192 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4194 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4195 fold_convert (long_integer_type_node
, lbound
));
4199 /* Compute the last element of the range, which is not
4200 necessarily "end" (think 0:5:3, which doesn't contain 5)
4201 and check it against both lower and upper bounds. */
4203 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4204 gfc_array_index_type
, end
,
4206 tmp
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
,
4207 gfc_array_index_type
, tmp
,
4209 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4210 gfc_array_index_type
, end
, tmp
);
4211 tmp2
= fold_build2_loc (input_location
, LT_EXPR
,
4212 boolean_type_node
, tmp
, lbound
);
4213 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4214 boolean_type_node
, non_zerosized
, tmp2
);
4217 tmp3
= fold_build2_loc (input_location
, GT_EXPR
,
4218 boolean_type_node
, tmp
, ubound
);
4219 tmp3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4220 boolean_type_node
, non_zerosized
, tmp3
);
4221 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4222 "outside of expected range (%%ld:%%ld)",
4223 dim
+ 1, expr_name
);
4224 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4226 fold_convert (long_integer_type_node
, tmp
),
4227 fold_convert (long_integer_type_node
, ubound
),
4228 fold_convert (long_integer_type_node
, lbound
));
4229 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4231 fold_convert (long_integer_type_node
, tmp
),
4232 fold_convert (long_integer_type_node
, ubound
),
4233 fold_convert (long_integer_type_node
, lbound
));
4238 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4239 "below lower bound of %%ld",
4240 dim
+ 1, expr_name
);
4241 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4243 fold_convert (long_integer_type_node
, tmp
),
4244 fold_convert (long_integer_type_node
, lbound
));
4248 /* Check the section sizes match. */
4249 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4250 gfc_array_index_type
, end
,
4252 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
4253 gfc_array_index_type
, tmp
,
4255 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4256 gfc_array_index_type
,
4257 gfc_index_one_node
, tmp
);
4258 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
4259 gfc_array_index_type
, tmp
,
4260 build_int_cst (gfc_array_index_type
, 0));
4261 /* We remember the size of the first section, and check all the
4262 others against this. */
4265 tmp3
= fold_build2_loc (input_location
, NE_EXPR
,
4266 boolean_type_node
, tmp
, size
[n
]);
4267 msg
= xasprintf ("Array bound mismatch for dimension %d "
4268 "of array '%s' (%%ld/%%ld)",
4269 dim
+ 1, expr_name
);
4271 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4273 fold_convert (long_integer_type_node
, tmp
),
4274 fold_convert (long_integer_type_node
, size
[n
]));
4279 size
[n
] = gfc_evaluate_now (tmp
, &inner
);
4282 tmp
= gfc_finish_block (&inner
);
4284 /* For optional arguments, only check bounds if the argument is
4286 if (expr
->symtree
->n
.sym
->attr
.optional
4287 || expr
->symtree
->n
.sym
->attr
.not_always_present
)
4288 tmp
= build3_v (COND_EXPR
,
4289 gfc_conv_expr_present (expr
->symtree
->n
.sym
),
4290 tmp
, build_empty_stmt (input_location
));
4292 gfc_add_expr_to_block (&block
, tmp
);
4296 tmp
= gfc_finish_block (&block
);
4297 gfc_add_expr_to_block (&outer_loop
->pre
, tmp
);
4300 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4301 gfc_conv_ss_startstride (loop
);
4304 /* Return true if both symbols could refer to the same data object. Does
4305 not take account of aliasing due to equivalence statements. */
4308 symbols_could_alias (gfc_symbol
*lsym
, gfc_symbol
*rsym
, bool lsym_pointer
,
4309 bool lsym_target
, bool rsym_pointer
, bool rsym_target
)
4311 /* Aliasing isn't possible if the symbols have different base types. */
4312 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
4315 /* Pointers can point to other pointers and target objects. */
4317 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4318 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4321 /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
4322 and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
4324 if (lsym_target
&& rsym_target
4325 && ((lsym
->attr
.dummy
&& !lsym
->attr
.contiguous
4326 && (!lsym
->attr
.dimension
|| lsym
->as
->type
== AS_ASSUMED_SHAPE
))
4327 || (rsym
->attr
.dummy
&& !rsym
->attr
.contiguous
4328 && (!rsym
->attr
.dimension
4329 || rsym
->as
->type
== AS_ASSUMED_SHAPE
))))
4336 /* Return true if the two SS could be aliased, i.e. both point to the same data
4338 /* TODO: resolve aliases based on frontend expressions. */
4341 gfc_could_be_alias (gfc_ss
* lss
, gfc_ss
* rss
)
4345 gfc_expr
*lexpr
, *rexpr
;
4348 bool lsym_pointer
, lsym_target
, rsym_pointer
, rsym_target
;
4350 lexpr
= lss
->info
->expr
;
4351 rexpr
= rss
->info
->expr
;
4353 lsym
= lexpr
->symtree
->n
.sym
;
4354 rsym
= rexpr
->symtree
->n
.sym
;
4356 lsym_pointer
= lsym
->attr
.pointer
;
4357 lsym_target
= lsym
->attr
.target
;
4358 rsym_pointer
= rsym
->attr
.pointer
;
4359 rsym_target
= rsym
->attr
.target
;
4361 if (symbols_could_alias (lsym
, rsym
, lsym_pointer
, lsym_target
,
4362 rsym_pointer
, rsym_target
))
4365 if (rsym
->ts
.type
!= BT_DERIVED
&& rsym
->ts
.type
!= BT_CLASS
4366 && lsym
->ts
.type
!= BT_DERIVED
&& lsym
->ts
.type
!= BT_CLASS
)
4369 /* For derived types we must check all the component types. We can ignore
4370 array references as these will have the same base type as the previous
4372 for (lref
= lexpr
->ref
; lref
!= lss
->info
->data
.array
.ref
; lref
= lref
->next
)
4374 if (lref
->type
!= REF_COMPONENT
)
4377 lsym_pointer
= lsym_pointer
|| lref
->u
.c
.sym
->attr
.pointer
;
4378 lsym_target
= lsym_target
|| lref
->u
.c
.sym
->attr
.target
;
4380 if (symbols_could_alias (lref
->u
.c
.sym
, rsym
, lsym_pointer
, lsym_target
,
4381 rsym_pointer
, rsym_target
))
4384 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4385 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4387 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4392 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
;
4395 if (rref
->type
!= REF_COMPONENT
)
4398 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4399 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4401 if (symbols_could_alias (lref
->u
.c
.sym
, rref
->u
.c
.sym
,
4402 lsym_pointer
, lsym_target
,
4403 rsym_pointer
, rsym_target
))
4406 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4407 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4409 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4410 &rref
->u
.c
.sym
->ts
))
4412 if (gfc_compare_types (&lref
->u
.c
.sym
->ts
,
4413 &rref
->u
.c
.component
->ts
))
4415 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4416 &rref
->u
.c
.component
->ts
))
4422 lsym_pointer
= lsym
->attr
.pointer
;
4423 lsym_target
= lsym
->attr
.target
;
4424 lsym_pointer
= lsym
->attr
.pointer
;
4425 lsym_target
= lsym
->attr
.target
;
4427 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
; rref
= rref
->next
)
4429 if (rref
->type
!= REF_COMPONENT
)
4432 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4433 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4435 if (symbols_could_alias (rref
->u
.c
.sym
, lsym
,
4436 lsym_pointer
, lsym_target
,
4437 rsym_pointer
, rsym_target
))
4440 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4441 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4443 if (gfc_compare_types (&lsym
->ts
, &rref
->u
.c
.component
->ts
))
4452 /* Resolve array data dependencies. Creates a temporary if required. */
4453 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
4457 gfc_conv_resolve_dependencies (gfc_loopinfo
* loop
, gfc_ss
* dest
,
4463 gfc_expr
*dest_expr
;
4468 loop
->temp_ss
= NULL
;
4469 dest_expr
= dest
->info
->expr
;
4471 for (ss
= rss
; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
4473 ss_expr
= ss
->info
->expr
;
4475 if (ss
->info
->array_outer_dependency
)
4481 if (ss
->info
->type
!= GFC_SS_SECTION
)
4483 if (flag_realloc_lhs
4484 && dest_expr
!= ss_expr
4485 && gfc_is_reallocatable_lhs (dest_expr
)
4487 nDepend
= gfc_check_dependency (dest_expr
, ss_expr
, true);
4489 /* Check for cases like c(:)(1:2) = c(2)(2:3) */
4490 if (!nDepend
&& dest_expr
->rank
> 0
4491 && dest_expr
->ts
.type
== BT_CHARACTER
4492 && ss_expr
->expr_type
== EXPR_VARIABLE
)
4494 nDepend
= gfc_check_dependency (dest_expr
, ss_expr
, false);
4499 if (dest_expr
->symtree
->n
.sym
!= ss_expr
->symtree
->n
.sym
)
4501 if (gfc_could_be_alias (dest
, ss
)
4502 || gfc_are_equivalenced_arrays (dest_expr
, ss_expr
))
4510 lref
= dest_expr
->ref
;
4511 rref
= ss_expr
->ref
;
4513 nDepend
= gfc_dep_resolver (lref
, rref
, &loop
->reverse
[0]);
4518 for (i
= 0; i
< dest
->dimen
; i
++)
4519 for (j
= 0; j
< ss
->dimen
; j
++)
4521 && dest
->dim
[i
] == ss
->dim
[j
])
4523 /* If we don't access array elements in the same order,
4524 there is a dependency. */
4529 /* TODO : loop shifting. */
4532 /* Mark the dimensions for LOOP SHIFTING */
4533 for (n
= 0; n
< loop
->dimen
; n
++)
4535 int dim
= dest
->data
.info
.dim
[n
];
4537 if (lref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
4539 else if (! gfc_is_same_range (&lref
->u
.ar
,
4540 &rref
->u
.ar
, dim
, 0))
4544 /* Put all the dimensions with dependencies in the
4547 for (n
= 0; n
< loop
->dimen
; n
++)
4549 gcc_assert (loop
->order
[n
] == n
);
4551 loop
->order
[dim
++] = n
;
4553 for (n
= 0; n
< loop
->dimen
; n
++)
4556 loop
->order
[dim
++] = n
;
4559 gcc_assert (dim
== loop
->dimen
);
4570 tree base_type
= gfc_typenode_for_spec (&dest_expr
->ts
);
4571 if (GFC_ARRAY_TYPE_P (base_type
)
4572 || GFC_DESCRIPTOR_TYPE_P (base_type
))
4573 base_type
= gfc_get_element_type (base_type
);
4574 loop
->temp_ss
= gfc_get_temp_ss (base_type
, dest
->info
->string_length
,
4576 gfc_add_ss_to_loop (loop
, loop
->temp_ss
);
4579 loop
->temp_ss
= NULL
;
4583 /* Browse through each array's information from the scalarizer and set the loop
4584 bounds according to the "best" one (per dimension), i.e. the one which
4585 provides the most information (constant bounds, shape, etc.). */
4588 set_loop_bounds (gfc_loopinfo
*loop
)
4590 int n
, dim
, spec_dim
;
4591 gfc_array_info
*info
;
4592 gfc_array_info
*specinfo
;
4596 bool dynamic
[GFC_MAX_DIMENSIONS
];
4599 bool nonoptional_arr
;
4601 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
4603 loopspec
= loop
->specloop
;
4606 for (n
= 0; n
< loop
->dimen
; n
++)
4611 /* If there are both optional and nonoptional array arguments, scalarize
4612 over the nonoptional; otherwise, it does not matter as then all
4613 (optional) arrays have to be present per F2008, 125.2.12p3(6). */
4615 nonoptional_arr
= false;
4617 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4618 if (ss
->info
->type
!= GFC_SS_SCALAR
&& ss
->info
->type
!= GFC_SS_TEMP
4619 && ss
->info
->type
!= GFC_SS_REFERENCE
&& !ss
->info
->can_be_null_ref
)
4621 nonoptional_arr
= true;
4625 /* We use one SS term, and use that to determine the bounds of the
4626 loop for this dimension. We try to pick the simplest term. */
4627 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4629 gfc_ss_type ss_type
;
4631 ss_type
= ss
->info
->type
;
4632 if (ss_type
== GFC_SS_SCALAR
4633 || ss_type
== GFC_SS_TEMP
4634 || ss_type
== GFC_SS_REFERENCE
4635 || (ss
->info
->can_be_null_ref
&& nonoptional_arr
))
4638 info
= &ss
->info
->data
.array
;
4641 if (loopspec
[n
] != NULL
)
4643 specinfo
= &loopspec
[n
]->info
->data
.array
;
4644 spec_dim
= loopspec
[n
]->dim
[n
];
4648 /* Silence uninitialized warnings. */
4655 gcc_assert (info
->shape
[dim
]);
4656 /* The frontend has worked out the size for us. */
4659 || !integer_zerop (specinfo
->start
[spec_dim
]))
4660 /* Prefer zero-based descriptors if possible. */
4665 if (ss_type
== GFC_SS_CONSTRUCTOR
)
4667 gfc_constructor_base base
;
4668 /* An unknown size constructor will always be rank one.
4669 Higher rank constructors will either have known shape,
4670 or still be wrapped in a call to reshape. */
4671 gcc_assert (loop
->dimen
== 1);
4673 /* Always prefer to use the constructor bounds if the size
4674 can be determined at compile time. Prefer not to otherwise,
4675 since the general case involves realloc, and it's better to
4676 avoid that overhead if possible. */
4677 base
= ss
->info
->expr
->value
.constructor
;
4678 dynamic
[n
] = gfc_get_array_constructor_size (&i
, base
);
4679 if (!dynamic
[n
] || !loopspec
[n
])
4684 /* Avoid using an allocatable lhs in an assignment, since
4685 there might be a reallocation coming. */
4686 if (loopspec
[n
] && ss
->is_alloc_lhs
)
4691 /* Criteria for choosing a loop specifier (most important first):
4692 doesn't need realloc
4698 else if (loopspec
[n
]->info
->type
== GFC_SS_CONSTRUCTOR
&& dynamic
[n
])
4700 else if (integer_onep (info
->stride
[dim
])
4701 && !integer_onep (specinfo
->stride
[spec_dim
]))
4703 else if (INTEGER_CST_P (info
->stride
[dim
])
4704 && !INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
4706 else if (INTEGER_CST_P (info
->start
[dim
])
4707 && !INTEGER_CST_P (specinfo
->start
[spec_dim
])
4708 && integer_onep (info
->stride
[dim
])
4709 == integer_onep (specinfo
->stride
[spec_dim
])
4710 && INTEGER_CST_P (info
->stride
[dim
])
4711 == INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
4713 /* We don't work out the upper bound.
4714 else if (INTEGER_CST_P (info->finish[n])
4715 && ! INTEGER_CST_P (specinfo->finish[n]))
4716 loopspec[n] = ss; */
4719 /* We should have found the scalarization loop specifier. If not,
4721 gcc_assert (loopspec
[n
]);
4723 info
= &loopspec
[n
]->info
->data
.array
;
4724 dim
= loopspec
[n
]->dim
[n
];
4726 /* Set the extents of this range. */
4727 cshape
= info
->shape
;
4728 if (cshape
&& INTEGER_CST_P (info
->start
[dim
])
4729 && INTEGER_CST_P (info
->stride
[dim
]))
4731 loop
->from
[n
] = info
->start
[dim
];
4732 mpz_set (i
, cshape
[get_array_ref_dim_for_loop_dim (loopspec
[n
], n
)]);
4733 mpz_sub_ui (i
, i
, 1);
4734 /* To = from + (size - 1) * stride. */
4735 tmp
= gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
4736 if (!integer_onep (info
->stride
[dim
]))
4737 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
4738 gfc_array_index_type
, tmp
,
4740 loop
->to
[n
] = fold_build2_loc (input_location
, PLUS_EXPR
,
4741 gfc_array_index_type
,
4742 loop
->from
[n
], tmp
);
4746 loop
->from
[n
] = info
->start
[dim
];
4747 switch (loopspec
[n
]->info
->type
)
4749 case GFC_SS_CONSTRUCTOR
:
4750 /* The upper bound is calculated when we expand the
4752 gcc_assert (loop
->to
[n
] == NULL_TREE
);
4755 case GFC_SS_SECTION
:
4756 /* Use the end expression if it exists and is not constant,
4757 so that it is only evaluated once. */
4758 loop
->to
[n
] = info
->end
[dim
];
4761 case GFC_SS_FUNCTION
:
4762 /* The loop bound will be set when we generate the call. */
4763 gcc_assert (loop
->to
[n
] == NULL_TREE
);
4766 case GFC_SS_INTRINSIC
:
4768 gfc_expr
*expr
= loopspec
[n
]->info
->expr
;
4770 /* The {l,u}bound of an assumed rank. */
4771 gcc_assert ((expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
4772 || expr
->value
.function
.isym
->id
== GFC_ISYM_UBOUND
)
4773 && expr
->value
.function
.actual
->next
->expr
== NULL
4774 && expr
->value
.function
.actual
->expr
->rank
== -1);
4776 loop
->to
[n
] = info
->end
[dim
];
4785 /* Transform everything so we have a simple incrementing variable. */
4786 if (integer_onep (info
->stride
[dim
]))
4787 info
->delta
[dim
] = gfc_index_zero_node
;
4790 /* Set the delta for this section. */
4791 info
->delta
[dim
] = gfc_evaluate_now (loop
->from
[n
], &outer_loop
->pre
);
4792 /* Number of iterations is (end - start + step) / step.
4793 with start = 0, this simplifies to
4795 for (i = 0; i<=last; i++){...}; */
4796 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4797 gfc_array_index_type
, loop
->to
[n
],
4799 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
4800 gfc_array_index_type
, tmp
, info
->stride
[dim
]);
4801 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
4802 tmp
, build_int_cst (gfc_array_index_type
, -1));
4803 loop
->to
[n
] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
4804 /* Make the loop variable start at 0. */
4805 loop
->from
[n
] = gfc_index_zero_node
;
4810 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4811 set_loop_bounds (loop
);
4815 /* Initialize the scalarization loop. Creates the loop variables. Determines
4816 the range of the loop variables. Creates a temporary if required.
4817 Also generates code for scalar expressions which have been
4818 moved outside the loop. */
4821 gfc_conv_loop_setup (gfc_loopinfo
* loop
, locus
* where
)
4826 set_loop_bounds (loop
);
4828 /* Add all the scalar code that can be taken out of the loops.
4829 This may include calculating the loop bounds, so do it before
4830 allocating the temporary. */
4831 gfc_add_loop_ss_code (loop
, loop
->ss
, false, where
);
4833 tmp_ss
= loop
->temp_ss
;
4834 /* If we want a temporary then create it. */
4837 gfc_ss_info
*tmp_ss_info
;
4839 tmp_ss_info
= tmp_ss
->info
;
4840 gcc_assert (tmp_ss_info
->type
== GFC_SS_TEMP
);
4841 gcc_assert (loop
->parent
== NULL
);
4843 /* Make absolutely sure that this is a complete type. */
4844 if (tmp_ss_info
->string_length
)
4845 tmp_ss_info
->data
.temp
.type
4846 = gfc_get_character_type_len_for_eltype
4847 (TREE_TYPE (tmp_ss_info
->data
.temp
.type
),
4848 tmp_ss_info
->string_length
);
4850 tmp
= tmp_ss_info
->data
.temp
.type
;
4851 memset (&tmp_ss_info
->data
.array
, 0, sizeof (gfc_array_info
));
4852 tmp_ss_info
->type
= GFC_SS_SECTION
;
4854 gcc_assert (tmp_ss
->dimen
!= 0);
4856 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, tmp_ss
, tmp
,
4857 NULL_TREE
, false, true, false, where
);
4860 /* For array parameters we don't have loop variables, so don't calculate the
4862 if (!loop
->array_parameter
)
4863 gfc_set_delta (loop
);
4867 /* Calculates how to transform from loop variables to array indices for each
4868 array: once loop bounds are chosen, sets the difference (DELTA field) between
4869 loop bounds and array reference bounds, for each array info. */
4872 gfc_set_delta (gfc_loopinfo
*loop
)
4874 gfc_ss
*ss
, **loopspec
;
4875 gfc_array_info
*info
;
4879 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
4881 loopspec
= loop
->specloop
;
4883 /* Calculate the translation from loop variables to array indices. */
4884 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4886 gfc_ss_type ss_type
;
4888 ss_type
= ss
->info
->type
;
4889 if (ss_type
!= GFC_SS_SECTION
4890 && ss_type
!= GFC_SS_COMPONENT
4891 && ss_type
!= GFC_SS_CONSTRUCTOR
)
4894 info
= &ss
->info
->data
.array
;
4896 for (n
= 0; n
< ss
->dimen
; n
++)
4898 /* If we are specifying the range the delta is already set. */
4899 if (loopspec
[n
] != ss
)
4903 /* Calculate the offset relative to the loop variable.
4904 First multiply by the stride. */
4905 tmp
= loop
->from
[n
];
4906 if (!integer_onep (info
->stride
[dim
]))
4907 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
4908 gfc_array_index_type
,
4909 tmp
, info
->stride
[dim
]);
4911 /* Then subtract this from our starting value. */
4912 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4913 gfc_array_index_type
,
4914 info
->start
[dim
], tmp
);
4916 info
->delta
[dim
] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
4921 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4922 gfc_set_delta (loop
);
4926 /* Calculate the size of a given array dimension from the bounds. This
4927 is simply (ubound - lbound + 1) if this expression is positive
4928 or 0 if it is negative (pick either one if it is zero). Optionally
4929 (if or_expr is present) OR the (expression != 0) condition to it. */
4932 gfc_conv_array_extent_dim (tree lbound
, tree ubound
, tree
* or_expr
)
4937 /* Calculate (ubound - lbound + 1). */
4938 res
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4940 res
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
, res
,
4941 gfc_index_one_node
);
4943 /* Check whether the size for this dimension is negative. */
4944 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, res
,
4945 gfc_index_zero_node
);
4946 res
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
, cond
,
4947 gfc_index_zero_node
, res
);
4949 /* Build OR expression. */
4951 *or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
4952 boolean_type_node
, *or_expr
, cond
);
4958 /* For an array descriptor, get the total number of elements. This is just
4959 the product of the extents along from_dim to to_dim. */
4962 gfc_conv_descriptor_size_1 (tree desc
, int from_dim
, int to_dim
)
4967 res
= gfc_index_one_node
;
4969 for (dim
= from_dim
; dim
< to_dim
; ++dim
)
4975 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]);
4976 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]);
4978 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
4979 res
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4987 /* Full size of an array. */
4990 gfc_conv_descriptor_size (tree desc
, int rank
)
4992 return gfc_conv_descriptor_size_1 (desc
, 0, rank
);
4996 /* Size of a coarray for all dimensions but the last. */
4999 gfc_conv_descriptor_cosize (tree desc
, int rank
, int corank
)
5001 return gfc_conv_descriptor_size_1 (desc
, rank
, rank
+ corank
- 1);
5005 /* Fills in an array descriptor, and returns the size of the array.
5006 The size will be a simple_val, ie a variable or a constant. Also
5007 calculates the offset of the base. The pointer argument overflow,
5008 which should be of integer type, will increase in value if overflow
5009 occurs during the size calculation. Returns the size of the array.
5013 for (n = 0; n < rank; n++)
5015 a.lbound[n] = specified_lower_bound;
5016 offset = offset + a.lbond[n] * stride;
5018 a.ubound[n] = specified_upper_bound;
5019 a.stride[n] = stride;
5020 size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
5021 overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
5022 stride = stride * size;
5024 for (n = rank; n < rank+corank; n++)
5025 (Set lcobound/ucobound as above.)
5026 element_size = sizeof (array element);
5029 stride = (size_t) stride;
5030 overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
5031 stride = stride * element_size;
5037 gfc_array_init_size (tree descriptor
, int rank
, int corank
, tree
* poffset
,
5038 gfc_expr
** lower
, gfc_expr
** upper
, stmtblock_t
* pblock
,
5039 stmtblock_t
* descriptor_block
, tree
* overflow
,
5040 tree expr3_elem_size
, tree
*nelems
, gfc_expr
*expr3
,
5041 tree expr3_desc
, bool e3_is_array_constr
)
5054 stmtblock_t thenblock
;
5055 stmtblock_t elseblock
;
5060 type
= TREE_TYPE (descriptor
);
5062 stride
= gfc_index_one_node
;
5063 offset
= gfc_index_zero_node
;
5065 /* Set the dtype. */
5066 tmp
= gfc_conv_descriptor_dtype (descriptor
);
5067 gfc_add_modify (descriptor_block
, tmp
, gfc_get_dtype (type
));
5069 or_expr
= boolean_false_node
;
5071 for (n
= 0; n
< rank
; n
++)
5076 /* We have 3 possibilities for determining the size of the array:
5077 lower == NULL => lbound = 1, ubound = upper[n]
5078 upper[n] = NULL => lbound = 1, ubound = lower[n]
5079 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
5082 /* Set lower bound. */
5083 gfc_init_se (&se
, NULL
);
5084 if (expr3_desc
!= NULL_TREE
)
5086 if (e3_is_array_constr
)
5087 /* The lbound of a constant array [] starts at zero, but when
5088 allocating it, the standard expects the array to start at
5090 se
.expr
= gfc_index_one_node
;
5092 se
.expr
= gfc_conv_descriptor_lbound_get (expr3_desc
,
5095 else if (lower
== NULL
)
5096 se
.expr
= gfc_index_one_node
;
5099 gcc_assert (lower
[n
]);
5102 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
5103 gfc_add_block_to_block (pblock
, &se
.pre
);
5107 se
.expr
= gfc_index_one_node
;
5111 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
5112 gfc_rank_cst
[n
], se
.expr
);
5113 conv_lbound
= se
.expr
;
5115 /* Work out the offset for this component. */
5116 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5118 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
5119 gfc_array_index_type
, offset
, tmp
);
5121 /* Set upper bound. */
5122 gfc_init_se (&se
, NULL
);
5123 if (expr3_desc
!= NULL_TREE
)
5125 if (e3_is_array_constr
)
5127 /* The lbound of a constant array [] starts at zero, but when
5128 allocating it, the standard expects the array to start at
5129 one. Therefore fix the upper bound to be
5130 (desc.ubound - desc.lbound)+ 1. */
5131 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5132 gfc_array_index_type
,
5133 gfc_conv_descriptor_ubound_get (
5134 expr3_desc
, gfc_rank_cst
[n
]),
5135 gfc_conv_descriptor_lbound_get (
5136 expr3_desc
, gfc_rank_cst
[n
]));
5137 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5138 gfc_array_index_type
, tmp
,
5139 gfc_index_one_node
);
5140 se
.expr
= gfc_evaluate_now (tmp
, pblock
);
5143 se
.expr
= gfc_conv_descriptor_ubound_get (expr3_desc
,
5148 gcc_assert (ubound
);
5149 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
5150 gfc_add_block_to_block (pblock
, &se
.pre
);
5151 if (ubound
->expr_type
== EXPR_FUNCTION
)
5152 se
.expr
= gfc_evaluate_now (se
.expr
, pblock
);
5154 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
5155 gfc_rank_cst
[n
], se
.expr
);
5156 conv_ubound
= se
.expr
;
5158 /* Store the stride. */
5159 gfc_conv_descriptor_stride_set (descriptor_block
, descriptor
,
5160 gfc_rank_cst
[n
], stride
);
5162 /* Calculate size and check whether extent is negative. */
5163 size
= gfc_conv_array_extent_dim (conv_lbound
, conv_ubound
, &or_expr
);
5164 size
= gfc_evaluate_now (size
, pblock
);
5166 /* Check whether multiplying the stride by the number of
5167 elements in this dimension would overflow. We must also check
5168 whether the current dimension has zero size in order to avoid
5171 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
5172 gfc_array_index_type
,
5173 fold_convert (gfc_array_index_type
,
5174 TYPE_MAX_VALUE (gfc_array_index_type
)),
5176 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
5177 boolean_type_node
, tmp
, stride
),
5178 PRED_FORTRAN_OVERFLOW
);
5179 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5180 integer_one_node
, integer_zero_node
);
5181 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
5182 boolean_type_node
, size
,
5183 gfc_index_zero_node
),
5184 PRED_FORTRAN_SIZE_ZERO
);
5185 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5186 integer_zero_node
, tmp
);
5187 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
5189 *overflow
= gfc_evaluate_now (tmp
, pblock
);
5191 /* Multiply the stride by the number of elements in this dimension. */
5192 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
5193 gfc_array_index_type
, stride
, size
);
5194 stride
= gfc_evaluate_now (stride
, pblock
);
5197 for (n
= rank
; n
< rank
+ corank
; n
++)
5201 /* Set lower bound. */
5202 gfc_init_se (&se
, NULL
);
5203 if (lower
== NULL
|| lower
[n
] == NULL
)
5205 gcc_assert (n
== rank
+ corank
- 1);
5206 se
.expr
= gfc_index_one_node
;
5210 if (ubound
|| n
== rank
+ corank
- 1)
5212 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
5213 gfc_add_block_to_block (pblock
, &se
.pre
);
5217 se
.expr
= gfc_index_one_node
;
5221 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
5222 gfc_rank_cst
[n
], se
.expr
);
5224 if (n
< rank
+ corank
- 1)
5226 gfc_init_se (&se
, NULL
);
5227 gcc_assert (ubound
);
5228 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
5229 gfc_add_block_to_block (pblock
, &se
.pre
);
5230 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
5231 gfc_rank_cst
[n
], se
.expr
);
5235 /* The stride is the number of elements in the array, so multiply by the
5236 size of an element to get the total size. Obviously, if there is a
5237 SOURCE expression (expr3) we must use its element size. */
5238 if (expr3_elem_size
!= NULL_TREE
)
5239 tmp
= expr3_elem_size
;
5240 else if (expr3
!= NULL
)
5242 if (expr3
->ts
.type
== BT_CLASS
)
5245 gfc_expr
*sz
= gfc_copy_expr (expr3
);
5246 gfc_add_vptr_component (sz
);
5247 gfc_add_size_component (sz
);
5248 gfc_init_se (&se_sz
, NULL
);
5249 gfc_conv_expr (&se_sz
, sz
);
5255 tmp
= gfc_typenode_for_spec (&expr3
->ts
);
5256 tmp
= TYPE_SIZE_UNIT (tmp
);
5260 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
5262 /* Convert to size_t. */
5263 element_size
= fold_convert (size_type_node
, tmp
);
5266 return element_size
;
5268 *nelems
= gfc_evaluate_now (stride
, pblock
);
5269 stride
= fold_convert (size_type_node
, stride
);
5271 /* First check for overflow. Since an array of type character can
5272 have zero element_size, we must check for that before
5274 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
5276 TYPE_MAX_VALUE (size_type_node
), element_size
);
5277 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
5278 boolean_type_node
, tmp
, stride
),
5279 PRED_FORTRAN_OVERFLOW
);
5280 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5281 integer_one_node
, integer_zero_node
);
5282 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
5283 boolean_type_node
, element_size
,
5284 build_int_cst (size_type_node
, 0)),
5285 PRED_FORTRAN_SIZE_ZERO
);
5286 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5287 integer_zero_node
, tmp
);
5288 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
5290 *overflow
= gfc_evaluate_now (tmp
, pblock
);
5292 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5293 stride
, element_size
);
5295 if (poffset
!= NULL
)
5297 offset
= gfc_evaluate_now (offset
, pblock
);
5301 if (integer_zerop (or_expr
))
5303 if (integer_onep (or_expr
))
5304 return build_int_cst (size_type_node
, 0);
5306 var
= gfc_create_var (TREE_TYPE (size
), "size");
5307 gfc_start_block (&thenblock
);
5308 gfc_add_modify (&thenblock
, var
, build_int_cst (size_type_node
, 0));
5309 thencase
= gfc_finish_block (&thenblock
);
5311 gfc_start_block (&elseblock
);
5312 gfc_add_modify (&elseblock
, var
, size
);
5313 elsecase
= gfc_finish_block (&elseblock
);
5315 tmp
= gfc_evaluate_now (or_expr
, pblock
);
5316 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
5317 gfc_add_expr_to_block (pblock
, tmp
);
5323 /* Retrieve the last ref from the chain. This routine is specific to
5324 gfc_array_allocate ()'s needs. */
5327 retrieve_last_ref (gfc_ref
**ref_in
, gfc_ref
**prev_ref_in
)
5329 gfc_ref
*ref
, *prev_ref
;
5332 /* Prevent warnings for uninitialized variables. */
5333 prev_ref
= *prev_ref_in
;
5334 while (ref
&& ref
->next
!= NULL
)
5336 gcc_assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
5337 || (ref
->u
.ar
.dimen
== 0 && ref
->u
.ar
.codimen
> 0));
5342 if (ref
== NULL
|| ref
->type
!= REF_ARRAY
)
5346 *prev_ref_in
= prev_ref
;
5350 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
5351 the work for an ALLOCATE statement. */
5355 gfc_array_allocate (gfc_se
* se
, gfc_expr
* expr
, tree status
, tree errmsg
,
5356 tree errlen
, tree label_finish
, tree expr3_elem_size
,
5357 tree
*nelems
, gfc_expr
*expr3
, tree e3_arr_desc
,
5358 bool e3_is_array_constr
)
5362 tree offset
= NULL_TREE
;
5363 tree token
= NULL_TREE
;
5366 tree error
= NULL_TREE
;
5367 tree overflow
; /* Boolean storing whether size calculation overflows. */
5368 tree var_overflow
= NULL_TREE
;
5370 tree set_descriptor
;
5371 stmtblock_t set_descriptor_block
;
5372 stmtblock_t elseblock
;
5375 gfc_ref
*ref
, *prev_ref
= NULL
;
5376 bool allocatable
, coarray
, dimension
, alloc_w_e3_arr_spec
= false;
5380 /* Find the last reference in the chain. */
5381 if (!retrieve_last_ref (&ref
, &prev_ref
))
5384 if (ref
->u
.ar
.type
== AR_FULL
&& expr3
!= NULL
)
5386 /* F08:C633: Array shape from expr3. */
5389 /* Find the last reference in the chain. */
5390 if (!retrieve_last_ref (&ref
, &prev_ref
))
5392 alloc_w_e3_arr_spec
= true;
5397 allocatable
= expr
->symtree
->n
.sym
->attr
.allocatable
;
5398 coarray
= expr
->symtree
->n
.sym
->attr
.codimension
;
5399 dimension
= expr
->symtree
->n
.sym
->attr
.dimension
;
5403 allocatable
= prev_ref
->u
.c
.component
->attr
.allocatable
;
5404 coarray
= prev_ref
->u
.c
.component
->attr
.codimension
;
5405 dimension
= prev_ref
->u
.c
.component
->attr
.dimension
;
5409 gcc_assert (coarray
);
5411 /* Figure out the size of the array. */
5412 switch (ref
->u
.ar
.type
)
5418 upper
= ref
->u
.ar
.start
;
5424 lower
= ref
->u
.ar
.start
;
5425 upper
= ref
->u
.ar
.end
;
5429 gcc_assert (ref
->u
.ar
.as
->type
== AS_EXPLICIT
5430 || alloc_w_e3_arr_spec
);
5432 lower
= ref
->u
.ar
.as
->lower
;
5433 upper
= ref
->u
.ar
.as
->upper
;
5441 overflow
= integer_zero_node
;
5443 gfc_init_block (&set_descriptor_block
);
5444 size
= gfc_array_init_size (se
->expr
, alloc_w_e3_arr_spec
? expr
->rank
5445 : ref
->u
.ar
.as
->rank
,
5446 ref
->u
.ar
.as
->corank
, &offset
, lower
, upper
,
5447 &se
->pre
, &set_descriptor_block
, &overflow
,
5448 expr3_elem_size
, nelems
, expr3
, e3_arr_desc
,
5449 e3_is_array_constr
);
5453 var_overflow
= gfc_create_var (integer_type_node
, "overflow");
5454 gfc_add_modify (&se
->pre
, var_overflow
, overflow
);
5456 if (status
== NULL_TREE
)
5458 /* Generate the block of code handling overflow. */
5459 msg
= gfc_build_addr_expr (pchar_type_node
,
5460 gfc_build_localized_cstring_const
5461 ("Integer overflow when calculating the amount of "
5462 "memory to allocate"));
5463 error
= build_call_expr_loc (input_location
,
5464 gfor_fndecl_runtime_error
, 1, msg
);
5468 tree status_type
= TREE_TYPE (status
);
5469 stmtblock_t set_status_block
;
5471 gfc_start_block (&set_status_block
);
5472 gfc_add_modify (&set_status_block
, status
,
5473 build_int_cst (status_type
, LIBERROR_ALLOCATION
));
5474 error
= gfc_finish_block (&set_status_block
);
5478 gfc_start_block (&elseblock
);
5480 /* Allocate memory to store the data. */
5481 if (POINTER_TYPE_P (TREE_TYPE (se
->expr
)))
5482 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
5484 pointer
= gfc_conv_descriptor_data_get (se
->expr
);
5485 STRIP_NOPS (pointer
);
5487 if (coarray
&& flag_coarray
== GFC_FCOARRAY_LIB
)
5488 token
= gfc_build_addr_expr (NULL_TREE
,
5489 gfc_conv_descriptor_token (se
->expr
));
5491 /* The allocatable variant takes the old pointer as first argument. */
5493 gfc_allocate_allocatable (&elseblock
, pointer
, size
, token
,
5494 status
, errmsg
, errlen
, label_finish
, expr
);
5496 gfc_allocate_using_malloc (&elseblock
, pointer
, size
, status
);
5500 cond
= gfc_unlikely (fold_build2_loc (input_location
, NE_EXPR
,
5501 boolean_type_node
, var_overflow
, integer_zero_node
),
5502 PRED_FORTRAN_OVERFLOW
);
5503 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
5504 error
, gfc_finish_block (&elseblock
));
5507 tmp
= gfc_finish_block (&elseblock
);
5509 gfc_add_expr_to_block (&se
->pre
, tmp
);
5511 /* Update the array descriptors. */
5513 gfc_conv_descriptor_offset_set (&set_descriptor_block
, se
->expr
, offset
);
5515 set_descriptor
= gfc_finish_block (&set_descriptor_block
);
5516 if (status
!= NULL_TREE
)
5518 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
5519 boolean_type_node
, status
,
5520 build_int_cst (TREE_TYPE (status
), 0));
5521 gfc_add_expr_to_block (&se
->pre
,
5522 fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5523 gfc_likely (cond
, PRED_FORTRAN_FAIL_ALLOC
),
5525 build_empty_stmt (input_location
)));
5528 gfc_add_expr_to_block (&se
->pre
, set_descriptor
);
5530 if ((expr
->ts
.type
== BT_DERIVED
)
5531 && expr
->ts
.u
.derived
->attr
.alloc_comp
)
5533 tmp
= gfc_nullify_alloc_comp (expr
->ts
.u
.derived
, se
->expr
,
5534 ref
->u
.ar
.as
->rank
);
5535 gfc_add_expr_to_block (&se
->pre
, tmp
);
5542 /* Deallocate an array variable. Also used when an allocated variable goes
5547 gfc_array_deallocate (tree descriptor
, tree pstat
, tree errmsg
, tree errlen
,
5548 tree label_finish
, gfc_expr
* expr
)
5553 bool coarray
= gfc_is_coarray (expr
);
5555 gfc_start_block (&block
);
5557 /* Get a pointer to the data. */
5558 var
= gfc_conv_descriptor_data_get (descriptor
);
5561 /* Parameter is the address of the data component. */
5562 tmp
= gfc_deallocate_with_status (coarray
? descriptor
: var
, pstat
, errmsg
,
5563 errlen
, label_finish
, false, expr
, coarray
);
5564 gfc_add_expr_to_block (&block
, tmp
);
5566 /* Zero the data pointer; only for coarrays an error can occur and then
5567 the allocation status may not be changed. */
5568 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
5569 var
, build_int_cst (TREE_TYPE (var
), 0));
5570 if (pstat
!= NULL_TREE
&& coarray
&& flag_coarray
== GFC_FCOARRAY_LIB
)
5573 tree stat
= build_fold_indirect_ref_loc (input_location
, pstat
);
5575 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5576 stat
, build_int_cst (TREE_TYPE (stat
), 0));
5577 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5578 cond
, tmp
, build_empty_stmt (input_location
));
5581 gfc_add_expr_to_block (&block
, tmp
);
5583 return gfc_finish_block (&block
);
5587 /* Create an array constructor from an initialization expression.
5588 We assume the frontend already did any expansions and conversions. */
5591 gfc_conv_array_initializer (tree type
, gfc_expr
* expr
)
5598 vec
<constructor_elt
, va_gc
> *v
= NULL
;
5600 if (expr
->expr_type
== EXPR_VARIABLE
5601 && expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
5602 && expr
->symtree
->n
.sym
->value
)
5603 expr
= expr
->symtree
->n
.sym
->value
;
5605 switch (expr
->expr_type
)
5608 case EXPR_STRUCTURE
:
5609 /* A single scalar or derived type value. Create an array with all
5610 elements equal to that value. */
5611 gfc_init_se (&se
, NULL
);
5613 if (expr
->expr_type
== EXPR_CONSTANT
)
5614 gfc_conv_constant (&se
, expr
);
5616 gfc_conv_structure (&se
, expr
, 1);
5618 wtmp
= wi::to_offset (TYPE_MAX_VALUE (TYPE_DOMAIN (type
))) + 1;
5619 /* This will probably eat buckets of memory for large arrays. */
5622 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
, se
.expr
);
5628 /* Create a vector of all the elements. */
5629 for (c
= gfc_constructor_first (expr
->value
.constructor
);
5630 c
; c
= gfc_constructor_next (c
))
5634 /* Problems occur when we get something like
5635 integer :: a(lots) = (/(i, i=1, lots)/) */
5636 gfc_fatal_error ("The number of elements in the array "
5637 "constructor at %L requires an increase of "
5638 "the allowed %d upper limit. See "
5639 "%<-fmax-array-constructor%> option",
5640 &expr
->where
, flag_max_array_constructor
);
5643 if (mpz_cmp_si (c
->offset
, 0) != 0)
5644 index
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
5648 if (mpz_cmp_si (c
->repeat
, 1) > 0)
5654 mpz_add (maxval
, c
->offset
, c
->repeat
);
5655 mpz_sub_ui (maxval
, maxval
, 1);
5656 tmp2
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
5657 if (mpz_cmp_si (c
->offset
, 0) != 0)
5659 mpz_add_ui (maxval
, c
->offset
, 1);
5660 tmp1
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
5663 tmp1
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
5665 range
= fold_build2 (RANGE_EXPR
, gfc_array_index_type
, tmp1
, tmp2
);
5671 gfc_init_se (&se
, NULL
);
5672 switch (c
->expr
->expr_type
)
5675 gfc_conv_constant (&se
, c
->expr
);
5678 case EXPR_STRUCTURE
:
5679 gfc_conv_structure (&se
, c
->expr
, 1);
5683 /* Catch those occasional beasts that do not simplify
5684 for one reason or another, assuming that if they are
5685 standard defying the frontend will catch them. */
5686 gfc_conv_expr (&se
, c
->expr
);
5690 if (range
== NULL_TREE
)
5691 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
5694 if (index
!= NULL_TREE
)
5695 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
5696 CONSTRUCTOR_APPEND_ELT (v
, range
, se
.expr
);
5702 return gfc_build_null_descriptor (type
);
5708 /* Create a constructor from the list of elements. */
5709 tmp
= build_constructor (type
, v
);
5710 TREE_CONSTANT (tmp
) = 1;
5715 /* Generate code to evaluate non-constant coarray cobounds. */
5718 gfc_trans_array_cobounds (tree type
, stmtblock_t
* pblock
,
5719 const gfc_symbol
*sym
)
5727 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
5729 for (dim
= as
->rank
; dim
< as
->rank
+ as
->corank
; dim
++)
5731 /* Evaluate non-constant array bound expressions. */
5732 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
5733 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
5735 gfc_init_se (&se
, NULL
);
5736 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
5737 gfc_add_block_to_block (pblock
, &se
.pre
);
5738 gfc_add_modify (pblock
, lbound
, se
.expr
);
5740 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
5741 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
5743 gfc_init_se (&se
, NULL
);
5744 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
5745 gfc_add_block_to_block (pblock
, &se
.pre
);
5746 gfc_add_modify (pblock
, ubound
, se
.expr
);
5752 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
5753 returns the size (in elements) of the array. */
5756 gfc_trans_array_bounds (tree type
, gfc_symbol
* sym
, tree
* poffset
,
5757 stmtblock_t
* pblock
)
5770 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
5772 size
= gfc_index_one_node
;
5773 offset
= gfc_index_zero_node
;
5774 for (dim
= 0; dim
< as
->rank
; dim
++)
5776 /* Evaluate non-constant array bound expressions. */
5777 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
5778 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
5780 gfc_init_se (&se
, NULL
);
5781 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
5782 gfc_add_block_to_block (pblock
, &se
.pre
);
5783 gfc_add_modify (pblock
, lbound
, se
.expr
);
5785 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
5786 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
5788 gfc_init_se (&se
, NULL
);
5789 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
5790 gfc_add_block_to_block (pblock
, &se
.pre
);
5791 gfc_add_modify (pblock
, ubound
, se
.expr
);
5793 /* The offset of this dimension. offset = offset - lbound * stride. */
5794 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5796 offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5799 /* The size of this dimension, and the stride of the next. */
5800 if (dim
+ 1 < as
->rank
)
5801 stride
= GFC_TYPE_ARRAY_STRIDE (type
, dim
+ 1);
5803 stride
= GFC_TYPE_ARRAY_SIZE (type
);
5805 if (ubound
!= NULL_TREE
&& !(stride
&& INTEGER_CST_P (stride
)))
5807 /* Calculate stride = size * (ubound + 1 - lbound). */
5808 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5809 gfc_array_index_type
,
5810 gfc_index_one_node
, lbound
);
5811 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5812 gfc_array_index_type
, ubound
, tmp
);
5813 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5814 gfc_array_index_type
, size
, tmp
);
5816 gfc_add_modify (pblock
, stride
, tmp
);
5818 stride
= gfc_evaluate_now (tmp
, pblock
);
5820 /* Make sure that negative size arrays are translated
5821 to being zero size. */
5822 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
5823 stride
, gfc_index_zero_node
);
5824 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5825 gfc_array_index_type
, tmp
,
5826 stride
, gfc_index_zero_node
);
5827 gfc_add_modify (pblock
, stride
, tmp
);
5833 gfc_trans_array_cobounds (type
, pblock
, sym
);
5834 gfc_trans_vla_type_sizes (sym
, pblock
);
5841 /* Generate code to initialize/allocate an array variable. */
5844 gfc_trans_auto_array_allocation (tree decl
, gfc_symbol
* sym
,
5845 gfc_wrapped_block
* block
)
5849 tree tmp
= NULL_TREE
;
5856 gcc_assert (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
));
5858 /* Do nothing for USEd variables. */
5859 if (sym
->attr
.use_assoc
)
5862 type
= TREE_TYPE (decl
);
5863 gcc_assert (GFC_ARRAY_TYPE_P (type
));
5864 onstack
= TREE_CODE (type
) != POINTER_TYPE
;
5866 gfc_init_block (&init
);
5868 /* Evaluate character string length. */
5869 if (sym
->ts
.type
== BT_CHARACTER
5870 && onstack
&& !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
5872 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
5874 gfc_trans_vla_type_sizes (sym
, &init
);
5876 /* Emit a DECL_EXPR for this variable, which will cause the
5877 gimplifier to allocate storage, and all that good stuff. */
5878 tmp
= fold_build1_loc (input_location
, DECL_EXPR
, TREE_TYPE (decl
), decl
);
5879 gfc_add_expr_to_block (&init
, tmp
);
5884 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
5888 type
= TREE_TYPE (type
);
5890 gcc_assert (!sym
->attr
.use_assoc
);
5891 gcc_assert (!TREE_STATIC (decl
));
5892 gcc_assert (!sym
->module
);
5894 if (sym
->ts
.type
== BT_CHARACTER
5895 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
5896 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
5898 size
= gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
5900 /* Don't actually allocate space for Cray Pointees. */
5901 if (sym
->attr
.cray_pointee
)
5903 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
5904 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
5906 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
5910 if (flag_stack_arrays
)
5912 gcc_assert (TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
);
5913 space
= build_decl (sym
->declared_at
.lb
->location
,
5914 VAR_DECL
, create_tmp_var_name ("A"),
5915 TREE_TYPE (TREE_TYPE (decl
)));
5916 gfc_trans_vla_type_sizes (sym
, &init
);
5920 /* The size is the number of elements in the array, so multiply by the
5921 size of an element to get the total size. */
5922 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
5923 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5924 size
, fold_convert (gfc_array_index_type
, tmp
));
5926 /* Allocate memory to hold the data. */
5927 tmp
= gfc_call_malloc (&init
, TREE_TYPE (decl
), size
);
5928 gfc_add_modify (&init
, decl
, tmp
);
5930 /* Free the temporary. */
5931 tmp
= gfc_call_free (decl
);
5935 /* Set offset of the array. */
5936 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
5937 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
5939 /* Automatic arrays should not have initializers. */
5940 gcc_assert (!sym
->value
);
5942 inittree
= gfc_finish_block (&init
);
5949 /* Don't create new scope, emit the DECL_EXPR in exactly the scope
5950 where also space is located. */
5951 gfc_init_block (&init
);
5952 tmp
= fold_build1_loc (input_location
, DECL_EXPR
,
5953 TREE_TYPE (space
), space
);
5954 gfc_add_expr_to_block (&init
, tmp
);
5955 addr
= fold_build1_loc (sym
->declared_at
.lb
->location
,
5956 ADDR_EXPR
, TREE_TYPE (decl
), space
);
5957 gfc_add_modify (&init
, decl
, addr
);
5958 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
5961 gfc_add_init_cleanup (block
, inittree
, tmp
);
5965 /* Generate entry and exit code for g77 calling convention arrays. */
5968 gfc_trans_g77_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
5978 gfc_save_backend_locus (&loc
);
5979 gfc_set_backend_locus (&sym
->declared_at
);
5981 /* Descriptor type. */
5982 parm
= sym
->backend_decl
;
5983 type
= TREE_TYPE (parm
);
5984 gcc_assert (GFC_ARRAY_TYPE_P (type
));
5986 gfc_start_block (&init
);
5988 if (sym
->ts
.type
== BT_CHARACTER
5989 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
5990 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
5992 /* Evaluate the bounds of the array. */
5993 gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
5995 /* Set the offset. */
5996 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
5997 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
5999 /* Set the pointer itself if we aren't using the parameter directly. */
6000 if (TREE_CODE (parm
) != PARM_DECL
)
6002 tmp
= convert (TREE_TYPE (parm
), GFC_DECL_SAVED_DESCRIPTOR (parm
));
6003 gfc_add_modify (&init
, parm
, tmp
);
6005 stmt
= gfc_finish_block (&init
);
6007 gfc_restore_backend_locus (&loc
);
6009 /* Add the initialization code to the start of the function. */
6011 if (sym
->attr
.optional
|| sym
->attr
.not_always_present
)
6013 tmp
= gfc_conv_expr_present (sym
);
6014 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
6017 gfc_add_init_cleanup (block
, stmt
, NULL_TREE
);
6021 /* Modify the descriptor of an array parameter so that it has the
6022 correct lower bound. Also move the upper bound accordingly.
6023 If the array is not packed, it will be copied into a temporary.
6024 For each dimension we set the new lower and upper bounds. Then we copy the
6025 stride and calculate the offset for this dimension. We also work out
6026 what the stride of a packed array would be, and see it the two match.
6027 If the array need repacking, we set the stride to the values we just
6028 calculated, recalculate the offset and copy the array data.
6029 Code is also added to copy the data back at the end of the function.
6033 gfc_trans_dummy_array_bias (gfc_symbol
* sym
, tree tmpdesc
,
6034 gfc_wrapped_block
* block
)
6041 tree stmtInit
, stmtCleanup
;
6048 tree stride
, stride2
;
6058 bool is_classarray
= IS_CLASS_ARRAY (sym
);
6060 /* Do nothing for pointer and allocatable arrays. */
6061 if ((sym
->ts
.type
!= BT_CLASS
&& sym
->attr
.pointer
)
6062 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.class_pointer
)
6063 || sym
->attr
.allocatable
6064 || (is_classarray
&& CLASS_DATA (sym
)->attr
.allocatable
))
6067 if (!is_classarray
&& sym
->attr
.dummy
&& gfc_is_nodesc_array (sym
))
6069 gfc_trans_g77_array (sym
, block
);
6073 gfc_save_backend_locus (&loc
);
6074 gfc_set_backend_locus (&sym
->declared_at
);
6076 /* Descriptor type. */
6077 type
= TREE_TYPE (tmpdesc
);
6078 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6079 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6081 /* For a class array the dummy array descriptor is in the _class
6083 dumdesc
= gfc_class_data_get (dumdesc
);
6085 dumdesc
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
6086 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
6087 gfc_start_block (&init
);
6089 if (sym
->ts
.type
== BT_CHARACTER
6090 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
6091 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6093 checkparm
= (as
->type
== AS_EXPLICIT
6094 && (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
));
6096 no_repack
= !(GFC_DECL_PACKED_ARRAY (tmpdesc
)
6097 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
));
6099 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
))
6101 /* For non-constant shape arrays we only check if the first dimension
6102 is contiguous. Repacking higher dimensions wouldn't gain us
6103 anything as we still don't know the array stride. */
6104 partial
= gfc_create_var (boolean_type_node
, "partial");
6105 TREE_USED (partial
) = 1;
6106 tmp
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
6107 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, tmp
,
6108 gfc_index_one_node
);
6109 gfc_add_modify (&init
, partial
, tmp
);
6112 partial
= NULL_TREE
;
6114 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
6115 here, however I think it does the right thing. */
6118 /* Set the first stride. */
6119 stride
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
6120 stride
= gfc_evaluate_now (stride
, &init
);
6122 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
6123 stride
, gfc_index_zero_node
);
6124 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
6125 tmp
, gfc_index_one_node
, stride
);
6126 stride
= GFC_TYPE_ARRAY_STRIDE (type
, 0);
6127 gfc_add_modify (&init
, stride
, tmp
);
6129 /* Allow the user to disable array repacking. */
6130 stmt_unpacked
= NULL_TREE
;
6134 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type
, 0)));
6135 /* A library call to repack the array if necessary. */
6136 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6137 stmt_unpacked
= build_call_expr_loc (input_location
,
6138 gfor_fndecl_in_pack
, 1, tmp
);
6140 stride
= gfc_index_one_node
;
6142 if (warn_array_temporaries
)
6143 gfc_warning (OPT_Warray_temporaries
,
6144 "Creating array temporary at %L", &loc
);
6147 /* This is for the case where the array data is used directly without
6148 calling the repack function. */
6149 if (no_repack
|| partial
!= NULL_TREE
)
6150 stmt_packed
= gfc_conv_descriptor_data_get (dumdesc
);
6152 stmt_packed
= NULL_TREE
;
6154 /* Assign the data pointer. */
6155 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
6157 /* Don't repack unknown shape arrays when the first stride is 1. */
6158 tmp
= fold_build3_loc (input_location
, COND_EXPR
, TREE_TYPE (stmt_packed
),
6159 partial
, stmt_packed
, stmt_unpacked
);
6162 tmp
= stmt_packed
!= NULL_TREE
? stmt_packed
: stmt_unpacked
;
6163 gfc_add_modify (&init
, tmpdesc
, fold_convert (type
, tmp
));
6165 offset
= gfc_index_zero_node
;
6166 size
= gfc_index_one_node
;
6168 /* Evaluate the bounds of the array. */
6169 for (n
= 0; n
< as
->rank
; n
++)
6171 if (checkparm
|| !as
->upper
[n
])
6173 /* Get the bounds of the actual parameter. */
6174 dubound
= gfc_conv_descriptor_ubound_get (dumdesc
, gfc_rank_cst
[n
]);
6175 dlbound
= gfc_conv_descriptor_lbound_get (dumdesc
, gfc_rank_cst
[n
]);
6179 dubound
= NULL_TREE
;
6180 dlbound
= NULL_TREE
;
6183 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, n
);
6184 if (!INTEGER_CST_P (lbound
))
6186 gfc_init_se (&se
, NULL
);
6187 gfc_conv_expr_type (&se
, as
->lower
[n
],
6188 gfc_array_index_type
);
6189 gfc_add_block_to_block (&init
, &se
.pre
);
6190 gfc_add_modify (&init
, lbound
, se
.expr
);
6193 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, n
);
6194 /* Set the desired upper bound. */
6197 /* We know what we want the upper bound to be. */
6198 if (!INTEGER_CST_P (ubound
))
6200 gfc_init_se (&se
, NULL
);
6201 gfc_conv_expr_type (&se
, as
->upper
[n
],
6202 gfc_array_index_type
);
6203 gfc_add_block_to_block (&init
, &se
.pre
);
6204 gfc_add_modify (&init
, ubound
, se
.expr
);
6207 /* Check the sizes match. */
6210 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
6214 temp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6215 gfc_array_index_type
, ubound
, lbound
);
6216 temp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6217 gfc_array_index_type
,
6218 gfc_index_one_node
, temp
);
6219 stride2
= fold_build2_loc (input_location
, MINUS_EXPR
,
6220 gfc_array_index_type
, dubound
,
6222 stride2
= fold_build2_loc (input_location
, PLUS_EXPR
,
6223 gfc_array_index_type
,
6224 gfc_index_one_node
, stride2
);
6225 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6226 gfc_array_index_type
, temp
, stride2
);
6227 msg
= xasprintf ("Dimension %d of array '%s' has extent "
6228 "%%ld instead of %%ld", n
+1, sym
->name
);
6230 gfc_trans_runtime_check (true, false, tmp
, &init
, &loc
, msg
,
6231 fold_convert (long_integer_type_node
, temp
),
6232 fold_convert (long_integer_type_node
, stride2
));
6239 /* For assumed shape arrays move the upper bound by the same amount
6240 as the lower bound. */
6241 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6242 gfc_array_index_type
, dubound
, dlbound
);
6243 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6244 gfc_array_index_type
, tmp
, lbound
);
6245 gfc_add_modify (&init
, ubound
, tmp
);
6247 /* The offset of this dimension. offset = offset - lbound * stride. */
6248 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6250 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
6251 gfc_array_index_type
, offset
, tmp
);
6253 /* The size of this dimension, and the stride of the next. */
6254 if (n
+ 1 < as
->rank
)
6256 stride
= GFC_TYPE_ARRAY_STRIDE (type
, n
+ 1);
6258 if (no_repack
|| partial
!= NULL_TREE
)
6260 gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[n
+1]);
6262 /* Figure out the stride if not a known constant. */
6263 if (!INTEGER_CST_P (stride
))
6266 stmt_packed
= NULL_TREE
;
6269 /* Calculate stride = size * (ubound + 1 - lbound). */
6270 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6271 gfc_array_index_type
,
6272 gfc_index_one_node
, lbound
);
6273 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6274 gfc_array_index_type
, ubound
, tmp
);
6275 size
= fold_build2_loc (input_location
, MULT_EXPR
,
6276 gfc_array_index_type
, size
, tmp
);
6280 /* Assign the stride. */
6281 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
6282 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6283 gfc_array_index_type
, partial
,
6284 stmt_unpacked
, stmt_packed
);
6286 tmp
= (stmt_packed
!= NULL_TREE
) ? stmt_packed
: stmt_unpacked
;
6287 gfc_add_modify (&init
, stride
, tmp
);
6292 stride
= GFC_TYPE_ARRAY_SIZE (type
);
6294 if (stride
&& !INTEGER_CST_P (stride
))
6296 /* Calculate size = stride * (ubound + 1 - lbound). */
6297 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6298 gfc_array_index_type
,
6299 gfc_index_one_node
, lbound
);
6300 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6301 gfc_array_index_type
,
6303 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6304 gfc_array_index_type
,
6305 GFC_TYPE_ARRAY_STRIDE (type
, n
), tmp
);
6306 gfc_add_modify (&init
, stride
, tmp
);
6311 gfc_trans_array_cobounds (type
, &init
, sym
);
6313 /* Set the offset. */
6314 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
6315 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6317 gfc_trans_vla_type_sizes (sym
, &init
);
6319 stmtInit
= gfc_finish_block (&init
);
6321 /* Only do the entry/initialization code if the arg is present. */
6322 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6323 optional_arg
= (sym
->attr
.optional
6324 || (sym
->ns
->proc_name
->attr
.entry_master
6325 && sym
->attr
.dummy
));
6328 tmp
= gfc_conv_expr_present (sym
);
6329 stmtInit
= build3_v (COND_EXPR
, tmp
, stmtInit
,
6330 build_empty_stmt (input_location
));
6335 stmtCleanup
= NULL_TREE
;
6338 stmtblock_t cleanup
;
6339 gfc_start_block (&cleanup
);
6341 if (sym
->attr
.intent
!= INTENT_IN
)
6343 /* Copy the data back. */
6344 tmp
= build_call_expr_loc (input_location
,
6345 gfor_fndecl_in_unpack
, 2, dumdesc
, tmpdesc
);
6346 gfc_add_expr_to_block (&cleanup
, tmp
);
6349 /* Free the temporary. */
6350 tmp
= gfc_call_free (tmpdesc
);
6351 gfc_add_expr_to_block (&cleanup
, tmp
);
6353 stmtCleanup
= gfc_finish_block (&cleanup
);
6355 /* Only do the cleanup if the array was repacked. */
6356 tmp
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
6357 tmp
= gfc_conv_descriptor_data_get (tmp
);
6358 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6360 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6361 build_empty_stmt (input_location
));
6365 tmp
= gfc_conv_expr_present (sym
);
6366 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6367 build_empty_stmt (input_location
));
6371 /* We don't need to free any memory allocated by internal_pack as it will
6372 be freed at the end of the function by pop_context. */
6373 gfc_add_init_cleanup (block
, stmtInit
, stmtCleanup
);
6375 gfc_restore_backend_locus (&loc
);
6379 /* Calculate the overall offset, including subreferences. */
6381 gfc_get_dataptr_offset (stmtblock_t
*block
, tree parm
, tree desc
, tree offset
,
6382 bool subref
, gfc_expr
*expr
)
6392 /* If offset is NULL and this is not a subreferenced array, there is
6394 if (offset
== NULL_TREE
)
6397 offset
= gfc_index_zero_node
;
6402 tmp
= build_array_ref (desc
, offset
, NULL
, NULL
);
6404 /* Offset the data pointer for pointer assignments from arrays with
6405 subreferences; e.g. my_integer => my_type(:)%integer_component. */
6408 /* Go past the array reference. */
6409 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6410 if (ref
->type
== REF_ARRAY
&&
6411 ref
->u
.ar
.type
!= AR_ELEMENT
)
6417 /* Calculate the offset for each subsequent subreference. */
6418 for (; ref
; ref
= ref
->next
)
6423 field
= ref
->u
.c
.component
->backend_decl
;
6424 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
6425 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
6427 tmp
, field
, NULL_TREE
);
6431 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
6432 gfc_init_se (&start
, NULL
);
6433 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
6434 gfc_add_block_to_block (block
, &start
.pre
);
6435 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
6439 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
6440 && ref
->u
.ar
.type
== AR_ELEMENT
);
6442 /* TODO - Add bounds checking. */
6443 stride
= gfc_index_one_node
;
6444 index
= gfc_index_zero_node
;
6445 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
6450 /* Update the index. */
6451 gfc_init_se (&start
, NULL
);
6452 gfc_conv_expr_type (&start
, ref
->u
.ar
.start
[n
], gfc_array_index_type
);
6453 itmp
= gfc_evaluate_now (start
.expr
, block
);
6454 gfc_init_se (&start
, NULL
);
6455 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->lower
[n
], gfc_array_index_type
);
6456 jtmp
= gfc_evaluate_now (start
.expr
, block
);
6457 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6458 gfc_array_index_type
, itmp
, jtmp
);
6459 itmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6460 gfc_array_index_type
, itmp
, stride
);
6461 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
6462 gfc_array_index_type
, itmp
, index
);
6463 index
= gfc_evaluate_now (index
, block
);
6465 /* Update the stride. */
6466 gfc_init_se (&start
, NULL
);
6467 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->upper
[n
], gfc_array_index_type
);
6468 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6469 gfc_array_index_type
, start
.expr
,
6471 itmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6472 gfc_array_index_type
,
6473 gfc_index_one_node
, itmp
);
6474 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
6475 gfc_array_index_type
, stride
, itmp
);
6476 stride
= gfc_evaluate_now (stride
, block
);
6479 /* Apply the index to obtain the array element. */
6480 tmp
= gfc_build_array_ref (tmp
, index
, NULL
);
6490 /* Set the target data pointer. */
6491 offset
= gfc_build_addr_expr (gfc_array_dataptr_type (desc
), tmp
);
6492 gfc_conv_descriptor_data_set (block
, parm
, offset
);
6496 /* gfc_conv_expr_descriptor needs the string length an expression
6497 so that the size of the temporary can be obtained. This is done
6498 by adding up the string lengths of all the elements in the
6499 expression. Function with non-constant expressions have their
6500 string lengths mapped onto the actual arguments using the
6501 interface mapping machinery in trans-expr.c. */
6503 get_array_charlen (gfc_expr
*expr
, gfc_se
*se
)
6505 gfc_interface_mapping mapping
;
6506 gfc_formal_arglist
*formal
;
6507 gfc_actual_arglist
*arg
;
6510 if (expr
->ts
.u
.cl
->length
6511 && gfc_is_constant_expr (expr
->ts
.u
.cl
->length
))
6513 if (!expr
->ts
.u
.cl
->backend_decl
)
6514 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6518 switch (expr
->expr_type
)
6521 get_array_charlen (expr
->value
.op
.op1
, se
);
6523 /* For parentheses the expression ts.u.cl is identical. */
6524 if (expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
6527 expr
->ts
.u
.cl
->backend_decl
=
6528 gfc_create_var (gfc_charlen_type_node
, "sln");
6530 if (expr
->value
.op
.op2
)
6532 get_array_charlen (expr
->value
.op
.op2
, se
);
6534 gcc_assert (expr
->value
.op
.op
== INTRINSIC_CONCAT
);
6536 /* Add the string lengths and assign them to the expression
6537 string length backend declaration. */
6538 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
6539 fold_build2_loc (input_location
, PLUS_EXPR
,
6540 gfc_charlen_type_node
,
6541 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
,
6542 expr
->value
.op
.op2
->ts
.u
.cl
->backend_decl
));
6545 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
6546 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
);
6550 if (expr
->value
.function
.esym
== NULL
6551 || expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6553 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6557 /* Map expressions involving the dummy arguments onto the actual
6558 argument expressions. */
6559 gfc_init_interface_mapping (&mapping
);
6560 formal
= gfc_sym_get_dummy_args (expr
->symtree
->n
.sym
);
6561 arg
= expr
->value
.function
.actual
;
6563 /* Set se = NULL in the calls to the interface mapping, to suppress any
6565 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
6570 gfc_add_interface_mapping (&mapping
, formal
->sym
, NULL
, arg
->expr
);
6573 gfc_init_se (&tse
, NULL
);
6575 /* Build the expression for the character length and convert it. */
6576 gfc_apply_interface_mapping (&mapping
, &tse
, expr
->ts
.u
.cl
->length
);
6578 gfc_add_block_to_block (&se
->pre
, &tse
.pre
);
6579 gfc_add_block_to_block (&se
->post
, &tse
.post
);
6580 tse
.expr
= fold_convert (gfc_charlen_type_node
, tse
.expr
);
6581 tse
.expr
= fold_build2_loc (input_location
, MAX_EXPR
,
6582 gfc_charlen_type_node
, tse
.expr
,
6583 build_int_cst (gfc_charlen_type_node
, 0));
6584 expr
->ts
.u
.cl
->backend_decl
= tse
.expr
;
6585 gfc_free_interface_mapping (&mapping
);
6589 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6595 /* Helper function to check dimensions. */
6597 transposed_dims (gfc_ss
*ss
)
6601 for (n
= 0; n
< ss
->dimen
; n
++)
6602 if (ss
->dim
[n
] != n
)
6608 /* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
6609 AR_FULL, suitable for the scalarizer. */
6612 walk_coarray (gfc_expr
*e
)
6616 gcc_assert (gfc_get_corank (e
) > 0);
6618 ss
= gfc_walk_expr (e
);
6620 /* Fix scalar coarray. */
6621 if (ss
== gfc_ss_terminator
)
6628 if (ref
->type
== REF_ARRAY
6629 && ref
->u
.ar
.codimen
> 0)
6635 gcc_assert (ref
!= NULL
);
6636 if (ref
->u
.ar
.type
== AR_ELEMENT
)
6637 ref
->u
.ar
.type
= AR_SECTION
;
6638 ss
= gfc_reverse_ss (gfc_walk_array_ref (ss
, e
, ref
));
6645 /* Convert an array for passing as an actual argument. Expressions and
6646 vector subscripts are evaluated and stored in a temporary, which is then
6647 passed. For whole arrays the descriptor is passed. For array sections
6648 a modified copy of the descriptor is passed, but using the original data.
6650 This function is also used for array pointer assignments, and there
6653 - se->want_pointer && !se->direct_byref
6654 EXPR is an actual argument. On exit, se->expr contains a
6655 pointer to the array descriptor.
6657 - !se->want_pointer && !se->direct_byref
6658 EXPR is an actual argument to an intrinsic function or the
6659 left-hand side of a pointer assignment. On exit, se->expr
6660 contains the descriptor for EXPR.
6662 - !se->want_pointer && se->direct_byref
6663 EXPR is the right-hand side of a pointer assignment and
6664 se->expr is the descriptor for the previously-evaluated
6665 left-hand side. The function creates an assignment from
6669 The se->force_tmp flag disables the non-copying descriptor optimization
6670 that is used for transpose. It may be used in cases where there is an
6671 alias between the transpose argument and another argument in the same
6675 gfc_conv_expr_descriptor (gfc_se
*se
, gfc_expr
*expr
)
6678 gfc_ss_type ss_type
;
6679 gfc_ss_info
*ss_info
;
6681 gfc_array_info
*info
;
6690 bool subref_array_target
= false;
6691 gfc_expr
*arg
, *ss_expr
;
6693 if (se
->want_coarray
)
6694 ss
= walk_coarray (expr
);
6696 ss
= gfc_walk_expr (expr
);
6698 gcc_assert (ss
!= NULL
);
6699 gcc_assert (ss
!= gfc_ss_terminator
);
6702 ss_type
= ss_info
->type
;
6703 ss_expr
= ss_info
->expr
;
6705 /* Special case: TRANSPOSE which needs no temporary. */
6706 while (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
6707 && NULL
!= (arg
= gfc_get_noncopying_intrinsic_argument (expr
)))
6709 /* This is a call to transpose which has already been handled by the
6710 scalarizer, so that we just need to get its argument's descriptor. */
6711 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
6712 expr
= expr
->value
.function
.actual
->expr
;
6715 /* Special case things we know we can pass easily. */
6716 switch (expr
->expr_type
)
6719 /* If we have a linear array section, we can pass it directly.
6720 Otherwise we need to copy it into a temporary. */
6722 gcc_assert (ss_type
== GFC_SS_SECTION
);
6723 gcc_assert (ss_expr
== expr
);
6724 info
= &ss_info
->data
.array
;
6726 /* Get the descriptor for the array. */
6727 gfc_conv_ss_descriptor (&se
->pre
, ss
, 0);
6728 desc
= info
->descriptor
;
6730 subref_array_target
= se
->direct_byref
&& is_subref_array (expr
);
6731 need_tmp
= gfc_ref_needs_temporary_p (expr
->ref
)
6732 && !subref_array_target
;
6739 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
6741 /* Create a new descriptor if the array doesn't have one. */
6744 else if (info
->ref
->u
.ar
.type
== AR_FULL
|| se
->descriptor_only
)
6746 else if (se
->direct_byref
)
6749 full
= gfc_full_array_ref_p (info
->ref
, NULL
);
6751 if (full
&& !transposed_dims (ss
))
6753 if (se
->direct_byref
&& !se
->byref_noassign
)
6755 /* Copy the descriptor for pointer assignments. */
6756 gfc_add_modify (&se
->pre
, se
->expr
, desc
);
6758 /* Add any offsets from subreferences. */
6759 gfc_get_dataptr_offset (&se
->pre
, se
->expr
, desc
, NULL_TREE
,
6760 subref_array_target
, expr
);
6762 else if (se
->want_pointer
)
6764 /* We pass full arrays directly. This means that pointers and
6765 allocatable arrays should also work. */
6766 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
6773 if (expr
->ts
.type
== BT_CHARACTER
)
6774 se
->string_length
= gfc_get_expr_charlen (expr
);
6776 gfc_free_ss_chain (ss
);
6782 /* A transformational function return value will be a temporary
6783 array descriptor. We still need to go through the scalarizer
6784 to create the descriptor. Elemental functions are handled as
6785 arbitrary expressions, i.e. copy to a temporary. */
6787 if (se
->direct_byref
)
6789 gcc_assert (ss_type
== GFC_SS_FUNCTION
&& ss_expr
== expr
);
6791 /* For pointer assignments pass the descriptor directly. */
6795 gcc_assert (se
->ss
== ss
);
6796 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
6797 gfc_conv_expr (se
, expr
);
6798 gfc_free_ss_chain (ss
);
6802 if (ss_expr
!= expr
|| ss_type
!= GFC_SS_FUNCTION
)
6804 if (ss_expr
!= expr
)
6805 /* Elemental function. */
6806 gcc_assert ((expr
->value
.function
.esym
!= NULL
6807 && expr
->value
.function
.esym
->attr
.elemental
)
6808 || (expr
->value
.function
.isym
!= NULL
6809 && expr
->value
.function
.isym
->elemental
)
6810 || gfc_inline_intrinsic_function_p (expr
));
6812 gcc_assert (ss_type
== GFC_SS_INTRINSIC
);
6815 if (expr
->ts
.type
== BT_CHARACTER
6816 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
6817 get_array_charlen (expr
, se
);
6823 /* Transformational function. */
6824 info
= &ss_info
->data
.array
;
6830 /* Constant array constructors don't need a temporary. */
6831 if (ss_type
== GFC_SS_CONSTRUCTOR
6832 && expr
->ts
.type
!= BT_CHARACTER
6833 && gfc_constant_array_constructor_p (expr
->value
.constructor
))
6836 info
= &ss_info
->data
.array
;
6846 /* Something complicated. Copy it into a temporary. */
6852 /* If we are creating a temporary, we don't need to bother about aliases
6857 gfc_init_loopinfo (&loop
);
6859 /* Associate the SS with the loop. */
6860 gfc_add_ss_to_loop (&loop
, ss
);
6862 /* Tell the scalarizer not to bother creating loop variables, etc. */
6864 loop
.array_parameter
= 1;
6866 /* The right-hand side of a pointer assignment mustn't use a temporary. */
6867 gcc_assert (!se
->direct_byref
);
6869 /* Setup the scalarizing loops and bounds. */
6870 gfc_conv_ss_startstride (&loop
);
6874 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
6875 get_array_charlen (expr
, se
);
6877 /* Tell the scalarizer to make a temporary. */
6878 loop
.temp_ss
= gfc_get_temp_ss (gfc_typenode_for_spec (&expr
->ts
),
6879 ((expr
->ts
.type
== BT_CHARACTER
)
6880 ? expr
->ts
.u
.cl
->backend_decl
6884 se
->string_length
= loop
.temp_ss
->info
->string_length
;
6885 gcc_assert (loop
.temp_ss
->dimen
== loop
.dimen
);
6886 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
6889 gfc_conv_loop_setup (&loop
, & expr
->where
);
6893 /* Copy into a temporary and pass that. We don't need to copy the data
6894 back because expressions and vector subscripts must be INTENT_IN. */
6895 /* TODO: Optimize passing function return values. */
6899 /* Start the copying loops. */
6900 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
6901 gfc_mark_ss_chain_used (ss
, 1);
6902 gfc_start_scalarized_body (&loop
, &block
);
6904 /* Copy each data element. */
6905 gfc_init_se (&lse
, NULL
);
6906 gfc_copy_loopinfo_to_se (&lse
, &loop
);
6907 gfc_init_se (&rse
, NULL
);
6908 gfc_copy_loopinfo_to_se (&rse
, &loop
);
6910 lse
.ss
= loop
.temp_ss
;
6913 gfc_conv_scalarized_array_ref (&lse
, NULL
);
6914 if (expr
->ts
.type
== BT_CHARACTER
)
6916 gfc_conv_expr (&rse
, expr
);
6917 if (POINTER_TYPE_P (TREE_TYPE (rse
.expr
)))
6918 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
6922 gfc_conv_expr_val (&rse
, expr
);
6924 gfc_add_block_to_block (&block
, &rse
.pre
);
6925 gfc_add_block_to_block (&block
, &lse
.pre
);
6927 lse
.string_length
= rse
.string_length
;
6928 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
,
6929 expr
->expr_type
== EXPR_VARIABLE
6930 || expr
->expr_type
== EXPR_ARRAY
, false);
6931 gfc_add_expr_to_block (&block
, tmp
);
6933 /* Finish the copying loops. */
6934 gfc_trans_scalarizing_loops (&loop
, &block
);
6936 desc
= loop
.temp_ss
->info
->data
.array
.descriptor
;
6938 else if (expr
->expr_type
== EXPR_FUNCTION
&& !transposed_dims (ss
))
6940 desc
= info
->descriptor
;
6941 se
->string_length
= ss_info
->string_length
;
6945 /* We pass sections without copying to a temporary. Make a new
6946 descriptor and point it at the section we want. The loop variable
6947 limits will be the limits of the section.
6948 A function may decide to repack the array to speed up access, but
6949 we're not bothered about that here. */
6950 int dim
, ndim
, codim
;
6957 bool onebased
= false, rank_remap
;
6959 ndim
= info
->ref
? info
->ref
->u
.ar
.dimen
: ss
->dimen
;
6960 rank_remap
= ss
->dimen
< ndim
;
6962 if (se
->want_coarray
)
6964 gfc_array_ref
*ar
= &info
->ref
->u
.ar
;
6966 codim
= gfc_get_corank (expr
);
6967 for (n
= 0; n
< codim
- 1; n
++)
6969 /* Make sure we are not lost somehow. */
6970 gcc_assert (ar
->dimen_type
[n
+ ndim
] == DIMEN_THIS_IMAGE
);
6972 /* Make sure the call to gfc_conv_section_startstride won't
6973 generate unnecessary code to calculate stride. */
6974 gcc_assert (ar
->stride
[n
+ ndim
] == NULL
);
6976 gfc_conv_section_startstride (&loop
.pre
, ss
, n
+ ndim
);
6977 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
6978 loop
.to
[n
+ loop
.dimen
] = info
->end
[n
+ ndim
];
6981 gcc_assert (n
== codim
- 1);
6982 evaluate_bound (&loop
.pre
, info
->start
, ar
->start
,
6983 info
->descriptor
, n
+ ndim
, true,
6984 ar
->as
->type
== AS_DEFERRED
);
6985 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
6990 /* Set the string_length for a character array. */
6991 if (expr
->ts
.type
== BT_CHARACTER
)
6992 se
->string_length
= gfc_get_expr_charlen (expr
);
6994 /* If we have an array section or are assigning make sure that
6995 the lower bound is 1. References to the full
6996 array should otherwise keep the original bounds. */
6997 if ((!info
->ref
|| info
->ref
->u
.ar
.type
!= AR_FULL
) && !se
->want_pointer
)
6998 for (dim
= 0; dim
< loop
.dimen
; dim
++)
6999 if (!integer_onep (loop
.from
[dim
]))
7001 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7002 gfc_array_index_type
, gfc_index_one_node
,
7004 loop
.to
[dim
] = fold_build2_loc (input_location
, PLUS_EXPR
,
7005 gfc_array_index_type
,
7007 loop
.from
[dim
] = gfc_index_one_node
;
7010 desc
= info
->descriptor
;
7011 if (se
->direct_byref
&& !se
->byref_noassign
)
7013 /* For pointer assignments we fill in the destination. */
7015 parmtype
= TREE_TYPE (parm
);
7019 /* Otherwise make a new one. */
7020 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
7021 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
, codim
,
7022 loop
.from
, loop
.to
, 0,
7023 GFC_ARRAY_UNKNOWN
, false);
7024 parm
= gfc_create_var (parmtype
, "parm");
7027 offset
= gfc_index_zero_node
;
7029 /* The following can be somewhat confusing. We have two
7030 descriptors, a new one and the original array.
7031 {parm, parmtype, dim} refer to the new one.
7032 {desc, type, n, loop} refer to the original, which maybe
7033 a descriptorless array.
7034 The bounds of the scalarization are the bounds of the section.
7035 We don't have to worry about numeric overflows when calculating
7036 the offsets because all elements are within the array data. */
7038 /* Set the dtype. */
7039 tmp
= gfc_conv_descriptor_dtype (parm
);
7040 gfc_add_modify (&loop
.pre
, tmp
, gfc_get_dtype (parmtype
));
7042 /* Set offset for assignments to pointer only to zero if it is not
7044 if ((se
->direct_byref
|| se
->use_offset
)
7045 && ((info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
7046 || (expr
->expr_type
== EXPR_ARRAY
&& se
->use_offset
)))
7047 base
= gfc_index_zero_node
;
7048 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7049 base
= gfc_evaluate_now (gfc_conv_array_offset (desc
), &loop
.pre
);
7053 for (n
= 0; n
< ndim
; n
++)
7055 stride
= gfc_conv_array_stride (desc
, n
);
7057 /* Work out the offset. */
7059 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
7061 gcc_assert (info
->subscript
[n
]
7062 && info
->subscript
[n
]->info
->type
== GFC_SS_SCALAR
);
7063 start
= info
->subscript
[n
]->info
->data
.scalar
.value
;
7067 /* Evaluate and remember the start of the section. */
7068 start
= info
->start
[n
];
7069 stride
= gfc_evaluate_now (stride
, &loop
.pre
);
7072 tmp
= gfc_conv_array_lbound (desc
, n
);
7073 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
7075 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
7077 offset
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (tmp
),
7081 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
7083 /* For elemental dimensions, we only need the offset. */
7087 /* Vector subscripts need copying and are handled elsewhere. */
7089 gcc_assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
7091 /* look for the corresponding scalarizer dimension: dim. */
7092 for (dim
= 0; dim
< ndim
; dim
++)
7093 if (ss
->dim
[dim
] == n
)
7096 /* loop exited early: the DIM being looked for has been found. */
7097 gcc_assert (dim
< ndim
);
7099 /* Set the new lower bound. */
7100 from
= loop
.from
[dim
];
7103 onebased
= integer_onep (from
);
7104 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
7105 gfc_rank_cst
[dim
], from
);
7107 /* Set the new upper bound. */
7108 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
7109 gfc_rank_cst
[dim
], to
);
7111 /* Multiply the stride by the section stride to get the
7113 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
7114 gfc_array_index_type
,
7115 stride
, info
->stride
[n
]);
7117 if (se
->direct_byref
7118 && ((info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
7119 || (expr
->expr_type
== EXPR_ARRAY
&& se
->use_offset
)))
7121 base
= fold_build2_loc (input_location
, MINUS_EXPR
,
7122 TREE_TYPE (base
), base
, stride
);
7124 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)) || se
->use_offset
)
7127 tmp
= gfc_conv_array_lbound (desc
, n
);
7128 toonebased
= integer_onep (tmp
);
7129 // lb(arr) - from (- start + 1)
7130 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7131 TREE_TYPE (base
), tmp
, from
);
7132 if (onebased
&& toonebased
)
7134 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7135 TREE_TYPE (base
), tmp
, start
);
7136 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7137 TREE_TYPE (base
), tmp
,
7138 gfc_index_one_node
);
7140 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7141 TREE_TYPE (base
), tmp
,
7142 gfc_conv_array_stride (desc
, n
));
7143 base
= fold_build2_loc (input_location
, PLUS_EXPR
,
7144 TREE_TYPE (base
), tmp
, base
);
7147 /* Store the new stride. */
7148 gfc_conv_descriptor_stride_set (&loop
.pre
, parm
,
7149 gfc_rank_cst
[dim
], stride
);
7152 for (n
= loop
.dimen
; n
< loop
.dimen
+ codim
; n
++)
7154 from
= loop
.from
[n
];
7156 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
7157 gfc_rank_cst
[n
], from
);
7158 if (n
< loop
.dimen
+ codim
- 1)
7159 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
7160 gfc_rank_cst
[n
], to
);
7163 if (se
->data_not_needed
)
7164 gfc_conv_descriptor_data_set (&loop
.pre
, parm
,
7165 gfc_index_zero_node
);
7167 /* Point the data pointer at the 1st element in the section. */
7168 gfc_get_dataptr_offset (&loop
.pre
, parm
, desc
, offset
,
7169 subref_array_target
, expr
);
7171 /* Force the offset to be -1, when the lower bound of the highest
7172 dimension is one and the symbol is present and is not a
7173 pointer/allocatable or associated. */
7174 if (((se
->direct_byref
|| GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7175 && !se
->data_not_needed
)
7176 || (se
->use_offset
&& base
!= NULL_TREE
))
7178 /* Set the offset depending on base. */
7179 tmp
= rank_remap
&& !se
->direct_byref
?
7180 fold_build2_loc (input_location
, PLUS_EXPR
,
7181 gfc_array_index_type
, base
,
7184 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, tmp
);
7186 else if (onebased
&& (!rank_remap
|| se
->use_offset
)
7188 && !(expr
->symtree
->n
.sym
&& expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
7189 && !CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.class_pointer
)
7190 && !expr
->symtree
->n
.sym
->attr
.allocatable
7191 && !expr
->symtree
->n
.sym
->attr
.pointer
7192 && !expr
->symtree
->n
.sym
->attr
.host_assoc
7193 && !expr
->symtree
->n
.sym
->attr
.use_assoc
)
7195 /* Set the offset to -1. */
7197 mpz_init_set_si (minus_one
, -1);
7198 tmp
= gfc_conv_mpz_to_tree (minus_one
, gfc_index_integer_kind
);
7199 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, tmp
);
7203 /* Only the callee knows what the correct offset it, so just set
7205 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, gfc_index_zero_node
);
7210 /* For class arrays add the class tree into the saved descriptor to
7211 enable getting of _vptr and the like. */
7212 if (expr
->expr_type
== EXPR_VARIABLE
&& VAR_P (desc
)
7213 && IS_CLASS_ARRAY (expr
->symtree
->n
.sym
))
7215 gfc_allocate_lang_decl (desc
);
7216 GFC_DECL_SAVED_DESCRIPTOR (desc
) =
7217 DECL_LANG_SPECIFIC (expr
->symtree
->n
.sym
->backend_decl
) ?
7218 GFC_DECL_SAVED_DESCRIPTOR (expr
->symtree
->n
.sym
->backend_decl
)
7219 : expr
->symtree
->n
.sym
->backend_decl
;
7221 if (!se
->direct_byref
|| se
->byref_noassign
)
7223 /* Get a pointer to the new descriptor. */
7224 if (se
->want_pointer
)
7225 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
7230 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
7231 gfc_add_block_to_block (&se
->post
, &loop
.post
);
7233 /* Cleanup the scalarizer. */
7234 gfc_cleanup_loop (&loop
);
7237 /* Helper function for gfc_conv_array_parameter if array size needs to be
7241 array_parameter_size (tree desc
, gfc_expr
*expr
, tree
*size
)
7244 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7245 *size
= GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc
));
7246 else if (expr
->rank
> 1)
7247 *size
= build_call_expr_loc (input_location
,
7248 gfor_fndecl_size0
, 1,
7249 gfc_build_addr_expr (NULL
, desc
));
7252 tree ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_index_zero_node
);
7253 tree lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_index_zero_node
);
7255 *size
= fold_build2_loc (input_location
, MINUS_EXPR
,
7256 gfc_array_index_type
, ubound
, lbound
);
7257 *size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7258 *size
, gfc_index_one_node
);
7259 *size
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
7260 *size
, gfc_index_zero_node
);
7262 elem
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
7263 *size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7264 *size
, fold_convert (gfc_array_index_type
, elem
));
7267 /* Convert an array for passing as an actual parameter. */
7268 /* TODO: Optimize passing g77 arrays. */
7271 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, bool g77
,
7272 const gfc_symbol
*fsym
, const char *proc_name
,
7277 tree tmp
= NULL_TREE
;
7279 tree parent
= DECL_CONTEXT (current_function_decl
);
7280 bool full_array_var
;
7281 bool this_array_result
;
7284 bool array_constructor
;
7285 bool good_allocatable
;
7286 bool ultimate_ptr_comp
;
7287 bool ultimate_alloc_comp
;
7292 ultimate_ptr_comp
= false;
7293 ultimate_alloc_comp
= false;
7295 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7297 if (ref
->next
== NULL
)
7300 if (ref
->type
== REF_COMPONENT
)
7302 ultimate_ptr_comp
= ref
->u
.c
.component
->attr
.pointer
;
7303 ultimate_alloc_comp
= ref
->u
.c
.component
->attr
.allocatable
;
7307 full_array_var
= false;
7310 if (expr
->expr_type
== EXPR_VARIABLE
&& ref
&& !ultimate_ptr_comp
)
7311 full_array_var
= gfc_full_array_ref_p (ref
, &contiguous
);
7313 sym
= full_array_var
? expr
->symtree
->n
.sym
: NULL
;
7315 /* The symbol should have an array specification. */
7316 gcc_assert (!sym
|| sym
->as
|| ref
->u
.ar
.as
);
7318 if (expr
->expr_type
== EXPR_ARRAY
&& expr
->ts
.type
== BT_CHARACTER
)
7320 get_array_ctor_strlen (&se
->pre
, expr
->value
.constructor
, &tmp
);
7321 expr
->ts
.u
.cl
->backend_decl
= tmp
;
7322 se
->string_length
= tmp
;
7325 /* Is this the result of the enclosing procedure? */
7326 this_array_result
= (full_array_var
&& sym
->attr
.flavor
== FL_PROCEDURE
);
7327 if (this_array_result
7328 && (sym
->backend_decl
!= current_function_decl
)
7329 && (sym
->backend_decl
!= parent
))
7330 this_array_result
= false;
7332 /* Passing address of the array if it is not pointer or assumed-shape. */
7333 if (full_array_var
&& g77
&& !this_array_result
7334 && sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
7336 tmp
= gfc_get_symbol_decl (sym
);
7338 if (sym
->ts
.type
== BT_CHARACTER
)
7339 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
7341 if (!sym
->attr
.pointer
7343 && sym
->as
->type
!= AS_ASSUMED_SHAPE
7344 && sym
->as
->type
!= AS_DEFERRED
7345 && sym
->as
->type
!= AS_ASSUMED_RANK
7346 && !sym
->attr
.allocatable
)
7348 /* Some variables are declared directly, others are declared as
7349 pointers and allocated on the heap. */
7350 if (sym
->attr
.dummy
|| POINTER_TYPE_P (TREE_TYPE (tmp
)))
7353 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
7355 array_parameter_size (tmp
, expr
, size
);
7359 if (sym
->attr
.allocatable
)
7361 if (sym
->attr
.dummy
|| sym
->attr
.result
)
7363 gfc_conv_expr_descriptor (se
, expr
);
7367 array_parameter_size (tmp
, expr
, size
);
7368 se
->expr
= gfc_conv_array_data (tmp
);
7373 /* A convenient reduction in scope. */
7374 contiguous
= g77
&& !this_array_result
&& contiguous
;
7376 /* There is no need to pack and unpack the array, if it is contiguous
7377 and not a deferred- or assumed-shape array, or if it is simply
7379 no_pack
= ((sym
&& sym
->as
7380 && !sym
->attr
.pointer
7381 && sym
->as
->type
!= AS_DEFERRED
7382 && sym
->as
->type
!= AS_ASSUMED_RANK
7383 && sym
->as
->type
!= AS_ASSUMED_SHAPE
)
7385 (ref
&& ref
->u
.ar
.as
7386 && ref
->u
.ar
.as
->type
!= AS_DEFERRED
7387 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_RANK
7388 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_SHAPE
)
7390 gfc_is_simply_contiguous (expr
, false, true));
7392 no_pack
= contiguous
&& no_pack
;
7394 /* Array constructors are always contiguous and do not need packing. */
7395 array_constructor
= g77
&& !this_array_result
&& expr
->expr_type
== EXPR_ARRAY
;
7397 /* Same is true of contiguous sections from allocatable variables. */
7398 good_allocatable
= contiguous
7400 && expr
->symtree
->n
.sym
->attr
.allocatable
;
7402 /* Or ultimate allocatable components. */
7403 ultimate_alloc_comp
= contiguous
&& ultimate_alloc_comp
;
7405 if (no_pack
|| array_constructor
|| good_allocatable
|| ultimate_alloc_comp
)
7407 gfc_conv_expr_descriptor (se
, expr
);
7408 /* Deallocate the allocatable components of structures that are
7410 if ((expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
)
7411 && expr
->ts
.u
.derived
->attr
.alloc_comp
7412 && expr
->expr_type
!= EXPR_VARIABLE
)
7414 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, se
->expr
, expr
->rank
);
7416 /* The components shall be deallocated before their containing entity. */
7417 gfc_prepend_expr_to_block (&se
->post
, tmp
);
7419 if (expr
->ts
.type
== BT_CHARACTER
)
7420 se
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
7422 array_parameter_size (se
->expr
, expr
, size
);
7423 se
->expr
= gfc_conv_array_data (se
->expr
);
7427 if (this_array_result
)
7429 /* Result of the enclosing function. */
7430 gfc_conv_expr_descriptor (se
, expr
);
7432 array_parameter_size (se
->expr
, expr
, size
);
7433 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7435 if (g77
&& TREE_TYPE (TREE_TYPE (se
->expr
)) != NULL_TREE
7436 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
7437 se
->expr
= gfc_conv_array_data (build_fold_indirect_ref_loc (input_location
,
7444 /* Every other type of array. */
7445 se
->want_pointer
= 1;
7446 gfc_conv_expr_descriptor (se
, expr
);
7448 array_parameter_size (build_fold_indirect_ref_loc (input_location
,
7453 /* Deallocate the allocatable components of structures that are
7454 not variable, for descriptorless arguments.
7455 Arguments with a descriptor are handled in gfc_conv_procedure_call. */
7456 if (g77
&& (expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
)
7457 && expr
->ts
.u
.derived
->attr
.alloc_comp
7458 && expr
->expr_type
!= EXPR_VARIABLE
)
7460 tmp
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7461 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
, expr
->rank
);
7463 /* The components shall be deallocated before their containing entity. */
7464 gfc_prepend_expr_to_block (&se
->post
, tmp
);
7467 if (g77
|| (fsym
&& fsym
->attr
.contiguous
7468 && !gfc_is_simply_contiguous (expr
, false, true)))
7470 tree origptr
= NULL_TREE
;
7474 /* For contiguous arrays, save the original value of the descriptor. */
7477 origptr
= gfc_create_var (pvoid_type_node
, "origptr");
7478 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7479 tmp
= gfc_conv_array_data (tmp
);
7480 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7481 TREE_TYPE (origptr
), origptr
,
7482 fold_convert (TREE_TYPE (origptr
), tmp
));
7483 gfc_add_expr_to_block (&se
->pre
, tmp
);
7486 /* Repack the array. */
7487 if (warn_array_temporaries
)
7490 gfc_warning (OPT_Warray_temporaries
,
7491 "Creating array temporary at %L for argument %qs",
7492 &expr
->where
, fsym
->name
);
7494 gfc_warning (OPT_Warray_temporaries
,
7495 "Creating array temporary at %L", &expr
->where
);
7498 ptr
= build_call_expr_loc (input_location
,
7499 gfor_fndecl_in_pack
, 1, desc
);
7501 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7503 tmp
= gfc_conv_expr_present (sym
);
7504 ptr
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
7505 tmp
, fold_convert (TREE_TYPE (se
->expr
), ptr
),
7506 fold_convert (TREE_TYPE (se
->expr
), null_pointer_node
));
7509 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
7511 /* Use the packed data for the actual argument, except for contiguous arrays,
7512 where the descriptor's data component is set. */
7517 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7519 gfc_ss
* ss
= gfc_walk_expr (expr
);
7520 if (!transposed_dims (ss
))
7521 gfc_conv_descriptor_data_set (&se
->pre
, tmp
, ptr
);
7524 tree old_field
, new_field
;
7526 /* The original descriptor has transposed dims so we can't reuse
7527 it directly; we have to create a new one. */
7528 tree old_desc
= tmp
;
7529 tree new_desc
= gfc_create_var (TREE_TYPE (old_desc
), "arg_desc");
7531 old_field
= gfc_conv_descriptor_dtype (old_desc
);
7532 new_field
= gfc_conv_descriptor_dtype (new_desc
);
7533 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7535 old_field
= gfc_conv_descriptor_offset (old_desc
);
7536 new_field
= gfc_conv_descriptor_offset (new_desc
);
7537 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7539 for (int i
= 0; i
< expr
->rank
; i
++)
7541 old_field
= gfc_conv_descriptor_dimension (old_desc
,
7542 gfc_rank_cst
[get_array_ref_dim_for_loop_dim (ss
, i
)]);
7543 new_field
= gfc_conv_descriptor_dimension (new_desc
,
7545 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7548 if (flag_coarray
== GFC_FCOARRAY_LIB
7549 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (old_desc
))
7550 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (old_desc
))
7551 == GFC_ARRAY_ALLOCATABLE
)
7553 old_field
= gfc_conv_descriptor_token (old_desc
);
7554 new_field
= gfc_conv_descriptor_token (new_desc
);
7555 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7558 gfc_conv_descriptor_data_set (&se
->pre
, new_desc
, ptr
);
7559 se
->expr
= gfc_build_addr_expr (NULL_TREE
, new_desc
);
7564 if (gfc_option
.rtcheck
& GFC_RTCHECK_ARRAY_TEMPS
)
7568 if (fsym
&& proc_name
)
7569 msg
= xasprintf ("An array temporary was created for argument "
7570 "'%s' of procedure '%s'", fsym
->name
, proc_name
);
7572 msg
= xasprintf ("An array temporary was created");
7574 tmp
= build_fold_indirect_ref_loc (input_location
,
7576 tmp
= gfc_conv_array_data (tmp
);
7577 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7578 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
7580 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7581 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7583 gfc_conv_expr_present (sym
), tmp
);
7585 gfc_trans_runtime_check (false, true, tmp
, &se
->pre
,
7590 gfc_start_block (&block
);
7592 /* Copy the data back. */
7593 if (fsym
== NULL
|| fsym
->attr
.intent
!= INTENT_IN
)
7595 tmp
= build_call_expr_loc (input_location
,
7596 gfor_fndecl_in_unpack
, 2, desc
, ptr
);
7597 gfc_add_expr_to_block (&block
, tmp
);
7600 /* Free the temporary. */
7601 tmp
= gfc_call_free (ptr
);
7602 gfc_add_expr_to_block (&block
, tmp
);
7604 stmt
= gfc_finish_block (&block
);
7606 gfc_init_block (&block
);
7607 /* Only if it was repacked. This code needs to be executed before the
7608 loop cleanup code. */
7609 tmp
= build_fold_indirect_ref_loc (input_location
,
7611 tmp
= gfc_conv_array_data (tmp
);
7612 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7613 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
7615 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7616 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7618 gfc_conv_expr_present (sym
), tmp
);
7620 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
7622 gfc_add_expr_to_block (&block
, tmp
);
7623 gfc_add_block_to_block (&block
, &se
->post
);
7625 gfc_init_block (&se
->post
);
7627 /* Reset the descriptor pointer. */
7630 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7631 gfc_conv_descriptor_data_set (&se
->post
, tmp
, origptr
);
7634 gfc_add_block_to_block (&se
->post
, &block
);
7639 /* Generate code to deallocate an array, if it is allocated. */
7642 gfc_trans_dealloc_allocated (tree descriptor
, bool coarray
, gfc_expr
*expr
)
7648 gfc_start_block (&block
);
7650 var
= gfc_conv_descriptor_data_get (descriptor
);
7653 /* Call array_deallocate with an int * present in the second argument.
7654 Although it is ignored here, it's presence ensures that arrays that
7655 are already deallocated are ignored. */
7656 tmp
= gfc_deallocate_with_status (coarray
? descriptor
: var
, NULL_TREE
,
7657 NULL_TREE
, NULL_TREE
, NULL_TREE
, true,
7659 gfc_add_expr_to_block (&block
, tmp
);
7661 /* Zero the data pointer. */
7662 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
7663 var
, build_int_cst (TREE_TYPE (var
), 0));
7664 gfc_add_expr_to_block (&block
, tmp
);
7666 return gfc_finish_block (&block
);
7670 /* This helper function calculates the size in words of a full array. */
7673 gfc_full_array_size (stmtblock_t
*block
, tree decl
, int rank
)
7678 idx
= gfc_rank_cst
[rank
- 1];
7679 nelems
= gfc_conv_descriptor_ubound_get (decl
, idx
);
7680 tmp
= gfc_conv_descriptor_lbound_get (decl
, idx
);
7681 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7683 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7684 tmp
, gfc_index_one_node
);
7685 tmp
= gfc_evaluate_now (tmp
, block
);
7687 nelems
= gfc_conv_descriptor_stride_get (decl
, idx
);
7688 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7690 return gfc_evaluate_now (tmp
, block
);
7694 /* Allocate dest to the same size as src, and copy src -> dest.
7695 If no_malloc is set, only the copy is done. */
7698 duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
7699 bool no_malloc
, bool no_memcpy
, tree str_sz
,
7700 tree add_when_allocated
)
7709 /* If the source is null, set the destination to null. Then,
7710 allocate memory to the destination. */
7711 gfc_init_block (&block
);
7713 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
7715 tmp
= null_pointer_node
;
7716 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, type
, dest
, tmp
);
7717 gfc_add_expr_to_block (&block
, tmp
);
7718 null_data
= gfc_finish_block (&block
);
7720 gfc_init_block (&block
);
7721 if (str_sz
!= NULL_TREE
)
7724 size
= TYPE_SIZE_UNIT (TREE_TYPE (type
));
7728 tmp
= gfc_call_malloc (&block
, type
, size
);
7729 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
7730 dest
, fold_convert (type
, tmp
));
7731 gfc_add_expr_to_block (&block
, tmp
);
7736 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
7737 tmp
= build_call_expr_loc (input_location
, tmp
, 3, dest
, src
,
7738 fold_convert (size_type_node
, size
));
7739 gfc_add_expr_to_block (&block
, tmp
);
7744 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
7745 null_data
= gfc_finish_block (&block
);
7747 gfc_init_block (&block
);
7749 nelems
= gfc_full_array_size (&block
, src
, rank
);
7751 nelems
= gfc_index_one_node
;
7753 if (str_sz
!= NULL_TREE
)
7754 tmp
= fold_convert (gfc_array_index_type
, str_sz
);
7756 tmp
= fold_convert (gfc_array_index_type
,
7757 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
7758 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7762 tmp
= TREE_TYPE (gfc_conv_descriptor_data_get (src
));
7763 tmp
= gfc_call_malloc (&block
, tmp
, size
);
7764 gfc_conv_descriptor_data_set (&block
, dest
, tmp
);
7767 /* We know the temporary and the value will be the same length,
7768 so can use memcpy. */
7771 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
7772 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
7773 gfc_conv_descriptor_data_get (dest
),
7774 gfc_conv_descriptor_data_get (src
),
7775 fold_convert (size_type_node
, size
));
7776 gfc_add_expr_to_block (&block
, tmp
);
7780 gfc_add_expr_to_block (&block
, add_when_allocated
);
7781 tmp
= gfc_finish_block (&block
);
7783 /* Null the destination if the source is null; otherwise do
7784 the allocate and copy. */
7785 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src
)))
7788 null_cond
= gfc_conv_descriptor_data_get (src
);
7790 null_cond
= convert (pvoid_type_node
, null_cond
);
7791 null_cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7792 null_cond
, null_pointer_node
);
7793 return build3_v (COND_EXPR
, null_cond
, tmp
, null_data
);
7797 /* Allocate dest to the same size as src, and copy data src -> dest. */
7800 gfc_duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
7801 tree add_when_allocated
)
7803 return duplicate_allocatable (dest
, src
, type
, rank
, false, false,
7804 NULL_TREE
, add_when_allocated
);
7808 /* Copy data src -> dest. */
7811 gfc_copy_allocatable_data (tree dest
, tree src
, tree type
, int rank
)
7813 return duplicate_allocatable (dest
, src
, type
, rank
, true, false,
7814 NULL_TREE
, NULL_TREE
);
7817 /* Allocate dest to the same size as src, but don't copy anything. */
7820 gfc_duplicate_allocatable_nocopy (tree dest
, tree src
, tree type
, int rank
)
7822 return duplicate_allocatable (dest
, src
, type
, rank
, false, true,
7823 NULL_TREE
, NULL_TREE
);
7827 /* Recursively traverse an object of derived type, generating code to
7828 deallocate, nullify or copy allocatable components. This is the work horse
7829 function for the functions named in this enum. */
7831 enum {DEALLOCATE_ALLOC_COMP
= 1, DEALLOCATE_ALLOC_COMP_NO_CAF
,
7832 NULLIFY_ALLOC_COMP
, COPY_ALLOC_COMP
, COPY_ONLY_ALLOC_COMP
,
7833 COPY_ALLOC_COMP_CAF
};
7836 structure_alloc_comps (gfc_symbol
* der_type
, tree decl
,
7837 tree dest
, int rank
, int purpose
)
7841 stmtblock_t fnblock
;
7842 stmtblock_t loopbody
;
7843 stmtblock_t tmpblock
;
7854 tree null_cond
= NULL_TREE
;
7855 tree add_when_allocated
;
7856 bool called_dealloc_with_status
;
7858 gfc_init_block (&fnblock
);
7860 decl_type
= TREE_TYPE (decl
);
7862 if ((POINTER_TYPE_P (decl_type
))
7863 || (TREE_CODE (decl_type
) == REFERENCE_TYPE
&& rank
== 0))
7865 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
7866 /* Deref dest in sync with decl, but only when it is not NULL. */
7868 dest
= build_fold_indirect_ref_loc (input_location
, dest
);
7871 /* Just in case it gets dereferenced. */
7872 decl_type
= TREE_TYPE (decl
);
7874 /* If this is an array of derived types with allocatable components
7875 build a loop and recursively call this function. */
7876 if (TREE_CODE (decl_type
) == ARRAY_TYPE
7877 || (GFC_DESCRIPTOR_TYPE_P (decl_type
) && rank
!= 0))
7879 tmp
= gfc_conv_array_data (decl
);
7880 var
= build_fold_indirect_ref_loc (input_location
, tmp
);
7882 /* Get the number of elements - 1 and set the counter. */
7883 if (GFC_DESCRIPTOR_TYPE_P (decl_type
))
7885 /* Use the descriptor for an allocatable array. Since this
7886 is a full array reference, we only need the descriptor
7887 information from dimension = rank. */
7888 tmp
= gfc_full_array_size (&fnblock
, decl
, rank
);
7889 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7890 gfc_array_index_type
, tmp
,
7891 gfc_index_one_node
);
7893 null_cond
= gfc_conv_descriptor_data_get (decl
);
7894 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
7895 boolean_type_node
, null_cond
,
7896 build_int_cst (TREE_TYPE (null_cond
), 0));
7900 /* Otherwise use the TYPE_DOMAIN information. */
7901 tmp
= array_type_nelts (decl_type
);
7902 tmp
= fold_convert (gfc_array_index_type
, tmp
);
7905 /* Remember that this is, in fact, the no. of elements - 1. */
7906 nelems
= gfc_evaluate_now (tmp
, &fnblock
);
7907 index
= gfc_create_var (gfc_array_index_type
, "S");
7909 /* Build the body of the loop. */
7910 gfc_init_block (&loopbody
);
7912 vref
= gfc_build_array_ref (var
, index
, NULL
);
7914 if (purpose
== COPY_ALLOC_COMP
|| purpose
== COPY_ONLY_ALLOC_COMP
)
7916 tmp
= build_fold_indirect_ref_loc (input_location
,
7917 gfc_conv_array_data (dest
));
7918 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
7919 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
,
7923 tmp
= structure_alloc_comps (der_type
, vref
, NULL_TREE
, rank
, purpose
);
7925 gfc_add_expr_to_block (&loopbody
, tmp
);
7927 /* Build the loop and return. */
7928 gfc_init_loopinfo (&loop
);
7930 loop
.from
[0] = gfc_index_zero_node
;
7931 loop
.loopvar
[0] = index
;
7932 loop
.to
[0] = nelems
;
7933 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
7934 gfc_add_block_to_block (&fnblock
, &loop
.pre
);
7936 tmp
= gfc_finish_block (&fnblock
);
7937 /* When copying allocateable components, the above implements the
7938 deep copy. Nevertheless is a deep copy only allowed, when the current
7939 component is allocated, for which code will be generated in
7940 gfc_duplicate_allocatable (), where the deep copy code is just added
7941 into the if's body, by adding tmp (the deep copy code) as last
7942 argument to gfc_duplicate_allocatable (). */
7943 if (purpose
== COPY_ALLOC_COMP
7944 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
7945 tmp
= gfc_duplicate_allocatable (dest
, decl
, decl_type
, rank
,
7947 else if (null_cond
!= NULL_TREE
)
7948 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
7949 build_empty_stmt (input_location
));
7954 /* Otherwise, act on the components or recursively call self to
7955 act on a chain of components. */
7956 for (c
= der_type
->components
; c
; c
= c
->next
)
7958 bool cmp_has_alloc_comps
= (c
->ts
.type
== BT_DERIVED
7959 || c
->ts
.type
== BT_CLASS
)
7960 && c
->ts
.u
.derived
->attr
.alloc_comp
;
7961 cdecl = c
->backend_decl
;
7962 ctype
= TREE_TYPE (cdecl);
7966 case DEALLOCATE_ALLOC_COMP
:
7967 case DEALLOCATE_ALLOC_COMP_NO_CAF
:
7969 /* gfc_deallocate_scalar_with_status calls gfc_deallocate_alloc_comp
7970 (i.e. this function) so generate all the calls and suppress the
7971 recursion from here, if necessary. */
7972 called_dealloc_with_status
= false;
7973 gfc_init_block (&tmpblock
);
7975 if ((c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
)
7976 || (c
->ts
.type
== BT_CLASS
&& !CLASS_DATA (c
)->attr
.class_pointer
))
7978 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7979 decl
, cdecl, NULL_TREE
);
7981 /* The finalizer frees allocatable components. */
7982 called_dealloc_with_status
7983 = gfc_add_comp_finalizer_call (&tmpblock
, comp
, c
,
7984 purpose
== DEALLOCATE_ALLOC_COMP
);
7989 if (c
->attr
.allocatable
&& !c
->attr
.proc_pointer
7990 && (c
->attr
.dimension
7991 || (c
->attr
.codimension
7992 && purpose
!= DEALLOCATE_ALLOC_COMP_NO_CAF
)))
7994 if (comp
== NULL_TREE
)
7995 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7996 decl
, cdecl, NULL_TREE
);
7997 tmp
= gfc_trans_dealloc_allocated (comp
, c
->attr
.codimension
, NULL
);
7998 gfc_add_expr_to_block (&tmpblock
, tmp
);
8000 else if (c
->attr
.allocatable
&& !c
->attr
.codimension
)
8002 /* Allocatable scalar components. */
8003 if (comp
== NULL_TREE
)
8004 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8005 decl
, cdecl, NULL_TREE
);
8007 tmp
= gfc_deallocate_scalar_with_status (comp
, NULL
, true, NULL
,
8009 gfc_add_expr_to_block (&tmpblock
, tmp
);
8010 called_dealloc_with_status
= true;
8012 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8013 void_type_node
, comp
,
8014 build_int_cst (TREE_TYPE (comp
), 0));
8015 gfc_add_expr_to_block (&tmpblock
, tmp
);
8017 else if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
8018 && (!CLASS_DATA (c
)->attr
.codimension
8019 || purpose
!= DEALLOCATE_ALLOC_COMP_NO_CAF
))
8021 /* Allocatable CLASS components. */
8023 /* Add reference to '_data' component. */
8024 tmp
= CLASS_DATA (c
)->backend_decl
;
8025 comp
= fold_build3_loc (input_location
, COMPONENT_REF
,
8026 TREE_TYPE (tmp
), comp
, tmp
, NULL_TREE
);
8028 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp
)))
8029 tmp
= gfc_trans_dealloc_allocated (comp
,
8030 CLASS_DATA (c
)->attr
.codimension
, NULL
);
8033 tmp
= gfc_deallocate_scalar_with_status (comp
, NULL_TREE
, true, NULL
,
8034 CLASS_DATA (c
)->ts
);
8035 gfc_add_expr_to_block (&tmpblock
, tmp
);
8036 called_dealloc_with_status
= true;
8038 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8039 void_type_node
, comp
,
8040 build_int_cst (TREE_TYPE (comp
), 0));
8042 gfc_add_expr_to_block (&tmpblock
, tmp
);
8044 /* Finally, reset the vptr to the declared type vtable and, if
8045 necessary reset the _len field.
8047 First recover the reference to the component and obtain
8049 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8050 decl
, cdecl, NULL_TREE
);
8051 tmp
= gfc_class_vptr_get (comp
);
8053 if (UNLIMITED_POLY (c
))
8055 /* Both vptr and _len field should be nulled. */
8056 gfc_add_modify (&tmpblock
, tmp
,
8057 build_int_cst (TREE_TYPE (tmp
), 0));
8058 tmp
= gfc_class_len_get (comp
);
8059 gfc_add_modify (&tmpblock
, tmp
,
8060 build_int_cst (TREE_TYPE (tmp
), 0));
8064 /* Build the vtable address and set the vptr with it. */
8067 vtable
= gfc_find_derived_vtab (c
->ts
.u
.derived
);
8068 vtab
= vtable
->backend_decl
;
8069 if (vtab
== NULL_TREE
)
8070 vtab
= gfc_get_symbol_decl (vtable
);
8071 vtab
= gfc_build_addr_expr (NULL
, vtab
);
8072 vtab
= fold_convert (TREE_TYPE (tmp
), vtab
);
8073 gfc_add_modify (&tmpblock
, tmp
, vtab
);
8077 if (cmp_has_alloc_comps
8078 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
8079 && !called_dealloc_with_status
)
8081 /* Do not deallocate the components of ultimate pointer
8082 components or iteratively call self if call has been made
8083 to gfc_trans_dealloc_allocated */
8084 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8085 decl
, cdecl, NULL_TREE
);
8086 rank
= c
->as
? c
->as
->rank
: 0;
8087 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
8089 gfc_add_expr_to_block (&fnblock
, tmp
);
8092 /* Now add the deallocation of this component. */
8093 gfc_add_block_to_block (&fnblock
, &tmpblock
);
8096 case NULLIFY_ALLOC_COMP
:
8097 if (c
->attr
.pointer
|| c
->attr
.proc_pointer
)
8099 else if (c
->attr
.allocatable
8100 && (c
->attr
.dimension
|| c
->attr
.codimension
))
8102 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8103 decl
, cdecl, NULL_TREE
);
8104 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
8106 else if (c
->attr
.allocatable
)
8108 /* Allocatable scalar components. */
8109 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8110 decl
, cdecl, NULL_TREE
);
8111 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8112 void_type_node
, comp
,
8113 build_int_cst (TREE_TYPE (comp
), 0));
8114 gfc_add_expr_to_block (&fnblock
, tmp
);
8115 if (gfc_deferred_strlen (c
, &comp
))
8117 comp
= fold_build3_loc (input_location
, COMPONENT_REF
,
8119 decl
, comp
, NULL_TREE
);
8120 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8121 TREE_TYPE (comp
), comp
,
8122 build_int_cst (TREE_TYPE (comp
), 0));
8123 gfc_add_expr_to_block (&fnblock
, tmp
);
8126 else if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
8128 /* Allocatable CLASS components. */
8129 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8130 decl
, cdecl, NULL_TREE
);
8131 /* Add reference to '_data' component. */
8132 tmp
= CLASS_DATA (c
)->backend_decl
;
8133 comp
= fold_build3_loc (input_location
, COMPONENT_REF
,
8134 TREE_TYPE (tmp
), comp
, tmp
, NULL_TREE
);
8135 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp
)))
8136 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
8139 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8140 void_type_node
, comp
,
8141 build_int_cst (TREE_TYPE (comp
), 0));
8142 gfc_add_expr_to_block (&fnblock
, tmp
);
8145 else if (cmp_has_alloc_comps
)
8147 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8148 decl
, cdecl, NULL_TREE
);
8149 rank
= c
->as
? c
->as
->rank
: 0;
8150 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
8152 gfc_add_expr_to_block (&fnblock
, tmp
);
8156 case COPY_ALLOC_COMP_CAF
:
8157 if (!c
->attr
.codimension
8158 && (c
->ts
.type
!= BT_CLASS
|| CLASS_DATA (c
)->attr
.coarray_comp
)
8159 && (c
->ts
.type
!= BT_DERIVED
8160 || !c
->ts
.u
.derived
->attr
.coarray_comp
))
8163 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, decl
,
8165 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, dest
,
8168 if (c
->attr
.codimension
)
8170 if (c
->ts
.type
== BT_CLASS
)
8172 comp
= gfc_class_data_get (comp
);
8173 dcmp
= gfc_class_data_get (dcmp
);
8175 gfc_conv_descriptor_data_set (&fnblock
, dcmp
,
8176 gfc_conv_descriptor_data_get (comp
));
8180 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, dcmp
,
8182 gfc_add_expr_to_block (&fnblock
, tmp
);
8187 case COPY_ALLOC_COMP
:
8188 if (c
->attr
.pointer
)
8191 /* We need source and destination components. */
8192 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, decl
,
8194 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, dest
,
8196 dcmp
= fold_convert (TREE_TYPE (comp
), dcmp
);
8198 if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
8206 dst_data
= gfc_class_data_get (dcmp
);
8207 src_data
= gfc_class_data_get (comp
);
8208 size
= fold_convert (size_type_node
,
8209 gfc_class_vtab_size_get (comp
));
8211 if (CLASS_DATA (c
)->attr
.dimension
)
8213 nelems
= gfc_conv_descriptor_size (src_data
,
8214 CLASS_DATA (c
)->as
->rank
);
8215 size
= fold_build2_loc (input_location
, MULT_EXPR
,
8216 size_type_node
, size
,
8217 fold_convert (size_type_node
,
8221 nelems
= build_int_cst (size_type_node
, 1);
8223 if (CLASS_DATA (c
)->attr
.dimension
8224 || CLASS_DATA (c
)->attr
.codimension
)
8226 src_data
= gfc_conv_descriptor_data_get (src_data
);
8227 dst_data
= gfc_conv_descriptor_data_get (dst_data
);
8230 gfc_init_block (&tmpblock
);
8232 /* Coarray component have to have the same allocation status and
8233 shape/type-parameter/effective-type on the LHS and RHS of an
8234 intrinsic assignment. Hence, we did not deallocated them - and
8235 do not allocate them here. */
8236 if (!CLASS_DATA (c
)->attr
.codimension
)
8238 ftn_tree
= builtin_decl_explicit (BUILT_IN_MALLOC
);
8239 tmp
= build_call_expr_loc (input_location
, ftn_tree
, 1, size
);
8240 gfc_add_modify (&tmpblock
, dst_data
,
8241 fold_convert (TREE_TYPE (dst_data
), tmp
));
8244 tmp
= gfc_copy_class_to_class (comp
, dcmp
, nelems
,
8245 UNLIMITED_POLY (c
));
8246 gfc_add_expr_to_block (&tmpblock
, tmp
);
8247 tmp
= gfc_finish_block (&tmpblock
);
8249 gfc_init_block (&tmpblock
);
8250 gfc_add_modify (&tmpblock
, dst_data
,
8251 fold_convert (TREE_TYPE (dst_data
),
8252 null_pointer_node
));
8253 null_data
= gfc_finish_block (&tmpblock
);
8255 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
8256 boolean_type_node
, src_data
,
8259 gfc_add_expr_to_block (&fnblock
, build3_v (COND_EXPR
, null_cond
,
8264 /* To implement guarded deep copy, i.e., deep copy only allocatable
8265 components that are really allocated, the deep copy code has to
8266 be generated first and then added to the if-block in
8267 gfc_duplicate_allocatable (). */
8268 if (cmp_has_alloc_comps
8269 && !c
->attr
.proc_pointer
)
8271 rank
= c
->as
? c
->as
->rank
: 0;
8272 tmp
= fold_convert (TREE_TYPE (dcmp
), comp
);
8273 gfc_add_modify (&fnblock
, dcmp
, tmp
);
8274 add_when_allocated
= structure_alloc_comps (c
->ts
.u
.derived
,
8279 add_when_allocated
= NULL_TREE
;
8281 if (gfc_deferred_strlen (c
, &tmp
))
8285 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
8287 decl
, len
, NULL_TREE
);
8288 len
= fold_build3_loc (input_location
, COMPONENT_REF
,
8290 dest
, len
, NULL_TREE
);
8291 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8292 TREE_TYPE (len
), len
, tmp
);
8293 gfc_add_expr_to_block (&fnblock
, tmp
);
8294 size
= size_of_string_in_bytes (c
->ts
.kind
, len
);
8295 /* This component can not have allocatable components,
8296 therefore add_when_allocated of duplicate_allocatable ()
8298 tmp
= duplicate_allocatable (dcmp
, comp
, ctype
, rank
,
8299 false, false, size
, NULL_TREE
);
8300 gfc_add_expr_to_block (&fnblock
, tmp
);
8302 else if (c
->attr
.allocatable
&& !c
->attr
.proc_pointer
8303 && (!(cmp_has_alloc_comps
&& c
->as
)
8304 || c
->attr
.codimension
))
8306 rank
= c
->as
? c
->as
->rank
: 0;
8307 if (c
->attr
.codimension
)
8308 tmp
= gfc_copy_allocatable_data (dcmp
, comp
, ctype
, rank
);
8310 tmp
= gfc_duplicate_allocatable (dcmp
, comp
, ctype
, rank
,
8311 add_when_allocated
);
8312 gfc_add_expr_to_block (&fnblock
, tmp
);
8315 if (cmp_has_alloc_comps
)
8316 gfc_add_expr_to_block (&fnblock
, add_when_allocated
);
8326 return gfc_finish_block (&fnblock
);
8329 /* Recursively traverse an object of derived type, generating code to
8330 nullify allocatable components. */
8333 gfc_nullify_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
8335 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
8336 NULLIFY_ALLOC_COMP
);
8340 /* Recursively traverse an object of derived type, generating code to
8341 deallocate allocatable components. */
8344 gfc_deallocate_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
8346 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
8347 DEALLOCATE_ALLOC_COMP
);
8351 /* Recursively traverse an object of derived type, generating code to
8352 deallocate allocatable components. But do not deallocate coarrays.
8353 To be used for intrinsic assignment, which may not change the allocation
8354 status of coarrays. */
8357 gfc_deallocate_alloc_comp_no_caf (gfc_symbol
* der_type
, tree decl
, int rank
)
8359 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
8360 DEALLOCATE_ALLOC_COMP_NO_CAF
);
8365 gfc_reassign_alloc_comp_caf (gfc_symbol
*der_type
, tree decl
, tree dest
)
8367 return structure_alloc_comps (der_type
, decl
, dest
, 0, COPY_ALLOC_COMP_CAF
);
8371 /* Recursively traverse an object of derived type, generating code to
8372 copy it and its allocatable components. */
8375 gfc_copy_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
8377 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ALLOC_COMP
);
8381 /* Recursively traverse an object of derived type, generating code to
8382 copy only its allocatable components. */
8385 gfc_copy_only_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
8387 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ONLY_ALLOC_COMP
);
8391 /* Returns the value of LBOUND for an expression. This could be broken out
8392 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
8393 called by gfc_alloc_allocatable_for_assignment. */
8395 get_std_lbound (gfc_expr
*expr
, tree desc
, int dim
, bool assumed_size
)
8400 tree cond
, cond1
, cond3
, cond4
;
8404 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
8406 tmp
= gfc_rank_cst
[dim
];
8407 lbound
= gfc_conv_descriptor_lbound_get (desc
, tmp
);
8408 ubound
= gfc_conv_descriptor_ubound_get (desc
, tmp
);
8409 stride
= gfc_conv_descriptor_stride_get (desc
, tmp
);
8410 cond1
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
8412 cond3
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
8413 stride
, gfc_index_zero_node
);
8414 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8415 boolean_type_node
, cond3
, cond1
);
8416 cond4
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
8417 stride
, gfc_index_zero_node
);
8419 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
8420 tmp
, build_int_cst (gfc_array_index_type
,
8423 cond
= boolean_false_node
;
8425 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
8426 boolean_type_node
, cond3
, cond4
);
8427 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
8428 boolean_type_node
, cond
, cond1
);
8430 return fold_build3_loc (input_location
, COND_EXPR
,
8431 gfc_array_index_type
, cond
,
8432 lbound
, gfc_index_one_node
);
8435 if (expr
->expr_type
== EXPR_FUNCTION
)
8437 /* A conversion function, so use the argument. */
8438 gcc_assert (expr
->value
.function
.isym
8439 && expr
->value
.function
.isym
->conversion
);
8440 expr
= expr
->value
.function
.actual
->expr
;
8443 if (expr
->expr_type
== EXPR_VARIABLE
)
8445 tmp
= TREE_TYPE (expr
->symtree
->n
.sym
->backend_decl
);
8446 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
8448 if (ref
->type
== REF_COMPONENT
8449 && ref
->u
.c
.component
->as
8451 && ref
->next
->u
.ar
.type
== AR_FULL
)
8452 tmp
= TREE_TYPE (ref
->u
.c
.component
->backend_decl
);
8454 return GFC_TYPE_ARRAY_LBOUND(tmp
, dim
);
8457 return gfc_index_one_node
;
8461 /* Returns true if an expression represents an lhs that can be reallocated
8465 gfc_is_reallocatable_lhs (gfc_expr
*expr
)
8472 /* An allocatable variable. */
8473 if (expr
->symtree
->n
.sym
->attr
.allocatable
8475 && expr
->ref
->type
== REF_ARRAY
8476 && expr
->ref
->u
.ar
.type
== AR_FULL
)
8479 /* All that can be left are allocatable components. */
8480 if ((expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
8481 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
8482 || !expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
8485 /* Find a component ref followed by an array reference. */
8486 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
8488 && ref
->type
== REF_COMPONENT
8489 && ref
->next
->type
== REF_ARRAY
8490 && !ref
->next
->next
)
8496 /* Return true if valid reallocatable lhs. */
8497 if (ref
->u
.c
.component
->attr
.allocatable
8498 && ref
->next
->u
.ar
.type
== AR_FULL
)
8506 concat_str_length (gfc_expr
* expr
)
8513 type
= gfc_typenode_for_spec (&expr
->value
.op
.op1
->ts
);
8514 len1
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
8515 if (len1
== NULL_TREE
)
8517 if (expr
->value
.op
.op1
->expr_type
== EXPR_OP
)
8518 len1
= concat_str_length (expr
->value
.op
.op1
);
8519 else if (expr
->value
.op
.op1
->expr_type
== EXPR_CONSTANT
)
8520 len1
= build_int_cst (gfc_charlen_type_node
,
8521 expr
->value
.op
.op1
->value
.character
.length
);
8522 else if (expr
->value
.op
.op1
->ts
.u
.cl
->length
)
8524 gfc_init_se (&se
, NULL
);
8525 gfc_conv_expr (&se
, expr
->value
.op
.op1
->ts
.u
.cl
->length
);
8531 gfc_init_se (&se
, NULL
);
8532 se
.want_pointer
= 1;
8533 se
.descriptor_only
= 1;
8534 gfc_conv_expr (&se
, expr
->value
.op
.op1
);
8535 len1
= se
.string_length
;
8539 type
= gfc_typenode_for_spec (&expr
->value
.op
.op2
->ts
);
8540 len2
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
8541 if (len2
== NULL_TREE
)
8543 if (expr
->value
.op
.op2
->expr_type
== EXPR_OP
)
8544 len2
= concat_str_length (expr
->value
.op
.op2
);
8545 else if (expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
8546 len2
= build_int_cst (gfc_charlen_type_node
,
8547 expr
->value
.op
.op2
->value
.character
.length
);
8548 else if (expr
->value
.op
.op2
->ts
.u
.cl
->length
)
8550 gfc_init_se (&se
, NULL
);
8551 gfc_conv_expr (&se
, expr
->value
.op
.op2
->ts
.u
.cl
->length
);
8557 gfc_init_se (&se
, NULL
);
8558 se
.want_pointer
= 1;
8559 se
.descriptor_only
= 1;
8560 gfc_conv_expr (&se
, expr
->value
.op
.op2
);
8561 len2
= se
.string_length
;
8565 gcc_assert(len1
&& len2
);
8566 len1
= fold_convert (gfc_charlen_type_node
, len1
);
8567 len2
= fold_convert (gfc_charlen_type_node
, len2
);
8569 return fold_build2_loc (input_location
, PLUS_EXPR
,
8570 gfc_charlen_type_node
, len1
, len2
);
8574 /* Allocate the lhs of an assignment to an allocatable array, otherwise
8578 gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop
,
8582 stmtblock_t realloc_block
;
8583 stmtblock_t alloc_block
;
8587 gfc_array_info
*linfo
;
8609 gfc_array_spec
* as
;
8611 /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
8612 Find the lhs expression in the loop chain and set expr1 and
8613 expr2 accordingly. */
8614 if (expr1
->expr_type
== EXPR_FUNCTION
&& expr2
== NULL
)
8617 /* Find the ss for the lhs. */
8619 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
8620 if (lss
->info
->expr
&& lss
->info
->expr
->expr_type
== EXPR_VARIABLE
)
8622 if (lss
== gfc_ss_terminator
)
8624 expr1
= lss
->info
->expr
;
8627 /* Bail out if this is not a valid allocate on assignment. */
8628 if (!gfc_is_reallocatable_lhs (expr1
)
8629 || (expr2
&& !expr2
->rank
))
8632 /* Find the ss for the lhs. */
8634 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
8635 if (lss
->info
->expr
== expr1
)
8638 if (lss
== gfc_ss_terminator
)
8641 linfo
= &lss
->info
->data
.array
;
8643 /* Find an ss for the rhs. For operator expressions, we see the
8644 ss's for the operands. Any one of these will do. */
8646 for (; rss
&& rss
!= gfc_ss_terminator
; rss
= rss
->loop_chain
)
8647 if (rss
->info
->expr
!= expr1
&& rss
!= loop
->temp_ss
)
8650 if (expr2
&& rss
== gfc_ss_terminator
)
8653 gfc_start_block (&fblock
);
8655 /* Since the lhs is allocatable, this must be a descriptor type.
8656 Get the data and array size. */
8657 desc
= linfo
->descriptor
;
8658 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)));
8659 array1
= gfc_conv_descriptor_data_get (desc
);
8661 /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
8662 deallocated if expr is an array of different shape or any of the
8663 corresponding length type parameter values of variable and expr
8664 differ." This assures F95 compatibility. */
8665 jump_label1
= gfc_build_label_decl (NULL_TREE
);
8666 jump_label2
= gfc_build_label_decl (NULL_TREE
);
8668 /* Allocate if data is NULL. */
8669 cond_null
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
8670 array1
, build_int_cst (TREE_TYPE (array1
), 0));
8672 if (expr1
->ts
.deferred
)
8673 cond_null
= gfc_evaluate_now (boolean_true_node
, &fblock
);
8675 cond_null
= gfc_evaluate_now (cond_null
, &fblock
);
8677 tmp
= build3_v (COND_EXPR
, cond_null
,
8678 build1_v (GOTO_EXPR
, jump_label1
),
8679 build_empty_stmt (input_location
));
8680 gfc_add_expr_to_block (&fblock
, tmp
);
8682 /* Get arrayspec if expr is a full array. */
8683 if (expr2
&& expr2
->expr_type
== EXPR_FUNCTION
8684 && expr2
->value
.function
.isym
8685 && expr2
->value
.function
.isym
->conversion
)
8687 /* For conversion functions, take the arg. */
8688 gfc_expr
*arg
= expr2
->value
.function
.actual
->expr
;
8689 as
= gfc_get_full_arrayspec_from_expr (arg
);
8692 as
= gfc_get_full_arrayspec_from_expr (expr2
);
8696 /* If the lhs shape is not the same as the rhs jump to setting the
8697 bounds and doing the reallocation....... */
8698 for (n
= 0; n
< expr1
->rank
; n
++)
8700 /* Check the shape. */
8701 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
8702 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
8703 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8704 gfc_array_index_type
,
8705 loop
->to
[n
], loop
->from
[n
]);
8706 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8707 gfc_array_index_type
,
8709 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8710 gfc_array_index_type
,
8712 cond
= fold_build2_loc (input_location
, NE_EXPR
,
8714 tmp
, gfc_index_zero_node
);
8715 tmp
= build3_v (COND_EXPR
, cond
,
8716 build1_v (GOTO_EXPR
, jump_label1
),
8717 build_empty_stmt (input_location
));
8718 gfc_add_expr_to_block (&fblock
, tmp
);
8721 /* ....else jump past the (re)alloc code. */
8722 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
8723 gfc_add_expr_to_block (&fblock
, tmp
);
8725 /* Add the label to start automatic (re)allocation. */
8726 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
8727 gfc_add_expr_to_block (&fblock
, tmp
);
8729 /* If the lhs has not been allocated, its bounds will not have been
8730 initialized and so its size is set to zero. */
8731 size1
= gfc_create_var (gfc_array_index_type
, NULL
);
8732 gfc_init_block (&alloc_block
);
8733 gfc_add_modify (&alloc_block
, size1
, gfc_index_zero_node
);
8734 gfc_init_block (&realloc_block
);
8735 gfc_add_modify (&realloc_block
, size1
,
8736 gfc_conv_descriptor_size (desc
, expr1
->rank
));
8737 tmp
= build3_v (COND_EXPR
, cond_null
,
8738 gfc_finish_block (&alloc_block
),
8739 gfc_finish_block (&realloc_block
));
8740 gfc_add_expr_to_block (&fblock
, tmp
);
8742 /* Get the rhs size and fix it. */
8744 desc2
= rss
->info
->data
.array
.descriptor
;
8748 size2
= gfc_index_one_node
;
8749 for (n
= 0; n
< expr2
->rank
; n
++)
8751 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8752 gfc_array_index_type
,
8753 loop
->to
[n
], loop
->from
[n
]);
8754 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8755 gfc_array_index_type
,
8756 tmp
, gfc_index_one_node
);
8757 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
8758 gfc_array_index_type
,
8761 size2
= gfc_evaluate_now (size2
, &fblock
);
8763 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
8766 /* If the lhs is deferred length, assume that the element size
8767 changes and force a reallocation. */
8768 if (expr1
->ts
.deferred
)
8769 neq_size
= gfc_evaluate_now (boolean_true_node
, &fblock
);
8771 neq_size
= gfc_evaluate_now (cond
, &fblock
);
8773 /* Deallocation of allocatable components will have to occur on
8774 reallocation. Fix the old descriptor now. */
8775 if ((expr1
->ts
.type
== BT_DERIVED
)
8776 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
8777 old_desc
= gfc_evaluate_now (desc
, &fblock
);
8779 old_desc
= NULL_TREE
;
8781 /* Now modify the lhs descriptor and the associated scalarizer
8782 variables. F2003 7.4.1.3: "If variable is or becomes an
8783 unallocated allocatable variable, then it is allocated with each
8784 deferred type parameter equal to the corresponding type parameters
8785 of expr , with the shape of expr , and with each lower bound equal
8786 to the corresponding element of LBOUND(expr)."
8787 Reuse size1 to keep a dimension-by-dimension track of the
8788 stride of the new array. */
8789 size1
= gfc_index_one_node
;
8790 offset
= gfc_index_zero_node
;
8792 for (n
= 0; n
< expr2
->rank
; n
++)
8794 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8795 gfc_array_index_type
,
8796 loop
->to
[n
], loop
->from
[n
]);
8797 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8798 gfc_array_index_type
,
8799 tmp
, gfc_index_one_node
);
8801 lbound
= gfc_index_one_node
;
8806 lbd
= get_std_lbound (expr2
, desc2
, n
,
8807 as
->type
== AS_ASSUMED_SIZE
);
8808 ubound
= fold_build2_loc (input_location
,
8810 gfc_array_index_type
,
8812 ubound
= fold_build2_loc (input_location
,
8814 gfc_array_index_type
,
8819 gfc_conv_descriptor_lbound_set (&fblock
, desc
,
8822 gfc_conv_descriptor_ubound_set (&fblock
, desc
,
8825 gfc_conv_descriptor_stride_set (&fblock
, desc
,
8828 lbound
= gfc_conv_descriptor_lbound_get (desc
,
8830 tmp2
= fold_build2_loc (input_location
, MULT_EXPR
,
8831 gfc_array_index_type
,
8833 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
8834 gfc_array_index_type
,
8836 size1
= fold_build2_loc (input_location
, MULT_EXPR
,
8837 gfc_array_index_type
,
8841 /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
8842 the array offset is saved and the info.offset is used for a
8843 running offset. Use the saved_offset instead. */
8844 tmp
= gfc_conv_descriptor_offset (desc
);
8845 gfc_add_modify (&fblock
, tmp
, offset
);
8846 if (linfo
->saved_offset
8847 && TREE_CODE (linfo
->saved_offset
) == VAR_DECL
)
8848 gfc_add_modify (&fblock
, linfo
->saved_offset
, tmp
);
8850 /* Now set the deltas for the lhs. */
8851 for (n
= 0; n
< expr1
->rank
; n
++)
8853 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
8855 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8856 gfc_array_index_type
, tmp
,
8858 if (linfo
->delta
[dim
]
8859 && TREE_CODE (linfo
->delta
[dim
]) == VAR_DECL
)
8860 gfc_add_modify (&fblock
, linfo
->delta
[dim
], tmp
);
8863 /* Get the new lhs size in bytes. */
8864 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
8866 if (expr2
->ts
.deferred
)
8868 if (TREE_CODE (expr2
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
8869 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
8871 tmp
= rss
->info
->string_length
;
8875 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
8876 if (!tmp
&& expr2
->expr_type
== EXPR_OP
8877 && expr2
->value
.op
.op
== INTRINSIC_CONCAT
)
8879 tmp
= concat_str_length (expr2
);
8880 expr2
->ts
.u
.cl
->backend_decl
= gfc_evaluate_now (tmp
, &fblock
);
8882 tmp
= fold_convert (TREE_TYPE (expr1
->ts
.u
.cl
->backend_decl
), tmp
);
8885 if (expr1
->ts
.u
.cl
->backend_decl
8886 && TREE_CODE (expr1
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
8887 gfc_add_modify (&fblock
, expr1
->ts
.u
.cl
->backend_decl
, tmp
);
8889 gfc_add_modify (&fblock
, lss
->info
->string_length
, tmp
);
8891 else if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.u
.cl
->backend_decl
)
8893 tmp
= TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
)));
8894 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8895 gfc_array_index_type
, tmp
,
8896 expr1
->ts
.u
.cl
->backend_decl
);
8899 tmp
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
8900 tmp
= fold_convert (gfc_array_index_type
, tmp
);
8901 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
8902 gfc_array_index_type
,
8904 size2
= fold_convert (size_type_node
, size2
);
8905 size2
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
8906 size2
, size_one_node
);
8907 size2
= gfc_evaluate_now (size2
, &fblock
);
8909 /* For deferred character length, the 'size' field of the dtype might
8910 have changed so set the dtype. */
8911 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
8912 && expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
8915 tmp
= gfc_conv_descriptor_dtype (desc
);
8916 if (expr2
->ts
.u
.cl
->backend_decl
)
8917 type
= gfc_typenode_for_spec (&expr2
->ts
);
8919 type
= gfc_typenode_for_spec (&expr1
->ts
);
8921 gfc_add_modify (&fblock
, tmp
,
8922 gfc_get_dtype_rank_type (expr1
->rank
,type
));
8925 /* Realloc expression. Note that the scalarizer uses desc.data
8926 in the array reference - (*desc.data)[<element>]. */
8927 gfc_init_block (&realloc_block
);
8929 if ((expr1
->ts
.type
== BT_DERIVED
)
8930 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
8932 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, old_desc
,
8934 gfc_add_expr_to_block (&realloc_block
, tmp
);
8937 tmp
= build_call_expr_loc (input_location
,
8938 builtin_decl_explicit (BUILT_IN_REALLOC
), 2,
8939 fold_convert (pvoid_type_node
, array1
),
8941 gfc_conv_descriptor_data_set (&realloc_block
,
8944 if ((expr1
->ts
.type
== BT_DERIVED
)
8945 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
8947 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, desc
,
8949 gfc_add_expr_to_block (&realloc_block
, tmp
);
8952 realloc_expr
= gfc_finish_block (&realloc_block
);
8954 /* Only reallocate if sizes are different. */
8955 tmp
= build3_v (COND_EXPR
, neq_size
, realloc_expr
,
8956 build_empty_stmt (input_location
));
8960 /* Malloc expression. */
8961 gfc_init_block (&alloc_block
);
8962 tmp
= build_call_expr_loc (input_location
,
8963 builtin_decl_explicit (BUILT_IN_MALLOC
),
8965 gfc_conv_descriptor_data_set (&alloc_block
,
8968 /* We already set the dtype in the case of deferred character
8970 if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
8971 && expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
))
8973 tmp
= gfc_conv_descriptor_dtype (desc
);
8974 gfc_add_modify (&alloc_block
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
8977 if ((expr1
->ts
.type
== BT_DERIVED
)
8978 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
8980 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, desc
,
8982 gfc_add_expr_to_block (&alloc_block
, tmp
);
8984 alloc_expr
= gfc_finish_block (&alloc_block
);
8986 /* Malloc if not allocated; realloc otherwise. */
8987 tmp
= build_int_cst (TREE_TYPE (array1
), 0);
8988 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
8991 tmp
= build3_v (COND_EXPR
, cond
, alloc_expr
, realloc_expr
);
8992 gfc_add_expr_to_block (&fblock
, tmp
);
8994 /* Make sure that the scalarizer data pointer is updated. */
8996 && TREE_CODE (linfo
->data
) == VAR_DECL
)
8998 tmp
= gfc_conv_descriptor_data_get (desc
);
8999 gfc_add_modify (&fblock
, linfo
->data
, tmp
);
9002 /* Add the exit label. */
9003 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
9004 gfc_add_expr_to_block (&fblock
, tmp
);
9006 return gfc_finish_block (&fblock
);
9010 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
9011 Do likewise, recursively if necessary, with the allocatable components of
9015 gfc_trans_deferred_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
9021 stmtblock_t cleanup
;
9024 bool sym_has_alloc_comp
, has_finalizer
;
9026 sym_has_alloc_comp
= (sym
->ts
.type
== BT_DERIVED
9027 || sym
->ts
.type
== BT_CLASS
)
9028 && sym
->ts
.u
.derived
->attr
.alloc_comp
;
9029 has_finalizer
= sym
->ts
.type
== BT_CLASS
|| sym
->ts
.type
== BT_DERIVED
9030 ? gfc_is_finalizable (sym
->ts
.u
.derived
, NULL
) : false;
9032 /* Make sure the frontend gets these right. */
9033 gcc_assert (sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym_has_alloc_comp
9036 gfc_save_backend_locus (&loc
);
9037 gfc_set_backend_locus (&sym
->declared_at
);
9038 gfc_init_block (&init
);
9040 gcc_assert (TREE_CODE (sym
->backend_decl
) == VAR_DECL
9041 || TREE_CODE (sym
->backend_decl
) == PARM_DECL
);
9043 if (sym
->ts
.type
== BT_CHARACTER
9044 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
9046 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
9047 gfc_trans_vla_type_sizes (sym
, &init
);
9050 /* Dummy, use associated and result variables don't need anything special. */
9051 if (sym
->attr
.dummy
|| sym
->attr
.use_assoc
|| sym
->attr
.result
)
9053 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
9054 gfc_restore_backend_locus (&loc
);
9058 descriptor
= sym
->backend_decl
;
9060 /* Although static, derived types with default initializers and
9061 allocatable components must not be nulled wholesale; instead they
9062 are treated component by component. */
9063 if (TREE_STATIC (descriptor
) && !sym_has_alloc_comp
&& !has_finalizer
)
9065 /* SAVEd variables are not freed on exit. */
9066 gfc_trans_static_array_pointer (sym
);
9068 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
9069 gfc_restore_backend_locus (&loc
);
9073 /* Get the descriptor type. */
9074 type
= TREE_TYPE (sym
->backend_decl
);
9076 if ((sym_has_alloc_comp
|| (has_finalizer
&& sym
->ts
.type
!= BT_CLASS
))
9077 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
9080 && !(TREE_STATIC (sym
->backend_decl
) && sym
->attr
.is_main_program
))
9082 if (sym
->value
== NULL
9083 || !gfc_has_default_initializer (sym
->ts
.u
.derived
))
9085 rank
= sym
->as
? sym
->as
->rank
: 0;
9086 tmp
= gfc_nullify_alloc_comp (sym
->ts
.u
.derived
,
9088 gfc_add_expr_to_block (&init
, tmp
);
9091 gfc_init_default_dt (sym
, &init
, false);
9094 else if (!GFC_DESCRIPTOR_TYPE_P (type
))
9096 /* If the backend_decl is not a descriptor, we must have a pointer
9098 descriptor
= build_fold_indirect_ref_loc (input_location
,
9100 type
= TREE_TYPE (descriptor
);
9103 /* NULLIFY the data pointer, for non-saved allocatables. */
9104 if (GFC_DESCRIPTOR_TYPE_P (type
) && !sym
->attr
.save
&& sym
->attr
.allocatable
)
9105 gfc_conv_descriptor_data_set (&init
, descriptor
, null_pointer_node
);
9107 gfc_restore_backend_locus (&loc
);
9108 gfc_init_block (&cleanup
);
9110 /* Allocatable arrays need to be freed when they go out of scope.
9111 The allocatable components of pointers must not be touched. */
9112 if (!sym
->attr
.allocatable
&& has_finalizer
&& sym
->ts
.type
!= BT_CLASS
9113 && !sym
->attr
.pointer
&& !sym
->attr
.artificial
&& !sym
->attr
.save
9114 && !sym
->ns
->proc_name
->attr
.is_main_program
)
9117 sym
->attr
.referenced
= 1;
9118 e
= gfc_lval_expr_from_sym (sym
);
9119 gfc_add_finalizer_call (&cleanup
, e
);
9122 else if ((!sym
->attr
.allocatable
|| !has_finalizer
)
9123 && sym_has_alloc_comp
&& !(sym
->attr
.function
|| sym
->attr
.result
)
9124 && !sym
->attr
.pointer
&& !sym
->attr
.save
9125 && !sym
->ns
->proc_name
->attr
.is_main_program
)
9128 rank
= sym
->as
? sym
->as
->rank
: 0;
9129 tmp
= gfc_deallocate_alloc_comp (sym
->ts
.u
.derived
, descriptor
, rank
);
9130 gfc_add_expr_to_block (&cleanup
, tmp
);
9133 if (sym
->attr
.allocatable
&& (sym
->attr
.dimension
|| sym
->attr
.codimension
)
9134 && !sym
->attr
.save
&& !sym
->attr
.result
9135 && !sym
->ns
->proc_name
->attr
.is_main_program
)
9138 e
= has_finalizer
? gfc_lval_expr_from_sym (sym
) : NULL
;
9139 tmp
= gfc_trans_dealloc_allocated (sym
->backend_decl
,
9140 sym
->attr
.codimension
, e
);
9143 gfc_add_expr_to_block (&cleanup
, tmp
);
9146 gfc_add_init_cleanup (block
, gfc_finish_block (&init
),
9147 gfc_finish_block (&cleanup
));
9150 /************ Expression Walking Functions ******************/
9152 /* Walk a variable reference.
9154 Possible extension - multiple component subscripts.
9155 x(:,:) = foo%a(:)%b(:)
9157 forall (i=..., j=...)
9158 x(i,j) = foo%a(j)%b(i)
9160 This adds a fair amount of complexity because you need to deal with more
9161 than one ref. Maybe handle in a similar manner to vector subscripts.
9162 Maybe not worth the effort. */
9166 gfc_walk_variable_expr (gfc_ss
* ss
, gfc_expr
* expr
)
9170 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
9171 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
9174 return gfc_walk_array_ref (ss
, expr
, ref
);
9179 gfc_walk_array_ref (gfc_ss
* ss
, gfc_expr
* expr
, gfc_ref
* ref
)
9185 for (; ref
; ref
= ref
->next
)
9187 if (ref
->type
== REF_SUBSTRING
)
9189 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.start
);
9190 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.end
);
9193 /* We're only interested in array sections from now on. */
9194 if (ref
->type
!= REF_ARRAY
)
9202 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
9203 ss
= gfc_get_scalar_ss (ss
, ar
->start
[n
]);
9207 newss
= gfc_get_array_ss (ss
, expr
, ar
->as
->rank
, GFC_SS_SECTION
);
9208 newss
->info
->data
.array
.ref
= ref
;
9210 /* Make sure array is the same as array(:,:), this way
9211 we don't need to special case all the time. */
9212 ar
->dimen
= ar
->as
->rank
;
9213 for (n
= 0; n
< ar
->dimen
; n
++)
9215 ar
->dimen_type
[n
] = DIMEN_RANGE
;
9217 gcc_assert (ar
->start
[n
] == NULL
);
9218 gcc_assert (ar
->end
[n
] == NULL
);
9219 gcc_assert (ar
->stride
[n
] == NULL
);
9225 newss
= gfc_get_array_ss (ss
, expr
, 0, GFC_SS_SECTION
);
9226 newss
->info
->data
.array
.ref
= ref
;
9228 /* We add SS chains for all the subscripts in the section. */
9229 for (n
= 0; n
< ar
->dimen
; n
++)
9233 switch (ar
->dimen_type
[n
])
9236 /* Add SS for elemental (scalar) subscripts. */
9237 gcc_assert (ar
->start
[n
]);
9238 indexss
= gfc_get_scalar_ss (gfc_ss_terminator
, ar
->start
[n
]);
9239 indexss
->loop_chain
= gfc_ss_terminator
;
9240 newss
->info
->data
.array
.subscript
[n
] = indexss
;
9244 /* We don't add anything for sections, just remember this
9245 dimension for later. */
9246 newss
->dim
[newss
->dimen
] = n
;
9251 /* Create a GFC_SS_VECTOR index in which we can store
9252 the vector's descriptor. */
9253 indexss
= gfc_get_array_ss (gfc_ss_terminator
, ar
->start
[n
],
9255 indexss
->loop_chain
= gfc_ss_terminator
;
9256 newss
->info
->data
.array
.subscript
[n
] = indexss
;
9257 newss
->dim
[newss
->dimen
] = n
;
9262 /* We should know what sort of section it is by now. */
9266 /* We should have at least one non-elemental dimension,
9267 unless we are creating a descriptor for a (scalar) coarray. */
9268 gcc_assert (newss
->dimen
> 0
9269 || newss
->info
->data
.array
.ref
->u
.ar
.as
->corank
> 0);
9274 /* We should know what sort of section it is by now. */
9283 /* Walk an expression operator. If only one operand of a binary expression is
9284 scalar, we must also add the scalar term to the SS chain. */
9287 gfc_walk_op_expr (gfc_ss
* ss
, gfc_expr
* expr
)
9292 head
= gfc_walk_subexpr (ss
, expr
->value
.op
.op1
);
9293 if (expr
->value
.op
.op2
== NULL
)
9296 head2
= gfc_walk_subexpr (head
, expr
->value
.op
.op2
);
9298 /* All operands are scalar. Pass back and let the caller deal with it. */
9302 /* All operands require scalarization. */
9303 if (head
!= ss
&& (expr
->value
.op
.op2
== NULL
|| head2
!= head
))
9306 /* One of the operands needs scalarization, the other is scalar.
9307 Create a gfc_ss for the scalar expression. */
9310 /* First operand is scalar. We build the chain in reverse order, so
9311 add the scalar SS after the second operand. */
9313 while (head
&& head
->next
!= ss
)
9315 /* Check we haven't somehow broken the chain. */
9317 head
->next
= gfc_get_scalar_ss (ss
, expr
->value
.op
.op1
);
9319 else /* head2 == head */
9321 gcc_assert (head2
== head
);
9322 /* Second operand is scalar. */
9323 head2
= gfc_get_scalar_ss (head2
, expr
->value
.op
.op2
);
9330 /* Reverse a SS chain. */
9333 gfc_reverse_ss (gfc_ss
* ss
)
9338 gcc_assert (ss
!= NULL
);
9340 head
= gfc_ss_terminator
;
9341 while (ss
!= gfc_ss_terminator
)
9344 /* Check we didn't somehow break the chain. */
9345 gcc_assert (next
!= NULL
);
9355 /* Given an expression referring to a procedure, return the symbol of its
9356 interface. We can't get the procedure symbol directly as we have to handle
9357 the case of (deferred) type-bound procedures. */
9360 gfc_get_proc_ifc_for_expr (gfc_expr
*procedure_ref
)
9365 if (procedure_ref
== NULL
)
9368 /* Normal procedure case. */
9369 if (procedure_ref
->expr_type
== EXPR_FUNCTION
9370 && procedure_ref
->value
.function
.esym
)
9371 sym
= procedure_ref
->value
.function
.esym
;
9373 sym
= procedure_ref
->symtree
->n
.sym
;
9375 /* Typebound procedure case. */
9376 for (ref
= procedure_ref
->ref
; ref
; ref
= ref
->next
)
9378 if (ref
->type
== REF_COMPONENT
9379 && ref
->u
.c
.component
->attr
.proc_pointer
)
9380 sym
= ref
->u
.c
.component
->ts
.interface
;
9389 /* Walk the arguments of an elemental function.
9390 PROC_EXPR is used to check whether an argument is permitted to be absent. If
9391 it is NULL, we don't do the check and the argument is assumed to be present.
9395 gfc_walk_elemental_function_args (gfc_ss
* ss
, gfc_actual_arglist
*arg
,
9396 gfc_symbol
*proc_ifc
, gfc_ss_type type
)
9398 gfc_formal_arglist
*dummy_arg
;
9404 head
= gfc_ss_terminator
;
9408 dummy_arg
= gfc_sym_get_dummy_args (proc_ifc
);
9413 for (; arg
; arg
= arg
->next
)
9415 if (!arg
->expr
|| arg
->expr
->expr_type
== EXPR_NULL
)
9418 newss
= gfc_walk_subexpr (head
, arg
->expr
);
9421 /* Scalar argument. */
9422 gcc_assert (type
== GFC_SS_SCALAR
|| type
== GFC_SS_REFERENCE
);
9423 newss
= gfc_get_scalar_ss (head
, arg
->expr
);
9424 newss
->info
->type
= type
;
9426 newss
->info
->data
.scalar
.dummy_arg
= dummy_arg
->sym
;
9431 if (dummy_arg
!= NULL
9432 && dummy_arg
->sym
->attr
.optional
9433 && arg
->expr
->expr_type
== EXPR_VARIABLE
9434 && (gfc_expr_attr (arg
->expr
).optional
9435 || gfc_expr_attr (arg
->expr
).allocatable
9436 || gfc_expr_attr (arg
->expr
).pointer
))
9437 newss
->info
->can_be_null_ref
= true;
9443 while (tail
->next
!= gfc_ss_terminator
)
9448 if (dummy_arg
!= NULL
)
9449 dummy_arg
= dummy_arg
->next
;
9454 /* If all the arguments are scalar we don't need the argument SS. */
9455 gfc_free_ss_chain (head
);
9460 /* Add it onto the existing chain. */
9466 /* Walk a function call. Scalar functions are passed back, and taken out of
9467 scalarization loops. For elemental functions we walk their arguments.
9468 The result of functions returning arrays is stored in a temporary outside
9469 the loop, so that the function is only called once. Hence we do not need
9470 to walk their arguments. */
9473 gfc_walk_function_expr (gfc_ss
* ss
, gfc_expr
* expr
)
9475 gfc_intrinsic_sym
*isym
;
9477 gfc_component
*comp
= NULL
;
9479 isym
= expr
->value
.function
.isym
;
9481 /* Handle intrinsic functions separately. */
9483 return gfc_walk_intrinsic_function (ss
, expr
, isym
);
9485 sym
= expr
->value
.function
.esym
;
9487 sym
= expr
->symtree
->n
.sym
;
9489 if (gfc_is_alloc_class_array_function (expr
))
9490 return gfc_get_array_ss (ss
, expr
,
9491 CLASS_DATA (expr
->value
.function
.esym
->result
)->as
->rank
,
9494 /* A function that returns arrays. */
9495 comp
= gfc_get_proc_ptr_comp (expr
);
9496 if ((!comp
&& gfc_return_by_reference (sym
) && sym
->result
->attr
.dimension
)
9497 || (comp
&& comp
->attr
.dimension
))
9498 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
9500 /* Walk the parameters of an elemental function. For now we always pass
9502 if (sym
->attr
.elemental
|| (comp
&& comp
->attr
.elemental
))
9504 gfc_ss
*old_ss
= ss
;
9506 ss
= gfc_walk_elemental_function_args (old_ss
,
9507 expr
->value
.function
.actual
,
9508 gfc_get_proc_ifc_for_expr (expr
),
9512 || sym
->attr
.proc_pointer
9513 || sym
->attr
.if_source
!= IFSRC_DECL
9514 || sym
->attr
.array_outer_dependency
))
9515 ss
->info
->array_outer_dependency
= 1;
9518 /* Scalar functions are OK as these are evaluated outside the scalarization
9519 loop. Pass back and let the caller deal with it. */
9524 /* An array temporary is constructed for array constructors. */
9527 gfc_walk_array_constructor (gfc_ss
* ss
, gfc_expr
* expr
)
9529 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_CONSTRUCTOR
);
9533 /* Walk an expression. Add walked expressions to the head of the SS chain.
9534 A wholly scalar expression will not be added. */
9537 gfc_walk_subexpr (gfc_ss
* ss
, gfc_expr
* expr
)
9541 switch (expr
->expr_type
)
9544 head
= gfc_walk_variable_expr (ss
, expr
);
9548 head
= gfc_walk_op_expr (ss
, expr
);
9552 head
= gfc_walk_function_expr (ss
, expr
);
9557 case EXPR_STRUCTURE
:
9558 /* Pass back and let the caller deal with it. */
9562 head
= gfc_walk_array_constructor (ss
, expr
);
9565 case EXPR_SUBSTRING
:
9566 /* Pass back and let the caller deal with it. */
9570 gfc_internal_error ("bad expression type during walk (%d)",
9577 /* Entry point for expression walking.
9578 A return value equal to the passed chain means this is
9579 a scalar expression. It is up to the caller to take whatever action is
9580 necessary to translate these. */
9583 gfc_walk_expr (gfc_expr
* expr
)
9587 res
= gfc_walk_subexpr (gfc_ss_terminator
, expr
);
9588 return gfc_reverse_ss (res
);