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"
84 #include "gimple.h" /* For create_tmp_var_name. */
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
);
252 gfc_conv_descriptor_rank (tree desc
)
257 dtype
= gfc_conv_descriptor_dtype (desc
);
258 tmp
= build_int_cst (TREE_TYPE (dtype
), GFC_DTYPE_RANK_MASK
);
259 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, TREE_TYPE (dtype
),
261 return fold_convert (gfc_get_int_type (gfc_default_integer_kind
), tmp
);
266 gfc_get_descriptor_dimension (tree desc
)
270 type
= TREE_TYPE (desc
);
271 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
273 field
= gfc_advance_chain (TYPE_FIELDS (type
), DIMENSION_FIELD
);
274 gcc_assert (field
!= NULL_TREE
275 && TREE_CODE (TREE_TYPE (field
)) == ARRAY_TYPE
276 && TREE_CODE (TREE_TYPE (TREE_TYPE (field
))) == RECORD_TYPE
);
278 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
279 desc
, field
, NULL_TREE
);
284 gfc_conv_descriptor_dimension (tree desc
, tree dim
)
288 tmp
= gfc_get_descriptor_dimension (desc
);
290 return gfc_build_array_ref (tmp
, dim
, NULL
);
295 gfc_conv_descriptor_token (tree desc
)
300 type
= TREE_TYPE (desc
);
301 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
302 gcc_assert (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ALLOCATABLE
);
303 gcc_assert (gfc_option
.coarray
== GFC_FCOARRAY_LIB
);
304 field
= gfc_advance_chain (TYPE_FIELDS (type
), CAF_TOKEN_FIELD
);
305 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == prvoid_type_node
);
307 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
308 desc
, field
, NULL_TREE
);
313 gfc_conv_descriptor_stride (tree desc
, tree dim
)
318 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
319 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
320 field
= gfc_advance_chain (field
, STRIDE_SUBFIELD
);
321 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
323 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
324 tmp
, field
, NULL_TREE
);
329 gfc_conv_descriptor_stride_get (tree desc
, tree dim
)
331 tree type
= TREE_TYPE (desc
);
332 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
333 if (integer_zerop (dim
)
334 && (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ALLOCATABLE
335 ||GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE_CONT
336 ||GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_RANK_CONT
337 ||GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER_CONT
))
338 return gfc_index_one_node
;
340 return gfc_conv_descriptor_stride (desc
, dim
);
344 gfc_conv_descriptor_stride_set (stmtblock_t
*block
, tree desc
,
345 tree dim
, tree value
)
347 tree t
= gfc_conv_descriptor_stride (desc
, dim
);
348 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
352 gfc_conv_descriptor_lbound (tree desc
, tree dim
)
357 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
358 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
359 field
= gfc_advance_chain (field
, LBOUND_SUBFIELD
);
360 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
362 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
363 tmp
, field
, NULL_TREE
);
368 gfc_conv_descriptor_lbound_get (tree desc
, tree dim
)
370 return gfc_conv_descriptor_lbound (desc
, dim
);
374 gfc_conv_descriptor_lbound_set (stmtblock_t
*block
, tree desc
,
375 tree dim
, tree value
)
377 tree t
= gfc_conv_descriptor_lbound (desc
, dim
);
378 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
382 gfc_conv_descriptor_ubound (tree desc
, tree dim
)
387 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
388 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
389 field
= gfc_advance_chain (field
, UBOUND_SUBFIELD
);
390 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
392 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
393 tmp
, field
, NULL_TREE
);
398 gfc_conv_descriptor_ubound_get (tree desc
, tree dim
)
400 return gfc_conv_descriptor_ubound (desc
, dim
);
404 gfc_conv_descriptor_ubound_set (stmtblock_t
*block
, tree desc
,
405 tree dim
, tree value
)
407 tree t
= gfc_conv_descriptor_ubound (desc
, dim
);
408 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
411 /* Build a null array descriptor constructor. */
414 gfc_build_null_descriptor (tree type
)
419 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
420 gcc_assert (DATA_FIELD
== 0);
421 field
= TYPE_FIELDS (type
);
423 /* Set a NULL data pointer. */
424 tmp
= build_constructor_single (type
, field
, null_pointer_node
);
425 TREE_CONSTANT (tmp
) = 1;
426 /* All other fields are ignored. */
432 /* Modify a descriptor such that the lbound of a given dimension is the value
433 specified. This also updates ubound and offset accordingly. */
436 gfc_conv_shift_descriptor_lbound (stmtblock_t
* block
, tree desc
,
437 int dim
, tree new_lbound
)
439 tree offs
, ubound
, lbound
, stride
;
440 tree diff
, offs_diff
;
442 new_lbound
= fold_convert (gfc_array_index_type
, new_lbound
);
444 offs
= gfc_conv_descriptor_offset_get (desc
);
445 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]);
446 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]);
447 stride
= gfc_conv_descriptor_stride_get (desc
, gfc_rank_cst
[dim
]);
449 /* Get difference (new - old) by which to shift stuff. */
450 diff
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
453 /* Shift ubound and offset accordingly. This has to be done before
454 updating the lbound, as they depend on the lbound expression! */
455 ubound
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
457 gfc_conv_descriptor_ubound_set (block
, desc
, gfc_rank_cst
[dim
], ubound
);
458 offs_diff
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
460 offs
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
462 gfc_conv_descriptor_offset_set (block
, desc
, offs
);
464 /* Finally set lbound to value we want. */
465 gfc_conv_descriptor_lbound_set (block
, desc
, gfc_rank_cst
[dim
], new_lbound
);
469 /* Cleanup those #defines. */
474 #undef DIMENSION_FIELD
475 #undef CAF_TOKEN_FIELD
476 #undef STRIDE_SUBFIELD
477 #undef LBOUND_SUBFIELD
478 #undef UBOUND_SUBFIELD
481 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
482 flags & 1 = Main loop body.
483 flags & 2 = temp copy loop. */
486 gfc_mark_ss_chain_used (gfc_ss
* ss
, unsigned flags
)
488 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
489 ss
->info
->useflags
= flags
;
493 /* Free a gfc_ss chain. */
496 gfc_free_ss_chain (gfc_ss
* ss
)
500 while (ss
!= gfc_ss_terminator
)
502 gcc_assert (ss
!= NULL
);
511 free_ss_info (gfc_ss_info
*ss_info
)
516 if (ss_info
->refcount
> 0)
519 gcc_assert (ss_info
->refcount
== 0);
521 switch (ss_info
->type
)
524 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
525 if (ss_info
->data
.array
.subscript
[n
])
526 gfc_free_ss_chain (ss_info
->data
.array
.subscript
[n
]);
540 gfc_free_ss (gfc_ss
* ss
)
542 free_ss_info (ss
->info
);
547 /* Creates and initializes an array type gfc_ss struct. */
550 gfc_get_array_ss (gfc_ss
*next
, gfc_expr
*expr
, int dimen
, gfc_ss_type type
)
553 gfc_ss_info
*ss_info
;
556 ss_info
= gfc_get_ss_info ();
558 ss_info
->type
= type
;
559 ss_info
->expr
= expr
;
565 for (i
= 0; i
< ss
->dimen
; i
++)
572 /* Creates and initializes a temporary type gfc_ss struct. */
575 gfc_get_temp_ss (tree type
, tree string_length
, int dimen
)
578 gfc_ss_info
*ss_info
;
581 ss_info
= gfc_get_ss_info ();
583 ss_info
->type
= GFC_SS_TEMP
;
584 ss_info
->string_length
= string_length
;
585 ss_info
->data
.temp
.type
= type
;
589 ss
->next
= gfc_ss_terminator
;
591 for (i
= 0; i
< ss
->dimen
; i
++)
598 /* Creates and initializes a scalar type gfc_ss struct. */
601 gfc_get_scalar_ss (gfc_ss
*next
, gfc_expr
*expr
)
604 gfc_ss_info
*ss_info
;
606 ss_info
= gfc_get_ss_info ();
608 ss_info
->type
= GFC_SS_SCALAR
;
609 ss_info
->expr
= expr
;
619 /* Free all the SS associated with a loop. */
622 gfc_cleanup_loop (gfc_loopinfo
* loop
)
624 gfc_loopinfo
*loop_next
, **ploop
;
629 while (ss
!= gfc_ss_terminator
)
631 gcc_assert (ss
!= NULL
);
632 next
= ss
->loop_chain
;
637 /* Remove reference to self in the parent loop. */
639 for (ploop
= &loop
->parent
->nested
; *ploop
; ploop
= &(*ploop
)->next
)
646 /* Free non-freed nested loops. */
647 for (loop
= loop
->nested
; loop
; loop
= loop_next
)
649 loop_next
= loop
->next
;
650 gfc_cleanup_loop (loop
);
657 set_ss_loop (gfc_ss
*ss
, gfc_loopinfo
*loop
)
661 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
665 if (ss
->info
->type
== GFC_SS_SCALAR
666 || ss
->info
->type
== GFC_SS_REFERENCE
667 || ss
->info
->type
== GFC_SS_TEMP
)
670 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
671 if (ss
->info
->data
.array
.subscript
[n
] != NULL
)
672 set_ss_loop (ss
->info
->data
.array
.subscript
[n
], loop
);
677 /* Associate a SS chain with a loop. */
680 gfc_add_ss_to_loop (gfc_loopinfo
* loop
, gfc_ss
* head
)
683 gfc_loopinfo
*nested_loop
;
685 if (head
== gfc_ss_terminator
)
688 set_ss_loop (head
, loop
);
691 for (; ss
&& ss
!= gfc_ss_terminator
; ss
= ss
->next
)
695 nested_loop
= ss
->nested_ss
->loop
;
697 /* More than one ss can belong to the same loop. Hence, we add the
698 loop to the chain only if it is different from the previously
699 added one, to avoid duplicate nested loops. */
700 if (nested_loop
!= loop
->nested
)
702 gcc_assert (nested_loop
->parent
== NULL
);
703 nested_loop
->parent
= loop
;
705 gcc_assert (nested_loop
->next
== NULL
);
706 nested_loop
->next
= loop
->nested
;
707 loop
->nested
= nested_loop
;
710 gcc_assert (nested_loop
->parent
== loop
);
713 if (ss
->next
== gfc_ss_terminator
)
714 ss
->loop_chain
= loop
->ss
;
716 ss
->loop_chain
= ss
->next
;
718 gcc_assert (ss
== gfc_ss_terminator
);
723 /* Generate an initializer for a static pointer or allocatable array. */
726 gfc_trans_static_array_pointer (gfc_symbol
* sym
)
730 gcc_assert (TREE_STATIC (sym
->backend_decl
));
731 /* Just zero the data member. */
732 type
= TREE_TYPE (sym
->backend_decl
);
733 DECL_INITIAL (sym
->backend_decl
) = gfc_build_null_descriptor (type
);
737 /* If the bounds of SE's loop have not yet been set, see if they can be
738 determined from array spec AS, which is the array spec of a called
739 function. MAPPING maps the callee's dummy arguments to the values
740 that the caller is passing. Add any initialization and finalization
744 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping
* mapping
,
745 gfc_se
* se
, gfc_array_spec
* as
)
747 int n
, dim
, total_dim
;
756 if (!as
|| as
->type
!= AS_EXPLICIT
)
759 for (ss
= se
->ss
; ss
; ss
= ss
->parent
)
761 total_dim
+= ss
->loop
->dimen
;
762 for (n
= 0; n
< ss
->loop
->dimen
; n
++)
764 /* The bound is known, nothing to do. */
765 if (ss
->loop
->to
[n
] != NULL_TREE
)
769 gcc_assert (dim
< as
->rank
);
770 gcc_assert (ss
->loop
->dimen
<= as
->rank
);
772 /* Evaluate the lower bound. */
773 gfc_init_se (&tmpse
, NULL
);
774 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->lower
[dim
]);
775 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
776 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
777 lower
= fold_convert (gfc_array_index_type
, tmpse
.expr
);
779 /* ...and the upper bound. */
780 gfc_init_se (&tmpse
, NULL
);
781 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->upper
[dim
]);
782 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
783 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
784 upper
= fold_convert (gfc_array_index_type
, tmpse
.expr
);
786 /* Set the upper bound of the loop to UPPER - LOWER. */
787 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
788 gfc_array_index_type
, upper
, lower
);
789 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
790 ss
->loop
->to
[n
] = tmp
;
794 gcc_assert (total_dim
== as
->rank
);
798 /* Generate code to allocate an array temporary, or create a variable to
799 hold the data. If size is NULL, zero the descriptor so that the
800 callee will allocate the array. If DEALLOC is true, also generate code to
801 free the array afterwards.
803 If INITIAL is not NULL, it is packed using internal_pack and the result used
804 as data instead of allocating a fresh, unitialized area of memory.
806 Initialization code is added to PRE and finalization code to POST.
807 DYNAMIC is true if the caller may want to extend the array later
808 using realloc. This prevents us from putting the array on the stack. */
811 gfc_trans_allocate_array_storage (stmtblock_t
* pre
, stmtblock_t
* post
,
812 gfc_array_info
* info
, tree size
, tree nelem
,
813 tree initial
, bool dynamic
, bool dealloc
)
819 desc
= info
->descriptor
;
820 info
->offset
= gfc_index_zero_node
;
821 if (size
== NULL_TREE
|| integer_zerop (size
))
823 /* A callee allocated array. */
824 gfc_conv_descriptor_data_set (pre
, desc
, null_pointer_node
);
829 /* Allocate the temporary. */
830 onstack
= !dynamic
&& initial
== NULL_TREE
831 && (gfc_option
.flag_stack_arrays
832 || gfc_can_put_var_on_stack (size
));
836 /* Make a temporary variable to hold the data. */
837 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (nelem
),
838 nelem
, gfc_index_one_node
);
839 tmp
= gfc_evaluate_now (tmp
, pre
);
840 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
842 tmp
= build_array_type (gfc_get_element_type (TREE_TYPE (desc
)),
844 tmp
= gfc_create_var (tmp
, "A");
845 /* If we're here only because of -fstack-arrays we have to
846 emit a DECL_EXPR to make the gimplifier emit alloca calls. */
847 if (!gfc_can_put_var_on_stack (size
))
848 gfc_add_expr_to_block (pre
,
849 fold_build1_loc (input_location
,
850 DECL_EXPR
, TREE_TYPE (tmp
),
852 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
853 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
857 /* Allocate memory to hold the data or call internal_pack. */
858 if (initial
== NULL_TREE
)
860 tmp
= gfc_call_malloc (pre
, NULL
, size
);
861 tmp
= gfc_evaluate_now (tmp
, pre
);
868 stmtblock_t do_copying
;
870 tmp
= TREE_TYPE (initial
); /* Pointer to descriptor. */
871 gcc_assert (TREE_CODE (tmp
) == POINTER_TYPE
);
872 tmp
= TREE_TYPE (tmp
); /* The descriptor itself. */
873 tmp
= gfc_get_element_type (tmp
);
874 gcc_assert (tmp
== gfc_get_element_type (TREE_TYPE (desc
)));
875 packed
= gfc_create_var (build_pointer_type (tmp
), "data");
877 tmp
= build_call_expr_loc (input_location
,
878 gfor_fndecl_in_pack
, 1, initial
);
879 tmp
= fold_convert (TREE_TYPE (packed
), tmp
);
880 gfc_add_modify (pre
, packed
, tmp
);
882 tmp
= build_fold_indirect_ref_loc (input_location
,
884 source_data
= gfc_conv_descriptor_data_get (tmp
);
886 /* internal_pack may return source->data without any allocation
887 or copying if it is already packed. If that's the case, we
888 need to allocate and copy manually. */
890 gfc_start_block (&do_copying
);
891 tmp
= gfc_call_malloc (&do_copying
, NULL
, size
);
892 tmp
= fold_convert (TREE_TYPE (packed
), tmp
);
893 gfc_add_modify (&do_copying
, packed
, tmp
);
894 tmp
= gfc_build_memcpy_call (packed
, source_data
, size
);
895 gfc_add_expr_to_block (&do_copying
, tmp
);
897 was_packed
= fold_build2_loc (input_location
, EQ_EXPR
,
898 boolean_type_node
, packed
,
900 tmp
= gfc_finish_block (&do_copying
);
901 tmp
= build3_v (COND_EXPR
, was_packed
, tmp
,
902 build_empty_stmt (input_location
));
903 gfc_add_expr_to_block (pre
, tmp
);
905 tmp
= fold_convert (pvoid_type_node
, packed
);
908 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
911 info
->data
= gfc_conv_descriptor_data_get (desc
);
913 /* The offset is zero because we create temporaries with a zero
915 gfc_conv_descriptor_offset_set (pre
, desc
, gfc_index_zero_node
);
917 if (dealloc
&& !onstack
)
919 /* Free the temporary. */
920 tmp
= gfc_conv_descriptor_data_get (desc
);
921 tmp
= gfc_call_free (fold_convert (pvoid_type_node
, tmp
));
922 gfc_add_expr_to_block (post
, tmp
);
927 /* Get the scalarizer array dimension corresponding to actual array dimension
930 For example, if SS represents the array ref a(1,:,:,1), it is a
931 bidimensional scalarizer array, and the result would be 0 for ARRAY_DIM=1,
932 and 1 for ARRAY_DIM=2.
933 If SS represents transpose(a(:,1,1,:)), it is again a bidimensional
934 scalarizer array, and the result would be 1 for ARRAY_DIM=0 and 0 for
936 If SS represents sum(a(:,:,:,1), dim=1), it is a 2+1-dimensional scalarizer
937 array. If called on the inner ss, the result would be respectively 0,1,2 for
938 ARRAY_DIM=0,1,2. If called on the outer ss, the result would be 0,1
939 for ARRAY_DIM=1,2. */
942 get_scalarizer_dim_for_array_dim (gfc_ss
*ss
, int array_dim
)
949 for (; ss
; ss
= ss
->parent
)
950 for (n
= 0; n
< ss
->dimen
; n
++)
951 if (ss
->dim
[n
] < array_dim
)
954 return array_ref_dim
;
959 innermost_ss (gfc_ss
*ss
)
961 while (ss
->nested_ss
!= NULL
)
969 /* Get the array reference dimension corresponding to the given loop dimension.
970 It is different from the true array dimension given by the dim array in
971 the case of a partial array reference (i.e. a(:,:,1,:) for example)
972 It is different from the loop dimension in the case of a transposed array.
976 get_array_ref_dim_for_loop_dim (gfc_ss
*ss
, int loop_dim
)
978 return get_scalarizer_dim_for_array_dim (innermost_ss (ss
),
983 /* Generate code to create and initialize the descriptor for a temporary
984 array. This is used for both temporaries needed by the scalarizer, and
985 functions returning arrays. Adjusts the loop variables to be
986 zero-based, and calculates the loop bounds for callee allocated arrays.
987 Allocate the array unless it's callee allocated (we have a callee
988 allocated array if 'callee_alloc' is true, or if loop->to[n] is
989 NULL_TREE for any n). Also fills in the descriptor, data and offset
990 fields of info if known. Returns the size of the array, or NULL for a
991 callee allocated array.
993 'eltype' == NULL signals that the temporary should be a class object.
994 The 'initial' expression is used to obtain the size of the dynamic
995 type; otherwise the allocation and initialisation proceeds as for any
998 PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
999 gfc_trans_allocate_array_storage. */
1002 gfc_trans_create_temp_array (stmtblock_t
* pre
, stmtblock_t
* post
, gfc_ss
* ss
,
1003 tree eltype
, tree initial
, bool dynamic
,
1004 bool dealloc
, bool callee_alloc
, locus
* where
)
1008 gfc_array_info
*info
;
1009 tree from
[GFC_MAX_DIMENSIONS
], to
[GFC_MAX_DIMENSIONS
];
1017 tree class_expr
= NULL_TREE
;
1018 int n
, dim
, tmp_dim
;
1021 /* This signals a class array for which we need the size of the
1022 dynamic type. Generate an eltype and then the class expression. */
1023 if (eltype
== NULL_TREE
&& initial
)
1025 gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial
)));
1026 class_expr
= build_fold_indirect_ref_loc (input_location
, initial
);
1027 eltype
= TREE_TYPE (class_expr
);
1028 eltype
= gfc_get_element_type (eltype
);
1029 /* Obtain the structure (class) expression. */
1030 class_expr
= TREE_OPERAND (class_expr
, 0);
1031 gcc_assert (class_expr
);
1034 memset (from
, 0, sizeof (from
));
1035 memset (to
, 0, sizeof (to
));
1037 info
= &ss
->info
->data
.array
;
1039 gcc_assert (ss
->dimen
> 0);
1040 gcc_assert (ss
->loop
->dimen
== ss
->dimen
);
1042 if (gfc_option
.warn_array_temp
&& where
)
1043 gfc_warning ("Creating array temporary at %L", where
);
1045 /* Set the lower bound to zero. */
1046 for (s
= ss
; s
; s
= s
->parent
)
1050 total_dim
+= loop
->dimen
;
1051 for (n
= 0; n
< loop
->dimen
; n
++)
1055 /* Callee allocated arrays may not have a known bound yet. */
1057 loop
->to
[n
] = gfc_evaluate_now (
1058 fold_build2_loc (input_location
, MINUS_EXPR
,
1059 gfc_array_index_type
,
1060 loop
->to
[n
], loop
->from
[n
]),
1062 loop
->from
[n
] = gfc_index_zero_node
;
1064 /* We have just changed the loop bounds, we must clear the
1065 corresponding specloop, so that delta calculation is not skipped
1066 later in gfc_set_delta. */
1067 loop
->specloop
[n
] = NULL
;
1069 /* We are constructing the temporary's descriptor based on the loop
1070 dimensions. As the dimensions may be accessed in arbitrary order
1071 (think of transpose) the size taken from the n'th loop may not map
1072 to the n'th dimension of the array. We need to reconstruct loop
1073 infos in the right order before using it to set the descriptor
1075 tmp_dim
= get_scalarizer_dim_for_array_dim (ss
, dim
);
1076 from
[tmp_dim
] = loop
->from
[n
];
1077 to
[tmp_dim
] = loop
->to
[n
];
1079 info
->delta
[dim
] = gfc_index_zero_node
;
1080 info
->start
[dim
] = gfc_index_zero_node
;
1081 info
->end
[dim
] = gfc_index_zero_node
;
1082 info
->stride
[dim
] = gfc_index_one_node
;
1086 /* Initialize the descriptor. */
1088 gfc_get_array_type_bounds (eltype
, total_dim
, 0, from
, to
, 1,
1089 GFC_ARRAY_UNKNOWN
, true);
1090 desc
= gfc_create_var (type
, "atmp");
1091 GFC_DECL_PACKED_ARRAY (desc
) = 1;
1093 info
->descriptor
= desc
;
1094 size
= gfc_index_one_node
;
1096 /* Fill in the array dtype. */
1097 tmp
= gfc_conv_descriptor_dtype (desc
);
1098 gfc_add_modify (pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
1101 Fill in the bounds and stride. This is a packed array, so:
1104 for (n = 0; n < rank; n++)
1107 delta = ubound[n] + 1 - lbound[n];
1108 size = size * delta;
1110 size = size * sizeof(element);
1113 or_expr
= NULL_TREE
;
1115 /* If there is at least one null loop->to[n], it is a callee allocated
1117 for (n
= 0; n
< total_dim
; n
++)
1118 if (to
[n
] == NULL_TREE
)
1124 if (size
== NULL_TREE
)
1125 for (s
= ss
; s
; s
= s
->parent
)
1126 for (n
= 0; n
< s
->loop
->dimen
; n
++)
1128 dim
= get_scalarizer_dim_for_array_dim (ss
, s
->dim
[n
]);
1130 /* For a callee allocated array express the loop bounds in terms
1131 of the descriptor fields. */
1132 tmp
= fold_build2_loc (input_location
,
1133 MINUS_EXPR
, gfc_array_index_type
,
1134 gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]),
1135 gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]));
1136 s
->loop
->to
[n
] = tmp
;
1140 for (n
= 0; n
< total_dim
; n
++)
1142 /* Store the stride and bound components in the descriptor. */
1143 gfc_conv_descriptor_stride_set (pre
, desc
, gfc_rank_cst
[n
], size
);
1145 gfc_conv_descriptor_lbound_set (pre
, desc
, gfc_rank_cst
[n
],
1146 gfc_index_zero_node
);
1148 gfc_conv_descriptor_ubound_set (pre
, desc
, gfc_rank_cst
[n
], to
[n
]);
1150 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1151 gfc_array_index_type
,
1152 to
[n
], gfc_index_one_node
);
1154 /* Check whether the size for this dimension is negative. */
1155 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
1156 tmp
, gfc_index_zero_node
);
1157 cond
= gfc_evaluate_now (cond
, pre
);
1162 or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1163 boolean_type_node
, or_expr
, cond
);
1165 size
= fold_build2_loc (input_location
, MULT_EXPR
,
1166 gfc_array_index_type
, size
, tmp
);
1167 size
= gfc_evaluate_now (size
, pre
);
1171 /* Get the size of the array. */
1172 if (size
&& !callee_alloc
)
1175 /* If or_expr is true, then the extent in at least one
1176 dimension is zero and the size is set to zero. */
1177 size
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
1178 or_expr
, gfc_index_zero_node
, size
);
1181 if (class_expr
== NULL_TREE
)
1182 elemsize
= fold_convert (gfc_array_index_type
,
1183 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
1185 elemsize
= gfc_vtable_size_get (class_expr
);
1187 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
1196 gfc_trans_allocate_array_storage (pre
, post
, info
, size
, nelem
, initial
,
1202 if (ss
->dimen
> ss
->loop
->temp_dim
)
1203 ss
->loop
->temp_dim
= ss
->dimen
;
1209 /* Return the number of iterations in a loop that starts at START,
1210 ends at END, and has step STEP. */
1213 gfc_get_iteration_count (tree start
, tree end
, tree step
)
1218 type
= TREE_TYPE (step
);
1219 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, end
, start
);
1220 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
, type
, tmp
, step
);
1221 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
,
1222 build_int_cst (type
, 1));
1223 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, type
, tmp
,
1224 build_int_cst (type
, 0));
1225 return fold_convert (gfc_array_index_type
, tmp
);
1229 /* Extend the data in array DESC by EXTRA elements. */
1232 gfc_grow_array (stmtblock_t
* pblock
, tree desc
, tree extra
)
1239 if (integer_zerop (extra
))
1242 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[0]);
1244 /* Add EXTRA to the upper bound. */
1245 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1247 gfc_conv_descriptor_ubound_set (pblock
, desc
, gfc_rank_cst
[0], tmp
);
1249 /* Get the value of the current data pointer. */
1250 arg0
= gfc_conv_descriptor_data_get (desc
);
1252 /* Calculate the new array size. */
1253 size
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
1254 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1255 ubound
, gfc_index_one_node
);
1256 arg1
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
1257 fold_convert (size_type_node
, tmp
),
1258 fold_convert (size_type_node
, size
));
1260 /* Call the realloc() function. */
1261 tmp
= gfc_call_realloc (pblock
, arg0
, arg1
);
1262 gfc_conv_descriptor_data_set (pblock
, desc
, tmp
);
1266 /* Return true if the bounds of iterator I can only be determined
1270 gfc_iterator_has_dynamic_bounds (gfc_iterator
* i
)
1272 return (i
->start
->expr_type
!= EXPR_CONSTANT
1273 || i
->end
->expr_type
!= EXPR_CONSTANT
1274 || i
->step
->expr_type
!= EXPR_CONSTANT
);
1278 /* Split the size of constructor element EXPR into the sum of two terms,
1279 one of which can be determined at compile time and one of which must
1280 be calculated at run time. Set *SIZE to the former and return true
1281 if the latter might be nonzero. */
1284 gfc_get_array_constructor_element_size (mpz_t
* size
, gfc_expr
* expr
)
1286 if (expr
->expr_type
== EXPR_ARRAY
)
1287 return gfc_get_array_constructor_size (size
, expr
->value
.constructor
);
1288 else if (expr
->rank
> 0)
1290 /* Calculate everything at run time. */
1291 mpz_set_ui (*size
, 0);
1296 /* A single element. */
1297 mpz_set_ui (*size
, 1);
1303 /* Like gfc_get_array_constructor_element_size, but applied to the whole
1304 of array constructor C. */
1307 gfc_get_array_constructor_size (mpz_t
* size
, gfc_constructor_base base
)
1315 mpz_set_ui (*size
, 0);
1320 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1323 if (i
&& gfc_iterator_has_dynamic_bounds (i
))
1327 dynamic
|= gfc_get_array_constructor_element_size (&len
, c
->expr
);
1330 /* Multiply the static part of the element size by the
1331 number of iterations. */
1332 mpz_sub (val
, i
->end
->value
.integer
, i
->start
->value
.integer
);
1333 mpz_fdiv_q (val
, val
, i
->step
->value
.integer
);
1334 mpz_add_ui (val
, val
, 1);
1335 if (mpz_sgn (val
) > 0)
1336 mpz_mul (len
, len
, val
);
1338 mpz_set_ui (len
, 0);
1340 mpz_add (*size
, *size
, len
);
1349 /* Make sure offset is a variable. */
1352 gfc_put_offset_into_var (stmtblock_t
* pblock
, tree
* poffset
,
1355 /* We should have already created the offset variable. We cannot
1356 create it here because we may be in an inner scope. */
1357 gcc_assert (*offsetvar
!= NULL_TREE
);
1358 gfc_add_modify (pblock
, *offsetvar
, *poffset
);
1359 *poffset
= *offsetvar
;
1360 TREE_USED (*offsetvar
) = 1;
1364 /* Variables needed for bounds-checking. */
1365 static bool first_len
;
1366 static tree first_len_val
;
1367 static bool typespec_chararray_ctor
;
1370 gfc_trans_array_ctor_element (stmtblock_t
* pblock
, tree desc
,
1371 tree offset
, gfc_se
* se
, gfc_expr
* expr
)
1375 gfc_conv_expr (se
, expr
);
1377 /* Store the value. */
1378 tmp
= build_fold_indirect_ref_loc (input_location
,
1379 gfc_conv_descriptor_data_get (desc
));
1380 tmp
= gfc_build_array_ref (tmp
, offset
, NULL
);
1382 if (expr
->ts
.type
== BT_CHARACTER
)
1384 int i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
1387 esize
= size_in_bytes (gfc_get_element_type (TREE_TYPE (desc
)));
1388 esize
= fold_convert (gfc_charlen_type_node
, esize
);
1389 esize
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1390 gfc_charlen_type_node
, esize
,
1391 build_int_cst (gfc_charlen_type_node
,
1392 gfc_character_kinds
[i
].bit_size
/ 8));
1394 gfc_conv_string_parameter (se
);
1395 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
1397 /* The temporary is an array of pointers. */
1398 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1399 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1403 /* The temporary is an array of string values. */
1404 tmp
= gfc_build_addr_expr (gfc_get_pchar_type (expr
->ts
.kind
), tmp
);
1405 /* We know the temporary and the value will be the same length,
1406 so can use memcpy. */
1407 gfc_trans_string_copy (&se
->pre
, esize
, tmp
, expr
->ts
.kind
,
1408 se
->string_length
, se
->expr
, expr
->ts
.kind
);
1410 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && !typespec_chararray_ctor
)
1414 gfc_add_modify (&se
->pre
, first_len_val
,
1420 /* Verify that all constructor elements are of the same
1422 tree cond
= fold_build2_loc (input_location
, NE_EXPR
,
1423 boolean_type_node
, first_len_val
,
1425 gfc_trans_runtime_check
1426 (true, false, cond
, &se
->pre
, &expr
->where
,
1427 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1428 fold_convert (long_integer_type_node
, first_len_val
),
1429 fold_convert (long_integer_type_node
, se
->string_length
));
1435 /* TODO: Should the frontend already have done this conversion? */
1436 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1437 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1440 gfc_add_block_to_block (pblock
, &se
->pre
);
1441 gfc_add_block_to_block (pblock
, &se
->post
);
1445 /* Add the contents of an array to the constructor. DYNAMIC is as for
1446 gfc_trans_array_constructor_value. */
1449 gfc_trans_array_constructor_subarray (stmtblock_t
* pblock
,
1450 tree type ATTRIBUTE_UNUSED
,
1451 tree desc
, gfc_expr
* expr
,
1452 tree
* poffset
, tree
* offsetvar
,
1463 /* We need this to be a variable so we can increment it. */
1464 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1466 gfc_init_se (&se
, NULL
);
1468 /* Walk the array expression. */
1469 ss
= gfc_walk_expr (expr
);
1470 gcc_assert (ss
!= gfc_ss_terminator
);
1472 /* Initialize the scalarizer. */
1473 gfc_init_loopinfo (&loop
);
1474 gfc_add_ss_to_loop (&loop
, ss
);
1476 /* Initialize the loop. */
1477 gfc_conv_ss_startstride (&loop
);
1478 gfc_conv_loop_setup (&loop
, &expr
->where
);
1480 /* Make sure the constructed array has room for the new data. */
1483 /* Set SIZE to the total number of elements in the subarray. */
1484 size
= gfc_index_one_node
;
1485 for (n
= 0; n
< loop
.dimen
; n
++)
1487 tmp
= gfc_get_iteration_count (loop
.from
[n
], loop
.to
[n
],
1488 gfc_index_one_node
);
1489 size
= fold_build2_loc (input_location
, MULT_EXPR
,
1490 gfc_array_index_type
, size
, tmp
);
1493 /* Grow the constructed array by SIZE elements. */
1494 gfc_grow_array (&loop
.pre
, desc
, size
);
1497 /* Make the loop body. */
1498 gfc_mark_ss_chain_used (ss
, 1);
1499 gfc_start_scalarized_body (&loop
, &body
);
1500 gfc_copy_loopinfo_to_se (&se
, &loop
);
1503 gfc_trans_array_ctor_element (&body
, desc
, *poffset
, &se
, expr
);
1504 gcc_assert (se
.ss
== gfc_ss_terminator
);
1506 /* Increment the offset. */
1507 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1508 *poffset
, gfc_index_one_node
);
1509 gfc_add_modify (&body
, *poffset
, tmp
);
1511 /* Finish the loop. */
1512 gfc_trans_scalarizing_loops (&loop
, &body
);
1513 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
1514 tmp
= gfc_finish_block (&loop
.pre
);
1515 gfc_add_expr_to_block (pblock
, tmp
);
1517 gfc_cleanup_loop (&loop
);
1521 /* Assign the values to the elements of an array constructor. DYNAMIC
1522 is true if descriptor DESC only contains enough data for the static
1523 size calculated by gfc_get_array_constructor_size. When true, memory
1524 for the dynamic parts must be allocated using realloc. */
1527 gfc_trans_array_constructor_value (stmtblock_t
* pblock
, tree type
,
1528 tree desc
, gfc_constructor_base base
,
1529 tree
* poffset
, tree
* offsetvar
,
1533 tree start
= NULL_TREE
;
1534 tree end
= NULL_TREE
;
1535 tree step
= NULL_TREE
;
1541 tree shadow_loopvar
= NULL_TREE
;
1542 gfc_saved_var saved_loopvar
;
1545 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1547 /* If this is an iterator or an array, the offset must be a variable. */
1548 if ((c
->iterator
|| c
->expr
->rank
> 0) && INTEGER_CST_P (*poffset
))
1549 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1551 /* Shadowing the iterator avoids changing its value and saves us from
1552 keeping track of it. Further, it makes sure that there's always a
1553 backend-decl for the symbol, even if there wasn't one before,
1554 e.g. in the case of an iterator that appears in a specification
1555 expression in an interface mapping. */
1561 /* Evaluate loop bounds before substituting the loop variable
1562 in case they depend on it. Such a case is invalid, but it is
1563 not more expensive to do the right thing here.
1565 gfc_init_se (&se
, NULL
);
1566 gfc_conv_expr_val (&se
, c
->iterator
->start
);
1567 gfc_add_block_to_block (pblock
, &se
.pre
);
1568 start
= gfc_evaluate_now (se
.expr
, pblock
);
1570 gfc_init_se (&se
, NULL
);
1571 gfc_conv_expr_val (&se
, c
->iterator
->end
);
1572 gfc_add_block_to_block (pblock
, &se
.pre
);
1573 end
= gfc_evaluate_now (se
.expr
, pblock
);
1575 gfc_init_se (&se
, NULL
);
1576 gfc_conv_expr_val (&se
, c
->iterator
->step
);
1577 gfc_add_block_to_block (pblock
, &se
.pre
);
1578 step
= gfc_evaluate_now (se
.expr
, pblock
);
1580 sym
= c
->iterator
->var
->symtree
->n
.sym
;
1581 type
= gfc_typenode_for_spec (&sym
->ts
);
1583 shadow_loopvar
= gfc_create_var (type
, "shadow_loopvar");
1584 gfc_shadow_sym (sym
, shadow_loopvar
, &saved_loopvar
);
1587 gfc_start_block (&body
);
1589 if (c
->expr
->expr_type
== EXPR_ARRAY
)
1591 /* Array constructors can be nested. */
1592 gfc_trans_array_constructor_value (&body
, type
, desc
,
1593 c
->expr
->value
.constructor
,
1594 poffset
, offsetvar
, dynamic
);
1596 else if (c
->expr
->rank
> 0)
1598 gfc_trans_array_constructor_subarray (&body
, type
, desc
, c
->expr
,
1599 poffset
, offsetvar
, dynamic
);
1603 /* This code really upsets the gimplifier so don't bother for now. */
1610 while (p
&& !(p
->iterator
|| p
->expr
->expr_type
!= EXPR_CONSTANT
))
1612 p
= gfc_constructor_next (p
);
1617 /* Scalar values. */
1618 gfc_init_se (&se
, NULL
);
1619 gfc_trans_array_ctor_element (&body
, desc
, *poffset
,
1622 *poffset
= fold_build2_loc (input_location
, PLUS_EXPR
,
1623 gfc_array_index_type
,
1624 *poffset
, gfc_index_one_node
);
1628 /* Collect multiple scalar constants into a constructor. */
1629 vec
<constructor_elt
, va_gc
> *v
= NULL
;
1633 HOST_WIDE_INT idx
= 0;
1636 /* Count the number of consecutive scalar constants. */
1637 while (p
&& !(p
->iterator
1638 || p
->expr
->expr_type
!= EXPR_CONSTANT
))
1640 gfc_init_se (&se
, NULL
);
1641 gfc_conv_constant (&se
, p
->expr
);
1643 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
1644 se
.expr
= fold_convert (type
, se
.expr
);
1645 /* For constant character array constructors we build
1646 an array of pointers. */
1647 else if (POINTER_TYPE_P (type
))
1648 se
.expr
= gfc_build_addr_expr
1649 (gfc_get_pchar_type (p
->expr
->ts
.kind
),
1652 CONSTRUCTOR_APPEND_ELT (v
,
1653 build_int_cst (gfc_array_index_type
,
1657 p
= gfc_constructor_next (p
);
1660 bound
= size_int (n
- 1);
1661 /* Create an array type to hold them. */
1662 tmptype
= build_range_type (gfc_array_index_type
,
1663 gfc_index_zero_node
, bound
);
1664 tmptype
= build_array_type (type
, tmptype
);
1666 init
= build_constructor (tmptype
, v
);
1667 TREE_CONSTANT (init
) = 1;
1668 TREE_STATIC (init
) = 1;
1669 /* Create a static variable to hold the data. */
1670 tmp
= gfc_create_var (tmptype
, "data");
1671 TREE_STATIC (tmp
) = 1;
1672 TREE_CONSTANT (tmp
) = 1;
1673 TREE_READONLY (tmp
) = 1;
1674 DECL_INITIAL (tmp
) = init
;
1677 /* Use BUILTIN_MEMCPY to assign the values. */
1678 tmp
= gfc_conv_descriptor_data_get (desc
);
1679 tmp
= build_fold_indirect_ref_loc (input_location
,
1681 tmp
= gfc_build_array_ref (tmp
, *poffset
, NULL
);
1682 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1683 init
= gfc_build_addr_expr (NULL_TREE
, init
);
1685 size
= TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type
));
1686 bound
= build_int_cst (size_type_node
, n
* size
);
1687 tmp
= build_call_expr_loc (input_location
,
1688 builtin_decl_explicit (BUILT_IN_MEMCPY
),
1689 3, tmp
, init
, bound
);
1690 gfc_add_expr_to_block (&body
, tmp
);
1692 *poffset
= fold_build2_loc (input_location
, PLUS_EXPR
,
1693 gfc_array_index_type
, *poffset
,
1694 build_int_cst (gfc_array_index_type
, n
));
1696 if (!INTEGER_CST_P (*poffset
))
1698 gfc_add_modify (&body
, *offsetvar
, *poffset
);
1699 *poffset
= *offsetvar
;
1703 /* The frontend should already have done any expansions
1707 /* Pass the code as is. */
1708 tmp
= gfc_finish_block (&body
);
1709 gfc_add_expr_to_block (pblock
, tmp
);
1713 /* Build the implied do-loop. */
1714 stmtblock_t implied_do_block
;
1720 loopbody
= gfc_finish_block (&body
);
1722 /* Create a new block that holds the implied-do loop. A temporary
1723 loop-variable is used. */
1724 gfc_start_block(&implied_do_block
);
1726 /* Initialize the loop. */
1727 gfc_add_modify (&implied_do_block
, shadow_loopvar
, start
);
1729 /* If this array expands dynamically, and the number of iterations
1730 is not constant, we won't have allocated space for the static
1731 part of C->EXPR's size. Do that now. */
1732 if (dynamic
&& gfc_iterator_has_dynamic_bounds (c
->iterator
))
1734 /* Get the number of iterations. */
1735 tmp
= gfc_get_iteration_count (shadow_loopvar
, end
, step
);
1737 /* Get the static part of C->EXPR's size. */
1738 gfc_get_array_constructor_element_size (&size
, c
->expr
);
1739 tmp2
= gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
1741 /* Grow the array by TMP * TMP2 elements. */
1742 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
1743 gfc_array_index_type
, tmp
, tmp2
);
1744 gfc_grow_array (&implied_do_block
, desc
, tmp
);
1747 /* Generate the loop body. */
1748 exit_label
= gfc_build_label_decl (NULL_TREE
);
1749 gfc_start_block (&body
);
1751 /* Generate the exit condition. Depending on the sign of
1752 the step variable we have to generate the correct
1754 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1755 step
, build_int_cst (TREE_TYPE (step
), 0));
1756 cond
= fold_build3_loc (input_location
, COND_EXPR
,
1757 boolean_type_node
, tmp
,
1758 fold_build2_loc (input_location
, GT_EXPR
,
1759 boolean_type_node
, shadow_loopvar
, end
),
1760 fold_build2_loc (input_location
, LT_EXPR
,
1761 boolean_type_node
, shadow_loopvar
, end
));
1762 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1763 TREE_USED (exit_label
) = 1;
1764 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
1765 build_empty_stmt (input_location
));
1766 gfc_add_expr_to_block (&body
, tmp
);
1768 /* The main loop body. */
1769 gfc_add_expr_to_block (&body
, loopbody
);
1771 /* Increase loop variable by step. */
1772 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1773 TREE_TYPE (shadow_loopvar
), shadow_loopvar
,
1775 gfc_add_modify (&body
, shadow_loopvar
, tmp
);
1777 /* Finish the loop. */
1778 tmp
= gfc_finish_block (&body
);
1779 tmp
= build1_v (LOOP_EXPR
, tmp
);
1780 gfc_add_expr_to_block (&implied_do_block
, tmp
);
1782 /* Add the exit label. */
1783 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1784 gfc_add_expr_to_block (&implied_do_block
, tmp
);
1786 /* Finish the implied-do loop. */
1787 tmp
= gfc_finish_block(&implied_do_block
);
1788 gfc_add_expr_to_block(pblock
, tmp
);
1790 gfc_restore_sym (c
->iterator
->var
->symtree
->n
.sym
, &saved_loopvar
);
1797 /* A catch-all to obtain the string length for anything that is not
1798 a substring of non-constant length, a constant, array or variable. */
1801 get_array_ctor_all_strlen (stmtblock_t
*block
, gfc_expr
*e
, tree
*len
)
1805 /* Don't bother if we already know the length is a constant. */
1806 if (*len
&& INTEGER_CST_P (*len
))
1809 if (!e
->ref
&& e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
1810 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1813 gfc_conv_const_charlen (e
->ts
.u
.cl
);
1814 *len
= e
->ts
.u
.cl
->backend_decl
;
1818 /* Otherwise, be brutal even if inefficient. */
1819 gfc_init_se (&se
, NULL
);
1821 /* No function call, in case of side effects. */
1822 se
.no_function_call
= 1;
1824 gfc_conv_expr (&se
, e
);
1826 gfc_conv_expr_descriptor (&se
, e
);
1828 /* Fix the value. */
1829 *len
= gfc_evaluate_now (se
.string_length
, &se
.pre
);
1831 gfc_add_block_to_block (block
, &se
.pre
);
1832 gfc_add_block_to_block (block
, &se
.post
);
1834 e
->ts
.u
.cl
->backend_decl
= *len
;
1839 /* Figure out the string length of a variable reference expression.
1840 Used by get_array_ctor_strlen. */
1843 get_array_ctor_var_strlen (stmtblock_t
*block
, gfc_expr
* expr
, tree
* len
)
1849 /* Don't bother if we already know the length is a constant. */
1850 if (*len
&& INTEGER_CST_P (*len
))
1853 ts
= &expr
->symtree
->n
.sym
->ts
;
1854 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1859 /* Array references don't change the string length. */
1863 /* Use the length of the component. */
1864 ts
= &ref
->u
.c
.component
->ts
;
1868 if (ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1869 || ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1871 /* Note that this might evaluate expr. */
1872 get_array_ctor_all_strlen (block
, expr
, len
);
1875 mpz_init_set_ui (char_len
, 1);
1876 mpz_add (char_len
, char_len
, ref
->u
.ss
.end
->value
.integer
);
1877 mpz_sub (char_len
, char_len
, ref
->u
.ss
.start
->value
.integer
);
1878 *len
= gfc_conv_mpz_to_tree (char_len
, gfc_default_integer_kind
);
1879 *len
= convert (gfc_charlen_type_node
, *len
);
1880 mpz_clear (char_len
);
1888 *len
= ts
->u
.cl
->backend_decl
;
1892 /* Figure out the string length of a character array constructor.
1893 If len is NULL, don't calculate the length; this happens for recursive calls
1894 when a sub-array-constructor is an element but not at the first position,
1895 so when we're not interested in the length.
1896 Returns TRUE if all elements are character constants. */
1899 get_array_ctor_strlen (stmtblock_t
*block
, gfc_constructor_base base
, tree
* len
)
1906 if (gfc_constructor_first (base
) == NULL
)
1909 *len
= build_int_cstu (gfc_charlen_type_node
, 0);
1913 /* Loop over all constructor elements to find out is_const, but in len we
1914 want to store the length of the first, not the last, element. We can
1915 of course exit the loop as soon as is_const is found to be false. */
1916 for (c
= gfc_constructor_first (base
);
1917 c
&& is_const
; c
= gfc_constructor_next (c
))
1919 switch (c
->expr
->expr_type
)
1922 if (len
&& !(*len
&& INTEGER_CST_P (*len
)))
1923 *len
= build_int_cstu (gfc_charlen_type_node
,
1924 c
->expr
->value
.character
.length
);
1928 if (!get_array_ctor_strlen (block
, c
->expr
->value
.constructor
, len
))
1935 get_array_ctor_var_strlen (block
, c
->expr
, len
);
1941 get_array_ctor_all_strlen (block
, c
->expr
, len
);
1945 /* After the first iteration, we don't want the length modified. */
1952 /* Check whether the array constructor C consists entirely of constant
1953 elements, and if so returns the number of those elements, otherwise
1954 return zero. Note, an empty or NULL array constructor returns zero. */
1956 unsigned HOST_WIDE_INT
1957 gfc_constant_array_constructor_p (gfc_constructor_base base
)
1959 unsigned HOST_WIDE_INT nelem
= 0;
1961 gfc_constructor
*c
= gfc_constructor_first (base
);
1965 || c
->expr
->rank
> 0
1966 || c
->expr
->expr_type
!= EXPR_CONSTANT
)
1968 c
= gfc_constructor_next (c
);
1975 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1976 and the tree type of it's elements, TYPE, return a static constant
1977 variable that is compile-time initialized. */
1980 gfc_build_constant_array_constructor (gfc_expr
* expr
, tree type
)
1982 tree tmptype
, init
, tmp
;
1983 HOST_WIDE_INT nelem
;
1988 vec
<constructor_elt
, va_gc
> *v
= NULL
;
1990 /* First traverse the constructor list, converting the constants
1991 to tree to build an initializer. */
1993 c
= gfc_constructor_first (expr
->value
.constructor
);
1996 gfc_init_se (&se
, NULL
);
1997 gfc_conv_constant (&se
, c
->expr
);
1998 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
1999 se
.expr
= fold_convert (type
, se
.expr
);
2000 else if (POINTER_TYPE_P (type
))
2001 se
.expr
= gfc_build_addr_expr (gfc_get_pchar_type (c
->expr
->ts
.kind
),
2003 CONSTRUCTOR_APPEND_ELT (v
, build_int_cst (gfc_array_index_type
, nelem
),
2005 c
= gfc_constructor_next (c
);
2009 /* Next determine the tree type for the array. We use the gfortran
2010 front-end's gfc_get_nodesc_array_type in order to create a suitable
2011 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
2013 memset (&as
, 0, sizeof (gfc_array_spec
));
2015 as
.rank
= expr
->rank
;
2016 as
.type
= AS_EXPLICIT
;
2019 as
.lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2020 as
.upper
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
2024 for (i
= 0; i
< expr
->rank
; i
++)
2026 int tmp
= (int) mpz_get_si (expr
->shape
[i
]);
2027 as
.lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2028 as
.upper
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
2032 tmptype
= gfc_get_nodesc_array_type (type
, &as
, PACKED_STATIC
, true);
2034 /* as is not needed anymore. */
2035 for (i
= 0; i
< as
.rank
+ as
.corank
; i
++)
2037 gfc_free_expr (as
.lower
[i
]);
2038 gfc_free_expr (as
.upper
[i
]);
2041 init
= build_constructor (tmptype
, v
);
2043 TREE_CONSTANT (init
) = 1;
2044 TREE_STATIC (init
) = 1;
2046 tmp
= gfc_create_var (tmptype
, "A");
2047 TREE_STATIC (tmp
) = 1;
2048 TREE_CONSTANT (tmp
) = 1;
2049 TREE_READONLY (tmp
) = 1;
2050 DECL_INITIAL (tmp
) = init
;
2056 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
2057 This mostly initializes the scalarizer state info structure with the
2058 appropriate values to directly use the array created by the function
2059 gfc_build_constant_array_constructor. */
2062 trans_constant_array_constructor (gfc_ss
* ss
, tree type
)
2064 gfc_array_info
*info
;
2068 tmp
= gfc_build_constant_array_constructor (ss
->info
->expr
, type
);
2070 info
= &ss
->info
->data
.array
;
2072 info
->descriptor
= tmp
;
2073 info
->data
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2074 info
->offset
= gfc_index_zero_node
;
2076 for (i
= 0; i
< ss
->dimen
; i
++)
2078 info
->delta
[i
] = gfc_index_zero_node
;
2079 info
->start
[i
] = gfc_index_zero_node
;
2080 info
->end
[i
] = gfc_index_zero_node
;
2081 info
->stride
[i
] = gfc_index_one_node
;
2087 get_rank (gfc_loopinfo
*loop
)
2092 for (; loop
; loop
= loop
->parent
)
2093 rank
+= loop
->dimen
;
2099 /* Helper routine of gfc_trans_array_constructor to determine if the
2100 bounds of the loop specified by LOOP are constant and simple enough
2101 to use with trans_constant_array_constructor. Returns the
2102 iteration count of the loop if suitable, and NULL_TREE otherwise. */
2105 constant_array_constructor_loop_size (gfc_loopinfo
* l
)
2108 tree size
= gfc_index_one_node
;
2112 total_dim
= get_rank (l
);
2114 for (loop
= l
; loop
; loop
= loop
->parent
)
2116 for (i
= 0; i
< loop
->dimen
; i
++)
2118 /* If the bounds aren't constant, return NULL_TREE. */
2119 if (!INTEGER_CST_P (loop
->from
[i
]) || !INTEGER_CST_P (loop
->to
[i
]))
2121 if (!integer_zerop (loop
->from
[i
]))
2123 /* Only allow nonzero "from" in one-dimensional arrays. */
2126 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2127 gfc_array_index_type
,
2128 loop
->to
[i
], loop
->from
[i
]);
2132 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2133 gfc_array_index_type
, tmp
, gfc_index_one_node
);
2134 size
= fold_build2_loc (input_location
, MULT_EXPR
,
2135 gfc_array_index_type
, size
, tmp
);
2144 get_loop_upper_bound_for_array (gfc_ss
*array
, int array_dim
)
2149 gcc_assert (array
->nested_ss
== NULL
);
2151 for (ss
= array
; ss
; ss
= ss
->parent
)
2152 for (n
= 0; n
< ss
->loop
->dimen
; n
++)
2153 if (array_dim
== get_array_ref_dim_for_loop_dim (ss
, n
))
2154 return &(ss
->loop
->to
[n
]);
2160 static gfc_loopinfo
*
2161 outermost_loop (gfc_loopinfo
* loop
)
2163 while (loop
->parent
!= NULL
)
2164 loop
= loop
->parent
;
2170 /* Array constructors are handled by constructing a temporary, then using that
2171 within the scalarization loop. This is not optimal, but seems by far the
2175 trans_array_constructor (gfc_ss
* ss
, locus
* where
)
2177 gfc_constructor_base c
;
2185 bool old_first_len
, old_typespec_chararray_ctor
;
2186 tree old_first_len_val
;
2187 gfc_loopinfo
*loop
, *outer_loop
;
2188 gfc_ss_info
*ss_info
;
2192 /* Save the old values for nested checking. */
2193 old_first_len
= first_len
;
2194 old_first_len_val
= first_len_val
;
2195 old_typespec_chararray_ctor
= typespec_chararray_ctor
;
2198 outer_loop
= outermost_loop (loop
);
2200 expr
= ss_info
->expr
;
2202 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
2203 typespec was given for the array constructor. */
2204 typespec_chararray_ctor
= (expr
->ts
.u
.cl
2205 && expr
->ts
.u
.cl
->length_from_typespec
);
2207 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2208 && expr
->ts
.type
== BT_CHARACTER
&& !typespec_chararray_ctor
)
2210 first_len_val
= gfc_create_var (gfc_charlen_type_node
, "len");
2214 gcc_assert (ss
->dimen
== ss
->loop
->dimen
);
2216 c
= expr
->value
.constructor
;
2217 if (expr
->ts
.type
== BT_CHARACTER
)
2221 /* get_array_ctor_strlen walks the elements of the constructor, if a
2222 typespec was given, we already know the string length and want the one
2224 if (typespec_chararray_ctor
&& expr
->ts
.u
.cl
->length
2225 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
2229 const_string
= false;
2230 gfc_init_se (&length_se
, NULL
);
2231 gfc_conv_expr_type (&length_se
, expr
->ts
.u
.cl
->length
,
2232 gfc_charlen_type_node
);
2233 ss_info
->string_length
= length_se
.expr
;
2234 gfc_add_block_to_block (&outer_loop
->pre
, &length_se
.pre
);
2235 gfc_add_block_to_block (&outer_loop
->post
, &length_se
.post
);
2238 const_string
= get_array_ctor_strlen (&outer_loop
->pre
, c
,
2239 &ss_info
->string_length
);
2241 /* Complex character array constructors should have been taken care of
2242 and not end up here. */
2243 gcc_assert (ss_info
->string_length
);
2245 expr
->ts
.u
.cl
->backend_decl
= ss_info
->string_length
;
2247 type
= gfc_get_character_type_len (expr
->ts
.kind
, ss_info
->string_length
);
2249 type
= build_pointer_type (type
);
2252 type
= gfc_typenode_for_spec (&expr
->ts
);
2254 /* See if the constructor determines the loop bounds. */
2257 loop_ubound0
= get_loop_upper_bound_for_array (ss
, 0);
2259 if (expr
->shape
&& get_rank (loop
) > 1 && *loop_ubound0
== NULL_TREE
)
2261 /* We have a multidimensional parameter. */
2262 for (s
= ss
; s
; s
= s
->parent
)
2265 for (n
= 0; n
< s
->loop
->dimen
; n
++)
2267 s
->loop
->from
[n
] = gfc_index_zero_node
;
2268 s
->loop
->to
[n
] = gfc_conv_mpz_to_tree (expr
->shape
[s
->dim
[n
]],
2269 gfc_index_integer_kind
);
2270 s
->loop
->to
[n
] = fold_build2_loc (input_location
, MINUS_EXPR
,
2271 gfc_array_index_type
,
2273 gfc_index_one_node
);
2278 if (*loop_ubound0
== NULL_TREE
)
2282 /* We should have a 1-dimensional, zero-based loop. */
2283 gcc_assert (loop
->parent
== NULL
&& loop
->nested
== NULL
);
2284 gcc_assert (loop
->dimen
== 1);
2285 gcc_assert (integer_zerop (loop
->from
[0]));
2287 /* Split the constructor size into a static part and a dynamic part.
2288 Allocate the static size up-front and record whether the dynamic
2289 size might be nonzero. */
2291 dynamic
= gfc_get_array_constructor_size (&size
, c
);
2292 mpz_sub_ui (size
, size
, 1);
2293 loop
->to
[0] = gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
2297 /* Special case constant array constructors. */
2300 unsigned HOST_WIDE_INT nelem
= gfc_constant_array_constructor_p (c
);
2303 tree size
= constant_array_constructor_loop_size (loop
);
2304 if (size
&& compare_tree_int (size
, nelem
) == 0)
2306 trans_constant_array_constructor (ss
, type
);
2312 if (TREE_CODE (*loop_ubound0
) == VAR_DECL
)
2315 gfc_trans_create_temp_array (&outer_loop
->pre
, &outer_loop
->post
, ss
, type
,
2316 NULL_TREE
, dynamic
, true, false, where
);
2318 desc
= ss_info
->data
.array
.descriptor
;
2319 offset
= gfc_index_zero_node
;
2320 offsetvar
= gfc_create_var_np (gfc_array_index_type
, "offset");
2321 TREE_NO_WARNING (offsetvar
) = 1;
2322 TREE_USED (offsetvar
) = 0;
2323 gfc_trans_array_constructor_value (&outer_loop
->pre
, type
, desc
, c
,
2324 &offset
, &offsetvar
, dynamic
);
2326 /* If the array grows dynamically, the upper bound of the loop variable
2327 is determined by the array's final upper bound. */
2330 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2331 gfc_array_index_type
,
2332 offsetvar
, gfc_index_one_node
);
2333 tmp
= gfc_evaluate_now (tmp
, &outer_loop
->pre
);
2334 gfc_conv_descriptor_ubound_set (&loop
->pre
, desc
, gfc_rank_cst
[0], tmp
);
2335 if (*loop_ubound0
&& TREE_CODE (*loop_ubound0
) == VAR_DECL
)
2336 gfc_add_modify (&outer_loop
->pre
, *loop_ubound0
, tmp
);
2338 *loop_ubound0
= tmp
;
2341 if (TREE_USED (offsetvar
))
2342 pushdecl (offsetvar
);
2344 gcc_assert (INTEGER_CST_P (offset
));
2347 /* Disable bound checking for now because it's probably broken. */
2348 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2355 /* Restore old values of globals. */
2356 first_len
= old_first_len
;
2357 first_len_val
= old_first_len_val
;
2358 typespec_chararray_ctor
= old_typespec_chararray_ctor
;
2362 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
2363 called after evaluating all of INFO's vector dimensions. Go through
2364 each such vector dimension and see if we can now fill in any missing
2368 set_vector_loop_bounds (gfc_ss
* ss
)
2370 gfc_loopinfo
*loop
, *outer_loop
;
2371 gfc_array_info
*info
;
2379 outer_loop
= outermost_loop (ss
->loop
);
2381 info
= &ss
->info
->data
.array
;
2383 for (; ss
; ss
= ss
->parent
)
2387 for (n
= 0; n
< loop
->dimen
; n
++)
2390 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_VECTOR
2391 || loop
->to
[n
] != NULL
)
2394 /* Loop variable N indexes vector dimension DIM, and we don't
2395 yet know the upper bound of loop variable N. Set it to the
2396 difference between the vector's upper and lower bounds. */
2397 gcc_assert (loop
->from
[n
] == gfc_index_zero_node
);
2398 gcc_assert (info
->subscript
[dim
]
2399 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
2401 gfc_init_se (&se
, NULL
);
2402 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
2403 zero
= gfc_rank_cst
[0];
2404 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2405 gfc_array_index_type
,
2406 gfc_conv_descriptor_ubound_get (desc
, zero
),
2407 gfc_conv_descriptor_lbound_get (desc
, zero
));
2408 tmp
= gfc_evaluate_now (tmp
, &outer_loop
->pre
);
2415 /* Add the pre and post chains for all the scalar expressions in a SS chain
2416 to loop. This is called after the loop parameters have been calculated,
2417 but before the actual scalarizing loops. */
2420 gfc_add_loop_ss_code (gfc_loopinfo
* loop
, gfc_ss
* ss
, bool subscript
,
2423 gfc_loopinfo
*nested_loop
, *outer_loop
;
2425 gfc_ss_info
*ss_info
;
2426 gfc_array_info
*info
;
2430 /* Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise,
2431 arguments could get evaluated multiple times. */
2432 if (ss
->is_alloc_lhs
)
2435 outer_loop
= outermost_loop (loop
);
2437 /* TODO: This can generate bad code if there are ordering dependencies,
2438 e.g., a callee allocated function and an unknown size constructor. */
2439 gcc_assert (ss
!= NULL
);
2441 for (; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2445 /* Cross loop arrays are handled from within the most nested loop. */
2446 if (ss
->nested_ss
!= NULL
)
2450 expr
= ss_info
->expr
;
2451 info
= &ss_info
->data
.array
;
2453 switch (ss_info
->type
)
2456 /* Scalar expression. Evaluate this now. This includes elemental
2457 dimension indices, but not array section bounds. */
2458 gfc_init_se (&se
, NULL
);
2459 gfc_conv_expr (&se
, expr
);
2460 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2462 if (expr
->ts
.type
!= BT_CHARACTER
)
2464 /* Move the evaluation of scalar expressions outside the
2465 scalarization loop, except for WHERE assignments. */
2467 se
.expr
= convert(gfc_array_index_type
, se
.expr
);
2468 if (!ss_info
->where
)
2469 se
.expr
= gfc_evaluate_now (se
.expr
, &outer_loop
->pre
);
2470 gfc_add_block_to_block (&outer_loop
->pre
, &se
.post
);
2473 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2475 ss_info
->data
.scalar
.value
= se
.expr
;
2476 ss_info
->string_length
= se
.string_length
;
2479 case GFC_SS_REFERENCE
:
2480 /* Scalar argument to elemental procedure. */
2481 gfc_init_se (&se
, NULL
);
2482 if (ss_info
->can_be_null_ref
)
2484 /* If the actual argument can be absent (in other words, it can
2485 be a NULL reference), don't try to evaluate it; pass instead
2486 the reference directly. */
2487 gfc_conv_expr_reference (&se
, expr
);
2491 /* Otherwise, evaluate the argument outside the loop and pass
2492 a reference to the value. */
2493 gfc_conv_expr (&se
, expr
);
2495 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2496 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2497 if (gfc_is_class_scalar_expr (expr
))
2498 /* This is necessary because the dynamic type will always be
2499 large than the declared type. In consequence, assigning
2500 the value to a temporary could segfault.
2501 OOP-TODO: see if this is generally correct or is the value
2502 has to be written to an allocated temporary, whose address
2503 is passed via ss_info. */
2504 ss_info
->data
.scalar
.value
= se
.expr
;
2506 ss_info
->data
.scalar
.value
= gfc_evaluate_now (se
.expr
,
2509 ss_info
->string_length
= se
.string_length
;
2512 case GFC_SS_SECTION
:
2513 /* Add the expressions for scalar and vector subscripts. */
2514 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2515 if (info
->subscript
[n
])
2516 gfc_add_loop_ss_code (loop
, info
->subscript
[n
], true, where
);
2518 set_vector_loop_bounds (ss
);
2522 /* Get the vector's descriptor and store it in SS. */
2523 gfc_init_se (&se
, NULL
);
2524 gfc_conv_expr_descriptor (&se
, expr
);
2525 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2526 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2527 info
->descriptor
= se
.expr
;
2530 case GFC_SS_INTRINSIC
:
2531 gfc_add_intrinsic_ss_code (loop
, ss
);
2534 case GFC_SS_FUNCTION
:
2535 /* Array function return value. We call the function and save its
2536 result in a temporary for use inside the loop. */
2537 gfc_init_se (&se
, NULL
);
2540 gfc_conv_expr (&se
, expr
);
2541 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2542 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2543 ss_info
->string_length
= se
.string_length
;
2546 case GFC_SS_CONSTRUCTOR
:
2547 if (expr
->ts
.type
== BT_CHARACTER
2548 && ss_info
->string_length
== NULL
2550 && expr
->ts
.u
.cl
->length
)
2552 gfc_init_se (&se
, NULL
);
2553 gfc_conv_expr_type (&se
, expr
->ts
.u
.cl
->length
,
2554 gfc_charlen_type_node
);
2555 ss_info
->string_length
= se
.expr
;
2556 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2557 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2559 trans_array_constructor (ss
, where
);
2563 case GFC_SS_COMPONENT
:
2564 /* Do nothing. These are handled elsewhere. */
2573 for (nested_loop
= loop
->nested
; nested_loop
;
2574 nested_loop
= nested_loop
->next
)
2575 gfc_add_loop_ss_code (nested_loop
, nested_loop
->ss
, subscript
, where
);
2579 /* Translate expressions for the descriptor and data pointer of a SS. */
2583 gfc_conv_ss_descriptor (stmtblock_t
* block
, gfc_ss
* ss
, int base
)
2586 gfc_ss_info
*ss_info
;
2587 gfc_array_info
*info
;
2591 info
= &ss_info
->data
.array
;
2593 /* Get the descriptor for the array to be scalarized. */
2594 gcc_assert (ss_info
->expr
->expr_type
== EXPR_VARIABLE
);
2595 gfc_init_se (&se
, NULL
);
2596 se
.descriptor_only
= 1;
2597 gfc_conv_expr_lhs (&se
, ss_info
->expr
);
2598 gfc_add_block_to_block (block
, &se
.pre
);
2599 info
->descriptor
= se
.expr
;
2600 ss_info
->string_length
= se
.string_length
;
2604 /* Also the data pointer. */
2605 tmp
= gfc_conv_array_data (se
.expr
);
2606 /* If this is a variable or address of a variable we use it directly.
2607 Otherwise we must evaluate it now to avoid breaking dependency
2608 analysis by pulling the expressions for elemental array indices
2611 || (TREE_CODE (tmp
) == ADDR_EXPR
2612 && DECL_P (TREE_OPERAND (tmp
, 0)))))
2613 tmp
= gfc_evaluate_now (tmp
, block
);
2616 tmp
= gfc_conv_array_offset (se
.expr
);
2617 info
->offset
= gfc_evaluate_now (tmp
, block
);
2619 /* Make absolutely sure that the saved_offset is indeed saved
2620 so that the variable is still accessible after the loops
2622 info
->saved_offset
= info
->offset
;
2627 /* Initialize a gfc_loopinfo structure. */
2630 gfc_init_loopinfo (gfc_loopinfo
* loop
)
2634 memset (loop
, 0, sizeof (gfc_loopinfo
));
2635 gfc_init_block (&loop
->pre
);
2636 gfc_init_block (&loop
->post
);
2638 /* Initially scalarize in order and default to no loop reversal. */
2639 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2642 loop
->reverse
[n
] = GFC_INHIBIT_REVERSE
;
2645 loop
->ss
= gfc_ss_terminator
;
2649 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2653 gfc_copy_loopinfo_to_se (gfc_se
* se
, gfc_loopinfo
* loop
)
2659 /* Return an expression for the data pointer of an array. */
2662 gfc_conv_array_data (tree descriptor
)
2666 type
= TREE_TYPE (descriptor
);
2667 if (GFC_ARRAY_TYPE_P (type
))
2669 if (TREE_CODE (type
) == POINTER_TYPE
)
2673 /* Descriptorless arrays. */
2674 return gfc_build_addr_expr (NULL_TREE
, descriptor
);
2678 return gfc_conv_descriptor_data_get (descriptor
);
2682 /* Return an expression for the base offset of an array. */
2685 gfc_conv_array_offset (tree descriptor
)
2689 type
= TREE_TYPE (descriptor
);
2690 if (GFC_ARRAY_TYPE_P (type
))
2691 return GFC_TYPE_ARRAY_OFFSET (type
);
2693 return gfc_conv_descriptor_offset_get (descriptor
);
2697 /* Get an expression for the array stride. */
2700 gfc_conv_array_stride (tree descriptor
, int dim
)
2705 type
= TREE_TYPE (descriptor
);
2707 /* For descriptorless arrays use the array size. */
2708 tmp
= GFC_TYPE_ARRAY_STRIDE (type
, dim
);
2709 if (tmp
!= NULL_TREE
)
2712 tmp
= gfc_conv_descriptor_stride_get (descriptor
, gfc_rank_cst
[dim
]);
2717 /* Like gfc_conv_array_stride, but for the lower bound. */
2720 gfc_conv_array_lbound (tree descriptor
, int dim
)
2725 type
= TREE_TYPE (descriptor
);
2727 tmp
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
2728 if (tmp
!= NULL_TREE
)
2731 tmp
= gfc_conv_descriptor_lbound_get (descriptor
, gfc_rank_cst
[dim
]);
2736 /* Like gfc_conv_array_stride, but for the upper bound. */
2739 gfc_conv_array_ubound (tree descriptor
, int dim
)
2744 type
= TREE_TYPE (descriptor
);
2746 tmp
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
2747 if (tmp
!= NULL_TREE
)
2750 /* This should only ever happen when passing an assumed shape array
2751 as an actual parameter. The value will never be used. */
2752 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor
)))
2753 return gfc_index_zero_node
;
2755 tmp
= gfc_conv_descriptor_ubound_get (descriptor
, gfc_rank_cst
[dim
]);
2760 /* Generate code to perform an array index bound check. */
2763 trans_array_bound_check (gfc_se
* se
, gfc_ss
*ss
, tree index
, int n
,
2764 locus
* where
, bool check_upper
)
2767 tree tmp_lo
, tmp_up
;
2770 const char * name
= NULL
;
2772 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
2775 descriptor
= ss
->info
->data
.array
.descriptor
;
2777 index
= gfc_evaluate_now (index
, &se
->pre
);
2779 /* We find a name for the error message. */
2780 name
= ss
->info
->expr
->symtree
->n
.sym
->name
;
2781 gcc_assert (name
!= NULL
);
2783 if (TREE_CODE (descriptor
) == VAR_DECL
)
2784 name
= IDENTIFIER_POINTER (DECL_NAME (descriptor
));
2786 /* If upper bound is present, include both bounds in the error message. */
2789 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
2790 tmp_up
= gfc_conv_array_ubound (descriptor
, n
);
2793 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
2794 "outside of expected range (%%ld:%%ld)", n
+1, name
);
2796 asprintf (&msg
, "Index '%%ld' of dimension %d "
2797 "outside of expected range (%%ld:%%ld)", n
+1);
2799 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2801 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2802 fold_convert (long_integer_type_node
, index
),
2803 fold_convert (long_integer_type_node
, tmp_lo
),
2804 fold_convert (long_integer_type_node
, tmp_up
));
2805 fault
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2807 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2808 fold_convert (long_integer_type_node
, index
),
2809 fold_convert (long_integer_type_node
, tmp_lo
),
2810 fold_convert (long_integer_type_node
, tmp_up
));
2815 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
2818 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
2819 "below lower bound of %%ld", n
+1, name
);
2821 asprintf (&msg
, "Index '%%ld' of dimension %d "
2822 "below lower bound of %%ld", n
+1);
2824 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2826 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2827 fold_convert (long_integer_type_node
, index
),
2828 fold_convert (long_integer_type_node
, tmp_lo
));
2836 /* Return the offset for an index. Performs bound checking for elemental
2837 dimensions. Single element references are processed separately.
2838 DIM is the array dimension, I is the loop dimension. */
2841 conv_array_index_offset (gfc_se
* se
, gfc_ss
* ss
, int dim
, int i
,
2842 gfc_array_ref
* ar
, tree stride
)
2844 gfc_array_info
*info
;
2849 info
= &ss
->info
->data
.array
;
2851 /* Get the index into the array for this dimension. */
2854 gcc_assert (ar
->type
!= AR_ELEMENT
);
2855 switch (ar
->dimen_type
[dim
])
2857 case DIMEN_THIS_IMAGE
:
2861 /* Elemental dimension. */
2862 gcc_assert (info
->subscript
[dim
]
2863 && info
->subscript
[dim
]->info
->type
== GFC_SS_SCALAR
);
2864 /* We've already translated this value outside the loop. */
2865 index
= info
->subscript
[dim
]->info
->data
.scalar
.value
;
2867 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
2868 ar
->as
->type
!= AS_ASSUMED_SIZE
2869 || dim
< ar
->dimen
- 1);
2873 gcc_assert (info
&& se
->loop
);
2874 gcc_assert (info
->subscript
[dim
]
2875 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
2876 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
2878 /* Get a zero-based index into the vector. */
2879 index
= fold_build2_loc (input_location
, MINUS_EXPR
,
2880 gfc_array_index_type
,
2881 se
->loop
->loopvar
[i
], se
->loop
->from
[i
]);
2883 /* Multiply the index by the stride. */
2884 index
= fold_build2_loc (input_location
, MULT_EXPR
,
2885 gfc_array_index_type
,
2886 index
, gfc_conv_array_stride (desc
, 0));
2888 /* Read the vector to get an index into info->descriptor. */
2889 data
= build_fold_indirect_ref_loc (input_location
,
2890 gfc_conv_array_data (desc
));
2891 index
= gfc_build_array_ref (data
, index
, NULL
);
2892 index
= gfc_evaluate_now (index
, &se
->pre
);
2893 index
= fold_convert (gfc_array_index_type
, index
);
2895 /* Do any bounds checking on the final info->descriptor index. */
2896 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
2897 ar
->as
->type
!= AS_ASSUMED_SIZE
2898 || dim
< ar
->dimen
- 1);
2902 /* Scalarized dimension. */
2903 gcc_assert (info
&& se
->loop
);
2905 /* Multiply the loop variable by the stride and delta. */
2906 index
= se
->loop
->loopvar
[i
];
2907 if (!integer_onep (info
->stride
[dim
]))
2908 index
= fold_build2_loc (input_location
, MULT_EXPR
,
2909 gfc_array_index_type
, index
,
2911 if (!integer_zerop (info
->delta
[dim
]))
2912 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
2913 gfc_array_index_type
, index
,
2923 /* Temporary array or derived type component. */
2924 gcc_assert (se
->loop
);
2925 index
= se
->loop
->loopvar
[se
->loop
->order
[i
]];
2927 /* Pointer functions can have stride[0] different from unity.
2928 Use the stride returned by the function call and stored in
2929 the descriptor for the temporary. */
2930 if (se
->ss
&& se
->ss
->info
->type
== GFC_SS_FUNCTION
2931 && se
->ss
->info
->expr
2932 && se
->ss
->info
->expr
->symtree
2933 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
2934 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
->attr
.pointer
)
2935 stride
= gfc_conv_descriptor_stride_get (info
->descriptor
,
2938 if (!integer_zerop (info
->delta
[dim
]))
2939 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
2940 gfc_array_index_type
, index
, info
->delta
[dim
]);
2943 /* Multiply by the stride. */
2944 if (!integer_onep (stride
))
2945 index
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
2952 /* Build a scalarized array reference using the vptr 'size'. */
2955 build_class_array_ref (gfc_se
*se
, tree base
, tree index
)
2962 gfc_expr
*expr
= se
->ss
->info
->expr
;
2967 if (expr
== NULL
|| expr
->ts
.type
!= BT_CLASS
)
2970 if (expr
->symtree
&& expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
2971 ts
= &expr
->symtree
->n
.sym
->ts
;
2976 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2978 if (ref
->type
== REF_COMPONENT
2979 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
2980 && ref
->next
&& ref
->next
->type
== REF_COMPONENT
2981 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0
2983 && ref
->next
->next
->type
== REF_ARRAY
2984 && ref
->next
->next
->u
.ar
.type
!= AR_ELEMENT
)
2986 ts
= &ref
->u
.c
.component
->ts
;
2995 if (class_ref
== NULL
)
2996 decl
= expr
->symtree
->n
.sym
->backend_decl
;
2999 /* Remove everything after the last class reference, convert the
3000 expression and then recover its tailend once more. */
3002 ref
= class_ref
->next
;
3003 class_ref
->next
= NULL
;
3004 gfc_init_se (&tmpse
, NULL
);
3005 gfc_conv_expr (&tmpse
, expr
);
3007 class_ref
->next
= ref
;
3010 size
= gfc_vtable_size_get (decl
);
3012 /* Build the address of the element. */
3013 type
= TREE_TYPE (TREE_TYPE (base
));
3014 size
= fold_convert (TREE_TYPE (index
), size
);
3015 offset
= fold_build2_loc (input_location
, MULT_EXPR
,
3016 gfc_array_index_type
,
3018 tmp
= gfc_build_addr_expr (pvoid_type_node
, base
);
3019 tmp
= fold_build_pointer_plus_loc (input_location
, tmp
, offset
);
3020 tmp
= fold_convert (build_pointer_type (type
), tmp
);
3022 /* Return the element in the se expression. */
3023 se
->expr
= build_fold_indirect_ref_loc (input_location
, tmp
);
3028 /* Build a scalarized reference to an array. */
3031 gfc_conv_scalarized_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
3033 gfc_array_info
*info
;
3034 tree decl
= NULL_TREE
;
3042 expr
= ss
->info
->expr
;
3043 info
= &ss
->info
->data
.array
;
3045 n
= se
->loop
->order
[0];
3049 index
= conv_array_index_offset (se
, ss
, ss
->dim
[n
], n
, ar
, info
->stride0
);
3050 /* Add the offset for this dimension to the stored offset for all other
3052 if (!integer_zerop (info
->offset
))
3053 index
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3054 index
, info
->offset
);
3056 if (expr
&& is_subref_array (expr
))
3057 decl
= expr
->symtree
->n
.sym
->backend_decl
;
3059 tmp
= build_fold_indirect_ref_loc (input_location
, info
->data
);
3061 /* Use the vptr 'size' field to access a class the element of a class
3063 if (build_class_array_ref (se
, tmp
, index
))
3066 se
->expr
= gfc_build_array_ref (tmp
, index
, decl
);
3070 /* Translate access of temporary array. */
3073 gfc_conv_tmp_array_ref (gfc_se
* se
)
3075 se
->string_length
= se
->ss
->info
->string_length
;
3076 gfc_conv_scalarized_array_ref (se
, NULL
);
3077 gfc_advance_se_ss_chain (se
);
3080 /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
3083 add_to_offset (tree
*cst_offset
, tree
*offset
, tree t
)
3085 if (TREE_CODE (t
) == INTEGER_CST
)
3086 *cst_offset
= int_const_binop (PLUS_EXPR
, *cst_offset
, t
);
3089 if (!integer_zerop (*offset
))
3090 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3091 gfc_array_index_type
, *offset
, t
);
3099 build_array_ref (tree desc
, tree offset
, tree decl
)
3104 /* Class container types do not always have the GFC_CLASS_TYPE_P
3105 but the canonical type does. */
3106 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
3107 && TREE_CODE (desc
) == COMPONENT_REF
)
3109 type
= TREE_TYPE (TREE_OPERAND (desc
, 0));
3110 if (TYPE_CANONICAL (type
)
3111 && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type
)))
3112 type
= TYPE_CANONICAL (type
);
3117 /* Class array references need special treatment because the assigned
3118 type size needs to be used to point to the element. */
3119 if (type
&& GFC_CLASS_TYPE_P (type
))
3121 type
= gfc_get_element_type (TREE_TYPE (desc
));
3122 tmp
= TREE_OPERAND (desc
, 0);
3123 tmp
= gfc_get_class_array_ref (offset
, tmp
);
3124 tmp
= fold_convert (build_pointer_type (type
), tmp
);
3125 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3129 tmp
= gfc_conv_array_data (desc
);
3130 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3131 tmp
= gfc_build_array_ref (tmp
, offset
, decl
);
3136 /* Build an array reference. se->expr already holds the array descriptor.
3137 This should be either a variable, indirect variable reference or component
3138 reference. For arrays which do not have a descriptor, se->expr will be
3140 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
3143 gfc_conv_array_ref (gfc_se
* se
, gfc_array_ref
* ar
, gfc_symbol
* sym
,
3147 tree offset
, cst_offset
;
3155 gcc_assert (ar
->codimen
);
3157 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
->expr
)))
3158 se
->expr
= build_fold_indirect_ref (gfc_conv_array_data (se
->expr
));
3161 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se
->expr
))
3162 && TREE_CODE (TREE_TYPE (se
->expr
)) == POINTER_TYPE
)
3163 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3165 /* Use the actual tree type and not the wrapped coarray. */
3166 if (!se
->want_pointer
)
3167 se
->expr
= fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se
->expr
)),
3174 /* Handle scalarized references separately. */
3175 if (ar
->type
!= AR_ELEMENT
)
3177 gfc_conv_scalarized_array_ref (se
, ar
);
3178 gfc_advance_se_ss_chain (se
);
3182 cst_offset
= offset
= gfc_index_zero_node
;
3183 add_to_offset (&cst_offset
, &offset
, gfc_conv_array_offset (se
->expr
));
3185 /* Calculate the offsets from all the dimensions. Make sure to associate
3186 the final offset so that we form a chain of loop invariant summands. */
3187 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
3189 /* Calculate the index for this dimension. */
3190 gfc_init_se (&indexse
, se
);
3191 gfc_conv_expr_type (&indexse
, ar
->start
[n
], gfc_array_index_type
);
3192 gfc_add_block_to_block (&se
->pre
, &indexse
.pre
);
3194 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3196 /* Check array bounds. */
3200 /* Evaluate the indexse.expr only once. */
3201 indexse
.expr
= save_expr (indexse
.expr
);
3204 tmp
= gfc_conv_array_lbound (se
->expr
, n
);
3205 if (sym
->attr
.temporary
)
3207 gfc_init_se (&tmpse
, se
);
3208 gfc_conv_expr_type (&tmpse
, ar
->as
->lower
[n
],
3209 gfc_array_index_type
);
3210 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3214 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
3216 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
3217 "below lower bound of %%ld", n
+1, sym
->name
);
3218 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3219 fold_convert (long_integer_type_node
,
3221 fold_convert (long_integer_type_node
, tmp
));
3224 /* Upper bound, but not for the last dimension of assumed-size
3226 if (n
< ar
->dimen
- 1 || ar
->as
->type
!= AS_ASSUMED_SIZE
)
3228 tmp
= gfc_conv_array_ubound (se
->expr
, n
);
3229 if (sym
->attr
.temporary
)
3231 gfc_init_se (&tmpse
, se
);
3232 gfc_conv_expr_type (&tmpse
, ar
->as
->upper
[n
],
3233 gfc_array_index_type
);
3234 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3238 cond
= fold_build2_loc (input_location
, GT_EXPR
,
3239 boolean_type_node
, indexse
.expr
, tmp
);
3240 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
3241 "above upper bound of %%ld", n
+1, sym
->name
);
3242 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3243 fold_convert (long_integer_type_node
,
3245 fold_convert (long_integer_type_node
, tmp
));
3250 /* Multiply the index by the stride. */
3251 stride
= gfc_conv_array_stride (se
->expr
, n
);
3252 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3253 indexse
.expr
, stride
);
3255 /* And add it to the total. */
3256 add_to_offset (&cst_offset
, &offset
, tmp
);
3259 if (!integer_zerop (cst_offset
))
3260 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3261 gfc_array_index_type
, offset
, cst_offset
);
3263 se
->expr
= build_array_ref (se
->expr
, offset
, sym
->backend_decl
);
3267 /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
3268 LOOP_DIM dimension (if any) to array's offset. */
3271 add_array_offset (stmtblock_t
*pblock
, gfc_loopinfo
*loop
, gfc_ss
*ss
,
3272 gfc_array_ref
*ar
, int array_dim
, int loop_dim
)
3275 gfc_array_info
*info
;
3278 info
= &ss
->info
->data
.array
;
3280 gfc_init_se (&se
, NULL
);
3282 se
.expr
= info
->descriptor
;
3283 stride
= gfc_conv_array_stride (info
->descriptor
, array_dim
);
3284 index
= conv_array_index_offset (&se
, ss
, array_dim
, loop_dim
, ar
, stride
);
3285 gfc_add_block_to_block (pblock
, &se
.pre
);
3287 info
->offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3288 gfc_array_index_type
,
3289 info
->offset
, index
);
3290 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
3294 /* Generate the code to be executed immediately before entering a
3295 scalarization loop. */
3298 gfc_trans_preloop_setup (gfc_loopinfo
* loop
, int dim
, int flag
,
3299 stmtblock_t
* pblock
)
3302 gfc_ss_info
*ss_info
;
3303 gfc_array_info
*info
;
3304 gfc_ss_type ss_type
;
3306 gfc_loopinfo
*ploop
;
3310 /* This code will be executed before entering the scalarization loop
3311 for this dimension. */
3312 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3316 if ((ss_info
->useflags
& flag
) == 0)
3319 ss_type
= ss_info
->type
;
3320 if (ss_type
!= GFC_SS_SECTION
3321 && ss_type
!= GFC_SS_FUNCTION
3322 && ss_type
!= GFC_SS_CONSTRUCTOR
3323 && ss_type
!= GFC_SS_COMPONENT
)
3326 info
= &ss_info
->data
.array
;
3328 gcc_assert (dim
< ss
->dimen
);
3329 gcc_assert (ss
->dimen
== loop
->dimen
);
3332 ar
= &info
->ref
->u
.ar
;
3336 if (dim
== loop
->dimen
- 1 && loop
->parent
!= NULL
)
3338 /* If we are in the outermost dimension of this loop, the previous
3339 dimension shall be in the parent loop. */
3340 gcc_assert (ss
->parent
!= NULL
);
3343 ploop
= loop
->parent
;
3345 /* ss and ss->parent are about the same array. */
3346 gcc_assert (ss_info
== pss
->info
);
3354 if (dim
== loop
->dimen
- 1)
3359 /* For the time being, there is no loop reordering. */
3360 gcc_assert (i
== ploop
->order
[i
]);
3361 i
= ploop
->order
[i
];
3363 if (dim
== loop
->dimen
- 1 && loop
->parent
== NULL
)
3365 stride
= gfc_conv_array_stride (info
->descriptor
,
3366 innermost_ss (ss
)->dim
[i
]);
3368 /* Calculate the stride of the innermost loop. Hopefully this will
3369 allow the backend optimizers to do their stuff more effectively.
3371 info
->stride0
= gfc_evaluate_now (stride
, pblock
);
3373 /* For the outermost loop calculate the offset due to any
3374 elemental dimensions. It will have been initialized with the
3375 base offset of the array. */
3378 for (i
= 0; i
< ar
->dimen
; i
++)
3380 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
3383 add_array_offset (pblock
, loop
, ss
, ar
, i
, /* unused */ -1);
3388 /* Add the offset for the previous loop dimension. */
3389 add_array_offset (pblock
, ploop
, ss
, ar
, pss
->dim
[i
], i
);
3391 /* Remember this offset for the second loop. */
3392 if (dim
== loop
->temp_dim
- 1 && loop
->parent
== NULL
)
3393 info
->saved_offset
= info
->offset
;
3398 /* Start a scalarized expression. Creates a scope and declares loop
3402 gfc_start_scalarized_body (gfc_loopinfo
* loop
, stmtblock_t
* pbody
)
3408 gcc_assert (!loop
->array_parameter
);
3410 for (dim
= loop
->dimen
- 1; dim
>= 0; dim
--)
3412 n
= loop
->order
[dim
];
3414 gfc_start_block (&loop
->code
[n
]);
3416 /* Create the loop variable. */
3417 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "S");
3419 if (dim
< loop
->temp_dim
)
3423 /* Calculate values that will be constant within this loop. */
3424 gfc_trans_preloop_setup (loop
, dim
, flags
, &loop
->code
[n
]);
3426 gfc_start_block (pbody
);
3430 /* Generates the actual loop code for a scalarization loop. */
3433 gfc_trans_scalarized_loop_end (gfc_loopinfo
* loop
, int n
,
3434 stmtblock_t
* pbody
)
3445 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
))
3446 == (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
)
3447 && n
== loop
->dimen
- 1)
3449 /* We create an OMP_FOR construct for the outermost scalarized loop. */
3450 init
= make_tree_vec (1);
3451 cond
= make_tree_vec (1);
3452 incr
= make_tree_vec (1);
3454 /* Cycle statement is implemented with a goto. Exit statement must not
3455 be present for this loop. */
3456 exit_label
= gfc_build_label_decl (NULL_TREE
);
3457 TREE_USED (exit_label
) = 1;
3459 /* Label for cycle statements (if needed). */
3460 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3461 gfc_add_expr_to_block (pbody
, tmp
);
3463 stmt
= make_node (OMP_FOR
);
3465 TREE_TYPE (stmt
) = void_type_node
;
3466 OMP_FOR_BODY (stmt
) = loopbody
= gfc_finish_block (pbody
);
3468 OMP_FOR_CLAUSES (stmt
) = build_omp_clause (input_location
,
3469 OMP_CLAUSE_SCHEDULE
);
3470 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt
))
3471 = OMP_CLAUSE_SCHEDULE_STATIC
;
3472 if (ompws_flags
& OMPWS_NOWAIT
)
3473 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt
))
3474 = build_omp_clause (input_location
, OMP_CLAUSE_NOWAIT
);
3476 /* Initialize the loopvar. */
3477 TREE_VEC_ELT (init
, 0) = build2_v (MODIFY_EXPR
, loop
->loopvar
[n
],
3479 OMP_FOR_INIT (stmt
) = init
;
3480 /* The exit condition. */
3481 TREE_VEC_ELT (cond
, 0) = build2_loc (input_location
, LE_EXPR
,
3483 loop
->loopvar
[n
], loop
->to
[n
]);
3484 SET_EXPR_LOCATION (TREE_VEC_ELT (cond
, 0), input_location
);
3485 OMP_FOR_COND (stmt
) = cond
;
3486 /* Increment the loopvar. */
3487 tmp
= build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3488 loop
->loopvar
[n
], gfc_index_one_node
);
3489 TREE_VEC_ELT (incr
, 0) = fold_build2_loc (input_location
, MODIFY_EXPR
,
3490 void_type_node
, loop
->loopvar
[n
], tmp
);
3491 OMP_FOR_INCR (stmt
) = incr
;
3493 ompws_flags
&= ~OMPWS_CURR_SINGLEUNIT
;
3494 gfc_add_expr_to_block (&loop
->code
[n
], stmt
);
3498 bool reverse_loop
= (loop
->reverse
[n
] == GFC_REVERSE_SET
)
3499 && (loop
->temp_ss
== NULL
);
3501 loopbody
= gfc_finish_block (pbody
);
3505 tmp
= loop
->from
[n
];
3506 loop
->from
[n
] = loop
->to
[n
];
3510 /* Initialize the loopvar. */
3511 if (loop
->loopvar
[n
] != loop
->from
[n
])
3512 gfc_add_modify (&loop
->code
[n
], loop
->loopvar
[n
], loop
->from
[n
]);
3514 exit_label
= gfc_build_label_decl (NULL_TREE
);
3516 /* Generate the loop body. */
3517 gfc_init_block (&block
);
3519 /* The exit condition. */
3520 cond
= fold_build2_loc (input_location
, reverse_loop
? LT_EXPR
: GT_EXPR
,
3521 boolean_type_node
, loop
->loopvar
[n
], loop
->to
[n
]);
3522 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3523 TREE_USED (exit_label
) = 1;
3524 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3525 gfc_add_expr_to_block (&block
, tmp
);
3527 /* The main body. */
3528 gfc_add_expr_to_block (&block
, loopbody
);
3530 /* Increment the loopvar. */
3531 tmp
= fold_build2_loc (input_location
,
3532 reverse_loop
? MINUS_EXPR
: PLUS_EXPR
,
3533 gfc_array_index_type
, loop
->loopvar
[n
],
3534 gfc_index_one_node
);
3536 gfc_add_modify (&block
, loop
->loopvar
[n
], tmp
);
3538 /* Build the loop. */
3539 tmp
= gfc_finish_block (&block
);
3540 tmp
= build1_v (LOOP_EXPR
, tmp
);
3541 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
3543 /* Add the exit label. */
3544 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3545 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
3551 /* Finishes and generates the loops for a scalarized expression. */
3554 gfc_trans_scalarizing_loops (gfc_loopinfo
* loop
, stmtblock_t
* body
)
3559 stmtblock_t
*pblock
;
3563 /* Generate the loops. */
3564 for (dim
= 0; dim
< loop
->dimen
; dim
++)
3566 n
= loop
->order
[dim
];
3567 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
3568 loop
->loopvar
[n
] = NULL_TREE
;
3569 pblock
= &loop
->code
[n
];
3572 tmp
= gfc_finish_block (pblock
);
3573 gfc_add_expr_to_block (&loop
->pre
, tmp
);
3575 /* Clear all the used flags. */
3576 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3577 if (ss
->parent
== NULL
)
3578 ss
->info
->useflags
= 0;
3582 /* Finish the main body of a scalarized expression, and start the secondary
3586 gfc_trans_scalarized_loop_boundary (gfc_loopinfo
* loop
, stmtblock_t
* body
)
3590 stmtblock_t
*pblock
;
3594 /* We finish as many loops as are used by the temporary. */
3595 for (dim
= 0; dim
< loop
->temp_dim
- 1; dim
++)
3597 n
= loop
->order
[dim
];
3598 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
3599 loop
->loopvar
[n
] = NULL_TREE
;
3600 pblock
= &loop
->code
[n
];
3603 /* We don't want to finish the outermost loop entirely. */
3604 n
= loop
->order
[loop
->temp_dim
- 1];
3605 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
3607 /* Restore the initial offsets. */
3608 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3610 gfc_ss_type ss_type
;
3611 gfc_ss_info
*ss_info
;
3615 if ((ss_info
->useflags
& 2) == 0)
3618 ss_type
= ss_info
->type
;
3619 if (ss_type
!= GFC_SS_SECTION
3620 && ss_type
!= GFC_SS_FUNCTION
3621 && ss_type
!= GFC_SS_CONSTRUCTOR
3622 && ss_type
!= GFC_SS_COMPONENT
)
3625 ss_info
->data
.array
.offset
= ss_info
->data
.array
.saved_offset
;
3628 /* Restart all the inner loops we just finished. */
3629 for (dim
= loop
->temp_dim
- 2; dim
>= 0; dim
--)
3631 n
= loop
->order
[dim
];
3633 gfc_start_block (&loop
->code
[n
]);
3635 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "Q");
3637 gfc_trans_preloop_setup (loop
, dim
, 2, &loop
->code
[n
]);
3640 /* Start a block for the secondary copying code. */
3641 gfc_start_block (body
);
3645 /* Precalculate (either lower or upper) bound of an array section.
3646 BLOCK: Block in which the (pre)calculation code will go.
3647 BOUNDS[DIM]: Where the bound value will be stored once evaluated.
3648 VALUES[DIM]: Specified bound (NULL <=> unspecified).
3649 DESC: Array descriptor from which the bound will be picked if unspecified
3650 (either lower or upper bound according to LBOUND). */
3653 evaluate_bound (stmtblock_t
*block
, tree
*bounds
, gfc_expr
** values
,
3654 tree desc
, int dim
, bool lbound
)
3657 gfc_expr
* input_val
= values
[dim
];
3658 tree
*output
= &bounds
[dim
];
3663 /* Specified section bound. */
3664 gfc_init_se (&se
, NULL
);
3665 gfc_conv_expr_type (&se
, input_val
, gfc_array_index_type
);
3666 gfc_add_block_to_block (block
, &se
.pre
);
3671 /* No specific bound specified so use the bound of the array. */
3672 *output
= lbound
? gfc_conv_array_lbound (desc
, dim
) :
3673 gfc_conv_array_ubound (desc
, dim
);
3675 *output
= gfc_evaluate_now (*output
, block
);
3679 /* Calculate the lower bound of an array section. */
3682 gfc_conv_section_startstride (gfc_loopinfo
* loop
, gfc_ss
* ss
, int dim
)
3684 gfc_expr
*stride
= NULL
;
3687 gfc_array_info
*info
;
3690 gcc_assert (ss
->info
->type
== GFC_SS_SECTION
);
3692 info
= &ss
->info
->data
.array
;
3693 ar
= &info
->ref
->u
.ar
;
3695 if (ar
->dimen_type
[dim
] == DIMEN_VECTOR
)
3697 /* We use a zero-based index to access the vector. */
3698 info
->start
[dim
] = gfc_index_zero_node
;
3699 info
->end
[dim
] = NULL
;
3700 info
->stride
[dim
] = gfc_index_one_node
;
3704 gcc_assert (ar
->dimen_type
[dim
] == DIMEN_RANGE
3705 || ar
->dimen_type
[dim
] == DIMEN_THIS_IMAGE
);
3706 desc
= info
->descriptor
;
3707 stride
= ar
->stride
[dim
];
3709 /* Calculate the start of the range. For vector subscripts this will
3710 be the range of the vector. */
3711 evaluate_bound (&loop
->pre
, info
->start
, ar
->start
, desc
, dim
, true);
3713 /* Similarly calculate the end. Although this is not used in the
3714 scalarizer, it is needed when checking bounds and where the end
3715 is an expression with side-effects. */
3716 evaluate_bound (&loop
->pre
, info
->end
, ar
->end
, desc
, dim
, false);
3718 /* Calculate the stride. */
3720 info
->stride
[dim
] = gfc_index_one_node
;
3723 gfc_init_se (&se
, NULL
);
3724 gfc_conv_expr_type (&se
, stride
, gfc_array_index_type
);
3725 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
3726 info
->stride
[dim
] = gfc_evaluate_now (se
.expr
, &loop
->pre
);
3731 /* Calculates the range start and stride for a SS chain. Also gets the
3732 descriptor and data pointer. The range of vector subscripts is the size
3733 of the vector. Array bounds are also checked. */
3736 gfc_conv_ss_startstride (gfc_loopinfo
* loop
)
3744 /* Determine the rank of the loop. */
3745 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3747 switch (ss
->info
->type
)
3749 case GFC_SS_SECTION
:
3750 case GFC_SS_CONSTRUCTOR
:
3751 case GFC_SS_FUNCTION
:
3752 case GFC_SS_COMPONENT
:
3753 loop
->dimen
= ss
->dimen
;
3756 /* As usual, lbound and ubound are exceptions!. */
3757 case GFC_SS_INTRINSIC
:
3758 switch (ss
->info
->expr
->value
.function
.isym
->id
)
3760 case GFC_ISYM_LBOUND
:
3761 case GFC_ISYM_UBOUND
:
3762 case GFC_ISYM_LCOBOUND
:
3763 case GFC_ISYM_UCOBOUND
:
3764 case GFC_ISYM_THIS_IMAGE
:
3765 loop
->dimen
= ss
->dimen
;
3777 /* We should have determined the rank of the expression by now. If
3778 not, that's bad news. */
3782 /* Loop over all the SS in the chain. */
3783 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3785 gfc_ss_info
*ss_info
;
3786 gfc_array_info
*info
;
3790 expr
= ss_info
->expr
;
3791 info
= &ss_info
->data
.array
;
3793 if (expr
&& expr
->shape
&& !info
->shape
)
3794 info
->shape
= expr
->shape
;
3796 switch (ss_info
->type
)
3798 case GFC_SS_SECTION
:
3799 /* Get the descriptor for the array. If it is a cross loops array,
3800 we got the descriptor already in the outermost loop. */
3801 if (ss
->parent
== NULL
)
3802 gfc_conv_ss_descriptor (&loop
->pre
, ss
, !loop
->array_parameter
);
3804 for (n
= 0; n
< ss
->dimen
; n
++)
3805 gfc_conv_section_startstride (loop
, ss
, ss
->dim
[n
]);
3808 case GFC_SS_INTRINSIC
:
3809 switch (expr
->value
.function
.isym
->id
)
3811 /* Fall through to supply start and stride. */
3812 case GFC_ISYM_LBOUND
:
3813 case GFC_ISYM_UBOUND
:
3817 /* This is the variant without DIM=... */
3818 gcc_assert (expr
->value
.function
.actual
->next
->expr
== NULL
);
3820 arg
= expr
->value
.function
.actual
->expr
;
3821 if (arg
->rank
== -1)
3826 /* The rank (hence the return value's shape) is unknown,
3827 we have to retrieve it. */
3828 gfc_init_se (&se
, NULL
);
3829 se
.descriptor_only
= 1;
3830 gfc_conv_expr (&se
, arg
);
3831 /* This is a bare variable, so there is no preliminary
3833 gcc_assert (se
.pre
.head
== NULL_TREE
3834 && se
.post
.head
== NULL_TREE
);
3835 rank
= gfc_conv_descriptor_rank (se
.expr
);
3836 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3837 gfc_array_index_type
,
3838 fold_convert (gfc_array_index_type
,
3840 gfc_index_one_node
);
3841 info
->end
[0] = gfc_evaluate_now (tmp
, &loop
->pre
);
3842 info
->start
[0] = gfc_index_zero_node
;
3843 info
->stride
[0] = gfc_index_one_node
;
3846 /* Otherwise fall through GFC_SS_FUNCTION. */
3848 case GFC_ISYM_LCOBOUND
:
3849 case GFC_ISYM_UCOBOUND
:
3850 case GFC_ISYM_THIS_IMAGE
:
3857 case GFC_SS_CONSTRUCTOR
:
3858 case GFC_SS_FUNCTION
:
3859 for (n
= 0; n
< ss
->dimen
; n
++)
3861 int dim
= ss
->dim
[n
];
3863 info
->start
[dim
] = gfc_index_zero_node
;
3864 info
->end
[dim
] = gfc_index_zero_node
;
3865 info
->stride
[dim
] = gfc_index_one_node
;
3874 /* The rest is just runtime bound checking. */
3875 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3878 tree lbound
, ubound
;
3880 tree size
[GFC_MAX_DIMENSIONS
];
3881 tree stride_pos
, stride_neg
, non_zerosized
, tmp2
, tmp3
;
3882 gfc_array_info
*info
;
3886 gfc_start_block (&block
);
3888 for (n
= 0; n
< loop
->dimen
; n
++)
3889 size
[n
] = NULL_TREE
;
3891 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3894 gfc_ss_info
*ss_info
;
3897 const char *expr_name
;
3900 if (ss_info
->type
!= GFC_SS_SECTION
)
3903 /* Catch allocatable lhs in f2003. */
3904 if (gfc_option
.flag_realloc_lhs
&& ss
->is_alloc_lhs
)
3907 expr
= ss_info
->expr
;
3908 expr_loc
= &expr
->where
;
3909 expr_name
= expr
->symtree
->name
;
3911 gfc_start_block (&inner
);
3913 /* TODO: range checking for mapped dimensions. */
3914 info
= &ss_info
->data
.array
;
3916 /* This code only checks ranges. Elemental and vector
3917 dimensions are checked later. */
3918 for (n
= 0; n
< loop
->dimen
; n
++)
3923 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
3926 if (dim
== info
->ref
->u
.ar
.dimen
- 1
3927 && info
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
3928 check_upper
= false;
3932 /* Zero stride is not allowed. */
3933 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
3934 info
->stride
[dim
], gfc_index_zero_node
);
3935 asprintf (&msg
, "Zero stride is not allowed, for dimension %d "
3936 "of array '%s'", dim
+ 1, expr_name
);
3937 gfc_trans_runtime_check (true, false, tmp
, &inner
,
3941 desc
= info
->descriptor
;
3943 /* This is the run-time equivalent of resolve.c's
3944 check_dimension(). The logical is more readable there
3945 than it is here, with all the trees. */
3946 lbound
= gfc_conv_array_lbound (desc
, dim
);
3947 end
= info
->end
[dim
];
3949 ubound
= gfc_conv_array_ubound (desc
, dim
);
3953 /* non_zerosized is true when the selected range is not
3955 stride_pos
= fold_build2_loc (input_location
, GT_EXPR
,
3956 boolean_type_node
, info
->stride
[dim
],
3957 gfc_index_zero_node
);
3958 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
3959 info
->start
[dim
], end
);
3960 stride_pos
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3961 boolean_type_node
, stride_pos
, tmp
);
3963 stride_neg
= fold_build2_loc (input_location
, LT_EXPR
,
3965 info
->stride
[dim
], gfc_index_zero_node
);
3966 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
3967 info
->start
[dim
], end
);
3968 stride_neg
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3971 non_zerosized
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
3973 stride_pos
, stride_neg
);
3975 /* Check the start of the range against the lower and upper
3976 bounds of the array, if the range is not empty.
3977 If upper bound is present, include both bounds in the
3981 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
3983 info
->start
[dim
], lbound
);
3984 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3986 non_zerosized
, tmp
);
3987 tmp2
= fold_build2_loc (input_location
, GT_EXPR
,
3989 info
->start
[dim
], ubound
);
3990 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3992 non_zerosized
, tmp2
);
3993 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
3994 "outside of expected range (%%ld:%%ld)",
3995 dim
+ 1, expr_name
);
3996 gfc_trans_runtime_check (true, false, tmp
, &inner
,
3998 fold_convert (long_integer_type_node
, info
->start
[dim
]),
3999 fold_convert (long_integer_type_node
, lbound
),
4000 fold_convert (long_integer_type_node
, ubound
));
4001 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4003 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4004 fold_convert (long_integer_type_node
, lbound
),
4005 fold_convert (long_integer_type_node
, ubound
));
4010 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
4012 info
->start
[dim
], lbound
);
4013 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4014 boolean_type_node
, non_zerosized
, tmp
);
4015 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
4016 "below lower bound of %%ld",
4017 dim
+ 1, expr_name
);
4018 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4020 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4021 fold_convert (long_integer_type_node
, lbound
));
4025 /* Compute the last element of the range, which is not
4026 necessarily "end" (think 0:5:3, which doesn't contain 5)
4027 and check it against both lower and upper bounds. */
4029 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4030 gfc_array_index_type
, end
,
4032 tmp
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
,
4033 gfc_array_index_type
, tmp
,
4035 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4036 gfc_array_index_type
, end
, tmp
);
4037 tmp2
= fold_build2_loc (input_location
, LT_EXPR
,
4038 boolean_type_node
, tmp
, lbound
);
4039 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4040 boolean_type_node
, non_zerosized
, tmp2
);
4043 tmp3
= fold_build2_loc (input_location
, GT_EXPR
,
4044 boolean_type_node
, tmp
, ubound
);
4045 tmp3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4046 boolean_type_node
, non_zerosized
, tmp3
);
4047 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
4048 "outside of expected range (%%ld:%%ld)",
4049 dim
+ 1, expr_name
);
4050 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4052 fold_convert (long_integer_type_node
, tmp
),
4053 fold_convert (long_integer_type_node
, ubound
),
4054 fold_convert (long_integer_type_node
, lbound
));
4055 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4057 fold_convert (long_integer_type_node
, tmp
),
4058 fold_convert (long_integer_type_node
, ubound
),
4059 fold_convert (long_integer_type_node
, lbound
));
4064 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
4065 "below lower bound of %%ld",
4066 dim
+ 1, expr_name
);
4067 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4069 fold_convert (long_integer_type_node
, tmp
),
4070 fold_convert (long_integer_type_node
, lbound
));
4074 /* Check the section sizes match. */
4075 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4076 gfc_array_index_type
, end
,
4078 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
4079 gfc_array_index_type
, tmp
,
4081 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4082 gfc_array_index_type
,
4083 gfc_index_one_node
, tmp
);
4084 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
4085 gfc_array_index_type
, tmp
,
4086 build_int_cst (gfc_array_index_type
, 0));
4087 /* We remember the size of the first section, and check all the
4088 others against this. */
4091 tmp3
= fold_build2_loc (input_location
, NE_EXPR
,
4092 boolean_type_node
, tmp
, size
[n
]);
4093 asprintf (&msg
, "Array bound mismatch for dimension %d "
4094 "of array '%s' (%%ld/%%ld)",
4095 dim
+ 1, expr_name
);
4097 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4099 fold_convert (long_integer_type_node
, tmp
),
4100 fold_convert (long_integer_type_node
, size
[n
]));
4105 size
[n
] = gfc_evaluate_now (tmp
, &inner
);
4108 tmp
= gfc_finish_block (&inner
);
4110 /* For optional arguments, only check bounds if the argument is
4112 if (expr
->symtree
->n
.sym
->attr
.optional
4113 || expr
->symtree
->n
.sym
->attr
.not_always_present
)
4114 tmp
= build3_v (COND_EXPR
,
4115 gfc_conv_expr_present (expr
->symtree
->n
.sym
),
4116 tmp
, build_empty_stmt (input_location
));
4118 gfc_add_expr_to_block (&block
, tmp
);
4122 tmp
= gfc_finish_block (&block
);
4123 gfc_add_expr_to_block (&loop
->pre
, tmp
);
4126 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4127 gfc_conv_ss_startstride (loop
);
4130 /* Return true if both symbols could refer to the same data object. Does
4131 not take account of aliasing due to equivalence statements. */
4134 symbols_could_alias (gfc_symbol
*lsym
, gfc_symbol
*rsym
, bool lsym_pointer
,
4135 bool lsym_target
, bool rsym_pointer
, bool rsym_target
)
4137 /* Aliasing isn't possible if the symbols have different base types. */
4138 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
4141 /* Pointers can point to other pointers and target objects. */
4143 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4144 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4147 /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
4148 and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
4150 if (lsym_target
&& rsym_target
4151 && ((lsym
->attr
.dummy
&& !lsym
->attr
.contiguous
4152 && (!lsym
->attr
.dimension
|| lsym
->as
->type
== AS_ASSUMED_SHAPE
))
4153 || (rsym
->attr
.dummy
&& !rsym
->attr
.contiguous
4154 && (!rsym
->attr
.dimension
4155 || rsym
->as
->type
== AS_ASSUMED_SHAPE
))))
4162 /* Return true if the two SS could be aliased, i.e. both point to the same data
4164 /* TODO: resolve aliases based on frontend expressions. */
4167 gfc_could_be_alias (gfc_ss
* lss
, gfc_ss
* rss
)
4171 gfc_expr
*lexpr
, *rexpr
;
4174 bool lsym_pointer
, lsym_target
, rsym_pointer
, rsym_target
;
4176 lexpr
= lss
->info
->expr
;
4177 rexpr
= rss
->info
->expr
;
4179 lsym
= lexpr
->symtree
->n
.sym
;
4180 rsym
= rexpr
->symtree
->n
.sym
;
4182 lsym_pointer
= lsym
->attr
.pointer
;
4183 lsym_target
= lsym
->attr
.target
;
4184 rsym_pointer
= rsym
->attr
.pointer
;
4185 rsym_target
= rsym
->attr
.target
;
4187 if (symbols_could_alias (lsym
, rsym
, lsym_pointer
, lsym_target
,
4188 rsym_pointer
, rsym_target
))
4191 if (rsym
->ts
.type
!= BT_DERIVED
&& rsym
->ts
.type
!= BT_CLASS
4192 && lsym
->ts
.type
!= BT_DERIVED
&& lsym
->ts
.type
!= BT_CLASS
)
4195 /* For derived types we must check all the component types. We can ignore
4196 array references as these will have the same base type as the previous
4198 for (lref
= lexpr
->ref
; lref
!= lss
->info
->data
.array
.ref
; lref
= lref
->next
)
4200 if (lref
->type
!= REF_COMPONENT
)
4203 lsym_pointer
= lsym_pointer
|| lref
->u
.c
.sym
->attr
.pointer
;
4204 lsym_target
= lsym_target
|| lref
->u
.c
.sym
->attr
.target
;
4206 if (symbols_could_alias (lref
->u
.c
.sym
, rsym
, lsym_pointer
, lsym_target
,
4207 rsym_pointer
, rsym_target
))
4210 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4211 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4213 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4218 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
;
4221 if (rref
->type
!= REF_COMPONENT
)
4224 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4225 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4227 if (symbols_could_alias (lref
->u
.c
.sym
, rref
->u
.c
.sym
,
4228 lsym_pointer
, lsym_target
,
4229 rsym_pointer
, rsym_target
))
4232 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4233 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4235 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4236 &rref
->u
.c
.sym
->ts
))
4238 if (gfc_compare_types (&lref
->u
.c
.sym
->ts
,
4239 &rref
->u
.c
.component
->ts
))
4241 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4242 &rref
->u
.c
.component
->ts
))
4248 lsym_pointer
= lsym
->attr
.pointer
;
4249 lsym_target
= lsym
->attr
.target
;
4250 lsym_pointer
= lsym
->attr
.pointer
;
4251 lsym_target
= lsym
->attr
.target
;
4253 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
; rref
= rref
->next
)
4255 if (rref
->type
!= REF_COMPONENT
)
4258 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4259 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4261 if (symbols_could_alias (rref
->u
.c
.sym
, lsym
,
4262 lsym_pointer
, lsym_target
,
4263 rsym_pointer
, rsym_target
))
4266 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4267 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4269 if (gfc_compare_types (&lsym
->ts
, &rref
->u
.c
.component
->ts
))
4278 /* Resolve array data dependencies. Creates a temporary if required. */
4279 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
4283 gfc_conv_resolve_dependencies (gfc_loopinfo
* loop
, gfc_ss
* dest
,
4289 gfc_expr
*dest_expr
;
4294 loop
->temp_ss
= NULL
;
4295 dest_expr
= dest
->info
->expr
;
4297 for (ss
= rss
; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
4299 if (ss
->info
->type
!= GFC_SS_SECTION
)
4302 ss_expr
= ss
->info
->expr
;
4304 if (dest_expr
->symtree
->n
.sym
!= ss_expr
->symtree
->n
.sym
)
4306 if (gfc_could_be_alias (dest
, ss
)
4307 || gfc_are_equivalenced_arrays (dest_expr
, ss_expr
))
4315 lref
= dest_expr
->ref
;
4316 rref
= ss_expr
->ref
;
4318 nDepend
= gfc_dep_resolver (lref
, rref
, &loop
->reverse
[0]);
4323 for (i
= 0; i
< dest
->dimen
; i
++)
4324 for (j
= 0; j
< ss
->dimen
; j
++)
4326 && dest
->dim
[i
] == ss
->dim
[j
])
4328 /* If we don't access array elements in the same order,
4329 there is a dependency. */
4334 /* TODO : loop shifting. */
4337 /* Mark the dimensions for LOOP SHIFTING */
4338 for (n
= 0; n
< loop
->dimen
; n
++)
4340 int dim
= dest
->data
.info
.dim
[n
];
4342 if (lref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
4344 else if (! gfc_is_same_range (&lref
->u
.ar
,
4345 &rref
->u
.ar
, dim
, 0))
4349 /* Put all the dimensions with dependencies in the
4352 for (n
= 0; n
< loop
->dimen
; n
++)
4354 gcc_assert (loop
->order
[n
] == n
);
4356 loop
->order
[dim
++] = n
;
4358 for (n
= 0; n
< loop
->dimen
; n
++)
4361 loop
->order
[dim
++] = n
;
4364 gcc_assert (dim
== loop
->dimen
);
4375 tree base_type
= gfc_typenode_for_spec (&dest_expr
->ts
);
4376 if (GFC_ARRAY_TYPE_P (base_type
)
4377 || GFC_DESCRIPTOR_TYPE_P (base_type
))
4378 base_type
= gfc_get_element_type (base_type
);
4379 loop
->temp_ss
= gfc_get_temp_ss (base_type
, dest
->info
->string_length
,
4381 gfc_add_ss_to_loop (loop
, loop
->temp_ss
);
4384 loop
->temp_ss
= NULL
;
4388 /* Browse through each array's information from the scalarizer and set the loop
4389 bounds according to the "best" one (per dimension), i.e. the one which
4390 provides the most information (constant bounds, shape, etc.). */
4393 set_loop_bounds (gfc_loopinfo
*loop
)
4395 int n
, dim
, spec_dim
;
4396 gfc_array_info
*info
;
4397 gfc_array_info
*specinfo
;
4401 bool dynamic
[GFC_MAX_DIMENSIONS
];
4404 bool nonoptional_arr
;
4406 loopspec
= loop
->specloop
;
4409 for (n
= 0; n
< loop
->dimen
; n
++)
4414 /* If there are both optional and nonoptional array arguments, scalarize
4415 over the nonoptional; otherwise, it does not matter as then all
4416 (optional) arrays have to be present per F2008, 125.2.12p3(6). */
4418 nonoptional_arr
= false;
4420 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4421 if (ss
->info
->type
!= GFC_SS_SCALAR
&& ss
->info
->type
!= GFC_SS_TEMP
4422 && ss
->info
->type
!= GFC_SS_REFERENCE
&& !ss
->info
->can_be_null_ref
)
4423 nonoptional_arr
= true;
4425 /* We use one SS term, and use that to determine the bounds of the
4426 loop for this dimension. We try to pick the simplest term. */
4427 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4429 gfc_ss_type ss_type
;
4431 ss_type
= ss
->info
->type
;
4432 if (ss_type
== GFC_SS_SCALAR
4433 || ss_type
== GFC_SS_TEMP
4434 || ss_type
== GFC_SS_REFERENCE
4435 || (ss
->info
->can_be_null_ref
&& nonoptional_arr
))
4438 info
= &ss
->info
->data
.array
;
4441 if (loopspec
[n
] != NULL
)
4443 specinfo
= &loopspec
[n
]->info
->data
.array
;
4444 spec_dim
= loopspec
[n
]->dim
[n
];
4448 /* Silence uninitialized warnings. */
4455 gcc_assert (info
->shape
[dim
]);
4456 /* The frontend has worked out the size for us. */
4459 || !integer_zerop (specinfo
->start
[spec_dim
]))
4460 /* Prefer zero-based descriptors if possible. */
4465 if (ss_type
== GFC_SS_CONSTRUCTOR
)
4467 gfc_constructor_base base
;
4468 /* An unknown size constructor will always be rank one.
4469 Higher rank constructors will either have known shape,
4470 or still be wrapped in a call to reshape. */
4471 gcc_assert (loop
->dimen
== 1);
4473 /* Always prefer to use the constructor bounds if the size
4474 can be determined at compile time. Prefer not to otherwise,
4475 since the general case involves realloc, and it's better to
4476 avoid that overhead if possible. */
4477 base
= ss
->info
->expr
->value
.constructor
;
4478 dynamic
[n
] = gfc_get_array_constructor_size (&i
, base
);
4479 if (!dynamic
[n
] || !loopspec
[n
])
4484 /* Avoid using an allocatable lhs in an assignment, since
4485 there might be a reallocation coming. */
4486 if (loopspec
[n
] && ss
->is_alloc_lhs
)
4491 /* Criteria for choosing a loop specifier (most important first):
4492 doesn't need realloc
4498 else if (loopspec
[n
]->info
->type
== GFC_SS_CONSTRUCTOR
&& dynamic
[n
])
4500 else if (integer_onep (info
->stride
[dim
])
4501 && !integer_onep (specinfo
->stride
[spec_dim
]))
4503 else if (INTEGER_CST_P (info
->stride
[dim
])
4504 && !INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
4506 else if (INTEGER_CST_P (info
->start
[dim
])
4507 && !INTEGER_CST_P (specinfo
->start
[spec_dim
])
4508 && integer_onep (info
->stride
[dim
])
4509 == integer_onep (specinfo
->stride
[spec_dim
])
4510 && INTEGER_CST_P (info
->stride
[dim
])
4511 == INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
4513 /* We don't work out the upper bound.
4514 else if (INTEGER_CST_P (info->finish[n])
4515 && ! INTEGER_CST_P (specinfo->finish[n]))
4516 loopspec[n] = ss; */
4519 /* We should have found the scalarization loop specifier. If not,
4521 gcc_assert (loopspec
[n
]);
4523 info
= &loopspec
[n
]->info
->data
.array
;
4524 dim
= loopspec
[n
]->dim
[n
];
4526 /* Set the extents of this range. */
4527 cshape
= info
->shape
;
4528 if (cshape
&& INTEGER_CST_P (info
->start
[dim
])
4529 && INTEGER_CST_P (info
->stride
[dim
]))
4531 loop
->from
[n
] = info
->start
[dim
];
4532 mpz_set (i
, cshape
[get_array_ref_dim_for_loop_dim (loopspec
[n
], n
)]);
4533 mpz_sub_ui (i
, i
, 1);
4534 /* To = from + (size - 1) * stride. */
4535 tmp
= gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
4536 if (!integer_onep (info
->stride
[dim
]))
4537 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
4538 gfc_array_index_type
, tmp
,
4540 loop
->to
[n
] = fold_build2_loc (input_location
, PLUS_EXPR
,
4541 gfc_array_index_type
,
4542 loop
->from
[n
], tmp
);
4546 loop
->from
[n
] = info
->start
[dim
];
4547 switch (loopspec
[n
]->info
->type
)
4549 case GFC_SS_CONSTRUCTOR
:
4550 /* The upper bound is calculated when we expand the
4552 gcc_assert (loop
->to
[n
] == NULL_TREE
);
4555 case GFC_SS_SECTION
:
4556 /* Use the end expression if it exists and is not constant,
4557 so that it is only evaluated once. */
4558 loop
->to
[n
] = info
->end
[dim
];
4561 case GFC_SS_FUNCTION
:
4562 /* The loop bound will be set when we generate the call. */
4563 gcc_assert (loop
->to
[n
] == NULL_TREE
);
4566 case GFC_SS_INTRINSIC
:
4568 gfc_expr
*expr
= loopspec
[n
]->info
->expr
;
4570 /* The {l,u}bound of an assumed rank. */
4571 gcc_assert ((expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
4572 || expr
->value
.function
.isym
->id
== GFC_ISYM_UBOUND
)
4573 && expr
->value
.function
.actual
->next
->expr
== NULL
4574 && expr
->value
.function
.actual
->expr
->rank
== -1);
4576 loop
->to
[n
] = info
->end
[dim
];
4585 /* Transform everything so we have a simple incrementing variable. */
4586 if (integer_onep (info
->stride
[dim
]))
4587 info
->delta
[dim
] = gfc_index_zero_node
;
4590 /* Set the delta for this section. */
4591 info
->delta
[dim
] = gfc_evaluate_now (loop
->from
[n
], &loop
->pre
);
4592 /* Number of iterations is (end - start + step) / step.
4593 with start = 0, this simplifies to
4595 for (i = 0; i<=last; i++){...}; */
4596 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4597 gfc_array_index_type
, loop
->to
[n
],
4599 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
4600 gfc_array_index_type
, tmp
, info
->stride
[dim
]);
4601 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
4602 tmp
, build_int_cst (gfc_array_index_type
, -1));
4603 loop
->to
[n
] = gfc_evaluate_now (tmp
, &loop
->pre
);
4604 /* Make the loop variable start at 0. */
4605 loop
->from
[n
] = gfc_index_zero_node
;
4610 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4611 set_loop_bounds (loop
);
4615 /* Initialize the scalarization loop. Creates the loop variables. Determines
4616 the range of the loop variables. Creates a temporary if required.
4617 Also generates code for scalar expressions which have been
4618 moved outside the loop. */
4621 gfc_conv_loop_setup (gfc_loopinfo
* loop
, locus
* where
)
4626 set_loop_bounds (loop
);
4628 /* Add all the scalar code that can be taken out of the loops.
4629 This may include calculating the loop bounds, so do it before
4630 allocating the temporary. */
4631 gfc_add_loop_ss_code (loop
, loop
->ss
, false, where
);
4633 tmp_ss
= loop
->temp_ss
;
4634 /* If we want a temporary then create it. */
4637 gfc_ss_info
*tmp_ss_info
;
4639 tmp_ss_info
= tmp_ss
->info
;
4640 gcc_assert (tmp_ss_info
->type
== GFC_SS_TEMP
);
4641 gcc_assert (loop
->parent
== NULL
);
4643 /* Make absolutely sure that this is a complete type. */
4644 if (tmp_ss_info
->string_length
)
4645 tmp_ss_info
->data
.temp
.type
4646 = gfc_get_character_type_len_for_eltype
4647 (TREE_TYPE (tmp_ss_info
->data
.temp
.type
),
4648 tmp_ss_info
->string_length
);
4650 tmp
= tmp_ss_info
->data
.temp
.type
;
4651 memset (&tmp_ss_info
->data
.array
, 0, sizeof (gfc_array_info
));
4652 tmp_ss_info
->type
= GFC_SS_SECTION
;
4654 gcc_assert (tmp_ss
->dimen
!= 0);
4656 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, tmp_ss
, tmp
,
4657 NULL_TREE
, false, true, false, where
);
4660 /* For array parameters we don't have loop variables, so don't calculate the
4662 if (!loop
->array_parameter
)
4663 gfc_set_delta (loop
);
4667 /* Calculates how to transform from loop variables to array indices for each
4668 array: once loop bounds are chosen, sets the difference (DELTA field) between
4669 loop bounds and array reference bounds, for each array info. */
4672 gfc_set_delta (gfc_loopinfo
*loop
)
4674 gfc_ss
*ss
, **loopspec
;
4675 gfc_array_info
*info
;
4679 loopspec
= loop
->specloop
;
4681 /* Calculate the translation from loop variables to array indices. */
4682 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4684 gfc_ss_type ss_type
;
4686 ss_type
= ss
->info
->type
;
4687 if (ss_type
!= GFC_SS_SECTION
4688 && ss_type
!= GFC_SS_COMPONENT
4689 && ss_type
!= GFC_SS_CONSTRUCTOR
)
4692 info
= &ss
->info
->data
.array
;
4694 for (n
= 0; n
< ss
->dimen
; n
++)
4696 /* If we are specifying the range the delta is already set. */
4697 if (loopspec
[n
] != ss
)
4701 /* Calculate the offset relative to the loop variable.
4702 First multiply by the stride. */
4703 tmp
= loop
->from
[n
];
4704 if (!integer_onep (info
->stride
[dim
]))
4705 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
4706 gfc_array_index_type
,
4707 tmp
, info
->stride
[dim
]);
4709 /* Then subtract this from our starting value. */
4710 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4711 gfc_array_index_type
,
4712 info
->start
[dim
], tmp
);
4714 info
->delta
[dim
] = gfc_evaluate_now (tmp
, &loop
->pre
);
4719 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4720 gfc_set_delta (loop
);
4724 /* Calculate the size of a given array dimension from the bounds. This
4725 is simply (ubound - lbound + 1) if this expression is positive
4726 or 0 if it is negative (pick either one if it is zero). Optionally
4727 (if or_expr is present) OR the (expression != 0) condition to it. */
4730 gfc_conv_array_extent_dim (tree lbound
, tree ubound
, tree
* or_expr
)
4735 /* Calculate (ubound - lbound + 1). */
4736 res
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4738 res
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
, res
,
4739 gfc_index_one_node
);
4741 /* Check whether the size for this dimension is negative. */
4742 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, res
,
4743 gfc_index_zero_node
);
4744 res
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
, cond
,
4745 gfc_index_zero_node
, res
);
4747 /* Build OR expression. */
4749 *or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
4750 boolean_type_node
, *or_expr
, cond
);
4756 /* For an array descriptor, get the total number of elements. This is just
4757 the product of the extents along from_dim to to_dim. */
4760 gfc_conv_descriptor_size_1 (tree desc
, int from_dim
, int to_dim
)
4765 res
= gfc_index_one_node
;
4767 for (dim
= from_dim
; dim
< to_dim
; ++dim
)
4773 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]);
4774 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]);
4776 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
4777 res
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4785 /* Full size of an array. */
4788 gfc_conv_descriptor_size (tree desc
, int rank
)
4790 return gfc_conv_descriptor_size_1 (desc
, 0, rank
);
4794 /* Size of a coarray for all dimensions but the last. */
4797 gfc_conv_descriptor_cosize (tree desc
, int rank
, int corank
)
4799 return gfc_conv_descriptor_size_1 (desc
, rank
, rank
+ corank
- 1);
4803 /* Fills in an array descriptor, and returns the size of the array.
4804 The size will be a simple_val, ie a variable or a constant. Also
4805 calculates the offset of the base. The pointer argument overflow,
4806 which should be of integer type, will increase in value if overflow
4807 occurs during the size calculation. Returns the size of the array.
4811 for (n = 0; n < rank; n++)
4813 a.lbound[n] = specified_lower_bound;
4814 offset = offset + a.lbond[n] * stride;
4816 a.ubound[n] = specified_upper_bound;
4817 a.stride[n] = stride;
4818 size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
4819 overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
4820 stride = stride * size;
4822 for (n = rank; n < rank+corank; n++)
4823 (Set lcobound/ucobound as above.)
4824 element_size = sizeof (array element);
4827 stride = (size_t) stride;
4828 overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
4829 stride = stride * element_size;
4835 gfc_array_init_size (tree descriptor
, int rank
, int corank
, tree
* poffset
,
4836 gfc_expr
** lower
, gfc_expr
** upper
, stmtblock_t
* pblock
,
4837 stmtblock_t
* descriptor_block
, tree
* overflow
,
4838 tree expr3_elem_size
, tree
*nelems
, gfc_expr
*expr3
)
4851 stmtblock_t thenblock
;
4852 stmtblock_t elseblock
;
4857 type
= TREE_TYPE (descriptor
);
4859 stride
= gfc_index_one_node
;
4860 offset
= gfc_index_zero_node
;
4862 /* Set the dtype. */
4863 tmp
= gfc_conv_descriptor_dtype (descriptor
);
4864 gfc_add_modify (descriptor_block
, tmp
, gfc_get_dtype (TREE_TYPE (descriptor
)));
4866 or_expr
= boolean_false_node
;
4868 for (n
= 0; n
< rank
; n
++)
4873 /* We have 3 possibilities for determining the size of the array:
4874 lower == NULL => lbound = 1, ubound = upper[n]
4875 upper[n] = NULL => lbound = 1, ubound = lower[n]
4876 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
4879 /* Set lower bound. */
4880 gfc_init_se (&se
, NULL
);
4882 se
.expr
= gfc_index_one_node
;
4885 gcc_assert (lower
[n
]);
4888 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
4889 gfc_add_block_to_block (pblock
, &se
.pre
);
4893 se
.expr
= gfc_index_one_node
;
4897 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
4898 gfc_rank_cst
[n
], se
.expr
);
4899 conv_lbound
= se
.expr
;
4901 /* Work out the offset for this component. */
4902 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4904 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
4905 gfc_array_index_type
, offset
, tmp
);
4907 /* Set upper bound. */
4908 gfc_init_se (&se
, NULL
);
4909 gcc_assert (ubound
);
4910 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
4911 gfc_add_block_to_block (pblock
, &se
.pre
);
4913 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
4914 gfc_rank_cst
[n
], se
.expr
);
4915 conv_ubound
= se
.expr
;
4917 /* Store the stride. */
4918 gfc_conv_descriptor_stride_set (descriptor_block
, descriptor
,
4919 gfc_rank_cst
[n
], stride
);
4921 /* Calculate size and check whether extent is negative. */
4922 size
= gfc_conv_array_extent_dim (conv_lbound
, conv_ubound
, &or_expr
);
4923 size
= gfc_evaluate_now (size
, pblock
);
4925 /* Check whether multiplying the stride by the number of
4926 elements in this dimension would overflow. We must also check
4927 whether the current dimension has zero size in order to avoid
4930 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
4931 gfc_array_index_type
,
4932 fold_convert (gfc_array_index_type
,
4933 TYPE_MAX_VALUE (gfc_array_index_type
)),
4935 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
4936 boolean_type_node
, tmp
, stride
));
4937 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
4938 integer_one_node
, integer_zero_node
);
4939 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
4940 boolean_type_node
, size
,
4941 gfc_index_zero_node
));
4942 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
4943 integer_zero_node
, tmp
);
4944 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
4946 *overflow
= gfc_evaluate_now (tmp
, pblock
);
4948 /* Multiply the stride by the number of elements in this dimension. */
4949 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
4950 gfc_array_index_type
, stride
, size
);
4951 stride
= gfc_evaluate_now (stride
, pblock
);
4954 for (n
= rank
; n
< rank
+ corank
; n
++)
4958 /* Set lower bound. */
4959 gfc_init_se (&se
, NULL
);
4960 if (lower
== NULL
|| lower
[n
] == NULL
)
4962 gcc_assert (n
== rank
+ corank
- 1);
4963 se
.expr
= gfc_index_one_node
;
4967 if (ubound
|| n
== rank
+ corank
- 1)
4969 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
4970 gfc_add_block_to_block (pblock
, &se
.pre
);
4974 se
.expr
= gfc_index_one_node
;
4978 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
4979 gfc_rank_cst
[n
], se
.expr
);
4981 if (n
< rank
+ corank
- 1)
4983 gfc_init_se (&se
, NULL
);
4984 gcc_assert (ubound
);
4985 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
4986 gfc_add_block_to_block (pblock
, &se
.pre
);
4987 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
4988 gfc_rank_cst
[n
], se
.expr
);
4992 /* The stride is the number of elements in the array, so multiply by the
4993 size of an element to get the total size. Obviously, if there is a
4994 SOURCE expression (expr3) we must use its element size. */
4995 if (expr3_elem_size
!= NULL_TREE
)
4996 tmp
= expr3_elem_size
;
4997 else if (expr3
!= NULL
)
4999 if (expr3
->ts
.type
== BT_CLASS
)
5002 gfc_expr
*sz
= gfc_copy_expr (expr3
);
5003 gfc_add_vptr_component (sz
);
5004 gfc_add_size_component (sz
);
5005 gfc_init_se (&se_sz
, NULL
);
5006 gfc_conv_expr (&se_sz
, sz
);
5012 tmp
= gfc_typenode_for_spec (&expr3
->ts
);
5013 tmp
= TYPE_SIZE_UNIT (tmp
);
5017 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
5019 /* Convert to size_t. */
5020 element_size
= fold_convert (size_type_node
, tmp
);
5023 return element_size
;
5025 *nelems
= gfc_evaluate_now (stride
, pblock
);
5026 stride
= fold_convert (size_type_node
, stride
);
5028 /* First check for overflow. Since an array of type character can
5029 have zero element_size, we must check for that before
5031 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
5033 TYPE_MAX_VALUE (size_type_node
), element_size
);
5034 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
5035 boolean_type_node
, tmp
, stride
));
5036 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5037 integer_one_node
, integer_zero_node
);
5038 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
5039 boolean_type_node
, element_size
,
5040 build_int_cst (size_type_node
, 0)));
5041 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5042 integer_zero_node
, tmp
);
5043 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
5045 *overflow
= gfc_evaluate_now (tmp
, pblock
);
5047 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5048 stride
, element_size
);
5050 if (poffset
!= NULL
)
5052 offset
= gfc_evaluate_now (offset
, pblock
);
5056 if (integer_zerop (or_expr
))
5058 if (integer_onep (or_expr
))
5059 return build_int_cst (size_type_node
, 0);
5061 var
= gfc_create_var (TREE_TYPE (size
), "size");
5062 gfc_start_block (&thenblock
);
5063 gfc_add_modify (&thenblock
, var
, build_int_cst (size_type_node
, 0));
5064 thencase
= gfc_finish_block (&thenblock
);
5066 gfc_start_block (&elseblock
);
5067 gfc_add_modify (&elseblock
, var
, size
);
5068 elsecase
= gfc_finish_block (&elseblock
);
5070 tmp
= gfc_evaluate_now (or_expr
, pblock
);
5071 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
5072 gfc_add_expr_to_block (pblock
, tmp
);
5078 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
5079 the work for an ALLOCATE statement. */
5083 gfc_array_allocate (gfc_se
* se
, gfc_expr
* expr
, tree status
, tree errmsg
,
5084 tree errlen
, tree label_finish
, tree expr3_elem_size
,
5085 tree
*nelems
, gfc_expr
*expr3
)
5089 tree offset
= NULL_TREE
;
5090 tree token
= NULL_TREE
;
5093 tree error
= NULL_TREE
;
5094 tree overflow
; /* Boolean storing whether size calculation overflows. */
5095 tree var_overflow
= NULL_TREE
;
5097 tree set_descriptor
;
5098 stmtblock_t set_descriptor_block
;
5099 stmtblock_t elseblock
;
5102 gfc_ref
*ref
, *prev_ref
= NULL
;
5103 bool allocatable
, coarray
, dimension
;
5107 /* Find the last reference in the chain. */
5108 while (ref
&& ref
->next
!= NULL
)
5110 gcc_assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
5111 || (ref
->u
.ar
.dimen
== 0 && ref
->u
.ar
.codimen
> 0));
5116 if (ref
== NULL
|| ref
->type
!= REF_ARRAY
)
5121 allocatable
= expr
->symtree
->n
.sym
->attr
.allocatable
;
5122 coarray
= expr
->symtree
->n
.sym
->attr
.codimension
;
5123 dimension
= expr
->symtree
->n
.sym
->attr
.dimension
;
5127 allocatable
= prev_ref
->u
.c
.component
->attr
.allocatable
;
5128 coarray
= prev_ref
->u
.c
.component
->attr
.codimension
;
5129 dimension
= prev_ref
->u
.c
.component
->attr
.dimension
;
5133 gcc_assert (coarray
);
5135 /* Figure out the size of the array. */
5136 switch (ref
->u
.ar
.type
)
5142 upper
= ref
->u
.ar
.start
;
5148 lower
= ref
->u
.ar
.start
;
5149 upper
= ref
->u
.ar
.end
;
5153 gcc_assert (ref
->u
.ar
.as
->type
== AS_EXPLICIT
);
5155 lower
= ref
->u
.ar
.as
->lower
;
5156 upper
= ref
->u
.ar
.as
->upper
;
5164 overflow
= integer_zero_node
;
5166 gfc_init_block (&set_descriptor_block
);
5167 size
= gfc_array_init_size (se
->expr
, ref
->u
.ar
.as
->rank
,
5168 ref
->u
.ar
.as
->corank
, &offset
, lower
, upper
,
5169 &se
->pre
, &set_descriptor_block
, &overflow
,
5170 expr3_elem_size
, nelems
, expr3
);
5175 var_overflow
= gfc_create_var (integer_type_node
, "overflow");
5176 gfc_add_modify (&se
->pre
, var_overflow
, overflow
);
5178 /* Generate the block of code handling overflow. */
5179 msg
= gfc_build_addr_expr (pchar_type_node
,
5180 gfc_build_localized_cstring_const
5181 ("Integer overflow when calculating the amount of "
5182 "memory to allocate"));
5183 error
= build_call_expr_loc (input_location
, gfor_fndecl_runtime_error
,
5187 if (status
!= NULL_TREE
)
5189 tree status_type
= TREE_TYPE (status
);
5190 stmtblock_t set_status_block
;
5192 gfc_start_block (&set_status_block
);
5193 gfc_add_modify (&set_status_block
, status
,
5194 build_int_cst (status_type
, LIBERROR_ALLOCATION
));
5195 error
= gfc_finish_block (&set_status_block
);
5198 gfc_start_block (&elseblock
);
5200 /* Allocate memory to store the data. */
5201 if (POINTER_TYPE_P (TREE_TYPE (se
->expr
)))
5202 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
5204 pointer
= gfc_conv_descriptor_data_get (se
->expr
);
5205 STRIP_NOPS (pointer
);
5207 if (coarray
&& gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
5208 token
= gfc_build_addr_expr (NULL_TREE
,
5209 gfc_conv_descriptor_token (se
->expr
));
5211 /* The allocatable variant takes the old pointer as first argument. */
5213 gfc_allocate_allocatable (&elseblock
, pointer
, size
, token
,
5214 status
, errmsg
, errlen
, label_finish
, expr
);
5216 gfc_allocate_using_malloc (&elseblock
, pointer
, size
, status
);
5220 cond
= gfc_unlikely (fold_build2_loc (input_location
, NE_EXPR
,
5221 boolean_type_node
, var_overflow
, integer_zero_node
));
5222 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
5223 error
, gfc_finish_block (&elseblock
));
5226 tmp
= gfc_finish_block (&elseblock
);
5228 gfc_add_expr_to_block (&se
->pre
, tmp
);
5230 if (expr
->ts
.type
== BT_CLASS
)
5232 tmp
= build_int_cst (unsigned_char_type_node
, 0);
5233 /* With class objects, it is best to play safe and null the
5234 memory because we cannot know if dynamic types have allocatable
5235 components or not. */
5236 tmp
= build_call_expr_loc (input_location
,
5237 builtin_decl_explicit (BUILT_IN_MEMSET
),
5238 3, pointer
, tmp
, size
);
5239 gfc_add_expr_to_block (&se
->pre
, tmp
);
5242 /* Update the array descriptors. */
5244 gfc_conv_descriptor_offset_set (&set_descriptor_block
, se
->expr
, offset
);
5246 set_descriptor
= gfc_finish_block (&set_descriptor_block
);
5247 if (status
!= NULL_TREE
)
5249 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
5250 boolean_type_node
, status
,
5251 build_int_cst (TREE_TYPE (status
), 0));
5252 gfc_add_expr_to_block (&se
->pre
,
5253 fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5254 gfc_likely (cond
), set_descriptor
,
5255 build_empty_stmt (input_location
)));
5258 gfc_add_expr_to_block (&se
->pre
, set_descriptor
);
5260 if ((expr
->ts
.type
== BT_DERIVED
)
5261 && expr
->ts
.u
.derived
->attr
.alloc_comp
)
5263 tmp
= gfc_nullify_alloc_comp (expr
->ts
.u
.derived
, se
->expr
,
5264 ref
->u
.ar
.as
->rank
);
5265 gfc_add_expr_to_block (&se
->pre
, tmp
);
5272 /* Deallocate an array variable. Also used when an allocated variable goes
5277 gfc_array_deallocate (tree descriptor
, tree pstat
, tree errmsg
, tree errlen
,
5278 tree label_finish
, gfc_expr
* expr
)
5283 bool coarray
= gfc_is_coarray (expr
);
5285 gfc_start_block (&block
);
5287 /* Get a pointer to the data. */
5288 var
= gfc_conv_descriptor_data_get (descriptor
);
5291 /* Parameter is the address of the data component. */
5292 tmp
= gfc_deallocate_with_status (coarray
? descriptor
: var
, pstat
, errmsg
,
5293 errlen
, label_finish
, false, expr
, coarray
);
5294 gfc_add_expr_to_block (&block
, tmp
);
5296 /* Zero the data pointer; only for coarrays an error can occur and then
5297 the allocation status may not be changed. */
5298 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
5299 var
, build_int_cst (TREE_TYPE (var
), 0));
5300 if (pstat
!= NULL_TREE
&& coarray
&& gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
5303 tree stat
= build_fold_indirect_ref_loc (input_location
, pstat
);
5305 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5306 stat
, build_int_cst (TREE_TYPE (stat
), 0));
5307 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5308 cond
, tmp
, build_empty_stmt (input_location
));
5311 gfc_add_expr_to_block (&block
, tmp
);
5313 return gfc_finish_block (&block
);
5317 /* Create an array constructor from an initialization expression.
5318 We assume the frontend already did any expansions and conversions. */
5321 gfc_conv_array_initializer (tree type
, gfc_expr
* expr
)
5327 unsigned HOST_WIDE_INT lo
;
5329 vec
<constructor_elt
, va_gc
> *v
= NULL
;
5331 if (expr
->expr_type
== EXPR_VARIABLE
5332 && expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
5333 && expr
->symtree
->n
.sym
->value
)
5334 expr
= expr
->symtree
->n
.sym
->value
;
5336 switch (expr
->expr_type
)
5339 case EXPR_STRUCTURE
:
5340 /* A single scalar or derived type value. Create an array with all
5341 elements equal to that value. */
5342 gfc_init_se (&se
, NULL
);
5344 if (expr
->expr_type
== EXPR_CONSTANT
)
5345 gfc_conv_constant (&se
, expr
);
5347 gfc_conv_structure (&se
, expr
, 1);
5349 tmp
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
5350 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
5351 hi
= TREE_INT_CST_HIGH (tmp
);
5352 lo
= TREE_INT_CST_LOW (tmp
);
5356 /* This will probably eat buckets of memory for large arrays. */
5357 while (hi
!= 0 || lo
!= 0)
5359 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
, se
.expr
);
5367 /* Create a vector of all the elements. */
5368 for (c
= gfc_constructor_first (expr
->value
.constructor
);
5369 c
; c
= gfc_constructor_next (c
))
5373 /* Problems occur when we get something like
5374 integer :: a(lots) = (/(i, i=1, lots)/) */
5375 gfc_fatal_error ("The number of elements in the array constructor "
5376 "at %L requires an increase of the allowed %d "
5377 "upper limit. See -fmax-array-constructor "
5378 "option", &expr
->where
,
5379 gfc_option
.flag_max_array_constructor
);
5382 if (mpz_cmp_si (c
->offset
, 0) != 0)
5383 index
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
5387 if (mpz_cmp_si (c
->repeat
, 1) > 0)
5393 mpz_add (maxval
, c
->offset
, c
->repeat
);
5394 mpz_sub_ui (maxval
, maxval
, 1);
5395 tmp2
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
5396 if (mpz_cmp_si (c
->offset
, 0) != 0)
5398 mpz_add_ui (maxval
, c
->offset
, 1);
5399 tmp1
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
5402 tmp1
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
5404 range
= fold_build2 (RANGE_EXPR
, gfc_array_index_type
, tmp1
, tmp2
);
5410 gfc_init_se (&se
, NULL
);
5411 switch (c
->expr
->expr_type
)
5414 gfc_conv_constant (&se
, c
->expr
);
5417 case EXPR_STRUCTURE
:
5418 gfc_conv_structure (&se
, c
->expr
, 1);
5422 /* Catch those occasional beasts that do not simplify
5423 for one reason or another, assuming that if they are
5424 standard defying the frontend will catch them. */
5425 gfc_conv_expr (&se
, c
->expr
);
5429 if (range
== NULL_TREE
)
5430 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
5433 if (index
!= NULL_TREE
)
5434 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
5435 CONSTRUCTOR_APPEND_ELT (v
, range
, se
.expr
);
5441 return gfc_build_null_descriptor (type
);
5447 /* Create a constructor from the list of elements. */
5448 tmp
= build_constructor (type
, v
);
5449 TREE_CONSTANT (tmp
) = 1;
5454 /* Generate code to evaluate non-constant coarray cobounds. */
5457 gfc_trans_array_cobounds (tree type
, stmtblock_t
* pblock
,
5458 const gfc_symbol
*sym
)
5468 for (dim
= as
->rank
; dim
< as
->rank
+ as
->corank
; dim
++)
5470 /* Evaluate non-constant array bound expressions. */
5471 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
5472 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
5474 gfc_init_se (&se
, NULL
);
5475 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
5476 gfc_add_block_to_block (pblock
, &se
.pre
);
5477 gfc_add_modify (pblock
, lbound
, se
.expr
);
5479 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
5480 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
5482 gfc_init_se (&se
, NULL
);
5483 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
5484 gfc_add_block_to_block (pblock
, &se
.pre
);
5485 gfc_add_modify (pblock
, ubound
, se
.expr
);
5491 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
5492 returns the size (in elements) of the array. */
5495 gfc_trans_array_bounds (tree type
, gfc_symbol
* sym
, tree
* poffset
,
5496 stmtblock_t
* pblock
)
5511 size
= gfc_index_one_node
;
5512 offset
= gfc_index_zero_node
;
5513 for (dim
= 0; dim
< as
->rank
; dim
++)
5515 /* Evaluate non-constant array bound expressions. */
5516 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
5517 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
5519 gfc_init_se (&se
, NULL
);
5520 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
5521 gfc_add_block_to_block (pblock
, &se
.pre
);
5522 gfc_add_modify (pblock
, lbound
, se
.expr
);
5524 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
5525 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
5527 gfc_init_se (&se
, NULL
);
5528 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
5529 gfc_add_block_to_block (pblock
, &se
.pre
);
5530 gfc_add_modify (pblock
, ubound
, se
.expr
);
5532 /* The offset of this dimension. offset = offset - lbound * stride. */
5533 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5535 offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5538 /* The size of this dimension, and the stride of the next. */
5539 if (dim
+ 1 < as
->rank
)
5540 stride
= GFC_TYPE_ARRAY_STRIDE (type
, dim
+ 1);
5542 stride
= GFC_TYPE_ARRAY_SIZE (type
);
5544 if (ubound
!= NULL_TREE
&& !(stride
&& INTEGER_CST_P (stride
)))
5546 /* Calculate stride = size * (ubound + 1 - lbound). */
5547 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5548 gfc_array_index_type
,
5549 gfc_index_one_node
, lbound
);
5550 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5551 gfc_array_index_type
, ubound
, tmp
);
5552 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5553 gfc_array_index_type
, size
, tmp
);
5555 gfc_add_modify (pblock
, stride
, tmp
);
5557 stride
= gfc_evaluate_now (tmp
, pblock
);
5559 /* Make sure that negative size arrays are translated
5560 to being zero size. */
5561 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
5562 stride
, gfc_index_zero_node
);
5563 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5564 gfc_array_index_type
, tmp
,
5565 stride
, gfc_index_zero_node
);
5566 gfc_add_modify (pblock
, stride
, tmp
);
5572 gfc_trans_array_cobounds (type
, pblock
, sym
);
5573 gfc_trans_vla_type_sizes (sym
, pblock
);
5580 /* Generate code to initialize/allocate an array variable. */
5583 gfc_trans_auto_array_allocation (tree decl
, gfc_symbol
* sym
,
5584 gfc_wrapped_block
* block
)
5588 tree tmp
= NULL_TREE
;
5595 gcc_assert (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
));
5597 /* Do nothing for USEd variables. */
5598 if (sym
->attr
.use_assoc
)
5601 type
= TREE_TYPE (decl
);
5602 gcc_assert (GFC_ARRAY_TYPE_P (type
));
5603 onstack
= TREE_CODE (type
) != POINTER_TYPE
;
5605 gfc_init_block (&init
);
5607 /* Evaluate character string length. */
5608 if (sym
->ts
.type
== BT_CHARACTER
5609 && onstack
&& !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
5611 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
5613 gfc_trans_vla_type_sizes (sym
, &init
);
5615 /* Emit a DECL_EXPR for this variable, which will cause the
5616 gimplifier to allocate storage, and all that good stuff. */
5617 tmp
= fold_build1_loc (input_location
, DECL_EXPR
, TREE_TYPE (decl
), decl
);
5618 gfc_add_expr_to_block (&init
, tmp
);
5623 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
5627 type
= TREE_TYPE (type
);
5629 gcc_assert (!sym
->attr
.use_assoc
);
5630 gcc_assert (!TREE_STATIC (decl
));
5631 gcc_assert (!sym
->module
);
5633 if (sym
->ts
.type
== BT_CHARACTER
5634 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
5635 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
5637 size
= gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
5639 /* Don't actually allocate space for Cray Pointees. */
5640 if (sym
->attr
.cray_pointee
)
5642 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
5643 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
5645 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
5649 if (gfc_option
.flag_stack_arrays
)
5651 gcc_assert (TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
);
5652 space
= build_decl (sym
->declared_at
.lb
->location
,
5653 VAR_DECL
, create_tmp_var_name ("A"),
5654 TREE_TYPE (TREE_TYPE (decl
)));
5655 gfc_trans_vla_type_sizes (sym
, &init
);
5659 /* The size is the number of elements in the array, so multiply by the
5660 size of an element to get the total size. */
5661 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
5662 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5663 size
, fold_convert (gfc_array_index_type
, tmp
));
5665 /* Allocate memory to hold the data. */
5666 tmp
= gfc_call_malloc (&init
, TREE_TYPE (decl
), size
);
5667 gfc_add_modify (&init
, decl
, tmp
);
5669 /* Free the temporary. */
5670 tmp
= gfc_call_free (convert (pvoid_type_node
, decl
));
5674 /* Set offset of the array. */
5675 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
5676 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
5678 /* Automatic arrays should not have initializers. */
5679 gcc_assert (!sym
->value
);
5681 inittree
= gfc_finish_block (&init
);
5688 /* Don't create new scope, emit the DECL_EXPR in exactly the scope
5689 where also space is located. */
5690 gfc_init_block (&init
);
5691 tmp
= fold_build1_loc (input_location
, DECL_EXPR
,
5692 TREE_TYPE (space
), space
);
5693 gfc_add_expr_to_block (&init
, tmp
);
5694 addr
= fold_build1_loc (sym
->declared_at
.lb
->location
,
5695 ADDR_EXPR
, TREE_TYPE (decl
), space
);
5696 gfc_add_modify (&init
, decl
, addr
);
5697 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
5700 gfc_add_init_cleanup (block
, inittree
, tmp
);
5704 /* Generate entry and exit code for g77 calling convention arrays. */
5707 gfc_trans_g77_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
5717 gfc_save_backend_locus (&loc
);
5718 gfc_set_backend_locus (&sym
->declared_at
);
5720 /* Descriptor type. */
5721 parm
= sym
->backend_decl
;
5722 type
= TREE_TYPE (parm
);
5723 gcc_assert (GFC_ARRAY_TYPE_P (type
));
5725 gfc_start_block (&init
);
5727 if (sym
->ts
.type
== BT_CHARACTER
5728 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
5729 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
5731 /* Evaluate the bounds of the array. */
5732 gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
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 /* Set the pointer itself if we aren't using the parameter directly. */
5739 if (TREE_CODE (parm
) != PARM_DECL
)
5741 tmp
= convert (TREE_TYPE (parm
), GFC_DECL_SAVED_DESCRIPTOR (parm
));
5742 gfc_add_modify (&init
, parm
, tmp
);
5744 stmt
= gfc_finish_block (&init
);
5746 gfc_restore_backend_locus (&loc
);
5748 /* Add the initialization code to the start of the function. */
5750 if (sym
->attr
.optional
|| sym
->attr
.not_always_present
)
5752 tmp
= gfc_conv_expr_present (sym
);
5753 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
5756 gfc_add_init_cleanup (block
, stmt
, NULL_TREE
);
5760 /* Modify the descriptor of an array parameter so that it has the
5761 correct lower bound. Also move the upper bound accordingly.
5762 If the array is not packed, it will be copied into a temporary.
5763 For each dimension we set the new lower and upper bounds. Then we copy the
5764 stride and calculate the offset for this dimension. We also work out
5765 what the stride of a packed array would be, and see it the two match.
5766 If the array need repacking, we set the stride to the values we just
5767 calculated, recalculate the offset and copy the array data.
5768 Code is also added to copy the data back at the end of the function.
5772 gfc_trans_dummy_array_bias (gfc_symbol
* sym
, tree tmpdesc
,
5773 gfc_wrapped_block
* block
)
5780 tree stmtInit
, stmtCleanup
;
5787 tree stride
, stride2
;
5797 /* Do nothing for pointer and allocatable arrays. */
5798 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
5801 if (sym
->attr
.dummy
&& gfc_is_nodesc_array (sym
))
5803 gfc_trans_g77_array (sym
, block
);
5807 gfc_save_backend_locus (&loc
);
5808 gfc_set_backend_locus (&sym
->declared_at
);
5810 /* Descriptor type. */
5811 type
= TREE_TYPE (tmpdesc
);
5812 gcc_assert (GFC_ARRAY_TYPE_P (type
));
5813 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
5814 dumdesc
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
5815 gfc_start_block (&init
);
5817 if (sym
->ts
.type
== BT_CHARACTER
5818 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
5819 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
5821 checkparm
= (sym
->as
->type
== AS_EXPLICIT
5822 && (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
));
5824 no_repack
= !(GFC_DECL_PACKED_ARRAY (tmpdesc
)
5825 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
));
5827 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
))
5829 /* For non-constant shape arrays we only check if the first dimension
5830 is contiguous. Repacking higher dimensions wouldn't gain us
5831 anything as we still don't know the array stride. */
5832 partial
= gfc_create_var (boolean_type_node
, "partial");
5833 TREE_USED (partial
) = 1;
5834 tmp
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
5835 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, tmp
,
5836 gfc_index_one_node
);
5837 gfc_add_modify (&init
, partial
, tmp
);
5840 partial
= NULL_TREE
;
5842 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
5843 here, however I think it does the right thing. */
5846 /* Set the first stride. */
5847 stride
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
5848 stride
= gfc_evaluate_now (stride
, &init
);
5850 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5851 stride
, gfc_index_zero_node
);
5852 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
5853 tmp
, gfc_index_one_node
, stride
);
5854 stride
= GFC_TYPE_ARRAY_STRIDE (type
, 0);
5855 gfc_add_modify (&init
, stride
, tmp
);
5857 /* Allow the user to disable array repacking. */
5858 stmt_unpacked
= NULL_TREE
;
5862 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type
, 0)));
5863 /* A library call to repack the array if necessary. */
5864 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
5865 stmt_unpacked
= build_call_expr_loc (input_location
,
5866 gfor_fndecl_in_pack
, 1, tmp
);
5868 stride
= gfc_index_one_node
;
5870 if (gfc_option
.warn_array_temp
)
5871 gfc_warning ("Creating array temporary at %L", &loc
);
5874 /* This is for the case where the array data is used directly without
5875 calling the repack function. */
5876 if (no_repack
|| partial
!= NULL_TREE
)
5877 stmt_packed
= gfc_conv_descriptor_data_get (dumdesc
);
5879 stmt_packed
= NULL_TREE
;
5881 /* Assign the data pointer. */
5882 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
5884 /* Don't repack unknown shape arrays when the first stride is 1. */
5885 tmp
= fold_build3_loc (input_location
, COND_EXPR
, TREE_TYPE (stmt_packed
),
5886 partial
, stmt_packed
, stmt_unpacked
);
5889 tmp
= stmt_packed
!= NULL_TREE
? stmt_packed
: stmt_unpacked
;
5890 gfc_add_modify (&init
, tmpdesc
, fold_convert (type
, tmp
));
5892 offset
= gfc_index_zero_node
;
5893 size
= gfc_index_one_node
;
5895 /* Evaluate the bounds of the array. */
5896 for (n
= 0; n
< sym
->as
->rank
; n
++)
5898 if (checkparm
|| !sym
->as
->upper
[n
])
5900 /* Get the bounds of the actual parameter. */
5901 dubound
= gfc_conv_descriptor_ubound_get (dumdesc
, gfc_rank_cst
[n
]);
5902 dlbound
= gfc_conv_descriptor_lbound_get (dumdesc
, gfc_rank_cst
[n
]);
5906 dubound
= NULL_TREE
;
5907 dlbound
= NULL_TREE
;
5910 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, n
);
5911 if (!INTEGER_CST_P (lbound
))
5913 gfc_init_se (&se
, NULL
);
5914 gfc_conv_expr_type (&se
, sym
->as
->lower
[n
],
5915 gfc_array_index_type
);
5916 gfc_add_block_to_block (&init
, &se
.pre
);
5917 gfc_add_modify (&init
, lbound
, se
.expr
);
5920 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, n
);
5921 /* Set the desired upper bound. */
5922 if (sym
->as
->upper
[n
])
5924 /* We know what we want the upper bound to be. */
5925 if (!INTEGER_CST_P (ubound
))
5927 gfc_init_se (&se
, NULL
);
5928 gfc_conv_expr_type (&se
, sym
->as
->upper
[n
],
5929 gfc_array_index_type
);
5930 gfc_add_block_to_block (&init
, &se
.pre
);
5931 gfc_add_modify (&init
, ubound
, se
.expr
);
5934 /* Check the sizes match. */
5937 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
5941 temp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5942 gfc_array_index_type
, ubound
, lbound
);
5943 temp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5944 gfc_array_index_type
,
5945 gfc_index_one_node
, temp
);
5946 stride2
= fold_build2_loc (input_location
, MINUS_EXPR
,
5947 gfc_array_index_type
, dubound
,
5949 stride2
= fold_build2_loc (input_location
, PLUS_EXPR
,
5950 gfc_array_index_type
,
5951 gfc_index_one_node
, stride2
);
5952 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
5953 gfc_array_index_type
, temp
, stride2
);
5954 asprintf (&msg
, "Dimension %d of array '%s' has extent "
5955 "%%ld instead of %%ld", n
+1, sym
->name
);
5957 gfc_trans_runtime_check (true, false, tmp
, &init
, &loc
, msg
,
5958 fold_convert (long_integer_type_node
, temp
),
5959 fold_convert (long_integer_type_node
, stride2
));
5966 /* For assumed shape arrays move the upper bound by the same amount
5967 as the lower bound. */
5968 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5969 gfc_array_index_type
, dubound
, dlbound
);
5970 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5971 gfc_array_index_type
, tmp
, lbound
);
5972 gfc_add_modify (&init
, ubound
, tmp
);
5974 /* The offset of this dimension. offset = offset - lbound * stride. */
5975 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5977 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
5978 gfc_array_index_type
, offset
, tmp
);
5980 /* The size of this dimension, and the stride of the next. */
5981 if (n
+ 1 < sym
->as
->rank
)
5983 stride
= GFC_TYPE_ARRAY_STRIDE (type
, n
+ 1);
5985 if (no_repack
|| partial
!= NULL_TREE
)
5987 gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[n
+1]);
5989 /* Figure out the stride if not a known constant. */
5990 if (!INTEGER_CST_P (stride
))
5993 stmt_packed
= NULL_TREE
;
5996 /* Calculate stride = size * (ubound + 1 - lbound). */
5997 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5998 gfc_array_index_type
,
5999 gfc_index_one_node
, lbound
);
6000 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6001 gfc_array_index_type
, ubound
, tmp
);
6002 size
= fold_build2_loc (input_location
, MULT_EXPR
,
6003 gfc_array_index_type
, size
, tmp
);
6007 /* Assign the stride. */
6008 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
6009 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6010 gfc_array_index_type
, partial
,
6011 stmt_unpacked
, stmt_packed
);
6013 tmp
= (stmt_packed
!= NULL_TREE
) ? stmt_packed
: stmt_unpacked
;
6014 gfc_add_modify (&init
, stride
, tmp
);
6019 stride
= GFC_TYPE_ARRAY_SIZE (type
);
6021 if (stride
&& !INTEGER_CST_P (stride
))
6023 /* Calculate size = stride * (ubound + 1 - lbound). */
6024 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6025 gfc_array_index_type
,
6026 gfc_index_one_node
, lbound
);
6027 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6028 gfc_array_index_type
,
6030 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6031 gfc_array_index_type
,
6032 GFC_TYPE_ARRAY_STRIDE (type
, n
), tmp
);
6033 gfc_add_modify (&init
, stride
, tmp
);
6038 gfc_trans_array_cobounds (type
, &init
, sym
);
6040 /* Set the offset. */
6041 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
6042 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6044 gfc_trans_vla_type_sizes (sym
, &init
);
6046 stmtInit
= gfc_finish_block (&init
);
6048 /* Only do the entry/initialization code if the arg is present. */
6049 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6050 optional_arg
= (sym
->attr
.optional
6051 || (sym
->ns
->proc_name
->attr
.entry_master
6052 && sym
->attr
.dummy
));
6055 tmp
= gfc_conv_expr_present (sym
);
6056 stmtInit
= build3_v (COND_EXPR
, tmp
, stmtInit
,
6057 build_empty_stmt (input_location
));
6062 stmtCleanup
= NULL_TREE
;
6065 stmtblock_t cleanup
;
6066 gfc_start_block (&cleanup
);
6068 if (sym
->attr
.intent
!= INTENT_IN
)
6070 /* Copy the data back. */
6071 tmp
= build_call_expr_loc (input_location
,
6072 gfor_fndecl_in_unpack
, 2, dumdesc
, tmpdesc
);
6073 gfc_add_expr_to_block (&cleanup
, tmp
);
6076 /* Free the temporary. */
6077 tmp
= gfc_call_free (tmpdesc
);
6078 gfc_add_expr_to_block (&cleanup
, tmp
);
6080 stmtCleanup
= gfc_finish_block (&cleanup
);
6082 /* Only do the cleanup if the array was repacked. */
6083 tmp
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
6084 tmp
= gfc_conv_descriptor_data_get (tmp
);
6085 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6087 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6088 build_empty_stmt (input_location
));
6092 tmp
= gfc_conv_expr_present (sym
);
6093 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6094 build_empty_stmt (input_location
));
6098 /* We don't need to free any memory allocated by internal_pack as it will
6099 be freed at the end of the function by pop_context. */
6100 gfc_add_init_cleanup (block
, stmtInit
, stmtCleanup
);
6102 gfc_restore_backend_locus (&loc
);
6106 /* Calculate the overall offset, including subreferences. */
6108 gfc_get_dataptr_offset (stmtblock_t
*block
, tree parm
, tree desc
, tree offset
,
6109 bool subref
, gfc_expr
*expr
)
6119 /* If offset is NULL and this is not a subreferenced array, there is
6121 if (offset
== NULL_TREE
)
6124 offset
= gfc_index_zero_node
;
6129 tmp
= build_array_ref (desc
, offset
, NULL
);
6131 /* Offset the data pointer for pointer assignments from arrays with
6132 subreferences; e.g. my_integer => my_type(:)%integer_component. */
6135 /* Go past the array reference. */
6136 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6137 if (ref
->type
== REF_ARRAY
&&
6138 ref
->u
.ar
.type
!= AR_ELEMENT
)
6144 /* Calculate the offset for each subsequent subreference. */
6145 for (; ref
; ref
= ref
->next
)
6150 field
= ref
->u
.c
.component
->backend_decl
;
6151 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
6152 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
6154 tmp
, field
, NULL_TREE
);
6158 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
6159 gfc_init_se (&start
, NULL
);
6160 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
6161 gfc_add_block_to_block (block
, &start
.pre
);
6162 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
6166 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
6167 && ref
->u
.ar
.type
== AR_ELEMENT
);
6169 /* TODO - Add bounds checking. */
6170 stride
= gfc_index_one_node
;
6171 index
= gfc_index_zero_node
;
6172 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
6177 /* Update the index. */
6178 gfc_init_se (&start
, NULL
);
6179 gfc_conv_expr_type (&start
, ref
->u
.ar
.start
[n
], gfc_array_index_type
);
6180 itmp
= gfc_evaluate_now (start
.expr
, block
);
6181 gfc_init_se (&start
, NULL
);
6182 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->lower
[n
], gfc_array_index_type
);
6183 jtmp
= gfc_evaluate_now (start
.expr
, block
);
6184 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6185 gfc_array_index_type
, itmp
, jtmp
);
6186 itmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6187 gfc_array_index_type
, itmp
, stride
);
6188 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
6189 gfc_array_index_type
, itmp
, index
);
6190 index
= gfc_evaluate_now (index
, block
);
6192 /* Update the stride. */
6193 gfc_init_se (&start
, NULL
);
6194 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->upper
[n
], gfc_array_index_type
);
6195 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6196 gfc_array_index_type
, start
.expr
,
6198 itmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6199 gfc_array_index_type
,
6200 gfc_index_one_node
, itmp
);
6201 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
6202 gfc_array_index_type
, stride
, itmp
);
6203 stride
= gfc_evaluate_now (stride
, block
);
6206 /* Apply the index to obtain the array element. */
6207 tmp
= gfc_build_array_ref (tmp
, index
, NULL
);
6217 /* Set the target data pointer. */
6218 offset
= gfc_build_addr_expr (gfc_array_dataptr_type (desc
), tmp
);
6219 gfc_conv_descriptor_data_set (block
, parm
, offset
);
6223 /* gfc_conv_expr_descriptor needs the string length an expression
6224 so that the size of the temporary can be obtained. This is done
6225 by adding up the string lengths of all the elements in the
6226 expression. Function with non-constant expressions have their
6227 string lengths mapped onto the actual arguments using the
6228 interface mapping machinery in trans-expr.c. */
6230 get_array_charlen (gfc_expr
*expr
, gfc_se
*se
)
6232 gfc_interface_mapping mapping
;
6233 gfc_formal_arglist
*formal
;
6234 gfc_actual_arglist
*arg
;
6237 if (expr
->ts
.u
.cl
->length
6238 && gfc_is_constant_expr (expr
->ts
.u
.cl
->length
))
6240 if (!expr
->ts
.u
.cl
->backend_decl
)
6241 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6245 switch (expr
->expr_type
)
6248 get_array_charlen (expr
->value
.op
.op1
, se
);
6250 /* For parentheses the expression ts.u.cl is identical. */
6251 if (expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
6254 expr
->ts
.u
.cl
->backend_decl
=
6255 gfc_create_var (gfc_charlen_type_node
, "sln");
6257 if (expr
->value
.op
.op2
)
6259 get_array_charlen (expr
->value
.op
.op2
, se
);
6261 gcc_assert (expr
->value
.op
.op
== INTRINSIC_CONCAT
);
6263 /* Add the string lengths and assign them to the expression
6264 string length backend declaration. */
6265 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
6266 fold_build2_loc (input_location
, PLUS_EXPR
,
6267 gfc_charlen_type_node
,
6268 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
,
6269 expr
->value
.op
.op2
->ts
.u
.cl
->backend_decl
));
6272 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
6273 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
);
6277 if (expr
->value
.function
.esym
== NULL
6278 || expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6280 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6284 /* Map expressions involving the dummy arguments onto the actual
6285 argument expressions. */
6286 gfc_init_interface_mapping (&mapping
);
6287 formal
= expr
->symtree
->n
.sym
->formal
;
6288 arg
= expr
->value
.function
.actual
;
6290 /* Set se = NULL in the calls to the interface mapping, to suppress any
6292 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
6297 gfc_add_interface_mapping (&mapping
, formal
->sym
, NULL
, arg
->expr
);
6300 gfc_init_se (&tse
, NULL
);
6302 /* Build the expression for the character length and convert it. */
6303 gfc_apply_interface_mapping (&mapping
, &tse
, expr
->ts
.u
.cl
->length
);
6305 gfc_add_block_to_block (&se
->pre
, &tse
.pre
);
6306 gfc_add_block_to_block (&se
->post
, &tse
.post
);
6307 tse
.expr
= fold_convert (gfc_charlen_type_node
, tse
.expr
);
6308 tse
.expr
= fold_build2_loc (input_location
, MAX_EXPR
,
6309 gfc_charlen_type_node
, tse
.expr
,
6310 build_int_cst (gfc_charlen_type_node
, 0));
6311 expr
->ts
.u
.cl
->backend_decl
= tse
.expr
;
6312 gfc_free_interface_mapping (&mapping
);
6316 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6322 /* Helper function to check dimensions. */
6324 transposed_dims (gfc_ss
*ss
)
6328 for (n
= 0; n
< ss
->dimen
; n
++)
6329 if (ss
->dim
[n
] != n
)
6335 /* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
6336 AR_FULL, suitable for the scalarizer. */
6339 walk_coarray (gfc_expr
*e
)
6343 gcc_assert (gfc_get_corank (e
) > 0);
6345 ss
= gfc_walk_expr (e
);
6347 /* Fix scalar coarray. */
6348 if (ss
== gfc_ss_terminator
)
6355 if (ref
->type
== REF_ARRAY
6356 && ref
->u
.ar
.codimen
> 0)
6362 gcc_assert (ref
!= NULL
);
6363 if (ref
->u
.ar
.type
== AR_ELEMENT
)
6364 ref
->u
.ar
.type
= AR_SECTION
;
6365 ss
= gfc_reverse_ss (gfc_walk_array_ref (ss
, e
, ref
));
6372 /* Convert an array for passing as an actual argument. Expressions and
6373 vector subscripts are evaluated and stored in a temporary, which is then
6374 passed. For whole arrays the descriptor is passed. For array sections
6375 a modified copy of the descriptor is passed, but using the original data.
6377 This function is also used for array pointer assignments, and there
6380 - se->want_pointer && !se->direct_byref
6381 EXPR is an actual argument. On exit, se->expr contains a
6382 pointer to the array descriptor.
6384 - !se->want_pointer && !se->direct_byref
6385 EXPR is an actual argument to an intrinsic function or the
6386 left-hand side of a pointer assignment. On exit, se->expr
6387 contains the descriptor for EXPR.
6389 - !se->want_pointer && se->direct_byref
6390 EXPR is the right-hand side of a pointer assignment and
6391 se->expr is the descriptor for the previously-evaluated
6392 left-hand side. The function creates an assignment from
6396 The se->force_tmp flag disables the non-copying descriptor optimization
6397 that is used for transpose. It may be used in cases where there is an
6398 alias between the transpose argument and another argument in the same
6402 gfc_conv_expr_descriptor (gfc_se
*se
, gfc_expr
*expr
)
6405 gfc_ss_type ss_type
;
6406 gfc_ss_info
*ss_info
;
6408 gfc_array_info
*info
;
6417 bool subref_array_target
= false;
6418 gfc_expr
*arg
, *ss_expr
;
6420 if (se
->want_coarray
)
6421 ss
= walk_coarray (expr
);
6423 ss
= gfc_walk_expr (expr
);
6425 gcc_assert (ss
!= NULL
);
6426 gcc_assert (ss
!= gfc_ss_terminator
);
6429 ss_type
= ss_info
->type
;
6430 ss_expr
= ss_info
->expr
;
6432 /* Special case: TRANSPOSE which needs no temporary. */
6433 while (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
6434 && NULL
!= (arg
= gfc_get_noncopying_intrinsic_argument (expr
)))
6436 /* This is a call to transpose which has already been handled by the
6437 scalarizer, so that we just need to get its argument's descriptor. */
6438 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
6439 expr
= expr
->value
.function
.actual
->expr
;
6442 /* Special case things we know we can pass easily. */
6443 switch (expr
->expr_type
)
6446 /* If we have a linear array section, we can pass it directly.
6447 Otherwise we need to copy it into a temporary. */
6449 gcc_assert (ss_type
== GFC_SS_SECTION
);
6450 gcc_assert (ss_expr
== expr
);
6451 info
= &ss_info
->data
.array
;
6453 /* Get the descriptor for the array. */
6454 gfc_conv_ss_descriptor (&se
->pre
, ss
, 0);
6455 desc
= info
->descriptor
;
6457 subref_array_target
= se
->direct_byref
&& is_subref_array (expr
);
6458 need_tmp
= gfc_ref_needs_temporary_p (expr
->ref
)
6459 && !subref_array_target
;
6466 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
6468 /* Create a new descriptor if the array doesn't have one. */
6471 else if (info
->ref
->u
.ar
.type
== AR_FULL
|| se
->descriptor_only
)
6473 else if (se
->direct_byref
)
6476 full
= gfc_full_array_ref_p (info
->ref
, NULL
);
6478 if (full
&& !transposed_dims (ss
))
6480 if (se
->direct_byref
&& !se
->byref_noassign
)
6482 /* Copy the descriptor for pointer assignments. */
6483 gfc_add_modify (&se
->pre
, se
->expr
, desc
);
6485 /* Add any offsets from subreferences. */
6486 gfc_get_dataptr_offset (&se
->pre
, se
->expr
, desc
, NULL_TREE
,
6487 subref_array_target
, expr
);
6489 else if (se
->want_pointer
)
6491 /* We pass full arrays directly. This means that pointers and
6492 allocatable arrays should also work. */
6493 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
6500 if (expr
->ts
.type
== BT_CHARACTER
)
6501 se
->string_length
= gfc_get_expr_charlen (expr
);
6503 gfc_free_ss_chain (ss
);
6509 /* A transformational function return value will be a temporary
6510 array descriptor. We still need to go through the scalarizer
6511 to create the descriptor. Elemental functions are handled as
6512 arbitrary expressions, i.e. copy to a temporary. */
6514 if (se
->direct_byref
)
6516 gcc_assert (ss_type
== GFC_SS_FUNCTION
&& ss_expr
== expr
);
6518 /* For pointer assignments pass the descriptor directly. */
6522 gcc_assert (se
->ss
== ss
);
6523 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
6524 gfc_conv_expr (se
, expr
);
6525 gfc_free_ss_chain (ss
);
6529 if (ss_expr
!= expr
|| ss_type
!= GFC_SS_FUNCTION
)
6531 if (ss_expr
!= expr
)
6532 /* Elemental function. */
6533 gcc_assert ((expr
->value
.function
.esym
!= NULL
6534 && expr
->value
.function
.esym
->attr
.elemental
)
6535 || (expr
->value
.function
.isym
!= NULL
6536 && expr
->value
.function
.isym
->elemental
)
6537 || gfc_inline_intrinsic_function_p (expr
));
6539 gcc_assert (ss_type
== GFC_SS_INTRINSIC
);
6542 if (expr
->ts
.type
== BT_CHARACTER
6543 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
6544 get_array_charlen (expr
, se
);
6550 /* Transformational function. */
6551 info
= &ss_info
->data
.array
;
6557 /* Constant array constructors don't need a temporary. */
6558 if (ss_type
== GFC_SS_CONSTRUCTOR
6559 && expr
->ts
.type
!= BT_CHARACTER
6560 && gfc_constant_array_constructor_p (expr
->value
.constructor
))
6563 info
= &ss_info
->data
.array
;
6573 /* Something complicated. Copy it into a temporary. */
6579 /* If we are creating a temporary, we don't need to bother about aliases
6584 gfc_init_loopinfo (&loop
);
6586 /* Associate the SS with the loop. */
6587 gfc_add_ss_to_loop (&loop
, ss
);
6589 /* Tell the scalarizer not to bother creating loop variables, etc. */
6591 loop
.array_parameter
= 1;
6593 /* The right-hand side of a pointer assignment mustn't use a temporary. */
6594 gcc_assert (!se
->direct_byref
);
6596 /* Setup the scalarizing loops and bounds. */
6597 gfc_conv_ss_startstride (&loop
);
6601 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
6602 get_array_charlen (expr
, se
);
6604 /* Tell the scalarizer to make a temporary. */
6605 loop
.temp_ss
= gfc_get_temp_ss (gfc_typenode_for_spec (&expr
->ts
),
6606 ((expr
->ts
.type
== BT_CHARACTER
)
6607 ? expr
->ts
.u
.cl
->backend_decl
6611 se
->string_length
= loop
.temp_ss
->info
->string_length
;
6612 gcc_assert (loop
.temp_ss
->dimen
== loop
.dimen
);
6613 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
6616 gfc_conv_loop_setup (&loop
, & expr
->where
);
6620 /* Copy into a temporary and pass that. We don't need to copy the data
6621 back because expressions and vector subscripts must be INTENT_IN. */
6622 /* TODO: Optimize passing function return values. */
6626 /* Start the copying loops. */
6627 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
6628 gfc_mark_ss_chain_used (ss
, 1);
6629 gfc_start_scalarized_body (&loop
, &block
);
6631 /* Copy each data element. */
6632 gfc_init_se (&lse
, NULL
);
6633 gfc_copy_loopinfo_to_se (&lse
, &loop
);
6634 gfc_init_se (&rse
, NULL
);
6635 gfc_copy_loopinfo_to_se (&rse
, &loop
);
6637 lse
.ss
= loop
.temp_ss
;
6640 gfc_conv_scalarized_array_ref (&lse
, NULL
);
6641 if (expr
->ts
.type
== BT_CHARACTER
)
6643 gfc_conv_expr (&rse
, expr
);
6644 if (POINTER_TYPE_P (TREE_TYPE (rse
.expr
)))
6645 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
6649 gfc_conv_expr_val (&rse
, expr
);
6651 gfc_add_block_to_block (&block
, &rse
.pre
);
6652 gfc_add_block_to_block (&block
, &lse
.pre
);
6654 lse
.string_length
= rse
.string_length
;
6655 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true,
6656 expr
->expr_type
== EXPR_VARIABLE
6657 || expr
->expr_type
== EXPR_ARRAY
, true);
6658 gfc_add_expr_to_block (&block
, tmp
);
6660 /* Finish the copying loops. */
6661 gfc_trans_scalarizing_loops (&loop
, &block
);
6663 desc
= loop
.temp_ss
->info
->data
.array
.descriptor
;
6665 else if (expr
->expr_type
== EXPR_FUNCTION
&& !transposed_dims (ss
))
6667 desc
= info
->descriptor
;
6668 se
->string_length
= ss_info
->string_length
;
6672 /* We pass sections without copying to a temporary. Make a new
6673 descriptor and point it at the section we want. The loop variable
6674 limits will be the limits of the section.
6675 A function may decide to repack the array to speed up access, but
6676 we're not bothered about that here. */
6677 int dim
, ndim
, codim
;
6685 ndim
= info
->ref
? info
->ref
->u
.ar
.dimen
: ss
->dimen
;
6687 if (se
->want_coarray
)
6689 gfc_array_ref
*ar
= &info
->ref
->u
.ar
;
6691 codim
= gfc_get_corank (expr
);
6692 for (n
= 0; n
< codim
- 1; n
++)
6694 /* Make sure we are not lost somehow. */
6695 gcc_assert (ar
->dimen_type
[n
+ ndim
] == DIMEN_THIS_IMAGE
);
6697 /* Make sure the call to gfc_conv_section_startstride won't
6698 generate unnecessary code to calculate stride. */
6699 gcc_assert (ar
->stride
[n
+ ndim
] == NULL
);
6701 gfc_conv_section_startstride (&loop
, ss
, n
+ ndim
);
6702 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
6703 loop
.to
[n
+ loop
.dimen
] = info
->end
[n
+ ndim
];
6706 gcc_assert (n
== codim
- 1);
6707 evaluate_bound (&loop
.pre
, info
->start
, ar
->start
,
6708 info
->descriptor
, n
+ ndim
, true);
6709 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
6714 /* Set the string_length for a character array. */
6715 if (expr
->ts
.type
== BT_CHARACTER
)
6716 se
->string_length
= gfc_get_expr_charlen (expr
);
6718 desc
= info
->descriptor
;
6719 if (se
->direct_byref
&& !se
->byref_noassign
)
6721 /* For pointer assignments we fill in the destination. */
6723 parmtype
= TREE_TYPE (parm
);
6727 /* Otherwise make a new one. */
6728 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
6729 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
, codim
,
6730 loop
.from
, loop
.to
, 0,
6731 GFC_ARRAY_UNKNOWN
, false);
6732 parm
= gfc_create_var (parmtype
, "parm");
6735 offset
= gfc_index_zero_node
;
6737 /* The following can be somewhat confusing. We have two
6738 descriptors, a new one and the original array.
6739 {parm, parmtype, dim} refer to the new one.
6740 {desc, type, n, loop} refer to the original, which maybe
6741 a descriptorless array.
6742 The bounds of the scalarization are the bounds of the section.
6743 We don't have to worry about numeric overflows when calculating
6744 the offsets because all elements are within the array data. */
6746 /* Set the dtype. */
6747 tmp
= gfc_conv_descriptor_dtype (parm
);
6748 gfc_add_modify (&loop
.pre
, tmp
, gfc_get_dtype (parmtype
));
6750 /* Set offset for assignments to pointer only to zero if it is not
6752 if (se
->direct_byref
6753 && info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
6754 base
= gfc_index_zero_node
;
6755 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
6756 base
= gfc_evaluate_now (gfc_conv_array_offset (desc
), &loop
.pre
);
6760 for (n
= 0; n
< ndim
; n
++)
6762 stride
= gfc_conv_array_stride (desc
, n
);
6764 /* Work out the offset. */
6766 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
6768 gcc_assert (info
->subscript
[n
]
6769 && info
->subscript
[n
]->info
->type
== GFC_SS_SCALAR
);
6770 start
= info
->subscript
[n
]->info
->data
.scalar
.value
;
6774 /* Evaluate and remember the start of the section. */
6775 start
= info
->start
[n
];
6776 stride
= gfc_evaluate_now (stride
, &loop
.pre
);
6779 tmp
= gfc_conv_array_lbound (desc
, n
);
6780 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
6782 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
6784 offset
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (tmp
),
6788 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
6790 /* For elemental dimensions, we only need the offset. */
6794 /* Vector subscripts need copying and are handled elsewhere. */
6796 gcc_assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
6798 /* look for the corresponding scalarizer dimension: dim. */
6799 for (dim
= 0; dim
< ndim
; dim
++)
6800 if (ss
->dim
[dim
] == n
)
6803 /* loop exited early: the DIM being looked for has been found. */
6804 gcc_assert (dim
< ndim
);
6806 /* Set the new lower bound. */
6807 from
= loop
.from
[dim
];
6810 /* If we have an array section or are assigning make sure that
6811 the lower bound is 1. References to the full
6812 array should otherwise keep the original bounds. */
6814 || info
->ref
->u
.ar
.type
!= AR_FULL
)
6815 && !integer_onep (from
))
6817 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6818 gfc_array_index_type
, gfc_index_one_node
,
6820 to
= fold_build2_loc (input_location
, PLUS_EXPR
,
6821 gfc_array_index_type
, to
, tmp
);
6822 from
= gfc_index_one_node
;
6824 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
6825 gfc_rank_cst
[dim
], from
);
6827 /* Set the new upper bound. */
6828 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
6829 gfc_rank_cst
[dim
], to
);
6831 /* Multiply the stride by the section stride to get the
6833 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
6834 gfc_array_index_type
,
6835 stride
, info
->stride
[n
]);
6837 if (se
->direct_byref
6839 && info
->ref
->u
.ar
.type
!= AR_FULL
)
6841 base
= fold_build2_loc (input_location
, MINUS_EXPR
,
6842 TREE_TYPE (base
), base
, stride
);
6844 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
6846 tmp
= gfc_conv_array_lbound (desc
, n
);
6847 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6848 TREE_TYPE (base
), tmp
, loop
.from
[dim
]);
6849 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6850 TREE_TYPE (base
), tmp
,
6851 gfc_conv_array_stride (desc
, n
));
6852 base
= fold_build2_loc (input_location
, PLUS_EXPR
,
6853 TREE_TYPE (base
), tmp
, base
);
6856 /* Store the new stride. */
6857 gfc_conv_descriptor_stride_set (&loop
.pre
, parm
,
6858 gfc_rank_cst
[dim
], stride
);
6861 for (n
= loop
.dimen
; n
< loop
.dimen
+ codim
; n
++)
6863 from
= loop
.from
[n
];
6865 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
6866 gfc_rank_cst
[n
], from
);
6867 if (n
< loop
.dimen
+ codim
- 1)
6868 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
6869 gfc_rank_cst
[n
], to
);
6872 if (se
->data_not_needed
)
6873 gfc_conv_descriptor_data_set (&loop
.pre
, parm
,
6874 gfc_index_zero_node
);
6876 /* Point the data pointer at the 1st element in the section. */
6877 gfc_get_dataptr_offset (&loop
.pre
, parm
, desc
, offset
,
6878 subref_array_target
, expr
);
6880 if ((se
->direct_byref
|| GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
6881 && !se
->data_not_needed
)
6883 /* Set the offset. */
6884 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, base
);
6888 /* Only the callee knows what the correct offset it, so just set
6890 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, gfc_index_zero_node
);
6895 if (!se
->direct_byref
|| se
->byref_noassign
)
6897 /* Get a pointer to the new descriptor. */
6898 if (se
->want_pointer
)
6899 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
6904 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
6905 gfc_add_block_to_block (&se
->post
, &loop
.post
);
6907 /* Cleanup the scalarizer. */
6908 gfc_cleanup_loop (&loop
);
6911 /* Helper function for gfc_conv_array_parameter if array size needs to be
6915 array_parameter_size (tree desc
, gfc_expr
*expr
, tree
*size
)
6918 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
6919 *size
= GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc
));
6920 else if (expr
->rank
> 1)
6921 *size
= build_call_expr_loc (input_location
,
6922 gfor_fndecl_size0
, 1,
6923 gfc_build_addr_expr (NULL
, desc
));
6926 tree ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_index_zero_node
);
6927 tree lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_index_zero_node
);
6929 *size
= fold_build2_loc (input_location
, MINUS_EXPR
,
6930 gfc_array_index_type
, ubound
, lbound
);
6931 *size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
6932 *size
, gfc_index_one_node
);
6933 *size
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
6934 *size
, gfc_index_zero_node
);
6936 elem
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
6937 *size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6938 *size
, fold_convert (gfc_array_index_type
, elem
));
6941 /* Convert an array for passing as an actual parameter. */
6942 /* TODO: Optimize passing g77 arrays. */
6945 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, bool g77
,
6946 const gfc_symbol
*fsym
, const char *proc_name
,
6951 tree tmp
= NULL_TREE
;
6953 tree parent
= DECL_CONTEXT (current_function_decl
);
6954 bool full_array_var
;
6955 bool this_array_result
;
6958 bool array_constructor
;
6959 bool good_allocatable
;
6960 bool ultimate_ptr_comp
;
6961 bool ultimate_alloc_comp
;
6966 ultimate_ptr_comp
= false;
6967 ultimate_alloc_comp
= false;
6969 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6971 if (ref
->next
== NULL
)
6974 if (ref
->type
== REF_COMPONENT
)
6976 ultimate_ptr_comp
= ref
->u
.c
.component
->attr
.pointer
;
6977 ultimate_alloc_comp
= ref
->u
.c
.component
->attr
.allocatable
;
6981 full_array_var
= false;
6984 if (expr
->expr_type
== EXPR_VARIABLE
&& ref
&& !ultimate_ptr_comp
)
6985 full_array_var
= gfc_full_array_ref_p (ref
, &contiguous
);
6987 sym
= full_array_var
? expr
->symtree
->n
.sym
: NULL
;
6989 /* The symbol should have an array specification. */
6990 gcc_assert (!sym
|| sym
->as
|| ref
->u
.ar
.as
);
6992 if (expr
->expr_type
== EXPR_ARRAY
&& expr
->ts
.type
== BT_CHARACTER
)
6994 get_array_ctor_strlen (&se
->pre
, expr
->value
.constructor
, &tmp
);
6995 expr
->ts
.u
.cl
->backend_decl
= tmp
;
6996 se
->string_length
= tmp
;
6999 /* Is this the result of the enclosing procedure? */
7000 this_array_result
= (full_array_var
&& sym
->attr
.flavor
== FL_PROCEDURE
);
7001 if (this_array_result
7002 && (sym
->backend_decl
!= current_function_decl
)
7003 && (sym
->backend_decl
!= parent
))
7004 this_array_result
= false;
7006 /* Passing address of the array if it is not pointer or assumed-shape. */
7007 if (full_array_var
&& g77
&& !this_array_result
)
7009 tmp
= gfc_get_symbol_decl (sym
);
7011 if (sym
->ts
.type
== BT_CHARACTER
)
7012 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
7014 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
7016 gfc_conv_expr_descriptor (se
, expr
);
7017 se
->expr
= gfc_conv_array_data (se
->expr
);
7021 if (!sym
->attr
.pointer
7023 && sym
->as
->type
!= AS_ASSUMED_SHAPE
7024 && sym
->as
->type
!= AS_DEFERRED
7025 && sym
->as
->type
!= AS_ASSUMED_RANK
7026 && !sym
->attr
.allocatable
)
7028 /* Some variables are declared directly, others are declared as
7029 pointers and allocated on the heap. */
7030 if (sym
->attr
.dummy
|| POINTER_TYPE_P (TREE_TYPE (tmp
)))
7033 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
7035 array_parameter_size (tmp
, expr
, size
);
7039 if (sym
->attr
.allocatable
)
7041 if (sym
->attr
.dummy
|| sym
->attr
.result
)
7043 gfc_conv_expr_descriptor (se
, expr
);
7047 array_parameter_size (tmp
, expr
, size
);
7048 se
->expr
= gfc_conv_array_data (tmp
);
7053 /* A convenient reduction in scope. */
7054 contiguous
= g77
&& !this_array_result
&& contiguous
;
7056 /* There is no need to pack and unpack the array, if it is contiguous
7057 and not a deferred- or assumed-shape array, or if it is simply
7059 no_pack
= ((sym
&& sym
->as
7060 && !sym
->attr
.pointer
7061 && sym
->as
->type
!= AS_DEFERRED
7062 && sym
->as
->type
!= AS_ASSUMED_RANK
7063 && sym
->as
->type
!= AS_ASSUMED_SHAPE
)
7065 (ref
&& ref
->u
.ar
.as
7066 && ref
->u
.ar
.as
->type
!= AS_DEFERRED
7067 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_RANK
7068 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_SHAPE
)
7070 gfc_is_simply_contiguous (expr
, false));
7072 no_pack
= contiguous
&& no_pack
;
7074 /* Array constructors are always contiguous and do not need packing. */
7075 array_constructor
= g77
&& !this_array_result
&& expr
->expr_type
== EXPR_ARRAY
;
7077 /* Same is true of contiguous sections from allocatable variables. */
7078 good_allocatable
= contiguous
7080 && expr
->symtree
->n
.sym
->attr
.allocatable
;
7082 /* Or ultimate allocatable components. */
7083 ultimate_alloc_comp
= contiguous
&& ultimate_alloc_comp
;
7085 if (no_pack
|| array_constructor
|| good_allocatable
|| ultimate_alloc_comp
)
7087 gfc_conv_expr_descriptor (se
, expr
);
7088 if (expr
->ts
.type
== BT_CHARACTER
)
7089 se
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
7091 array_parameter_size (se
->expr
, expr
, size
);
7092 se
->expr
= gfc_conv_array_data (se
->expr
);
7096 if (this_array_result
)
7098 /* Result of the enclosing function. */
7099 gfc_conv_expr_descriptor (se
, expr
);
7101 array_parameter_size (se
->expr
, expr
, size
);
7102 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7104 if (g77
&& TREE_TYPE (TREE_TYPE (se
->expr
)) != NULL_TREE
7105 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
7106 se
->expr
= gfc_conv_array_data (build_fold_indirect_ref_loc (input_location
,
7113 /* Every other type of array. */
7114 se
->want_pointer
= 1;
7115 gfc_conv_expr_descriptor (se
, expr
);
7117 array_parameter_size (build_fold_indirect_ref_loc (input_location
,
7122 /* Deallocate the allocatable components of structures that are
7124 if ((expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
)
7125 && expr
->ts
.u
.derived
->attr
.alloc_comp
7126 && expr
->expr_type
!= EXPR_VARIABLE
)
7128 tmp
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7129 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
, expr
->rank
);
7131 /* The components shall be deallocated before their containing entity. */
7132 gfc_prepend_expr_to_block (&se
->post
, tmp
);
7135 if (g77
|| (fsym
&& fsym
->attr
.contiguous
7136 && !gfc_is_simply_contiguous (expr
, false)))
7138 tree origptr
= NULL_TREE
;
7142 /* For contiguous arrays, save the original value of the descriptor. */
7145 origptr
= gfc_create_var (pvoid_type_node
, "origptr");
7146 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7147 tmp
= gfc_conv_array_data (tmp
);
7148 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7149 TREE_TYPE (origptr
), origptr
,
7150 fold_convert (TREE_TYPE (origptr
), tmp
));
7151 gfc_add_expr_to_block (&se
->pre
, tmp
);
7154 /* Repack the array. */
7155 if (gfc_option
.warn_array_temp
)
7158 gfc_warning ("Creating array temporary at %L for argument '%s'",
7159 &expr
->where
, fsym
->name
);
7161 gfc_warning ("Creating array temporary at %L", &expr
->where
);
7164 ptr
= build_call_expr_loc (input_location
,
7165 gfor_fndecl_in_pack
, 1, desc
);
7167 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7169 tmp
= gfc_conv_expr_present (sym
);
7170 ptr
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
7171 tmp
, fold_convert (TREE_TYPE (se
->expr
), ptr
),
7172 fold_convert (TREE_TYPE (se
->expr
), null_pointer_node
));
7175 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
7177 /* Use the packed data for the actual argument, except for contiguous arrays,
7178 where the descriptor's data component is set. */
7183 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7184 gfc_conv_descriptor_data_set (&se
->pre
, tmp
, ptr
);
7187 if (gfc_option
.rtcheck
& GFC_RTCHECK_ARRAY_TEMPS
)
7191 if (fsym
&& proc_name
)
7192 asprintf (&msg
, "An array temporary was created for argument "
7193 "'%s' of procedure '%s'", fsym
->name
, proc_name
);
7195 asprintf (&msg
, "An array temporary was created");
7197 tmp
= build_fold_indirect_ref_loc (input_location
,
7199 tmp
= gfc_conv_array_data (tmp
);
7200 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7201 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
7203 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7204 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7206 gfc_conv_expr_present (sym
), tmp
);
7208 gfc_trans_runtime_check (false, true, tmp
, &se
->pre
,
7213 gfc_start_block (&block
);
7215 /* Copy the data back. */
7216 if (fsym
== NULL
|| fsym
->attr
.intent
!= INTENT_IN
)
7218 tmp
= build_call_expr_loc (input_location
,
7219 gfor_fndecl_in_unpack
, 2, desc
, ptr
);
7220 gfc_add_expr_to_block (&block
, tmp
);
7223 /* Free the temporary. */
7224 tmp
= gfc_call_free (convert (pvoid_type_node
, ptr
));
7225 gfc_add_expr_to_block (&block
, tmp
);
7227 stmt
= gfc_finish_block (&block
);
7229 gfc_init_block (&block
);
7230 /* Only if it was repacked. This code needs to be executed before the
7231 loop cleanup code. */
7232 tmp
= build_fold_indirect_ref_loc (input_location
,
7234 tmp
= gfc_conv_array_data (tmp
);
7235 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7236 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
7238 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7239 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7241 gfc_conv_expr_present (sym
), tmp
);
7243 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
7245 gfc_add_expr_to_block (&block
, tmp
);
7246 gfc_add_block_to_block (&block
, &se
->post
);
7248 gfc_init_block (&se
->post
);
7250 /* Reset the descriptor pointer. */
7253 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7254 gfc_conv_descriptor_data_set (&se
->post
, tmp
, origptr
);
7257 gfc_add_block_to_block (&se
->post
, &block
);
7262 /* Generate code to deallocate an array, if it is allocated. */
7265 gfc_trans_dealloc_allocated (tree descriptor
, bool coarray
)
7271 gfc_start_block (&block
);
7273 var
= gfc_conv_descriptor_data_get (descriptor
);
7276 /* Call array_deallocate with an int * present in the second argument.
7277 Although it is ignored here, it's presence ensures that arrays that
7278 are already deallocated are ignored. */
7279 tmp
= gfc_deallocate_with_status (coarray
? descriptor
: var
, NULL_TREE
,
7280 NULL_TREE
, NULL_TREE
, NULL_TREE
, true,
7282 gfc_add_expr_to_block (&block
, tmp
);
7284 /* Zero the data pointer. */
7285 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
7286 var
, build_int_cst (TREE_TYPE (var
), 0));
7287 gfc_add_expr_to_block (&block
, tmp
);
7289 return gfc_finish_block (&block
);
7293 /* This helper function calculates the size in words of a full array. */
7296 get_full_array_size (stmtblock_t
*block
, tree decl
, int rank
)
7301 idx
= gfc_rank_cst
[rank
- 1];
7302 nelems
= gfc_conv_descriptor_ubound_get (decl
, idx
);
7303 tmp
= gfc_conv_descriptor_lbound_get (decl
, idx
);
7304 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7306 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7307 tmp
, gfc_index_one_node
);
7308 tmp
= gfc_evaluate_now (tmp
, block
);
7310 nelems
= gfc_conv_descriptor_stride_get (decl
, idx
);
7311 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7313 return gfc_evaluate_now (tmp
, block
);
7317 /* Allocate dest to the same size as src, and copy src -> dest.
7318 If no_malloc is set, only the copy is done. */
7321 duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
7331 /* If the source is null, set the destination to null. Then,
7332 allocate memory to the destination. */
7333 gfc_init_block (&block
);
7337 tmp
= null_pointer_node
;
7338 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, type
, dest
, tmp
);
7339 gfc_add_expr_to_block (&block
, tmp
);
7340 null_data
= gfc_finish_block (&block
);
7342 gfc_init_block (&block
);
7343 size
= TYPE_SIZE_UNIT (TREE_TYPE (type
));
7346 tmp
= gfc_call_malloc (&block
, type
, size
);
7347 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
7348 dest
, fold_convert (type
, tmp
));
7349 gfc_add_expr_to_block (&block
, tmp
);
7352 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
7353 tmp
= build_call_expr_loc (input_location
, tmp
, 3, dest
, src
,
7354 fold_convert (size_type_node
, size
));
7358 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
7359 null_data
= gfc_finish_block (&block
);
7361 gfc_init_block (&block
);
7362 nelems
= get_full_array_size (&block
, src
, rank
);
7363 tmp
= fold_convert (gfc_array_index_type
,
7364 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
7365 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7369 tmp
= TREE_TYPE (gfc_conv_descriptor_data_get (src
));
7370 tmp
= gfc_call_malloc (&block
, tmp
, size
);
7371 gfc_conv_descriptor_data_set (&block
, dest
, tmp
);
7374 /* We know the temporary and the value will be the same length,
7375 so can use memcpy. */
7376 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
7377 tmp
= build_call_expr_loc (input_location
,
7378 tmp
, 3, gfc_conv_descriptor_data_get (dest
),
7379 gfc_conv_descriptor_data_get (src
),
7380 fold_convert (size_type_node
, size
));
7383 gfc_add_expr_to_block (&block
, tmp
);
7384 tmp
= gfc_finish_block (&block
);
7386 /* Null the destination if the source is null; otherwise do
7387 the allocate and copy. */
7391 null_cond
= gfc_conv_descriptor_data_get (src
);
7393 null_cond
= convert (pvoid_type_node
, null_cond
);
7394 null_cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7395 null_cond
, null_pointer_node
);
7396 return build3_v (COND_EXPR
, null_cond
, tmp
, null_data
);
7400 /* Allocate dest to the same size as src, and copy data src -> dest. */
7403 gfc_duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
)
7405 return duplicate_allocatable (dest
, src
, type
, rank
, false);
7409 /* Copy data src -> dest. */
7412 gfc_copy_allocatable_data (tree dest
, tree src
, tree type
, int rank
)
7414 return duplicate_allocatable (dest
, src
, type
, rank
, true);
7418 /* Recursively traverse an object of derived type, generating code to
7419 deallocate, nullify or copy allocatable components. This is the work horse
7420 function for the functions named in this enum. */
7422 enum {DEALLOCATE_ALLOC_COMP
= 1, NULLIFY_ALLOC_COMP
, COPY_ALLOC_COMP
,
7423 COPY_ONLY_ALLOC_COMP
};
7426 structure_alloc_comps (gfc_symbol
* der_type
, tree decl
,
7427 tree dest
, int rank
, int purpose
)
7431 stmtblock_t fnblock
;
7432 stmtblock_t loopbody
;
7433 stmtblock_t tmpblock
;
7444 tree null_cond
= NULL_TREE
;
7445 bool called_dealloc_with_status
;
7447 gfc_init_block (&fnblock
);
7449 decl_type
= TREE_TYPE (decl
);
7451 if ((POINTER_TYPE_P (decl_type
) && rank
!= 0)
7452 || (TREE_CODE (decl_type
) == REFERENCE_TYPE
&& rank
== 0))
7453 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
7455 /* Just in case in gets dereferenced. */
7456 decl_type
= TREE_TYPE (decl
);
7458 /* If this an array of derived types with allocatable components
7459 build a loop and recursively call this function. */
7460 if (TREE_CODE (decl_type
) == ARRAY_TYPE
7461 || (GFC_DESCRIPTOR_TYPE_P (decl_type
) && rank
!= 0))
7463 tmp
= gfc_conv_array_data (decl
);
7464 var
= build_fold_indirect_ref_loc (input_location
,
7467 /* Get the number of elements - 1 and set the counter. */
7468 if (GFC_DESCRIPTOR_TYPE_P (decl_type
))
7470 /* Use the descriptor for an allocatable array. Since this
7471 is a full array reference, we only need the descriptor
7472 information from dimension = rank. */
7473 tmp
= get_full_array_size (&fnblock
, decl
, rank
);
7474 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7475 gfc_array_index_type
, tmp
,
7476 gfc_index_one_node
);
7478 null_cond
= gfc_conv_descriptor_data_get (decl
);
7479 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
7480 boolean_type_node
, null_cond
,
7481 build_int_cst (TREE_TYPE (null_cond
), 0));
7485 /* Otherwise use the TYPE_DOMAIN information. */
7486 tmp
= array_type_nelts (decl_type
);
7487 tmp
= fold_convert (gfc_array_index_type
, tmp
);
7490 /* Remember that this is, in fact, the no. of elements - 1. */
7491 nelems
= gfc_evaluate_now (tmp
, &fnblock
);
7492 index
= gfc_create_var (gfc_array_index_type
, "S");
7494 /* Build the body of the loop. */
7495 gfc_init_block (&loopbody
);
7497 vref
= gfc_build_array_ref (var
, index
, NULL
);
7499 if (purpose
== COPY_ALLOC_COMP
)
7501 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
7503 tmp
= gfc_duplicate_allocatable (dest
, decl
, decl_type
, rank
);
7504 gfc_add_expr_to_block (&fnblock
, tmp
);
7506 tmp
= build_fold_indirect_ref_loc (input_location
,
7507 gfc_conv_array_data (dest
));
7508 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
7509 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
, purpose
);
7511 else if (purpose
== COPY_ONLY_ALLOC_COMP
)
7513 tmp
= build_fold_indirect_ref_loc (input_location
,
7514 gfc_conv_array_data (dest
));
7515 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
7516 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
,
7520 tmp
= structure_alloc_comps (der_type
, vref
, NULL_TREE
, rank
, purpose
);
7522 gfc_add_expr_to_block (&loopbody
, tmp
);
7524 /* Build the loop and return. */
7525 gfc_init_loopinfo (&loop
);
7527 loop
.from
[0] = gfc_index_zero_node
;
7528 loop
.loopvar
[0] = index
;
7529 loop
.to
[0] = nelems
;
7530 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
7531 gfc_add_block_to_block (&fnblock
, &loop
.pre
);
7533 tmp
= gfc_finish_block (&fnblock
);
7534 if (null_cond
!= NULL_TREE
)
7535 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
7536 build_empty_stmt (input_location
));
7541 /* Otherwise, act on the components or recursively call self to
7542 act on a chain of components. */
7543 for (c
= der_type
->components
; c
; c
= c
->next
)
7545 bool cmp_has_alloc_comps
= (c
->ts
.type
== BT_DERIVED
7546 || c
->ts
.type
== BT_CLASS
)
7547 && c
->ts
.u
.derived
->attr
.alloc_comp
;
7548 cdecl = c
->backend_decl
;
7549 ctype
= TREE_TYPE (cdecl);
7553 case DEALLOCATE_ALLOC_COMP
:
7555 /* gfc_deallocate_scalar_with_status calls gfc_deallocate_alloc_comp
7556 (i.e. this function) so generate all the calls and suppress the
7557 recursion from here, if necessary. */
7558 called_dealloc_with_status
= false;
7559 gfc_init_block (&tmpblock
);
7561 if (c
->attr
.allocatable
7562 && (c
->attr
.dimension
|| c
->attr
.codimension
))
7564 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7565 decl
, cdecl, NULL_TREE
);
7566 tmp
= gfc_trans_dealloc_allocated (comp
, c
->attr
.codimension
);
7567 gfc_add_expr_to_block (&tmpblock
, tmp
);
7569 else if (c
->attr
.allocatable
)
7571 /* Allocatable scalar components. */
7572 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7573 decl
, cdecl, NULL_TREE
);
7575 tmp
= gfc_deallocate_scalar_with_status (comp
, NULL
, true, NULL
,
7577 gfc_add_expr_to_block (&tmpblock
, tmp
);
7578 called_dealloc_with_status
= true;
7580 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7581 void_type_node
, comp
,
7582 build_int_cst (TREE_TYPE (comp
), 0));
7583 gfc_add_expr_to_block (&tmpblock
, tmp
);
7585 else if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
7587 /* Allocatable CLASS components. */
7588 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7589 decl
, cdecl, NULL_TREE
);
7591 /* Add reference to '_data' component. */
7592 tmp
= CLASS_DATA (c
)->backend_decl
;
7593 comp
= fold_build3_loc (input_location
, COMPONENT_REF
,
7594 TREE_TYPE (tmp
), comp
, tmp
, NULL_TREE
);
7596 if (GFC_DESCRIPTOR_TYPE_P(TREE_TYPE (comp
)))
7597 tmp
= gfc_trans_dealloc_allocated (comp
,
7598 CLASS_DATA (c
)->attr
.codimension
);
7601 tmp
= gfc_deallocate_scalar_with_status (comp
, NULL_TREE
, true, NULL
,
7602 CLASS_DATA (c
)->ts
);
7603 gfc_add_expr_to_block (&tmpblock
, tmp
);
7604 called_dealloc_with_status
= true;
7606 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7607 void_type_node
, comp
,
7608 build_int_cst (TREE_TYPE (comp
), 0));
7610 gfc_add_expr_to_block (&tmpblock
, tmp
);
7613 if (cmp_has_alloc_comps
7615 && !called_dealloc_with_status
)
7617 /* Do not deallocate the components of ultimate pointer
7618 components or iteratively call self if call has been made
7619 to gfc_trans_dealloc_allocated */
7620 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7621 decl
, cdecl, NULL_TREE
);
7622 rank
= c
->as
? c
->as
->rank
: 0;
7623 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
7625 gfc_add_expr_to_block (&fnblock
, tmp
);
7628 /* Now add the deallocation of this component. */
7629 gfc_add_block_to_block (&fnblock
, &tmpblock
);
7632 case NULLIFY_ALLOC_COMP
:
7633 if (c
->attr
.pointer
)
7635 else if (c
->attr
.allocatable
7636 && (c
->attr
.dimension
|| c
->attr
.codimension
))
7638 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7639 decl
, cdecl, NULL_TREE
);
7640 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
7642 else if (c
->attr
.allocatable
)
7644 /* Allocatable scalar components. */
7645 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7646 decl
, cdecl, NULL_TREE
);
7647 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7648 void_type_node
, comp
,
7649 build_int_cst (TREE_TYPE (comp
), 0));
7650 gfc_add_expr_to_block (&fnblock
, tmp
);
7652 else if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
7654 /* Allocatable CLASS components. */
7655 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7656 decl
, cdecl, NULL_TREE
);
7657 /* Add reference to '_data' component. */
7658 tmp
= CLASS_DATA (c
)->backend_decl
;
7659 comp
= fold_build3_loc (input_location
, COMPONENT_REF
,
7660 TREE_TYPE (tmp
), comp
, tmp
, NULL_TREE
);
7661 if (GFC_DESCRIPTOR_TYPE_P(TREE_TYPE (comp
)))
7662 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
7665 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7666 void_type_node
, comp
,
7667 build_int_cst (TREE_TYPE (comp
), 0));
7668 gfc_add_expr_to_block (&fnblock
, tmp
);
7671 else if (cmp_has_alloc_comps
)
7673 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7674 decl
, cdecl, NULL_TREE
);
7675 rank
= c
->as
? c
->as
->rank
: 0;
7676 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
7678 gfc_add_expr_to_block (&fnblock
, tmp
);
7682 case COPY_ALLOC_COMP
:
7683 if (c
->attr
.pointer
)
7686 /* We need source and destination components. */
7687 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, decl
,
7689 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, dest
,
7691 dcmp
= fold_convert (TREE_TYPE (comp
), dcmp
);
7693 if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
7701 dst_data
= gfc_class_data_get (dcmp
);
7702 src_data
= gfc_class_data_get (comp
);
7703 size
= fold_convert (size_type_node
, gfc_vtable_size_get (comp
));
7705 if (CLASS_DATA (c
)->attr
.dimension
)
7707 nelems
= gfc_conv_descriptor_size (src_data
,
7708 CLASS_DATA (c
)->as
->rank
);
7709 src_data
= gfc_conv_descriptor_data_get (src_data
);
7710 dst_data
= gfc_conv_descriptor_data_get (dst_data
);
7713 nelems
= build_int_cst (size_type_node
, 1);
7715 gfc_init_block (&tmpblock
);
7717 /* We need to use CALLOC as _copy might try to free allocatable
7718 components of the destination. */
7719 ftn_tree
= builtin_decl_explicit (BUILT_IN_CALLOC
);
7720 tmp
= build_call_expr_loc (input_location
, ftn_tree
, 2, nelems
,
7722 gfc_add_modify (&tmpblock
, dst_data
,
7723 fold_convert (TREE_TYPE (dst_data
), tmp
));
7725 tmp
= gfc_copy_class_to_class (comp
, dcmp
, nelems
);
7726 gfc_add_expr_to_block (&tmpblock
, tmp
);
7727 tmp
= gfc_finish_block (&tmpblock
);
7729 gfc_init_block (&tmpblock
);
7730 gfc_add_modify (&tmpblock
, dst_data
,
7731 fold_convert (TREE_TYPE (dst_data
),
7732 null_pointer_node
));
7733 null_data
= gfc_finish_block (&tmpblock
);
7735 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
7736 boolean_type_node
, src_data
,
7739 gfc_add_expr_to_block (&fnblock
, build3_v (COND_EXPR
, null_cond
,
7744 if (c
->attr
.allocatable
&& !cmp_has_alloc_comps
)
7746 rank
= c
->as
? c
->as
->rank
: 0;
7747 tmp
= gfc_duplicate_allocatable (dcmp
, comp
, ctype
, rank
);
7748 gfc_add_expr_to_block (&fnblock
, tmp
);
7751 if (cmp_has_alloc_comps
)
7753 rank
= c
->as
? c
->as
->rank
: 0;
7754 tmp
= fold_convert (TREE_TYPE (dcmp
), comp
);
7755 gfc_add_modify (&fnblock
, dcmp
, tmp
);
7756 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, dcmp
,
7758 gfc_add_expr_to_block (&fnblock
, tmp
);
7768 return gfc_finish_block (&fnblock
);
7771 /* Recursively traverse an object of derived type, generating code to
7772 nullify allocatable components. */
7775 gfc_nullify_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
7777 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
7778 NULLIFY_ALLOC_COMP
);
7782 /* Recursively traverse an object of derived type, generating code to
7783 deallocate allocatable components. */
7786 gfc_deallocate_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
7788 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
7789 DEALLOCATE_ALLOC_COMP
);
7793 /* Recursively traverse an object of derived type, generating code to
7794 copy it and its allocatable components. */
7797 gfc_copy_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
7799 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ALLOC_COMP
);
7803 /* Recursively traverse an object of derived type, generating code to
7804 copy only its allocatable components. */
7807 gfc_copy_only_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
7809 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ONLY_ALLOC_COMP
);
7813 /* Returns the value of LBOUND for an expression. This could be broken out
7814 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
7815 called by gfc_alloc_allocatable_for_assignment. */
7817 get_std_lbound (gfc_expr
*expr
, tree desc
, int dim
, bool assumed_size
)
7822 tree cond
, cond1
, cond3
, cond4
;
7826 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
7828 tmp
= gfc_rank_cst
[dim
];
7829 lbound
= gfc_conv_descriptor_lbound_get (desc
, tmp
);
7830 ubound
= gfc_conv_descriptor_ubound_get (desc
, tmp
);
7831 stride
= gfc_conv_descriptor_stride_get (desc
, tmp
);
7832 cond1
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
7834 cond3
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
7835 stride
, gfc_index_zero_node
);
7836 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7837 boolean_type_node
, cond3
, cond1
);
7838 cond4
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
7839 stride
, gfc_index_zero_node
);
7841 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
7842 tmp
, build_int_cst (gfc_array_index_type
,
7845 cond
= boolean_false_node
;
7847 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
7848 boolean_type_node
, cond3
, cond4
);
7849 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
7850 boolean_type_node
, cond
, cond1
);
7852 return fold_build3_loc (input_location
, COND_EXPR
,
7853 gfc_array_index_type
, cond
,
7854 lbound
, gfc_index_one_node
);
7857 if (expr
->expr_type
== EXPR_FUNCTION
)
7859 /* A conversion function, so use the argument. */
7860 gcc_assert (expr
->value
.function
.isym
7861 && expr
->value
.function
.isym
->conversion
);
7862 expr
= expr
->value
.function
.actual
->expr
;
7865 if (expr
->expr_type
== EXPR_VARIABLE
)
7867 tmp
= TREE_TYPE (expr
->symtree
->n
.sym
->backend_decl
);
7868 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7870 if (ref
->type
== REF_COMPONENT
7871 && ref
->u
.c
.component
->as
7873 && ref
->next
->u
.ar
.type
== AR_FULL
)
7874 tmp
= TREE_TYPE (ref
->u
.c
.component
->backend_decl
);
7876 return GFC_TYPE_ARRAY_LBOUND(tmp
, dim
);
7879 return gfc_index_one_node
;
7883 /* Returns true if an expression represents an lhs that can be reallocated
7887 gfc_is_reallocatable_lhs (gfc_expr
*expr
)
7894 /* An allocatable variable. */
7895 if (expr
->symtree
->n
.sym
->attr
.allocatable
7897 && expr
->ref
->type
== REF_ARRAY
7898 && expr
->ref
->u
.ar
.type
== AR_FULL
)
7901 /* All that can be left are allocatable components. */
7902 if ((expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
7903 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
7904 || !expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
7907 /* Find a component ref followed by an array reference. */
7908 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7910 && ref
->type
== REF_COMPONENT
7911 && ref
->next
->type
== REF_ARRAY
7912 && !ref
->next
->next
)
7918 /* Return true if valid reallocatable lhs. */
7919 if (ref
->u
.c
.component
->attr
.allocatable
7920 && ref
->next
->u
.ar
.type
== AR_FULL
)
7927 /* Allocate the lhs of an assignment to an allocatable array, otherwise
7931 gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop
,
7935 stmtblock_t realloc_block
;
7936 stmtblock_t alloc_block
;
7940 gfc_array_info
*linfo
;
7960 gfc_array_spec
* as
;
7962 /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
7963 Find the lhs expression in the loop chain and set expr1 and
7964 expr2 accordingly. */
7965 if (expr1
->expr_type
== EXPR_FUNCTION
&& expr2
== NULL
)
7968 /* Find the ss for the lhs. */
7970 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
7971 if (lss
->info
->expr
&& lss
->info
->expr
->expr_type
== EXPR_VARIABLE
)
7973 if (lss
== gfc_ss_terminator
)
7975 expr1
= lss
->info
->expr
;
7978 /* Bail out if this is not a valid allocate on assignment. */
7979 if (!gfc_is_reallocatable_lhs (expr1
)
7980 || (expr2
&& !expr2
->rank
))
7983 /* Find the ss for the lhs. */
7985 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
7986 if (lss
->info
->expr
== expr1
)
7989 if (lss
== gfc_ss_terminator
)
7992 linfo
= &lss
->info
->data
.array
;
7994 /* Find an ss for the rhs. For operator expressions, we see the
7995 ss's for the operands. Any one of these will do. */
7997 for (; rss
&& rss
!= gfc_ss_terminator
; rss
= rss
->loop_chain
)
7998 if (rss
->info
->expr
!= expr1
&& rss
!= loop
->temp_ss
)
8001 if (expr2
&& rss
== gfc_ss_terminator
)
8004 gfc_start_block (&fblock
);
8006 /* Since the lhs is allocatable, this must be a descriptor type.
8007 Get the data and array size. */
8008 desc
= linfo
->descriptor
;
8009 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)));
8010 array1
= gfc_conv_descriptor_data_get (desc
);
8012 /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
8013 deallocated if expr is an array of different shape or any of the
8014 corresponding length type parameter values of variable and expr
8015 differ." This assures F95 compatibility. */
8016 jump_label1
= gfc_build_label_decl (NULL_TREE
);
8017 jump_label2
= gfc_build_label_decl (NULL_TREE
);
8019 /* Allocate if data is NULL. */
8020 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
8021 array1
, build_int_cst (TREE_TYPE (array1
), 0));
8022 tmp
= build3_v (COND_EXPR
, cond
,
8023 build1_v (GOTO_EXPR
, jump_label1
),
8024 build_empty_stmt (input_location
));
8025 gfc_add_expr_to_block (&fblock
, tmp
);
8027 /* Get arrayspec if expr is a full array. */
8028 if (expr2
&& expr2
->expr_type
== EXPR_FUNCTION
8029 && expr2
->value
.function
.isym
8030 && expr2
->value
.function
.isym
->conversion
)
8032 /* For conversion functions, take the arg. */
8033 gfc_expr
*arg
= expr2
->value
.function
.actual
->expr
;
8034 as
= gfc_get_full_arrayspec_from_expr (arg
);
8037 as
= gfc_get_full_arrayspec_from_expr (expr2
);
8041 /* If the lhs shape is not the same as the rhs jump to setting the
8042 bounds and doing the reallocation....... */
8043 for (n
= 0; n
< expr1
->rank
; n
++)
8045 /* Check the shape. */
8046 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
8047 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
8048 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8049 gfc_array_index_type
,
8050 loop
->to
[n
], loop
->from
[n
]);
8051 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8052 gfc_array_index_type
,
8054 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8055 gfc_array_index_type
,
8057 cond
= fold_build2_loc (input_location
, NE_EXPR
,
8059 tmp
, gfc_index_zero_node
);
8060 tmp
= build3_v (COND_EXPR
, cond
,
8061 build1_v (GOTO_EXPR
, jump_label1
),
8062 build_empty_stmt (input_location
));
8063 gfc_add_expr_to_block (&fblock
, tmp
);
8066 /* ....else jump past the (re)alloc code. */
8067 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
8068 gfc_add_expr_to_block (&fblock
, tmp
);
8070 /* Add the label to start automatic (re)allocation. */
8071 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
8072 gfc_add_expr_to_block (&fblock
, tmp
);
8074 size1
= gfc_conv_descriptor_size (desc
, expr1
->rank
);
8076 /* Get the rhs size. Fix both sizes. */
8078 desc2
= rss
->info
->data
.array
.descriptor
;
8081 size2
= gfc_index_one_node
;
8082 for (n
= 0; n
< expr2
->rank
; n
++)
8084 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8085 gfc_array_index_type
,
8086 loop
->to
[n
], loop
->from
[n
]);
8087 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8088 gfc_array_index_type
,
8089 tmp
, gfc_index_one_node
);
8090 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
8091 gfc_array_index_type
,
8095 size1
= gfc_evaluate_now (size1
, &fblock
);
8096 size2
= gfc_evaluate_now (size2
, &fblock
);
8098 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
8100 neq_size
= gfc_evaluate_now (cond
, &fblock
);
8103 /* Now modify the lhs descriptor and the associated scalarizer
8104 variables. F2003 7.4.1.3: "If variable is or becomes an
8105 unallocated allocatable variable, then it is allocated with each
8106 deferred type parameter equal to the corresponding type parameters
8107 of expr , with the shape of expr , and with each lower bound equal
8108 to the corresponding element of LBOUND(expr)."
8109 Reuse size1 to keep a dimension-by-dimension track of the
8110 stride of the new array. */
8111 size1
= gfc_index_one_node
;
8112 offset
= gfc_index_zero_node
;
8114 for (n
= 0; n
< expr2
->rank
; n
++)
8116 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8117 gfc_array_index_type
,
8118 loop
->to
[n
], loop
->from
[n
]);
8119 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8120 gfc_array_index_type
,
8121 tmp
, gfc_index_one_node
);
8123 lbound
= gfc_index_one_node
;
8128 lbd
= get_std_lbound (expr2
, desc2
, n
,
8129 as
->type
== AS_ASSUMED_SIZE
);
8130 ubound
= fold_build2_loc (input_location
,
8132 gfc_array_index_type
,
8134 ubound
= fold_build2_loc (input_location
,
8136 gfc_array_index_type
,
8141 gfc_conv_descriptor_lbound_set (&fblock
, desc
,
8144 gfc_conv_descriptor_ubound_set (&fblock
, desc
,
8147 gfc_conv_descriptor_stride_set (&fblock
, desc
,
8150 lbound
= gfc_conv_descriptor_lbound_get (desc
,
8152 tmp2
= fold_build2_loc (input_location
, MULT_EXPR
,
8153 gfc_array_index_type
,
8155 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
8156 gfc_array_index_type
,
8158 size1
= fold_build2_loc (input_location
, MULT_EXPR
,
8159 gfc_array_index_type
,
8163 /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
8164 the array offset is saved and the info.offset is used for a
8165 running offset. Use the saved_offset instead. */
8166 tmp
= gfc_conv_descriptor_offset (desc
);
8167 gfc_add_modify (&fblock
, tmp
, offset
);
8168 if (linfo
->saved_offset
8169 && TREE_CODE (linfo
->saved_offset
) == VAR_DECL
)
8170 gfc_add_modify (&fblock
, linfo
->saved_offset
, tmp
);
8172 /* Now set the deltas for the lhs. */
8173 for (n
= 0; n
< expr1
->rank
; n
++)
8175 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
8177 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8178 gfc_array_index_type
, tmp
,
8180 if (linfo
->delta
[dim
]
8181 && TREE_CODE (linfo
->delta
[dim
]) == VAR_DECL
)
8182 gfc_add_modify (&fblock
, linfo
->delta
[dim
], tmp
);
8185 /* Get the new lhs size in bytes. */
8186 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
8188 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
8189 gcc_assert (expr1
->ts
.u
.cl
->backend_decl
);
8190 tmp
= fold_convert (TREE_TYPE (expr1
->ts
.u
.cl
->backend_decl
), tmp
);
8191 gfc_add_modify (&fblock
, expr1
->ts
.u
.cl
->backend_decl
, tmp
);
8193 else if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.u
.cl
->backend_decl
)
8195 tmp
= TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
)));
8196 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8197 gfc_array_index_type
, tmp
,
8198 expr1
->ts
.u
.cl
->backend_decl
);
8201 tmp
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
8202 tmp
= fold_convert (gfc_array_index_type
, tmp
);
8203 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
8204 gfc_array_index_type
,
8206 size2
= fold_convert (size_type_node
, size2
);
8207 size2
= gfc_evaluate_now (size2
, &fblock
);
8209 /* Realloc expression. Note that the scalarizer uses desc.data
8210 in the array reference - (*desc.data)[<element>]. */
8211 gfc_init_block (&realloc_block
);
8212 tmp
= build_call_expr_loc (input_location
,
8213 builtin_decl_explicit (BUILT_IN_REALLOC
), 2,
8214 fold_convert (pvoid_type_node
, array1
),
8216 gfc_conv_descriptor_data_set (&realloc_block
,
8218 realloc_expr
= gfc_finish_block (&realloc_block
);
8220 /* Only reallocate if sizes are different. */
8221 tmp
= build3_v (COND_EXPR
, neq_size
, realloc_expr
,
8222 build_empty_stmt (input_location
));
8226 /* Malloc expression. */
8227 gfc_init_block (&alloc_block
);
8228 tmp
= build_call_expr_loc (input_location
,
8229 builtin_decl_explicit (BUILT_IN_MALLOC
),
8231 gfc_conv_descriptor_data_set (&alloc_block
,
8233 tmp
= gfc_conv_descriptor_dtype (desc
);
8234 gfc_add_modify (&alloc_block
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
8235 alloc_expr
= gfc_finish_block (&alloc_block
);
8237 /* Malloc if not allocated; realloc otherwise. */
8238 tmp
= build_int_cst (TREE_TYPE (array1
), 0);
8239 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
8242 tmp
= build3_v (COND_EXPR
, cond
, alloc_expr
, realloc_expr
);
8243 gfc_add_expr_to_block (&fblock
, tmp
);
8245 /* Make sure that the scalarizer data pointer is updated. */
8247 && TREE_CODE (linfo
->data
) == VAR_DECL
)
8249 tmp
= gfc_conv_descriptor_data_get (desc
);
8250 gfc_add_modify (&fblock
, linfo
->data
, tmp
);
8253 /* Add the exit label. */
8254 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
8255 gfc_add_expr_to_block (&fblock
, tmp
);
8257 return gfc_finish_block (&fblock
);
8261 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
8262 Do likewise, recursively if necessary, with the allocatable components of
8266 gfc_trans_deferred_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
8272 stmtblock_t cleanup
;
8275 bool sym_has_alloc_comp
;
8277 sym_has_alloc_comp
= (sym
->ts
.type
== BT_DERIVED
8278 || sym
->ts
.type
== BT_CLASS
)
8279 && sym
->ts
.u
.derived
->attr
.alloc_comp
;
8281 /* Make sure the frontend gets these right. */
8282 if (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym_has_alloc_comp
))
8283 fatal_error ("Possible front-end bug: Deferred array size without pointer, "
8284 "allocatable attribute or derived type without allocatable "
8287 gfc_save_backend_locus (&loc
);
8288 gfc_set_backend_locus (&sym
->declared_at
);
8289 gfc_init_block (&init
);
8291 gcc_assert (TREE_CODE (sym
->backend_decl
) == VAR_DECL
8292 || TREE_CODE (sym
->backend_decl
) == PARM_DECL
);
8294 if (sym
->ts
.type
== BT_CHARACTER
8295 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
8297 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
8298 gfc_trans_vla_type_sizes (sym
, &init
);
8301 /* Dummy, use associated and result variables don't need anything special. */
8302 if (sym
->attr
.dummy
|| sym
->attr
.use_assoc
|| sym
->attr
.result
)
8304 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
8305 gfc_restore_backend_locus (&loc
);
8309 descriptor
= sym
->backend_decl
;
8311 /* Although static, derived types with default initializers and
8312 allocatable components must not be nulled wholesale; instead they
8313 are treated component by component. */
8314 if (TREE_STATIC (descriptor
) && !sym_has_alloc_comp
)
8316 /* SAVEd variables are not freed on exit. */
8317 gfc_trans_static_array_pointer (sym
);
8319 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
8320 gfc_restore_backend_locus (&loc
);
8324 /* Get the descriptor type. */
8325 type
= TREE_TYPE (sym
->backend_decl
);
8327 if (sym_has_alloc_comp
&& !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
8330 && !(TREE_STATIC (sym
->backend_decl
) && sym
->attr
.is_main_program
))
8332 if (sym
->value
== NULL
8333 || !gfc_has_default_initializer (sym
->ts
.u
.derived
))
8335 rank
= sym
->as
? sym
->as
->rank
: 0;
8336 tmp
= gfc_nullify_alloc_comp (sym
->ts
.u
.derived
,
8338 gfc_add_expr_to_block (&init
, tmp
);
8341 gfc_init_default_dt (sym
, &init
, false);
8344 else if (!GFC_DESCRIPTOR_TYPE_P (type
))
8346 /* If the backend_decl is not a descriptor, we must have a pointer
8348 descriptor
= build_fold_indirect_ref_loc (input_location
,
8350 type
= TREE_TYPE (descriptor
);
8353 /* NULLIFY the data pointer. */
8354 if (GFC_DESCRIPTOR_TYPE_P (type
) && !sym
->attr
.save
)
8355 gfc_conv_descriptor_data_set (&init
, descriptor
, null_pointer_node
);
8357 gfc_restore_backend_locus (&loc
);
8358 gfc_init_block (&cleanup
);
8360 /* Allocatable arrays need to be freed when they go out of scope.
8361 The allocatable components of pointers must not be touched. */
8362 if (sym_has_alloc_comp
&& !(sym
->attr
.function
|| sym
->attr
.result
)
8363 && !sym
->attr
.pointer
&& !sym
->attr
.save
)
8366 rank
= sym
->as
? sym
->as
->rank
: 0;
8367 tmp
= gfc_deallocate_alloc_comp (sym
->ts
.u
.derived
, descriptor
, rank
);
8368 gfc_add_expr_to_block (&cleanup
, tmp
);
8371 if (sym
->attr
.allocatable
&& (sym
->attr
.dimension
|| sym
->attr
.codimension
)
8372 && !sym
->attr
.save
&& !sym
->attr
.result
)
8374 tmp
= gfc_trans_dealloc_allocated (sym
->backend_decl
,
8375 sym
->attr
.codimension
);
8376 gfc_add_expr_to_block (&cleanup
, tmp
);
8379 gfc_add_init_cleanup (block
, gfc_finish_block (&init
),
8380 gfc_finish_block (&cleanup
));
8383 /************ Expression Walking Functions ******************/
8385 /* Walk a variable reference.
8387 Possible extension - multiple component subscripts.
8388 x(:,:) = foo%a(:)%b(:)
8390 forall (i=..., j=...)
8391 x(i,j) = foo%a(j)%b(i)
8393 This adds a fair amount of complexity because you need to deal with more
8394 than one ref. Maybe handle in a similar manner to vector subscripts.
8395 Maybe not worth the effort. */
8399 gfc_walk_variable_expr (gfc_ss
* ss
, gfc_expr
* expr
)
8403 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
8404 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
8407 return gfc_walk_array_ref (ss
, expr
, ref
);
8412 gfc_walk_array_ref (gfc_ss
* ss
, gfc_expr
* expr
, gfc_ref
* ref
)
8418 for (; ref
; ref
= ref
->next
)
8420 if (ref
->type
== REF_SUBSTRING
)
8422 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.start
);
8423 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.end
);
8426 /* We're only interested in array sections from now on. */
8427 if (ref
->type
!= REF_ARRAY
)
8435 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
8436 ss
= gfc_get_scalar_ss (ss
, ar
->start
[n
]);
8440 newss
= gfc_get_array_ss (ss
, expr
, ar
->as
->rank
, GFC_SS_SECTION
);
8441 newss
->info
->data
.array
.ref
= ref
;
8443 /* Make sure array is the same as array(:,:), this way
8444 we don't need to special case all the time. */
8445 ar
->dimen
= ar
->as
->rank
;
8446 for (n
= 0; n
< ar
->dimen
; n
++)
8448 ar
->dimen_type
[n
] = DIMEN_RANGE
;
8450 gcc_assert (ar
->start
[n
] == NULL
);
8451 gcc_assert (ar
->end
[n
] == NULL
);
8452 gcc_assert (ar
->stride
[n
] == NULL
);
8458 newss
= gfc_get_array_ss (ss
, expr
, 0, GFC_SS_SECTION
);
8459 newss
->info
->data
.array
.ref
= ref
;
8461 /* We add SS chains for all the subscripts in the section. */
8462 for (n
= 0; n
< ar
->dimen
; n
++)
8466 switch (ar
->dimen_type
[n
])
8469 /* Add SS for elemental (scalar) subscripts. */
8470 gcc_assert (ar
->start
[n
]);
8471 indexss
= gfc_get_scalar_ss (gfc_ss_terminator
, ar
->start
[n
]);
8472 indexss
->loop_chain
= gfc_ss_terminator
;
8473 newss
->info
->data
.array
.subscript
[n
] = indexss
;
8477 /* We don't add anything for sections, just remember this
8478 dimension for later. */
8479 newss
->dim
[newss
->dimen
] = n
;
8484 /* Create a GFC_SS_VECTOR index in which we can store
8485 the vector's descriptor. */
8486 indexss
= gfc_get_array_ss (gfc_ss_terminator
, ar
->start
[n
],
8488 indexss
->loop_chain
= gfc_ss_terminator
;
8489 newss
->info
->data
.array
.subscript
[n
] = indexss
;
8490 newss
->dim
[newss
->dimen
] = n
;
8495 /* We should know what sort of section it is by now. */
8499 /* We should have at least one non-elemental dimension,
8500 unless we are creating a descriptor for a (scalar) coarray. */
8501 gcc_assert (newss
->dimen
> 0
8502 || newss
->info
->data
.array
.ref
->u
.ar
.as
->corank
> 0);
8507 /* We should know what sort of section it is by now. */
8516 /* Walk an expression operator. If only one operand of a binary expression is
8517 scalar, we must also add the scalar term to the SS chain. */
8520 gfc_walk_op_expr (gfc_ss
* ss
, gfc_expr
* expr
)
8525 head
= gfc_walk_subexpr (ss
, expr
->value
.op
.op1
);
8526 if (expr
->value
.op
.op2
== NULL
)
8529 head2
= gfc_walk_subexpr (head
, expr
->value
.op
.op2
);
8531 /* All operands are scalar. Pass back and let the caller deal with it. */
8535 /* All operands require scalarization. */
8536 if (head
!= ss
&& (expr
->value
.op
.op2
== NULL
|| head2
!= head
))
8539 /* One of the operands needs scalarization, the other is scalar.
8540 Create a gfc_ss for the scalar expression. */
8543 /* First operand is scalar. We build the chain in reverse order, so
8544 add the scalar SS after the second operand. */
8546 while (head
&& head
->next
!= ss
)
8548 /* Check we haven't somehow broken the chain. */
8550 head
->next
= gfc_get_scalar_ss (ss
, expr
->value
.op
.op1
);
8552 else /* head2 == head */
8554 gcc_assert (head2
== head
);
8555 /* Second operand is scalar. */
8556 head2
= gfc_get_scalar_ss (head2
, expr
->value
.op
.op2
);
8563 /* Reverse a SS chain. */
8566 gfc_reverse_ss (gfc_ss
* ss
)
8571 gcc_assert (ss
!= NULL
);
8573 head
= gfc_ss_terminator
;
8574 while (ss
!= gfc_ss_terminator
)
8577 /* Check we didn't somehow break the chain. */
8578 gcc_assert (next
!= NULL
);
8588 /* Given an expression referring to a procedure, return the symbol of its
8589 interface. We can't get the procedure symbol directly as we have to handle
8590 the case of (deferred) type-bound procedures. */
8593 gfc_get_proc_ifc_for_expr (gfc_expr
*procedure_ref
)
8598 if (procedure_ref
== NULL
)
8601 /* Normal procedure case. */
8602 sym
= procedure_ref
->symtree
->n
.sym
;
8604 /* Typebound procedure case. */
8605 for (ref
= procedure_ref
->ref
; ref
; ref
= ref
->next
)
8607 if (ref
->type
== REF_COMPONENT
8608 && ref
->u
.c
.component
->attr
.proc_pointer
)
8609 sym
= ref
->u
.c
.component
->ts
.interface
;
8618 /* Walk the arguments of an elemental function.
8619 PROC_EXPR is used to check whether an argument is permitted to be absent. If
8620 it is NULL, we don't do the check and the argument is assumed to be present.
8624 gfc_walk_elemental_function_args (gfc_ss
* ss
, gfc_actual_arglist
*arg
,
8625 gfc_symbol
*proc_ifc
, gfc_ss_type type
)
8627 gfc_formal_arglist
*dummy_arg
;
8633 head
= gfc_ss_terminator
;
8637 dummy_arg
= proc_ifc
->formal
;
8642 for (; arg
; arg
= arg
->next
)
8644 if (!arg
->expr
|| arg
->expr
->expr_type
== EXPR_NULL
)
8647 newss
= gfc_walk_subexpr (head
, arg
->expr
);
8650 /* Scalar argument. */
8651 gcc_assert (type
== GFC_SS_SCALAR
|| type
== GFC_SS_REFERENCE
);
8652 newss
= gfc_get_scalar_ss (head
, arg
->expr
);
8653 newss
->info
->type
= type
;
8659 if (dummy_arg
!= NULL
8660 && dummy_arg
->sym
->attr
.optional
8661 && arg
->expr
->expr_type
== EXPR_VARIABLE
8662 && (gfc_expr_attr (arg
->expr
).optional
8663 || gfc_expr_attr (arg
->expr
).allocatable
8664 || gfc_expr_attr (arg
->expr
).pointer
))
8665 newss
->info
->can_be_null_ref
= true;
8671 while (tail
->next
!= gfc_ss_terminator
)
8675 if (dummy_arg
!= NULL
)
8676 dummy_arg
= dummy_arg
->next
;
8681 /* If all the arguments are scalar we don't need the argument SS. */
8682 gfc_free_ss_chain (head
);
8687 /* Add it onto the existing chain. */
8693 /* Walk a function call. Scalar functions are passed back, and taken out of
8694 scalarization loops. For elemental functions we walk their arguments.
8695 The result of functions returning arrays is stored in a temporary outside
8696 the loop, so that the function is only called once. Hence we do not need
8697 to walk their arguments. */
8700 gfc_walk_function_expr (gfc_ss
* ss
, gfc_expr
* expr
)
8702 gfc_intrinsic_sym
*isym
;
8704 gfc_component
*comp
= NULL
;
8706 isym
= expr
->value
.function
.isym
;
8708 /* Handle intrinsic functions separately. */
8710 return gfc_walk_intrinsic_function (ss
, expr
, isym
);
8712 sym
= expr
->value
.function
.esym
;
8714 sym
= expr
->symtree
->n
.sym
;
8716 /* A function that returns arrays. */
8717 comp
= gfc_get_proc_ptr_comp (expr
);
8718 if ((!comp
&& gfc_return_by_reference (sym
) && sym
->result
->attr
.dimension
)
8719 || (comp
&& comp
->attr
.dimension
))
8720 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
8722 /* Walk the parameters of an elemental function. For now we always pass
8724 if (sym
->attr
.elemental
|| (comp
&& comp
->attr
.elemental
))
8725 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
8726 gfc_get_proc_ifc_for_expr (expr
),
8729 /* Scalar functions are OK as these are evaluated outside the scalarization
8730 loop. Pass back and let the caller deal with it. */
8735 /* An array temporary is constructed for array constructors. */
8738 gfc_walk_array_constructor (gfc_ss
* ss
, gfc_expr
* expr
)
8740 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_CONSTRUCTOR
);
8744 /* Walk an expression. Add walked expressions to the head of the SS chain.
8745 A wholly scalar expression will not be added. */
8748 gfc_walk_subexpr (gfc_ss
* ss
, gfc_expr
* expr
)
8752 switch (expr
->expr_type
)
8755 head
= gfc_walk_variable_expr (ss
, expr
);
8759 head
= gfc_walk_op_expr (ss
, expr
);
8763 head
= gfc_walk_function_expr (ss
, expr
);
8768 case EXPR_STRUCTURE
:
8769 /* Pass back and let the caller deal with it. */
8773 head
= gfc_walk_array_constructor (ss
, expr
);
8776 case EXPR_SUBSTRING
:
8777 /* Pass back and let the caller deal with it. */
8781 internal_error ("bad expression type during walk (%d)",
8788 /* Entry point for expression walking.
8789 A return value equal to the passed chain means this is
8790 a scalar expression. It is up to the caller to take whatever action is
8791 necessary to translate these. */
8794 gfc_walk_expr (gfc_expr
* expr
)
8798 res
= gfc_walk_subexpr (gfc_ss_terminator
, expr
);
8799 return gfc_reverse_ss (res
);