1 /* Array translation routines
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
4 Free Software Foundation, Inc.
5 Contributed by Paul Brook <paul@nowt.org>
6 and Steven Bosscher <s.bosscher@student.tudelft.nl>
8 This file is part of GCC.
10 GCC is free software; you can redistribute it and/or modify it under
11 the terms of the GNU General Public License as published by the Free
12 Software Foundation; either version 3, or (at your option) any later
15 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
16 WARRANTY; without even the implied warranty of MERCHANTABILITY or
17 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
20 You should have received a copy of the GNU General Public License
21 along with GCC; see the file COPYING3. If not see
22 <http://www.gnu.org/licenses/>. */
24 /* trans-array.c-- Various array related code, including scalarization,
25 allocation, initialization and other support routines. */
27 /* How the scalarizer works.
28 In gfortran, array expressions use the same core routines as scalar
30 First, a Scalarization State (SS) chain is built. This is done by walking
31 the expression tree, and building a linear list of the terms in the
32 expression. As the tree is walked, scalar subexpressions are translated.
34 The scalarization parameters are stored in a gfc_loopinfo structure.
35 First the start and stride of each term is calculated by
36 gfc_conv_ss_startstride. During this process the expressions for the array
37 descriptors and data pointers are also translated.
39 If the expression is an assignment, we must then resolve any dependencies.
40 In fortran all the rhs values of an assignment must be evaluated before
41 any assignments take place. This can require a temporary array to store the
42 values. We also require a temporary when we are passing array expressions
43 or vector subscripts as procedure parameters.
45 Array sections are passed without copying to a temporary. These use the
46 scalarizer to determine the shape of the section. The flag
47 loop->array_parameter tells the scalarizer that the actual values and loop
48 variables will not be required.
50 The function gfc_conv_loop_setup generates the scalarization setup code.
51 It determines the range of the scalarizing loop variables. If a temporary
52 is required, this is created and initialized. Code for scalar expressions
53 taken outside the loop is also generated at this time. Next the offset and
54 scaling required to translate from loop variables to array indices for each
57 A call to gfc_start_scalarized_body marks the start of the scalarized
58 expression. This creates a scope and declares the loop variables. Before
59 calling this gfc_make_ss_chain_used must be used to indicate which terms
60 will be used inside this loop.
62 The scalar gfc_conv_* functions are then used to build the main body of the
63 scalarization loop. Scalarization loop variables and precalculated scalar
64 values are automatically substituted. Note that gfc_advance_se_ss_chain
65 must be used, rather than changing the se->ss directly.
67 For assignment expressions requiring a temporary two sub loops are
68 generated. The first stores the result of the expression in the temporary,
69 the second copies it to the result. A call to
70 gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
71 the start of the copying loop. The temporary may be less than full rank.
73 Finally gfc_trans_scalarizing_loops is called to generate the implicit do
74 loops. The loops are added to the pre chain of the loopinfo. The post
75 chain may still contain cleanup code.
77 After the loop code has been added into its parent scope gfc_cleanup_loop
78 is called to free all the SS allocated by the scalarizer. */
82 #include "coretypes.h"
85 #include "diagnostic-core.h" /* For internal_error/fatal_error. */
88 #include "constructor.h"
90 #include "trans-stmt.h"
91 #include "trans-types.h"
92 #include "trans-array.h"
93 #include "trans-const.h"
94 #include "dependency.h"
96 static bool gfc_get_array_constructor_size (mpz_t
*, gfc_constructor_base
);
98 /* The contents of this structure aren't actually used, just the address. */
99 static gfc_ss gfc_ss_terminator_var
;
100 gfc_ss
* const gfc_ss_terminator
= &gfc_ss_terminator_var
;
104 gfc_array_dataptr_type (tree desc
)
106 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
)));
110 /* Build expressions to access the members of an array descriptor.
111 It's surprisingly easy to mess up here, so never access
112 an array descriptor by "brute force", always use these
113 functions. This also avoids problems if we change the format
114 of an array descriptor.
116 To understand these magic numbers, look at the comments
117 before gfc_build_array_type() in trans-types.c.
119 The code within these defines should be the only code which knows the format
120 of an array descriptor.
122 Any code just needing to read obtain the bounds of an array should use
123 gfc_conv_array_* rather than the following functions as these will return
124 know constant values, and work with arrays which do not have descriptors.
126 Don't forget to #undef these! */
129 #define OFFSET_FIELD 1
130 #define DTYPE_FIELD 2
131 #define DIMENSION_FIELD 3
132 #define CAF_TOKEN_FIELD 4
134 #define STRIDE_SUBFIELD 0
135 #define LBOUND_SUBFIELD 1
136 #define UBOUND_SUBFIELD 2
138 /* This provides READ-ONLY access to the data field. The field itself
139 doesn't have the proper type. */
142 gfc_conv_descriptor_data_get (tree desc
)
146 type
= TREE_TYPE (desc
);
147 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
149 field
= TYPE_FIELDS (type
);
150 gcc_assert (DATA_FIELD
== 0);
152 t
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
), desc
,
154 t
= fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type
), t
);
159 /* This provides WRITE access to the data field.
161 TUPLES_P is true if we are generating tuples.
163 This function gets called through the following macros:
164 gfc_conv_descriptor_data_set
165 gfc_conv_descriptor_data_set. */
168 gfc_conv_descriptor_data_set (stmtblock_t
*block
, tree desc
, tree value
)
172 type
= TREE_TYPE (desc
);
173 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
175 field
= TYPE_FIELDS (type
);
176 gcc_assert (DATA_FIELD
== 0);
178 t
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
), desc
,
180 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (field
), value
));
184 /* This provides address access to the data field. This should only be
185 used by array allocation, passing this on to the runtime. */
188 gfc_conv_descriptor_data_addr (tree desc
)
192 type
= TREE_TYPE (desc
);
193 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
195 field
= TYPE_FIELDS (type
);
196 gcc_assert (DATA_FIELD
== 0);
198 t
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
), desc
,
200 return gfc_build_addr_expr (NULL_TREE
, t
);
204 gfc_conv_descriptor_offset (tree desc
)
209 type
= TREE_TYPE (desc
);
210 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
212 field
= gfc_advance_chain (TYPE_FIELDS (type
), OFFSET_FIELD
);
213 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
215 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
216 desc
, field
, NULL_TREE
);
220 gfc_conv_descriptor_offset_get (tree desc
)
222 return gfc_conv_descriptor_offset (desc
);
226 gfc_conv_descriptor_offset_set (stmtblock_t
*block
, tree desc
,
229 tree t
= gfc_conv_descriptor_offset (desc
);
230 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
235 gfc_conv_descriptor_dtype (tree desc
)
240 type
= TREE_TYPE (desc
);
241 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
243 field
= gfc_advance_chain (TYPE_FIELDS (type
), DTYPE_FIELD
);
244 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
246 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
247 desc
, field
, NULL_TREE
);
251 gfc_conv_descriptor_dimension (tree desc
, tree dim
)
257 type
= TREE_TYPE (desc
);
258 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
260 field
= gfc_advance_chain (TYPE_FIELDS (type
), DIMENSION_FIELD
);
261 gcc_assert (field
!= NULL_TREE
262 && TREE_CODE (TREE_TYPE (field
)) == ARRAY_TYPE
263 && TREE_CODE (TREE_TYPE (TREE_TYPE (field
))) == RECORD_TYPE
);
265 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
266 desc
, field
, NULL_TREE
);
267 tmp
= gfc_build_array_ref (tmp
, dim
, NULL
);
273 gfc_conv_descriptor_token (tree desc
)
278 type
= TREE_TYPE (desc
);
279 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
280 gcc_assert (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ALLOCATABLE
);
281 gcc_assert (gfc_option
.coarray
== GFC_FCOARRAY_LIB
);
282 field
= gfc_advance_chain (TYPE_FIELDS (type
), CAF_TOKEN_FIELD
);
283 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == prvoid_type_node
);
285 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
286 desc
, field
, NULL_TREE
);
291 gfc_conv_descriptor_stride (tree desc
, tree dim
)
296 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
297 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
298 field
= gfc_advance_chain (field
, STRIDE_SUBFIELD
);
299 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
301 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
302 tmp
, field
, NULL_TREE
);
307 gfc_conv_descriptor_stride_get (tree desc
, tree dim
)
309 tree type
= TREE_TYPE (desc
);
310 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
311 if (integer_zerop (dim
)
312 && (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ALLOCATABLE
313 ||GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE_CONT
314 ||GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER_CONT
))
315 return gfc_index_one_node
;
317 return gfc_conv_descriptor_stride (desc
, dim
);
321 gfc_conv_descriptor_stride_set (stmtblock_t
*block
, tree desc
,
322 tree dim
, tree value
)
324 tree t
= gfc_conv_descriptor_stride (desc
, dim
);
325 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
329 gfc_conv_descriptor_lbound (tree desc
, tree dim
)
334 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
335 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
336 field
= gfc_advance_chain (field
, LBOUND_SUBFIELD
);
337 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
339 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
340 tmp
, field
, NULL_TREE
);
345 gfc_conv_descriptor_lbound_get (tree desc
, tree dim
)
347 return gfc_conv_descriptor_lbound (desc
, dim
);
351 gfc_conv_descriptor_lbound_set (stmtblock_t
*block
, tree desc
,
352 tree dim
, tree value
)
354 tree t
= gfc_conv_descriptor_lbound (desc
, dim
);
355 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
359 gfc_conv_descriptor_ubound (tree desc
, tree dim
)
364 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
365 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
366 field
= gfc_advance_chain (field
, UBOUND_SUBFIELD
);
367 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
369 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
370 tmp
, field
, NULL_TREE
);
375 gfc_conv_descriptor_ubound_get (tree desc
, tree dim
)
377 return gfc_conv_descriptor_ubound (desc
, dim
);
381 gfc_conv_descriptor_ubound_set (stmtblock_t
*block
, tree desc
,
382 tree dim
, tree value
)
384 tree t
= gfc_conv_descriptor_ubound (desc
, dim
);
385 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
388 /* Build a null array descriptor constructor. */
391 gfc_build_null_descriptor (tree type
)
396 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
397 gcc_assert (DATA_FIELD
== 0);
398 field
= TYPE_FIELDS (type
);
400 /* Set a NULL data pointer. */
401 tmp
= build_constructor_single (type
, field
, null_pointer_node
);
402 TREE_CONSTANT (tmp
) = 1;
403 /* All other fields are ignored. */
409 /* Modify a descriptor such that the lbound of a given dimension is the value
410 specified. This also updates ubound and offset accordingly. */
413 gfc_conv_shift_descriptor_lbound (stmtblock_t
* block
, tree desc
,
414 int dim
, tree new_lbound
)
416 tree offs
, ubound
, lbound
, stride
;
417 tree diff
, offs_diff
;
419 new_lbound
= fold_convert (gfc_array_index_type
, new_lbound
);
421 offs
= gfc_conv_descriptor_offset_get (desc
);
422 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]);
423 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]);
424 stride
= gfc_conv_descriptor_stride_get (desc
, gfc_rank_cst
[dim
]);
426 /* Get difference (new - old) by which to shift stuff. */
427 diff
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
430 /* Shift ubound and offset accordingly. This has to be done before
431 updating the lbound, as they depend on the lbound expression! */
432 ubound
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
434 gfc_conv_descriptor_ubound_set (block
, desc
, gfc_rank_cst
[dim
], ubound
);
435 offs_diff
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
437 offs
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
439 gfc_conv_descriptor_offset_set (block
, desc
, offs
);
441 /* Finally set lbound to value we want. */
442 gfc_conv_descriptor_lbound_set (block
, desc
, gfc_rank_cst
[dim
], new_lbound
);
446 /* Cleanup those #defines. */
451 #undef DIMENSION_FIELD
452 #undef CAF_TOKEN_FIELD
453 #undef STRIDE_SUBFIELD
454 #undef LBOUND_SUBFIELD
455 #undef UBOUND_SUBFIELD
458 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
459 flags & 1 = Main loop body.
460 flags & 2 = temp copy loop. */
463 gfc_mark_ss_chain_used (gfc_ss
* ss
, unsigned flags
)
465 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
466 ss
->info
->useflags
= flags
;
470 /* Free a gfc_ss chain. */
473 gfc_free_ss_chain (gfc_ss
* ss
)
477 while (ss
!= gfc_ss_terminator
)
479 gcc_assert (ss
!= NULL
);
488 free_ss_info (gfc_ss_info
*ss_info
)
491 if (ss_info
->refcount
> 0)
494 gcc_assert (ss_info
->refcount
== 0);
502 gfc_free_ss (gfc_ss
* ss
)
504 gfc_ss_info
*ss_info
;
509 switch (ss_info
->type
)
512 for (n
= 0; n
< ss
->dimen
; n
++)
514 if (ss_info
->data
.array
.subscript
[ss
->dim
[n
]])
515 gfc_free_ss_chain (ss_info
->data
.array
.subscript
[ss
->dim
[n
]]);
523 free_ss_info (ss_info
);
528 /* Creates and initializes an array type gfc_ss struct. */
531 gfc_get_array_ss (gfc_ss
*next
, gfc_expr
*expr
, int dimen
, gfc_ss_type type
)
534 gfc_ss_info
*ss_info
;
537 ss_info
= gfc_get_ss_info ();
539 ss_info
->type
= type
;
540 ss_info
->expr
= expr
;
546 for (i
= 0; i
< ss
->dimen
; i
++)
553 /* Creates and initializes a temporary type gfc_ss struct. */
556 gfc_get_temp_ss (tree type
, tree string_length
, int dimen
)
559 gfc_ss_info
*ss_info
;
562 ss_info
= gfc_get_ss_info ();
564 ss_info
->type
= GFC_SS_TEMP
;
565 ss_info
->string_length
= string_length
;
566 ss_info
->data
.temp
.type
= type
;
570 ss
->next
= gfc_ss_terminator
;
572 for (i
= 0; i
< ss
->dimen
; i
++)
579 /* Creates and initializes a scalar type gfc_ss struct. */
582 gfc_get_scalar_ss (gfc_ss
*next
, gfc_expr
*expr
)
585 gfc_ss_info
*ss_info
;
587 ss_info
= gfc_get_ss_info ();
589 ss_info
->type
= GFC_SS_SCALAR
;
590 ss_info
->expr
= expr
;
600 /* Free all the SS associated with a loop. */
603 gfc_cleanup_loop (gfc_loopinfo
* loop
)
605 gfc_loopinfo
*loop_next
, **ploop
;
610 while (ss
!= gfc_ss_terminator
)
612 gcc_assert (ss
!= NULL
);
613 next
= ss
->loop_chain
;
618 /* Remove reference to self in the parent loop. */
620 for (ploop
= &loop
->parent
->nested
; *ploop
; ploop
= &(*ploop
)->next
)
627 /* Free non-freed nested loops. */
628 for (loop
= loop
->nested
; loop
; loop
= loop_next
)
630 loop_next
= loop
->next
;
631 gfc_cleanup_loop (loop
);
638 set_ss_loop (gfc_ss
*ss
, gfc_loopinfo
*loop
)
642 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
646 if (ss
->info
->type
== GFC_SS_SCALAR
647 || ss
->info
->type
== GFC_SS_REFERENCE
648 || ss
->info
->type
== GFC_SS_TEMP
)
651 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
652 if (ss
->info
->data
.array
.subscript
[n
] != NULL
)
653 set_ss_loop (ss
->info
->data
.array
.subscript
[n
], loop
);
658 /* Associate a SS chain with a loop. */
661 gfc_add_ss_to_loop (gfc_loopinfo
* loop
, gfc_ss
* head
)
664 gfc_loopinfo
*nested_loop
;
666 if (head
== gfc_ss_terminator
)
669 set_ss_loop (head
, loop
);
672 for (; ss
&& ss
!= gfc_ss_terminator
; ss
= ss
->next
)
676 nested_loop
= ss
->nested_ss
->loop
;
678 /* More than one ss can belong to the same loop. Hence, we add the
679 loop to the chain only if it is different from the previously
680 added one, to avoid duplicate nested loops. */
681 if (nested_loop
!= loop
->nested
)
683 gcc_assert (nested_loop
->parent
== NULL
);
684 nested_loop
->parent
= loop
;
686 gcc_assert (nested_loop
->next
== NULL
);
687 nested_loop
->next
= loop
->nested
;
688 loop
->nested
= nested_loop
;
691 gcc_assert (nested_loop
->parent
== loop
);
694 if (ss
->next
== gfc_ss_terminator
)
695 ss
->loop_chain
= loop
->ss
;
697 ss
->loop_chain
= ss
->next
;
699 gcc_assert (ss
== gfc_ss_terminator
);
704 /* Generate an initializer for a static pointer or allocatable array. */
707 gfc_trans_static_array_pointer (gfc_symbol
* sym
)
711 gcc_assert (TREE_STATIC (sym
->backend_decl
));
712 /* Just zero the data member. */
713 type
= TREE_TYPE (sym
->backend_decl
);
714 DECL_INITIAL (sym
->backend_decl
) = gfc_build_null_descriptor (type
);
718 /* If the bounds of SE's loop have not yet been set, see if they can be
719 determined from array spec AS, which is the array spec of a called
720 function. MAPPING maps the callee's dummy arguments to the values
721 that the caller is passing. Add any initialization and finalization
725 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping
* mapping
,
726 gfc_se
* se
, gfc_array_spec
* as
)
728 int n
, dim
, total_dim
;
737 if (!as
|| as
->type
!= AS_EXPLICIT
)
740 for (ss
= se
->ss
; ss
; ss
= ss
->parent
)
742 total_dim
+= ss
->loop
->dimen
;
743 for (n
= 0; n
< ss
->loop
->dimen
; n
++)
745 /* The bound is known, nothing to do. */
746 if (ss
->loop
->to
[n
] != NULL_TREE
)
750 gcc_assert (dim
< as
->rank
);
751 gcc_assert (ss
->loop
->dimen
<= as
->rank
);
753 /* Evaluate the lower bound. */
754 gfc_init_se (&tmpse
, NULL
);
755 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->lower
[dim
]);
756 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
757 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
758 lower
= fold_convert (gfc_array_index_type
, tmpse
.expr
);
760 /* ...and the upper bound. */
761 gfc_init_se (&tmpse
, NULL
);
762 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->upper
[dim
]);
763 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
764 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
765 upper
= fold_convert (gfc_array_index_type
, tmpse
.expr
);
767 /* Set the upper bound of the loop to UPPER - LOWER. */
768 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
769 gfc_array_index_type
, upper
, lower
);
770 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
771 ss
->loop
->to
[n
] = tmp
;
775 gcc_assert (total_dim
== as
->rank
);
779 /* Generate code to allocate an array temporary, or create a variable to
780 hold the data. If size is NULL, zero the descriptor so that the
781 callee will allocate the array. If DEALLOC is true, also generate code to
782 free the array afterwards.
784 If INITIAL is not NULL, it is packed using internal_pack and the result used
785 as data instead of allocating a fresh, unitialized area of memory.
787 Initialization code is added to PRE and finalization code to POST.
788 DYNAMIC is true if the caller may want to extend the array later
789 using realloc. This prevents us from putting the array on the stack. */
792 gfc_trans_allocate_array_storage (stmtblock_t
* pre
, stmtblock_t
* post
,
793 gfc_array_info
* info
, tree size
, tree nelem
,
794 tree initial
, bool dynamic
, bool dealloc
)
800 desc
= info
->descriptor
;
801 info
->offset
= gfc_index_zero_node
;
802 if (size
== NULL_TREE
|| integer_zerop (size
))
804 /* A callee allocated array. */
805 gfc_conv_descriptor_data_set (pre
, desc
, null_pointer_node
);
810 /* Allocate the temporary. */
811 onstack
= !dynamic
&& initial
== NULL_TREE
812 && (gfc_option
.flag_stack_arrays
813 || gfc_can_put_var_on_stack (size
));
817 /* Make a temporary variable to hold the data. */
818 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (nelem
),
819 nelem
, gfc_index_one_node
);
820 tmp
= gfc_evaluate_now (tmp
, pre
);
821 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
823 tmp
= build_array_type (gfc_get_element_type (TREE_TYPE (desc
)),
825 tmp
= gfc_create_var (tmp
, "A");
826 /* If we're here only because of -fstack-arrays we have to
827 emit a DECL_EXPR to make the gimplifier emit alloca calls. */
828 if (!gfc_can_put_var_on_stack (size
))
829 gfc_add_expr_to_block (pre
,
830 fold_build1_loc (input_location
,
831 DECL_EXPR
, TREE_TYPE (tmp
),
833 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
834 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
838 /* Allocate memory to hold the data or call internal_pack. */
839 if (initial
== NULL_TREE
)
841 tmp
= gfc_call_malloc (pre
, NULL
, size
);
842 tmp
= gfc_evaluate_now (tmp
, pre
);
849 stmtblock_t do_copying
;
851 tmp
= TREE_TYPE (initial
); /* Pointer to descriptor. */
852 gcc_assert (TREE_CODE (tmp
) == POINTER_TYPE
);
853 tmp
= TREE_TYPE (tmp
); /* The descriptor itself. */
854 tmp
= gfc_get_element_type (tmp
);
855 gcc_assert (tmp
== gfc_get_element_type (TREE_TYPE (desc
)));
856 packed
= gfc_create_var (build_pointer_type (tmp
), "data");
858 tmp
= build_call_expr_loc (input_location
,
859 gfor_fndecl_in_pack
, 1, initial
);
860 tmp
= fold_convert (TREE_TYPE (packed
), tmp
);
861 gfc_add_modify (pre
, packed
, tmp
);
863 tmp
= build_fold_indirect_ref_loc (input_location
,
865 source_data
= gfc_conv_descriptor_data_get (tmp
);
867 /* internal_pack may return source->data without any allocation
868 or copying if it is already packed. If that's the case, we
869 need to allocate and copy manually. */
871 gfc_start_block (&do_copying
);
872 tmp
= gfc_call_malloc (&do_copying
, NULL
, size
);
873 tmp
= fold_convert (TREE_TYPE (packed
), tmp
);
874 gfc_add_modify (&do_copying
, packed
, tmp
);
875 tmp
= gfc_build_memcpy_call (packed
, source_data
, size
);
876 gfc_add_expr_to_block (&do_copying
, tmp
);
878 was_packed
= fold_build2_loc (input_location
, EQ_EXPR
,
879 boolean_type_node
, packed
,
881 tmp
= gfc_finish_block (&do_copying
);
882 tmp
= build3_v (COND_EXPR
, was_packed
, tmp
,
883 build_empty_stmt (input_location
));
884 gfc_add_expr_to_block (pre
, tmp
);
886 tmp
= fold_convert (pvoid_type_node
, packed
);
889 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
892 info
->data
= gfc_conv_descriptor_data_get (desc
);
894 /* The offset is zero because we create temporaries with a zero
896 gfc_conv_descriptor_offset_set (pre
, desc
, gfc_index_zero_node
);
898 if (dealloc
&& !onstack
)
900 /* Free the temporary. */
901 tmp
= gfc_conv_descriptor_data_get (desc
);
902 tmp
= gfc_call_free (fold_convert (pvoid_type_node
, tmp
));
903 gfc_add_expr_to_block (post
, tmp
);
908 /* Get the scalarizer array dimension corresponding to actual array dimension
911 For example, if SS represents the array ref a(1,:,:,1), it is a
912 bidimensional scalarizer array, and the result would be 0 for ARRAY_DIM=1,
913 and 1 for ARRAY_DIM=2.
914 If SS represents transpose(a(:,1,1,:)), it is again a bidimensional
915 scalarizer array, and the result would be 1 for ARRAY_DIM=0 and 0 for
917 If SS represents sum(a(:,:,:,1), dim=1), it is a 2+1-dimensional scalarizer
918 array. If called on the inner ss, the result would be respectively 0,1,2 for
919 ARRAY_DIM=0,1,2. If called on the outer ss, the result would be 0,1
920 for ARRAY_DIM=1,2. */
923 get_scalarizer_dim_for_array_dim (gfc_ss
*ss
, int array_dim
)
930 for (; ss
; ss
= ss
->parent
)
931 for (n
= 0; n
< ss
->dimen
; n
++)
932 if (ss
->dim
[n
] < array_dim
)
935 return array_ref_dim
;
940 innermost_ss (gfc_ss
*ss
)
942 while (ss
->nested_ss
!= NULL
)
950 /* Get the array reference dimension corresponding to the given loop dimension.
951 It is different from the true array dimension given by the dim array in
952 the case of a partial array reference (i.e. a(:,:,1,:) for example)
953 It is different from the loop dimension in the case of a transposed array.
957 get_array_ref_dim_for_loop_dim (gfc_ss
*ss
, int loop_dim
)
959 return get_scalarizer_dim_for_array_dim (innermost_ss (ss
),
964 /* Generate code to create and initialize the descriptor for a temporary
965 array. This is used for both temporaries needed by the scalarizer, and
966 functions returning arrays. Adjusts the loop variables to be
967 zero-based, and calculates the loop bounds for callee allocated arrays.
968 Allocate the array unless it's callee allocated (we have a callee
969 allocated array if 'callee_alloc' is true, or if loop->to[n] is
970 NULL_TREE for any n). Also fills in the descriptor, data and offset
971 fields of info if known. Returns the size of the array, or NULL for a
972 callee allocated array.
974 'eltype' == NULL signals that the temporary should be a class object.
975 The 'initial' expression is used to obtain the size of the dynamic
976 type; otehrwise the allocation and initialisation proceeds as for any
979 PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
980 gfc_trans_allocate_array_storage. */
983 gfc_trans_create_temp_array (stmtblock_t
* pre
, stmtblock_t
* post
, gfc_ss
* ss
,
984 tree eltype
, tree initial
, bool dynamic
,
985 bool dealloc
, bool callee_alloc
, locus
* where
)
989 gfc_array_info
*info
;
990 tree from
[GFC_MAX_DIMENSIONS
], to
[GFC_MAX_DIMENSIONS
];
998 tree class_expr
= NULL_TREE
;
1002 /* This signals a class array for which we need the size of the
1003 dynamic type. Generate an eltype and then the class expression. */
1004 if (eltype
== NULL_TREE
&& initial
)
1006 if (POINTER_TYPE_P (TREE_TYPE (initial
)))
1007 class_expr
= build_fold_indirect_ref_loc (input_location
, initial
);
1008 eltype
= TREE_TYPE (class_expr
);
1009 eltype
= gfc_get_element_type (eltype
);
1010 /* Obtain the structure (class) expression. */
1011 class_expr
= TREE_OPERAND (class_expr
, 0);
1012 gcc_assert (class_expr
);
1015 memset (from
, 0, sizeof (from
));
1016 memset (to
, 0, sizeof (to
));
1018 info
= &ss
->info
->data
.array
;
1020 gcc_assert (ss
->dimen
> 0);
1021 gcc_assert (ss
->loop
->dimen
== ss
->dimen
);
1023 if (gfc_option
.warn_array_temp
&& where
)
1024 gfc_warning ("Creating array temporary at %L", where
);
1026 /* Set the lower bound to zero. */
1027 for (s
= ss
; s
; s
= s
->parent
)
1031 total_dim
+= loop
->dimen
;
1032 for (n
= 0; n
< loop
->dimen
; n
++)
1036 /* Callee allocated arrays may not have a known bound yet. */
1038 loop
->to
[n
] = gfc_evaluate_now (
1039 fold_build2_loc (input_location
, MINUS_EXPR
,
1040 gfc_array_index_type
,
1041 loop
->to
[n
], loop
->from
[n
]),
1043 loop
->from
[n
] = gfc_index_zero_node
;
1045 /* We have just changed the loop bounds, we must clear the
1046 corresponding specloop, so that delta calculation is not skipped
1047 later in gfc_set_delta. */
1048 loop
->specloop
[n
] = NULL
;
1050 /* We are constructing the temporary's descriptor based on the loop
1051 dimensions. As the dimensions may be accessed in arbitrary order
1052 (think of transpose) the size taken from the n'th loop may not map
1053 to the n'th dimension of the array. We need to reconstruct loop
1054 infos in the right order before using it to set the descriptor
1056 tmp_dim
= get_scalarizer_dim_for_array_dim (ss
, dim
);
1057 from
[tmp_dim
] = loop
->from
[n
];
1058 to
[tmp_dim
] = loop
->to
[n
];
1060 info
->delta
[dim
] = gfc_index_zero_node
;
1061 info
->start
[dim
] = gfc_index_zero_node
;
1062 info
->end
[dim
] = gfc_index_zero_node
;
1063 info
->stride
[dim
] = gfc_index_one_node
;
1067 /* Initialize the descriptor. */
1069 gfc_get_array_type_bounds (eltype
, total_dim
, 0, from
, to
, 1,
1070 GFC_ARRAY_UNKNOWN
, true);
1071 desc
= gfc_create_var (type
, "atmp");
1072 GFC_DECL_PACKED_ARRAY (desc
) = 1;
1074 info
->descriptor
= desc
;
1075 size
= gfc_index_one_node
;
1077 /* Fill in the array dtype. */
1078 tmp
= gfc_conv_descriptor_dtype (desc
);
1079 gfc_add_modify (pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
1082 Fill in the bounds and stride. This is a packed array, so:
1085 for (n = 0; n < rank; n++)
1088 delta = ubound[n] + 1 - lbound[n];
1089 size = size * delta;
1091 size = size * sizeof(element);
1094 or_expr
= NULL_TREE
;
1096 /* If there is at least one null loop->to[n], it is a callee allocated
1098 for (n
= 0; n
< total_dim
; n
++)
1099 if (to
[n
] == NULL_TREE
)
1105 if (size
== NULL_TREE
)
1106 for (s
= ss
; s
; s
= s
->parent
)
1107 for (n
= 0; n
< s
->loop
->dimen
; n
++)
1109 dim
= get_scalarizer_dim_for_array_dim (ss
, s
->dim
[n
]);
1111 /* For a callee allocated array express the loop bounds in terms
1112 of the descriptor fields. */
1113 tmp
= fold_build2_loc (input_location
,
1114 MINUS_EXPR
, gfc_array_index_type
,
1115 gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]),
1116 gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]));
1117 s
->loop
->to
[n
] = tmp
;
1121 for (n
= 0; n
< total_dim
; n
++)
1123 /* Store the stride and bound components in the descriptor. */
1124 gfc_conv_descriptor_stride_set (pre
, desc
, gfc_rank_cst
[n
], size
);
1126 gfc_conv_descriptor_lbound_set (pre
, desc
, gfc_rank_cst
[n
],
1127 gfc_index_zero_node
);
1129 gfc_conv_descriptor_ubound_set (pre
, desc
, gfc_rank_cst
[n
], to
[n
]);
1131 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1132 gfc_array_index_type
,
1133 to
[n
], gfc_index_one_node
);
1135 /* Check whether the size for this dimension is negative. */
1136 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
1137 tmp
, gfc_index_zero_node
);
1138 cond
= gfc_evaluate_now (cond
, pre
);
1143 or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1144 boolean_type_node
, or_expr
, cond
);
1146 size
= fold_build2_loc (input_location
, MULT_EXPR
,
1147 gfc_array_index_type
, size
, tmp
);
1148 size
= gfc_evaluate_now (size
, pre
);
1152 /* Get the size of the array. */
1153 if (size
&& !callee_alloc
)
1156 /* If or_expr is true, then the extent in at least one
1157 dimension is zero and the size is set to zero. */
1158 size
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
1159 or_expr
, gfc_index_zero_node
, size
);
1162 if (class_expr
== NULL_TREE
)
1163 elemsize
= fold_convert (gfc_array_index_type
,
1164 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
1166 elemsize
= gfc_vtable_size_get (class_expr
);
1168 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
1177 gfc_trans_allocate_array_storage (pre
, post
, info
, size
, nelem
, initial
,
1183 if (ss
->dimen
> ss
->loop
->temp_dim
)
1184 ss
->loop
->temp_dim
= ss
->dimen
;
1190 /* Return the number of iterations in a loop that starts at START,
1191 ends at END, and has step STEP. */
1194 gfc_get_iteration_count (tree start
, tree end
, tree step
)
1199 type
= TREE_TYPE (step
);
1200 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, end
, start
);
1201 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
, type
, tmp
, step
);
1202 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
,
1203 build_int_cst (type
, 1));
1204 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, type
, tmp
,
1205 build_int_cst (type
, 0));
1206 return fold_convert (gfc_array_index_type
, tmp
);
1210 /* Extend the data in array DESC by EXTRA elements. */
1213 gfc_grow_array (stmtblock_t
* pblock
, tree desc
, tree extra
)
1220 if (integer_zerop (extra
))
1223 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[0]);
1225 /* Add EXTRA to the upper bound. */
1226 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1228 gfc_conv_descriptor_ubound_set (pblock
, desc
, gfc_rank_cst
[0], tmp
);
1230 /* Get the value of the current data pointer. */
1231 arg0
= gfc_conv_descriptor_data_get (desc
);
1233 /* Calculate the new array size. */
1234 size
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
1235 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1236 ubound
, gfc_index_one_node
);
1237 arg1
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
1238 fold_convert (size_type_node
, tmp
),
1239 fold_convert (size_type_node
, size
));
1241 /* Call the realloc() function. */
1242 tmp
= gfc_call_realloc (pblock
, arg0
, arg1
);
1243 gfc_conv_descriptor_data_set (pblock
, desc
, tmp
);
1247 /* Return true if the bounds of iterator I can only be determined
1251 gfc_iterator_has_dynamic_bounds (gfc_iterator
* i
)
1253 return (i
->start
->expr_type
!= EXPR_CONSTANT
1254 || i
->end
->expr_type
!= EXPR_CONSTANT
1255 || i
->step
->expr_type
!= EXPR_CONSTANT
);
1259 /* Split the size of constructor element EXPR into the sum of two terms,
1260 one of which can be determined at compile time and one of which must
1261 be calculated at run time. Set *SIZE to the former and return true
1262 if the latter might be nonzero. */
1265 gfc_get_array_constructor_element_size (mpz_t
* size
, gfc_expr
* expr
)
1267 if (expr
->expr_type
== EXPR_ARRAY
)
1268 return gfc_get_array_constructor_size (size
, expr
->value
.constructor
);
1269 else if (expr
->rank
> 0)
1271 /* Calculate everything at run time. */
1272 mpz_set_ui (*size
, 0);
1277 /* A single element. */
1278 mpz_set_ui (*size
, 1);
1284 /* Like gfc_get_array_constructor_element_size, but applied to the whole
1285 of array constructor C. */
1288 gfc_get_array_constructor_size (mpz_t
* size
, gfc_constructor_base base
)
1296 mpz_set_ui (*size
, 0);
1301 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1304 if (i
&& gfc_iterator_has_dynamic_bounds (i
))
1308 dynamic
|= gfc_get_array_constructor_element_size (&len
, c
->expr
);
1311 /* Multiply the static part of the element size by the
1312 number of iterations. */
1313 mpz_sub (val
, i
->end
->value
.integer
, i
->start
->value
.integer
);
1314 mpz_fdiv_q (val
, val
, i
->step
->value
.integer
);
1315 mpz_add_ui (val
, val
, 1);
1316 if (mpz_sgn (val
) > 0)
1317 mpz_mul (len
, len
, val
);
1319 mpz_set_ui (len
, 0);
1321 mpz_add (*size
, *size
, len
);
1330 /* Make sure offset is a variable. */
1333 gfc_put_offset_into_var (stmtblock_t
* pblock
, tree
* poffset
,
1336 /* We should have already created the offset variable. We cannot
1337 create it here because we may be in an inner scope. */
1338 gcc_assert (*offsetvar
!= NULL_TREE
);
1339 gfc_add_modify (pblock
, *offsetvar
, *poffset
);
1340 *poffset
= *offsetvar
;
1341 TREE_USED (*offsetvar
) = 1;
1345 /* Variables needed for bounds-checking. */
1346 static bool first_len
;
1347 static tree first_len_val
;
1348 static bool typespec_chararray_ctor
;
1351 gfc_trans_array_ctor_element (stmtblock_t
* pblock
, tree desc
,
1352 tree offset
, gfc_se
* se
, gfc_expr
* expr
)
1356 gfc_conv_expr (se
, expr
);
1358 /* Store the value. */
1359 tmp
= build_fold_indirect_ref_loc (input_location
,
1360 gfc_conv_descriptor_data_get (desc
));
1361 tmp
= gfc_build_array_ref (tmp
, offset
, NULL
);
1363 if (expr
->ts
.type
== BT_CHARACTER
)
1365 int i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
1368 esize
= size_in_bytes (gfc_get_element_type (TREE_TYPE (desc
)));
1369 esize
= fold_convert (gfc_charlen_type_node
, esize
);
1370 esize
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1371 gfc_charlen_type_node
, esize
,
1372 build_int_cst (gfc_charlen_type_node
,
1373 gfc_character_kinds
[i
].bit_size
/ 8));
1375 gfc_conv_string_parameter (se
);
1376 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
1378 /* The temporary is an array of pointers. */
1379 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1380 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1384 /* The temporary is an array of string values. */
1385 tmp
= gfc_build_addr_expr (gfc_get_pchar_type (expr
->ts
.kind
), tmp
);
1386 /* We know the temporary and the value will be the same length,
1387 so can use memcpy. */
1388 gfc_trans_string_copy (&se
->pre
, esize
, tmp
, expr
->ts
.kind
,
1389 se
->string_length
, se
->expr
, expr
->ts
.kind
);
1391 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && !typespec_chararray_ctor
)
1395 gfc_add_modify (&se
->pre
, first_len_val
,
1401 /* Verify that all constructor elements are of the same
1403 tree cond
= fold_build2_loc (input_location
, NE_EXPR
,
1404 boolean_type_node
, first_len_val
,
1406 gfc_trans_runtime_check
1407 (true, false, cond
, &se
->pre
, &expr
->where
,
1408 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1409 fold_convert (long_integer_type_node
, first_len_val
),
1410 fold_convert (long_integer_type_node
, se
->string_length
));
1416 /* TODO: Should the frontend already have done this conversion? */
1417 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1418 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1421 gfc_add_block_to_block (pblock
, &se
->pre
);
1422 gfc_add_block_to_block (pblock
, &se
->post
);
1426 /* Add the contents of an array to the constructor. DYNAMIC is as for
1427 gfc_trans_array_constructor_value. */
1430 gfc_trans_array_constructor_subarray (stmtblock_t
* pblock
,
1431 tree type ATTRIBUTE_UNUSED
,
1432 tree desc
, gfc_expr
* expr
,
1433 tree
* poffset
, tree
* offsetvar
,
1444 /* We need this to be a variable so we can increment it. */
1445 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1447 gfc_init_se (&se
, NULL
);
1449 /* Walk the array expression. */
1450 ss
= gfc_walk_expr (expr
);
1451 gcc_assert (ss
!= gfc_ss_terminator
);
1453 /* Initialize the scalarizer. */
1454 gfc_init_loopinfo (&loop
);
1455 gfc_add_ss_to_loop (&loop
, ss
);
1457 /* Initialize the loop. */
1458 gfc_conv_ss_startstride (&loop
);
1459 gfc_conv_loop_setup (&loop
, &expr
->where
);
1461 /* Make sure the constructed array has room for the new data. */
1464 /* Set SIZE to the total number of elements in the subarray. */
1465 size
= gfc_index_one_node
;
1466 for (n
= 0; n
< loop
.dimen
; n
++)
1468 tmp
= gfc_get_iteration_count (loop
.from
[n
], loop
.to
[n
],
1469 gfc_index_one_node
);
1470 size
= fold_build2_loc (input_location
, MULT_EXPR
,
1471 gfc_array_index_type
, size
, tmp
);
1474 /* Grow the constructed array by SIZE elements. */
1475 gfc_grow_array (&loop
.pre
, desc
, size
);
1478 /* Make the loop body. */
1479 gfc_mark_ss_chain_used (ss
, 1);
1480 gfc_start_scalarized_body (&loop
, &body
);
1481 gfc_copy_loopinfo_to_se (&se
, &loop
);
1484 gfc_trans_array_ctor_element (&body
, desc
, *poffset
, &se
, expr
);
1485 gcc_assert (se
.ss
== gfc_ss_terminator
);
1487 /* Increment the offset. */
1488 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1489 *poffset
, gfc_index_one_node
);
1490 gfc_add_modify (&body
, *poffset
, tmp
);
1492 /* Finish the loop. */
1493 gfc_trans_scalarizing_loops (&loop
, &body
);
1494 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
1495 tmp
= gfc_finish_block (&loop
.pre
);
1496 gfc_add_expr_to_block (pblock
, tmp
);
1498 gfc_cleanup_loop (&loop
);
1502 /* Assign the values to the elements of an array constructor. DYNAMIC
1503 is true if descriptor DESC only contains enough data for the static
1504 size calculated by gfc_get_array_constructor_size. When true, memory
1505 for the dynamic parts must be allocated using realloc. */
1508 gfc_trans_array_constructor_value (stmtblock_t
* pblock
, tree type
,
1509 tree desc
, gfc_constructor_base base
,
1510 tree
* poffset
, tree
* offsetvar
,
1519 tree shadow_loopvar
= NULL_TREE
;
1520 gfc_saved_var saved_loopvar
;
1523 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1525 /* If this is an iterator or an array, the offset must be a variable. */
1526 if ((c
->iterator
|| c
->expr
->rank
> 0) && INTEGER_CST_P (*poffset
))
1527 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1529 /* Shadowing the iterator avoids changing its value and saves us from
1530 keeping track of it. Further, it makes sure that there's always a
1531 backend-decl for the symbol, even if there wasn't one before,
1532 e.g. in the case of an iterator that appears in a specification
1533 expression in an interface mapping. */
1536 gfc_symbol
*sym
= c
->iterator
->var
->symtree
->n
.sym
;
1537 tree type
= gfc_typenode_for_spec (&sym
->ts
);
1539 shadow_loopvar
= gfc_create_var (type
, "shadow_loopvar");
1540 gfc_shadow_sym (sym
, shadow_loopvar
, &saved_loopvar
);
1543 gfc_start_block (&body
);
1545 if (c
->expr
->expr_type
== EXPR_ARRAY
)
1547 /* Array constructors can be nested. */
1548 gfc_trans_array_constructor_value (&body
, type
, desc
,
1549 c
->expr
->value
.constructor
,
1550 poffset
, offsetvar
, dynamic
);
1552 else if (c
->expr
->rank
> 0)
1554 gfc_trans_array_constructor_subarray (&body
, type
, desc
, c
->expr
,
1555 poffset
, offsetvar
, dynamic
);
1559 /* This code really upsets the gimplifier so don't bother for now. */
1566 while (p
&& !(p
->iterator
|| p
->expr
->expr_type
!= EXPR_CONSTANT
))
1568 p
= gfc_constructor_next (p
);
1573 /* Scalar values. */
1574 gfc_init_se (&se
, NULL
);
1575 gfc_trans_array_ctor_element (&body
, desc
, *poffset
,
1578 *poffset
= fold_build2_loc (input_location
, PLUS_EXPR
,
1579 gfc_array_index_type
,
1580 *poffset
, gfc_index_one_node
);
1584 /* Collect multiple scalar constants into a constructor. */
1585 VEC(constructor_elt
,gc
) *v
= NULL
;
1589 HOST_WIDE_INT idx
= 0;
1592 /* Count the number of consecutive scalar constants. */
1593 while (p
&& !(p
->iterator
1594 || p
->expr
->expr_type
!= EXPR_CONSTANT
))
1596 gfc_init_se (&se
, NULL
);
1597 gfc_conv_constant (&se
, p
->expr
);
1599 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
1600 se
.expr
= fold_convert (type
, se
.expr
);
1601 /* For constant character array constructors we build
1602 an array of pointers. */
1603 else if (POINTER_TYPE_P (type
))
1604 se
.expr
= gfc_build_addr_expr
1605 (gfc_get_pchar_type (p
->expr
->ts
.kind
),
1608 CONSTRUCTOR_APPEND_ELT (v
,
1609 build_int_cst (gfc_array_index_type
,
1613 p
= gfc_constructor_next (p
);
1616 bound
= size_int (n
- 1);
1617 /* Create an array type to hold them. */
1618 tmptype
= build_range_type (gfc_array_index_type
,
1619 gfc_index_zero_node
, bound
);
1620 tmptype
= build_array_type (type
, tmptype
);
1622 init
= build_constructor (tmptype
, v
);
1623 TREE_CONSTANT (init
) = 1;
1624 TREE_STATIC (init
) = 1;
1625 /* Create a static variable to hold the data. */
1626 tmp
= gfc_create_var (tmptype
, "data");
1627 TREE_STATIC (tmp
) = 1;
1628 TREE_CONSTANT (tmp
) = 1;
1629 TREE_READONLY (tmp
) = 1;
1630 DECL_INITIAL (tmp
) = init
;
1633 /* Use BUILTIN_MEMCPY to assign the values. */
1634 tmp
= gfc_conv_descriptor_data_get (desc
);
1635 tmp
= build_fold_indirect_ref_loc (input_location
,
1637 tmp
= gfc_build_array_ref (tmp
, *poffset
, NULL
);
1638 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1639 init
= gfc_build_addr_expr (NULL_TREE
, init
);
1641 size
= TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type
));
1642 bound
= build_int_cst (size_type_node
, n
* size
);
1643 tmp
= build_call_expr_loc (input_location
,
1644 builtin_decl_explicit (BUILT_IN_MEMCPY
),
1645 3, tmp
, init
, bound
);
1646 gfc_add_expr_to_block (&body
, tmp
);
1648 *poffset
= fold_build2_loc (input_location
, PLUS_EXPR
,
1649 gfc_array_index_type
, *poffset
,
1650 build_int_cst (gfc_array_index_type
, n
));
1652 if (!INTEGER_CST_P (*poffset
))
1654 gfc_add_modify (&body
, *offsetvar
, *poffset
);
1655 *poffset
= *offsetvar
;
1659 /* The frontend should already have done any expansions
1663 /* Pass the code as is. */
1664 tmp
= gfc_finish_block (&body
);
1665 gfc_add_expr_to_block (pblock
, tmp
);
1669 /* Build the implied do-loop. */
1670 stmtblock_t implied_do_block
;
1678 loopbody
= gfc_finish_block (&body
);
1680 /* Create a new block that holds the implied-do loop. A temporary
1681 loop-variable is used. */
1682 gfc_start_block(&implied_do_block
);
1684 /* Initialize the loop. */
1685 gfc_init_se (&se
, NULL
);
1686 gfc_conv_expr_val (&se
, c
->iterator
->start
);
1687 gfc_add_block_to_block (&implied_do_block
, &se
.pre
);
1688 gfc_add_modify (&implied_do_block
, shadow_loopvar
, se
.expr
);
1690 gfc_init_se (&se
, NULL
);
1691 gfc_conv_expr_val (&se
, c
->iterator
->end
);
1692 gfc_add_block_to_block (&implied_do_block
, &se
.pre
);
1693 end
= gfc_evaluate_now (se
.expr
, &implied_do_block
);
1695 gfc_init_se (&se
, NULL
);
1696 gfc_conv_expr_val (&se
, c
->iterator
->step
);
1697 gfc_add_block_to_block (&implied_do_block
, &se
.pre
);
1698 step
= gfc_evaluate_now (se
.expr
, &implied_do_block
);
1700 /* If this array expands dynamically, and the number of iterations
1701 is not constant, we won't have allocated space for the static
1702 part of C->EXPR's size. Do that now. */
1703 if (dynamic
&& gfc_iterator_has_dynamic_bounds (c
->iterator
))
1705 /* Get the number of iterations. */
1706 tmp
= gfc_get_iteration_count (shadow_loopvar
, end
, step
);
1708 /* Get the static part of C->EXPR's size. */
1709 gfc_get_array_constructor_element_size (&size
, c
->expr
);
1710 tmp2
= gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
1712 /* Grow the array by TMP * TMP2 elements. */
1713 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
1714 gfc_array_index_type
, tmp
, tmp2
);
1715 gfc_grow_array (&implied_do_block
, desc
, tmp
);
1718 /* Generate the loop body. */
1719 exit_label
= gfc_build_label_decl (NULL_TREE
);
1720 gfc_start_block (&body
);
1722 /* Generate the exit condition. Depending on the sign of
1723 the step variable we have to generate the correct
1725 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1726 step
, build_int_cst (TREE_TYPE (step
), 0));
1727 cond
= fold_build3_loc (input_location
, COND_EXPR
,
1728 boolean_type_node
, tmp
,
1729 fold_build2_loc (input_location
, GT_EXPR
,
1730 boolean_type_node
, shadow_loopvar
, end
),
1731 fold_build2_loc (input_location
, LT_EXPR
,
1732 boolean_type_node
, shadow_loopvar
, end
));
1733 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1734 TREE_USED (exit_label
) = 1;
1735 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
1736 build_empty_stmt (input_location
));
1737 gfc_add_expr_to_block (&body
, tmp
);
1739 /* The main loop body. */
1740 gfc_add_expr_to_block (&body
, loopbody
);
1742 /* Increase loop variable by step. */
1743 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1744 TREE_TYPE (shadow_loopvar
), shadow_loopvar
,
1746 gfc_add_modify (&body
, shadow_loopvar
, tmp
);
1748 /* Finish the loop. */
1749 tmp
= gfc_finish_block (&body
);
1750 tmp
= build1_v (LOOP_EXPR
, tmp
);
1751 gfc_add_expr_to_block (&implied_do_block
, tmp
);
1753 /* Add the exit label. */
1754 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1755 gfc_add_expr_to_block (&implied_do_block
, tmp
);
1757 /* Finishe the implied-do loop. */
1758 tmp
= gfc_finish_block(&implied_do_block
);
1759 gfc_add_expr_to_block(pblock
, tmp
);
1761 gfc_restore_sym (c
->iterator
->var
->symtree
->n
.sym
, &saved_loopvar
);
1768 /* A catch-all to obtain the string length for anything that is not a
1769 a substring of non-constant length, a constant, array or variable. */
1772 get_array_ctor_all_strlen (stmtblock_t
*block
, gfc_expr
*e
, tree
*len
)
1777 /* Don't bother if we already know the length is a constant. */
1778 if (*len
&& INTEGER_CST_P (*len
))
1781 if (!e
->ref
&& e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
1782 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1785 gfc_conv_const_charlen (e
->ts
.u
.cl
);
1786 *len
= e
->ts
.u
.cl
->backend_decl
;
1790 /* Otherwise, be brutal even if inefficient. */
1791 ss
= gfc_walk_expr (e
);
1792 gfc_init_se (&se
, NULL
);
1794 /* No function call, in case of side effects. */
1795 se
.no_function_call
= 1;
1796 if (ss
== gfc_ss_terminator
)
1797 gfc_conv_expr (&se
, e
);
1799 gfc_conv_expr_descriptor (&se
, e
, ss
);
1801 /* Fix the value. */
1802 *len
= gfc_evaluate_now (se
.string_length
, &se
.pre
);
1804 gfc_add_block_to_block (block
, &se
.pre
);
1805 gfc_add_block_to_block (block
, &se
.post
);
1807 e
->ts
.u
.cl
->backend_decl
= *len
;
1812 /* Figure out the string length of a variable reference expression.
1813 Used by get_array_ctor_strlen. */
1816 get_array_ctor_var_strlen (stmtblock_t
*block
, gfc_expr
* expr
, tree
* len
)
1822 /* Don't bother if we already know the length is a constant. */
1823 if (*len
&& INTEGER_CST_P (*len
))
1826 ts
= &expr
->symtree
->n
.sym
->ts
;
1827 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1832 /* Array references don't change the string length. */
1836 /* Use the length of the component. */
1837 ts
= &ref
->u
.c
.component
->ts
;
1841 if (ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1842 || ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1844 /* Note that this might evaluate expr. */
1845 get_array_ctor_all_strlen (block
, expr
, len
);
1848 mpz_init_set_ui (char_len
, 1);
1849 mpz_add (char_len
, char_len
, ref
->u
.ss
.end
->value
.integer
);
1850 mpz_sub (char_len
, char_len
, ref
->u
.ss
.start
->value
.integer
);
1851 *len
= gfc_conv_mpz_to_tree (char_len
, gfc_default_integer_kind
);
1852 *len
= convert (gfc_charlen_type_node
, *len
);
1853 mpz_clear (char_len
);
1861 *len
= ts
->u
.cl
->backend_decl
;
1865 /* Figure out the string length of a character array constructor.
1866 If len is NULL, don't calculate the length; this happens for recursive calls
1867 when a sub-array-constructor is an element but not at the first position,
1868 so when we're not interested in the length.
1869 Returns TRUE if all elements are character constants. */
1872 get_array_ctor_strlen (stmtblock_t
*block
, gfc_constructor_base base
, tree
* len
)
1879 if (gfc_constructor_first (base
) == NULL
)
1882 *len
= build_int_cstu (gfc_charlen_type_node
, 0);
1886 /* Loop over all constructor elements to find out is_const, but in len we
1887 want to store the length of the first, not the last, element. We can
1888 of course exit the loop as soon as is_const is found to be false. */
1889 for (c
= gfc_constructor_first (base
);
1890 c
&& is_const
; c
= gfc_constructor_next (c
))
1892 switch (c
->expr
->expr_type
)
1895 if (len
&& !(*len
&& INTEGER_CST_P (*len
)))
1896 *len
= build_int_cstu (gfc_charlen_type_node
,
1897 c
->expr
->value
.character
.length
);
1901 if (!get_array_ctor_strlen (block
, c
->expr
->value
.constructor
, len
))
1908 get_array_ctor_var_strlen (block
, c
->expr
, len
);
1914 get_array_ctor_all_strlen (block
, c
->expr
, len
);
1918 /* After the first iteration, we don't want the length modified. */
1925 /* Check whether the array constructor C consists entirely of constant
1926 elements, and if so returns the number of those elements, otherwise
1927 return zero. Note, an empty or NULL array constructor returns zero. */
1929 unsigned HOST_WIDE_INT
1930 gfc_constant_array_constructor_p (gfc_constructor_base base
)
1932 unsigned HOST_WIDE_INT nelem
= 0;
1934 gfc_constructor
*c
= gfc_constructor_first (base
);
1938 || c
->expr
->rank
> 0
1939 || c
->expr
->expr_type
!= EXPR_CONSTANT
)
1941 c
= gfc_constructor_next (c
);
1948 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1949 and the tree type of it's elements, TYPE, return a static constant
1950 variable that is compile-time initialized. */
1953 gfc_build_constant_array_constructor (gfc_expr
* expr
, tree type
)
1955 tree tmptype
, init
, tmp
;
1956 HOST_WIDE_INT nelem
;
1961 VEC(constructor_elt
,gc
) *v
= NULL
;
1963 /* First traverse the constructor list, converting the constants
1964 to tree to build an initializer. */
1966 c
= gfc_constructor_first (expr
->value
.constructor
);
1969 gfc_init_se (&se
, NULL
);
1970 gfc_conv_constant (&se
, c
->expr
);
1971 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
1972 se
.expr
= fold_convert (type
, se
.expr
);
1973 else if (POINTER_TYPE_P (type
))
1974 se
.expr
= gfc_build_addr_expr (gfc_get_pchar_type (c
->expr
->ts
.kind
),
1976 CONSTRUCTOR_APPEND_ELT (v
, build_int_cst (gfc_array_index_type
, nelem
),
1978 c
= gfc_constructor_next (c
);
1982 /* Next determine the tree type for the array. We use the gfortran
1983 front-end's gfc_get_nodesc_array_type in order to create a suitable
1984 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
1986 memset (&as
, 0, sizeof (gfc_array_spec
));
1988 as
.rank
= expr
->rank
;
1989 as
.type
= AS_EXPLICIT
;
1992 as
.lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
1993 as
.upper
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
1997 for (i
= 0; i
< expr
->rank
; i
++)
1999 int tmp
= (int) mpz_get_si (expr
->shape
[i
]);
2000 as
.lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2001 as
.upper
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
2005 tmptype
= gfc_get_nodesc_array_type (type
, &as
, PACKED_STATIC
, true);
2007 /* as is not needed anymore. */
2008 for (i
= 0; i
< as
.rank
+ as
.corank
; i
++)
2010 gfc_free_expr (as
.lower
[i
]);
2011 gfc_free_expr (as
.upper
[i
]);
2014 init
= build_constructor (tmptype
, v
);
2016 TREE_CONSTANT (init
) = 1;
2017 TREE_STATIC (init
) = 1;
2019 tmp
= gfc_create_var (tmptype
, "A");
2020 TREE_STATIC (tmp
) = 1;
2021 TREE_CONSTANT (tmp
) = 1;
2022 TREE_READONLY (tmp
) = 1;
2023 DECL_INITIAL (tmp
) = init
;
2029 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
2030 This mostly initializes the scalarizer state info structure with the
2031 appropriate values to directly use the array created by the function
2032 gfc_build_constant_array_constructor. */
2035 trans_constant_array_constructor (gfc_ss
* ss
, tree type
)
2037 gfc_array_info
*info
;
2041 tmp
= gfc_build_constant_array_constructor (ss
->info
->expr
, type
);
2043 info
= &ss
->info
->data
.array
;
2045 info
->descriptor
= tmp
;
2046 info
->data
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2047 info
->offset
= gfc_index_zero_node
;
2049 for (i
= 0; i
< ss
->dimen
; i
++)
2051 info
->delta
[i
] = gfc_index_zero_node
;
2052 info
->start
[i
] = gfc_index_zero_node
;
2053 info
->end
[i
] = gfc_index_zero_node
;
2054 info
->stride
[i
] = gfc_index_one_node
;
2060 get_rank (gfc_loopinfo
*loop
)
2065 for (; loop
; loop
= loop
->parent
)
2066 rank
+= loop
->dimen
;
2072 /* Helper routine of gfc_trans_array_constructor to determine if the
2073 bounds of the loop specified by LOOP are constant and simple enough
2074 to use with trans_constant_array_constructor. Returns the
2075 iteration count of the loop if suitable, and NULL_TREE otherwise. */
2078 constant_array_constructor_loop_size (gfc_loopinfo
* l
)
2081 tree size
= gfc_index_one_node
;
2085 total_dim
= get_rank (l
);
2087 for (loop
= l
; loop
; loop
= loop
->parent
)
2089 for (i
= 0; i
< loop
->dimen
; i
++)
2091 /* If the bounds aren't constant, return NULL_TREE. */
2092 if (!INTEGER_CST_P (loop
->from
[i
]) || !INTEGER_CST_P (loop
->to
[i
]))
2094 if (!integer_zerop (loop
->from
[i
]))
2096 /* Only allow nonzero "from" in one-dimensional arrays. */
2099 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2100 gfc_array_index_type
,
2101 loop
->to
[i
], loop
->from
[i
]);
2105 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2106 gfc_array_index_type
, tmp
, gfc_index_one_node
);
2107 size
= fold_build2_loc (input_location
, MULT_EXPR
,
2108 gfc_array_index_type
, size
, tmp
);
2117 get_loop_upper_bound_for_array (gfc_ss
*array
, int array_dim
)
2122 gcc_assert (array
->nested_ss
== NULL
);
2124 for (ss
= array
; ss
; ss
= ss
->parent
)
2125 for (n
= 0; n
< ss
->loop
->dimen
; n
++)
2126 if (array_dim
== get_array_ref_dim_for_loop_dim (ss
, n
))
2127 return &(ss
->loop
->to
[n
]);
2133 static gfc_loopinfo
*
2134 outermost_loop (gfc_loopinfo
* loop
)
2136 while (loop
->parent
!= NULL
)
2137 loop
= loop
->parent
;
2143 /* Array constructors are handled by constructing a temporary, then using that
2144 within the scalarization loop. This is not optimal, but seems by far the
2148 trans_array_constructor (gfc_ss
* ss
, locus
* where
)
2150 gfc_constructor_base c
;
2158 bool old_first_len
, old_typespec_chararray_ctor
;
2159 tree old_first_len_val
;
2160 gfc_loopinfo
*loop
, *outer_loop
;
2161 gfc_ss_info
*ss_info
;
2165 /* Save the old values for nested checking. */
2166 old_first_len
= first_len
;
2167 old_first_len_val
= first_len_val
;
2168 old_typespec_chararray_ctor
= typespec_chararray_ctor
;
2171 outer_loop
= outermost_loop (loop
);
2173 expr
= ss_info
->expr
;
2175 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
2176 typespec was given for the array constructor. */
2177 typespec_chararray_ctor
= (expr
->ts
.u
.cl
2178 && expr
->ts
.u
.cl
->length_from_typespec
);
2180 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2181 && expr
->ts
.type
== BT_CHARACTER
&& !typespec_chararray_ctor
)
2183 first_len_val
= gfc_create_var (gfc_charlen_type_node
, "len");
2187 gcc_assert (ss
->dimen
== ss
->loop
->dimen
);
2189 c
= expr
->value
.constructor
;
2190 if (expr
->ts
.type
== BT_CHARACTER
)
2194 /* get_array_ctor_strlen walks the elements of the constructor, if a
2195 typespec was given, we already know the string length and want the one
2197 if (typespec_chararray_ctor
&& expr
->ts
.u
.cl
->length
2198 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
2202 const_string
= false;
2203 gfc_init_se (&length_se
, NULL
);
2204 gfc_conv_expr_type (&length_se
, expr
->ts
.u
.cl
->length
,
2205 gfc_charlen_type_node
);
2206 ss_info
->string_length
= length_se
.expr
;
2207 gfc_add_block_to_block (&outer_loop
->pre
, &length_se
.pre
);
2208 gfc_add_block_to_block (&outer_loop
->post
, &length_se
.post
);
2211 const_string
= get_array_ctor_strlen (&outer_loop
->pre
, c
,
2212 &ss_info
->string_length
);
2214 /* Complex character array constructors should have been taken care of
2215 and not end up here. */
2216 gcc_assert (ss_info
->string_length
);
2218 expr
->ts
.u
.cl
->backend_decl
= ss_info
->string_length
;
2220 type
= gfc_get_character_type_len (expr
->ts
.kind
, ss_info
->string_length
);
2222 type
= build_pointer_type (type
);
2225 type
= gfc_typenode_for_spec (&expr
->ts
);
2227 /* See if the constructor determines the loop bounds. */
2230 loop_ubound0
= get_loop_upper_bound_for_array (ss
, 0);
2232 if (expr
->shape
&& get_rank (loop
) > 1 && *loop_ubound0
== NULL_TREE
)
2234 /* We have a multidimensional parameter. */
2235 for (s
= ss
; s
; s
= s
->parent
)
2238 for (n
= 0; n
< s
->loop
->dimen
; n
++)
2240 s
->loop
->from
[n
] = gfc_index_zero_node
;
2241 s
->loop
->to
[n
] = gfc_conv_mpz_to_tree (expr
->shape
[s
->dim
[n
]],
2242 gfc_index_integer_kind
);
2243 s
->loop
->to
[n
] = fold_build2_loc (input_location
, MINUS_EXPR
,
2244 gfc_array_index_type
,
2246 gfc_index_one_node
);
2251 if (*loop_ubound0
== NULL_TREE
)
2255 /* We should have a 1-dimensional, zero-based loop. */
2256 gcc_assert (loop
->parent
== NULL
&& loop
->nested
== NULL
);
2257 gcc_assert (loop
->dimen
== 1);
2258 gcc_assert (integer_zerop (loop
->from
[0]));
2260 /* Split the constructor size into a static part and a dynamic part.
2261 Allocate the static size up-front and record whether the dynamic
2262 size might be nonzero. */
2264 dynamic
= gfc_get_array_constructor_size (&size
, c
);
2265 mpz_sub_ui (size
, size
, 1);
2266 loop
->to
[0] = gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
2270 /* Special case constant array constructors. */
2273 unsigned HOST_WIDE_INT nelem
= gfc_constant_array_constructor_p (c
);
2276 tree size
= constant_array_constructor_loop_size (loop
);
2277 if (size
&& compare_tree_int (size
, nelem
) == 0)
2279 trans_constant_array_constructor (ss
, type
);
2285 if (TREE_CODE (*loop_ubound0
) == VAR_DECL
)
2288 gfc_trans_create_temp_array (&outer_loop
->pre
, &outer_loop
->post
, ss
, type
,
2289 NULL_TREE
, dynamic
, true, false, where
);
2291 desc
= ss_info
->data
.array
.descriptor
;
2292 offset
= gfc_index_zero_node
;
2293 offsetvar
= gfc_create_var_np (gfc_array_index_type
, "offset");
2294 TREE_NO_WARNING (offsetvar
) = 1;
2295 TREE_USED (offsetvar
) = 0;
2296 gfc_trans_array_constructor_value (&outer_loop
->pre
, type
, desc
, c
,
2297 &offset
, &offsetvar
, dynamic
);
2299 /* If the array grows dynamically, the upper bound of the loop variable
2300 is determined by the array's final upper bound. */
2303 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2304 gfc_array_index_type
,
2305 offsetvar
, gfc_index_one_node
);
2306 tmp
= gfc_evaluate_now (tmp
, &outer_loop
->pre
);
2307 gfc_conv_descriptor_ubound_set (&loop
->pre
, desc
, gfc_rank_cst
[0], tmp
);
2308 if (*loop_ubound0
&& TREE_CODE (*loop_ubound0
) == VAR_DECL
)
2309 gfc_add_modify (&outer_loop
->pre
, *loop_ubound0
, tmp
);
2311 *loop_ubound0
= tmp
;
2314 if (TREE_USED (offsetvar
))
2315 pushdecl (offsetvar
);
2317 gcc_assert (INTEGER_CST_P (offset
));
2320 /* Disable bound checking for now because it's probably broken. */
2321 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2328 /* Restore old values of globals. */
2329 first_len
= old_first_len
;
2330 first_len_val
= old_first_len_val
;
2331 typespec_chararray_ctor
= old_typespec_chararray_ctor
;
2335 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
2336 called after evaluating all of INFO's vector dimensions. Go through
2337 each such vector dimension and see if we can now fill in any missing
2341 set_vector_loop_bounds (gfc_ss
* ss
)
2343 gfc_loopinfo
*loop
, *outer_loop
;
2344 gfc_array_info
*info
;
2352 outer_loop
= outermost_loop (ss
->loop
);
2354 info
= &ss
->info
->data
.array
;
2356 for (; ss
; ss
= ss
->parent
)
2360 for (n
= 0; n
< loop
->dimen
; n
++)
2363 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_VECTOR
2364 || loop
->to
[n
] != NULL
)
2367 /* Loop variable N indexes vector dimension DIM, and we don't
2368 yet know the upper bound of loop variable N. Set it to the
2369 difference between the vector's upper and lower bounds. */
2370 gcc_assert (loop
->from
[n
] == gfc_index_zero_node
);
2371 gcc_assert (info
->subscript
[dim
]
2372 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
2374 gfc_init_se (&se
, NULL
);
2375 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
2376 zero
= gfc_rank_cst
[0];
2377 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2378 gfc_array_index_type
,
2379 gfc_conv_descriptor_ubound_get (desc
, zero
),
2380 gfc_conv_descriptor_lbound_get (desc
, zero
));
2381 tmp
= gfc_evaluate_now (tmp
, &outer_loop
->pre
);
2388 /* Add the pre and post chains for all the scalar expressions in a SS chain
2389 to loop. This is called after the loop parameters have been calculated,
2390 but before the actual scalarizing loops. */
2393 gfc_add_loop_ss_code (gfc_loopinfo
* loop
, gfc_ss
* ss
, bool subscript
,
2396 gfc_loopinfo
*nested_loop
, *outer_loop
;
2398 gfc_ss_info
*ss_info
;
2399 gfc_array_info
*info
;
2401 bool skip_nested
= false;
2404 outer_loop
= outermost_loop (loop
);
2406 /* TODO: This can generate bad code if there are ordering dependencies,
2407 e.g., a callee allocated function and an unknown size constructor. */
2408 gcc_assert (ss
!= NULL
);
2410 for (; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2414 /* Cross loop arrays are handled from within the most nested loop. */
2415 if (ss
->nested_ss
!= NULL
)
2419 expr
= ss_info
->expr
;
2420 info
= &ss_info
->data
.array
;
2422 switch (ss_info
->type
)
2425 /* Scalar expression. Evaluate this now. This includes elemental
2426 dimension indices, but not array section bounds. */
2427 gfc_init_se (&se
, NULL
);
2428 gfc_conv_expr (&se
, expr
);
2429 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2431 if (expr
->ts
.type
!= BT_CHARACTER
)
2433 /* Move the evaluation of scalar expressions outside the
2434 scalarization loop, except for WHERE assignments. */
2436 se
.expr
= convert(gfc_array_index_type
, se
.expr
);
2437 if (!ss_info
->where
)
2438 se
.expr
= gfc_evaluate_now (se
.expr
, &outer_loop
->pre
);
2439 gfc_add_block_to_block (&outer_loop
->pre
, &se
.post
);
2442 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2444 ss_info
->data
.scalar
.value
= se
.expr
;
2445 ss_info
->string_length
= se
.string_length
;
2448 case GFC_SS_REFERENCE
:
2449 /* Scalar argument to elemental procedure. */
2450 gfc_init_se (&se
, NULL
);
2451 if (ss_info
->can_be_null_ref
)
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 gfc_conv_expr_reference (&se
, expr
);
2460 /* Otherwise, evaluate the argument outside the loop and pass
2461 a reference to the value. */
2462 gfc_conv_expr (&se
, expr
);
2464 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2465 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2466 if (gfc_is_class_scalar_expr (expr
))
2467 /* This is necessary because the dynamic type will always be
2468 large than the declared type. In consequence, assigning
2469 the value to a temporary could segfault.
2470 OOP-TODO: see if this is generally correct or is the value
2471 has to be written to an allocated temporary, whose address
2472 is passed via ss_info. */
2473 ss_info
->data
.scalar
.value
= se
.expr
;
2475 ss_info
->data
.scalar
.value
= gfc_evaluate_now (se
.expr
,
2478 ss_info
->string_length
= se
.string_length
;
2481 case GFC_SS_SECTION
:
2482 /* Add the expressions for scalar and vector subscripts. */
2483 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2484 if (info
->subscript
[n
])
2486 gfc_add_loop_ss_code (loop
, info
->subscript
[n
], true, where
);
2487 /* The recursive call will have taken care of the nested loops.
2488 No need to do it twice. */
2492 set_vector_loop_bounds (ss
);
2496 /* Get the vector's descriptor and store it in SS. */
2497 gfc_init_se (&se
, NULL
);
2498 gfc_conv_expr_descriptor (&se
, expr
, gfc_walk_expr (expr
));
2499 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2500 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2501 info
->descriptor
= se
.expr
;
2504 case GFC_SS_INTRINSIC
:
2505 gfc_add_intrinsic_ss_code (loop
, ss
);
2508 case GFC_SS_FUNCTION
:
2509 /* Array function return value. We call the function and save its
2510 result in a temporary for use inside the loop. */
2511 gfc_init_se (&se
, NULL
);
2514 gfc_conv_expr (&se
, expr
);
2515 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2516 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2517 ss_info
->string_length
= se
.string_length
;
2520 case GFC_SS_CONSTRUCTOR
:
2521 if (expr
->ts
.type
== BT_CHARACTER
2522 && ss_info
->string_length
== NULL
2524 && expr
->ts
.u
.cl
->length
)
2526 gfc_init_se (&se
, NULL
);
2527 gfc_conv_expr_type (&se
, expr
->ts
.u
.cl
->length
,
2528 gfc_charlen_type_node
);
2529 ss_info
->string_length
= se
.expr
;
2530 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2531 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2533 trans_array_constructor (ss
, where
);
2537 case GFC_SS_COMPONENT
:
2538 /* Do nothing. These are handled elsewhere. */
2547 for (nested_loop
= loop
->nested
; nested_loop
;
2548 nested_loop
= nested_loop
->next
)
2549 gfc_add_loop_ss_code (nested_loop
, nested_loop
->ss
, subscript
, where
);
2553 /* Translate expressions for the descriptor and data pointer of a SS. */
2557 gfc_conv_ss_descriptor (stmtblock_t
* block
, gfc_ss
* ss
, int base
)
2560 gfc_ss_info
*ss_info
;
2561 gfc_array_info
*info
;
2565 info
= &ss_info
->data
.array
;
2567 /* Get the descriptor for the array to be scalarized. */
2568 gcc_assert (ss_info
->expr
->expr_type
== EXPR_VARIABLE
);
2569 gfc_init_se (&se
, NULL
);
2570 se
.descriptor_only
= 1;
2571 gfc_conv_expr_lhs (&se
, ss_info
->expr
);
2572 gfc_add_block_to_block (block
, &se
.pre
);
2573 info
->descriptor
= se
.expr
;
2574 ss_info
->string_length
= se
.string_length
;
2578 /* Also the data pointer. */
2579 tmp
= gfc_conv_array_data (se
.expr
);
2580 /* If this is a variable or address of a variable we use it directly.
2581 Otherwise we must evaluate it now to avoid breaking dependency
2582 analysis by pulling the expressions for elemental array indices
2585 || (TREE_CODE (tmp
) == ADDR_EXPR
2586 && DECL_P (TREE_OPERAND (tmp
, 0)))))
2587 tmp
= gfc_evaluate_now (tmp
, block
);
2590 tmp
= gfc_conv_array_offset (se
.expr
);
2591 info
->offset
= gfc_evaluate_now (tmp
, block
);
2593 /* Make absolutely sure that the saved_offset is indeed saved
2594 so that the variable is still accessible after the loops
2596 info
->saved_offset
= info
->offset
;
2601 /* Initialize a gfc_loopinfo structure. */
2604 gfc_init_loopinfo (gfc_loopinfo
* loop
)
2608 memset (loop
, 0, sizeof (gfc_loopinfo
));
2609 gfc_init_block (&loop
->pre
);
2610 gfc_init_block (&loop
->post
);
2612 /* Initially scalarize in order and default to no loop reversal. */
2613 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2616 loop
->reverse
[n
] = GFC_INHIBIT_REVERSE
;
2619 loop
->ss
= gfc_ss_terminator
;
2623 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2627 gfc_copy_loopinfo_to_se (gfc_se
* se
, gfc_loopinfo
* loop
)
2633 /* Return an expression for the data pointer of an array. */
2636 gfc_conv_array_data (tree descriptor
)
2640 type
= TREE_TYPE (descriptor
);
2641 if (GFC_ARRAY_TYPE_P (type
))
2643 if (TREE_CODE (type
) == POINTER_TYPE
)
2647 /* Descriptorless arrays. */
2648 return gfc_build_addr_expr (NULL_TREE
, descriptor
);
2652 return gfc_conv_descriptor_data_get (descriptor
);
2656 /* Return an expression for the base offset of an array. */
2659 gfc_conv_array_offset (tree descriptor
)
2663 type
= TREE_TYPE (descriptor
);
2664 if (GFC_ARRAY_TYPE_P (type
))
2665 return GFC_TYPE_ARRAY_OFFSET (type
);
2667 return gfc_conv_descriptor_offset_get (descriptor
);
2671 /* Get an expression for the array stride. */
2674 gfc_conv_array_stride (tree descriptor
, int dim
)
2679 type
= TREE_TYPE (descriptor
);
2681 /* For descriptorless arrays use the array size. */
2682 tmp
= GFC_TYPE_ARRAY_STRIDE (type
, dim
);
2683 if (tmp
!= NULL_TREE
)
2686 tmp
= gfc_conv_descriptor_stride_get (descriptor
, gfc_rank_cst
[dim
]);
2691 /* Like gfc_conv_array_stride, but for the lower bound. */
2694 gfc_conv_array_lbound (tree descriptor
, int dim
)
2699 type
= TREE_TYPE (descriptor
);
2701 tmp
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
2702 if (tmp
!= NULL_TREE
)
2705 tmp
= gfc_conv_descriptor_lbound_get (descriptor
, gfc_rank_cst
[dim
]);
2710 /* Like gfc_conv_array_stride, but for the upper bound. */
2713 gfc_conv_array_ubound (tree descriptor
, int dim
)
2718 type
= TREE_TYPE (descriptor
);
2720 tmp
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
2721 if (tmp
!= NULL_TREE
)
2724 /* This should only ever happen when passing an assumed shape array
2725 as an actual parameter. The value will never be used. */
2726 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor
)))
2727 return gfc_index_zero_node
;
2729 tmp
= gfc_conv_descriptor_ubound_get (descriptor
, gfc_rank_cst
[dim
]);
2734 /* Generate code to perform an array index bound check. */
2737 trans_array_bound_check (gfc_se
* se
, gfc_ss
*ss
, tree index
, int n
,
2738 locus
* where
, bool check_upper
)
2741 tree tmp_lo
, tmp_up
;
2744 const char * name
= NULL
;
2746 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
2749 descriptor
= ss
->info
->data
.array
.descriptor
;
2751 index
= gfc_evaluate_now (index
, &se
->pre
);
2753 /* We find a name for the error message. */
2754 name
= ss
->info
->expr
->symtree
->n
.sym
->name
;
2755 gcc_assert (name
!= NULL
);
2757 if (TREE_CODE (descriptor
) == VAR_DECL
)
2758 name
= IDENTIFIER_POINTER (DECL_NAME (descriptor
));
2760 /* If upper bound is present, include both bounds in the error message. */
2763 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
2764 tmp_up
= gfc_conv_array_ubound (descriptor
, n
);
2767 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
2768 "outside of expected range (%%ld:%%ld)", n
+1, name
);
2770 asprintf (&msg
, "Index '%%ld' of dimension %d "
2771 "outside of expected range (%%ld:%%ld)", n
+1);
2773 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2775 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2776 fold_convert (long_integer_type_node
, index
),
2777 fold_convert (long_integer_type_node
, tmp_lo
),
2778 fold_convert (long_integer_type_node
, tmp_up
));
2779 fault
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2781 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2782 fold_convert (long_integer_type_node
, index
),
2783 fold_convert (long_integer_type_node
, tmp_lo
),
2784 fold_convert (long_integer_type_node
, tmp_up
));
2789 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
2792 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
2793 "below lower bound of %%ld", n
+1, name
);
2795 asprintf (&msg
, "Index '%%ld' of dimension %d "
2796 "below lower bound of %%ld", n
+1);
2798 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2800 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2801 fold_convert (long_integer_type_node
, index
),
2802 fold_convert (long_integer_type_node
, tmp_lo
));
2810 /* Return the offset for an index. Performs bound checking for elemental
2811 dimensions. Single element references are processed separately.
2812 DIM is the array dimension, I is the loop dimension. */
2815 conv_array_index_offset (gfc_se
* se
, gfc_ss
* ss
, int dim
, int i
,
2816 gfc_array_ref
* ar
, tree stride
)
2818 gfc_array_info
*info
;
2823 info
= &ss
->info
->data
.array
;
2825 /* Get the index into the array for this dimension. */
2828 gcc_assert (ar
->type
!= AR_ELEMENT
);
2829 switch (ar
->dimen_type
[dim
])
2831 case DIMEN_THIS_IMAGE
:
2835 /* Elemental dimension. */
2836 gcc_assert (info
->subscript
[dim
]
2837 && info
->subscript
[dim
]->info
->type
== GFC_SS_SCALAR
);
2838 /* We've already translated this value outside the loop. */
2839 index
= info
->subscript
[dim
]->info
->data
.scalar
.value
;
2841 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
2842 ar
->as
->type
!= AS_ASSUMED_SIZE
2843 || dim
< ar
->dimen
- 1);
2847 gcc_assert (info
&& se
->loop
);
2848 gcc_assert (info
->subscript
[dim
]
2849 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
2850 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
2852 /* Get a zero-based index into the vector. */
2853 index
= fold_build2_loc (input_location
, MINUS_EXPR
,
2854 gfc_array_index_type
,
2855 se
->loop
->loopvar
[i
], se
->loop
->from
[i
]);
2857 /* Multiply the index by the stride. */
2858 index
= fold_build2_loc (input_location
, MULT_EXPR
,
2859 gfc_array_index_type
,
2860 index
, gfc_conv_array_stride (desc
, 0));
2862 /* Read the vector to get an index into info->descriptor. */
2863 data
= build_fold_indirect_ref_loc (input_location
,
2864 gfc_conv_array_data (desc
));
2865 index
= gfc_build_array_ref (data
, index
, NULL
);
2866 index
= gfc_evaluate_now (index
, &se
->pre
);
2867 index
= fold_convert (gfc_array_index_type
, index
);
2869 /* Do any bounds checking on the final info->descriptor index. */
2870 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
2871 ar
->as
->type
!= AS_ASSUMED_SIZE
2872 || dim
< ar
->dimen
- 1);
2876 /* Scalarized dimension. */
2877 gcc_assert (info
&& se
->loop
);
2879 /* Multiply the loop variable by the stride and delta. */
2880 index
= se
->loop
->loopvar
[i
];
2881 if (!integer_onep (info
->stride
[dim
]))
2882 index
= fold_build2_loc (input_location
, MULT_EXPR
,
2883 gfc_array_index_type
, index
,
2885 if (!integer_zerop (info
->delta
[dim
]))
2886 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
2887 gfc_array_index_type
, index
,
2897 /* Temporary array or derived type component. */
2898 gcc_assert (se
->loop
);
2899 index
= se
->loop
->loopvar
[se
->loop
->order
[i
]];
2901 /* Pointer functions can have stride[0] different from unity.
2902 Use the stride returned by the function call and stored in
2903 the descriptor for the temporary. */
2904 if (se
->ss
&& se
->ss
->info
->type
== GFC_SS_FUNCTION
2905 && se
->ss
->info
->expr
2906 && se
->ss
->info
->expr
->symtree
2907 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
2908 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
->attr
.pointer
)
2909 stride
= gfc_conv_descriptor_stride_get (info
->descriptor
,
2912 if (!integer_zerop (info
->delta
[dim
]))
2913 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
2914 gfc_array_index_type
, index
, info
->delta
[dim
]);
2917 /* Multiply by the stride. */
2918 if (!integer_onep (stride
))
2919 index
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
2926 /* Build a scalarized array reference using the vptr 'size'. */
2929 build_class_array_ref (gfc_se
*se
, tree base
, tree index
)
2936 gfc_expr
*expr
= se
->ss
->info
->expr
;
2941 if (expr
== NULL
|| expr
->ts
.type
!= BT_CLASS
)
2944 if (expr
->symtree
&& expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
2945 ts
= &expr
->symtree
->n
.sym
->ts
;
2950 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2952 if (ref
->type
== REF_COMPONENT
2953 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
2954 && ref
->next
&& ref
->next
->type
== REF_COMPONENT
2955 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0
2957 && ref
->next
->next
->type
== REF_ARRAY
2958 && ref
->next
->next
->u
.ar
.type
!= AR_ELEMENT
)
2960 ts
= &ref
->u
.c
.component
->ts
;
2969 if (class_ref
== NULL
)
2970 decl
= expr
->symtree
->n
.sym
->backend_decl
;
2973 /* Remove everything after the last class reference, convert the
2974 expression and then recover its tailend once more. */
2976 ref
= class_ref
->next
;
2977 class_ref
->next
= NULL
;
2978 gfc_init_se (&tmpse
, NULL
);
2979 gfc_conv_expr (&tmpse
, expr
);
2981 class_ref
->next
= ref
;
2984 size
= gfc_vtable_size_get (decl
);
2986 /* Build the address of the element. */
2987 type
= TREE_TYPE (TREE_TYPE (base
));
2988 size
= fold_convert (TREE_TYPE (index
), size
);
2989 offset
= fold_build2_loc (input_location
, MULT_EXPR
,
2990 gfc_array_index_type
,
2992 tmp
= gfc_build_addr_expr (pvoid_type_node
, base
);
2993 tmp
= fold_build_pointer_plus_loc (input_location
, tmp
, offset
);
2994 tmp
= fold_convert (build_pointer_type (type
), tmp
);
2996 /* Return the element in the se expression. */
2997 se
->expr
= build_fold_indirect_ref_loc (input_location
, tmp
);
3002 /* Build a scalarized reference to an array. */
3005 gfc_conv_scalarized_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
3007 gfc_array_info
*info
;
3008 tree decl
= NULL_TREE
;
3016 expr
= ss
->info
->expr
;
3017 info
= &ss
->info
->data
.array
;
3019 n
= se
->loop
->order
[0];
3023 index
= conv_array_index_offset (se
, ss
, ss
->dim
[n
], n
, ar
, info
->stride0
);
3024 /* Add the offset for this dimension to the stored offset for all other
3026 if (!integer_zerop (info
->offset
))
3027 index
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3028 index
, info
->offset
);
3030 if (expr
&& is_subref_array (expr
))
3031 decl
= expr
->symtree
->n
.sym
->backend_decl
;
3033 tmp
= build_fold_indirect_ref_loc (input_location
, info
->data
);
3035 /* Use the vptr 'size' field to access a class the element of a class
3037 if (build_class_array_ref (se
, tmp
, index
))
3040 se
->expr
= gfc_build_array_ref (tmp
, index
, decl
);
3044 /* Translate access of temporary array. */
3047 gfc_conv_tmp_array_ref (gfc_se
* se
)
3049 se
->string_length
= se
->ss
->info
->string_length
;
3050 gfc_conv_scalarized_array_ref (se
, NULL
);
3051 gfc_advance_se_ss_chain (se
);
3054 /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
3057 add_to_offset (tree
*cst_offset
, tree
*offset
, tree t
)
3059 if (TREE_CODE (t
) == INTEGER_CST
)
3060 *cst_offset
= int_const_binop (PLUS_EXPR
, *cst_offset
, t
);
3063 if (!integer_zerop (*offset
))
3064 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3065 gfc_array_index_type
, *offset
, t
);
3073 build_array_ref (tree desc
, tree offset
, tree decl
)
3077 /* Class array references need special treatment because the assigned
3078 type size needs to be used to point to the element. */
3079 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
3080 && TREE_CODE (desc
) == COMPONENT_REF
3081 && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (desc
, 0))))
3083 tree type
= gfc_get_element_type (TREE_TYPE (desc
));
3084 tmp
= TREE_OPERAND (desc
, 0);
3085 tmp
= gfc_get_class_array_ref (offset
, tmp
);
3086 tmp
= fold_convert (build_pointer_type (type
), tmp
);
3087 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3091 tmp
= gfc_conv_array_data (desc
);
3092 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3093 tmp
= gfc_build_array_ref (tmp
, offset
, decl
);
3101 /* Build an array reference. se->expr already holds the array descriptor.
3102 This should be either a variable, indirect variable reference or component
3103 reference. For arrays which do not have a descriptor, se->expr will be
3105 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
3108 gfc_conv_array_ref (gfc_se
* se
, gfc_array_ref
* ar
, gfc_symbol
* sym
,
3112 tree offset
, cst_offset
;
3120 gcc_assert (ar
->codimen
);
3122 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
->expr
)))
3123 se
->expr
= build_fold_indirect_ref (gfc_conv_array_data (se
->expr
));
3126 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se
->expr
))
3127 && TREE_CODE (TREE_TYPE (se
->expr
)) == POINTER_TYPE
)
3128 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3130 /* Use the actual tree type and not the wrapped coarray. */
3131 if (!se
->want_pointer
)
3132 se
->expr
= fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se
->expr
)),
3139 /* Handle scalarized references separately. */
3140 if (ar
->type
!= AR_ELEMENT
)
3142 gfc_conv_scalarized_array_ref (se
, ar
);
3143 gfc_advance_se_ss_chain (se
);
3147 cst_offset
= offset
= gfc_index_zero_node
;
3148 add_to_offset (&cst_offset
, &offset
, gfc_conv_array_offset (se
->expr
));
3150 /* Calculate the offsets from all the dimensions. Make sure to associate
3151 the final offset so that we form a chain of loop invariant summands. */
3152 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
3154 /* Calculate the index for this dimension. */
3155 gfc_init_se (&indexse
, se
);
3156 gfc_conv_expr_type (&indexse
, ar
->start
[n
], gfc_array_index_type
);
3157 gfc_add_block_to_block (&se
->pre
, &indexse
.pre
);
3159 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3161 /* Check array bounds. */
3165 /* Evaluate the indexse.expr only once. */
3166 indexse
.expr
= save_expr (indexse
.expr
);
3169 tmp
= gfc_conv_array_lbound (se
->expr
, n
);
3170 if (sym
->attr
.temporary
)
3172 gfc_init_se (&tmpse
, se
);
3173 gfc_conv_expr_type (&tmpse
, ar
->as
->lower
[n
],
3174 gfc_array_index_type
);
3175 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3179 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
3181 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
3182 "below lower bound of %%ld", n
+1, sym
->name
);
3183 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3184 fold_convert (long_integer_type_node
,
3186 fold_convert (long_integer_type_node
, tmp
));
3189 /* Upper bound, but not for the last dimension of assumed-size
3191 if (n
< ar
->dimen
- 1 || ar
->as
->type
!= AS_ASSUMED_SIZE
)
3193 tmp
= gfc_conv_array_ubound (se
->expr
, n
);
3194 if (sym
->attr
.temporary
)
3196 gfc_init_se (&tmpse
, se
);
3197 gfc_conv_expr_type (&tmpse
, ar
->as
->upper
[n
],
3198 gfc_array_index_type
);
3199 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3203 cond
= fold_build2_loc (input_location
, GT_EXPR
,
3204 boolean_type_node
, indexse
.expr
, tmp
);
3205 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
3206 "above upper bound of %%ld", n
+1, sym
->name
);
3207 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3208 fold_convert (long_integer_type_node
,
3210 fold_convert (long_integer_type_node
, tmp
));
3215 /* Multiply the index by the stride. */
3216 stride
= gfc_conv_array_stride (se
->expr
, n
);
3217 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3218 indexse
.expr
, stride
);
3220 /* And add it to the total. */
3221 add_to_offset (&cst_offset
, &offset
, tmp
);
3224 if (!integer_zerop (cst_offset
))
3225 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3226 gfc_array_index_type
, offset
, cst_offset
);
3228 se
->expr
= build_array_ref (se
->expr
, offset
, sym
->backend_decl
);
3232 /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
3233 LOOP_DIM dimension (if any) to array's offset. */
3236 add_array_offset (stmtblock_t
*pblock
, gfc_loopinfo
*loop
, gfc_ss
*ss
,
3237 gfc_array_ref
*ar
, int array_dim
, int loop_dim
)
3240 gfc_array_info
*info
;
3243 info
= &ss
->info
->data
.array
;
3245 gfc_init_se (&se
, NULL
);
3247 se
.expr
= info
->descriptor
;
3248 stride
= gfc_conv_array_stride (info
->descriptor
, array_dim
);
3249 index
= conv_array_index_offset (&se
, ss
, array_dim
, loop_dim
, ar
, stride
);
3250 gfc_add_block_to_block (pblock
, &se
.pre
);
3252 info
->offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3253 gfc_array_index_type
,
3254 info
->offset
, index
);
3255 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
3259 /* Generate the code to be executed immediately before entering a
3260 scalarization loop. */
3263 gfc_trans_preloop_setup (gfc_loopinfo
* loop
, int dim
, int flag
,
3264 stmtblock_t
* pblock
)
3267 gfc_ss_info
*ss_info
;
3268 gfc_array_info
*info
;
3269 gfc_ss_type ss_type
;
3271 gfc_loopinfo
*ploop
;
3275 /* This code will be executed before entering the scalarization loop
3276 for this dimension. */
3277 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3281 if ((ss_info
->useflags
& flag
) == 0)
3284 ss_type
= ss_info
->type
;
3285 if (ss_type
!= GFC_SS_SECTION
3286 && ss_type
!= GFC_SS_FUNCTION
3287 && ss_type
!= GFC_SS_CONSTRUCTOR
3288 && ss_type
!= GFC_SS_COMPONENT
)
3291 info
= &ss_info
->data
.array
;
3293 gcc_assert (dim
< ss
->dimen
);
3294 gcc_assert (ss
->dimen
== loop
->dimen
);
3297 ar
= &info
->ref
->u
.ar
;
3301 if (dim
== loop
->dimen
- 1 && loop
->parent
!= NULL
)
3303 /* If we are in the outermost dimension of this loop, the previous
3304 dimension shall be in the parent loop. */
3305 gcc_assert (ss
->parent
!= NULL
);
3308 ploop
= loop
->parent
;
3310 /* ss and ss->parent are about the same array. */
3311 gcc_assert (ss_info
== pss
->info
);
3319 if (dim
== loop
->dimen
- 1)
3324 /* For the time being, there is no loop reordering. */
3325 gcc_assert (i
== ploop
->order
[i
]);
3326 i
= ploop
->order
[i
];
3328 if (dim
== loop
->dimen
- 1 && loop
->parent
== NULL
)
3330 stride
= gfc_conv_array_stride (info
->descriptor
,
3331 innermost_ss (ss
)->dim
[i
]);
3333 /* Calculate the stride of the innermost loop. Hopefully this will
3334 allow the backend optimizers to do their stuff more effectively.
3336 info
->stride0
= gfc_evaluate_now (stride
, pblock
);
3338 /* For the outermost loop calculate the offset due to any
3339 elemental dimensions. It will have been initialized with the
3340 base offset of the array. */
3343 for (i
= 0; i
< ar
->dimen
; i
++)
3345 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
3348 add_array_offset (pblock
, loop
, ss
, ar
, i
, /* unused */ -1);
3353 /* Add the offset for the previous loop dimension. */
3354 add_array_offset (pblock
, ploop
, ss
, ar
, pss
->dim
[i
], i
);
3356 /* Remember this offset for the second loop. */
3357 if (dim
== loop
->temp_dim
- 1 && loop
->parent
== NULL
)
3358 info
->saved_offset
= info
->offset
;
3363 /* Start a scalarized expression. Creates a scope and declares loop
3367 gfc_start_scalarized_body (gfc_loopinfo
* loop
, stmtblock_t
* pbody
)
3373 gcc_assert (!loop
->array_parameter
);
3375 for (dim
= loop
->dimen
- 1; dim
>= 0; dim
--)
3377 n
= loop
->order
[dim
];
3379 gfc_start_block (&loop
->code
[n
]);
3381 /* Create the loop variable. */
3382 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "S");
3384 if (dim
< loop
->temp_dim
)
3388 /* Calculate values that will be constant within this loop. */
3389 gfc_trans_preloop_setup (loop
, dim
, flags
, &loop
->code
[n
]);
3391 gfc_start_block (pbody
);
3395 /* Generates the actual loop code for a scalarization loop. */
3398 gfc_trans_scalarized_loop_end (gfc_loopinfo
* loop
, int n
,
3399 stmtblock_t
* pbody
)
3410 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
))
3411 == (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
)
3412 && n
== loop
->dimen
- 1)
3414 /* We create an OMP_FOR construct for the outermost scalarized loop. */
3415 init
= make_tree_vec (1);
3416 cond
= make_tree_vec (1);
3417 incr
= make_tree_vec (1);
3419 /* Cycle statement is implemented with a goto. Exit statement must not
3420 be present for this loop. */
3421 exit_label
= gfc_build_label_decl (NULL_TREE
);
3422 TREE_USED (exit_label
) = 1;
3424 /* Label for cycle statements (if needed). */
3425 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3426 gfc_add_expr_to_block (pbody
, tmp
);
3428 stmt
= make_node (OMP_FOR
);
3430 TREE_TYPE (stmt
) = void_type_node
;
3431 OMP_FOR_BODY (stmt
) = loopbody
= gfc_finish_block (pbody
);
3433 OMP_FOR_CLAUSES (stmt
) = build_omp_clause (input_location
,
3434 OMP_CLAUSE_SCHEDULE
);
3435 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt
))
3436 = OMP_CLAUSE_SCHEDULE_STATIC
;
3437 if (ompws_flags
& OMPWS_NOWAIT
)
3438 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt
))
3439 = build_omp_clause (input_location
, OMP_CLAUSE_NOWAIT
);
3441 /* Initialize the loopvar. */
3442 TREE_VEC_ELT (init
, 0) = build2_v (MODIFY_EXPR
, loop
->loopvar
[n
],
3444 OMP_FOR_INIT (stmt
) = init
;
3445 /* The exit condition. */
3446 TREE_VEC_ELT (cond
, 0) = build2_loc (input_location
, LE_EXPR
,
3448 loop
->loopvar
[n
], loop
->to
[n
]);
3449 SET_EXPR_LOCATION (TREE_VEC_ELT (cond
, 0), input_location
);
3450 OMP_FOR_COND (stmt
) = cond
;
3451 /* Increment the loopvar. */
3452 tmp
= build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3453 loop
->loopvar
[n
], gfc_index_one_node
);
3454 TREE_VEC_ELT (incr
, 0) = fold_build2_loc (input_location
, MODIFY_EXPR
,
3455 void_type_node
, loop
->loopvar
[n
], tmp
);
3456 OMP_FOR_INCR (stmt
) = incr
;
3458 ompws_flags
&= ~OMPWS_CURR_SINGLEUNIT
;
3459 gfc_add_expr_to_block (&loop
->code
[n
], stmt
);
3463 bool reverse_loop
= (loop
->reverse
[n
] == GFC_REVERSE_SET
)
3464 && (loop
->temp_ss
== NULL
);
3466 loopbody
= gfc_finish_block (pbody
);
3470 tmp
= loop
->from
[n
];
3471 loop
->from
[n
] = loop
->to
[n
];
3475 /* Initialize the loopvar. */
3476 if (loop
->loopvar
[n
] != loop
->from
[n
])
3477 gfc_add_modify (&loop
->code
[n
], loop
->loopvar
[n
], loop
->from
[n
]);
3479 exit_label
= gfc_build_label_decl (NULL_TREE
);
3481 /* Generate the loop body. */
3482 gfc_init_block (&block
);
3484 /* The exit condition. */
3485 cond
= fold_build2_loc (input_location
, reverse_loop
? LT_EXPR
: GT_EXPR
,
3486 boolean_type_node
, loop
->loopvar
[n
], loop
->to
[n
]);
3487 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3488 TREE_USED (exit_label
) = 1;
3489 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3490 gfc_add_expr_to_block (&block
, tmp
);
3492 /* The main body. */
3493 gfc_add_expr_to_block (&block
, loopbody
);
3495 /* Increment the loopvar. */
3496 tmp
= fold_build2_loc (input_location
,
3497 reverse_loop
? MINUS_EXPR
: PLUS_EXPR
,
3498 gfc_array_index_type
, loop
->loopvar
[n
],
3499 gfc_index_one_node
);
3501 gfc_add_modify (&block
, loop
->loopvar
[n
], tmp
);
3503 /* Build the loop. */
3504 tmp
= gfc_finish_block (&block
);
3505 tmp
= build1_v (LOOP_EXPR
, tmp
);
3506 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
3508 /* Add the exit label. */
3509 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3510 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
3516 /* Finishes and generates the loops for a scalarized expression. */
3519 gfc_trans_scalarizing_loops (gfc_loopinfo
* loop
, stmtblock_t
* body
)
3524 stmtblock_t
*pblock
;
3528 /* Generate the loops. */
3529 for (dim
= 0; dim
< loop
->dimen
; dim
++)
3531 n
= loop
->order
[dim
];
3532 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
3533 loop
->loopvar
[n
] = NULL_TREE
;
3534 pblock
= &loop
->code
[n
];
3537 tmp
= gfc_finish_block (pblock
);
3538 gfc_add_expr_to_block (&loop
->pre
, tmp
);
3540 /* Clear all the used flags. */
3541 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3542 if (ss
->parent
== NULL
)
3543 ss
->info
->useflags
= 0;
3547 /* Finish the main body of a scalarized expression, and start the secondary
3551 gfc_trans_scalarized_loop_boundary (gfc_loopinfo
* loop
, stmtblock_t
* body
)
3555 stmtblock_t
*pblock
;
3559 /* We finish as many loops as are used by the temporary. */
3560 for (dim
= 0; dim
< loop
->temp_dim
- 1; dim
++)
3562 n
= loop
->order
[dim
];
3563 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
3564 loop
->loopvar
[n
] = NULL_TREE
;
3565 pblock
= &loop
->code
[n
];
3568 /* We don't want to finish the outermost loop entirely. */
3569 n
= loop
->order
[loop
->temp_dim
- 1];
3570 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
3572 /* Restore the initial offsets. */
3573 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3575 gfc_ss_type ss_type
;
3576 gfc_ss_info
*ss_info
;
3580 if ((ss_info
->useflags
& 2) == 0)
3583 ss_type
= ss_info
->type
;
3584 if (ss_type
!= GFC_SS_SECTION
3585 && ss_type
!= GFC_SS_FUNCTION
3586 && ss_type
!= GFC_SS_CONSTRUCTOR
3587 && ss_type
!= GFC_SS_COMPONENT
)
3590 ss_info
->data
.array
.offset
= ss_info
->data
.array
.saved_offset
;
3593 /* Restart all the inner loops we just finished. */
3594 for (dim
= loop
->temp_dim
- 2; dim
>= 0; dim
--)
3596 n
= loop
->order
[dim
];
3598 gfc_start_block (&loop
->code
[n
]);
3600 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "Q");
3602 gfc_trans_preloop_setup (loop
, dim
, 2, &loop
->code
[n
]);
3605 /* Start a block for the secondary copying code. */
3606 gfc_start_block (body
);
3610 /* Precalculate (either lower or upper) bound of an array section.
3611 BLOCK: Block in which the (pre)calculation code will go.
3612 BOUNDS[DIM]: Where the bound value will be stored once evaluated.
3613 VALUES[DIM]: Specified bound (NULL <=> unspecified).
3614 DESC: Array descriptor from which the bound will be picked if unspecified
3615 (either lower or upper bound according to LBOUND). */
3618 evaluate_bound (stmtblock_t
*block
, tree
*bounds
, gfc_expr
** values
,
3619 tree desc
, int dim
, bool lbound
)
3622 gfc_expr
* input_val
= values
[dim
];
3623 tree
*output
= &bounds
[dim
];
3628 /* Specified section bound. */
3629 gfc_init_se (&se
, NULL
);
3630 gfc_conv_expr_type (&se
, input_val
, gfc_array_index_type
);
3631 gfc_add_block_to_block (block
, &se
.pre
);
3636 /* No specific bound specified so use the bound of the array. */
3637 *output
= lbound
? gfc_conv_array_lbound (desc
, dim
) :
3638 gfc_conv_array_ubound (desc
, dim
);
3640 *output
= gfc_evaluate_now (*output
, block
);
3644 /* Calculate the lower bound of an array section. */
3647 gfc_conv_section_startstride (gfc_loopinfo
* loop
, gfc_ss
* ss
, int dim
)
3649 gfc_expr
*stride
= NULL
;
3652 gfc_array_info
*info
;
3655 gcc_assert (ss
->info
->type
== GFC_SS_SECTION
);
3657 info
= &ss
->info
->data
.array
;
3658 ar
= &info
->ref
->u
.ar
;
3660 if (ar
->dimen_type
[dim
] == DIMEN_VECTOR
)
3662 /* We use a zero-based index to access the vector. */
3663 info
->start
[dim
] = gfc_index_zero_node
;
3664 info
->end
[dim
] = NULL
;
3665 info
->stride
[dim
] = gfc_index_one_node
;
3669 gcc_assert (ar
->dimen_type
[dim
] == DIMEN_RANGE
3670 || ar
->dimen_type
[dim
] == DIMEN_THIS_IMAGE
);
3671 desc
= info
->descriptor
;
3672 stride
= ar
->stride
[dim
];
3674 /* Calculate the start of the range. For vector subscripts this will
3675 be the range of the vector. */
3676 evaluate_bound (&loop
->pre
, info
->start
, ar
->start
, desc
, dim
, true);
3678 /* Similarly calculate the end. Although this is not used in the
3679 scalarizer, it is needed when checking bounds and where the end
3680 is an expression with side-effects. */
3681 evaluate_bound (&loop
->pre
, info
->end
, ar
->end
, desc
, dim
, false);
3683 /* Calculate the stride. */
3685 info
->stride
[dim
] = gfc_index_one_node
;
3688 gfc_init_se (&se
, NULL
);
3689 gfc_conv_expr_type (&se
, stride
, gfc_array_index_type
);
3690 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
3691 info
->stride
[dim
] = gfc_evaluate_now (se
.expr
, &loop
->pre
);
3696 /* Calculates the range start and stride for a SS chain. Also gets the
3697 descriptor and data pointer. The range of vector subscripts is the size
3698 of the vector. Array bounds are also checked. */
3701 gfc_conv_ss_startstride (gfc_loopinfo
* loop
)
3709 /* Determine the rank of the loop. */
3710 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3712 switch (ss
->info
->type
)
3714 case GFC_SS_SECTION
:
3715 case GFC_SS_CONSTRUCTOR
:
3716 case GFC_SS_FUNCTION
:
3717 case GFC_SS_COMPONENT
:
3718 loop
->dimen
= ss
->dimen
;
3721 /* As usual, lbound and ubound are exceptions!. */
3722 case GFC_SS_INTRINSIC
:
3723 switch (ss
->info
->expr
->value
.function
.isym
->id
)
3725 case GFC_ISYM_LBOUND
:
3726 case GFC_ISYM_UBOUND
:
3727 case GFC_ISYM_LCOBOUND
:
3728 case GFC_ISYM_UCOBOUND
:
3729 case GFC_ISYM_THIS_IMAGE
:
3730 loop
->dimen
= ss
->dimen
;
3742 /* We should have determined the rank of the expression by now. If
3743 not, that's bad news. */
3747 /* Loop over all the SS in the chain. */
3748 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3750 gfc_ss_info
*ss_info
;
3751 gfc_array_info
*info
;
3755 expr
= ss_info
->expr
;
3756 info
= &ss_info
->data
.array
;
3758 if (expr
&& expr
->shape
&& !info
->shape
)
3759 info
->shape
= expr
->shape
;
3761 switch (ss_info
->type
)
3763 case GFC_SS_SECTION
:
3764 /* Get the descriptor for the array. If it is a cross loops array,
3765 we got the descriptor already in the outermost loop. */
3766 if (ss
->parent
== NULL
)
3767 gfc_conv_ss_descriptor (&loop
->pre
, ss
, !loop
->array_parameter
);
3769 for (n
= 0; n
< ss
->dimen
; n
++)
3770 gfc_conv_section_startstride (loop
, ss
, ss
->dim
[n
]);
3773 case GFC_SS_INTRINSIC
:
3774 switch (expr
->value
.function
.isym
->id
)
3776 /* Fall through to supply start and stride. */
3777 case GFC_ISYM_LBOUND
:
3778 case GFC_ISYM_UBOUND
:
3779 case GFC_ISYM_LCOBOUND
:
3780 case GFC_ISYM_UCOBOUND
:
3781 case GFC_ISYM_THIS_IMAGE
:
3788 case GFC_SS_CONSTRUCTOR
:
3789 case GFC_SS_FUNCTION
:
3790 for (n
= 0; n
< ss
->dimen
; n
++)
3792 int dim
= ss
->dim
[n
];
3794 info
->start
[dim
] = gfc_index_zero_node
;
3795 info
->end
[dim
] = gfc_index_zero_node
;
3796 info
->stride
[dim
] = gfc_index_one_node
;
3805 /* The rest is just runtime bound checking. */
3806 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3809 tree lbound
, ubound
;
3811 tree size
[GFC_MAX_DIMENSIONS
];
3812 tree stride_pos
, stride_neg
, non_zerosized
, tmp2
, tmp3
;
3813 gfc_array_info
*info
;
3817 gfc_start_block (&block
);
3819 for (n
= 0; n
< loop
->dimen
; n
++)
3820 size
[n
] = NULL_TREE
;
3822 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3825 gfc_ss_info
*ss_info
;
3828 const char *expr_name
;
3831 if (ss_info
->type
!= GFC_SS_SECTION
)
3834 /* Catch allocatable lhs in f2003. */
3835 if (gfc_option
.flag_realloc_lhs
&& ss
->is_alloc_lhs
)
3838 expr
= ss_info
->expr
;
3839 expr_loc
= &expr
->where
;
3840 expr_name
= expr
->symtree
->name
;
3842 gfc_start_block (&inner
);
3844 /* TODO: range checking for mapped dimensions. */
3845 info
= &ss_info
->data
.array
;
3847 /* This code only checks ranges. Elemental and vector
3848 dimensions are checked later. */
3849 for (n
= 0; n
< loop
->dimen
; n
++)
3854 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
3857 if (dim
== info
->ref
->u
.ar
.dimen
- 1
3858 && info
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
3859 check_upper
= false;
3863 /* Zero stride is not allowed. */
3864 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
3865 info
->stride
[dim
], gfc_index_zero_node
);
3866 asprintf (&msg
, "Zero stride is not allowed, for dimension %d "
3867 "of array '%s'", dim
+ 1, expr_name
);
3868 gfc_trans_runtime_check (true, false, tmp
, &inner
,
3872 desc
= info
->descriptor
;
3874 /* This is the run-time equivalent of resolve.c's
3875 check_dimension(). The logical is more readable there
3876 than it is here, with all the trees. */
3877 lbound
= gfc_conv_array_lbound (desc
, dim
);
3878 end
= info
->end
[dim
];
3880 ubound
= gfc_conv_array_ubound (desc
, dim
);
3884 /* non_zerosized is true when the selected range is not
3886 stride_pos
= fold_build2_loc (input_location
, GT_EXPR
,
3887 boolean_type_node
, info
->stride
[dim
],
3888 gfc_index_zero_node
);
3889 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
3890 info
->start
[dim
], end
);
3891 stride_pos
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3892 boolean_type_node
, stride_pos
, tmp
);
3894 stride_neg
= fold_build2_loc (input_location
, LT_EXPR
,
3896 info
->stride
[dim
], gfc_index_zero_node
);
3897 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
3898 info
->start
[dim
], end
);
3899 stride_neg
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3902 non_zerosized
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
3904 stride_pos
, stride_neg
);
3906 /* Check the start of the range against the lower and upper
3907 bounds of the array, if the range is not empty.
3908 If upper bound is present, include both bounds in the
3912 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
3914 info
->start
[dim
], lbound
);
3915 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3917 non_zerosized
, tmp
);
3918 tmp2
= fold_build2_loc (input_location
, GT_EXPR
,
3920 info
->start
[dim
], ubound
);
3921 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3923 non_zerosized
, tmp2
);
3924 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
3925 "outside of expected range (%%ld:%%ld)",
3926 dim
+ 1, expr_name
);
3927 gfc_trans_runtime_check (true, false, tmp
, &inner
,
3929 fold_convert (long_integer_type_node
, info
->start
[dim
]),
3930 fold_convert (long_integer_type_node
, lbound
),
3931 fold_convert (long_integer_type_node
, ubound
));
3932 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
3934 fold_convert (long_integer_type_node
, info
->start
[dim
]),
3935 fold_convert (long_integer_type_node
, lbound
),
3936 fold_convert (long_integer_type_node
, ubound
));
3941 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
3943 info
->start
[dim
], lbound
);
3944 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3945 boolean_type_node
, non_zerosized
, tmp
);
3946 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
3947 "below lower bound of %%ld",
3948 dim
+ 1, expr_name
);
3949 gfc_trans_runtime_check (true, false, tmp
, &inner
,
3951 fold_convert (long_integer_type_node
, info
->start
[dim
]),
3952 fold_convert (long_integer_type_node
, lbound
));
3956 /* Compute the last element of the range, which is not
3957 necessarily "end" (think 0:5:3, which doesn't contain 5)
3958 and check it against both lower and upper bounds. */
3960 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3961 gfc_array_index_type
, end
,
3963 tmp
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
,
3964 gfc_array_index_type
, tmp
,
3966 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3967 gfc_array_index_type
, end
, tmp
);
3968 tmp2
= fold_build2_loc (input_location
, LT_EXPR
,
3969 boolean_type_node
, tmp
, lbound
);
3970 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3971 boolean_type_node
, non_zerosized
, tmp2
);
3974 tmp3
= fold_build2_loc (input_location
, GT_EXPR
,
3975 boolean_type_node
, tmp
, ubound
);
3976 tmp3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3977 boolean_type_node
, non_zerosized
, tmp3
);
3978 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
3979 "outside of expected range (%%ld:%%ld)",
3980 dim
+ 1, expr_name
);
3981 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
3983 fold_convert (long_integer_type_node
, tmp
),
3984 fold_convert (long_integer_type_node
, ubound
),
3985 fold_convert (long_integer_type_node
, lbound
));
3986 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
3988 fold_convert (long_integer_type_node
, tmp
),
3989 fold_convert (long_integer_type_node
, ubound
),
3990 fold_convert (long_integer_type_node
, lbound
));
3995 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
3996 "below lower bound of %%ld",
3997 dim
+ 1, expr_name
);
3998 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4000 fold_convert (long_integer_type_node
, tmp
),
4001 fold_convert (long_integer_type_node
, lbound
));
4005 /* Check the section sizes match. */
4006 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4007 gfc_array_index_type
, end
,
4009 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
4010 gfc_array_index_type
, tmp
,
4012 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4013 gfc_array_index_type
,
4014 gfc_index_one_node
, tmp
);
4015 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
4016 gfc_array_index_type
, tmp
,
4017 build_int_cst (gfc_array_index_type
, 0));
4018 /* We remember the size of the first section, and check all the
4019 others against this. */
4022 tmp3
= fold_build2_loc (input_location
, NE_EXPR
,
4023 boolean_type_node
, tmp
, size
[n
]);
4024 asprintf (&msg
, "Array bound mismatch for dimension %d "
4025 "of array '%s' (%%ld/%%ld)",
4026 dim
+ 1, expr_name
);
4028 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4030 fold_convert (long_integer_type_node
, tmp
),
4031 fold_convert (long_integer_type_node
, size
[n
]));
4036 size
[n
] = gfc_evaluate_now (tmp
, &inner
);
4039 tmp
= gfc_finish_block (&inner
);
4041 /* For optional arguments, only check bounds if the argument is
4043 if (expr
->symtree
->n
.sym
->attr
.optional
4044 || expr
->symtree
->n
.sym
->attr
.not_always_present
)
4045 tmp
= build3_v (COND_EXPR
,
4046 gfc_conv_expr_present (expr
->symtree
->n
.sym
),
4047 tmp
, build_empty_stmt (input_location
));
4049 gfc_add_expr_to_block (&block
, tmp
);
4053 tmp
= gfc_finish_block (&block
);
4054 gfc_add_expr_to_block (&loop
->pre
, tmp
);
4057 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4058 gfc_conv_ss_startstride (loop
);
4061 /* Return true if both symbols could refer to the same data object. Does
4062 not take account of aliasing due to equivalence statements. */
4065 symbols_could_alias (gfc_symbol
*lsym
, gfc_symbol
*rsym
, bool lsym_pointer
,
4066 bool lsym_target
, bool rsym_pointer
, bool rsym_target
)
4068 /* Aliasing isn't possible if the symbols have different base types. */
4069 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
4072 /* Pointers can point to other pointers and target objects. */
4074 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4075 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4078 /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
4079 and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
4081 if (lsym_target
&& rsym_target
4082 && ((lsym
->attr
.dummy
&& !lsym
->attr
.contiguous
4083 && (!lsym
->attr
.dimension
|| lsym
->as
->type
== AS_ASSUMED_SHAPE
))
4084 || (rsym
->attr
.dummy
&& !rsym
->attr
.contiguous
4085 && (!rsym
->attr
.dimension
4086 || rsym
->as
->type
== AS_ASSUMED_SHAPE
))))
4093 /* Return true if the two SS could be aliased, i.e. both point to the same data
4095 /* TODO: resolve aliases based on frontend expressions. */
4098 gfc_could_be_alias (gfc_ss
* lss
, gfc_ss
* rss
)
4102 gfc_expr
*lexpr
, *rexpr
;
4105 bool lsym_pointer
, lsym_target
, rsym_pointer
, rsym_target
;
4107 lexpr
= lss
->info
->expr
;
4108 rexpr
= rss
->info
->expr
;
4110 lsym
= lexpr
->symtree
->n
.sym
;
4111 rsym
= rexpr
->symtree
->n
.sym
;
4113 lsym_pointer
= lsym
->attr
.pointer
;
4114 lsym_target
= lsym
->attr
.target
;
4115 rsym_pointer
= rsym
->attr
.pointer
;
4116 rsym_target
= rsym
->attr
.target
;
4118 if (symbols_could_alias (lsym
, rsym
, lsym_pointer
, lsym_target
,
4119 rsym_pointer
, rsym_target
))
4122 if (rsym
->ts
.type
!= BT_DERIVED
&& rsym
->ts
.type
!= BT_CLASS
4123 && lsym
->ts
.type
!= BT_DERIVED
&& lsym
->ts
.type
!= BT_CLASS
)
4126 /* For derived types we must check all the component types. We can ignore
4127 array references as these will have the same base type as the previous
4129 for (lref
= lexpr
->ref
; lref
!= lss
->info
->data
.array
.ref
; lref
= lref
->next
)
4131 if (lref
->type
!= REF_COMPONENT
)
4134 lsym_pointer
= lsym_pointer
|| lref
->u
.c
.sym
->attr
.pointer
;
4135 lsym_target
= lsym_target
|| lref
->u
.c
.sym
->attr
.target
;
4137 if (symbols_could_alias (lref
->u
.c
.sym
, rsym
, lsym_pointer
, lsym_target
,
4138 rsym_pointer
, rsym_target
))
4141 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4142 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4144 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4149 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
;
4152 if (rref
->type
!= REF_COMPONENT
)
4155 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4156 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4158 if (symbols_could_alias (lref
->u
.c
.sym
, rref
->u
.c
.sym
,
4159 lsym_pointer
, lsym_target
,
4160 rsym_pointer
, rsym_target
))
4163 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4164 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4166 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4167 &rref
->u
.c
.sym
->ts
))
4169 if (gfc_compare_types (&lref
->u
.c
.sym
->ts
,
4170 &rref
->u
.c
.component
->ts
))
4172 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4173 &rref
->u
.c
.component
->ts
))
4179 lsym_pointer
= lsym
->attr
.pointer
;
4180 lsym_target
= lsym
->attr
.target
;
4181 lsym_pointer
= lsym
->attr
.pointer
;
4182 lsym_target
= lsym
->attr
.target
;
4184 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
; rref
= rref
->next
)
4186 if (rref
->type
!= REF_COMPONENT
)
4189 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4190 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4192 if (symbols_could_alias (rref
->u
.c
.sym
, lsym
,
4193 lsym_pointer
, lsym_target
,
4194 rsym_pointer
, rsym_target
))
4197 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4198 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4200 if (gfc_compare_types (&lsym
->ts
, &rref
->u
.c
.component
->ts
))
4209 /* Resolve array data dependencies. Creates a temporary if required. */
4210 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
4214 gfc_conv_resolve_dependencies (gfc_loopinfo
* loop
, gfc_ss
* dest
,
4220 gfc_expr
*dest_expr
;
4225 loop
->temp_ss
= NULL
;
4226 dest_expr
= dest
->info
->expr
;
4228 for (ss
= rss
; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
4230 if (ss
->info
->type
!= GFC_SS_SECTION
)
4233 ss_expr
= ss
->info
->expr
;
4235 if (dest_expr
->symtree
->n
.sym
!= ss_expr
->symtree
->n
.sym
)
4237 if (gfc_could_be_alias (dest
, ss
)
4238 || gfc_are_equivalenced_arrays (dest_expr
, ss_expr
))
4246 lref
= dest_expr
->ref
;
4247 rref
= ss_expr
->ref
;
4249 nDepend
= gfc_dep_resolver (lref
, rref
, &loop
->reverse
[0]);
4254 for (i
= 0; i
< dest
->dimen
; i
++)
4255 for (j
= 0; j
< ss
->dimen
; j
++)
4257 && dest
->dim
[i
] == ss
->dim
[j
])
4259 /* If we don't access array elements in the same order,
4260 there is a dependency. */
4265 /* TODO : loop shifting. */
4268 /* Mark the dimensions for LOOP SHIFTING */
4269 for (n
= 0; n
< loop
->dimen
; n
++)
4271 int dim
= dest
->data
.info
.dim
[n
];
4273 if (lref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
4275 else if (! gfc_is_same_range (&lref
->u
.ar
,
4276 &rref
->u
.ar
, dim
, 0))
4280 /* Put all the dimensions with dependencies in the
4283 for (n
= 0; n
< loop
->dimen
; n
++)
4285 gcc_assert (loop
->order
[n
] == n
);
4287 loop
->order
[dim
++] = n
;
4289 for (n
= 0; n
< loop
->dimen
; n
++)
4292 loop
->order
[dim
++] = n
;
4295 gcc_assert (dim
== loop
->dimen
);
4306 tree base_type
= gfc_typenode_for_spec (&dest_expr
->ts
);
4307 if (GFC_ARRAY_TYPE_P (base_type
)
4308 || GFC_DESCRIPTOR_TYPE_P (base_type
))
4309 base_type
= gfc_get_element_type (base_type
);
4310 loop
->temp_ss
= gfc_get_temp_ss (base_type
, dest
->info
->string_length
,
4312 gfc_add_ss_to_loop (loop
, loop
->temp_ss
);
4315 loop
->temp_ss
= NULL
;
4319 /* Browse through each array's information from the scalarizer and set the loop
4320 bounds according to the "best" one (per dimension), i.e. the one which
4321 provides the most information (constant bounds, shape, etc). */
4324 set_loop_bounds (gfc_loopinfo
*loop
)
4326 int n
, dim
, spec_dim
;
4327 gfc_array_info
*info
;
4328 gfc_array_info
*specinfo
;
4332 bool dynamic
[GFC_MAX_DIMENSIONS
];
4336 loopspec
= loop
->specloop
;
4339 for (n
= 0; n
< loop
->dimen
; n
++)
4343 /* We use one SS term, and use that to determine the bounds of the
4344 loop for this dimension. We try to pick the simplest term. */
4345 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4347 gfc_ss_type ss_type
;
4349 ss_type
= ss
->info
->type
;
4350 if (ss_type
== GFC_SS_SCALAR
4351 || ss_type
== GFC_SS_TEMP
4352 || ss_type
== GFC_SS_REFERENCE
)
4355 info
= &ss
->info
->data
.array
;
4358 if (loopspec
[n
] != NULL
)
4360 specinfo
= &loopspec
[n
]->info
->data
.array
;
4361 spec_dim
= loopspec
[n
]->dim
[n
];
4365 /* Silence unitialized warnings. */
4372 gcc_assert (info
->shape
[dim
]);
4373 /* The frontend has worked out the size for us. */
4376 || !integer_zerop (specinfo
->start
[spec_dim
]))
4377 /* Prefer zero-based descriptors if possible. */
4382 if (ss_type
== GFC_SS_CONSTRUCTOR
)
4384 gfc_constructor_base base
;
4385 /* An unknown size constructor will always be rank one.
4386 Higher rank constructors will either have known shape,
4387 or still be wrapped in a call to reshape. */
4388 gcc_assert (loop
->dimen
== 1);
4390 /* Always prefer to use the constructor bounds if the size
4391 can be determined at compile time. Prefer not to otherwise,
4392 since the general case involves realloc, and it's better to
4393 avoid that overhead if possible. */
4394 base
= ss
->info
->expr
->value
.constructor
;
4395 dynamic
[n
] = gfc_get_array_constructor_size (&i
, base
);
4396 if (!dynamic
[n
] || !loopspec
[n
])
4401 /* TODO: Pick the best bound if we have a choice between a
4402 function and something else. */
4403 if (ss_type
== GFC_SS_FUNCTION
)
4409 /* Avoid using an allocatable lhs in an assignment, since
4410 there might be a reallocation coming. */
4411 if (loopspec
[n
] && ss
->is_alloc_lhs
)
4414 if (ss_type
!= GFC_SS_SECTION
)
4419 /* Criteria for choosing a loop specifier (most important first):
4420 doesn't need realloc
4426 else if ((loopspec
[n
]->info
->type
== GFC_SS_CONSTRUCTOR
&& dynamic
[n
])
4427 || n
>= loop
->dimen
)
4429 else if (integer_onep (info
->stride
[dim
])
4430 && !integer_onep (specinfo
->stride
[spec_dim
]))
4432 else if (INTEGER_CST_P (info
->stride
[dim
])
4433 && !INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
4435 else if (INTEGER_CST_P (info
->start
[dim
])
4436 && !INTEGER_CST_P (specinfo
->start
[spec_dim
]))
4438 /* We don't work out the upper bound.
4439 else if (INTEGER_CST_P (info->finish[n])
4440 && ! INTEGER_CST_P (specinfo->finish[n]))
4441 loopspec[n] = ss; */
4444 /* We should have found the scalarization loop specifier. If not,
4446 gcc_assert (loopspec
[n
]);
4448 info
= &loopspec
[n
]->info
->data
.array
;
4449 dim
= loopspec
[n
]->dim
[n
];
4451 /* Set the extents of this range. */
4452 cshape
= info
->shape
;
4453 if (cshape
&& INTEGER_CST_P (info
->start
[dim
])
4454 && INTEGER_CST_P (info
->stride
[dim
]))
4456 loop
->from
[n
] = info
->start
[dim
];
4457 mpz_set (i
, cshape
[get_array_ref_dim_for_loop_dim (loopspec
[n
], n
)]);
4458 mpz_sub_ui (i
, i
, 1);
4459 /* To = from + (size - 1) * stride. */
4460 tmp
= gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
4461 if (!integer_onep (info
->stride
[dim
]))
4462 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
4463 gfc_array_index_type
, tmp
,
4465 loop
->to
[n
] = fold_build2_loc (input_location
, PLUS_EXPR
,
4466 gfc_array_index_type
,
4467 loop
->from
[n
], tmp
);
4471 loop
->from
[n
] = info
->start
[dim
];
4472 switch (loopspec
[n
]->info
->type
)
4474 case GFC_SS_CONSTRUCTOR
:
4475 /* The upper bound is calculated when we expand the
4477 gcc_assert (loop
->to
[n
] == NULL_TREE
);
4480 case GFC_SS_SECTION
:
4481 /* Use the end expression if it exists and is not constant,
4482 so that it is only evaluated once. */
4483 loop
->to
[n
] = info
->end
[dim
];
4486 case GFC_SS_FUNCTION
:
4487 /* The loop bound will be set when we generate the call. */
4488 gcc_assert (loop
->to
[n
] == NULL_TREE
);
4496 /* Transform everything so we have a simple incrementing variable. */
4497 if (integer_onep (info
->stride
[dim
]))
4498 info
->delta
[dim
] = gfc_index_zero_node
;
4501 /* Set the delta for this section. */
4502 info
->delta
[dim
] = gfc_evaluate_now (loop
->from
[n
], &loop
->pre
);
4503 /* Number of iterations is (end - start + step) / step.
4504 with start = 0, this simplifies to
4506 for (i = 0; i<=last; i++){...}; */
4507 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4508 gfc_array_index_type
, loop
->to
[n
],
4510 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
4511 gfc_array_index_type
, tmp
, info
->stride
[dim
]);
4512 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
4513 tmp
, build_int_cst (gfc_array_index_type
, -1));
4514 loop
->to
[n
] = gfc_evaluate_now (tmp
, &loop
->pre
);
4515 /* Make the loop variable start at 0. */
4516 loop
->from
[n
] = gfc_index_zero_node
;
4521 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4522 set_loop_bounds (loop
);
4526 /* Initialize the scalarization loop. Creates the loop variables. Determines
4527 the range of the loop variables. Creates a temporary if required.
4528 Also generates code for scalar expressions which have been
4529 moved outside the loop. */
4532 gfc_conv_loop_setup (gfc_loopinfo
* loop
, locus
* where
)
4537 set_loop_bounds (loop
);
4539 /* Add all the scalar code that can be taken out of the loops.
4540 This may include calculating the loop bounds, so do it before
4541 allocating the temporary. */
4542 gfc_add_loop_ss_code (loop
, loop
->ss
, false, where
);
4544 tmp_ss
= loop
->temp_ss
;
4545 /* If we want a temporary then create it. */
4548 gfc_ss_info
*tmp_ss_info
;
4550 tmp_ss_info
= tmp_ss
->info
;
4551 gcc_assert (tmp_ss_info
->type
== GFC_SS_TEMP
);
4552 gcc_assert (loop
->parent
== NULL
);
4554 /* Make absolutely sure that this is a complete type. */
4555 if (tmp_ss_info
->string_length
)
4556 tmp_ss_info
->data
.temp
.type
4557 = gfc_get_character_type_len_for_eltype
4558 (TREE_TYPE (tmp_ss_info
->data
.temp
.type
),
4559 tmp_ss_info
->string_length
);
4561 tmp
= tmp_ss_info
->data
.temp
.type
;
4562 memset (&tmp_ss_info
->data
.array
, 0, sizeof (gfc_array_info
));
4563 tmp_ss_info
->type
= GFC_SS_SECTION
;
4565 gcc_assert (tmp_ss
->dimen
!= 0);
4567 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, tmp_ss
, tmp
,
4568 NULL_TREE
, false, true, false, where
);
4571 /* For array parameters we don't have loop variables, so don't calculate the
4573 if (!loop
->array_parameter
)
4574 gfc_set_delta (loop
);
4578 /* Calculates how to transform from loop variables to array indices for each
4579 array: once loop bounds are chosen, sets the difference (DELTA field) between
4580 loop bounds and array reference bounds, for each array info. */
4583 gfc_set_delta (gfc_loopinfo
*loop
)
4585 gfc_ss
*ss
, **loopspec
;
4586 gfc_array_info
*info
;
4590 loopspec
= loop
->specloop
;
4592 /* Calculate the translation from loop variables to array indices. */
4593 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4595 gfc_ss_type ss_type
;
4597 ss_type
= ss
->info
->type
;
4598 if (ss_type
!= GFC_SS_SECTION
4599 && ss_type
!= GFC_SS_COMPONENT
4600 && ss_type
!= GFC_SS_CONSTRUCTOR
)
4603 info
= &ss
->info
->data
.array
;
4605 for (n
= 0; n
< ss
->dimen
; n
++)
4607 /* If we are specifying the range the delta is already set. */
4608 if (loopspec
[n
] != ss
)
4612 /* Calculate the offset relative to the loop variable.
4613 First multiply by the stride. */
4614 tmp
= loop
->from
[n
];
4615 if (!integer_onep (info
->stride
[dim
]))
4616 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
4617 gfc_array_index_type
,
4618 tmp
, info
->stride
[dim
]);
4620 /* Then subtract this from our starting value. */
4621 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4622 gfc_array_index_type
,
4623 info
->start
[dim
], tmp
);
4625 info
->delta
[dim
] = gfc_evaluate_now (tmp
, &loop
->pre
);
4630 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4631 gfc_set_delta (loop
);
4635 /* Calculate the size of a given array dimension from the bounds. This
4636 is simply (ubound - lbound + 1) if this expression is positive
4637 or 0 if it is negative (pick either one if it is zero). Optionally
4638 (if or_expr is present) OR the (expression != 0) condition to it. */
4641 gfc_conv_array_extent_dim (tree lbound
, tree ubound
, tree
* or_expr
)
4646 /* Calculate (ubound - lbound + 1). */
4647 res
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4649 res
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
, res
,
4650 gfc_index_one_node
);
4652 /* Check whether the size for this dimension is negative. */
4653 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, res
,
4654 gfc_index_zero_node
);
4655 res
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
, cond
,
4656 gfc_index_zero_node
, res
);
4658 /* Build OR expression. */
4660 *or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
4661 boolean_type_node
, *or_expr
, cond
);
4667 /* For an array descriptor, get the total number of elements. This is just
4668 the product of the extents along from_dim to to_dim. */
4671 gfc_conv_descriptor_size_1 (tree desc
, int from_dim
, int to_dim
)
4676 res
= gfc_index_one_node
;
4678 for (dim
= from_dim
; dim
< to_dim
; ++dim
)
4684 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]);
4685 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]);
4687 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
4688 res
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4696 /* Full size of an array. */
4699 gfc_conv_descriptor_size (tree desc
, int rank
)
4701 return gfc_conv_descriptor_size_1 (desc
, 0, rank
);
4705 /* Size of a coarray for all dimensions but the last. */
4708 gfc_conv_descriptor_cosize (tree desc
, int rank
, int corank
)
4710 return gfc_conv_descriptor_size_1 (desc
, rank
, rank
+ corank
- 1);
4714 /* Fills in an array descriptor, and returns the size of the array.
4715 The size will be a simple_val, ie a variable or a constant. Also
4716 calculates the offset of the base. The pointer argument overflow,
4717 which should be of integer type, will increase in value if overflow
4718 occurs during the size calculation. Returns the size of the array.
4722 for (n = 0; n < rank; n++)
4724 a.lbound[n] = specified_lower_bound;
4725 offset = offset + a.lbond[n] * stride;
4727 a.ubound[n] = specified_upper_bound;
4728 a.stride[n] = stride;
4729 size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
4730 overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
4731 stride = stride * size;
4733 for (n = rank; n < rank+corank; n++)
4734 (Set lcobound/ucobound as above.)
4735 element_size = sizeof (array element);
4738 stride = (size_t) stride;
4739 overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
4740 stride = stride * element_size;
4746 gfc_array_init_size (tree descriptor
, int rank
, int corank
, tree
* poffset
,
4747 gfc_expr
** lower
, gfc_expr
** upper
, stmtblock_t
* pblock
,
4748 stmtblock_t
* descriptor_block
, tree
* overflow
,
4749 tree expr3_elem_size
, tree
*nelems
, gfc_expr
*expr3
)
4762 stmtblock_t thenblock
;
4763 stmtblock_t elseblock
;
4768 type
= TREE_TYPE (descriptor
);
4770 stride
= gfc_index_one_node
;
4771 offset
= gfc_index_zero_node
;
4773 /* Set the dtype. */
4774 tmp
= gfc_conv_descriptor_dtype (descriptor
);
4775 gfc_add_modify (descriptor_block
, tmp
, gfc_get_dtype (TREE_TYPE (descriptor
)));
4777 or_expr
= boolean_false_node
;
4779 for (n
= 0; n
< rank
; n
++)
4784 /* We have 3 possibilities for determining the size of the array:
4785 lower == NULL => lbound = 1, ubound = upper[n]
4786 upper[n] = NULL => lbound = 1, ubound = lower[n]
4787 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
4790 /* Set lower bound. */
4791 gfc_init_se (&se
, NULL
);
4793 se
.expr
= gfc_index_one_node
;
4796 gcc_assert (lower
[n
]);
4799 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
4800 gfc_add_block_to_block (pblock
, &se
.pre
);
4804 se
.expr
= gfc_index_one_node
;
4808 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
4809 gfc_rank_cst
[n
], se
.expr
);
4810 conv_lbound
= se
.expr
;
4812 /* Work out the offset for this component. */
4813 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4815 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
4816 gfc_array_index_type
, offset
, tmp
);
4818 /* Set upper bound. */
4819 gfc_init_se (&se
, NULL
);
4820 gcc_assert (ubound
);
4821 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
4822 gfc_add_block_to_block (pblock
, &se
.pre
);
4824 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
4825 gfc_rank_cst
[n
], se
.expr
);
4826 conv_ubound
= se
.expr
;
4828 /* Store the stride. */
4829 gfc_conv_descriptor_stride_set (descriptor_block
, descriptor
,
4830 gfc_rank_cst
[n
], stride
);
4832 /* Calculate size and check whether extent is negative. */
4833 size
= gfc_conv_array_extent_dim (conv_lbound
, conv_ubound
, &or_expr
);
4834 size
= gfc_evaluate_now (size
, pblock
);
4836 /* Check whether multiplying the stride by the number of
4837 elements in this dimension would overflow. We must also check
4838 whether the current dimension has zero size in order to avoid
4841 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
4842 gfc_array_index_type
,
4843 fold_convert (gfc_array_index_type
,
4844 TYPE_MAX_VALUE (gfc_array_index_type
)),
4846 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
4847 boolean_type_node
, tmp
, stride
));
4848 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
4849 integer_one_node
, integer_zero_node
);
4850 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
4851 boolean_type_node
, size
,
4852 gfc_index_zero_node
));
4853 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
4854 integer_zero_node
, tmp
);
4855 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
4857 *overflow
= gfc_evaluate_now (tmp
, pblock
);
4859 /* Multiply the stride by the number of elements in this dimension. */
4860 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
4861 gfc_array_index_type
, stride
, size
);
4862 stride
= gfc_evaluate_now (stride
, pblock
);
4865 for (n
= rank
; n
< rank
+ corank
; n
++)
4869 /* Set lower bound. */
4870 gfc_init_se (&se
, NULL
);
4871 if (lower
== NULL
|| lower
[n
] == NULL
)
4873 gcc_assert (n
== rank
+ corank
- 1);
4874 se
.expr
= gfc_index_one_node
;
4878 if (ubound
|| n
== rank
+ corank
- 1)
4880 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
4881 gfc_add_block_to_block (pblock
, &se
.pre
);
4885 se
.expr
= gfc_index_one_node
;
4889 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
4890 gfc_rank_cst
[n
], se
.expr
);
4892 if (n
< rank
+ corank
- 1)
4894 gfc_init_se (&se
, NULL
);
4895 gcc_assert (ubound
);
4896 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
4897 gfc_add_block_to_block (pblock
, &se
.pre
);
4898 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
4899 gfc_rank_cst
[n
], se
.expr
);
4903 /* The stride is the number of elements in the array, so multiply by the
4904 size of an element to get the total size. Obviously, if there ia a
4905 SOURCE expression (expr3) we must use its element size. */
4906 if (expr3_elem_size
!= NULL_TREE
)
4907 tmp
= expr3_elem_size
;
4908 else if (expr3
!= NULL
)
4910 if (expr3
->ts
.type
== BT_CLASS
)
4913 gfc_expr
*sz
= gfc_copy_expr (expr3
);
4914 gfc_add_vptr_component (sz
);
4915 gfc_add_size_component (sz
);
4916 gfc_init_se (&se_sz
, NULL
);
4917 gfc_conv_expr (&se_sz
, sz
);
4923 tmp
= gfc_typenode_for_spec (&expr3
->ts
);
4924 tmp
= TYPE_SIZE_UNIT (tmp
);
4928 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
4930 /* Convert to size_t. */
4931 element_size
= fold_convert (size_type_node
, tmp
);
4934 return element_size
;
4936 *nelems
= gfc_evaluate_now (stride
, pblock
);
4937 stride
= fold_convert (size_type_node
, stride
);
4939 /* First check for overflow. Since an array of type character can
4940 have zero element_size, we must check for that before
4942 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
4944 TYPE_MAX_VALUE (size_type_node
), element_size
);
4945 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
4946 boolean_type_node
, tmp
, stride
));
4947 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
4948 integer_one_node
, integer_zero_node
);
4949 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
4950 boolean_type_node
, element_size
,
4951 build_int_cst (size_type_node
, 0)));
4952 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
4953 integer_zero_node
, tmp
);
4954 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
4956 *overflow
= gfc_evaluate_now (tmp
, pblock
);
4958 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
4959 stride
, element_size
);
4961 if (poffset
!= NULL
)
4963 offset
= gfc_evaluate_now (offset
, pblock
);
4967 if (integer_zerop (or_expr
))
4969 if (integer_onep (or_expr
))
4970 return build_int_cst (size_type_node
, 0);
4972 var
= gfc_create_var (TREE_TYPE (size
), "size");
4973 gfc_start_block (&thenblock
);
4974 gfc_add_modify (&thenblock
, var
, build_int_cst (size_type_node
, 0));
4975 thencase
= gfc_finish_block (&thenblock
);
4977 gfc_start_block (&elseblock
);
4978 gfc_add_modify (&elseblock
, var
, size
);
4979 elsecase
= gfc_finish_block (&elseblock
);
4981 tmp
= gfc_evaluate_now (or_expr
, pblock
);
4982 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
4983 gfc_add_expr_to_block (pblock
, tmp
);
4989 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
4990 the work for an ALLOCATE statement. */
4994 gfc_array_allocate (gfc_se
* se
, gfc_expr
* expr
, tree status
, tree errmsg
,
4995 tree errlen
, tree label_finish
, tree expr3_elem_size
,
4996 tree
*nelems
, gfc_expr
*expr3
)
5000 tree offset
= NULL_TREE
;
5001 tree token
= NULL_TREE
;
5004 tree error
= NULL_TREE
;
5005 tree overflow
; /* Boolean storing whether size calculation overflows. */
5006 tree var_overflow
= NULL_TREE
;
5008 tree set_descriptor
;
5009 stmtblock_t set_descriptor_block
;
5010 stmtblock_t elseblock
;
5013 gfc_ref
*ref
, *prev_ref
= NULL
;
5014 bool allocatable
, coarray
, dimension
;
5018 /* Find the last reference in the chain. */
5019 while (ref
&& ref
->next
!= NULL
)
5021 gcc_assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
5022 || (ref
->u
.ar
.dimen
== 0 && ref
->u
.ar
.codimen
> 0));
5027 if (ref
== NULL
|| ref
->type
!= REF_ARRAY
)
5032 allocatable
= expr
->symtree
->n
.sym
->attr
.allocatable
;
5033 coarray
= expr
->symtree
->n
.sym
->attr
.codimension
;
5034 dimension
= expr
->symtree
->n
.sym
->attr
.dimension
;
5038 allocatable
= prev_ref
->u
.c
.component
->attr
.allocatable
;
5039 coarray
= prev_ref
->u
.c
.component
->attr
.codimension
;
5040 dimension
= prev_ref
->u
.c
.component
->attr
.dimension
;
5044 gcc_assert (coarray
);
5046 /* Figure out the size of the array. */
5047 switch (ref
->u
.ar
.type
)
5053 upper
= ref
->u
.ar
.start
;
5059 lower
= ref
->u
.ar
.start
;
5060 upper
= ref
->u
.ar
.end
;
5064 gcc_assert (ref
->u
.ar
.as
->type
== AS_EXPLICIT
);
5066 lower
= ref
->u
.ar
.as
->lower
;
5067 upper
= ref
->u
.ar
.as
->upper
;
5075 overflow
= integer_zero_node
;
5077 gfc_init_block (&set_descriptor_block
);
5078 size
= gfc_array_init_size (se
->expr
, ref
->u
.ar
.as
->rank
,
5079 ref
->u
.ar
.as
->corank
, &offset
, lower
, upper
,
5080 &se
->pre
, &set_descriptor_block
, &overflow
,
5081 expr3_elem_size
, nelems
, expr3
);
5086 var_overflow
= gfc_create_var (integer_type_node
, "overflow");
5087 gfc_add_modify (&se
->pre
, var_overflow
, overflow
);
5089 /* Generate the block of code handling overflow. */
5090 msg
= gfc_build_addr_expr (pchar_type_node
,
5091 gfc_build_localized_cstring_const
5092 ("Integer overflow when calculating the amount of "
5093 "memory to allocate"));
5094 error
= build_call_expr_loc (input_location
, gfor_fndecl_runtime_error
,
5098 if (status
!= NULL_TREE
)
5100 tree status_type
= TREE_TYPE (status
);
5101 stmtblock_t set_status_block
;
5103 gfc_start_block (&set_status_block
);
5104 gfc_add_modify (&set_status_block
, status
,
5105 build_int_cst (status_type
, LIBERROR_ALLOCATION
));
5106 error
= gfc_finish_block (&set_status_block
);
5109 gfc_start_block (&elseblock
);
5111 /* Allocate memory to store the data. */
5112 if (POINTER_TYPE_P (TREE_TYPE (se
->expr
)))
5113 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
5115 pointer
= gfc_conv_descriptor_data_get (se
->expr
);
5116 STRIP_NOPS (pointer
);
5118 if (coarray
&& gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
5119 token
= gfc_build_addr_expr (NULL_TREE
,
5120 gfc_conv_descriptor_token (se
->expr
));
5122 /* The allocatable variant takes the old pointer as first argument. */
5124 gfc_allocate_allocatable (&elseblock
, pointer
, size
, token
,
5125 status
, errmsg
, errlen
, label_finish
, expr
);
5127 gfc_allocate_using_malloc (&elseblock
, pointer
, size
, status
);
5131 cond
= gfc_unlikely (fold_build2_loc (input_location
, NE_EXPR
,
5132 boolean_type_node
, var_overflow
, integer_zero_node
));
5133 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
5134 error
, gfc_finish_block (&elseblock
));
5137 tmp
= gfc_finish_block (&elseblock
);
5139 gfc_add_expr_to_block (&se
->pre
, tmp
);
5141 if (expr
->ts
.type
== BT_CLASS
)
5143 tmp
= build_int_cst (unsigned_char_type_node
, 0);
5144 /* With class objects, it is best to play safe and null the
5145 memory because we cannot know if dynamic types have allocatable
5146 components or not. */
5147 tmp
= build_call_expr_loc (input_location
,
5148 builtin_decl_explicit (BUILT_IN_MEMSET
),
5149 3, pointer
, tmp
, size
);
5150 gfc_add_expr_to_block (&se
->pre
, tmp
);
5153 /* Update the array descriptors. */
5155 gfc_conv_descriptor_offset_set (&set_descriptor_block
, se
->expr
, offset
);
5157 set_descriptor
= gfc_finish_block (&set_descriptor_block
);
5158 if (status
!= NULL_TREE
)
5160 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
5161 boolean_type_node
, status
,
5162 build_int_cst (TREE_TYPE (status
), 0));
5163 gfc_add_expr_to_block (&se
->pre
,
5164 fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5165 gfc_likely (cond
), set_descriptor
,
5166 build_empty_stmt (input_location
)));
5169 gfc_add_expr_to_block (&se
->pre
, set_descriptor
);
5171 if ((expr
->ts
.type
== BT_DERIVED
)
5172 && expr
->ts
.u
.derived
->attr
.alloc_comp
)
5174 tmp
= gfc_nullify_alloc_comp (expr
->ts
.u
.derived
, se
->expr
,
5175 ref
->u
.ar
.as
->rank
);
5176 gfc_add_expr_to_block (&se
->pre
, tmp
);
5183 /* Deallocate an array variable. Also used when an allocated variable goes
5188 gfc_array_deallocate (tree descriptor
, tree pstat
, tree errmsg
, tree errlen
,
5189 tree label_finish
, gfc_expr
* expr
)
5194 bool coarray
= gfc_is_coarray (expr
);
5196 gfc_start_block (&block
);
5198 /* Get a pointer to the data. */
5199 var
= gfc_conv_descriptor_data_get (descriptor
);
5202 /* Parameter is the address of the data component. */
5203 tmp
= gfc_deallocate_with_status (coarray
? descriptor
: var
, pstat
, errmsg
,
5204 errlen
, label_finish
, false, expr
, coarray
);
5205 gfc_add_expr_to_block (&block
, tmp
);
5207 /* Zero the data pointer; only for coarrays an error can occur and then
5208 the allocation status may not be changed. */
5209 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
5210 var
, build_int_cst (TREE_TYPE (var
), 0));
5211 if (pstat
!= NULL_TREE
&& coarray
&& gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
5214 tree stat
= build_fold_indirect_ref_loc (input_location
, pstat
);
5216 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5217 stat
, build_int_cst (TREE_TYPE (stat
), 0));
5218 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5219 cond
, tmp
, build_empty_stmt (input_location
));
5222 gfc_add_expr_to_block (&block
, tmp
);
5224 return gfc_finish_block (&block
);
5228 /* Create an array constructor from an initialization expression.
5229 We assume the frontend already did any expansions and conversions. */
5232 gfc_conv_array_initializer (tree type
, gfc_expr
* expr
)
5238 unsigned HOST_WIDE_INT lo
;
5240 VEC(constructor_elt
,gc
) *v
= NULL
;
5242 if (expr
->expr_type
== EXPR_VARIABLE
5243 && expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
5244 && expr
->symtree
->n
.sym
->value
)
5245 expr
= expr
->symtree
->n
.sym
->value
;
5247 switch (expr
->expr_type
)
5250 case EXPR_STRUCTURE
:
5251 /* A single scalar or derived type value. Create an array with all
5252 elements equal to that value. */
5253 gfc_init_se (&se
, NULL
);
5255 if (expr
->expr_type
== EXPR_CONSTANT
)
5256 gfc_conv_constant (&se
, expr
);
5258 gfc_conv_structure (&se
, expr
, 1);
5260 tmp
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
5261 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
5262 hi
= TREE_INT_CST_HIGH (tmp
);
5263 lo
= TREE_INT_CST_LOW (tmp
);
5267 /* This will probably eat buckets of memory for large arrays. */
5268 while (hi
!= 0 || lo
!= 0)
5270 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
, se
.expr
);
5278 /* Create a vector of all the elements. */
5279 for (c
= gfc_constructor_first (expr
->value
.constructor
);
5280 c
; c
= gfc_constructor_next (c
))
5284 /* Problems occur when we get something like
5285 integer :: a(lots) = (/(i, i=1, lots)/) */
5286 gfc_fatal_error ("The number of elements in the array constructor "
5287 "at %L requires an increase of the allowed %d "
5288 "upper limit. See -fmax-array-constructor "
5289 "option", &expr
->where
,
5290 gfc_option
.flag_max_array_constructor
);
5293 if (mpz_cmp_si (c
->offset
, 0) != 0)
5294 index
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
5298 if (mpz_cmp_si (c
->repeat
, 1) > 0)
5304 mpz_add (maxval
, c
->offset
, c
->repeat
);
5305 mpz_sub_ui (maxval
, maxval
, 1);
5306 tmp2
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
5307 if (mpz_cmp_si (c
->offset
, 0) != 0)
5309 mpz_add_ui (maxval
, c
->offset
, 1);
5310 tmp1
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
5313 tmp1
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
5315 range
= fold_build2 (RANGE_EXPR
, gfc_array_index_type
, tmp1
, tmp2
);
5321 gfc_init_se (&se
, NULL
);
5322 switch (c
->expr
->expr_type
)
5325 gfc_conv_constant (&se
, c
->expr
);
5328 case EXPR_STRUCTURE
:
5329 gfc_conv_structure (&se
, c
->expr
, 1);
5333 /* Catch those occasional beasts that do not simplify
5334 for one reason or another, assuming that if they are
5335 standard defying the frontend will catch them. */
5336 gfc_conv_expr (&se
, c
->expr
);
5340 if (range
== NULL_TREE
)
5341 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
5344 if (index
!= NULL_TREE
)
5345 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
5346 CONSTRUCTOR_APPEND_ELT (v
, range
, se
.expr
);
5352 return gfc_build_null_descriptor (type
);
5358 /* Create a constructor from the list of elements. */
5359 tmp
= build_constructor (type
, v
);
5360 TREE_CONSTANT (tmp
) = 1;
5365 /* Generate code to evaluate non-constant coarray cobounds. */
5368 gfc_trans_array_cobounds (tree type
, stmtblock_t
* pblock
,
5369 const gfc_symbol
*sym
)
5379 for (dim
= as
->rank
; dim
< as
->rank
+ as
->corank
; dim
++)
5381 /* Evaluate non-constant array bound expressions. */
5382 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
5383 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
5385 gfc_init_se (&se
, NULL
);
5386 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
5387 gfc_add_block_to_block (pblock
, &se
.pre
);
5388 gfc_add_modify (pblock
, lbound
, se
.expr
);
5390 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
5391 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
5393 gfc_init_se (&se
, NULL
);
5394 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
5395 gfc_add_block_to_block (pblock
, &se
.pre
);
5396 gfc_add_modify (pblock
, ubound
, se
.expr
);
5402 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
5403 returns the size (in elements) of the array. */
5406 gfc_trans_array_bounds (tree type
, gfc_symbol
* sym
, tree
* poffset
,
5407 stmtblock_t
* pblock
)
5422 size
= gfc_index_one_node
;
5423 offset
= gfc_index_zero_node
;
5424 for (dim
= 0; dim
< as
->rank
; dim
++)
5426 /* Evaluate non-constant array bound expressions. */
5427 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
5428 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
5430 gfc_init_se (&se
, NULL
);
5431 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
5432 gfc_add_block_to_block (pblock
, &se
.pre
);
5433 gfc_add_modify (pblock
, lbound
, se
.expr
);
5435 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
5436 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
5438 gfc_init_se (&se
, NULL
);
5439 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
5440 gfc_add_block_to_block (pblock
, &se
.pre
);
5441 gfc_add_modify (pblock
, ubound
, se
.expr
);
5443 /* The offset of this dimension. offset = offset - lbound * stride. */
5444 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5446 offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5449 /* The size of this dimension, and the stride of the next. */
5450 if (dim
+ 1 < as
->rank
)
5451 stride
= GFC_TYPE_ARRAY_STRIDE (type
, dim
+ 1);
5453 stride
= GFC_TYPE_ARRAY_SIZE (type
);
5455 if (ubound
!= NULL_TREE
&& !(stride
&& INTEGER_CST_P (stride
)))
5457 /* Calculate stride = size * (ubound + 1 - lbound). */
5458 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5459 gfc_array_index_type
,
5460 gfc_index_one_node
, lbound
);
5461 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5462 gfc_array_index_type
, ubound
, tmp
);
5463 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5464 gfc_array_index_type
, size
, tmp
);
5466 gfc_add_modify (pblock
, stride
, tmp
);
5468 stride
= gfc_evaluate_now (tmp
, pblock
);
5470 /* Make sure that negative size arrays are translated
5471 to being zero size. */
5472 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
5473 stride
, gfc_index_zero_node
);
5474 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5475 gfc_array_index_type
, tmp
,
5476 stride
, gfc_index_zero_node
);
5477 gfc_add_modify (pblock
, stride
, tmp
);
5483 gfc_trans_array_cobounds (type
, pblock
, sym
);
5484 gfc_trans_vla_type_sizes (sym
, pblock
);
5491 /* Generate code to initialize/allocate an array variable. */
5494 gfc_trans_auto_array_allocation (tree decl
, gfc_symbol
* sym
,
5495 gfc_wrapped_block
* block
)
5499 tree tmp
= NULL_TREE
;
5506 gcc_assert (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
));
5508 /* Do nothing for USEd variables. */
5509 if (sym
->attr
.use_assoc
)
5512 type
= TREE_TYPE (decl
);
5513 gcc_assert (GFC_ARRAY_TYPE_P (type
));
5514 onstack
= TREE_CODE (type
) != POINTER_TYPE
;
5516 gfc_init_block (&init
);
5518 /* Evaluate character string length. */
5519 if (sym
->ts
.type
== BT_CHARACTER
5520 && onstack
&& !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
5522 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
5524 gfc_trans_vla_type_sizes (sym
, &init
);
5526 /* Emit a DECL_EXPR for this variable, which will cause the
5527 gimplifier to allocate storage, and all that good stuff. */
5528 tmp
= fold_build1_loc (input_location
, DECL_EXPR
, TREE_TYPE (decl
), decl
);
5529 gfc_add_expr_to_block (&init
, tmp
);
5534 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
5538 type
= TREE_TYPE (type
);
5540 gcc_assert (!sym
->attr
.use_assoc
);
5541 gcc_assert (!TREE_STATIC (decl
));
5542 gcc_assert (!sym
->module
);
5544 if (sym
->ts
.type
== BT_CHARACTER
5545 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
5546 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
5548 size
= gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
5550 /* Don't actually allocate space for Cray Pointees. */
5551 if (sym
->attr
.cray_pointee
)
5553 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
5554 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
5556 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
5560 if (gfc_option
.flag_stack_arrays
)
5562 gcc_assert (TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
);
5563 space
= build_decl (sym
->declared_at
.lb
->location
,
5564 VAR_DECL
, create_tmp_var_name ("A"),
5565 TREE_TYPE (TREE_TYPE (decl
)));
5566 gfc_trans_vla_type_sizes (sym
, &init
);
5570 /* The size is the number of elements in the array, so multiply by the
5571 size of an element to get the total size. */
5572 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
5573 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5574 size
, fold_convert (gfc_array_index_type
, tmp
));
5576 /* Allocate memory to hold the data. */
5577 tmp
= gfc_call_malloc (&init
, TREE_TYPE (decl
), size
);
5578 gfc_add_modify (&init
, decl
, tmp
);
5580 /* Free the temporary. */
5581 tmp
= gfc_call_free (convert (pvoid_type_node
, decl
));
5585 /* Set offset of the array. */
5586 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
5587 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
5589 /* Automatic arrays should not have initializers. */
5590 gcc_assert (!sym
->value
);
5592 inittree
= gfc_finish_block (&init
);
5599 /* Don't create new scope, emit the DECL_EXPR in exactly the scope
5600 where also space is located. */
5601 gfc_init_block (&init
);
5602 tmp
= fold_build1_loc (input_location
, DECL_EXPR
,
5603 TREE_TYPE (space
), space
);
5604 gfc_add_expr_to_block (&init
, tmp
);
5605 addr
= fold_build1_loc (sym
->declared_at
.lb
->location
,
5606 ADDR_EXPR
, TREE_TYPE (decl
), space
);
5607 gfc_add_modify (&init
, decl
, addr
);
5608 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
5611 gfc_add_init_cleanup (block
, inittree
, tmp
);
5615 /* Generate entry and exit code for g77 calling convention arrays. */
5618 gfc_trans_g77_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
5628 gfc_save_backend_locus (&loc
);
5629 gfc_set_backend_locus (&sym
->declared_at
);
5631 /* Descriptor type. */
5632 parm
= sym
->backend_decl
;
5633 type
= TREE_TYPE (parm
);
5634 gcc_assert (GFC_ARRAY_TYPE_P (type
));
5636 gfc_start_block (&init
);
5638 if (sym
->ts
.type
== BT_CHARACTER
5639 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
5640 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
5642 /* Evaluate the bounds of the array. */
5643 gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
5645 /* Set the offset. */
5646 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
5647 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
5649 /* Set the pointer itself if we aren't using the parameter directly. */
5650 if (TREE_CODE (parm
) != PARM_DECL
)
5652 tmp
= convert (TREE_TYPE (parm
), GFC_DECL_SAVED_DESCRIPTOR (parm
));
5653 gfc_add_modify (&init
, parm
, tmp
);
5655 stmt
= gfc_finish_block (&init
);
5657 gfc_restore_backend_locus (&loc
);
5659 /* Add the initialization code to the start of the function. */
5661 if (sym
->attr
.optional
|| sym
->attr
.not_always_present
)
5663 tmp
= gfc_conv_expr_present (sym
);
5664 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
5667 gfc_add_init_cleanup (block
, stmt
, NULL_TREE
);
5671 /* Modify the descriptor of an array parameter so that it has the
5672 correct lower bound. Also move the upper bound accordingly.
5673 If the array is not packed, it will be copied into a temporary.
5674 For each dimension we set the new lower and upper bounds. Then we copy the
5675 stride and calculate the offset for this dimension. We also work out
5676 what the stride of a packed array would be, and see it the two match.
5677 If the array need repacking, we set the stride to the values we just
5678 calculated, recalculate the offset and copy the array data.
5679 Code is also added to copy the data back at the end of the function.
5683 gfc_trans_dummy_array_bias (gfc_symbol
* sym
, tree tmpdesc
,
5684 gfc_wrapped_block
* block
)
5691 tree stmtInit
, stmtCleanup
;
5698 tree stride
, stride2
;
5708 /* Do nothing for pointer and allocatable arrays. */
5709 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
5712 if (sym
->attr
.dummy
&& gfc_is_nodesc_array (sym
))
5714 gfc_trans_g77_array (sym
, block
);
5718 gfc_save_backend_locus (&loc
);
5719 gfc_set_backend_locus (&sym
->declared_at
);
5721 /* Descriptor type. */
5722 type
= TREE_TYPE (tmpdesc
);
5723 gcc_assert (GFC_ARRAY_TYPE_P (type
));
5724 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
5725 dumdesc
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
5726 gfc_start_block (&init
);
5728 if (sym
->ts
.type
== BT_CHARACTER
5729 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
5730 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
5732 checkparm
= (sym
->as
->type
== AS_EXPLICIT
5733 && (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
));
5735 no_repack
= !(GFC_DECL_PACKED_ARRAY (tmpdesc
)
5736 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
));
5738 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
))
5740 /* For non-constant shape arrays we only check if the first dimension
5741 is contiguous. Repacking higher dimensions wouldn't gain us
5742 anything as we still don't know the array stride. */
5743 partial
= gfc_create_var (boolean_type_node
, "partial");
5744 TREE_USED (partial
) = 1;
5745 tmp
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
5746 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, tmp
,
5747 gfc_index_one_node
);
5748 gfc_add_modify (&init
, partial
, tmp
);
5751 partial
= NULL_TREE
;
5753 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
5754 here, however I think it does the right thing. */
5757 /* Set the first stride. */
5758 stride
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
5759 stride
= gfc_evaluate_now (stride
, &init
);
5761 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5762 stride
, gfc_index_zero_node
);
5763 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
5764 tmp
, gfc_index_one_node
, stride
);
5765 stride
= GFC_TYPE_ARRAY_STRIDE (type
, 0);
5766 gfc_add_modify (&init
, stride
, tmp
);
5768 /* Allow the user to disable array repacking. */
5769 stmt_unpacked
= NULL_TREE
;
5773 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type
, 0)));
5774 /* A library call to repack the array if necessary. */
5775 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
5776 stmt_unpacked
= build_call_expr_loc (input_location
,
5777 gfor_fndecl_in_pack
, 1, tmp
);
5779 stride
= gfc_index_one_node
;
5781 if (gfc_option
.warn_array_temp
)
5782 gfc_warning ("Creating array temporary at %L", &loc
);
5785 /* This is for the case where the array data is used directly without
5786 calling the repack function. */
5787 if (no_repack
|| partial
!= NULL_TREE
)
5788 stmt_packed
= gfc_conv_descriptor_data_get (dumdesc
);
5790 stmt_packed
= NULL_TREE
;
5792 /* Assign the data pointer. */
5793 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
5795 /* Don't repack unknown shape arrays when the first stride is 1. */
5796 tmp
= fold_build3_loc (input_location
, COND_EXPR
, TREE_TYPE (stmt_packed
),
5797 partial
, stmt_packed
, stmt_unpacked
);
5800 tmp
= stmt_packed
!= NULL_TREE
? stmt_packed
: stmt_unpacked
;
5801 gfc_add_modify (&init
, tmpdesc
, fold_convert (type
, tmp
));
5803 offset
= gfc_index_zero_node
;
5804 size
= gfc_index_one_node
;
5806 /* Evaluate the bounds of the array. */
5807 for (n
= 0; n
< sym
->as
->rank
; n
++)
5809 if (checkparm
|| !sym
->as
->upper
[n
])
5811 /* Get the bounds of the actual parameter. */
5812 dubound
= gfc_conv_descriptor_ubound_get (dumdesc
, gfc_rank_cst
[n
]);
5813 dlbound
= gfc_conv_descriptor_lbound_get (dumdesc
, gfc_rank_cst
[n
]);
5817 dubound
= NULL_TREE
;
5818 dlbound
= NULL_TREE
;
5821 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, n
);
5822 if (!INTEGER_CST_P (lbound
))
5824 gfc_init_se (&se
, NULL
);
5825 gfc_conv_expr_type (&se
, sym
->as
->lower
[n
],
5826 gfc_array_index_type
);
5827 gfc_add_block_to_block (&init
, &se
.pre
);
5828 gfc_add_modify (&init
, lbound
, se
.expr
);
5831 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, n
);
5832 /* Set the desired upper bound. */
5833 if (sym
->as
->upper
[n
])
5835 /* We know what we want the upper bound to be. */
5836 if (!INTEGER_CST_P (ubound
))
5838 gfc_init_se (&se
, NULL
);
5839 gfc_conv_expr_type (&se
, sym
->as
->upper
[n
],
5840 gfc_array_index_type
);
5841 gfc_add_block_to_block (&init
, &se
.pre
);
5842 gfc_add_modify (&init
, ubound
, se
.expr
);
5845 /* Check the sizes match. */
5848 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
5852 temp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5853 gfc_array_index_type
, ubound
, lbound
);
5854 temp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5855 gfc_array_index_type
,
5856 gfc_index_one_node
, temp
);
5857 stride2
= fold_build2_loc (input_location
, MINUS_EXPR
,
5858 gfc_array_index_type
, dubound
,
5860 stride2
= fold_build2_loc (input_location
, PLUS_EXPR
,
5861 gfc_array_index_type
,
5862 gfc_index_one_node
, stride2
);
5863 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
5864 gfc_array_index_type
, temp
, stride2
);
5865 asprintf (&msg
, "Dimension %d of array '%s' has extent "
5866 "%%ld instead of %%ld", n
+1, sym
->name
);
5868 gfc_trans_runtime_check (true, false, tmp
, &init
, &loc
, msg
,
5869 fold_convert (long_integer_type_node
, temp
),
5870 fold_convert (long_integer_type_node
, stride2
));
5877 /* For assumed shape arrays move the upper bound by the same amount
5878 as the lower bound. */
5879 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5880 gfc_array_index_type
, dubound
, dlbound
);
5881 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5882 gfc_array_index_type
, tmp
, lbound
);
5883 gfc_add_modify (&init
, ubound
, tmp
);
5885 /* The offset of this dimension. offset = offset - lbound * stride. */
5886 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5888 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
5889 gfc_array_index_type
, offset
, tmp
);
5891 /* The size of this dimension, and the stride of the next. */
5892 if (n
+ 1 < sym
->as
->rank
)
5894 stride
= GFC_TYPE_ARRAY_STRIDE (type
, n
+ 1);
5896 if (no_repack
|| partial
!= NULL_TREE
)
5898 gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[n
+1]);
5900 /* Figure out the stride if not a known constant. */
5901 if (!INTEGER_CST_P (stride
))
5904 stmt_packed
= NULL_TREE
;
5907 /* Calculate stride = size * (ubound + 1 - lbound). */
5908 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5909 gfc_array_index_type
,
5910 gfc_index_one_node
, lbound
);
5911 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5912 gfc_array_index_type
, ubound
, tmp
);
5913 size
= fold_build2_loc (input_location
, MULT_EXPR
,
5914 gfc_array_index_type
, size
, tmp
);
5918 /* Assign the stride. */
5919 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
5920 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5921 gfc_array_index_type
, partial
,
5922 stmt_unpacked
, stmt_packed
);
5924 tmp
= (stmt_packed
!= NULL_TREE
) ? stmt_packed
: stmt_unpacked
;
5925 gfc_add_modify (&init
, stride
, tmp
);
5930 stride
= GFC_TYPE_ARRAY_SIZE (type
);
5932 if (stride
&& !INTEGER_CST_P (stride
))
5934 /* Calculate size = stride * (ubound + 1 - lbound). */
5935 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5936 gfc_array_index_type
,
5937 gfc_index_one_node
, lbound
);
5938 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5939 gfc_array_index_type
,
5941 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5942 gfc_array_index_type
,
5943 GFC_TYPE_ARRAY_STRIDE (type
, n
), tmp
);
5944 gfc_add_modify (&init
, stride
, tmp
);
5949 gfc_trans_array_cobounds (type
, &init
, sym
);
5951 /* Set the offset. */
5952 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
5953 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
5955 gfc_trans_vla_type_sizes (sym
, &init
);
5957 stmtInit
= gfc_finish_block (&init
);
5959 /* Only do the entry/initialization code if the arg is present. */
5960 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
5961 optional_arg
= (sym
->attr
.optional
5962 || (sym
->ns
->proc_name
->attr
.entry_master
5963 && sym
->attr
.dummy
));
5966 tmp
= gfc_conv_expr_present (sym
);
5967 stmtInit
= build3_v (COND_EXPR
, tmp
, stmtInit
,
5968 build_empty_stmt (input_location
));
5973 stmtCleanup
= NULL_TREE
;
5976 stmtblock_t cleanup
;
5977 gfc_start_block (&cleanup
);
5979 if (sym
->attr
.intent
!= INTENT_IN
)
5981 /* Copy the data back. */
5982 tmp
= build_call_expr_loc (input_location
,
5983 gfor_fndecl_in_unpack
, 2, dumdesc
, tmpdesc
);
5984 gfc_add_expr_to_block (&cleanup
, tmp
);
5987 /* Free the temporary. */
5988 tmp
= gfc_call_free (tmpdesc
);
5989 gfc_add_expr_to_block (&cleanup
, tmp
);
5991 stmtCleanup
= gfc_finish_block (&cleanup
);
5993 /* Only do the cleanup if the array was repacked. */
5994 tmp
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
5995 tmp
= gfc_conv_descriptor_data_get (tmp
);
5996 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5998 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
5999 build_empty_stmt (input_location
));
6003 tmp
= gfc_conv_expr_present (sym
);
6004 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6005 build_empty_stmt (input_location
));
6009 /* We don't need to free any memory allocated by internal_pack as it will
6010 be freed at the end of the function by pop_context. */
6011 gfc_add_init_cleanup (block
, stmtInit
, stmtCleanup
);
6013 gfc_restore_backend_locus (&loc
);
6017 /* Calculate the overall offset, including subreferences. */
6019 gfc_get_dataptr_offset (stmtblock_t
*block
, tree parm
, tree desc
, tree offset
,
6020 bool subref
, gfc_expr
*expr
)
6030 /* If offset is NULL and this is not a subreferenced array, there is
6032 if (offset
== NULL_TREE
)
6035 offset
= gfc_index_zero_node
;
6040 tmp
= build_array_ref (desc
, offset
, NULL
);
6042 /* Offset the data pointer for pointer assignments from arrays with
6043 subreferences; e.g. my_integer => my_type(:)%integer_component. */
6046 /* Go past the array reference. */
6047 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6048 if (ref
->type
== REF_ARRAY
&&
6049 ref
->u
.ar
.type
!= AR_ELEMENT
)
6055 /* Calculate the offset for each subsequent subreference. */
6056 for (; ref
; ref
= ref
->next
)
6061 field
= ref
->u
.c
.component
->backend_decl
;
6062 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
6063 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
6065 tmp
, field
, NULL_TREE
);
6069 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
6070 gfc_init_se (&start
, NULL
);
6071 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
6072 gfc_add_block_to_block (block
, &start
.pre
);
6073 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
6077 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
6078 && ref
->u
.ar
.type
== AR_ELEMENT
);
6080 /* TODO - Add bounds checking. */
6081 stride
= gfc_index_one_node
;
6082 index
= gfc_index_zero_node
;
6083 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
6088 /* Update the index. */
6089 gfc_init_se (&start
, NULL
);
6090 gfc_conv_expr_type (&start
, ref
->u
.ar
.start
[n
], gfc_array_index_type
);
6091 itmp
= gfc_evaluate_now (start
.expr
, block
);
6092 gfc_init_se (&start
, NULL
);
6093 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->lower
[n
], gfc_array_index_type
);
6094 jtmp
= gfc_evaluate_now (start
.expr
, block
);
6095 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6096 gfc_array_index_type
, itmp
, jtmp
);
6097 itmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6098 gfc_array_index_type
, itmp
, stride
);
6099 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
6100 gfc_array_index_type
, itmp
, index
);
6101 index
= gfc_evaluate_now (index
, block
);
6103 /* Update the stride. */
6104 gfc_init_se (&start
, NULL
);
6105 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->upper
[n
], gfc_array_index_type
);
6106 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6107 gfc_array_index_type
, start
.expr
,
6109 itmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6110 gfc_array_index_type
,
6111 gfc_index_one_node
, itmp
);
6112 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
6113 gfc_array_index_type
, stride
, itmp
);
6114 stride
= gfc_evaluate_now (stride
, block
);
6117 /* Apply the index to obtain the array element. */
6118 tmp
= gfc_build_array_ref (tmp
, index
, NULL
);
6128 /* Set the target data pointer. */
6129 offset
= gfc_build_addr_expr (gfc_array_dataptr_type (desc
), tmp
);
6130 gfc_conv_descriptor_data_set (block
, parm
, offset
);
6134 /* gfc_conv_expr_descriptor needs the string length an expression
6135 so that the size of the temporary can be obtained. This is done
6136 by adding up the string lengths of all the elements in the
6137 expression. Function with non-constant expressions have their
6138 string lengths mapped onto the actual arguments using the
6139 interface mapping machinery in trans-expr.c. */
6141 get_array_charlen (gfc_expr
*expr
, gfc_se
*se
)
6143 gfc_interface_mapping mapping
;
6144 gfc_formal_arglist
*formal
;
6145 gfc_actual_arglist
*arg
;
6148 if (expr
->ts
.u
.cl
->length
6149 && gfc_is_constant_expr (expr
->ts
.u
.cl
->length
))
6151 if (!expr
->ts
.u
.cl
->backend_decl
)
6152 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6156 switch (expr
->expr_type
)
6159 get_array_charlen (expr
->value
.op
.op1
, se
);
6161 /* For parentheses the expression ts.u.cl is identical. */
6162 if (expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
6165 expr
->ts
.u
.cl
->backend_decl
=
6166 gfc_create_var (gfc_charlen_type_node
, "sln");
6168 if (expr
->value
.op
.op2
)
6170 get_array_charlen (expr
->value
.op
.op2
, se
);
6172 gcc_assert (expr
->value
.op
.op
== INTRINSIC_CONCAT
);
6174 /* Add the string lengths and assign them to the expression
6175 string length backend declaration. */
6176 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
6177 fold_build2_loc (input_location
, PLUS_EXPR
,
6178 gfc_charlen_type_node
,
6179 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
,
6180 expr
->value
.op
.op2
->ts
.u
.cl
->backend_decl
));
6183 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
6184 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
);
6188 if (expr
->value
.function
.esym
== NULL
6189 || expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6191 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6195 /* Map expressions involving the dummy arguments onto the actual
6196 argument expressions. */
6197 gfc_init_interface_mapping (&mapping
);
6198 formal
= expr
->symtree
->n
.sym
->formal
;
6199 arg
= expr
->value
.function
.actual
;
6201 /* Set se = NULL in the calls to the interface mapping, to suppress any
6203 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
6208 gfc_add_interface_mapping (&mapping
, formal
->sym
, NULL
, arg
->expr
);
6211 gfc_init_se (&tse
, NULL
);
6213 /* Build the expression for the character length and convert it. */
6214 gfc_apply_interface_mapping (&mapping
, &tse
, expr
->ts
.u
.cl
->length
);
6216 gfc_add_block_to_block (&se
->pre
, &tse
.pre
);
6217 gfc_add_block_to_block (&se
->post
, &tse
.post
);
6218 tse
.expr
= fold_convert (gfc_charlen_type_node
, tse
.expr
);
6219 tse
.expr
= fold_build2_loc (input_location
, MAX_EXPR
,
6220 gfc_charlen_type_node
, tse
.expr
,
6221 build_int_cst (gfc_charlen_type_node
, 0));
6222 expr
->ts
.u
.cl
->backend_decl
= tse
.expr
;
6223 gfc_free_interface_mapping (&mapping
);
6227 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6233 /* Helper function to check dimensions. */
6235 transposed_dims (gfc_ss
*ss
)
6239 for (n
= 0; n
< ss
->dimen
; n
++)
6240 if (ss
->dim
[n
] != n
)
6245 /* Convert an array for passing as an actual argument. Expressions and
6246 vector subscripts are evaluated and stored in a temporary, which is then
6247 passed. For whole arrays the descriptor is passed. For array sections
6248 a modified copy of the descriptor is passed, but using the original data.
6250 This function is also used for array pointer assignments, and there
6253 - se->want_pointer && !se->direct_byref
6254 EXPR is an actual argument. On exit, se->expr contains a
6255 pointer to the array descriptor.
6257 - !se->want_pointer && !se->direct_byref
6258 EXPR is an actual argument to an intrinsic function or the
6259 left-hand side of a pointer assignment. On exit, se->expr
6260 contains the descriptor for EXPR.
6262 - !se->want_pointer && se->direct_byref
6263 EXPR is the right-hand side of a pointer assignment and
6264 se->expr is the descriptor for the previously-evaluated
6265 left-hand side. The function creates an assignment from
6269 The se->force_tmp flag disables the non-copying descriptor optimization
6270 that is used for transpose. It may be used in cases where there is an
6271 alias between the transpose argument and another argument in the same
6275 gfc_conv_expr_descriptor (gfc_se
* se
, gfc_expr
* expr
, gfc_ss
* ss
)
6277 gfc_ss_type ss_type
;
6278 gfc_ss_info
*ss_info
;
6280 gfc_array_info
*info
;
6289 bool subref_array_target
= false;
6290 gfc_expr
*arg
, *ss_expr
;
6292 gcc_assert (ss
!= NULL
);
6293 gcc_assert (ss
!= gfc_ss_terminator
);
6296 ss_type
= ss_info
->type
;
6297 ss_expr
= ss_info
->expr
;
6299 /* Special case things we know we can pass easily. */
6300 switch (expr
->expr_type
)
6303 /* If we have a linear array section, we can pass it directly.
6304 Otherwise we need to copy it into a temporary. */
6306 gcc_assert (ss_type
== GFC_SS_SECTION
);
6307 gcc_assert (ss_expr
== expr
);
6308 info
= &ss_info
->data
.array
;
6310 /* Get the descriptor for the array. */
6311 gfc_conv_ss_descriptor (&se
->pre
, ss
, 0);
6312 desc
= info
->descriptor
;
6314 subref_array_target
= se
->direct_byref
&& is_subref_array (expr
);
6315 need_tmp
= gfc_ref_needs_temporary_p (expr
->ref
)
6316 && !subref_array_target
;
6323 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
6325 /* Create a new descriptor if the array doesn't have one. */
6328 else if (info
->ref
->u
.ar
.type
== AR_FULL
)
6330 else if (se
->direct_byref
)
6333 full
= gfc_full_array_ref_p (info
->ref
, NULL
);
6335 if (full
&& !transposed_dims (ss
))
6337 if (se
->direct_byref
&& !se
->byref_noassign
)
6339 /* Copy the descriptor for pointer assignments. */
6340 gfc_add_modify (&se
->pre
, se
->expr
, desc
);
6342 /* Add any offsets from subreferences. */
6343 gfc_get_dataptr_offset (&se
->pre
, se
->expr
, desc
, NULL_TREE
,
6344 subref_array_target
, expr
);
6346 else if (se
->want_pointer
)
6348 /* We pass full arrays directly. This means that pointers and
6349 allocatable arrays should also work. */
6350 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
6357 if (expr
->ts
.type
== BT_CHARACTER
)
6358 se
->string_length
= gfc_get_expr_charlen (expr
);
6366 /* We don't need to copy data in some cases. */
6367 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
6370 /* This is a call to transpose... */
6371 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
6372 /* ... which has already been handled by the scalarizer, so
6373 that we just need to get its argument's descriptor. */
6374 gfc_conv_expr_descriptor (se
, expr
->value
.function
.actual
->expr
, ss
);
6378 /* A transformational function return value will be a temporary
6379 array descriptor. We still need to go through the scalarizer
6380 to create the descriptor. Elemental functions ar handled as
6381 arbitrary expressions, i.e. copy to a temporary. */
6383 if (se
->direct_byref
)
6385 gcc_assert (ss_type
== GFC_SS_FUNCTION
&& ss_expr
== expr
);
6387 /* For pointer assignments pass the descriptor directly. */
6391 gcc_assert (se
->ss
== ss
);
6392 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
6393 gfc_conv_expr (se
, expr
);
6397 if (ss_expr
!= expr
|| ss_type
!= GFC_SS_FUNCTION
)
6399 if (ss_expr
!= expr
)
6400 /* Elemental function. */
6401 gcc_assert ((expr
->value
.function
.esym
!= NULL
6402 && expr
->value
.function
.esym
->attr
.elemental
)
6403 || (expr
->value
.function
.isym
!= NULL
6404 && expr
->value
.function
.isym
->elemental
)
6405 || gfc_inline_intrinsic_function_p (expr
));
6407 gcc_assert (ss_type
== GFC_SS_INTRINSIC
);
6410 if (expr
->ts
.type
== BT_CHARACTER
6411 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
6412 get_array_charlen (expr
, se
);
6418 /* Transformational function. */
6419 info
= &ss_info
->data
.array
;
6425 /* Constant array constructors don't need a temporary. */
6426 if (ss_type
== GFC_SS_CONSTRUCTOR
6427 && expr
->ts
.type
!= BT_CHARACTER
6428 && gfc_constant_array_constructor_p (expr
->value
.constructor
))
6431 info
= &ss_info
->data
.array
;
6441 /* Something complicated. Copy it into a temporary. */
6447 /* If we are creating a temporary, we don't need to bother about aliases
6452 gfc_init_loopinfo (&loop
);
6454 /* Associate the SS with the loop. */
6455 gfc_add_ss_to_loop (&loop
, ss
);
6457 /* Tell the scalarizer not to bother creating loop variables, etc. */
6459 loop
.array_parameter
= 1;
6461 /* The right-hand side of a pointer assignment mustn't use a temporary. */
6462 gcc_assert (!se
->direct_byref
);
6464 /* Setup the scalarizing loops and bounds. */
6465 gfc_conv_ss_startstride (&loop
);
6469 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
6470 get_array_charlen (expr
, se
);
6472 /* Tell the scalarizer to make a temporary. */
6473 loop
.temp_ss
= gfc_get_temp_ss (gfc_typenode_for_spec (&expr
->ts
),
6474 ((expr
->ts
.type
== BT_CHARACTER
)
6475 ? expr
->ts
.u
.cl
->backend_decl
6479 se
->string_length
= loop
.temp_ss
->info
->string_length
;
6480 gcc_assert (loop
.temp_ss
->dimen
== loop
.dimen
);
6481 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
6484 gfc_conv_loop_setup (&loop
, & expr
->where
);
6488 /* Copy into a temporary and pass that. We don't need to copy the data
6489 back because expressions and vector subscripts must be INTENT_IN. */
6490 /* TODO: Optimize passing function return values. */
6494 /* Start the copying loops. */
6495 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
6496 gfc_mark_ss_chain_used (ss
, 1);
6497 gfc_start_scalarized_body (&loop
, &block
);
6499 /* Copy each data element. */
6500 gfc_init_se (&lse
, NULL
);
6501 gfc_copy_loopinfo_to_se (&lse
, &loop
);
6502 gfc_init_se (&rse
, NULL
);
6503 gfc_copy_loopinfo_to_se (&rse
, &loop
);
6505 lse
.ss
= loop
.temp_ss
;
6508 gfc_conv_scalarized_array_ref (&lse
, NULL
);
6509 if (expr
->ts
.type
== BT_CHARACTER
)
6511 gfc_conv_expr (&rse
, expr
);
6512 if (POINTER_TYPE_P (TREE_TYPE (rse
.expr
)))
6513 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
6517 gfc_conv_expr_val (&rse
, expr
);
6519 gfc_add_block_to_block (&block
, &rse
.pre
);
6520 gfc_add_block_to_block (&block
, &lse
.pre
);
6522 lse
.string_length
= rse
.string_length
;
6523 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true,
6524 expr
->expr_type
== EXPR_VARIABLE
6525 || expr
->expr_type
== EXPR_ARRAY
, true);
6526 gfc_add_expr_to_block (&block
, tmp
);
6528 /* Finish the copying loops. */
6529 gfc_trans_scalarizing_loops (&loop
, &block
);
6531 desc
= loop
.temp_ss
->info
->data
.array
.descriptor
;
6533 else if (expr
->expr_type
== EXPR_FUNCTION
&& !transposed_dims (ss
))
6535 desc
= info
->descriptor
;
6536 se
->string_length
= ss_info
->string_length
;
6540 /* We pass sections without copying to a temporary. Make a new
6541 descriptor and point it at the section we want. The loop variable
6542 limits will be the limits of the section.
6543 A function may decide to repack the array to speed up access, but
6544 we're not bothered about that here. */
6545 int dim
, ndim
, codim
;
6553 ndim
= info
->ref
? info
->ref
->u
.ar
.dimen
: ss
->dimen
;
6555 if (se
->want_coarray
)
6557 gfc_array_ref
*ar
= &info
->ref
->u
.ar
;
6559 codim
= gfc_get_corank (expr
);
6560 for (n
= 0; n
< codim
- 1; n
++)
6562 /* Make sure we are not lost somehow. */
6563 gcc_assert (ar
->dimen_type
[n
+ ndim
] == DIMEN_THIS_IMAGE
);
6565 /* Make sure the call to gfc_conv_section_startstride won't
6566 generate unnecessary code to calculate stride. */
6567 gcc_assert (ar
->stride
[n
+ ndim
] == NULL
);
6569 gfc_conv_section_startstride (&loop
, ss
, n
+ ndim
);
6570 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
6571 loop
.to
[n
+ loop
.dimen
] = info
->end
[n
+ ndim
];
6574 gcc_assert (n
== codim
- 1);
6575 evaluate_bound (&loop
.pre
, info
->start
, ar
->start
,
6576 info
->descriptor
, n
+ ndim
, true);
6577 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
6582 /* Set the string_length for a character array. */
6583 if (expr
->ts
.type
== BT_CHARACTER
)
6584 se
->string_length
= gfc_get_expr_charlen (expr
);
6586 desc
= info
->descriptor
;
6587 if (se
->direct_byref
&& !se
->byref_noassign
)
6589 /* For pointer assignments we fill in the destination. */
6591 parmtype
= TREE_TYPE (parm
);
6595 /* Otherwise make a new one. */
6596 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
6597 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
, codim
,
6598 loop
.from
, loop
.to
, 0,
6599 GFC_ARRAY_UNKNOWN
, false);
6600 parm
= gfc_create_var (parmtype
, "parm");
6603 offset
= gfc_index_zero_node
;
6605 /* The following can be somewhat confusing. We have two
6606 descriptors, a new one and the original array.
6607 {parm, parmtype, dim} refer to the new one.
6608 {desc, type, n, loop} refer to the original, which maybe
6609 a descriptorless array.
6610 The bounds of the scalarization are the bounds of the section.
6611 We don't have to worry about numeric overflows when calculating
6612 the offsets because all elements are within the array data. */
6614 /* Set the dtype. */
6615 tmp
= gfc_conv_descriptor_dtype (parm
);
6616 gfc_add_modify (&loop
.pre
, tmp
, gfc_get_dtype (parmtype
));
6618 /* Set offset for assignments to pointer only to zero if it is not
6620 if (se
->direct_byref
6621 && info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
6622 base
= gfc_index_zero_node
;
6623 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
6624 base
= gfc_evaluate_now (gfc_conv_array_offset (desc
), &loop
.pre
);
6628 for (n
= 0; n
< ndim
; n
++)
6630 stride
= gfc_conv_array_stride (desc
, n
);
6632 /* Work out the offset. */
6634 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
6636 gcc_assert (info
->subscript
[n
]
6637 && info
->subscript
[n
]->info
->type
== GFC_SS_SCALAR
);
6638 start
= info
->subscript
[n
]->info
->data
.scalar
.value
;
6642 /* Evaluate and remember the start of the section. */
6643 start
= info
->start
[n
];
6644 stride
= gfc_evaluate_now (stride
, &loop
.pre
);
6647 tmp
= gfc_conv_array_lbound (desc
, n
);
6648 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
6650 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
6652 offset
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (tmp
),
6656 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
6658 /* For elemental dimensions, we only need the offset. */
6662 /* Vector subscripts need copying and are handled elsewhere. */
6664 gcc_assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
6666 /* look for the corresponding scalarizer dimension: dim. */
6667 for (dim
= 0; dim
< ndim
; dim
++)
6668 if (ss
->dim
[dim
] == n
)
6671 /* loop exited early: the DIM being looked for has been found. */
6672 gcc_assert (dim
< ndim
);
6674 /* Set the new lower bound. */
6675 from
= loop
.from
[dim
];
6678 /* If we have an array section or are assigning make sure that
6679 the lower bound is 1. References to the full
6680 array should otherwise keep the original bounds. */
6682 || info
->ref
->u
.ar
.type
!= AR_FULL
)
6683 && !integer_onep (from
))
6685 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6686 gfc_array_index_type
, gfc_index_one_node
,
6688 to
= fold_build2_loc (input_location
, PLUS_EXPR
,
6689 gfc_array_index_type
, to
, tmp
);
6690 from
= gfc_index_one_node
;
6692 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
6693 gfc_rank_cst
[dim
], from
);
6695 /* Set the new upper bound. */
6696 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
6697 gfc_rank_cst
[dim
], to
);
6699 /* Multiply the stride by the section stride to get the
6701 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
6702 gfc_array_index_type
,
6703 stride
, info
->stride
[n
]);
6705 if (se
->direct_byref
6707 && info
->ref
->u
.ar
.type
!= AR_FULL
)
6709 base
= fold_build2_loc (input_location
, MINUS_EXPR
,
6710 TREE_TYPE (base
), base
, stride
);
6712 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
6714 tmp
= gfc_conv_array_lbound (desc
, n
);
6715 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6716 TREE_TYPE (base
), tmp
, loop
.from
[dim
]);
6717 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6718 TREE_TYPE (base
), tmp
,
6719 gfc_conv_array_stride (desc
, n
));
6720 base
= fold_build2_loc (input_location
, PLUS_EXPR
,
6721 TREE_TYPE (base
), tmp
, base
);
6724 /* Store the new stride. */
6725 gfc_conv_descriptor_stride_set (&loop
.pre
, parm
,
6726 gfc_rank_cst
[dim
], stride
);
6729 for (n
= loop
.dimen
; n
< loop
.dimen
+ codim
; n
++)
6731 from
= loop
.from
[n
];
6733 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
6734 gfc_rank_cst
[n
], from
);
6735 if (n
< loop
.dimen
+ codim
- 1)
6736 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
6737 gfc_rank_cst
[n
], to
);
6740 if (se
->data_not_needed
)
6741 gfc_conv_descriptor_data_set (&loop
.pre
, parm
,
6742 gfc_index_zero_node
);
6744 /* Point the data pointer at the 1st element in the section. */
6745 gfc_get_dataptr_offset (&loop
.pre
, parm
, desc
, offset
,
6746 subref_array_target
, expr
);
6748 if ((se
->direct_byref
|| GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
6749 && !se
->data_not_needed
)
6751 /* Set the offset. */
6752 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, base
);
6756 /* Only the callee knows what the correct offset it, so just set
6758 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, gfc_index_zero_node
);
6763 if (!se
->direct_byref
|| se
->byref_noassign
)
6765 /* Get a pointer to the new descriptor. */
6766 if (se
->want_pointer
)
6767 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
6772 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
6773 gfc_add_block_to_block (&se
->post
, &loop
.post
);
6775 /* Cleanup the scalarizer. */
6776 gfc_cleanup_loop (&loop
);
6779 /* Helper function for gfc_conv_array_parameter if array size needs to be
6783 array_parameter_size (tree desc
, gfc_expr
*expr
, tree
*size
)
6786 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
6787 *size
= GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc
));
6788 else if (expr
->rank
> 1)
6789 *size
= build_call_expr_loc (input_location
,
6790 gfor_fndecl_size0
, 1,
6791 gfc_build_addr_expr (NULL
, desc
));
6794 tree ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_index_zero_node
);
6795 tree lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_index_zero_node
);
6797 *size
= fold_build2_loc (input_location
, MINUS_EXPR
,
6798 gfc_array_index_type
, ubound
, lbound
);
6799 *size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
6800 *size
, gfc_index_one_node
);
6801 *size
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
6802 *size
, gfc_index_zero_node
);
6804 elem
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
6805 *size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6806 *size
, fold_convert (gfc_array_index_type
, elem
));
6809 /* Convert an array for passing as an actual parameter. */
6810 /* TODO: Optimize passing g77 arrays. */
6813 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, gfc_ss
* ss
, bool g77
,
6814 const gfc_symbol
*fsym
, const char *proc_name
,
6819 tree tmp
= NULL_TREE
;
6821 tree parent
= DECL_CONTEXT (current_function_decl
);
6822 bool full_array_var
;
6823 bool this_array_result
;
6826 bool array_constructor
;
6827 bool good_allocatable
;
6828 bool ultimate_ptr_comp
;
6829 bool ultimate_alloc_comp
;
6834 ultimate_ptr_comp
= false;
6835 ultimate_alloc_comp
= false;
6837 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6839 if (ref
->next
== NULL
)
6842 if (ref
->type
== REF_COMPONENT
)
6844 ultimate_ptr_comp
= ref
->u
.c
.component
->attr
.pointer
;
6845 ultimate_alloc_comp
= ref
->u
.c
.component
->attr
.allocatable
;
6849 full_array_var
= false;
6852 if (expr
->expr_type
== EXPR_VARIABLE
&& ref
&& !ultimate_ptr_comp
)
6853 full_array_var
= gfc_full_array_ref_p (ref
, &contiguous
);
6855 sym
= full_array_var
? expr
->symtree
->n
.sym
: NULL
;
6857 /* The symbol should have an array specification. */
6858 gcc_assert (!sym
|| sym
->as
|| ref
->u
.ar
.as
);
6860 if (expr
->expr_type
== EXPR_ARRAY
&& expr
->ts
.type
== BT_CHARACTER
)
6862 get_array_ctor_strlen (&se
->pre
, expr
->value
.constructor
, &tmp
);
6863 expr
->ts
.u
.cl
->backend_decl
= tmp
;
6864 se
->string_length
= tmp
;
6867 /* Is this the result of the enclosing procedure? */
6868 this_array_result
= (full_array_var
&& sym
->attr
.flavor
== FL_PROCEDURE
);
6869 if (this_array_result
6870 && (sym
->backend_decl
!= current_function_decl
)
6871 && (sym
->backend_decl
!= parent
))
6872 this_array_result
= false;
6874 /* Passing address of the array if it is not pointer or assumed-shape. */
6875 if (full_array_var
&& g77
&& !this_array_result
)
6877 tmp
= gfc_get_symbol_decl (sym
);
6879 if (sym
->ts
.type
== BT_CHARACTER
)
6880 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
6882 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
6884 gfc_conv_expr_descriptor (se
, expr
, ss
);
6885 se
->expr
= gfc_conv_array_data (se
->expr
);
6889 if (!sym
->attr
.pointer
6891 && sym
->as
->type
!= AS_ASSUMED_SHAPE
6892 && !sym
->attr
.allocatable
)
6894 /* Some variables are declared directly, others are declared as
6895 pointers and allocated on the heap. */
6896 if (sym
->attr
.dummy
|| POINTER_TYPE_P (TREE_TYPE (tmp
)))
6899 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
6901 array_parameter_size (tmp
, expr
, size
);
6905 if (sym
->attr
.allocatable
)
6907 if (sym
->attr
.dummy
|| sym
->attr
.result
)
6909 gfc_conv_expr_descriptor (se
, expr
, ss
);
6913 array_parameter_size (tmp
, expr
, size
);
6914 se
->expr
= gfc_conv_array_data (tmp
);
6919 /* A convenient reduction in scope. */
6920 contiguous
= g77
&& !this_array_result
&& contiguous
;
6922 /* There is no need to pack and unpack the array, if it is contiguous
6923 and not a deferred- or assumed-shape array, or if it is simply
6925 no_pack
= ((sym
&& sym
->as
6926 && !sym
->attr
.pointer
6927 && sym
->as
->type
!= AS_DEFERRED
6928 && sym
->as
->type
!= AS_ASSUMED_SHAPE
)
6930 (ref
&& ref
->u
.ar
.as
6931 && ref
->u
.ar
.as
->type
!= AS_DEFERRED
6932 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_SHAPE
)
6934 gfc_is_simply_contiguous (expr
, false));
6936 no_pack
= contiguous
&& no_pack
;
6938 /* Array constructors are always contiguous and do not need packing. */
6939 array_constructor
= g77
&& !this_array_result
&& expr
->expr_type
== EXPR_ARRAY
;
6941 /* Same is true of contiguous sections from allocatable variables. */
6942 good_allocatable
= contiguous
6944 && expr
->symtree
->n
.sym
->attr
.allocatable
;
6946 /* Or ultimate allocatable components. */
6947 ultimate_alloc_comp
= contiguous
&& ultimate_alloc_comp
;
6949 if (no_pack
|| array_constructor
|| good_allocatable
|| ultimate_alloc_comp
)
6951 gfc_conv_expr_descriptor (se
, expr
, ss
);
6952 if (expr
->ts
.type
== BT_CHARACTER
)
6953 se
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
6955 array_parameter_size (se
->expr
, expr
, size
);
6956 se
->expr
= gfc_conv_array_data (se
->expr
);
6960 if (this_array_result
)
6962 /* Result of the enclosing function. */
6963 gfc_conv_expr_descriptor (se
, expr
, ss
);
6965 array_parameter_size (se
->expr
, expr
, size
);
6966 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
6968 if (g77
&& TREE_TYPE (TREE_TYPE (se
->expr
)) != NULL_TREE
6969 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
6970 se
->expr
= gfc_conv_array_data (build_fold_indirect_ref_loc (input_location
,
6977 /* Every other type of array. */
6978 se
->want_pointer
= 1;
6979 gfc_conv_expr_descriptor (se
, expr
, ss
);
6981 array_parameter_size (build_fold_indirect_ref_loc (input_location
,
6986 /* Deallocate the allocatable components of structures that are
6988 if ((expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
)
6989 && expr
->ts
.u
.derived
->attr
.alloc_comp
6990 && expr
->expr_type
!= EXPR_VARIABLE
)
6992 tmp
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
6993 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
, expr
->rank
);
6995 /* The components shall be deallocated before their containing entity. */
6996 gfc_prepend_expr_to_block (&se
->post
, tmp
);
6999 if (g77
|| (fsym
&& fsym
->attr
.contiguous
7000 && !gfc_is_simply_contiguous (expr
, false)))
7002 tree origptr
= NULL_TREE
;
7006 /* For contiguous arrays, save the original value of the descriptor. */
7009 origptr
= gfc_create_var (pvoid_type_node
, "origptr");
7010 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7011 tmp
= gfc_conv_array_data (tmp
);
7012 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7013 TREE_TYPE (origptr
), origptr
,
7014 fold_convert (TREE_TYPE (origptr
), tmp
));
7015 gfc_add_expr_to_block (&se
->pre
, tmp
);
7018 /* Repack the array. */
7019 if (gfc_option
.warn_array_temp
)
7022 gfc_warning ("Creating array temporary at %L for argument '%s'",
7023 &expr
->where
, fsym
->name
);
7025 gfc_warning ("Creating array temporary at %L", &expr
->where
);
7028 ptr
= build_call_expr_loc (input_location
,
7029 gfor_fndecl_in_pack
, 1, desc
);
7031 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7033 tmp
= gfc_conv_expr_present (sym
);
7034 ptr
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
7035 tmp
, fold_convert (TREE_TYPE (se
->expr
), ptr
),
7036 fold_convert (TREE_TYPE (se
->expr
), null_pointer_node
));
7039 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
7041 /* Use the packed data for the actual argument, except for contiguous arrays,
7042 where the descriptor's data component is set. */
7047 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7048 gfc_conv_descriptor_data_set (&se
->pre
, tmp
, ptr
);
7051 if (gfc_option
.rtcheck
& GFC_RTCHECK_ARRAY_TEMPS
)
7055 if (fsym
&& proc_name
)
7056 asprintf (&msg
, "An array temporary was created for argument "
7057 "'%s' of procedure '%s'", fsym
->name
, proc_name
);
7059 asprintf (&msg
, "An array temporary was created");
7061 tmp
= build_fold_indirect_ref_loc (input_location
,
7063 tmp
= gfc_conv_array_data (tmp
);
7064 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7065 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
7067 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7068 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7070 gfc_conv_expr_present (sym
), tmp
);
7072 gfc_trans_runtime_check (false, true, tmp
, &se
->pre
,
7077 gfc_start_block (&block
);
7079 /* Copy the data back. */
7080 if (fsym
== NULL
|| fsym
->attr
.intent
!= INTENT_IN
)
7082 tmp
= build_call_expr_loc (input_location
,
7083 gfor_fndecl_in_unpack
, 2, desc
, ptr
);
7084 gfc_add_expr_to_block (&block
, tmp
);
7087 /* Free the temporary. */
7088 tmp
= gfc_call_free (convert (pvoid_type_node
, ptr
));
7089 gfc_add_expr_to_block (&block
, tmp
);
7091 stmt
= gfc_finish_block (&block
);
7093 gfc_init_block (&block
);
7094 /* Only if it was repacked. This code needs to be executed before the
7095 loop cleanup code. */
7096 tmp
= build_fold_indirect_ref_loc (input_location
,
7098 tmp
= gfc_conv_array_data (tmp
);
7099 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7100 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
7102 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7103 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7105 gfc_conv_expr_present (sym
), tmp
);
7107 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
7109 gfc_add_expr_to_block (&block
, tmp
);
7110 gfc_add_block_to_block (&block
, &se
->post
);
7112 gfc_init_block (&se
->post
);
7114 /* Reset the descriptor pointer. */
7117 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7118 gfc_conv_descriptor_data_set (&se
->post
, tmp
, origptr
);
7121 gfc_add_block_to_block (&se
->post
, &block
);
7126 /* Generate code to deallocate an array, if it is allocated. */
7129 gfc_trans_dealloc_allocated (tree descriptor
, bool coarray
)
7135 gfc_start_block (&block
);
7137 var
= gfc_conv_descriptor_data_get (descriptor
);
7140 /* Call array_deallocate with an int * present in the second argument.
7141 Although it is ignored here, it's presence ensures that arrays that
7142 are already deallocated are ignored. */
7143 tmp
= gfc_deallocate_with_status (coarray
? descriptor
: var
, NULL_TREE
,
7144 NULL_TREE
, NULL_TREE
, NULL_TREE
, true,
7146 gfc_add_expr_to_block (&block
, tmp
);
7148 /* Zero the data pointer. */
7149 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
7150 var
, build_int_cst (TREE_TYPE (var
), 0));
7151 gfc_add_expr_to_block (&block
, tmp
);
7153 return gfc_finish_block (&block
);
7157 /* This helper function calculates the size in words of a full array. */
7160 get_full_array_size (stmtblock_t
*block
, tree decl
, int rank
)
7165 idx
= gfc_rank_cst
[rank
- 1];
7166 nelems
= gfc_conv_descriptor_ubound_get (decl
, idx
);
7167 tmp
= gfc_conv_descriptor_lbound_get (decl
, idx
);
7168 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7170 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7171 tmp
, gfc_index_one_node
);
7172 tmp
= gfc_evaluate_now (tmp
, block
);
7174 nelems
= gfc_conv_descriptor_stride_get (decl
, idx
);
7175 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7177 return gfc_evaluate_now (tmp
, block
);
7181 /* Allocate dest to the same size as src, and copy src -> dest.
7182 If no_malloc is set, only the copy is done. */
7185 duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
7195 /* If the source is null, set the destination to null. Then,
7196 allocate memory to the destination. */
7197 gfc_init_block (&block
);
7201 tmp
= null_pointer_node
;
7202 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, type
, dest
, tmp
);
7203 gfc_add_expr_to_block (&block
, tmp
);
7204 null_data
= gfc_finish_block (&block
);
7206 gfc_init_block (&block
);
7207 size
= TYPE_SIZE_UNIT (TREE_TYPE (type
));
7210 tmp
= gfc_call_malloc (&block
, type
, size
);
7211 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
7212 dest
, fold_convert (type
, tmp
));
7213 gfc_add_expr_to_block (&block
, tmp
);
7216 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
7217 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
7222 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
7223 null_data
= gfc_finish_block (&block
);
7225 gfc_init_block (&block
);
7226 nelems
= get_full_array_size (&block
, src
, rank
);
7227 tmp
= fold_convert (gfc_array_index_type
,
7228 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
7229 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7233 tmp
= TREE_TYPE (gfc_conv_descriptor_data_get (src
));
7234 tmp
= gfc_call_malloc (&block
, tmp
, size
);
7235 gfc_conv_descriptor_data_set (&block
, dest
, tmp
);
7238 /* We know the temporary and the value will be the same length,
7239 so can use memcpy. */
7240 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
7241 tmp
= build_call_expr_loc (input_location
,
7242 tmp
, 3, gfc_conv_descriptor_data_get (dest
),
7243 gfc_conv_descriptor_data_get (src
), size
);
7246 gfc_add_expr_to_block (&block
, tmp
);
7247 tmp
= gfc_finish_block (&block
);
7249 /* Null the destination if the source is null; otherwise do
7250 the allocate and copy. */
7254 null_cond
= gfc_conv_descriptor_data_get (src
);
7256 null_cond
= convert (pvoid_type_node
, null_cond
);
7257 null_cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7258 null_cond
, null_pointer_node
);
7259 return build3_v (COND_EXPR
, null_cond
, tmp
, null_data
);
7263 /* Allocate dest to the same size as src, and copy data src -> dest. */
7266 gfc_duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
)
7268 return duplicate_allocatable (dest
, src
, type
, rank
, false);
7272 /* Copy data src -> dest. */
7275 gfc_copy_allocatable_data (tree dest
, tree src
, tree type
, int rank
)
7277 return duplicate_allocatable (dest
, src
, type
, rank
, true);
7281 /* Recursively traverse an object of derived type, generating code to
7282 deallocate, nullify or copy allocatable components. This is the work horse
7283 function for the functions named in this enum. */
7285 enum {DEALLOCATE_ALLOC_COMP
= 1, NULLIFY_ALLOC_COMP
, COPY_ALLOC_COMP
,
7286 COPY_ONLY_ALLOC_COMP
};
7289 structure_alloc_comps (gfc_symbol
* der_type
, tree decl
,
7290 tree dest
, int rank
, int purpose
)
7294 stmtblock_t fnblock
;
7295 stmtblock_t loopbody
;
7296 stmtblock_t tmpblock
;
7307 tree null_cond
= NULL_TREE
;
7308 bool called_dealloc_with_status
;
7310 gfc_init_block (&fnblock
);
7312 decl_type
= TREE_TYPE (decl
);
7314 if ((POINTER_TYPE_P (decl_type
) && rank
!= 0)
7315 || (TREE_CODE (decl_type
) == REFERENCE_TYPE
&& rank
== 0))
7317 decl
= build_fold_indirect_ref_loc (input_location
,
7320 /* Just in case in gets dereferenced. */
7321 decl_type
= TREE_TYPE (decl
);
7323 /* If this an array of derived types with allocatable components
7324 build a loop and recursively call this function. */
7325 if (TREE_CODE (decl_type
) == ARRAY_TYPE
7326 || GFC_DESCRIPTOR_TYPE_P (decl_type
))
7328 tmp
= gfc_conv_array_data (decl
);
7329 var
= build_fold_indirect_ref_loc (input_location
,
7332 /* Get the number of elements - 1 and set the counter. */
7333 if (GFC_DESCRIPTOR_TYPE_P (decl_type
))
7335 /* Use the descriptor for an allocatable array. Since this
7336 is a full array reference, we only need the descriptor
7337 information from dimension = rank. */
7338 tmp
= get_full_array_size (&fnblock
, decl
, rank
);
7339 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7340 gfc_array_index_type
, tmp
,
7341 gfc_index_one_node
);
7343 null_cond
= gfc_conv_descriptor_data_get (decl
);
7344 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
7345 boolean_type_node
, null_cond
,
7346 build_int_cst (TREE_TYPE (null_cond
), 0));
7350 /* Otherwise use the TYPE_DOMAIN information. */
7351 tmp
= array_type_nelts (decl_type
);
7352 tmp
= fold_convert (gfc_array_index_type
, tmp
);
7355 /* Remember that this is, in fact, the no. of elements - 1. */
7356 nelems
= gfc_evaluate_now (tmp
, &fnblock
);
7357 index
= gfc_create_var (gfc_array_index_type
, "S");
7359 /* Build the body of the loop. */
7360 gfc_init_block (&loopbody
);
7362 vref
= gfc_build_array_ref (var
, index
, NULL
);
7364 if (purpose
== COPY_ALLOC_COMP
)
7366 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
7368 tmp
= gfc_duplicate_allocatable (dest
, decl
, decl_type
, rank
);
7369 gfc_add_expr_to_block (&fnblock
, tmp
);
7371 tmp
= build_fold_indirect_ref_loc (input_location
,
7372 gfc_conv_array_data (dest
));
7373 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
7374 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
, purpose
);
7376 else if (purpose
== COPY_ONLY_ALLOC_COMP
)
7378 tmp
= build_fold_indirect_ref_loc (input_location
,
7379 gfc_conv_array_data (dest
));
7380 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
7381 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
,
7385 tmp
= structure_alloc_comps (der_type
, vref
, NULL_TREE
, rank
, purpose
);
7387 gfc_add_expr_to_block (&loopbody
, tmp
);
7389 /* Build the loop and return. */
7390 gfc_init_loopinfo (&loop
);
7392 loop
.from
[0] = gfc_index_zero_node
;
7393 loop
.loopvar
[0] = index
;
7394 loop
.to
[0] = nelems
;
7395 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
7396 gfc_add_block_to_block (&fnblock
, &loop
.pre
);
7398 tmp
= gfc_finish_block (&fnblock
);
7399 if (null_cond
!= NULL_TREE
)
7400 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
7401 build_empty_stmt (input_location
));
7406 /* Otherwise, act on the components or recursively call self to
7407 act on a chain of components. */
7408 for (c
= der_type
->components
; c
; c
= c
->next
)
7410 bool cmp_has_alloc_comps
= (c
->ts
.type
== BT_DERIVED
7411 || c
->ts
.type
== BT_CLASS
)
7412 && c
->ts
.u
.derived
->attr
.alloc_comp
;
7413 cdecl = c
->backend_decl
;
7414 ctype
= TREE_TYPE (cdecl);
7418 case DEALLOCATE_ALLOC_COMP
:
7420 /* gfc_deallocate_scalar_with_status calls gfc_deallocate_alloc_comp
7421 (ie. this function) so generate all the calls and suppress the
7422 recursion from here, if necessary. */
7423 called_dealloc_with_status
= false;
7424 gfc_init_block (&tmpblock
);
7426 if (c
->attr
.allocatable
7427 && (c
->attr
.dimension
|| c
->attr
.codimension
))
7429 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7430 decl
, cdecl, NULL_TREE
);
7431 tmp
= gfc_trans_dealloc_allocated (comp
, c
->attr
.codimension
);
7432 gfc_add_expr_to_block (&tmpblock
, tmp
);
7434 else if (c
->attr
.allocatable
)
7436 /* Allocatable scalar components. */
7437 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7438 decl
, cdecl, NULL_TREE
);
7440 tmp
= gfc_deallocate_scalar_with_status (comp
, NULL
, true, NULL
,
7442 gfc_add_expr_to_block (&tmpblock
, tmp
);
7443 called_dealloc_with_status
= true;
7445 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7446 void_type_node
, comp
,
7447 build_int_cst (TREE_TYPE (comp
), 0));
7448 gfc_add_expr_to_block (&tmpblock
, tmp
);
7450 else if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
7452 /* Allocatable CLASS components. */
7453 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7454 decl
, cdecl, NULL_TREE
);
7456 /* Add reference to '_data' component. */
7457 tmp
= CLASS_DATA (c
)->backend_decl
;
7458 comp
= fold_build3_loc (input_location
, COMPONENT_REF
,
7459 TREE_TYPE (tmp
), comp
, tmp
, NULL_TREE
);
7461 if (GFC_DESCRIPTOR_TYPE_P(TREE_TYPE (comp
)))
7462 tmp
= gfc_trans_dealloc_allocated (comp
,
7463 CLASS_DATA (c
)->attr
.codimension
);
7466 tmp
= gfc_deallocate_scalar_with_status (comp
, NULL
, true, NULL
,
7467 CLASS_DATA (c
)->ts
);
7468 gfc_add_expr_to_block (&tmpblock
, tmp
);
7469 called_dealloc_with_status
= true;
7471 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7472 void_type_node
, comp
,
7473 build_int_cst (TREE_TYPE (comp
), 0));
7475 gfc_add_expr_to_block (&tmpblock
, tmp
);
7478 if (cmp_has_alloc_comps
7480 && !called_dealloc_with_status
)
7482 /* Do not deallocate the components of ultimate pointer
7483 components or iteratively call self if call has been made
7484 to gfc_trans_dealloc_allocated */
7485 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7486 decl
, cdecl, NULL_TREE
);
7487 rank
= c
->as
? c
->as
->rank
: 0;
7488 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
7490 gfc_add_expr_to_block (&fnblock
, tmp
);
7493 /* Now add the deallocation of this component. */
7494 gfc_add_block_to_block (&fnblock
, &tmpblock
);
7497 case NULLIFY_ALLOC_COMP
:
7498 if (c
->attr
.pointer
)
7500 else if (c
->attr
.allocatable
7501 && (c
->attr
.dimension
|| c
->attr
.codimension
))
7503 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7504 decl
, cdecl, NULL_TREE
);
7505 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
7507 else if (c
->attr
.allocatable
)
7509 /* Allocatable scalar components. */
7510 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7511 decl
, cdecl, NULL_TREE
);
7512 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7513 void_type_node
, comp
,
7514 build_int_cst (TREE_TYPE (comp
), 0));
7515 gfc_add_expr_to_block (&fnblock
, tmp
);
7517 else if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
7519 /* Allocatable CLASS components. */
7520 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7521 decl
, cdecl, NULL_TREE
);
7522 /* Add reference to '_data' component. */
7523 tmp
= CLASS_DATA (c
)->backend_decl
;
7524 comp
= fold_build3_loc (input_location
, COMPONENT_REF
,
7525 TREE_TYPE (tmp
), comp
, tmp
, NULL_TREE
);
7526 if (GFC_DESCRIPTOR_TYPE_P(TREE_TYPE (comp
)))
7527 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
7530 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7531 void_type_node
, comp
,
7532 build_int_cst (TREE_TYPE (comp
), 0));
7533 gfc_add_expr_to_block (&fnblock
, tmp
);
7536 else if (cmp_has_alloc_comps
)
7538 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7539 decl
, cdecl, NULL_TREE
);
7540 rank
= c
->as
? c
->as
->rank
: 0;
7541 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
7543 gfc_add_expr_to_block (&fnblock
, tmp
);
7547 case COPY_ALLOC_COMP
:
7548 if (c
->attr
.pointer
)
7551 /* We need source and destination components. */
7552 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, decl
,
7554 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, dest
,
7556 dcmp
= fold_convert (TREE_TYPE (comp
), dcmp
);
7558 if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
7566 dst_data
= gfc_class_data_get (dcmp
);
7567 src_data
= gfc_class_data_get (comp
);
7568 size
= fold_convert (size_type_node
, gfc_vtable_size_get (comp
));
7570 if (CLASS_DATA (c
)->attr
.dimension
)
7572 nelems
= gfc_conv_descriptor_size (src_data
,
7573 CLASS_DATA (c
)->as
->rank
);
7574 src_data
= gfc_conv_descriptor_data_get (src_data
);
7575 dst_data
= gfc_conv_descriptor_data_get (dst_data
);
7578 nelems
= build_int_cst (size_type_node
, 1);
7580 gfc_init_block (&tmpblock
);
7582 /* We need to use CALLOC as _copy might try to free allocatable
7583 components of the destination. */
7584 ftn_tree
= builtin_decl_explicit (BUILT_IN_CALLOC
);
7585 tmp
= build_call_expr_loc (input_location
, ftn_tree
, 2, nelems
,
7587 gfc_add_modify (&tmpblock
, dst_data
,
7588 fold_convert (TREE_TYPE (dst_data
), tmp
));
7590 tmp
= gfc_copy_class_to_class (comp
, dcmp
, nelems
);
7591 gfc_add_expr_to_block (&tmpblock
, tmp
);
7592 tmp
= gfc_finish_block (&tmpblock
);
7594 gfc_init_block (&tmpblock
);
7595 gfc_add_modify (&tmpblock
, dst_data
,
7596 fold_convert (TREE_TYPE (dst_data
),
7597 null_pointer_node
));
7598 null_data
= gfc_finish_block (&tmpblock
);
7600 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
7601 boolean_type_node
, src_data
,
7604 gfc_add_expr_to_block (&fnblock
, build3_v (COND_EXPR
, null_cond
,
7609 if (c
->attr
.allocatable
&& !cmp_has_alloc_comps
)
7611 rank
= c
->as
? c
->as
->rank
: 0;
7612 tmp
= gfc_duplicate_allocatable (dcmp
, comp
, ctype
, rank
);
7613 gfc_add_expr_to_block (&fnblock
, tmp
);
7616 if (cmp_has_alloc_comps
)
7618 rank
= c
->as
? c
->as
->rank
: 0;
7619 tmp
= fold_convert (TREE_TYPE (dcmp
), comp
);
7620 gfc_add_modify (&fnblock
, dcmp
, tmp
);
7621 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, dcmp
,
7623 gfc_add_expr_to_block (&fnblock
, tmp
);
7633 return gfc_finish_block (&fnblock
);
7636 /* Recursively traverse an object of derived type, generating code to
7637 nullify allocatable components. */
7640 gfc_nullify_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
7642 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
7643 NULLIFY_ALLOC_COMP
);
7647 /* Recursively traverse an object of derived type, generating code to
7648 deallocate allocatable components. */
7651 gfc_deallocate_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
7653 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
7654 DEALLOCATE_ALLOC_COMP
);
7658 /* Recursively traverse an object of derived type, generating code to
7659 copy it and its allocatable components. */
7662 gfc_copy_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
7664 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ALLOC_COMP
);
7668 /* Recursively traverse an object of derived type, generating code to
7669 copy only its allocatable components. */
7672 gfc_copy_only_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
7674 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ONLY_ALLOC_COMP
);
7678 /* Returns the value of LBOUND for an expression. This could be broken out
7679 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
7680 called by gfc_alloc_allocatable_for_assignment. */
7682 get_std_lbound (gfc_expr
*expr
, tree desc
, int dim
, bool assumed_size
)
7687 tree cond
, cond1
, cond3
, cond4
;
7691 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
7693 tmp
= gfc_rank_cst
[dim
];
7694 lbound
= gfc_conv_descriptor_lbound_get (desc
, tmp
);
7695 ubound
= gfc_conv_descriptor_ubound_get (desc
, tmp
);
7696 stride
= gfc_conv_descriptor_stride_get (desc
, tmp
);
7697 cond1
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
7699 cond3
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
7700 stride
, gfc_index_zero_node
);
7701 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7702 boolean_type_node
, cond3
, cond1
);
7703 cond4
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
7704 stride
, gfc_index_zero_node
);
7706 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
7707 tmp
, build_int_cst (gfc_array_index_type
,
7710 cond
= boolean_false_node
;
7712 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
7713 boolean_type_node
, cond3
, cond4
);
7714 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
7715 boolean_type_node
, cond
, cond1
);
7717 return fold_build3_loc (input_location
, COND_EXPR
,
7718 gfc_array_index_type
, cond
,
7719 lbound
, gfc_index_one_node
);
7722 if (expr
->expr_type
== EXPR_FUNCTION
)
7724 /* A conversion function, so use the argument. */
7725 gcc_assert (expr
->value
.function
.isym
7726 && expr
->value
.function
.isym
->conversion
);
7727 expr
= expr
->value
.function
.actual
->expr
;
7730 if (expr
->expr_type
== EXPR_VARIABLE
)
7732 tmp
= TREE_TYPE (expr
->symtree
->n
.sym
->backend_decl
);
7733 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7735 if (ref
->type
== REF_COMPONENT
7736 && ref
->u
.c
.component
->as
7738 && ref
->next
->u
.ar
.type
== AR_FULL
)
7739 tmp
= TREE_TYPE (ref
->u
.c
.component
->backend_decl
);
7741 return GFC_TYPE_ARRAY_LBOUND(tmp
, dim
);
7744 return gfc_index_one_node
;
7748 /* Returns true if an expression represents an lhs that can be reallocated
7752 gfc_is_reallocatable_lhs (gfc_expr
*expr
)
7759 /* An allocatable variable. */
7760 if (expr
->symtree
->n
.sym
->attr
.allocatable
7762 && expr
->ref
->type
== REF_ARRAY
7763 && expr
->ref
->u
.ar
.type
== AR_FULL
)
7766 /* All that can be left are allocatable components. */
7767 if ((expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
7768 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
7769 || !expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
7772 /* Find a component ref followed by an array reference. */
7773 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7775 && ref
->type
== REF_COMPONENT
7776 && ref
->next
->type
== REF_ARRAY
7777 && !ref
->next
->next
)
7783 /* Return true if valid reallocatable lhs. */
7784 if (ref
->u
.c
.component
->attr
.allocatable
7785 && ref
->next
->u
.ar
.type
== AR_FULL
)
7792 /* Allocate the lhs of an assignment to an allocatable array, otherwise
7796 gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop
,
7800 stmtblock_t realloc_block
;
7801 stmtblock_t alloc_block
;
7805 gfc_array_info
*linfo
;
7825 gfc_array_spec
* as
;
7827 /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
7828 Find the lhs expression in the loop chain and set expr1 and
7829 expr2 accordingly. */
7830 if (expr1
->expr_type
== EXPR_FUNCTION
&& expr2
== NULL
)
7833 /* Find the ss for the lhs. */
7835 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
7836 if (lss
->info
->expr
&& lss
->info
->expr
->expr_type
== EXPR_VARIABLE
)
7838 if (lss
== gfc_ss_terminator
)
7840 expr1
= lss
->info
->expr
;
7843 /* Bail out if this is not a valid allocate on assignment. */
7844 if (!gfc_is_reallocatable_lhs (expr1
)
7845 || (expr2
&& !expr2
->rank
))
7848 /* Find the ss for the lhs. */
7850 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
7851 if (lss
->info
->expr
== expr1
)
7854 if (lss
== gfc_ss_terminator
)
7857 linfo
= &lss
->info
->data
.array
;
7859 /* Find an ss for the rhs. For operator expressions, we see the
7860 ss's for the operands. Any one of these will do. */
7862 for (; rss
&& rss
!= gfc_ss_terminator
; rss
= rss
->loop_chain
)
7863 if (rss
->info
->expr
!= expr1
&& rss
!= loop
->temp_ss
)
7866 if (expr2
&& rss
== gfc_ss_terminator
)
7869 gfc_start_block (&fblock
);
7871 /* Since the lhs is allocatable, this must be a descriptor type.
7872 Get the data and array size. */
7873 desc
= linfo
->descriptor
;
7874 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)));
7875 array1
= gfc_conv_descriptor_data_get (desc
);
7877 /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
7878 deallocated if expr is an array of different shape or any of the
7879 corresponding length type parameter values of variable and expr
7880 differ." This assures F95 compatibility. */
7881 jump_label1
= gfc_build_label_decl (NULL_TREE
);
7882 jump_label2
= gfc_build_label_decl (NULL_TREE
);
7884 /* Allocate if data is NULL. */
7885 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
7886 array1
, build_int_cst (TREE_TYPE (array1
), 0));
7887 tmp
= build3_v (COND_EXPR
, cond
,
7888 build1_v (GOTO_EXPR
, jump_label1
),
7889 build_empty_stmt (input_location
));
7890 gfc_add_expr_to_block (&fblock
, tmp
);
7892 /* Get arrayspec if expr is a full array. */
7893 if (expr2
&& expr2
->expr_type
== EXPR_FUNCTION
7894 && expr2
->value
.function
.isym
7895 && expr2
->value
.function
.isym
->conversion
)
7897 /* For conversion functions, take the arg. */
7898 gfc_expr
*arg
= expr2
->value
.function
.actual
->expr
;
7899 as
= gfc_get_full_arrayspec_from_expr (arg
);
7902 as
= gfc_get_full_arrayspec_from_expr (expr2
);
7906 /* If the lhs shape is not the same as the rhs jump to setting the
7907 bounds and doing the reallocation....... */
7908 for (n
= 0; n
< expr1
->rank
; n
++)
7910 /* Check the shape. */
7911 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
7912 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
7913 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7914 gfc_array_index_type
,
7915 loop
->to
[n
], loop
->from
[n
]);
7916 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7917 gfc_array_index_type
,
7919 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7920 gfc_array_index_type
,
7922 cond
= fold_build2_loc (input_location
, NE_EXPR
,
7924 tmp
, gfc_index_zero_node
);
7925 tmp
= build3_v (COND_EXPR
, cond
,
7926 build1_v (GOTO_EXPR
, jump_label1
),
7927 build_empty_stmt (input_location
));
7928 gfc_add_expr_to_block (&fblock
, tmp
);
7931 /* ....else jump past the (re)alloc code. */
7932 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
7933 gfc_add_expr_to_block (&fblock
, tmp
);
7935 /* Add the label to start automatic (re)allocation. */
7936 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
7937 gfc_add_expr_to_block (&fblock
, tmp
);
7939 size1
= gfc_conv_descriptor_size (desc
, expr1
->rank
);
7941 /* Get the rhs size. Fix both sizes. */
7943 desc2
= rss
->info
->data
.array
.descriptor
;
7946 size2
= gfc_index_one_node
;
7947 for (n
= 0; n
< expr2
->rank
; n
++)
7949 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7950 gfc_array_index_type
,
7951 loop
->to
[n
], loop
->from
[n
]);
7952 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7953 gfc_array_index_type
,
7954 tmp
, gfc_index_one_node
);
7955 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
7956 gfc_array_index_type
,
7960 size1
= gfc_evaluate_now (size1
, &fblock
);
7961 size2
= gfc_evaluate_now (size2
, &fblock
);
7963 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7965 neq_size
= gfc_evaluate_now (cond
, &fblock
);
7968 /* Now modify the lhs descriptor and the associated scalarizer
7969 variables. F2003 7.4.1.3: "If variable is or becomes an
7970 unallocated allocatable variable, then it is allocated with each
7971 deferred type parameter equal to the corresponding type parameters
7972 of expr , with the shape of expr , and with each lower bound equal
7973 to the corresponding element of LBOUND(expr)."
7974 Reuse size1 to keep a dimension-by-dimension track of the
7975 stride of the new array. */
7976 size1
= gfc_index_one_node
;
7977 offset
= gfc_index_zero_node
;
7979 for (n
= 0; n
< expr2
->rank
; n
++)
7981 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7982 gfc_array_index_type
,
7983 loop
->to
[n
], loop
->from
[n
]);
7984 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7985 gfc_array_index_type
,
7986 tmp
, gfc_index_one_node
);
7988 lbound
= gfc_index_one_node
;
7993 lbd
= get_std_lbound (expr2
, desc2
, n
,
7994 as
->type
== AS_ASSUMED_SIZE
);
7995 ubound
= fold_build2_loc (input_location
,
7997 gfc_array_index_type
,
7999 ubound
= fold_build2_loc (input_location
,
8001 gfc_array_index_type
,
8006 gfc_conv_descriptor_lbound_set (&fblock
, desc
,
8009 gfc_conv_descriptor_ubound_set (&fblock
, desc
,
8012 gfc_conv_descriptor_stride_set (&fblock
, desc
,
8015 lbound
= gfc_conv_descriptor_lbound_get (desc
,
8017 tmp2
= fold_build2_loc (input_location
, MULT_EXPR
,
8018 gfc_array_index_type
,
8020 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
8021 gfc_array_index_type
,
8023 size1
= fold_build2_loc (input_location
, MULT_EXPR
,
8024 gfc_array_index_type
,
8028 /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
8029 the array offset is saved and the info.offset is used for a
8030 running offset. Use the saved_offset instead. */
8031 tmp
= gfc_conv_descriptor_offset (desc
);
8032 gfc_add_modify (&fblock
, tmp
, offset
);
8033 if (linfo
->saved_offset
8034 && TREE_CODE (linfo
->saved_offset
) == VAR_DECL
)
8035 gfc_add_modify (&fblock
, linfo
->saved_offset
, tmp
);
8037 /* Now set the deltas for the lhs. */
8038 for (n
= 0; n
< expr1
->rank
; n
++)
8040 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
8042 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8043 gfc_array_index_type
, tmp
,
8045 if (linfo
->delta
[dim
]
8046 && TREE_CODE (linfo
->delta
[dim
]) == VAR_DECL
)
8047 gfc_add_modify (&fblock
, linfo
->delta
[dim
], tmp
);
8050 /* Get the new lhs size in bytes. */
8051 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
8053 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
8054 gcc_assert (expr1
->ts
.u
.cl
->backend_decl
);
8055 tmp
= fold_convert (TREE_TYPE (expr1
->ts
.u
.cl
->backend_decl
), tmp
);
8056 gfc_add_modify (&fblock
, expr1
->ts
.u
.cl
->backend_decl
, tmp
);
8058 else if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.u
.cl
->backend_decl
)
8060 tmp
= TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
)));
8061 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8062 gfc_array_index_type
, tmp
,
8063 expr1
->ts
.u
.cl
->backend_decl
);
8066 tmp
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
8067 tmp
= fold_convert (gfc_array_index_type
, tmp
);
8068 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
8069 gfc_array_index_type
,
8071 size2
= fold_convert (size_type_node
, size2
);
8072 size2
= gfc_evaluate_now (size2
, &fblock
);
8074 /* Realloc expression. Note that the scalarizer uses desc.data
8075 in the array reference - (*desc.data)[<element>]. */
8076 gfc_init_block (&realloc_block
);
8077 tmp
= build_call_expr_loc (input_location
,
8078 builtin_decl_explicit (BUILT_IN_REALLOC
), 2,
8079 fold_convert (pvoid_type_node
, array1
),
8081 gfc_conv_descriptor_data_set (&realloc_block
,
8083 realloc_expr
= gfc_finish_block (&realloc_block
);
8085 /* Only reallocate if sizes are different. */
8086 tmp
= build3_v (COND_EXPR
, neq_size
, realloc_expr
,
8087 build_empty_stmt (input_location
));
8091 /* Malloc expression. */
8092 gfc_init_block (&alloc_block
);
8093 tmp
= build_call_expr_loc (input_location
,
8094 builtin_decl_explicit (BUILT_IN_MALLOC
),
8096 gfc_conv_descriptor_data_set (&alloc_block
,
8098 tmp
= gfc_conv_descriptor_dtype (desc
);
8099 gfc_add_modify (&alloc_block
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
8100 alloc_expr
= gfc_finish_block (&alloc_block
);
8102 /* Malloc if not allocated; realloc otherwise. */
8103 tmp
= build_int_cst (TREE_TYPE (array1
), 0);
8104 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
8107 tmp
= build3_v (COND_EXPR
, cond
, alloc_expr
, realloc_expr
);
8108 gfc_add_expr_to_block (&fblock
, tmp
);
8110 /* Make sure that the scalarizer data pointer is updated. */
8112 && TREE_CODE (linfo
->data
) == VAR_DECL
)
8114 tmp
= gfc_conv_descriptor_data_get (desc
);
8115 gfc_add_modify (&fblock
, linfo
->data
, tmp
);
8118 /* Add the exit label. */
8119 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
8120 gfc_add_expr_to_block (&fblock
, tmp
);
8122 return gfc_finish_block (&fblock
);
8126 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
8127 Do likewise, recursively if necessary, with the allocatable components of
8131 gfc_trans_deferred_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
8137 stmtblock_t cleanup
;
8140 bool sym_has_alloc_comp
;
8142 sym_has_alloc_comp
= (sym
->ts
.type
== BT_DERIVED
8143 || sym
->ts
.type
== BT_CLASS
)
8144 && sym
->ts
.u
.derived
->attr
.alloc_comp
;
8146 /* Make sure the frontend gets these right. */
8147 if (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym_has_alloc_comp
))
8148 fatal_error ("Possible front-end bug: Deferred array size without pointer, "
8149 "allocatable attribute or derived type without allocatable "
8152 gfc_save_backend_locus (&loc
);
8153 gfc_set_backend_locus (&sym
->declared_at
);
8154 gfc_init_block (&init
);
8156 gcc_assert (TREE_CODE (sym
->backend_decl
) == VAR_DECL
8157 || TREE_CODE (sym
->backend_decl
) == PARM_DECL
);
8159 if (sym
->ts
.type
== BT_CHARACTER
8160 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
8162 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
8163 gfc_trans_vla_type_sizes (sym
, &init
);
8166 /* Dummy, use associated and result variables don't need anything special. */
8167 if (sym
->attr
.dummy
|| sym
->attr
.use_assoc
|| sym
->attr
.result
)
8169 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
8170 gfc_restore_backend_locus (&loc
);
8174 descriptor
= sym
->backend_decl
;
8176 /* Although static, derived types with default initializers and
8177 allocatable components must not be nulled wholesale; instead they
8178 are treated component by component. */
8179 if (TREE_STATIC (descriptor
) && !sym_has_alloc_comp
)
8181 /* SAVEd variables are not freed on exit. */
8182 gfc_trans_static_array_pointer (sym
);
8184 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
8185 gfc_restore_backend_locus (&loc
);
8189 /* Get the descriptor type. */
8190 type
= TREE_TYPE (sym
->backend_decl
);
8192 if (sym_has_alloc_comp
&& !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
8195 && !(TREE_STATIC (sym
->backend_decl
) && sym
->attr
.is_main_program
))
8197 if (sym
->value
== NULL
8198 || !gfc_has_default_initializer (sym
->ts
.u
.derived
))
8200 rank
= sym
->as
? sym
->as
->rank
: 0;
8201 tmp
= gfc_nullify_alloc_comp (sym
->ts
.u
.derived
,
8203 gfc_add_expr_to_block (&init
, tmp
);
8206 gfc_init_default_dt (sym
, &init
, false);
8209 else if (!GFC_DESCRIPTOR_TYPE_P (type
))
8211 /* If the backend_decl is not a descriptor, we must have a pointer
8213 descriptor
= build_fold_indirect_ref_loc (input_location
,
8215 type
= TREE_TYPE (descriptor
);
8218 /* NULLIFY the data pointer. */
8219 if (GFC_DESCRIPTOR_TYPE_P (type
) && !sym
->attr
.save
)
8220 gfc_conv_descriptor_data_set (&init
, descriptor
, null_pointer_node
);
8222 gfc_restore_backend_locus (&loc
);
8223 gfc_init_block (&cleanup
);
8225 /* Allocatable arrays need to be freed when they go out of scope.
8226 The allocatable components of pointers must not be touched. */
8227 if (sym_has_alloc_comp
&& !(sym
->attr
.function
|| sym
->attr
.result
)
8228 && !sym
->attr
.pointer
&& !sym
->attr
.save
)
8231 rank
= sym
->as
? sym
->as
->rank
: 0;
8232 tmp
= gfc_deallocate_alloc_comp (sym
->ts
.u
.derived
, descriptor
, rank
);
8233 gfc_add_expr_to_block (&cleanup
, tmp
);
8236 if (sym
->attr
.allocatable
&& (sym
->attr
.dimension
|| sym
->attr
.codimension
)
8237 && !sym
->attr
.save
&& !sym
->attr
.result
)
8239 tmp
= gfc_trans_dealloc_allocated (sym
->backend_decl
,
8240 sym
->attr
.codimension
);
8241 gfc_add_expr_to_block (&cleanup
, tmp
);
8244 gfc_add_init_cleanup (block
, gfc_finish_block (&init
),
8245 gfc_finish_block (&cleanup
));
8248 /************ Expression Walking Functions ******************/
8250 /* Walk a variable reference.
8252 Possible extension - multiple component subscripts.
8253 x(:,:) = foo%a(:)%b(:)
8255 forall (i=..., j=...)
8256 x(i,j) = foo%a(j)%b(i)
8258 This adds a fair amount of complexity because you need to deal with more
8259 than one ref. Maybe handle in a similar manner to vector subscripts.
8260 Maybe not worth the effort. */
8264 gfc_walk_variable_expr (gfc_ss
* ss
, gfc_expr
* expr
)
8268 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
8269 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
8272 return gfc_walk_array_ref (ss
, expr
, ref
);
8277 gfc_walk_array_ref (gfc_ss
* ss
, gfc_expr
* expr
, gfc_ref
* ref
)
8283 for (; ref
; ref
= ref
->next
)
8285 if (ref
->type
== REF_SUBSTRING
)
8287 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.start
);
8288 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.end
);
8291 /* We're only interested in array sections from now on. */
8292 if (ref
->type
!= REF_ARRAY
)
8300 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
8301 ss
= gfc_get_scalar_ss (ss
, ar
->start
[n
]);
8305 newss
= gfc_get_array_ss (ss
, expr
, ar
->as
->rank
, GFC_SS_SECTION
);
8306 newss
->info
->data
.array
.ref
= ref
;
8308 /* Make sure array is the same as array(:,:), this way
8309 we don't need to special case all the time. */
8310 ar
->dimen
= ar
->as
->rank
;
8311 for (n
= 0; n
< ar
->dimen
; n
++)
8313 ar
->dimen_type
[n
] = DIMEN_RANGE
;
8315 gcc_assert (ar
->start
[n
] == NULL
);
8316 gcc_assert (ar
->end
[n
] == NULL
);
8317 gcc_assert (ar
->stride
[n
] == NULL
);
8323 newss
= gfc_get_array_ss (ss
, expr
, 0, GFC_SS_SECTION
);
8324 newss
->info
->data
.array
.ref
= ref
;
8326 /* We add SS chains for all the subscripts in the section. */
8327 for (n
= 0; n
< ar
->dimen
; n
++)
8331 switch (ar
->dimen_type
[n
])
8334 /* Add SS for elemental (scalar) subscripts. */
8335 gcc_assert (ar
->start
[n
]);
8336 indexss
= gfc_get_scalar_ss (gfc_ss_terminator
, ar
->start
[n
]);
8337 indexss
->loop_chain
= gfc_ss_terminator
;
8338 newss
->info
->data
.array
.subscript
[n
] = indexss
;
8342 /* We don't add anything for sections, just remember this
8343 dimension for later. */
8344 newss
->dim
[newss
->dimen
] = n
;
8349 /* Create a GFC_SS_VECTOR index in which we can store
8350 the vector's descriptor. */
8351 indexss
= gfc_get_array_ss (gfc_ss_terminator
, ar
->start
[n
],
8353 indexss
->loop_chain
= gfc_ss_terminator
;
8354 newss
->info
->data
.array
.subscript
[n
] = indexss
;
8355 newss
->dim
[newss
->dimen
] = n
;
8360 /* We should know what sort of section it is by now. */
8364 /* We should have at least one non-elemental dimension,
8365 unless we are creating a descriptor for a (scalar) coarray. */
8366 gcc_assert (newss
->dimen
> 0
8367 || newss
->info
->data
.array
.ref
->u
.ar
.as
->corank
> 0);
8372 /* We should know what sort of section it is by now. */
8381 /* Walk an expression operator. If only one operand of a binary expression is
8382 scalar, we must also add the scalar term to the SS chain. */
8385 gfc_walk_op_expr (gfc_ss
* ss
, gfc_expr
* expr
)
8390 head
= gfc_walk_subexpr (ss
, expr
->value
.op
.op1
);
8391 if (expr
->value
.op
.op2
== NULL
)
8394 head2
= gfc_walk_subexpr (head
, expr
->value
.op
.op2
);
8396 /* All operands are scalar. Pass back and let the caller deal with it. */
8400 /* All operands require scalarization. */
8401 if (head
!= ss
&& (expr
->value
.op
.op2
== NULL
|| head2
!= head
))
8404 /* One of the operands needs scalarization, the other is scalar.
8405 Create a gfc_ss for the scalar expression. */
8408 /* First operand is scalar. We build the chain in reverse order, so
8409 add the scalar SS after the second operand. */
8411 while (head
&& head
->next
!= ss
)
8413 /* Check we haven't somehow broken the chain. */
8415 head
->next
= gfc_get_scalar_ss (ss
, expr
->value
.op
.op1
);
8417 else /* head2 == head */
8419 gcc_assert (head2
== head
);
8420 /* Second operand is scalar. */
8421 head2
= gfc_get_scalar_ss (head2
, expr
->value
.op
.op2
);
8428 /* Reverse a SS chain. */
8431 gfc_reverse_ss (gfc_ss
* ss
)
8436 gcc_assert (ss
!= NULL
);
8438 head
= gfc_ss_terminator
;
8439 while (ss
!= gfc_ss_terminator
)
8442 /* Check we didn't somehow break the chain. */
8443 gcc_assert (next
!= NULL
);
8453 /* Given an expression refering to a procedure, return the symbol of its
8454 interface. We can't get the procedure symbol directly as we have to handle
8455 the case of (deferred) type-bound procedures. */
8458 gfc_get_proc_ifc_for_expr (gfc_expr
*procedure_ref
)
8463 if (procedure_ref
== NULL
)
8466 /* Normal procedure case. */
8467 sym
= procedure_ref
->symtree
->n
.sym
;
8469 /* Typebound procedure case. */
8470 for (ref
= procedure_ref
->ref
; ref
; ref
= ref
->next
)
8472 if (ref
->type
== REF_COMPONENT
8473 && ref
->u
.c
.component
->attr
.proc_pointer
)
8474 sym
= ref
->u
.c
.component
->ts
.interface
;
8483 /* Walk the arguments of an elemental function.
8484 PROC_EXPR is used to check whether an argument is permitted to be absent. If
8485 it is NULL, we don't do the check and the argument is assumed to be present.
8489 gfc_walk_elemental_function_args (gfc_ss
* ss
, gfc_actual_arglist
*arg
,
8490 gfc_symbol
*proc_ifc
, gfc_ss_type type
)
8492 gfc_formal_arglist
*dummy_arg
;
8498 head
= gfc_ss_terminator
;
8502 dummy_arg
= proc_ifc
->formal
;
8507 for (; arg
; arg
= arg
->next
)
8509 if (!arg
->expr
|| arg
->expr
->expr_type
== EXPR_NULL
)
8512 newss
= gfc_walk_subexpr (head
, arg
->expr
);
8515 /* Scalar argument. */
8516 gcc_assert (type
== GFC_SS_SCALAR
|| type
== GFC_SS_REFERENCE
);
8517 newss
= gfc_get_scalar_ss (head
, arg
->expr
);
8518 newss
->info
->type
= type
;
8524 if (dummy_arg
!= NULL
8525 && dummy_arg
->sym
->attr
.optional
8526 && arg
->expr
->expr_type
== EXPR_VARIABLE
8527 && (gfc_expr_attr (arg
->expr
).optional
8528 || gfc_expr_attr (arg
->expr
).allocatable
8529 || gfc_expr_attr (arg
->expr
).pointer
))
8530 newss
->info
->can_be_null_ref
= true;
8536 while (tail
->next
!= gfc_ss_terminator
)
8540 if (dummy_arg
!= NULL
)
8541 dummy_arg
= dummy_arg
->next
;
8546 /* If all the arguments are scalar we don't need the argument SS. */
8547 gfc_free_ss_chain (head
);
8552 /* Add it onto the existing chain. */
8558 /* Walk a function call. Scalar functions are passed back, and taken out of
8559 scalarization loops. For elemental functions we walk their arguments.
8560 The result of functions returning arrays is stored in a temporary outside
8561 the loop, so that the function is only called once. Hence we do not need
8562 to walk their arguments. */
8565 gfc_walk_function_expr (gfc_ss
* ss
, gfc_expr
* expr
)
8567 gfc_intrinsic_sym
*isym
;
8569 gfc_component
*comp
= NULL
;
8571 isym
= expr
->value
.function
.isym
;
8573 /* Handle intrinsic functions separately. */
8575 return gfc_walk_intrinsic_function (ss
, expr
, isym
);
8577 sym
= expr
->value
.function
.esym
;
8579 sym
= expr
->symtree
->n
.sym
;
8581 /* A function that returns arrays. */
8582 gfc_is_proc_ptr_comp (expr
, &comp
);
8583 if ((!comp
&& gfc_return_by_reference (sym
) && sym
->result
->attr
.dimension
)
8584 || (comp
&& comp
->attr
.dimension
))
8585 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
8587 /* Walk the parameters of an elemental function. For now we always pass
8589 if (sym
->attr
.elemental
|| (comp
&& comp
->attr
.elemental
))
8590 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
8591 gfc_get_proc_ifc_for_expr (expr
),
8594 /* Scalar functions are OK as these are evaluated outside the scalarization
8595 loop. Pass back and let the caller deal with it. */
8600 /* An array temporary is constructed for array constructors. */
8603 gfc_walk_array_constructor (gfc_ss
* ss
, gfc_expr
* expr
)
8605 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_CONSTRUCTOR
);
8609 /* Walk an expression. Add walked expressions to the head of the SS chain.
8610 A wholly scalar expression will not be added. */
8613 gfc_walk_subexpr (gfc_ss
* ss
, gfc_expr
* expr
)
8617 switch (expr
->expr_type
)
8620 head
= gfc_walk_variable_expr (ss
, expr
);
8624 head
= gfc_walk_op_expr (ss
, expr
);
8628 head
= gfc_walk_function_expr (ss
, expr
);
8633 case EXPR_STRUCTURE
:
8634 /* Pass back and let the caller deal with it. */
8638 head
= gfc_walk_array_constructor (ss
, expr
);
8641 case EXPR_SUBSTRING
:
8642 /* Pass back and let the caller deal with it. */
8646 internal_error ("bad expression type during walk (%d)",
8653 /* Entry point for expression walking.
8654 A return value equal to the passed chain means this is
8655 a scalar expression. It is up to the caller to take whatever action is
8656 necessary to translate these. */
8659 gfc_walk_expr (gfc_expr
* expr
)
8663 res
= gfc_walk_subexpr (gfc_ss_terminator
, expr
);
8664 return gfc_reverse_ss (res
);