1 /* Array translation routines
2 Copyright (C) 2002-2015 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-array.c-- Various array related code, including scalarization,
23 allocation, initialization and other support routines. */
25 /* How the scalarizer works.
26 In gfortran, array expressions use the same core routines as scalar
28 First, a Scalarization State (SS) chain is built. This is done by walking
29 the expression tree, and building a linear list of the terms in the
30 expression. As the tree is walked, scalar subexpressions are translated.
32 The scalarization parameters are stored in a gfc_loopinfo structure.
33 First the start and stride of each term is calculated by
34 gfc_conv_ss_startstride. During this process the expressions for the array
35 descriptors and data pointers are also translated.
37 If the expression is an assignment, we must then resolve any dependencies.
38 In Fortran all the rhs values of an assignment must be evaluated before
39 any assignments take place. This can require a temporary array to store the
40 values. We also require a temporary when we are passing array expressions
41 or vector subscripts as procedure parameters.
43 Array sections are passed without copying to a temporary. These use the
44 scalarizer to determine the shape of the section. The flag
45 loop->array_parameter tells the scalarizer that the actual values and loop
46 variables will not be required.
48 The function gfc_conv_loop_setup generates the scalarization setup code.
49 It determines the range of the scalarizing loop variables. If a temporary
50 is required, this is created and initialized. Code for scalar expressions
51 taken outside the loop is also generated at this time. Next the offset and
52 scaling required to translate from loop variables to array indices for each
55 A call to gfc_start_scalarized_body marks the start of the scalarized
56 expression. This creates a scope and declares the loop variables. Before
57 calling this gfc_make_ss_chain_used must be used to indicate which terms
58 will be used inside this loop.
60 The scalar gfc_conv_* functions are then used to build the main body of the
61 scalarization loop. Scalarization loop variables and precalculated scalar
62 values are automatically substituted. Note that gfc_advance_se_ss_chain
63 must be used, rather than changing the se->ss directly.
65 For assignment expressions requiring a temporary two sub loops are
66 generated. The first stores the result of the expression in the temporary,
67 the second copies it to the result. A call to
68 gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
69 the start of the copying loop. The temporary may be less than full rank.
71 Finally gfc_trans_scalarizing_loops is called to generate the implicit do
72 loops. The loops are added to the pre chain of the loopinfo. The post
73 chain may still contain cleanup code.
75 After the loop code has been added into its parent scope gfc_cleanup_loop
76 is called to free all the SS allocated by the scalarizer. */
80 #include "coretypes.h"
85 #include "double-int.h"
93 #include "fold-const.h"
94 #include "gimple-expr.h"
95 #include "diagnostic-core.h" /* For internal_error/fatal_error. */
97 #include "constructor.h"
99 #include "trans-stmt.h"
100 #include "trans-types.h"
101 #include "trans-array.h"
102 #include "trans-const.h"
103 #include "dependency.h"
104 #include "wide-int.h"
106 static bool gfc_get_array_constructor_size (mpz_t
*, gfc_constructor_base
);
108 /* The contents of this structure aren't actually used, just the address. */
109 static gfc_ss gfc_ss_terminator_var
;
110 gfc_ss
* const gfc_ss_terminator
= &gfc_ss_terminator_var
;
114 gfc_array_dataptr_type (tree desc
)
116 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
)));
120 /* Build expressions to access the members of an array descriptor.
121 It's surprisingly easy to mess up here, so never access
122 an array descriptor by "brute force", always use these
123 functions. This also avoids problems if we change the format
124 of an array descriptor.
126 To understand these magic numbers, look at the comments
127 before gfc_build_array_type() in trans-types.c.
129 The code within these defines should be the only code which knows the format
130 of an array descriptor.
132 Any code just needing to read obtain the bounds of an array should use
133 gfc_conv_array_* rather than the following functions as these will return
134 know constant values, and work with arrays which do not have descriptors.
136 Don't forget to #undef these! */
139 #define OFFSET_FIELD 1
140 #define DTYPE_FIELD 2
141 #define DIMENSION_FIELD 3
142 #define CAF_TOKEN_FIELD 4
144 #define STRIDE_SUBFIELD 0
145 #define LBOUND_SUBFIELD 1
146 #define UBOUND_SUBFIELD 2
148 /* This provides READ-ONLY access to the data field. The field itself
149 doesn't have the proper type. */
152 gfc_conv_descriptor_data_get (tree desc
)
156 type
= TREE_TYPE (desc
);
157 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
159 field
= TYPE_FIELDS (type
);
160 gcc_assert (DATA_FIELD
== 0);
162 t
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
), desc
,
164 t
= fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type
), t
);
169 /* This provides WRITE access to the data field.
171 TUPLES_P is true if we are generating tuples.
173 This function gets called through the following macros:
174 gfc_conv_descriptor_data_set
175 gfc_conv_descriptor_data_set. */
178 gfc_conv_descriptor_data_set (stmtblock_t
*block
, tree desc
, tree value
)
182 type
= TREE_TYPE (desc
);
183 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
185 field
= TYPE_FIELDS (type
);
186 gcc_assert (DATA_FIELD
== 0);
188 t
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
), desc
,
190 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (field
), value
));
194 /* This provides address access to the data field. This should only be
195 used by array allocation, passing this on to the runtime. */
198 gfc_conv_descriptor_data_addr (tree desc
)
202 type
= TREE_TYPE (desc
);
203 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
205 field
= TYPE_FIELDS (type
);
206 gcc_assert (DATA_FIELD
== 0);
208 t
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
), desc
,
210 return gfc_build_addr_expr (NULL_TREE
, t
);
214 gfc_conv_descriptor_offset (tree desc
)
219 type
= TREE_TYPE (desc
);
220 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
222 field
= gfc_advance_chain (TYPE_FIELDS (type
), OFFSET_FIELD
);
223 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
225 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
226 desc
, field
, NULL_TREE
);
230 gfc_conv_descriptor_offset_get (tree desc
)
232 return gfc_conv_descriptor_offset (desc
);
236 gfc_conv_descriptor_offset_set (stmtblock_t
*block
, tree desc
,
239 tree t
= gfc_conv_descriptor_offset (desc
);
240 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
245 gfc_conv_descriptor_dtype (tree desc
)
250 type
= TREE_TYPE (desc
);
251 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
253 field
= gfc_advance_chain (TYPE_FIELDS (type
), DTYPE_FIELD
);
254 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
256 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
257 desc
, field
, NULL_TREE
);
262 gfc_conv_descriptor_rank (tree desc
)
267 dtype
= gfc_conv_descriptor_dtype (desc
);
268 tmp
= build_int_cst (TREE_TYPE (dtype
), GFC_DTYPE_RANK_MASK
);
269 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, TREE_TYPE (dtype
),
271 return fold_convert (gfc_get_int_type (gfc_default_integer_kind
), tmp
);
276 gfc_get_descriptor_dimension (tree desc
)
280 type
= TREE_TYPE (desc
);
281 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
283 field
= gfc_advance_chain (TYPE_FIELDS (type
), DIMENSION_FIELD
);
284 gcc_assert (field
!= NULL_TREE
285 && TREE_CODE (TREE_TYPE (field
)) == ARRAY_TYPE
286 && TREE_CODE (TREE_TYPE (TREE_TYPE (field
))) == RECORD_TYPE
);
288 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
289 desc
, field
, NULL_TREE
);
294 gfc_conv_descriptor_dimension (tree desc
, tree dim
)
298 tmp
= gfc_get_descriptor_dimension (desc
);
300 return gfc_build_array_ref (tmp
, dim
, NULL
);
305 gfc_conv_descriptor_token (tree desc
)
310 type
= TREE_TYPE (desc
);
311 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
312 gcc_assert (flag_coarray
== GFC_FCOARRAY_LIB
);
313 field
= gfc_advance_chain (TYPE_FIELDS (type
), CAF_TOKEN_FIELD
);
315 /* Should be a restricted pointer - except in the finalization wrapper. */
316 gcc_assert (field
!= NULL_TREE
317 && (TREE_TYPE (field
) == prvoid_type_node
318 || TREE_TYPE (field
) == pvoid_type_node
));
320 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
321 desc
, field
, NULL_TREE
);
326 gfc_conv_descriptor_stride (tree desc
, tree dim
)
331 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
332 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
333 field
= gfc_advance_chain (field
, STRIDE_SUBFIELD
);
334 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
336 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
337 tmp
, field
, NULL_TREE
);
342 gfc_conv_descriptor_stride_get (tree desc
, tree dim
)
344 tree type
= TREE_TYPE (desc
);
345 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
346 if (integer_zerop (dim
)
347 && (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ALLOCATABLE
348 ||GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE_CONT
349 ||GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_RANK_CONT
350 ||GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER_CONT
))
351 return gfc_index_one_node
;
353 return gfc_conv_descriptor_stride (desc
, dim
);
357 gfc_conv_descriptor_stride_set (stmtblock_t
*block
, tree desc
,
358 tree dim
, tree value
)
360 tree t
= gfc_conv_descriptor_stride (desc
, dim
);
361 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
365 gfc_conv_descriptor_lbound (tree desc
, tree dim
)
370 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
371 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
372 field
= gfc_advance_chain (field
, LBOUND_SUBFIELD
);
373 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
375 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
376 tmp
, field
, NULL_TREE
);
381 gfc_conv_descriptor_lbound_get (tree desc
, tree dim
)
383 return gfc_conv_descriptor_lbound (desc
, dim
);
387 gfc_conv_descriptor_lbound_set (stmtblock_t
*block
, tree desc
,
388 tree dim
, tree value
)
390 tree t
= gfc_conv_descriptor_lbound (desc
, dim
);
391 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
395 gfc_conv_descriptor_ubound (tree desc
, tree dim
)
400 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
401 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
402 field
= gfc_advance_chain (field
, UBOUND_SUBFIELD
);
403 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
405 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
406 tmp
, field
, NULL_TREE
);
411 gfc_conv_descriptor_ubound_get (tree desc
, tree dim
)
413 return gfc_conv_descriptor_ubound (desc
, dim
);
417 gfc_conv_descriptor_ubound_set (stmtblock_t
*block
, tree desc
,
418 tree dim
, tree value
)
420 tree t
= gfc_conv_descriptor_ubound (desc
, dim
);
421 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
424 /* Build a null array descriptor constructor. */
427 gfc_build_null_descriptor (tree type
)
432 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
433 gcc_assert (DATA_FIELD
== 0);
434 field
= TYPE_FIELDS (type
);
436 /* Set a NULL data pointer. */
437 tmp
= build_constructor_single (type
, field
, null_pointer_node
);
438 TREE_CONSTANT (tmp
) = 1;
439 /* All other fields are ignored. */
445 /* Modify a descriptor such that the lbound of a given dimension is the value
446 specified. This also updates ubound and offset accordingly. */
449 gfc_conv_shift_descriptor_lbound (stmtblock_t
* block
, tree desc
,
450 int dim
, tree new_lbound
)
452 tree offs
, ubound
, lbound
, stride
;
453 tree diff
, offs_diff
;
455 new_lbound
= fold_convert (gfc_array_index_type
, new_lbound
);
457 offs
= gfc_conv_descriptor_offset_get (desc
);
458 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]);
459 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]);
460 stride
= gfc_conv_descriptor_stride_get (desc
, gfc_rank_cst
[dim
]);
462 /* Get difference (new - old) by which to shift stuff. */
463 diff
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
466 /* Shift ubound and offset accordingly. This has to be done before
467 updating the lbound, as they depend on the lbound expression! */
468 ubound
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
470 gfc_conv_descriptor_ubound_set (block
, desc
, gfc_rank_cst
[dim
], ubound
);
471 offs_diff
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
473 offs
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
475 gfc_conv_descriptor_offset_set (block
, desc
, offs
);
477 /* Finally set lbound to value we want. */
478 gfc_conv_descriptor_lbound_set (block
, desc
, gfc_rank_cst
[dim
], new_lbound
);
482 /* Cleanup those #defines. */
487 #undef DIMENSION_FIELD
488 #undef CAF_TOKEN_FIELD
489 #undef STRIDE_SUBFIELD
490 #undef LBOUND_SUBFIELD
491 #undef UBOUND_SUBFIELD
494 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
495 flags & 1 = Main loop body.
496 flags & 2 = temp copy loop. */
499 gfc_mark_ss_chain_used (gfc_ss
* ss
, unsigned flags
)
501 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
502 ss
->info
->useflags
= flags
;
506 /* Free a gfc_ss chain. */
509 gfc_free_ss_chain (gfc_ss
* ss
)
513 while (ss
!= gfc_ss_terminator
)
515 gcc_assert (ss
!= NULL
);
524 free_ss_info (gfc_ss_info
*ss_info
)
529 if (ss_info
->refcount
> 0)
532 gcc_assert (ss_info
->refcount
== 0);
534 switch (ss_info
->type
)
537 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
538 if (ss_info
->data
.array
.subscript
[n
])
539 gfc_free_ss_chain (ss_info
->data
.array
.subscript
[n
]);
553 gfc_free_ss (gfc_ss
* ss
)
555 free_ss_info (ss
->info
);
560 /* Creates and initializes an array type gfc_ss struct. */
563 gfc_get_array_ss (gfc_ss
*next
, gfc_expr
*expr
, int dimen
, gfc_ss_type type
)
566 gfc_ss_info
*ss_info
;
569 ss_info
= gfc_get_ss_info ();
571 ss_info
->type
= type
;
572 ss_info
->expr
= expr
;
578 for (i
= 0; i
< ss
->dimen
; i
++)
585 /* Creates and initializes a temporary type gfc_ss struct. */
588 gfc_get_temp_ss (tree type
, tree string_length
, int dimen
)
591 gfc_ss_info
*ss_info
;
594 ss_info
= gfc_get_ss_info ();
596 ss_info
->type
= GFC_SS_TEMP
;
597 ss_info
->string_length
= string_length
;
598 ss_info
->data
.temp
.type
= type
;
602 ss
->next
= gfc_ss_terminator
;
604 for (i
= 0; i
< ss
->dimen
; i
++)
611 /* Creates and initializes a scalar type gfc_ss struct. */
614 gfc_get_scalar_ss (gfc_ss
*next
, gfc_expr
*expr
)
617 gfc_ss_info
*ss_info
;
619 ss_info
= gfc_get_ss_info ();
621 ss_info
->type
= GFC_SS_SCALAR
;
622 ss_info
->expr
= expr
;
632 /* Free all the SS associated with a loop. */
635 gfc_cleanup_loop (gfc_loopinfo
* loop
)
637 gfc_loopinfo
*loop_next
, **ploop
;
642 while (ss
!= gfc_ss_terminator
)
644 gcc_assert (ss
!= NULL
);
645 next
= ss
->loop_chain
;
650 /* Remove reference to self in the parent loop. */
652 for (ploop
= &loop
->parent
->nested
; *ploop
; ploop
= &(*ploop
)->next
)
659 /* Free non-freed nested loops. */
660 for (loop
= loop
->nested
; loop
; loop
= loop_next
)
662 loop_next
= loop
->next
;
663 gfc_cleanup_loop (loop
);
670 set_ss_loop (gfc_ss
*ss
, gfc_loopinfo
*loop
)
674 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
678 if (ss
->info
->type
== GFC_SS_SCALAR
679 || ss
->info
->type
== GFC_SS_REFERENCE
680 || ss
->info
->type
== GFC_SS_TEMP
)
683 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
684 if (ss
->info
->data
.array
.subscript
[n
] != NULL
)
685 set_ss_loop (ss
->info
->data
.array
.subscript
[n
], loop
);
690 /* Associate a SS chain with a loop. */
693 gfc_add_ss_to_loop (gfc_loopinfo
* loop
, gfc_ss
* head
)
696 gfc_loopinfo
*nested_loop
;
698 if (head
== gfc_ss_terminator
)
701 set_ss_loop (head
, loop
);
704 for (; ss
&& ss
!= gfc_ss_terminator
; ss
= ss
->next
)
708 nested_loop
= ss
->nested_ss
->loop
;
710 /* More than one ss can belong to the same loop. Hence, we add the
711 loop to the chain only if it is different from the previously
712 added one, to avoid duplicate nested loops. */
713 if (nested_loop
!= loop
->nested
)
715 gcc_assert (nested_loop
->parent
== NULL
);
716 nested_loop
->parent
= loop
;
718 gcc_assert (nested_loop
->next
== NULL
);
719 nested_loop
->next
= loop
->nested
;
720 loop
->nested
= nested_loop
;
723 gcc_assert (nested_loop
->parent
== loop
);
726 if (ss
->next
== gfc_ss_terminator
)
727 ss
->loop_chain
= loop
->ss
;
729 ss
->loop_chain
= ss
->next
;
731 gcc_assert (ss
== gfc_ss_terminator
);
736 /* Generate an initializer for a static pointer or allocatable array. */
739 gfc_trans_static_array_pointer (gfc_symbol
* sym
)
743 gcc_assert (TREE_STATIC (sym
->backend_decl
));
744 /* Just zero the data member. */
745 type
= TREE_TYPE (sym
->backend_decl
);
746 DECL_INITIAL (sym
->backend_decl
) = gfc_build_null_descriptor (type
);
750 /* If the bounds of SE's loop have not yet been set, see if they can be
751 determined from array spec AS, which is the array spec of a called
752 function. MAPPING maps the callee's dummy arguments to the values
753 that the caller is passing. Add any initialization and finalization
757 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping
* mapping
,
758 gfc_se
* se
, gfc_array_spec
* as
)
760 int n
, dim
, total_dim
;
769 if (!as
|| as
->type
!= AS_EXPLICIT
)
772 for (ss
= se
->ss
; ss
; ss
= ss
->parent
)
774 total_dim
+= ss
->loop
->dimen
;
775 for (n
= 0; n
< ss
->loop
->dimen
; n
++)
777 /* The bound is known, nothing to do. */
778 if (ss
->loop
->to
[n
] != NULL_TREE
)
782 gcc_assert (dim
< as
->rank
);
783 gcc_assert (ss
->loop
->dimen
<= as
->rank
);
785 /* Evaluate the lower bound. */
786 gfc_init_se (&tmpse
, NULL
);
787 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->lower
[dim
]);
788 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
789 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
790 lower
= fold_convert (gfc_array_index_type
, tmpse
.expr
);
792 /* ...and the upper bound. */
793 gfc_init_se (&tmpse
, NULL
);
794 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->upper
[dim
]);
795 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
796 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
797 upper
= fold_convert (gfc_array_index_type
, tmpse
.expr
);
799 /* Set the upper bound of the loop to UPPER - LOWER. */
800 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
801 gfc_array_index_type
, upper
, lower
);
802 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
803 ss
->loop
->to
[n
] = tmp
;
807 gcc_assert (total_dim
== as
->rank
);
811 /* Generate code to allocate an array temporary, or create a variable to
812 hold the data. If size is NULL, zero the descriptor so that the
813 callee will allocate the array. If DEALLOC is true, also generate code to
814 free the array afterwards.
816 If INITIAL is not NULL, it is packed using internal_pack and the result used
817 as data instead of allocating a fresh, unitialized area of memory.
819 Initialization code is added to PRE and finalization code to POST.
820 DYNAMIC is true if the caller may want to extend the array later
821 using realloc. This prevents us from putting the array on the stack. */
824 gfc_trans_allocate_array_storage (stmtblock_t
* pre
, stmtblock_t
* post
,
825 gfc_array_info
* info
, tree size
, tree nelem
,
826 tree initial
, bool dynamic
, bool dealloc
)
832 desc
= info
->descriptor
;
833 info
->offset
= gfc_index_zero_node
;
834 if (size
== NULL_TREE
|| integer_zerop (size
))
836 /* A callee allocated array. */
837 gfc_conv_descriptor_data_set (pre
, desc
, null_pointer_node
);
842 /* Allocate the temporary. */
843 onstack
= !dynamic
&& initial
== NULL_TREE
844 && (flag_stack_arrays
845 || gfc_can_put_var_on_stack (size
));
849 /* Make a temporary variable to hold the data. */
850 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (nelem
),
851 nelem
, gfc_index_one_node
);
852 tmp
= gfc_evaluate_now (tmp
, pre
);
853 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
855 tmp
= build_array_type (gfc_get_element_type (TREE_TYPE (desc
)),
857 tmp
= gfc_create_var (tmp
, "A");
858 /* If we're here only because of -fstack-arrays we have to
859 emit a DECL_EXPR to make the gimplifier emit alloca calls. */
860 if (!gfc_can_put_var_on_stack (size
))
861 gfc_add_expr_to_block (pre
,
862 fold_build1_loc (input_location
,
863 DECL_EXPR
, TREE_TYPE (tmp
),
865 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
866 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
870 /* Allocate memory to hold the data or call internal_pack. */
871 if (initial
== NULL_TREE
)
873 tmp
= gfc_call_malloc (pre
, NULL
, size
);
874 tmp
= gfc_evaluate_now (tmp
, pre
);
881 stmtblock_t do_copying
;
883 tmp
= TREE_TYPE (initial
); /* Pointer to descriptor. */
884 gcc_assert (TREE_CODE (tmp
) == POINTER_TYPE
);
885 tmp
= TREE_TYPE (tmp
); /* The descriptor itself. */
886 tmp
= gfc_get_element_type (tmp
);
887 gcc_assert (tmp
== gfc_get_element_type (TREE_TYPE (desc
)));
888 packed
= gfc_create_var (build_pointer_type (tmp
), "data");
890 tmp
= build_call_expr_loc (input_location
,
891 gfor_fndecl_in_pack
, 1, initial
);
892 tmp
= fold_convert (TREE_TYPE (packed
), tmp
);
893 gfc_add_modify (pre
, packed
, tmp
);
895 tmp
= build_fold_indirect_ref_loc (input_location
,
897 source_data
= gfc_conv_descriptor_data_get (tmp
);
899 /* internal_pack may return source->data without any allocation
900 or copying if it is already packed. If that's the case, we
901 need to allocate and copy manually. */
903 gfc_start_block (&do_copying
);
904 tmp
= gfc_call_malloc (&do_copying
, NULL
, size
);
905 tmp
= fold_convert (TREE_TYPE (packed
), tmp
);
906 gfc_add_modify (&do_copying
, packed
, tmp
);
907 tmp
= gfc_build_memcpy_call (packed
, source_data
, size
);
908 gfc_add_expr_to_block (&do_copying
, tmp
);
910 was_packed
= fold_build2_loc (input_location
, EQ_EXPR
,
911 boolean_type_node
, packed
,
913 tmp
= gfc_finish_block (&do_copying
);
914 tmp
= build3_v (COND_EXPR
, was_packed
, tmp
,
915 build_empty_stmt (input_location
));
916 gfc_add_expr_to_block (pre
, tmp
);
918 tmp
= fold_convert (pvoid_type_node
, packed
);
921 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
924 info
->data
= gfc_conv_descriptor_data_get (desc
);
926 /* The offset is zero because we create temporaries with a zero
928 gfc_conv_descriptor_offset_set (pre
, desc
, gfc_index_zero_node
);
930 if (dealloc
&& !onstack
)
932 /* Free the temporary. */
933 tmp
= gfc_conv_descriptor_data_get (desc
);
934 tmp
= gfc_call_free (fold_convert (pvoid_type_node
, tmp
));
935 gfc_add_expr_to_block (post
, tmp
);
940 /* Get the scalarizer array dimension corresponding to actual array dimension
943 For example, if SS represents the array ref a(1,:,:,1), it is a
944 bidimensional scalarizer array, and the result would be 0 for ARRAY_DIM=1,
945 and 1 for ARRAY_DIM=2.
946 If SS represents transpose(a(:,1,1,:)), it is again a bidimensional
947 scalarizer array, and the result would be 1 for ARRAY_DIM=0 and 0 for
949 If SS represents sum(a(:,:,:,1), dim=1), it is a 2+1-dimensional scalarizer
950 array. If called on the inner ss, the result would be respectively 0,1,2 for
951 ARRAY_DIM=0,1,2. If called on the outer ss, the result would be 0,1
952 for ARRAY_DIM=1,2. */
955 get_scalarizer_dim_for_array_dim (gfc_ss
*ss
, int array_dim
)
962 for (; ss
; ss
= ss
->parent
)
963 for (n
= 0; n
< ss
->dimen
; n
++)
964 if (ss
->dim
[n
] < array_dim
)
967 return array_ref_dim
;
972 innermost_ss (gfc_ss
*ss
)
974 while (ss
->nested_ss
!= NULL
)
982 /* Get the array reference dimension corresponding to the given loop dimension.
983 It is different from the true array dimension given by the dim array in
984 the case of a partial array reference (i.e. a(:,:,1,:) for example)
985 It is different from the loop dimension in the case of a transposed array.
989 get_array_ref_dim_for_loop_dim (gfc_ss
*ss
, int loop_dim
)
991 return get_scalarizer_dim_for_array_dim (innermost_ss (ss
),
996 /* Generate code to create and initialize the descriptor for a temporary
997 array. This is used for both temporaries needed by the scalarizer, and
998 functions returning arrays. Adjusts the loop variables to be
999 zero-based, and calculates the loop bounds for callee allocated arrays.
1000 Allocate the array unless it's callee allocated (we have a callee
1001 allocated array if 'callee_alloc' is true, or if loop->to[n] is
1002 NULL_TREE for any n). Also fills in the descriptor, data and offset
1003 fields of info if known. Returns the size of the array, or NULL for a
1004 callee allocated array.
1006 'eltype' == NULL signals that the temporary should be a class object.
1007 The 'initial' expression is used to obtain the size of the dynamic
1008 type; otherwise the allocation and initialization proceeds as for any
1011 PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
1012 gfc_trans_allocate_array_storage. */
1015 gfc_trans_create_temp_array (stmtblock_t
* pre
, stmtblock_t
* post
, gfc_ss
* ss
,
1016 tree eltype
, tree initial
, bool dynamic
,
1017 bool dealloc
, bool callee_alloc
, locus
* where
)
1021 gfc_array_info
*info
;
1022 tree from
[GFC_MAX_DIMENSIONS
], to
[GFC_MAX_DIMENSIONS
];
1030 tree class_expr
= NULL_TREE
;
1031 int n
, dim
, tmp_dim
;
1034 /* This signals a class array for which we need the size of the
1035 dynamic type. Generate an eltype and then the class expression. */
1036 if (eltype
== NULL_TREE
&& initial
)
1038 gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial
)));
1039 class_expr
= build_fold_indirect_ref_loc (input_location
, initial
);
1040 eltype
= TREE_TYPE (class_expr
);
1041 eltype
= gfc_get_element_type (eltype
);
1042 /* Obtain the structure (class) expression. */
1043 class_expr
= TREE_OPERAND (class_expr
, 0);
1044 gcc_assert (class_expr
);
1047 memset (from
, 0, sizeof (from
));
1048 memset (to
, 0, sizeof (to
));
1050 info
= &ss
->info
->data
.array
;
1052 gcc_assert (ss
->dimen
> 0);
1053 gcc_assert (ss
->loop
->dimen
== ss
->dimen
);
1055 if (warn_array_temporaries
&& where
)
1056 gfc_warning (OPT_Warray_temporaries
,
1057 "Creating array temporary at %L", where
);
1059 /* Set the lower bound to zero. */
1060 for (s
= ss
; s
; s
= s
->parent
)
1064 total_dim
+= loop
->dimen
;
1065 for (n
= 0; n
< loop
->dimen
; n
++)
1069 /* Callee allocated arrays may not have a known bound yet. */
1071 loop
->to
[n
] = gfc_evaluate_now (
1072 fold_build2_loc (input_location
, MINUS_EXPR
,
1073 gfc_array_index_type
,
1074 loop
->to
[n
], loop
->from
[n
]),
1076 loop
->from
[n
] = gfc_index_zero_node
;
1078 /* We have just changed the loop bounds, we must clear the
1079 corresponding specloop, so that delta calculation is not skipped
1080 later in gfc_set_delta. */
1081 loop
->specloop
[n
] = NULL
;
1083 /* We are constructing the temporary's descriptor based on the loop
1084 dimensions. As the dimensions may be accessed in arbitrary order
1085 (think of transpose) the size taken from the n'th loop may not map
1086 to the n'th dimension of the array. We need to reconstruct loop
1087 infos in the right order before using it to set the descriptor
1089 tmp_dim
= get_scalarizer_dim_for_array_dim (ss
, dim
);
1090 from
[tmp_dim
] = loop
->from
[n
];
1091 to
[tmp_dim
] = loop
->to
[n
];
1093 info
->delta
[dim
] = gfc_index_zero_node
;
1094 info
->start
[dim
] = gfc_index_zero_node
;
1095 info
->end
[dim
] = gfc_index_zero_node
;
1096 info
->stride
[dim
] = gfc_index_one_node
;
1100 /* Initialize the descriptor. */
1102 gfc_get_array_type_bounds (eltype
, total_dim
, 0, from
, to
, 1,
1103 GFC_ARRAY_UNKNOWN
, true);
1104 desc
= gfc_create_var (type
, "atmp");
1105 GFC_DECL_PACKED_ARRAY (desc
) = 1;
1107 info
->descriptor
= desc
;
1108 size
= gfc_index_one_node
;
1110 /* Fill in the array dtype. */
1111 tmp
= gfc_conv_descriptor_dtype (desc
);
1112 gfc_add_modify (pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
1115 Fill in the bounds and stride. This is a packed array, so:
1118 for (n = 0; n < rank; n++)
1121 delta = ubound[n] + 1 - lbound[n];
1122 size = size * delta;
1124 size = size * sizeof(element);
1127 or_expr
= NULL_TREE
;
1129 /* If there is at least one null loop->to[n], it is a callee allocated
1131 for (n
= 0; n
< total_dim
; n
++)
1132 if (to
[n
] == NULL_TREE
)
1138 if (size
== NULL_TREE
)
1139 for (s
= ss
; s
; s
= s
->parent
)
1140 for (n
= 0; n
< s
->loop
->dimen
; n
++)
1142 dim
= get_scalarizer_dim_for_array_dim (ss
, s
->dim
[n
]);
1144 /* For a callee allocated array express the loop bounds in terms
1145 of the descriptor fields. */
1146 tmp
= fold_build2_loc (input_location
,
1147 MINUS_EXPR
, gfc_array_index_type
,
1148 gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]),
1149 gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]));
1150 s
->loop
->to
[n
] = tmp
;
1154 for (n
= 0; n
< total_dim
; n
++)
1156 /* Store the stride and bound components in the descriptor. */
1157 gfc_conv_descriptor_stride_set (pre
, desc
, gfc_rank_cst
[n
], size
);
1159 gfc_conv_descriptor_lbound_set (pre
, desc
, gfc_rank_cst
[n
],
1160 gfc_index_zero_node
);
1162 gfc_conv_descriptor_ubound_set (pre
, desc
, gfc_rank_cst
[n
], to
[n
]);
1164 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1165 gfc_array_index_type
,
1166 to
[n
], gfc_index_one_node
);
1168 /* Check whether the size for this dimension is negative. */
1169 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
1170 tmp
, gfc_index_zero_node
);
1171 cond
= gfc_evaluate_now (cond
, pre
);
1176 or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1177 boolean_type_node
, or_expr
, cond
);
1179 size
= fold_build2_loc (input_location
, MULT_EXPR
,
1180 gfc_array_index_type
, size
, tmp
);
1181 size
= gfc_evaluate_now (size
, pre
);
1185 /* Get the size of the array. */
1186 if (size
&& !callee_alloc
)
1189 /* If or_expr is true, then the extent in at least one
1190 dimension is zero and the size is set to zero. */
1191 size
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
1192 or_expr
, gfc_index_zero_node
, size
);
1195 if (class_expr
== NULL_TREE
)
1196 elemsize
= fold_convert (gfc_array_index_type
,
1197 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
1199 elemsize
= gfc_class_vtab_size_get (class_expr
);
1201 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
1210 gfc_trans_allocate_array_storage (pre
, post
, info
, size
, nelem
, initial
,
1216 if (ss
->dimen
> ss
->loop
->temp_dim
)
1217 ss
->loop
->temp_dim
= ss
->dimen
;
1223 /* Return the number of iterations in a loop that starts at START,
1224 ends at END, and has step STEP. */
1227 gfc_get_iteration_count (tree start
, tree end
, tree step
)
1232 type
= TREE_TYPE (step
);
1233 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, end
, start
);
1234 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
, type
, tmp
, step
);
1235 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
,
1236 build_int_cst (type
, 1));
1237 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, type
, tmp
,
1238 build_int_cst (type
, 0));
1239 return fold_convert (gfc_array_index_type
, tmp
);
1243 /* Extend the data in array DESC by EXTRA elements. */
1246 gfc_grow_array (stmtblock_t
* pblock
, tree desc
, tree extra
)
1253 if (integer_zerop (extra
))
1256 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[0]);
1258 /* Add EXTRA to the upper bound. */
1259 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1261 gfc_conv_descriptor_ubound_set (pblock
, desc
, gfc_rank_cst
[0], tmp
);
1263 /* Get the value of the current data pointer. */
1264 arg0
= gfc_conv_descriptor_data_get (desc
);
1266 /* Calculate the new array size. */
1267 size
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
1268 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1269 ubound
, gfc_index_one_node
);
1270 arg1
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
1271 fold_convert (size_type_node
, tmp
),
1272 fold_convert (size_type_node
, size
));
1274 /* Call the realloc() function. */
1275 tmp
= gfc_call_realloc (pblock
, arg0
, arg1
);
1276 gfc_conv_descriptor_data_set (pblock
, desc
, tmp
);
1280 /* Return true if the bounds of iterator I can only be determined
1284 gfc_iterator_has_dynamic_bounds (gfc_iterator
* i
)
1286 return (i
->start
->expr_type
!= EXPR_CONSTANT
1287 || i
->end
->expr_type
!= EXPR_CONSTANT
1288 || i
->step
->expr_type
!= EXPR_CONSTANT
);
1292 /* Split the size of constructor element EXPR into the sum of two terms,
1293 one of which can be determined at compile time and one of which must
1294 be calculated at run time. Set *SIZE to the former and return true
1295 if the latter might be nonzero. */
1298 gfc_get_array_constructor_element_size (mpz_t
* size
, gfc_expr
* expr
)
1300 if (expr
->expr_type
== EXPR_ARRAY
)
1301 return gfc_get_array_constructor_size (size
, expr
->value
.constructor
);
1302 else if (expr
->rank
> 0)
1304 /* Calculate everything at run time. */
1305 mpz_set_ui (*size
, 0);
1310 /* A single element. */
1311 mpz_set_ui (*size
, 1);
1317 /* Like gfc_get_array_constructor_element_size, but applied to the whole
1318 of array constructor C. */
1321 gfc_get_array_constructor_size (mpz_t
* size
, gfc_constructor_base base
)
1329 mpz_set_ui (*size
, 0);
1334 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1337 if (i
&& gfc_iterator_has_dynamic_bounds (i
))
1341 dynamic
|= gfc_get_array_constructor_element_size (&len
, c
->expr
);
1344 /* Multiply the static part of the element size by the
1345 number of iterations. */
1346 mpz_sub (val
, i
->end
->value
.integer
, i
->start
->value
.integer
);
1347 mpz_fdiv_q (val
, val
, i
->step
->value
.integer
);
1348 mpz_add_ui (val
, val
, 1);
1349 if (mpz_sgn (val
) > 0)
1350 mpz_mul (len
, len
, val
);
1352 mpz_set_ui (len
, 0);
1354 mpz_add (*size
, *size
, len
);
1363 /* Make sure offset is a variable. */
1366 gfc_put_offset_into_var (stmtblock_t
* pblock
, tree
* poffset
,
1369 /* We should have already created the offset variable. We cannot
1370 create it here because we may be in an inner scope. */
1371 gcc_assert (*offsetvar
!= NULL_TREE
);
1372 gfc_add_modify (pblock
, *offsetvar
, *poffset
);
1373 *poffset
= *offsetvar
;
1374 TREE_USED (*offsetvar
) = 1;
1378 /* Variables needed for bounds-checking. */
1379 static bool first_len
;
1380 static tree first_len_val
;
1381 static bool typespec_chararray_ctor
;
1384 gfc_trans_array_ctor_element (stmtblock_t
* pblock
, tree desc
,
1385 tree offset
, gfc_se
* se
, gfc_expr
* expr
)
1389 gfc_conv_expr (se
, expr
);
1391 /* Store the value. */
1392 tmp
= build_fold_indirect_ref_loc (input_location
,
1393 gfc_conv_descriptor_data_get (desc
));
1394 tmp
= gfc_build_array_ref (tmp
, offset
, NULL
);
1396 if (expr
->ts
.type
== BT_CHARACTER
)
1398 int i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
1401 esize
= size_in_bytes (gfc_get_element_type (TREE_TYPE (desc
)));
1402 esize
= fold_convert (gfc_charlen_type_node
, esize
);
1403 esize
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1404 gfc_charlen_type_node
, esize
,
1405 build_int_cst (gfc_charlen_type_node
,
1406 gfc_character_kinds
[i
].bit_size
/ 8));
1408 gfc_conv_string_parameter (se
);
1409 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
1411 /* The temporary is an array of pointers. */
1412 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1413 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1417 /* The temporary is an array of string values. */
1418 tmp
= gfc_build_addr_expr (gfc_get_pchar_type (expr
->ts
.kind
), tmp
);
1419 /* We know the temporary and the value will be the same length,
1420 so can use memcpy. */
1421 gfc_trans_string_copy (&se
->pre
, esize
, tmp
, expr
->ts
.kind
,
1422 se
->string_length
, se
->expr
, expr
->ts
.kind
);
1424 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && !typespec_chararray_ctor
)
1428 gfc_add_modify (&se
->pre
, first_len_val
,
1434 /* Verify that all constructor elements are of the same
1436 tree cond
= fold_build2_loc (input_location
, NE_EXPR
,
1437 boolean_type_node
, first_len_val
,
1439 gfc_trans_runtime_check
1440 (true, false, cond
, &se
->pre
, &expr
->where
,
1441 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1442 fold_convert (long_integer_type_node
, first_len_val
),
1443 fold_convert (long_integer_type_node
, se
->string_length
));
1449 /* TODO: Should the frontend already have done this conversion? */
1450 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1451 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1454 gfc_add_block_to_block (pblock
, &se
->pre
);
1455 gfc_add_block_to_block (pblock
, &se
->post
);
1459 /* Add the contents of an array to the constructor. DYNAMIC is as for
1460 gfc_trans_array_constructor_value. */
1463 gfc_trans_array_constructor_subarray (stmtblock_t
* pblock
,
1464 tree type ATTRIBUTE_UNUSED
,
1465 tree desc
, gfc_expr
* expr
,
1466 tree
* poffset
, tree
* offsetvar
,
1477 /* We need this to be a variable so we can increment it. */
1478 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1480 gfc_init_se (&se
, NULL
);
1482 /* Walk the array expression. */
1483 ss
= gfc_walk_expr (expr
);
1484 gcc_assert (ss
!= gfc_ss_terminator
);
1486 /* Initialize the scalarizer. */
1487 gfc_init_loopinfo (&loop
);
1488 gfc_add_ss_to_loop (&loop
, ss
);
1490 /* Initialize the loop. */
1491 gfc_conv_ss_startstride (&loop
);
1492 gfc_conv_loop_setup (&loop
, &expr
->where
);
1494 /* Make sure the constructed array has room for the new data. */
1497 /* Set SIZE to the total number of elements in the subarray. */
1498 size
= gfc_index_one_node
;
1499 for (n
= 0; n
< loop
.dimen
; n
++)
1501 tmp
= gfc_get_iteration_count (loop
.from
[n
], loop
.to
[n
],
1502 gfc_index_one_node
);
1503 size
= fold_build2_loc (input_location
, MULT_EXPR
,
1504 gfc_array_index_type
, size
, tmp
);
1507 /* Grow the constructed array by SIZE elements. */
1508 gfc_grow_array (&loop
.pre
, desc
, size
);
1511 /* Make the loop body. */
1512 gfc_mark_ss_chain_used (ss
, 1);
1513 gfc_start_scalarized_body (&loop
, &body
);
1514 gfc_copy_loopinfo_to_se (&se
, &loop
);
1517 gfc_trans_array_ctor_element (&body
, desc
, *poffset
, &se
, expr
);
1518 gcc_assert (se
.ss
== gfc_ss_terminator
);
1520 /* Increment the offset. */
1521 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1522 *poffset
, gfc_index_one_node
);
1523 gfc_add_modify (&body
, *poffset
, tmp
);
1525 /* Finish the loop. */
1526 gfc_trans_scalarizing_loops (&loop
, &body
);
1527 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
1528 tmp
= gfc_finish_block (&loop
.pre
);
1529 gfc_add_expr_to_block (pblock
, tmp
);
1531 gfc_cleanup_loop (&loop
);
1535 /* Assign the values to the elements of an array constructor. DYNAMIC
1536 is true if descriptor DESC only contains enough data for the static
1537 size calculated by gfc_get_array_constructor_size. When true, memory
1538 for the dynamic parts must be allocated using realloc. */
1541 gfc_trans_array_constructor_value (stmtblock_t
* pblock
, tree type
,
1542 tree desc
, gfc_constructor_base base
,
1543 tree
* poffset
, tree
* offsetvar
,
1547 tree start
= NULL_TREE
;
1548 tree end
= NULL_TREE
;
1549 tree step
= NULL_TREE
;
1555 tree shadow_loopvar
= NULL_TREE
;
1556 gfc_saved_var saved_loopvar
;
1559 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1561 /* If this is an iterator or an array, the offset must be a variable. */
1562 if ((c
->iterator
|| c
->expr
->rank
> 0) && INTEGER_CST_P (*poffset
))
1563 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1565 /* Shadowing the iterator avoids changing its value and saves us from
1566 keeping track of it. Further, it makes sure that there's always a
1567 backend-decl for the symbol, even if there wasn't one before,
1568 e.g. in the case of an iterator that appears in a specification
1569 expression in an interface mapping. */
1575 /* Evaluate loop bounds before substituting the loop variable
1576 in case they depend on it. Such a case is invalid, but it is
1577 not more expensive to do the right thing here.
1579 gfc_init_se (&se
, NULL
);
1580 gfc_conv_expr_val (&se
, c
->iterator
->start
);
1581 gfc_add_block_to_block (pblock
, &se
.pre
);
1582 start
= gfc_evaluate_now (se
.expr
, pblock
);
1584 gfc_init_se (&se
, NULL
);
1585 gfc_conv_expr_val (&se
, c
->iterator
->end
);
1586 gfc_add_block_to_block (pblock
, &se
.pre
);
1587 end
= gfc_evaluate_now (se
.expr
, pblock
);
1589 gfc_init_se (&se
, NULL
);
1590 gfc_conv_expr_val (&se
, c
->iterator
->step
);
1591 gfc_add_block_to_block (pblock
, &se
.pre
);
1592 step
= gfc_evaluate_now (se
.expr
, pblock
);
1594 sym
= c
->iterator
->var
->symtree
->n
.sym
;
1595 type
= gfc_typenode_for_spec (&sym
->ts
);
1597 shadow_loopvar
= gfc_create_var (type
, "shadow_loopvar");
1598 gfc_shadow_sym (sym
, shadow_loopvar
, &saved_loopvar
);
1601 gfc_start_block (&body
);
1603 if (c
->expr
->expr_type
== EXPR_ARRAY
)
1605 /* Array constructors can be nested. */
1606 gfc_trans_array_constructor_value (&body
, type
, desc
,
1607 c
->expr
->value
.constructor
,
1608 poffset
, offsetvar
, dynamic
);
1610 else if (c
->expr
->rank
> 0)
1612 gfc_trans_array_constructor_subarray (&body
, type
, desc
, c
->expr
,
1613 poffset
, offsetvar
, dynamic
);
1617 /* This code really upsets the gimplifier so don't bother for now. */
1624 while (p
&& !(p
->iterator
|| p
->expr
->expr_type
!= EXPR_CONSTANT
))
1626 p
= gfc_constructor_next (p
);
1631 /* Scalar values. */
1632 gfc_init_se (&se
, NULL
);
1633 gfc_trans_array_ctor_element (&body
, desc
, *poffset
,
1636 *poffset
= fold_build2_loc (input_location
, PLUS_EXPR
,
1637 gfc_array_index_type
,
1638 *poffset
, gfc_index_one_node
);
1642 /* Collect multiple scalar constants into a constructor. */
1643 vec
<constructor_elt
, va_gc
> *v
= NULL
;
1647 HOST_WIDE_INT idx
= 0;
1650 /* Count the number of consecutive scalar constants. */
1651 while (p
&& !(p
->iterator
1652 || p
->expr
->expr_type
!= EXPR_CONSTANT
))
1654 gfc_init_se (&se
, NULL
);
1655 gfc_conv_constant (&se
, p
->expr
);
1657 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
1658 se
.expr
= fold_convert (type
, se
.expr
);
1659 /* For constant character array constructors we build
1660 an array of pointers. */
1661 else if (POINTER_TYPE_P (type
))
1662 se
.expr
= gfc_build_addr_expr
1663 (gfc_get_pchar_type (p
->expr
->ts
.kind
),
1666 CONSTRUCTOR_APPEND_ELT (v
,
1667 build_int_cst (gfc_array_index_type
,
1671 p
= gfc_constructor_next (p
);
1674 bound
= size_int (n
- 1);
1675 /* Create an array type to hold them. */
1676 tmptype
= build_range_type (gfc_array_index_type
,
1677 gfc_index_zero_node
, bound
);
1678 tmptype
= build_array_type (type
, tmptype
);
1680 init
= build_constructor (tmptype
, v
);
1681 TREE_CONSTANT (init
) = 1;
1682 TREE_STATIC (init
) = 1;
1683 /* Create a static variable to hold the data. */
1684 tmp
= gfc_create_var (tmptype
, "data");
1685 TREE_STATIC (tmp
) = 1;
1686 TREE_CONSTANT (tmp
) = 1;
1687 TREE_READONLY (tmp
) = 1;
1688 DECL_INITIAL (tmp
) = init
;
1691 /* Use BUILTIN_MEMCPY to assign the values. */
1692 tmp
= gfc_conv_descriptor_data_get (desc
);
1693 tmp
= build_fold_indirect_ref_loc (input_location
,
1695 tmp
= gfc_build_array_ref (tmp
, *poffset
, NULL
);
1696 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1697 init
= gfc_build_addr_expr (NULL_TREE
, init
);
1699 size
= TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type
));
1700 bound
= build_int_cst (size_type_node
, n
* size
);
1701 tmp
= build_call_expr_loc (input_location
,
1702 builtin_decl_explicit (BUILT_IN_MEMCPY
),
1703 3, tmp
, init
, bound
);
1704 gfc_add_expr_to_block (&body
, tmp
);
1706 *poffset
= fold_build2_loc (input_location
, PLUS_EXPR
,
1707 gfc_array_index_type
, *poffset
,
1708 build_int_cst (gfc_array_index_type
, n
));
1710 if (!INTEGER_CST_P (*poffset
))
1712 gfc_add_modify (&body
, *offsetvar
, *poffset
);
1713 *poffset
= *offsetvar
;
1717 /* The frontend should already have done any expansions
1721 /* Pass the code as is. */
1722 tmp
= gfc_finish_block (&body
);
1723 gfc_add_expr_to_block (pblock
, tmp
);
1727 /* Build the implied do-loop. */
1728 stmtblock_t implied_do_block
;
1734 loopbody
= gfc_finish_block (&body
);
1736 /* Create a new block that holds the implied-do loop. A temporary
1737 loop-variable is used. */
1738 gfc_start_block(&implied_do_block
);
1740 /* Initialize the loop. */
1741 gfc_add_modify (&implied_do_block
, shadow_loopvar
, start
);
1743 /* If this array expands dynamically, and the number of iterations
1744 is not constant, we won't have allocated space for the static
1745 part of C->EXPR's size. Do that now. */
1746 if (dynamic
&& gfc_iterator_has_dynamic_bounds (c
->iterator
))
1748 /* Get the number of iterations. */
1749 tmp
= gfc_get_iteration_count (shadow_loopvar
, end
, step
);
1751 /* Get the static part of C->EXPR's size. */
1752 gfc_get_array_constructor_element_size (&size
, c
->expr
);
1753 tmp2
= gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
1755 /* Grow the array by TMP * TMP2 elements. */
1756 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
1757 gfc_array_index_type
, tmp
, tmp2
);
1758 gfc_grow_array (&implied_do_block
, desc
, tmp
);
1761 /* Generate the loop body. */
1762 exit_label
= gfc_build_label_decl (NULL_TREE
);
1763 gfc_start_block (&body
);
1765 /* Generate the exit condition. Depending on the sign of
1766 the step variable we have to generate the correct
1768 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1769 step
, build_int_cst (TREE_TYPE (step
), 0));
1770 cond
= fold_build3_loc (input_location
, COND_EXPR
,
1771 boolean_type_node
, tmp
,
1772 fold_build2_loc (input_location
, GT_EXPR
,
1773 boolean_type_node
, shadow_loopvar
, end
),
1774 fold_build2_loc (input_location
, LT_EXPR
,
1775 boolean_type_node
, shadow_loopvar
, end
));
1776 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1777 TREE_USED (exit_label
) = 1;
1778 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
1779 build_empty_stmt (input_location
));
1780 gfc_add_expr_to_block (&body
, tmp
);
1782 /* The main loop body. */
1783 gfc_add_expr_to_block (&body
, loopbody
);
1785 /* Increase loop variable by step. */
1786 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1787 TREE_TYPE (shadow_loopvar
), shadow_loopvar
,
1789 gfc_add_modify (&body
, shadow_loopvar
, tmp
);
1791 /* Finish the loop. */
1792 tmp
= gfc_finish_block (&body
);
1793 tmp
= build1_v (LOOP_EXPR
, tmp
);
1794 gfc_add_expr_to_block (&implied_do_block
, tmp
);
1796 /* Add the exit label. */
1797 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1798 gfc_add_expr_to_block (&implied_do_block
, tmp
);
1800 /* Finish the implied-do loop. */
1801 tmp
= gfc_finish_block(&implied_do_block
);
1802 gfc_add_expr_to_block(pblock
, tmp
);
1804 gfc_restore_sym (c
->iterator
->var
->symtree
->n
.sym
, &saved_loopvar
);
1811 /* A catch-all to obtain the string length for anything that is not
1812 a substring of non-constant length, a constant, array or variable. */
1815 get_array_ctor_all_strlen (stmtblock_t
*block
, gfc_expr
*e
, tree
*len
)
1819 /* Don't bother if we already know the length is a constant. */
1820 if (*len
&& INTEGER_CST_P (*len
))
1823 if (!e
->ref
&& e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
1824 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1827 gfc_conv_const_charlen (e
->ts
.u
.cl
);
1828 *len
= e
->ts
.u
.cl
->backend_decl
;
1832 /* Otherwise, be brutal even if inefficient. */
1833 gfc_init_se (&se
, NULL
);
1835 /* No function call, in case of side effects. */
1836 se
.no_function_call
= 1;
1838 gfc_conv_expr (&se
, e
);
1840 gfc_conv_expr_descriptor (&se
, e
);
1842 /* Fix the value. */
1843 *len
= gfc_evaluate_now (se
.string_length
, &se
.pre
);
1845 gfc_add_block_to_block (block
, &se
.pre
);
1846 gfc_add_block_to_block (block
, &se
.post
);
1848 e
->ts
.u
.cl
->backend_decl
= *len
;
1853 /* Figure out the string length of a variable reference expression.
1854 Used by get_array_ctor_strlen. */
1857 get_array_ctor_var_strlen (stmtblock_t
*block
, gfc_expr
* expr
, tree
* len
)
1863 /* Don't bother if we already know the length is a constant. */
1864 if (*len
&& INTEGER_CST_P (*len
))
1867 ts
= &expr
->symtree
->n
.sym
->ts
;
1868 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1873 /* Array references don't change the string length. */
1877 /* Use the length of the component. */
1878 ts
= &ref
->u
.c
.component
->ts
;
1882 if (ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1883 || ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1885 /* Note that this might evaluate expr. */
1886 get_array_ctor_all_strlen (block
, expr
, len
);
1889 mpz_init_set_ui (char_len
, 1);
1890 mpz_add (char_len
, char_len
, ref
->u
.ss
.end
->value
.integer
);
1891 mpz_sub (char_len
, char_len
, ref
->u
.ss
.start
->value
.integer
);
1892 *len
= gfc_conv_mpz_to_tree (char_len
, gfc_default_integer_kind
);
1893 *len
= convert (gfc_charlen_type_node
, *len
);
1894 mpz_clear (char_len
);
1902 *len
= ts
->u
.cl
->backend_decl
;
1906 /* Figure out the string length of a character array constructor.
1907 If len is NULL, don't calculate the length; this happens for recursive calls
1908 when a sub-array-constructor is an element but not at the first position,
1909 so when we're not interested in the length.
1910 Returns TRUE if all elements are character constants. */
1913 get_array_ctor_strlen (stmtblock_t
*block
, gfc_constructor_base base
, tree
* len
)
1920 if (gfc_constructor_first (base
) == NULL
)
1923 *len
= build_int_cstu (gfc_charlen_type_node
, 0);
1927 /* Loop over all constructor elements to find out is_const, but in len we
1928 want to store the length of the first, not the last, element. We can
1929 of course exit the loop as soon as is_const is found to be false. */
1930 for (c
= gfc_constructor_first (base
);
1931 c
&& is_const
; c
= gfc_constructor_next (c
))
1933 switch (c
->expr
->expr_type
)
1936 if (len
&& !(*len
&& INTEGER_CST_P (*len
)))
1937 *len
= build_int_cstu (gfc_charlen_type_node
,
1938 c
->expr
->value
.character
.length
);
1942 if (!get_array_ctor_strlen (block
, c
->expr
->value
.constructor
, len
))
1949 get_array_ctor_var_strlen (block
, c
->expr
, len
);
1955 get_array_ctor_all_strlen (block
, c
->expr
, len
);
1959 /* After the first iteration, we don't want the length modified. */
1966 /* Check whether the array constructor C consists entirely of constant
1967 elements, and if so returns the number of those elements, otherwise
1968 return zero. Note, an empty or NULL array constructor returns zero. */
1970 unsigned HOST_WIDE_INT
1971 gfc_constant_array_constructor_p (gfc_constructor_base base
)
1973 unsigned HOST_WIDE_INT nelem
= 0;
1975 gfc_constructor
*c
= gfc_constructor_first (base
);
1979 || c
->expr
->rank
> 0
1980 || c
->expr
->expr_type
!= EXPR_CONSTANT
)
1982 c
= gfc_constructor_next (c
);
1989 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1990 and the tree type of it's elements, TYPE, return a static constant
1991 variable that is compile-time initialized. */
1994 gfc_build_constant_array_constructor (gfc_expr
* expr
, tree type
)
1996 tree tmptype
, init
, tmp
;
1997 HOST_WIDE_INT nelem
;
2002 vec
<constructor_elt
, va_gc
> *v
= NULL
;
2004 /* First traverse the constructor list, converting the constants
2005 to tree to build an initializer. */
2007 c
= gfc_constructor_first (expr
->value
.constructor
);
2010 gfc_init_se (&se
, NULL
);
2011 gfc_conv_constant (&se
, c
->expr
);
2012 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
2013 se
.expr
= fold_convert (type
, se
.expr
);
2014 else if (POINTER_TYPE_P (type
))
2015 se
.expr
= gfc_build_addr_expr (gfc_get_pchar_type (c
->expr
->ts
.kind
),
2017 CONSTRUCTOR_APPEND_ELT (v
, build_int_cst (gfc_array_index_type
, nelem
),
2019 c
= gfc_constructor_next (c
);
2023 /* Next determine the tree type for the array. We use the gfortran
2024 front-end's gfc_get_nodesc_array_type in order to create a suitable
2025 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
2027 memset (&as
, 0, sizeof (gfc_array_spec
));
2029 as
.rank
= expr
->rank
;
2030 as
.type
= AS_EXPLICIT
;
2033 as
.lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2034 as
.upper
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
2038 for (i
= 0; i
< expr
->rank
; i
++)
2040 int tmp
= (int) mpz_get_si (expr
->shape
[i
]);
2041 as
.lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2042 as
.upper
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
2046 tmptype
= gfc_get_nodesc_array_type (type
, &as
, PACKED_STATIC
, true);
2048 /* as is not needed anymore. */
2049 for (i
= 0; i
< as
.rank
+ as
.corank
; i
++)
2051 gfc_free_expr (as
.lower
[i
]);
2052 gfc_free_expr (as
.upper
[i
]);
2055 init
= build_constructor (tmptype
, v
);
2057 TREE_CONSTANT (init
) = 1;
2058 TREE_STATIC (init
) = 1;
2060 tmp
= build_decl (input_location
, VAR_DECL
, create_tmp_var_name ("A"),
2062 DECL_ARTIFICIAL (tmp
) = 1;
2063 DECL_IGNORED_P (tmp
) = 1;
2064 TREE_STATIC (tmp
) = 1;
2065 TREE_CONSTANT (tmp
) = 1;
2066 TREE_READONLY (tmp
) = 1;
2067 DECL_INITIAL (tmp
) = init
;
2074 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
2075 This mostly initializes the scalarizer state info structure with the
2076 appropriate values to directly use the array created by the function
2077 gfc_build_constant_array_constructor. */
2080 trans_constant_array_constructor (gfc_ss
* ss
, tree type
)
2082 gfc_array_info
*info
;
2086 tmp
= gfc_build_constant_array_constructor (ss
->info
->expr
, type
);
2088 info
= &ss
->info
->data
.array
;
2090 info
->descriptor
= tmp
;
2091 info
->data
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2092 info
->offset
= gfc_index_zero_node
;
2094 for (i
= 0; i
< ss
->dimen
; i
++)
2096 info
->delta
[i
] = gfc_index_zero_node
;
2097 info
->start
[i
] = gfc_index_zero_node
;
2098 info
->end
[i
] = gfc_index_zero_node
;
2099 info
->stride
[i
] = gfc_index_one_node
;
2105 get_rank (gfc_loopinfo
*loop
)
2110 for (; loop
; loop
= loop
->parent
)
2111 rank
+= loop
->dimen
;
2117 /* Helper routine of gfc_trans_array_constructor to determine if the
2118 bounds of the loop specified by LOOP are constant and simple enough
2119 to use with trans_constant_array_constructor. Returns the
2120 iteration count of the loop if suitable, and NULL_TREE otherwise. */
2123 constant_array_constructor_loop_size (gfc_loopinfo
* l
)
2126 tree size
= gfc_index_one_node
;
2130 total_dim
= get_rank (l
);
2132 for (loop
= l
; loop
; loop
= loop
->parent
)
2134 for (i
= 0; i
< loop
->dimen
; i
++)
2136 /* If the bounds aren't constant, return NULL_TREE. */
2137 if (!INTEGER_CST_P (loop
->from
[i
]) || !INTEGER_CST_P (loop
->to
[i
]))
2139 if (!integer_zerop (loop
->from
[i
]))
2141 /* Only allow nonzero "from" in one-dimensional arrays. */
2144 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2145 gfc_array_index_type
,
2146 loop
->to
[i
], loop
->from
[i
]);
2150 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2151 gfc_array_index_type
, tmp
, gfc_index_one_node
);
2152 size
= fold_build2_loc (input_location
, MULT_EXPR
,
2153 gfc_array_index_type
, size
, tmp
);
2162 get_loop_upper_bound_for_array (gfc_ss
*array
, int array_dim
)
2167 gcc_assert (array
->nested_ss
== NULL
);
2169 for (ss
= array
; ss
; ss
= ss
->parent
)
2170 for (n
= 0; n
< ss
->loop
->dimen
; n
++)
2171 if (array_dim
== get_array_ref_dim_for_loop_dim (ss
, n
))
2172 return &(ss
->loop
->to
[n
]);
2178 static gfc_loopinfo
*
2179 outermost_loop (gfc_loopinfo
* loop
)
2181 while (loop
->parent
!= NULL
)
2182 loop
= loop
->parent
;
2188 /* Array constructors are handled by constructing a temporary, then using that
2189 within the scalarization loop. This is not optimal, but seems by far the
2193 trans_array_constructor (gfc_ss
* ss
, locus
* where
)
2195 gfc_constructor_base c
;
2203 bool old_first_len
, old_typespec_chararray_ctor
;
2204 tree old_first_len_val
;
2205 gfc_loopinfo
*loop
, *outer_loop
;
2206 gfc_ss_info
*ss_info
;
2210 /* Save the old values for nested checking. */
2211 old_first_len
= first_len
;
2212 old_first_len_val
= first_len_val
;
2213 old_typespec_chararray_ctor
= typespec_chararray_ctor
;
2216 outer_loop
= outermost_loop (loop
);
2218 expr
= ss_info
->expr
;
2220 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
2221 typespec was given for the array constructor. */
2222 typespec_chararray_ctor
= (expr
->ts
.u
.cl
2223 && expr
->ts
.u
.cl
->length_from_typespec
);
2225 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2226 && expr
->ts
.type
== BT_CHARACTER
&& !typespec_chararray_ctor
)
2228 first_len_val
= gfc_create_var (gfc_charlen_type_node
, "len");
2232 gcc_assert (ss
->dimen
== ss
->loop
->dimen
);
2234 c
= expr
->value
.constructor
;
2235 if (expr
->ts
.type
== BT_CHARACTER
)
2239 /* get_array_ctor_strlen walks the elements of the constructor, if a
2240 typespec was given, we already know the string length and want the one
2242 if (typespec_chararray_ctor
&& expr
->ts
.u
.cl
->length
2243 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
2247 const_string
= false;
2248 gfc_init_se (&length_se
, NULL
);
2249 gfc_conv_expr_type (&length_se
, expr
->ts
.u
.cl
->length
,
2250 gfc_charlen_type_node
);
2251 ss_info
->string_length
= length_se
.expr
;
2252 gfc_add_block_to_block (&outer_loop
->pre
, &length_se
.pre
);
2253 gfc_add_block_to_block (&outer_loop
->post
, &length_se
.post
);
2256 const_string
= get_array_ctor_strlen (&outer_loop
->pre
, c
,
2257 &ss_info
->string_length
);
2259 /* Complex character array constructors should have been taken care of
2260 and not end up here. */
2261 gcc_assert (ss_info
->string_length
);
2263 expr
->ts
.u
.cl
->backend_decl
= ss_info
->string_length
;
2265 type
= gfc_get_character_type_len (expr
->ts
.kind
, ss_info
->string_length
);
2267 type
= build_pointer_type (type
);
2270 type
= gfc_typenode_for_spec (&expr
->ts
);
2272 /* See if the constructor determines the loop bounds. */
2275 loop_ubound0
= get_loop_upper_bound_for_array (ss
, 0);
2277 if (expr
->shape
&& get_rank (loop
) > 1 && *loop_ubound0
== NULL_TREE
)
2279 /* We have a multidimensional parameter. */
2280 for (s
= ss
; s
; s
= s
->parent
)
2283 for (n
= 0; n
< s
->loop
->dimen
; n
++)
2285 s
->loop
->from
[n
] = gfc_index_zero_node
;
2286 s
->loop
->to
[n
] = gfc_conv_mpz_to_tree (expr
->shape
[s
->dim
[n
]],
2287 gfc_index_integer_kind
);
2288 s
->loop
->to
[n
] = fold_build2_loc (input_location
, MINUS_EXPR
,
2289 gfc_array_index_type
,
2291 gfc_index_one_node
);
2296 if (*loop_ubound0
== NULL_TREE
)
2300 /* We should have a 1-dimensional, zero-based loop. */
2301 gcc_assert (loop
->parent
== NULL
&& loop
->nested
== NULL
);
2302 gcc_assert (loop
->dimen
== 1);
2303 gcc_assert (integer_zerop (loop
->from
[0]));
2305 /* Split the constructor size into a static part and a dynamic part.
2306 Allocate the static size up-front and record whether the dynamic
2307 size might be nonzero. */
2309 dynamic
= gfc_get_array_constructor_size (&size
, c
);
2310 mpz_sub_ui (size
, size
, 1);
2311 loop
->to
[0] = gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
2315 /* Special case constant array constructors. */
2318 unsigned HOST_WIDE_INT nelem
= gfc_constant_array_constructor_p (c
);
2321 tree size
= constant_array_constructor_loop_size (loop
);
2322 if (size
&& compare_tree_int (size
, nelem
) == 0)
2324 trans_constant_array_constructor (ss
, type
);
2330 gfc_trans_create_temp_array (&outer_loop
->pre
, &outer_loop
->post
, ss
, type
,
2331 NULL_TREE
, dynamic
, true, false, where
);
2333 desc
= ss_info
->data
.array
.descriptor
;
2334 offset
= gfc_index_zero_node
;
2335 offsetvar
= gfc_create_var_np (gfc_array_index_type
, "offset");
2336 TREE_NO_WARNING (offsetvar
) = 1;
2337 TREE_USED (offsetvar
) = 0;
2338 gfc_trans_array_constructor_value (&outer_loop
->pre
, type
, desc
, c
,
2339 &offset
, &offsetvar
, dynamic
);
2341 /* If the array grows dynamically, the upper bound of the loop variable
2342 is determined by the array's final upper bound. */
2345 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2346 gfc_array_index_type
,
2347 offsetvar
, gfc_index_one_node
);
2348 tmp
= gfc_evaluate_now (tmp
, &outer_loop
->pre
);
2349 gfc_conv_descriptor_ubound_set (&loop
->pre
, desc
, gfc_rank_cst
[0], tmp
);
2350 if (*loop_ubound0
&& TREE_CODE (*loop_ubound0
) == VAR_DECL
)
2351 gfc_add_modify (&outer_loop
->pre
, *loop_ubound0
, tmp
);
2353 *loop_ubound0
= tmp
;
2356 if (TREE_USED (offsetvar
))
2357 pushdecl (offsetvar
);
2359 gcc_assert (INTEGER_CST_P (offset
));
2362 /* Disable bound checking for now because it's probably broken. */
2363 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2370 /* Restore old values of globals. */
2371 first_len
= old_first_len
;
2372 first_len_val
= old_first_len_val
;
2373 typespec_chararray_ctor
= old_typespec_chararray_ctor
;
2377 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
2378 called after evaluating all of INFO's vector dimensions. Go through
2379 each such vector dimension and see if we can now fill in any missing
2383 set_vector_loop_bounds (gfc_ss
* ss
)
2385 gfc_loopinfo
*loop
, *outer_loop
;
2386 gfc_array_info
*info
;
2394 outer_loop
= outermost_loop (ss
->loop
);
2396 info
= &ss
->info
->data
.array
;
2398 for (; ss
; ss
= ss
->parent
)
2402 for (n
= 0; n
< loop
->dimen
; n
++)
2405 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_VECTOR
2406 || loop
->to
[n
] != NULL
)
2409 /* Loop variable N indexes vector dimension DIM, and we don't
2410 yet know the upper bound of loop variable N. Set it to the
2411 difference between the vector's upper and lower bounds. */
2412 gcc_assert (loop
->from
[n
] == gfc_index_zero_node
);
2413 gcc_assert (info
->subscript
[dim
]
2414 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
2416 gfc_init_se (&se
, NULL
);
2417 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
2418 zero
= gfc_rank_cst
[0];
2419 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2420 gfc_array_index_type
,
2421 gfc_conv_descriptor_ubound_get (desc
, zero
),
2422 gfc_conv_descriptor_lbound_get (desc
, zero
));
2423 tmp
= gfc_evaluate_now (tmp
, &outer_loop
->pre
);
2430 /* Add the pre and post chains for all the scalar expressions in a SS chain
2431 to loop. This is called after the loop parameters have been calculated,
2432 but before the actual scalarizing loops. */
2435 gfc_add_loop_ss_code (gfc_loopinfo
* loop
, gfc_ss
* ss
, bool subscript
,
2438 gfc_loopinfo
*nested_loop
, *outer_loop
;
2440 gfc_ss_info
*ss_info
;
2441 gfc_array_info
*info
;
2445 /* Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise,
2446 arguments could get evaluated multiple times. */
2447 if (ss
->is_alloc_lhs
)
2450 outer_loop
= outermost_loop (loop
);
2452 /* TODO: This can generate bad code if there are ordering dependencies,
2453 e.g., a callee allocated function and an unknown size constructor. */
2454 gcc_assert (ss
!= NULL
);
2456 for (; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2460 /* Cross loop arrays are handled from within the most nested loop. */
2461 if (ss
->nested_ss
!= NULL
)
2465 expr
= ss_info
->expr
;
2466 info
= &ss_info
->data
.array
;
2468 switch (ss_info
->type
)
2471 /* Scalar expression. Evaluate this now. This includes elemental
2472 dimension indices, but not array section bounds. */
2473 gfc_init_se (&se
, NULL
);
2474 gfc_conv_expr (&se
, expr
);
2475 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2477 if (expr
->ts
.type
!= BT_CHARACTER
2478 && !gfc_is_alloc_class_scalar_function (expr
))
2480 /* Move the evaluation of scalar expressions outside the
2481 scalarization loop, except for WHERE assignments. */
2483 se
.expr
= convert(gfc_array_index_type
, se
.expr
);
2484 if (!ss_info
->where
)
2485 se
.expr
= gfc_evaluate_now (se
.expr
, &outer_loop
->pre
);
2486 gfc_add_block_to_block (&outer_loop
->pre
, &se
.post
);
2489 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2491 ss_info
->data
.scalar
.value
= se
.expr
;
2492 ss_info
->string_length
= se
.string_length
;
2495 case GFC_SS_REFERENCE
:
2496 /* Scalar argument to elemental procedure. */
2497 gfc_init_se (&se
, NULL
);
2498 if (ss_info
->can_be_null_ref
|| (expr
->symtree
2499 && (expr
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
2500 || expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)))
2502 /* If the actual argument can be absent (in other words, it can
2503 be a NULL reference), don't try to evaluate it; pass instead
2504 the reference directly. The reference is also needed when
2505 expr is of type class or derived. */
2506 gfc_conv_expr_reference (&se
, expr
);
2510 /* Otherwise, evaluate the argument outside the loop and pass
2511 a reference to the value. */
2512 gfc_conv_expr (&se
, expr
);
2515 /* Ensure that a pointer to the string is stored. */
2516 if (expr
->ts
.type
== BT_CHARACTER
)
2517 gfc_conv_string_parameter (&se
);
2519 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2520 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2521 if (gfc_is_class_scalar_expr (expr
))
2522 /* This is necessary because the dynamic type will always be
2523 large than the declared type. In consequence, assigning
2524 the value to a temporary could segfault.
2525 OOP-TODO: see if this is generally correct or is the value
2526 has to be written to an allocated temporary, whose address
2527 is passed via ss_info. */
2528 ss_info
->data
.scalar
.value
= se
.expr
;
2530 ss_info
->data
.scalar
.value
= gfc_evaluate_now (se
.expr
,
2533 ss_info
->string_length
= se
.string_length
;
2536 case GFC_SS_SECTION
:
2537 /* Add the expressions for scalar and vector subscripts. */
2538 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2539 if (info
->subscript
[n
])
2540 gfc_add_loop_ss_code (loop
, info
->subscript
[n
], true, where
);
2542 set_vector_loop_bounds (ss
);
2546 /* Get the vector's descriptor and store it in SS. */
2547 gfc_init_se (&se
, NULL
);
2548 gfc_conv_expr_descriptor (&se
, expr
);
2549 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2550 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2551 info
->descriptor
= se
.expr
;
2554 case GFC_SS_INTRINSIC
:
2555 gfc_add_intrinsic_ss_code (loop
, ss
);
2558 case GFC_SS_FUNCTION
:
2559 /* Array function return value. We call the function and save its
2560 result in a temporary for use inside the loop. */
2561 gfc_init_se (&se
, NULL
);
2564 gfc_conv_expr (&se
, expr
);
2565 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2566 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2567 ss_info
->string_length
= se
.string_length
;
2570 case GFC_SS_CONSTRUCTOR
:
2571 if (expr
->ts
.type
== BT_CHARACTER
2572 && ss_info
->string_length
== NULL
2574 && expr
->ts
.u
.cl
->length
)
2576 gfc_init_se (&se
, NULL
);
2577 gfc_conv_expr_type (&se
, expr
->ts
.u
.cl
->length
,
2578 gfc_charlen_type_node
);
2579 ss_info
->string_length
= se
.expr
;
2580 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2581 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2583 trans_array_constructor (ss
, where
);
2587 case GFC_SS_COMPONENT
:
2588 /* Do nothing. These are handled elsewhere. */
2597 for (nested_loop
= loop
->nested
; nested_loop
;
2598 nested_loop
= nested_loop
->next
)
2599 gfc_add_loop_ss_code (nested_loop
, nested_loop
->ss
, subscript
, where
);
2603 /* Translate expressions for the descriptor and data pointer of a SS. */
2607 gfc_conv_ss_descriptor (stmtblock_t
* block
, gfc_ss
* ss
, int base
)
2610 gfc_ss_info
*ss_info
;
2611 gfc_array_info
*info
;
2615 info
= &ss_info
->data
.array
;
2617 /* Get the descriptor for the array to be scalarized. */
2618 gcc_assert (ss_info
->expr
->expr_type
== EXPR_VARIABLE
);
2619 gfc_init_se (&se
, NULL
);
2620 se
.descriptor_only
= 1;
2621 gfc_conv_expr_lhs (&se
, ss_info
->expr
);
2622 gfc_add_block_to_block (block
, &se
.pre
);
2623 info
->descriptor
= se
.expr
;
2624 ss_info
->string_length
= se
.string_length
;
2628 /* Also the data pointer. */
2629 tmp
= gfc_conv_array_data (se
.expr
);
2630 /* If this is a variable or address of a variable we use it directly.
2631 Otherwise we must evaluate it now to avoid breaking dependency
2632 analysis by pulling the expressions for elemental array indices
2635 || (TREE_CODE (tmp
) == ADDR_EXPR
2636 && DECL_P (TREE_OPERAND (tmp
, 0)))))
2637 tmp
= gfc_evaluate_now (tmp
, block
);
2640 tmp
= gfc_conv_array_offset (se
.expr
);
2641 info
->offset
= gfc_evaluate_now (tmp
, block
);
2643 /* Make absolutely sure that the saved_offset is indeed saved
2644 so that the variable is still accessible after the loops
2646 info
->saved_offset
= info
->offset
;
2651 /* Initialize a gfc_loopinfo structure. */
2654 gfc_init_loopinfo (gfc_loopinfo
* loop
)
2658 memset (loop
, 0, sizeof (gfc_loopinfo
));
2659 gfc_init_block (&loop
->pre
);
2660 gfc_init_block (&loop
->post
);
2662 /* Initially scalarize in order and default to no loop reversal. */
2663 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2666 loop
->reverse
[n
] = GFC_INHIBIT_REVERSE
;
2669 loop
->ss
= gfc_ss_terminator
;
2673 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2677 gfc_copy_loopinfo_to_se (gfc_se
* se
, gfc_loopinfo
* loop
)
2683 /* Return an expression for the data pointer of an array. */
2686 gfc_conv_array_data (tree descriptor
)
2690 type
= TREE_TYPE (descriptor
);
2691 if (GFC_ARRAY_TYPE_P (type
))
2693 if (TREE_CODE (type
) == POINTER_TYPE
)
2697 /* Descriptorless arrays. */
2698 return gfc_build_addr_expr (NULL_TREE
, descriptor
);
2702 return gfc_conv_descriptor_data_get (descriptor
);
2706 /* Return an expression for the base offset of an array. */
2709 gfc_conv_array_offset (tree descriptor
)
2713 type
= TREE_TYPE (descriptor
);
2714 if (GFC_ARRAY_TYPE_P (type
))
2715 return GFC_TYPE_ARRAY_OFFSET (type
);
2717 return gfc_conv_descriptor_offset_get (descriptor
);
2721 /* Get an expression for the array stride. */
2724 gfc_conv_array_stride (tree descriptor
, int dim
)
2729 type
= TREE_TYPE (descriptor
);
2731 /* For descriptorless arrays use the array size. */
2732 tmp
= GFC_TYPE_ARRAY_STRIDE (type
, dim
);
2733 if (tmp
!= NULL_TREE
)
2736 tmp
= gfc_conv_descriptor_stride_get (descriptor
, gfc_rank_cst
[dim
]);
2741 /* Like gfc_conv_array_stride, but for the lower bound. */
2744 gfc_conv_array_lbound (tree descriptor
, int dim
)
2749 type
= TREE_TYPE (descriptor
);
2751 tmp
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
2752 if (tmp
!= NULL_TREE
)
2755 tmp
= gfc_conv_descriptor_lbound_get (descriptor
, gfc_rank_cst
[dim
]);
2760 /* Like gfc_conv_array_stride, but for the upper bound. */
2763 gfc_conv_array_ubound (tree descriptor
, int dim
)
2768 type
= TREE_TYPE (descriptor
);
2770 tmp
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
2771 if (tmp
!= NULL_TREE
)
2774 /* This should only ever happen when passing an assumed shape array
2775 as an actual parameter. The value will never be used. */
2776 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor
)))
2777 return gfc_index_zero_node
;
2779 tmp
= gfc_conv_descriptor_ubound_get (descriptor
, gfc_rank_cst
[dim
]);
2784 /* Generate code to perform an array index bound check. */
2787 trans_array_bound_check (gfc_se
* se
, gfc_ss
*ss
, tree index
, int n
,
2788 locus
* where
, bool check_upper
)
2791 tree tmp_lo
, tmp_up
;
2794 const char * name
= NULL
;
2796 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
2799 descriptor
= ss
->info
->data
.array
.descriptor
;
2801 index
= gfc_evaluate_now (index
, &se
->pre
);
2803 /* We find a name for the error message. */
2804 name
= ss
->info
->expr
->symtree
->n
.sym
->name
;
2805 gcc_assert (name
!= NULL
);
2807 if (TREE_CODE (descriptor
) == VAR_DECL
)
2808 name
= IDENTIFIER_POINTER (DECL_NAME (descriptor
));
2810 /* If upper bound is present, include both bounds in the error message. */
2813 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
2814 tmp_up
= gfc_conv_array_ubound (descriptor
, n
);
2817 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
2818 "outside of expected range (%%ld:%%ld)", n
+1, name
);
2820 msg
= xasprintf ("Index '%%ld' of dimension %d "
2821 "outside of expected range (%%ld:%%ld)", n
+1);
2823 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2825 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2826 fold_convert (long_integer_type_node
, index
),
2827 fold_convert (long_integer_type_node
, tmp_lo
),
2828 fold_convert (long_integer_type_node
, tmp_up
));
2829 fault
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2831 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2832 fold_convert (long_integer_type_node
, index
),
2833 fold_convert (long_integer_type_node
, tmp_lo
),
2834 fold_convert (long_integer_type_node
, tmp_up
));
2839 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
2842 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
2843 "below lower bound of %%ld", n
+1, name
);
2845 msg
= xasprintf ("Index '%%ld' of dimension %d "
2846 "below lower bound of %%ld", n
+1);
2848 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2850 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2851 fold_convert (long_integer_type_node
, index
),
2852 fold_convert (long_integer_type_node
, tmp_lo
));
2860 /* Return the offset for an index. Performs bound checking for elemental
2861 dimensions. Single element references are processed separately.
2862 DIM is the array dimension, I is the loop dimension. */
2865 conv_array_index_offset (gfc_se
* se
, gfc_ss
* ss
, int dim
, int i
,
2866 gfc_array_ref
* ar
, tree stride
)
2868 gfc_array_info
*info
;
2873 info
= &ss
->info
->data
.array
;
2875 /* Get the index into the array for this dimension. */
2878 gcc_assert (ar
->type
!= AR_ELEMENT
);
2879 switch (ar
->dimen_type
[dim
])
2881 case DIMEN_THIS_IMAGE
:
2885 /* Elemental dimension. */
2886 gcc_assert (info
->subscript
[dim
]
2887 && info
->subscript
[dim
]->info
->type
== GFC_SS_SCALAR
);
2888 /* We've already translated this value outside the loop. */
2889 index
= info
->subscript
[dim
]->info
->data
.scalar
.value
;
2891 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
2892 ar
->as
->type
!= AS_ASSUMED_SIZE
2893 || dim
< ar
->dimen
- 1);
2897 gcc_assert (info
&& se
->loop
);
2898 gcc_assert (info
->subscript
[dim
]
2899 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
2900 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
2902 /* Get a zero-based index into the vector. */
2903 index
= fold_build2_loc (input_location
, MINUS_EXPR
,
2904 gfc_array_index_type
,
2905 se
->loop
->loopvar
[i
], se
->loop
->from
[i
]);
2907 /* Multiply the index by the stride. */
2908 index
= fold_build2_loc (input_location
, MULT_EXPR
,
2909 gfc_array_index_type
,
2910 index
, gfc_conv_array_stride (desc
, 0));
2912 /* Read the vector to get an index into info->descriptor. */
2913 data
= build_fold_indirect_ref_loc (input_location
,
2914 gfc_conv_array_data (desc
));
2915 index
= gfc_build_array_ref (data
, index
, NULL
);
2916 index
= gfc_evaluate_now (index
, &se
->pre
);
2917 index
= fold_convert (gfc_array_index_type
, index
);
2919 /* Do any bounds checking on the final info->descriptor index. */
2920 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
2921 ar
->as
->type
!= AS_ASSUMED_SIZE
2922 || dim
< ar
->dimen
- 1);
2926 /* Scalarized dimension. */
2927 gcc_assert (info
&& se
->loop
);
2929 /* Multiply the loop variable by the stride and delta. */
2930 index
= se
->loop
->loopvar
[i
];
2931 if (!integer_onep (info
->stride
[dim
]))
2932 index
= fold_build2_loc (input_location
, MULT_EXPR
,
2933 gfc_array_index_type
, index
,
2935 if (!integer_zerop (info
->delta
[dim
]))
2936 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
2937 gfc_array_index_type
, index
,
2947 /* Temporary array or derived type component. */
2948 gcc_assert (se
->loop
);
2949 index
= se
->loop
->loopvar
[se
->loop
->order
[i
]];
2951 /* Pointer functions can have stride[0] different from unity.
2952 Use the stride returned by the function call and stored in
2953 the descriptor for the temporary. */
2954 if (se
->ss
&& se
->ss
->info
->type
== GFC_SS_FUNCTION
2955 && se
->ss
->info
->expr
2956 && se
->ss
->info
->expr
->symtree
2957 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
2958 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
->attr
.pointer
)
2959 stride
= gfc_conv_descriptor_stride_get (info
->descriptor
,
2962 if (info
->delta
[dim
] && !integer_zerop (info
->delta
[dim
]))
2963 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
2964 gfc_array_index_type
, index
, info
->delta
[dim
]);
2967 /* Multiply by the stride. */
2968 if (!integer_onep (stride
))
2969 index
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
2976 /* Build a scalarized array reference using the vptr 'size'. */
2979 build_class_array_ref (gfc_se
*se
, tree base
, tree index
)
2986 gfc_expr
*expr
= se
->ss
->info
->expr
;
2992 || (expr
->ts
.type
!= BT_CLASS
2993 && !gfc_is_alloc_class_array_function (expr
)))
2996 if (expr
->symtree
&& expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
2997 ts
= &expr
->symtree
->n
.sym
->ts
;
3002 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3004 if (ref
->type
== REF_COMPONENT
3005 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
3006 && ref
->next
&& ref
->next
->type
== REF_COMPONENT
3007 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0
3009 && ref
->next
->next
->type
== REF_ARRAY
3010 && ref
->next
->next
->u
.ar
.type
!= AR_ELEMENT
)
3012 ts
= &ref
->u
.c
.component
->ts
;
3021 if (class_ref
== NULL
&& expr
->symtree
->n
.sym
->attr
.function
3022 && expr
->symtree
->n
.sym
== expr
->symtree
->n
.sym
->result
)
3024 gcc_assert (expr
->symtree
->n
.sym
->backend_decl
== current_function_decl
);
3025 decl
= gfc_get_fake_result_decl (expr
->symtree
->n
.sym
, 0);
3027 else if (gfc_is_alloc_class_array_function (expr
))
3031 for (tmp
= base
; tmp
; tmp
= TREE_OPERAND (tmp
, 0))
3034 type
= TREE_TYPE (tmp
);
3037 if (GFC_CLASS_TYPE_P (type
))
3039 if (type
!= TYPE_CANONICAL (type
))
3040 type
= TYPE_CANONICAL (type
);
3044 if (TREE_CODE (tmp
) == VAR_DECL
)
3048 if (decl
== NULL_TREE
)
3051 else if (class_ref
== NULL
)
3053 decl
= expr
->symtree
->n
.sym
->backend_decl
;
3054 /* For class arrays the tree containing the class is stored in
3055 GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl.
3056 For all others it's sym's backend_decl directly. */
3057 if (DECL_LANG_SPECIFIC (decl
) && GFC_DECL_SAVED_DESCRIPTOR (decl
))
3058 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
3062 /* Remove everything after the last class reference, convert the
3063 expression and then recover its tailend once more. */
3065 ref
= class_ref
->next
;
3066 class_ref
->next
= NULL
;
3067 gfc_init_se (&tmpse
, NULL
);
3068 gfc_conv_expr (&tmpse
, expr
);
3070 class_ref
->next
= ref
;
3073 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
3074 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
3076 if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl
)))
3079 size
= gfc_class_vtab_size_get (decl
);
3081 /* Build the address of the element. */
3082 type
= TREE_TYPE (TREE_TYPE (base
));
3083 size
= fold_convert (TREE_TYPE (index
), size
);
3084 offset
= fold_build2_loc (input_location
, MULT_EXPR
,
3085 gfc_array_index_type
,
3087 tmp
= gfc_build_addr_expr (pvoid_type_node
, base
);
3088 tmp
= fold_build_pointer_plus_loc (input_location
, tmp
, offset
);
3089 tmp
= fold_convert (build_pointer_type (type
), tmp
);
3091 /* Return the element in the se expression. */
3092 se
->expr
= build_fold_indirect_ref_loc (input_location
, tmp
);
3097 /* Build a scalarized reference to an array. */
3100 gfc_conv_scalarized_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
3102 gfc_array_info
*info
;
3103 tree decl
= NULL_TREE
;
3111 expr
= ss
->info
->expr
;
3112 info
= &ss
->info
->data
.array
;
3114 n
= se
->loop
->order
[0];
3118 index
= conv_array_index_offset (se
, ss
, ss
->dim
[n
], n
, ar
, info
->stride0
);
3119 /* Add the offset for this dimension to the stored offset for all other
3121 if (info
->offset
&& !integer_zerop (info
->offset
))
3122 index
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3123 index
, info
->offset
);
3125 if (expr
&& is_subref_array (expr
))
3126 decl
= expr
->symtree
->n
.sym
->backend_decl
;
3128 tmp
= build_fold_indirect_ref_loc (input_location
, info
->data
);
3130 /* Use the vptr 'size' field to access a class the element of a class
3132 if (build_class_array_ref (se
, tmp
, index
))
3135 se
->expr
= gfc_build_array_ref (tmp
, index
, decl
);
3139 /* Translate access of temporary array. */
3142 gfc_conv_tmp_array_ref (gfc_se
* se
)
3144 se
->string_length
= se
->ss
->info
->string_length
;
3145 gfc_conv_scalarized_array_ref (se
, NULL
);
3146 gfc_advance_se_ss_chain (se
);
3149 /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
3152 add_to_offset (tree
*cst_offset
, tree
*offset
, tree t
)
3154 if (TREE_CODE (t
) == INTEGER_CST
)
3155 *cst_offset
= int_const_binop (PLUS_EXPR
, *cst_offset
, t
);
3158 if (!integer_zerop (*offset
))
3159 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3160 gfc_array_index_type
, *offset
, t
);
3168 build_array_ref (tree desc
, tree offset
, tree decl
, tree vptr
)
3173 bool classarray
= false;
3175 /* For class arrays the class declaration is stored in the saved
3177 if (INDIRECT_REF_P (desc
)
3178 && DECL_LANG_SPECIFIC (TREE_OPERAND (desc
, 0))
3179 && GFC_DECL_SAVED_DESCRIPTOR (TREE_OPERAND (desc
, 0)))
3180 cdecl = gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (
3181 TREE_OPERAND (desc
, 0)));
3185 /* Class container types do not always have the GFC_CLASS_TYPE_P
3186 but the canonical type does. */
3187 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdecl))
3188 && TREE_CODE (cdecl) == COMPONENT_REF
)
3190 type
= TREE_TYPE (TREE_OPERAND (cdecl, 0));
3191 if (TYPE_CANONICAL (type
)
3192 && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type
)))
3194 type
= TREE_TYPE (desc
);
3201 /* Class array references need special treatment because the assigned
3202 type size needs to be used to point to the element. */
3205 type
= gfc_get_element_type (type
);
3206 tmp
= TREE_OPERAND (cdecl, 0);
3207 tmp
= gfc_get_class_array_ref (offset
, tmp
);
3208 tmp
= fold_convert (build_pointer_type (type
), tmp
);
3209 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3213 tmp
= gfc_conv_array_data (desc
);
3214 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3215 tmp
= gfc_build_array_ref (tmp
, offset
, decl
, vptr
);
3220 /* Build an array reference. se->expr already holds the array descriptor.
3221 This should be either a variable, indirect variable reference or component
3222 reference. For arrays which do not have a descriptor, se->expr will be
3224 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
3227 gfc_conv_array_ref (gfc_se
* se
, gfc_array_ref
* ar
, gfc_expr
*expr
,
3231 tree offset
, cst_offset
;
3236 gfc_symbol
* sym
= expr
->symtree
->n
.sym
;
3237 char *var_name
= NULL
;
3241 gcc_assert (ar
->codimen
);
3243 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
->expr
)))
3244 se
->expr
= build_fold_indirect_ref (gfc_conv_array_data (se
->expr
));
3247 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se
->expr
))
3248 && TREE_CODE (TREE_TYPE (se
->expr
)) == POINTER_TYPE
)
3249 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3251 /* Use the actual tree type and not the wrapped coarray. */
3252 if (!se
->want_pointer
)
3253 se
->expr
= fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se
->expr
)),
3260 /* Handle scalarized references separately. */
3261 if (ar
->type
!= AR_ELEMENT
)
3263 gfc_conv_scalarized_array_ref (se
, ar
);
3264 gfc_advance_se_ss_chain (se
);
3268 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3273 len
= strlen (sym
->name
) + 1;
3274 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3276 if (ref
->type
== REF_ARRAY
&& &ref
->u
.ar
== ar
)
3278 if (ref
->type
== REF_COMPONENT
)
3279 len
+= 1 + strlen (ref
->u
.c
.component
->name
);
3282 var_name
= XALLOCAVEC (char, len
);
3283 strcpy (var_name
, sym
->name
);
3285 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3287 if (ref
->type
== REF_ARRAY
&& &ref
->u
.ar
== ar
)
3289 if (ref
->type
== REF_COMPONENT
)
3291 strcat (var_name
, "%%");
3292 strcat (var_name
, ref
->u
.c
.component
->name
);
3297 cst_offset
= offset
= gfc_index_zero_node
;
3298 add_to_offset (&cst_offset
, &offset
, gfc_conv_array_offset (se
->expr
));
3300 /* Calculate the offsets from all the dimensions. Make sure to associate
3301 the final offset so that we form a chain of loop invariant summands. */
3302 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
3304 /* Calculate the index for this dimension. */
3305 gfc_init_se (&indexse
, se
);
3306 gfc_conv_expr_type (&indexse
, ar
->start
[n
], gfc_array_index_type
);
3307 gfc_add_block_to_block (&se
->pre
, &indexse
.pre
);
3309 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3311 /* Check array bounds. */
3315 /* Evaluate the indexse.expr only once. */
3316 indexse
.expr
= save_expr (indexse
.expr
);
3319 tmp
= gfc_conv_array_lbound (se
->expr
, n
);
3320 if (sym
->attr
.temporary
)
3322 gfc_init_se (&tmpse
, se
);
3323 gfc_conv_expr_type (&tmpse
, ar
->as
->lower
[n
],
3324 gfc_array_index_type
);
3325 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3329 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
3331 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3332 "below lower bound of %%ld", n
+1, var_name
);
3333 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3334 fold_convert (long_integer_type_node
,
3336 fold_convert (long_integer_type_node
, tmp
));
3339 /* Upper bound, but not for the last dimension of assumed-size
3341 if (n
< ar
->dimen
- 1 || ar
->as
->type
!= AS_ASSUMED_SIZE
)
3343 tmp
= gfc_conv_array_ubound (se
->expr
, n
);
3344 if (sym
->attr
.temporary
)
3346 gfc_init_se (&tmpse
, se
);
3347 gfc_conv_expr_type (&tmpse
, ar
->as
->upper
[n
],
3348 gfc_array_index_type
);
3349 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3353 cond
= fold_build2_loc (input_location
, GT_EXPR
,
3354 boolean_type_node
, indexse
.expr
, tmp
);
3355 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3356 "above upper bound of %%ld", n
+1, var_name
);
3357 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3358 fold_convert (long_integer_type_node
,
3360 fold_convert (long_integer_type_node
, tmp
));
3365 /* Multiply the index by the stride. */
3366 stride
= gfc_conv_array_stride (se
->expr
, n
);
3367 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3368 indexse
.expr
, stride
);
3370 /* And add it to the total. */
3371 add_to_offset (&cst_offset
, &offset
, tmp
);
3374 if (!integer_zerop (cst_offset
))
3375 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3376 gfc_array_index_type
, offset
, cst_offset
);
3378 se
->expr
= build_array_ref (se
->expr
, offset
, sym
->ts
.type
== BT_CLASS
?
3379 NULL_TREE
: sym
->backend_decl
, se
->class_vptr
);
3383 /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
3384 LOOP_DIM dimension (if any) to array's offset. */
3387 add_array_offset (stmtblock_t
*pblock
, gfc_loopinfo
*loop
, gfc_ss
*ss
,
3388 gfc_array_ref
*ar
, int array_dim
, int loop_dim
)
3391 gfc_array_info
*info
;
3394 info
= &ss
->info
->data
.array
;
3396 gfc_init_se (&se
, NULL
);
3398 se
.expr
= info
->descriptor
;
3399 stride
= gfc_conv_array_stride (info
->descriptor
, array_dim
);
3400 index
= conv_array_index_offset (&se
, ss
, array_dim
, loop_dim
, ar
, stride
);
3401 gfc_add_block_to_block (pblock
, &se
.pre
);
3403 info
->offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3404 gfc_array_index_type
,
3405 info
->offset
, index
);
3406 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
3410 /* Generate the code to be executed immediately before entering a
3411 scalarization loop. */
3414 gfc_trans_preloop_setup (gfc_loopinfo
* loop
, int dim
, int flag
,
3415 stmtblock_t
* pblock
)
3418 gfc_ss_info
*ss_info
;
3419 gfc_array_info
*info
;
3420 gfc_ss_type ss_type
;
3422 gfc_loopinfo
*ploop
;
3426 /* This code will be executed before entering the scalarization loop
3427 for this dimension. */
3428 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3432 if ((ss_info
->useflags
& flag
) == 0)
3435 ss_type
= ss_info
->type
;
3436 if (ss_type
!= GFC_SS_SECTION
3437 && ss_type
!= GFC_SS_FUNCTION
3438 && ss_type
!= GFC_SS_CONSTRUCTOR
3439 && ss_type
!= GFC_SS_COMPONENT
)
3442 info
= &ss_info
->data
.array
;
3444 gcc_assert (dim
< ss
->dimen
);
3445 gcc_assert (ss
->dimen
== loop
->dimen
);
3448 ar
= &info
->ref
->u
.ar
;
3452 if (dim
== loop
->dimen
- 1 && loop
->parent
!= NULL
)
3454 /* If we are in the outermost dimension of this loop, the previous
3455 dimension shall be in the parent loop. */
3456 gcc_assert (ss
->parent
!= NULL
);
3459 ploop
= loop
->parent
;
3461 /* ss and ss->parent are about the same array. */
3462 gcc_assert (ss_info
== pss
->info
);
3470 if (dim
== loop
->dimen
- 1)
3475 /* For the time being, there is no loop reordering. */
3476 gcc_assert (i
== ploop
->order
[i
]);
3477 i
= ploop
->order
[i
];
3479 if (dim
== loop
->dimen
- 1 && loop
->parent
== NULL
)
3481 stride
= gfc_conv_array_stride (info
->descriptor
,
3482 innermost_ss (ss
)->dim
[i
]);
3484 /* Calculate the stride of the innermost loop. Hopefully this will
3485 allow the backend optimizers to do their stuff more effectively.
3487 info
->stride0
= gfc_evaluate_now (stride
, pblock
);
3489 /* For the outermost loop calculate the offset due to any
3490 elemental dimensions. It will have been initialized with the
3491 base offset of the array. */
3494 for (i
= 0; i
< ar
->dimen
; i
++)
3496 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
3499 add_array_offset (pblock
, loop
, ss
, ar
, i
, /* unused */ -1);
3504 /* Add the offset for the previous loop dimension. */
3505 add_array_offset (pblock
, ploop
, ss
, ar
, pss
->dim
[i
], i
);
3507 /* Remember this offset for the second loop. */
3508 if (dim
== loop
->temp_dim
- 1 && loop
->parent
== NULL
)
3509 info
->saved_offset
= info
->offset
;
3514 /* Start a scalarized expression. Creates a scope and declares loop
3518 gfc_start_scalarized_body (gfc_loopinfo
* loop
, stmtblock_t
* pbody
)
3524 gcc_assert (!loop
->array_parameter
);
3526 for (dim
= loop
->dimen
- 1; dim
>= 0; dim
--)
3528 n
= loop
->order
[dim
];
3530 gfc_start_block (&loop
->code
[n
]);
3532 /* Create the loop variable. */
3533 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "S");
3535 if (dim
< loop
->temp_dim
)
3539 /* Calculate values that will be constant within this loop. */
3540 gfc_trans_preloop_setup (loop
, dim
, flags
, &loop
->code
[n
]);
3542 gfc_start_block (pbody
);
3546 /* Generates the actual loop code for a scalarization loop. */
3549 gfc_trans_scalarized_loop_end (gfc_loopinfo
* loop
, int n
,
3550 stmtblock_t
* pbody
)
3561 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
))
3562 == (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
)
3563 && n
== loop
->dimen
- 1)
3565 /* We create an OMP_FOR construct for the outermost scalarized loop. */
3566 init
= make_tree_vec (1);
3567 cond
= make_tree_vec (1);
3568 incr
= make_tree_vec (1);
3570 /* Cycle statement is implemented with a goto. Exit statement must not
3571 be present for this loop. */
3572 exit_label
= gfc_build_label_decl (NULL_TREE
);
3573 TREE_USED (exit_label
) = 1;
3575 /* Label for cycle statements (if needed). */
3576 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3577 gfc_add_expr_to_block (pbody
, tmp
);
3579 stmt
= make_node (OMP_FOR
);
3581 TREE_TYPE (stmt
) = void_type_node
;
3582 OMP_FOR_BODY (stmt
) = loopbody
= gfc_finish_block (pbody
);
3584 OMP_FOR_CLAUSES (stmt
) = build_omp_clause (input_location
,
3585 OMP_CLAUSE_SCHEDULE
);
3586 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt
))
3587 = OMP_CLAUSE_SCHEDULE_STATIC
;
3588 if (ompws_flags
& OMPWS_NOWAIT
)
3589 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt
))
3590 = build_omp_clause (input_location
, OMP_CLAUSE_NOWAIT
);
3592 /* Initialize the loopvar. */
3593 TREE_VEC_ELT (init
, 0) = build2_v (MODIFY_EXPR
, loop
->loopvar
[n
],
3595 OMP_FOR_INIT (stmt
) = init
;
3596 /* The exit condition. */
3597 TREE_VEC_ELT (cond
, 0) = build2_loc (input_location
, LE_EXPR
,
3599 loop
->loopvar
[n
], loop
->to
[n
]);
3600 SET_EXPR_LOCATION (TREE_VEC_ELT (cond
, 0), input_location
);
3601 OMP_FOR_COND (stmt
) = cond
;
3602 /* Increment the loopvar. */
3603 tmp
= build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3604 loop
->loopvar
[n
], gfc_index_one_node
);
3605 TREE_VEC_ELT (incr
, 0) = fold_build2_loc (input_location
, MODIFY_EXPR
,
3606 void_type_node
, loop
->loopvar
[n
], tmp
);
3607 OMP_FOR_INCR (stmt
) = incr
;
3609 ompws_flags
&= ~OMPWS_CURR_SINGLEUNIT
;
3610 gfc_add_expr_to_block (&loop
->code
[n
], stmt
);
3614 bool reverse_loop
= (loop
->reverse
[n
] == GFC_REVERSE_SET
)
3615 && (loop
->temp_ss
== NULL
);
3617 loopbody
= gfc_finish_block (pbody
);
3621 tmp
= loop
->from
[n
];
3622 loop
->from
[n
] = loop
->to
[n
];
3626 /* Initialize the loopvar. */
3627 if (loop
->loopvar
[n
] != loop
->from
[n
])
3628 gfc_add_modify (&loop
->code
[n
], loop
->loopvar
[n
], loop
->from
[n
]);
3630 exit_label
= gfc_build_label_decl (NULL_TREE
);
3632 /* Generate the loop body. */
3633 gfc_init_block (&block
);
3635 /* The exit condition. */
3636 cond
= fold_build2_loc (input_location
, reverse_loop
? LT_EXPR
: GT_EXPR
,
3637 boolean_type_node
, loop
->loopvar
[n
], loop
->to
[n
]);
3638 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3639 TREE_USED (exit_label
) = 1;
3640 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3641 gfc_add_expr_to_block (&block
, tmp
);
3643 /* The main body. */
3644 gfc_add_expr_to_block (&block
, loopbody
);
3646 /* Increment the loopvar. */
3647 tmp
= fold_build2_loc (input_location
,
3648 reverse_loop
? MINUS_EXPR
: PLUS_EXPR
,
3649 gfc_array_index_type
, loop
->loopvar
[n
],
3650 gfc_index_one_node
);
3652 gfc_add_modify (&block
, loop
->loopvar
[n
], tmp
);
3654 /* Build the loop. */
3655 tmp
= gfc_finish_block (&block
);
3656 tmp
= build1_v (LOOP_EXPR
, tmp
);
3657 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
3659 /* Add the exit label. */
3660 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3661 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
3667 /* Finishes and generates the loops for a scalarized expression. */
3670 gfc_trans_scalarizing_loops (gfc_loopinfo
* loop
, stmtblock_t
* body
)
3675 stmtblock_t
*pblock
;
3679 /* Generate the loops. */
3680 for (dim
= 0; dim
< loop
->dimen
; dim
++)
3682 n
= loop
->order
[dim
];
3683 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
3684 loop
->loopvar
[n
] = NULL_TREE
;
3685 pblock
= &loop
->code
[n
];
3688 tmp
= gfc_finish_block (pblock
);
3689 gfc_add_expr_to_block (&loop
->pre
, tmp
);
3691 /* Clear all the used flags. */
3692 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3693 if (ss
->parent
== NULL
)
3694 ss
->info
->useflags
= 0;
3698 /* Finish the main body of a scalarized expression, and start the secondary
3702 gfc_trans_scalarized_loop_boundary (gfc_loopinfo
* loop
, stmtblock_t
* body
)
3706 stmtblock_t
*pblock
;
3710 /* We finish as many loops as are used by the temporary. */
3711 for (dim
= 0; dim
< loop
->temp_dim
- 1; dim
++)
3713 n
= loop
->order
[dim
];
3714 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
3715 loop
->loopvar
[n
] = NULL_TREE
;
3716 pblock
= &loop
->code
[n
];
3719 /* We don't want to finish the outermost loop entirely. */
3720 n
= loop
->order
[loop
->temp_dim
- 1];
3721 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
3723 /* Restore the initial offsets. */
3724 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3726 gfc_ss_type ss_type
;
3727 gfc_ss_info
*ss_info
;
3731 if ((ss_info
->useflags
& 2) == 0)
3734 ss_type
= ss_info
->type
;
3735 if (ss_type
!= GFC_SS_SECTION
3736 && ss_type
!= GFC_SS_FUNCTION
3737 && ss_type
!= GFC_SS_CONSTRUCTOR
3738 && ss_type
!= GFC_SS_COMPONENT
)
3741 ss_info
->data
.array
.offset
= ss_info
->data
.array
.saved_offset
;
3744 /* Restart all the inner loops we just finished. */
3745 for (dim
= loop
->temp_dim
- 2; dim
>= 0; dim
--)
3747 n
= loop
->order
[dim
];
3749 gfc_start_block (&loop
->code
[n
]);
3751 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "Q");
3753 gfc_trans_preloop_setup (loop
, dim
, 2, &loop
->code
[n
]);
3756 /* Start a block for the secondary copying code. */
3757 gfc_start_block (body
);
3761 /* Precalculate (either lower or upper) bound of an array section.
3762 BLOCK: Block in which the (pre)calculation code will go.
3763 BOUNDS[DIM]: Where the bound value will be stored once evaluated.
3764 VALUES[DIM]: Specified bound (NULL <=> unspecified).
3765 DESC: Array descriptor from which the bound will be picked if unspecified
3766 (either lower or upper bound according to LBOUND). */
3769 evaluate_bound (stmtblock_t
*block
, tree
*bounds
, gfc_expr
** values
,
3770 tree desc
, int dim
, bool lbound
)
3773 gfc_expr
* input_val
= values
[dim
];
3774 tree
*output
= &bounds
[dim
];
3779 /* Specified section bound. */
3780 gfc_init_se (&se
, NULL
);
3781 gfc_conv_expr_type (&se
, input_val
, gfc_array_index_type
);
3782 gfc_add_block_to_block (block
, &se
.pre
);
3787 /* No specific bound specified so use the bound of the array. */
3788 *output
= lbound
? gfc_conv_array_lbound (desc
, dim
) :
3789 gfc_conv_array_ubound (desc
, dim
);
3791 *output
= gfc_evaluate_now (*output
, block
);
3795 /* Calculate the lower bound of an array section. */
3798 gfc_conv_section_startstride (stmtblock_t
* block
, gfc_ss
* ss
, int dim
)
3800 gfc_expr
*stride
= NULL
;
3803 gfc_array_info
*info
;
3806 gcc_assert (ss
->info
->type
== GFC_SS_SECTION
);
3808 info
= &ss
->info
->data
.array
;
3809 ar
= &info
->ref
->u
.ar
;
3811 if (ar
->dimen_type
[dim
] == DIMEN_VECTOR
)
3813 /* We use a zero-based index to access the vector. */
3814 info
->start
[dim
] = gfc_index_zero_node
;
3815 info
->end
[dim
] = NULL
;
3816 info
->stride
[dim
] = gfc_index_one_node
;
3820 gcc_assert (ar
->dimen_type
[dim
] == DIMEN_RANGE
3821 || ar
->dimen_type
[dim
] == DIMEN_THIS_IMAGE
);
3822 desc
= info
->descriptor
;
3823 stride
= ar
->stride
[dim
];
3825 /* Calculate the start of the range. For vector subscripts this will
3826 be the range of the vector. */
3827 evaluate_bound (block
, info
->start
, ar
->start
, desc
, dim
, true);
3829 /* Similarly calculate the end. Although this is not used in the
3830 scalarizer, it is needed when checking bounds and where the end
3831 is an expression with side-effects. */
3832 evaluate_bound (block
, info
->end
, ar
->end
, desc
, dim
, false);
3834 /* Calculate the stride. */
3836 info
->stride
[dim
] = gfc_index_one_node
;
3839 gfc_init_se (&se
, NULL
);
3840 gfc_conv_expr_type (&se
, stride
, gfc_array_index_type
);
3841 gfc_add_block_to_block (block
, &se
.pre
);
3842 info
->stride
[dim
] = gfc_evaluate_now (se
.expr
, block
);
3847 /* Calculates the range start and stride for a SS chain. Also gets the
3848 descriptor and data pointer. The range of vector subscripts is the size
3849 of the vector. Array bounds are also checked. */
3852 gfc_conv_ss_startstride (gfc_loopinfo
* loop
)
3859 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
3862 /* Determine the rank of the loop. */
3863 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3865 switch (ss
->info
->type
)
3867 case GFC_SS_SECTION
:
3868 case GFC_SS_CONSTRUCTOR
:
3869 case GFC_SS_FUNCTION
:
3870 case GFC_SS_COMPONENT
:
3871 loop
->dimen
= ss
->dimen
;
3874 /* As usual, lbound and ubound are exceptions!. */
3875 case GFC_SS_INTRINSIC
:
3876 switch (ss
->info
->expr
->value
.function
.isym
->id
)
3878 case GFC_ISYM_LBOUND
:
3879 case GFC_ISYM_UBOUND
:
3880 case GFC_ISYM_LCOBOUND
:
3881 case GFC_ISYM_UCOBOUND
:
3882 case GFC_ISYM_THIS_IMAGE
:
3883 loop
->dimen
= ss
->dimen
;
3895 /* We should have determined the rank of the expression by now. If
3896 not, that's bad news. */
3900 /* Loop over all the SS in the chain. */
3901 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3903 gfc_ss_info
*ss_info
;
3904 gfc_array_info
*info
;
3908 expr
= ss_info
->expr
;
3909 info
= &ss_info
->data
.array
;
3911 if (expr
&& expr
->shape
&& !info
->shape
)
3912 info
->shape
= expr
->shape
;
3914 switch (ss_info
->type
)
3916 case GFC_SS_SECTION
:
3917 /* Get the descriptor for the array. If it is a cross loops array,
3918 we got the descriptor already in the outermost loop. */
3919 if (ss
->parent
== NULL
)
3920 gfc_conv_ss_descriptor (&outer_loop
->pre
, ss
,
3921 !loop
->array_parameter
);
3923 for (n
= 0; n
< ss
->dimen
; n
++)
3924 gfc_conv_section_startstride (&outer_loop
->pre
, ss
, ss
->dim
[n
]);
3927 case GFC_SS_INTRINSIC
:
3928 switch (expr
->value
.function
.isym
->id
)
3930 /* Fall through to supply start and stride. */
3931 case GFC_ISYM_LBOUND
:
3932 case GFC_ISYM_UBOUND
:
3936 /* This is the variant without DIM=... */
3937 gcc_assert (expr
->value
.function
.actual
->next
->expr
== NULL
);
3939 arg
= expr
->value
.function
.actual
->expr
;
3940 if (arg
->rank
== -1)
3945 /* The rank (hence the return value's shape) is unknown,
3946 we have to retrieve it. */
3947 gfc_init_se (&se
, NULL
);
3948 se
.descriptor_only
= 1;
3949 gfc_conv_expr (&se
, arg
);
3950 /* This is a bare variable, so there is no preliminary
3952 gcc_assert (se
.pre
.head
== NULL_TREE
3953 && se
.post
.head
== NULL_TREE
);
3954 rank
= gfc_conv_descriptor_rank (se
.expr
);
3955 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3956 gfc_array_index_type
,
3957 fold_convert (gfc_array_index_type
,
3959 gfc_index_one_node
);
3960 info
->end
[0] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
3961 info
->start
[0] = gfc_index_zero_node
;
3962 info
->stride
[0] = gfc_index_one_node
;
3965 /* Otherwise fall through GFC_SS_FUNCTION. */
3967 case GFC_ISYM_LCOBOUND
:
3968 case GFC_ISYM_UCOBOUND
:
3969 case GFC_ISYM_THIS_IMAGE
:
3976 case GFC_SS_CONSTRUCTOR
:
3977 case GFC_SS_FUNCTION
:
3978 for (n
= 0; n
< ss
->dimen
; n
++)
3980 int dim
= ss
->dim
[n
];
3982 info
->start
[dim
] = gfc_index_zero_node
;
3983 info
->end
[dim
] = gfc_index_zero_node
;
3984 info
->stride
[dim
] = gfc_index_one_node
;
3993 /* The rest is just runtime bound checking. */
3994 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3997 tree lbound
, ubound
;
3999 tree size
[GFC_MAX_DIMENSIONS
];
4000 tree stride_pos
, stride_neg
, non_zerosized
, tmp2
, tmp3
;
4001 gfc_array_info
*info
;
4005 gfc_start_block (&block
);
4007 for (n
= 0; n
< loop
->dimen
; n
++)
4008 size
[n
] = NULL_TREE
;
4010 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4013 gfc_ss_info
*ss_info
;
4016 const char *expr_name
;
4019 if (ss_info
->type
!= GFC_SS_SECTION
)
4022 /* Catch allocatable lhs in f2003. */
4023 if (flag_realloc_lhs
&& ss
->is_alloc_lhs
)
4026 expr
= ss_info
->expr
;
4027 expr_loc
= &expr
->where
;
4028 expr_name
= expr
->symtree
->name
;
4030 gfc_start_block (&inner
);
4032 /* TODO: range checking for mapped dimensions. */
4033 info
= &ss_info
->data
.array
;
4035 /* This code only checks ranges. Elemental and vector
4036 dimensions are checked later. */
4037 for (n
= 0; n
< loop
->dimen
; n
++)
4042 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
4045 if (dim
== info
->ref
->u
.ar
.dimen
- 1
4046 && info
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
4047 check_upper
= false;
4051 /* Zero stride is not allowed. */
4052 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4053 info
->stride
[dim
], gfc_index_zero_node
);
4054 msg
= xasprintf ("Zero stride is not allowed, for dimension %d "
4055 "of array '%s'", dim
+ 1, expr_name
);
4056 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4060 desc
= info
->descriptor
;
4062 /* This is the run-time equivalent of resolve.c's
4063 check_dimension(). The logical is more readable there
4064 than it is here, with all the trees. */
4065 lbound
= gfc_conv_array_lbound (desc
, dim
);
4066 end
= info
->end
[dim
];
4068 ubound
= gfc_conv_array_ubound (desc
, dim
);
4072 /* non_zerosized is true when the selected range is not
4074 stride_pos
= fold_build2_loc (input_location
, GT_EXPR
,
4075 boolean_type_node
, info
->stride
[dim
],
4076 gfc_index_zero_node
);
4077 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
4078 info
->start
[dim
], end
);
4079 stride_pos
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4080 boolean_type_node
, stride_pos
, tmp
);
4082 stride_neg
= fold_build2_loc (input_location
, LT_EXPR
,
4084 info
->stride
[dim
], gfc_index_zero_node
);
4085 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
4086 info
->start
[dim
], end
);
4087 stride_neg
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4090 non_zerosized
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
4092 stride_pos
, stride_neg
);
4094 /* Check the start of the range against the lower and upper
4095 bounds of the array, if the range is not empty.
4096 If upper bound is present, include both bounds in the
4100 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
4102 info
->start
[dim
], lbound
);
4103 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4105 non_zerosized
, tmp
);
4106 tmp2
= fold_build2_loc (input_location
, GT_EXPR
,
4108 info
->start
[dim
], ubound
);
4109 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4111 non_zerosized
, tmp2
);
4112 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4113 "outside of expected range (%%ld:%%ld)",
4114 dim
+ 1, expr_name
);
4115 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4117 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4118 fold_convert (long_integer_type_node
, lbound
),
4119 fold_convert (long_integer_type_node
, ubound
));
4120 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4122 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4123 fold_convert (long_integer_type_node
, lbound
),
4124 fold_convert (long_integer_type_node
, ubound
));
4129 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
4131 info
->start
[dim
], lbound
);
4132 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4133 boolean_type_node
, non_zerosized
, tmp
);
4134 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4135 "below lower bound of %%ld",
4136 dim
+ 1, expr_name
);
4137 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4139 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4140 fold_convert (long_integer_type_node
, lbound
));
4144 /* Compute the last element of the range, which is not
4145 necessarily "end" (think 0:5:3, which doesn't contain 5)
4146 and check it against both lower and upper bounds. */
4148 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4149 gfc_array_index_type
, end
,
4151 tmp
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
,
4152 gfc_array_index_type
, tmp
,
4154 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4155 gfc_array_index_type
, end
, tmp
);
4156 tmp2
= fold_build2_loc (input_location
, LT_EXPR
,
4157 boolean_type_node
, tmp
, lbound
);
4158 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4159 boolean_type_node
, non_zerosized
, tmp2
);
4162 tmp3
= fold_build2_loc (input_location
, GT_EXPR
,
4163 boolean_type_node
, tmp
, ubound
);
4164 tmp3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4165 boolean_type_node
, non_zerosized
, tmp3
);
4166 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4167 "outside of expected range (%%ld:%%ld)",
4168 dim
+ 1, expr_name
);
4169 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4171 fold_convert (long_integer_type_node
, tmp
),
4172 fold_convert (long_integer_type_node
, ubound
),
4173 fold_convert (long_integer_type_node
, lbound
));
4174 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4176 fold_convert (long_integer_type_node
, tmp
),
4177 fold_convert (long_integer_type_node
, ubound
),
4178 fold_convert (long_integer_type_node
, lbound
));
4183 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4184 "below lower bound of %%ld",
4185 dim
+ 1, expr_name
);
4186 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4188 fold_convert (long_integer_type_node
, tmp
),
4189 fold_convert (long_integer_type_node
, lbound
));
4193 /* Check the section sizes match. */
4194 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4195 gfc_array_index_type
, end
,
4197 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
4198 gfc_array_index_type
, tmp
,
4200 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4201 gfc_array_index_type
,
4202 gfc_index_one_node
, tmp
);
4203 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
4204 gfc_array_index_type
, tmp
,
4205 build_int_cst (gfc_array_index_type
, 0));
4206 /* We remember the size of the first section, and check all the
4207 others against this. */
4210 tmp3
= fold_build2_loc (input_location
, NE_EXPR
,
4211 boolean_type_node
, tmp
, size
[n
]);
4212 msg
= xasprintf ("Array bound mismatch for dimension %d "
4213 "of array '%s' (%%ld/%%ld)",
4214 dim
+ 1, expr_name
);
4216 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4218 fold_convert (long_integer_type_node
, tmp
),
4219 fold_convert (long_integer_type_node
, size
[n
]));
4224 size
[n
] = gfc_evaluate_now (tmp
, &inner
);
4227 tmp
= gfc_finish_block (&inner
);
4229 /* For optional arguments, only check bounds if the argument is
4231 if (expr
->symtree
->n
.sym
->attr
.optional
4232 || expr
->symtree
->n
.sym
->attr
.not_always_present
)
4233 tmp
= build3_v (COND_EXPR
,
4234 gfc_conv_expr_present (expr
->symtree
->n
.sym
),
4235 tmp
, build_empty_stmt (input_location
));
4237 gfc_add_expr_to_block (&block
, tmp
);
4241 tmp
= gfc_finish_block (&block
);
4242 gfc_add_expr_to_block (&outer_loop
->pre
, tmp
);
4245 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4246 gfc_conv_ss_startstride (loop
);
4249 /* Return true if both symbols could refer to the same data object. Does
4250 not take account of aliasing due to equivalence statements. */
4253 symbols_could_alias (gfc_symbol
*lsym
, gfc_symbol
*rsym
, bool lsym_pointer
,
4254 bool lsym_target
, bool rsym_pointer
, bool rsym_target
)
4256 /* Aliasing isn't possible if the symbols have different base types. */
4257 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
4260 /* Pointers can point to other pointers and target objects. */
4262 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4263 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4266 /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
4267 and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
4269 if (lsym_target
&& rsym_target
4270 && ((lsym
->attr
.dummy
&& !lsym
->attr
.contiguous
4271 && (!lsym
->attr
.dimension
|| lsym
->as
->type
== AS_ASSUMED_SHAPE
))
4272 || (rsym
->attr
.dummy
&& !rsym
->attr
.contiguous
4273 && (!rsym
->attr
.dimension
4274 || rsym
->as
->type
== AS_ASSUMED_SHAPE
))))
4281 /* Return true if the two SS could be aliased, i.e. both point to the same data
4283 /* TODO: resolve aliases based on frontend expressions. */
4286 gfc_could_be_alias (gfc_ss
* lss
, gfc_ss
* rss
)
4290 gfc_expr
*lexpr
, *rexpr
;
4293 bool lsym_pointer
, lsym_target
, rsym_pointer
, rsym_target
;
4295 lexpr
= lss
->info
->expr
;
4296 rexpr
= rss
->info
->expr
;
4298 lsym
= lexpr
->symtree
->n
.sym
;
4299 rsym
= rexpr
->symtree
->n
.sym
;
4301 lsym_pointer
= lsym
->attr
.pointer
;
4302 lsym_target
= lsym
->attr
.target
;
4303 rsym_pointer
= rsym
->attr
.pointer
;
4304 rsym_target
= rsym
->attr
.target
;
4306 if (symbols_could_alias (lsym
, rsym
, lsym_pointer
, lsym_target
,
4307 rsym_pointer
, rsym_target
))
4310 if (rsym
->ts
.type
!= BT_DERIVED
&& rsym
->ts
.type
!= BT_CLASS
4311 && lsym
->ts
.type
!= BT_DERIVED
&& lsym
->ts
.type
!= BT_CLASS
)
4314 /* For derived types we must check all the component types. We can ignore
4315 array references as these will have the same base type as the previous
4317 for (lref
= lexpr
->ref
; lref
!= lss
->info
->data
.array
.ref
; lref
= lref
->next
)
4319 if (lref
->type
!= REF_COMPONENT
)
4322 lsym_pointer
= lsym_pointer
|| lref
->u
.c
.sym
->attr
.pointer
;
4323 lsym_target
= lsym_target
|| lref
->u
.c
.sym
->attr
.target
;
4325 if (symbols_could_alias (lref
->u
.c
.sym
, rsym
, lsym_pointer
, lsym_target
,
4326 rsym_pointer
, rsym_target
))
4329 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4330 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4332 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4337 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
;
4340 if (rref
->type
!= REF_COMPONENT
)
4343 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4344 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4346 if (symbols_could_alias (lref
->u
.c
.sym
, rref
->u
.c
.sym
,
4347 lsym_pointer
, lsym_target
,
4348 rsym_pointer
, rsym_target
))
4351 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4352 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4354 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4355 &rref
->u
.c
.sym
->ts
))
4357 if (gfc_compare_types (&lref
->u
.c
.sym
->ts
,
4358 &rref
->u
.c
.component
->ts
))
4360 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4361 &rref
->u
.c
.component
->ts
))
4367 lsym_pointer
= lsym
->attr
.pointer
;
4368 lsym_target
= lsym
->attr
.target
;
4369 lsym_pointer
= lsym
->attr
.pointer
;
4370 lsym_target
= lsym
->attr
.target
;
4372 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
; rref
= rref
->next
)
4374 if (rref
->type
!= REF_COMPONENT
)
4377 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4378 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4380 if (symbols_could_alias (rref
->u
.c
.sym
, lsym
,
4381 lsym_pointer
, lsym_target
,
4382 rsym_pointer
, rsym_target
))
4385 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4386 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4388 if (gfc_compare_types (&lsym
->ts
, &rref
->u
.c
.component
->ts
))
4397 /* Resolve array data dependencies. Creates a temporary if required. */
4398 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
4402 gfc_conv_resolve_dependencies (gfc_loopinfo
* loop
, gfc_ss
* dest
,
4408 gfc_expr
*dest_expr
;
4413 loop
->temp_ss
= NULL
;
4414 dest_expr
= dest
->info
->expr
;
4416 for (ss
= rss
; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
4418 ss_expr
= ss
->info
->expr
;
4420 if (ss
->info
->array_outer_dependency
)
4426 if (ss
->info
->type
!= GFC_SS_SECTION
)
4428 if (flag_realloc_lhs
4429 && dest_expr
!= ss_expr
4430 && gfc_is_reallocatable_lhs (dest_expr
)
4432 nDepend
= gfc_check_dependency (dest_expr
, ss_expr
, true);
4434 /* Check for cases like c(:)(1:2) = c(2)(2:3) */
4435 if (!nDepend
&& dest_expr
->rank
> 0
4436 && dest_expr
->ts
.type
== BT_CHARACTER
4437 && ss_expr
->expr_type
== EXPR_VARIABLE
)
4439 nDepend
= gfc_check_dependency (dest_expr
, ss_expr
, false);
4444 if (dest_expr
->symtree
->n
.sym
!= ss_expr
->symtree
->n
.sym
)
4446 if (gfc_could_be_alias (dest
, ss
)
4447 || gfc_are_equivalenced_arrays (dest_expr
, ss_expr
))
4455 lref
= dest_expr
->ref
;
4456 rref
= ss_expr
->ref
;
4458 nDepend
= gfc_dep_resolver (lref
, rref
, &loop
->reverse
[0]);
4463 for (i
= 0; i
< dest
->dimen
; i
++)
4464 for (j
= 0; j
< ss
->dimen
; j
++)
4466 && dest
->dim
[i
] == ss
->dim
[j
])
4468 /* If we don't access array elements in the same order,
4469 there is a dependency. */
4474 /* TODO : loop shifting. */
4477 /* Mark the dimensions for LOOP SHIFTING */
4478 for (n
= 0; n
< loop
->dimen
; n
++)
4480 int dim
= dest
->data
.info
.dim
[n
];
4482 if (lref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
4484 else if (! gfc_is_same_range (&lref
->u
.ar
,
4485 &rref
->u
.ar
, dim
, 0))
4489 /* Put all the dimensions with dependencies in the
4492 for (n
= 0; n
< loop
->dimen
; n
++)
4494 gcc_assert (loop
->order
[n
] == n
);
4496 loop
->order
[dim
++] = n
;
4498 for (n
= 0; n
< loop
->dimen
; n
++)
4501 loop
->order
[dim
++] = n
;
4504 gcc_assert (dim
== loop
->dimen
);
4515 tree base_type
= gfc_typenode_for_spec (&dest_expr
->ts
);
4516 if (GFC_ARRAY_TYPE_P (base_type
)
4517 || GFC_DESCRIPTOR_TYPE_P (base_type
))
4518 base_type
= gfc_get_element_type (base_type
);
4519 loop
->temp_ss
= gfc_get_temp_ss (base_type
, dest
->info
->string_length
,
4521 gfc_add_ss_to_loop (loop
, loop
->temp_ss
);
4524 loop
->temp_ss
= NULL
;
4528 /* Browse through each array's information from the scalarizer and set the loop
4529 bounds according to the "best" one (per dimension), i.e. the one which
4530 provides the most information (constant bounds, shape, etc.). */
4533 set_loop_bounds (gfc_loopinfo
*loop
)
4535 int n
, dim
, spec_dim
;
4536 gfc_array_info
*info
;
4537 gfc_array_info
*specinfo
;
4541 bool dynamic
[GFC_MAX_DIMENSIONS
];
4544 bool nonoptional_arr
;
4546 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
4548 loopspec
= loop
->specloop
;
4551 for (n
= 0; n
< loop
->dimen
; n
++)
4556 /* If there are both optional and nonoptional array arguments, scalarize
4557 over the nonoptional; otherwise, it does not matter as then all
4558 (optional) arrays have to be present per F2008, 125.2.12p3(6). */
4560 nonoptional_arr
= false;
4562 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4563 if (ss
->info
->type
!= GFC_SS_SCALAR
&& ss
->info
->type
!= GFC_SS_TEMP
4564 && ss
->info
->type
!= GFC_SS_REFERENCE
&& !ss
->info
->can_be_null_ref
)
4566 nonoptional_arr
= true;
4570 /* We use one SS term, and use that to determine the bounds of the
4571 loop for this dimension. We try to pick the simplest term. */
4572 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4574 gfc_ss_type ss_type
;
4576 ss_type
= ss
->info
->type
;
4577 if (ss_type
== GFC_SS_SCALAR
4578 || ss_type
== GFC_SS_TEMP
4579 || ss_type
== GFC_SS_REFERENCE
4580 || (ss
->info
->can_be_null_ref
&& nonoptional_arr
))
4583 info
= &ss
->info
->data
.array
;
4586 if (loopspec
[n
] != NULL
)
4588 specinfo
= &loopspec
[n
]->info
->data
.array
;
4589 spec_dim
= loopspec
[n
]->dim
[n
];
4593 /* Silence uninitialized warnings. */
4600 gcc_assert (info
->shape
[dim
]);
4601 /* The frontend has worked out the size for us. */
4604 || !integer_zerop (specinfo
->start
[spec_dim
]))
4605 /* Prefer zero-based descriptors if possible. */
4610 if (ss_type
== GFC_SS_CONSTRUCTOR
)
4612 gfc_constructor_base base
;
4613 /* An unknown size constructor will always be rank one.
4614 Higher rank constructors will either have known shape,
4615 or still be wrapped in a call to reshape. */
4616 gcc_assert (loop
->dimen
== 1);
4618 /* Always prefer to use the constructor bounds if the size
4619 can be determined at compile time. Prefer not to otherwise,
4620 since the general case involves realloc, and it's better to
4621 avoid that overhead if possible. */
4622 base
= ss
->info
->expr
->value
.constructor
;
4623 dynamic
[n
] = gfc_get_array_constructor_size (&i
, base
);
4624 if (!dynamic
[n
] || !loopspec
[n
])
4629 /* Avoid using an allocatable lhs in an assignment, since
4630 there might be a reallocation coming. */
4631 if (loopspec
[n
] && ss
->is_alloc_lhs
)
4636 /* Criteria for choosing a loop specifier (most important first):
4637 doesn't need realloc
4643 else if (loopspec
[n
]->info
->type
== GFC_SS_CONSTRUCTOR
&& dynamic
[n
])
4645 else if (integer_onep (info
->stride
[dim
])
4646 && !integer_onep (specinfo
->stride
[spec_dim
]))
4648 else if (INTEGER_CST_P (info
->stride
[dim
])
4649 && !INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
4651 else if (INTEGER_CST_P (info
->start
[dim
])
4652 && !INTEGER_CST_P (specinfo
->start
[spec_dim
])
4653 && integer_onep (info
->stride
[dim
])
4654 == integer_onep (specinfo
->stride
[spec_dim
])
4655 && INTEGER_CST_P (info
->stride
[dim
])
4656 == INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
4658 /* We don't work out the upper bound.
4659 else if (INTEGER_CST_P (info->finish[n])
4660 && ! INTEGER_CST_P (specinfo->finish[n]))
4661 loopspec[n] = ss; */
4664 /* We should have found the scalarization loop specifier. If not,
4666 gcc_assert (loopspec
[n
]);
4668 info
= &loopspec
[n
]->info
->data
.array
;
4669 dim
= loopspec
[n
]->dim
[n
];
4671 /* Set the extents of this range. */
4672 cshape
= info
->shape
;
4673 if (cshape
&& INTEGER_CST_P (info
->start
[dim
])
4674 && INTEGER_CST_P (info
->stride
[dim
]))
4676 loop
->from
[n
] = info
->start
[dim
];
4677 mpz_set (i
, cshape
[get_array_ref_dim_for_loop_dim (loopspec
[n
], n
)]);
4678 mpz_sub_ui (i
, i
, 1);
4679 /* To = from + (size - 1) * stride. */
4680 tmp
= gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
4681 if (!integer_onep (info
->stride
[dim
]))
4682 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
4683 gfc_array_index_type
, tmp
,
4685 loop
->to
[n
] = fold_build2_loc (input_location
, PLUS_EXPR
,
4686 gfc_array_index_type
,
4687 loop
->from
[n
], tmp
);
4691 loop
->from
[n
] = info
->start
[dim
];
4692 switch (loopspec
[n
]->info
->type
)
4694 case GFC_SS_CONSTRUCTOR
:
4695 /* The upper bound is calculated when we expand the
4697 gcc_assert (loop
->to
[n
] == NULL_TREE
);
4700 case GFC_SS_SECTION
:
4701 /* Use the end expression if it exists and is not constant,
4702 so that it is only evaluated once. */
4703 loop
->to
[n
] = info
->end
[dim
];
4706 case GFC_SS_FUNCTION
:
4707 /* The loop bound will be set when we generate the call. */
4708 gcc_assert (loop
->to
[n
] == NULL_TREE
);
4711 case GFC_SS_INTRINSIC
:
4713 gfc_expr
*expr
= loopspec
[n
]->info
->expr
;
4715 /* The {l,u}bound of an assumed rank. */
4716 gcc_assert ((expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
4717 || expr
->value
.function
.isym
->id
== GFC_ISYM_UBOUND
)
4718 && expr
->value
.function
.actual
->next
->expr
== NULL
4719 && expr
->value
.function
.actual
->expr
->rank
== -1);
4721 loop
->to
[n
] = info
->end
[dim
];
4730 /* Transform everything so we have a simple incrementing variable. */
4731 if (integer_onep (info
->stride
[dim
]))
4732 info
->delta
[dim
] = gfc_index_zero_node
;
4735 /* Set the delta for this section. */
4736 info
->delta
[dim
] = gfc_evaluate_now (loop
->from
[n
], &outer_loop
->pre
);
4737 /* Number of iterations is (end - start + step) / step.
4738 with start = 0, this simplifies to
4740 for (i = 0; i<=last; i++){...}; */
4741 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4742 gfc_array_index_type
, loop
->to
[n
],
4744 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
4745 gfc_array_index_type
, tmp
, info
->stride
[dim
]);
4746 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
4747 tmp
, build_int_cst (gfc_array_index_type
, -1));
4748 loop
->to
[n
] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
4749 /* Make the loop variable start at 0. */
4750 loop
->from
[n
] = gfc_index_zero_node
;
4755 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4756 set_loop_bounds (loop
);
4760 /* Initialize the scalarization loop. Creates the loop variables. Determines
4761 the range of the loop variables. Creates a temporary if required.
4762 Also generates code for scalar expressions which have been
4763 moved outside the loop. */
4766 gfc_conv_loop_setup (gfc_loopinfo
* loop
, locus
* where
)
4771 set_loop_bounds (loop
);
4773 /* Add all the scalar code that can be taken out of the loops.
4774 This may include calculating the loop bounds, so do it before
4775 allocating the temporary. */
4776 gfc_add_loop_ss_code (loop
, loop
->ss
, false, where
);
4778 tmp_ss
= loop
->temp_ss
;
4779 /* If we want a temporary then create it. */
4782 gfc_ss_info
*tmp_ss_info
;
4784 tmp_ss_info
= tmp_ss
->info
;
4785 gcc_assert (tmp_ss_info
->type
== GFC_SS_TEMP
);
4786 gcc_assert (loop
->parent
== NULL
);
4788 /* Make absolutely sure that this is a complete type. */
4789 if (tmp_ss_info
->string_length
)
4790 tmp_ss_info
->data
.temp
.type
4791 = gfc_get_character_type_len_for_eltype
4792 (TREE_TYPE (tmp_ss_info
->data
.temp
.type
),
4793 tmp_ss_info
->string_length
);
4795 tmp
= tmp_ss_info
->data
.temp
.type
;
4796 memset (&tmp_ss_info
->data
.array
, 0, sizeof (gfc_array_info
));
4797 tmp_ss_info
->type
= GFC_SS_SECTION
;
4799 gcc_assert (tmp_ss
->dimen
!= 0);
4801 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, tmp_ss
, tmp
,
4802 NULL_TREE
, false, true, false, where
);
4805 /* For array parameters we don't have loop variables, so don't calculate the
4807 if (!loop
->array_parameter
)
4808 gfc_set_delta (loop
);
4812 /* Calculates how to transform from loop variables to array indices for each
4813 array: once loop bounds are chosen, sets the difference (DELTA field) between
4814 loop bounds and array reference bounds, for each array info. */
4817 gfc_set_delta (gfc_loopinfo
*loop
)
4819 gfc_ss
*ss
, **loopspec
;
4820 gfc_array_info
*info
;
4824 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
4826 loopspec
= loop
->specloop
;
4828 /* Calculate the translation from loop variables to array indices. */
4829 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4831 gfc_ss_type ss_type
;
4833 ss_type
= ss
->info
->type
;
4834 if (ss_type
!= GFC_SS_SECTION
4835 && ss_type
!= GFC_SS_COMPONENT
4836 && ss_type
!= GFC_SS_CONSTRUCTOR
)
4839 info
= &ss
->info
->data
.array
;
4841 for (n
= 0; n
< ss
->dimen
; n
++)
4843 /* If we are specifying the range the delta is already set. */
4844 if (loopspec
[n
] != ss
)
4848 /* Calculate the offset relative to the loop variable.
4849 First multiply by the stride. */
4850 tmp
= loop
->from
[n
];
4851 if (!integer_onep (info
->stride
[dim
]))
4852 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
4853 gfc_array_index_type
,
4854 tmp
, info
->stride
[dim
]);
4856 /* Then subtract this from our starting value. */
4857 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4858 gfc_array_index_type
,
4859 info
->start
[dim
], tmp
);
4861 info
->delta
[dim
] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
4866 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4867 gfc_set_delta (loop
);
4871 /* Calculate the size of a given array dimension from the bounds. This
4872 is simply (ubound - lbound + 1) if this expression is positive
4873 or 0 if it is negative (pick either one if it is zero). Optionally
4874 (if or_expr is present) OR the (expression != 0) condition to it. */
4877 gfc_conv_array_extent_dim (tree lbound
, tree ubound
, tree
* or_expr
)
4882 /* Calculate (ubound - lbound + 1). */
4883 res
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4885 res
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
, res
,
4886 gfc_index_one_node
);
4888 /* Check whether the size for this dimension is negative. */
4889 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, res
,
4890 gfc_index_zero_node
);
4891 res
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
, cond
,
4892 gfc_index_zero_node
, res
);
4894 /* Build OR expression. */
4896 *or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
4897 boolean_type_node
, *or_expr
, cond
);
4903 /* For an array descriptor, get the total number of elements. This is just
4904 the product of the extents along from_dim to to_dim. */
4907 gfc_conv_descriptor_size_1 (tree desc
, int from_dim
, int to_dim
)
4912 res
= gfc_index_one_node
;
4914 for (dim
= from_dim
; dim
< to_dim
; ++dim
)
4920 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]);
4921 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]);
4923 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
4924 res
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4932 /* Full size of an array. */
4935 gfc_conv_descriptor_size (tree desc
, int rank
)
4937 return gfc_conv_descriptor_size_1 (desc
, 0, rank
);
4941 /* Size of a coarray for all dimensions but the last. */
4944 gfc_conv_descriptor_cosize (tree desc
, int rank
, int corank
)
4946 return gfc_conv_descriptor_size_1 (desc
, rank
, rank
+ corank
- 1);
4950 /* Fills in an array descriptor, and returns the size of the array.
4951 The size will be a simple_val, ie a variable or a constant. Also
4952 calculates the offset of the base. The pointer argument overflow,
4953 which should be of integer type, will increase in value if overflow
4954 occurs during the size calculation. Returns the size of the array.
4958 for (n = 0; n < rank; n++)
4960 a.lbound[n] = specified_lower_bound;
4961 offset = offset + a.lbond[n] * stride;
4963 a.ubound[n] = specified_upper_bound;
4964 a.stride[n] = stride;
4965 size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
4966 overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
4967 stride = stride * size;
4969 for (n = rank; n < rank+corank; n++)
4970 (Set lcobound/ucobound as above.)
4971 element_size = sizeof (array element);
4974 stride = (size_t) stride;
4975 overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
4976 stride = stride * element_size;
4982 gfc_array_init_size (tree descriptor
, int rank
, int corank
, tree
* poffset
,
4983 gfc_expr
** lower
, gfc_expr
** upper
, stmtblock_t
* pblock
,
4984 stmtblock_t
* descriptor_block
, tree
* overflow
,
4985 tree expr3_elem_size
, tree
*nelems
, gfc_expr
*expr3
)
4998 stmtblock_t thenblock
;
4999 stmtblock_t elseblock
;
5004 type
= TREE_TYPE (descriptor
);
5006 stride
= gfc_index_one_node
;
5007 offset
= gfc_index_zero_node
;
5009 /* Set the dtype. */
5010 tmp
= gfc_conv_descriptor_dtype (descriptor
);
5011 gfc_add_modify (descriptor_block
, tmp
, gfc_get_dtype (type
));
5013 or_expr
= boolean_false_node
;
5015 for (n
= 0; n
< rank
; n
++)
5020 /* We have 3 possibilities for determining the size of the array:
5021 lower == NULL => lbound = 1, ubound = upper[n]
5022 upper[n] = NULL => lbound = 1, ubound = lower[n]
5023 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
5026 /* Set lower bound. */
5027 gfc_init_se (&se
, NULL
);
5029 se
.expr
= gfc_index_one_node
;
5032 gcc_assert (lower
[n
]);
5035 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
5036 gfc_add_block_to_block (pblock
, &se
.pre
);
5040 se
.expr
= gfc_index_one_node
;
5044 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
5045 gfc_rank_cst
[n
], se
.expr
);
5046 conv_lbound
= se
.expr
;
5048 /* Work out the offset for this component. */
5049 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5051 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
5052 gfc_array_index_type
, offset
, tmp
);
5054 /* Set upper bound. */
5055 gfc_init_se (&se
, NULL
);
5056 gcc_assert (ubound
);
5057 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
5058 gfc_add_block_to_block (pblock
, &se
.pre
);
5060 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
5061 gfc_rank_cst
[n
], se
.expr
);
5062 conv_ubound
= se
.expr
;
5064 /* Store the stride. */
5065 gfc_conv_descriptor_stride_set (descriptor_block
, descriptor
,
5066 gfc_rank_cst
[n
], stride
);
5068 /* Calculate size and check whether extent is negative. */
5069 size
= gfc_conv_array_extent_dim (conv_lbound
, conv_ubound
, &or_expr
);
5070 size
= gfc_evaluate_now (size
, pblock
);
5072 /* Check whether multiplying the stride by the number of
5073 elements in this dimension would overflow. We must also check
5074 whether the current dimension has zero size in order to avoid
5077 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
5078 gfc_array_index_type
,
5079 fold_convert (gfc_array_index_type
,
5080 TYPE_MAX_VALUE (gfc_array_index_type
)),
5082 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
5083 boolean_type_node
, tmp
, stride
),
5084 PRED_FORTRAN_OVERFLOW
);
5085 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5086 integer_one_node
, integer_zero_node
);
5087 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
5088 boolean_type_node
, size
,
5089 gfc_index_zero_node
),
5090 PRED_FORTRAN_SIZE_ZERO
);
5091 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5092 integer_zero_node
, tmp
);
5093 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
5095 *overflow
= gfc_evaluate_now (tmp
, pblock
);
5097 /* Multiply the stride by the number of elements in this dimension. */
5098 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
5099 gfc_array_index_type
, stride
, size
);
5100 stride
= gfc_evaluate_now (stride
, pblock
);
5103 for (n
= rank
; n
< rank
+ corank
; n
++)
5107 /* Set lower bound. */
5108 gfc_init_se (&se
, NULL
);
5109 if (lower
== NULL
|| lower
[n
] == NULL
)
5111 gcc_assert (n
== rank
+ corank
- 1);
5112 se
.expr
= gfc_index_one_node
;
5116 if (ubound
|| n
== rank
+ corank
- 1)
5118 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
5119 gfc_add_block_to_block (pblock
, &se
.pre
);
5123 se
.expr
= gfc_index_one_node
;
5127 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
5128 gfc_rank_cst
[n
], se
.expr
);
5130 if (n
< rank
+ corank
- 1)
5132 gfc_init_se (&se
, NULL
);
5133 gcc_assert (ubound
);
5134 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
5135 gfc_add_block_to_block (pblock
, &se
.pre
);
5136 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
5137 gfc_rank_cst
[n
], se
.expr
);
5141 /* The stride is the number of elements in the array, so multiply by the
5142 size of an element to get the total size. Obviously, if there is a
5143 SOURCE expression (expr3) we must use its element size. */
5144 if (expr3_elem_size
!= NULL_TREE
)
5145 tmp
= expr3_elem_size
;
5146 else if (expr3
!= NULL
)
5148 if (expr3
->ts
.type
== BT_CLASS
)
5151 gfc_expr
*sz
= gfc_copy_expr (expr3
);
5152 gfc_add_vptr_component (sz
);
5153 gfc_add_size_component (sz
);
5154 gfc_init_se (&se_sz
, NULL
);
5155 gfc_conv_expr (&se_sz
, sz
);
5161 tmp
= gfc_typenode_for_spec (&expr3
->ts
);
5162 tmp
= TYPE_SIZE_UNIT (tmp
);
5166 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
5168 /* Convert to size_t. */
5169 element_size
= fold_convert (size_type_node
, tmp
);
5172 return element_size
;
5174 *nelems
= gfc_evaluate_now (stride
, pblock
);
5175 stride
= fold_convert (size_type_node
, stride
);
5177 /* First check for overflow. Since an array of type character can
5178 have zero element_size, we must check for that before
5180 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
5182 TYPE_MAX_VALUE (size_type_node
), element_size
);
5183 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
5184 boolean_type_node
, tmp
, stride
),
5185 PRED_FORTRAN_OVERFLOW
);
5186 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5187 integer_one_node
, integer_zero_node
);
5188 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
5189 boolean_type_node
, element_size
,
5190 build_int_cst (size_type_node
, 0)),
5191 PRED_FORTRAN_SIZE_ZERO
);
5192 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5193 integer_zero_node
, tmp
);
5194 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
5196 *overflow
= gfc_evaluate_now (tmp
, pblock
);
5198 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5199 stride
, element_size
);
5201 if (poffset
!= NULL
)
5203 offset
= gfc_evaluate_now (offset
, pblock
);
5207 if (integer_zerop (or_expr
))
5209 if (integer_onep (or_expr
))
5210 return build_int_cst (size_type_node
, 0);
5212 var
= gfc_create_var (TREE_TYPE (size
), "size");
5213 gfc_start_block (&thenblock
);
5214 gfc_add_modify (&thenblock
, var
, build_int_cst (size_type_node
, 0));
5215 thencase
= gfc_finish_block (&thenblock
);
5217 gfc_start_block (&elseblock
);
5218 gfc_add_modify (&elseblock
, var
, size
);
5219 elsecase
= gfc_finish_block (&elseblock
);
5221 tmp
= gfc_evaluate_now (or_expr
, pblock
);
5222 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
5223 gfc_add_expr_to_block (pblock
, tmp
);
5229 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
5230 the work for an ALLOCATE statement. */
5234 gfc_array_allocate (gfc_se
* se
, gfc_expr
* expr
, tree status
, tree errmsg
,
5235 tree errlen
, tree label_finish
, tree expr3_elem_size
,
5236 tree
*nelems
, gfc_expr
*expr3
)
5240 tree offset
= NULL_TREE
;
5241 tree token
= NULL_TREE
;
5244 tree error
= NULL_TREE
;
5245 tree overflow
; /* Boolean storing whether size calculation overflows. */
5246 tree var_overflow
= NULL_TREE
;
5248 tree set_descriptor
;
5249 stmtblock_t set_descriptor_block
;
5250 stmtblock_t elseblock
;
5253 gfc_ref
*ref
, *prev_ref
= NULL
;
5254 bool allocatable
, coarray
, dimension
;
5258 /* Find the last reference in the chain. */
5259 while (ref
&& ref
->next
!= NULL
)
5261 gcc_assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
5262 || (ref
->u
.ar
.dimen
== 0 && ref
->u
.ar
.codimen
> 0));
5267 if (ref
== NULL
|| ref
->type
!= REF_ARRAY
)
5272 allocatable
= expr
->symtree
->n
.sym
->attr
.allocatable
;
5273 coarray
= expr
->symtree
->n
.sym
->attr
.codimension
;
5274 dimension
= expr
->symtree
->n
.sym
->attr
.dimension
;
5278 allocatable
= prev_ref
->u
.c
.component
->attr
.allocatable
;
5279 coarray
= prev_ref
->u
.c
.component
->attr
.codimension
;
5280 dimension
= prev_ref
->u
.c
.component
->attr
.dimension
;
5284 gcc_assert (coarray
);
5286 /* Figure out the size of the array. */
5287 switch (ref
->u
.ar
.type
)
5293 upper
= ref
->u
.ar
.start
;
5299 lower
= ref
->u
.ar
.start
;
5300 upper
= ref
->u
.ar
.end
;
5304 gcc_assert (ref
->u
.ar
.as
->type
== AS_EXPLICIT
);
5306 lower
= ref
->u
.ar
.as
->lower
;
5307 upper
= ref
->u
.ar
.as
->upper
;
5315 overflow
= integer_zero_node
;
5317 gfc_init_block (&set_descriptor_block
);
5318 size
= gfc_array_init_size (se
->expr
, ref
->u
.ar
.as
->rank
,
5319 ref
->u
.ar
.as
->corank
, &offset
, lower
, upper
,
5320 &se
->pre
, &set_descriptor_block
, &overflow
,
5321 expr3_elem_size
, nelems
, expr3
);
5325 var_overflow
= gfc_create_var (integer_type_node
, "overflow");
5326 gfc_add_modify (&se
->pre
, var_overflow
, overflow
);
5328 if (status
== NULL_TREE
)
5330 /* Generate the block of code handling overflow. */
5331 msg
= gfc_build_addr_expr (pchar_type_node
,
5332 gfc_build_localized_cstring_const
5333 ("Integer overflow when calculating the amount of "
5334 "memory to allocate"));
5335 error
= build_call_expr_loc (input_location
,
5336 gfor_fndecl_runtime_error
, 1, msg
);
5340 tree status_type
= TREE_TYPE (status
);
5341 stmtblock_t set_status_block
;
5343 gfc_start_block (&set_status_block
);
5344 gfc_add_modify (&set_status_block
, status
,
5345 build_int_cst (status_type
, LIBERROR_ALLOCATION
));
5346 error
= gfc_finish_block (&set_status_block
);
5350 gfc_start_block (&elseblock
);
5352 /* Allocate memory to store the data. */
5353 if (POINTER_TYPE_P (TREE_TYPE (se
->expr
)))
5354 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
5356 pointer
= gfc_conv_descriptor_data_get (se
->expr
);
5357 STRIP_NOPS (pointer
);
5359 if (coarray
&& flag_coarray
== GFC_FCOARRAY_LIB
)
5360 token
= gfc_build_addr_expr (NULL_TREE
,
5361 gfc_conv_descriptor_token (se
->expr
));
5363 /* The allocatable variant takes the old pointer as first argument. */
5365 gfc_allocate_allocatable (&elseblock
, pointer
, size
, token
,
5366 status
, errmsg
, errlen
, label_finish
, expr
);
5368 gfc_allocate_using_malloc (&elseblock
, pointer
, size
, status
);
5372 cond
= gfc_unlikely (fold_build2_loc (input_location
, NE_EXPR
,
5373 boolean_type_node
, var_overflow
, integer_zero_node
),
5374 PRED_FORTRAN_OVERFLOW
);
5375 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
5376 error
, gfc_finish_block (&elseblock
));
5379 tmp
= gfc_finish_block (&elseblock
);
5381 gfc_add_expr_to_block (&se
->pre
, tmp
);
5383 /* Update the array descriptors. */
5385 gfc_conv_descriptor_offset_set (&set_descriptor_block
, se
->expr
, offset
);
5387 set_descriptor
= gfc_finish_block (&set_descriptor_block
);
5388 if (status
!= NULL_TREE
)
5390 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
5391 boolean_type_node
, status
,
5392 build_int_cst (TREE_TYPE (status
), 0));
5393 gfc_add_expr_to_block (&se
->pre
,
5394 fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5395 gfc_likely (cond
, PRED_FORTRAN_FAIL_ALLOC
),
5397 build_empty_stmt (input_location
)));
5400 gfc_add_expr_to_block (&se
->pre
, set_descriptor
);
5402 if ((expr
->ts
.type
== BT_DERIVED
)
5403 && expr
->ts
.u
.derived
->attr
.alloc_comp
)
5405 tmp
= gfc_nullify_alloc_comp (expr
->ts
.u
.derived
, se
->expr
,
5406 ref
->u
.ar
.as
->rank
);
5407 gfc_add_expr_to_block (&se
->pre
, tmp
);
5414 /* Deallocate an array variable. Also used when an allocated variable goes
5419 gfc_array_deallocate (tree descriptor
, tree pstat
, tree errmsg
, tree errlen
,
5420 tree label_finish
, gfc_expr
* expr
)
5425 bool coarray
= gfc_is_coarray (expr
);
5427 gfc_start_block (&block
);
5429 /* Get a pointer to the data. */
5430 var
= gfc_conv_descriptor_data_get (descriptor
);
5433 /* Parameter is the address of the data component. */
5434 tmp
= gfc_deallocate_with_status (coarray
? descriptor
: var
, pstat
, errmsg
,
5435 errlen
, label_finish
, false, expr
, coarray
);
5436 gfc_add_expr_to_block (&block
, tmp
);
5438 /* Zero the data pointer; only for coarrays an error can occur and then
5439 the allocation status may not be changed. */
5440 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
5441 var
, build_int_cst (TREE_TYPE (var
), 0));
5442 if (pstat
!= NULL_TREE
&& coarray
&& flag_coarray
== GFC_FCOARRAY_LIB
)
5445 tree stat
= build_fold_indirect_ref_loc (input_location
, pstat
);
5447 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5448 stat
, build_int_cst (TREE_TYPE (stat
), 0));
5449 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5450 cond
, tmp
, build_empty_stmt (input_location
));
5453 gfc_add_expr_to_block (&block
, tmp
);
5455 return gfc_finish_block (&block
);
5459 /* Create an array constructor from an initialization expression.
5460 We assume the frontend already did any expansions and conversions. */
5463 gfc_conv_array_initializer (tree type
, gfc_expr
* expr
)
5470 vec
<constructor_elt
, va_gc
> *v
= NULL
;
5472 if (expr
->expr_type
== EXPR_VARIABLE
5473 && expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
5474 && expr
->symtree
->n
.sym
->value
)
5475 expr
= expr
->symtree
->n
.sym
->value
;
5477 switch (expr
->expr_type
)
5480 case EXPR_STRUCTURE
:
5481 /* A single scalar or derived type value. Create an array with all
5482 elements equal to that value. */
5483 gfc_init_se (&se
, NULL
);
5485 if (expr
->expr_type
== EXPR_CONSTANT
)
5486 gfc_conv_constant (&se
, expr
);
5488 gfc_conv_structure (&se
, expr
, 1);
5490 wtmp
= wi::to_offset (TYPE_MAX_VALUE (TYPE_DOMAIN (type
))) + 1;
5491 /* This will probably eat buckets of memory for large arrays. */
5494 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
, se
.expr
);
5500 /* Create a vector of all the elements. */
5501 for (c
= gfc_constructor_first (expr
->value
.constructor
);
5502 c
; c
= gfc_constructor_next (c
))
5506 /* Problems occur when we get something like
5507 integer :: a(lots) = (/(i, i=1, lots)/) */
5508 gfc_fatal_error ("The number of elements in the array "
5509 "constructor at %L requires an increase of "
5510 "the allowed %d upper limit. See "
5511 "%<-fmax-array-constructor%> option",
5512 &expr
->where
, flag_max_array_constructor
);
5515 if (mpz_cmp_si (c
->offset
, 0) != 0)
5516 index
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
5520 if (mpz_cmp_si (c
->repeat
, 1) > 0)
5526 mpz_add (maxval
, c
->offset
, c
->repeat
);
5527 mpz_sub_ui (maxval
, maxval
, 1);
5528 tmp2
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
5529 if (mpz_cmp_si (c
->offset
, 0) != 0)
5531 mpz_add_ui (maxval
, c
->offset
, 1);
5532 tmp1
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
5535 tmp1
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
5537 range
= fold_build2 (RANGE_EXPR
, gfc_array_index_type
, tmp1
, tmp2
);
5543 gfc_init_se (&se
, NULL
);
5544 switch (c
->expr
->expr_type
)
5547 gfc_conv_constant (&se
, c
->expr
);
5550 case EXPR_STRUCTURE
:
5551 gfc_conv_structure (&se
, c
->expr
, 1);
5555 /* Catch those occasional beasts that do not simplify
5556 for one reason or another, assuming that if they are
5557 standard defying the frontend will catch them. */
5558 gfc_conv_expr (&se
, c
->expr
);
5562 if (range
== NULL_TREE
)
5563 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
5566 if (index
!= NULL_TREE
)
5567 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
5568 CONSTRUCTOR_APPEND_ELT (v
, range
, se
.expr
);
5574 return gfc_build_null_descriptor (type
);
5580 /* Create a constructor from the list of elements. */
5581 tmp
= build_constructor (type
, v
);
5582 TREE_CONSTANT (tmp
) = 1;
5587 /* Generate code to evaluate non-constant coarray cobounds. */
5590 gfc_trans_array_cobounds (tree type
, stmtblock_t
* pblock
,
5591 const gfc_symbol
*sym
)
5599 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
5601 for (dim
= as
->rank
; dim
< as
->rank
+ as
->corank
; dim
++)
5603 /* Evaluate non-constant array bound expressions. */
5604 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
5605 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
5607 gfc_init_se (&se
, NULL
);
5608 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
5609 gfc_add_block_to_block (pblock
, &se
.pre
);
5610 gfc_add_modify (pblock
, lbound
, se
.expr
);
5612 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
5613 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
5615 gfc_init_se (&se
, NULL
);
5616 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
5617 gfc_add_block_to_block (pblock
, &se
.pre
);
5618 gfc_add_modify (pblock
, ubound
, se
.expr
);
5624 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
5625 returns the size (in elements) of the array. */
5628 gfc_trans_array_bounds (tree type
, gfc_symbol
* sym
, tree
* poffset
,
5629 stmtblock_t
* pblock
)
5642 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
5644 size
= gfc_index_one_node
;
5645 offset
= gfc_index_zero_node
;
5646 for (dim
= 0; dim
< as
->rank
; dim
++)
5648 /* Evaluate non-constant array bound expressions. */
5649 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
5650 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
5652 gfc_init_se (&se
, NULL
);
5653 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
5654 gfc_add_block_to_block (pblock
, &se
.pre
);
5655 gfc_add_modify (pblock
, lbound
, se
.expr
);
5657 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
5658 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
5660 gfc_init_se (&se
, NULL
);
5661 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
5662 gfc_add_block_to_block (pblock
, &se
.pre
);
5663 gfc_add_modify (pblock
, ubound
, se
.expr
);
5665 /* The offset of this dimension. offset = offset - lbound * stride. */
5666 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5668 offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5671 /* The size of this dimension, and the stride of the next. */
5672 if (dim
+ 1 < as
->rank
)
5673 stride
= GFC_TYPE_ARRAY_STRIDE (type
, dim
+ 1);
5675 stride
= GFC_TYPE_ARRAY_SIZE (type
);
5677 if (ubound
!= NULL_TREE
&& !(stride
&& INTEGER_CST_P (stride
)))
5679 /* Calculate stride = size * (ubound + 1 - lbound). */
5680 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5681 gfc_array_index_type
,
5682 gfc_index_one_node
, lbound
);
5683 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5684 gfc_array_index_type
, ubound
, tmp
);
5685 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5686 gfc_array_index_type
, size
, tmp
);
5688 gfc_add_modify (pblock
, stride
, tmp
);
5690 stride
= gfc_evaluate_now (tmp
, pblock
);
5692 /* Make sure that negative size arrays are translated
5693 to being zero size. */
5694 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
5695 stride
, gfc_index_zero_node
);
5696 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5697 gfc_array_index_type
, tmp
,
5698 stride
, gfc_index_zero_node
);
5699 gfc_add_modify (pblock
, stride
, tmp
);
5705 gfc_trans_array_cobounds (type
, pblock
, sym
);
5706 gfc_trans_vla_type_sizes (sym
, pblock
);
5713 /* Generate code to initialize/allocate an array variable. */
5716 gfc_trans_auto_array_allocation (tree decl
, gfc_symbol
* sym
,
5717 gfc_wrapped_block
* block
)
5721 tree tmp
= NULL_TREE
;
5728 gcc_assert (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
));
5730 /* Do nothing for USEd variables. */
5731 if (sym
->attr
.use_assoc
)
5734 type
= TREE_TYPE (decl
);
5735 gcc_assert (GFC_ARRAY_TYPE_P (type
));
5736 onstack
= TREE_CODE (type
) != POINTER_TYPE
;
5738 gfc_init_block (&init
);
5740 /* Evaluate character string length. */
5741 if (sym
->ts
.type
== BT_CHARACTER
5742 && onstack
&& !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
5744 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
5746 gfc_trans_vla_type_sizes (sym
, &init
);
5748 /* Emit a DECL_EXPR for this variable, which will cause the
5749 gimplifier to allocate storage, and all that good stuff. */
5750 tmp
= fold_build1_loc (input_location
, DECL_EXPR
, TREE_TYPE (decl
), decl
);
5751 gfc_add_expr_to_block (&init
, tmp
);
5756 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
5760 type
= TREE_TYPE (type
);
5762 gcc_assert (!sym
->attr
.use_assoc
);
5763 gcc_assert (!TREE_STATIC (decl
));
5764 gcc_assert (!sym
->module
);
5766 if (sym
->ts
.type
== BT_CHARACTER
5767 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
5768 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
5770 size
= gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
5772 /* Don't actually allocate space for Cray Pointees. */
5773 if (sym
->attr
.cray_pointee
)
5775 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
5776 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
5778 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
5782 if (flag_stack_arrays
)
5784 gcc_assert (TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
);
5785 space
= build_decl (sym
->declared_at
.lb
->location
,
5786 VAR_DECL
, create_tmp_var_name ("A"),
5787 TREE_TYPE (TREE_TYPE (decl
)));
5788 gfc_trans_vla_type_sizes (sym
, &init
);
5792 /* The size is the number of elements in the array, so multiply by the
5793 size of an element to get the total size. */
5794 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
5795 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5796 size
, fold_convert (gfc_array_index_type
, tmp
));
5798 /* Allocate memory to hold the data. */
5799 tmp
= gfc_call_malloc (&init
, TREE_TYPE (decl
), size
);
5800 gfc_add_modify (&init
, decl
, tmp
);
5802 /* Free the temporary. */
5803 tmp
= gfc_call_free (convert (pvoid_type_node
, decl
));
5807 /* Set offset of the array. */
5808 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
5809 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
5811 /* Automatic arrays should not have initializers. */
5812 gcc_assert (!sym
->value
);
5814 inittree
= gfc_finish_block (&init
);
5821 /* Don't create new scope, emit the DECL_EXPR in exactly the scope
5822 where also space is located. */
5823 gfc_init_block (&init
);
5824 tmp
= fold_build1_loc (input_location
, DECL_EXPR
,
5825 TREE_TYPE (space
), space
);
5826 gfc_add_expr_to_block (&init
, tmp
);
5827 addr
= fold_build1_loc (sym
->declared_at
.lb
->location
,
5828 ADDR_EXPR
, TREE_TYPE (decl
), space
);
5829 gfc_add_modify (&init
, decl
, addr
);
5830 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
5833 gfc_add_init_cleanup (block
, inittree
, tmp
);
5837 /* Generate entry and exit code for g77 calling convention arrays. */
5840 gfc_trans_g77_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
5850 gfc_save_backend_locus (&loc
);
5851 gfc_set_backend_locus (&sym
->declared_at
);
5853 /* Descriptor type. */
5854 parm
= sym
->backend_decl
;
5855 type
= TREE_TYPE (parm
);
5856 gcc_assert (GFC_ARRAY_TYPE_P (type
));
5858 gfc_start_block (&init
);
5860 if (sym
->ts
.type
== BT_CHARACTER
5861 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
5862 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
5864 /* Evaluate the bounds of the array. */
5865 gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
5867 /* Set the offset. */
5868 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
5869 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
5871 /* Set the pointer itself if we aren't using the parameter directly. */
5872 if (TREE_CODE (parm
) != PARM_DECL
)
5874 tmp
= convert (TREE_TYPE (parm
), GFC_DECL_SAVED_DESCRIPTOR (parm
));
5875 gfc_add_modify (&init
, parm
, tmp
);
5877 stmt
= gfc_finish_block (&init
);
5879 gfc_restore_backend_locus (&loc
);
5881 /* Add the initialization code to the start of the function. */
5883 if (sym
->attr
.optional
|| sym
->attr
.not_always_present
)
5885 tmp
= gfc_conv_expr_present (sym
);
5886 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
5889 gfc_add_init_cleanup (block
, stmt
, NULL_TREE
);
5893 /* Modify the descriptor of an array parameter so that it has the
5894 correct lower bound. Also move the upper bound accordingly.
5895 If the array is not packed, it will be copied into a temporary.
5896 For each dimension we set the new lower and upper bounds. Then we copy the
5897 stride and calculate the offset for this dimension. We also work out
5898 what the stride of a packed array would be, and see it the two match.
5899 If the array need repacking, we set the stride to the values we just
5900 calculated, recalculate the offset and copy the array data.
5901 Code is also added to copy the data back at the end of the function.
5905 gfc_trans_dummy_array_bias (gfc_symbol
* sym
, tree tmpdesc
,
5906 gfc_wrapped_block
* block
)
5913 tree stmtInit
, stmtCleanup
;
5920 tree stride
, stride2
;
5930 bool is_classarray
= IS_CLASS_ARRAY (sym
);
5932 /* Do nothing for pointer and allocatable arrays. */
5933 if ((sym
->ts
.type
!= BT_CLASS
&& sym
->attr
.pointer
)
5934 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.class_pointer
)
5935 || sym
->attr
.allocatable
5936 || (is_classarray
&& CLASS_DATA (sym
)->attr
.allocatable
))
5939 if (!is_classarray
&& sym
->attr
.dummy
&& gfc_is_nodesc_array (sym
))
5941 gfc_trans_g77_array (sym
, block
);
5945 gfc_save_backend_locus (&loc
);
5946 gfc_set_backend_locus (&sym
->declared_at
);
5948 /* Descriptor type. */
5949 type
= TREE_TYPE (tmpdesc
);
5950 gcc_assert (GFC_ARRAY_TYPE_P (type
));
5951 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
5953 /* For a class array the dummy array descriptor is in the _class
5955 dumdesc
= gfc_class_data_get (dumdesc
);
5957 dumdesc
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
5958 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
5959 gfc_start_block (&init
);
5961 if (sym
->ts
.type
== BT_CHARACTER
5962 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
5963 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
5965 checkparm
= (as
->type
== AS_EXPLICIT
5966 && (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
));
5968 no_repack
= !(GFC_DECL_PACKED_ARRAY (tmpdesc
)
5969 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
));
5971 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
))
5973 /* For non-constant shape arrays we only check if the first dimension
5974 is contiguous. Repacking higher dimensions wouldn't gain us
5975 anything as we still don't know the array stride. */
5976 partial
= gfc_create_var (boolean_type_node
, "partial");
5977 TREE_USED (partial
) = 1;
5978 tmp
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
5979 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, tmp
,
5980 gfc_index_one_node
);
5981 gfc_add_modify (&init
, partial
, tmp
);
5984 partial
= NULL_TREE
;
5986 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
5987 here, however I think it does the right thing. */
5990 /* Set the first stride. */
5991 stride
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
5992 stride
= gfc_evaluate_now (stride
, &init
);
5994 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5995 stride
, gfc_index_zero_node
);
5996 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
5997 tmp
, gfc_index_one_node
, stride
);
5998 stride
= GFC_TYPE_ARRAY_STRIDE (type
, 0);
5999 gfc_add_modify (&init
, stride
, tmp
);
6001 /* Allow the user to disable array repacking. */
6002 stmt_unpacked
= NULL_TREE
;
6006 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type
, 0)));
6007 /* A library call to repack the array if necessary. */
6008 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6009 stmt_unpacked
= build_call_expr_loc (input_location
,
6010 gfor_fndecl_in_pack
, 1, tmp
);
6012 stride
= gfc_index_one_node
;
6014 if (warn_array_temporaries
)
6015 gfc_warning (OPT_Warray_temporaries
,
6016 "Creating array temporary at %L", &loc
);
6019 /* This is for the case where the array data is used directly without
6020 calling the repack function. */
6021 if (no_repack
|| partial
!= NULL_TREE
)
6022 stmt_packed
= gfc_conv_descriptor_data_get (dumdesc
);
6024 stmt_packed
= NULL_TREE
;
6026 /* Assign the data pointer. */
6027 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
6029 /* Don't repack unknown shape arrays when the first stride is 1. */
6030 tmp
= fold_build3_loc (input_location
, COND_EXPR
, TREE_TYPE (stmt_packed
),
6031 partial
, stmt_packed
, stmt_unpacked
);
6034 tmp
= stmt_packed
!= NULL_TREE
? stmt_packed
: stmt_unpacked
;
6035 gfc_add_modify (&init
, tmpdesc
, fold_convert (type
, tmp
));
6037 offset
= gfc_index_zero_node
;
6038 size
= gfc_index_one_node
;
6040 /* Evaluate the bounds of the array. */
6041 for (n
= 0; n
< as
->rank
; n
++)
6043 if (checkparm
|| !as
->upper
[n
])
6045 /* Get the bounds of the actual parameter. */
6046 dubound
= gfc_conv_descriptor_ubound_get (dumdesc
, gfc_rank_cst
[n
]);
6047 dlbound
= gfc_conv_descriptor_lbound_get (dumdesc
, gfc_rank_cst
[n
]);
6051 dubound
= NULL_TREE
;
6052 dlbound
= NULL_TREE
;
6055 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, n
);
6056 if (!INTEGER_CST_P (lbound
))
6058 gfc_init_se (&se
, NULL
);
6059 gfc_conv_expr_type (&se
, as
->lower
[n
],
6060 gfc_array_index_type
);
6061 gfc_add_block_to_block (&init
, &se
.pre
);
6062 gfc_add_modify (&init
, lbound
, se
.expr
);
6065 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, n
);
6066 /* Set the desired upper bound. */
6069 /* We know what we want the upper bound to be. */
6070 if (!INTEGER_CST_P (ubound
))
6072 gfc_init_se (&se
, NULL
);
6073 gfc_conv_expr_type (&se
, as
->upper
[n
],
6074 gfc_array_index_type
);
6075 gfc_add_block_to_block (&init
, &se
.pre
);
6076 gfc_add_modify (&init
, ubound
, se
.expr
);
6079 /* Check the sizes match. */
6082 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
6086 temp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6087 gfc_array_index_type
, ubound
, lbound
);
6088 temp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6089 gfc_array_index_type
,
6090 gfc_index_one_node
, temp
);
6091 stride2
= fold_build2_loc (input_location
, MINUS_EXPR
,
6092 gfc_array_index_type
, dubound
,
6094 stride2
= fold_build2_loc (input_location
, PLUS_EXPR
,
6095 gfc_array_index_type
,
6096 gfc_index_one_node
, stride2
);
6097 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6098 gfc_array_index_type
, temp
, stride2
);
6099 msg
= xasprintf ("Dimension %d of array '%s' has extent "
6100 "%%ld instead of %%ld", n
+1, sym
->name
);
6102 gfc_trans_runtime_check (true, false, tmp
, &init
, &loc
, msg
,
6103 fold_convert (long_integer_type_node
, temp
),
6104 fold_convert (long_integer_type_node
, stride2
));
6111 /* For assumed shape arrays move the upper bound by the same amount
6112 as the lower bound. */
6113 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6114 gfc_array_index_type
, dubound
, dlbound
);
6115 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6116 gfc_array_index_type
, tmp
, lbound
);
6117 gfc_add_modify (&init
, ubound
, tmp
);
6119 /* The offset of this dimension. offset = offset - lbound * stride. */
6120 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6122 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
6123 gfc_array_index_type
, offset
, tmp
);
6125 /* The size of this dimension, and the stride of the next. */
6126 if (n
+ 1 < as
->rank
)
6128 stride
= GFC_TYPE_ARRAY_STRIDE (type
, n
+ 1);
6130 if (no_repack
|| partial
!= NULL_TREE
)
6132 gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[n
+1]);
6134 /* Figure out the stride if not a known constant. */
6135 if (!INTEGER_CST_P (stride
))
6138 stmt_packed
= NULL_TREE
;
6141 /* Calculate stride = size * (ubound + 1 - lbound). */
6142 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6143 gfc_array_index_type
,
6144 gfc_index_one_node
, lbound
);
6145 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6146 gfc_array_index_type
, ubound
, tmp
);
6147 size
= fold_build2_loc (input_location
, MULT_EXPR
,
6148 gfc_array_index_type
, size
, tmp
);
6152 /* Assign the stride. */
6153 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
6154 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6155 gfc_array_index_type
, partial
,
6156 stmt_unpacked
, stmt_packed
);
6158 tmp
= (stmt_packed
!= NULL_TREE
) ? stmt_packed
: stmt_unpacked
;
6159 gfc_add_modify (&init
, stride
, tmp
);
6164 stride
= GFC_TYPE_ARRAY_SIZE (type
);
6166 if (stride
&& !INTEGER_CST_P (stride
))
6168 /* Calculate size = stride * (ubound + 1 - lbound). */
6169 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6170 gfc_array_index_type
,
6171 gfc_index_one_node
, lbound
);
6172 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6173 gfc_array_index_type
,
6175 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6176 gfc_array_index_type
,
6177 GFC_TYPE_ARRAY_STRIDE (type
, n
), tmp
);
6178 gfc_add_modify (&init
, stride
, tmp
);
6183 gfc_trans_array_cobounds (type
, &init
, sym
);
6185 /* Set the offset. */
6186 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
6187 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6189 gfc_trans_vla_type_sizes (sym
, &init
);
6191 stmtInit
= gfc_finish_block (&init
);
6193 /* Only do the entry/initialization code if the arg is present. */
6194 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6195 optional_arg
= (sym
->attr
.optional
6196 || (sym
->ns
->proc_name
->attr
.entry_master
6197 && sym
->attr
.dummy
));
6200 tmp
= gfc_conv_expr_present (sym
);
6201 stmtInit
= build3_v (COND_EXPR
, tmp
, stmtInit
,
6202 build_empty_stmt (input_location
));
6207 stmtCleanup
= NULL_TREE
;
6210 stmtblock_t cleanup
;
6211 gfc_start_block (&cleanup
);
6213 if (sym
->attr
.intent
!= INTENT_IN
)
6215 /* Copy the data back. */
6216 tmp
= build_call_expr_loc (input_location
,
6217 gfor_fndecl_in_unpack
, 2, dumdesc
, tmpdesc
);
6218 gfc_add_expr_to_block (&cleanup
, tmp
);
6221 /* Free the temporary. */
6222 tmp
= gfc_call_free (tmpdesc
);
6223 gfc_add_expr_to_block (&cleanup
, tmp
);
6225 stmtCleanup
= gfc_finish_block (&cleanup
);
6227 /* Only do the cleanup if the array was repacked. */
6228 tmp
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
6229 tmp
= gfc_conv_descriptor_data_get (tmp
);
6230 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6232 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6233 build_empty_stmt (input_location
));
6237 tmp
= gfc_conv_expr_present (sym
);
6238 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6239 build_empty_stmt (input_location
));
6243 /* We don't need to free any memory allocated by internal_pack as it will
6244 be freed at the end of the function by pop_context. */
6245 gfc_add_init_cleanup (block
, stmtInit
, stmtCleanup
);
6247 gfc_restore_backend_locus (&loc
);
6251 /* Calculate the overall offset, including subreferences. */
6253 gfc_get_dataptr_offset (stmtblock_t
*block
, tree parm
, tree desc
, tree offset
,
6254 bool subref
, gfc_expr
*expr
)
6264 /* If offset is NULL and this is not a subreferenced array, there is
6266 if (offset
== NULL_TREE
)
6269 offset
= gfc_index_zero_node
;
6274 tmp
= build_array_ref (desc
, offset
, NULL
, NULL
);
6276 /* Offset the data pointer for pointer assignments from arrays with
6277 subreferences; e.g. my_integer => my_type(:)%integer_component. */
6280 /* Go past the array reference. */
6281 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6282 if (ref
->type
== REF_ARRAY
&&
6283 ref
->u
.ar
.type
!= AR_ELEMENT
)
6289 /* Calculate the offset for each subsequent subreference. */
6290 for (; ref
; ref
= ref
->next
)
6295 field
= ref
->u
.c
.component
->backend_decl
;
6296 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
6297 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
6299 tmp
, field
, NULL_TREE
);
6303 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
6304 gfc_init_se (&start
, NULL
);
6305 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
6306 gfc_add_block_to_block (block
, &start
.pre
);
6307 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
6311 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
6312 && ref
->u
.ar
.type
== AR_ELEMENT
);
6314 /* TODO - Add bounds checking. */
6315 stride
= gfc_index_one_node
;
6316 index
= gfc_index_zero_node
;
6317 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
6322 /* Update the index. */
6323 gfc_init_se (&start
, NULL
);
6324 gfc_conv_expr_type (&start
, ref
->u
.ar
.start
[n
], gfc_array_index_type
);
6325 itmp
= gfc_evaluate_now (start
.expr
, block
);
6326 gfc_init_se (&start
, NULL
);
6327 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->lower
[n
], gfc_array_index_type
);
6328 jtmp
= gfc_evaluate_now (start
.expr
, block
);
6329 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6330 gfc_array_index_type
, itmp
, jtmp
);
6331 itmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6332 gfc_array_index_type
, itmp
, stride
);
6333 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
6334 gfc_array_index_type
, itmp
, index
);
6335 index
= gfc_evaluate_now (index
, block
);
6337 /* Update the stride. */
6338 gfc_init_se (&start
, NULL
);
6339 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->upper
[n
], gfc_array_index_type
);
6340 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6341 gfc_array_index_type
, start
.expr
,
6343 itmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6344 gfc_array_index_type
,
6345 gfc_index_one_node
, itmp
);
6346 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
6347 gfc_array_index_type
, stride
, itmp
);
6348 stride
= gfc_evaluate_now (stride
, block
);
6351 /* Apply the index to obtain the array element. */
6352 tmp
= gfc_build_array_ref (tmp
, index
, NULL
);
6362 /* Set the target data pointer. */
6363 offset
= gfc_build_addr_expr (gfc_array_dataptr_type (desc
), tmp
);
6364 gfc_conv_descriptor_data_set (block
, parm
, offset
);
6368 /* gfc_conv_expr_descriptor needs the string length an expression
6369 so that the size of the temporary can be obtained. This is done
6370 by adding up the string lengths of all the elements in the
6371 expression. Function with non-constant expressions have their
6372 string lengths mapped onto the actual arguments using the
6373 interface mapping machinery in trans-expr.c. */
6375 get_array_charlen (gfc_expr
*expr
, gfc_se
*se
)
6377 gfc_interface_mapping mapping
;
6378 gfc_formal_arglist
*formal
;
6379 gfc_actual_arglist
*arg
;
6382 if (expr
->ts
.u
.cl
->length
6383 && gfc_is_constant_expr (expr
->ts
.u
.cl
->length
))
6385 if (!expr
->ts
.u
.cl
->backend_decl
)
6386 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6390 switch (expr
->expr_type
)
6393 get_array_charlen (expr
->value
.op
.op1
, se
);
6395 /* For parentheses the expression ts.u.cl is identical. */
6396 if (expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
6399 expr
->ts
.u
.cl
->backend_decl
=
6400 gfc_create_var (gfc_charlen_type_node
, "sln");
6402 if (expr
->value
.op
.op2
)
6404 get_array_charlen (expr
->value
.op
.op2
, se
);
6406 gcc_assert (expr
->value
.op
.op
== INTRINSIC_CONCAT
);
6408 /* Add the string lengths and assign them to the expression
6409 string length backend declaration. */
6410 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
6411 fold_build2_loc (input_location
, PLUS_EXPR
,
6412 gfc_charlen_type_node
,
6413 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
,
6414 expr
->value
.op
.op2
->ts
.u
.cl
->backend_decl
));
6417 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
6418 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
);
6422 if (expr
->value
.function
.esym
== NULL
6423 || expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6425 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6429 /* Map expressions involving the dummy arguments onto the actual
6430 argument expressions. */
6431 gfc_init_interface_mapping (&mapping
);
6432 formal
= gfc_sym_get_dummy_args (expr
->symtree
->n
.sym
);
6433 arg
= expr
->value
.function
.actual
;
6435 /* Set se = NULL in the calls to the interface mapping, to suppress any
6437 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
6442 gfc_add_interface_mapping (&mapping
, formal
->sym
, NULL
, arg
->expr
);
6445 gfc_init_se (&tse
, NULL
);
6447 /* Build the expression for the character length and convert it. */
6448 gfc_apply_interface_mapping (&mapping
, &tse
, expr
->ts
.u
.cl
->length
);
6450 gfc_add_block_to_block (&se
->pre
, &tse
.pre
);
6451 gfc_add_block_to_block (&se
->post
, &tse
.post
);
6452 tse
.expr
= fold_convert (gfc_charlen_type_node
, tse
.expr
);
6453 tse
.expr
= fold_build2_loc (input_location
, MAX_EXPR
,
6454 gfc_charlen_type_node
, tse
.expr
,
6455 build_int_cst (gfc_charlen_type_node
, 0));
6456 expr
->ts
.u
.cl
->backend_decl
= tse
.expr
;
6457 gfc_free_interface_mapping (&mapping
);
6461 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6467 /* Helper function to check dimensions. */
6469 transposed_dims (gfc_ss
*ss
)
6473 for (n
= 0; n
< ss
->dimen
; n
++)
6474 if (ss
->dim
[n
] != n
)
6480 /* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
6481 AR_FULL, suitable for the scalarizer. */
6484 walk_coarray (gfc_expr
*e
)
6488 gcc_assert (gfc_get_corank (e
) > 0);
6490 ss
= gfc_walk_expr (e
);
6492 /* Fix scalar coarray. */
6493 if (ss
== gfc_ss_terminator
)
6500 if (ref
->type
== REF_ARRAY
6501 && ref
->u
.ar
.codimen
> 0)
6507 gcc_assert (ref
!= NULL
);
6508 if (ref
->u
.ar
.type
== AR_ELEMENT
)
6509 ref
->u
.ar
.type
= AR_SECTION
;
6510 ss
= gfc_reverse_ss (gfc_walk_array_ref (ss
, e
, ref
));
6517 /* Convert an array for passing as an actual argument. Expressions and
6518 vector subscripts are evaluated and stored in a temporary, which is then
6519 passed. For whole arrays the descriptor is passed. For array sections
6520 a modified copy of the descriptor is passed, but using the original data.
6522 This function is also used for array pointer assignments, and there
6525 - se->want_pointer && !se->direct_byref
6526 EXPR is an actual argument. On exit, se->expr contains a
6527 pointer to the array descriptor.
6529 - !se->want_pointer && !se->direct_byref
6530 EXPR is an actual argument to an intrinsic function or the
6531 left-hand side of a pointer assignment. On exit, se->expr
6532 contains the descriptor for EXPR.
6534 - !se->want_pointer && se->direct_byref
6535 EXPR is the right-hand side of a pointer assignment and
6536 se->expr is the descriptor for the previously-evaluated
6537 left-hand side. The function creates an assignment from
6541 The se->force_tmp flag disables the non-copying descriptor optimization
6542 that is used for transpose. It may be used in cases where there is an
6543 alias between the transpose argument and another argument in the same
6547 gfc_conv_expr_descriptor (gfc_se
*se
, gfc_expr
*expr
)
6550 gfc_ss_type ss_type
;
6551 gfc_ss_info
*ss_info
;
6553 gfc_array_info
*info
;
6562 bool subref_array_target
= false;
6563 gfc_expr
*arg
, *ss_expr
;
6565 if (se
->want_coarray
)
6566 ss
= walk_coarray (expr
);
6568 ss
= gfc_walk_expr (expr
);
6570 gcc_assert (ss
!= NULL
);
6571 gcc_assert (ss
!= gfc_ss_terminator
);
6574 ss_type
= ss_info
->type
;
6575 ss_expr
= ss_info
->expr
;
6577 /* Special case: TRANSPOSE which needs no temporary. */
6578 while (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
6579 && NULL
!= (arg
= gfc_get_noncopying_intrinsic_argument (expr
)))
6581 /* This is a call to transpose which has already been handled by the
6582 scalarizer, so that we just need to get its argument's descriptor. */
6583 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
6584 expr
= expr
->value
.function
.actual
->expr
;
6587 /* Special case things we know we can pass easily. */
6588 switch (expr
->expr_type
)
6591 /* If we have a linear array section, we can pass it directly.
6592 Otherwise we need to copy it into a temporary. */
6594 gcc_assert (ss_type
== GFC_SS_SECTION
);
6595 gcc_assert (ss_expr
== expr
);
6596 info
= &ss_info
->data
.array
;
6598 /* Get the descriptor for the array. */
6599 gfc_conv_ss_descriptor (&se
->pre
, ss
, 0);
6600 desc
= info
->descriptor
;
6602 subref_array_target
= se
->direct_byref
&& is_subref_array (expr
);
6603 need_tmp
= gfc_ref_needs_temporary_p (expr
->ref
)
6604 && !subref_array_target
;
6611 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
6613 /* Create a new descriptor if the array doesn't have one. */
6616 else if (info
->ref
->u
.ar
.type
== AR_FULL
|| se
->descriptor_only
)
6618 else if (se
->direct_byref
)
6621 full
= gfc_full_array_ref_p (info
->ref
, NULL
);
6623 if (full
&& !transposed_dims (ss
))
6625 if (se
->direct_byref
&& !se
->byref_noassign
)
6627 /* Copy the descriptor for pointer assignments. */
6628 gfc_add_modify (&se
->pre
, se
->expr
, desc
);
6630 /* Add any offsets from subreferences. */
6631 gfc_get_dataptr_offset (&se
->pre
, se
->expr
, desc
, NULL_TREE
,
6632 subref_array_target
, expr
);
6634 else if (se
->want_pointer
)
6636 /* We pass full arrays directly. This means that pointers and
6637 allocatable arrays should also work. */
6638 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
6645 if (expr
->ts
.type
== BT_CHARACTER
)
6646 se
->string_length
= gfc_get_expr_charlen (expr
);
6648 gfc_free_ss_chain (ss
);
6654 /* A transformational function return value will be a temporary
6655 array descriptor. We still need to go through the scalarizer
6656 to create the descriptor. Elemental functions are handled as
6657 arbitrary expressions, i.e. copy to a temporary. */
6659 if (se
->direct_byref
)
6661 gcc_assert (ss_type
== GFC_SS_FUNCTION
&& ss_expr
== expr
);
6663 /* For pointer assignments pass the descriptor directly. */
6667 gcc_assert (se
->ss
== ss
);
6668 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
6669 gfc_conv_expr (se
, expr
);
6670 gfc_free_ss_chain (ss
);
6674 if (ss_expr
!= expr
|| ss_type
!= GFC_SS_FUNCTION
)
6676 if (ss_expr
!= expr
)
6677 /* Elemental function. */
6678 gcc_assert ((expr
->value
.function
.esym
!= NULL
6679 && expr
->value
.function
.esym
->attr
.elemental
)
6680 || (expr
->value
.function
.isym
!= NULL
6681 && expr
->value
.function
.isym
->elemental
)
6682 || gfc_inline_intrinsic_function_p (expr
));
6684 gcc_assert (ss_type
== GFC_SS_INTRINSIC
);
6687 if (expr
->ts
.type
== BT_CHARACTER
6688 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
6689 get_array_charlen (expr
, se
);
6695 /* Transformational function. */
6696 info
= &ss_info
->data
.array
;
6702 /* Constant array constructors don't need a temporary. */
6703 if (ss_type
== GFC_SS_CONSTRUCTOR
6704 && expr
->ts
.type
!= BT_CHARACTER
6705 && gfc_constant_array_constructor_p (expr
->value
.constructor
))
6708 info
= &ss_info
->data
.array
;
6718 /* Something complicated. Copy it into a temporary. */
6724 /* If we are creating a temporary, we don't need to bother about aliases
6729 gfc_init_loopinfo (&loop
);
6731 /* Associate the SS with the loop. */
6732 gfc_add_ss_to_loop (&loop
, ss
);
6734 /* Tell the scalarizer not to bother creating loop variables, etc. */
6736 loop
.array_parameter
= 1;
6738 /* The right-hand side of a pointer assignment mustn't use a temporary. */
6739 gcc_assert (!se
->direct_byref
);
6741 /* Setup the scalarizing loops and bounds. */
6742 gfc_conv_ss_startstride (&loop
);
6746 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
6747 get_array_charlen (expr
, se
);
6749 /* Tell the scalarizer to make a temporary. */
6750 loop
.temp_ss
= gfc_get_temp_ss (gfc_typenode_for_spec (&expr
->ts
),
6751 ((expr
->ts
.type
== BT_CHARACTER
)
6752 ? expr
->ts
.u
.cl
->backend_decl
6756 se
->string_length
= loop
.temp_ss
->info
->string_length
;
6757 gcc_assert (loop
.temp_ss
->dimen
== loop
.dimen
);
6758 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
6761 gfc_conv_loop_setup (&loop
, & expr
->where
);
6765 /* Copy into a temporary and pass that. We don't need to copy the data
6766 back because expressions and vector subscripts must be INTENT_IN. */
6767 /* TODO: Optimize passing function return values. */
6771 /* Start the copying loops. */
6772 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
6773 gfc_mark_ss_chain_used (ss
, 1);
6774 gfc_start_scalarized_body (&loop
, &block
);
6776 /* Copy each data element. */
6777 gfc_init_se (&lse
, NULL
);
6778 gfc_copy_loopinfo_to_se (&lse
, &loop
);
6779 gfc_init_se (&rse
, NULL
);
6780 gfc_copy_loopinfo_to_se (&rse
, &loop
);
6782 lse
.ss
= loop
.temp_ss
;
6785 gfc_conv_scalarized_array_ref (&lse
, NULL
);
6786 if (expr
->ts
.type
== BT_CHARACTER
)
6788 gfc_conv_expr (&rse
, expr
);
6789 if (POINTER_TYPE_P (TREE_TYPE (rse
.expr
)))
6790 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
6794 gfc_conv_expr_val (&rse
, expr
);
6796 gfc_add_block_to_block (&block
, &rse
.pre
);
6797 gfc_add_block_to_block (&block
, &lse
.pre
);
6799 lse
.string_length
= rse
.string_length
;
6800 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true,
6801 expr
->expr_type
== EXPR_VARIABLE
6802 || expr
->expr_type
== EXPR_ARRAY
, true);
6803 gfc_add_expr_to_block (&block
, tmp
);
6805 /* Finish the copying loops. */
6806 gfc_trans_scalarizing_loops (&loop
, &block
);
6808 desc
= loop
.temp_ss
->info
->data
.array
.descriptor
;
6810 else if (expr
->expr_type
== EXPR_FUNCTION
&& !transposed_dims (ss
))
6812 desc
= info
->descriptor
;
6813 se
->string_length
= ss_info
->string_length
;
6817 /* We pass sections without copying to a temporary. Make a new
6818 descriptor and point it at the section we want. The loop variable
6819 limits will be the limits of the section.
6820 A function may decide to repack the array to speed up access, but
6821 we're not bothered about that here. */
6822 int dim
, ndim
, codim
;
6829 bool onebased
= false;
6831 ndim
= info
->ref
? info
->ref
->u
.ar
.dimen
: ss
->dimen
;
6833 if (se
->want_coarray
)
6835 gfc_array_ref
*ar
= &info
->ref
->u
.ar
;
6837 codim
= gfc_get_corank (expr
);
6838 for (n
= 0; n
< codim
- 1; n
++)
6840 /* Make sure we are not lost somehow. */
6841 gcc_assert (ar
->dimen_type
[n
+ ndim
] == DIMEN_THIS_IMAGE
);
6843 /* Make sure the call to gfc_conv_section_startstride won't
6844 generate unnecessary code to calculate stride. */
6845 gcc_assert (ar
->stride
[n
+ ndim
] == NULL
);
6847 gfc_conv_section_startstride (&loop
.pre
, ss
, n
+ ndim
);
6848 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
6849 loop
.to
[n
+ loop
.dimen
] = info
->end
[n
+ ndim
];
6852 gcc_assert (n
== codim
- 1);
6853 evaluate_bound (&loop
.pre
, info
->start
, ar
->start
,
6854 info
->descriptor
, n
+ ndim
, true);
6855 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
6860 /* Set the string_length for a character array. */
6861 if (expr
->ts
.type
== BT_CHARACTER
)
6862 se
->string_length
= gfc_get_expr_charlen (expr
);
6864 desc
= info
->descriptor
;
6865 if (se
->direct_byref
&& !se
->byref_noassign
)
6867 /* For pointer assignments we fill in the destination. */
6869 parmtype
= TREE_TYPE (parm
);
6873 /* Otherwise make a new one. */
6874 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
6875 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
, codim
,
6876 loop
.from
, loop
.to
, 0,
6877 GFC_ARRAY_UNKNOWN
, false);
6878 parm
= gfc_create_var (parmtype
, "parm");
6881 offset
= gfc_index_zero_node
;
6883 /* The following can be somewhat confusing. We have two
6884 descriptors, a new one and the original array.
6885 {parm, parmtype, dim} refer to the new one.
6886 {desc, type, n, loop} refer to the original, which maybe
6887 a descriptorless array.
6888 The bounds of the scalarization are the bounds of the section.
6889 We don't have to worry about numeric overflows when calculating
6890 the offsets because all elements are within the array data. */
6892 /* Set the dtype. */
6893 tmp
= gfc_conv_descriptor_dtype (parm
);
6894 gfc_add_modify (&loop
.pre
, tmp
, gfc_get_dtype (parmtype
));
6896 /* Set offset for assignments to pointer only to zero if it is not
6898 if ((se
->direct_byref
|| se
->use_offset
)
6899 && ((info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
6900 || (expr
->expr_type
== EXPR_ARRAY
&& se
->use_offset
)))
6901 base
= gfc_index_zero_node
;
6902 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
6903 base
= gfc_evaluate_now (gfc_conv_array_offset (desc
), &loop
.pre
);
6907 for (n
= 0; n
< ndim
; n
++)
6909 stride
= gfc_conv_array_stride (desc
, n
);
6911 /* Work out the offset. */
6913 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
6915 gcc_assert (info
->subscript
[n
]
6916 && info
->subscript
[n
]->info
->type
== GFC_SS_SCALAR
);
6917 start
= info
->subscript
[n
]->info
->data
.scalar
.value
;
6921 /* Evaluate and remember the start of the section. */
6922 start
= info
->start
[n
];
6923 stride
= gfc_evaluate_now (stride
, &loop
.pre
);
6926 tmp
= gfc_conv_array_lbound (desc
, n
);
6927 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
6929 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
6931 offset
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (tmp
),
6935 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
6937 /* For elemental dimensions, we only need the offset. */
6941 /* Vector subscripts need copying and are handled elsewhere. */
6943 gcc_assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
6945 /* look for the corresponding scalarizer dimension: dim. */
6946 for (dim
= 0; dim
< ndim
; dim
++)
6947 if (ss
->dim
[dim
] == n
)
6950 /* loop exited early: the DIM being looked for has been found. */
6951 gcc_assert (dim
< ndim
);
6953 /* Set the new lower bound. */
6954 from
= loop
.from
[dim
];
6957 /* If we have an array section or are assigning make sure that
6958 the lower bound is 1. References to the full
6959 array should otherwise keep the original bounds. */
6961 || info
->ref
->u
.ar
.type
!= AR_FULL
)
6962 && !integer_onep (from
))
6964 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6965 gfc_array_index_type
, gfc_index_one_node
,
6967 to
= fold_build2_loc (input_location
, PLUS_EXPR
,
6968 gfc_array_index_type
, to
, tmp
);
6969 from
= gfc_index_one_node
;
6971 onebased
= integer_onep (from
);
6972 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
6973 gfc_rank_cst
[dim
], from
);
6975 /* Set the new upper bound. */
6976 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
6977 gfc_rank_cst
[dim
], to
);
6979 /* Multiply the stride by the section stride to get the
6981 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
6982 gfc_array_index_type
,
6983 stride
, info
->stride
[n
]);
6985 if (se
->direct_byref
6986 && ((info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
6987 || (expr
->expr_type
== EXPR_ARRAY
&& se
->use_offset
)))
6989 base
= fold_build2_loc (input_location
, MINUS_EXPR
,
6990 TREE_TYPE (base
), base
, stride
);
6992 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)) || se
->use_offset
)
6994 tmp
= gfc_conv_array_lbound (desc
, n
);
6995 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6996 TREE_TYPE (base
), tmp
, loop
.from
[dim
]);
6997 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6998 TREE_TYPE (base
), tmp
,
6999 gfc_conv_array_stride (desc
, n
));
7000 base
= fold_build2_loc (input_location
, PLUS_EXPR
,
7001 TREE_TYPE (base
), tmp
, base
);
7004 /* Store the new stride. */
7005 gfc_conv_descriptor_stride_set (&loop
.pre
, parm
,
7006 gfc_rank_cst
[dim
], stride
);
7009 for (n
= loop
.dimen
; n
< loop
.dimen
+ codim
; n
++)
7011 from
= loop
.from
[n
];
7013 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
7014 gfc_rank_cst
[n
], from
);
7015 if (n
< loop
.dimen
+ codim
- 1)
7016 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
7017 gfc_rank_cst
[n
], to
);
7020 if (se
->data_not_needed
)
7021 gfc_conv_descriptor_data_set (&loop
.pre
, parm
,
7022 gfc_index_zero_node
);
7024 /* Point the data pointer at the 1st element in the section. */
7025 gfc_get_dataptr_offset (&loop
.pre
, parm
, desc
, offset
,
7026 subref_array_target
, expr
);
7028 /* Force the offset to be -1, when the lower bound of the highest
7029 dimension is one and the symbol is present and is not a
7030 pointer/allocatable or associated. */
7031 if (onebased
&& se
->use_offset
7033 && !(expr
->symtree
->n
.sym
&& expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
7034 && !CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.class_pointer
)
7035 && !expr
->symtree
->n
.sym
->attr
.allocatable
7036 && !expr
->symtree
->n
.sym
->attr
.pointer
7037 && !expr
->symtree
->n
.sym
->attr
.host_assoc
7038 && !expr
->symtree
->n
.sym
->attr
.use_assoc
)
7040 /* Set the offset to -1. */
7042 mpz_init_set_si (minus_one
, -1);
7043 tmp
= gfc_conv_mpz_to_tree (minus_one
, gfc_index_integer_kind
);
7044 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, tmp
);
7046 else if (((se
->direct_byref
|| GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7047 && !se
->data_not_needed
)
7048 || (se
->use_offset
&& base
!= NULL_TREE
))
7049 /* Set the offset depending on base. */
7050 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, base
);
7053 /* Only the callee knows what the correct offset it, so just set
7055 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, gfc_index_zero_node
);
7060 if (!se
->direct_byref
|| se
->byref_noassign
)
7062 /* Get a pointer to the new descriptor. */
7063 if (se
->want_pointer
)
7064 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
7069 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
7070 gfc_add_block_to_block (&se
->post
, &loop
.post
);
7072 /* Cleanup the scalarizer. */
7073 gfc_cleanup_loop (&loop
);
7076 /* Helper function for gfc_conv_array_parameter if array size needs to be
7080 array_parameter_size (tree desc
, gfc_expr
*expr
, tree
*size
)
7083 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7084 *size
= GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc
));
7085 else if (expr
->rank
> 1)
7086 *size
= build_call_expr_loc (input_location
,
7087 gfor_fndecl_size0
, 1,
7088 gfc_build_addr_expr (NULL
, desc
));
7091 tree ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_index_zero_node
);
7092 tree lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_index_zero_node
);
7094 *size
= fold_build2_loc (input_location
, MINUS_EXPR
,
7095 gfc_array_index_type
, ubound
, lbound
);
7096 *size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7097 *size
, gfc_index_one_node
);
7098 *size
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
7099 *size
, gfc_index_zero_node
);
7101 elem
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
7102 *size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7103 *size
, fold_convert (gfc_array_index_type
, elem
));
7106 /* Convert an array for passing as an actual parameter. */
7107 /* TODO: Optimize passing g77 arrays. */
7110 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, bool g77
,
7111 const gfc_symbol
*fsym
, const char *proc_name
,
7116 tree tmp
= NULL_TREE
;
7118 tree parent
= DECL_CONTEXT (current_function_decl
);
7119 bool full_array_var
;
7120 bool this_array_result
;
7123 bool array_constructor
;
7124 bool good_allocatable
;
7125 bool ultimate_ptr_comp
;
7126 bool ultimate_alloc_comp
;
7131 ultimate_ptr_comp
= false;
7132 ultimate_alloc_comp
= false;
7134 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7136 if (ref
->next
== NULL
)
7139 if (ref
->type
== REF_COMPONENT
)
7141 ultimate_ptr_comp
= ref
->u
.c
.component
->attr
.pointer
;
7142 ultimate_alloc_comp
= ref
->u
.c
.component
->attr
.allocatable
;
7146 full_array_var
= false;
7149 if (expr
->expr_type
== EXPR_VARIABLE
&& ref
&& !ultimate_ptr_comp
)
7150 full_array_var
= gfc_full_array_ref_p (ref
, &contiguous
);
7152 sym
= full_array_var
? expr
->symtree
->n
.sym
: NULL
;
7154 /* The symbol should have an array specification. */
7155 gcc_assert (!sym
|| sym
->as
|| ref
->u
.ar
.as
);
7157 if (expr
->expr_type
== EXPR_ARRAY
&& expr
->ts
.type
== BT_CHARACTER
)
7159 get_array_ctor_strlen (&se
->pre
, expr
->value
.constructor
, &tmp
);
7160 expr
->ts
.u
.cl
->backend_decl
= tmp
;
7161 se
->string_length
= tmp
;
7164 /* Is this the result of the enclosing procedure? */
7165 this_array_result
= (full_array_var
&& sym
->attr
.flavor
== FL_PROCEDURE
);
7166 if (this_array_result
7167 && (sym
->backend_decl
!= current_function_decl
)
7168 && (sym
->backend_decl
!= parent
))
7169 this_array_result
= false;
7171 /* Passing address of the array if it is not pointer or assumed-shape. */
7172 if (full_array_var
&& g77
&& !this_array_result
7173 && sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
7175 tmp
= gfc_get_symbol_decl (sym
);
7177 if (sym
->ts
.type
== BT_CHARACTER
)
7178 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
7180 if (!sym
->attr
.pointer
7182 && sym
->as
->type
!= AS_ASSUMED_SHAPE
7183 && sym
->as
->type
!= AS_DEFERRED
7184 && sym
->as
->type
!= AS_ASSUMED_RANK
7185 && !sym
->attr
.allocatable
)
7187 /* Some variables are declared directly, others are declared as
7188 pointers and allocated on the heap. */
7189 if (sym
->attr
.dummy
|| POINTER_TYPE_P (TREE_TYPE (tmp
)))
7192 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
7194 array_parameter_size (tmp
, expr
, size
);
7198 if (sym
->attr
.allocatable
)
7200 if (sym
->attr
.dummy
|| sym
->attr
.result
)
7202 gfc_conv_expr_descriptor (se
, expr
);
7206 array_parameter_size (tmp
, expr
, size
);
7207 se
->expr
= gfc_conv_array_data (tmp
);
7212 /* A convenient reduction in scope. */
7213 contiguous
= g77
&& !this_array_result
&& contiguous
;
7215 /* There is no need to pack and unpack the array, if it is contiguous
7216 and not a deferred- or assumed-shape array, or if it is simply
7218 no_pack
= ((sym
&& sym
->as
7219 && !sym
->attr
.pointer
7220 && sym
->as
->type
!= AS_DEFERRED
7221 && sym
->as
->type
!= AS_ASSUMED_RANK
7222 && sym
->as
->type
!= AS_ASSUMED_SHAPE
)
7224 (ref
&& ref
->u
.ar
.as
7225 && ref
->u
.ar
.as
->type
!= AS_DEFERRED
7226 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_RANK
7227 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_SHAPE
)
7229 gfc_is_simply_contiguous (expr
, false));
7231 no_pack
= contiguous
&& no_pack
;
7233 /* Array constructors are always contiguous and do not need packing. */
7234 array_constructor
= g77
&& !this_array_result
&& expr
->expr_type
== EXPR_ARRAY
;
7236 /* Same is true of contiguous sections from allocatable variables. */
7237 good_allocatable
= contiguous
7239 && expr
->symtree
->n
.sym
->attr
.allocatable
;
7241 /* Or ultimate allocatable components. */
7242 ultimate_alloc_comp
= contiguous
&& ultimate_alloc_comp
;
7244 if (no_pack
|| array_constructor
|| good_allocatable
|| ultimate_alloc_comp
)
7246 gfc_conv_expr_descriptor (se
, expr
);
7247 if (expr
->ts
.type
== BT_CHARACTER
)
7248 se
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
7250 array_parameter_size (se
->expr
, expr
, size
);
7251 se
->expr
= gfc_conv_array_data (se
->expr
);
7255 if (this_array_result
)
7257 /* Result of the enclosing function. */
7258 gfc_conv_expr_descriptor (se
, expr
);
7260 array_parameter_size (se
->expr
, expr
, size
);
7261 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7263 if (g77
&& TREE_TYPE (TREE_TYPE (se
->expr
)) != NULL_TREE
7264 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
7265 se
->expr
= gfc_conv_array_data (build_fold_indirect_ref_loc (input_location
,
7272 /* Every other type of array. */
7273 se
->want_pointer
= 1;
7274 gfc_conv_expr_descriptor (se
, expr
);
7276 array_parameter_size (build_fold_indirect_ref_loc (input_location
,
7281 /* Deallocate the allocatable components of structures that are
7283 if ((expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
)
7284 && expr
->ts
.u
.derived
->attr
.alloc_comp
7285 && expr
->expr_type
!= EXPR_VARIABLE
)
7287 tmp
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7288 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
, expr
->rank
);
7290 /* The components shall be deallocated before their containing entity. */
7291 gfc_prepend_expr_to_block (&se
->post
, tmp
);
7294 if (g77
|| (fsym
&& fsym
->attr
.contiguous
7295 && !gfc_is_simply_contiguous (expr
, false)))
7297 tree origptr
= NULL_TREE
;
7301 /* For contiguous arrays, save the original value of the descriptor. */
7304 origptr
= gfc_create_var (pvoid_type_node
, "origptr");
7305 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7306 tmp
= gfc_conv_array_data (tmp
);
7307 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7308 TREE_TYPE (origptr
), origptr
,
7309 fold_convert (TREE_TYPE (origptr
), tmp
));
7310 gfc_add_expr_to_block (&se
->pre
, tmp
);
7313 /* Repack the array. */
7314 if (warn_array_temporaries
)
7317 gfc_warning (OPT_Warray_temporaries
,
7318 "Creating array temporary at %L for argument %qs",
7319 &expr
->where
, fsym
->name
);
7321 gfc_warning (OPT_Warray_temporaries
,
7322 "Creating array temporary at %L", &expr
->where
);
7325 ptr
= build_call_expr_loc (input_location
,
7326 gfor_fndecl_in_pack
, 1, desc
);
7328 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7330 tmp
= gfc_conv_expr_present (sym
);
7331 ptr
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
7332 tmp
, fold_convert (TREE_TYPE (se
->expr
), ptr
),
7333 fold_convert (TREE_TYPE (se
->expr
), null_pointer_node
));
7336 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
7338 /* Use the packed data for the actual argument, except for contiguous arrays,
7339 where the descriptor's data component is set. */
7344 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7346 gfc_ss
* ss
= gfc_walk_expr (expr
);
7347 if (!transposed_dims (ss
))
7348 gfc_conv_descriptor_data_set (&se
->pre
, tmp
, ptr
);
7351 tree old_field
, new_field
;
7353 /* The original descriptor has transposed dims so we can't reuse
7354 it directly; we have to create a new one. */
7355 tree old_desc
= tmp
;
7356 tree new_desc
= gfc_create_var (TREE_TYPE (old_desc
), "arg_desc");
7358 old_field
= gfc_conv_descriptor_dtype (old_desc
);
7359 new_field
= gfc_conv_descriptor_dtype (new_desc
);
7360 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7362 old_field
= gfc_conv_descriptor_offset (old_desc
);
7363 new_field
= gfc_conv_descriptor_offset (new_desc
);
7364 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7366 for (int i
= 0; i
< expr
->rank
; i
++)
7368 old_field
= gfc_conv_descriptor_dimension (old_desc
,
7369 gfc_rank_cst
[get_array_ref_dim_for_loop_dim (ss
, i
)]);
7370 new_field
= gfc_conv_descriptor_dimension (new_desc
,
7372 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7375 if (flag_coarray
== GFC_FCOARRAY_LIB
7376 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (old_desc
))
7377 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (old_desc
))
7378 == GFC_ARRAY_ALLOCATABLE
)
7380 old_field
= gfc_conv_descriptor_token (old_desc
);
7381 new_field
= gfc_conv_descriptor_token (new_desc
);
7382 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7385 gfc_conv_descriptor_data_set (&se
->pre
, new_desc
, ptr
);
7386 se
->expr
= gfc_build_addr_expr (NULL_TREE
, new_desc
);
7391 if (gfc_option
.rtcheck
& GFC_RTCHECK_ARRAY_TEMPS
)
7395 if (fsym
&& proc_name
)
7396 msg
= xasprintf ("An array temporary was created for argument "
7397 "'%s' of procedure '%s'", fsym
->name
, proc_name
);
7399 msg
= xasprintf ("An array temporary was created");
7401 tmp
= build_fold_indirect_ref_loc (input_location
,
7403 tmp
= gfc_conv_array_data (tmp
);
7404 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7405 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
7407 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7408 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7410 gfc_conv_expr_present (sym
), tmp
);
7412 gfc_trans_runtime_check (false, true, tmp
, &se
->pre
,
7417 gfc_start_block (&block
);
7419 /* Copy the data back. */
7420 if (fsym
== NULL
|| fsym
->attr
.intent
!= INTENT_IN
)
7422 tmp
= build_call_expr_loc (input_location
,
7423 gfor_fndecl_in_unpack
, 2, desc
, ptr
);
7424 gfc_add_expr_to_block (&block
, tmp
);
7427 /* Free the temporary. */
7428 tmp
= gfc_call_free (convert (pvoid_type_node
, ptr
));
7429 gfc_add_expr_to_block (&block
, tmp
);
7431 stmt
= gfc_finish_block (&block
);
7433 gfc_init_block (&block
);
7434 /* Only if it was repacked. This code needs to be executed before the
7435 loop cleanup code. */
7436 tmp
= build_fold_indirect_ref_loc (input_location
,
7438 tmp
= gfc_conv_array_data (tmp
);
7439 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7440 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
7442 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7443 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7445 gfc_conv_expr_present (sym
), tmp
);
7447 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
7449 gfc_add_expr_to_block (&block
, tmp
);
7450 gfc_add_block_to_block (&block
, &se
->post
);
7452 gfc_init_block (&se
->post
);
7454 /* Reset the descriptor pointer. */
7457 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7458 gfc_conv_descriptor_data_set (&se
->post
, tmp
, origptr
);
7461 gfc_add_block_to_block (&se
->post
, &block
);
7466 /* Generate code to deallocate an array, if it is allocated. */
7469 gfc_trans_dealloc_allocated (tree descriptor
, bool coarray
, gfc_expr
*expr
)
7475 gfc_start_block (&block
);
7477 var
= gfc_conv_descriptor_data_get (descriptor
);
7480 /* Call array_deallocate with an int * present in the second argument.
7481 Although it is ignored here, it's presence ensures that arrays that
7482 are already deallocated are ignored. */
7483 tmp
= gfc_deallocate_with_status (coarray
? descriptor
: var
, NULL_TREE
,
7484 NULL_TREE
, NULL_TREE
, NULL_TREE
, true,
7486 gfc_add_expr_to_block (&block
, tmp
);
7488 /* Zero the data pointer. */
7489 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
7490 var
, build_int_cst (TREE_TYPE (var
), 0));
7491 gfc_add_expr_to_block (&block
, tmp
);
7493 return gfc_finish_block (&block
);
7497 /* This helper function calculates the size in words of a full array. */
7500 gfc_full_array_size (stmtblock_t
*block
, tree decl
, int rank
)
7505 idx
= gfc_rank_cst
[rank
- 1];
7506 nelems
= gfc_conv_descriptor_ubound_get (decl
, idx
);
7507 tmp
= gfc_conv_descriptor_lbound_get (decl
, idx
);
7508 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7510 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7511 tmp
, gfc_index_one_node
);
7512 tmp
= gfc_evaluate_now (tmp
, block
);
7514 nelems
= gfc_conv_descriptor_stride_get (decl
, idx
);
7515 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7517 return gfc_evaluate_now (tmp
, block
);
7521 /* Allocate dest to the same size as src, and copy src -> dest.
7522 If no_malloc is set, only the copy is done. */
7525 duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
7526 bool no_malloc
, bool no_memcpy
, tree str_sz
,
7527 tree add_when_allocated
)
7536 /* If the source is null, set the destination to null. Then,
7537 allocate memory to the destination. */
7538 gfc_init_block (&block
);
7540 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
7542 tmp
= null_pointer_node
;
7543 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, type
, dest
, tmp
);
7544 gfc_add_expr_to_block (&block
, tmp
);
7545 null_data
= gfc_finish_block (&block
);
7547 gfc_init_block (&block
);
7548 if (str_sz
!= NULL_TREE
)
7551 size
= TYPE_SIZE_UNIT (TREE_TYPE (type
));
7555 tmp
= gfc_call_malloc (&block
, type
, size
);
7556 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
7557 dest
, fold_convert (type
, tmp
));
7558 gfc_add_expr_to_block (&block
, tmp
);
7563 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
7564 tmp
= build_call_expr_loc (input_location
, tmp
, 3, dest
, src
,
7565 fold_convert (size_type_node
, size
));
7566 gfc_add_expr_to_block (&block
, tmp
);
7571 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
7572 null_data
= gfc_finish_block (&block
);
7574 gfc_init_block (&block
);
7576 nelems
= gfc_full_array_size (&block
, src
, rank
);
7578 nelems
= gfc_index_one_node
;
7580 if (str_sz
!= NULL_TREE
)
7581 tmp
= fold_convert (gfc_array_index_type
, str_sz
);
7583 tmp
= fold_convert (gfc_array_index_type
,
7584 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
7585 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7589 tmp
= TREE_TYPE (gfc_conv_descriptor_data_get (src
));
7590 tmp
= gfc_call_malloc (&block
, tmp
, size
);
7591 gfc_conv_descriptor_data_set (&block
, dest
, tmp
);
7594 /* We know the temporary and the value will be the same length,
7595 so can use memcpy. */
7598 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
7599 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
7600 gfc_conv_descriptor_data_get (dest
),
7601 gfc_conv_descriptor_data_get (src
),
7602 fold_convert (size_type_node
, size
));
7603 gfc_add_expr_to_block (&block
, tmp
);
7607 gfc_add_expr_to_block (&block
, add_when_allocated
);
7608 tmp
= gfc_finish_block (&block
);
7610 /* Null the destination if the source is null; otherwise do
7611 the allocate and copy. */
7612 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src
)))
7615 null_cond
= gfc_conv_descriptor_data_get (src
);
7617 null_cond
= convert (pvoid_type_node
, null_cond
);
7618 null_cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7619 null_cond
, null_pointer_node
);
7620 return build3_v (COND_EXPR
, null_cond
, tmp
, null_data
);
7624 /* Allocate dest to the same size as src, and copy data src -> dest. */
7627 gfc_duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
7628 tree add_when_allocated
)
7630 return duplicate_allocatable (dest
, src
, type
, rank
, false, false,
7631 NULL_TREE
, add_when_allocated
);
7635 /* Copy data src -> dest. */
7638 gfc_copy_allocatable_data (tree dest
, tree src
, tree type
, int rank
)
7640 return duplicate_allocatable (dest
, src
, type
, rank
, true, false,
7641 NULL_TREE
, NULL_TREE
);
7644 /* Allocate dest to the same size as src, but don't copy anything. */
7647 gfc_duplicate_allocatable_nocopy (tree dest
, tree src
, tree type
, int rank
)
7649 return duplicate_allocatable (dest
, src
, type
, rank
, false, true,
7650 NULL_TREE
, NULL_TREE
);
7654 /* Recursively traverse an object of derived type, generating code to
7655 deallocate, nullify or copy allocatable components. This is the work horse
7656 function for the functions named in this enum. */
7658 enum {DEALLOCATE_ALLOC_COMP
= 1, DEALLOCATE_ALLOC_COMP_NO_CAF
,
7659 NULLIFY_ALLOC_COMP
, COPY_ALLOC_COMP
, COPY_ONLY_ALLOC_COMP
,
7660 COPY_ALLOC_COMP_CAF
};
7663 structure_alloc_comps (gfc_symbol
* der_type
, tree decl
,
7664 tree dest
, int rank
, int purpose
)
7668 stmtblock_t fnblock
;
7669 stmtblock_t loopbody
;
7670 stmtblock_t tmpblock
;
7681 tree null_cond
= NULL_TREE
;
7682 tree add_when_allocated
;
7683 bool called_dealloc_with_status
;
7685 gfc_init_block (&fnblock
);
7687 decl_type
= TREE_TYPE (decl
);
7689 if ((POINTER_TYPE_P (decl_type
))
7690 || (TREE_CODE (decl_type
) == REFERENCE_TYPE
&& rank
== 0))
7692 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
7693 /* Deref dest in sync with decl, but only when it is not NULL. */
7695 dest
= build_fold_indirect_ref_loc (input_location
, dest
);
7698 /* Just in case it gets dereferenced. */
7699 decl_type
= TREE_TYPE (decl
);
7701 /* If this is an array of derived types with allocatable components
7702 build a loop and recursively call this function. */
7703 if (TREE_CODE (decl_type
) == ARRAY_TYPE
7704 || (GFC_DESCRIPTOR_TYPE_P (decl_type
) && rank
!= 0))
7706 tmp
= gfc_conv_array_data (decl
);
7707 var
= build_fold_indirect_ref_loc (input_location
, tmp
);
7709 /* Get the number of elements - 1 and set the counter. */
7710 if (GFC_DESCRIPTOR_TYPE_P (decl_type
))
7712 /* Use the descriptor for an allocatable array. Since this
7713 is a full array reference, we only need the descriptor
7714 information from dimension = rank. */
7715 tmp
= gfc_full_array_size (&fnblock
, decl
, rank
);
7716 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7717 gfc_array_index_type
, tmp
,
7718 gfc_index_one_node
);
7720 null_cond
= gfc_conv_descriptor_data_get (decl
);
7721 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
7722 boolean_type_node
, null_cond
,
7723 build_int_cst (TREE_TYPE (null_cond
), 0));
7727 /* Otherwise use the TYPE_DOMAIN information. */
7728 tmp
= array_type_nelts (decl_type
);
7729 tmp
= fold_convert (gfc_array_index_type
, tmp
);
7732 /* Remember that this is, in fact, the no. of elements - 1. */
7733 nelems
= gfc_evaluate_now (tmp
, &fnblock
);
7734 index
= gfc_create_var (gfc_array_index_type
, "S");
7736 /* Build the body of the loop. */
7737 gfc_init_block (&loopbody
);
7739 vref
= gfc_build_array_ref (var
, index
, NULL
);
7741 if (purpose
== COPY_ALLOC_COMP
|| purpose
== COPY_ONLY_ALLOC_COMP
)
7743 tmp
= build_fold_indirect_ref_loc (input_location
,
7744 gfc_conv_array_data (dest
));
7745 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
7746 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
,
7750 tmp
= structure_alloc_comps (der_type
, vref
, NULL_TREE
, rank
, purpose
);
7752 gfc_add_expr_to_block (&loopbody
, tmp
);
7754 /* Build the loop and return. */
7755 gfc_init_loopinfo (&loop
);
7757 loop
.from
[0] = gfc_index_zero_node
;
7758 loop
.loopvar
[0] = index
;
7759 loop
.to
[0] = nelems
;
7760 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
7761 gfc_add_block_to_block (&fnblock
, &loop
.pre
);
7763 tmp
= gfc_finish_block (&fnblock
);
7764 /* When copying allocateable components, the above implements the
7765 deep copy. Nevertheless is a deep copy only allowed, when the current
7766 component is allocated, for which code will be generated in
7767 gfc_duplicate_allocatable (), where the deep copy code is just added
7768 into the if's body, by adding tmp (the deep copy code) as last
7769 argument to gfc_duplicate_allocatable (). */
7770 if (purpose
== COPY_ALLOC_COMP
7771 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
7772 tmp
= gfc_duplicate_allocatable (dest
, decl
, decl_type
, rank
,
7774 else if (null_cond
!= NULL_TREE
)
7775 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
7776 build_empty_stmt (input_location
));
7781 /* Otherwise, act on the components or recursively call self to
7782 act on a chain of components. */
7783 for (c
= der_type
->components
; c
; c
= c
->next
)
7785 bool cmp_has_alloc_comps
= (c
->ts
.type
== BT_DERIVED
7786 || c
->ts
.type
== BT_CLASS
)
7787 && c
->ts
.u
.derived
->attr
.alloc_comp
;
7788 cdecl = c
->backend_decl
;
7789 ctype
= TREE_TYPE (cdecl);
7793 case DEALLOCATE_ALLOC_COMP
:
7794 case DEALLOCATE_ALLOC_COMP_NO_CAF
:
7796 /* gfc_deallocate_scalar_with_status calls gfc_deallocate_alloc_comp
7797 (i.e. this function) so generate all the calls and suppress the
7798 recursion from here, if necessary. */
7799 called_dealloc_with_status
= false;
7800 gfc_init_block (&tmpblock
);
7802 if ((c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
)
7803 || (c
->ts
.type
== BT_CLASS
&& !CLASS_DATA (c
)->attr
.class_pointer
))
7805 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7806 decl
, cdecl, NULL_TREE
);
7808 /* The finalizer frees allocatable components. */
7809 called_dealloc_with_status
7810 = gfc_add_comp_finalizer_call (&tmpblock
, comp
, c
,
7811 purpose
== DEALLOCATE_ALLOC_COMP
);
7816 if (c
->attr
.allocatable
&& !c
->attr
.proc_pointer
7817 && (c
->attr
.dimension
7818 || (c
->attr
.codimension
7819 && purpose
!= DEALLOCATE_ALLOC_COMP_NO_CAF
)))
7821 if (comp
== NULL_TREE
)
7822 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7823 decl
, cdecl, NULL_TREE
);
7824 tmp
= gfc_trans_dealloc_allocated (comp
, c
->attr
.codimension
, NULL
);
7825 gfc_add_expr_to_block (&tmpblock
, tmp
);
7827 else if (c
->attr
.allocatable
&& !c
->attr
.codimension
)
7829 /* Allocatable scalar components. */
7830 if (comp
== NULL_TREE
)
7831 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7832 decl
, cdecl, NULL_TREE
);
7834 tmp
= gfc_deallocate_scalar_with_status (comp
, NULL
, true, NULL
,
7836 gfc_add_expr_to_block (&tmpblock
, tmp
);
7837 called_dealloc_with_status
= true;
7839 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7840 void_type_node
, comp
,
7841 build_int_cst (TREE_TYPE (comp
), 0));
7842 gfc_add_expr_to_block (&tmpblock
, tmp
);
7844 else if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
7845 && (!CLASS_DATA (c
)->attr
.codimension
7846 || purpose
!= DEALLOCATE_ALLOC_COMP_NO_CAF
))
7848 /* Allocatable CLASS components. */
7850 /* Add reference to '_data' component. */
7851 tmp
= CLASS_DATA (c
)->backend_decl
;
7852 comp
= fold_build3_loc (input_location
, COMPONENT_REF
,
7853 TREE_TYPE (tmp
), comp
, tmp
, NULL_TREE
);
7855 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp
)))
7856 tmp
= gfc_trans_dealloc_allocated (comp
,
7857 CLASS_DATA (c
)->attr
.codimension
, NULL
);
7860 tmp
= gfc_deallocate_scalar_with_status (comp
, NULL_TREE
, true, NULL
,
7861 CLASS_DATA (c
)->ts
);
7862 gfc_add_expr_to_block (&tmpblock
, tmp
);
7863 called_dealloc_with_status
= true;
7865 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7866 void_type_node
, comp
,
7867 build_int_cst (TREE_TYPE (comp
), 0));
7869 gfc_add_expr_to_block (&tmpblock
, tmp
);
7872 if (cmp_has_alloc_comps
7874 && !called_dealloc_with_status
)
7876 /* Do not deallocate the components of ultimate pointer
7877 components or iteratively call self if call has been made
7878 to gfc_trans_dealloc_allocated */
7879 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7880 decl
, cdecl, NULL_TREE
);
7881 rank
= c
->as
? c
->as
->rank
: 0;
7882 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
7884 gfc_add_expr_to_block (&fnblock
, tmp
);
7887 /* Now add the deallocation of this component. */
7888 gfc_add_block_to_block (&fnblock
, &tmpblock
);
7891 case NULLIFY_ALLOC_COMP
:
7892 if (c
->attr
.pointer
|| c
->attr
.proc_pointer
)
7894 else if (c
->attr
.allocatable
7895 && (c
->attr
.dimension
|| c
->attr
.codimension
))
7897 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7898 decl
, cdecl, NULL_TREE
);
7899 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
7901 else if (c
->attr
.allocatable
)
7903 /* Allocatable scalar components. */
7904 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7905 decl
, cdecl, NULL_TREE
);
7906 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7907 void_type_node
, comp
,
7908 build_int_cst (TREE_TYPE (comp
), 0));
7909 gfc_add_expr_to_block (&fnblock
, tmp
);
7910 if (gfc_deferred_strlen (c
, &comp
))
7912 comp
= fold_build3_loc (input_location
, COMPONENT_REF
,
7914 decl
, comp
, NULL_TREE
);
7915 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7916 TREE_TYPE (comp
), comp
,
7917 build_int_cst (TREE_TYPE (comp
), 0));
7918 gfc_add_expr_to_block (&fnblock
, tmp
);
7921 else if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
7923 /* Allocatable CLASS components. */
7924 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7925 decl
, cdecl, NULL_TREE
);
7926 /* Add reference to '_data' component. */
7927 tmp
= CLASS_DATA (c
)->backend_decl
;
7928 comp
= fold_build3_loc (input_location
, COMPONENT_REF
,
7929 TREE_TYPE (tmp
), comp
, tmp
, NULL_TREE
);
7930 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp
)))
7931 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
7934 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7935 void_type_node
, comp
,
7936 build_int_cst (TREE_TYPE (comp
), 0));
7937 gfc_add_expr_to_block (&fnblock
, tmp
);
7940 else if (cmp_has_alloc_comps
)
7942 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7943 decl
, cdecl, NULL_TREE
);
7944 rank
= c
->as
? c
->as
->rank
: 0;
7945 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
7947 gfc_add_expr_to_block (&fnblock
, tmp
);
7951 case COPY_ALLOC_COMP_CAF
:
7952 if (!c
->attr
.codimension
7953 && (c
->ts
.type
!= BT_CLASS
|| CLASS_DATA (c
)->attr
.coarray_comp
)
7954 && (c
->ts
.type
!= BT_DERIVED
7955 || !c
->ts
.u
.derived
->attr
.coarray_comp
))
7958 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, decl
,
7960 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, dest
,
7963 if (c
->attr
.codimension
)
7965 if (c
->ts
.type
== BT_CLASS
)
7967 comp
= gfc_class_data_get (comp
);
7968 dcmp
= gfc_class_data_get (dcmp
);
7970 gfc_conv_descriptor_data_set (&fnblock
, dcmp
,
7971 gfc_conv_descriptor_data_get (comp
));
7975 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, dcmp
,
7977 gfc_add_expr_to_block (&fnblock
, tmp
);
7982 case COPY_ALLOC_COMP
:
7983 if (c
->attr
.pointer
)
7986 /* We need source and destination components. */
7987 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, decl
,
7989 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, dest
,
7991 dcmp
= fold_convert (TREE_TYPE (comp
), dcmp
);
7993 if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
8001 dst_data
= gfc_class_data_get (dcmp
);
8002 src_data
= gfc_class_data_get (comp
);
8003 size
= fold_convert (size_type_node
,
8004 gfc_class_vtab_size_get (comp
));
8006 if (CLASS_DATA (c
)->attr
.dimension
)
8008 nelems
= gfc_conv_descriptor_size (src_data
,
8009 CLASS_DATA (c
)->as
->rank
);
8010 size
= fold_build2_loc (input_location
, MULT_EXPR
,
8011 size_type_node
, size
,
8012 fold_convert (size_type_node
,
8016 nelems
= build_int_cst (size_type_node
, 1);
8018 if (CLASS_DATA (c
)->attr
.dimension
8019 || CLASS_DATA (c
)->attr
.codimension
)
8021 src_data
= gfc_conv_descriptor_data_get (src_data
);
8022 dst_data
= gfc_conv_descriptor_data_get (dst_data
);
8025 gfc_init_block (&tmpblock
);
8027 /* Coarray component have to have the same allocation status and
8028 shape/type-parameter/effective-type on the LHS and RHS of an
8029 intrinsic assignment. Hence, we did not deallocated them - and
8030 do not allocate them here. */
8031 if (!CLASS_DATA (c
)->attr
.codimension
)
8033 ftn_tree
= builtin_decl_explicit (BUILT_IN_MALLOC
);
8034 tmp
= build_call_expr_loc (input_location
, ftn_tree
, 1, size
);
8035 gfc_add_modify (&tmpblock
, dst_data
,
8036 fold_convert (TREE_TYPE (dst_data
), tmp
));
8039 tmp
= gfc_copy_class_to_class (comp
, dcmp
, nelems
,
8040 UNLIMITED_POLY (c
));
8041 gfc_add_expr_to_block (&tmpblock
, tmp
);
8042 tmp
= gfc_finish_block (&tmpblock
);
8044 gfc_init_block (&tmpblock
);
8045 gfc_add_modify (&tmpblock
, dst_data
,
8046 fold_convert (TREE_TYPE (dst_data
),
8047 null_pointer_node
));
8048 null_data
= gfc_finish_block (&tmpblock
);
8050 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
8051 boolean_type_node
, src_data
,
8054 gfc_add_expr_to_block (&fnblock
, build3_v (COND_EXPR
, null_cond
,
8059 /* To implement guarded deep copy, i.e., deep copy only allocatable
8060 components that are really allocated, the deep copy code has to
8061 be generated first and then added to the if-block in
8062 gfc_duplicate_allocatable (). */
8063 if (cmp_has_alloc_comps
)
8065 rank
= c
->as
? c
->as
->rank
: 0;
8066 tmp
= fold_convert (TREE_TYPE (dcmp
), comp
);
8067 gfc_add_modify (&fnblock
, dcmp
, tmp
);
8068 add_when_allocated
= structure_alloc_comps (c
->ts
.u
.derived
,
8073 add_when_allocated
= NULL_TREE
;
8075 if (gfc_deferred_strlen (c
, &tmp
))
8079 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
8081 decl
, len
, NULL_TREE
);
8082 len
= fold_build3_loc (input_location
, COMPONENT_REF
,
8084 dest
, len
, NULL_TREE
);
8085 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8086 TREE_TYPE (len
), len
, tmp
);
8087 gfc_add_expr_to_block (&fnblock
, tmp
);
8088 size
= size_of_string_in_bytes (c
->ts
.kind
, len
);
8089 /* This component can not have allocatable components,
8090 therefore add_when_allocated of duplicate_allocatable ()
8092 tmp
= duplicate_allocatable (dcmp
, comp
, ctype
, rank
,
8093 false, false, size
, NULL_TREE
);
8094 gfc_add_expr_to_block (&fnblock
, tmp
);
8096 else if (c
->attr
.allocatable
&& !c
->attr
.proc_pointer
8097 && (!(cmp_has_alloc_comps
&& c
->as
)
8098 || c
->attr
.codimension
))
8100 rank
= c
->as
? c
->as
->rank
: 0;
8101 if (c
->attr
.codimension
)
8102 tmp
= gfc_copy_allocatable_data (dcmp
, comp
, ctype
, rank
);
8104 tmp
= gfc_duplicate_allocatable (dcmp
, comp
, ctype
, rank
,
8105 add_when_allocated
);
8106 gfc_add_expr_to_block (&fnblock
, tmp
);
8109 if (cmp_has_alloc_comps
)
8110 gfc_add_expr_to_block (&fnblock
, add_when_allocated
);
8120 return gfc_finish_block (&fnblock
);
8123 /* Recursively traverse an object of derived type, generating code to
8124 nullify allocatable components. */
8127 gfc_nullify_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
8129 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
8130 NULLIFY_ALLOC_COMP
);
8134 /* Recursively traverse an object of derived type, generating code to
8135 deallocate allocatable components. */
8138 gfc_deallocate_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
8140 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
8141 DEALLOCATE_ALLOC_COMP
);
8145 /* Recursively traverse an object of derived type, generating code to
8146 deallocate allocatable components. But do not deallocate coarrays.
8147 To be used for intrinsic assignment, which may not change the allocation
8148 status of coarrays. */
8151 gfc_deallocate_alloc_comp_no_caf (gfc_symbol
* der_type
, tree decl
, int rank
)
8153 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
8154 DEALLOCATE_ALLOC_COMP_NO_CAF
);
8159 gfc_reassign_alloc_comp_caf (gfc_symbol
*der_type
, tree decl
, tree dest
)
8161 return structure_alloc_comps (der_type
, decl
, dest
, 0, COPY_ALLOC_COMP_CAF
);
8165 /* Recursively traverse an object of derived type, generating code to
8166 copy it and its allocatable components. */
8169 gfc_copy_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
8171 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ALLOC_COMP
);
8175 /* Recursively traverse an object of derived type, generating code to
8176 copy only its allocatable components. */
8179 gfc_copy_only_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
8181 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ONLY_ALLOC_COMP
);
8185 /* Returns the value of LBOUND for an expression. This could be broken out
8186 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
8187 called by gfc_alloc_allocatable_for_assignment. */
8189 get_std_lbound (gfc_expr
*expr
, tree desc
, int dim
, bool assumed_size
)
8194 tree cond
, cond1
, cond3
, cond4
;
8198 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
8200 tmp
= gfc_rank_cst
[dim
];
8201 lbound
= gfc_conv_descriptor_lbound_get (desc
, tmp
);
8202 ubound
= gfc_conv_descriptor_ubound_get (desc
, tmp
);
8203 stride
= gfc_conv_descriptor_stride_get (desc
, tmp
);
8204 cond1
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
8206 cond3
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
8207 stride
, gfc_index_zero_node
);
8208 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8209 boolean_type_node
, cond3
, cond1
);
8210 cond4
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
8211 stride
, gfc_index_zero_node
);
8213 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
8214 tmp
, build_int_cst (gfc_array_index_type
,
8217 cond
= boolean_false_node
;
8219 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
8220 boolean_type_node
, cond3
, cond4
);
8221 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
8222 boolean_type_node
, cond
, cond1
);
8224 return fold_build3_loc (input_location
, COND_EXPR
,
8225 gfc_array_index_type
, cond
,
8226 lbound
, gfc_index_one_node
);
8229 if (expr
->expr_type
== EXPR_FUNCTION
)
8231 /* A conversion function, so use the argument. */
8232 gcc_assert (expr
->value
.function
.isym
8233 && expr
->value
.function
.isym
->conversion
);
8234 expr
= expr
->value
.function
.actual
->expr
;
8237 if (expr
->expr_type
== EXPR_VARIABLE
)
8239 tmp
= TREE_TYPE (expr
->symtree
->n
.sym
->backend_decl
);
8240 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
8242 if (ref
->type
== REF_COMPONENT
8243 && ref
->u
.c
.component
->as
8245 && ref
->next
->u
.ar
.type
== AR_FULL
)
8246 tmp
= TREE_TYPE (ref
->u
.c
.component
->backend_decl
);
8248 return GFC_TYPE_ARRAY_LBOUND(tmp
, dim
);
8251 return gfc_index_one_node
;
8255 /* Returns true if an expression represents an lhs that can be reallocated
8259 gfc_is_reallocatable_lhs (gfc_expr
*expr
)
8266 /* An allocatable variable. */
8267 if (expr
->symtree
->n
.sym
->attr
.allocatable
8269 && expr
->ref
->type
== REF_ARRAY
8270 && expr
->ref
->u
.ar
.type
== AR_FULL
)
8273 /* All that can be left are allocatable components. */
8274 if ((expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
8275 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
8276 || !expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
8279 /* Find a component ref followed by an array reference. */
8280 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
8282 && ref
->type
== REF_COMPONENT
8283 && ref
->next
->type
== REF_ARRAY
8284 && !ref
->next
->next
)
8290 /* Return true if valid reallocatable lhs. */
8291 if (ref
->u
.c
.component
->attr
.allocatable
8292 && ref
->next
->u
.ar
.type
== AR_FULL
)
8299 /* Allocate the lhs of an assignment to an allocatable array, otherwise
8303 gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop
,
8307 stmtblock_t realloc_block
;
8308 stmtblock_t alloc_block
;
8312 gfc_array_info
*linfo
;
8334 gfc_array_spec
* as
;
8336 /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
8337 Find the lhs expression in the loop chain and set expr1 and
8338 expr2 accordingly. */
8339 if (expr1
->expr_type
== EXPR_FUNCTION
&& expr2
== NULL
)
8342 /* Find the ss for the lhs. */
8344 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
8345 if (lss
->info
->expr
&& lss
->info
->expr
->expr_type
== EXPR_VARIABLE
)
8347 if (lss
== gfc_ss_terminator
)
8349 expr1
= lss
->info
->expr
;
8352 /* Bail out if this is not a valid allocate on assignment. */
8353 if (!gfc_is_reallocatable_lhs (expr1
)
8354 || (expr2
&& !expr2
->rank
))
8357 /* Find the ss for the lhs. */
8359 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
8360 if (lss
->info
->expr
== expr1
)
8363 if (lss
== gfc_ss_terminator
)
8366 linfo
= &lss
->info
->data
.array
;
8368 /* Find an ss for the rhs. For operator expressions, we see the
8369 ss's for the operands. Any one of these will do. */
8371 for (; rss
&& rss
!= gfc_ss_terminator
; rss
= rss
->loop_chain
)
8372 if (rss
->info
->expr
!= expr1
&& rss
!= loop
->temp_ss
)
8375 if (expr2
&& rss
== gfc_ss_terminator
)
8378 gfc_start_block (&fblock
);
8380 /* Since the lhs is allocatable, this must be a descriptor type.
8381 Get the data and array size. */
8382 desc
= linfo
->descriptor
;
8383 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)));
8384 array1
= gfc_conv_descriptor_data_get (desc
);
8386 /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
8387 deallocated if expr is an array of different shape or any of the
8388 corresponding length type parameter values of variable and expr
8389 differ." This assures F95 compatibility. */
8390 jump_label1
= gfc_build_label_decl (NULL_TREE
);
8391 jump_label2
= gfc_build_label_decl (NULL_TREE
);
8393 /* Allocate if data is NULL. */
8394 cond_null
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
8395 array1
, build_int_cst (TREE_TYPE (array1
), 0));
8396 tmp
= build3_v (COND_EXPR
, cond_null
,
8397 build1_v (GOTO_EXPR
, jump_label1
),
8398 build_empty_stmt (input_location
));
8399 gfc_add_expr_to_block (&fblock
, tmp
);
8401 /* Get arrayspec if expr is a full array. */
8402 if (expr2
&& expr2
->expr_type
== EXPR_FUNCTION
8403 && expr2
->value
.function
.isym
8404 && expr2
->value
.function
.isym
->conversion
)
8406 /* For conversion functions, take the arg. */
8407 gfc_expr
*arg
= expr2
->value
.function
.actual
->expr
;
8408 as
= gfc_get_full_arrayspec_from_expr (arg
);
8411 as
= gfc_get_full_arrayspec_from_expr (expr2
);
8415 /* If the lhs shape is not the same as the rhs jump to setting the
8416 bounds and doing the reallocation....... */
8417 for (n
= 0; n
< expr1
->rank
; n
++)
8419 /* Check the shape. */
8420 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
8421 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
8422 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8423 gfc_array_index_type
,
8424 loop
->to
[n
], loop
->from
[n
]);
8425 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8426 gfc_array_index_type
,
8428 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8429 gfc_array_index_type
,
8431 cond
= fold_build2_loc (input_location
, NE_EXPR
,
8433 tmp
, gfc_index_zero_node
);
8434 tmp
= build3_v (COND_EXPR
, cond
,
8435 build1_v (GOTO_EXPR
, jump_label1
),
8436 build_empty_stmt (input_location
));
8437 gfc_add_expr_to_block (&fblock
, tmp
);
8440 /* ....else jump past the (re)alloc code. */
8441 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
8442 gfc_add_expr_to_block (&fblock
, tmp
);
8444 /* Add the label to start automatic (re)allocation. */
8445 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
8446 gfc_add_expr_to_block (&fblock
, tmp
);
8448 /* If the lhs has not been allocated, its bounds will not have been
8449 initialized and so its size is set to zero. */
8450 size1
= gfc_create_var (gfc_array_index_type
, NULL
);
8451 gfc_init_block (&alloc_block
);
8452 gfc_add_modify (&alloc_block
, size1
, gfc_index_zero_node
);
8453 gfc_init_block (&realloc_block
);
8454 gfc_add_modify (&realloc_block
, size1
,
8455 gfc_conv_descriptor_size (desc
, expr1
->rank
));
8456 tmp
= build3_v (COND_EXPR
, cond_null
,
8457 gfc_finish_block (&alloc_block
),
8458 gfc_finish_block (&realloc_block
));
8459 gfc_add_expr_to_block (&fblock
, tmp
);
8461 /* Get the rhs size and fix it. */
8463 desc2
= rss
->info
->data
.array
.descriptor
;
8467 size2
= gfc_index_one_node
;
8468 for (n
= 0; n
< expr2
->rank
; n
++)
8470 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8471 gfc_array_index_type
,
8472 loop
->to
[n
], loop
->from
[n
]);
8473 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8474 gfc_array_index_type
,
8475 tmp
, gfc_index_one_node
);
8476 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
8477 gfc_array_index_type
,
8480 size2
= gfc_evaluate_now (size2
, &fblock
);
8482 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
8484 neq_size
= gfc_evaluate_now (cond
, &fblock
);
8486 /* Deallocation of allocatable components will have to occur on
8487 reallocation. Fix the old descriptor now. */
8488 if ((expr1
->ts
.type
== BT_DERIVED
)
8489 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
8490 old_desc
= gfc_evaluate_now (desc
, &fblock
);
8492 old_desc
= NULL_TREE
;
8494 /* Now modify the lhs descriptor and the associated scalarizer
8495 variables. F2003 7.4.1.3: "If variable is or becomes an
8496 unallocated allocatable variable, then it is allocated with each
8497 deferred type parameter equal to the corresponding type parameters
8498 of expr , with the shape of expr , and with each lower bound equal
8499 to the corresponding element of LBOUND(expr)."
8500 Reuse size1 to keep a dimension-by-dimension track of the
8501 stride of the new array. */
8502 size1
= gfc_index_one_node
;
8503 offset
= gfc_index_zero_node
;
8505 for (n
= 0; n
< expr2
->rank
; n
++)
8507 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8508 gfc_array_index_type
,
8509 loop
->to
[n
], loop
->from
[n
]);
8510 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8511 gfc_array_index_type
,
8512 tmp
, gfc_index_one_node
);
8514 lbound
= gfc_index_one_node
;
8519 lbd
= get_std_lbound (expr2
, desc2
, n
,
8520 as
->type
== AS_ASSUMED_SIZE
);
8521 ubound
= fold_build2_loc (input_location
,
8523 gfc_array_index_type
,
8525 ubound
= fold_build2_loc (input_location
,
8527 gfc_array_index_type
,
8532 gfc_conv_descriptor_lbound_set (&fblock
, desc
,
8535 gfc_conv_descriptor_ubound_set (&fblock
, desc
,
8538 gfc_conv_descriptor_stride_set (&fblock
, desc
,
8541 lbound
= gfc_conv_descriptor_lbound_get (desc
,
8543 tmp2
= fold_build2_loc (input_location
, MULT_EXPR
,
8544 gfc_array_index_type
,
8546 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
8547 gfc_array_index_type
,
8549 size1
= fold_build2_loc (input_location
, MULT_EXPR
,
8550 gfc_array_index_type
,
8554 /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
8555 the array offset is saved and the info.offset is used for a
8556 running offset. Use the saved_offset instead. */
8557 tmp
= gfc_conv_descriptor_offset (desc
);
8558 gfc_add_modify (&fblock
, tmp
, offset
);
8559 if (linfo
->saved_offset
8560 && TREE_CODE (linfo
->saved_offset
) == VAR_DECL
)
8561 gfc_add_modify (&fblock
, linfo
->saved_offset
, tmp
);
8563 /* Now set the deltas for the lhs. */
8564 for (n
= 0; n
< expr1
->rank
; n
++)
8566 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
8568 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8569 gfc_array_index_type
, tmp
,
8571 if (linfo
->delta
[dim
]
8572 && TREE_CODE (linfo
->delta
[dim
]) == VAR_DECL
)
8573 gfc_add_modify (&fblock
, linfo
->delta
[dim
], tmp
);
8576 /* Get the new lhs size in bytes. */
8577 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
8579 if (expr2
->ts
.deferred
)
8581 if (TREE_CODE (expr2
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
8582 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
8584 tmp
= rss
->info
->string_length
;
8588 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
8589 tmp
= fold_convert (TREE_TYPE (expr1
->ts
.u
.cl
->backend_decl
), tmp
);
8592 if (expr1
->ts
.u
.cl
->backend_decl
8593 && TREE_CODE (expr1
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
8594 gfc_add_modify (&fblock
, expr1
->ts
.u
.cl
->backend_decl
, tmp
);
8596 gfc_add_modify (&fblock
, lss
->info
->string_length
, tmp
);
8598 else if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.u
.cl
->backend_decl
)
8600 tmp
= TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
)));
8601 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8602 gfc_array_index_type
, tmp
,
8603 expr1
->ts
.u
.cl
->backend_decl
);
8606 tmp
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
8607 tmp
= fold_convert (gfc_array_index_type
, tmp
);
8608 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
8609 gfc_array_index_type
,
8611 size2
= fold_convert (size_type_node
, size2
);
8612 size2
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
8613 size2
, size_one_node
);
8614 size2
= gfc_evaluate_now (size2
, &fblock
);
8616 /* Realloc expression. Note that the scalarizer uses desc.data
8617 in the array reference - (*desc.data)[<element>]. */
8618 gfc_init_block (&realloc_block
);
8620 if ((expr1
->ts
.type
== BT_DERIVED
)
8621 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
8623 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, old_desc
,
8625 gfc_add_expr_to_block (&realloc_block
, tmp
);
8628 tmp
= build_call_expr_loc (input_location
,
8629 builtin_decl_explicit (BUILT_IN_REALLOC
), 2,
8630 fold_convert (pvoid_type_node
, array1
),
8632 gfc_conv_descriptor_data_set (&realloc_block
,
8635 if ((expr1
->ts
.type
== BT_DERIVED
)
8636 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
8638 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, desc
,
8640 gfc_add_expr_to_block (&realloc_block
, tmp
);
8643 realloc_expr
= gfc_finish_block (&realloc_block
);
8645 /* Only reallocate if sizes are different. */
8646 tmp
= build3_v (COND_EXPR
, neq_size
, realloc_expr
,
8647 build_empty_stmt (input_location
));
8651 /* Malloc expression. */
8652 gfc_init_block (&alloc_block
);
8653 tmp
= build_call_expr_loc (input_location
,
8654 builtin_decl_explicit (BUILT_IN_MALLOC
),
8656 gfc_conv_descriptor_data_set (&alloc_block
,
8658 tmp
= gfc_conv_descriptor_dtype (desc
);
8659 gfc_add_modify (&alloc_block
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
8660 if ((expr1
->ts
.type
== BT_DERIVED
)
8661 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
8663 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, desc
,
8665 gfc_add_expr_to_block (&alloc_block
, tmp
);
8667 alloc_expr
= gfc_finish_block (&alloc_block
);
8669 /* Malloc if not allocated; realloc otherwise. */
8670 tmp
= build_int_cst (TREE_TYPE (array1
), 0);
8671 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
8674 tmp
= build3_v (COND_EXPR
, cond
, alloc_expr
, realloc_expr
);
8675 gfc_add_expr_to_block (&fblock
, tmp
);
8677 /* Make sure that the scalarizer data pointer is updated. */
8679 && TREE_CODE (linfo
->data
) == VAR_DECL
)
8681 tmp
= gfc_conv_descriptor_data_get (desc
);
8682 gfc_add_modify (&fblock
, linfo
->data
, tmp
);
8685 /* Add the exit label. */
8686 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
8687 gfc_add_expr_to_block (&fblock
, tmp
);
8689 return gfc_finish_block (&fblock
);
8693 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
8694 Do likewise, recursively if necessary, with the allocatable components of
8698 gfc_trans_deferred_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
8704 stmtblock_t cleanup
;
8707 bool sym_has_alloc_comp
, has_finalizer
;
8709 sym_has_alloc_comp
= (sym
->ts
.type
== BT_DERIVED
8710 || sym
->ts
.type
== BT_CLASS
)
8711 && sym
->ts
.u
.derived
->attr
.alloc_comp
;
8712 has_finalizer
= sym
->ts
.type
== BT_CLASS
|| sym
->ts
.type
== BT_DERIVED
8713 ? gfc_is_finalizable (sym
->ts
.u
.derived
, NULL
) : false;
8715 /* Make sure the frontend gets these right. */
8716 gcc_assert (sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym_has_alloc_comp
8719 gfc_save_backend_locus (&loc
);
8720 gfc_set_backend_locus (&sym
->declared_at
);
8721 gfc_init_block (&init
);
8723 gcc_assert (TREE_CODE (sym
->backend_decl
) == VAR_DECL
8724 || TREE_CODE (sym
->backend_decl
) == PARM_DECL
);
8726 if (sym
->ts
.type
== BT_CHARACTER
8727 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
8729 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
8730 gfc_trans_vla_type_sizes (sym
, &init
);
8733 /* Dummy, use associated and result variables don't need anything special. */
8734 if (sym
->attr
.dummy
|| sym
->attr
.use_assoc
|| sym
->attr
.result
)
8736 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
8737 gfc_restore_backend_locus (&loc
);
8741 descriptor
= sym
->backend_decl
;
8743 /* Although static, derived types with default initializers and
8744 allocatable components must not be nulled wholesale; instead they
8745 are treated component by component. */
8746 if (TREE_STATIC (descriptor
) && !sym_has_alloc_comp
&& !has_finalizer
)
8748 /* SAVEd variables are not freed on exit. */
8749 gfc_trans_static_array_pointer (sym
);
8751 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
8752 gfc_restore_backend_locus (&loc
);
8756 /* Get the descriptor type. */
8757 type
= TREE_TYPE (sym
->backend_decl
);
8759 if ((sym_has_alloc_comp
|| (has_finalizer
&& sym
->ts
.type
!= BT_CLASS
))
8760 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
8763 && !(TREE_STATIC (sym
->backend_decl
) && sym
->attr
.is_main_program
))
8765 if (sym
->value
== NULL
8766 || !gfc_has_default_initializer (sym
->ts
.u
.derived
))
8768 rank
= sym
->as
? sym
->as
->rank
: 0;
8769 tmp
= gfc_nullify_alloc_comp (sym
->ts
.u
.derived
,
8771 gfc_add_expr_to_block (&init
, tmp
);
8774 gfc_init_default_dt (sym
, &init
, false);
8777 else if (!GFC_DESCRIPTOR_TYPE_P (type
))
8779 /* If the backend_decl is not a descriptor, we must have a pointer
8781 descriptor
= build_fold_indirect_ref_loc (input_location
,
8783 type
= TREE_TYPE (descriptor
);
8786 /* NULLIFY the data pointer, for non-saved allocatables. */
8787 if (GFC_DESCRIPTOR_TYPE_P (type
) && !sym
->attr
.save
&& sym
->attr
.allocatable
)
8788 gfc_conv_descriptor_data_set (&init
, descriptor
, null_pointer_node
);
8790 gfc_restore_backend_locus (&loc
);
8791 gfc_init_block (&cleanup
);
8793 /* Allocatable arrays need to be freed when they go out of scope.
8794 The allocatable components of pointers must not be touched. */
8795 if (!sym
->attr
.allocatable
&& has_finalizer
&& sym
->ts
.type
!= BT_CLASS
8796 && !sym
->attr
.pointer
&& !sym
->attr
.artificial
&& !sym
->attr
.save
8797 && !sym
->ns
->proc_name
->attr
.is_main_program
)
8800 sym
->attr
.referenced
= 1;
8801 e
= gfc_lval_expr_from_sym (sym
);
8802 gfc_add_finalizer_call (&cleanup
, e
);
8805 else if ((!sym
->attr
.allocatable
|| !has_finalizer
)
8806 && sym_has_alloc_comp
&& !(sym
->attr
.function
|| sym
->attr
.result
)
8807 && !sym
->attr
.pointer
&& !sym
->attr
.save
8808 && !sym
->ns
->proc_name
->attr
.is_main_program
)
8811 rank
= sym
->as
? sym
->as
->rank
: 0;
8812 tmp
= gfc_deallocate_alloc_comp (sym
->ts
.u
.derived
, descriptor
, rank
);
8813 gfc_add_expr_to_block (&cleanup
, tmp
);
8816 if (sym
->attr
.allocatable
&& (sym
->attr
.dimension
|| sym
->attr
.codimension
)
8817 && !sym
->attr
.save
&& !sym
->attr
.result
8818 && !sym
->ns
->proc_name
->attr
.is_main_program
)
8821 e
= has_finalizer
? gfc_lval_expr_from_sym (sym
) : NULL
;
8822 tmp
= gfc_trans_dealloc_allocated (sym
->backend_decl
,
8823 sym
->attr
.codimension
, e
);
8826 gfc_add_expr_to_block (&cleanup
, tmp
);
8829 gfc_add_init_cleanup (block
, gfc_finish_block (&init
),
8830 gfc_finish_block (&cleanup
));
8833 /************ Expression Walking Functions ******************/
8835 /* Walk a variable reference.
8837 Possible extension - multiple component subscripts.
8838 x(:,:) = foo%a(:)%b(:)
8840 forall (i=..., j=...)
8841 x(i,j) = foo%a(j)%b(i)
8843 This adds a fair amount of complexity because you need to deal with more
8844 than one ref. Maybe handle in a similar manner to vector subscripts.
8845 Maybe not worth the effort. */
8849 gfc_walk_variable_expr (gfc_ss
* ss
, gfc_expr
* expr
)
8853 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
8854 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
8857 return gfc_walk_array_ref (ss
, expr
, ref
);
8862 gfc_walk_array_ref (gfc_ss
* ss
, gfc_expr
* expr
, gfc_ref
* ref
)
8868 for (; ref
; ref
= ref
->next
)
8870 if (ref
->type
== REF_SUBSTRING
)
8872 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.start
);
8873 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.end
);
8876 /* We're only interested in array sections from now on. */
8877 if (ref
->type
!= REF_ARRAY
)
8885 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
8886 ss
= gfc_get_scalar_ss (ss
, ar
->start
[n
]);
8890 newss
= gfc_get_array_ss (ss
, expr
, ar
->as
->rank
, GFC_SS_SECTION
);
8891 newss
->info
->data
.array
.ref
= ref
;
8893 /* Make sure array is the same as array(:,:), this way
8894 we don't need to special case all the time. */
8895 ar
->dimen
= ar
->as
->rank
;
8896 for (n
= 0; n
< ar
->dimen
; n
++)
8898 ar
->dimen_type
[n
] = DIMEN_RANGE
;
8900 gcc_assert (ar
->start
[n
] == NULL
);
8901 gcc_assert (ar
->end
[n
] == NULL
);
8902 gcc_assert (ar
->stride
[n
] == NULL
);
8908 newss
= gfc_get_array_ss (ss
, expr
, 0, GFC_SS_SECTION
);
8909 newss
->info
->data
.array
.ref
= ref
;
8911 /* We add SS chains for all the subscripts in the section. */
8912 for (n
= 0; n
< ar
->dimen
; n
++)
8916 switch (ar
->dimen_type
[n
])
8919 /* Add SS for elemental (scalar) subscripts. */
8920 gcc_assert (ar
->start
[n
]);
8921 indexss
= gfc_get_scalar_ss (gfc_ss_terminator
, ar
->start
[n
]);
8922 indexss
->loop_chain
= gfc_ss_terminator
;
8923 newss
->info
->data
.array
.subscript
[n
] = indexss
;
8927 /* We don't add anything for sections, just remember this
8928 dimension for later. */
8929 newss
->dim
[newss
->dimen
] = n
;
8934 /* Create a GFC_SS_VECTOR index in which we can store
8935 the vector's descriptor. */
8936 indexss
= gfc_get_array_ss (gfc_ss_terminator
, ar
->start
[n
],
8938 indexss
->loop_chain
= gfc_ss_terminator
;
8939 newss
->info
->data
.array
.subscript
[n
] = indexss
;
8940 newss
->dim
[newss
->dimen
] = n
;
8945 /* We should know what sort of section it is by now. */
8949 /* We should have at least one non-elemental dimension,
8950 unless we are creating a descriptor for a (scalar) coarray. */
8951 gcc_assert (newss
->dimen
> 0
8952 || newss
->info
->data
.array
.ref
->u
.ar
.as
->corank
> 0);
8957 /* We should know what sort of section it is by now. */
8966 /* Walk an expression operator. If only one operand of a binary expression is
8967 scalar, we must also add the scalar term to the SS chain. */
8970 gfc_walk_op_expr (gfc_ss
* ss
, gfc_expr
* expr
)
8975 head
= gfc_walk_subexpr (ss
, expr
->value
.op
.op1
);
8976 if (expr
->value
.op
.op2
== NULL
)
8979 head2
= gfc_walk_subexpr (head
, expr
->value
.op
.op2
);
8981 /* All operands are scalar. Pass back and let the caller deal with it. */
8985 /* All operands require scalarization. */
8986 if (head
!= ss
&& (expr
->value
.op
.op2
== NULL
|| head2
!= head
))
8989 /* One of the operands needs scalarization, the other is scalar.
8990 Create a gfc_ss for the scalar expression. */
8993 /* First operand is scalar. We build the chain in reverse order, so
8994 add the scalar SS after the second operand. */
8996 while (head
&& head
->next
!= ss
)
8998 /* Check we haven't somehow broken the chain. */
9000 head
->next
= gfc_get_scalar_ss (ss
, expr
->value
.op
.op1
);
9002 else /* head2 == head */
9004 gcc_assert (head2
== head
);
9005 /* Second operand is scalar. */
9006 head2
= gfc_get_scalar_ss (head2
, expr
->value
.op
.op2
);
9013 /* Reverse a SS chain. */
9016 gfc_reverse_ss (gfc_ss
* ss
)
9021 gcc_assert (ss
!= NULL
);
9023 head
= gfc_ss_terminator
;
9024 while (ss
!= gfc_ss_terminator
)
9027 /* Check we didn't somehow break the chain. */
9028 gcc_assert (next
!= NULL
);
9038 /* Given an expression referring to a procedure, return the symbol of its
9039 interface. We can't get the procedure symbol directly as we have to handle
9040 the case of (deferred) type-bound procedures. */
9043 gfc_get_proc_ifc_for_expr (gfc_expr
*procedure_ref
)
9048 if (procedure_ref
== NULL
)
9051 /* Normal procedure case. */
9052 sym
= procedure_ref
->symtree
->n
.sym
;
9054 /* Typebound procedure case. */
9055 for (ref
= procedure_ref
->ref
; ref
; ref
= ref
->next
)
9057 if (ref
->type
== REF_COMPONENT
9058 && ref
->u
.c
.component
->attr
.proc_pointer
)
9059 sym
= ref
->u
.c
.component
->ts
.interface
;
9068 /* Walk the arguments of an elemental function.
9069 PROC_EXPR is used to check whether an argument is permitted to be absent. If
9070 it is NULL, we don't do the check and the argument is assumed to be present.
9074 gfc_walk_elemental_function_args (gfc_ss
* ss
, gfc_actual_arglist
*arg
,
9075 gfc_symbol
*proc_ifc
, gfc_ss_type type
)
9077 gfc_formal_arglist
*dummy_arg
;
9083 head
= gfc_ss_terminator
;
9087 dummy_arg
= gfc_sym_get_dummy_args (proc_ifc
);
9092 for (; arg
; arg
= arg
->next
)
9094 if (!arg
->expr
|| arg
->expr
->expr_type
== EXPR_NULL
)
9097 newss
= gfc_walk_subexpr (head
, arg
->expr
);
9100 /* Scalar argument. */
9101 gcc_assert (type
== GFC_SS_SCALAR
|| type
== GFC_SS_REFERENCE
);
9102 newss
= gfc_get_scalar_ss (head
, arg
->expr
);
9103 newss
->info
->type
= type
;
9109 if (dummy_arg
!= NULL
9110 && dummy_arg
->sym
->attr
.optional
9111 && arg
->expr
->expr_type
== EXPR_VARIABLE
9112 && (gfc_expr_attr (arg
->expr
).optional
9113 || gfc_expr_attr (arg
->expr
).allocatable
9114 || gfc_expr_attr (arg
->expr
).pointer
))
9115 newss
->info
->can_be_null_ref
= true;
9121 while (tail
->next
!= gfc_ss_terminator
)
9125 if (dummy_arg
!= NULL
)
9126 dummy_arg
= dummy_arg
->next
;
9131 /* If all the arguments are scalar we don't need the argument SS. */
9132 gfc_free_ss_chain (head
);
9137 /* Add it onto the existing chain. */
9143 /* Walk a function call. Scalar functions are passed back, and taken out of
9144 scalarization loops. For elemental functions we walk their arguments.
9145 The result of functions returning arrays is stored in a temporary outside
9146 the loop, so that the function is only called once. Hence we do not need
9147 to walk their arguments. */
9150 gfc_walk_function_expr (gfc_ss
* ss
, gfc_expr
* expr
)
9152 gfc_intrinsic_sym
*isym
;
9154 gfc_component
*comp
= NULL
;
9156 isym
= expr
->value
.function
.isym
;
9158 /* Handle intrinsic functions separately. */
9160 return gfc_walk_intrinsic_function (ss
, expr
, isym
);
9162 sym
= expr
->value
.function
.esym
;
9164 sym
= expr
->symtree
->n
.sym
;
9166 if (gfc_is_alloc_class_array_function (expr
))
9167 return gfc_get_array_ss (ss
, expr
,
9168 CLASS_DATA (expr
->value
.function
.esym
->result
)->as
->rank
,
9171 /* A function that returns arrays. */
9172 comp
= gfc_get_proc_ptr_comp (expr
);
9173 if ((!comp
&& gfc_return_by_reference (sym
) && sym
->result
->attr
.dimension
)
9174 || (comp
&& comp
->attr
.dimension
))
9175 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
9177 /* Walk the parameters of an elemental function. For now we always pass
9179 if (sym
->attr
.elemental
|| (comp
&& comp
->attr
.elemental
))
9181 gfc_ss
*old_ss
= ss
;
9183 ss
= gfc_walk_elemental_function_args (old_ss
,
9184 expr
->value
.function
.actual
,
9185 gfc_get_proc_ifc_for_expr (expr
),
9189 || sym
->attr
.proc_pointer
9190 || sym
->attr
.if_source
!= IFSRC_DECL
9191 || sym
->attr
.array_outer_dependency
))
9192 ss
->info
->array_outer_dependency
= 1;
9195 /* Scalar functions are OK as these are evaluated outside the scalarization
9196 loop. Pass back and let the caller deal with it. */
9201 /* An array temporary is constructed for array constructors. */
9204 gfc_walk_array_constructor (gfc_ss
* ss
, gfc_expr
* expr
)
9206 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_CONSTRUCTOR
);
9210 /* Walk an expression. Add walked expressions to the head of the SS chain.
9211 A wholly scalar expression will not be added. */
9214 gfc_walk_subexpr (gfc_ss
* ss
, gfc_expr
* expr
)
9218 switch (expr
->expr_type
)
9221 head
= gfc_walk_variable_expr (ss
, expr
);
9225 head
= gfc_walk_op_expr (ss
, expr
);
9229 head
= gfc_walk_function_expr (ss
, expr
);
9234 case EXPR_STRUCTURE
:
9235 /* Pass back and let the caller deal with it. */
9239 head
= gfc_walk_array_constructor (ss
, expr
);
9242 case EXPR_SUBSTRING
:
9243 /* Pass back and let the caller deal with it. */
9247 gfc_internal_error ("bad expression type during walk (%d)",
9254 /* Entry point for expression walking.
9255 A return value equal to the passed chain means this is
9256 a scalar expression. It is up to the caller to take whatever action is
9257 necessary to translate these. */
9260 gfc_walk_expr (gfc_expr
* expr
)
9264 res
= gfc_walk_subexpr (gfc_ss_terminator
, expr
);
9265 return gfc_reverse_ss (res
);