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_vtable_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
)
2479 /* Move the evaluation of scalar expressions outside the
2480 scalarization loop, except for WHERE assignments. */
2482 se
.expr
= convert(gfc_array_index_type
, se
.expr
);
2483 if (!ss_info
->where
)
2484 se
.expr
= gfc_evaluate_now (se
.expr
, &outer_loop
->pre
);
2485 gfc_add_block_to_block (&outer_loop
->pre
, &se
.post
);
2488 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2490 ss_info
->data
.scalar
.value
= se
.expr
;
2491 ss_info
->string_length
= se
.string_length
;
2494 case GFC_SS_REFERENCE
:
2495 /* Scalar argument to elemental procedure. */
2496 gfc_init_se (&se
, NULL
);
2497 if (ss_info
->can_be_null_ref
)
2499 /* If the actual argument can be absent (in other words, it can
2500 be a NULL reference), don't try to evaluate it; pass instead
2501 the reference directly. */
2502 gfc_conv_expr_reference (&se
, expr
);
2506 /* Otherwise, evaluate the argument outside the loop and pass
2507 a reference to the value. */
2508 gfc_conv_expr (&se
, expr
);
2511 /* Ensure that a pointer to the string is stored. */
2512 if (expr
->ts
.type
== BT_CHARACTER
)
2513 gfc_conv_string_parameter (&se
);
2515 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2516 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2517 if (gfc_is_class_scalar_expr (expr
))
2518 /* This is necessary because the dynamic type will always be
2519 large than the declared type. In consequence, assigning
2520 the value to a temporary could segfault.
2521 OOP-TODO: see if this is generally correct or is the value
2522 has to be written to an allocated temporary, whose address
2523 is passed via ss_info. */
2524 ss_info
->data
.scalar
.value
= se
.expr
;
2526 ss_info
->data
.scalar
.value
= gfc_evaluate_now (se
.expr
,
2529 ss_info
->string_length
= se
.string_length
;
2532 case GFC_SS_SECTION
:
2533 /* Add the expressions for scalar and vector subscripts. */
2534 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2535 if (info
->subscript
[n
])
2536 gfc_add_loop_ss_code (loop
, info
->subscript
[n
], true, where
);
2538 set_vector_loop_bounds (ss
);
2542 /* Get the vector's descriptor and store it in SS. */
2543 gfc_init_se (&se
, NULL
);
2544 gfc_conv_expr_descriptor (&se
, expr
);
2545 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2546 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2547 info
->descriptor
= se
.expr
;
2550 case GFC_SS_INTRINSIC
:
2551 gfc_add_intrinsic_ss_code (loop
, ss
);
2554 case GFC_SS_FUNCTION
:
2555 /* Array function return value. We call the function and save its
2556 result in a temporary for use inside the loop. */
2557 gfc_init_se (&se
, NULL
);
2560 gfc_conv_expr (&se
, expr
);
2561 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2562 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2563 ss_info
->string_length
= se
.string_length
;
2566 case GFC_SS_CONSTRUCTOR
:
2567 if (expr
->ts
.type
== BT_CHARACTER
2568 && ss_info
->string_length
== NULL
2570 && expr
->ts
.u
.cl
->length
)
2572 gfc_init_se (&se
, NULL
);
2573 gfc_conv_expr_type (&se
, expr
->ts
.u
.cl
->length
,
2574 gfc_charlen_type_node
);
2575 ss_info
->string_length
= se
.expr
;
2576 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2577 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2579 trans_array_constructor (ss
, where
);
2583 case GFC_SS_COMPONENT
:
2584 /* Do nothing. These are handled elsewhere. */
2593 for (nested_loop
= loop
->nested
; nested_loop
;
2594 nested_loop
= nested_loop
->next
)
2595 gfc_add_loop_ss_code (nested_loop
, nested_loop
->ss
, subscript
, where
);
2599 /* Translate expressions for the descriptor and data pointer of a SS. */
2603 gfc_conv_ss_descriptor (stmtblock_t
* block
, gfc_ss
* ss
, int base
)
2606 gfc_ss_info
*ss_info
;
2607 gfc_array_info
*info
;
2611 info
= &ss_info
->data
.array
;
2613 /* Get the descriptor for the array to be scalarized. */
2614 gcc_assert (ss_info
->expr
->expr_type
== EXPR_VARIABLE
);
2615 gfc_init_se (&se
, NULL
);
2616 se
.descriptor_only
= 1;
2617 gfc_conv_expr_lhs (&se
, ss_info
->expr
);
2618 gfc_add_block_to_block (block
, &se
.pre
);
2619 info
->descriptor
= se
.expr
;
2620 ss_info
->string_length
= se
.string_length
;
2624 /* Also the data pointer. */
2625 tmp
= gfc_conv_array_data (se
.expr
);
2626 /* If this is a variable or address of a variable we use it directly.
2627 Otherwise we must evaluate it now to avoid breaking dependency
2628 analysis by pulling the expressions for elemental array indices
2631 || (TREE_CODE (tmp
) == ADDR_EXPR
2632 && DECL_P (TREE_OPERAND (tmp
, 0)))))
2633 tmp
= gfc_evaluate_now (tmp
, block
);
2636 tmp
= gfc_conv_array_offset (se
.expr
);
2637 info
->offset
= gfc_evaluate_now (tmp
, block
);
2639 /* Make absolutely sure that the saved_offset is indeed saved
2640 so that the variable is still accessible after the loops
2642 info
->saved_offset
= info
->offset
;
2647 /* Initialize a gfc_loopinfo structure. */
2650 gfc_init_loopinfo (gfc_loopinfo
* loop
)
2654 memset (loop
, 0, sizeof (gfc_loopinfo
));
2655 gfc_init_block (&loop
->pre
);
2656 gfc_init_block (&loop
->post
);
2658 /* Initially scalarize in order and default to no loop reversal. */
2659 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2662 loop
->reverse
[n
] = GFC_INHIBIT_REVERSE
;
2665 loop
->ss
= gfc_ss_terminator
;
2669 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2673 gfc_copy_loopinfo_to_se (gfc_se
* se
, gfc_loopinfo
* loop
)
2679 /* Return an expression for the data pointer of an array. */
2682 gfc_conv_array_data (tree descriptor
)
2686 type
= TREE_TYPE (descriptor
);
2687 if (GFC_ARRAY_TYPE_P (type
))
2689 if (TREE_CODE (type
) == POINTER_TYPE
)
2693 /* Descriptorless arrays. */
2694 return gfc_build_addr_expr (NULL_TREE
, descriptor
);
2698 return gfc_conv_descriptor_data_get (descriptor
);
2702 /* Return an expression for the base offset of an array. */
2705 gfc_conv_array_offset (tree descriptor
)
2709 type
= TREE_TYPE (descriptor
);
2710 if (GFC_ARRAY_TYPE_P (type
))
2711 return GFC_TYPE_ARRAY_OFFSET (type
);
2713 return gfc_conv_descriptor_offset_get (descriptor
);
2717 /* Get an expression for the array stride. */
2720 gfc_conv_array_stride (tree descriptor
, int dim
)
2725 type
= TREE_TYPE (descriptor
);
2727 /* For descriptorless arrays use the array size. */
2728 tmp
= GFC_TYPE_ARRAY_STRIDE (type
, dim
);
2729 if (tmp
!= NULL_TREE
)
2732 tmp
= gfc_conv_descriptor_stride_get (descriptor
, gfc_rank_cst
[dim
]);
2737 /* Like gfc_conv_array_stride, but for the lower bound. */
2740 gfc_conv_array_lbound (tree descriptor
, int dim
)
2745 type
= TREE_TYPE (descriptor
);
2747 tmp
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
2748 if (tmp
!= NULL_TREE
)
2751 tmp
= gfc_conv_descriptor_lbound_get (descriptor
, gfc_rank_cst
[dim
]);
2756 /* Like gfc_conv_array_stride, but for the upper bound. */
2759 gfc_conv_array_ubound (tree descriptor
, int dim
)
2764 type
= TREE_TYPE (descriptor
);
2766 tmp
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
2767 if (tmp
!= NULL_TREE
)
2770 /* This should only ever happen when passing an assumed shape array
2771 as an actual parameter. The value will never be used. */
2772 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor
)))
2773 return gfc_index_zero_node
;
2775 tmp
= gfc_conv_descriptor_ubound_get (descriptor
, gfc_rank_cst
[dim
]);
2780 /* Generate code to perform an array index bound check. */
2783 trans_array_bound_check (gfc_se
* se
, gfc_ss
*ss
, tree index
, int n
,
2784 locus
* where
, bool check_upper
)
2787 tree tmp_lo
, tmp_up
;
2790 const char * name
= NULL
;
2792 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
2795 descriptor
= ss
->info
->data
.array
.descriptor
;
2797 index
= gfc_evaluate_now (index
, &se
->pre
);
2799 /* We find a name for the error message. */
2800 name
= ss
->info
->expr
->symtree
->n
.sym
->name
;
2801 gcc_assert (name
!= NULL
);
2803 if (TREE_CODE (descriptor
) == VAR_DECL
)
2804 name
= IDENTIFIER_POINTER (DECL_NAME (descriptor
));
2806 /* If upper bound is present, include both bounds in the error message. */
2809 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
2810 tmp_up
= gfc_conv_array_ubound (descriptor
, n
);
2813 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
2814 "outside of expected range (%%ld:%%ld)", n
+1, name
);
2816 msg
= xasprintf ("Index '%%ld' of dimension %d "
2817 "outside of expected range (%%ld:%%ld)", n
+1);
2819 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2821 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2822 fold_convert (long_integer_type_node
, index
),
2823 fold_convert (long_integer_type_node
, tmp_lo
),
2824 fold_convert (long_integer_type_node
, tmp_up
));
2825 fault
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2827 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2828 fold_convert (long_integer_type_node
, index
),
2829 fold_convert (long_integer_type_node
, tmp_lo
),
2830 fold_convert (long_integer_type_node
, tmp_up
));
2835 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
2838 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
2839 "below lower bound of %%ld", n
+1, name
);
2841 msg
= xasprintf ("Index '%%ld' of dimension %d "
2842 "below lower bound of %%ld", n
+1);
2844 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2846 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2847 fold_convert (long_integer_type_node
, index
),
2848 fold_convert (long_integer_type_node
, tmp_lo
));
2856 /* Return the offset for an index. Performs bound checking for elemental
2857 dimensions. Single element references are processed separately.
2858 DIM is the array dimension, I is the loop dimension. */
2861 conv_array_index_offset (gfc_se
* se
, gfc_ss
* ss
, int dim
, int i
,
2862 gfc_array_ref
* ar
, tree stride
)
2864 gfc_array_info
*info
;
2869 info
= &ss
->info
->data
.array
;
2871 /* Get the index into the array for this dimension. */
2874 gcc_assert (ar
->type
!= AR_ELEMENT
);
2875 switch (ar
->dimen_type
[dim
])
2877 case DIMEN_THIS_IMAGE
:
2881 /* Elemental dimension. */
2882 gcc_assert (info
->subscript
[dim
]
2883 && info
->subscript
[dim
]->info
->type
== GFC_SS_SCALAR
);
2884 /* We've already translated this value outside the loop. */
2885 index
= info
->subscript
[dim
]->info
->data
.scalar
.value
;
2887 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
2888 ar
->as
->type
!= AS_ASSUMED_SIZE
2889 || dim
< ar
->dimen
- 1);
2893 gcc_assert (info
&& se
->loop
);
2894 gcc_assert (info
->subscript
[dim
]
2895 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
2896 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
2898 /* Get a zero-based index into the vector. */
2899 index
= fold_build2_loc (input_location
, MINUS_EXPR
,
2900 gfc_array_index_type
,
2901 se
->loop
->loopvar
[i
], se
->loop
->from
[i
]);
2903 /* Multiply the index by the stride. */
2904 index
= fold_build2_loc (input_location
, MULT_EXPR
,
2905 gfc_array_index_type
,
2906 index
, gfc_conv_array_stride (desc
, 0));
2908 /* Read the vector to get an index into info->descriptor. */
2909 data
= build_fold_indirect_ref_loc (input_location
,
2910 gfc_conv_array_data (desc
));
2911 index
= gfc_build_array_ref (data
, index
, NULL
);
2912 index
= gfc_evaluate_now (index
, &se
->pre
);
2913 index
= fold_convert (gfc_array_index_type
, index
);
2915 /* Do any bounds checking on the final info->descriptor index. */
2916 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
2917 ar
->as
->type
!= AS_ASSUMED_SIZE
2918 || dim
< ar
->dimen
- 1);
2922 /* Scalarized dimension. */
2923 gcc_assert (info
&& se
->loop
);
2925 /* Multiply the loop variable by the stride and delta. */
2926 index
= se
->loop
->loopvar
[i
];
2927 if (!integer_onep (info
->stride
[dim
]))
2928 index
= fold_build2_loc (input_location
, MULT_EXPR
,
2929 gfc_array_index_type
, index
,
2931 if (!integer_zerop (info
->delta
[dim
]))
2932 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
2933 gfc_array_index_type
, index
,
2943 /* Temporary array or derived type component. */
2944 gcc_assert (se
->loop
);
2945 index
= se
->loop
->loopvar
[se
->loop
->order
[i
]];
2947 /* Pointer functions can have stride[0] different from unity.
2948 Use the stride returned by the function call and stored in
2949 the descriptor for the temporary. */
2950 if (se
->ss
&& se
->ss
->info
->type
== GFC_SS_FUNCTION
2951 && se
->ss
->info
->expr
2952 && se
->ss
->info
->expr
->symtree
2953 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
2954 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
->attr
.pointer
)
2955 stride
= gfc_conv_descriptor_stride_get (info
->descriptor
,
2958 if (!integer_zerop (info
->delta
[dim
]))
2959 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
2960 gfc_array_index_type
, index
, info
->delta
[dim
]);
2963 /* Multiply by the stride. */
2964 if (!integer_onep (stride
))
2965 index
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
2972 /* Build a scalarized array reference using the vptr 'size'. */
2975 build_class_array_ref (gfc_se
*se
, tree base
, tree index
)
2982 gfc_expr
*expr
= se
->ss
->info
->expr
;
2987 if (expr
== NULL
|| expr
->ts
.type
!= BT_CLASS
)
2990 if (expr
->symtree
&& expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
2991 ts
= &expr
->symtree
->n
.sym
->ts
;
2996 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2998 if (ref
->type
== REF_COMPONENT
2999 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
3000 && ref
->next
&& ref
->next
->type
== REF_COMPONENT
3001 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0
3003 && ref
->next
->next
->type
== REF_ARRAY
3004 && ref
->next
->next
->u
.ar
.type
!= AR_ELEMENT
)
3006 ts
= &ref
->u
.c
.component
->ts
;
3015 if (class_ref
== NULL
&& expr
->symtree
->n
.sym
->attr
.function
3016 && expr
->symtree
->n
.sym
== expr
->symtree
->n
.sym
->result
)
3018 gcc_assert (expr
->symtree
->n
.sym
->backend_decl
== current_function_decl
);
3019 decl
= gfc_get_fake_result_decl (expr
->symtree
->n
.sym
, 0);
3021 else if (class_ref
== NULL
)
3022 decl
= expr
->symtree
->n
.sym
->backend_decl
;
3025 /* Remove everything after the last class reference, convert the
3026 expression and then recover its tailend once more. */
3028 ref
= class_ref
->next
;
3029 class_ref
->next
= NULL
;
3030 gfc_init_se (&tmpse
, NULL
);
3031 gfc_conv_expr (&tmpse
, expr
);
3033 class_ref
->next
= ref
;
3036 size
= gfc_vtable_size_get (decl
);
3038 /* Build the address of the element. */
3039 type
= TREE_TYPE (TREE_TYPE (base
));
3040 size
= fold_convert (TREE_TYPE (index
), size
);
3041 offset
= fold_build2_loc (input_location
, MULT_EXPR
,
3042 gfc_array_index_type
,
3044 tmp
= gfc_build_addr_expr (pvoid_type_node
, base
);
3045 tmp
= fold_build_pointer_plus_loc (input_location
, tmp
, offset
);
3046 tmp
= fold_convert (build_pointer_type (type
), tmp
);
3048 /* Return the element in the se expression. */
3049 se
->expr
= build_fold_indirect_ref_loc (input_location
, tmp
);
3054 /* Build a scalarized reference to an array. */
3057 gfc_conv_scalarized_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
3059 gfc_array_info
*info
;
3060 tree decl
= NULL_TREE
;
3068 expr
= ss
->info
->expr
;
3069 info
= &ss
->info
->data
.array
;
3071 n
= se
->loop
->order
[0];
3075 index
= conv_array_index_offset (se
, ss
, ss
->dim
[n
], n
, ar
, info
->stride0
);
3076 /* Add the offset for this dimension to the stored offset for all other
3078 if (!integer_zerop (info
->offset
))
3079 index
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3080 index
, info
->offset
);
3082 if (expr
&& is_subref_array (expr
))
3083 decl
= expr
->symtree
->n
.sym
->backend_decl
;
3085 tmp
= build_fold_indirect_ref_loc (input_location
, info
->data
);
3087 /* Use the vptr 'size' field to access a class the element of a class
3089 if (build_class_array_ref (se
, tmp
, index
))
3092 se
->expr
= gfc_build_array_ref (tmp
, index
, decl
);
3096 /* Translate access of temporary array. */
3099 gfc_conv_tmp_array_ref (gfc_se
* se
)
3101 se
->string_length
= se
->ss
->info
->string_length
;
3102 gfc_conv_scalarized_array_ref (se
, NULL
);
3103 gfc_advance_se_ss_chain (se
);
3106 /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
3109 add_to_offset (tree
*cst_offset
, tree
*offset
, tree t
)
3111 if (TREE_CODE (t
) == INTEGER_CST
)
3112 *cst_offset
= int_const_binop (PLUS_EXPR
, *cst_offset
, t
);
3115 if (!integer_zerop (*offset
))
3116 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3117 gfc_array_index_type
, *offset
, t
);
3125 build_array_ref (tree desc
, tree offset
, tree decl
)
3130 /* Class container types do not always have the GFC_CLASS_TYPE_P
3131 but the canonical type does. */
3132 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
3133 && TREE_CODE (desc
) == COMPONENT_REF
)
3135 type
= TREE_TYPE (TREE_OPERAND (desc
, 0));
3136 if (TYPE_CANONICAL (type
)
3137 && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type
)))
3138 type
= TYPE_CANONICAL (type
);
3143 /* Class array references need special treatment because the assigned
3144 type size needs to be used to point to the element. */
3145 if (type
&& GFC_CLASS_TYPE_P (type
))
3147 type
= gfc_get_element_type (TREE_TYPE (desc
));
3148 tmp
= TREE_OPERAND (desc
, 0);
3149 tmp
= gfc_get_class_array_ref (offset
, tmp
);
3150 tmp
= fold_convert (build_pointer_type (type
), tmp
);
3151 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3155 tmp
= gfc_conv_array_data (desc
);
3156 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3157 tmp
= gfc_build_array_ref (tmp
, offset
, decl
);
3162 /* Build an array reference. se->expr already holds the array descriptor.
3163 This should be either a variable, indirect variable reference or component
3164 reference. For arrays which do not have a descriptor, se->expr will be
3166 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
3169 gfc_conv_array_ref (gfc_se
* se
, gfc_array_ref
* ar
, gfc_expr
*expr
,
3173 tree offset
, cst_offset
;
3178 gfc_symbol
* sym
= expr
->symtree
->n
.sym
;
3179 char *var_name
= NULL
;
3183 gcc_assert (ar
->codimen
);
3185 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
->expr
)))
3186 se
->expr
= build_fold_indirect_ref (gfc_conv_array_data (se
->expr
));
3189 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se
->expr
))
3190 && TREE_CODE (TREE_TYPE (se
->expr
)) == POINTER_TYPE
)
3191 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3193 /* Use the actual tree type and not the wrapped coarray. */
3194 if (!se
->want_pointer
)
3195 se
->expr
= fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se
->expr
)),
3202 /* Handle scalarized references separately. */
3203 if (ar
->type
!= AR_ELEMENT
)
3205 gfc_conv_scalarized_array_ref (se
, ar
);
3206 gfc_advance_se_ss_chain (se
);
3210 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3215 len
= strlen (sym
->name
) + 1;
3216 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3218 if (ref
->type
== REF_ARRAY
&& &ref
->u
.ar
== ar
)
3220 if (ref
->type
== REF_COMPONENT
)
3221 len
+= 1 + strlen (ref
->u
.c
.component
->name
);
3224 var_name
= XALLOCAVEC (char, len
);
3225 strcpy (var_name
, sym
->name
);
3227 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3229 if (ref
->type
== REF_ARRAY
&& &ref
->u
.ar
== ar
)
3231 if (ref
->type
== REF_COMPONENT
)
3233 strcat (var_name
, "%%");
3234 strcat (var_name
, ref
->u
.c
.component
->name
);
3239 cst_offset
= offset
= gfc_index_zero_node
;
3240 add_to_offset (&cst_offset
, &offset
, gfc_conv_array_offset (se
->expr
));
3242 /* Calculate the offsets from all the dimensions. Make sure to associate
3243 the final offset so that we form a chain of loop invariant summands. */
3244 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
3246 /* Calculate the index for this dimension. */
3247 gfc_init_se (&indexse
, se
);
3248 gfc_conv_expr_type (&indexse
, ar
->start
[n
], gfc_array_index_type
);
3249 gfc_add_block_to_block (&se
->pre
, &indexse
.pre
);
3251 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3253 /* Check array bounds. */
3257 /* Evaluate the indexse.expr only once. */
3258 indexse
.expr
= save_expr (indexse
.expr
);
3261 tmp
= gfc_conv_array_lbound (se
->expr
, n
);
3262 if (sym
->attr
.temporary
)
3264 gfc_init_se (&tmpse
, se
);
3265 gfc_conv_expr_type (&tmpse
, ar
->as
->lower
[n
],
3266 gfc_array_index_type
);
3267 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3271 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
3273 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3274 "below lower bound of %%ld", n
+1, var_name
);
3275 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3276 fold_convert (long_integer_type_node
,
3278 fold_convert (long_integer_type_node
, tmp
));
3281 /* Upper bound, but not for the last dimension of assumed-size
3283 if (n
< ar
->dimen
- 1 || ar
->as
->type
!= AS_ASSUMED_SIZE
)
3285 tmp
= gfc_conv_array_ubound (se
->expr
, n
);
3286 if (sym
->attr
.temporary
)
3288 gfc_init_se (&tmpse
, se
);
3289 gfc_conv_expr_type (&tmpse
, ar
->as
->upper
[n
],
3290 gfc_array_index_type
);
3291 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3295 cond
= fold_build2_loc (input_location
, GT_EXPR
,
3296 boolean_type_node
, indexse
.expr
, tmp
);
3297 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3298 "above upper bound of %%ld", n
+1, var_name
);
3299 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3300 fold_convert (long_integer_type_node
,
3302 fold_convert (long_integer_type_node
, tmp
));
3307 /* Multiply the index by the stride. */
3308 stride
= gfc_conv_array_stride (se
->expr
, n
);
3309 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3310 indexse
.expr
, stride
);
3312 /* And add it to the total. */
3313 add_to_offset (&cst_offset
, &offset
, tmp
);
3316 if (!integer_zerop (cst_offset
))
3317 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3318 gfc_array_index_type
, offset
, cst_offset
);
3320 se
->expr
= build_array_ref (se
->expr
, offset
, sym
->backend_decl
);
3324 /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
3325 LOOP_DIM dimension (if any) to array's offset. */
3328 add_array_offset (stmtblock_t
*pblock
, gfc_loopinfo
*loop
, gfc_ss
*ss
,
3329 gfc_array_ref
*ar
, int array_dim
, int loop_dim
)
3332 gfc_array_info
*info
;
3335 info
= &ss
->info
->data
.array
;
3337 gfc_init_se (&se
, NULL
);
3339 se
.expr
= info
->descriptor
;
3340 stride
= gfc_conv_array_stride (info
->descriptor
, array_dim
);
3341 index
= conv_array_index_offset (&se
, ss
, array_dim
, loop_dim
, ar
, stride
);
3342 gfc_add_block_to_block (pblock
, &se
.pre
);
3344 info
->offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3345 gfc_array_index_type
,
3346 info
->offset
, index
);
3347 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
3351 /* Generate the code to be executed immediately before entering a
3352 scalarization loop. */
3355 gfc_trans_preloop_setup (gfc_loopinfo
* loop
, int dim
, int flag
,
3356 stmtblock_t
* pblock
)
3359 gfc_ss_info
*ss_info
;
3360 gfc_array_info
*info
;
3361 gfc_ss_type ss_type
;
3363 gfc_loopinfo
*ploop
;
3367 /* This code will be executed before entering the scalarization loop
3368 for this dimension. */
3369 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3373 if ((ss_info
->useflags
& flag
) == 0)
3376 ss_type
= ss_info
->type
;
3377 if (ss_type
!= GFC_SS_SECTION
3378 && ss_type
!= GFC_SS_FUNCTION
3379 && ss_type
!= GFC_SS_CONSTRUCTOR
3380 && ss_type
!= GFC_SS_COMPONENT
)
3383 info
= &ss_info
->data
.array
;
3385 gcc_assert (dim
< ss
->dimen
);
3386 gcc_assert (ss
->dimen
== loop
->dimen
);
3389 ar
= &info
->ref
->u
.ar
;
3393 if (dim
== loop
->dimen
- 1 && loop
->parent
!= NULL
)
3395 /* If we are in the outermost dimension of this loop, the previous
3396 dimension shall be in the parent loop. */
3397 gcc_assert (ss
->parent
!= NULL
);
3400 ploop
= loop
->parent
;
3402 /* ss and ss->parent are about the same array. */
3403 gcc_assert (ss_info
== pss
->info
);
3411 if (dim
== loop
->dimen
- 1)
3416 /* For the time being, there is no loop reordering. */
3417 gcc_assert (i
== ploop
->order
[i
]);
3418 i
= ploop
->order
[i
];
3420 if (dim
== loop
->dimen
- 1 && loop
->parent
== NULL
)
3422 stride
= gfc_conv_array_stride (info
->descriptor
,
3423 innermost_ss (ss
)->dim
[i
]);
3425 /* Calculate the stride of the innermost loop. Hopefully this will
3426 allow the backend optimizers to do their stuff more effectively.
3428 info
->stride0
= gfc_evaluate_now (stride
, pblock
);
3430 /* For the outermost loop calculate the offset due to any
3431 elemental dimensions. It will have been initialized with the
3432 base offset of the array. */
3435 for (i
= 0; i
< ar
->dimen
; i
++)
3437 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
3440 add_array_offset (pblock
, loop
, ss
, ar
, i
, /* unused */ -1);
3445 /* Add the offset for the previous loop dimension. */
3446 add_array_offset (pblock
, ploop
, ss
, ar
, pss
->dim
[i
], i
);
3448 /* Remember this offset for the second loop. */
3449 if (dim
== loop
->temp_dim
- 1 && loop
->parent
== NULL
)
3450 info
->saved_offset
= info
->offset
;
3455 /* Start a scalarized expression. Creates a scope and declares loop
3459 gfc_start_scalarized_body (gfc_loopinfo
* loop
, stmtblock_t
* pbody
)
3465 gcc_assert (!loop
->array_parameter
);
3467 for (dim
= loop
->dimen
- 1; dim
>= 0; dim
--)
3469 n
= loop
->order
[dim
];
3471 gfc_start_block (&loop
->code
[n
]);
3473 /* Create the loop variable. */
3474 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "S");
3476 if (dim
< loop
->temp_dim
)
3480 /* Calculate values that will be constant within this loop. */
3481 gfc_trans_preloop_setup (loop
, dim
, flags
, &loop
->code
[n
]);
3483 gfc_start_block (pbody
);
3487 /* Generates the actual loop code for a scalarization loop. */
3490 gfc_trans_scalarized_loop_end (gfc_loopinfo
* loop
, int n
,
3491 stmtblock_t
* pbody
)
3502 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
))
3503 == (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
)
3504 && n
== loop
->dimen
- 1)
3506 /* We create an OMP_FOR construct for the outermost scalarized loop. */
3507 init
= make_tree_vec (1);
3508 cond
= make_tree_vec (1);
3509 incr
= make_tree_vec (1);
3511 /* Cycle statement is implemented with a goto. Exit statement must not
3512 be present for this loop. */
3513 exit_label
= gfc_build_label_decl (NULL_TREE
);
3514 TREE_USED (exit_label
) = 1;
3516 /* Label for cycle statements (if needed). */
3517 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3518 gfc_add_expr_to_block (pbody
, tmp
);
3520 stmt
= make_node (OMP_FOR
);
3522 TREE_TYPE (stmt
) = void_type_node
;
3523 OMP_FOR_BODY (stmt
) = loopbody
= gfc_finish_block (pbody
);
3525 OMP_FOR_CLAUSES (stmt
) = build_omp_clause (input_location
,
3526 OMP_CLAUSE_SCHEDULE
);
3527 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt
))
3528 = OMP_CLAUSE_SCHEDULE_STATIC
;
3529 if (ompws_flags
& OMPWS_NOWAIT
)
3530 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt
))
3531 = build_omp_clause (input_location
, OMP_CLAUSE_NOWAIT
);
3533 /* Initialize the loopvar. */
3534 TREE_VEC_ELT (init
, 0) = build2_v (MODIFY_EXPR
, loop
->loopvar
[n
],
3536 OMP_FOR_INIT (stmt
) = init
;
3537 /* The exit condition. */
3538 TREE_VEC_ELT (cond
, 0) = build2_loc (input_location
, LE_EXPR
,
3540 loop
->loopvar
[n
], loop
->to
[n
]);
3541 SET_EXPR_LOCATION (TREE_VEC_ELT (cond
, 0), input_location
);
3542 OMP_FOR_COND (stmt
) = cond
;
3543 /* Increment the loopvar. */
3544 tmp
= build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3545 loop
->loopvar
[n
], gfc_index_one_node
);
3546 TREE_VEC_ELT (incr
, 0) = fold_build2_loc (input_location
, MODIFY_EXPR
,
3547 void_type_node
, loop
->loopvar
[n
], tmp
);
3548 OMP_FOR_INCR (stmt
) = incr
;
3550 ompws_flags
&= ~OMPWS_CURR_SINGLEUNIT
;
3551 gfc_add_expr_to_block (&loop
->code
[n
], stmt
);
3555 bool reverse_loop
= (loop
->reverse
[n
] == GFC_REVERSE_SET
)
3556 && (loop
->temp_ss
== NULL
);
3558 loopbody
= gfc_finish_block (pbody
);
3562 tmp
= loop
->from
[n
];
3563 loop
->from
[n
] = loop
->to
[n
];
3567 /* Initialize the loopvar. */
3568 if (loop
->loopvar
[n
] != loop
->from
[n
])
3569 gfc_add_modify (&loop
->code
[n
], loop
->loopvar
[n
], loop
->from
[n
]);
3571 exit_label
= gfc_build_label_decl (NULL_TREE
);
3573 /* Generate the loop body. */
3574 gfc_init_block (&block
);
3576 /* The exit condition. */
3577 cond
= fold_build2_loc (input_location
, reverse_loop
? LT_EXPR
: GT_EXPR
,
3578 boolean_type_node
, loop
->loopvar
[n
], loop
->to
[n
]);
3579 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3580 TREE_USED (exit_label
) = 1;
3581 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3582 gfc_add_expr_to_block (&block
, tmp
);
3584 /* The main body. */
3585 gfc_add_expr_to_block (&block
, loopbody
);
3587 /* Increment the loopvar. */
3588 tmp
= fold_build2_loc (input_location
,
3589 reverse_loop
? MINUS_EXPR
: PLUS_EXPR
,
3590 gfc_array_index_type
, loop
->loopvar
[n
],
3591 gfc_index_one_node
);
3593 gfc_add_modify (&block
, loop
->loopvar
[n
], tmp
);
3595 /* Build the loop. */
3596 tmp
= gfc_finish_block (&block
);
3597 tmp
= build1_v (LOOP_EXPR
, tmp
);
3598 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
3600 /* Add the exit label. */
3601 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3602 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
3608 /* Finishes and generates the loops for a scalarized expression. */
3611 gfc_trans_scalarizing_loops (gfc_loopinfo
* loop
, stmtblock_t
* body
)
3616 stmtblock_t
*pblock
;
3620 /* Generate the loops. */
3621 for (dim
= 0; dim
< loop
->dimen
; dim
++)
3623 n
= loop
->order
[dim
];
3624 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
3625 loop
->loopvar
[n
] = NULL_TREE
;
3626 pblock
= &loop
->code
[n
];
3629 tmp
= gfc_finish_block (pblock
);
3630 gfc_add_expr_to_block (&loop
->pre
, tmp
);
3632 /* Clear all the used flags. */
3633 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3634 if (ss
->parent
== NULL
)
3635 ss
->info
->useflags
= 0;
3639 /* Finish the main body of a scalarized expression, and start the secondary
3643 gfc_trans_scalarized_loop_boundary (gfc_loopinfo
* loop
, stmtblock_t
* body
)
3647 stmtblock_t
*pblock
;
3651 /* We finish as many loops as are used by the temporary. */
3652 for (dim
= 0; dim
< loop
->temp_dim
- 1; dim
++)
3654 n
= loop
->order
[dim
];
3655 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
3656 loop
->loopvar
[n
] = NULL_TREE
;
3657 pblock
= &loop
->code
[n
];
3660 /* We don't want to finish the outermost loop entirely. */
3661 n
= loop
->order
[loop
->temp_dim
- 1];
3662 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
3664 /* Restore the initial offsets. */
3665 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3667 gfc_ss_type ss_type
;
3668 gfc_ss_info
*ss_info
;
3672 if ((ss_info
->useflags
& 2) == 0)
3675 ss_type
= ss_info
->type
;
3676 if (ss_type
!= GFC_SS_SECTION
3677 && ss_type
!= GFC_SS_FUNCTION
3678 && ss_type
!= GFC_SS_CONSTRUCTOR
3679 && ss_type
!= GFC_SS_COMPONENT
)
3682 ss_info
->data
.array
.offset
= ss_info
->data
.array
.saved_offset
;
3685 /* Restart all the inner loops we just finished. */
3686 for (dim
= loop
->temp_dim
- 2; dim
>= 0; dim
--)
3688 n
= loop
->order
[dim
];
3690 gfc_start_block (&loop
->code
[n
]);
3692 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "Q");
3694 gfc_trans_preloop_setup (loop
, dim
, 2, &loop
->code
[n
]);
3697 /* Start a block for the secondary copying code. */
3698 gfc_start_block (body
);
3702 /* Precalculate (either lower or upper) bound of an array section.
3703 BLOCK: Block in which the (pre)calculation code will go.
3704 BOUNDS[DIM]: Where the bound value will be stored once evaluated.
3705 VALUES[DIM]: Specified bound (NULL <=> unspecified).
3706 DESC: Array descriptor from which the bound will be picked if unspecified
3707 (either lower or upper bound according to LBOUND). */
3710 evaluate_bound (stmtblock_t
*block
, tree
*bounds
, gfc_expr
** values
,
3711 tree desc
, int dim
, bool lbound
)
3714 gfc_expr
* input_val
= values
[dim
];
3715 tree
*output
= &bounds
[dim
];
3720 /* Specified section bound. */
3721 gfc_init_se (&se
, NULL
);
3722 gfc_conv_expr_type (&se
, input_val
, gfc_array_index_type
);
3723 gfc_add_block_to_block (block
, &se
.pre
);
3728 /* No specific bound specified so use the bound of the array. */
3729 *output
= lbound
? gfc_conv_array_lbound (desc
, dim
) :
3730 gfc_conv_array_ubound (desc
, dim
);
3732 *output
= gfc_evaluate_now (*output
, block
);
3736 /* Calculate the lower bound of an array section. */
3739 gfc_conv_section_startstride (stmtblock_t
* block
, gfc_ss
* ss
, int dim
)
3741 gfc_expr
*stride
= NULL
;
3744 gfc_array_info
*info
;
3747 gcc_assert (ss
->info
->type
== GFC_SS_SECTION
);
3749 info
= &ss
->info
->data
.array
;
3750 ar
= &info
->ref
->u
.ar
;
3752 if (ar
->dimen_type
[dim
] == DIMEN_VECTOR
)
3754 /* We use a zero-based index to access the vector. */
3755 info
->start
[dim
] = gfc_index_zero_node
;
3756 info
->end
[dim
] = NULL
;
3757 info
->stride
[dim
] = gfc_index_one_node
;
3761 gcc_assert (ar
->dimen_type
[dim
] == DIMEN_RANGE
3762 || ar
->dimen_type
[dim
] == DIMEN_THIS_IMAGE
);
3763 desc
= info
->descriptor
;
3764 stride
= ar
->stride
[dim
];
3766 /* Calculate the start of the range. For vector subscripts this will
3767 be the range of the vector. */
3768 evaluate_bound (block
, info
->start
, ar
->start
, desc
, dim
, true);
3770 /* Similarly calculate the end. Although this is not used in the
3771 scalarizer, it is needed when checking bounds and where the end
3772 is an expression with side-effects. */
3773 evaluate_bound (block
, info
->end
, ar
->end
, desc
, dim
, false);
3775 /* Calculate the stride. */
3777 info
->stride
[dim
] = gfc_index_one_node
;
3780 gfc_init_se (&se
, NULL
);
3781 gfc_conv_expr_type (&se
, stride
, gfc_array_index_type
);
3782 gfc_add_block_to_block (block
, &se
.pre
);
3783 info
->stride
[dim
] = gfc_evaluate_now (se
.expr
, block
);
3788 /* Calculates the range start and stride for a SS chain. Also gets the
3789 descriptor and data pointer. The range of vector subscripts is the size
3790 of the vector. Array bounds are also checked. */
3793 gfc_conv_ss_startstride (gfc_loopinfo
* loop
)
3800 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
3803 /* Determine the rank of the loop. */
3804 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3806 switch (ss
->info
->type
)
3808 case GFC_SS_SECTION
:
3809 case GFC_SS_CONSTRUCTOR
:
3810 case GFC_SS_FUNCTION
:
3811 case GFC_SS_COMPONENT
:
3812 loop
->dimen
= ss
->dimen
;
3815 /* As usual, lbound and ubound are exceptions!. */
3816 case GFC_SS_INTRINSIC
:
3817 switch (ss
->info
->expr
->value
.function
.isym
->id
)
3819 case GFC_ISYM_LBOUND
:
3820 case GFC_ISYM_UBOUND
:
3821 case GFC_ISYM_LCOBOUND
:
3822 case GFC_ISYM_UCOBOUND
:
3823 case GFC_ISYM_THIS_IMAGE
:
3824 loop
->dimen
= ss
->dimen
;
3836 /* We should have determined the rank of the expression by now. If
3837 not, that's bad news. */
3841 /* Loop over all the SS in the chain. */
3842 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3844 gfc_ss_info
*ss_info
;
3845 gfc_array_info
*info
;
3849 expr
= ss_info
->expr
;
3850 info
= &ss_info
->data
.array
;
3852 if (expr
&& expr
->shape
&& !info
->shape
)
3853 info
->shape
= expr
->shape
;
3855 switch (ss_info
->type
)
3857 case GFC_SS_SECTION
:
3858 /* Get the descriptor for the array. If it is a cross loops array,
3859 we got the descriptor already in the outermost loop. */
3860 if (ss
->parent
== NULL
)
3861 gfc_conv_ss_descriptor (&outer_loop
->pre
, ss
,
3862 !loop
->array_parameter
);
3864 for (n
= 0; n
< ss
->dimen
; n
++)
3865 gfc_conv_section_startstride (&outer_loop
->pre
, ss
, ss
->dim
[n
]);
3868 case GFC_SS_INTRINSIC
:
3869 switch (expr
->value
.function
.isym
->id
)
3871 /* Fall through to supply start and stride. */
3872 case GFC_ISYM_LBOUND
:
3873 case GFC_ISYM_UBOUND
:
3877 /* This is the variant without DIM=... */
3878 gcc_assert (expr
->value
.function
.actual
->next
->expr
== NULL
);
3880 arg
= expr
->value
.function
.actual
->expr
;
3881 if (arg
->rank
== -1)
3886 /* The rank (hence the return value's shape) is unknown,
3887 we have to retrieve it. */
3888 gfc_init_se (&se
, NULL
);
3889 se
.descriptor_only
= 1;
3890 gfc_conv_expr (&se
, arg
);
3891 /* This is a bare variable, so there is no preliminary
3893 gcc_assert (se
.pre
.head
== NULL_TREE
3894 && se
.post
.head
== NULL_TREE
);
3895 rank
= gfc_conv_descriptor_rank (se
.expr
);
3896 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3897 gfc_array_index_type
,
3898 fold_convert (gfc_array_index_type
,
3900 gfc_index_one_node
);
3901 info
->end
[0] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
3902 info
->start
[0] = gfc_index_zero_node
;
3903 info
->stride
[0] = gfc_index_one_node
;
3906 /* Otherwise fall through GFC_SS_FUNCTION. */
3908 case GFC_ISYM_LCOBOUND
:
3909 case GFC_ISYM_UCOBOUND
:
3910 case GFC_ISYM_THIS_IMAGE
:
3917 case GFC_SS_CONSTRUCTOR
:
3918 case GFC_SS_FUNCTION
:
3919 for (n
= 0; n
< ss
->dimen
; n
++)
3921 int dim
= ss
->dim
[n
];
3923 info
->start
[dim
] = gfc_index_zero_node
;
3924 info
->end
[dim
] = gfc_index_zero_node
;
3925 info
->stride
[dim
] = gfc_index_one_node
;
3934 /* The rest is just runtime bound checking. */
3935 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3938 tree lbound
, ubound
;
3940 tree size
[GFC_MAX_DIMENSIONS
];
3941 tree stride_pos
, stride_neg
, non_zerosized
, tmp2
, tmp3
;
3942 gfc_array_info
*info
;
3946 gfc_start_block (&block
);
3948 for (n
= 0; n
< loop
->dimen
; n
++)
3949 size
[n
] = NULL_TREE
;
3951 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3954 gfc_ss_info
*ss_info
;
3957 const char *expr_name
;
3960 if (ss_info
->type
!= GFC_SS_SECTION
)
3963 /* Catch allocatable lhs in f2003. */
3964 if (flag_realloc_lhs
&& ss
->is_alloc_lhs
)
3967 expr
= ss_info
->expr
;
3968 expr_loc
= &expr
->where
;
3969 expr_name
= expr
->symtree
->name
;
3971 gfc_start_block (&inner
);
3973 /* TODO: range checking for mapped dimensions. */
3974 info
= &ss_info
->data
.array
;
3976 /* This code only checks ranges. Elemental and vector
3977 dimensions are checked later. */
3978 for (n
= 0; n
< loop
->dimen
; n
++)
3983 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
3986 if (dim
== info
->ref
->u
.ar
.dimen
- 1
3987 && info
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
3988 check_upper
= false;
3992 /* Zero stride is not allowed. */
3993 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
3994 info
->stride
[dim
], gfc_index_zero_node
);
3995 msg
= xasprintf ("Zero stride is not allowed, for dimension %d "
3996 "of array '%s'", dim
+ 1, expr_name
);
3997 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4001 desc
= info
->descriptor
;
4003 /* This is the run-time equivalent of resolve.c's
4004 check_dimension(). The logical is more readable there
4005 than it is here, with all the trees. */
4006 lbound
= gfc_conv_array_lbound (desc
, dim
);
4007 end
= info
->end
[dim
];
4009 ubound
= gfc_conv_array_ubound (desc
, dim
);
4013 /* non_zerosized is true when the selected range is not
4015 stride_pos
= fold_build2_loc (input_location
, GT_EXPR
,
4016 boolean_type_node
, info
->stride
[dim
],
4017 gfc_index_zero_node
);
4018 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
4019 info
->start
[dim
], end
);
4020 stride_pos
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4021 boolean_type_node
, stride_pos
, tmp
);
4023 stride_neg
= fold_build2_loc (input_location
, LT_EXPR
,
4025 info
->stride
[dim
], gfc_index_zero_node
);
4026 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
4027 info
->start
[dim
], end
);
4028 stride_neg
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4031 non_zerosized
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
4033 stride_pos
, stride_neg
);
4035 /* Check the start of the range against the lower and upper
4036 bounds of the array, if the range is not empty.
4037 If upper bound is present, include both bounds in the
4041 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
4043 info
->start
[dim
], lbound
);
4044 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4046 non_zerosized
, tmp
);
4047 tmp2
= fold_build2_loc (input_location
, GT_EXPR
,
4049 info
->start
[dim
], ubound
);
4050 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4052 non_zerosized
, tmp2
);
4053 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4054 "outside of expected range (%%ld:%%ld)",
4055 dim
+ 1, expr_name
);
4056 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4058 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4059 fold_convert (long_integer_type_node
, lbound
),
4060 fold_convert (long_integer_type_node
, ubound
));
4061 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4063 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4064 fold_convert (long_integer_type_node
, lbound
),
4065 fold_convert (long_integer_type_node
, ubound
));
4070 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
4072 info
->start
[dim
], lbound
);
4073 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4074 boolean_type_node
, non_zerosized
, tmp
);
4075 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4076 "below lower bound of %%ld",
4077 dim
+ 1, expr_name
);
4078 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4080 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4081 fold_convert (long_integer_type_node
, lbound
));
4085 /* Compute the last element of the range, which is not
4086 necessarily "end" (think 0:5:3, which doesn't contain 5)
4087 and check it against both lower and upper bounds. */
4089 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4090 gfc_array_index_type
, end
,
4092 tmp
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
,
4093 gfc_array_index_type
, tmp
,
4095 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4096 gfc_array_index_type
, end
, tmp
);
4097 tmp2
= fold_build2_loc (input_location
, LT_EXPR
,
4098 boolean_type_node
, tmp
, lbound
);
4099 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4100 boolean_type_node
, non_zerosized
, tmp2
);
4103 tmp3
= fold_build2_loc (input_location
, GT_EXPR
,
4104 boolean_type_node
, tmp
, ubound
);
4105 tmp3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4106 boolean_type_node
, non_zerosized
, tmp3
);
4107 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4108 "outside of expected range (%%ld:%%ld)",
4109 dim
+ 1, expr_name
);
4110 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4112 fold_convert (long_integer_type_node
, tmp
),
4113 fold_convert (long_integer_type_node
, ubound
),
4114 fold_convert (long_integer_type_node
, lbound
));
4115 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4117 fold_convert (long_integer_type_node
, tmp
),
4118 fold_convert (long_integer_type_node
, ubound
),
4119 fold_convert (long_integer_type_node
, lbound
));
4124 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4125 "below lower bound of %%ld",
4126 dim
+ 1, expr_name
);
4127 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4129 fold_convert (long_integer_type_node
, tmp
),
4130 fold_convert (long_integer_type_node
, lbound
));
4134 /* Check the section sizes match. */
4135 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4136 gfc_array_index_type
, end
,
4138 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
4139 gfc_array_index_type
, tmp
,
4141 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4142 gfc_array_index_type
,
4143 gfc_index_one_node
, tmp
);
4144 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
4145 gfc_array_index_type
, tmp
,
4146 build_int_cst (gfc_array_index_type
, 0));
4147 /* We remember the size of the first section, and check all the
4148 others against this. */
4151 tmp3
= fold_build2_loc (input_location
, NE_EXPR
,
4152 boolean_type_node
, tmp
, size
[n
]);
4153 msg
= xasprintf ("Array bound mismatch for dimension %d "
4154 "of array '%s' (%%ld/%%ld)",
4155 dim
+ 1, expr_name
);
4157 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4159 fold_convert (long_integer_type_node
, tmp
),
4160 fold_convert (long_integer_type_node
, size
[n
]));
4165 size
[n
] = gfc_evaluate_now (tmp
, &inner
);
4168 tmp
= gfc_finish_block (&inner
);
4170 /* For optional arguments, only check bounds if the argument is
4172 if (expr
->symtree
->n
.sym
->attr
.optional
4173 || expr
->symtree
->n
.sym
->attr
.not_always_present
)
4174 tmp
= build3_v (COND_EXPR
,
4175 gfc_conv_expr_present (expr
->symtree
->n
.sym
),
4176 tmp
, build_empty_stmt (input_location
));
4178 gfc_add_expr_to_block (&block
, tmp
);
4182 tmp
= gfc_finish_block (&block
);
4183 gfc_add_expr_to_block (&outer_loop
->pre
, tmp
);
4186 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4187 gfc_conv_ss_startstride (loop
);
4190 /* Return true if both symbols could refer to the same data object. Does
4191 not take account of aliasing due to equivalence statements. */
4194 symbols_could_alias (gfc_symbol
*lsym
, gfc_symbol
*rsym
, bool lsym_pointer
,
4195 bool lsym_target
, bool rsym_pointer
, bool rsym_target
)
4197 /* Aliasing isn't possible if the symbols have different base types. */
4198 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
4201 /* Pointers can point to other pointers and target objects. */
4203 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4204 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4207 /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
4208 and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
4210 if (lsym_target
&& rsym_target
4211 && ((lsym
->attr
.dummy
&& !lsym
->attr
.contiguous
4212 && (!lsym
->attr
.dimension
|| lsym
->as
->type
== AS_ASSUMED_SHAPE
))
4213 || (rsym
->attr
.dummy
&& !rsym
->attr
.contiguous
4214 && (!rsym
->attr
.dimension
4215 || rsym
->as
->type
== AS_ASSUMED_SHAPE
))))
4222 /* Return true if the two SS could be aliased, i.e. both point to the same data
4224 /* TODO: resolve aliases based on frontend expressions. */
4227 gfc_could_be_alias (gfc_ss
* lss
, gfc_ss
* rss
)
4231 gfc_expr
*lexpr
, *rexpr
;
4234 bool lsym_pointer
, lsym_target
, rsym_pointer
, rsym_target
;
4236 lexpr
= lss
->info
->expr
;
4237 rexpr
= rss
->info
->expr
;
4239 lsym
= lexpr
->symtree
->n
.sym
;
4240 rsym
= rexpr
->symtree
->n
.sym
;
4242 lsym_pointer
= lsym
->attr
.pointer
;
4243 lsym_target
= lsym
->attr
.target
;
4244 rsym_pointer
= rsym
->attr
.pointer
;
4245 rsym_target
= rsym
->attr
.target
;
4247 if (symbols_could_alias (lsym
, rsym
, lsym_pointer
, lsym_target
,
4248 rsym_pointer
, rsym_target
))
4251 if (rsym
->ts
.type
!= BT_DERIVED
&& rsym
->ts
.type
!= BT_CLASS
4252 && lsym
->ts
.type
!= BT_DERIVED
&& lsym
->ts
.type
!= BT_CLASS
)
4255 /* For derived types we must check all the component types. We can ignore
4256 array references as these will have the same base type as the previous
4258 for (lref
= lexpr
->ref
; lref
!= lss
->info
->data
.array
.ref
; lref
= lref
->next
)
4260 if (lref
->type
!= REF_COMPONENT
)
4263 lsym_pointer
= lsym_pointer
|| lref
->u
.c
.sym
->attr
.pointer
;
4264 lsym_target
= lsym_target
|| lref
->u
.c
.sym
->attr
.target
;
4266 if (symbols_could_alias (lref
->u
.c
.sym
, rsym
, lsym_pointer
, lsym_target
,
4267 rsym_pointer
, rsym_target
))
4270 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4271 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4273 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4278 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
;
4281 if (rref
->type
!= REF_COMPONENT
)
4284 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4285 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4287 if (symbols_could_alias (lref
->u
.c
.sym
, rref
->u
.c
.sym
,
4288 lsym_pointer
, lsym_target
,
4289 rsym_pointer
, rsym_target
))
4292 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4293 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4295 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4296 &rref
->u
.c
.sym
->ts
))
4298 if (gfc_compare_types (&lref
->u
.c
.sym
->ts
,
4299 &rref
->u
.c
.component
->ts
))
4301 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4302 &rref
->u
.c
.component
->ts
))
4308 lsym_pointer
= lsym
->attr
.pointer
;
4309 lsym_target
= lsym
->attr
.target
;
4310 lsym_pointer
= lsym
->attr
.pointer
;
4311 lsym_target
= lsym
->attr
.target
;
4313 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
; rref
= rref
->next
)
4315 if (rref
->type
!= REF_COMPONENT
)
4318 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4319 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4321 if (symbols_could_alias (rref
->u
.c
.sym
, lsym
,
4322 lsym_pointer
, lsym_target
,
4323 rsym_pointer
, rsym_target
))
4326 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4327 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4329 if (gfc_compare_types (&lsym
->ts
, &rref
->u
.c
.component
->ts
))
4338 /* Resolve array data dependencies. Creates a temporary if required. */
4339 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
4343 gfc_conv_resolve_dependencies (gfc_loopinfo
* loop
, gfc_ss
* dest
,
4349 gfc_expr
*dest_expr
;
4354 loop
->temp_ss
= NULL
;
4355 dest_expr
= dest
->info
->expr
;
4357 for (ss
= rss
; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
4359 ss_expr
= ss
->info
->expr
;
4361 if (ss
->info
->type
!= GFC_SS_SECTION
)
4363 if (flag_realloc_lhs
4364 && dest_expr
!= ss_expr
4365 && gfc_is_reallocatable_lhs (dest_expr
)
4367 nDepend
= gfc_check_dependency (dest_expr
, ss_expr
, true);
4369 /* Check for cases like c(:)(1:2) = c(2)(2:3) */
4370 if (!nDepend
&& dest_expr
->rank
> 0
4371 && dest_expr
->ts
.type
== BT_CHARACTER
4372 && ss_expr
->expr_type
== EXPR_VARIABLE
)
4374 nDepend
= gfc_check_dependency (dest_expr
, ss_expr
, false);
4379 if (dest_expr
->symtree
->n
.sym
!= ss_expr
->symtree
->n
.sym
)
4381 if (gfc_could_be_alias (dest
, ss
)
4382 || gfc_are_equivalenced_arrays (dest_expr
, ss_expr
))
4390 lref
= dest_expr
->ref
;
4391 rref
= ss_expr
->ref
;
4393 nDepend
= gfc_dep_resolver (lref
, rref
, &loop
->reverse
[0]);
4398 for (i
= 0; i
< dest
->dimen
; i
++)
4399 for (j
= 0; j
< ss
->dimen
; j
++)
4401 && dest
->dim
[i
] == ss
->dim
[j
])
4403 /* If we don't access array elements in the same order,
4404 there is a dependency. */
4409 /* TODO : loop shifting. */
4412 /* Mark the dimensions for LOOP SHIFTING */
4413 for (n
= 0; n
< loop
->dimen
; n
++)
4415 int dim
= dest
->data
.info
.dim
[n
];
4417 if (lref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
4419 else if (! gfc_is_same_range (&lref
->u
.ar
,
4420 &rref
->u
.ar
, dim
, 0))
4424 /* Put all the dimensions with dependencies in the
4427 for (n
= 0; n
< loop
->dimen
; n
++)
4429 gcc_assert (loop
->order
[n
] == n
);
4431 loop
->order
[dim
++] = n
;
4433 for (n
= 0; n
< loop
->dimen
; n
++)
4436 loop
->order
[dim
++] = n
;
4439 gcc_assert (dim
== loop
->dimen
);
4450 tree base_type
= gfc_typenode_for_spec (&dest_expr
->ts
);
4451 if (GFC_ARRAY_TYPE_P (base_type
)
4452 || GFC_DESCRIPTOR_TYPE_P (base_type
))
4453 base_type
= gfc_get_element_type (base_type
);
4454 loop
->temp_ss
= gfc_get_temp_ss (base_type
, dest
->info
->string_length
,
4456 gfc_add_ss_to_loop (loop
, loop
->temp_ss
);
4459 loop
->temp_ss
= NULL
;
4463 /* Browse through each array's information from the scalarizer and set the loop
4464 bounds according to the "best" one (per dimension), i.e. the one which
4465 provides the most information (constant bounds, shape, etc.). */
4468 set_loop_bounds (gfc_loopinfo
*loop
)
4470 int n
, dim
, spec_dim
;
4471 gfc_array_info
*info
;
4472 gfc_array_info
*specinfo
;
4476 bool dynamic
[GFC_MAX_DIMENSIONS
];
4479 bool nonoptional_arr
;
4481 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
4483 loopspec
= loop
->specloop
;
4486 for (n
= 0; n
< loop
->dimen
; n
++)
4491 /* If there are both optional and nonoptional array arguments, scalarize
4492 over the nonoptional; otherwise, it does not matter as then all
4493 (optional) arrays have to be present per F2008, 125.2.12p3(6). */
4495 nonoptional_arr
= false;
4497 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4498 if (ss
->info
->type
!= GFC_SS_SCALAR
&& ss
->info
->type
!= GFC_SS_TEMP
4499 && ss
->info
->type
!= GFC_SS_REFERENCE
&& !ss
->info
->can_be_null_ref
)
4501 nonoptional_arr
= true;
4505 /* We use one SS term, and use that to determine the bounds of the
4506 loop for this dimension. We try to pick the simplest term. */
4507 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4509 gfc_ss_type ss_type
;
4511 ss_type
= ss
->info
->type
;
4512 if (ss_type
== GFC_SS_SCALAR
4513 || ss_type
== GFC_SS_TEMP
4514 || ss_type
== GFC_SS_REFERENCE
4515 || (ss
->info
->can_be_null_ref
&& nonoptional_arr
))
4518 info
= &ss
->info
->data
.array
;
4521 if (loopspec
[n
] != NULL
)
4523 specinfo
= &loopspec
[n
]->info
->data
.array
;
4524 spec_dim
= loopspec
[n
]->dim
[n
];
4528 /* Silence uninitialized warnings. */
4535 gcc_assert (info
->shape
[dim
]);
4536 /* The frontend has worked out the size for us. */
4539 || !integer_zerop (specinfo
->start
[spec_dim
]))
4540 /* Prefer zero-based descriptors if possible. */
4545 if (ss_type
== GFC_SS_CONSTRUCTOR
)
4547 gfc_constructor_base base
;
4548 /* An unknown size constructor will always be rank one.
4549 Higher rank constructors will either have known shape,
4550 or still be wrapped in a call to reshape. */
4551 gcc_assert (loop
->dimen
== 1);
4553 /* Always prefer to use the constructor bounds if the size
4554 can be determined at compile time. Prefer not to otherwise,
4555 since the general case involves realloc, and it's better to
4556 avoid that overhead if possible. */
4557 base
= ss
->info
->expr
->value
.constructor
;
4558 dynamic
[n
] = gfc_get_array_constructor_size (&i
, base
);
4559 if (!dynamic
[n
] || !loopspec
[n
])
4564 /* Avoid using an allocatable lhs in an assignment, since
4565 there might be a reallocation coming. */
4566 if (loopspec
[n
] && ss
->is_alloc_lhs
)
4571 /* Criteria for choosing a loop specifier (most important first):
4572 doesn't need realloc
4578 else if (loopspec
[n
]->info
->type
== GFC_SS_CONSTRUCTOR
&& dynamic
[n
])
4580 else if (integer_onep (info
->stride
[dim
])
4581 && !integer_onep (specinfo
->stride
[spec_dim
]))
4583 else if (INTEGER_CST_P (info
->stride
[dim
])
4584 && !INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
4586 else if (INTEGER_CST_P (info
->start
[dim
])
4587 && !INTEGER_CST_P (specinfo
->start
[spec_dim
])
4588 && integer_onep (info
->stride
[dim
])
4589 == integer_onep (specinfo
->stride
[spec_dim
])
4590 && INTEGER_CST_P (info
->stride
[dim
])
4591 == INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
4593 /* We don't work out the upper bound.
4594 else if (INTEGER_CST_P (info->finish[n])
4595 && ! INTEGER_CST_P (specinfo->finish[n]))
4596 loopspec[n] = ss; */
4599 /* We should have found the scalarization loop specifier. If not,
4601 gcc_assert (loopspec
[n
]);
4603 info
= &loopspec
[n
]->info
->data
.array
;
4604 dim
= loopspec
[n
]->dim
[n
];
4606 /* Set the extents of this range. */
4607 cshape
= info
->shape
;
4608 if (cshape
&& INTEGER_CST_P (info
->start
[dim
])
4609 && INTEGER_CST_P (info
->stride
[dim
]))
4611 loop
->from
[n
] = info
->start
[dim
];
4612 mpz_set (i
, cshape
[get_array_ref_dim_for_loop_dim (loopspec
[n
], n
)]);
4613 mpz_sub_ui (i
, i
, 1);
4614 /* To = from + (size - 1) * stride. */
4615 tmp
= gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
4616 if (!integer_onep (info
->stride
[dim
]))
4617 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
4618 gfc_array_index_type
, tmp
,
4620 loop
->to
[n
] = fold_build2_loc (input_location
, PLUS_EXPR
,
4621 gfc_array_index_type
,
4622 loop
->from
[n
], tmp
);
4626 loop
->from
[n
] = info
->start
[dim
];
4627 switch (loopspec
[n
]->info
->type
)
4629 case GFC_SS_CONSTRUCTOR
:
4630 /* The upper bound is calculated when we expand the
4632 gcc_assert (loop
->to
[n
] == NULL_TREE
);
4635 case GFC_SS_SECTION
:
4636 /* Use the end expression if it exists and is not constant,
4637 so that it is only evaluated once. */
4638 loop
->to
[n
] = info
->end
[dim
];
4641 case GFC_SS_FUNCTION
:
4642 /* The loop bound will be set when we generate the call. */
4643 gcc_assert (loop
->to
[n
] == NULL_TREE
);
4646 case GFC_SS_INTRINSIC
:
4648 gfc_expr
*expr
= loopspec
[n
]->info
->expr
;
4650 /* The {l,u}bound of an assumed rank. */
4651 gcc_assert ((expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
4652 || expr
->value
.function
.isym
->id
== GFC_ISYM_UBOUND
)
4653 && expr
->value
.function
.actual
->next
->expr
== NULL
4654 && expr
->value
.function
.actual
->expr
->rank
== -1);
4656 loop
->to
[n
] = info
->end
[dim
];
4665 /* Transform everything so we have a simple incrementing variable. */
4666 if (integer_onep (info
->stride
[dim
]))
4667 info
->delta
[dim
] = gfc_index_zero_node
;
4670 /* Set the delta for this section. */
4671 info
->delta
[dim
] = gfc_evaluate_now (loop
->from
[n
], &outer_loop
->pre
);
4672 /* Number of iterations is (end - start + step) / step.
4673 with start = 0, this simplifies to
4675 for (i = 0; i<=last; i++){...}; */
4676 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4677 gfc_array_index_type
, loop
->to
[n
],
4679 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
4680 gfc_array_index_type
, tmp
, info
->stride
[dim
]);
4681 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
4682 tmp
, build_int_cst (gfc_array_index_type
, -1));
4683 loop
->to
[n
] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
4684 /* Make the loop variable start at 0. */
4685 loop
->from
[n
] = gfc_index_zero_node
;
4690 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4691 set_loop_bounds (loop
);
4695 /* Initialize the scalarization loop. Creates the loop variables. Determines
4696 the range of the loop variables. Creates a temporary if required.
4697 Also generates code for scalar expressions which have been
4698 moved outside the loop. */
4701 gfc_conv_loop_setup (gfc_loopinfo
* loop
, locus
* where
)
4706 set_loop_bounds (loop
);
4708 /* Add all the scalar code that can be taken out of the loops.
4709 This may include calculating the loop bounds, so do it before
4710 allocating the temporary. */
4711 gfc_add_loop_ss_code (loop
, loop
->ss
, false, where
);
4713 tmp_ss
= loop
->temp_ss
;
4714 /* If we want a temporary then create it. */
4717 gfc_ss_info
*tmp_ss_info
;
4719 tmp_ss_info
= tmp_ss
->info
;
4720 gcc_assert (tmp_ss_info
->type
== GFC_SS_TEMP
);
4721 gcc_assert (loop
->parent
== NULL
);
4723 /* Make absolutely sure that this is a complete type. */
4724 if (tmp_ss_info
->string_length
)
4725 tmp_ss_info
->data
.temp
.type
4726 = gfc_get_character_type_len_for_eltype
4727 (TREE_TYPE (tmp_ss_info
->data
.temp
.type
),
4728 tmp_ss_info
->string_length
);
4730 tmp
= tmp_ss_info
->data
.temp
.type
;
4731 memset (&tmp_ss_info
->data
.array
, 0, sizeof (gfc_array_info
));
4732 tmp_ss_info
->type
= GFC_SS_SECTION
;
4734 gcc_assert (tmp_ss
->dimen
!= 0);
4736 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, tmp_ss
, tmp
,
4737 NULL_TREE
, false, true, false, where
);
4740 /* For array parameters we don't have loop variables, so don't calculate the
4742 if (!loop
->array_parameter
)
4743 gfc_set_delta (loop
);
4747 /* Calculates how to transform from loop variables to array indices for each
4748 array: once loop bounds are chosen, sets the difference (DELTA field) between
4749 loop bounds and array reference bounds, for each array info. */
4752 gfc_set_delta (gfc_loopinfo
*loop
)
4754 gfc_ss
*ss
, **loopspec
;
4755 gfc_array_info
*info
;
4759 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
4761 loopspec
= loop
->specloop
;
4763 /* Calculate the translation from loop variables to array indices. */
4764 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4766 gfc_ss_type ss_type
;
4768 ss_type
= ss
->info
->type
;
4769 if (ss_type
!= GFC_SS_SECTION
4770 && ss_type
!= GFC_SS_COMPONENT
4771 && ss_type
!= GFC_SS_CONSTRUCTOR
)
4774 info
= &ss
->info
->data
.array
;
4776 for (n
= 0; n
< ss
->dimen
; n
++)
4778 /* If we are specifying the range the delta is already set. */
4779 if (loopspec
[n
] != ss
)
4783 /* Calculate the offset relative to the loop variable.
4784 First multiply by the stride. */
4785 tmp
= loop
->from
[n
];
4786 if (!integer_onep (info
->stride
[dim
]))
4787 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
4788 gfc_array_index_type
,
4789 tmp
, info
->stride
[dim
]);
4791 /* Then subtract this from our starting value. */
4792 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4793 gfc_array_index_type
,
4794 info
->start
[dim
], tmp
);
4796 info
->delta
[dim
] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
4801 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4802 gfc_set_delta (loop
);
4806 /* Calculate the size of a given array dimension from the bounds. This
4807 is simply (ubound - lbound + 1) if this expression is positive
4808 or 0 if it is negative (pick either one if it is zero). Optionally
4809 (if or_expr is present) OR the (expression != 0) condition to it. */
4812 gfc_conv_array_extent_dim (tree lbound
, tree ubound
, tree
* or_expr
)
4817 /* Calculate (ubound - lbound + 1). */
4818 res
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4820 res
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
, res
,
4821 gfc_index_one_node
);
4823 /* Check whether the size for this dimension is negative. */
4824 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, res
,
4825 gfc_index_zero_node
);
4826 res
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
, cond
,
4827 gfc_index_zero_node
, res
);
4829 /* Build OR expression. */
4831 *or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
4832 boolean_type_node
, *or_expr
, cond
);
4838 /* For an array descriptor, get the total number of elements. This is just
4839 the product of the extents along from_dim to to_dim. */
4842 gfc_conv_descriptor_size_1 (tree desc
, int from_dim
, int to_dim
)
4847 res
= gfc_index_one_node
;
4849 for (dim
= from_dim
; dim
< to_dim
; ++dim
)
4855 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]);
4856 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]);
4858 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
4859 res
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4867 /* Full size of an array. */
4870 gfc_conv_descriptor_size (tree desc
, int rank
)
4872 return gfc_conv_descriptor_size_1 (desc
, 0, rank
);
4876 /* Size of a coarray for all dimensions but the last. */
4879 gfc_conv_descriptor_cosize (tree desc
, int rank
, int corank
)
4881 return gfc_conv_descriptor_size_1 (desc
, rank
, rank
+ corank
- 1);
4885 /* Fills in an array descriptor, and returns the size of the array.
4886 The size will be a simple_val, ie a variable or a constant. Also
4887 calculates the offset of the base. The pointer argument overflow,
4888 which should be of integer type, will increase in value if overflow
4889 occurs during the size calculation. Returns the size of the array.
4893 for (n = 0; n < rank; n++)
4895 a.lbound[n] = specified_lower_bound;
4896 offset = offset + a.lbond[n] * stride;
4898 a.ubound[n] = specified_upper_bound;
4899 a.stride[n] = stride;
4900 size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
4901 overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
4902 stride = stride * size;
4904 for (n = rank; n < rank+corank; n++)
4905 (Set lcobound/ucobound as above.)
4906 element_size = sizeof (array element);
4909 stride = (size_t) stride;
4910 overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
4911 stride = stride * element_size;
4917 gfc_array_init_size (tree descriptor
, int rank
, int corank
, tree
* poffset
,
4918 gfc_expr
** lower
, gfc_expr
** upper
, stmtblock_t
* pblock
,
4919 stmtblock_t
* descriptor_block
, tree
* overflow
,
4920 tree expr3_elem_size
, tree
*nelems
, gfc_expr
*expr3
,
4934 stmtblock_t thenblock
;
4935 stmtblock_t elseblock
;
4940 type
= TREE_TYPE (descriptor
);
4942 stride
= gfc_index_one_node
;
4943 offset
= gfc_index_zero_node
;
4945 /* Set the dtype. */
4946 tmp
= gfc_conv_descriptor_dtype (descriptor
);
4947 gfc_add_modify (descriptor_block
, tmp
, gfc_get_dtype (TREE_TYPE (descriptor
)));
4949 or_expr
= boolean_false_node
;
4951 for (n
= 0; n
< rank
; n
++)
4956 /* We have 3 possibilities for determining the size of the array:
4957 lower == NULL => lbound = 1, ubound = upper[n]
4958 upper[n] = NULL => lbound = 1, ubound = lower[n]
4959 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
4962 /* Set lower bound. */
4963 gfc_init_se (&se
, NULL
);
4965 se
.expr
= gfc_index_one_node
;
4968 gcc_assert (lower
[n
]);
4971 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
4972 gfc_add_block_to_block (pblock
, &se
.pre
);
4976 se
.expr
= gfc_index_one_node
;
4980 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
4981 gfc_rank_cst
[n
], se
.expr
);
4982 conv_lbound
= se
.expr
;
4984 /* Work out the offset for this component. */
4985 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4987 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
4988 gfc_array_index_type
, offset
, tmp
);
4990 /* Set upper bound. */
4991 gfc_init_se (&se
, NULL
);
4992 gcc_assert (ubound
);
4993 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
4994 gfc_add_block_to_block (pblock
, &se
.pre
);
4996 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
4997 gfc_rank_cst
[n
], se
.expr
);
4998 conv_ubound
= se
.expr
;
5000 /* Store the stride. */
5001 gfc_conv_descriptor_stride_set (descriptor_block
, descriptor
,
5002 gfc_rank_cst
[n
], stride
);
5004 /* Calculate size and check whether extent is negative. */
5005 size
= gfc_conv_array_extent_dim (conv_lbound
, conv_ubound
, &or_expr
);
5006 size
= gfc_evaluate_now (size
, pblock
);
5008 /* Check whether multiplying the stride by the number of
5009 elements in this dimension would overflow. We must also check
5010 whether the current dimension has zero size in order to avoid
5013 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
5014 gfc_array_index_type
,
5015 fold_convert (gfc_array_index_type
,
5016 TYPE_MAX_VALUE (gfc_array_index_type
)),
5018 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
5019 boolean_type_node
, tmp
, stride
),
5020 PRED_FORTRAN_OVERFLOW
);
5021 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5022 integer_one_node
, integer_zero_node
);
5023 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
5024 boolean_type_node
, size
,
5025 gfc_index_zero_node
),
5026 PRED_FORTRAN_SIZE_ZERO
);
5027 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5028 integer_zero_node
, tmp
);
5029 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
5031 *overflow
= gfc_evaluate_now (tmp
, pblock
);
5033 /* Multiply the stride by the number of elements in this dimension. */
5034 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
5035 gfc_array_index_type
, stride
, size
);
5036 stride
= gfc_evaluate_now (stride
, pblock
);
5039 for (n
= rank
; n
< rank
+ corank
; n
++)
5043 /* Set lower bound. */
5044 gfc_init_se (&se
, NULL
);
5045 if (lower
== NULL
|| lower
[n
] == NULL
)
5047 gcc_assert (n
== rank
+ corank
- 1);
5048 se
.expr
= gfc_index_one_node
;
5052 if (ubound
|| n
== rank
+ corank
- 1)
5054 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
5055 gfc_add_block_to_block (pblock
, &se
.pre
);
5059 se
.expr
= gfc_index_one_node
;
5063 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
5064 gfc_rank_cst
[n
], se
.expr
);
5066 if (n
< rank
+ corank
- 1)
5068 gfc_init_se (&se
, NULL
);
5069 gcc_assert (ubound
);
5070 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
5071 gfc_add_block_to_block (pblock
, &se
.pre
);
5072 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
5073 gfc_rank_cst
[n
], se
.expr
);
5077 /* The stride is the number of elements in the array, so multiply by the
5078 size of an element to get the total size. Obviously, if there is a
5079 SOURCE expression (expr3) we must use its element size. */
5080 if (expr3_elem_size
!= NULL_TREE
)
5081 tmp
= expr3_elem_size
;
5082 else if (expr3
!= NULL
)
5084 if (expr3
->ts
.type
== BT_CLASS
)
5087 gfc_expr
*sz
= gfc_copy_expr (expr3
);
5088 gfc_add_vptr_component (sz
);
5089 gfc_add_size_component (sz
);
5090 gfc_init_se (&se_sz
, NULL
);
5091 gfc_conv_expr (&se_sz
, sz
);
5097 tmp
= gfc_typenode_for_spec (&expr3
->ts
);
5098 tmp
= TYPE_SIZE_UNIT (tmp
);
5101 else if (ts
->type
!= BT_UNKNOWN
&& ts
->type
!= BT_CHARACTER
)
5102 /* FIXME: Properly handle characters. See PR 57456. */
5103 tmp
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (ts
));
5105 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
5107 /* Convert to size_t. */
5108 element_size
= fold_convert (size_type_node
, tmp
);
5111 return element_size
;
5113 *nelems
= gfc_evaluate_now (stride
, pblock
);
5114 stride
= fold_convert (size_type_node
, stride
);
5116 /* First check for overflow. Since an array of type character can
5117 have zero element_size, we must check for that before
5119 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
5121 TYPE_MAX_VALUE (size_type_node
), element_size
);
5122 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
5123 boolean_type_node
, tmp
, stride
),
5124 PRED_FORTRAN_OVERFLOW
);
5125 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5126 integer_one_node
, integer_zero_node
);
5127 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
5128 boolean_type_node
, element_size
,
5129 build_int_cst (size_type_node
, 0)),
5130 PRED_FORTRAN_SIZE_ZERO
);
5131 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5132 integer_zero_node
, tmp
);
5133 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
5135 *overflow
= gfc_evaluate_now (tmp
, pblock
);
5137 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5138 stride
, element_size
);
5140 if (poffset
!= NULL
)
5142 offset
= gfc_evaluate_now (offset
, pblock
);
5146 if (integer_zerop (or_expr
))
5148 if (integer_onep (or_expr
))
5149 return build_int_cst (size_type_node
, 0);
5151 var
= gfc_create_var (TREE_TYPE (size
), "size");
5152 gfc_start_block (&thenblock
);
5153 gfc_add_modify (&thenblock
, var
, build_int_cst (size_type_node
, 0));
5154 thencase
= gfc_finish_block (&thenblock
);
5156 gfc_start_block (&elseblock
);
5157 gfc_add_modify (&elseblock
, var
, size
);
5158 elsecase
= gfc_finish_block (&elseblock
);
5160 tmp
= gfc_evaluate_now (or_expr
, pblock
);
5161 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
5162 gfc_add_expr_to_block (pblock
, tmp
);
5168 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
5169 the work for an ALLOCATE statement. */
5173 gfc_array_allocate (gfc_se
* se
, gfc_expr
* expr
, tree status
, tree errmsg
,
5174 tree errlen
, tree label_finish
, tree expr3_elem_size
,
5175 tree
*nelems
, gfc_expr
*expr3
, gfc_typespec
*ts
)
5179 tree offset
= NULL_TREE
;
5180 tree token
= NULL_TREE
;
5183 tree error
= NULL_TREE
;
5184 tree overflow
; /* Boolean storing whether size calculation overflows. */
5185 tree var_overflow
= NULL_TREE
;
5187 tree set_descriptor
;
5188 stmtblock_t set_descriptor_block
;
5189 stmtblock_t elseblock
;
5192 gfc_ref
*ref
, *prev_ref
= NULL
;
5193 bool allocatable
, coarray
, dimension
;
5197 /* Find the last reference in the chain. */
5198 while (ref
&& ref
->next
!= NULL
)
5200 gcc_assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
5201 || (ref
->u
.ar
.dimen
== 0 && ref
->u
.ar
.codimen
> 0));
5206 if (ref
== NULL
|| ref
->type
!= REF_ARRAY
)
5211 allocatable
= expr
->symtree
->n
.sym
->attr
.allocatable
;
5212 coarray
= expr
->symtree
->n
.sym
->attr
.codimension
;
5213 dimension
= expr
->symtree
->n
.sym
->attr
.dimension
;
5217 allocatable
= prev_ref
->u
.c
.component
->attr
.allocatable
;
5218 coarray
= prev_ref
->u
.c
.component
->attr
.codimension
;
5219 dimension
= prev_ref
->u
.c
.component
->attr
.dimension
;
5223 gcc_assert (coarray
);
5225 /* Figure out the size of the array. */
5226 switch (ref
->u
.ar
.type
)
5232 upper
= ref
->u
.ar
.start
;
5238 lower
= ref
->u
.ar
.start
;
5239 upper
= ref
->u
.ar
.end
;
5243 gcc_assert (ref
->u
.ar
.as
->type
== AS_EXPLICIT
);
5245 lower
= ref
->u
.ar
.as
->lower
;
5246 upper
= ref
->u
.ar
.as
->upper
;
5254 overflow
= integer_zero_node
;
5256 gfc_init_block (&set_descriptor_block
);
5257 size
= gfc_array_init_size (se
->expr
, ref
->u
.ar
.as
->rank
,
5258 ref
->u
.ar
.as
->corank
, &offset
, lower
, upper
,
5259 &se
->pre
, &set_descriptor_block
, &overflow
,
5260 expr3_elem_size
, nelems
, expr3
, ts
);
5264 var_overflow
= gfc_create_var (integer_type_node
, "overflow");
5265 gfc_add_modify (&se
->pre
, var_overflow
, overflow
);
5267 if (status
== NULL_TREE
)
5269 /* Generate the block of code handling overflow. */
5270 msg
= gfc_build_addr_expr (pchar_type_node
,
5271 gfc_build_localized_cstring_const
5272 ("Integer overflow when calculating the amount of "
5273 "memory to allocate"));
5274 error
= build_call_expr_loc (input_location
,
5275 gfor_fndecl_runtime_error
, 1, msg
);
5279 tree status_type
= TREE_TYPE (status
);
5280 stmtblock_t set_status_block
;
5282 gfc_start_block (&set_status_block
);
5283 gfc_add_modify (&set_status_block
, status
,
5284 build_int_cst (status_type
, LIBERROR_ALLOCATION
));
5285 error
= gfc_finish_block (&set_status_block
);
5289 gfc_start_block (&elseblock
);
5291 /* Allocate memory to store the data. */
5292 if (POINTER_TYPE_P (TREE_TYPE (se
->expr
)))
5293 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
5295 pointer
= gfc_conv_descriptor_data_get (se
->expr
);
5296 STRIP_NOPS (pointer
);
5298 if (coarray
&& flag_coarray
== GFC_FCOARRAY_LIB
)
5299 token
= gfc_build_addr_expr (NULL_TREE
,
5300 gfc_conv_descriptor_token (se
->expr
));
5302 /* The allocatable variant takes the old pointer as first argument. */
5304 gfc_allocate_allocatable (&elseblock
, pointer
, size
, token
,
5305 status
, errmsg
, errlen
, label_finish
, expr
);
5307 gfc_allocate_using_malloc (&elseblock
, pointer
, size
, status
);
5311 cond
= gfc_unlikely (fold_build2_loc (input_location
, NE_EXPR
,
5312 boolean_type_node
, var_overflow
, integer_zero_node
),
5313 PRED_FORTRAN_OVERFLOW
);
5314 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
5315 error
, gfc_finish_block (&elseblock
));
5318 tmp
= gfc_finish_block (&elseblock
);
5320 gfc_add_expr_to_block (&se
->pre
, tmp
);
5322 /* Update the array descriptors. */
5324 gfc_conv_descriptor_offset_set (&set_descriptor_block
, se
->expr
, offset
);
5326 set_descriptor
= gfc_finish_block (&set_descriptor_block
);
5327 if (status
!= NULL_TREE
)
5329 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
5330 boolean_type_node
, status
,
5331 build_int_cst (TREE_TYPE (status
), 0));
5332 gfc_add_expr_to_block (&se
->pre
,
5333 fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5334 gfc_likely (cond
, PRED_FORTRAN_FAIL_ALLOC
),
5336 build_empty_stmt (input_location
)));
5339 gfc_add_expr_to_block (&se
->pre
, set_descriptor
);
5341 if ((expr
->ts
.type
== BT_DERIVED
)
5342 && expr
->ts
.u
.derived
->attr
.alloc_comp
)
5344 tmp
= gfc_nullify_alloc_comp (expr
->ts
.u
.derived
, se
->expr
,
5345 ref
->u
.ar
.as
->rank
);
5346 gfc_add_expr_to_block (&se
->pre
, tmp
);
5353 /* Deallocate an array variable. Also used when an allocated variable goes
5358 gfc_array_deallocate (tree descriptor
, tree pstat
, tree errmsg
, tree errlen
,
5359 tree label_finish
, gfc_expr
* expr
)
5364 bool coarray
= gfc_is_coarray (expr
);
5366 gfc_start_block (&block
);
5368 /* Get a pointer to the data. */
5369 var
= gfc_conv_descriptor_data_get (descriptor
);
5372 /* Parameter is the address of the data component. */
5373 tmp
= gfc_deallocate_with_status (coarray
? descriptor
: var
, pstat
, errmsg
,
5374 errlen
, label_finish
, false, expr
, coarray
);
5375 gfc_add_expr_to_block (&block
, tmp
);
5377 /* Zero the data pointer; only for coarrays an error can occur and then
5378 the allocation status may not be changed. */
5379 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
5380 var
, build_int_cst (TREE_TYPE (var
), 0));
5381 if (pstat
!= NULL_TREE
&& coarray
&& flag_coarray
== GFC_FCOARRAY_LIB
)
5384 tree stat
= build_fold_indirect_ref_loc (input_location
, pstat
);
5386 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5387 stat
, build_int_cst (TREE_TYPE (stat
), 0));
5388 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5389 cond
, tmp
, build_empty_stmt (input_location
));
5392 gfc_add_expr_to_block (&block
, tmp
);
5394 return gfc_finish_block (&block
);
5398 /* Create an array constructor from an initialization expression.
5399 We assume the frontend already did any expansions and conversions. */
5402 gfc_conv_array_initializer (tree type
, gfc_expr
* expr
)
5409 vec
<constructor_elt
, va_gc
> *v
= NULL
;
5411 if (expr
->expr_type
== EXPR_VARIABLE
5412 && expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
5413 && expr
->symtree
->n
.sym
->value
)
5414 expr
= expr
->symtree
->n
.sym
->value
;
5416 switch (expr
->expr_type
)
5419 case EXPR_STRUCTURE
:
5420 /* A single scalar or derived type value. Create an array with all
5421 elements equal to that value. */
5422 gfc_init_se (&se
, NULL
);
5424 if (expr
->expr_type
== EXPR_CONSTANT
)
5425 gfc_conv_constant (&se
, expr
);
5427 gfc_conv_structure (&se
, expr
, 1);
5429 wtmp
= wi::to_offset (TYPE_MAX_VALUE (TYPE_DOMAIN (type
))) + 1;
5430 /* This will probably eat buckets of memory for large arrays. */
5433 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
, se
.expr
);
5439 /* Create a vector of all the elements. */
5440 for (c
= gfc_constructor_first (expr
->value
.constructor
);
5441 c
; c
= gfc_constructor_next (c
))
5445 /* Problems occur when we get something like
5446 integer :: a(lots) = (/(i, i=1, lots)/) */
5447 gfc_fatal_error ("The number of elements in the array "
5448 "constructor at %L requires an increase of "
5449 "the allowed %d upper limit. See "
5450 "%<-fmax-array-constructor%> option",
5451 &expr
->where
, flag_max_array_constructor
);
5454 if (mpz_cmp_si (c
->offset
, 0) != 0)
5455 index
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
5459 if (mpz_cmp_si (c
->repeat
, 1) > 0)
5465 mpz_add (maxval
, c
->offset
, c
->repeat
);
5466 mpz_sub_ui (maxval
, maxval
, 1);
5467 tmp2
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
5468 if (mpz_cmp_si (c
->offset
, 0) != 0)
5470 mpz_add_ui (maxval
, c
->offset
, 1);
5471 tmp1
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
5474 tmp1
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
5476 range
= fold_build2 (RANGE_EXPR
, gfc_array_index_type
, tmp1
, tmp2
);
5482 gfc_init_se (&se
, NULL
);
5483 switch (c
->expr
->expr_type
)
5486 gfc_conv_constant (&se
, c
->expr
);
5489 case EXPR_STRUCTURE
:
5490 gfc_conv_structure (&se
, c
->expr
, 1);
5494 /* Catch those occasional beasts that do not simplify
5495 for one reason or another, assuming that if they are
5496 standard defying the frontend will catch them. */
5497 gfc_conv_expr (&se
, c
->expr
);
5501 if (range
== NULL_TREE
)
5502 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
5505 if (index
!= NULL_TREE
)
5506 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
5507 CONSTRUCTOR_APPEND_ELT (v
, range
, se
.expr
);
5513 return gfc_build_null_descriptor (type
);
5519 /* Create a constructor from the list of elements. */
5520 tmp
= build_constructor (type
, v
);
5521 TREE_CONSTANT (tmp
) = 1;
5526 /* Generate code to evaluate non-constant coarray cobounds. */
5529 gfc_trans_array_cobounds (tree type
, stmtblock_t
* pblock
,
5530 const gfc_symbol
*sym
)
5540 for (dim
= as
->rank
; dim
< as
->rank
+ as
->corank
; dim
++)
5542 /* Evaluate non-constant array bound expressions. */
5543 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
5544 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
5546 gfc_init_se (&se
, NULL
);
5547 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
5548 gfc_add_block_to_block (pblock
, &se
.pre
);
5549 gfc_add_modify (pblock
, lbound
, se
.expr
);
5551 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
5552 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
5554 gfc_init_se (&se
, NULL
);
5555 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
5556 gfc_add_block_to_block (pblock
, &se
.pre
);
5557 gfc_add_modify (pblock
, ubound
, se
.expr
);
5563 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
5564 returns the size (in elements) of the array. */
5567 gfc_trans_array_bounds (tree type
, gfc_symbol
* sym
, tree
* poffset
,
5568 stmtblock_t
* pblock
)
5583 size
= gfc_index_one_node
;
5584 offset
= gfc_index_zero_node
;
5585 for (dim
= 0; dim
< as
->rank
; dim
++)
5587 /* Evaluate non-constant array bound expressions. */
5588 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
5589 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
5591 gfc_init_se (&se
, NULL
);
5592 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
5593 gfc_add_block_to_block (pblock
, &se
.pre
);
5594 gfc_add_modify (pblock
, lbound
, se
.expr
);
5596 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
5597 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
5599 gfc_init_se (&se
, NULL
);
5600 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
5601 gfc_add_block_to_block (pblock
, &se
.pre
);
5602 gfc_add_modify (pblock
, ubound
, se
.expr
);
5604 /* The offset of this dimension. offset = offset - lbound * stride. */
5605 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5607 offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5610 /* The size of this dimension, and the stride of the next. */
5611 if (dim
+ 1 < as
->rank
)
5612 stride
= GFC_TYPE_ARRAY_STRIDE (type
, dim
+ 1);
5614 stride
= GFC_TYPE_ARRAY_SIZE (type
);
5616 if (ubound
!= NULL_TREE
&& !(stride
&& INTEGER_CST_P (stride
)))
5618 /* Calculate stride = size * (ubound + 1 - lbound). */
5619 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5620 gfc_array_index_type
,
5621 gfc_index_one_node
, lbound
);
5622 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5623 gfc_array_index_type
, ubound
, tmp
);
5624 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5625 gfc_array_index_type
, size
, tmp
);
5627 gfc_add_modify (pblock
, stride
, tmp
);
5629 stride
= gfc_evaluate_now (tmp
, pblock
);
5631 /* Make sure that negative size arrays are translated
5632 to being zero size. */
5633 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
5634 stride
, gfc_index_zero_node
);
5635 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5636 gfc_array_index_type
, tmp
,
5637 stride
, gfc_index_zero_node
);
5638 gfc_add_modify (pblock
, stride
, tmp
);
5644 gfc_trans_array_cobounds (type
, pblock
, sym
);
5645 gfc_trans_vla_type_sizes (sym
, pblock
);
5652 /* Generate code to initialize/allocate an array variable. */
5655 gfc_trans_auto_array_allocation (tree decl
, gfc_symbol
* sym
,
5656 gfc_wrapped_block
* block
)
5660 tree tmp
= NULL_TREE
;
5667 gcc_assert (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
));
5669 /* Do nothing for USEd variables. */
5670 if (sym
->attr
.use_assoc
)
5673 type
= TREE_TYPE (decl
);
5674 gcc_assert (GFC_ARRAY_TYPE_P (type
));
5675 onstack
= TREE_CODE (type
) != POINTER_TYPE
;
5677 gfc_init_block (&init
);
5679 /* Evaluate character string length. */
5680 if (sym
->ts
.type
== BT_CHARACTER
5681 && onstack
&& !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
5683 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
5685 gfc_trans_vla_type_sizes (sym
, &init
);
5687 /* Emit a DECL_EXPR for this variable, which will cause the
5688 gimplifier to allocate storage, and all that good stuff. */
5689 tmp
= fold_build1_loc (input_location
, DECL_EXPR
, TREE_TYPE (decl
), decl
);
5690 gfc_add_expr_to_block (&init
, tmp
);
5695 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
5699 type
= TREE_TYPE (type
);
5701 gcc_assert (!sym
->attr
.use_assoc
);
5702 gcc_assert (!TREE_STATIC (decl
));
5703 gcc_assert (!sym
->module
);
5705 if (sym
->ts
.type
== BT_CHARACTER
5706 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
5707 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
5709 size
= gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
5711 /* Don't actually allocate space for Cray Pointees. */
5712 if (sym
->attr
.cray_pointee
)
5714 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
5715 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
5717 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
5721 if (flag_stack_arrays
)
5723 gcc_assert (TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
);
5724 space
= build_decl (sym
->declared_at
.lb
->location
,
5725 VAR_DECL
, create_tmp_var_name ("A"),
5726 TREE_TYPE (TREE_TYPE (decl
)));
5727 gfc_trans_vla_type_sizes (sym
, &init
);
5731 /* The size is the number of elements in the array, so multiply by the
5732 size of an element to get the total size. */
5733 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
5734 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5735 size
, fold_convert (gfc_array_index_type
, tmp
));
5737 /* Allocate memory to hold the data. */
5738 tmp
= gfc_call_malloc (&init
, TREE_TYPE (decl
), size
);
5739 gfc_add_modify (&init
, decl
, tmp
);
5741 /* Free the temporary. */
5742 tmp
= gfc_call_free (convert (pvoid_type_node
, decl
));
5746 /* Set offset of the array. */
5747 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
5748 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
5750 /* Automatic arrays should not have initializers. */
5751 gcc_assert (!sym
->value
);
5753 inittree
= gfc_finish_block (&init
);
5760 /* Don't create new scope, emit the DECL_EXPR in exactly the scope
5761 where also space is located. */
5762 gfc_init_block (&init
);
5763 tmp
= fold_build1_loc (input_location
, DECL_EXPR
,
5764 TREE_TYPE (space
), space
);
5765 gfc_add_expr_to_block (&init
, tmp
);
5766 addr
= fold_build1_loc (sym
->declared_at
.lb
->location
,
5767 ADDR_EXPR
, TREE_TYPE (decl
), space
);
5768 gfc_add_modify (&init
, decl
, addr
);
5769 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
5772 gfc_add_init_cleanup (block
, inittree
, tmp
);
5776 /* Generate entry and exit code for g77 calling convention arrays. */
5779 gfc_trans_g77_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
5789 gfc_save_backend_locus (&loc
);
5790 gfc_set_backend_locus (&sym
->declared_at
);
5792 /* Descriptor type. */
5793 parm
= sym
->backend_decl
;
5794 type
= TREE_TYPE (parm
);
5795 gcc_assert (GFC_ARRAY_TYPE_P (type
));
5797 gfc_start_block (&init
);
5799 if (sym
->ts
.type
== BT_CHARACTER
5800 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
5801 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
5803 /* Evaluate the bounds of the array. */
5804 gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
5806 /* Set the offset. */
5807 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
5808 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
5810 /* Set the pointer itself if we aren't using the parameter directly. */
5811 if (TREE_CODE (parm
) != PARM_DECL
)
5813 tmp
= convert (TREE_TYPE (parm
), GFC_DECL_SAVED_DESCRIPTOR (parm
));
5814 gfc_add_modify (&init
, parm
, tmp
);
5816 stmt
= gfc_finish_block (&init
);
5818 gfc_restore_backend_locus (&loc
);
5820 /* Add the initialization code to the start of the function. */
5822 if (sym
->attr
.optional
|| sym
->attr
.not_always_present
)
5824 tmp
= gfc_conv_expr_present (sym
);
5825 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
5828 gfc_add_init_cleanup (block
, stmt
, NULL_TREE
);
5832 /* Modify the descriptor of an array parameter so that it has the
5833 correct lower bound. Also move the upper bound accordingly.
5834 If the array is not packed, it will be copied into a temporary.
5835 For each dimension we set the new lower and upper bounds. Then we copy the
5836 stride and calculate the offset for this dimension. We also work out
5837 what the stride of a packed array would be, and see it the two match.
5838 If the array need repacking, we set the stride to the values we just
5839 calculated, recalculate the offset and copy the array data.
5840 Code is also added to copy the data back at the end of the function.
5844 gfc_trans_dummy_array_bias (gfc_symbol
* sym
, tree tmpdesc
,
5845 gfc_wrapped_block
* block
)
5852 tree stmtInit
, stmtCleanup
;
5859 tree stride
, stride2
;
5869 /* Do nothing for pointer and allocatable arrays. */
5870 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
5873 if (sym
->attr
.dummy
&& gfc_is_nodesc_array (sym
))
5875 gfc_trans_g77_array (sym
, block
);
5879 gfc_save_backend_locus (&loc
);
5880 gfc_set_backend_locus (&sym
->declared_at
);
5882 /* Descriptor type. */
5883 type
= TREE_TYPE (tmpdesc
);
5884 gcc_assert (GFC_ARRAY_TYPE_P (type
));
5885 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
5886 dumdesc
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
5887 gfc_start_block (&init
);
5889 if (sym
->ts
.type
== BT_CHARACTER
5890 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
5891 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
5893 checkparm
= (sym
->as
->type
== AS_EXPLICIT
5894 && (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
));
5896 no_repack
= !(GFC_DECL_PACKED_ARRAY (tmpdesc
)
5897 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
));
5899 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
))
5901 /* For non-constant shape arrays we only check if the first dimension
5902 is contiguous. Repacking higher dimensions wouldn't gain us
5903 anything as we still don't know the array stride. */
5904 partial
= gfc_create_var (boolean_type_node
, "partial");
5905 TREE_USED (partial
) = 1;
5906 tmp
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
5907 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, tmp
,
5908 gfc_index_one_node
);
5909 gfc_add_modify (&init
, partial
, tmp
);
5912 partial
= NULL_TREE
;
5914 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
5915 here, however I think it does the right thing. */
5918 /* Set the first stride. */
5919 stride
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
5920 stride
= gfc_evaluate_now (stride
, &init
);
5922 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5923 stride
, gfc_index_zero_node
);
5924 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
5925 tmp
, gfc_index_one_node
, stride
);
5926 stride
= GFC_TYPE_ARRAY_STRIDE (type
, 0);
5927 gfc_add_modify (&init
, stride
, tmp
);
5929 /* Allow the user to disable array repacking. */
5930 stmt_unpacked
= NULL_TREE
;
5934 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type
, 0)));
5935 /* A library call to repack the array if necessary. */
5936 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
5937 stmt_unpacked
= build_call_expr_loc (input_location
,
5938 gfor_fndecl_in_pack
, 1, tmp
);
5940 stride
= gfc_index_one_node
;
5942 if (warn_array_temporaries
)
5943 gfc_warning (OPT_Warray_temporaries
,
5944 "Creating array temporary at %L", &loc
);
5947 /* This is for the case where the array data is used directly without
5948 calling the repack function. */
5949 if (no_repack
|| partial
!= NULL_TREE
)
5950 stmt_packed
= gfc_conv_descriptor_data_get (dumdesc
);
5952 stmt_packed
= NULL_TREE
;
5954 /* Assign the data pointer. */
5955 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
5957 /* Don't repack unknown shape arrays when the first stride is 1. */
5958 tmp
= fold_build3_loc (input_location
, COND_EXPR
, TREE_TYPE (stmt_packed
),
5959 partial
, stmt_packed
, stmt_unpacked
);
5962 tmp
= stmt_packed
!= NULL_TREE
? stmt_packed
: stmt_unpacked
;
5963 gfc_add_modify (&init
, tmpdesc
, fold_convert (type
, tmp
));
5965 offset
= gfc_index_zero_node
;
5966 size
= gfc_index_one_node
;
5968 /* Evaluate the bounds of the array. */
5969 for (n
= 0; n
< sym
->as
->rank
; n
++)
5971 if (checkparm
|| !sym
->as
->upper
[n
])
5973 /* Get the bounds of the actual parameter. */
5974 dubound
= gfc_conv_descriptor_ubound_get (dumdesc
, gfc_rank_cst
[n
]);
5975 dlbound
= gfc_conv_descriptor_lbound_get (dumdesc
, gfc_rank_cst
[n
]);
5979 dubound
= NULL_TREE
;
5980 dlbound
= NULL_TREE
;
5983 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, n
);
5984 if (!INTEGER_CST_P (lbound
))
5986 gfc_init_se (&se
, NULL
);
5987 gfc_conv_expr_type (&se
, sym
->as
->lower
[n
],
5988 gfc_array_index_type
);
5989 gfc_add_block_to_block (&init
, &se
.pre
);
5990 gfc_add_modify (&init
, lbound
, se
.expr
);
5993 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, n
);
5994 /* Set the desired upper bound. */
5995 if (sym
->as
->upper
[n
])
5997 /* We know what we want the upper bound to be. */
5998 if (!INTEGER_CST_P (ubound
))
6000 gfc_init_se (&se
, NULL
);
6001 gfc_conv_expr_type (&se
, sym
->as
->upper
[n
],
6002 gfc_array_index_type
);
6003 gfc_add_block_to_block (&init
, &se
.pre
);
6004 gfc_add_modify (&init
, ubound
, se
.expr
);
6007 /* Check the sizes match. */
6010 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
6014 temp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6015 gfc_array_index_type
, ubound
, lbound
);
6016 temp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6017 gfc_array_index_type
,
6018 gfc_index_one_node
, temp
);
6019 stride2
= fold_build2_loc (input_location
, MINUS_EXPR
,
6020 gfc_array_index_type
, dubound
,
6022 stride2
= fold_build2_loc (input_location
, PLUS_EXPR
,
6023 gfc_array_index_type
,
6024 gfc_index_one_node
, stride2
);
6025 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6026 gfc_array_index_type
, temp
, stride2
);
6027 msg
= xasprintf ("Dimension %d of array '%s' has extent "
6028 "%%ld instead of %%ld", n
+1, sym
->name
);
6030 gfc_trans_runtime_check (true, false, tmp
, &init
, &loc
, msg
,
6031 fold_convert (long_integer_type_node
, temp
),
6032 fold_convert (long_integer_type_node
, stride2
));
6039 /* For assumed shape arrays move the upper bound by the same amount
6040 as the lower bound. */
6041 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6042 gfc_array_index_type
, dubound
, dlbound
);
6043 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6044 gfc_array_index_type
, tmp
, lbound
);
6045 gfc_add_modify (&init
, ubound
, tmp
);
6047 /* The offset of this dimension. offset = offset - lbound * stride. */
6048 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6050 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
6051 gfc_array_index_type
, offset
, tmp
);
6053 /* The size of this dimension, and the stride of the next. */
6054 if (n
+ 1 < sym
->as
->rank
)
6056 stride
= GFC_TYPE_ARRAY_STRIDE (type
, n
+ 1);
6058 if (no_repack
|| partial
!= NULL_TREE
)
6060 gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[n
+1]);
6062 /* Figure out the stride if not a known constant. */
6063 if (!INTEGER_CST_P (stride
))
6066 stmt_packed
= NULL_TREE
;
6069 /* Calculate stride = size * (ubound + 1 - lbound). */
6070 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6071 gfc_array_index_type
,
6072 gfc_index_one_node
, lbound
);
6073 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6074 gfc_array_index_type
, ubound
, tmp
);
6075 size
= fold_build2_loc (input_location
, MULT_EXPR
,
6076 gfc_array_index_type
, size
, tmp
);
6080 /* Assign the stride. */
6081 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
6082 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6083 gfc_array_index_type
, partial
,
6084 stmt_unpacked
, stmt_packed
);
6086 tmp
= (stmt_packed
!= NULL_TREE
) ? stmt_packed
: stmt_unpacked
;
6087 gfc_add_modify (&init
, stride
, tmp
);
6092 stride
= GFC_TYPE_ARRAY_SIZE (type
);
6094 if (stride
&& !INTEGER_CST_P (stride
))
6096 /* Calculate size = stride * (ubound + 1 - lbound). */
6097 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6098 gfc_array_index_type
,
6099 gfc_index_one_node
, lbound
);
6100 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6101 gfc_array_index_type
,
6103 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6104 gfc_array_index_type
,
6105 GFC_TYPE_ARRAY_STRIDE (type
, n
), tmp
);
6106 gfc_add_modify (&init
, stride
, tmp
);
6111 gfc_trans_array_cobounds (type
, &init
, sym
);
6113 /* Set the offset. */
6114 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
6115 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6117 gfc_trans_vla_type_sizes (sym
, &init
);
6119 stmtInit
= gfc_finish_block (&init
);
6121 /* Only do the entry/initialization code if the arg is present. */
6122 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6123 optional_arg
= (sym
->attr
.optional
6124 || (sym
->ns
->proc_name
->attr
.entry_master
6125 && sym
->attr
.dummy
));
6128 tmp
= gfc_conv_expr_present (sym
);
6129 stmtInit
= build3_v (COND_EXPR
, tmp
, stmtInit
,
6130 build_empty_stmt (input_location
));
6135 stmtCleanup
= NULL_TREE
;
6138 stmtblock_t cleanup
;
6139 gfc_start_block (&cleanup
);
6141 if (sym
->attr
.intent
!= INTENT_IN
)
6143 /* Copy the data back. */
6144 tmp
= build_call_expr_loc (input_location
,
6145 gfor_fndecl_in_unpack
, 2, dumdesc
, tmpdesc
);
6146 gfc_add_expr_to_block (&cleanup
, tmp
);
6149 /* Free the temporary. */
6150 tmp
= gfc_call_free (tmpdesc
);
6151 gfc_add_expr_to_block (&cleanup
, tmp
);
6153 stmtCleanup
= gfc_finish_block (&cleanup
);
6155 /* Only do the cleanup if the array was repacked. */
6156 tmp
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
6157 tmp
= gfc_conv_descriptor_data_get (tmp
);
6158 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6160 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6161 build_empty_stmt (input_location
));
6165 tmp
= gfc_conv_expr_present (sym
);
6166 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6167 build_empty_stmt (input_location
));
6171 /* We don't need to free any memory allocated by internal_pack as it will
6172 be freed at the end of the function by pop_context. */
6173 gfc_add_init_cleanup (block
, stmtInit
, stmtCleanup
);
6175 gfc_restore_backend_locus (&loc
);
6179 /* Calculate the overall offset, including subreferences. */
6181 gfc_get_dataptr_offset (stmtblock_t
*block
, tree parm
, tree desc
, tree offset
,
6182 bool subref
, gfc_expr
*expr
)
6192 /* If offset is NULL and this is not a subreferenced array, there is
6194 if (offset
== NULL_TREE
)
6197 offset
= gfc_index_zero_node
;
6202 tmp
= build_array_ref (desc
, offset
, NULL
);
6204 /* Offset the data pointer for pointer assignments from arrays with
6205 subreferences; e.g. my_integer => my_type(:)%integer_component. */
6208 /* Go past the array reference. */
6209 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6210 if (ref
->type
== REF_ARRAY
&&
6211 ref
->u
.ar
.type
!= AR_ELEMENT
)
6217 /* Calculate the offset for each subsequent subreference. */
6218 for (; ref
; ref
= ref
->next
)
6223 field
= ref
->u
.c
.component
->backend_decl
;
6224 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
6225 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
6227 tmp
, field
, NULL_TREE
);
6231 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
6232 gfc_init_se (&start
, NULL
);
6233 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
6234 gfc_add_block_to_block (block
, &start
.pre
);
6235 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
6239 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
6240 && ref
->u
.ar
.type
== AR_ELEMENT
);
6242 /* TODO - Add bounds checking. */
6243 stride
= gfc_index_one_node
;
6244 index
= gfc_index_zero_node
;
6245 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
6250 /* Update the index. */
6251 gfc_init_se (&start
, NULL
);
6252 gfc_conv_expr_type (&start
, ref
->u
.ar
.start
[n
], gfc_array_index_type
);
6253 itmp
= gfc_evaluate_now (start
.expr
, block
);
6254 gfc_init_se (&start
, NULL
);
6255 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->lower
[n
], gfc_array_index_type
);
6256 jtmp
= gfc_evaluate_now (start
.expr
, block
);
6257 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6258 gfc_array_index_type
, itmp
, jtmp
);
6259 itmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6260 gfc_array_index_type
, itmp
, stride
);
6261 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
6262 gfc_array_index_type
, itmp
, index
);
6263 index
= gfc_evaluate_now (index
, block
);
6265 /* Update the stride. */
6266 gfc_init_se (&start
, NULL
);
6267 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->upper
[n
], gfc_array_index_type
);
6268 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6269 gfc_array_index_type
, start
.expr
,
6271 itmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6272 gfc_array_index_type
,
6273 gfc_index_one_node
, itmp
);
6274 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
6275 gfc_array_index_type
, stride
, itmp
);
6276 stride
= gfc_evaluate_now (stride
, block
);
6279 /* Apply the index to obtain the array element. */
6280 tmp
= gfc_build_array_ref (tmp
, index
, NULL
);
6290 /* Set the target data pointer. */
6291 offset
= gfc_build_addr_expr (gfc_array_dataptr_type (desc
), tmp
);
6292 gfc_conv_descriptor_data_set (block
, parm
, offset
);
6296 /* gfc_conv_expr_descriptor needs the string length an expression
6297 so that the size of the temporary can be obtained. This is done
6298 by adding up the string lengths of all the elements in the
6299 expression. Function with non-constant expressions have their
6300 string lengths mapped onto the actual arguments using the
6301 interface mapping machinery in trans-expr.c. */
6303 get_array_charlen (gfc_expr
*expr
, gfc_se
*se
)
6305 gfc_interface_mapping mapping
;
6306 gfc_formal_arglist
*formal
;
6307 gfc_actual_arglist
*arg
;
6310 if (expr
->ts
.u
.cl
->length
6311 && gfc_is_constant_expr (expr
->ts
.u
.cl
->length
))
6313 if (!expr
->ts
.u
.cl
->backend_decl
)
6314 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6318 switch (expr
->expr_type
)
6321 get_array_charlen (expr
->value
.op
.op1
, se
);
6323 /* For parentheses the expression ts.u.cl is identical. */
6324 if (expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
6327 expr
->ts
.u
.cl
->backend_decl
=
6328 gfc_create_var (gfc_charlen_type_node
, "sln");
6330 if (expr
->value
.op
.op2
)
6332 get_array_charlen (expr
->value
.op
.op2
, se
);
6334 gcc_assert (expr
->value
.op
.op
== INTRINSIC_CONCAT
);
6336 /* Add the string lengths and assign them to the expression
6337 string length backend declaration. */
6338 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
6339 fold_build2_loc (input_location
, PLUS_EXPR
,
6340 gfc_charlen_type_node
,
6341 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
,
6342 expr
->value
.op
.op2
->ts
.u
.cl
->backend_decl
));
6345 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
6346 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
);
6350 if (expr
->value
.function
.esym
== NULL
6351 || expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6353 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6357 /* Map expressions involving the dummy arguments onto the actual
6358 argument expressions. */
6359 gfc_init_interface_mapping (&mapping
);
6360 formal
= gfc_sym_get_dummy_args (expr
->symtree
->n
.sym
);
6361 arg
= expr
->value
.function
.actual
;
6363 /* Set se = NULL in the calls to the interface mapping, to suppress any
6365 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
6370 gfc_add_interface_mapping (&mapping
, formal
->sym
, NULL
, arg
->expr
);
6373 gfc_init_se (&tse
, NULL
);
6375 /* Build the expression for the character length and convert it. */
6376 gfc_apply_interface_mapping (&mapping
, &tse
, expr
->ts
.u
.cl
->length
);
6378 gfc_add_block_to_block (&se
->pre
, &tse
.pre
);
6379 gfc_add_block_to_block (&se
->post
, &tse
.post
);
6380 tse
.expr
= fold_convert (gfc_charlen_type_node
, tse
.expr
);
6381 tse
.expr
= fold_build2_loc (input_location
, MAX_EXPR
,
6382 gfc_charlen_type_node
, tse
.expr
,
6383 build_int_cst (gfc_charlen_type_node
, 0));
6384 expr
->ts
.u
.cl
->backend_decl
= tse
.expr
;
6385 gfc_free_interface_mapping (&mapping
);
6389 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6395 /* Helper function to check dimensions. */
6397 transposed_dims (gfc_ss
*ss
)
6401 for (n
= 0; n
< ss
->dimen
; n
++)
6402 if (ss
->dim
[n
] != n
)
6408 /* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
6409 AR_FULL, suitable for the scalarizer. */
6412 walk_coarray (gfc_expr
*e
)
6416 gcc_assert (gfc_get_corank (e
) > 0);
6418 ss
= gfc_walk_expr (e
);
6420 /* Fix scalar coarray. */
6421 if (ss
== gfc_ss_terminator
)
6428 if (ref
->type
== REF_ARRAY
6429 && ref
->u
.ar
.codimen
> 0)
6435 gcc_assert (ref
!= NULL
);
6436 if (ref
->u
.ar
.type
== AR_ELEMENT
)
6437 ref
->u
.ar
.type
= AR_SECTION
;
6438 ss
= gfc_reverse_ss (gfc_walk_array_ref (ss
, e
, ref
));
6445 /* Convert an array for passing as an actual argument. Expressions and
6446 vector subscripts are evaluated and stored in a temporary, which is then
6447 passed. For whole arrays the descriptor is passed. For array sections
6448 a modified copy of the descriptor is passed, but using the original data.
6450 This function is also used for array pointer assignments, and there
6453 - se->want_pointer && !se->direct_byref
6454 EXPR is an actual argument. On exit, se->expr contains a
6455 pointer to the array descriptor.
6457 - !se->want_pointer && !se->direct_byref
6458 EXPR is an actual argument to an intrinsic function or the
6459 left-hand side of a pointer assignment. On exit, se->expr
6460 contains the descriptor for EXPR.
6462 - !se->want_pointer && se->direct_byref
6463 EXPR is the right-hand side of a pointer assignment and
6464 se->expr is the descriptor for the previously-evaluated
6465 left-hand side. The function creates an assignment from
6469 The se->force_tmp flag disables the non-copying descriptor optimization
6470 that is used for transpose. It may be used in cases where there is an
6471 alias between the transpose argument and another argument in the same
6475 gfc_conv_expr_descriptor (gfc_se
*se
, gfc_expr
*expr
)
6478 gfc_ss_type ss_type
;
6479 gfc_ss_info
*ss_info
;
6481 gfc_array_info
*info
;
6490 bool subref_array_target
= false;
6491 gfc_expr
*arg
, *ss_expr
;
6493 if (se
->want_coarray
)
6494 ss
= walk_coarray (expr
);
6496 ss
= gfc_walk_expr (expr
);
6498 gcc_assert (ss
!= NULL
);
6499 gcc_assert (ss
!= gfc_ss_terminator
);
6502 ss_type
= ss_info
->type
;
6503 ss_expr
= ss_info
->expr
;
6505 /* Special case: TRANSPOSE which needs no temporary. */
6506 while (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
6507 && NULL
!= (arg
= gfc_get_noncopying_intrinsic_argument (expr
)))
6509 /* This is a call to transpose which has already been handled by the
6510 scalarizer, so that we just need to get its argument's descriptor. */
6511 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
6512 expr
= expr
->value
.function
.actual
->expr
;
6515 /* Special case things we know we can pass easily. */
6516 switch (expr
->expr_type
)
6519 /* If we have a linear array section, we can pass it directly.
6520 Otherwise we need to copy it into a temporary. */
6522 gcc_assert (ss_type
== GFC_SS_SECTION
);
6523 gcc_assert (ss_expr
== expr
);
6524 info
= &ss_info
->data
.array
;
6526 /* Get the descriptor for the array. */
6527 gfc_conv_ss_descriptor (&se
->pre
, ss
, 0);
6528 desc
= info
->descriptor
;
6530 subref_array_target
= se
->direct_byref
&& is_subref_array (expr
);
6531 need_tmp
= gfc_ref_needs_temporary_p (expr
->ref
)
6532 && !subref_array_target
;
6539 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
6541 /* Create a new descriptor if the array doesn't have one. */
6544 else if (info
->ref
->u
.ar
.type
== AR_FULL
|| se
->descriptor_only
)
6546 else if (se
->direct_byref
)
6549 full
= gfc_full_array_ref_p (info
->ref
, NULL
);
6551 if (full
&& !transposed_dims (ss
))
6553 if (se
->direct_byref
&& !se
->byref_noassign
)
6555 /* Copy the descriptor for pointer assignments. */
6556 gfc_add_modify (&se
->pre
, se
->expr
, desc
);
6558 /* Add any offsets from subreferences. */
6559 gfc_get_dataptr_offset (&se
->pre
, se
->expr
, desc
, NULL_TREE
,
6560 subref_array_target
, expr
);
6562 else if (se
->want_pointer
)
6564 /* We pass full arrays directly. This means that pointers and
6565 allocatable arrays should also work. */
6566 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
6573 if (expr
->ts
.type
== BT_CHARACTER
)
6574 se
->string_length
= gfc_get_expr_charlen (expr
);
6576 gfc_free_ss_chain (ss
);
6582 /* A transformational function return value will be a temporary
6583 array descriptor. We still need to go through the scalarizer
6584 to create the descriptor. Elemental functions are handled as
6585 arbitrary expressions, i.e. copy to a temporary. */
6587 if (se
->direct_byref
)
6589 gcc_assert (ss_type
== GFC_SS_FUNCTION
&& ss_expr
== expr
);
6591 /* For pointer assignments pass the descriptor directly. */
6595 gcc_assert (se
->ss
== ss
);
6596 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
6597 gfc_conv_expr (se
, expr
);
6598 gfc_free_ss_chain (ss
);
6602 if (ss_expr
!= expr
|| ss_type
!= GFC_SS_FUNCTION
)
6604 if (ss_expr
!= expr
)
6605 /* Elemental function. */
6606 gcc_assert ((expr
->value
.function
.esym
!= NULL
6607 && expr
->value
.function
.esym
->attr
.elemental
)
6608 || (expr
->value
.function
.isym
!= NULL
6609 && expr
->value
.function
.isym
->elemental
)
6610 || gfc_inline_intrinsic_function_p (expr
));
6612 gcc_assert (ss_type
== GFC_SS_INTRINSIC
);
6615 if (expr
->ts
.type
== BT_CHARACTER
6616 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
6617 get_array_charlen (expr
, se
);
6623 /* Transformational function. */
6624 info
= &ss_info
->data
.array
;
6630 /* Constant array constructors don't need a temporary. */
6631 if (ss_type
== GFC_SS_CONSTRUCTOR
6632 && expr
->ts
.type
!= BT_CHARACTER
6633 && gfc_constant_array_constructor_p (expr
->value
.constructor
))
6636 info
= &ss_info
->data
.array
;
6646 /* Something complicated. Copy it into a temporary. */
6652 /* If we are creating a temporary, we don't need to bother about aliases
6657 gfc_init_loopinfo (&loop
);
6659 /* Associate the SS with the loop. */
6660 gfc_add_ss_to_loop (&loop
, ss
);
6662 /* Tell the scalarizer not to bother creating loop variables, etc. */
6664 loop
.array_parameter
= 1;
6666 /* The right-hand side of a pointer assignment mustn't use a temporary. */
6667 gcc_assert (!se
->direct_byref
);
6669 /* Setup the scalarizing loops and bounds. */
6670 gfc_conv_ss_startstride (&loop
);
6674 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
6675 get_array_charlen (expr
, se
);
6677 /* Tell the scalarizer to make a temporary. */
6678 loop
.temp_ss
= gfc_get_temp_ss (gfc_typenode_for_spec (&expr
->ts
),
6679 ((expr
->ts
.type
== BT_CHARACTER
)
6680 ? expr
->ts
.u
.cl
->backend_decl
6684 se
->string_length
= loop
.temp_ss
->info
->string_length
;
6685 gcc_assert (loop
.temp_ss
->dimen
== loop
.dimen
);
6686 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
6689 gfc_conv_loop_setup (&loop
, & expr
->where
);
6693 /* Copy into a temporary and pass that. We don't need to copy the data
6694 back because expressions and vector subscripts must be INTENT_IN. */
6695 /* TODO: Optimize passing function return values. */
6699 /* Start the copying loops. */
6700 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
6701 gfc_mark_ss_chain_used (ss
, 1);
6702 gfc_start_scalarized_body (&loop
, &block
);
6704 /* Copy each data element. */
6705 gfc_init_se (&lse
, NULL
);
6706 gfc_copy_loopinfo_to_se (&lse
, &loop
);
6707 gfc_init_se (&rse
, NULL
);
6708 gfc_copy_loopinfo_to_se (&rse
, &loop
);
6710 lse
.ss
= loop
.temp_ss
;
6713 gfc_conv_scalarized_array_ref (&lse
, NULL
);
6714 if (expr
->ts
.type
== BT_CHARACTER
)
6716 gfc_conv_expr (&rse
, expr
);
6717 if (POINTER_TYPE_P (TREE_TYPE (rse
.expr
)))
6718 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
6722 gfc_conv_expr_val (&rse
, expr
);
6724 gfc_add_block_to_block (&block
, &rse
.pre
);
6725 gfc_add_block_to_block (&block
, &lse
.pre
);
6727 lse
.string_length
= rse
.string_length
;
6728 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true,
6729 expr
->expr_type
== EXPR_VARIABLE
6730 || expr
->expr_type
== EXPR_ARRAY
, true);
6731 gfc_add_expr_to_block (&block
, tmp
);
6733 /* Finish the copying loops. */
6734 gfc_trans_scalarizing_loops (&loop
, &block
);
6736 desc
= loop
.temp_ss
->info
->data
.array
.descriptor
;
6738 else if (expr
->expr_type
== EXPR_FUNCTION
&& !transposed_dims (ss
))
6740 desc
= info
->descriptor
;
6741 se
->string_length
= ss_info
->string_length
;
6745 /* We pass sections without copying to a temporary. Make a new
6746 descriptor and point it at the section we want. The loop variable
6747 limits will be the limits of the section.
6748 A function may decide to repack the array to speed up access, but
6749 we're not bothered about that here. */
6750 int dim
, ndim
, codim
;
6758 ndim
= info
->ref
? info
->ref
->u
.ar
.dimen
: ss
->dimen
;
6760 if (se
->want_coarray
)
6762 gfc_array_ref
*ar
= &info
->ref
->u
.ar
;
6764 codim
= gfc_get_corank (expr
);
6765 for (n
= 0; n
< codim
- 1; n
++)
6767 /* Make sure we are not lost somehow. */
6768 gcc_assert (ar
->dimen_type
[n
+ ndim
] == DIMEN_THIS_IMAGE
);
6770 /* Make sure the call to gfc_conv_section_startstride won't
6771 generate unnecessary code to calculate stride. */
6772 gcc_assert (ar
->stride
[n
+ ndim
] == NULL
);
6774 gfc_conv_section_startstride (&loop
.pre
, ss
, n
+ ndim
);
6775 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
6776 loop
.to
[n
+ loop
.dimen
] = info
->end
[n
+ ndim
];
6779 gcc_assert (n
== codim
- 1);
6780 evaluate_bound (&loop
.pre
, info
->start
, ar
->start
,
6781 info
->descriptor
, n
+ ndim
, true);
6782 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
6787 /* Set the string_length for a character array. */
6788 if (expr
->ts
.type
== BT_CHARACTER
)
6789 se
->string_length
= gfc_get_expr_charlen (expr
);
6791 desc
= info
->descriptor
;
6792 if (se
->direct_byref
&& !se
->byref_noassign
)
6794 /* For pointer assignments we fill in the destination. */
6796 parmtype
= TREE_TYPE (parm
);
6800 /* Otherwise make a new one. */
6801 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
6802 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
, codim
,
6803 loop
.from
, loop
.to
, 0,
6804 GFC_ARRAY_UNKNOWN
, false);
6805 parm
= gfc_create_var (parmtype
, "parm");
6808 offset
= gfc_index_zero_node
;
6810 /* The following can be somewhat confusing. We have two
6811 descriptors, a new one and the original array.
6812 {parm, parmtype, dim} refer to the new one.
6813 {desc, type, n, loop} refer to the original, which maybe
6814 a descriptorless array.
6815 The bounds of the scalarization are the bounds of the section.
6816 We don't have to worry about numeric overflows when calculating
6817 the offsets because all elements are within the array data. */
6819 /* Set the dtype. */
6820 tmp
= gfc_conv_descriptor_dtype (parm
);
6821 gfc_add_modify (&loop
.pre
, tmp
, gfc_get_dtype (parmtype
));
6823 /* Set offset for assignments to pointer only to zero if it is not
6825 if ((se
->direct_byref
|| se
->use_offset
)
6826 && ((info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
6827 || (expr
->expr_type
== EXPR_ARRAY
&& se
->use_offset
)))
6828 base
= gfc_index_zero_node
;
6829 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
6830 base
= gfc_evaluate_now (gfc_conv_array_offset (desc
), &loop
.pre
);
6834 for (n
= 0; n
< ndim
; n
++)
6836 stride
= gfc_conv_array_stride (desc
, n
);
6838 /* Work out the offset. */
6840 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
6842 gcc_assert (info
->subscript
[n
]
6843 && info
->subscript
[n
]->info
->type
== GFC_SS_SCALAR
);
6844 start
= info
->subscript
[n
]->info
->data
.scalar
.value
;
6848 /* Evaluate and remember the start of the section. */
6849 start
= info
->start
[n
];
6850 stride
= gfc_evaluate_now (stride
, &loop
.pre
);
6853 tmp
= gfc_conv_array_lbound (desc
, n
);
6854 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
6856 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
6858 offset
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (tmp
),
6862 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
6864 /* For elemental dimensions, we only need the offset. */
6868 /* Vector subscripts need copying and are handled elsewhere. */
6870 gcc_assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
6872 /* look for the corresponding scalarizer dimension: dim. */
6873 for (dim
= 0; dim
< ndim
; dim
++)
6874 if (ss
->dim
[dim
] == n
)
6877 /* loop exited early: the DIM being looked for has been found. */
6878 gcc_assert (dim
< ndim
);
6880 /* Set the new lower bound. */
6881 from
= loop
.from
[dim
];
6884 /* If we have an array section or are assigning make sure that
6885 the lower bound is 1. References to the full
6886 array should otherwise keep the original bounds. */
6888 || info
->ref
->u
.ar
.type
!= AR_FULL
)
6889 && !integer_onep (from
))
6891 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6892 gfc_array_index_type
, gfc_index_one_node
,
6894 to
= fold_build2_loc (input_location
, PLUS_EXPR
,
6895 gfc_array_index_type
, to
, tmp
);
6896 from
= gfc_index_one_node
;
6898 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
6899 gfc_rank_cst
[dim
], from
);
6901 /* Set the new upper bound. */
6902 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
6903 gfc_rank_cst
[dim
], to
);
6905 /* Multiply the stride by the section stride to get the
6907 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
6908 gfc_array_index_type
,
6909 stride
, info
->stride
[n
]);
6911 if (se
->direct_byref
6912 && ((info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
6913 || (expr
->expr_type
== EXPR_ARRAY
&& se
->use_offset
)))
6915 base
= fold_build2_loc (input_location
, MINUS_EXPR
,
6916 TREE_TYPE (base
), base
, stride
);
6918 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)) || se
->use_offset
)
6920 tmp
= gfc_conv_array_lbound (desc
, n
);
6921 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6922 TREE_TYPE (base
), tmp
, loop
.from
[dim
]);
6923 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6924 TREE_TYPE (base
), tmp
,
6925 gfc_conv_array_stride (desc
, n
));
6926 base
= fold_build2_loc (input_location
, PLUS_EXPR
,
6927 TREE_TYPE (base
), tmp
, base
);
6930 /* Store the new stride. */
6931 gfc_conv_descriptor_stride_set (&loop
.pre
, parm
,
6932 gfc_rank_cst
[dim
], stride
);
6935 for (n
= loop
.dimen
; n
< loop
.dimen
+ codim
; n
++)
6937 from
= loop
.from
[n
];
6939 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
6940 gfc_rank_cst
[n
], from
);
6941 if (n
< loop
.dimen
+ codim
- 1)
6942 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
6943 gfc_rank_cst
[n
], to
);
6946 if (se
->data_not_needed
)
6947 gfc_conv_descriptor_data_set (&loop
.pre
, parm
,
6948 gfc_index_zero_node
);
6950 /* Point the data pointer at the 1st element in the section. */
6951 gfc_get_dataptr_offset (&loop
.pre
, parm
, desc
, offset
,
6952 subref_array_target
, expr
);
6954 if (((se
->direct_byref
|| GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
6955 && !se
->data_not_needed
)
6956 || (se
->use_offset
&& base
!= NULL_TREE
))
6958 /* Set the offset. */
6959 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, base
);
6963 /* Only the callee knows what the correct offset it, so just set
6965 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, gfc_index_zero_node
);
6970 if (!se
->direct_byref
|| se
->byref_noassign
)
6972 /* Get a pointer to the new descriptor. */
6973 if (se
->want_pointer
)
6974 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
6979 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
6980 gfc_add_block_to_block (&se
->post
, &loop
.post
);
6982 /* Cleanup the scalarizer. */
6983 gfc_cleanup_loop (&loop
);
6986 /* Helper function for gfc_conv_array_parameter if array size needs to be
6990 array_parameter_size (tree desc
, gfc_expr
*expr
, tree
*size
)
6993 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
6994 *size
= GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc
));
6995 else if (expr
->rank
> 1)
6996 *size
= build_call_expr_loc (input_location
,
6997 gfor_fndecl_size0
, 1,
6998 gfc_build_addr_expr (NULL
, desc
));
7001 tree ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_index_zero_node
);
7002 tree lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_index_zero_node
);
7004 *size
= fold_build2_loc (input_location
, MINUS_EXPR
,
7005 gfc_array_index_type
, ubound
, lbound
);
7006 *size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7007 *size
, gfc_index_one_node
);
7008 *size
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
7009 *size
, gfc_index_zero_node
);
7011 elem
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
7012 *size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7013 *size
, fold_convert (gfc_array_index_type
, elem
));
7016 /* Convert an array for passing as an actual parameter. */
7017 /* TODO: Optimize passing g77 arrays. */
7020 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, bool g77
,
7021 const gfc_symbol
*fsym
, const char *proc_name
,
7026 tree tmp
= NULL_TREE
;
7028 tree parent
= DECL_CONTEXT (current_function_decl
);
7029 bool full_array_var
;
7030 bool this_array_result
;
7033 bool array_constructor
;
7034 bool good_allocatable
;
7035 bool ultimate_ptr_comp
;
7036 bool ultimate_alloc_comp
;
7041 ultimate_ptr_comp
= false;
7042 ultimate_alloc_comp
= false;
7044 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7046 if (ref
->next
== NULL
)
7049 if (ref
->type
== REF_COMPONENT
)
7051 ultimate_ptr_comp
= ref
->u
.c
.component
->attr
.pointer
;
7052 ultimate_alloc_comp
= ref
->u
.c
.component
->attr
.allocatable
;
7056 full_array_var
= false;
7059 if (expr
->expr_type
== EXPR_VARIABLE
&& ref
&& !ultimate_ptr_comp
)
7060 full_array_var
= gfc_full_array_ref_p (ref
, &contiguous
);
7062 sym
= full_array_var
? expr
->symtree
->n
.sym
: NULL
;
7064 /* The symbol should have an array specification. */
7065 gcc_assert (!sym
|| sym
->as
|| ref
->u
.ar
.as
);
7067 if (expr
->expr_type
== EXPR_ARRAY
&& expr
->ts
.type
== BT_CHARACTER
)
7069 get_array_ctor_strlen (&se
->pre
, expr
->value
.constructor
, &tmp
);
7070 expr
->ts
.u
.cl
->backend_decl
= tmp
;
7071 se
->string_length
= tmp
;
7074 /* Is this the result of the enclosing procedure? */
7075 this_array_result
= (full_array_var
&& sym
->attr
.flavor
== FL_PROCEDURE
);
7076 if (this_array_result
7077 && (sym
->backend_decl
!= current_function_decl
)
7078 && (sym
->backend_decl
!= parent
))
7079 this_array_result
= false;
7081 /* Passing address of the array if it is not pointer or assumed-shape. */
7082 if (full_array_var
&& g77
&& !this_array_result
7083 && sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
7085 tmp
= gfc_get_symbol_decl (sym
);
7087 if (sym
->ts
.type
== BT_CHARACTER
)
7088 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
7090 if (!sym
->attr
.pointer
7092 && sym
->as
->type
!= AS_ASSUMED_SHAPE
7093 && sym
->as
->type
!= AS_DEFERRED
7094 && sym
->as
->type
!= AS_ASSUMED_RANK
7095 && !sym
->attr
.allocatable
)
7097 /* Some variables are declared directly, others are declared as
7098 pointers and allocated on the heap. */
7099 if (sym
->attr
.dummy
|| POINTER_TYPE_P (TREE_TYPE (tmp
)))
7102 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
7104 array_parameter_size (tmp
, expr
, size
);
7108 if (sym
->attr
.allocatable
)
7110 if (sym
->attr
.dummy
|| sym
->attr
.result
)
7112 gfc_conv_expr_descriptor (se
, expr
);
7116 array_parameter_size (tmp
, expr
, size
);
7117 se
->expr
= gfc_conv_array_data (tmp
);
7122 /* A convenient reduction in scope. */
7123 contiguous
= g77
&& !this_array_result
&& contiguous
;
7125 /* There is no need to pack and unpack the array, if it is contiguous
7126 and not a deferred- or assumed-shape array, or if it is simply
7128 no_pack
= ((sym
&& sym
->as
7129 && !sym
->attr
.pointer
7130 && sym
->as
->type
!= AS_DEFERRED
7131 && sym
->as
->type
!= AS_ASSUMED_RANK
7132 && sym
->as
->type
!= AS_ASSUMED_SHAPE
)
7134 (ref
&& ref
->u
.ar
.as
7135 && ref
->u
.ar
.as
->type
!= AS_DEFERRED
7136 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_RANK
7137 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_SHAPE
)
7139 gfc_is_simply_contiguous (expr
, false));
7141 no_pack
= contiguous
&& no_pack
;
7143 /* Array constructors are always contiguous and do not need packing. */
7144 array_constructor
= g77
&& !this_array_result
&& expr
->expr_type
== EXPR_ARRAY
;
7146 /* Same is true of contiguous sections from allocatable variables. */
7147 good_allocatable
= contiguous
7149 && expr
->symtree
->n
.sym
->attr
.allocatable
;
7151 /* Or ultimate allocatable components. */
7152 ultimate_alloc_comp
= contiguous
&& ultimate_alloc_comp
;
7154 if (no_pack
|| array_constructor
|| good_allocatable
|| ultimate_alloc_comp
)
7156 gfc_conv_expr_descriptor (se
, expr
);
7157 if (expr
->ts
.type
== BT_CHARACTER
)
7158 se
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
7160 array_parameter_size (se
->expr
, expr
, size
);
7161 se
->expr
= gfc_conv_array_data (se
->expr
);
7165 if (this_array_result
)
7167 /* Result of the enclosing function. */
7168 gfc_conv_expr_descriptor (se
, expr
);
7170 array_parameter_size (se
->expr
, expr
, size
);
7171 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7173 if (g77
&& TREE_TYPE (TREE_TYPE (se
->expr
)) != NULL_TREE
7174 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
7175 se
->expr
= gfc_conv_array_data (build_fold_indirect_ref_loc (input_location
,
7182 /* Every other type of array. */
7183 se
->want_pointer
= 1;
7184 gfc_conv_expr_descriptor (se
, expr
);
7186 array_parameter_size (build_fold_indirect_ref_loc (input_location
,
7191 /* Deallocate the allocatable components of structures that are
7193 if ((expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
)
7194 && expr
->ts
.u
.derived
->attr
.alloc_comp
7195 && expr
->expr_type
!= EXPR_VARIABLE
)
7197 tmp
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7198 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
, expr
->rank
);
7200 /* The components shall be deallocated before their containing entity. */
7201 gfc_prepend_expr_to_block (&se
->post
, tmp
);
7204 if (g77
|| (fsym
&& fsym
->attr
.contiguous
7205 && !gfc_is_simply_contiguous (expr
, false)))
7207 tree origptr
= NULL_TREE
;
7211 /* For contiguous arrays, save the original value of the descriptor. */
7214 origptr
= gfc_create_var (pvoid_type_node
, "origptr");
7215 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7216 tmp
= gfc_conv_array_data (tmp
);
7217 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7218 TREE_TYPE (origptr
), origptr
,
7219 fold_convert (TREE_TYPE (origptr
), tmp
));
7220 gfc_add_expr_to_block (&se
->pre
, tmp
);
7223 /* Repack the array. */
7224 if (warn_array_temporaries
)
7227 gfc_warning (OPT_Warray_temporaries
,
7228 "Creating array temporary at %L for argument %qs",
7229 &expr
->where
, fsym
->name
);
7231 gfc_warning (OPT_Warray_temporaries
,
7232 "Creating array temporary at %L", &expr
->where
);
7235 ptr
= build_call_expr_loc (input_location
,
7236 gfor_fndecl_in_pack
, 1, desc
);
7238 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7240 tmp
= gfc_conv_expr_present (sym
);
7241 ptr
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
7242 tmp
, fold_convert (TREE_TYPE (se
->expr
), ptr
),
7243 fold_convert (TREE_TYPE (se
->expr
), null_pointer_node
));
7246 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
7248 /* Use the packed data for the actual argument, except for contiguous arrays,
7249 where the descriptor's data component is set. */
7254 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7256 gfc_ss
* ss
= gfc_walk_expr (expr
);
7257 if (!transposed_dims (ss
))
7258 gfc_conv_descriptor_data_set (&se
->pre
, tmp
, ptr
);
7261 tree old_field
, new_field
;
7263 /* The original descriptor has transposed dims so we can't reuse
7264 it directly; we have to create a new one. */
7265 tree old_desc
= tmp
;
7266 tree new_desc
= gfc_create_var (TREE_TYPE (old_desc
), "arg_desc");
7268 old_field
= gfc_conv_descriptor_dtype (old_desc
);
7269 new_field
= gfc_conv_descriptor_dtype (new_desc
);
7270 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7272 old_field
= gfc_conv_descriptor_offset (old_desc
);
7273 new_field
= gfc_conv_descriptor_offset (new_desc
);
7274 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7276 for (int i
= 0; i
< expr
->rank
; i
++)
7278 old_field
= gfc_conv_descriptor_dimension (old_desc
,
7279 gfc_rank_cst
[get_array_ref_dim_for_loop_dim (ss
, i
)]);
7280 new_field
= gfc_conv_descriptor_dimension (new_desc
,
7282 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7285 if (flag_coarray
== GFC_FCOARRAY_LIB
7286 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (old_desc
))
7287 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (old_desc
))
7288 == GFC_ARRAY_ALLOCATABLE
)
7290 old_field
= gfc_conv_descriptor_token (old_desc
);
7291 new_field
= gfc_conv_descriptor_token (new_desc
);
7292 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7295 gfc_conv_descriptor_data_set (&se
->pre
, new_desc
, ptr
);
7296 se
->expr
= gfc_build_addr_expr (NULL_TREE
, new_desc
);
7301 if (gfc_option
.rtcheck
& GFC_RTCHECK_ARRAY_TEMPS
)
7305 if (fsym
&& proc_name
)
7306 msg
= xasprintf ("An array temporary was created for argument "
7307 "'%s' of procedure '%s'", fsym
->name
, proc_name
);
7309 msg
= xasprintf ("An array temporary was created");
7311 tmp
= build_fold_indirect_ref_loc (input_location
,
7313 tmp
= gfc_conv_array_data (tmp
);
7314 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7315 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
7317 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7318 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7320 gfc_conv_expr_present (sym
), tmp
);
7322 gfc_trans_runtime_check (false, true, tmp
, &se
->pre
,
7327 gfc_start_block (&block
);
7329 /* Copy the data back. */
7330 if (fsym
== NULL
|| fsym
->attr
.intent
!= INTENT_IN
)
7332 tmp
= build_call_expr_loc (input_location
,
7333 gfor_fndecl_in_unpack
, 2, desc
, ptr
);
7334 gfc_add_expr_to_block (&block
, tmp
);
7337 /* Free the temporary. */
7338 tmp
= gfc_call_free (convert (pvoid_type_node
, ptr
));
7339 gfc_add_expr_to_block (&block
, tmp
);
7341 stmt
= gfc_finish_block (&block
);
7343 gfc_init_block (&block
);
7344 /* Only if it was repacked. This code needs to be executed before the
7345 loop cleanup code. */
7346 tmp
= build_fold_indirect_ref_loc (input_location
,
7348 tmp
= gfc_conv_array_data (tmp
);
7349 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7350 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
7352 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7353 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7355 gfc_conv_expr_present (sym
), tmp
);
7357 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
7359 gfc_add_expr_to_block (&block
, tmp
);
7360 gfc_add_block_to_block (&block
, &se
->post
);
7362 gfc_init_block (&se
->post
);
7364 /* Reset the descriptor pointer. */
7367 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7368 gfc_conv_descriptor_data_set (&se
->post
, tmp
, origptr
);
7371 gfc_add_block_to_block (&se
->post
, &block
);
7376 /* Generate code to deallocate an array, if it is allocated. */
7379 gfc_trans_dealloc_allocated (tree descriptor
, bool coarray
, gfc_expr
*expr
)
7385 gfc_start_block (&block
);
7387 var
= gfc_conv_descriptor_data_get (descriptor
);
7390 /* Call array_deallocate with an int * present in the second argument.
7391 Although it is ignored here, it's presence ensures that arrays that
7392 are already deallocated are ignored. */
7393 tmp
= gfc_deallocate_with_status (coarray
? descriptor
: var
, NULL_TREE
,
7394 NULL_TREE
, NULL_TREE
, NULL_TREE
, true,
7396 gfc_add_expr_to_block (&block
, tmp
);
7398 /* Zero the data pointer. */
7399 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
7400 var
, build_int_cst (TREE_TYPE (var
), 0));
7401 gfc_add_expr_to_block (&block
, tmp
);
7403 return gfc_finish_block (&block
);
7407 /* This helper function calculates the size in words of a full array. */
7410 gfc_full_array_size (stmtblock_t
*block
, tree decl
, int rank
)
7415 idx
= gfc_rank_cst
[rank
- 1];
7416 nelems
= gfc_conv_descriptor_ubound_get (decl
, idx
);
7417 tmp
= gfc_conv_descriptor_lbound_get (decl
, idx
);
7418 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7420 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7421 tmp
, gfc_index_one_node
);
7422 tmp
= gfc_evaluate_now (tmp
, block
);
7424 nelems
= gfc_conv_descriptor_stride_get (decl
, idx
);
7425 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7427 return gfc_evaluate_now (tmp
, block
);
7431 /* Allocate dest to the same size as src, and copy src -> dest.
7432 If no_malloc is set, only the copy is done. */
7435 duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
7436 bool no_malloc
, bool no_memcpy
, tree str_sz
)
7445 /* If the source is null, set the destination to null. Then,
7446 allocate memory to the destination. */
7447 gfc_init_block (&block
);
7449 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
7451 tmp
= null_pointer_node
;
7452 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, type
, dest
, tmp
);
7453 gfc_add_expr_to_block (&block
, tmp
);
7454 null_data
= gfc_finish_block (&block
);
7456 gfc_init_block (&block
);
7457 if (str_sz
!= NULL_TREE
)
7460 size
= TYPE_SIZE_UNIT (TREE_TYPE (type
));
7464 tmp
= gfc_call_malloc (&block
, type
, size
);
7465 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
7466 dest
, fold_convert (type
, tmp
));
7467 gfc_add_expr_to_block (&block
, tmp
);
7472 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
7473 tmp
= build_call_expr_loc (input_location
, tmp
, 3, dest
, src
,
7474 fold_convert (size_type_node
, size
));
7475 gfc_add_expr_to_block (&block
, tmp
);
7480 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
7481 null_data
= gfc_finish_block (&block
);
7483 gfc_init_block (&block
);
7485 nelems
= gfc_full_array_size (&block
, src
, rank
);
7487 nelems
= gfc_index_one_node
;
7489 if (str_sz
!= NULL_TREE
)
7490 tmp
= fold_convert (gfc_array_index_type
, str_sz
);
7492 tmp
= fold_convert (gfc_array_index_type
,
7493 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
7494 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7498 tmp
= TREE_TYPE (gfc_conv_descriptor_data_get (src
));
7499 tmp
= gfc_call_malloc (&block
, tmp
, size
);
7500 gfc_conv_descriptor_data_set (&block
, dest
, tmp
);
7503 /* We know the temporary and the value will be the same length,
7504 so can use memcpy. */
7507 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
7508 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
7509 gfc_conv_descriptor_data_get (dest
),
7510 gfc_conv_descriptor_data_get (src
),
7511 fold_convert (size_type_node
, size
));
7512 gfc_add_expr_to_block (&block
, tmp
);
7516 tmp
= gfc_finish_block (&block
);
7518 /* Null the destination if the source is null; otherwise do
7519 the allocate and copy. */
7520 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src
)))
7523 null_cond
= gfc_conv_descriptor_data_get (src
);
7525 null_cond
= convert (pvoid_type_node
, null_cond
);
7526 null_cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7527 null_cond
, null_pointer_node
);
7528 return build3_v (COND_EXPR
, null_cond
, tmp
, null_data
);
7532 /* Allocate dest to the same size as src, and copy data src -> dest. */
7535 gfc_duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
)
7537 return duplicate_allocatable (dest
, src
, type
, rank
, false, false,
7542 /* Copy data src -> dest. */
7545 gfc_copy_allocatable_data (tree dest
, tree src
, tree type
, int rank
)
7547 return duplicate_allocatable (dest
, src
, type
, rank
, true, false,
7551 /* Allocate dest to the same size as src, but don't copy anything. */
7554 gfc_duplicate_allocatable_nocopy (tree dest
, tree src
, tree type
, int rank
)
7556 return duplicate_allocatable (dest
, src
, type
, rank
, false, true, NULL_TREE
);
7560 /* Recursively traverse an object of derived type, generating code to
7561 deallocate, nullify or copy allocatable components. This is the work horse
7562 function for the functions named in this enum. */
7564 enum {DEALLOCATE_ALLOC_COMP
= 1, DEALLOCATE_ALLOC_COMP_NO_CAF
,
7565 NULLIFY_ALLOC_COMP
, COPY_ALLOC_COMP
, COPY_ONLY_ALLOC_COMP
,
7566 COPY_ALLOC_COMP_CAF
};
7569 structure_alloc_comps (gfc_symbol
* der_type
, tree decl
,
7570 tree dest
, int rank
, int purpose
)
7574 stmtblock_t fnblock
;
7575 stmtblock_t loopbody
;
7576 stmtblock_t tmpblock
;
7587 tree null_cond
= NULL_TREE
;
7588 bool called_dealloc_with_status
;
7590 gfc_init_block (&fnblock
);
7592 decl_type
= TREE_TYPE (decl
);
7594 if ((POINTER_TYPE_P (decl_type
) && rank
!= 0)
7595 || (TREE_CODE (decl_type
) == REFERENCE_TYPE
&& rank
== 0))
7596 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
7598 /* Just in case in gets dereferenced. */
7599 decl_type
= TREE_TYPE (decl
);
7601 /* If this an array of derived types with allocatable components
7602 build a loop and recursively call this function. */
7603 if (TREE_CODE (decl_type
) == ARRAY_TYPE
7604 || (GFC_DESCRIPTOR_TYPE_P (decl_type
) && rank
!= 0))
7606 tmp
= gfc_conv_array_data (decl
);
7607 var
= build_fold_indirect_ref_loc (input_location
,
7610 /* Get the number of elements - 1 and set the counter. */
7611 if (GFC_DESCRIPTOR_TYPE_P (decl_type
))
7613 /* Use the descriptor for an allocatable array. Since this
7614 is a full array reference, we only need the descriptor
7615 information from dimension = rank. */
7616 tmp
= gfc_full_array_size (&fnblock
, decl
, rank
);
7617 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7618 gfc_array_index_type
, tmp
,
7619 gfc_index_one_node
);
7621 null_cond
= gfc_conv_descriptor_data_get (decl
);
7622 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
7623 boolean_type_node
, null_cond
,
7624 build_int_cst (TREE_TYPE (null_cond
), 0));
7628 /* Otherwise use the TYPE_DOMAIN information. */
7629 tmp
= array_type_nelts (decl_type
);
7630 tmp
= fold_convert (gfc_array_index_type
, tmp
);
7633 /* Remember that this is, in fact, the no. of elements - 1. */
7634 nelems
= gfc_evaluate_now (tmp
, &fnblock
);
7635 index
= gfc_create_var (gfc_array_index_type
, "S");
7637 /* Build the body of the loop. */
7638 gfc_init_block (&loopbody
);
7640 vref
= gfc_build_array_ref (var
, index
, NULL
);
7642 if (purpose
== COPY_ALLOC_COMP
)
7644 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
7646 tmp
= gfc_duplicate_allocatable (dest
, decl
, decl_type
, rank
);
7647 gfc_add_expr_to_block (&fnblock
, tmp
);
7649 tmp
= build_fold_indirect_ref_loc (input_location
,
7650 gfc_conv_array_data (dest
));
7651 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
7652 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
, purpose
);
7654 else if (purpose
== COPY_ONLY_ALLOC_COMP
)
7656 tmp
= build_fold_indirect_ref_loc (input_location
,
7657 gfc_conv_array_data (dest
));
7658 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
7659 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
,
7663 tmp
= structure_alloc_comps (der_type
, vref
, NULL_TREE
, rank
, purpose
);
7665 gfc_add_expr_to_block (&loopbody
, tmp
);
7667 /* Build the loop and return. */
7668 gfc_init_loopinfo (&loop
);
7670 loop
.from
[0] = gfc_index_zero_node
;
7671 loop
.loopvar
[0] = index
;
7672 loop
.to
[0] = nelems
;
7673 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
7674 gfc_add_block_to_block (&fnblock
, &loop
.pre
);
7676 tmp
= gfc_finish_block (&fnblock
);
7677 if (null_cond
!= NULL_TREE
)
7678 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
7679 build_empty_stmt (input_location
));
7684 /* Otherwise, act on the components or recursively call self to
7685 act on a chain of components. */
7686 for (c
= der_type
->components
; c
; c
= c
->next
)
7688 bool cmp_has_alloc_comps
= (c
->ts
.type
== BT_DERIVED
7689 || c
->ts
.type
== BT_CLASS
)
7690 && c
->ts
.u
.derived
->attr
.alloc_comp
;
7691 cdecl = c
->backend_decl
;
7692 ctype
= TREE_TYPE (cdecl);
7696 case DEALLOCATE_ALLOC_COMP
:
7697 case DEALLOCATE_ALLOC_COMP_NO_CAF
:
7699 /* gfc_deallocate_scalar_with_status calls gfc_deallocate_alloc_comp
7700 (i.e. this function) so generate all the calls and suppress the
7701 recursion from here, if necessary. */
7702 called_dealloc_with_status
= false;
7703 gfc_init_block (&tmpblock
);
7705 if ((c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
)
7706 || (c
->ts
.type
== BT_CLASS
&& !CLASS_DATA (c
)->attr
.class_pointer
))
7708 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7709 decl
, cdecl, NULL_TREE
);
7711 /* The finalizer frees allocatable components. */
7712 called_dealloc_with_status
7713 = gfc_add_comp_finalizer_call (&tmpblock
, comp
, c
,
7714 purpose
== DEALLOCATE_ALLOC_COMP
);
7719 if (c
->attr
.allocatable
&& !c
->attr
.proc_pointer
7720 && (c
->attr
.dimension
7721 || (c
->attr
.codimension
7722 && purpose
!= DEALLOCATE_ALLOC_COMP_NO_CAF
)))
7724 if (comp
== NULL_TREE
)
7725 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7726 decl
, cdecl, NULL_TREE
);
7727 tmp
= gfc_trans_dealloc_allocated (comp
, c
->attr
.codimension
, NULL
);
7728 gfc_add_expr_to_block (&tmpblock
, tmp
);
7730 else if (c
->attr
.allocatable
&& !c
->attr
.codimension
)
7732 /* Allocatable scalar components. */
7733 if (comp
== NULL_TREE
)
7734 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7735 decl
, cdecl, NULL_TREE
);
7737 tmp
= gfc_deallocate_scalar_with_status (comp
, NULL
, true, NULL
,
7739 gfc_add_expr_to_block (&tmpblock
, tmp
);
7740 called_dealloc_with_status
= true;
7742 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7743 void_type_node
, comp
,
7744 build_int_cst (TREE_TYPE (comp
), 0));
7745 gfc_add_expr_to_block (&tmpblock
, tmp
);
7747 else if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
7748 && (!CLASS_DATA (c
)->attr
.codimension
7749 || purpose
!= DEALLOCATE_ALLOC_COMP_NO_CAF
))
7751 /* Allocatable CLASS components. */
7753 /* Add reference to '_data' component. */
7754 tmp
= CLASS_DATA (c
)->backend_decl
;
7755 comp
= fold_build3_loc (input_location
, COMPONENT_REF
,
7756 TREE_TYPE (tmp
), comp
, tmp
, NULL_TREE
);
7758 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp
)))
7759 tmp
= gfc_trans_dealloc_allocated (comp
,
7760 CLASS_DATA (c
)->attr
.codimension
, NULL
);
7763 tmp
= gfc_deallocate_scalar_with_status (comp
, NULL_TREE
, true, NULL
,
7764 CLASS_DATA (c
)->ts
);
7765 gfc_add_expr_to_block (&tmpblock
, tmp
);
7766 called_dealloc_with_status
= true;
7768 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7769 void_type_node
, comp
,
7770 build_int_cst (TREE_TYPE (comp
), 0));
7772 gfc_add_expr_to_block (&tmpblock
, tmp
);
7775 if (cmp_has_alloc_comps
7777 && !called_dealloc_with_status
)
7779 /* Do not deallocate the components of ultimate pointer
7780 components or iteratively call self if call has been made
7781 to gfc_trans_dealloc_allocated */
7782 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7783 decl
, cdecl, NULL_TREE
);
7784 rank
= c
->as
? c
->as
->rank
: 0;
7785 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
7787 gfc_add_expr_to_block (&fnblock
, tmp
);
7790 /* Now add the deallocation of this component. */
7791 gfc_add_block_to_block (&fnblock
, &tmpblock
);
7794 case NULLIFY_ALLOC_COMP
:
7795 if (c
->attr
.pointer
|| c
->attr
.proc_pointer
)
7797 else if (c
->attr
.allocatable
7798 && (c
->attr
.dimension
|| c
->attr
.codimension
))
7800 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7801 decl
, cdecl, NULL_TREE
);
7802 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
7804 else if (c
->attr
.allocatable
)
7806 /* Allocatable scalar components. */
7807 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7808 decl
, cdecl, NULL_TREE
);
7809 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7810 void_type_node
, comp
,
7811 build_int_cst (TREE_TYPE (comp
), 0));
7812 gfc_add_expr_to_block (&fnblock
, tmp
);
7813 if (gfc_deferred_strlen (c
, &comp
))
7815 comp
= fold_build3_loc (input_location
, COMPONENT_REF
,
7817 decl
, comp
, NULL_TREE
);
7818 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7819 TREE_TYPE (comp
), comp
,
7820 build_int_cst (TREE_TYPE (comp
), 0));
7821 gfc_add_expr_to_block (&fnblock
, tmp
);
7824 else if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
7826 /* Allocatable CLASS components. */
7827 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7828 decl
, cdecl, NULL_TREE
);
7829 /* Add reference to '_data' component. */
7830 tmp
= CLASS_DATA (c
)->backend_decl
;
7831 comp
= fold_build3_loc (input_location
, COMPONENT_REF
,
7832 TREE_TYPE (tmp
), comp
, tmp
, NULL_TREE
);
7833 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp
)))
7834 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
7837 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7838 void_type_node
, comp
,
7839 build_int_cst (TREE_TYPE (comp
), 0));
7840 gfc_add_expr_to_block (&fnblock
, tmp
);
7843 else if (cmp_has_alloc_comps
)
7845 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7846 decl
, cdecl, NULL_TREE
);
7847 rank
= c
->as
? c
->as
->rank
: 0;
7848 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
7850 gfc_add_expr_to_block (&fnblock
, tmp
);
7854 case COPY_ALLOC_COMP_CAF
:
7855 if (!c
->attr
.codimension
7856 && (c
->ts
.type
!= BT_CLASS
|| CLASS_DATA (c
)->attr
.coarray_comp
)
7857 && (c
->ts
.type
!= BT_DERIVED
7858 || !c
->ts
.u
.derived
->attr
.coarray_comp
))
7861 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, decl
,
7863 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, dest
,
7866 if (c
->attr
.codimension
)
7868 if (c
->ts
.type
== BT_CLASS
)
7870 comp
= gfc_class_data_get (comp
);
7871 dcmp
= gfc_class_data_get (dcmp
);
7873 gfc_conv_descriptor_data_set (&fnblock
, dcmp
,
7874 gfc_conv_descriptor_data_get (comp
));
7878 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, dcmp
,
7880 gfc_add_expr_to_block (&fnblock
, tmp
);
7885 case COPY_ALLOC_COMP
:
7886 if (c
->attr
.pointer
)
7889 /* We need source and destination components. */
7890 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, decl
,
7892 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, dest
,
7894 dcmp
= fold_convert (TREE_TYPE (comp
), dcmp
);
7896 if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
7904 dst_data
= gfc_class_data_get (dcmp
);
7905 src_data
= gfc_class_data_get (comp
);
7906 size
= fold_convert (size_type_node
, gfc_vtable_size_get (comp
));
7908 if (CLASS_DATA (c
)->attr
.dimension
)
7910 nelems
= gfc_conv_descriptor_size (src_data
,
7911 CLASS_DATA (c
)->as
->rank
);
7912 size
= fold_build2_loc (input_location
, MULT_EXPR
,
7913 size_type_node
, size
,
7914 fold_convert (size_type_node
,
7918 nelems
= build_int_cst (size_type_node
, 1);
7920 if (CLASS_DATA (c
)->attr
.dimension
7921 || CLASS_DATA (c
)->attr
.codimension
)
7923 src_data
= gfc_conv_descriptor_data_get (src_data
);
7924 dst_data
= gfc_conv_descriptor_data_get (dst_data
);
7927 gfc_init_block (&tmpblock
);
7929 /* Coarray component have to have the same allocation status and
7930 shape/type-parameter/effective-type on the LHS and RHS of an
7931 intrinsic assignment. Hence, we did not deallocated them - and
7932 do not allocate them here. */
7933 if (!CLASS_DATA (c
)->attr
.codimension
)
7935 ftn_tree
= builtin_decl_explicit (BUILT_IN_MALLOC
);
7936 tmp
= build_call_expr_loc (input_location
, ftn_tree
, 1, size
);
7937 gfc_add_modify (&tmpblock
, dst_data
,
7938 fold_convert (TREE_TYPE (dst_data
), tmp
));
7941 tmp
= gfc_copy_class_to_class (comp
, dcmp
, nelems
);
7942 gfc_add_expr_to_block (&tmpblock
, tmp
);
7943 tmp
= gfc_finish_block (&tmpblock
);
7945 gfc_init_block (&tmpblock
);
7946 gfc_add_modify (&tmpblock
, dst_data
,
7947 fold_convert (TREE_TYPE (dst_data
),
7948 null_pointer_node
));
7949 null_data
= gfc_finish_block (&tmpblock
);
7951 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
7952 boolean_type_node
, src_data
,
7955 gfc_add_expr_to_block (&fnblock
, build3_v (COND_EXPR
, null_cond
,
7960 if (gfc_deferred_strlen (c
, &tmp
))
7964 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
7966 decl
, len
, NULL_TREE
);
7967 len
= fold_build3_loc (input_location
, COMPONENT_REF
,
7969 dest
, len
, NULL_TREE
);
7970 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7971 TREE_TYPE (len
), len
, tmp
);
7972 gfc_add_expr_to_block (&fnblock
, tmp
);
7973 size
= size_of_string_in_bytes (c
->ts
.kind
, len
);
7974 tmp
= duplicate_allocatable (dcmp
, comp
, ctype
, rank
,
7975 false, false, size
);
7976 gfc_add_expr_to_block (&fnblock
, tmp
);
7978 else if (c
->attr
.allocatable
&& !c
->attr
.proc_pointer
7979 && !cmp_has_alloc_comps
)
7981 rank
= c
->as
? c
->as
->rank
: 0;
7982 if (c
->attr
.codimension
)
7983 tmp
= gfc_copy_allocatable_data (dcmp
, comp
, ctype
, rank
);
7985 tmp
= gfc_duplicate_allocatable (dcmp
, comp
, ctype
, rank
);
7986 gfc_add_expr_to_block (&fnblock
, tmp
);
7989 if (cmp_has_alloc_comps
)
7991 rank
= c
->as
? c
->as
->rank
: 0;
7992 tmp
= fold_convert (TREE_TYPE (dcmp
), comp
);
7993 gfc_add_modify (&fnblock
, dcmp
, tmp
);
7994 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, dcmp
,
7996 gfc_add_expr_to_block (&fnblock
, tmp
);
8006 return gfc_finish_block (&fnblock
);
8009 /* Recursively traverse an object of derived type, generating code to
8010 nullify allocatable components. */
8013 gfc_nullify_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
8015 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
8016 NULLIFY_ALLOC_COMP
);
8020 /* Recursively traverse an object of derived type, generating code to
8021 deallocate allocatable components. */
8024 gfc_deallocate_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
8026 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
8027 DEALLOCATE_ALLOC_COMP
);
8031 /* Recursively traverse an object of derived type, generating code to
8032 deallocate allocatable components. But do not deallocate coarrays.
8033 To be used for intrinsic assignment, which may not change the allocation
8034 status of coarrays. */
8037 gfc_deallocate_alloc_comp_no_caf (gfc_symbol
* der_type
, tree decl
, int rank
)
8039 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
8040 DEALLOCATE_ALLOC_COMP_NO_CAF
);
8045 gfc_reassign_alloc_comp_caf (gfc_symbol
*der_type
, tree decl
, tree dest
)
8047 return structure_alloc_comps (der_type
, decl
, dest
, 0, COPY_ALLOC_COMP_CAF
);
8051 /* Recursively traverse an object of derived type, generating code to
8052 copy it and its allocatable components. */
8055 gfc_copy_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
8057 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ALLOC_COMP
);
8061 /* Recursively traverse an object of derived type, generating code to
8062 copy only its allocatable components. */
8065 gfc_copy_only_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
8067 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ONLY_ALLOC_COMP
);
8071 /* Returns the value of LBOUND for an expression. This could be broken out
8072 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
8073 called by gfc_alloc_allocatable_for_assignment. */
8075 get_std_lbound (gfc_expr
*expr
, tree desc
, int dim
, bool assumed_size
)
8080 tree cond
, cond1
, cond3
, cond4
;
8084 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
8086 tmp
= gfc_rank_cst
[dim
];
8087 lbound
= gfc_conv_descriptor_lbound_get (desc
, tmp
);
8088 ubound
= gfc_conv_descriptor_ubound_get (desc
, tmp
);
8089 stride
= gfc_conv_descriptor_stride_get (desc
, tmp
);
8090 cond1
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
8092 cond3
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
8093 stride
, gfc_index_zero_node
);
8094 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8095 boolean_type_node
, cond3
, cond1
);
8096 cond4
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
8097 stride
, gfc_index_zero_node
);
8099 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
8100 tmp
, build_int_cst (gfc_array_index_type
,
8103 cond
= boolean_false_node
;
8105 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
8106 boolean_type_node
, cond3
, cond4
);
8107 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
8108 boolean_type_node
, cond
, cond1
);
8110 return fold_build3_loc (input_location
, COND_EXPR
,
8111 gfc_array_index_type
, cond
,
8112 lbound
, gfc_index_one_node
);
8115 if (expr
->expr_type
== EXPR_FUNCTION
)
8117 /* A conversion function, so use the argument. */
8118 gcc_assert (expr
->value
.function
.isym
8119 && expr
->value
.function
.isym
->conversion
);
8120 expr
= expr
->value
.function
.actual
->expr
;
8123 if (expr
->expr_type
== EXPR_VARIABLE
)
8125 tmp
= TREE_TYPE (expr
->symtree
->n
.sym
->backend_decl
);
8126 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
8128 if (ref
->type
== REF_COMPONENT
8129 && ref
->u
.c
.component
->as
8131 && ref
->next
->u
.ar
.type
== AR_FULL
)
8132 tmp
= TREE_TYPE (ref
->u
.c
.component
->backend_decl
);
8134 return GFC_TYPE_ARRAY_LBOUND(tmp
, dim
);
8137 return gfc_index_one_node
;
8141 /* Returns true if an expression represents an lhs that can be reallocated
8145 gfc_is_reallocatable_lhs (gfc_expr
*expr
)
8152 /* An allocatable variable. */
8153 if (expr
->symtree
->n
.sym
->attr
.allocatable
8155 && expr
->ref
->type
== REF_ARRAY
8156 && expr
->ref
->u
.ar
.type
== AR_FULL
)
8159 /* All that can be left are allocatable components. */
8160 if ((expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
8161 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
8162 || !expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
8165 /* Find a component ref followed by an array reference. */
8166 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
8168 && ref
->type
== REF_COMPONENT
8169 && ref
->next
->type
== REF_ARRAY
8170 && !ref
->next
->next
)
8176 /* Return true if valid reallocatable lhs. */
8177 if (ref
->u
.c
.component
->attr
.allocatable
8178 && ref
->next
->u
.ar
.type
== AR_FULL
)
8185 /* Allocate the lhs of an assignment to an allocatable array, otherwise
8189 gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop
,
8193 stmtblock_t realloc_block
;
8194 stmtblock_t alloc_block
;
8198 gfc_array_info
*linfo
;
8220 gfc_array_spec
* as
;
8222 /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
8223 Find the lhs expression in the loop chain and set expr1 and
8224 expr2 accordingly. */
8225 if (expr1
->expr_type
== EXPR_FUNCTION
&& expr2
== NULL
)
8228 /* Find the ss for the lhs. */
8230 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
8231 if (lss
->info
->expr
&& lss
->info
->expr
->expr_type
== EXPR_VARIABLE
)
8233 if (lss
== gfc_ss_terminator
)
8235 expr1
= lss
->info
->expr
;
8238 /* Bail out if this is not a valid allocate on assignment. */
8239 if (!gfc_is_reallocatable_lhs (expr1
)
8240 || (expr2
&& !expr2
->rank
))
8243 /* Find the ss for the lhs. */
8245 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
8246 if (lss
->info
->expr
== expr1
)
8249 if (lss
== gfc_ss_terminator
)
8252 linfo
= &lss
->info
->data
.array
;
8254 /* Find an ss for the rhs. For operator expressions, we see the
8255 ss's for the operands. Any one of these will do. */
8257 for (; rss
&& rss
!= gfc_ss_terminator
; rss
= rss
->loop_chain
)
8258 if (rss
->info
->expr
!= expr1
&& rss
!= loop
->temp_ss
)
8261 if (expr2
&& rss
== gfc_ss_terminator
)
8264 gfc_start_block (&fblock
);
8266 /* Since the lhs is allocatable, this must be a descriptor type.
8267 Get the data and array size. */
8268 desc
= linfo
->descriptor
;
8269 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)));
8270 array1
= gfc_conv_descriptor_data_get (desc
);
8272 /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
8273 deallocated if expr is an array of different shape or any of the
8274 corresponding length type parameter values of variable and expr
8275 differ." This assures F95 compatibility. */
8276 jump_label1
= gfc_build_label_decl (NULL_TREE
);
8277 jump_label2
= gfc_build_label_decl (NULL_TREE
);
8279 /* Allocate if data is NULL. */
8280 cond_null
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
8281 array1
, build_int_cst (TREE_TYPE (array1
), 0));
8282 tmp
= build3_v (COND_EXPR
, cond_null
,
8283 build1_v (GOTO_EXPR
, jump_label1
),
8284 build_empty_stmt (input_location
));
8285 gfc_add_expr_to_block (&fblock
, tmp
);
8287 /* Get arrayspec if expr is a full array. */
8288 if (expr2
&& expr2
->expr_type
== EXPR_FUNCTION
8289 && expr2
->value
.function
.isym
8290 && expr2
->value
.function
.isym
->conversion
)
8292 /* For conversion functions, take the arg. */
8293 gfc_expr
*arg
= expr2
->value
.function
.actual
->expr
;
8294 as
= gfc_get_full_arrayspec_from_expr (arg
);
8297 as
= gfc_get_full_arrayspec_from_expr (expr2
);
8301 /* If the lhs shape is not the same as the rhs jump to setting the
8302 bounds and doing the reallocation....... */
8303 for (n
= 0; n
< expr1
->rank
; n
++)
8305 /* Check the shape. */
8306 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
8307 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
8308 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8309 gfc_array_index_type
,
8310 loop
->to
[n
], loop
->from
[n
]);
8311 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8312 gfc_array_index_type
,
8314 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8315 gfc_array_index_type
,
8317 cond
= fold_build2_loc (input_location
, NE_EXPR
,
8319 tmp
, gfc_index_zero_node
);
8320 tmp
= build3_v (COND_EXPR
, cond
,
8321 build1_v (GOTO_EXPR
, jump_label1
),
8322 build_empty_stmt (input_location
));
8323 gfc_add_expr_to_block (&fblock
, tmp
);
8326 /* ....else jump past the (re)alloc code. */
8327 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
8328 gfc_add_expr_to_block (&fblock
, tmp
);
8330 /* Add the label to start automatic (re)allocation. */
8331 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
8332 gfc_add_expr_to_block (&fblock
, tmp
);
8334 /* If the lhs has not been allocated, its bounds will not have been
8335 initialized and so its size is set to zero. */
8336 size1
= gfc_create_var (gfc_array_index_type
, NULL
);
8337 gfc_init_block (&alloc_block
);
8338 gfc_add_modify (&alloc_block
, size1
, gfc_index_zero_node
);
8339 gfc_init_block (&realloc_block
);
8340 gfc_add_modify (&realloc_block
, size1
,
8341 gfc_conv_descriptor_size (desc
, expr1
->rank
));
8342 tmp
= build3_v (COND_EXPR
, cond_null
,
8343 gfc_finish_block (&alloc_block
),
8344 gfc_finish_block (&realloc_block
));
8345 gfc_add_expr_to_block (&fblock
, tmp
);
8347 /* Get the rhs size and fix it. */
8349 desc2
= rss
->info
->data
.array
.descriptor
;
8353 size2
= gfc_index_one_node
;
8354 for (n
= 0; n
< expr2
->rank
; n
++)
8356 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8357 gfc_array_index_type
,
8358 loop
->to
[n
], loop
->from
[n
]);
8359 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8360 gfc_array_index_type
,
8361 tmp
, gfc_index_one_node
);
8362 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
8363 gfc_array_index_type
,
8366 size2
= gfc_evaluate_now (size2
, &fblock
);
8368 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
8370 neq_size
= gfc_evaluate_now (cond
, &fblock
);
8372 /* Deallocation of allocatable components will have to occur on
8373 reallocation. Fix the old descriptor now. */
8374 if ((expr1
->ts
.type
== BT_DERIVED
)
8375 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
8376 old_desc
= gfc_evaluate_now (desc
, &fblock
);
8378 old_desc
= NULL_TREE
;
8380 /* Now modify the lhs descriptor and the associated scalarizer
8381 variables. F2003 7.4.1.3: "If variable is or becomes an
8382 unallocated allocatable variable, then it is allocated with each
8383 deferred type parameter equal to the corresponding type parameters
8384 of expr , with the shape of expr , and with each lower bound equal
8385 to the corresponding element of LBOUND(expr)."
8386 Reuse size1 to keep a dimension-by-dimension track of the
8387 stride of the new array. */
8388 size1
= gfc_index_one_node
;
8389 offset
= gfc_index_zero_node
;
8391 for (n
= 0; n
< expr2
->rank
; n
++)
8393 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8394 gfc_array_index_type
,
8395 loop
->to
[n
], loop
->from
[n
]);
8396 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8397 gfc_array_index_type
,
8398 tmp
, gfc_index_one_node
);
8400 lbound
= gfc_index_one_node
;
8405 lbd
= get_std_lbound (expr2
, desc2
, n
,
8406 as
->type
== AS_ASSUMED_SIZE
);
8407 ubound
= fold_build2_loc (input_location
,
8409 gfc_array_index_type
,
8411 ubound
= fold_build2_loc (input_location
,
8413 gfc_array_index_type
,
8418 gfc_conv_descriptor_lbound_set (&fblock
, desc
,
8421 gfc_conv_descriptor_ubound_set (&fblock
, desc
,
8424 gfc_conv_descriptor_stride_set (&fblock
, desc
,
8427 lbound
= gfc_conv_descriptor_lbound_get (desc
,
8429 tmp2
= fold_build2_loc (input_location
, MULT_EXPR
,
8430 gfc_array_index_type
,
8432 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
8433 gfc_array_index_type
,
8435 size1
= fold_build2_loc (input_location
, MULT_EXPR
,
8436 gfc_array_index_type
,
8440 /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
8441 the array offset is saved and the info.offset is used for a
8442 running offset. Use the saved_offset instead. */
8443 tmp
= gfc_conv_descriptor_offset (desc
);
8444 gfc_add_modify (&fblock
, tmp
, offset
);
8445 if (linfo
->saved_offset
8446 && TREE_CODE (linfo
->saved_offset
) == VAR_DECL
)
8447 gfc_add_modify (&fblock
, linfo
->saved_offset
, tmp
);
8449 /* Now set the deltas for the lhs. */
8450 for (n
= 0; n
< expr1
->rank
; n
++)
8452 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
8454 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8455 gfc_array_index_type
, tmp
,
8457 if (linfo
->delta
[dim
]
8458 && TREE_CODE (linfo
->delta
[dim
]) == VAR_DECL
)
8459 gfc_add_modify (&fblock
, linfo
->delta
[dim
], tmp
);
8462 /* Get the new lhs size in bytes. */
8463 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
8465 if (expr2
->ts
.deferred
)
8467 if (TREE_CODE (expr2
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
8468 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
8470 tmp
= rss
->info
->string_length
;
8474 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
8475 tmp
= fold_convert (TREE_TYPE (expr1
->ts
.u
.cl
->backend_decl
), tmp
);
8478 if (expr1
->ts
.u
.cl
->backend_decl
8479 && TREE_CODE (expr1
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
8480 gfc_add_modify (&fblock
, expr1
->ts
.u
.cl
->backend_decl
, tmp
);
8482 gfc_add_modify (&fblock
, lss
->info
->string_length
, tmp
);
8484 else if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.u
.cl
->backend_decl
)
8486 tmp
= TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
)));
8487 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8488 gfc_array_index_type
, tmp
,
8489 expr1
->ts
.u
.cl
->backend_decl
);
8492 tmp
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
8493 tmp
= fold_convert (gfc_array_index_type
, tmp
);
8494 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
8495 gfc_array_index_type
,
8497 size2
= fold_convert (size_type_node
, size2
);
8498 size2
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
8499 size2
, size_one_node
);
8500 size2
= gfc_evaluate_now (size2
, &fblock
);
8502 /* Realloc expression. Note that the scalarizer uses desc.data
8503 in the array reference - (*desc.data)[<element>]. */
8504 gfc_init_block (&realloc_block
);
8506 if ((expr1
->ts
.type
== BT_DERIVED
)
8507 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
8509 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, old_desc
,
8511 gfc_add_expr_to_block (&realloc_block
, tmp
);
8514 tmp
= build_call_expr_loc (input_location
,
8515 builtin_decl_explicit (BUILT_IN_REALLOC
), 2,
8516 fold_convert (pvoid_type_node
, array1
),
8518 gfc_conv_descriptor_data_set (&realloc_block
,
8521 if ((expr1
->ts
.type
== BT_DERIVED
)
8522 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
8524 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, desc
,
8526 gfc_add_expr_to_block (&realloc_block
, tmp
);
8529 realloc_expr
= gfc_finish_block (&realloc_block
);
8531 /* Only reallocate if sizes are different. */
8532 tmp
= build3_v (COND_EXPR
, neq_size
, realloc_expr
,
8533 build_empty_stmt (input_location
));
8537 /* Malloc expression. */
8538 gfc_init_block (&alloc_block
);
8539 tmp
= build_call_expr_loc (input_location
,
8540 builtin_decl_explicit (BUILT_IN_MALLOC
),
8542 gfc_conv_descriptor_data_set (&alloc_block
,
8544 tmp
= gfc_conv_descriptor_dtype (desc
);
8545 gfc_add_modify (&alloc_block
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
8546 if ((expr1
->ts
.type
== BT_DERIVED
)
8547 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
8549 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, desc
,
8551 gfc_add_expr_to_block (&alloc_block
, tmp
);
8553 alloc_expr
= gfc_finish_block (&alloc_block
);
8555 /* Malloc if not allocated; realloc otherwise. */
8556 tmp
= build_int_cst (TREE_TYPE (array1
), 0);
8557 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
8560 tmp
= build3_v (COND_EXPR
, cond
, alloc_expr
, realloc_expr
);
8561 gfc_add_expr_to_block (&fblock
, tmp
);
8563 /* Make sure that the scalarizer data pointer is updated. */
8565 && TREE_CODE (linfo
->data
) == VAR_DECL
)
8567 tmp
= gfc_conv_descriptor_data_get (desc
);
8568 gfc_add_modify (&fblock
, linfo
->data
, tmp
);
8571 /* Add the exit label. */
8572 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
8573 gfc_add_expr_to_block (&fblock
, tmp
);
8575 return gfc_finish_block (&fblock
);
8579 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
8580 Do likewise, recursively if necessary, with the allocatable components of
8584 gfc_trans_deferred_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
8590 stmtblock_t cleanup
;
8593 bool sym_has_alloc_comp
, has_finalizer
;
8595 sym_has_alloc_comp
= (sym
->ts
.type
== BT_DERIVED
8596 || sym
->ts
.type
== BT_CLASS
)
8597 && sym
->ts
.u
.derived
->attr
.alloc_comp
;
8598 has_finalizer
= sym
->ts
.type
== BT_CLASS
|| sym
->ts
.type
== BT_DERIVED
8599 ? gfc_is_finalizable (sym
->ts
.u
.derived
, NULL
) : false;
8601 /* Make sure the frontend gets these right. */
8602 gcc_assert (sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym_has_alloc_comp
8605 gfc_save_backend_locus (&loc
);
8606 gfc_set_backend_locus (&sym
->declared_at
);
8607 gfc_init_block (&init
);
8609 gcc_assert (TREE_CODE (sym
->backend_decl
) == VAR_DECL
8610 || TREE_CODE (sym
->backend_decl
) == PARM_DECL
);
8612 if (sym
->ts
.type
== BT_CHARACTER
8613 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
8615 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
8616 gfc_trans_vla_type_sizes (sym
, &init
);
8619 /* Dummy, use associated and result variables don't need anything special. */
8620 if (sym
->attr
.dummy
|| sym
->attr
.use_assoc
|| sym
->attr
.result
)
8622 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
8623 gfc_restore_backend_locus (&loc
);
8627 descriptor
= sym
->backend_decl
;
8629 /* Although static, derived types with default initializers and
8630 allocatable components must not be nulled wholesale; instead they
8631 are treated component by component. */
8632 if (TREE_STATIC (descriptor
) && !sym_has_alloc_comp
&& !has_finalizer
)
8634 /* SAVEd variables are not freed on exit. */
8635 gfc_trans_static_array_pointer (sym
);
8637 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
8638 gfc_restore_backend_locus (&loc
);
8642 /* Get the descriptor type. */
8643 type
= TREE_TYPE (sym
->backend_decl
);
8645 if ((sym_has_alloc_comp
|| (has_finalizer
&& sym
->ts
.type
!= BT_CLASS
))
8646 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
8649 && !(TREE_STATIC (sym
->backend_decl
) && sym
->attr
.is_main_program
))
8651 if (sym
->value
== NULL
8652 || !gfc_has_default_initializer (sym
->ts
.u
.derived
))
8654 rank
= sym
->as
? sym
->as
->rank
: 0;
8655 tmp
= gfc_nullify_alloc_comp (sym
->ts
.u
.derived
,
8657 gfc_add_expr_to_block (&init
, tmp
);
8660 gfc_init_default_dt (sym
, &init
, false);
8663 else if (!GFC_DESCRIPTOR_TYPE_P (type
))
8665 /* If the backend_decl is not a descriptor, we must have a pointer
8667 descriptor
= build_fold_indirect_ref_loc (input_location
,
8669 type
= TREE_TYPE (descriptor
);
8672 /* NULLIFY the data pointer, for non-saved allocatables. */
8673 if (GFC_DESCRIPTOR_TYPE_P (type
) && !sym
->attr
.save
&& sym
->attr
.allocatable
)
8674 gfc_conv_descriptor_data_set (&init
, descriptor
, null_pointer_node
);
8676 gfc_restore_backend_locus (&loc
);
8677 gfc_init_block (&cleanup
);
8679 /* Allocatable arrays need to be freed when they go out of scope.
8680 The allocatable components of pointers must not be touched. */
8681 if (!sym
->attr
.allocatable
&& has_finalizer
&& sym
->ts
.type
!= BT_CLASS
8682 && !sym
->attr
.pointer
&& !sym
->attr
.artificial
&& !sym
->attr
.save
8683 && !sym
->ns
->proc_name
->attr
.is_main_program
)
8686 sym
->attr
.referenced
= 1;
8687 e
= gfc_lval_expr_from_sym (sym
);
8688 gfc_add_finalizer_call (&cleanup
, e
);
8691 else if ((!sym
->attr
.allocatable
|| !has_finalizer
)
8692 && sym_has_alloc_comp
&& !(sym
->attr
.function
|| sym
->attr
.result
)
8693 && !sym
->attr
.pointer
&& !sym
->attr
.save
8694 && !sym
->ns
->proc_name
->attr
.is_main_program
)
8697 rank
= sym
->as
? sym
->as
->rank
: 0;
8698 tmp
= gfc_deallocate_alloc_comp (sym
->ts
.u
.derived
, descriptor
, rank
);
8699 gfc_add_expr_to_block (&cleanup
, tmp
);
8702 if (sym
->attr
.allocatable
&& (sym
->attr
.dimension
|| sym
->attr
.codimension
)
8703 && !sym
->attr
.save
&& !sym
->attr
.result
8704 && !sym
->ns
->proc_name
->attr
.is_main_program
)
8707 e
= has_finalizer
? gfc_lval_expr_from_sym (sym
) : NULL
;
8708 tmp
= gfc_trans_dealloc_allocated (sym
->backend_decl
,
8709 sym
->attr
.codimension
, e
);
8712 gfc_add_expr_to_block (&cleanup
, tmp
);
8715 gfc_add_init_cleanup (block
, gfc_finish_block (&init
),
8716 gfc_finish_block (&cleanup
));
8719 /************ Expression Walking Functions ******************/
8721 /* Walk a variable reference.
8723 Possible extension - multiple component subscripts.
8724 x(:,:) = foo%a(:)%b(:)
8726 forall (i=..., j=...)
8727 x(i,j) = foo%a(j)%b(i)
8729 This adds a fair amount of complexity because you need to deal with more
8730 than one ref. Maybe handle in a similar manner to vector subscripts.
8731 Maybe not worth the effort. */
8735 gfc_walk_variable_expr (gfc_ss
* ss
, gfc_expr
* expr
)
8739 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
8740 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
8743 return gfc_walk_array_ref (ss
, expr
, ref
);
8748 gfc_walk_array_ref (gfc_ss
* ss
, gfc_expr
* expr
, gfc_ref
* ref
)
8754 for (; ref
; ref
= ref
->next
)
8756 if (ref
->type
== REF_SUBSTRING
)
8758 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.start
);
8759 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.end
);
8762 /* We're only interested in array sections from now on. */
8763 if (ref
->type
!= REF_ARRAY
)
8771 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
8772 ss
= gfc_get_scalar_ss (ss
, ar
->start
[n
]);
8776 newss
= gfc_get_array_ss (ss
, expr
, ar
->as
->rank
, GFC_SS_SECTION
);
8777 newss
->info
->data
.array
.ref
= ref
;
8779 /* Make sure array is the same as array(:,:), this way
8780 we don't need to special case all the time. */
8781 ar
->dimen
= ar
->as
->rank
;
8782 for (n
= 0; n
< ar
->dimen
; n
++)
8784 ar
->dimen_type
[n
] = DIMEN_RANGE
;
8786 gcc_assert (ar
->start
[n
] == NULL
);
8787 gcc_assert (ar
->end
[n
] == NULL
);
8788 gcc_assert (ar
->stride
[n
] == NULL
);
8794 newss
= gfc_get_array_ss (ss
, expr
, 0, GFC_SS_SECTION
);
8795 newss
->info
->data
.array
.ref
= ref
;
8797 /* We add SS chains for all the subscripts in the section. */
8798 for (n
= 0; n
< ar
->dimen
; n
++)
8802 switch (ar
->dimen_type
[n
])
8805 /* Add SS for elemental (scalar) subscripts. */
8806 gcc_assert (ar
->start
[n
]);
8807 indexss
= gfc_get_scalar_ss (gfc_ss_terminator
, ar
->start
[n
]);
8808 indexss
->loop_chain
= gfc_ss_terminator
;
8809 newss
->info
->data
.array
.subscript
[n
] = indexss
;
8813 /* We don't add anything for sections, just remember this
8814 dimension for later. */
8815 newss
->dim
[newss
->dimen
] = n
;
8820 /* Create a GFC_SS_VECTOR index in which we can store
8821 the vector's descriptor. */
8822 indexss
= gfc_get_array_ss (gfc_ss_terminator
, ar
->start
[n
],
8824 indexss
->loop_chain
= gfc_ss_terminator
;
8825 newss
->info
->data
.array
.subscript
[n
] = indexss
;
8826 newss
->dim
[newss
->dimen
] = n
;
8831 /* We should know what sort of section it is by now. */
8835 /* We should have at least one non-elemental dimension,
8836 unless we are creating a descriptor for a (scalar) coarray. */
8837 gcc_assert (newss
->dimen
> 0
8838 || newss
->info
->data
.array
.ref
->u
.ar
.as
->corank
> 0);
8843 /* We should know what sort of section it is by now. */
8852 /* Walk an expression operator. If only one operand of a binary expression is
8853 scalar, we must also add the scalar term to the SS chain. */
8856 gfc_walk_op_expr (gfc_ss
* ss
, gfc_expr
* expr
)
8861 head
= gfc_walk_subexpr (ss
, expr
->value
.op
.op1
);
8862 if (expr
->value
.op
.op2
== NULL
)
8865 head2
= gfc_walk_subexpr (head
, expr
->value
.op
.op2
);
8867 /* All operands are scalar. Pass back and let the caller deal with it. */
8871 /* All operands require scalarization. */
8872 if (head
!= ss
&& (expr
->value
.op
.op2
== NULL
|| head2
!= head
))
8875 /* One of the operands needs scalarization, the other is scalar.
8876 Create a gfc_ss for the scalar expression. */
8879 /* First operand is scalar. We build the chain in reverse order, so
8880 add the scalar SS after the second operand. */
8882 while (head
&& head
->next
!= ss
)
8884 /* Check we haven't somehow broken the chain. */
8886 head
->next
= gfc_get_scalar_ss (ss
, expr
->value
.op
.op1
);
8888 else /* head2 == head */
8890 gcc_assert (head2
== head
);
8891 /* Second operand is scalar. */
8892 head2
= gfc_get_scalar_ss (head2
, expr
->value
.op
.op2
);
8899 /* Reverse a SS chain. */
8902 gfc_reverse_ss (gfc_ss
* ss
)
8907 gcc_assert (ss
!= NULL
);
8909 head
= gfc_ss_terminator
;
8910 while (ss
!= gfc_ss_terminator
)
8913 /* Check we didn't somehow break the chain. */
8914 gcc_assert (next
!= NULL
);
8924 /* Given an expression referring to a procedure, return the symbol of its
8925 interface. We can't get the procedure symbol directly as we have to handle
8926 the case of (deferred) type-bound procedures. */
8929 gfc_get_proc_ifc_for_expr (gfc_expr
*procedure_ref
)
8934 if (procedure_ref
== NULL
)
8937 /* Normal procedure case. */
8938 sym
= procedure_ref
->symtree
->n
.sym
;
8940 /* Typebound procedure case. */
8941 for (ref
= procedure_ref
->ref
; ref
; ref
= ref
->next
)
8943 if (ref
->type
== REF_COMPONENT
8944 && ref
->u
.c
.component
->attr
.proc_pointer
)
8945 sym
= ref
->u
.c
.component
->ts
.interface
;
8954 /* Walk the arguments of an elemental function.
8955 PROC_EXPR is used to check whether an argument is permitted to be absent. If
8956 it is NULL, we don't do the check and the argument is assumed to be present.
8960 gfc_walk_elemental_function_args (gfc_ss
* ss
, gfc_actual_arglist
*arg
,
8961 gfc_symbol
*proc_ifc
, gfc_ss_type type
)
8963 gfc_formal_arglist
*dummy_arg
;
8969 head
= gfc_ss_terminator
;
8973 dummy_arg
= gfc_sym_get_dummy_args (proc_ifc
);
8978 for (; arg
; arg
= arg
->next
)
8980 if (!arg
->expr
|| arg
->expr
->expr_type
== EXPR_NULL
)
8983 newss
= gfc_walk_subexpr (head
, arg
->expr
);
8986 /* Scalar argument. */
8987 gcc_assert (type
== GFC_SS_SCALAR
|| type
== GFC_SS_REFERENCE
);
8988 newss
= gfc_get_scalar_ss (head
, arg
->expr
);
8989 newss
->info
->type
= type
;
8995 if (dummy_arg
!= NULL
8996 && dummy_arg
->sym
->attr
.optional
8997 && arg
->expr
->expr_type
== EXPR_VARIABLE
8998 && (gfc_expr_attr (arg
->expr
).optional
8999 || gfc_expr_attr (arg
->expr
).allocatable
9000 || gfc_expr_attr (arg
->expr
).pointer
))
9001 newss
->info
->can_be_null_ref
= true;
9007 while (tail
->next
!= gfc_ss_terminator
)
9011 if (dummy_arg
!= NULL
)
9012 dummy_arg
= dummy_arg
->next
;
9017 /* If all the arguments are scalar we don't need the argument SS. */
9018 gfc_free_ss_chain (head
);
9023 /* Add it onto the existing chain. */
9029 /* Walk a function call. Scalar functions are passed back, and taken out of
9030 scalarization loops. For elemental functions we walk their arguments.
9031 The result of functions returning arrays is stored in a temporary outside
9032 the loop, so that the function is only called once. Hence we do not need
9033 to walk their arguments. */
9036 gfc_walk_function_expr (gfc_ss
* ss
, gfc_expr
* expr
)
9038 gfc_intrinsic_sym
*isym
;
9040 gfc_component
*comp
= NULL
;
9042 isym
= expr
->value
.function
.isym
;
9044 /* Handle intrinsic functions separately. */
9046 return gfc_walk_intrinsic_function (ss
, expr
, isym
);
9048 sym
= expr
->value
.function
.esym
;
9050 sym
= expr
->symtree
->n
.sym
;
9052 /* A function that returns arrays. */
9053 comp
= gfc_get_proc_ptr_comp (expr
);
9054 if ((!comp
&& gfc_return_by_reference (sym
) && sym
->result
->attr
.dimension
)
9055 || (comp
&& comp
->attr
.dimension
))
9056 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
9058 /* Walk the parameters of an elemental function. For now we always pass
9060 if (sym
->attr
.elemental
|| (comp
&& comp
->attr
.elemental
))
9061 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
9062 gfc_get_proc_ifc_for_expr (expr
),
9065 /* Scalar functions are OK as these are evaluated outside the scalarization
9066 loop. Pass back and let the caller deal with it. */
9071 /* An array temporary is constructed for array constructors. */
9074 gfc_walk_array_constructor (gfc_ss
* ss
, gfc_expr
* expr
)
9076 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_CONSTRUCTOR
);
9080 /* Walk an expression. Add walked expressions to the head of the SS chain.
9081 A wholly scalar expression will not be added. */
9084 gfc_walk_subexpr (gfc_ss
* ss
, gfc_expr
* expr
)
9088 switch (expr
->expr_type
)
9091 head
= gfc_walk_variable_expr (ss
, expr
);
9095 head
= gfc_walk_op_expr (ss
, expr
);
9099 head
= gfc_walk_function_expr (ss
, expr
);
9104 case EXPR_STRUCTURE
:
9105 /* Pass back and let the caller deal with it. */
9109 head
= gfc_walk_array_constructor (ss
, expr
);
9112 case EXPR_SUBSTRING
:
9113 /* Pass back and let the caller deal with it. */
9117 gfc_internal_error ("bad expression type during walk (%d)",
9124 /* Entry point for expression walking.
9125 A return value equal to the passed chain means this is
9126 a scalar expression. It is up to the caller to take whatever action is
9127 necessary to translate these. */
9130 gfc_walk_expr (gfc_expr
* expr
)
9134 res
= gfc_walk_subexpr (gfc_ss_terminator
, expr
);
9135 return gfc_reverse_ss (res
);