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 PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
975 gfc_trans_allocate_array_storage. */
978 gfc_trans_create_temp_array (stmtblock_t
* pre
, stmtblock_t
* post
, gfc_ss
* ss
,
979 tree eltype
, tree initial
, bool dynamic
,
980 bool dealloc
, bool callee_alloc
, locus
* where
)
984 gfc_array_info
*info
;
985 tree from
[GFC_MAX_DIMENSIONS
], to
[GFC_MAX_DIMENSIONS
];
996 memset (from
, 0, sizeof (from
));
997 memset (to
, 0, sizeof (to
));
999 info
= &ss
->info
->data
.array
;
1001 gcc_assert (ss
->dimen
> 0);
1002 gcc_assert (ss
->loop
->dimen
== ss
->dimen
);
1004 if (gfc_option
.warn_array_temp
&& where
)
1005 gfc_warning ("Creating array temporary at %L", where
);
1007 /* Set the lower bound to zero. */
1008 for (s
= ss
; s
; s
= s
->parent
)
1012 total_dim
+= loop
->dimen
;
1013 for (n
= 0; n
< loop
->dimen
; n
++)
1017 /* Callee allocated arrays may not have a known bound yet. */
1019 loop
->to
[n
] = gfc_evaluate_now (
1020 fold_build2_loc (input_location
, MINUS_EXPR
,
1021 gfc_array_index_type
,
1022 loop
->to
[n
], loop
->from
[n
]),
1024 loop
->from
[n
] = gfc_index_zero_node
;
1026 /* We have just changed the loop bounds, we must clear the
1027 corresponding specloop, so that delta calculation is not skipped
1028 later in gfc_set_delta. */
1029 loop
->specloop
[n
] = NULL
;
1031 /* We are constructing the temporary's descriptor based on the loop
1032 dimensions. As the dimensions may be accessed in arbitrary order
1033 (think of transpose) the size taken from the n'th loop may not map
1034 to the n'th dimension of the array. We need to reconstruct loop
1035 infos in the right order before using it to set the descriptor
1037 tmp_dim
= get_scalarizer_dim_for_array_dim (ss
, dim
);
1038 from
[tmp_dim
] = loop
->from
[n
];
1039 to
[tmp_dim
] = loop
->to
[n
];
1041 info
->delta
[dim
] = gfc_index_zero_node
;
1042 info
->start
[dim
] = gfc_index_zero_node
;
1043 info
->end
[dim
] = gfc_index_zero_node
;
1044 info
->stride
[dim
] = gfc_index_one_node
;
1048 /* Initialize the descriptor. */
1050 gfc_get_array_type_bounds (eltype
, total_dim
, 0, from
, to
, 1,
1051 GFC_ARRAY_UNKNOWN
, true);
1052 desc
= gfc_create_var (type
, "atmp");
1053 GFC_DECL_PACKED_ARRAY (desc
) = 1;
1055 info
->descriptor
= desc
;
1056 size
= gfc_index_one_node
;
1058 /* Fill in the array dtype. */
1059 tmp
= gfc_conv_descriptor_dtype (desc
);
1060 gfc_add_modify (pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
1063 Fill in the bounds and stride. This is a packed array, so:
1066 for (n = 0; n < rank; n++)
1069 delta = ubound[n] + 1 - lbound[n];
1070 size = size * delta;
1072 size = size * sizeof(element);
1075 or_expr
= NULL_TREE
;
1077 /* If there is at least one null loop->to[n], it is a callee allocated
1079 for (n
= 0; n
< total_dim
; n
++)
1080 if (to
[n
] == NULL_TREE
)
1086 if (size
== NULL_TREE
)
1087 for (s
= ss
; s
; s
= s
->parent
)
1088 for (n
= 0; n
< s
->loop
->dimen
; n
++)
1090 dim
= get_scalarizer_dim_for_array_dim (ss
, ss
->dim
[n
]);
1092 /* For a callee allocated array express the loop bounds in terms
1093 of the descriptor fields. */
1094 tmp
= fold_build2_loc (input_location
,
1095 MINUS_EXPR
, gfc_array_index_type
,
1096 gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]),
1097 gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]));
1098 s
->loop
->to
[n
] = tmp
;
1102 for (n
= 0; n
< total_dim
; n
++)
1104 /* Store the stride and bound components in the descriptor. */
1105 gfc_conv_descriptor_stride_set (pre
, desc
, gfc_rank_cst
[n
], size
);
1107 gfc_conv_descriptor_lbound_set (pre
, desc
, gfc_rank_cst
[n
],
1108 gfc_index_zero_node
);
1110 gfc_conv_descriptor_ubound_set (pre
, desc
, gfc_rank_cst
[n
], to
[n
]);
1112 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1113 gfc_array_index_type
,
1114 to
[n
], gfc_index_one_node
);
1116 /* Check whether the size for this dimension is negative. */
1117 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
1118 tmp
, gfc_index_zero_node
);
1119 cond
= gfc_evaluate_now (cond
, pre
);
1124 or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1125 boolean_type_node
, or_expr
, cond
);
1127 size
= fold_build2_loc (input_location
, MULT_EXPR
,
1128 gfc_array_index_type
, size
, tmp
);
1129 size
= gfc_evaluate_now (size
, pre
);
1133 /* Get the size of the array. */
1134 if (size
&& !callee_alloc
)
1136 /* If or_expr is true, then the extent in at least one
1137 dimension is zero and the size is set to zero. */
1138 size
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
1139 or_expr
, gfc_index_zero_node
, size
);
1142 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
1144 fold_convert (gfc_array_index_type
,
1145 TYPE_SIZE_UNIT (gfc_get_element_type (type
))));
1153 gfc_trans_allocate_array_storage (pre
, post
, info
, size
, nelem
, initial
,
1159 if (ss
->dimen
> ss
->loop
->temp_dim
)
1160 ss
->loop
->temp_dim
= ss
->dimen
;
1166 /* Return the number of iterations in a loop that starts at START,
1167 ends at END, and has step STEP. */
1170 gfc_get_iteration_count (tree start
, tree end
, tree step
)
1175 type
= TREE_TYPE (step
);
1176 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, end
, start
);
1177 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
, type
, tmp
, step
);
1178 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
,
1179 build_int_cst (type
, 1));
1180 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, type
, tmp
,
1181 build_int_cst (type
, 0));
1182 return fold_convert (gfc_array_index_type
, tmp
);
1186 /* Extend the data in array DESC by EXTRA elements. */
1189 gfc_grow_array (stmtblock_t
* pblock
, tree desc
, tree extra
)
1196 if (integer_zerop (extra
))
1199 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[0]);
1201 /* Add EXTRA to the upper bound. */
1202 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1204 gfc_conv_descriptor_ubound_set (pblock
, desc
, gfc_rank_cst
[0], tmp
);
1206 /* Get the value of the current data pointer. */
1207 arg0
= gfc_conv_descriptor_data_get (desc
);
1209 /* Calculate the new array size. */
1210 size
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
1211 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1212 ubound
, gfc_index_one_node
);
1213 arg1
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
1214 fold_convert (size_type_node
, tmp
),
1215 fold_convert (size_type_node
, size
));
1217 /* Call the realloc() function. */
1218 tmp
= gfc_call_realloc (pblock
, arg0
, arg1
);
1219 gfc_conv_descriptor_data_set (pblock
, desc
, tmp
);
1223 /* Return true if the bounds of iterator I can only be determined
1227 gfc_iterator_has_dynamic_bounds (gfc_iterator
* i
)
1229 return (i
->start
->expr_type
!= EXPR_CONSTANT
1230 || i
->end
->expr_type
!= EXPR_CONSTANT
1231 || i
->step
->expr_type
!= EXPR_CONSTANT
);
1235 /* Split the size of constructor element EXPR into the sum of two terms,
1236 one of which can be determined at compile time and one of which must
1237 be calculated at run time. Set *SIZE to the former and return true
1238 if the latter might be nonzero. */
1241 gfc_get_array_constructor_element_size (mpz_t
* size
, gfc_expr
* expr
)
1243 if (expr
->expr_type
== EXPR_ARRAY
)
1244 return gfc_get_array_constructor_size (size
, expr
->value
.constructor
);
1245 else if (expr
->rank
> 0)
1247 /* Calculate everything at run time. */
1248 mpz_set_ui (*size
, 0);
1253 /* A single element. */
1254 mpz_set_ui (*size
, 1);
1260 /* Like gfc_get_array_constructor_element_size, but applied to the whole
1261 of array constructor C. */
1264 gfc_get_array_constructor_size (mpz_t
* size
, gfc_constructor_base base
)
1272 mpz_set_ui (*size
, 0);
1277 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1280 if (i
&& gfc_iterator_has_dynamic_bounds (i
))
1284 dynamic
|= gfc_get_array_constructor_element_size (&len
, c
->expr
);
1287 /* Multiply the static part of the element size by the
1288 number of iterations. */
1289 mpz_sub (val
, i
->end
->value
.integer
, i
->start
->value
.integer
);
1290 mpz_fdiv_q (val
, val
, i
->step
->value
.integer
);
1291 mpz_add_ui (val
, val
, 1);
1292 if (mpz_sgn (val
) > 0)
1293 mpz_mul (len
, len
, val
);
1295 mpz_set_ui (len
, 0);
1297 mpz_add (*size
, *size
, len
);
1306 /* Make sure offset is a variable. */
1309 gfc_put_offset_into_var (stmtblock_t
* pblock
, tree
* poffset
,
1312 /* We should have already created the offset variable. We cannot
1313 create it here because we may be in an inner scope. */
1314 gcc_assert (*offsetvar
!= NULL_TREE
);
1315 gfc_add_modify (pblock
, *offsetvar
, *poffset
);
1316 *poffset
= *offsetvar
;
1317 TREE_USED (*offsetvar
) = 1;
1321 /* Variables needed for bounds-checking. */
1322 static bool first_len
;
1323 static tree first_len_val
;
1324 static bool typespec_chararray_ctor
;
1327 gfc_trans_array_ctor_element (stmtblock_t
* pblock
, tree desc
,
1328 tree offset
, gfc_se
* se
, gfc_expr
* expr
)
1332 gfc_conv_expr (se
, expr
);
1334 /* Store the value. */
1335 tmp
= build_fold_indirect_ref_loc (input_location
,
1336 gfc_conv_descriptor_data_get (desc
));
1337 tmp
= gfc_build_array_ref (tmp
, offset
, NULL
);
1339 if (expr
->ts
.type
== BT_CHARACTER
)
1341 int i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
1344 esize
= size_in_bytes (gfc_get_element_type (TREE_TYPE (desc
)));
1345 esize
= fold_convert (gfc_charlen_type_node
, esize
);
1346 esize
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1347 gfc_charlen_type_node
, esize
,
1348 build_int_cst (gfc_charlen_type_node
,
1349 gfc_character_kinds
[i
].bit_size
/ 8));
1351 gfc_conv_string_parameter (se
);
1352 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
1354 /* The temporary is an array of pointers. */
1355 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1356 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1360 /* The temporary is an array of string values. */
1361 tmp
= gfc_build_addr_expr (gfc_get_pchar_type (expr
->ts
.kind
), tmp
);
1362 /* We know the temporary and the value will be the same length,
1363 so can use memcpy. */
1364 gfc_trans_string_copy (&se
->pre
, esize
, tmp
, expr
->ts
.kind
,
1365 se
->string_length
, se
->expr
, expr
->ts
.kind
);
1367 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && !typespec_chararray_ctor
)
1371 gfc_add_modify (&se
->pre
, first_len_val
,
1377 /* Verify that all constructor elements are of the same
1379 tree cond
= fold_build2_loc (input_location
, NE_EXPR
,
1380 boolean_type_node
, first_len_val
,
1382 gfc_trans_runtime_check
1383 (true, false, cond
, &se
->pre
, &expr
->where
,
1384 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1385 fold_convert (long_integer_type_node
, first_len_val
),
1386 fold_convert (long_integer_type_node
, se
->string_length
));
1392 /* TODO: Should the frontend already have done this conversion? */
1393 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1394 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1397 gfc_add_block_to_block (pblock
, &se
->pre
);
1398 gfc_add_block_to_block (pblock
, &se
->post
);
1402 /* Add the contents of an array to the constructor. DYNAMIC is as for
1403 gfc_trans_array_constructor_value. */
1406 gfc_trans_array_constructor_subarray (stmtblock_t
* pblock
,
1407 tree type ATTRIBUTE_UNUSED
,
1408 tree desc
, gfc_expr
* expr
,
1409 tree
* poffset
, tree
* offsetvar
,
1420 /* We need this to be a variable so we can increment it. */
1421 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1423 gfc_init_se (&se
, NULL
);
1425 /* Walk the array expression. */
1426 ss
= gfc_walk_expr (expr
);
1427 gcc_assert (ss
!= gfc_ss_terminator
);
1429 /* Initialize the scalarizer. */
1430 gfc_init_loopinfo (&loop
);
1431 gfc_add_ss_to_loop (&loop
, ss
);
1433 /* Initialize the loop. */
1434 gfc_conv_ss_startstride (&loop
);
1435 gfc_conv_loop_setup (&loop
, &expr
->where
);
1437 /* Make sure the constructed array has room for the new data. */
1440 /* Set SIZE to the total number of elements in the subarray. */
1441 size
= gfc_index_one_node
;
1442 for (n
= 0; n
< loop
.dimen
; n
++)
1444 tmp
= gfc_get_iteration_count (loop
.from
[n
], loop
.to
[n
],
1445 gfc_index_one_node
);
1446 size
= fold_build2_loc (input_location
, MULT_EXPR
,
1447 gfc_array_index_type
, size
, tmp
);
1450 /* Grow the constructed array by SIZE elements. */
1451 gfc_grow_array (&loop
.pre
, desc
, size
);
1454 /* Make the loop body. */
1455 gfc_mark_ss_chain_used (ss
, 1);
1456 gfc_start_scalarized_body (&loop
, &body
);
1457 gfc_copy_loopinfo_to_se (&se
, &loop
);
1460 gfc_trans_array_ctor_element (&body
, desc
, *poffset
, &se
, expr
);
1461 gcc_assert (se
.ss
== gfc_ss_terminator
);
1463 /* Increment the offset. */
1464 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1465 *poffset
, gfc_index_one_node
);
1466 gfc_add_modify (&body
, *poffset
, tmp
);
1468 /* Finish the loop. */
1469 gfc_trans_scalarizing_loops (&loop
, &body
);
1470 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
1471 tmp
= gfc_finish_block (&loop
.pre
);
1472 gfc_add_expr_to_block (pblock
, tmp
);
1474 gfc_cleanup_loop (&loop
);
1478 /* Assign the values to the elements of an array constructor. DYNAMIC
1479 is true if descriptor DESC only contains enough data for the static
1480 size calculated by gfc_get_array_constructor_size. When true, memory
1481 for the dynamic parts must be allocated using realloc. */
1484 gfc_trans_array_constructor_value (stmtblock_t
* pblock
, tree type
,
1485 tree desc
, gfc_constructor_base base
,
1486 tree
* poffset
, tree
* offsetvar
,
1495 tree shadow_loopvar
= NULL_TREE
;
1496 gfc_saved_var saved_loopvar
;
1499 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1501 /* If this is an iterator or an array, the offset must be a variable. */
1502 if ((c
->iterator
|| c
->expr
->rank
> 0) && INTEGER_CST_P (*poffset
))
1503 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1505 /* Shadowing the iterator avoids changing its value and saves us from
1506 keeping track of it. Further, it makes sure that there's always a
1507 backend-decl for the symbol, even if there wasn't one before,
1508 e.g. in the case of an iterator that appears in a specification
1509 expression in an interface mapping. */
1512 gfc_symbol
*sym
= c
->iterator
->var
->symtree
->n
.sym
;
1513 tree type
= gfc_typenode_for_spec (&sym
->ts
);
1515 shadow_loopvar
= gfc_create_var (type
, "shadow_loopvar");
1516 gfc_shadow_sym (sym
, shadow_loopvar
, &saved_loopvar
);
1519 gfc_start_block (&body
);
1521 if (c
->expr
->expr_type
== EXPR_ARRAY
)
1523 /* Array constructors can be nested. */
1524 gfc_trans_array_constructor_value (&body
, type
, desc
,
1525 c
->expr
->value
.constructor
,
1526 poffset
, offsetvar
, dynamic
);
1528 else if (c
->expr
->rank
> 0)
1530 gfc_trans_array_constructor_subarray (&body
, type
, desc
, c
->expr
,
1531 poffset
, offsetvar
, dynamic
);
1535 /* This code really upsets the gimplifier so don't bother for now. */
1542 while (p
&& !(p
->iterator
|| p
->expr
->expr_type
!= EXPR_CONSTANT
))
1544 p
= gfc_constructor_next (p
);
1549 /* Scalar values. */
1550 gfc_init_se (&se
, NULL
);
1551 gfc_trans_array_ctor_element (&body
, desc
, *poffset
,
1554 *poffset
= fold_build2_loc (input_location
, PLUS_EXPR
,
1555 gfc_array_index_type
,
1556 *poffset
, gfc_index_one_node
);
1560 /* Collect multiple scalar constants into a constructor. */
1561 VEC(constructor_elt
,gc
) *v
= NULL
;
1565 HOST_WIDE_INT idx
= 0;
1568 /* Count the number of consecutive scalar constants. */
1569 while (p
&& !(p
->iterator
1570 || p
->expr
->expr_type
!= EXPR_CONSTANT
))
1572 gfc_init_se (&se
, NULL
);
1573 gfc_conv_constant (&se
, p
->expr
);
1575 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
1576 se
.expr
= fold_convert (type
, se
.expr
);
1577 /* For constant character array constructors we build
1578 an array of pointers. */
1579 else if (POINTER_TYPE_P (type
))
1580 se
.expr
= gfc_build_addr_expr
1581 (gfc_get_pchar_type (p
->expr
->ts
.kind
),
1584 CONSTRUCTOR_APPEND_ELT (v
,
1585 build_int_cst (gfc_array_index_type
,
1589 p
= gfc_constructor_next (p
);
1592 bound
= size_int (n
- 1);
1593 /* Create an array type to hold them. */
1594 tmptype
= build_range_type (gfc_array_index_type
,
1595 gfc_index_zero_node
, bound
);
1596 tmptype
= build_array_type (type
, tmptype
);
1598 init
= build_constructor (tmptype
, v
);
1599 TREE_CONSTANT (init
) = 1;
1600 TREE_STATIC (init
) = 1;
1601 /* Create a static variable to hold the data. */
1602 tmp
= gfc_create_var (tmptype
, "data");
1603 TREE_STATIC (tmp
) = 1;
1604 TREE_CONSTANT (tmp
) = 1;
1605 TREE_READONLY (tmp
) = 1;
1606 DECL_INITIAL (tmp
) = init
;
1609 /* Use BUILTIN_MEMCPY to assign the values. */
1610 tmp
= gfc_conv_descriptor_data_get (desc
);
1611 tmp
= build_fold_indirect_ref_loc (input_location
,
1613 tmp
= gfc_build_array_ref (tmp
, *poffset
, NULL
);
1614 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1615 init
= gfc_build_addr_expr (NULL_TREE
, init
);
1617 size
= TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type
));
1618 bound
= build_int_cst (size_type_node
, n
* size
);
1619 tmp
= build_call_expr_loc (input_location
,
1620 builtin_decl_explicit (BUILT_IN_MEMCPY
),
1621 3, tmp
, init
, bound
);
1622 gfc_add_expr_to_block (&body
, tmp
);
1624 *poffset
= fold_build2_loc (input_location
, PLUS_EXPR
,
1625 gfc_array_index_type
, *poffset
,
1626 build_int_cst (gfc_array_index_type
, n
));
1628 if (!INTEGER_CST_P (*poffset
))
1630 gfc_add_modify (&body
, *offsetvar
, *poffset
);
1631 *poffset
= *offsetvar
;
1635 /* The frontend should already have done any expansions
1639 /* Pass the code as is. */
1640 tmp
= gfc_finish_block (&body
);
1641 gfc_add_expr_to_block (pblock
, tmp
);
1645 /* Build the implied do-loop. */
1646 stmtblock_t implied_do_block
;
1654 loopbody
= gfc_finish_block (&body
);
1656 /* Create a new block that holds the implied-do loop. A temporary
1657 loop-variable is used. */
1658 gfc_start_block(&implied_do_block
);
1660 /* Initialize the loop. */
1661 gfc_init_se (&se
, NULL
);
1662 gfc_conv_expr_val (&se
, c
->iterator
->start
);
1663 gfc_add_block_to_block (&implied_do_block
, &se
.pre
);
1664 gfc_add_modify (&implied_do_block
, shadow_loopvar
, se
.expr
);
1666 gfc_init_se (&se
, NULL
);
1667 gfc_conv_expr_val (&se
, c
->iterator
->end
);
1668 gfc_add_block_to_block (&implied_do_block
, &se
.pre
);
1669 end
= gfc_evaluate_now (se
.expr
, &implied_do_block
);
1671 gfc_init_se (&se
, NULL
);
1672 gfc_conv_expr_val (&se
, c
->iterator
->step
);
1673 gfc_add_block_to_block (&implied_do_block
, &se
.pre
);
1674 step
= gfc_evaluate_now (se
.expr
, &implied_do_block
);
1676 /* If this array expands dynamically, and the number of iterations
1677 is not constant, we won't have allocated space for the static
1678 part of C->EXPR's size. Do that now. */
1679 if (dynamic
&& gfc_iterator_has_dynamic_bounds (c
->iterator
))
1681 /* Get the number of iterations. */
1682 tmp
= gfc_get_iteration_count (shadow_loopvar
, end
, step
);
1684 /* Get the static part of C->EXPR's size. */
1685 gfc_get_array_constructor_element_size (&size
, c
->expr
);
1686 tmp2
= gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
1688 /* Grow the array by TMP * TMP2 elements. */
1689 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
1690 gfc_array_index_type
, tmp
, tmp2
);
1691 gfc_grow_array (&implied_do_block
, desc
, tmp
);
1694 /* Generate the loop body. */
1695 exit_label
= gfc_build_label_decl (NULL_TREE
);
1696 gfc_start_block (&body
);
1698 /* Generate the exit condition. Depending on the sign of
1699 the step variable we have to generate the correct
1701 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1702 step
, build_int_cst (TREE_TYPE (step
), 0));
1703 cond
= fold_build3_loc (input_location
, COND_EXPR
,
1704 boolean_type_node
, tmp
,
1705 fold_build2_loc (input_location
, GT_EXPR
,
1706 boolean_type_node
, shadow_loopvar
, end
),
1707 fold_build2_loc (input_location
, LT_EXPR
,
1708 boolean_type_node
, shadow_loopvar
, end
));
1709 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1710 TREE_USED (exit_label
) = 1;
1711 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
1712 build_empty_stmt (input_location
));
1713 gfc_add_expr_to_block (&body
, tmp
);
1715 /* The main loop body. */
1716 gfc_add_expr_to_block (&body
, loopbody
);
1718 /* Increase loop variable by step. */
1719 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1720 TREE_TYPE (shadow_loopvar
), shadow_loopvar
,
1722 gfc_add_modify (&body
, shadow_loopvar
, tmp
);
1724 /* Finish the loop. */
1725 tmp
= gfc_finish_block (&body
);
1726 tmp
= build1_v (LOOP_EXPR
, tmp
);
1727 gfc_add_expr_to_block (&implied_do_block
, tmp
);
1729 /* Add the exit label. */
1730 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1731 gfc_add_expr_to_block (&implied_do_block
, tmp
);
1733 /* Finishe the implied-do loop. */
1734 tmp
= gfc_finish_block(&implied_do_block
);
1735 gfc_add_expr_to_block(pblock
, tmp
);
1737 gfc_restore_sym (c
->iterator
->var
->symtree
->n
.sym
, &saved_loopvar
);
1744 /* A catch-all to obtain the string length for anything that is not a
1745 a substring of non-constant length, a constant, array or variable. */
1748 get_array_ctor_all_strlen (stmtblock_t
*block
, gfc_expr
*e
, tree
*len
)
1753 /* Don't bother if we already know the length is a constant. */
1754 if (*len
&& INTEGER_CST_P (*len
))
1757 if (!e
->ref
&& e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
1758 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1761 gfc_conv_const_charlen (e
->ts
.u
.cl
);
1762 *len
= e
->ts
.u
.cl
->backend_decl
;
1766 /* Otherwise, be brutal even if inefficient. */
1767 ss
= gfc_walk_expr (e
);
1768 gfc_init_se (&se
, NULL
);
1770 /* No function call, in case of side effects. */
1771 se
.no_function_call
= 1;
1772 if (ss
== gfc_ss_terminator
)
1773 gfc_conv_expr (&se
, e
);
1775 gfc_conv_expr_descriptor (&se
, e
, ss
);
1777 /* Fix the value. */
1778 *len
= gfc_evaluate_now (se
.string_length
, &se
.pre
);
1780 gfc_add_block_to_block (block
, &se
.pre
);
1781 gfc_add_block_to_block (block
, &se
.post
);
1783 e
->ts
.u
.cl
->backend_decl
= *len
;
1788 /* Figure out the string length of a variable reference expression.
1789 Used by get_array_ctor_strlen. */
1792 get_array_ctor_var_strlen (stmtblock_t
*block
, gfc_expr
* expr
, tree
* len
)
1798 /* Don't bother if we already know the length is a constant. */
1799 if (*len
&& INTEGER_CST_P (*len
))
1802 ts
= &expr
->symtree
->n
.sym
->ts
;
1803 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1808 /* Array references don't change the string length. */
1812 /* Use the length of the component. */
1813 ts
= &ref
->u
.c
.component
->ts
;
1817 if (ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1818 || ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1820 /* Note that this might evaluate expr. */
1821 get_array_ctor_all_strlen (block
, expr
, len
);
1824 mpz_init_set_ui (char_len
, 1);
1825 mpz_add (char_len
, char_len
, ref
->u
.ss
.end
->value
.integer
);
1826 mpz_sub (char_len
, char_len
, ref
->u
.ss
.start
->value
.integer
);
1827 *len
= gfc_conv_mpz_to_tree (char_len
, gfc_default_integer_kind
);
1828 *len
= convert (gfc_charlen_type_node
, *len
);
1829 mpz_clear (char_len
);
1837 *len
= ts
->u
.cl
->backend_decl
;
1841 /* Figure out the string length of a character array constructor.
1842 If len is NULL, don't calculate the length; this happens for recursive calls
1843 when a sub-array-constructor is an element but not at the first position,
1844 so when we're not interested in the length.
1845 Returns TRUE if all elements are character constants. */
1848 get_array_ctor_strlen (stmtblock_t
*block
, gfc_constructor_base base
, tree
* len
)
1855 if (gfc_constructor_first (base
) == NULL
)
1858 *len
= build_int_cstu (gfc_charlen_type_node
, 0);
1862 /* Loop over all constructor elements to find out is_const, but in len we
1863 want to store the length of the first, not the last, element. We can
1864 of course exit the loop as soon as is_const is found to be false. */
1865 for (c
= gfc_constructor_first (base
);
1866 c
&& is_const
; c
= gfc_constructor_next (c
))
1868 switch (c
->expr
->expr_type
)
1871 if (len
&& !(*len
&& INTEGER_CST_P (*len
)))
1872 *len
= build_int_cstu (gfc_charlen_type_node
,
1873 c
->expr
->value
.character
.length
);
1877 if (!get_array_ctor_strlen (block
, c
->expr
->value
.constructor
, len
))
1884 get_array_ctor_var_strlen (block
, c
->expr
, len
);
1890 get_array_ctor_all_strlen (block
, c
->expr
, len
);
1894 /* After the first iteration, we don't want the length modified. */
1901 /* Check whether the array constructor C consists entirely of constant
1902 elements, and if so returns the number of those elements, otherwise
1903 return zero. Note, an empty or NULL array constructor returns zero. */
1905 unsigned HOST_WIDE_INT
1906 gfc_constant_array_constructor_p (gfc_constructor_base base
)
1908 unsigned HOST_WIDE_INT nelem
= 0;
1910 gfc_constructor
*c
= gfc_constructor_first (base
);
1914 || c
->expr
->rank
> 0
1915 || c
->expr
->expr_type
!= EXPR_CONSTANT
)
1917 c
= gfc_constructor_next (c
);
1924 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1925 and the tree type of it's elements, TYPE, return a static constant
1926 variable that is compile-time initialized. */
1929 gfc_build_constant_array_constructor (gfc_expr
* expr
, tree type
)
1931 tree tmptype
, init
, tmp
;
1932 HOST_WIDE_INT nelem
;
1937 VEC(constructor_elt
,gc
) *v
= NULL
;
1939 /* First traverse the constructor list, converting the constants
1940 to tree to build an initializer. */
1942 c
= gfc_constructor_first (expr
->value
.constructor
);
1945 gfc_init_se (&se
, NULL
);
1946 gfc_conv_constant (&se
, c
->expr
);
1947 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
1948 se
.expr
= fold_convert (type
, se
.expr
);
1949 else if (POINTER_TYPE_P (type
))
1950 se
.expr
= gfc_build_addr_expr (gfc_get_pchar_type (c
->expr
->ts
.kind
),
1952 CONSTRUCTOR_APPEND_ELT (v
, build_int_cst (gfc_array_index_type
, nelem
),
1954 c
= gfc_constructor_next (c
);
1958 /* Next determine the tree type for the array. We use the gfortran
1959 front-end's gfc_get_nodesc_array_type in order to create a suitable
1960 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
1962 memset (&as
, 0, sizeof (gfc_array_spec
));
1964 as
.rank
= expr
->rank
;
1965 as
.type
= AS_EXPLICIT
;
1968 as
.lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
1969 as
.upper
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
1973 for (i
= 0; i
< expr
->rank
; i
++)
1975 int tmp
= (int) mpz_get_si (expr
->shape
[i
]);
1976 as
.lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
1977 as
.upper
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
1981 tmptype
= gfc_get_nodesc_array_type (type
, &as
, PACKED_STATIC
, true);
1983 /* as is not needed anymore. */
1984 for (i
= 0; i
< as
.rank
+ as
.corank
; i
++)
1986 gfc_free_expr (as
.lower
[i
]);
1987 gfc_free_expr (as
.upper
[i
]);
1990 init
= build_constructor (tmptype
, v
);
1992 TREE_CONSTANT (init
) = 1;
1993 TREE_STATIC (init
) = 1;
1995 tmp
= gfc_create_var (tmptype
, "A");
1996 TREE_STATIC (tmp
) = 1;
1997 TREE_CONSTANT (tmp
) = 1;
1998 TREE_READONLY (tmp
) = 1;
1999 DECL_INITIAL (tmp
) = init
;
2005 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
2006 This mostly initializes the scalarizer state info structure with the
2007 appropriate values to directly use the array created by the function
2008 gfc_build_constant_array_constructor. */
2011 trans_constant_array_constructor (gfc_ss
* ss
, tree type
)
2013 gfc_array_info
*info
;
2017 tmp
= gfc_build_constant_array_constructor (ss
->info
->expr
, type
);
2019 info
= &ss
->info
->data
.array
;
2021 info
->descriptor
= tmp
;
2022 info
->data
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2023 info
->offset
= gfc_index_zero_node
;
2025 for (i
= 0; i
< ss
->dimen
; i
++)
2027 info
->delta
[i
] = gfc_index_zero_node
;
2028 info
->start
[i
] = gfc_index_zero_node
;
2029 info
->end
[i
] = gfc_index_zero_node
;
2030 info
->stride
[i
] = gfc_index_one_node
;
2036 get_rank (gfc_loopinfo
*loop
)
2041 for (; loop
; loop
= loop
->parent
)
2042 rank
+= loop
->dimen
;
2048 /* Helper routine of gfc_trans_array_constructor to determine if the
2049 bounds of the loop specified by LOOP are constant and simple enough
2050 to use with trans_constant_array_constructor. Returns the
2051 iteration count of the loop if suitable, and NULL_TREE otherwise. */
2054 constant_array_constructor_loop_size (gfc_loopinfo
* l
)
2057 tree size
= gfc_index_one_node
;
2061 total_dim
= get_rank (l
);
2063 for (loop
= l
; loop
; loop
= loop
->parent
)
2065 for (i
= 0; i
< loop
->dimen
; i
++)
2067 /* If the bounds aren't constant, return NULL_TREE. */
2068 if (!INTEGER_CST_P (loop
->from
[i
]) || !INTEGER_CST_P (loop
->to
[i
]))
2070 if (!integer_zerop (loop
->from
[i
]))
2072 /* Only allow nonzero "from" in one-dimensional arrays. */
2075 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2076 gfc_array_index_type
,
2077 loop
->to
[i
], loop
->from
[i
]);
2081 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2082 gfc_array_index_type
, tmp
, gfc_index_one_node
);
2083 size
= fold_build2_loc (input_location
, MULT_EXPR
,
2084 gfc_array_index_type
, size
, tmp
);
2093 get_loop_upper_bound_for_array (gfc_ss
*array
, int array_dim
)
2098 gcc_assert (array
->nested_ss
== NULL
);
2100 for (ss
= array
; ss
; ss
= ss
->parent
)
2101 for (n
= 0; n
< ss
->loop
->dimen
; n
++)
2102 if (array_dim
== get_array_ref_dim_for_loop_dim (ss
, n
))
2103 return &(ss
->loop
->to
[n
]);
2109 static gfc_loopinfo
*
2110 outermost_loop (gfc_loopinfo
* loop
)
2112 while (loop
->parent
!= NULL
)
2113 loop
= loop
->parent
;
2119 /* Array constructors are handled by constructing a temporary, then using that
2120 within the scalarization loop. This is not optimal, but seems by far the
2124 trans_array_constructor (gfc_ss
* ss
, locus
* where
)
2126 gfc_constructor_base c
;
2134 bool old_first_len
, old_typespec_chararray_ctor
;
2135 tree old_first_len_val
;
2136 gfc_loopinfo
*loop
, *outer_loop
;
2137 gfc_ss_info
*ss_info
;
2141 /* Save the old values for nested checking. */
2142 old_first_len
= first_len
;
2143 old_first_len_val
= first_len_val
;
2144 old_typespec_chararray_ctor
= typespec_chararray_ctor
;
2147 outer_loop
= outermost_loop (loop
);
2149 expr
= ss_info
->expr
;
2151 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
2152 typespec was given for the array constructor. */
2153 typespec_chararray_ctor
= (expr
->ts
.u
.cl
2154 && expr
->ts
.u
.cl
->length_from_typespec
);
2156 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2157 && expr
->ts
.type
== BT_CHARACTER
&& !typespec_chararray_ctor
)
2159 first_len_val
= gfc_create_var (gfc_charlen_type_node
, "len");
2163 gcc_assert (ss
->dimen
== ss
->loop
->dimen
);
2165 c
= expr
->value
.constructor
;
2166 if (expr
->ts
.type
== BT_CHARACTER
)
2170 /* get_array_ctor_strlen walks the elements of the constructor, if a
2171 typespec was given, we already know the string length and want the one
2173 if (typespec_chararray_ctor
&& expr
->ts
.u
.cl
->length
2174 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
2178 const_string
= false;
2179 gfc_init_se (&length_se
, NULL
);
2180 gfc_conv_expr_type (&length_se
, expr
->ts
.u
.cl
->length
,
2181 gfc_charlen_type_node
);
2182 ss_info
->string_length
= length_se
.expr
;
2183 gfc_add_block_to_block (&outer_loop
->pre
, &length_se
.pre
);
2184 gfc_add_block_to_block (&outer_loop
->post
, &length_se
.post
);
2187 const_string
= get_array_ctor_strlen (&outer_loop
->pre
, c
,
2188 &ss_info
->string_length
);
2190 /* Complex character array constructors should have been taken care of
2191 and not end up here. */
2192 gcc_assert (ss_info
->string_length
);
2194 expr
->ts
.u
.cl
->backend_decl
= ss_info
->string_length
;
2196 type
= gfc_get_character_type_len (expr
->ts
.kind
, ss_info
->string_length
);
2198 type
= build_pointer_type (type
);
2201 type
= gfc_typenode_for_spec (&expr
->ts
);
2203 /* See if the constructor determines the loop bounds. */
2206 loop_ubound0
= get_loop_upper_bound_for_array (ss
, 0);
2208 if (expr
->shape
&& get_rank (loop
) > 1 && *loop_ubound0
== NULL_TREE
)
2210 /* We have a multidimensional parameter. */
2211 for (s
= ss
; s
; s
= s
->parent
)
2214 for (n
= 0; n
< s
->loop
->dimen
; n
++)
2216 s
->loop
->from
[n
] = gfc_index_zero_node
;
2217 s
->loop
->to
[n
] = gfc_conv_mpz_to_tree (expr
->shape
[s
->dim
[n
]],
2218 gfc_index_integer_kind
);
2219 s
->loop
->to
[n
] = fold_build2_loc (input_location
, MINUS_EXPR
,
2220 gfc_array_index_type
,
2222 gfc_index_one_node
);
2227 if (*loop_ubound0
== NULL_TREE
)
2231 /* We should have a 1-dimensional, zero-based loop. */
2232 gcc_assert (loop
->parent
== NULL
&& loop
->nested
== NULL
);
2233 gcc_assert (loop
->dimen
== 1);
2234 gcc_assert (integer_zerop (loop
->from
[0]));
2236 /* Split the constructor size into a static part and a dynamic part.
2237 Allocate the static size up-front and record whether the dynamic
2238 size might be nonzero. */
2240 dynamic
= gfc_get_array_constructor_size (&size
, c
);
2241 mpz_sub_ui (size
, size
, 1);
2242 loop
->to
[0] = gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
2246 /* Special case constant array constructors. */
2249 unsigned HOST_WIDE_INT nelem
= gfc_constant_array_constructor_p (c
);
2252 tree size
= constant_array_constructor_loop_size (loop
);
2253 if (size
&& compare_tree_int (size
, nelem
) == 0)
2255 trans_constant_array_constructor (ss
, type
);
2261 if (TREE_CODE (*loop_ubound0
) == VAR_DECL
)
2264 gfc_trans_create_temp_array (&outer_loop
->pre
, &outer_loop
->post
, ss
, type
,
2265 NULL_TREE
, dynamic
, true, false, where
);
2267 desc
= ss_info
->data
.array
.descriptor
;
2268 offset
= gfc_index_zero_node
;
2269 offsetvar
= gfc_create_var_np (gfc_array_index_type
, "offset");
2270 TREE_NO_WARNING (offsetvar
) = 1;
2271 TREE_USED (offsetvar
) = 0;
2272 gfc_trans_array_constructor_value (&outer_loop
->pre
, type
, desc
, c
,
2273 &offset
, &offsetvar
, dynamic
);
2275 /* If the array grows dynamically, the upper bound of the loop variable
2276 is determined by the array's final upper bound. */
2279 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2280 gfc_array_index_type
,
2281 offsetvar
, gfc_index_one_node
);
2282 tmp
= gfc_evaluate_now (tmp
, &outer_loop
->pre
);
2283 gfc_conv_descriptor_ubound_set (&loop
->pre
, desc
, gfc_rank_cst
[0], tmp
);
2284 if (*loop_ubound0
&& TREE_CODE (*loop_ubound0
) == VAR_DECL
)
2285 gfc_add_modify (&outer_loop
->pre
, *loop_ubound0
, tmp
);
2287 *loop_ubound0
= tmp
;
2290 if (TREE_USED (offsetvar
))
2291 pushdecl (offsetvar
);
2293 gcc_assert (INTEGER_CST_P (offset
));
2296 /* Disable bound checking for now because it's probably broken. */
2297 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2304 /* Restore old values of globals. */
2305 first_len
= old_first_len
;
2306 first_len_val
= old_first_len_val
;
2307 typespec_chararray_ctor
= old_typespec_chararray_ctor
;
2311 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
2312 called after evaluating all of INFO's vector dimensions. Go through
2313 each such vector dimension and see if we can now fill in any missing
2317 set_vector_loop_bounds (gfc_ss
* ss
)
2319 gfc_loopinfo
*loop
, *outer_loop
;
2320 gfc_array_info
*info
;
2328 outer_loop
= outermost_loop (ss
->loop
);
2330 info
= &ss
->info
->data
.array
;
2332 for (; ss
; ss
= ss
->parent
)
2336 for (n
= 0; n
< loop
->dimen
; n
++)
2339 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_VECTOR
2340 || loop
->to
[n
] != NULL
)
2343 /* Loop variable N indexes vector dimension DIM, and we don't
2344 yet know the upper bound of loop variable N. Set it to the
2345 difference between the vector's upper and lower bounds. */
2346 gcc_assert (loop
->from
[n
] == gfc_index_zero_node
);
2347 gcc_assert (info
->subscript
[dim
]
2348 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
2350 gfc_init_se (&se
, NULL
);
2351 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
2352 zero
= gfc_rank_cst
[0];
2353 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2354 gfc_array_index_type
,
2355 gfc_conv_descriptor_ubound_get (desc
, zero
),
2356 gfc_conv_descriptor_lbound_get (desc
, zero
));
2357 tmp
= gfc_evaluate_now (tmp
, &outer_loop
->pre
);
2364 /* Add the pre and post chains for all the scalar expressions in a SS chain
2365 to loop. This is called after the loop parameters have been calculated,
2366 but before the actual scalarizing loops. */
2369 gfc_add_loop_ss_code (gfc_loopinfo
* loop
, gfc_ss
* ss
, bool subscript
,
2372 gfc_loopinfo
*nested_loop
, *outer_loop
;
2374 gfc_ss_info
*ss_info
;
2375 gfc_array_info
*info
;
2377 bool skip_nested
= false;
2380 outer_loop
= outermost_loop (loop
);
2382 /* TODO: This can generate bad code if there are ordering dependencies,
2383 e.g., a callee allocated function and an unknown size constructor. */
2384 gcc_assert (ss
!= NULL
);
2386 for (; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2390 /* Cross loop arrays are handled from within the most nested loop. */
2391 if (ss
->nested_ss
!= NULL
)
2395 expr
= ss_info
->expr
;
2396 info
= &ss_info
->data
.array
;
2398 switch (ss_info
->type
)
2401 /* Scalar expression. Evaluate this now. This includes elemental
2402 dimension indices, but not array section bounds. */
2403 gfc_init_se (&se
, NULL
);
2404 gfc_conv_expr (&se
, expr
);
2405 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2407 if (expr
->ts
.type
!= BT_CHARACTER
)
2409 /* Move the evaluation of scalar expressions outside the
2410 scalarization loop, except for WHERE assignments. */
2412 se
.expr
= convert(gfc_array_index_type
, se
.expr
);
2413 if (!ss_info
->where
)
2414 se
.expr
= gfc_evaluate_now (se
.expr
, &outer_loop
->pre
);
2415 gfc_add_block_to_block (&outer_loop
->pre
, &se
.post
);
2418 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2420 ss_info
->data
.scalar
.value
= se
.expr
;
2421 ss_info
->string_length
= se
.string_length
;
2424 case GFC_SS_REFERENCE
:
2425 /* Scalar argument to elemental procedure. Evaluate this
2427 gfc_init_se (&se
, NULL
);
2428 gfc_conv_expr (&se
, expr
);
2429 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2430 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2432 ss_info
->data
.scalar
.value
= gfc_evaluate_now (se
.expr
,
2434 ss_info
->string_length
= se
.string_length
;
2437 case GFC_SS_SECTION
:
2438 /* Add the expressions for scalar and vector subscripts. */
2439 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2440 if (info
->subscript
[n
])
2442 gfc_add_loop_ss_code (loop
, info
->subscript
[n
], true, where
);
2443 /* The recursive call will have taken care of the nested loops.
2444 No need to do it twice. */
2448 set_vector_loop_bounds (ss
);
2452 /* Get the vector's descriptor and store it in SS. */
2453 gfc_init_se (&se
, NULL
);
2454 gfc_conv_expr_descriptor (&se
, expr
, gfc_walk_expr (expr
));
2455 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2456 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2457 info
->descriptor
= se
.expr
;
2460 case GFC_SS_INTRINSIC
:
2461 gfc_add_intrinsic_ss_code (loop
, ss
);
2464 case GFC_SS_FUNCTION
:
2465 /* Array function return value. We call the function and save its
2466 result in a temporary for use inside the loop. */
2467 gfc_init_se (&se
, NULL
);
2470 gfc_conv_expr (&se
, expr
);
2471 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2472 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2473 ss_info
->string_length
= se
.string_length
;
2476 case GFC_SS_CONSTRUCTOR
:
2477 if (expr
->ts
.type
== BT_CHARACTER
2478 && ss_info
->string_length
== NULL
2480 && expr
->ts
.u
.cl
->length
)
2482 gfc_init_se (&se
, NULL
);
2483 gfc_conv_expr_type (&se
, expr
->ts
.u
.cl
->length
,
2484 gfc_charlen_type_node
);
2485 ss_info
->string_length
= se
.expr
;
2486 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2487 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2489 trans_array_constructor (ss
, where
);
2493 case GFC_SS_COMPONENT
:
2494 /* Do nothing. These are handled elsewhere. */
2503 for (nested_loop
= loop
->nested
; nested_loop
;
2504 nested_loop
= nested_loop
->next
)
2505 gfc_add_loop_ss_code (nested_loop
, nested_loop
->ss
, subscript
, where
);
2509 /* Translate expressions for the descriptor and data pointer of a SS. */
2513 gfc_conv_ss_descriptor (stmtblock_t
* block
, gfc_ss
* ss
, int base
)
2516 gfc_ss_info
*ss_info
;
2517 gfc_array_info
*info
;
2521 info
= &ss_info
->data
.array
;
2523 /* Get the descriptor for the array to be scalarized. */
2524 gcc_assert (ss_info
->expr
->expr_type
== EXPR_VARIABLE
);
2525 gfc_init_se (&se
, NULL
);
2526 se
.descriptor_only
= 1;
2527 gfc_conv_expr_lhs (&se
, ss_info
->expr
);
2528 gfc_add_block_to_block (block
, &se
.pre
);
2529 info
->descriptor
= se
.expr
;
2530 ss_info
->string_length
= se
.string_length
;
2534 /* Also the data pointer. */
2535 tmp
= gfc_conv_array_data (se
.expr
);
2536 /* If this is a variable or address of a variable we use it directly.
2537 Otherwise we must evaluate it now to avoid breaking dependency
2538 analysis by pulling the expressions for elemental array indices
2541 || (TREE_CODE (tmp
) == ADDR_EXPR
2542 && DECL_P (TREE_OPERAND (tmp
, 0)))))
2543 tmp
= gfc_evaluate_now (tmp
, block
);
2546 tmp
= gfc_conv_array_offset (se
.expr
);
2547 info
->offset
= gfc_evaluate_now (tmp
, block
);
2549 /* Make absolutely sure that the saved_offset is indeed saved
2550 so that the variable is still accessible after the loops
2552 info
->saved_offset
= info
->offset
;
2557 /* Initialize a gfc_loopinfo structure. */
2560 gfc_init_loopinfo (gfc_loopinfo
* loop
)
2564 memset (loop
, 0, sizeof (gfc_loopinfo
));
2565 gfc_init_block (&loop
->pre
);
2566 gfc_init_block (&loop
->post
);
2568 /* Initially scalarize in order and default to no loop reversal. */
2569 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2572 loop
->reverse
[n
] = GFC_INHIBIT_REVERSE
;
2575 loop
->ss
= gfc_ss_terminator
;
2579 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2583 gfc_copy_loopinfo_to_se (gfc_se
* se
, gfc_loopinfo
* loop
)
2589 /* Return an expression for the data pointer of an array. */
2592 gfc_conv_array_data (tree descriptor
)
2596 type
= TREE_TYPE (descriptor
);
2597 if (GFC_ARRAY_TYPE_P (type
))
2599 if (TREE_CODE (type
) == POINTER_TYPE
)
2603 /* Descriptorless arrays. */
2604 return gfc_build_addr_expr (NULL_TREE
, descriptor
);
2608 return gfc_conv_descriptor_data_get (descriptor
);
2612 /* Return an expression for the base offset of an array. */
2615 gfc_conv_array_offset (tree descriptor
)
2619 type
= TREE_TYPE (descriptor
);
2620 if (GFC_ARRAY_TYPE_P (type
))
2621 return GFC_TYPE_ARRAY_OFFSET (type
);
2623 return gfc_conv_descriptor_offset_get (descriptor
);
2627 /* Get an expression for the array stride. */
2630 gfc_conv_array_stride (tree descriptor
, int dim
)
2635 type
= TREE_TYPE (descriptor
);
2637 /* For descriptorless arrays use the array size. */
2638 tmp
= GFC_TYPE_ARRAY_STRIDE (type
, dim
);
2639 if (tmp
!= NULL_TREE
)
2642 tmp
= gfc_conv_descriptor_stride_get (descriptor
, gfc_rank_cst
[dim
]);
2647 /* Like gfc_conv_array_stride, but for the lower bound. */
2650 gfc_conv_array_lbound (tree descriptor
, int dim
)
2655 type
= TREE_TYPE (descriptor
);
2657 tmp
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
2658 if (tmp
!= NULL_TREE
)
2661 tmp
= gfc_conv_descriptor_lbound_get (descriptor
, gfc_rank_cst
[dim
]);
2666 /* Like gfc_conv_array_stride, but for the upper bound. */
2669 gfc_conv_array_ubound (tree descriptor
, int dim
)
2674 type
= TREE_TYPE (descriptor
);
2676 tmp
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
2677 if (tmp
!= NULL_TREE
)
2680 /* This should only ever happen when passing an assumed shape array
2681 as an actual parameter. The value will never be used. */
2682 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor
)))
2683 return gfc_index_zero_node
;
2685 tmp
= gfc_conv_descriptor_ubound_get (descriptor
, gfc_rank_cst
[dim
]);
2690 /* Generate code to perform an array index bound check. */
2693 trans_array_bound_check (gfc_se
* se
, gfc_ss
*ss
, tree index
, int n
,
2694 locus
* where
, bool check_upper
)
2697 tree tmp_lo
, tmp_up
;
2700 const char * name
= NULL
;
2702 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
2705 descriptor
= ss
->info
->data
.array
.descriptor
;
2707 index
= gfc_evaluate_now (index
, &se
->pre
);
2709 /* We find a name for the error message. */
2710 name
= ss
->info
->expr
->symtree
->n
.sym
->name
;
2711 gcc_assert (name
!= NULL
);
2713 if (TREE_CODE (descriptor
) == VAR_DECL
)
2714 name
= IDENTIFIER_POINTER (DECL_NAME (descriptor
));
2716 /* If upper bound is present, include both bounds in the error message. */
2719 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
2720 tmp_up
= gfc_conv_array_ubound (descriptor
, n
);
2723 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
2724 "outside of expected range (%%ld:%%ld)", n
+1, name
);
2726 asprintf (&msg
, "Index '%%ld' of dimension %d "
2727 "outside of expected range (%%ld:%%ld)", n
+1);
2729 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2731 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2732 fold_convert (long_integer_type_node
, index
),
2733 fold_convert (long_integer_type_node
, tmp_lo
),
2734 fold_convert (long_integer_type_node
, tmp_up
));
2735 fault
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2737 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2738 fold_convert (long_integer_type_node
, index
),
2739 fold_convert (long_integer_type_node
, tmp_lo
),
2740 fold_convert (long_integer_type_node
, tmp_up
));
2745 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
2748 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
2749 "below lower bound of %%ld", n
+1, name
);
2751 asprintf (&msg
, "Index '%%ld' of dimension %d "
2752 "below lower bound of %%ld", n
+1);
2754 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2756 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2757 fold_convert (long_integer_type_node
, index
),
2758 fold_convert (long_integer_type_node
, tmp_lo
));
2766 /* Return the offset for an index. Performs bound checking for elemental
2767 dimensions. Single element references are processed separately.
2768 DIM is the array dimension, I is the loop dimension. */
2771 conv_array_index_offset (gfc_se
* se
, gfc_ss
* ss
, int dim
, int i
,
2772 gfc_array_ref
* ar
, tree stride
)
2774 gfc_array_info
*info
;
2779 info
= &ss
->info
->data
.array
;
2781 /* Get the index into the array for this dimension. */
2784 gcc_assert (ar
->type
!= AR_ELEMENT
);
2785 switch (ar
->dimen_type
[dim
])
2787 case DIMEN_THIS_IMAGE
:
2791 /* Elemental dimension. */
2792 gcc_assert (info
->subscript
[dim
]
2793 && info
->subscript
[dim
]->info
->type
== GFC_SS_SCALAR
);
2794 /* We've already translated this value outside the loop. */
2795 index
= info
->subscript
[dim
]->info
->data
.scalar
.value
;
2797 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
2798 ar
->as
->type
!= AS_ASSUMED_SIZE
2799 || dim
< ar
->dimen
- 1);
2803 gcc_assert (info
&& se
->loop
);
2804 gcc_assert (info
->subscript
[dim
]
2805 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
2806 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
2808 /* Get a zero-based index into the vector. */
2809 index
= fold_build2_loc (input_location
, MINUS_EXPR
,
2810 gfc_array_index_type
,
2811 se
->loop
->loopvar
[i
], se
->loop
->from
[i
]);
2813 /* Multiply the index by the stride. */
2814 index
= fold_build2_loc (input_location
, MULT_EXPR
,
2815 gfc_array_index_type
,
2816 index
, gfc_conv_array_stride (desc
, 0));
2818 /* Read the vector to get an index into info->descriptor. */
2819 data
= build_fold_indirect_ref_loc (input_location
,
2820 gfc_conv_array_data (desc
));
2821 index
= gfc_build_array_ref (data
, index
, NULL
);
2822 index
= gfc_evaluate_now (index
, &se
->pre
);
2823 index
= fold_convert (gfc_array_index_type
, index
);
2825 /* Do any bounds checking on the final info->descriptor index. */
2826 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
2827 ar
->as
->type
!= AS_ASSUMED_SIZE
2828 || dim
< ar
->dimen
- 1);
2832 /* Scalarized dimension. */
2833 gcc_assert (info
&& se
->loop
);
2835 /* Multiply the loop variable by the stride and delta. */
2836 index
= se
->loop
->loopvar
[i
];
2837 if (!integer_onep (info
->stride
[dim
]))
2838 index
= fold_build2_loc (input_location
, MULT_EXPR
,
2839 gfc_array_index_type
, index
,
2841 if (!integer_zerop (info
->delta
[dim
]))
2842 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
2843 gfc_array_index_type
, index
,
2853 /* Temporary array or derived type component. */
2854 gcc_assert (se
->loop
);
2855 index
= se
->loop
->loopvar
[se
->loop
->order
[i
]];
2857 /* Pointer functions can have stride[0] different from unity.
2858 Use the stride returned by the function call and stored in
2859 the descriptor for the temporary. */
2860 if (se
->ss
&& se
->ss
->info
->type
== GFC_SS_FUNCTION
2861 && se
->ss
->info
->expr
2862 && se
->ss
->info
->expr
->symtree
2863 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
2864 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
->attr
.pointer
)
2865 stride
= gfc_conv_descriptor_stride_get (info
->descriptor
,
2868 if (!integer_zerop (info
->delta
[dim
]))
2869 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
2870 gfc_array_index_type
, index
, info
->delta
[dim
]);
2873 /* Multiply by the stride. */
2874 if (!integer_onep (stride
))
2875 index
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
2882 /* Build a scalarized reference to an array. */
2885 gfc_conv_scalarized_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
2887 gfc_array_info
*info
;
2888 tree decl
= NULL_TREE
;
2896 expr
= ss
->info
->expr
;
2897 info
= &ss
->info
->data
.array
;
2899 n
= se
->loop
->order
[0];
2903 index
= conv_array_index_offset (se
, ss
, ss
->dim
[n
], n
, ar
, info
->stride0
);
2904 /* Add the offset for this dimension to the stored offset for all other
2906 if (!integer_zerop (info
->offset
))
2907 index
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
2908 index
, info
->offset
);
2910 if (expr
&& is_subref_array (expr
))
2911 decl
= expr
->symtree
->n
.sym
->backend_decl
;
2913 tmp
= build_fold_indirect_ref_loc (input_location
, info
->data
);
2914 se
->expr
= gfc_build_array_ref (tmp
, index
, decl
);
2918 /* Translate access of temporary array. */
2921 gfc_conv_tmp_array_ref (gfc_se
* se
)
2923 se
->string_length
= se
->ss
->info
->string_length
;
2924 gfc_conv_scalarized_array_ref (se
, NULL
);
2925 gfc_advance_se_ss_chain (se
);
2928 /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
2931 add_to_offset (tree
*cst_offset
, tree
*offset
, tree t
)
2933 if (TREE_CODE (t
) == INTEGER_CST
)
2934 *cst_offset
= int_const_binop (PLUS_EXPR
, *cst_offset
, t
);
2937 if (!integer_zerop (*offset
))
2938 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
2939 gfc_array_index_type
, *offset
, t
);
2945 /* Build an array reference. se->expr already holds the array descriptor.
2946 This should be either a variable, indirect variable reference or component
2947 reference. For arrays which do not have a descriptor, se->expr will be
2949 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2952 gfc_conv_array_ref (gfc_se
* se
, gfc_array_ref
* ar
, gfc_symbol
* sym
,
2956 tree offset
, cst_offset
;
2964 gcc_assert (ar
->codimen
);
2966 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
->expr
)))
2967 se
->expr
= build_fold_indirect_ref (gfc_conv_array_data (se
->expr
));
2970 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se
->expr
))
2971 && TREE_CODE (TREE_TYPE (se
->expr
)) == POINTER_TYPE
)
2972 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
2974 /* Use the actual tree type and not the wrapped coarray. */
2975 if (!se
->want_pointer
)
2976 se
->expr
= fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se
->expr
)),
2983 /* Handle scalarized references separately. */
2984 if (ar
->type
!= AR_ELEMENT
)
2986 gfc_conv_scalarized_array_ref (se
, ar
);
2987 gfc_advance_se_ss_chain (se
);
2991 cst_offset
= offset
= gfc_index_zero_node
;
2992 add_to_offset (&cst_offset
, &offset
, gfc_conv_array_offset (se
->expr
));
2994 /* Calculate the offsets from all the dimensions. Make sure to associate
2995 the final offset so that we form a chain of loop invariant summands. */
2996 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
2998 /* Calculate the index for this dimension. */
2999 gfc_init_se (&indexse
, se
);
3000 gfc_conv_expr_type (&indexse
, ar
->start
[n
], gfc_array_index_type
);
3001 gfc_add_block_to_block (&se
->pre
, &indexse
.pre
);
3003 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3005 /* Check array bounds. */
3009 /* Evaluate the indexse.expr only once. */
3010 indexse
.expr
= save_expr (indexse
.expr
);
3013 tmp
= gfc_conv_array_lbound (se
->expr
, n
);
3014 if (sym
->attr
.temporary
)
3016 gfc_init_se (&tmpse
, se
);
3017 gfc_conv_expr_type (&tmpse
, ar
->as
->lower
[n
],
3018 gfc_array_index_type
);
3019 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3023 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
3025 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
3026 "below lower bound of %%ld", n
+1, sym
->name
);
3027 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3028 fold_convert (long_integer_type_node
,
3030 fold_convert (long_integer_type_node
, tmp
));
3033 /* Upper bound, but not for the last dimension of assumed-size
3035 if (n
< ar
->dimen
- 1 || ar
->as
->type
!= AS_ASSUMED_SIZE
)
3037 tmp
= gfc_conv_array_ubound (se
->expr
, n
);
3038 if (sym
->attr
.temporary
)
3040 gfc_init_se (&tmpse
, se
);
3041 gfc_conv_expr_type (&tmpse
, ar
->as
->upper
[n
],
3042 gfc_array_index_type
);
3043 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3047 cond
= fold_build2_loc (input_location
, GT_EXPR
,
3048 boolean_type_node
, indexse
.expr
, tmp
);
3049 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
3050 "above upper bound of %%ld", n
+1, sym
->name
);
3051 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3052 fold_convert (long_integer_type_node
,
3054 fold_convert (long_integer_type_node
, tmp
));
3059 /* Multiply the index by the stride. */
3060 stride
= gfc_conv_array_stride (se
->expr
, n
);
3061 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3062 indexse
.expr
, stride
);
3064 /* And add it to the total. */
3065 add_to_offset (&cst_offset
, &offset
, tmp
);
3068 if (!integer_zerop (cst_offset
))
3069 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3070 gfc_array_index_type
, offset
, cst_offset
);
3072 /* Access the calculated element. */
3073 tmp
= gfc_conv_array_data (se
->expr
);
3074 tmp
= build_fold_indirect_ref (tmp
);
3075 se
->expr
= gfc_build_array_ref (tmp
, offset
, sym
->backend_decl
);
3079 /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
3080 LOOP_DIM dimension (if any) to array's offset. */
3083 add_array_offset (stmtblock_t
*pblock
, gfc_loopinfo
*loop
, gfc_ss
*ss
,
3084 gfc_array_ref
*ar
, int array_dim
, int loop_dim
)
3087 gfc_array_info
*info
;
3090 info
= &ss
->info
->data
.array
;
3092 gfc_init_se (&se
, NULL
);
3094 se
.expr
= info
->descriptor
;
3095 stride
= gfc_conv_array_stride (info
->descriptor
, array_dim
);
3096 index
= conv_array_index_offset (&se
, ss
, array_dim
, loop_dim
, ar
, stride
);
3097 gfc_add_block_to_block (pblock
, &se
.pre
);
3099 info
->offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3100 gfc_array_index_type
,
3101 info
->offset
, index
);
3102 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
3106 /* Generate the code to be executed immediately before entering a
3107 scalarization loop. */
3110 gfc_trans_preloop_setup (gfc_loopinfo
* loop
, int dim
, int flag
,
3111 stmtblock_t
* pblock
)
3114 gfc_ss_info
*ss_info
;
3115 gfc_array_info
*info
;
3116 gfc_ss_type ss_type
;
3118 gfc_loopinfo
*ploop
;
3122 /* This code will be executed before entering the scalarization loop
3123 for this dimension. */
3124 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3128 if ((ss_info
->useflags
& flag
) == 0)
3131 ss_type
= ss_info
->type
;
3132 if (ss_type
!= GFC_SS_SECTION
3133 && ss_type
!= GFC_SS_FUNCTION
3134 && ss_type
!= GFC_SS_CONSTRUCTOR
3135 && ss_type
!= GFC_SS_COMPONENT
)
3138 info
= &ss_info
->data
.array
;
3140 gcc_assert (dim
< ss
->dimen
);
3141 gcc_assert (ss
->dimen
== loop
->dimen
);
3144 ar
= &info
->ref
->u
.ar
;
3148 if (dim
== loop
->dimen
- 1 && loop
->parent
!= NULL
)
3150 /* If we are in the outermost dimension of this loop, the previous
3151 dimension shall be in the parent loop. */
3152 gcc_assert (ss
->parent
!= NULL
);
3155 ploop
= loop
->parent
;
3157 /* ss and ss->parent are about the same array. */
3158 gcc_assert (ss_info
== pss
->info
);
3166 if (dim
== loop
->dimen
- 1)
3171 /* For the time being, there is no loop reordering. */
3172 gcc_assert (i
== ploop
->order
[i
]);
3173 i
= ploop
->order
[i
];
3175 if (dim
== loop
->dimen
- 1 && loop
->parent
== NULL
)
3177 stride
= gfc_conv_array_stride (info
->descriptor
,
3178 innermost_ss (ss
)->dim
[i
]);
3180 /* Calculate the stride of the innermost loop. Hopefully this will
3181 allow the backend optimizers to do their stuff more effectively.
3183 info
->stride0
= gfc_evaluate_now (stride
, pblock
);
3185 /* For the outermost loop calculate the offset due to any
3186 elemental dimensions. It will have been initialized with the
3187 base offset of the array. */
3190 for (i
= 0; i
< ar
->dimen
; i
++)
3192 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
3195 add_array_offset (pblock
, loop
, ss
, ar
, i
, /* unused */ -1);
3200 /* Add the offset for the previous loop dimension. */
3201 add_array_offset (pblock
, ploop
, ss
, ar
, pss
->dim
[i
], i
);
3203 /* Remember this offset for the second loop. */
3204 if (dim
== loop
->temp_dim
- 1 && loop
->parent
== NULL
)
3205 info
->saved_offset
= info
->offset
;
3210 /* Start a scalarized expression. Creates a scope and declares loop
3214 gfc_start_scalarized_body (gfc_loopinfo
* loop
, stmtblock_t
* pbody
)
3220 gcc_assert (!loop
->array_parameter
);
3222 for (dim
= loop
->dimen
- 1; dim
>= 0; dim
--)
3224 n
= loop
->order
[dim
];
3226 gfc_start_block (&loop
->code
[n
]);
3228 /* Create the loop variable. */
3229 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "S");
3231 if (dim
< loop
->temp_dim
)
3235 /* Calculate values that will be constant within this loop. */
3236 gfc_trans_preloop_setup (loop
, dim
, flags
, &loop
->code
[n
]);
3238 gfc_start_block (pbody
);
3242 /* Generates the actual loop code for a scalarization loop. */
3245 gfc_trans_scalarized_loop_end (gfc_loopinfo
* loop
, int n
,
3246 stmtblock_t
* pbody
)
3257 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
))
3258 == (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
)
3259 && n
== loop
->dimen
- 1)
3261 /* We create an OMP_FOR construct for the outermost scalarized loop. */
3262 init
= make_tree_vec (1);
3263 cond
= make_tree_vec (1);
3264 incr
= make_tree_vec (1);
3266 /* Cycle statement is implemented with a goto. Exit statement must not
3267 be present for this loop. */
3268 exit_label
= gfc_build_label_decl (NULL_TREE
);
3269 TREE_USED (exit_label
) = 1;
3271 /* Label for cycle statements (if needed). */
3272 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3273 gfc_add_expr_to_block (pbody
, tmp
);
3275 stmt
= make_node (OMP_FOR
);
3277 TREE_TYPE (stmt
) = void_type_node
;
3278 OMP_FOR_BODY (stmt
) = loopbody
= gfc_finish_block (pbody
);
3280 OMP_FOR_CLAUSES (stmt
) = build_omp_clause (input_location
,
3281 OMP_CLAUSE_SCHEDULE
);
3282 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt
))
3283 = OMP_CLAUSE_SCHEDULE_STATIC
;
3284 if (ompws_flags
& OMPWS_NOWAIT
)
3285 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt
))
3286 = build_omp_clause (input_location
, OMP_CLAUSE_NOWAIT
);
3288 /* Initialize the loopvar. */
3289 TREE_VEC_ELT (init
, 0) = build2_v (MODIFY_EXPR
, loop
->loopvar
[n
],
3291 OMP_FOR_INIT (stmt
) = init
;
3292 /* The exit condition. */
3293 TREE_VEC_ELT (cond
, 0) = build2_loc (input_location
, LE_EXPR
,
3295 loop
->loopvar
[n
], loop
->to
[n
]);
3296 SET_EXPR_LOCATION (TREE_VEC_ELT (cond
, 0), input_location
);
3297 OMP_FOR_COND (stmt
) = cond
;
3298 /* Increment the loopvar. */
3299 tmp
= build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3300 loop
->loopvar
[n
], gfc_index_one_node
);
3301 TREE_VEC_ELT (incr
, 0) = fold_build2_loc (input_location
, MODIFY_EXPR
,
3302 void_type_node
, loop
->loopvar
[n
], tmp
);
3303 OMP_FOR_INCR (stmt
) = incr
;
3305 ompws_flags
&= ~OMPWS_CURR_SINGLEUNIT
;
3306 gfc_add_expr_to_block (&loop
->code
[n
], stmt
);
3310 bool reverse_loop
= (loop
->reverse
[n
] == GFC_REVERSE_SET
)
3311 && (loop
->temp_ss
== NULL
);
3313 loopbody
= gfc_finish_block (pbody
);
3317 tmp
= loop
->from
[n
];
3318 loop
->from
[n
] = loop
->to
[n
];
3322 /* Initialize the loopvar. */
3323 if (loop
->loopvar
[n
] != loop
->from
[n
])
3324 gfc_add_modify (&loop
->code
[n
], loop
->loopvar
[n
], loop
->from
[n
]);
3326 exit_label
= gfc_build_label_decl (NULL_TREE
);
3328 /* Generate the loop body. */
3329 gfc_init_block (&block
);
3331 /* The exit condition. */
3332 cond
= fold_build2_loc (input_location
, reverse_loop
? LT_EXPR
: GT_EXPR
,
3333 boolean_type_node
, loop
->loopvar
[n
], loop
->to
[n
]);
3334 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3335 TREE_USED (exit_label
) = 1;
3336 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3337 gfc_add_expr_to_block (&block
, tmp
);
3339 /* The main body. */
3340 gfc_add_expr_to_block (&block
, loopbody
);
3342 /* Increment the loopvar. */
3343 tmp
= fold_build2_loc (input_location
,
3344 reverse_loop
? MINUS_EXPR
: PLUS_EXPR
,
3345 gfc_array_index_type
, loop
->loopvar
[n
],
3346 gfc_index_one_node
);
3348 gfc_add_modify (&block
, loop
->loopvar
[n
], tmp
);
3350 /* Build the loop. */
3351 tmp
= gfc_finish_block (&block
);
3352 tmp
= build1_v (LOOP_EXPR
, tmp
);
3353 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
3355 /* Add the exit label. */
3356 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3357 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
3363 /* Finishes and generates the loops for a scalarized expression. */
3366 gfc_trans_scalarizing_loops (gfc_loopinfo
* loop
, stmtblock_t
* body
)
3371 stmtblock_t
*pblock
;
3375 /* Generate the loops. */
3376 for (dim
= 0; dim
< loop
->dimen
; dim
++)
3378 n
= loop
->order
[dim
];
3379 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
3380 loop
->loopvar
[n
] = NULL_TREE
;
3381 pblock
= &loop
->code
[n
];
3384 tmp
= gfc_finish_block (pblock
);
3385 gfc_add_expr_to_block (&loop
->pre
, tmp
);
3387 /* Clear all the used flags. */
3388 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3389 if (ss
->parent
== NULL
)
3390 ss
->info
->useflags
= 0;
3394 /* Finish the main body of a scalarized expression, and start the secondary
3398 gfc_trans_scalarized_loop_boundary (gfc_loopinfo
* loop
, stmtblock_t
* body
)
3402 stmtblock_t
*pblock
;
3406 /* We finish as many loops as are used by the temporary. */
3407 for (dim
= 0; dim
< loop
->temp_dim
- 1; dim
++)
3409 n
= loop
->order
[dim
];
3410 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
3411 loop
->loopvar
[n
] = NULL_TREE
;
3412 pblock
= &loop
->code
[n
];
3415 /* We don't want to finish the outermost loop entirely. */
3416 n
= loop
->order
[loop
->temp_dim
- 1];
3417 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
3419 /* Restore the initial offsets. */
3420 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3422 gfc_ss_type ss_type
;
3423 gfc_ss_info
*ss_info
;
3427 if ((ss_info
->useflags
& 2) == 0)
3430 ss_type
= ss_info
->type
;
3431 if (ss_type
!= GFC_SS_SECTION
3432 && ss_type
!= GFC_SS_FUNCTION
3433 && ss_type
!= GFC_SS_CONSTRUCTOR
3434 && ss_type
!= GFC_SS_COMPONENT
)
3437 ss_info
->data
.array
.offset
= ss_info
->data
.array
.saved_offset
;
3440 /* Restart all the inner loops we just finished. */
3441 for (dim
= loop
->temp_dim
- 2; dim
>= 0; dim
--)
3443 n
= loop
->order
[dim
];
3445 gfc_start_block (&loop
->code
[n
]);
3447 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "Q");
3449 gfc_trans_preloop_setup (loop
, dim
, 2, &loop
->code
[n
]);
3452 /* Start a block for the secondary copying code. */
3453 gfc_start_block (body
);
3457 /* Precalculate (either lower or upper) bound of an array section.
3458 BLOCK: Block in which the (pre)calculation code will go.
3459 BOUNDS[DIM]: Where the bound value will be stored once evaluated.
3460 VALUES[DIM]: Specified bound (NULL <=> unspecified).
3461 DESC: Array descriptor from which the bound will be picked if unspecified
3462 (either lower or upper bound according to LBOUND). */
3465 evaluate_bound (stmtblock_t
*block
, tree
*bounds
, gfc_expr
** values
,
3466 tree desc
, int dim
, bool lbound
)
3469 gfc_expr
* input_val
= values
[dim
];
3470 tree
*output
= &bounds
[dim
];
3475 /* Specified section bound. */
3476 gfc_init_se (&se
, NULL
);
3477 gfc_conv_expr_type (&se
, input_val
, gfc_array_index_type
);
3478 gfc_add_block_to_block (block
, &se
.pre
);
3483 /* No specific bound specified so use the bound of the array. */
3484 *output
= lbound
? gfc_conv_array_lbound (desc
, dim
) :
3485 gfc_conv_array_ubound (desc
, dim
);
3487 *output
= gfc_evaluate_now (*output
, block
);
3491 /* Calculate the lower bound of an array section. */
3494 gfc_conv_section_startstride (gfc_loopinfo
* loop
, gfc_ss
* ss
, int dim
)
3496 gfc_expr
*stride
= NULL
;
3499 gfc_array_info
*info
;
3502 gcc_assert (ss
->info
->type
== GFC_SS_SECTION
);
3504 info
= &ss
->info
->data
.array
;
3505 ar
= &info
->ref
->u
.ar
;
3507 if (ar
->dimen_type
[dim
] == DIMEN_VECTOR
)
3509 /* We use a zero-based index to access the vector. */
3510 info
->start
[dim
] = gfc_index_zero_node
;
3511 info
->end
[dim
] = NULL
;
3512 info
->stride
[dim
] = gfc_index_one_node
;
3516 gcc_assert (ar
->dimen_type
[dim
] == DIMEN_RANGE
3517 || ar
->dimen_type
[dim
] == DIMEN_THIS_IMAGE
);
3518 desc
= info
->descriptor
;
3519 stride
= ar
->stride
[dim
];
3521 /* Calculate the start of the range. For vector subscripts this will
3522 be the range of the vector. */
3523 evaluate_bound (&loop
->pre
, info
->start
, ar
->start
, desc
, dim
, true);
3525 /* Similarly calculate the end. Although this is not used in the
3526 scalarizer, it is needed when checking bounds and where the end
3527 is an expression with side-effects. */
3528 evaluate_bound (&loop
->pre
, info
->end
, ar
->end
, desc
, dim
, false);
3530 /* Calculate the stride. */
3532 info
->stride
[dim
] = gfc_index_one_node
;
3535 gfc_init_se (&se
, NULL
);
3536 gfc_conv_expr_type (&se
, stride
, gfc_array_index_type
);
3537 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
3538 info
->stride
[dim
] = gfc_evaluate_now (se
.expr
, &loop
->pre
);
3543 /* Calculates the range start and stride for a SS chain. Also gets the
3544 descriptor and data pointer. The range of vector subscripts is the size
3545 of the vector. Array bounds are also checked. */
3548 gfc_conv_ss_startstride (gfc_loopinfo
* loop
)
3556 /* Determine the rank of the loop. */
3557 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3559 switch (ss
->info
->type
)
3561 case GFC_SS_SECTION
:
3562 case GFC_SS_CONSTRUCTOR
:
3563 case GFC_SS_FUNCTION
:
3564 case GFC_SS_COMPONENT
:
3565 loop
->dimen
= ss
->dimen
;
3568 /* As usual, lbound and ubound are exceptions!. */
3569 case GFC_SS_INTRINSIC
:
3570 switch (ss
->info
->expr
->value
.function
.isym
->id
)
3572 case GFC_ISYM_LBOUND
:
3573 case GFC_ISYM_UBOUND
:
3574 case GFC_ISYM_LCOBOUND
:
3575 case GFC_ISYM_UCOBOUND
:
3576 case GFC_ISYM_THIS_IMAGE
:
3577 loop
->dimen
= ss
->dimen
;
3589 /* We should have determined the rank of the expression by now. If
3590 not, that's bad news. */
3594 /* Loop over all the SS in the chain. */
3595 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3597 gfc_ss_info
*ss_info
;
3598 gfc_array_info
*info
;
3602 expr
= ss_info
->expr
;
3603 info
= &ss_info
->data
.array
;
3605 if (expr
&& expr
->shape
&& !info
->shape
)
3606 info
->shape
= expr
->shape
;
3608 switch (ss_info
->type
)
3610 case GFC_SS_SECTION
:
3611 /* Get the descriptor for the array. If it is a cross loops array,
3612 we got the descriptor already in the outermost loop. */
3613 if (ss
->parent
== NULL
)
3614 gfc_conv_ss_descriptor (&loop
->pre
, ss
, !loop
->array_parameter
);
3616 for (n
= 0; n
< ss
->dimen
; n
++)
3617 gfc_conv_section_startstride (loop
, ss
, ss
->dim
[n
]);
3620 case GFC_SS_INTRINSIC
:
3621 switch (expr
->value
.function
.isym
->id
)
3623 /* Fall through to supply start and stride. */
3624 case GFC_ISYM_LBOUND
:
3625 case GFC_ISYM_UBOUND
:
3626 case GFC_ISYM_LCOBOUND
:
3627 case GFC_ISYM_UCOBOUND
:
3628 case GFC_ISYM_THIS_IMAGE
:
3635 case GFC_SS_CONSTRUCTOR
:
3636 case GFC_SS_FUNCTION
:
3637 for (n
= 0; n
< ss
->dimen
; n
++)
3639 int dim
= ss
->dim
[n
];
3641 info
->start
[dim
] = gfc_index_zero_node
;
3642 info
->end
[dim
] = gfc_index_zero_node
;
3643 info
->stride
[dim
] = gfc_index_one_node
;
3652 /* The rest is just runtime bound checking. */
3653 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3656 tree lbound
, ubound
;
3658 tree size
[GFC_MAX_DIMENSIONS
];
3659 tree stride_pos
, stride_neg
, non_zerosized
, tmp2
, tmp3
;
3660 gfc_array_info
*info
;
3664 gfc_start_block (&block
);
3666 for (n
= 0; n
< loop
->dimen
; n
++)
3667 size
[n
] = NULL_TREE
;
3669 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3672 gfc_ss_info
*ss_info
;
3675 const char *expr_name
;
3678 if (ss_info
->type
!= GFC_SS_SECTION
)
3681 /* Catch allocatable lhs in f2003. */
3682 if (gfc_option
.flag_realloc_lhs
&& ss
->is_alloc_lhs
)
3685 expr
= ss_info
->expr
;
3686 expr_loc
= &expr
->where
;
3687 expr_name
= expr
->symtree
->name
;
3689 gfc_start_block (&inner
);
3691 /* TODO: range checking for mapped dimensions. */
3692 info
= &ss_info
->data
.array
;
3694 /* This code only checks ranges. Elemental and vector
3695 dimensions are checked later. */
3696 for (n
= 0; n
< loop
->dimen
; n
++)
3701 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
3704 if (dim
== info
->ref
->u
.ar
.dimen
- 1
3705 && info
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
3706 check_upper
= false;
3710 /* Zero stride is not allowed. */
3711 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
3712 info
->stride
[dim
], gfc_index_zero_node
);
3713 asprintf (&msg
, "Zero stride is not allowed, for dimension %d "
3714 "of array '%s'", dim
+ 1, expr_name
);
3715 gfc_trans_runtime_check (true, false, tmp
, &inner
,
3719 desc
= info
->descriptor
;
3721 /* This is the run-time equivalent of resolve.c's
3722 check_dimension(). The logical is more readable there
3723 than it is here, with all the trees. */
3724 lbound
= gfc_conv_array_lbound (desc
, dim
);
3725 end
= info
->end
[dim
];
3727 ubound
= gfc_conv_array_ubound (desc
, dim
);
3731 /* non_zerosized is true when the selected range is not
3733 stride_pos
= fold_build2_loc (input_location
, GT_EXPR
,
3734 boolean_type_node
, info
->stride
[dim
],
3735 gfc_index_zero_node
);
3736 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
3737 info
->start
[dim
], end
);
3738 stride_pos
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3739 boolean_type_node
, stride_pos
, tmp
);
3741 stride_neg
= fold_build2_loc (input_location
, LT_EXPR
,
3743 info
->stride
[dim
], gfc_index_zero_node
);
3744 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
3745 info
->start
[dim
], end
);
3746 stride_neg
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3749 non_zerosized
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
3751 stride_pos
, stride_neg
);
3753 /* Check the start of the range against the lower and upper
3754 bounds of the array, if the range is not empty.
3755 If upper bound is present, include both bounds in the
3759 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
3761 info
->start
[dim
], lbound
);
3762 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3764 non_zerosized
, tmp
);
3765 tmp2
= fold_build2_loc (input_location
, GT_EXPR
,
3767 info
->start
[dim
], ubound
);
3768 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3770 non_zerosized
, tmp2
);
3771 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
3772 "outside of expected range (%%ld:%%ld)",
3773 dim
+ 1, expr_name
);
3774 gfc_trans_runtime_check (true, false, tmp
, &inner
,
3776 fold_convert (long_integer_type_node
, info
->start
[dim
]),
3777 fold_convert (long_integer_type_node
, lbound
),
3778 fold_convert (long_integer_type_node
, ubound
));
3779 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
3781 fold_convert (long_integer_type_node
, info
->start
[dim
]),
3782 fold_convert (long_integer_type_node
, lbound
),
3783 fold_convert (long_integer_type_node
, ubound
));
3788 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
3790 info
->start
[dim
], lbound
);
3791 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3792 boolean_type_node
, non_zerosized
, tmp
);
3793 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
3794 "below lower bound of %%ld",
3795 dim
+ 1, expr_name
);
3796 gfc_trans_runtime_check (true, false, tmp
, &inner
,
3798 fold_convert (long_integer_type_node
, info
->start
[dim
]),
3799 fold_convert (long_integer_type_node
, lbound
));
3803 /* Compute the last element of the range, which is not
3804 necessarily "end" (think 0:5:3, which doesn't contain 5)
3805 and check it against both lower and upper bounds. */
3807 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3808 gfc_array_index_type
, end
,
3810 tmp
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
,
3811 gfc_array_index_type
, tmp
,
3813 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3814 gfc_array_index_type
, end
, tmp
);
3815 tmp2
= fold_build2_loc (input_location
, LT_EXPR
,
3816 boolean_type_node
, tmp
, lbound
);
3817 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3818 boolean_type_node
, non_zerosized
, tmp2
);
3821 tmp3
= fold_build2_loc (input_location
, GT_EXPR
,
3822 boolean_type_node
, tmp
, ubound
);
3823 tmp3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3824 boolean_type_node
, non_zerosized
, tmp3
);
3825 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
3826 "outside of expected range (%%ld:%%ld)",
3827 dim
+ 1, expr_name
);
3828 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
3830 fold_convert (long_integer_type_node
, tmp
),
3831 fold_convert (long_integer_type_node
, ubound
),
3832 fold_convert (long_integer_type_node
, lbound
));
3833 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
3835 fold_convert (long_integer_type_node
, tmp
),
3836 fold_convert (long_integer_type_node
, ubound
),
3837 fold_convert (long_integer_type_node
, lbound
));
3842 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
3843 "below lower bound of %%ld",
3844 dim
+ 1, expr_name
);
3845 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
3847 fold_convert (long_integer_type_node
, tmp
),
3848 fold_convert (long_integer_type_node
, lbound
));
3852 /* Check the section sizes match. */
3853 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3854 gfc_array_index_type
, end
,
3856 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
3857 gfc_array_index_type
, tmp
,
3859 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3860 gfc_array_index_type
,
3861 gfc_index_one_node
, tmp
);
3862 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
3863 gfc_array_index_type
, tmp
,
3864 build_int_cst (gfc_array_index_type
, 0));
3865 /* We remember the size of the first section, and check all the
3866 others against this. */
3869 tmp3
= fold_build2_loc (input_location
, NE_EXPR
,
3870 boolean_type_node
, tmp
, size
[n
]);
3871 asprintf (&msg
, "Array bound mismatch for dimension %d "
3872 "of array '%s' (%%ld/%%ld)",
3873 dim
+ 1, expr_name
);
3875 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
3877 fold_convert (long_integer_type_node
, tmp
),
3878 fold_convert (long_integer_type_node
, size
[n
]));
3883 size
[n
] = gfc_evaluate_now (tmp
, &inner
);
3886 tmp
= gfc_finish_block (&inner
);
3888 /* For optional arguments, only check bounds if the argument is
3890 if (expr
->symtree
->n
.sym
->attr
.optional
3891 || expr
->symtree
->n
.sym
->attr
.not_always_present
)
3892 tmp
= build3_v (COND_EXPR
,
3893 gfc_conv_expr_present (expr
->symtree
->n
.sym
),
3894 tmp
, build_empty_stmt (input_location
));
3896 gfc_add_expr_to_block (&block
, tmp
);
3900 tmp
= gfc_finish_block (&block
);
3901 gfc_add_expr_to_block (&loop
->pre
, tmp
);
3904 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
3905 gfc_conv_ss_startstride (loop
);
3908 /* Return true if both symbols could refer to the same data object. Does
3909 not take account of aliasing due to equivalence statements. */
3912 symbols_could_alias (gfc_symbol
*lsym
, gfc_symbol
*rsym
, bool lsym_pointer
,
3913 bool lsym_target
, bool rsym_pointer
, bool rsym_target
)
3915 /* Aliasing isn't possible if the symbols have different base types. */
3916 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
3919 /* Pointers can point to other pointers and target objects. */
3921 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
3922 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
3925 /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
3926 and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
3928 if (lsym_target
&& rsym_target
3929 && ((lsym
->attr
.dummy
&& !lsym
->attr
.contiguous
3930 && (!lsym
->attr
.dimension
|| lsym
->as
->type
== AS_ASSUMED_SHAPE
))
3931 || (rsym
->attr
.dummy
&& !rsym
->attr
.contiguous
3932 && (!rsym
->attr
.dimension
3933 || rsym
->as
->type
== AS_ASSUMED_SHAPE
))))
3940 /* Return true if the two SS could be aliased, i.e. both point to the same data
3942 /* TODO: resolve aliases based on frontend expressions. */
3945 gfc_could_be_alias (gfc_ss
* lss
, gfc_ss
* rss
)
3949 gfc_expr
*lexpr
, *rexpr
;
3952 bool lsym_pointer
, lsym_target
, rsym_pointer
, rsym_target
;
3954 lexpr
= lss
->info
->expr
;
3955 rexpr
= rss
->info
->expr
;
3957 lsym
= lexpr
->symtree
->n
.sym
;
3958 rsym
= rexpr
->symtree
->n
.sym
;
3960 lsym_pointer
= lsym
->attr
.pointer
;
3961 lsym_target
= lsym
->attr
.target
;
3962 rsym_pointer
= rsym
->attr
.pointer
;
3963 rsym_target
= rsym
->attr
.target
;
3965 if (symbols_could_alias (lsym
, rsym
, lsym_pointer
, lsym_target
,
3966 rsym_pointer
, rsym_target
))
3969 if (rsym
->ts
.type
!= BT_DERIVED
&& rsym
->ts
.type
!= BT_CLASS
3970 && lsym
->ts
.type
!= BT_DERIVED
&& lsym
->ts
.type
!= BT_CLASS
)
3973 /* For derived types we must check all the component types. We can ignore
3974 array references as these will have the same base type as the previous
3976 for (lref
= lexpr
->ref
; lref
!= lss
->info
->data
.array
.ref
; lref
= lref
->next
)
3978 if (lref
->type
!= REF_COMPONENT
)
3981 lsym_pointer
= lsym_pointer
|| lref
->u
.c
.sym
->attr
.pointer
;
3982 lsym_target
= lsym_target
|| lref
->u
.c
.sym
->attr
.target
;
3984 if (symbols_could_alias (lref
->u
.c
.sym
, rsym
, lsym_pointer
, lsym_target
,
3985 rsym_pointer
, rsym_target
))
3988 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
3989 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
3991 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
3996 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
;
3999 if (rref
->type
!= REF_COMPONENT
)
4002 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4003 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4005 if (symbols_could_alias (lref
->u
.c
.sym
, rref
->u
.c
.sym
,
4006 lsym_pointer
, lsym_target
,
4007 rsym_pointer
, rsym_target
))
4010 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4011 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4013 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4014 &rref
->u
.c
.sym
->ts
))
4016 if (gfc_compare_types (&lref
->u
.c
.sym
->ts
,
4017 &rref
->u
.c
.component
->ts
))
4019 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4020 &rref
->u
.c
.component
->ts
))
4026 lsym_pointer
= lsym
->attr
.pointer
;
4027 lsym_target
= lsym
->attr
.target
;
4028 lsym_pointer
= lsym
->attr
.pointer
;
4029 lsym_target
= lsym
->attr
.target
;
4031 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
; rref
= rref
->next
)
4033 if (rref
->type
!= REF_COMPONENT
)
4036 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4037 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4039 if (symbols_could_alias (rref
->u
.c
.sym
, lsym
,
4040 lsym_pointer
, lsym_target
,
4041 rsym_pointer
, rsym_target
))
4044 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4045 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4047 if (gfc_compare_types (&lsym
->ts
, &rref
->u
.c
.component
->ts
))
4056 /* Resolve array data dependencies. Creates a temporary if required. */
4057 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
4061 gfc_conv_resolve_dependencies (gfc_loopinfo
* loop
, gfc_ss
* dest
,
4067 gfc_expr
*dest_expr
;
4072 loop
->temp_ss
= NULL
;
4073 dest_expr
= dest
->info
->expr
;
4075 for (ss
= rss
; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
4077 if (ss
->info
->type
!= GFC_SS_SECTION
)
4080 ss_expr
= ss
->info
->expr
;
4082 if (dest_expr
->symtree
->n
.sym
!= ss_expr
->symtree
->n
.sym
)
4084 if (gfc_could_be_alias (dest
, ss
)
4085 || gfc_are_equivalenced_arrays (dest_expr
, ss_expr
))
4093 lref
= dest_expr
->ref
;
4094 rref
= ss_expr
->ref
;
4096 nDepend
= gfc_dep_resolver (lref
, rref
, &loop
->reverse
[0]);
4101 for (i
= 0; i
< dest
->dimen
; i
++)
4102 for (j
= 0; j
< ss
->dimen
; j
++)
4104 && dest
->dim
[i
] == ss
->dim
[j
])
4106 /* If we don't access array elements in the same order,
4107 there is a dependency. */
4112 /* TODO : loop shifting. */
4115 /* Mark the dimensions for LOOP SHIFTING */
4116 for (n
= 0; n
< loop
->dimen
; n
++)
4118 int dim
= dest
->data
.info
.dim
[n
];
4120 if (lref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
4122 else if (! gfc_is_same_range (&lref
->u
.ar
,
4123 &rref
->u
.ar
, dim
, 0))
4127 /* Put all the dimensions with dependencies in the
4130 for (n
= 0; n
< loop
->dimen
; n
++)
4132 gcc_assert (loop
->order
[n
] == n
);
4134 loop
->order
[dim
++] = n
;
4136 for (n
= 0; n
< loop
->dimen
; n
++)
4139 loop
->order
[dim
++] = n
;
4142 gcc_assert (dim
== loop
->dimen
);
4153 tree base_type
= gfc_typenode_for_spec (&dest_expr
->ts
);
4154 if (GFC_ARRAY_TYPE_P (base_type
)
4155 || GFC_DESCRIPTOR_TYPE_P (base_type
))
4156 base_type
= gfc_get_element_type (base_type
);
4157 loop
->temp_ss
= gfc_get_temp_ss (base_type
, dest
->info
->string_length
,
4159 gfc_add_ss_to_loop (loop
, loop
->temp_ss
);
4162 loop
->temp_ss
= NULL
;
4166 /* Browse through each array's information from the scalarizer and set the loop
4167 bounds according to the "best" one (per dimension), i.e. the one which
4168 provides the most information (constant bounds, shape, etc). */
4171 set_loop_bounds (gfc_loopinfo
*loop
)
4173 int n
, dim
, spec_dim
;
4174 gfc_array_info
*info
;
4175 gfc_array_info
*specinfo
;
4179 bool dynamic
[GFC_MAX_DIMENSIONS
];
4183 loopspec
= loop
->specloop
;
4186 for (n
= 0; n
< loop
->dimen
; n
++)
4190 /* We use one SS term, and use that to determine the bounds of the
4191 loop for this dimension. We try to pick the simplest term. */
4192 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4194 gfc_ss_type ss_type
;
4196 ss_type
= ss
->info
->type
;
4197 if (ss_type
== GFC_SS_SCALAR
4198 || ss_type
== GFC_SS_TEMP
4199 || ss_type
== GFC_SS_REFERENCE
)
4202 info
= &ss
->info
->data
.array
;
4205 if (loopspec
[n
] != NULL
)
4207 specinfo
= &loopspec
[n
]->info
->data
.array
;
4208 spec_dim
= loopspec
[n
]->dim
[n
];
4212 /* Silence unitialized warnings. */
4219 gcc_assert (info
->shape
[dim
]);
4220 /* The frontend has worked out the size for us. */
4223 || !integer_zerop (specinfo
->start
[spec_dim
]))
4224 /* Prefer zero-based descriptors if possible. */
4229 if (ss_type
== GFC_SS_CONSTRUCTOR
)
4231 gfc_constructor_base base
;
4232 /* An unknown size constructor will always be rank one.
4233 Higher rank constructors will either have known shape,
4234 or still be wrapped in a call to reshape. */
4235 gcc_assert (loop
->dimen
== 1);
4237 /* Always prefer to use the constructor bounds if the size
4238 can be determined at compile time. Prefer not to otherwise,
4239 since the general case involves realloc, and it's better to
4240 avoid that overhead if possible. */
4241 base
= ss
->info
->expr
->value
.constructor
;
4242 dynamic
[n
] = gfc_get_array_constructor_size (&i
, base
);
4243 if (!dynamic
[n
] || !loopspec
[n
])
4248 /* TODO: Pick the best bound if we have a choice between a
4249 function and something else. */
4250 if (ss_type
== GFC_SS_FUNCTION
)
4256 /* Avoid using an allocatable lhs in an assignment, since
4257 there might be a reallocation coming. */
4258 if (loopspec
[n
] && ss
->is_alloc_lhs
)
4261 if (ss_type
!= GFC_SS_SECTION
)
4266 /* Criteria for choosing a loop specifier (most important first):
4267 doesn't need realloc
4273 else if ((loopspec
[n
]->info
->type
== GFC_SS_CONSTRUCTOR
&& dynamic
[n
])
4274 || n
>= loop
->dimen
)
4276 else if (integer_onep (info
->stride
[dim
])
4277 && !integer_onep (specinfo
->stride
[spec_dim
]))
4279 else if (INTEGER_CST_P (info
->stride
[dim
])
4280 && !INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
4282 else if (INTEGER_CST_P (info
->start
[dim
])
4283 && !INTEGER_CST_P (specinfo
->start
[spec_dim
]))
4285 /* We don't work out the upper bound.
4286 else if (INTEGER_CST_P (info->finish[n])
4287 && ! INTEGER_CST_P (specinfo->finish[n]))
4288 loopspec[n] = ss; */
4291 /* We should have found the scalarization loop specifier. If not,
4293 gcc_assert (loopspec
[n
]);
4295 info
= &loopspec
[n
]->info
->data
.array
;
4296 dim
= loopspec
[n
]->dim
[n
];
4298 /* Set the extents of this range. */
4299 cshape
= info
->shape
;
4300 if (cshape
&& INTEGER_CST_P (info
->start
[dim
])
4301 && INTEGER_CST_P (info
->stride
[dim
]))
4303 loop
->from
[n
] = info
->start
[dim
];
4304 mpz_set (i
, cshape
[get_array_ref_dim_for_loop_dim (loopspec
[n
], n
)]);
4305 mpz_sub_ui (i
, i
, 1);
4306 /* To = from + (size - 1) * stride. */
4307 tmp
= gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
4308 if (!integer_onep (info
->stride
[dim
]))
4309 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
4310 gfc_array_index_type
, tmp
,
4312 loop
->to
[n
] = fold_build2_loc (input_location
, PLUS_EXPR
,
4313 gfc_array_index_type
,
4314 loop
->from
[n
], tmp
);
4318 loop
->from
[n
] = info
->start
[dim
];
4319 switch (loopspec
[n
]->info
->type
)
4321 case GFC_SS_CONSTRUCTOR
:
4322 /* The upper bound is calculated when we expand the
4324 gcc_assert (loop
->to
[n
] == NULL_TREE
);
4327 case GFC_SS_SECTION
:
4328 /* Use the end expression if it exists and is not constant,
4329 so that it is only evaluated once. */
4330 loop
->to
[n
] = info
->end
[dim
];
4333 case GFC_SS_FUNCTION
:
4334 /* The loop bound will be set when we generate the call. */
4335 gcc_assert (loop
->to
[n
] == NULL_TREE
);
4343 /* Transform everything so we have a simple incrementing variable. */
4344 if (n
< loop
->dimen
&& integer_onep (info
->stride
[dim
]))
4345 info
->delta
[dim
] = gfc_index_zero_node
;
4346 else if (n
< loop
->dimen
)
4348 /* Set the delta for this section. */
4349 info
->delta
[dim
] = gfc_evaluate_now (loop
->from
[n
], &loop
->pre
);
4350 /* Number of iterations is (end - start + step) / step.
4351 with start = 0, this simplifies to
4353 for (i = 0; i<=last; i++){...}; */
4354 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4355 gfc_array_index_type
, loop
->to
[n
],
4357 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
4358 gfc_array_index_type
, tmp
, info
->stride
[dim
]);
4359 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
4360 tmp
, build_int_cst (gfc_array_index_type
, -1));
4361 loop
->to
[n
] = gfc_evaluate_now (tmp
, &loop
->pre
);
4362 /* Make the loop variable start at 0. */
4363 loop
->from
[n
] = gfc_index_zero_node
;
4368 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4369 set_loop_bounds (loop
);
4373 /* Initialize the scalarization loop. Creates the loop variables. Determines
4374 the range of the loop variables. Creates a temporary if required.
4375 Also generates code for scalar expressions which have been
4376 moved outside the loop. */
4379 gfc_conv_loop_setup (gfc_loopinfo
* loop
, locus
* where
)
4384 set_loop_bounds (loop
);
4386 /* Add all the scalar code that can be taken out of the loops.
4387 This may include calculating the loop bounds, so do it before
4388 allocating the temporary. */
4389 gfc_add_loop_ss_code (loop
, loop
->ss
, false, where
);
4391 tmp_ss
= loop
->temp_ss
;
4392 /* If we want a temporary then create it. */
4395 gfc_ss_info
*tmp_ss_info
;
4397 tmp_ss_info
= tmp_ss
->info
;
4398 gcc_assert (tmp_ss_info
->type
== GFC_SS_TEMP
);
4399 gcc_assert (loop
->parent
== NULL
);
4401 /* Make absolutely sure that this is a complete type. */
4402 if (tmp_ss_info
->string_length
)
4403 tmp_ss_info
->data
.temp
.type
4404 = gfc_get_character_type_len_for_eltype
4405 (TREE_TYPE (tmp_ss_info
->data
.temp
.type
),
4406 tmp_ss_info
->string_length
);
4408 tmp
= tmp_ss_info
->data
.temp
.type
;
4409 memset (&tmp_ss_info
->data
.array
, 0, sizeof (gfc_array_info
));
4410 tmp_ss_info
->type
= GFC_SS_SECTION
;
4412 gcc_assert (tmp_ss
->dimen
!= 0);
4414 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, tmp_ss
, tmp
,
4415 NULL_TREE
, false, true, false, where
);
4418 /* For array parameters we don't have loop variables, so don't calculate the
4420 if (!loop
->array_parameter
)
4421 gfc_set_delta (loop
);
4425 /* Calculates how to transform from loop variables to array indices for each
4426 array: once loop bounds are chosen, sets the difference (DELTA field) between
4427 loop bounds and array reference bounds, for each array info. */
4430 gfc_set_delta (gfc_loopinfo
*loop
)
4432 gfc_ss
*ss
, **loopspec
;
4433 gfc_array_info
*info
;
4437 loopspec
= loop
->specloop
;
4439 /* Calculate the translation from loop variables to array indices. */
4440 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4442 gfc_ss_type ss_type
;
4444 ss_type
= ss
->info
->type
;
4445 if (ss_type
!= GFC_SS_SECTION
4446 && ss_type
!= GFC_SS_COMPONENT
4447 && ss_type
!= GFC_SS_CONSTRUCTOR
)
4450 info
= &ss
->info
->data
.array
;
4452 for (n
= 0; n
< ss
->dimen
; n
++)
4454 /* If we are specifying the range the delta is already set. */
4455 if (loopspec
[n
] != ss
)
4459 /* Calculate the offset relative to the loop variable.
4460 First multiply by the stride. */
4461 tmp
= loop
->from
[n
];
4462 if (!integer_onep (info
->stride
[dim
]))
4463 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
4464 gfc_array_index_type
,
4465 tmp
, info
->stride
[dim
]);
4467 /* Then subtract this from our starting value. */
4468 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4469 gfc_array_index_type
,
4470 info
->start
[dim
], tmp
);
4472 info
->delta
[dim
] = gfc_evaluate_now (tmp
, &loop
->pre
);
4477 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4478 gfc_set_delta (loop
);
4482 /* Calculate the size of a given array dimension from the bounds. This
4483 is simply (ubound - lbound + 1) if this expression is positive
4484 or 0 if it is negative (pick either one if it is zero). Optionally
4485 (if or_expr is present) OR the (expression != 0) condition to it. */
4488 gfc_conv_array_extent_dim (tree lbound
, tree ubound
, tree
* or_expr
)
4493 /* Calculate (ubound - lbound + 1). */
4494 res
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4496 res
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
, res
,
4497 gfc_index_one_node
);
4499 /* Check whether the size for this dimension is negative. */
4500 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, res
,
4501 gfc_index_zero_node
);
4502 res
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
, cond
,
4503 gfc_index_zero_node
, res
);
4505 /* Build OR expression. */
4507 *or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
4508 boolean_type_node
, *or_expr
, cond
);
4514 /* For an array descriptor, get the total number of elements. This is just
4515 the product of the extents along from_dim to to_dim. */
4518 gfc_conv_descriptor_size_1 (tree desc
, int from_dim
, int to_dim
)
4523 res
= gfc_index_one_node
;
4525 for (dim
= from_dim
; dim
< to_dim
; ++dim
)
4531 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]);
4532 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]);
4534 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
4535 res
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4543 /* Full size of an array. */
4546 gfc_conv_descriptor_size (tree desc
, int rank
)
4548 return gfc_conv_descriptor_size_1 (desc
, 0, rank
);
4552 /* Size of a coarray for all dimensions but the last. */
4555 gfc_conv_descriptor_cosize (tree desc
, int rank
, int corank
)
4557 return gfc_conv_descriptor_size_1 (desc
, rank
, rank
+ corank
- 1);
4561 /* Fills in an array descriptor, and returns the size of the array.
4562 The size will be a simple_val, ie a variable or a constant. Also
4563 calculates the offset of the base. The pointer argument overflow,
4564 which should be of integer type, will increase in value if overflow
4565 occurs during the size calculation. Returns the size of the array.
4569 for (n = 0; n < rank; n++)
4571 a.lbound[n] = specified_lower_bound;
4572 offset = offset + a.lbond[n] * stride;
4574 a.ubound[n] = specified_upper_bound;
4575 a.stride[n] = stride;
4576 size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
4577 overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
4578 stride = stride * size;
4580 for (n = rank; n < rank+corank; n++)
4581 (Set lcobound/ucobound as above.)
4582 element_size = sizeof (array element);
4585 stride = (size_t) stride;
4586 overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
4587 stride = stride * element_size;
4593 gfc_array_init_size (tree descriptor
, int rank
, int corank
, tree
* poffset
,
4594 gfc_expr
** lower
, gfc_expr
** upper
, stmtblock_t
* pblock
,
4595 stmtblock_t
* descriptor_block
, tree
* overflow
)
4608 stmtblock_t thenblock
;
4609 stmtblock_t elseblock
;
4614 type
= TREE_TYPE (descriptor
);
4616 stride
= gfc_index_one_node
;
4617 offset
= gfc_index_zero_node
;
4619 /* Set the dtype. */
4620 tmp
= gfc_conv_descriptor_dtype (descriptor
);
4621 gfc_add_modify (descriptor_block
, tmp
, gfc_get_dtype (TREE_TYPE (descriptor
)));
4623 or_expr
= boolean_false_node
;
4625 for (n
= 0; n
< rank
; n
++)
4630 /* We have 3 possibilities for determining the size of the array:
4631 lower == NULL => lbound = 1, ubound = upper[n]
4632 upper[n] = NULL => lbound = 1, ubound = lower[n]
4633 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
4636 /* Set lower bound. */
4637 gfc_init_se (&se
, NULL
);
4639 se
.expr
= gfc_index_one_node
;
4642 gcc_assert (lower
[n
]);
4645 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
4646 gfc_add_block_to_block (pblock
, &se
.pre
);
4650 se
.expr
= gfc_index_one_node
;
4654 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
4655 gfc_rank_cst
[n
], se
.expr
);
4656 conv_lbound
= se
.expr
;
4658 /* Work out the offset for this component. */
4659 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4661 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
4662 gfc_array_index_type
, offset
, tmp
);
4664 /* Set upper bound. */
4665 gfc_init_se (&se
, NULL
);
4666 gcc_assert (ubound
);
4667 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
4668 gfc_add_block_to_block (pblock
, &se
.pre
);
4670 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
4671 gfc_rank_cst
[n
], se
.expr
);
4672 conv_ubound
= se
.expr
;
4674 /* Store the stride. */
4675 gfc_conv_descriptor_stride_set (descriptor_block
, descriptor
,
4676 gfc_rank_cst
[n
], stride
);
4678 /* Calculate size and check whether extent is negative. */
4679 size
= gfc_conv_array_extent_dim (conv_lbound
, conv_ubound
, &or_expr
);
4680 size
= gfc_evaluate_now (size
, pblock
);
4682 /* Check whether multiplying the stride by the number of
4683 elements in this dimension would overflow. We must also check
4684 whether the current dimension has zero size in order to avoid
4687 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
4688 gfc_array_index_type
,
4689 fold_convert (gfc_array_index_type
,
4690 TYPE_MAX_VALUE (gfc_array_index_type
)),
4692 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
4693 boolean_type_node
, tmp
, stride
));
4694 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
4695 integer_one_node
, integer_zero_node
);
4696 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
4697 boolean_type_node
, size
,
4698 gfc_index_zero_node
));
4699 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
4700 integer_zero_node
, tmp
);
4701 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
4703 *overflow
= gfc_evaluate_now (tmp
, pblock
);
4705 /* Multiply the stride by the number of elements in this dimension. */
4706 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
4707 gfc_array_index_type
, stride
, size
);
4708 stride
= gfc_evaluate_now (stride
, pblock
);
4711 for (n
= rank
; n
< rank
+ corank
; n
++)
4715 /* Set lower bound. */
4716 gfc_init_se (&se
, NULL
);
4717 if (lower
== NULL
|| lower
[n
] == NULL
)
4719 gcc_assert (n
== rank
+ corank
- 1);
4720 se
.expr
= gfc_index_one_node
;
4724 if (ubound
|| n
== rank
+ corank
- 1)
4726 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
4727 gfc_add_block_to_block (pblock
, &se
.pre
);
4731 se
.expr
= gfc_index_one_node
;
4735 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
4736 gfc_rank_cst
[n
], se
.expr
);
4738 if (n
< rank
+ corank
- 1)
4740 gfc_init_se (&se
, NULL
);
4741 gcc_assert (ubound
);
4742 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
4743 gfc_add_block_to_block (pblock
, &se
.pre
);
4744 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
4745 gfc_rank_cst
[n
], se
.expr
);
4749 /* The stride is the number of elements in the array, so multiply by the
4750 size of an element to get the total size. */
4751 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
4752 /* Convert to size_t. */
4753 element_size
= fold_convert (size_type_node
, tmp
);
4756 return element_size
;
4758 stride
= fold_convert (size_type_node
, stride
);
4760 /* First check for overflow. Since an array of type character can
4761 have zero element_size, we must check for that before
4763 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
4765 TYPE_MAX_VALUE (size_type_node
), element_size
);
4766 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
4767 boolean_type_node
, tmp
, stride
));
4768 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
4769 integer_one_node
, integer_zero_node
);
4770 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
4771 boolean_type_node
, element_size
,
4772 build_int_cst (size_type_node
, 0)));
4773 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
4774 integer_zero_node
, tmp
);
4775 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
4777 *overflow
= gfc_evaluate_now (tmp
, pblock
);
4779 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
4780 stride
, element_size
);
4782 if (poffset
!= NULL
)
4784 offset
= gfc_evaluate_now (offset
, pblock
);
4788 if (integer_zerop (or_expr
))
4790 if (integer_onep (or_expr
))
4791 return build_int_cst (size_type_node
, 0);
4793 var
= gfc_create_var (TREE_TYPE (size
), "size");
4794 gfc_start_block (&thenblock
);
4795 gfc_add_modify (&thenblock
, var
, build_int_cst (size_type_node
, 0));
4796 thencase
= gfc_finish_block (&thenblock
);
4798 gfc_start_block (&elseblock
);
4799 gfc_add_modify (&elseblock
, var
, size
);
4800 elsecase
= gfc_finish_block (&elseblock
);
4802 tmp
= gfc_evaluate_now (or_expr
, pblock
);
4803 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
4804 gfc_add_expr_to_block (pblock
, tmp
);
4810 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
4811 the work for an ALLOCATE statement. */
4815 gfc_array_allocate (gfc_se
* se
, gfc_expr
* expr
, tree status
, tree errmsg
,
4820 tree offset
= NULL_TREE
;
4821 tree token
= NULL_TREE
;
4824 tree error
= NULL_TREE
;
4825 tree overflow
; /* Boolean storing whether size calculation overflows. */
4826 tree var_overflow
= NULL_TREE
;
4828 tree set_descriptor
;
4829 stmtblock_t set_descriptor_block
;
4830 stmtblock_t elseblock
;
4833 gfc_ref
*ref
, *prev_ref
= NULL
;
4834 bool allocatable
, coarray
, dimension
;
4838 /* Find the last reference in the chain. */
4839 while (ref
&& ref
->next
!= NULL
)
4841 gcc_assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
4842 || (ref
->u
.ar
.dimen
== 0 && ref
->u
.ar
.codimen
> 0));
4847 if (ref
== NULL
|| ref
->type
!= REF_ARRAY
)
4852 allocatable
= expr
->symtree
->n
.sym
->attr
.allocatable
;
4853 coarray
= expr
->symtree
->n
.sym
->attr
.codimension
;
4854 dimension
= expr
->symtree
->n
.sym
->attr
.dimension
;
4858 allocatable
= prev_ref
->u
.c
.component
->attr
.allocatable
;
4859 coarray
= prev_ref
->u
.c
.component
->attr
.codimension
;
4860 dimension
= prev_ref
->u
.c
.component
->attr
.dimension
;
4864 gcc_assert (coarray
);
4866 /* Figure out the size of the array. */
4867 switch (ref
->u
.ar
.type
)
4873 upper
= ref
->u
.ar
.start
;
4879 lower
= ref
->u
.ar
.start
;
4880 upper
= ref
->u
.ar
.end
;
4884 gcc_assert (ref
->u
.ar
.as
->type
== AS_EXPLICIT
);
4886 lower
= ref
->u
.ar
.as
->lower
;
4887 upper
= ref
->u
.ar
.as
->upper
;
4895 overflow
= integer_zero_node
;
4897 gfc_init_block (&set_descriptor_block
);
4898 size
= gfc_array_init_size (se
->expr
, ref
->u
.ar
.as
->rank
,
4899 ref
->u
.ar
.as
->corank
, &offset
, lower
, upper
,
4900 &se
->pre
, &set_descriptor_block
, &overflow
);
4905 var_overflow
= gfc_create_var (integer_type_node
, "overflow");
4906 gfc_add_modify (&se
->pre
, var_overflow
, overflow
);
4908 /* Generate the block of code handling overflow. */
4909 msg
= gfc_build_addr_expr (pchar_type_node
,
4910 gfc_build_localized_cstring_const
4911 ("Integer overflow when calculating the amount of "
4912 "memory to allocate"));
4913 error
= build_call_expr_loc (input_location
, gfor_fndecl_runtime_error
,
4917 if (status
!= NULL_TREE
)
4919 tree status_type
= TREE_TYPE (status
);
4920 stmtblock_t set_status_block
;
4922 gfc_start_block (&set_status_block
);
4923 gfc_add_modify (&set_status_block
, status
,
4924 build_int_cst (status_type
, LIBERROR_ALLOCATION
));
4925 error
= gfc_finish_block (&set_status_block
);
4928 gfc_start_block (&elseblock
);
4930 /* Allocate memory to store the data. */
4931 pointer
= gfc_conv_descriptor_data_get (se
->expr
);
4932 STRIP_NOPS (pointer
);
4934 if (coarray
&& gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
4935 token
= gfc_build_addr_expr (NULL_TREE
,
4936 gfc_conv_descriptor_token (se
->expr
));
4938 /* The allocatable variant takes the old pointer as first argument. */
4940 gfc_allocate_allocatable (&elseblock
, pointer
, size
, token
,
4941 status
, errmsg
, errlen
, expr
);
4943 gfc_allocate_using_malloc (&elseblock
, pointer
, size
, status
);
4947 cond
= gfc_unlikely (fold_build2_loc (input_location
, NE_EXPR
,
4948 boolean_type_node
, var_overflow
, integer_zero_node
));
4949 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
4950 error
, gfc_finish_block (&elseblock
));
4953 tmp
= gfc_finish_block (&elseblock
);
4955 gfc_add_expr_to_block (&se
->pre
, tmp
);
4957 /* Update the array descriptors. */
4959 gfc_conv_descriptor_offset_set (&set_descriptor_block
, se
->expr
, offset
);
4961 set_descriptor
= gfc_finish_block (&set_descriptor_block
);
4962 if (status
!= NULL_TREE
)
4964 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
4965 boolean_type_node
, status
,
4966 build_int_cst (TREE_TYPE (status
), 0));
4967 gfc_add_expr_to_block (&se
->pre
,
4968 fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
4969 gfc_likely (cond
), set_descriptor
,
4970 build_empty_stmt (input_location
)));
4973 gfc_add_expr_to_block (&se
->pre
, set_descriptor
);
4975 if ((expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
)
4976 && expr
->ts
.u
.derived
->attr
.alloc_comp
)
4978 tmp
= gfc_nullify_alloc_comp (expr
->ts
.u
.derived
, se
->expr
,
4979 ref
->u
.ar
.as
->rank
);
4980 gfc_add_expr_to_block (&se
->pre
, tmp
);
4987 /* Deallocate an array variable. Also used when an allocated variable goes
4992 gfc_array_deallocate (tree descriptor
, tree pstat
, gfc_expr
* expr
)
4998 gfc_start_block (&block
);
4999 /* Get a pointer to the data. */
5000 var
= gfc_conv_descriptor_data_get (descriptor
);
5003 /* Parameter is the address of the data component. */
5004 tmp
= gfc_deallocate_with_status (var
, pstat
, false, expr
);
5005 gfc_add_expr_to_block (&block
, tmp
);
5007 /* Zero the data pointer. */
5008 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
5009 var
, build_int_cst (TREE_TYPE (var
), 0));
5010 gfc_add_expr_to_block (&block
, tmp
);
5012 return gfc_finish_block (&block
);
5016 /* Create an array constructor from an initialization expression.
5017 We assume the frontend already did any expansions and conversions. */
5020 gfc_conv_array_initializer (tree type
, gfc_expr
* expr
)
5026 unsigned HOST_WIDE_INT lo
;
5028 VEC(constructor_elt
,gc
) *v
= NULL
;
5030 switch (expr
->expr_type
)
5033 case EXPR_STRUCTURE
:
5034 /* A single scalar or derived type value. Create an array with all
5035 elements equal to that value. */
5036 gfc_init_se (&se
, NULL
);
5038 if (expr
->expr_type
== EXPR_CONSTANT
)
5039 gfc_conv_constant (&se
, expr
);
5041 gfc_conv_structure (&se
, expr
, 1);
5043 tmp
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
5044 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
5045 hi
= TREE_INT_CST_HIGH (tmp
);
5046 lo
= TREE_INT_CST_LOW (tmp
);
5050 /* This will probably eat buckets of memory for large arrays. */
5051 while (hi
!= 0 || lo
!= 0)
5053 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
, se
.expr
);
5061 /* Create a vector of all the elements. */
5062 for (c
= gfc_constructor_first (expr
->value
.constructor
);
5063 c
; c
= gfc_constructor_next (c
))
5067 /* Problems occur when we get something like
5068 integer :: a(lots) = (/(i, i=1, lots)/) */
5069 gfc_fatal_error ("The number of elements in the array constructor "
5070 "at %L requires an increase of the allowed %d "
5071 "upper limit. See -fmax-array-constructor "
5072 "option", &expr
->where
,
5073 gfc_option
.flag_max_array_constructor
);
5076 if (mpz_cmp_si (c
->offset
, 0) != 0)
5077 index
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
5081 if (mpz_cmp_si (c
->repeat
, 1) > 0)
5087 mpz_add (maxval
, c
->offset
, c
->repeat
);
5088 mpz_sub_ui (maxval
, maxval
, 1);
5089 tmp2
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
5090 if (mpz_cmp_si (c
->offset
, 0) != 0)
5092 mpz_add_ui (maxval
, c
->offset
, 1);
5093 tmp1
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
5096 tmp1
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
5098 range
= fold_build2 (RANGE_EXPR
, gfc_array_index_type
, tmp1
, tmp2
);
5104 gfc_init_se (&se
, NULL
);
5105 switch (c
->expr
->expr_type
)
5108 gfc_conv_constant (&se
, c
->expr
);
5111 case EXPR_STRUCTURE
:
5112 gfc_conv_structure (&se
, c
->expr
, 1);
5116 /* Catch those occasional beasts that do not simplify
5117 for one reason or another, assuming that if they are
5118 standard defying the frontend will catch them. */
5119 gfc_conv_expr (&se
, c
->expr
);
5123 if (range
== NULL_TREE
)
5124 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
5127 if (index
!= NULL_TREE
)
5128 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
5129 CONSTRUCTOR_APPEND_ELT (v
, range
, se
.expr
);
5135 return gfc_build_null_descriptor (type
);
5141 /* Create a constructor from the list of elements. */
5142 tmp
= build_constructor (type
, v
);
5143 TREE_CONSTANT (tmp
) = 1;
5148 /* Generate code to evaluate non-constant coarray cobounds. */
5151 gfc_trans_array_cobounds (tree type
, stmtblock_t
* pblock
,
5152 const gfc_symbol
*sym
)
5162 for (dim
= as
->rank
; dim
< as
->rank
+ as
->corank
; dim
++)
5164 /* Evaluate non-constant array bound expressions. */
5165 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
5166 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
5168 gfc_init_se (&se
, NULL
);
5169 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
5170 gfc_add_block_to_block (pblock
, &se
.pre
);
5171 gfc_add_modify (pblock
, lbound
, se
.expr
);
5173 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
5174 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
5176 gfc_init_se (&se
, NULL
);
5177 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
5178 gfc_add_block_to_block (pblock
, &se
.pre
);
5179 gfc_add_modify (pblock
, ubound
, se
.expr
);
5185 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
5186 returns the size (in elements) of the array. */
5189 gfc_trans_array_bounds (tree type
, gfc_symbol
* sym
, tree
* poffset
,
5190 stmtblock_t
* pblock
)
5205 size
= gfc_index_one_node
;
5206 offset
= gfc_index_zero_node
;
5207 for (dim
= 0; dim
< as
->rank
; dim
++)
5209 /* Evaluate non-constant array bound expressions. */
5210 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
5211 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
5213 gfc_init_se (&se
, NULL
);
5214 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
5215 gfc_add_block_to_block (pblock
, &se
.pre
);
5216 gfc_add_modify (pblock
, lbound
, se
.expr
);
5218 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
5219 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
5221 gfc_init_se (&se
, NULL
);
5222 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
5223 gfc_add_block_to_block (pblock
, &se
.pre
);
5224 gfc_add_modify (pblock
, ubound
, se
.expr
);
5226 /* The offset of this dimension. offset = offset - lbound * stride. */
5227 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5229 offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5232 /* The size of this dimension, and the stride of the next. */
5233 if (dim
+ 1 < as
->rank
)
5234 stride
= GFC_TYPE_ARRAY_STRIDE (type
, dim
+ 1);
5236 stride
= GFC_TYPE_ARRAY_SIZE (type
);
5238 if (ubound
!= NULL_TREE
&& !(stride
&& INTEGER_CST_P (stride
)))
5240 /* Calculate stride = size * (ubound + 1 - lbound). */
5241 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5242 gfc_array_index_type
,
5243 gfc_index_one_node
, lbound
);
5244 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5245 gfc_array_index_type
, ubound
, tmp
);
5246 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5247 gfc_array_index_type
, size
, tmp
);
5249 gfc_add_modify (pblock
, stride
, tmp
);
5251 stride
= gfc_evaluate_now (tmp
, pblock
);
5253 /* Make sure that negative size arrays are translated
5254 to being zero size. */
5255 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
5256 stride
, gfc_index_zero_node
);
5257 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5258 gfc_array_index_type
, tmp
,
5259 stride
, gfc_index_zero_node
);
5260 gfc_add_modify (pblock
, stride
, tmp
);
5266 gfc_trans_array_cobounds (type
, pblock
, sym
);
5267 gfc_trans_vla_type_sizes (sym
, pblock
);
5274 /* Generate code to initialize/allocate an array variable. */
5277 gfc_trans_auto_array_allocation (tree decl
, gfc_symbol
* sym
,
5278 gfc_wrapped_block
* block
)
5282 tree tmp
= NULL_TREE
;
5289 gcc_assert (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
));
5291 /* Do nothing for USEd variables. */
5292 if (sym
->attr
.use_assoc
)
5295 type
= TREE_TYPE (decl
);
5296 gcc_assert (GFC_ARRAY_TYPE_P (type
));
5297 onstack
= TREE_CODE (type
) != POINTER_TYPE
;
5299 gfc_init_block (&init
);
5301 /* Evaluate character string length. */
5302 if (sym
->ts
.type
== BT_CHARACTER
5303 && onstack
&& !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
5305 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
5307 gfc_trans_vla_type_sizes (sym
, &init
);
5309 /* Emit a DECL_EXPR for this variable, which will cause the
5310 gimplifier to allocate storage, and all that good stuff. */
5311 tmp
= fold_build1_loc (input_location
, DECL_EXPR
, TREE_TYPE (decl
), decl
);
5312 gfc_add_expr_to_block (&init
, tmp
);
5317 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
5321 type
= TREE_TYPE (type
);
5323 gcc_assert (!sym
->attr
.use_assoc
);
5324 gcc_assert (!TREE_STATIC (decl
));
5325 gcc_assert (!sym
->module
);
5327 if (sym
->ts
.type
== BT_CHARACTER
5328 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
5329 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
5331 size
= gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
5333 /* Don't actually allocate space for Cray Pointees. */
5334 if (sym
->attr
.cray_pointee
)
5336 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
5337 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
5339 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
5343 if (gfc_option
.flag_stack_arrays
)
5345 gcc_assert (TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
);
5346 space
= build_decl (sym
->declared_at
.lb
->location
,
5347 VAR_DECL
, create_tmp_var_name ("A"),
5348 TREE_TYPE (TREE_TYPE (decl
)));
5349 gfc_trans_vla_type_sizes (sym
, &init
);
5353 /* The size is the number of elements in the array, so multiply by the
5354 size of an element to get the total size. */
5355 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
5356 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5357 size
, fold_convert (gfc_array_index_type
, tmp
));
5359 /* Allocate memory to hold the data. */
5360 tmp
= gfc_call_malloc (&init
, TREE_TYPE (decl
), size
);
5361 gfc_add_modify (&init
, decl
, tmp
);
5363 /* Free the temporary. */
5364 tmp
= gfc_call_free (convert (pvoid_type_node
, decl
));
5368 /* Set offset of the array. */
5369 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
5370 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
5372 /* Automatic arrays should not have initializers. */
5373 gcc_assert (!sym
->value
);
5375 inittree
= gfc_finish_block (&init
);
5382 /* Don't create new scope, emit the DECL_EXPR in exactly the scope
5383 where also space is located. */
5384 gfc_init_block (&init
);
5385 tmp
= fold_build1_loc (input_location
, DECL_EXPR
,
5386 TREE_TYPE (space
), space
);
5387 gfc_add_expr_to_block (&init
, tmp
);
5388 addr
= fold_build1_loc (sym
->declared_at
.lb
->location
,
5389 ADDR_EXPR
, TREE_TYPE (decl
), space
);
5390 gfc_add_modify (&init
, decl
, addr
);
5391 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
5394 gfc_add_init_cleanup (block
, inittree
, tmp
);
5398 /* Generate entry and exit code for g77 calling convention arrays. */
5401 gfc_trans_g77_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
5411 gfc_save_backend_locus (&loc
);
5412 gfc_set_backend_locus (&sym
->declared_at
);
5414 /* Descriptor type. */
5415 parm
= sym
->backend_decl
;
5416 type
= TREE_TYPE (parm
);
5417 gcc_assert (GFC_ARRAY_TYPE_P (type
));
5419 gfc_start_block (&init
);
5421 if (sym
->ts
.type
== BT_CHARACTER
5422 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
5423 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
5425 /* Evaluate the bounds of the array. */
5426 gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
5428 /* Set the offset. */
5429 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
5430 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
5432 /* Set the pointer itself if we aren't using the parameter directly. */
5433 if (TREE_CODE (parm
) != PARM_DECL
)
5435 tmp
= convert (TREE_TYPE (parm
), GFC_DECL_SAVED_DESCRIPTOR (parm
));
5436 gfc_add_modify (&init
, parm
, tmp
);
5438 stmt
= gfc_finish_block (&init
);
5440 gfc_restore_backend_locus (&loc
);
5442 /* Add the initialization code to the start of the function. */
5444 if (sym
->attr
.optional
|| sym
->attr
.not_always_present
)
5446 tmp
= gfc_conv_expr_present (sym
);
5447 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
5450 gfc_add_init_cleanup (block
, stmt
, NULL_TREE
);
5454 /* Modify the descriptor of an array parameter so that it has the
5455 correct lower bound. Also move the upper bound accordingly.
5456 If the array is not packed, it will be copied into a temporary.
5457 For each dimension we set the new lower and upper bounds. Then we copy the
5458 stride and calculate the offset for this dimension. We also work out
5459 what the stride of a packed array would be, and see it the two match.
5460 If the array need repacking, we set the stride to the values we just
5461 calculated, recalculate the offset and copy the array data.
5462 Code is also added to copy the data back at the end of the function.
5466 gfc_trans_dummy_array_bias (gfc_symbol
* sym
, tree tmpdesc
,
5467 gfc_wrapped_block
* block
)
5474 tree stmtInit
, stmtCleanup
;
5481 tree stride
, stride2
;
5491 /* Do nothing for pointer and allocatable arrays. */
5492 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
5495 if (sym
->attr
.dummy
&& gfc_is_nodesc_array (sym
))
5497 gfc_trans_g77_array (sym
, block
);
5501 gfc_save_backend_locus (&loc
);
5502 gfc_set_backend_locus (&sym
->declared_at
);
5504 /* Descriptor type. */
5505 type
= TREE_TYPE (tmpdesc
);
5506 gcc_assert (GFC_ARRAY_TYPE_P (type
));
5507 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
5508 dumdesc
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
5509 gfc_start_block (&init
);
5511 if (sym
->ts
.type
== BT_CHARACTER
5512 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
5513 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
5515 checkparm
= (sym
->as
->type
== AS_EXPLICIT
5516 && (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
));
5518 no_repack
= !(GFC_DECL_PACKED_ARRAY (tmpdesc
)
5519 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
));
5521 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
))
5523 /* For non-constant shape arrays we only check if the first dimension
5524 is contiguous. Repacking higher dimensions wouldn't gain us
5525 anything as we still don't know the array stride. */
5526 partial
= gfc_create_var (boolean_type_node
, "partial");
5527 TREE_USED (partial
) = 1;
5528 tmp
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
5529 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, tmp
,
5530 gfc_index_one_node
);
5531 gfc_add_modify (&init
, partial
, tmp
);
5534 partial
= NULL_TREE
;
5536 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
5537 here, however I think it does the right thing. */
5540 /* Set the first stride. */
5541 stride
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
5542 stride
= gfc_evaluate_now (stride
, &init
);
5544 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5545 stride
, gfc_index_zero_node
);
5546 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
5547 tmp
, gfc_index_one_node
, stride
);
5548 stride
= GFC_TYPE_ARRAY_STRIDE (type
, 0);
5549 gfc_add_modify (&init
, stride
, tmp
);
5551 /* Allow the user to disable array repacking. */
5552 stmt_unpacked
= NULL_TREE
;
5556 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type
, 0)));
5557 /* A library call to repack the array if necessary. */
5558 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
5559 stmt_unpacked
= build_call_expr_loc (input_location
,
5560 gfor_fndecl_in_pack
, 1, tmp
);
5562 stride
= gfc_index_one_node
;
5564 if (gfc_option
.warn_array_temp
)
5565 gfc_warning ("Creating array temporary at %L", &loc
);
5568 /* This is for the case where the array data is used directly without
5569 calling the repack function. */
5570 if (no_repack
|| partial
!= NULL_TREE
)
5571 stmt_packed
= gfc_conv_descriptor_data_get (dumdesc
);
5573 stmt_packed
= NULL_TREE
;
5575 /* Assign the data pointer. */
5576 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
5578 /* Don't repack unknown shape arrays when the first stride is 1. */
5579 tmp
= fold_build3_loc (input_location
, COND_EXPR
, TREE_TYPE (stmt_packed
),
5580 partial
, stmt_packed
, stmt_unpacked
);
5583 tmp
= stmt_packed
!= NULL_TREE
? stmt_packed
: stmt_unpacked
;
5584 gfc_add_modify (&init
, tmpdesc
, fold_convert (type
, tmp
));
5586 offset
= gfc_index_zero_node
;
5587 size
= gfc_index_one_node
;
5589 /* Evaluate the bounds of the array. */
5590 for (n
= 0; n
< sym
->as
->rank
; n
++)
5592 if (checkparm
|| !sym
->as
->upper
[n
])
5594 /* Get the bounds of the actual parameter. */
5595 dubound
= gfc_conv_descriptor_ubound_get (dumdesc
, gfc_rank_cst
[n
]);
5596 dlbound
= gfc_conv_descriptor_lbound_get (dumdesc
, gfc_rank_cst
[n
]);
5600 dubound
= NULL_TREE
;
5601 dlbound
= NULL_TREE
;
5604 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, n
);
5605 if (!INTEGER_CST_P (lbound
))
5607 gfc_init_se (&se
, NULL
);
5608 gfc_conv_expr_type (&se
, sym
->as
->lower
[n
],
5609 gfc_array_index_type
);
5610 gfc_add_block_to_block (&init
, &se
.pre
);
5611 gfc_add_modify (&init
, lbound
, se
.expr
);
5614 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, n
);
5615 /* Set the desired upper bound. */
5616 if (sym
->as
->upper
[n
])
5618 /* We know what we want the upper bound to be. */
5619 if (!INTEGER_CST_P (ubound
))
5621 gfc_init_se (&se
, NULL
);
5622 gfc_conv_expr_type (&se
, sym
->as
->upper
[n
],
5623 gfc_array_index_type
);
5624 gfc_add_block_to_block (&init
, &se
.pre
);
5625 gfc_add_modify (&init
, ubound
, se
.expr
);
5628 /* Check the sizes match. */
5631 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
5635 temp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5636 gfc_array_index_type
, ubound
, lbound
);
5637 temp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5638 gfc_array_index_type
,
5639 gfc_index_one_node
, temp
);
5640 stride2
= fold_build2_loc (input_location
, MINUS_EXPR
,
5641 gfc_array_index_type
, dubound
,
5643 stride2
= fold_build2_loc (input_location
, PLUS_EXPR
,
5644 gfc_array_index_type
,
5645 gfc_index_one_node
, stride2
);
5646 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
5647 gfc_array_index_type
, temp
, stride2
);
5648 asprintf (&msg
, "Dimension %d of array '%s' has extent "
5649 "%%ld instead of %%ld", n
+1, sym
->name
);
5651 gfc_trans_runtime_check (true, false, tmp
, &init
, &loc
, msg
,
5652 fold_convert (long_integer_type_node
, temp
),
5653 fold_convert (long_integer_type_node
, stride2
));
5660 /* For assumed shape arrays move the upper bound by the same amount
5661 as the lower bound. */
5662 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5663 gfc_array_index_type
, dubound
, dlbound
);
5664 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5665 gfc_array_index_type
, tmp
, lbound
);
5666 gfc_add_modify (&init
, ubound
, tmp
);
5668 /* The offset of this dimension. offset = offset - lbound * stride. */
5669 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5671 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
5672 gfc_array_index_type
, offset
, tmp
);
5674 /* The size of this dimension, and the stride of the next. */
5675 if (n
+ 1 < sym
->as
->rank
)
5677 stride
= GFC_TYPE_ARRAY_STRIDE (type
, n
+ 1);
5679 if (no_repack
|| partial
!= NULL_TREE
)
5681 gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[n
+1]);
5683 /* Figure out the stride if not a known constant. */
5684 if (!INTEGER_CST_P (stride
))
5687 stmt_packed
= NULL_TREE
;
5690 /* Calculate stride = size * (ubound + 1 - lbound). */
5691 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5692 gfc_array_index_type
,
5693 gfc_index_one_node
, lbound
);
5694 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5695 gfc_array_index_type
, ubound
, tmp
);
5696 size
= fold_build2_loc (input_location
, MULT_EXPR
,
5697 gfc_array_index_type
, size
, tmp
);
5701 /* Assign the stride. */
5702 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
5703 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5704 gfc_array_index_type
, partial
,
5705 stmt_unpacked
, stmt_packed
);
5707 tmp
= (stmt_packed
!= NULL_TREE
) ? stmt_packed
: stmt_unpacked
;
5708 gfc_add_modify (&init
, stride
, tmp
);
5713 stride
= GFC_TYPE_ARRAY_SIZE (type
);
5715 if (stride
&& !INTEGER_CST_P (stride
))
5717 /* Calculate size = stride * (ubound + 1 - lbound). */
5718 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5719 gfc_array_index_type
,
5720 gfc_index_one_node
, lbound
);
5721 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5722 gfc_array_index_type
,
5724 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5725 gfc_array_index_type
,
5726 GFC_TYPE_ARRAY_STRIDE (type
, n
), tmp
);
5727 gfc_add_modify (&init
, stride
, tmp
);
5732 gfc_trans_array_cobounds (type
, &init
, sym
);
5734 /* Set the offset. */
5735 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
5736 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
5738 gfc_trans_vla_type_sizes (sym
, &init
);
5740 stmtInit
= gfc_finish_block (&init
);
5742 /* Only do the entry/initialization code if the arg is present. */
5743 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
5744 optional_arg
= (sym
->attr
.optional
5745 || (sym
->ns
->proc_name
->attr
.entry_master
5746 && sym
->attr
.dummy
));
5749 tmp
= gfc_conv_expr_present (sym
);
5750 stmtInit
= build3_v (COND_EXPR
, tmp
, stmtInit
,
5751 build_empty_stmt (input_location
));
5756 stmtCleanup
= NULL_TREE
;
5759 stmtblock_t cleanup
;
5760 gfc_start_block (&cleanup
);
5762 if (sym
->attr
.intent
!= INTENT_IN
)
5764 /* Copy the data back. */
5765 tmp
= build_call_expr_loc (input_location
,
5766 gfor_fndecl_in_unpack
, 2, dumdesc
, tmpdesc
);
5767 gfc_add_expr_to_block (&cleanup
, tmp
);
5770 /* Free the temporary. */
5771 tmp
= gfc_call_free (tmpdesc
);
5772 gfc_add_expr_to_block (&cleanup
, tmp
);
5774 stmtCleanup
= gfc_finish_block (&cleanup
);
5776 /* Only do the cleanup if the array was repacked. */
5777 tmp
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
5778 tmp
= gfc_conv_descriptor_data_get (tmp
);
5779 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5781 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
5782 build_empty_stmt (input_location
));
5786 tmp
= gfc_conv_expr_present (sym
);
5787 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
5788 build_empty_stmt (input_location
));
5792 /* We don't need to free any memory allocated by internal_pack as it will
5793 be freed at the end of the function by pop_context. */
5794 gfc_add_init_cleanup (block
, stmtInit
, stmtCleanup
);
5796 gfc_restore_backend_locus (&loc
);
5800 /* Calculate the overall offset, including subreferences. */
5802 gfc_get_dataptr_offset (stmtblock_t
*block
, tree parm
, tree desc
, tree offset
,
5803 bool subref
, gfc_expr
*expr
)
5813 /* If offset is NULL and this is not a subreferenced array, there is
5815 if (offset
== NULL_TREE
)
5818 offset
= gfc_index_zero_node
;
5823 tmp
= gfc_conv_array_data (desc
);
5824 tmp
= build_fold_indirect_ref_loc (input_location
,
5826 tmp
= gfc_build_array_ref (tmp
, offset
, NULL
);
5828 /* Offset the data pointer for pointer assignments from arrays with
5829 subreferences; e.g. my_integer => my_type(:)%integer_component. */
5832 /* Go past the array reference. */
5833 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5834 if (ref
->type
== REF_ARRAY
&&
5835 ref
->u
.ar
.type
!= AR_ELEMENT
)
5841 /* Calculate the offset for each subsequent subreference. */
5842 for (; ref
; ref
= ref
->next
)
5847 field
= ref
->u
.c
.component
->backend_decl
;
5848 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
5849 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
5851 tmp
, field
, NULL_TREE
);
5855 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
5856 gfc_init_se (&start
, NULL
);
5857 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
5858 gfc_add_block_to_block (block
, &start
.pre
);
5859 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
5863 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
5864 && ref
->u
.ar
.type
== AR_ELEMENT
);
5866 /* TODO - Add bounds checking. */
5867 stride
= gfc_index_one_node
;
5868 index
= gfc_index_zero_node
;
5869 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
5874 /* Update the index. */
5875 gfc_init_se (&start
, NULL
);
5876 gfc_conv_expr_type (&start
, ref
->u
.ar
.start
[n
], gfc_array_index_type
);
5877 itmp
= gfc_evaluate_now (start
.expr
, block
);
5878 gfc_init_se (&start
, NULL
);
5879 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->lower
[n
], gfc_array_index_type
);
5880 jtmp
= gfc_evaluate_now (start
.expr
, block
);
5881 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5882 gfc_array_index_type
, itmp
, jtmp
);
5883 itmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5884 gfc_array_index_type
, itmp
, stride
);
5885 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
5886 gfc_array_index_type
, itmp
, index
);
5887 index
= gfc_evaluate_now (index
, block
);
5889 /* Update the stride. */
5890 gfc_init_se (&start
, NULL
);
5891 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->upper
[n
], gfc_array_index_type
);
5892 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5893 gfc_array_index_type
, start
.expr
,
5895 itmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5896 gfc_array_index_type
,
5897 gfc_index_one_node
, itmp
);
5898 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
5899 gfc_array_index_type
, stride
, itmp
);
5900 stride
= gfc_evaluate_now (stride
, block
);
5903 /* Apply the index to obtain the array element. */
5904 tmp
= gfc_build_array_ref (tmp
, index
, NULL
);
5914 /* Set the target data pointer. */
5915 offset
= gfc_build_addr_expr (gfc_array_dataptr_type (desc
), tmp
);
5916 gfc_conv_descriptor_data_set (block
, parm
, offset
);
5920 /* gfc_conv_expr_descriptor needs the string length an expression
5921 so that the size of the temporary can be obtained. This is done
5922 by adding up the string lengths of all the elements in the
5923 expression. Function with non-constant expressions have their
5924 string lengths mapped onto the actual arguments using the
5925 interface mapping machinery in trans-expr.c. */
5927 get_array_charlen (gfc_expr
*expr
, gfc_se
*se
)
5929 gfc_interface_mapping mapping
;
5930 gfc_formal_arglist
*formal
;
5931 gfc_actual_arglist
*arg
;
5934 if (expr
->ts
.u
.cl
->length
5935 && gfc_is_constant_expr (expr
->ts
.u
.cl
->length
))
5937 if (!expr
->ts
.u
.cl
->backend_decl
)
5938 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
5942 switch (expr
->expr_type
)
5945 get_array_charlen (expr
->value
.op
.op1
, se
);
5947 /* For parentheses the expression ts.u.cl is identical. */
5948 if (expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
5951 expr
->ts
.u
.cl
->backend_decl
=
5952 gfc_create_var (gfc_charlen_type_node
, "sln");
5954 if (expr
->value
.op
.op2
)
5956 get_array_charlen (expr
->value
.op
.op2
, se
);
5958 gcc_assert (expr
->value
.op
.op
== INTRINSIC_CONCAT
);
5960 /* Add the string lengths and assign them to the expression
5961 string length backend declaration. */
5962 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
5963 fold_build2_loc (input_location
, PLUS_EXPR
,
5964 gfc_charlen_type_node
,
5965 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
,
5966 expr
->value
.op
.op2
->ts
.u
.cl
->backend_decl
));
5969 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
5970 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
);
5974 if (expr
->value
.function
.esym
== NULL
5975 || expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
5977 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
5981 /* Map expressions involving the dummy arguments onto the actual
5982 argument expressions. */
5983 gfc_init_interface_mapping (&mapping
);
5984 formal
= expr
->symtree
->n
.sym
->formal
;
5985 arg
= expr
->value
.function
.actual
;
5987 /* Set se = NULL in the calls to the interface mapping, to suppress any
5989 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
5994 gfc_add_interface_mapping (&mapping
, formal
->sym
, NULL
, arg
->expr
);
5997 gfc_init_se (&tse
, NULL
);
5999 /* Build the expression for the character length and convert it. */
6000 gfc_apply_interface_mapping (&mapping
, &tse
, expr
->ts
.u
.cl
->length
);
6002 gfc_add_block_to_block (&se
->pre
, &tse
.pre
);
6003 gfc_add_block_to_block (&se
->post
, &tse
.post
);
6004 tse
.expr
= fold_convert (gfc_charlen_type_node
, tse
.expr
);
6005 tse
.expr
= fold_build2_loc (input_location
, MAX_EXPR
,
6006 gfc_charlen_type_node
, tse
.expr
,
6007 build_int_cst (gfc_charlen_type_node
, 0));
6008 expr
->ts
.u
.cl
->backend_decl
= tse
.expr
;
6009 gfc_free_interface_mapping (&mapping
);
6013 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6019 /* Helper function to check dimensions. */
6021 transposed_dims (gfc_ss
*ss
)
6025 for (n
= 0; n
< ss
->dimen
; n
++)
6026 if (ss
->dim
[n
] != n
)
6031 /* Convert an array for passing as an actual argument. Expressions and
6032 vector subscripts are evaluated and stored in a temporary, which is then
6033 passed. For whole arrays the descriptor is passed. For array sections
6034 a modified copy of the descriptor is passed, but using the original data.
6036 This function is also used for array pointer assignments, and there
6039 - se->want_pointer && !se->direct_byref
6040 EXPR is an actual argument. On exit, se->expr contains a
6041 pointer to the array descriptor.
6043 - !se->want_pointer && !se->direct_byref
6044 EXPR is an actual argument to an intrinsic function or the
6045 left-hand side of a pointer assignment. On exit, se->expr
6046 contains the descriptor for EXPR.
6048 - !se->want_pointer && se->direct_byref
6049 EXPR is the right-hand side of a pointer assignment and
6050 se->expr is the descriptor for the previously-evaluated
6051 left-hand side. The function creates an assignment from
6055 The se->force_tmp flag disables the non-copying descriptor optimization
6056 that is used for transpose. It may be used in cases where there is an
6057 alias between the transpose argument and another argument in the same
6061 gfc_conv_expr_descriptor (gfc_se
* se
, gfc_expr
* expr
, gfc_ss
* ss
)
6063 gfc_ss_type ss_type
;
6064 gfc_ss_info
*ss_info
;
6066 gfc_array_info
*info
;
6075 bool subref_array_target
= false;
6076 gfc_expr
*arg
, *ss_expr
;
6078 gcc_assert (ss
!= NULL
);
6079 gcc_assert (ss
!= gfc_ss_terminator
);
6082 ss_type
= ss_info
->type
;
6083 ss_expr
= ss_info
->expr
;
6085 /* Special case things we know we can pass easily. */
6086 switch (expr
->expr_type
)
6089 /* If we have a linear array section, we can pass it directly.
6090 Otherwise we need to copy it into a temporary. */
6092 gcc_assert (ss_type
== GFC_SS_SECTION
);
6093 gcc_assert (ss_expr
== expr
);
6094 info
= &ss_info
->data
.array
;
6096 /* Get the descriptor for the array. */
6097 gfc_conv_ss_descriptor (&se
->pre
, ss
, 0);
6098 desc
= info
->descriptor
;
6100 subref_array_target
= se
->direct_byref
&& is_subref_array (expr
);
6101 need_tmp
= gfc_ref_needs_temporary_p (expr
->ref
)
6102 && !subref_array_target
;
6109 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
6111 /* Create a new descriptor if the array doesn't have one. */
6114 else if (info
->ref
->u
.ar
.type
== AR_FULL
)
6116 else if (se
->direct_byref
)
6119 full
= gfc_full_array_ref_p (info
->ref
, NULL
);
6121 if (full
&& !transposed_dims (ss
))
6123 if (se
->direct_byref
&& !se
->byref_noassign
)
6125 /* Copy the descriptor for pointer assignments. */
6126 gfc_add_modify (&se
->pre
, se
->expr
, desc
);
6128 /* Add any offsets from subreferences. */
6129 gfc_get_dataptr_offset (&se
->pre
, se
->expr
, desc
, NULL_TREE
,
6130 subref_array_target
, expr
);
6132 else if (se
->want_pointer
)
6134 /* We pass full arrays directly. This means that pointers and
6135 allocatable arrays should also work. */
6136 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
6143 if (expr
->ts
.type
== BT_CHARACTER
)
6144 se
->string_length
= gfc_get_expr_charlen (expr
);
6152 /* We don't need to copy data in some cases. */
6153 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
6156 /* This is a call to transpose... */
6157 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
6158 /* ... which has already been handled by the scalarizer, so
6159 that we just need to get its argument's descriptor. */
6160 gfc_conv_expr_descriptor (se
, expr
->value
.function
.actual
->expr
, ss
);
6164 /* A transformational function return value will be a temporary
6165 array descriptor. We still need to go through the scalarizer
6166 to create the descriptor. Elemental functions ar handled as
6167 arbitrary expressions, i.e. copy to a temporary. */
6169 if (se
->direct_byref
)
6171 gcc_assert (ss_type
== GFC_SS_FUNCTION
&& ss_expr
== expr
);
6173 /* For pointer assignments pass the descriptor directly. */
6177 gcc_assert (se
->ss
== ss
);
6178 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
6179 gfc_conv_expr (se
, expr
);
6183 if (ss_expr
!= expr
|| ss_type
!= GFC_SS_FUNCTION
)
6185 if (ss_expr
!= expr
)
6186 /* Elemental function. */
6187 gcc_assert ((expr
->value
.function
.esym
!= NULL
6188 && expr
->value
.function
.esym
->attr
.elemental
)
6189 || (expr
->value
.function
.isym
!= NULL
6190 && expr
->value
.function
.isym
->elemental
)
6191 || gfc_inline_intrinsic_function_p (expr
));
6193 gcc_assert (ss_type
== GFC_SS_INTRINSIC
);
6196 if (expr
->ts
.type
== BT_CHARACTER
6197 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
6198 get_array_charlen (expr
, se
);
6204 /* Transformational function. */
6205 info
= &ss_info
->data
.array
;
6211 /* Constant array constructors don't need a temporary. */
6212 if (ss_type
== GFC_SS_CONSTRUCTOR
6213 && expr
->ts
.type
!= BT_CHARACTER
6214 && gfc_constant_array_constructor_p (expr
->value
.constructor
))
6217 info
= &ss_info
->data
.array
;
6227 /* Something complicated. Copy it into a temporary. */
6233 /* If we are creating a temporary, we don't need to bother about aliases
6238 gfc_init_loopinfo (&loop
);
6240 /* Associate the SS with the loop. */
6241 gfc_add_ss_to_loop (&loop
, ss
);
6243 /* Tell the scalarizer not to bother creating loop variables, etc. */
6245 loop
.array_parameter
= 1;
6247 /* The right-hand side of a pointer assignment mustn't use a temporary. */
6248 gcc_assert (!se
->direct_byref
);
6250 /* Setup the scalarizing loops and bounds. */
6251 gfc_conv_ss_startstride (&loop
);
6255 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
6256 get_array_charlen (expr
, se
);
6258 /* Tell the scalarizer to make a temporary. */
6259 loop
.temp_ss
= gfc_get_temp_ss (gfc_typenode_for_spec (&expr
->ts
),
6260 ((expr
->ts
.type
== BT_CHARACTER
)
6261 ? expr
->ts
.u
.cl
->backend_decl
6265 se
->string_length
= loop
.temp_ss
->info
->string_length
;
6266 gcc_assert (loop
.temp_ss
->dimen
== loop
.dimen
);
6267 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
6270 gfc_conv_loop_setup (&loop
, & expr
->where
);
6274 /* Copy into a temporary and pass that. We don't need to copy the data
6275 back because expressions and vector subscripts must be INTENT_IN. */
6276 /* TODO: Optimize passing function return values. */
6280 /* Start the copying loops. */
6281 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
6282 gfc_mark_ss_chain_used (ss
, 1);
6283 gfc_start_scalarized_body (&loop
, &block
);
6285 /* Copy each data element. */
6286 gfc_init_se (&lse
, NULL
);
6287 gfc_copy_loopinfo_to_se (&lse
, &loop
);
6288 gfc_init_se (&rse
, NULL
);
6289 gfc_copy_loopinfo_to_se (&rse
, &loop
);
6291 lse
.ss
= loop
.temp_ss
;
6294 gfc_conv_scalarized_array_ref (&lse
, NULL
);
6295 if (expr
->ts
.type
== BT_CHARACTER
)
6297 gfc_conv_expr (&rse
, expr
);
6298 if (POINTER_TYPE_P (TREE_TYPE (rse
.expr
)))
6299 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
6303 gfc_conv_expr_val (&rse
, expr
);
6305 gfc_add_block_to_block (&block
, &rse
.pre
);
6306 gfc_add_block_to_block (&block
, &lse
.pre
);
6308 lse
.string_length
= rse
.string_length
;
6309 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true,
6310 expr
->expr_type
== EXPR_VARIABLE
6311 || expr
->expr_type
== EXPR_ARRAY
, true);
6312 gfc_add_expr_to_block (&block
, tmp
);
6314 /* Finish the copying loops. */
6315 gfc_trans_scalarizing_loops (&loop
, &block
);
6317 desc
= loop
.temp_ss
->info
->data
.array
.descriptor
;
6319 else if (expr
->expr_type
== EXPR_FUNCTION
&& !transposed_dims (ss
))
6321 desc
= info
->descriptor
;
6322 se
->string_length
= ss_info
->string_length
;
6326 /* We pass sections without copying to a temporary. Make a new
6327 descriptor and point it at the section we want. The loop variable
6328 limits will be the limits of the section.
6329 A function may decide to repack the array to speed up access, but
6330 we're not bothered about that here. */
6331 int dim
, ndim
, codim
;
6339 ndim
= info
->ref
? info
->ref
->u
.ar
.dimen
: ss
->dimen
;
6341 if (se
->want_coarray
)
6343 gfc_array_ref
*ar
= &info
->ref
->u
.ar
;
6345 codim
= gfc_get_corank (expr
);
6346 for (n
= 0; n
< codim
- 1; n
++)
6348 /* Make sure we are not lost somehow. */
6349 gcc_assert (ar
->dimen_type
[n
+ ndim
] == DIMEN_THIS_IMAGE
);
6351 /* Make sure the call to gfc_conv_section_startstride won't
6352 generate unnecessary code to calculate stride. */
6353 gcc_assert (ar
->stride
[n
+ ndim
] == NULL
);
6355 gfc_conv_section_startstride (&loop
, ss
, n
+ ndim
);
6356 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
6357 loop
.to
[n
+ loop
.dimen
] = info
->end
[n
+ ndim
];
6360 gcc_assert (n
== codim
- 1);
6361 evaluate_bound (&loop
.pre
, info
->start
, ar
->start
,
6362 info
->descriptor
, n
+ ndim
, true);
6363 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
6368 /* Set the string_length for a character array. */
6369 if (expr
->ts
.type
== BT_CHARACTER
)
6370 se
->string_length
= gfc_get_expr_charlen (expr
);
6372 desc
= info
->descriptor
;
6373 if (se
->direct_byref
&& !se
->byref_noassign
)
6375 /* For pointer assignments we fill in the destination. */
6377 parmtype
= TREE_TYPE (parm
);
6381 /* Otherwise make a new one. */
6382 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
6383 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
, codim
,
6384 loop
.from
, loop
.to
, 0,
6385 GFC_ARRAY_UNKNOWN
, false);
6386 parm
= gfc_create_var (parmtype
, "parm");
6389 offset
= gfc_index_zero_node
;
6391 /* The following can be somewhat confusing. We have two
6392 descriptors, a new one and the original array.
6393 {parm, parmtype, dim} refer to the new one.
6394 {desc, type, n, loop} refer to the original, which maybe
6395 a descriptorless array.
6396 The bounds of the scalarization are the bounds of the section.
6397 We don't have to worry about numeric overflows when calculating
6398 the offsets because all elements are within the array data. */
6400 /* Set the dtype. */
6401 tmp
= gfc_conv_descriptor_dtype (parm
);
6402 gfc_add_modify (&loop
.pre
, tmp
, gfc_get_dtype (parmtype
));
6404 /* Set offset for assignments to pointer only to zero if it is not
6406 if (se
->direct_byref
6407 && info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
6408 base
= gfc_index_zero_node
;
6409 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
6410 base
= gfc_evaluate_now (gfc_conv_array_offset (desc
), &loop
.pre
);
6414 for (n
= 0; n
< ndim
; n
++)
6416 stride
= gfc_conv_array_stride (desc
, n
);
6418 /* Work out the offset. */
6420 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
6422 gcc_assert (info
->subscript
[n
]
6423 && info
->subscript
[n
]->info
->type
== GFC_SS_SCALAR
);
6424 start
= info
->subscript
[n
]->info
->data
.scalar
.value
;
6428 /* Evaluate and remember the start of the section. */
6429 start
= info
->start
[n
];
6430 stride
= gfc_evaluate_now (stride
, &loop
.pre
);
6433 tmp
= gfc_conv_array_lbound (desc
, n
);
6434 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
6436 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
6438 offset
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (tmp
),
6442 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
6444 /* For elemental dimensions, we only need the offset. */
6448 /* Vector subscripts need copying and are handled elsewhere. */
6450 gcc_assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
6452 /* look for the corresponding scalarizer dimension: dim. */
6453 for (dim
= 0; dim
< ndim
; dim
++)
6454 if (ss
->dim
[dim
] == n
)
6457 /* loop exited early: the DIM being looked for has been found. */
6458 gcc_assert (dim
< ndim
);
6460 /* Set the new lower bound. */
6461 from
= loop
.from
[dim
];
6464 /* If we have an array section or are assigning make sure that
6465 the lower bound is 1. References to the full
6466 array should otherwise keep the original bounds. */
6468 || info
->ref
->u
.ar
.type
!= AR_FULL
)
6469 && !integer_onep (from
))
6471 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6472 gfc_array_index_type
, gfc_index_one_node
,
6474 to
= fold_build2_loc (input_location
, PLUS_EXPR
,
6475 gfc_array_index_type
, to
, tmp
);
6476 from
= gfc_index_one_node
;
6478 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
6479 gfc_rank_cst
[dim
], from
);
6481 /* Set the new upper bound. */
6482 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
6483 gfc_rank_cst
[dim
], to
);
6485 /* Multiply the stride by the section stride to get the
6487 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
6488 gfc_array_index_type
,
6489 stride
, info
->stride
[n
]);
6491 if (se
->direct_byref
6493 && info
->ref
->u
.ar
.type
!= AR_FULL
)
6495 base
= fold_build2_loc (input_location
, MINUS_EXPR
,
6496 TREE_TYPE (base
), base
, stride
);
6498 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
6500 tmp
= gfc_conv_array_lbound (desc
, n
);
6501 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6502 TREE_TYPE (base
), tmp
, loop
.from
[dim
]);
6503 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6504 TREE_TYPE (base
), tmp
,
6505 gfc_conv_array_stride (desc
, n
));
6506 base
= fold_build2_loc (input_location
, PLUS_EXPR
,
6507 TREE_TYPE (base
), tmp
, base
);
6510 /* Store the new stride. */
6511 gfc_conv_descriptor_stride_set (&loop
.pre
, parm
,
6512 gfc_rank_cst
[dim
], stride
);
6515 for (n
= loop
.dimen
; n
< loop
.dimen
+ codim
; n
++)
6517 from
= loop
.from
[n
];
6519 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
6520 gfc_rank_cst
[n
], from
);
6521 if (n
< loop
.dimen
+ codim
- 1)
6522 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
6523 gfc_rank_cst
[n
], to
);
6526 if (se
->data_not_needed
)
6527 gfc_conv_descriptor_data_set (&loop
.pre
, parm
,
6528 gfc_index_zero_node
);
6530 /* Point the data pointer at the 1st element in the section. */
6531 gfc_get_dataptr_offset (&loop
.pre
, parm
, desc
, offset
,
6532 subref_array_target
, expr
);
6534 if ((se
->direct_byref
|| GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
6535 && !se
->data_not_needed
)
6537 /* Set the offset. */
6538 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, base
);
6542 /* Only the callee knows what the correct offset it, so just set
6544 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, gfc_index_zero_node
);
6549 if (!se
->direct_byref
|| se
->byref_noassign
)
6551 /* Get a pointer to the new descriptor. */
6552 if (se
->want_pointer
)
6553 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
6558 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
6559 gfc_add_block_to_block (&se
->post
, &loop
.post
);
6561 /* Cleanup the scalarizer. */
6562 gfc_cleanup_loop (&loop
);
6565 /* Helper function for gfc_conv_array_parameter if array size needs to be
6569 array_parameter_size (tree desc
, gfc_expr
*expr
, tree
*size
)
6572 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
6573 *size
= GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc
));
6574 else if (expr
->rank
> 1)
6575 *size
= build_call_expr_loc (input_location
,
6576 gfor_fndecl_size0
, 1,
6577 gfc_build_addr_expr (NULL
, desc
));
6580 tree ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_index_zero_node
);
6581 tree lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_index_zero_node
);
6583 *size
= fold_build2_loc (input_location
, MINUS_EXPR
,
6584 gfc_array_index_type
, ubound
, lbound
);
6585 *size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
6586 *size
, gfc_index_one_node
);
6587 *size
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
6588 *size
, gfc_index_zero_node
);
6590 elem
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
6591 *size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6592 *size
, fold_convert (gfc_array_index_type
, elem
));
6595 /* Convert an array for passing as an actual parameter. */
6596 /* TODO: Optimize passing g77 arrays. */
6599 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, gfc_ss
* ss
, bool g77
,
6600 const gfc_symbol
*fsym
, const char *proc_name
,
6605 tree tmp
= NULL_TREE
;
6607 tree parent
= DECL_CONTEXT (current_function_decl
);
6608 bool full_array_var
;
6609 bool this_array_result
;
6612 bool array_constructor
;
6613 bool good_allocatable
;
6614 bool ultimate_ptr_comp
;
6615 bool ultimate_alloc_comp
;
6620 ultimate_ptr_comp
= false;
6621 ultimate_alloc_comp
= false;
6623 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6625 if (ref
->next
== NULL
)
6628 if (ref
->type
== REF_COMPONENT
)
6630 ultimate_ptr_comp
= ref
->u
.c
.component
->attr
.pointer
;
6631 ultimate_alloc_comp
= ref
->u
.c
.component
->attr
.allocatable
;
6635 full_array_var
= false;
6638 if (expr
->expr_type
== EXPR_VARIABLE
&& ref
&& !ultimate_ptr_comp
)
6639 full_array_var
= gfc_full_array_ref_p (ref
, &contiguous
);
6641 sym
= full_array_var
? expr
->symtree
->n
.sym
: NULL
;
6643 /* The symbol should have an array specification. */
6644 gcc_assert (!sym
|| sym
->as
|| ref
->u
.ar
.as
);
6646 if (expr
->expr_type
== EXPR_ARRAY
&& expr
->ts
.type
== BT_CHARACTER
)
6648 get_array_ctor_strlen (&se
->pre
, expr
->value
.constructor
, &tmp
);
6649 expr
->ts
.u
.cl
->backend_decl
= tmp
;
6650 se
->string_length
= tmp
;
6653 /* Is this the result of the enclosing procedure? */
6654 this_array_result
= (full_array_var
&& sym
->attr
.flavor
== FL_PROCEDURE
);
6655 if (this_array_result
6656 && (sym
->backend_decl
!= current_function_decl
)
6657 && (sym
->backend_decl
!= parent
))
6658 this_array_result
= false;
6660 /* Passing address of the array if it is not pointer or assumed-shape. */
6661 if (full_array_var
&& g77
&& !this_array_result
)
6663 tmp
= gfc_get_symbol_decl (sym
);
6665 if (sym
->ts
.type
== BT_CHARACTER
)
6666 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
6668 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
6670 gfc_conv_expr_descriptor (se
, expr
, ss
);
6671 se
->expr
= gfc_conv_array_data (se
->expr
);
6675 if (!sym
->attr
.pointer
6677 && sym
->as
->type
!= AS_ASSUMED_SHAPE
6678 && !sym
->attr
.allocatable
)
6680 /* Some variables are declared directly, others are declared as
6681 pointers and allocated on the heap. */
6682 if (sym
->attr
.dummy
|| POINTER_TYPE_P (TREE_TYPE (tmp
)))
6685 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
6687 array_parameter_size (tmp
, expr
, size
);
6691 if (sym
->attr
.allocatable
)
6693 if (sym
->attr
.dummy
|| sym
->attr
.result
)
6695 gfc_conv_expr_descriptor (se
, expr
, ss
);
6699 array_parameter_size (tmp
, expr
, size
);
6700 se
->expr
= gfc_conv_array_data (tmp
);
6705 /* A convenient reduction in scope. */
6706 contiguous
= g77
&& !this_array_result
&& contiguous
;
6708 /* There is no need to pack and unpack the array, if it is contiguous
6709 and not a deferred- or assumed-shape array, or if it is simply
6711 no_pack
= ((sym
&& sym
->as
6712 && !sym
->attr
.pointer
6713 && sym
->as
->type
!= AS_DEFERRED
6714 && sym
->as
->type
!= AS_ASSUMED_SHAPE
)
6716 (ref
&& ref
->u
.ar
.as
6717 && ref
->u
.ar
.as
->type
!= AS_DEFERRED
6718 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_SHAPE
)
6720 gfc_is_simply_contiguous (expr
, false));
6722 no_pack
= contiguous
&& no_pack
;
6724 /* Array constructors are always contiguous and do not need packing. */
6725 array_constructor
= g77
&& !this_array_result
&& expr
->expr_type
== EXPR_ARRAY
;
6727 /* Same is true of contiguous sections from allocatable variables. */
6728 good_allocatable
= contiguous
6730 && expr
->symtree
->n
.sym
->attr
.allocatable
;
6732 /* Or ultimate allocatable components. */
6733 ultimate_alloc_comp
= contiguous
&& ultimate_alloc_comp
;
6735 if (no_pack
|| array_constructor
|| good_allocatable
|| ultimate_alloc_comp
)
6737 gfc_conv_expr_descriptor (se
, expr
, ss
);
6738 if (expr
->ts
.type
== BT_CHARACTER
)
6739 se
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
6741 array_parameter_size (se
->expr
, expr
, size
);
6742 se
->expr
= gfc_conv_array_data (se
->expr
);
6746 if (this_array_result
)
6748 /* Result of the enclosing function. */
6749 gfc_conv_expr_descriptor (se
, expr
, ss
);
6751 array_parameter_size (se
->expr
, expr
, size
);
6752 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
6754 if (g77
&& TREE_TYPE (TREE_TYPE (se
->expr
)) != NULL_TREE
6755 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
6756 se
->expr
= gfc_conv_array_data (build_fold_indirect_ref_loc (input_location
,
6763 /* Every other type of array. */
6764 se
->want_pointer
= 1;
6765 gfc_conv_expr_descriptor (se
, expr
, ss
);
6767 array_parameter_size (build_fold_indirect_ref_loc (input_location
,
6772 /* Deallocate the allocatable components of structures that are
6774 if ((expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
)
6775 && expr
->ts
.u
.derived
->attr
.alloc_comp
6776 && expr
->expr_type
!= EXPR_VARIABLE
)
6778 tmp
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
6779 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
, expr
->rank
);
6781 /* The components shall be deallocated before their containing entity. */
6782 gfc_prepend_expr_to_block (&se
->post
, tmp
);
6785 if (g77
|| (fsym
&& fsym
->attr
.contiguous
6786 && !gfc_is_simply_contiguous (expr
, false)))
6788 tree origptr
= NULL_TREE
;
6792 /* For contiguous arrays, save the original value of the descriptor. */
6795 origptr
= gfc_create_var (pvoid_type_node
, "origptr");
6796 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
6797 tmp
= gfc_conv_array_data (tmp
);
6798 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
6799 TREE_TYPE (origptr
), origptr
,
6800 fold_convert (TREE_TYPE (origptr
), tmp
));
6801 gfc_add_expr_to_block (&se
->pre
, tmp
);
6804 /* Repack the array. */
6805 if (gfc_option
.warn_array_temp
)
6808 gfc_warning ("Creating array temporary at %L for argument '%s'",
6809 &expr
->where
, fsym
->name
);
6811 gfc_warning ("Creating array temporary at %L", &expr
->where
);
6814 ptr
= build_call_expr_loc (input_location
,
6815 gfor_fndecl_in_pack
, 1, desc
);
6817 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
6819 tmp
= gfc_conv_expr_present (sym
);
6820 ptr
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
6821 tmp
, fold_convert (TREE_TYPE (se
->expr
), ptr
),
6822 fold_convert (TREE_TYPE (se
->expr
), null_pointer_node
));
6825 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
6827 /* Use the packed data for the actual argument, except for contiguous arrays,
6828 where the descriptor's data component is set. */
6833 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
6834 gfc_conv_descriptor_data_set (&se
->pre
, tmp
, ptr
);
6837 if (gfc_option
.rtcheck
& GFC_RTCHECK_ARRAY_TEMPS
)
6841 if (fsym
&& proc_name
)
6842 asprintf (&msg
, "An array temporary was created for argument "
6843 "'%s' of procedure '%s'", fsym
->name
, proc_name
);
6845 asprintf (&msg
, "An array temporary was created");
6847 tmp
= build_fold_indirect_ref_loc (input_location
,
6849 tmp
= gfc_conv_array_data (tmp
);
6850 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6851 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
6853 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
6854 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
6856 gfc_conv_expr_present (sym
), tmp
);
6858 gfc_trans_runtime_check (false, true, tmp
, &se
->pre
,
6863 gfc_start_block (&block
);
6865 /* Copy the data back. */
6866 if (fsym
== NULL
|| fsym
->attr
.intent
!= INTENT_IN
)
6868 tmp
= build_call_expr_loc (input_location
,
6869 gfor_fndecl_in_unpack
, 2, desc
, ptr
);
6870 gfc_add_expr_to_block (&block
, tmp
);
6873 /* Free the temporary. */
6874 tmp
= gfc_call_free (convert (pvoid_type_node
, ptr
));
6875 gfc_add_expr_to_block (&block
, tmp
);
6877 stmt
= gfc_finish_block (&block
);
6879 gfc_init_block (&block
);
6880 /* Only if it was repacked. This code needs to be executed before the
6881 loop cleanup code. */
6882 tmp
= build_fold_indirect_ref_loc (input_location
,
6884 tmp
= gfc_conv_array_data (tmp
);
6885 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6886 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
6888 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
6889 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
6891 gfc_conv_expr_present (sym
), tmp
);
6893 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
6895 gfc_add_expr_to_block (&block
, tmp
);
6896 gfc_add_block_to_block (&block
, &se
->post
);
6898 gfc_init_block (&se
->post
);
6900 /* Reset the descriptor pointer. */
6903 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
6904 gfc_conv_descriptor_data_set (&se
->post
, tmp
, origptr
);
6907 gfc_add_block_to_block (&se
->post
, &block
);
6912 /* Generate code to deallocate an array, if it is allocated. */
6915 gfc_trans_dealloc_allocated (tree descriptor
)
6921 gfc_start_block (&block
);
6923 var
= gfc_conv_descriptor_data_get (descriptor
);
6926 /* Call array_deallocate with an int * present in the second argument.
6927 Although it is ignored here, it's presence ensures that arrays that
6928 are already deallocated are ignored. */
6929 tmp
= gfc_deallocate_with_status (var
, NULL_TREE
, true, NULL
);
6930 gfc_add_expr_to_block (&block
, tmp
);
6932 /* Zero the data pointer. */
6933 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
6934 var
, build_int_cst (TREE_TYPE (var
), 0));
6935 gfc_add_expr_to_block (&block
, tmp
);
6937 return gfc_finish_block (&block
);
6941 /* This helper function calculates the size in words of a full array. */
6944 get_full_array_size (stmtblock_t
*block
, tree decl
, int rank
)
6949 idx
= gfc_rank_cst
[rank
- 1];
6950 nelems
= gfc_conv_descriptor_ubound_get (decl
, idx
);
6951 tmp
= gfc_conv_descriptor_lbound_get (decl
, idx
);
6952 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6954 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
6955 tmp
, gfc_index_one_node
);
6956 tmp
= gfc_evaluate_now (tmp
, block
);
6958 nelems
= gfc_conv_descriptor_stride_get (decl
, idx
);
6959 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6961 return gfc_evaluate_now (tmp
, block
);
6965 /* Allocate dest to the same size as src, and copy src -> dest.
6966 If no_malloc is set, only the copy is done. */
6969 duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
6979 /* If the source is null, set the destination to null. Then,
6980 allocate memory to the destination. */
6981 gfc_init_block (&block
);
6985 tmp
= null_pointer_node
;
6986 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, type
, dest
, tmp
);
6987 gfc_add_expr_to_block (&block
, tmp
);
6988 null_data
= gfc_finish_block (&block
);
6990 gfc_init_block (&block
);
6991 size
= TYPE_SIZE_UNIT (TREE_TYPE (type
));
6994 tmp
= gfc_call_malloc (&block
, type
, size
);
6995 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
6996 dest
, fold_convert (type
, tmp
));
6997 gfc_add_expr_to_block (&block
, tmp
);
7000 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
7001 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
7006 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
7007 null_data
= gfc_finish_block (&block
);
7009 gfc_init_block (&block
);
7010 nelems
= get_full_array_size (&block
, src
, rank
);
7011 tmp
= fold_convert (gfc_array_index_type
,
7012 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
7013 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7017 tmp
= TREE_TYPE (gfc_conv_descriptor_data_get (src
));
7018 tmp
= gfc_call_malloc (&block
, tmp
, size
);
7019 gfc_conv_descriptor_data_set (&block
, dest
, tmp
);
7022 /* We know the temporary and the value will be the same length,
7023 so can use memcpy. */
7024 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
7025 tmp
= build_call_expr_loc (input_location
,
7026 tmp
, 3, gfc_conv_descriptor_data_get (dest
),
7027 gfc_conv_descriptor_data_get (src
), size
);
7030 gfc_add_expr_to_block (&block
, tmp
);
7031 tmp
= gfc_finish_block (&block
);
7033 /* Null the destination if the source is null; otherwise do
7034 the allocate and copy. */
7038 null_cond
= gfc_conv_descriptor_data_get (src
);
7040 null_cond
= convert (pvoid_type_node
, null_cond
);
7041 null_cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7042 null_cond
, null_pointer_node
);
7043 return build3_v (COND_EXPR
, null_cond
, tmp
, null_data
);
7047 /* Allocate dest to the same size as src, and copy data src -> dest. */
7050 gfc_duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
)
7052 return duplicate_allocatable (dest
, src
, type
, rank
, false);
7056 /* Copy data src -> dest. */
7059 gfc_copy_allocatable_data (tree dest
, tree src
, tree type
, int rank
)
7061 return duplicate_allocatable (dest
, src
, type
, rank
, true);
7065 /* Recursively traverse an object of derived type, generating code to
7066 deallocate, nullify or copy allocatable components. This is the work horse
7067 function for the functions named in this enum. */
7069 enum {DEALLOCATE_ALLOC_COMP
= 1, NULLIFY_ALLOC_COMP
, COPY_ALLOC_COMP
,
7070 COPY_ONLY_ALLOC_COMP
};
7073 structure_alloc_comps (gfc_symbol
* der_type
, tree decl
,
7074 tree dest
, int rank
, int purpose
)
7078 stmtblock_t fnblock
;
7079 stmtblock_t loopbody
;
7090 tree null_cond
= NULL_TREE
;
7092 gfc_init_block (&fnblock
);
7094 decl_type
= TREE_TYPE (decl
);
7096 if ((POINTER_TYPE_P (decl_type
) && rank
!= 0)
7097 || (TREE_CODE (decl_type
) == REFERENCE_TYPE
&& rank
== 0))
7099 decl
= build_fold_indirect_ref_loc (input_location
,
7102 /* Just in case in gets dereferenced. */
7103 decl_type
= TREE_TYPE (decl
);
7105 /* If this an array of derived types with allocatable components
7106 build a loop and recursively call this function. */
7107 if (TREE_CODE (decl_type
) == ARRAY_TYPE
7108 || GFC_DESCRIPTOR_TYPE_P (decl_type
))
7110 tmp
= gfc_conv_array_data (decl
);
7111 var
= build_fold_indirect_ref_loc (input_location
,
7114 /* Get the number of elements - 1 and set the counter. */
7115 if (GFC_DESCRIPTOR_TYPE_P (decl_type
))
7117 /* Use the descriptor for an allocatable array. Since this
7118 is a full array reference, we only need the descriptor
7119 information from dimension = rank. */
7120 tmp
= get_full_array_size (&fnblock
, decl
, rank
);
7121 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7122 gfc_array_index_type
, tmp
,
7123 gfc_index_one_node
);
7125 null_cond
= gfc_conv_descriptor_data_get (decl
);
7126 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
7127 boolean_type_node
, null_cond
,
7128 build_int_cst (TREE_TYPE (null_cond
), 0));
7132 /* Otherwise use the TYPE_DOMAIN information. */
7133 tmp
= array_type_nelts (decl_type
);
7134 tmp
= fold_convert (gfc_array_index_type
, tmp
);
7137 /* Remember that this is, in fact, the no. of elements - 1. */
7138 nelems
= gfc_evaluate_now (tmp
, &fnblock
);
7139 index
= gfc_create_var (gfc_array_index_type
, "S");
7141 /* Build the body of the loop. */
7142 gfc_init_block (&loopbody
);
7144 vref
= gfc_build_array_ref (var
, index
, NULL
);
7146 if (purpose
== COPY_ALLOC_COMP
)
7148 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
7150 tmp
= gfc_duplicate_allocatable (dest
, decl
, decl_type
, rank
);
7151 gfc_add_expr_to_block (&fnblock
, tmp
);
7153 tmp
= build_fold_indirect_ref_loc (input_location
,
7154 gfc_conv_array_data (dest
));
7155 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
7156 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
, purpose
);
7158 else if (purpose
== COPY_ONLY_ALLOC_COMP
)
7160 tmp
= build_fold_indirect_ref_loc (input_location
,
7161 gfc_conv_array_data (dest
));
7162 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
7163 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
,
7167 tmp
= structure_alloc_comps (der_type
, vref
, NULL_TREE
, rank
, purpose
);
7169 gfc_add_expr_to_block (&loopbody
, tmp
);
7171 /* Build the loop and return. */
7172 gfc_init_loopinfo (&loop
);
7174 loop
.from
[0] = gfc_index_zero_node
;
7175 loop
.loopvar
[0] = index
;
7176 loop
.to
[0] = nelems
;
7177 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
7178 gfc_add_block_to_block (&fnblock
, &loop
.pre
);
7180 tmp
= gfc_finish_block (&fnblock
);
7181 if (null_cond
!= NULL_TREE
)
7182 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
7183 build_empty_stmt (input_location
));
7188 /* Otherwise, act on the components or recursively call self to
7189 act on a chain of components. */
7190 for (c
= der_type
->components
; c
; c
= c
->next
)
7192 bool cmp_has_alloc_comps
= (c
->ts
.type
== BT_DERIVED
7193 || c
->ts
.type
== BT_CLASS
)
7194 && c
->ts
.u
.derived
->attr
.alloc_comp
;
7195 cdecl = c
->backend_decl
;
7196 ctype
= TREE_TYPE (cdecl);
7200 case DEALLOCATE_ALLOC_COMP
:
7201 if (cmp_has_alloc_comps
&& !c
->attr
.pointer
)
7203 /* Do not deallocate the components of ultimate pointer
7205 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7206 decl
, cdecl, NULL_TREE
);
7207 rank
= c
->as
? c
->as
->rank
: 0;
7208 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
7210 gfc_add_expr_to_block (&fnblock
, tmp
);
7213 if (c
->attr
.allocatable
7214 && (c
->attr
.dimension
|| c
->attr
.codimension
))
7216 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7217 decl
, cdecl, NULL_TREE
);
7218 tmp
= gfc_trans_dealloc_allocated (comp
);
7219 gfc_add_expr_to_block (&fnblock
, tmp
);
7221 else if (c
->attr
.allocatable
)
7223 /* Allocatable scalar components. */
7224 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7225 decl
, cdecl, NULL_TREE
);
7227 tmp
= gfc_deallocate_scalar_with_status (comp
, NULL
, true, NULL
,
7229 gfc_add_expr_to_block (&fnblock
, tmp
);
7231 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7232 void_type_node
, comp
,
7233 build_int_cst (TREE_TYPE (comp
), 0));
7234 gfc_add_expr_to_block (&fnblock
, tmp
);
7236 else if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
7238 /* Allocatable scalar CLASS components. */
7239 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7240 decl
, cdecl, NULL_TREE
);
7242 /* Add reference to '_data' component. */
7243 tmp
= CLASS_DATA (c
)->backend_decl
;
7244 comp
= fold_build3_loc (input_location
, COMPONENT_REF
,
7245 TREE_TYPE (tmp
), comp
, tmp
, NULL_TREE
);
7247 tmp
= gfc_deallocate_scalar_with_status (comp
, NULL
, true, NULL
,
7248 CLASS_DATA (c
)->ts
);
7249 gfc_add_expr_to_block (&fnblock
, tmp
);
7251 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7252 void_type_node
, comp
,
7253 build_int_cst (TREE_TYPE (comp
), 0));
7254 gfc_add_expr_to_block (&fnblock
, tmp
);
7258 case NULLIFY_ALLOC_COMP
:
7259 if (c
->attr
.pointer
)
7261 else if (c
->attr
.allocatable
7262 && (c
->attr
.dimension
|| c
->attr
.codimension
))
7264 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7265 decl
, cdecl, NULL_TREE
);
7266 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
7268 else if (c
->attr
.allocatable
)
7270 /* Allocatable scalar components. */
7271 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7272 decl
, cdecl, NULL_TREE
);
7273 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7274 void_type_node
, comp
,
7275 build_int_cst (TREE_TYPE (comp
), 0));
7276 gfc_add_expr_to_block (&fnblock
, tmp
);
7278 else if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
7280 /* Allocatable scalar CLASS components. */
7281 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7282 decl
, cdecl, NULL_TREE
);
7283 /* Add reference to '_data' component. */
7284 tmp
= CLASS_DATA (c
)->backend_decl
;
7285 comp
= fold_build3_loc (input_location
, COMPONENT_REF
,
7286 TREE_TYPE (tmp
), comp
, tmp
, NULL_TREE
);
7287 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7288 void_type_node
, comp
,
7289 build_int_cst (TREE_TYPE (comp
), 0));
7290 gfc_add_expr_to_block (&fnblock
, tmp
);
7292 else if (cmp_has_alloc_comps
)
7294 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7295 decl
, cdecl, NULL_TREE
);
7296 rank
= c
->as
? c
->as
->rank
: 0;
7297 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
7299 gfc_add_expr_to_block (&fnblock
, tmp
);
7303 case COPY_ALLOC_COMP
:
7304 if (c
->attr
.pointer
)
7307 /* We need source and destination components. */
7308 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, decl
,
7310 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, dest
,
7312 dcmp
= fold_convert (TREE_TYPE (comp
), dcmp
);
7314 if (c
->attr
.allocatable
&& !cmp_has_alloc_comps
)
7316 rank
= c
->as
? c
->as
->rank
: 0;
7317 tmp
= gfc_duplicate_allocatable (dcmp
, comp
, ctype
, rank
);
7318 gfc_add_expr_to_block (&fnblock
, tmp
);
7321 if (cmp_has_alloc_comps
)
7323 rank
= c
->as
? c
->as
->rank
: 0;
7324 tmp
= fold_convert (TREE_TYPE (dcmp
), comp
);
7325 gfc_add_modify (&fnblock
, dcmp
, tmp
);
7326 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, dcmp
,
7328 gfc_add_expr_to_block (&fnblock
, tmp
);
7338 return gfc_finish_block (&fnblock
);
7341 /* Recursively traverse an object of derived type, generating code to
7342 nullify allocatable components. */
7345 gfc_nullify_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
7347 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
7348 NULLIFY_ALLOC_COMP
);
7352 /* Recursively traverse an object of derived type, generating code to
7353 deallocate allocatable components. */
7356 gfc_deallocate_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
7358 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
7359 DEALLOCATE_ALLOC_COMP
);
7363 /* Recursively traverse an object of derived type, generating code to
7364 copy it and its allocatable components. */
7367 gfc_copy_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
7369 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ALLOC_COMP
);
7373 /* Recursively traverse an object of derived type, generating code to
7374 copy only its allocatable components. */
7377 gfc_copy_only_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
7379 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ONLY_ALLOC_COMP
);
7383 /* Returns the value of LBOUND for an expression. This could be broken out
7384 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
7385 called by gfc_alloc_allocatable_for_assignment. */
7387 get_std_lbound (gfc_expr
*expr
, tree desc
, int dim
, bool assumed_size
)
7392 tree cond
, cond1
, cond3
, cond4
;
7396 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
7398 tmp
= gfc_rank_cst
[dim
];
7399 lbound
= gfc_conv_descriptor_lbound_get (desc
, tmp
);
7400 ubound
= gfc_conv_descriptor_ubound_get (desc
, tmp
);
7401 stride
= gfc_conv_descriptor_stride_get (desc
, tmp
);
7402 cond1
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
7404 cond3
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
7405 stride
, gfc_index_zero_node
);
7406 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7407 boolean_type_node
, cond3
, cond1
);
7408 cond4
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
7409 stride
, gfc_index_zero_node
);
7411 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
7412 tmp
, build_int_cst (gfc_array_index_type
,
7415 cond
= boolean_false_node
;
7417 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
7418 boolean_type_node
, cond3
, cond4
);
7419 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
7420 boolean_type_node
, cond
, cond1
);
7422 return fold_build3_loc (input_location
, COND_EXPR
,
7423 gfc_array_index_type
, cond
,
7424 lbound
, gfc_index_one_node
);
7426 else if (expr
->expr_type
== EXPR_VARIABLE
)
7428 tmp
= TREE_TYPE (expr
->symtree
->n
.sym
->backend_decl
);
7429 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7431 if (ref
->type
== REF_COMPONENT
7432 && ref
->u
.c
.component
->as
7434 && ref
->next
->u
.ar
.type
== AR_FULL
)
7435 tmp
= TREE_TYPE (ref
->u
.c
.component
->backend_decl
);
7437 return GFC_TYPE_ARRAY_LBOUND(tmp
, dim
);
7439 else if (expr
->expr_type
== EXPR_FUNCTION
)
7441 /* A conversion function, so use the argument. */
7442 expr
= expr
->value
.function
.actual
->expr
;
7443 if (expr
->expr_type
!= EXPR_VARIABLE
)
7444 return gfc_index_one_node
;
7445 desc
= TREE_TYPE (expr
->symtree
->n
.sym
->backend_decl
);
7446 return get_std_lbound (expr
, desc
, dim
, assumed_size
);
7449 return gfc_index_one_node
;
7453 /* Returns true if an expression represents an lhs that can be reallocated
7457 gfc_is_reallocatable_lhs (gfc_expr
*expr
)
7464 /* An allocatable variable. */
7465 if (expr
->symtree
->n
.sym
->attr
.allocatable
7467 && expr
->ref
->type
== REF_ARRAY
7468 && expr
->ref
->u
.ar
.type
== AR_FULL
)
7471 /* All that can be left are allocatable components. */
7472 if ((expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
7473 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
7474 || !expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
7477 /* Find a component ref followed by an array reference. */
7478 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7480 && ref
->type
== REF_COMPONENT
7481 && ref
->next
->type
== REF_ARRAY
7482 && !ref
->next
->next
)
7488 /* Return true if valid reallocatable lhs. */
7489 if (ref
->u
.c
.component
->attr
.allocatable
7490 && ref
->next
->u
.ar
.type
== AR_FULL
)
7497 /* Allocate the lhs of an assignment to an allocatable array, otherwise
7501 gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop
,
7505 stmtblock_t realloc_block
;
7506 stmtblock_t alloc_block
;
7510 gfc_array_info
*linfo
;
7530 gfc_array_spec
* as
;
7532 /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
7533 Find the lhs expression in the loop chain and set expr1 and
7534 expr2 accordingly. */
7535 if (expr1
->expr_type
== EXPR_FUNCTION
&& expr2
== NULL
)
7538 /* Find the ss for the lhs. */
7540 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
7541 if (lss
->info
->expr
&& lss
->info
->expr
->expr_type
== EXPR_VARIABLE
)
7543 if (lss
== gfc_ss_terminator
)
7545 expr1
= lss
->info
->expr
;
7548 /* Bail out if this is not a valid allocate on assignment. */
7549 if (!gfc_is_reallocatable_lhs (expr1
)
7550 || (expr2
&& !expr2
->rank
))
7553 /* Find the ss for the lhs. */
7555 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
7556 if (lss
->info
->expr
== expr1
)
7559 if (lss
== gfc_ss_terminator
)
7562 linfo
= &lss
->info
->data
.array
;
7564 /* Find an ss for the rhs. For operator expressions, we see the
7565 ss's for the operands. Any one of these will do. */
7567 for (; rss
&& rss
!= gfc_ss_terminator
; rss
= rss
->loop_chain
)
7568 if (rss
->info
->expr
!= expr1
&& rss
!= loop
->temp_ss
)
7571 if (expr2
&& rss
== gfc_ss_terminator
)
7574 gfc_start_block (&fblock
);
7576 /* Since the lhs is allocatable, this must be a descriptor type.
7577 Get the data and array size. */
7578 desc
= linfo
->descriptor
;
7579 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)));
7580 array1
= gfc_conv_descriptor_data_get (desc
);
7582 /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
7583 deallocated if expr is an array of different shape or any of the
7584 corresponding length type parameter values of variable and expr
7585 differ." This assures F95 compatibility. */
7586 jump_label1
= gfc_build_label_decl (NULL_TREE
);
7587 jump_label2
= gfc_build_label_decl (NULL_TREE
);
7589 /* Allocate if data is NULL. */
7590 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
7591 array1
, build_int_cst (TREE_TYPE (array1
), 0));
7592 tmp
= build3_v (COND_EXPR
, cond
,
7593 build1_v (GOTO_EXPR
, jump_label1
),
7594 build_empty_stmt (input_location
));
7595 gfc_add_expr_to_block (&fblock
, tmp
);
7597 /* Get arrayspec if expr is a full array. */
7598 if (expr2
&& expr2
->expr_type
== EXPR_FUNCTION
7599 && expr2
->value
.function
.isym
7600 && expr2
->value
.function
.isym
->conversion
)
7602 /* For conversion functions, take the arg. */
7603 gfc_expr
*arg
= expr2
->value
.function
.actual
->expr
;
7604 as
= gfc_get_full_arrayspec_from_expr (arg
);
7607 as
= gfc_get_full_arrayspec_from_expr (expr2
);
7611 /* If the lhs shape is not the same as the rhs jump to setting the
7612 bounds and doing the reallocation....... */
7613 for (n
= 0; n
< expr1
->rank
; n
++)
7615 /* Check the shape. */
7616 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
7617 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
7618 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7619 gfc_array_index_type
,
7620 loop
->to
[n
], loop
->from
[n
]);
7621 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7622 gfc_array_index_type
,
7624 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7625 gfc_array_index_type
,
7627 cond
= fold_build2_loc (input_location
, NE_EXPR
,
7629 tmp
, gfc_index_zero_node
);
7630 tmp
= build3_v (COND_EXPR
, cond
,
7631 build1_v (GOTO_EXPR
, jump_label1
),
7632 build_empty_stmt (input_location
));
7633 gfc_add_expr_to_block (&fblock
, tmp
);
7636 /* ....else jump past the (re)alloc code. */
7637 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
7638 gfc_add_expr_to_block (&fblock
, tmp
);
7640 /* Add the label to start automatic (re)allocation. */
7641 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
7642 gfc_add_expr_to_block (&fblock
, tmp
);
7644 size1
= gfc_conv_descriptor_size (desc
, expr1
->rank
);
7646 /* Get the rhs size. Fix both sizes. */
7648 desc2
= rss
->info
->data
.array
.descriptor
;
7651 size2
= gfc_index_one_node
;
7652 for (n
= 0; n
< expr2
->rank
; n
++)
7654 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7655 gfc_array_index_type
,
7656 loop
->to
[n
], loop
->from
[n
]);
7657 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7658 gfc_array_index_type
,
7659 tmp
, gfc_index_one_node
);
7660 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
7661 gfc_array_index_type
,
7665 size1
= gfc_evaluate_now (size1
, &fblock
);
7666 size2
= gfc_evaluate_now (size2
, &fblock
);
7668 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7670 neq_size
= gfc_evaluate_now (cond
, &fblock
);
7673 /* Now modify the lhs descriptor and the associated scalarizer
7674 variables. F2003 7.4.1.3: "If variable is or becomes an
7675 unallocated allocatable variable, then it is allocated with each
7676 deferred type parameter equal to the corresponding type parameters
7677 of expr , with the shape of expr , and with each lower bound equal
7678 to the corresponding element of LBOUND(expr)."
7679 Reuse size1 to keep a dimension-by-dimension track of the
7680 stride of the new array. */
7681 size1
= gfc_index_one_node
;
7682 offset
= gfc_index_zero_node
;
7684 for (n
= 0; n
< expr2
->rank
; n
++)
7686 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7687 gfc_array_index_type
,
7688 loop
->to
[n
], loop
->from
[n
]);
7689 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7690 gfc_array_index_type
,
7691 tmp
, gfc_index_one_node
);
7693 lbound
= gfc_index_one_node
;
7698 lbd
= get_std_lbound (expr2
, desc2
, n
,
7699 as
->type
== AS_ASSUMED_SIZE
);
7700 ubound
= fold_build2_loc (input_location
,
7702 gfc_array_index_type
,
7704 ubound
= fold_build2_loc (input_location
,
7706 gfc_array_index_type
,
7711 gfc_conv_descriptor_lbound_set (&fblock
, desc
,
7714 gfc_conv_descriptor_ubound_set (&fblock
, desc
,
7717 gfc_conv_descriptor_stride_set (&fblock
, desc
,
7720 lbound
= gfc_conv_descriptor_lbound_get (desc
,
7722 tmp2
= fold_build2_loc (input_location
, MULT_EXPR
,
7723 gfc_array_index_type
,
7725 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
7726 gfc_array_index_type
,
7728 size1
= fold_build2_loc (input_location
, MULT_EXPR
,
7729 gfc_array_index_type
,
7733 /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
7734 the array offset is saved and the info.offset is used for a
7735 running offset. Use the saved_offset instead. */
7736 tmp
= gfc_conv_descriptor_offset (desc
);
7737 gfc_add_modify (&fblock
, tmp
, offset
);
7738 if (linfo
->saved_offset
7739 && TREE_CODE (linfo
->saved_offset
) == VAR_DECL
)
7740 gfc_add_modify (&fblock
, linfo
->saved_offset
, tmp
);
7742 /* Now set the deltas for the lhs. */
7743 for (n
= 0; n
< expr1
->rank
; n
++)
7745 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
7747 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7748 gfc_array_index_type
, tmp
,
7750 if (linfo
->delta
[dim
]
7751 && TREE_CODE (linfo
->delta
[dim
]) == VAR_DECL
)
7752 gfc_add_modify (&fblock
, linfo
->delta
[dim
], tmp
);
7755 /* Get the new lhs size in bytes. */
7756 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
7758 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
7759 gcc_assert (expr1
->ts
.u
.cl
->backend_decl
);
7760 tmp
= fold_convert (TREE_TYPE (expr1
->ts
.u
.cl
->backend_decl
), tmp
);
7761 gfc_add_modify (&fblock
, expr1
->ts
.u
.cl
->backend_decl
, tmp
);
7763 else if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.u
.cl
->backend_decl
)
7765 tmp
= TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
)));
7766 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7767 gfc_array_index_type
, tmp
,
7768 expr1
->ts
.u
.cl
->backend_decl
);
7771 tmp
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
7772 tmp
= fold_convert (gfc_array_index_type
, tmp
);
7773 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
7774 gfc_array_index_type
,
7776 size2
= fold_convert (size_type_node
, size2
);
7777 size2
= gfc_evaluate_now (size2
, &fblock
);
7779 /* Realloc expression. Note that the scalarizer uses desc.data
7780 in the array reference - (*desc.data)[<element>]. */
7781 gfc_init_block (&realloc_block
);
7782 tmp
= build_call_expr_loc (input_location
,
7783 builtin_decl_explicit (BUILT_IN_REALLOC
), 2,
7784 fold_convert (pvoid_type_node
, array1
),
7786 gfc_conv_descriptor_data_set (&realloc_block
,
7788 realloc_expr
= gfc_finish_block (&realloc_block
);
7790 /* Only reallocate if sizes are different. */
7791 tmp
= build3_v (COND_EXPR
, neq_size
, realloc_expr
,
7792 build_empty_stmt (input_location
));
7796 /* Malloc expression. */
7797 gfc_init_block (&alloc_block
);
7798 tmp
= build_call_expr_loc (input_location
,
7799 builtin_decl_explicit (BUILT_IN_MALLOC
),
7801 gfc_conv_descriptor_data_set (&alloc_block
,
7803 tmp
= gfc_conv_descriptor_dtype (desc
);
7804 gfc_add_modify (&alloc_block
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
7805 alloc_expr
= gfc_finish_block (&alloc_block
);
7807 /* Malloc if not allocated; realloc otherwise. */
7808 tmp
= build_int_cst (TREE_TYPE (array1
), 0);
7809 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
7812 tmp
= build3_v (COND_EXPR
, cond
, alloc_expr
, realloc_expr
);
7813 gfc_add_expr_to_block (&fblock
, tmp
);
7815 /* Make sure that the scalarizer data pointer is updated. */
7817 && TREE_CODE (linfo
->data
) == VAR_DECL
)
7819 tmp
= gfc_conv_descriptor_data_get (desc
);
7820 gfc_add_modify (&fblock
, linfo
->data
, tmp
);
7823 /* Add the exit label. */
7824 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
7825 gfc_add_expr_to_block (&fblock
, tmp
);
7827 return gfc_finish_block (&fblock
);
7831 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
7832 Do likewise, recursively if necessary, with the allocatable components of
7836 gfc_trans_deferred_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
7842 stmtblock_t cleanup
;
7845 bool sym_has_alloc_comp
;
7847 sym_has_alloc_comp
= (sym
->ts
.type
== BT_DERIVED
7848 || sym
->ts
.type
== BT_CLASS
)
7849 && sym
->ts
.u
.derived
->attr
.alloc_comp
;
7851 /* Make sure the frontend gets these right. */
7852 if (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym_has_alloc_comp
))
7853 fatal_error ("Possible front-end bug: Deferred array size without pointer, "
7854 "allocatable attribute or derived type without allocatable "
7857 gfc_save_backend_locus (&loc
);
7858 gfc_set_backend_locus (&sym
->declared_at
);
7859 gfc_init_block (&init
);
7861 gcc_assert (TREE_CODE (sym
->backend_decl
) == VAR_DECL
7862 || TREE_CODE (sym
->backend_decl
) == PARM_DECL
);
7864 if (sym
->ts
.type
== BT_CHARACTER
7865 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
7867 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
7868 gfc_trans_vla_type_sizes (sym
, &init
);
7871 /* Dummy, use associated and result variables don't need anything special. */
7872 if (sym
->attr
.dummy
|| sym
->attr
.use_assoc
|| sym
->attr
.result
)
7874 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
7875 gfc_restore_backend_locus (&loc
);
7879 descriptor
= sym
->backend_decl
;
7881 /* Although static, derived types with default initializers and
7882 allocatable components must not be nulled wholesale; instead they
7883 are treated component by component. */
7884 if (TREE_STATIC (descriptor
) && !sym_has_alloc_comp
)
7886 /* SAVEd variables are not freed on exit. */
7887 gfc_trans_static_array_pointer (sym
);
7889 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
7890 gfc_restore_backend_locus (&loc
);
7894 /* Get the descriptor type. */
7895 type
= TREE_TYPE (sym
->backend_decl
);
7897 if (sym_has_alloc_comp
&& !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
7900 && !(TREE_STATIC (sym
->backend_decl
) && sym
->attr
.is_main_program
))
7902 if (sym
->value
== NULL
7903 || !gfc_has_default_initializer (sym
->ts
.u
.derived
))
7905 rank
= sym
->as
? sym
->as
->rank
: 0;
7906 tmp
= gfc_nullify_alloc_comp (sym
->ts
.u
.derived
,
7908 gfc_add_expr_to_block (&init
, tmp
);
7911 gfc_init_default_dt (sym
, &init
, false);
7914 else if (!GFC_DESCRIPTOR_TYPE_P (type
))
7916 /* If the backend_decl is not a descriptor, we must have a pointer
7918 descriptor
= build_fold_indirect_ref_loc (input_location
,
7920 type
= TREE_TYPE (descriptor
);
7923 /* NULLIFY the data pointer. */
7924 if (GFC_DESCRIPTOR_TYPE_P (type
) && !sym
->attr
.save
)
7925 gfc_conv_descriptor_data_set (&init
, descriptor
, null_pointer_node
);
7927 gfc_restore_backend_locus (&loc
);
7928 gfc_init_block (&cleanup
);
7930 /* Allocatable arrays need to be freed when they go out of scope.
7931 The allocatable components of pointers must not be touched. */
7932 if (sym_has_alloc_comp
&& !(sym
->attr
.function
|| sym
->attr
.result
)
7933 && !sym
->attr
.pointer
&& !sym
->attr
.save
)
7936 rank
= sym
->as
? sym
->as
->rank
: 0;
7937 tmp
= gfc_deallocate_alloc_comp (sym
->ts
.u
.derived
, descriptor
, rank
);
7938 gfc_add_expr_to_block (&cleanup
, tmp
);
7941 if (sym
->attr
.allocatable
&& (sym
->attr
.dimension
|| sym
->attr
.codimension
)
7942 && !sym
->attr
.save
&& !sym
->attr
.result
)
7944 tmp
= gfc_trans_dealloc_allocated (sym
->backend_decl
);
7945 gfc_add_expr_to_block (&cleanup
, tmp
);
7948 gfc_add_init_cleanup (block
, gfc_finish_block (&init
),
7949 gfc_finish_block (&cleanup
));
7952 /************ Expression Walking Functions ******************/
7954 /* Walk a variable reference.
7956 Possible extension - multiple component subscripts.
7957 x(:,:) = foo%a(:)%b(:)
7959 forall (i=..., j=...)
7960 x(i,j) = foo%a(j)%b(i)
7962 This adds a fair amount of complexity because you need to deal with more
7963 than one ref. Maybe handle in a similar manner to vector subscripts.
7964 Maybe not worth the effort. */
7968 gfc_walk_variable_expr (gfc_ss
* ss
, gfc_expr
* expr
)
7972 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7973 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
7976 return gfc_walk_array_ref (ss
, expr
, ref
);
7981 gfc_walk_array_ref (gfc_ss
* ss
, gfc_expr
* expr
, gfc_ref
* ref
)
7987 for (; ref
; ref
= ref
->next
)
7989 if (ref
->type
== REF_SUBSTRING
)
7991 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.start
);
7992 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.end
);
7995 /* We're only interested in array sections from now on. */
7996 if (ref
->type
!= REF_ARRAY
)
8004 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
8005 ss
= gfc_get_scalar_ss (ss
, ar
->start
[n
]);
8009 newss
= gfc_get_array_ss (ss
, expr
, ar
->as
->rank
, GFC_SS_SECTION
);
8010 newss
->info
->data
.array
.ref
= ref
;
8012 /* Make sure array is the same as array(:,:), this way
8013 we don't need to special case all the time. */
8014 ar
->dimen
= ar
->as
->rank
;
8015 for (n
= 0; n
< ar
->dimen
; n
++)
8017 ar
->dimen_type
[n
] = DIMEN_RANGE
;
8019 gcc_assert (ar
->start
[n
] == NULL
);
8020 gcc_assert (ar
->end
[n
] == NULL
);
8021 gcc_assert (ar
->stride
[n
] == NULL
);
8027 newss
= gfc_get_array_ss (ss
, expr
, 0, GFC_SS_SECTION
);
8028 newss
->info
->data
.array
.ref
= ref
;
8030 /* We add SS chains for all the subscripts in the section. */
8031 for (n
= 0; n
< ar
->dimen
; n
++)
8035 switch (ar
->dimen_type
[n
])
8038 /* Add SS for elemental (scalar) subscripts. */
8039 gcc_assert (ar
->start
[n
]);
8040 indexss
= gfc_get_scalar_ss (gfc_ss_terminator
, ar
->start
[n
]);
8041 indexss
->loop_chain
= gfc_ss_terminator
;
8042 newss
->info
->data
.array
.subscript
[n
] = indexss
;
8046 /* We don't add anything for sections, just remember this
8047 dimension for later. */
8048 newss
->dim
[newss
->dimen
] = n
;
8053 /* Create a GFC_SS_VECTOR index in which we can store
8054 the vector's descriptor. */
8055 indexss
= gfc_get_array_ss (gfc_ss_terminator
, ar
->start
[n
],
8057 indexss
->loop_chain
= gfc_ss_terminator
;
8058 newss
->info
->data
.array
.subscript
[n
] = indexss
;
8059 newss
->dim
[newss
->dimen
] = n
;
8064 /* We should know what sort of section it is by now. */
8068 /* We should have at least one non-elemental dimension,
8069 unless we are creating a descriptor for a (scalar) coarray. */
8070 gcc_assert (newss
->dimen
> 0
8071 || newss
->info
->data
.array
.ref
->u
.ar
.as
->corank
> 0);
8076 /* We should know what sort of section it is by now. */
8085 /* Walk an expression operator. If only one operand of a binary expression is
8086 scalar, we must also add the scalar term to the SS chain. */
8089 gfc_walk_op_expr (gfc_ss
* ss
, gfc_expr
* expr
)
8094 head
= gfc_walk_subexpr (ss
, expr
->value
.op
.op1
);
8095 if (expr
->value
.op
.op2
== NULL
)
8098 head2
= gfc_walk_subexpr (head
, expr
->value
.op
.op2
);
8100 /* All operands are scalar. Pass back and let the caller deal with it. */
8104 /* All operands require scalarization. */
8105 if (head
!= ss
&& (expr
->value
.op
.op2
== NULL
|| head2
!= head
))
8108 /* One of the operands needs scalarization, the other is scalar.
8109 Create a gfc_ss for the scalar expression. */
8112 /* First operand is scalar. We build the chain in reverse order, so
8113 add the scalar SS after the second operand. */
8115 while (head
&& head
->next
!= ss
)
8117 /* Check we haven't somehow broken the chain. */
8119 head
->next
= gfc_get_scalar_ss (ss
, expr
->value
.op
.op1
);
8121 else /* head2 == head */
8123 gcc_assert (head2
== head
);
8124 /* Second operand is scalar. */
8125 head2
= gfc_get_scalar_ss (head2
, expr
->value
.op
.op2
);
8132 /* Reverse a SS chain. */
8135 gfc_reverse_ss (gfc_ss
* ss
)
8140 gcc_assert (ss
!= NULL
);
8142 head
= gfc_ss_terminator
;
8143 while (ss
!= gfc_ss_terminator
)
8146 /* Check we didn't somehow break the chain. */
8147 gcc_assert (next
!= NULL
);
8157 /* Walk the arguments of an elemental function. */
8160 gfc_walk_elemental_function_args (gfc_ss
* ss
, gfc_actual_arglist
*arg
,
8168 head
= gfc_ss_terminator
;
8171 for (; arg
; arg
= arg
->next
)
8176 newss
= gfc_walk_subexpr (head
, arg
->expr
);
8179 /* Scalar argument. */
8180 gcc_assert (type
== GFC_SS_SCALAR
|| type
== GFC_SS_REFERENCE
);
8181 newss
= gfc_get_scalar_ss (head
, arg
->expr
);
8182 newss
->info
->type
= type
;
8191 while (tail
->next
!= gfc_ss_terminator
)
8198 /* If all the arguments are scalar we don't need the argument SS. */
8199 gfc_free_ss_chain (head
);
8204 /* Add it onto the existing chain. */
8210 /* Walk a function call. Scalar functions are passed back, and taken out of
8211 scalarization loops. For elemental functions we walk their arguments.
8212 The result of functions returning arrays is stored in a temporary outside
8213 the loop, so that the function is only called once. Hence we do not need
8214 to walk their arguments. */
8217 gfc_walk_function_expr (gfc_ss
* ss
, gfc_expr
* expr
)
8219 gfc_intrinsic_sym
*isym
;
8221 gfc_component
*comp
= NULL
;
8223 isym
= expr
->value
.function
.isym
;
8225 /* Handle intrinsic functions separately. */
8227 return gfc_walk_intrinsic_function (ss
, expr
, isym
);
8229 sym
= expr
->value
.function
.esym
;
8231 sym
= expr
->symtree
->n
.sym
;
8233 /* A function that returns arrays. */
8234 gfc_is_proc_ptr_comp (expr
, &comp
);
8235 if ((!comp
&& gfc_return_by_reference (sym
) && sym
->result
->attr
.dimension
)
8236 || (comp
&& comp
->attr
.dimension
))
8237 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
8239 /* Walk the parameters of an elemental function. For now we always pass
8241 if (sym
->attr
.elemental
)
8242 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
8245 /* Scalar functions are OK as these are evaluated outside the scalarization
8246 loop. Pass back and let the caller deal with it. */
8251 /* An array temporary is constructed for array constructors. */
8254 gfc_walk_array_constructor (gfc_ss
* ss
, gfc_expr
* expr
)
8256 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_CONSTRUCTOR
);
8260 /* Walk an expression. Add walked expressions to the head of the SS chain.
8261 A wholly scalar expression will not be added. */
8264 gfc_walk_subexpr (gfc_ss
* ss
, gfc_expr
* expr
)
8268 switch (expr
->expr_type
)
8271 head
= gfc_walk_variable_expr (ss
, expr
);
8275 head
= gfc_walk_op_expr (ss
, expr
);
8279 head
= gfc_walk_function_expr (ss
, expr
);
8284 case EXPR_STRUCTURE
:
8285 /* Pass back and let the caller deal with it. */
8289 head
= gfc_walk_array_constructor (ss
, expr
);
8292 case EXPR_SUBSTRING
:
8293 /* Pass back and let the caller deal with it. */
8297 internal_error ("bad expression type during walk (%d)",
8304 /* Entry point for expression walking.
8305 A return value equal to the passed chain means this is
8306 a scalar expression. It is up to the caller to take whatever action is
8307 necessary to translate these. */
8310 gfc_walk_expr (gfc_expr
* expr
)
8314 res
= gfc_walk_subexpr (gfc_ss_terminator
, expr
);
8315 return gfc_reverse_ss (res
);