1 /* Array translation routines
2 Copyright (C) 2002-2017 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"
84 #include "gimple-expr.h"
86 #include "fold-const.h"
87 #include "constructor.h"
88 #include "trans-types.h"
89 #include "trans-array.h"
90 #include "trans-const.h"
91 #include "dependency.h"
93 static bool gfc_get_array_constructor_size (mpz_t
*, gfc_constructor_base
);
95 /* The contents of this structure aren't actually used, just the address. */
96 static gfc_ss gfc_ss_terminator_var
;
97 gfc_ss
* const gfc_ss_terminator
= &gfc_ss_terminator_var
;
101 gfc_array_dataptr_type (tree desc
)
103 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
)));
107 /* Build expressions to access the members of an array descriptor.
108 It's surprisingly easy to mess up here, so never access
109 an array descriptor by "brute force", always use these
110 functions. This also avoids problems if we change the format
111 of an array descriptor.
113 To understand these magic numbers, look at the comments
114 before gfc_build_array_type() in trans-types.c.
116 The code within these defines should be the only code which knows the format
117 of an array descriptor.
119 Any code just needing to read obtain the bounds of an array should use
120 gfc_conv_array_* rather than the following functions as these will return
121 know constant values, and work with arrays which do not have descriptors.
123 Don't forget to #undef these! */
126 #define OFFSET_FIELD 1
127 #define DTYPE_FIELD 2
128 #define DIMENSION_FIELD 3
129 #define CAF_TOKEN_FIELD 4
131 #define STRIDE_SUBFIELD 0
132 #define LBOUND_SUBFIELD 1
133 #define UBOUND_SUBFIELD 2
135 /* This provides READ-ONLY access to the data field. The field itself
136 doesn't have the proper type. */
139 gfc_conv_descriptor_data_get (tree desc
)
143 type
= TREE_TYPE (desc
);
144 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
146 field
= TYPE_FIELDS (type
);
147 gcc_assert (DATA_FIELD
== 0);
149 t
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
), desc
,
151 t
= fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type
), t
);
156 /* This provides WRITE access to the data field.
158 TUPLES_P is true if we are generating tuples.
160 This function gets called through the following macros:
161 gfc_conv_descriptor_data_set
162 gfc_conv_descriptor_data_set. */
165 gfc_conv_descriptor_data_set (stmtblock_t
*block
, tree desc
, tree value
)
169 type
= TREE_TYPE (desc
);
170 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
172 field
= TYPE_FIELDS (type
);
173 gcc_assert (DATA_FIELD
== 0);
175 t
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
), desc
,
177 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (field
), value
));
181 /* This provides address access to the data field. This should only be
182 used by array allocation, passing this on to the runtime. */
185 gfc_conv_descriptor_data_addr (tree desc
)
189 type
= TREE_TYPE (desc
);
190 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
192 field
= TYPE_FIELDS (type
);
193 gcc_assert (DATA_FIELD
== 0);
195 t
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
), desc
,
197 return gfc_build_addr_expr (NULL_TREE
, t
);
201 gfc_conv_descriptor_offset (tree desc
)
206 type
= TREE_TYPE (desc
);
207 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
209 field
= gfc_advance_chain (TYPE_FIELDS (type
), OFFSET_FIELD
);
210 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
212 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
213 desc
, field
, NULL_TREE
);
217 gfc_conv_descriptor_offset_get (tree desc
)
219 return gfc_conv_descriptor_offset (desc
);
223 gfc_conv_descriptor_offset_set (stmtblock_t
*block
, tree desc
,
226 tree t
= gfc_conv_descriptor_offset (desc
);
227 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
232 gfc_conv_descriptor_dtype (tree desc
)
237 type
= TREE_TYPE (desc
);
238 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
240 field
= gfc_advance_chain (TYPE_FIELDS (type
), DTYPE_FIELD
);
241 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
243 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
244 desc
, field
, NULL_TREE
);
249 gfc_conv_descriptor_rank (tree desc
)
254 dtype
= gfc_conv_descriptor_dtype (desc
);
255 tmp
= build_int_cst (TREE_TYPE (dtype
), GFC_DTYPE_RANK_MASK
);
256 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, TREE_TYPE (dtype
),
258 return fold_convert (gfc_get_int_type (gfc_default_integer_kind
), tmp
);
263 gfc_get_descriptor_dimension (tree desc
)
267 type
= TREE_TYPE (desc
);
268 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
270 field
= gfc_advance_chain (TYPE_FIELDS (type
), DIMENSION_FIELD
);
271 gcc_assert (field
!= NULL_TREE
272 && TREE_CODE (TREE_TYPE (field
)) == ARRAY_TYPE
273 && TREE_CODE (TREE_TYPE (TREE_TYPE (field
))) == RECORD_TYPE
);
275 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
276 desc
, field
, NULL_TREE
);
281 gfc_conv_descriptor_dimension (tree desc
, tree dim
)
285 tmp
= gfc_get_descriptor_dimension (desc
);
287 return gfc_build_array_ref (tmp
, dim
, NULL
);
292 gfc_conv_descriptor_token (tree desc
)
297 type
= TREE_TYPE (desc
);
298 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
299 gcc_assert (flag_coarray
== GFC_FCOARRAY_LIB
);
300 field
= gfc_advance_chain (TYPE_FIELDS (type
), CAF_TOKEN_FIELD
);
302 /* Should be a restricted pointer - except in the finalization wrapper. */
303 gcc_assert (field
!= NULL_TREE
304 && (TREE_TYPE (field
) == prvoid_type_node
305 || TREE_TYPE (field
) == pvoid_type_node
));
307 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
308 desc
, field
, NULL_TREE
);
313 gfc_conv_descriptor_stride (tree desc
, tree dim
)
318 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
319 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
320 field
= gfc_advance_chain (field
, STRIDE_SUBFIELD
);
321 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
323 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
324 tmp
, field
, NULL_TREE
);
329 gfc_conv_descriptor_stride_get (tree desc
, tree dim
)
331 tree type
= TREE_TYPE (desc
);
332 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
333 if (integer_zerop (dim
)
334 && (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ALLOCATABLE
335 ||GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE_CONT
336 ||GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_RANK_CONT
337 ||GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER_CONT
))
338 return gfc_index_one_node
;
340 return gfc_conv_descriptor_stride (desc
, dim
);
344 gfc_conv_descriptor_stride_set (stmtblock_t
*block
, tree desc
,
345 tree dim
, tree value
)
347 tree t
= gfc_conv_descriptor_stride (desc
, dim
);
348 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
352 gfc_conv_descriptor_lbound (tree desc
, tree dim
)
357 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
358 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
359 field
= gfc_advance_chain (field
, LBOUND_SUBFIELD
);
360 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
362 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
363 tmp
, field
, NULL_TREE
);
368 gfc_conv_descriptor_lbound_get (tree desc
, tree dim
)
370 return gfc_conv_descriptor_lbound (desc
, dim
);
374 gfc_conv_descriptor_lbound_set (stmtblock_t
*block
, tree desc
,
375 tree dim
, tree value
)
377 tree t
= gfc_conv_descriptor_lbound (desc
, dim
);
378 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
382 gfc_conv_descriptor_ubound (tree desc
, tree dim
)
387 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
388 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
389 field
= gfc_advance_chain (field
, UBOUND_SUBFIELD
);
390 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
392 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
393 tmp
, field
, NULL_TREE
);
398 gfc_conv_descriptor_ubound_get (tree desc
, tree dim
)
400 return gfc_conv_descriptor_ubound (desc
, dim
);
404 gfc_conv_descriptor_ubound_set (stmtblock_t
*block
, tree desc
,
405 tree dim
, tree value
)
407 tree t
= gfc_conv_descriptor_ubound (desc
, dim
);
408 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
411 /* Build a null array descriptor constructor. */
414 gfc_build_null_descriptor (tree type
)
419 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
420 gcc_assert (DATA_FIELD
== 0);
421 field
= TYPE_FIELDS (type
);
423 /* Set a NULL data pointer. */
424 tmp
= build_constructor_single (type
, field
, null_pointer_node
);
425 TREE_CONSTANT (tmp
) = 1;
426 /* All other fields are ignored. */
432 /* Modify a descriptor such that the lbound of a given dimension is the value
433 specified. This also updates ubound and offset accordingly. */
436 gfc_conv_shift_descriptor_lbound (stmtblock_t
* block
, tree desc
,
437 int dim
, tree new_lbound
)
439 tree offs
, ubound
, lbound
, stride
;
440 tree diff
, offs_diff
;
442 new_lbound
= fold_convert (gfc_array_index_type
, new_lbound
);
444 offs
= gfc_conv_descriptor_offset_get (desc
);
445 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]);
446 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]);
447 stride
= gfc_conv_descriptor_stride_get (desc
, gfc_rank_cst
[dim
]);
449 /* Get difference (new - old) by which to shift stuff. */
450 diff
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
453 /* Shift ubound and offset accordingly. This has to be done before
454 updating the lbound, as they depend on the lbound expression! */
455 ubound
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
457 gfc_conv_descriptor_ubound_set (block
, desc
, gfc_rank_cst
[dim
], ubound
);
458 offs_diff
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
460 offs
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
462 gfc_conv_descriptor_offset_set (block
, desc
, offs
);
464 /* Finally set lbound to value we want. */
465 gfc_conv_descriptor_lbound_set (block
, desc
, gfc_rank_cst
[dim
], new_lbound
);
469 /* Cleanup those #defines. */
474 #undef DIMENSION_FIELD
475 #undef CAF_TOKEN_FIELD
476 #undef STRIDE_SUBFIELD
477 #undef LBOUND_SUBFIELD
478 #undef UBOUND_SUBFIELD
481 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
482 flags & 1 = Main loop body.
483 flags & 2 = temp copy loop. */
486 gfc_mark_ss_chain_used (gfc_ss
* ss
, unsigned flags
)
488 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
489 ss
->info
->useflags
= flags
;
493 /* Free a gfc_ss chain. */
496 gfc_free_ss_chain (gfc_ss
* ss
)
500 while (ss
!= gfc_ss_terminator
)
502 gcc_assert (ss
!= NULL
);
511 free_ss_info (gfc_ss_info
*ss_info
)
516 if (ss_info
->refcount
> 0)
519 gcc_assert (ss_info
->refcount
== 0);
521 switch (ss_info
->type
)
524 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
525 if (ss_info
->data
.array
.subscript
[n
])
526 gfc_free_ss_chain (ss_info
->data
.array
.subscript
[n
]);
540 gfc_free_ss (gfc_ss
* ss
)
542 free_ss_info (ss
->info
);
547 /* Creates and initializes an array type gfc_ss struct. */
550 gfc_get_array_ss (gfc_ss
*next
, gfc_expr
*expr
, int dimen
, gfc_ss_type type
)
553 gfc_ss_info
*ss_info
;
556 ss_info
= gfc_get_ss_info ();
558 ss_info
->type
= type
;
559 ss_info
->expr
= expr
;
565 for (i
= 0; i
< ss
->dimen
; i
++)
572 /* Creates and initializes a temporary type gfc_ss struct. */
575 gfc_get_temp_ss (tree type
, tree string_length
, int dimen
)
578 gfc_ss_info
*ss_info
;
581 ss_info
= gfc_get_ss_info ();
583 ss_info
->type
= GFC_SS_TEMP
;
584 ss_info
->string_length
= string_length
;
585 ss_info
->data
.temp
.type
= type
;
589 ss
->next
= gfc_ss_terminator
;
591 for (i
= 0; i
< ss
->dimen
; i
++)
598 /* Creates and initializes a scalar type gfc_ss struct. */
601 gfc_get_scalar_ss (gfc_ss
*next
, gfc_expr
*expr
)
604 gfc_ss_info
*ss_info
;
606 ss_info
= gfc_get_ss_info ();
608 ss_info
->type
= GFC_SS_SCALAR
;
609 ss_info
->expr
= expr
;
619 /* Free all the SS associated with a loop. */
622 gfc_cleanup_loop (gfc_loopinfo
* loop
)
624 gfc_loopinfo
*loop_next
, **ploop
;
629 while (ss
!= gfc_ss_terminator
)
631 gcc_assert (ss
!= NULL
);
632 next
= ss
->loop_chain
;
637 /* Remove reference to self in the parent loop. */
639 for (ploop
= &loop
->parent
->nested
; *ploop
; ploop
= &(*ploop
)->next
)
646 /* Free non-freed nested loops. */
647 for (loop
= loop
->nested
; loop
; loop
= loop_next
)
649 loop_next
= loop
->next
;
650 gfc_cleanup_loop (loop
);
657 set_ss_loop (gfc_ss
*ss
, gfc_loopinfo
*loop
)
661 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
665 if (ss
->info
->type
== GFC_SS_SCALAR
666 || ss
->info
->type
== GFC_SS_REFERENCE
667 || ss
->info
->type
== GFC_SS_TEMP
)
670 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
671 if (ss
->info
->data
.array
.subscript
[n
] != NULL
)
672 set_ss_loop (ss
->info
->data
.array
.subscript
[n
], loop
);
677 /* Associate a SS chain with a loop. */
680 gfc_add_ss_to_loop (gfc_loopinfo
* loop
, gfc_ss
* head
)
683 gfc_loopinfo
*nested_loop
;
685 if (head
== gfc_ss_terminator
)
688 set_ss_loop (head
, loop
);
691 for (; ss
&& ss
!= gfc_ss_terminator
; ss
= ss
->next
)
695 nested_loop
= ss
->nested_ss
->loop
;
697 /* More than one ss can belong to the same loop. Hence, we add the
698 loop to the chain only if it is different from the previously
699 added one, to avoid duplicate nested loops. */
700 if (nested_loop
!= loop
->nested
)
702 gcc_assert (nested_loop
->parent
== NULL
);
703 nested_loop
->parent
= loop
;
705 gcc_assert (nested_loop
->next
== NULL
);
706 nested_loop
->next
= loop
->nested
;
707 loop
->nested
= nested_loop
;
710 gcc_assert (nested_loop
->parent
== loop
);
713 if (ss
->next
== gfc_ss_terminator
)
714 ss
->loop_chain
= loop
->ss
;
716 ss
->loop_chain
= ss
->next
;
718 gcc_assert (ss
== gfc_ss_terminator
);
723 /* Generate an initializer for a static pointer or allocatable array. */
726 gfc_trans_static_array_pointer (gfc_symbol
* sym
)
730 gcc_assert (TREE_STATIC (sym
->backend_decl
));
731 /* Just zero the data member. */
732 type
= TREE_TYPE (sym
->backend_decl
);
733 DECL_INITIAL (sym
->backend_decl
) = gfc_build_null_descriptor (type
);
737 /* If the bounds of SE's loop have not yet been set, see if they can be
738 determined from array spec AS, which is the array spec of a called
739 function. MAPPING maps the callee's dummy arguments to the values
740 that the caller is passing. Add any initialization and finalization
744 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping
* mapping
,
745 gfc_se
* se
, gfc_array_spec
* as
)
747 int n
, dim
, total_dim
;
756 if (!as
|| as
->type
!= AS_EXPLICIT
)
759 for (ss
= se
->ss
; ss
; ss
= ss
->parent
)
761 total_dim
+= ss
->loop
->dimen
;
762 for (n
= 0; n
< ss
->loop
->dimen
; n
++)
764 /* The bound is known, nothing to do. */
765 if (ss
->loop
->to
[n
] != NULL_TREE
)
769 gcc_assert (dim
< as
->rank
);
770 gcc_assert (ss
->loop
->dimen
<= as
->rank
);
772 /* Evaluate the lower bound. */
773 gfc_init_se (&tmpse
, NULL
);
774 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->lower
[dim
]);
775 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
776 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
777 lower
= fold_convert (gfc_array_index_type
, tmpse
.expr
);
779 /* ...and the upper bound. */
780 gfc_init_se (&tmpse
, NULL
);
781 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->upper
[dim
]);
782 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
783 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
784 upper
= fold_convert (gfc_array_index_type
, tmpse
.expr
);
786 /* Set the upper bound of the loop to UPPER - LOWER. */
787 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
788 gfc_array_index_type
, upper
, lower
);
789 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
790 ss
->loop
->to
[n
] = tmp
;
794 gcc_assert (total_dim
== as
->rank
);
798 /* Generate code to allocate an array temporary, or create a variable to
799 hold the data. If size is NULL, zero the descriptor so that the
800 callee will allocate the array. If DEALLOC is true, also generate code to
801 free the array afterwards.
803 If INITIAL is not NULL, it is packed using internal_pack and the result used
804 as data instead of allocating a fresh, unitialized area of memory.
806 Initialization code is added to PRE and finalization code to POST.
807 DYNAMIC is true if the caller may want to extend the array later
808 using realloc. This prevents us from putting the array on the stack. */
811 gfc_trans_allocate_array_storage (stmtblock_t
* pre
, stmtblock_t
* post
,
812 gfc_array_info
* info
, tree size
, tree nelem
,
813 tree initial
, bool dynamic
, bool dealloc
)
819 desc
= info
->descriptor
;
820 info
->offset
= gfc_index_zero_node
;
821 if (size
== NULL_TREE
|| integer_zerop (size
))
823 /* A callee allocated array. */
824 gfc_conv_descriptor_data_set (pre
, desc
, null_pointer_node
);
829 /* Allocate the temporary. */
830 onstack
= !dynamic
&& initial
== NULL_TREE
831 && (flag_stack_arrays
832 || gfc_can_put_var_on_stack (size
));
836 /* Make a temporary variable to hold the data. */
837 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (nelem
),
838 nelem
, gfc_index_one_node
);
839 tmp
= gfc_evaluate_now (tmp
, pre
);
840 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
842 tmp
= build_array_type (gfc_get_element_type (TREE_TYPE (desc
)),
844 tmp
= gfc_create_var (tmp
, "A");
845 /* If we're here only because of -fstack-arrays we have to
846 emit a DECL_EXPR to make the gimplifier emit alloca calls. */
847 if (!gfc_can_put_var_on_stack (size
))
848 gfc_add_expr_to_block (pre
,
849 fold_build1_loc (input_location
,
850 DECL_EXPR
, TREE_TYPE (tmp
),
852 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
853 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
857 /* Allocate memory to hold the data or call internal_pack. */
858 if (initial
== NULL_TREE
)
860 tmp
= gfc_call_malloc (pre
, NULL
, size
);
861 tmp
= gfc_evaluate_now (tmp
, pre
);
868 stmtblock_t do_copying
;
870 tmp
= TREE_TYPE (initial
); /* Pointer to descriptor. */
871 gcc_assert (TREE_CODE (tmp
) == POINTER_TYPE
);
872 tmp
= TREE_TYPE (tmp
); /* The descriptor itself. */
873 tmp
= gfc_get_element_type (tmp
);
874 gcc_assert (tmp
== gfc_get_element_type (TREE_TYPE (desc
)));
875 packed
= gfc_create_var (build_pointer_type (tmp
), "data");
877 tmp
= build_call_expr_loc (input_location
,
878 gfor_fndecl_in_pack
, 1, initial
);
879 tmp
= fold_convert (TREE_TYPE (packed
), tmp
);
880 gfc_add_modify (pre
, packed
, tmp
);
882 tmp
= build_fold_indirect_ref_loc (input_location
,
884 source_data
= gfc_conv_descriptor_data_get (tmp
);
886 /* internal_pack may return source->data without any allocation
887 or copying if it is already packed. If that's the case, we
888 need to allocate and copy manually. */
890 gfc_start_block (&do_copying
);
891 tmp
= gfc_call_malloc (&do_copying
, NULL
, size
);
892 tmp
= fold_convert (TREE_TYPE (packed
), tmp
);
893 gfc_add_modify (&do_copying
, packed
, tmp
);
894 tmp
= gfc_build_memcpy_call (packed
, source_data
, size
);
895 gfc_add_expr_to_block (&do_copying
, tmp
);
897 was_packed
= fold_build2_loc (input_location
, EQ_EXPR
,
898 boolean_type_node
, packed
,
900 tmp
= gfc_finish_block (&do_copying
);
901 tmp
= build3_v (COND_EXPR
, was_packed
, tmp
,
902 build_empty_stmt (input_location
));
903 gfc_add_expr_to_block (pre
, tmp
);
905 tmp
= fold_convert (pvoid_type_node
, packed
);
908 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
911 info
->data
= gfc_conv_descriptor_data_get (desc
);
913 /* The offset is zero because we create temporaries with a zero
915 gfc_conv_descriptor_offset_set (pre
, desc
, gfc_index_zero_node
);
917 if (dealloc
&& !onstack
)
919 /* Free the temporary. */
920 tmp
= gfc_conv_descriptor_data_get (desc
);
921 tmp
= gfc_call_free (tmp
);
922 gfc_add_expr_to_block (post
, tmp
);
927 /* Get the scalarizer array dimension corresponding to actual array dimension
930 For example, if SS represents the array ref a(1,:,:,1), it is a
931 bidimensional scalarizer array, and the result would be 0 for ARRAY_DIM=1,
932 and 1 for ARRAY_DIM=2.
933 If SS represents transpose(a(:,1,1,:)), it is again a bidimensional
934 scalarizer array, and the result would be 1 for ARRAY_DIM=0 and 0 for
936 If SS represents sum(a(:,:,:,1), dim=1), it is a 2+1-dimensional scalarizer
937 array. If called on the inner ss, the result would be respectively 0,1,2 for
938 ARRAY_DIM=0,1,2. If called on the outer ss, the result would be 0,1
939 for ARRAY_DIM=1,2. */
942 get_scalarizer_dim_for_array_dim (gfc_ss
*ss
, int array_dim
)
949 for (; ss
; ss
= ss
->parent
)
950 for (n
= 0; n
< ss
->dimen
; n
++)
951 if (ss
->dim
[n
] < array_dim
)
954 return array_ref_dim
;
959 innermost_ss (gfc_ss
*ss
)
961 while (ss
->nested_ss
!= NULL
)
969 /* Get the array reference dimension corresponding to the given loop dimension.
970 It is different from the true array dimension given by the dim array in
971 the case of a partial array reference (i.e. a(:,:,1,:) for example)
972 It is different from the loop dimension in the case of a transposed array.
976 get_array_ref_dim_for_loop_dim (gfc_ss
*ss
, int loop_dim
)
978 return get_scalarizer_dim_for_array_dim (innermost_ss (ss
),
983 /* Generate code to create and initialize the descriptor for a temporary
984 array. This is used for both temporaries needed by the scalarizer, and
985 functions returning arrays. Adjusts the loop variables to be
986 zero-based, and calculates the loop bounds for callee allocated arrays.
987 Allocate the array unless it's callee allocated (we have a callee
988 allocated array if 'callee_alloc' is true, or if loop->to[n] is
989 NULL_TREE for any n). Also fills in the descriptor, data and offset
990 fields of info if known. Returns the size of the array, or NULL for a
991 callee allocated array.
993 'eltype' == NULL signals that the temporary should be a class object.
994 The 'initial' expression is used to obtain the size of the dynamic
995 type; otherwise the allocation and initialization proceeds as for any
998 PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
999 gfc_trans_allocate_array_storage. */
1002 gfc_trans_create_temp_array (stmtblock_t
* pre
, stmtblock_t
* post
, gfc_ss
* ss
,
1003 tree eltype
, tree initial
, bool dynamic
,
1004 bool dealloc
, bool callee_alloc
, locus
* where
)
1008 gfc_array_info
*info
;
1009 tree from
[GFC_MAX_DIMENSIONS
], to
[GFC_MAX_DIMENSIONS
];
1017 tree class_expr
= NULL_TREE
;
1018 int n
, dim
, tmp_dim
;
1021 /* This signals a class array for which we need the size of the
1022 dynamic type. Generate an eltype and then the class expression. */
1023 if (eltype
== NULL_TREE
&& initial
)
1025 gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial
)));
1026 class_expr
= build_fold_indirect_ref_loc (input_location
, initial
);
1027 eltype
= TREE_TYPE (class_expr
);
1028 eltype
= gfc_get_element_type (eltype
);
1029 /* Obtain the structure (class) expression. */
1030 class_expr
= TREE_OPERAND (class_expr
, 0);
1031 gcc_assert (class_expr
);
1034 memset (from
, 0, sizeof (from
));
1035 memset (to
, 0, sizeof (to
));
1037 info
= &ss
->info
->data
.array
;
1039 gcc_assert (ss
->dimen
> 0);
1040 gcc_assert (ss
->loop
->dimen
== ss
->dimen
);
1042 if (warn_array_temporaries
&& where
)
1043 gfc_warning (OPT_Warray_temporaries
,
1044 "Creating array temporary at %L", where
);
1046 /* Set the lower bound to zero. */
1047 for (s
= ss
; s
; s
= s
->parent
)
1051 total_dim
+= loop
->dimen
;
1052 for (n
= 0; n
< loop
->dimen
; n
++)
1056 /* Callee allocated arrays may not have a known bound yet. */
1058 loop
->to
[n
] = gfc_evaluate_now (
1059 fold_build2_loc (input_location
, MINUS_EXPR
,
1060 gfc_array_index_type
,
1061 loop
->to
[n
], loop
->from
[n
]),
1063 loop
->from
[n
] = gfc_index_zero_node
;
1065 /* We have just changed the loop bounds, we must clear the
1066 corresponding specloop, so that delta calculation is not skipped
1067 later in gfc_set_delta. */
1068 loop
->specloop
[n
] = NULL
;
1070 /* We are constructing the temporary's descriptor based on the loop
1071 dimensions. As the dimensions may be accessed in arbitrary order
1072 (think of transpose) the size taken from the n'th loop may not map
1073 to the n'th dimension of the array. We need to reconstruct loop
1074 infos in the right order before using it to set the descriptor
1076 tmp_dim
= get_scalarizer_dim_for_array_dim (ss
, dim
);
1077 from
[tmp_dim
] = loop
->from
[n
];
1078 to
[tmp_dim
] = loop
->to
[n
];
1080 info
->delta
[dim
] = gfc_index_zero_node
;
1081 info
->start
[dim
] = gfc_index_zero_node
;
1082 info
->end
[dim
] = gfc_index_zero_node
;
1083 info
->stride
[dim
] = gfc_index_one_node
;
1087 /* Initialize the descriptor. */
1089 gfc_get_array_type_bounds (eltype
, total_dim
, 0, from
, to
, 1,
1090 GFC_ARRAY_UNKNOWN
, true);
1091 desc
= gfc_create_var (type
, "atmp");
1092 GFC_DECL_PACKED_ARRAY (desc
) = 1;
1094 info
->descriptor
= desc
;
1095 size
= gfc_index_one_node
;
1097 /* Emit a DECL_EXPR for the variable sized array type in
1098 GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
1099 sizes works correctly. */
1100 tree arraytype
= TREE_TYPE (GFC_TYPE_ARRAY_DATAPTR_TYPE (type
));
1101 if (! TYPE_NAME (arraytype
))
1102 TYPE_NAME (arraytype
) = build_decl (UNKNOWN_LOCATION
, TYPE_DECL
,
1103 NULL_TREE
, arraytype
);
1104 gfc_add_expr_to_block (pre
, build1 (DECL_EXPR
,
1105 arraytype
, TYPE_NAME (arraytype
)));
1107 /* Fill in the array dtype. */
1108 tmp
= gfc_conv_descriptor_dtype (desc
);
1109 gfc_add_modify (pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
1112 Fill in the bounds and stride. This is a packed array, so:
1115 for (n = 0; n < rank; n++)
1118 delta = ubound[n] + 1 - lbound[n];
1119 size = size * delta;
1121 size = size * sizeof(element);
1124 or_expr
= NULL_TREE
;
1126 /* If there is at least one null loop->to[n], it is a callee allocated
1128 for (n
= 0; n
< total_dim
; n
++)
1129 if (to
[n
] == NULL_TREE
)
1135 if (size
== NULL_TREE
)
1136 for (s
= ss
; s
; s
= s
->parent
)
1137 for (n
= 0; n
< s
->loop
->dimen
; n
++)
1139 dim
= get_scalarizer_dim_for_array_dim (ss
, s
->dim
[n
]);
1141 /* For a callee allocated array express the loop bounds in terms
1142 of the descriptor fields. */
1143 tmp
= fold_build2_loc (input_location
,
1144 MINUS_EXPR
, gfc_array_index_type
,
1145 gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]),
1146 gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]));
1147 s
->loop
->to
[n
] = tmp
;
1151 for (n
= 0; n
< total_dim
; n
++)
1153 /* Store the stride and bound components in the descriptor. */
1154 gfc_conv_descriptor_stride_set (pre
, desc
, gfc_rank_cst
[n
], size
);
1156 gfc_conv_descriptor_lbound_set (pre
, desc
, gfc_rank_cst
[n
],
1157 gfc_index_zero_node
);
1159 gfc_conv_descriptor_ubound_set (pre
, desc
, gfc_rank_cst
[n
], to
[n
]);
1161 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1162 gfc_array_index_type
,
1163 to
[n
], gfc_index_one_node
);
1165 /* Check whether the size for this dimension is negative. */
1166 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
1167 tmp
, gfc_index_zero_node
);
1168 cond
= gfc_evaluate_now (cond
, pre
);
1173 or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1174 boolean_type_node
, or_expr
, cond
);
1176 size
= fold_build2_loc (input_location
, MULT_EXPR
,
1177 gfc_array_index_type
, size
, tmp
);
1178 size
= gfc_evaluate_now (size
, pre
);
1182 /* Get the size of the array. */
1183 if (size
&& !callee_alloc
)
1186 /* If or_expr is true, then the extent in at least one
1187 dimension is zero and the size is set to zero. */
1188 size
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
1189 or_expr
, gfc_index_zero_node
, size
);
1192 if (class_expr
== NULL_TREE
)
1193 elemsize
= fold_convert (gfc_array_index_type
,
1194 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
1196 elemsize
= gfc_class_vtab_size_get (class_expr
);
1198 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
1207 gfc_trans_allocate_array_storage (pre
, post
, info
, size
, nelem
, initial
,
1213 if (ss
->dimen
> ss
->loop
->temp_dim
)
1214 ss
->loop
->temp_dim
= ss
->dimen
;
1220 /* Return the number of iterations in a loop that starts at START,
1221 ends at END, and has step STEP. */
1224 gfc_get_iteration_count (tree start
, tree end
, tree step
)
1229 type
= TREE_TYPE (step
);
1230 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, end
, start
);
1231 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
, type
, tmp
, step
);
1232 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
,
1233 build_int_cst (type
, 1));
1234 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, type
, tmp
,
1235 build_int_cst (type
, 0));
1236 return fold_convert (gfc_array_index_type
, tmp
);
1240 /* Extend the data in array DESC by EXTRA elements. */
1243 gfc_grow_array (stmtblock_t
* pblock
, tree desc
, tree extra
)
1250 if (integer_zerop (extra
))
1253 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[0]);
1255 /* Add EXTRA to the upper bound. */
1256 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1258 gfc_conv_descriptor_ubound_set (pblock
, desc
, gfc_rank_cst
[0], tmp
);
1260 /* Get the value of the current data pointer. */
1261 arg0
= gfc_conv_descriptor_data_get (desc
);
1263 /* Calculate the new array size. */
1264 size
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
1265 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1266 ubound
, gfc_index_one_node
);
1267 arg1
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
1268 fold_convert (size_type_node
, tmp
),
1269 fold_convert (size_type_node
, size
));
1271 /* Call the realloc() function. */
1272 tmp
= gfc_call_realloc (pblock
, arg0
, arg1
);
1273 gfc_conv_descriptor_data_set (pblock
, desc
, tmp
);
1277 /* Return true if the bounds of iterator I can only be determined
1281 gfc_iterator_has_dynamic_bounds (gfc_iterator
* i
)
1283 return (i
->start
->expr_type
!= EXPR_CONSTANT
1284 || i
->end
->expr_type
!= EXPR_CONSTANT
1285 || i
->step
->expr_type
!= EXPR_CONSTANT
);
1289 /* Split the size of constructor element EXPR into the sum of two terms,
1290 one of which can be determined at compile time and one of which must
1291 be calculated at run time. Set *SIZE to the former and return true
1292 if the latter might be nonzero. */
1295 gfc_get_array_constructor_element_size (mpz_t
* size
, gfc_expr
* expr
)
1297 if (expr
->expr_type
== EXPR_ARRAY
)
1298 return gfc_get_array_constructor_size (size
, expr
->value
.constructor
);
1299 else if (expr
->rank
> 0)
1301 /* Calculate everything at run time. */
1302 mpz_set_ui (*size
, 0);
1307 /* A single element. */
1308 mpz_set_ui (*size
, 1);
1314 /* Like gfc_get_array_constructor_element_size, but applied to the whole
1315 of array constructor C. */
1318 gfc_get_array_constructor_size (mpz_t
* size
, gfc_constructor_base base
)
1326 mpz_set_ui (*size
, 0);
1331 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1334 if (i
&& gfc_iterator_has_dynamic_bounds (i
))
1338 dynamic
|= gfc_get_array_constructor_element_size (&len
, c
->expr
);
1341 /* Multiply the static part of the element size by the
1342 number of iterations. */
1343 mpz_sub (val
, i
->end
->value
.integer
, i
->start
->value
.integer
);
1344 mpz_fdiv_q (val
, val
, i
->step
->value
.integer
);
1345 mpz_add_ui (val
, val
, 1);
1346 if (mpz_sgn (val
) > 0)
1347 mpz_mul (len
, len
, val
);
1349 mpz_set_ui (len
, 0);
1351 mpz_add (*size
, *size
, len
);
1360 /* Make sure offset is a variable. */
1363 gfc_put_offset_into_var (stmtblock_t
* pblock
, tree
* poffset
,
1366 /* We should have already created the offset variable. We cannot
1367 create it here because we may be in an inner scope. */
1368 gcc_assert (*offsetvar
!= NULL_TREE
);
1369 gfc_add_modify (pblock
, *offsetvar
, *poffset
);
1370 *poffset
= *offsetvar
;
1371 TREE_USED (*offsetvar
) = 1;
1375 /* Variables needed for bounds-checking. */
1376 static bool first_len
;
1377 static tree first_len_val
;
1378 static bool typespec_chararray_ctor
;
1381 gfc_trans_array_ctor_element (stmtblock_t
* pblock
, tree desc
,
1382 tree offset
, gfc_se
* se
, gfc_expr
* expr
)
1386 gfc_conv_expr (se
, expr
);
1388 /* Store the value. */
1389 tmp
= build_fold_indirect_ref_loc (input_location
,
1390 gfc_conv_descriptor_data_get (desc
));
1391 tmp
= gfc_build_array_ref (tmp
, offset
, NULL
);
1393 if (expr
->ts
.type
== BT_CHARACTER
)
1395 int i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
1398 esize
= size_in_bytes (gfc_get_element_type (TREE_TYPE (desc
)));
1399 esize
= fold_convert (gfc_charlen_type_node
, esize
);
1400 esize
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1401 gfc_charlen_type_node
, esize
,
1402 build_int_cst (gfc_charlen_type_node
,
1403 gfc_character_kinds
[i
].bit_size
/ 8));
1405 gfc_conv_string_parameter (se
);
1406 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
1408 /* The temporary is an array of pointers. */
1409 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1410 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1414 /* The temporary is an array of string values. */
1415 tmp
= gfc_build_addr_expr (gfc_get_pchar_type (expr
->ts
.kind
), tmp
);
1416 /* We know the temporary and the value will be the same length,
1417 so can use memcpy. */
1418 gfc_trans_string_copy (&se
->pre
, esize
, tmp
, expr
->ts
.kind
,
1419 se
->string_length
, se
->expr
, expr
->ts
.kind
);
1421 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && !typespec_chararray_ctor
)
1425 gfc_add_modify (&se
->pre
, first_len_val
,
1431 /* Verify that all constructor elements are of the same
1433 tree cond
= fold_build2_loc (input_location
, NE_EXPR
,
1434 boolean_type_node
, first_len_val
,
1436 gfc_trans_runtime_check
1437 (true, false, cond
, &se
->pre
, &expr
->where
,
1438 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1439 fold_convert (long_integer_type_node
, first_len_val
),
1440 fold_convert (long_integer_type_node
, se
->string_length
));
1446 /* TODO: Should the frontend already have done this conversion? */
1447 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1448 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1451 gfc_add_block_to_block (pblock
, &se
->pre
);
1452 gfc_add_block_to_block (pblock
, &se
->post
);
1456 /* Add the contents of an array to the constructor. DYNAMIC is as for
1457 gfc_trans_array_constructor_value. */
1460 gfc_trans_array_constructor_subarray (stmtblock_t
* pblock
,
1461 tree type ATTRIBUTE_UNUSED
,
1462 tree desc
, gfc_expr
* expr
,
1463 tree
* poffset
, tree
* offsetvar
,
1474 /* We need this to be a variable so we can increment it. */
1475 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1477 gfc_init_se (&se
, NULL
);
1479 /* Walk the array expression. */
1480 ss
= gfc_walk_expr (expr
);
1481 gcc_assert (ss
!= gfc_ss_terminator
);
1483 /* Initialize the scalarizer. */
1484 gfc_init_loopinfo (&loop
);
1485 gfc_add_ss_to_loop (&loop
, ss
);
1487 /* Initialize the loop. */
1488 gfc_conv_ss_startstride (&loop
);
1489 gfc_conv_loop_setup (&loop
, &expr
->where
);
1491 /* Make sure the constructed array has room for the new data. */
1494 /* Set SIZE to the total number of elements in the subarray. */
1495 size
= gfc_index_one_node
;
1496 for (n
= 0; n
< loop
.dimen
; n
++)
1498 tmp
= gfc_get_iteration_count (loop
.from
[n
], loop
.to
[n
],
1499 gfc_index_one_node
);
1500 size
= fold_build2_loc (input_location
, MULT_EXPR
,
1501 gfc_array_index_type
, size
, tmp
);
1504 /* Grow the constructed array by SIZE elements. */
1505 gfc_grow_array (&loop
.pre
, desc
, size
);
1508 /* Make the loop body. */
1509 gfc_mark_ss_chain_used (ss
, 1);
1510 gfc_start_scalarized_body (&loop
, &body
);
1511 gfc_copy_loopinfo_to_se (&se
, &loop
);
1514 gfc_trans_array_ctor_element (&body
, desc
, *poffset
, &se
, expr
);
1515 gcc_assert (se
.ss
== gfc_ss_terminator
);
1517 /* Increment the offset. */
1518 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1519 *poffset
, gfc_index_one_node
);
1520 gfc_add_modify (&body
, *poffset
, tmp
);
1522 /* Finish the loop. */
1523 gfc_trans_scalarizing_loops (&loop
, &body
);
1524 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
1525 tmp
= gfc_finish_block (&loop
.pre
);
1526 gfc_add_expr_to_block (pblock
, tmp
);
1528 gfc_cleanup_loop (&loop
);
1532 /* Assign the values to the elements of an array constructor. DYNAMIC
1533 is true if descriptor DESC only contains enough data for the static
1534 size calculated by gfc_get_array_constructor_size. When true, memory
1535 for the dynamic parts must be allocated using realloc. */
1538 gfc_trans_array_constructor_value (stmtblock_t
* pblock
, tree type
,
1539 tree desc
, gfc_constructor_base base
,
1540 tree
* poffset
, tree
* offsetvar
,
1544 tree start
= NULL_TREE
;
1545 tree end
= NULL_TREE
;
1546 tree step
= NULL_TREE
;
1552 tree shadow_loopvar
= NULL_TREE
;
1553 gfc_saved_var saved_loopvar
;
1556 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1558 /* If this is an iterator or an array, the offset must be a variable. */
1559 if ((c
->iterator
|| c
->expr
->rank
> 0) && INTEGER_CST_P (*poffset
))
1560 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1562 /* Shadowing the iterator avoids changing its value and saves us from
1563 keeping track of it. Further, it makes sure that there's always a
1564 backend-decl for the symbol, even if there wasn't one before,
1565 e.g. in the case of an iterator that appears in a specification
1566 expression in an interface mapping. */
1572 /* Evaluate loop bounds before substituting the loop variable
1573 in case they depend on it. Such a case is invalid, but it is
1574 not more expensive to do the right thing here.
1576 gfc_init_se (&se
, NULL
);
1577 gfc_conv_expr_val (&se
, c
->iterator
->start
);
1578 gfc_add_block_to_block (pblock
, &se
.pre
);
1579 start
= gfc_evaluate_now (se
.expr
, pblock
);
1581 gfc_init_se (&se
, NULL
);
1582 gfc_conv_expr_val (&se
, c
->iterator
->end
);
1583 gfc_add_block_to_block (pblock
, &se
.pre
);
1584 end
= gfc_evaluate_now (se
.expr
, pblock
);
1586 gfc_init_se (&se
, NULL
);
1587 gfc_conv_expr_val (&se
, c
->iterator
->step
);
1588 gfc_add_block_to_block (pblock
, &se
.pre
);
1589 step
= gfc_evaluate_now (se
.expr
, pblock
);
1591 sym
= c
->iterator
->var
->symtree
->n
.sym
;
1592 type
= gfc_typenode_for_spec (&sym
->ts
);
1594 shadow_loopvar
= gfc_create_var (type
, "shadow_loopvar");
1595 gfc_shadow_sym (sym
, shadow_loopvar
, &saved_loopvar
);
1598 gfc_start_block (&body
);
1600 if (c
->expr
->expr_type
== EXPR_ARRAY
)
1602 /* Array constructors can be nested. */
1603 gfc_trans_array_constructor_value (&body
, type
, desc
,
1604 c
->expr
->value
.constructor
,
1605 poffset
, offsetvar
, dynamic
);
1607 else if (c
->expr
->rank
> 0)
1609 gfc_trans_array_constructor_subarray (&body
, type
, desc
, c
->expr
,
1610 poffset
, offsetvar
, dynamic
);
1614 /* This code really upsets the gimplifier so don't bother for now. */
1621 while (p
&& !(p
->iterator
|| p
->expr
->expr_type
!= EXPR_CONSTANT
))
1623 p
= gfc_constructor_next (p
);
1628 /* Scalar values. */
1629 gfc_init_se (&se
, NULL
);
1630 gfc_trans_array_ctor_element (&body
, desc
, *poffset
,
1633 *poffset
= fold_build2_loc (input_location
, PLUS_EXPR
,
1634 gfc_array_index_type
,
1635 *poffset
, gfc_index_one_node
);
1639 /* Collect multiple scalar constants into a constructor. */
1640 vec
<constructor_elt
, va_gc
> *v
= NULL
;
1644 HOST_WIDE_INT idx
= 0;
1647 /* Count the number of consecutive scalar constants. */
1648 while (p
&& !(p
->iterator
1649 || p
->expr
->expr_type
!= EXPR_CONSTANT
))
1651 gfc_init_se (&se
, NULL
);
1652 gfc_conv_constant (&se
, p
->expr
);
1654 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
1655 se
.expr
= fold_convert (type
, se
.expr
);
1656 /* For constant character array constructors we build
1657 an array of pointers. */
1658 else if (POINTER_TYPE_P (type
))
1659 se
.expr
= gfc_build_addr_expr
1660 (gfc_get_pchar_type (p
->expr
->ts
.kind
),
1663 CONSTRUCTOR_APPEND_ELT (v
,
1664 build_int_cst (gfc_array_index_type
,
1668 p
= gfc_constructor_next (p
);
1671 bound
= size_int (n
- 1);
1672 /* Create an array type to hold them. */
1673 tmptype
= build_range_type (gfc_array_index_type
,
1674 gfc_index_zero_node
, bound
);
1675 tmptype
= build_array_type (type
, tmptype
);
1677 init
= build_constructor (tmptype
, v
);
1678 TREE_CONSTANT (init
) = 1;
1679 TREE_STATIC (init
) = 1;
1680 /* Create a static variable to hold the data. */
1681 tmp
= gfc_create_var (tmptype
, "data");
1682 TREE_STATIC (tmp
) = 1;
1683 TREE_CONSTANT (tmp
) = 1;
1684 TREE_READONLY (tmp
) = 1;
1685 DECL_INITIAL (tmp
) = init
;
1688 /* Use BUILTIN_MEMCPY to assign the values. */
1689 tmp
= gfc_conv_descriptor_data_get (desc
);
1690 tmp
= build_fold_indirect_ref_loc (input_location
,
1692 tmp
= gfc_build_array_ref (tmp
, *poffset
, NULL
);
1693 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1694 init
= gfc_build_addr_expr (NULL_TREE
, init
);
1696 size
= TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type
));
1697 bound
= build_int_cst (size_type_node
, n
* size
);
1698 tmp
= build_call_expr_loc (input_location
,
1699 builtin_decl_explicit (BUILT_IN_MEMCPY
),
1700 3, tmp
, init
, bound
);
1701 gfc_add_expr_to_block (&body
, tmp
);
1703 *poffset
= fold_build2_loc (input_location
, PLUS_EXPR
,
1704 gfc_array_index_type
, *poffset
,
1705 build_int_cst (gfc_array_index_type
, n
));
1707 if (!INTEGER_CST_P (*poffset
))
1709 gfc_add_modify (&body
, *offsetvar
, *poffset
);
1710 *poffset
= *offsetvar
;
1714 /* The frontend should already have done any expansions
1718 /* Pass the code as is. */
1719 tmp
= gfc_finish_block (&body
);
1720 gfc_add_expr_to_block (pblock
, tmp
);
1724 /* Build the implied do-loop. */
1725 stmtblock_t implied_do_block
;
1731 loopbody
= gfc_finish_block (&body
);
1733 /* Create a new block that holds the implied-do loop. A temporary
1734 loop-variable is used. */
1735 gfc_start_block(&implied_do_block
);
1737 /* Initialize the loop. */
1738 gfc_add_modify (&implied_do_block
, shadow_loopvar
, start
);
1740 /* If this array expands dynamically, and the number of iterations
1741 is not constant, we won't have allocated space for the static
1742 part of C->EXPR's size. Do that now. */
1743 if (dynamic
&& gfc_iterator_has_dynamic_bounds (c
->iterator
))
1745 /* Get the number of iterations. */
1746 tmp
= gfc_get_iteration_count (shadow_loopvar
, end
, step
);
1748 /* Get the static part of C->EXPR's size. */
1749 gfc_get_array_constructor_element_size (&size
, c
->expr
);
1750 tmp2
= gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
1752 /* Grow the array by TMP * TMP2 elements. */
1753 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
1754 gfc_array_index_type
, tmp
, tmp2
);
1755 gfc_grow_array (&implied_do_block
, desc
, tmp
);
1758 /* Generate the loop body. */
1759 exit_label
= gfc_build_label_decl (NULL_TREE
);
1760 gfc_start_block (&body
);
1762 /* Generate the exit condition. Depending on the sign of
1763 the step variable we have to generate the correct
1765 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1766 step
, build_int_cst (TREE_TYPE (step
), 0));
1767 cond
= fold_build3_loc (input_location
, COND_EXPR
,
1768 boolean_type_node
, tmp
,
1769 fold_build2_loc (input_location
, GT_EXPR
,
1770 boolean_type_node
, shadow_loopvar
, end
),
1771 fold_build2_loc (input_location
, LT_EXPR
,
1772 boolean_type_node
, shadow_loopvar
, end
));
1773 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1774 TREE_USED (exit_label
) = 1;
1775 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
1776 build_empty_stmt (input_location
));
1777 gfc_add_expr_to_block (&body
, tmp
);
1779 /* The main loop body. */
1780 gfc_add_expr_to_block (&body
, loopbody
);
1782 /* Increase loop variable by step. */
1783 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1784 TREE_TYPE (shadow_loopvar
), shadow_loopvar
,
1786 gfc_add_modify (&body
, shadow_loopvar
, tmp
);
1788 /* Finish the loop. */
1789 tmp
= gfc_finish_block (&body
);
1790 tmp
= build1_v (LOOP_EXPR
, tmp
);
1791 gfc_add_expr_to_block (&implied_do_block
, tmp
);
1793 /* Add the exit label. */
1794 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1795 gfc_add_expr_to_block (&implied_do_block
, tmp
);
1797 /* Finish the implied-do loop. */
1798 tmp
= gfc_finish_block(&implied_do_block
);
1799 gfc_add_expr_to_block(pblock
, tmp
);
1801 gfc_restore_sym (c
->iterator
->var
->symtree
->n
.sym
, &saved_loopvar
);
1808 /* The array constructor code can create a string length with an operand
1809 in the form of a temporary variable. This variable will retain its
1810 context (current_function_decl). If we store this length tree in a
1811 gfc_charlen structure which is shared by a variable in another
1812 context, the resulting gfc_charlen structure with a variable in a
1813 different context, we could trip the assertion in expand_expr_real_1
1814 when it sees that a variable has been created in one context and
1815 referenced in another.
1817 If this might be the case, we create a new gfc_charlen structure and
1818 link it into the current namespace. */
1821 store_backend_decl (gfc_charlen
**clp
, tree len
, bool force_new_cl
)
1825 gfc_charlen
*new_cl
= gfc_new_charlen (gfc_current_ns
, *clp
);
1828 (*clp
)->backend_decl
= len
;
1831 /* A catch-all to obtain the string length for anything that is not
1832 a substring of non-constant length, a constant, array or variable. */
1835 get_array_ctor_all_strlen (stmtblock_t
*block
, gfc_expr
*e
, tree
*len
)
1839 /* Don't bother if we already know the length is a constant. */
1840 if (*len
&& INTEGER_CST_P (*len
))
1843 if (!e
->ref
&& e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
1844 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1847 gfc_conv_const_charlen (e
->ts
.u
.cl
);
1848 *len
= e
->ts
.u
.cl
->backend_decl
;
1852 /* Otherwise, be brutal even if inefficient. */
1853 gfc_init_se (&se
, NULL
);
1855 /* No function call, in case of side effects. */
1856 se
.no_function_call
= 1;
1858 gfc_conv_expr (&se
, e
);
1860 gfc_conv_expr_descriptor (&se
, e
);
1862 /* Fix the value. */
1863 *len
= gfc_evaluate_now (se
.string_length
, &se
.pre
);
1865 gfc_add_block_to_block (block
, &se
.pre
);
1866 gfc_add_block_to_block (block
, &se
.post
);
1868 store_backend_decl (&e
->ts
.u
.cl
, *len
, true);
1873 /* Figure out the string length of a variable reference expression.
1874 Used by get_array_ctor_strlen. */
1877 get_array_ctor_var_strlen (stmtblock_t
*block
, gfc_expr
* expr
, tree
* len
)
1883 /* Don't bother if we already know the length is a constant. */
1884 if (*len
&& INTEGER_CST_P (*len
))
1887 ts
= &expr
->symtree
->n
.sym
->ts
;
1888 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1893 /* Array references don't change the string length. */
1897 /* Use the length of the component. */
1898 ts
= &ref
->u
.c
.component
->ts
;
1902 if (ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1903 || ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1905 /* Note that this might evaluate expr. */
1906 get_array_ctor_all_strlen (block
, expr
, len
);
1909 mpz_init_set_ui (char_len
, 1);
1910 mpz_add (char_len
, char_len
, ref
->u
.ss
.end
->value
.integer
);
1911 mpz_sub (char_len
, char_len
, ref
->u
.ss
.start
->value
.integer
);
1912 *len
= gfc_conv_mpz_to_tree (char_len
, gfc_default_integer_kind
);
1913 *len
= convert (gfc_charlen_type_node
, *len
);
1914 mpz_clear (char_len
);
1922 *len
= ts
->u
.cl
->backend_decl
;
1926 /* Figure out the string length of a character array constructor.
1927 If len is NULL, don't calculate the length; this happens for recursive calls
1928 when a sub-array-constructor is an element but not at the first position,
1929 so when we're not interested in the length.
1930 Returns TRUE if all elements are character constants. */
1933 get_array_ctor_strlen (stmtblock_t
*block
, gfc_constructor_base base
, tree
* len
)
1940 if (gfc_constructor_first (base
) == NULL
)
1943 *len
= build_int_cstu (gfc_charlen_type_node
, 0);
1947 /* Loop over all constructor elements to find out is_const, but in len we
1948 want to store the length of the first, not the last, element. We can
1949 of course exit the loop as soon as is_const is found to be false. */
1950 for (c
= gfc_constructor_first (base
);
1951 c
&& is_const
; c
= gfc_constructor_next (c
))
1953 switch (c
->expr
->expr_type
)
1956 if (len
&& !(*len
&& INTEGER_CST_P (*len
)))
1957 *len
= build_int_cstu (gfc_charlen_type_node
,
1958 c
->expr
->value
.character
.length
);
1962 if (!get_array_ctor_strlen (block
, c
->expr
->value
.constructor
, len
))
1969 get_array_ctor_var_strlen (block
, c
->expr
, len
);
1975 get_array_ctor_all_strlen (block
, c
->expr
, len
);
1979 /* After the first iteration, we don't want the length modified. */
1986 /* Check whether the array constructor C consists entirely of constant
1987 elements, and if so returns the number of those elements, otherwise
1988 return zero. Note, an empty or NULL array constructor returns zero. */
1990 unsigned HOST_WIDE_INT
1991 gfc_constant_array_constructor_p (gfc_constructor_base base
)
1993 unsigned HOST_WIDE_INT nelem
= 0;
1995 gfc_constructor
*c
= gfc_constructor_first (base
);
1999 || c
->expr
->rank
> 0
2000 || c
->expr
->expr_type
!= EXPR_CONSTANT
)
2002 c
= gfc_constructor_next (c
);
2009 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
2010 and the tree type of it's elements, TYPE, return a static constant
2011 variable that is compile-time initialized. */
2014 gfc_build_constant_array_constructor (gfc_expr
* expr
, tree type
)
2016 tree tmptype
, init
, tmp
;
2017 HOST_WIDE_INT nelem
;
2022 vec
<constructor_elt
, va_gc
> *v
= NULL
;
2024 /* First traverse the constructor list, converting the constants
2025 to tree to build an initializer. */
2027 c
= gfc_constructor_first (expr
->value
.constructor
);
2030 gfc_init_se (&se
, NULL
);
2031 gfc_conv_constant (&se
, c
->expr
);
2032 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
2033 se
.expr
= fold_convert (type
, se
.expr
);
2034 else if (POINTER_TYPE_P (type
))
2035 se
.expr
= gfc_build_addr_expr (gfc_get_pchar_type (c
->expr
->ts
.kind
),
2037 CONSTRUCTOR_APPEND_ELT (v
, build_int_cst (gfc_array_index_type
, nelem
),
2039 c
= gfc_constructor_next (c
);
2043 /* Next determine the tree type for the array. We use the gfortran
2044 front-end's gfc_get_nodesc_array_type in order to create a suitable
2045 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
2047 memset (&as
, 0, sizeof (gfc_array_spec
));
2049 as
.rank
= expr
->rank
;
2050 as
.type
= AS_EXPLICIT
;
2053 as
.lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2054 as
.upper
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
2058 for (i
= 0; i
< expr
->rank
; i
++)
2060 int tmp
= (int) mpz_get_si (expr
->shape
[i
]);
2061 as
.lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2062 as
.upper
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
2066 tmptype
= gfc_get_nodesc_array_type (type
, &as
, PACKED_STATIC
, true);
2068 /* as is not needed anymore. */
2069 for (i
= 0; i
< as
.rank
+ as
.corank
; i
++)
2071 gfc_free_expr (as
.lower
[i
]);
2072 gfc_free_expr (as
.upper
[i
]);
2075 init
= build_constructor (tmptype
, v
);
2077 TREE_CONSTANT (init
) = 1;
2078 TREE_STATIC (init
) = 1;
2080 tmp
= build_decl (input_location
, VAR_DECL
, create_tmp_var_name ("A"),
2082 DECL_ARTIFICIAL (tmp
) = 1;
2083 DECL_IGNORED_P (tmp
) = 1;
2084 TREE_STATIC (tmp
) = 1;
2085 TREE_CONSTANT (tmp
) = 1;
2086 TREE_READONLY (tmp
) = 1;
2087 DECL_INITIAL (tmp
) = init
;
2094 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
2095 This mostly initializes the scalarizer state info structure with the
2096 appropriate values to directly use the array created by the function
2097 gfc_build_constant_array_constructor. */
2100 trans_constant_array_constructor (gfc_ss
* ss
, tree type
)
2102 gfc_array_info
*info
;
2106 tmp
= gfc_build_constant_array_constructor (ss
->info
->expr
, type
);
2108 info
= &ss
->info
->data
.array
;
2110 info
->descriptor
= tmp
;
2111 info
->data
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2112 info
->offset
= gfc_index_zero_node
;
2114 for (i
= 0; i
< ss
->dimen
; i
++)
2116 info
->delta
[i
] = gfc_index_zero_node
;
2117 info
->start
[i
] = gfc_index_zero_node
;
2118 info
->end
[i
] = gfc_index_zero_node
;
2119 info
->stride
[i
] = gfc_index_one_node
;
2125 get_rank (gfc_loopinfo
*loop
)
2130 for (; loop
; loop
= loop
->parent
)
2131 rank
+= loop
->dimen
;
2137 /* Helper routine of gfc_trans_array_constructor to determine if the
2138 bounds of the loop specified by LOOP are constant and simple enough
2139 to use with trans_constant_array_constructor. Returns the
2140 iteration count of the loop if suitable, and NULL_TREE otherwise. */
2143 constant_array_constructor_loop_size (gfc_loopinfo
* l
)
2146 tree size
= gfc_index_one_node
;
2150 total_dim
= get_rank (l
);
2152 for (loop
= l
; loop
; loop
= loop
->parent
)
2154 for (i
= 0; i
< loop
->dimen
; i
++)
2156 /* If the bounds aren't constant, return NULL_TREE. */
2157 if (!INTEGER_CST_P (loop
->from
[i
]) || !INTEGER_CST_P (loop
->to
[i
]))
2159 if (!integer_zerop (loop
->from
[i
]))
2161 /* Only allow nonzero "from" in one-dimensional arrays. */
2164 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2165 gfc_array_index_type
,
2166 loop
->to
[i
], loop
->from
[i
]);
2170 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2171 gfc_array_index_type
, tmp
, gfc_index_one_node
);
2172 size
= fold_build2_loc (input_location
, MULT_EXPR
,
2173 gfc_array_index_type
, size
, tmp
);
2182 get_loop_upper_bound_for_array (gfc_ss
*array
, int array_dim
)
2187 gcc_assert (array
->nested_ss
== NULL
);
2189 for (ss
= array
; ss
; ss
= ss
->parent
)
2190 for (n
= 0; n
< ss
->loop
->dimen
; n
++)
2191 if (array_dim
== get_array_ref_dim_for_loop_dim (ss
, n
))
2192 return &(ss
->loop
->to
[n
]);
2198 static gfc_loopinfo
*
2199 outermost_loop (gfc_loopinfo
* loop
)
2201 while (loop
->parent
!= NULL
)
2202 loop
= loop
->parent
;
2208 /* Array constructors are handled by constructing a temporary, then using that
2209 within the scalarization loop. This is not optimal, but seems by far the
2213 trans_array_constructor (gfc_ss
* ss
, locus
* where
)
2215 gfc_constructor_base c
;
2223 bool old_first_len
, old_typespec_chararray_ctor
;
2224 tree old_first_len_val
;
2225 gfc_loopinfo
*loop
, *outer_loop
;
2226 gfc_ss_info
*ss_info
;
2232 /* Save the old values for nested checking. */
2233 old_first_len
= first_len
;
2234 old_first_len_val
= first_len_val
;
2235 old_typespec_chararray_ctor
= typespec_chararray_ctor
;
2238 outer_loop
= outermost_loop (loop
);
2240 expr
= ss_info
->expr
;
2242 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
2243 typespec was given for the array constructor. */
2244 typespec_chararray_ctor
= (expr
->ts
.type
== BT_CHARACTER
2246 && expr
->ts
.u
.cl
->length_from_typespec
);
2248 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2249 && expr
->ts
.type
== BT_CHARACTER
&& !typespec_chararray_ctor
)
2251 first_len_val
= gfc_create_var (gfc_charlen_type_node
, "len");
2255 gcc_assert (ss
->dimen
== ss
->loop
->dimen
);
2257 c
= expr
->value
.constructor
;
2258 if (expr
->ts
.type
== BT_CHARACTER
)
2261 bool force_new_cl
= false;
2263 /* get_array_ctor_strlen walks the elements of the constructor, if a
2264 typespec was given, we already know the string length and want the one
2266 if (typespec_chararray_ctor
&& expr
->ts
.u
.cl
->length
2267 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
2271 const_string
= false;
2272 gfc_init_se (&length_se
, NULL
);
2273 gfc_conv_expr_type (&length_se
, expr
->ts
.u
.cl
->length
,
2274 gfc_charlen_type_node
);
2275 ss_info
->string_length
= length_se
.expr
;
2277 /* Check if the character length is negative. If it is, then
2279 neg_len
= fold_build2_loc (input_location
, LT_EXPR
,
2280 boolean_type_node
, ss_info
->string_length
,
2281 build_int_cst (gfc_charlen_type_node
, 0));
2282 /* Print a warning if bounds checking is enabled. */
2283 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2285 msg
= xasprintf ("Negative character length treated as LEN = 0");
2286 gfc_trans_runtime_check (false, true, neg_len
, &length_se
.pre
,
2291 ss_info
->string_length
2292 = fold_build3_loc (input_location
, COND_EXPR
,
2293 gfc_charlen_type_node
, neg_len
,
2294 build_int_cst (gfc_charlen_type_node
, 0),
2295 ss_info
->string_length
);
2296 ss_info
->string_length
= gfc_evaluate_now (ss_info
->string_length
,
2299 gfc_add_block_to_block (&outer_loop
->pre
, &length_se
.pre
);
2300 gfc_add_block_to_block (&outer_loop
->post
, &length_se
.post
);
2304 const_string
= get_array_ctor_strlen (&outer_loop
->pre
, c
,
2305 &ss_info
->string_length
);
2306 force_new_cl
= true;
2309 /* Complex character array constructors should have been taken care of
2310 and not end up here. */
2311 gcc_assert (ss_info
->string_length
);
2313 store_backend_decl (&expr
->ts
.u
.cl
, ss_info
->string_length
, force_new_cl
);
2315 type
= gfc_get_character_type_len (expr
->ts
.kind
, ss_info
->string_length
);
2317 type
= build_pointer_type (type
);
2320 type
= gfc_typenode_for_spec (expr
->ts
.type
== BT_CLASS
2321 ? &CLASS_DATA (expr
)->ts
: &expr
->ts
);
2323 /* See if the constructor determines the loop bounds. */
2326 loop_ubound0
= get_loop_upper_bound_for_array (ss
, 0);
2328 if (expr
->shape
&& get_rank (loop
) > 1 && *loop_ubound0
== NULL_TREE
)
2330 /* We have a multidimensional parameter. */
2331 for (s
= ss
; s
; s
= s
->parent
)
2334 for (n
= 0; n
< s
->loop
->dimen
; n
++)
2336 s
->loop
->from
[n
] = gfc_index_zero_node
;
2337 s
->loop
->to
[n
] = gfc_conv_mpz_to_tree (expr
->shape
[s
->dim
[n
]],
2338 gfc_index_integer_kind
);
2339 s
->loop
->to
[n
] = fold_build2_loc (input_location
, MINUS_EXPR
,
2340 gfc_array_index_type
,
2342 gfc_index_one_node
);
2347 if (*loop_ubound0
== NULL_TREE
)
2351 /* We should have a 1-dimensional, zero-based loop. */
2352 gcc_assert (loop
->parent
== NULL
&& loop
->nested
== NULL
);
2353 gcc_assert (loop
->dimen
== 1);
2354 gcc_assert (integer_zerop (loop
->from
[0]));
2356 /* Split the constructor size into a static part and a dynamic part.
2357 Allocate the static size up-front and record whether the dynamic
2358 size might be nonzero. */
2360 dynamic
= gfc_get_array_constructor_size (&size
, c
);
2361 mpz_sub_ui (size
, size
, 1);
2362 loop
->to
[0] = gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
2366 /* Special case constant array constructors. */
2369 unsigned HOST_WIDE_INT nelem
= gfc_constant_array_constructor_p (c
);
2372 tree size
= constant_array_constructor_loop_size (loop
);
2373 if (size
&& compare_tree_int (size
, nelem
) == 0)
2375 trans_constant_array_constructor (ss
, type
);
2381 gfc_trans_create_temp_array (&outer_loop
->pre
, &outer_loop
->post
, ss
, type
,
2382 NULL_TREE
, dynamic
, true, false, where
);
2384 desc
= ss_info
->data
.array
.descriptor
;
2385 offset
= gfc_index_zero_node
;
2386 offsetvar
= gfc_create_var_np (gfc_array_index_type
, "offset");
2387 TREE_NO_WARNING (offsetvar
) = 1;
2388 TREE_USED (offsetvar
) = 0;
2389 gfc_trans_array_constructor_value (&outer_loop
->pre
, type
, desc
, c
,
2390 &offset
, &offsetvar
, dynamic
);
2392 /* If the array grows dynamically, the upper bound of the loop variable
2393 is determined by the array's final upper bound. */
2396 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2397 gfc_array_index_type
,
2398 offsetvar
, gfc_index_one_node
);
2399 tmp
= gfc_evaluate_now (tmp
, &outer_loop
->pre
);
2400 gfc_conv_descriptor_ubound_set (&loop
->pre
, desc
, gfc_rank_cst
[0], tmp
);
2401 if (*loop_ubound0
&& VAR_P (*loop_ubound0
))
2402 gfc_add_modify (&outer_loop
->pre
, *loop_ubound0
, tmp
);
2404 *loop_ubound0
= tmp
;
2407 if (TREE_USED (offsetvar
))
2408 pushdecl (offsetvar
);
2410 gcc_assert (INTEGER_CST_P (offset
));
2413 /* Disable bound checking for now because it's probably broken. */
2414 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2421 /* Restore old values of globals. */
2422 first_len
= old_first_len
;
2423 first_len_val
= old_first_len_val
;
2424 typespec_chararray_ctor
= old_typespec_chararray_ctor
;
2428 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
2429 called after evaluating all of INFO's vector dimensions. Go through
2430 each such vector dimension and see if we can now fill in any missing
2434 set_vector_loop_bounds (gfc_ss
* ss
)
2436 gfc_loopinfo
*loop
, *outer_loop
;
2437 gfc_array_info
*info
;
2445 outer_loop
= outermost_loop (ss
->loop
);
2447 info
= &ss
->info
->data
.array
;
2449 for (; ss
; ss
= ss
->parent
)
2453 for (n
= 0; n
< loop
->dimen
; n
++)
2456 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_VECTOR
2457 || loop
->to
[n
] != NULL
)
2460 /* Loop variable N indexes vector dimension DIM, and we don't
2461 yet know the upper bound of loop variable N. Set it to the
2462 difference between the vector's upper and lower bounds. */
2463 gcc_assert (loop
->from
[n
] == gfc_index_zero_node
);
2464 gcc_assert (info
->subscript
[dim
]
2465 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
2467 gfc_init_se (&se
, NULL
);
2468 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
2469 zero
= gfc_rank_cst
[0];
2470 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2471 gfc_array_index_type
,
2472 gfc_conv_descriptor_ubound_get (desc
, zero
),
2473 gfc_conv_descriptor_lbound_get (desc
, zero
));
2474 tmp
= gfc_evaluate_now (tmp
, &outer_loop
->pre
);
2481 /* Tells whether a scalar argument to an elemental procedure is saved out
2482 of a scalarization loop as a value or as a reference. */
2485 gfc_scalar_elemental_arg_saved_as_reference (gfc_ss_info
* ss_info
)
2487 if (ss_info
->type
!= GFC_SS_REFERENCE
)
2490 /* If the actual argument can be absent (in other words, it can
2491 be a NULL reference), don't try to evaluate it; pass instead
2492 the reference directly. */
2493 if (ss_info
->can_be_null_ref
)
2496 /* If the expression is of polymorphic type, it's actual size is not known,
2497 so we avoid copying it anywhere. */
2498 if (ss_info
->data
.scalar
.dummy_arg
2499 && ss_info
->data
.scalar
.dummy_arg
->ts
.type
== BT_CLASS
2500 && ss_info
->expr
->ts
.type
== BT_CLASS
)
2503 /* If the expression is a data reference of aggregate type,
2504 and the data reference is not used on the left hand side,
2505 avoid a copy by saving a reference to the content. */
2506 if (!ss_info
->data
.scalar
.needs_temporary
2507 && (ss_info
->expr
->ts
.type
== BT_DERIVED
2508 || ss_info
->expr
->ts
.type
== BT_CLASS
)
2509 && gfc_expr_is_variable (ss_info
->expr
))
2512 /* Otherwise the expression is evaluated to a temporary variable before the
2513 scalarization loop. */
2518 /* Add the pre and post chains for all the scalar expressions in a SS chain
2519 to loop. This is called after the loop parameters have been calculated,
2520 but before the actual scalarizing loops. */
2523 gfc_add_loop_ss_code (gfc_loopinfo
* loop
, gfc_ss
* ss
, bool subscript
,
2526 gfc_loopinfo
*nested_loop
, *outer_loop
;
2528 gfc_ss_info
*ss_info
;
2529 gfc_array_info
*info
;
2533 /* Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise,
2534 arguments could get evaluated multiple times. */
2535 if (ss
->is_alloc_lhs
)
2538 outer_loop
= outermost_loop (loop
);
2540 /* TODO: This can generate bad code if there are ordering dependencies,
2541 e.g., a callee allocated function and an unknown size constructor. */
2542 gcc_assert (ss
!= NULL
);
2544 for (; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2548 /* Cross loop arrays are handled from within the most nested loop. */
2549 if (ss
->nested_ss
!= NULL
)
2553 expr
= ss_info
->expr
;
2554 info
= &ss_info
->data
.array
;
2556 switch (ss_info
->type
)
2559 /* Scalar expression. Evaluate this now. This includes elemental
2560 dimension indices, but not array section bounds. */
2561 gfc_init_se (&se
, NULL
);
2562 gfc_conv_expr (&se
, expr
);
2563 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2565 if (expr
->ts
.type
!= BT_CHARACTER
2566 && !gfc_is_alloc_class_scalar_function (expr
))
2568 /* Move the evaluation of scalar expressions outside the
2569 scalarization loop, except for WHERE assignments. */
2571 se
.expr
= convert(gfc_array_index_type
, se
.expr
);
2572 if (!ss_info
->where
)
2573 se
.expr
= gfc_evaluate_now (se
.expr
, &outer_loop
->pre
);
2574 gfc_add_block_to_block (&outer_loop
->pre
, &se
.post
);
2577 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2579 ss_info
->data
.scalar
.value
= se
.expr
;
2580 ss_info
->string_length
= se
.string_length
;
2583 case GFC_SS_REFERENCE
:
2584 /* Scalar argument to elemental procedure. */
2585 gfc_init_se (&se
, NULL
);
2586 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info
))
2587 gfc_conv_expr_reference (&se
, expr
);
2590 /* Evaluate the argument outside the loop and pass
2591 a reference to the value. */
2592 gfc_conv_expr (&se
, expr
);
2595 /* Ensure that a pointer to the string is stored. */
2596 if (expr
->ts
.type
== BT_CHARACTER
)
2597 gfc_conv_string_parameter (&se
);
2599 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2600 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2601 if (gfc_is_class_scalar_expr (expr
))
2602 /* This is necessary because the dynamic type will always be
2603 large than the declared type. In consequence, assigning
2604 the value to a temporary could segfault.
2605 OOP-TODO: see if this is generally correct or is the value
2606 has to be written to an allocated temporary, whose address
2607 is passed via ss_info. */
2608 ss_info
->data
.scalar
.value
= se
.expr
;
2610 ss_info
->data
.scalar
.value
= gfc_evaluate_now (se
.expr
,
2613 ss_info
->string_length
= se
.string_length
;
2616 case GFC_SS_SECTION
:
2617 /* Add the expressions for scalar and vector subscripts. */
2618 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2619 if (info
->subscript
[n
])
2620 gfc_add_loop_ss_code (loop
, info
->subscript
[n
], true, where
);
2622 set_vector_loop_bounds (ss
);
2626 /* Get the vector's descriptor and store it in SS. */
2627 gfc_init_se (&se
, NULL
);
2628 gfc_conv_expr_descriptor (&se
, expr
);
2629 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2630 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2631 info
->descriptor
= se
.expr
;
2634 case GFC_SS_INTRINSIC
:
2635 gfc_add_intrinsic_ss_code (loop
, ss
);
2638 case GFC_SS_FUNCTION
:
2639 /* Array function return value. We call the function and save its
2640 result in a temporary for use inside the loop. */
2641 gfc_init_se (&se
, NULL
);
2644 gfc_conv_expr (&se
, expr
);
2645 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2646 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2647 ss_info
->string_length
= se
.string_length
;
2650 case GFC_SS_CONSTRUCTOR
:
2651 if (expr
->ts
.type
== BT_CHARACTER
2652 && ss_info
->string_length
== NULL
2654 && expr
->ts
.u
.cl
->length
2655 && expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2657 gfc_init_se (&se
, NULL
);
2658 gfc_conv_expr_type (&se
, expr
->ts
.u
.cl
->length
,
2659 gfc_charlen_type_node
);
2660 ss_info
->string_length
= se
.expr
;
2661 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2662 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2664 trans_array_constructor (ss
, where
);
2668 case GFC_SS_COMPONENT
:
2669 /* Do nothing. These are handled elsewhere. */
2678 for (nested_loop
= loop
->nested
; nested_loop
;
2679 nested_loop
= nested_loop
->next
)
2680 gfc_add_loop_ss_code (nested_loop
, nested_loop
->ss
, subscript
, where
);
2684 /* Translate expressions for the descriptor and data pointer of a SS. */
2688 gfc_conv_ss_descriptor (stmtblock_t
* block
, gfc_ss
* ss
, int base
)
2691 gfc_ss_info
*ss_info
;
2692 gfc_array_info
*info
;
2696 info
= &ss_info
->data
.array
;
2698 /* Get the descriptor for the array to be scalarized. */
2699 gcc_assert (ss_info
->expr
->expr_type
== EXPR_VARIABLE
);
2700 gfc_init_se (&se
, NULL
);
2701 se
.descriptor_only
= 1;
2702 gfc_conv_expr_lhs (&se
, ss_info
->expr
);
2703 gfc_add_block_to_block (block
, &se
.pre
);
2704 info
->descriptor
= se
.expr
;
2705 ss_info
->string_length
= se
.string_length
;
2709 if (ss_info
->expr
->ts
.type
== BT_CHARACTER
&& !ss_info
->expr
->ts
.deferred
2710 && ss_info
->expr
->ts
.u
.cl
->length
== NULL
)
2712 /* Emit a DECL_EXPR for the variable sized array type in
2713 GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
2714 sizes works correctly. */
2715 tree arraytype
= TREE_TYPE (
2716 GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (info
->descriptor
)));
2717 if (! TYPE_NAME (arraytype
))
2718 TYPE_NAME (arraytype
) = build_decl (UNKNOWN_LOCATION
, TYPE_DECL
,
2719 NULL_TREE
, arraytype
);
2720 gfc_add_expr_to_block (block
, build1 (DECL_EXPR
, arraytype
,
2721 TYPE_NAME (arraytype
)));
2723 /* Also the data pointer. */
2724 tmp
= gfc_conv_array_data (se
.expr
);
2725 /* If this is a variable or address of a variable we use it directly.
2726 Otherwise we must evaluate it now to avoid breaking dependency
2727 analysis by pulling the expressions for elemental array indices
2730 || (TREE_CODE (tmp
) == ADDR_EXPR
2731 && DECL_P (TREE_OPERAND (tmp
, 0)))))
2732 tmp
= gfc_evaluate_now (tmp
, block
);
2735 tmp
= gfc_conv_array_offset (se
.expr
);
2736 info
->offset
= gfc_evaluate_now (tmp
, block
);
2738 /* Make absolutely sure that the saved_offset is indeed saved
2739 so that the variable is still accessible after the loops
2741 info
->saved_offset
= info
->offset
;
2746 /* Initialize a gfc_loopinfo structure. */
2749 gfc_init_loopinfo (gfc_loopinfo
* loop
)
2753 memset (loop
, 0, sizeof (gfc_loopinfo
));
2754 gfc_init_block (&loop
->pre
);
2755 gfc_init_block (&loop
->post
);
2757 /* Initially scalarize in order and default to no loop reversal. */
2758 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2761 loop
->reverse
[n
] = GFC_INHIBIT_REVERSE
;
2764 loop
->ss
= gfc_ss_terminator
;
2768 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2772 gfc_copy_loopinfo_to_se (gfc_se
* se
, gfc_loopinfo
* loop
)
2778 /* Return an expression for the data pointer of an array. */
2781 gfc_conv_array_data (tree descriptor
)
2785 type
= TREE_TYPE (descriptor
);
2786 if (GFC_ARRAY_TYPE_P (type
))
2788 if (TREE_CODE (type
) == POINTER_TYPE
)
2792 /* Descriptorless arrays. */
2793 return gfc_build_addr_expr (NULL_TREE
, descriptor
);
2797 return gfc_conv_descriptor_data_get (descriptor
);
2801 /* Return an expression for the base offset of an array. */
2804 gfc_conv_array_offset (tree descriptor
)
2808 type
= TREE_TYPE (descriptor
);
2809 if (GFC_ARRAY_TYPE_P (type
))
2810 return GFC_TYPE_ARRAY_OFFSET (type
);
2812 return gfc_conv_descriptor_offset_get (descriptor
);
2816 /* Get an expression for the array stride. */
2819 gfc_conv_array_stride (tree descriptor
, int dim
)
2824 type
= TREE_TYPE (descriptor
);
2826 /* For descriptorless arrays use the array size. */
2827 tmp
= GFC_TYPE_ARRAY_STRIDE (type
, dim
);
2828 if (tmp
!= NULL_TREE
)
2831 tmp
= gfc_conv_descriptor_stride_get (descriptor
, gfc_rank_cst
[dim
]);
2836 /* Like gfc_conv_array_stride, but for the lower bound. */
2839 gfc_conv_array_lbound (tree descriptor
, int dim
)
2844 type
= TREE_TYPE (descriptor
);
2846 tmp
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
2847 if (tmp
!= NULL_TREE
)
2850 tmp
= gfc_conv_descriptor_lbound_get (descriptor
, gfc_rank_cst
[dim
]);
2855 /* Like gfc_conv_array_stride, but for the upper bound. */
2858 gfc_conv_array_ubound (tree descriptor
, int dim
)
2863 type
= TREE_TYPE (descriptor
);
2865 tmp
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
2866 if (tmp
!= NULL_TREE
)
2869 /* This should only ever happen when passing an assumed shape array
2870 as an actual parameter. The value will never be used. */
2871 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor
)))
2872 return gfc_index_zero_node
;
2874 tmp
= gfc_conv_descriptor_ubound_get (descriptor
, gfc_rank_cst
[dim
]);
2879 /* Generate code to perform an array index bound check. */
2882 trans_array_bound_check (gfc_se
* se
, gfc_ss
*ss
, tree index
, int n
,
2883 locus
* where
, bool check_upper
)
2886 tree tmp_lo
, tmp_up
;
2889 const char * name
= NULL
;
2891 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
2894 descriptor
= ss
->info
->data
.array
.descriptor
;
2896 index
= gfc_evaluate_now (index
, &se
->pre
);
2898 /* We find a name for the error message. */
2899 name
= ss
->info
->expr
->symtree
->n
.sym
->name
;
2900 gcc_assert (name
!= NULL
);
2902 if (VAR_P (descriptor
))
2903 name
= IDENTIFIER_POINTER (DECL_NAME (descriptor
));
2905 /* If upper bound is present, include both bounds in the error message. */
2908 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
2909 tmp_up
= gfc_conv_array_ubound (descriptor
, n
);
2912 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
2913 "outside of expected range (%%ld:%%ld)", n
+1, name
);
2915 msg
= xasprintf ("Index '%%ld' of dimension %d "
2916 "outside of expected range (%%ld:%%ld)", n
+1);
2918 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2920 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2921 fold_convert (long_integer_type_node
, index
),
2922 fold_convert (long_integer_type_node
, tmp_lo
),
2923 fold_convert (long_integer_type_node
, tmp_up
));
2924 fault
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2926 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2927 fold_convert (long_integer_type_node
, index
),
2928 fold_convert (long_integer_type_node
, tmp_lo
),
2929 fold_convert (long_integer_type_node
, tmp_up
));
2934 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
2937 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
2938 "below lower bound of %%ld", n
+1, name
);
2940 msg
= xasprintf ("Index '%%ld' of dimension %d "
2941 "below lower bound of %%ld", n
+1);
2943 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2945 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2946 fold_convert (long_integer_type_node
, index
),
2947 fold_convert (long_integer_type_node
, tmp_lo
));
2955 /* Return the offset for an index. Performs bound checking for elemental
2956 dimensions. Single element references are processed separately.
2957 DIM is the array dimension, I is the loop dimension. */
2960 conv_array_index_offset (gfc_se
* se
, gfc_ss
* ss
, int dim
, int i
,
2961 gfc_array_ref
* ar
, tree stride
)
2963 gfc_array_info
*info
;
2968 info
= &ss
->info
->data
.array
;
2970 /* Get the index into the array for this dimension. */
2973 gcc_assert (ar
->type
!= AR_ELEMENT
);
2974 switch (ar
->dimen_type
[dim
])
2976 case DIMEN_THIS_IMAGE
:
2980 /* Elemental dimension. */
2981 gcc_assert (info
->subscript
[dim
]
2982 && info
->subscript
[dim
]->info
->type
== GFC_SS_SCALAR
);
2983 /* We've already translated this value outside the loop. */
2984 index
= info
->subscript
[dim
]->info
->data
.scalar
.value
;
2986 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
2987 ar
->as
->type
!= AS_ASSUMED_SIZE
2988 || dim
< ar
->dimen
- 1);
2992 gcc_assert (info
&& se
->loop
);
2993 gcc_assert (info
->subscript
[dim
]
2994 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
2995 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
2997 /* Get a zero-based index into the vector. */
2998 index
= fold_build2_loc (input_location
, MINUS_EXPR
,
2999 gfc_array_index_type
,
3000 se
->loop
->loopvar
[i
], se
->loop
->from
[i
]);
3002 /* Multiply the index by the stride. */
3003 index
= fold_build2_loc (input_location
, MULT_EXPR
,
3004 gfc_array_index_type
,
3005 index
, gfc_conv_array_stride (desc
, 0));
3007 /* Read the vector to get an index into info->descriptor. */
3008 data
= build_fold_indirect_ref_loc (input_location
,
3009 gfc_conv_array_data (desc
));
3010 index
= gfc_build_array_ref (data
, index
, NULL
);
3011 index
= gfc_evaluate_now (index
, &se
->pre
);
3012 index
= fold_convert (gfc_array_index_type
, index
);
3014 /* Do any bounds checking on the final info->descriptor index. */
3015 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
3016 ar
->as
->type
!= AS_ASSUMED_SIZE
3017 || dim
< ar
->dimen
- 1);
3021 /* Scalarized dimension. */
3022 gcc_assert (info
&& se
->loop
);
3024 /* Multiply the loop variable by the stride and delta. */
3025 index
= se
->loop
->loopvar
[i
];
3026 if (!integer_onep (info
->stride
[dim
]))
3027 index
= fold_build2_loc (input_location
, MULT_EXPR
,
3028 gfc_array_index_type
, index
,
3030 if (!integer_zerop (info
->delta
[dim
]))
3031 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
3032 gfc_array_index_type
, index
,
3042 /* Temporary array or derived type component. */
3043 gcc_assert (se
->loop
);
3044 index
= se
->loop
->loopvar
[se
->loop
->order
[i
]];
3046 /* Pointer functions can have stride[0] different from unity.
3047 Use the stride returned by the function call and stored in
3048 the descriptor for the temporary. */
3049 if (se
->ss
&& se
->ss
->info
->type
== GFC_SS_FUNCTION
3050 && se
->ss
->info
->expr
3051 && se
->ss
->info
->expr
->symtree
3052 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
3053 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
->attr
.pointer
)
3054 stride
= gfc_conv_descriptor_stride_get (info
->descriptor
,
3057 if (info
->delta
[dim
] && !integer_zerop (info
->delta
[dim
]))
3058 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
3059 gfc_array_index_type
, index
, info
->delta
[dim
]);
3062 /* Multiply by the stride. */
3063 if (!integer_onep (stride
))
3064 index
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3071 /* Build a scalarized array reference using the vptr 'size'. */
3074 build_class_array_ref (gfc_se
*se
, tree base
, tree index
)
3079 tree decl
= NULL_TREE
;
3081 gfc_expr
*expr
= se
->ss
->info
->expr
;
3083 gfc_ref
*class_ref
= NULL
;
3086 if (se
->expr
&& DECL_P (se
->expr
) && DECL_LANG_SPECIFIC (se
->expr
)
3087 && GFC_DECL_SAVED_DESCRIPTOR (se
->expr
)
3088 && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (se
->expr
))))
3093 || (expr
->ts
.type
!= BT_CLASS
3094 && !gfc_is_alloc_class_array_function (expr
)
3095 && !gfc_is_class_array_ref (expr
, NULL
)))
3098 if (expr
->symtree
&& expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
3099 ts
= &expr
->symtree
->n
.sym
->ts
;
3103 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3105 if (ref
->type
== REF_COMPONENT
3106 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
3107 && ref
->next
&& ref
->next
->type
== REF_COMPONENT
3108 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0
3110 && ref
->next
->next
->type
== REF_ARRAY
3111 && ref
->next
->next
->u
.ar
.type
!= AR_ELEMENT
)
3113 ts
= &ref
->u
.c
.component
->ts
;
3123 if (class_ref
== NULL
&& expr
&& expr
->symtree
->n
.sym
->attr
.function
3124 && expr
->symtree
->n
.sym
== expr
->symtree
->n
.sym
->result
)
3126 gcc_assert (expr
->symtree
->n
.sym
->backend_decl
== current_function_decl
);
3127 decl
= gfc_get_fake_result_decl (expr
->symtree
->n
.sym
, 0);
3129 else if (expr
&& gfc_is_alloc_class_array_function (expr
))
3133 for (tmp
= base
; tmp
; tmp
= TREE_OPERAND (tmp
, 0))
3136 type
= TREE_TYPE (tmp
);
3139 if (GFC_CLASS_TYPE_P (type
))
3141 if (type
!= TYPE_CANONICAL (type
))
3142 type
= TYPE_CANONICAL (type
);
3150 if (decl
== NULL_TREE
)
3153 else if (class_ref
== NULL
)
3155 if (decl
== NULL_TREE
)
3156 decl
= expr
->symtree
->n
.sym
->backend_decl
;
3157 /* For class arrays the tree containing the class is stored in
3158 GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl.
3159 For all others it's sym's backend_decl directly. */
3160 if (DECL_LANG_SPECIFIC (decl
) && GFC_DECL_SAVED_DESCRIPTOR (decl
))
3161 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
3165 /* Remove everything after the last class reference, convert the
3166 expression and then recover its tailend once more. */
3168 ref
= class_ref
->next
;
3169 class_ref
->next
= NULL
;
3170 gfc_init_se (&tmpse
, NULL
);
3171 gfc_conv_expr (&tmpse
, expr
);
3172 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3174 class_ref
->next
= ref
;
3177 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
3178 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
3180 if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl
)))
3183 size
= gfc_class_vtab_size_get (decl
);
3185 /* For unlimited polymorphic entities then _len component needs to be
3186 multiplied with the size. If no _len component is present, then
3187 gfc_class_len_or_zero_get () return a zero_node. */
3188 tmp
= gfc_class_len_or_zero_get (decl
);
3189 if (!integer_zerop (tmp
))
3190 size
= fold_build2 (MULT_EXPR
, TREE_TYPE (index
),
3191 fold_convert (TREE_TYPE (index
), size
),
3192 fold_build2 (MAX_EXPR
, TREE_TYPE (index
),
3193 fold_convert (TREE_TYPE (index
), tmp
),
3194 fold_convert (TREE_TYPE (index
),
3195 integer_one_node
)));
3197 size
= fold_convert (TREE_TYPE (index
), size
);
3199 /* Build the address of the element. */
3200 type
= TREE_TYPE (TREE_TYPE (base
));
3201 offset
= fold_build2_loc (input_location
, MULT_EXPR
,
3202 gfc_array_index_type
,
3204 tmp
= gfc_build_addr_expr (pvoid_type_node
, base
);
3205 tmp
= fold_build_pointer_plus_loc (input_location
, tmp
, offset
);
3206 tmp
= fold_convert (build_pointer_type (type
), tmp
);
3208 /* Return the element in the se expression. */
3209 se
->expr
= build_fold_indirect_ref_loc (input_location
, tmp
);
3214 /* Build a scalarized reference to an array. */
3217 gfc_conv_scalarized_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
3219 gfc_array_info
*info
;
3220 tree decl
= NULL_TREE
;
3228 expr
= ss
->info
->expr
;
3229 info
= &ss
->info
->data
.array
;
3231 n
= se
->loop
->order
[0];
3235 index
= conv_array_index_offset (se
, ss
, ss
->dim
[n
], n
, ar
, info
->stride0
);
3236 /* Add the offset for this dimension to the stored offset for all other
3238 if (info
->offset
&& !integer_zerop (info
->offset
))
3239 index
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3240 index
, info
->offset
);
3242 if (expr
&& (is_subref_array (expr
)
3243 || (expr
->ts
.deferred
&& (expr
->expr_type
== EXPR_VARIABLE
3244 || expr
->expr_type
== EXPR_FUNCTION
))))
3245 decl
= expr
->symtree
->n
.sym
->backend_decl
;
3247 tmp
= build_fold_indirect_ref_loc (input_location
, info
->data
);
3249 /* Use the vptr 'size' field to access a class the element of a class
3251 if (build_class_array_ref (se
, tmp
, index
))
3254 se
->expr
= gfc_build_array_ref (tmp
, index
, decl
);
3258 /* Translate access of temporary array. */
3261 gfc_conv_tmp_array_ref (gfc_se
* se
)
3263 se
->string_length
= se
->ss
->info
->string_length
;
3264 gfc_conv_scalarized_array_ref (se
, NULL
);
3265 gfc_advance_se_ss_chain (se
);
3268 /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
3271 add_to_offset (tree
*cst_offset
, tree
*offset
, tree t
)
3273 if (TREE_CODE (t
) == INTEGER_CST
)
3274 *cst_offset
= int_const_binop (PLUS_EXPR
, *cst_offset
, t
);
3277 if (!integer_zerop (*offset
))
3278 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3279 gfc_array_index_type
, *offset
, t
);
3287 build_array_ref (tree desc
, tree offset
, tree decl
, tree vptr
)
3292 bool classarray
= false;
3294 /* For class arrays the class declaration is stored in the saved
3296 if (INDIRECT_REF_P (desc
)
3297 && DECL_LANG_SPECIFIC (TREE_OPERAND (desc
, 0))
3298 && GFC_DECL_SAVED_DESCRIPTOR (TREE_OPERAND (desc
, 0)))
3299 cdecl = gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (
3300 TREE_OPERAND (desc
, 0)));
3304 /* Class container types do not always have the GFC_CLASS_TYPE_P
3305 but the canonical type does. */
3306 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdecl))
3307 && TREE_CODE (cdecl) == COMPONENT_REF
)
3309 type
= TREE_TYPE (TREE_OPERAND (cdecl, 0));
3310 if (TYPE_CANONICAL (type
)
3311 && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type
)))
3313 type
= TREE_TYPE (desc
);
3320 /* Class array references need special treatment because the assigned
3321 type size needs to be used to point to the element. */
3324 type
= gfc_get_element_type (type
);
3325 tmp
= TREE_OPERAND (cdecl, 0);
3326 tmp
= gfc_get_class_array_ref (offset
, tmp
, NULL_TREE
);
3327 tmp
= fold_convert (build_pointer_type (type
), tmp
);
3328 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3332 tmp
= gfc_conv_array_data (desc
);
3333 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3334 tmp
= gfc_build_array_ref (tmp
, offset
, decl
, vptr
);
3339 /* Build an array reference. se->expr already holds the array descriptor.
3340 This should be either a variable, indirect variable reference or component
3341 reference. For arrays which do not have a descriptor, se->expr will be
3343 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
3346 gfc_conv_array_ref (gfc_se
* se
, gfc_array_ref
* ar
, gfc_expr
*expr
,
3350 tree offset
, cst_offset
;
3355 gfc_symbol
* sym
= expr
->symtree
->n
.sym
;
3356 char *var_name
= NULL
;
3360 gcc_assert (ar
->codimen
);
3362 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
->expr
)))
3363 se
->expr
= build_fold_indirect_ref (gfc_conv_array_data (se
->expr
));
3366 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se
->expr
))
3367 && TREE_CODE (TREE_TYPE (se
->expr
)) == POINTER_TYPE
)
3368 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3370 /* Use the actual tree type and not the wrapped coarray. */
3371 if (!se
->want_pointer
)
3372 se
->expr
= fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se
->expr
)),
3379 /* Handle scalarized references separately. */
3380 if (ar
->type
!= AR_ELEMENT
)
3382 gfc_conv_scalarized_array_ref (se
, ar
);
3383 gfc_advance_se_ss_chain (se
);
3387 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3392 len
= strlen (sym
->name
) + 1;
3393 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3395 if (ref
->type
== REF_ARRAY
&& &ref
->u
.ar
== ar
)
3397 if (ref
->type
== REF_COMPONENT
)
3398 len
+= 2 + strlen (ref
->u
.c
.component
->name
);
3401 var_name
= XALLOCAVEC (char, len
);
3402 strcpy (var_name
, sym
->name
);
3404 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3406 if (ref
->type
== REF_ARRAY
&& &ref
->u
.ar
== ar
)
3408 if (ref
->type
== REF_COMPONENT
)
3410 strcat (var_name
, "%%");
3411 strcat (var_name
, ref
->u
.c
.component
->name
);
3416 cst_offset
= offset
= gfc_index_zero_node
;
3417 add_to_offset (&cst_offset
, &offset
, gfc_conv_array_offset (se
->expr
));
3419 /* Calculate the offsets from all the dimensions. Make sure to associate
3420 the final offset so that we form a chain of loop invariant summands. */
3421 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
3423 /* Calculate the index for this dimension. */
3424 gfc_init_se (&indexse
, se
);
3425 gfc_conv_expr_type (&indexse
, ar
->start
[n
], gfc_array_index_type
);
3426 gfc_add_block_to_block (&se
->pre
, &indexse
.pre
);
3428 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3430 /* Check array bounds. */
3434 /* Evaluate the indexse.expr only once. */
3435 indexse
.expr
= save_expr (indexse
.expr
);
3438 tmp
= gfc_conv_array_lbound (se
->expr
, n
);
3439 if (sym
->attr
.temporary
)
3441 gfc_init_se (&tmpse
, se
);
3442 gfc_conv_expr_type (&tmpse
, ar
->as
->lower
[n
],
3443 gfc_array_index_type
);
3444 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3448 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
3450 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3451 "below lower bound of %%ld", n
+1, var_name
);
3452 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3453 fold_convert (long_integer_type_node
,
3455 fold_convert (long_integer_type_node
, tmp
));
3458 /* Upper bound, but not for the last dimension of assumed-size
3460 if (n
< ar
->dimen
- 1 || ar
->as
->type
!= AS_ASSUMED_SIZE
)
3462 tmp
= gfc_conv_array_ubound (se
->expr
, n
);
3463 if (sym
->attr
.temporary
)
3465 gfc_init_se (&tmpse
, se
);
3466 gfc_conv_expr_type (&tmpse
, ar
->as
->upper
[n
],
3467 gfc_array_index_type
);
3468 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3472 cond
= fold_build2_loc (input_location
, GT_EXPR
,
3473 boolean_type_node
, indexse
.expr
, tmp
);
3474 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3475 "above upper bound of %%ld", n
+1, var_name
);
3476 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3477 fold_convert (long_integer_type_node
,
3479 fold_convert (long_integer_type_node
, tmp
));
3484 /* Multiply the index by the stride. */
3485 stride
= gfc_conv_array_stride (se
->expr
, n
);
3486 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3487 indexse
.expr
, stride
);
3489 /* And add it to the total. */
3490 add_to_offset (&cst_offset
, &offset
, tmp
);
3493 if (!integer_zerop (cst_offset
))
3494 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3495 gfc_array_index_type
, offset
, cst_offset
);
3497 se
->expr
= build_array_ref (se
->expr
, offset
, sym
->ts
.type
== BT_CLASS
?
3498 NULL_TREE
: sym
->backend_decl
, se
->class_vptr
);
3502 /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
3503 LOOP_DIM dimension (if any) to array's offset. */
3506 add_array_offset (stmtblock_t
*pblock
, gfc_loopinfo
*loop
, gfc_ss
*ss
,
3507 gfc_array_ref
*ar
, int array_dim
, int loop_dim
)
3510 gfc_array_info
*info
;
3513 info
= &ss
->info
->data
.array
;
3515 gfc_init_se (&se
, NULL
);
3517 se
.expr
= info
->descriptor
;
3518 stride
= gfc_conv_array_stride (info
->descriptor
, array_dim
);
3519 index
= conv_array_index_offset (&se
, ss
, array_dim
, loop_dim
, ar
, stride
);
3520 gfc_add_block_to_block (pblock
, &se
.pre
);
3522 info
->offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3523 gfc_array_index_type
,
3524 info
->offset
, index
);
3525 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
3529 /* Generate the code to be executed immediately before entering a
3530 scalarization loop. */
3533 gfc_trans_preloop_setup (gfc_loopinfo
* loop
, int dim
, int flag
,
3534 stmtblock_t
* pblock
)
3537 gfc_ss_info
*ss_info
;
3538 gfc_array_info
*info
;
3539 gfc_ss_type ss_type
;
3541 gfc_loopinfo
*ploop
;
3545 /* This code will be executed before entering the scalarization loop
3546 for this dimension. */
3547 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3551 if ((ss_info
->useflags
& flag
) == 0)
3554 ss_type
= ss_info
->type
;
3555 if (ss_type
!= GFC_SS_SECTION
3556 && ss_type
!= GFC_SS_FUNCTION
3557 && ss_type
!= GFC_SS_CONSTRUCTOR
3558 && ss_type
!= GFC_SS_COMPONENT
)
3561 info
= &ss_info
->data
.array
;
3563 gcc_assert (dim
< ss
->dimen
);
3564 gcc_assert (ss
->dimen
== loop
->dimen
);
3567 ar
= &info
->ref
->u
.ar
;
3571 if (dim
== loop
->dimen
- 1 && loop
->parent
!= NULL
)
3573 /* If we are in the outermost dimension of this loop, the previous
3574 dimension shall be in the parent loop. */
3575 gcc_assert (ss
->parent
!= NULL
);
3578 ploop
= loop
->parent
;
3580 /* ss and ss->parent are about the same array. */
3581 gcc_assert (ss_info
== pss
->info
);
3589 if (dim
== loop
->dimen
- 1)
3594 /* For the time being, there is no loop reordering. */
3595 gcc_assert (i
== ploop
->order
[i
]);
3596 i
= ploop
->order
[i
];
3598 if (dim
== loop
->dimen
- 1 && loop
->parent
== NULL
)
3600 stride
= gfc_conv_array_stride (info
->descriptor
,
3601 innermost_ss (ss
)->dim
[i
]);
3603 /* Calculate the stride of the innermost loop. Hopefully this will
3604 allow the backend optimizers to do their stuff more effectively.
3606 info
->stride0
= gfc_evaluate_now (stride
, pblock
);
3608 /* For the outermost loop calculate the offset due to any
3609 elemental dimensions. It will have been initialized with the
3610 base offset of the array. */
3613 for (i
= 0; i
< ar
->dimen
; i
++)
3615 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
3618 add_array_offset (pblock
, loop
, ss
, ar
, i
, /* unused */ -1);
3623 /* Add the offset for the previous loop dimension. */
3624 add_array_offset (pblock
, ploop
, ss
, ar
, pss
->dim
[i
], i
);
3626 /* Remember this offset for the second loop. */
3627 if (dim
== loop
->temp_dim
- 1 && loop
->parent
== NULL
)
3628 info
->saved_offset
= info
->offset
;
3633 /* Start a scalarized expression. Creates a scope and declares loop
3637 gfc_start_scalarized_body (gfc_loopinfo
* loop
, stmtblock_t
* pbody
)
3643 gcc_assert (!loop
->array_parameter
);
3645 for (dim
= loop
->dimen
- 1; dim
>= 0; dim
--)
3647 n
= loop
->order
[dim
];
3649 gfc_start_block (&loop
->code
[n
]);
3651 /* Create the loop variable. */
3652 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "S");
3654 if (dim
< loop
->temp_dim
)
3658 /* Calculate values that will be constant within this loop. */
3659 gfc_trans_preloop_setup (loop
, dim
, flags
, &loop
->code
[n
]);
3661 gfc_start_block (pbody
);
3665 /* Generates the actual loop code for a scalarization loop. */
3668 gfc_trans_scalarized_loop_end (gfc_loopinfo
* loop
, int n
,
3669 stmtblock_t
* pbody
)
3680 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
3681 | OMPWS_SCALARIZER_BODY
))
3682 == (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
)
3683 && n
== loop
->dimen
- 1)
3685 /* We create an OMP_FOR construct for the outermost scalarized loop. */
3686 init
= make_tree_vec (1);
3687 cond
= make_tree_vec (1);
3688 incr
= make_tree_vec (1);
3690 /* Cycle statement is implemented with a goto. Exit statement must not
3691 be present for this loop. */
3692 exit_label
= gfc_build_label_decl (NULL_TREE
);
3693 TREE_USED (exit_label
) = 1;
3695 /* Label for cycle statements (if needed). */
3696 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3697 gfc_add_expr_to_block (pbody
, tmp
);
3699 stmt
= make_node (OMP_FOR
);
3701 TREE_TYPE (stmt
) = void_type_node
;
3702 OMP_FOR_BODY (stmt
) = loopbody
= gfc_finish_block (pbody
);
3704 OMP_FOR_CLAUSES (stmt
) = build_omp_clause (input_location
,
3705 OMP_CLAUSE_SCHEDULE
);
3706 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt
))
3707 = OMP_CLAUSE_SCHEDULE_STATIC
;
3708 if (ompws_flags
& OMPWS_NOWAIT
)
3709 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt
))
3710 = build_omp_clause (input_location
, OMP_CLAUSE_NOWAIT
);
3712 /* Initialize the loopvar. */
3713 TREE_VEC_ELT (init
, 0) = build2_v (MODIFY_EXPR
, loop
->loopvar
[n
],
3715 OMP_FOR_INIT (stmt
) = init
;
3716 /* The exit condition. */
3717 TREE_VEC_ELT (cond
, 0) = build2_loc (input_location
, LE_EXPR
,
3719 loop
->loopvar
[n
], loop
->to
[n
]);
3720 SET_EXPR_LOCATION (TREE_VEC_ELT (cond
, 0), input_location
);
3721 OMP_FOR_COND (stmt
) = cond
;
3722 /* Increment the loopvar. */
3723 tmp
= build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3724 loop
->loopvar
[n
], gfc_index_one_node
);
3725 TREE_VEC_ELT (incr
, 0) = fold_build2_loc (input_location
, MODIFY_EXPR
,
3726 void_type_node
, loop
->loopvar
[n
], tmp
);
3727 OMP_FOR_INCR (stmt
) = incr
;
3729 ompws_flags
&= ~OMPWS_CURR_SINGLEUNIT
;
3730 gfc_add_expr_to_block (&loop
->code
[n
], stmt
);
3734 bool reverse_loop
= (loop
->reverse
[n
] == GFC_REVERSE_SET
)
3735 && (loop
->temp_ss
== NULL
);
3737 loopbody
= gfc_finish_block (pbody
);
3740 std::swap (loop
->from
[n
], loop
->to
[n
]);
3742 /* Initialize the loopvar. */
3743 if (loop
->loopvar
[n
] != loop
->from
[n
])
3744 gfc_add_modify (&loop
->code
[n
], loop
->loopvar
[n
], loop
->from
[n
]);
3746 exit_label
= gfc_build_label_decl (NULL_TREE
);
3748 /* Generate the loop body. */
3749 gfc_init_block (&block
);
3751 /* The exit condition. */
3752 cond
= fold_build2_loc (input_location
, reverse_loop
? LT_EXPR
: GT_EXPR
,
3753 boolean_type_node
, loop
->loopvar
[n
], loop
->to
[n
]);
3754 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3755 TREE_USED (exit_label
) = 1;
3756 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3757 gfc_add_expr_to_block (&block
, tmp
);
3759 /* The main body. */
3760 gfc_add_expr_to_block (&block
, loopbody
);
3762 /* Increment the loopvar. */
3763 tmp
= fold_build2_loc (input_location
,
3764 reverse_loop
? MINUS_EXPR
: PLUS_EXPR
,
3765 gfc_array_index_type
, loop
->loopvar
[n
],
3766 gfc_index_one_node
);
3768 gfc_add_modify (&block
, loop
->loopvar
[n
], tmp
);
3770 /* Build the loop. */
3771 tmp
= gfc_finish_block (&block
);
3772 tmp
= build1_v (LOOP_EXPR
, tmp
);
3773 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
3775 /* Add the exit label. */
3776 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3777 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
3783 /* Finishes and generates the loops for a scalarized expression. */
3786 gfc_trans_scalarizing_loops (gfc_loopinfo
* loop
, stmtblock_t
* body
)
3791 stmtblock_t
*pblock
;
3795 /* Generate the loops. */
3796 for (dim
= 0; dim
< loop
->dimen
; dim
++)
3798 n
= loop
->order
[dim
];
3799 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
3800 loop
->loopvar
[n
] = NULL_TREE
;
3801 pblock
= &loop
->code
[n
];
3804 tmp
= gfc_finish_block (pblock
);
3805 gfc_add_expr_to_block (&loop
->pre
, tmp
);
3807 /* Clear all the used flags. */
3808 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3809 if (ss
->parent
== NULL
)
3810 ss
->info
->useflags
= 0;
3814 /* Finish the main body of a scalarized expression, and start the secondary
3818 gfc_trans_scalarized_loop_boundary (gfc_loopinfo
* loop
, stmtblock_t
* body
)
3822 stmtblock_t
*pblock
;
3826 /* We finish as many loops as are used by the temporary. */
3827 for (dim
= 0; dim
< loop
->temp_dim
- 1; dim
++)
3829 n
= loop
->order
[dim
];
3830 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
3831 loop
->loopvar
[n
] = NULL_TREE
;
3832 pblock
= &loop
->code
[n
];
3835 /* We don't want to finish the outermost loop entirely. */
3836 n
= loop
->order
[loop
->temp_dim
- 1];
3837 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
3839 /* Restore the initial offsets. */
3840 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3842 gfc_ss_type ss_type
;
3843 gfc_ss_info
*ss_info
;
3847 if ((ss_info
->useflags
& 2) == 0)
3850 ss_type
= ss_info
->type
;
3851 if (ss_type
!= GFC_SS_SECTION
3852 && ss_type
!= GFC_SS_FUNCTION
3853 && ss_type
!= GFC_SS_CONSTRUCTOR
3854 && ss_type
!= GFC_SS_COMPONENT
)
3857 ss_info
->data
.array
.offset
= ss_info
->data
.array
.saved_offset
;
3860 /* Restart all the inner loops we just finished. */
3861 for (dim
= loop
->temp_dim
- 2; dim
>= 0; dim
--)
3863 n
= loop
->order
[dim
];
3865 gfc_start_block (&loop
->code
[n
]);
3867 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "Q");
3869 gfc_trans_preloop_setup (loop
, dim
, 2, &loop
->code
[n
]);
3872 /* Start a block for the secondary copying code. */
3873 gfc_start_block (body
);
3877 /* Precalculate (either lower or upper) bound of an array section.
3878 BLOCK: Block in which the (pre)calculation code will go.
3879 BOUNDS[DIM]: Where the bound value will be stored once evaluated.
3880 VALUES[DIM]: Specified bound (NULL <=> unspecified).
3881 DESC: Array descriptor from which the bound will be picked if unspecified
3882 (either lower or upper bound according to LBOUND). */
3885 evaluate_bound (stmtblock_t
*block
, tree
*bounds
, gfc_expr
** values
,
3886 tree desc
, int dim
, bool lbound
, bool deferred
)
3889 gfc_expr
* input_val
= values
[dim
];
3890 tree
*output
= &bounds
[dim
];
3895 /* Specified section bound. */
3896 gfc_init_se (&se
, NULL
);
3897 gfc_conv_expr_type (&se
, input_val
, gfc_array_index_type
);
3898 gfc_add_block_to_block (block
, &se
.pre
);
3901 else if (deferred
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
3903 /* The gfc_conv_array_lbound () routine returns a constant zero for
3904 deferred length arrays, which in the scalarizer wreaks havoc, when
3905 copying to a (newly allocated) one-based array.
3906 Keep returning the actual result in sync for both bounds. */
3907 *output
= lbound
? gfc_conv_descriptor_lbound_get (desc
,
3909 gfc_conv_descriptor_ubound_get (desc
,
3914 /* No specific bound specified so use the bound of the array. */
3915 *output
= lbound
? gfc_conv_array_lbound (desc
, dim
) :
3916 gfc_conv_array_ubound (desc
, dim
);
3918 *output
= gfc_evaluate_now (*output
, block
);
3922 /* Calculate the lower bound of an array section. */
3925 gfc_conv_section_startstride (stmtblock_t
* block
, gfc_ss
* ss
, int dim
)
3927 gfc_expr
*stride
= NULL
;
3930 gfc_array_info
*info
;
3933 gcc_assert (ss
->info
->type
== GFC_SS_SECTION
);
3935 info
= &ss
->info
->data
.array
;
3936 ar
= &info
->ref
->u
.ar
;
3938 if (ar
->dimen_type
[dim
] == DIMEN_VECTOR
)
3940 /* We use a zero-based index to access the vector. */
3941 info
->start
[dim
] = gfc_index_zero_node
;
3942 info
->end
[dim
] = NULL
;
3943 info
->stride
[dim
] = gfc_index_one_node
;
3947 gcc_assert (ar
->dimen_type
[dim
] == DIMEN_RANGE
3948 || ar
->dimen_type
[dim
] == DIMEN_THIS_IMAGE
);
3949 desc
= info
->descriptor
;
3950 stride
= ar
->stride
[dim
];
3953 /* Calculate the start of the range. For vector subscripts this will
3954 be the range of the vector. */
3955 evaluate_bound (block
, info
->start
, ar
->start
, desc
, dim
, true,
3956 ar
->as
->type
== AS_DEFERRED
);
3958 /* Similarly calculate the end. Although this is not used in the
3959 scalarizer, it is needed when checking bounds and where the end
3960 is an expression with side-effects. */
3961 evaluate_bound (block
, info
->end
, ar
->end
, desc
, dim
, false,
3962 ar
->as
->type
== AS_DEFERRED
);
3965 /* Calculate the stride. */
3967 info
->stride
[dim
] = gfc_index_one_node
;
3970 gfc_init_se (&se
, NULL
);
3971 gfc_conv_expr_type (&se
, stride
, gfc_array_index_type
);
3972 gfc_add_block_to_block (block
, &se
.pre
);
3973 info
->stride
[dim
] = gfc_evaluate_now (se
.expr
, block
);
3978 /* Calculates the range start and stride for a SS chain. Also gets the
3979 descriptor and data pointer. The range of vector subscripts is the size
3980 of the vector. Array bounds are also checked. */
3983 gfc_conv_ss_startstride (gfc_loopinfo
* loop
)
3990 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
3993 /* Determine the rank of the loop. */
3994 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3996 switch (ss
->info
->type
)
3998 case GFC_SS_SECTION
:
3999 case GFC_SS_CONSTRUCTOR
:
4000 case GFC_SS_FUNCTION
:
4001 case GFC_SS_COMPONENT
:
4002 loop
->dimen
= ss
->dimen
;
4005 /* As usual, lbound and ubound are exceptions!. */
4006 case GFC_SS_INTRINSIC
:
4007 switch (ss
->info
->expr
->value
.function
.isym
->id
)
4009 case GFC_ISYM_LBOUND
:
4010 case GFC_ISYM_UBOUND
:
4011 case GFC_ISYM_LCOBOUND
:
4012 case GFC_ISYM_UCOBOUND
:
4013 case GFC_ISYM_THIS_IMAGE
:
4014 loop
->dimen
= ss
->dimen
;
4026 /* We should have determined the rank of the expression by now. If
4027 not, that's bad news. */
4031 /* Loop over all the SS in the chain. */
4032 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4034 gfc_ss_info
*ss_info
;
4035 gfc_array_info
*info
;
4039 expr
= ss_info
->expr
;
4040 info
= &ss_info
->data
.array
;
4042 if (expr
&& expr
->shape
&& !info
->shape
)
4043 info
->shape
= expr
->shape
;
4045 switch (ss_info
->type
)
4047 case GFC_SS_SECTION
:
4048 /* Get the descriptor for the array. If it is a cross loops array,
4049 we got the descriptor already in the outermost loop. */
4050 if (ss
->parent
== NULL
)
4051 gfc_conv_ss_descriptor (&outer_loop
->pre
, ss
,
4052 !loop
->array_parameter
);
4054 for (n
= 0; n
< ss
->dimen
; n
++)
4055 gfc_conv_section_startstride (&outer_loop
->pre
, ss
, ss
->dim
[n
]);
4058 case GFC_SS_INTRINSIC
:
4059 switch (expr
->value
.function
.isym
->id
)
4061 /* Fall through to supply start and stride. */
4062 case GFC_ISYM_LBOUND
:
4063 case GFC_ISYM_UBOUND
:
4067 /* This is the variant without DIM=... */
4068 gcc_assert (expr
->value
.function
.actual
->next
->expr
== NULL
);
4070 arg
= expr
->value
.function
.actual
->expr
;
4071 if (arg
->rank
== -1)
4076 /* The rank (hence the return value's shape) is unknown,
4077 we have to retrieve it. */
4078 gfc_init_se (&se
, NULL
);
4079 se
.descriptor_only
= 1;
4080 gfc_conv_expr (&se
, arg
);
4081 /* This is a bare variable, so there is no preliminary
4083 gcc_assert (se
.pre
.head
== NULL_TREE
4084 && se
.post
.head
== NULL_TREE
);
4085 rank
= gfc_conv_descriptor_rank (se
.expr
);
4086 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4087 gfc_array_index_type
,
4088 fold_convert (gfc_array_index_type
,
4090 gfc_index_one_node
);
4091 info
->end
[0] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
4092 info
->start
[0] = gfc_index_zero_node
;
4093 info
->stride
[0] = gfc_index_one_node
;
4096 /* Otherwise fall through GFC_SS_FUNCTION. */
4099 case GFC_ISYM_LCOBOUND
:
4100 case GFC_ISYM_UCOBOUND
:
4101 case GFC_ISYM_THIS_IMAGE
:
4109 case GFC_SS_CONSTRUCTOR
:
4110 case GFC_SS_FUNCTION
:
4111 for (n
= 0; n
< ss
->dimen
; n
++)
4113 int dim
= ss
->dim
[n
];
4115 info
->start
[dim
] = gfc_index_zero_node
;
4116 info
->end
[dim
] = gfc_index_zero_node
;
4117 info
->stride
[dim
] = gfc_index_one_node
;
4126 /* The rest is just runtime bound checking. */
4127 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
4130 tree lbound
, ubound
;
4132 tree size
[GFC_MAX_DIMENSIONS
];
4133 tree stride_pos
, stride_neg
, non_zerosized
, tmp2
, tmp3
;
4134 gfc_array_info
*info
;
4138 gfc_start_block (&block
);
4140 for (n
= 0; n
< loop
->dimen
; n
++)
4141 size
[n
] = NULL_TREE
;
4143 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4146 gfc_ss_info
*ss_info
;
4149 const char *expr_name
;
4152 if (ss_info
->type
!= GFC_SS_SECTION
)
4155 /* Catch allocatable lhs in f2003. */
4156 if (flag_realloc_lhs
&& ss
->is_alloc_lhs
)
4159 expr
= ss_info
->expr
;
4160 expr_loc
= &expr
->where
;
4161 expr_name
= expr
->symtree
->name
;
4163 gfc_start_block (&inner
);
4165 /* TODO: range checking for mapped dimensions. */
4166 info
= &ss_info
->data
.array
;
4168 /* This code only checks ranges. Elemental and vector
4169 dimensions are checked later. */
4170 for (n
= 0; n
< loop
->dimen
; n
++)
4175 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
4178 if (dim
== info
->ref
->u
.ar
.dimen
- 1
4179 && info
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
4180 check_upper
= false;
4184 /* Zero stride is not allowed. */
4185 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4186 info
->stride
[dim
], gfc_index_zero_node
);
4187 msg
= xasprintf ("Zero stride is not allowed, for dimension %d "
4188 "of array '%s'", dim
+ 1, expr_name
);
4189 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4193 desc
= info
->descriptor
;
4195 /* This is the run-time equivalent of resolve.c's
4196 check_dimension(). The logical is more readable there
4197 than it is here, with all the trees. */
4198 lbound
= gfc_conv_array_lbound (desc
, dim
);
4199 end
= info
->end
[dim
];
4201 ubound
= gfc_conv_array_ubound (desc
, dim
);
4205 /* non_zerosized is true when the selected range is not
4207 stride_pos
= fold_build2_loc (input_location
, GT_EXPR
,
4208 boolean_type_node
, info
->stride
[dim
],
4209 gfc_index_zero_node
);
4210 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
4211 info
->start
[dim
], end
);
4212 stride_pos
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4213 boolean_type_node
, stride_pos
, tmp
);
4215 stride_neg
= fold_build2_loc (input_location
, LT_EXPR
,
4217 info
->stride
[dim
], gfc_index_zero_node
);
4218 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
4219 info
->start
[dim
], end
);
4220 stride_neg
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4223 non_zerosized
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
4225 stride_pos
, stride_neg
);
4227 /* Check the start of the range against the lower and upper
4228 bounds of the array, if the range is not empty.
4229 If upper bound is present, include both bounds in the
4233 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
4235 info
->start
[dim
], lbound
);
4236 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4238 non_zerosized
, tmp
);
4239 tmp2
= fold_build2_loc (input_location
, GT_EXPR
,
4241 info
->start
[dim
], ubound
);
4242 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4244 non_zerosized
, tmp2
);
4245 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4246 "outside of expected range (%%ld:%%ld)",
4247 dim
+ 1, expr_name
);
4248 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4250 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4251 fold_convert (long_integer_type_node
, lbound
),
4252 fold_convert (long_integer_type_node
, ubound
));
4253 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4255 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4256 fold_convert (long_integer_type_node
, lbound
),
4257 fold_convert (long_integer_type_node
, ubound
));
4262 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
4264 info
->start
[dim
], lbound
);
4265 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4266 boolean_type_node
, non_zerosized
, tmp
);
4267 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4268 "below lower bound of %%ld",
4269 dim
+ 1, expr_name
);
4270 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4272 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4273 fold_convert (long_integer_type_node
, lbound
));
4277 /* Compute the last element of the range, which is not
4278 necessarily "end" (think 0:5:3, which doesn't contain 5)
4279 and check it against both lower and upper bounds. */
4281 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4282 gfc_array_index_type
, end
,
4284 tmp
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
,
4285 gfc_array_index_type
, tmp
,
4287 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4288 gfc_array_index_type
, end
, tmp
);
4289 tmp2
= fold_build2_loc (input_location
, LT_EXPR
,
4290 boolean_type_node
, tmp
, lbound
);
4291 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4292 boolean_type_node
, non_zerosized
, tmp2
);
4295 tmp3
= fold_build2_loc (input_location
, GT_EXPR
,
4296 boolean_type_node
, tmp
, ubound
);
4297 tmp3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4298 boolean_type_node
, non_zerosized
, tmp3
);
4299 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4300 "outside of expected range (%%ld:%%ld)",
4301 dim
+ 1, expr_name
);
4302 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4304 fold_convert (long_integer_type_node
, tmp
),
4305 fold_convert (long_integer_type_node
, ubound
),
4306 fold_convert (long_integer_type_node
, lbound
));
4307 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4309 fold_convert (long_integer_type_node
, tmp
),
4310 fold_convert (long_integer_type_node
, ubound
),
4311 fold_convert (long_integer_type_node
, lbound
));
4316 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4317 "below lower bound of %%ld",
4318 dim
+ 1, expr_name
);
4319 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4321 fold_convert (long_integer_type_node
, tmp
),
4322 fold_convert (long_integer_type_node
, lbound
));
4326 /* Check the section sizes match. */
4327 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4328 gfc_array_index_type
, end
,
4330 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
4331 gfc_array_index_type
, tmp
,
4333 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4334 gfc_array_index_type
,
4335 gfc_index_one_node
, tmp
);
4336 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
4337 gfc_array_index_type
, tmp
,
4338 build_int_cst (gfc_array_index_type
, 0));
4339 /* We remember the size of the first section, and check all the
4340 others against this. */
4343 tmp3
= fold_build2_loc (input_location
, NE_EXPR
,
4344 boolean_type_node
, tmp
, size
[n
]);
4345 msg
= xasprintf ("Array bound mismatch for dimension %d "
4346 "of array '%s' (%%ld/%%ld)",
4347 dim
+ 1, expr_name
);
4349 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4351 fold_convert (long_integer_type_node
, tmp
),
4352 fold_convert (long_integer_type_node
, size
[n
]));
4357 size
[n
] = gfc_evaluate_now (tmp
, &inner
);
4360 tmp
= gfc_finish_block (&inner
);
4362 /* For optional arguments, only check bounds if the argument is
4364 if (expr
->symtree
->n
.sym
->attr
.optional
4365 || expr
->symtree
->n
.sym
->attr
.not_always_present
)
4366 tmp
= build3_v (COND_EXPR
,
4367 gfc_conv_expr_present (expr
->symtree
->n
.sym
),
4368 tmp
, build_empty_stmt (input_location
));
4370 gfc_add_expr_to_block (&block
, tmp
);
4374 tmp
= gfc_finish_block (&block
);
4375 gfc_add_expr_to_block (&outer_loop
->pre
, tmp
);
4378 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4379 gfc_conv_ss_startstride (loop
);
4382 /* Return true if both symbols could refer to the same data object. Does
4383 not take account of aliasing due to equivalence statements. */
4386 symbols_could_alias (gfc_symbol
*lsym
, gfc_symbol
*rsym
, bool lsym_pointer
,
4387 bool lsym_target
, bool rsym_pointer
, bool rsym_target
)
4389 /* Aliasing isn't possible if the symbols have different base types. */
4390 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
4393 /* Pointers can point to other pointers and target objects. */
4395 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4396 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4399 /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
4400 and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
4402 if (lsym_target
&& rsym_target
4403 && ((lsym
->attr
.dummy
&& !lsym
->attr
.contiguous
4404 && (!lsym
->attr
.dimension
|| lsym
->as
->type
== AS_ASSUMED_SHAPE
))
4405 || (rsym
->attr
.dummy
&& !rsym
->attr
.contiguous
4406 && (!rsym
->attr
.dimension
4407 || rsym
->as
->type
== AS_ASSUMED_SHAPE
))))
4414 /* Return true if the two SS could be aliased, i.e. both point to the same data
4416 /* TODO: resolve aliases based on frontend expressions. */
4419 gfc_could_be_alias (gfc_ss
* lss
, gfc_ss
* rss
)
4423 gfc_expr
*lexpr
, *rexpr
;
4426 bool lsym_pointer
, lsym_target
, rsym_pointer
, rsym_target
;
4428 lexpr
= lss
->info
->expr
;
4429 rexpr
= rss
->info
->expr
;
4431 lsym
= lexpr
->symtree
->n
.sym
;
4432 rsym
= rexpr
->symtree
->n
.sym
;
4434 lsym_pointer
= lsym
->attr
.pointer
;
4435 lsym_target
= lsym
->attr
.target
;
4436 rsym_pointer
= rsym
->attr
.pointer
;
4437 rsym_target
= rsym
->attr
.target
;
4439 if (symbols_could_alias (lsym
, rsym
, lsym_pointer
, lsym_target
,
4440 rsym_pointer
, rsym_target
))
4443 if (rsym
->ts
.type
!= BT_DERIVED
&& rsym
->ts
.type
!= BT_CLASS
4444 && lsym
->ts
.type
!= BT_DERIVED
&& lsym
->ts
.type
!= BT_CLASS
)
4447 /* For derived types we must check all the component types. We can ignore
4448 array references as these will have the same base type as the previous
4450 for (lref
= lexpr
->ref
; lref
!= lss
->info
->data
.array
.ref
; lref
= lref
->next
)
4452 if (lref
->type
!= REF_COMPONENT
)
4455 lsym_pointer
= lsym_pointer
|| lref
->u
.c
.sym
->attr
.pointer
;
4456 lsym_target
= lsym_target
|| lref
->u
.c
.sym
->attr
.target
;
4458 if (symbols_could_alias (lref
->u
.c
.sym
, rsym
, lsym_pointer
, lsym_target
,
4459 rsym_pointer
, rsym_target
))
4462 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4463 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4465 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4470 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
;
4473 if (rref
->type
!= REF_COMPONENT
)
4476 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4477 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4479 if (symbols_could_alias (lref
->u
.c
.sym
, rref
->u
.c
.sym
,
4480 lsym_pointer
, lsym_target
,
4481 rsym_pointer
, rsym_target
))
4484 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4485 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4487 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4488 &rref
->u
.c
.sym
->ts
))
4490 if (gfc_compare_types (&lref
->u
.c
.sym
->ts
,
4491 &rref
->u
.c
.component
->ts
))
4493 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4494 &rref
->u
.c
.component
->ts
))
4500 lsym_pointer
= lsym
->attr
.pointer
;
4501 lsym_target
= lsym
->attr
.target
;
4502 lsym_pointer
= lsym
->attr
.pointer
;
4503 lsym_target
= lsym
->attr
.target
;
4505 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
; rref
= rref
->next
)
4507 if (rref
->type
!= REF_COMPONENT
)
4510 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4511 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4513 if (symbols_could_alias (rref
->u
.c
.sym
, lsym
,
4514 lsym_pointer
, lsym_target
,
4515 rsym_pointer
, rsym_target
))
4518 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4519 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4521 if (gfc_compare_types (&lsym
->ts
, &rref
->u
.c
.component
->ts
))
4530 /* Resolve array data dependencies. Creates a temporary if required. */
4531 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
4535 gfc_conv_resolve_dependencies (gfc_loopinfo
* loop
, gfc_ss
* dest
,
4541 gfc_ss_info
*ss_info
;
4542 gfc_expr
*dest_expr
;
4547 loop
->temp_ss
= NULL
;
4548 dest_expr
= dest
->info
->expr
;
4550 for (ss
= rss
; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
4553 ss_expr
= ss_info
->expr
;
4555 if (ss_info
->array_outer_dependency
)
4561 if (ss_info
->type
!= GFC_SS_SECTION
)
4563 if (flag_realloc_lhs
4564 && dest_expr
!= ss_expr
4565 && gfc_is_reallocatable_lhs (dest_expr
)
4567 nDepend
= gfc_check_dependency (dest_expr
, ss_expr
, true);
4569 /* Check for cases like c(:)(1:2) = c(2)(2:3) */
4570 if (!nDepend
&& dest_expr
->rank
> 0
4571 && dest_expr
->ts
.type
== BT_CHARACTER
4572 && ss_expr
->expr_type
== EXPR_VARIABLE
)
4574 nDepend
= gfc_check_dependency (dest_expr
, ss_expr
, false);
4576 if (ss_info
->type
== GFC_SS_REFERENCE
4577 && gfc_check_dependency (dest_expr
, ss_expr
, false))
4578 ss_info
->data
.scalar
.needs_temporary
= 1;
4583 if (dest_expr
->symtree
->n
.sym
!= ss_expr
->symtree
->n
.sym
)
4585 if (gfc_could_be_alias (dest
, ss
)
4586 || gfc_are_equivalenced_arrays (dest_expr
, ss_expr
))
4594 lref
= dest_expr
->ref
;
4595 rref
= ss_expr
->ref
;
4597 nDepend
= gfc_dep_resolver (lref
, rref
, &loop
->reverse
[0]);
4602 for (i
= 0; i
< dest
->dimen
; i
++)
4603 for (j
= 0; j
< ss
->dimen
; j
++)
4605 && dest
->dim
[i
] == ss
->dim
[j
])
4607 /* If we don't access array elements in the same order,
4608 there is a dependency. */
4613 /* TODO : loop shifting. */
4616 /* Mark the dimensions for LOOP SHIFTING */
4617 for (n
= 0; n
< loop
->dimen
; n
++)
4619 int dim
= dest
->data
.info
.dim
[n
];
4621 if (lref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
4623 else if (! gfc_is_same_range (&lref
->u
.ar
,
4624 &rref
->u
.ar
, dim
, 0))
4628 /* Put all the dimensions with dependencies in the
4631 for (n
= 0; n
< loop
->dimen
; n
++)
4633 gcc_assert (loop
->order
[n
] == n
);
4635 loop
->order
[dim
++] = n
;
4637 for (n
= 0; n
< loop
->dimen
; n
++)
4640 loop
->order
[dim
++] = n
;
4643 gcc_assert (dim
== loop
->dimen
);
4654 tree base_type
= gfc_typenode_for_spec (&dest_expr
->ts
);
4655 if (GFC_ARRAY_TYPE_P (base_type
)
4656 || GFC_DESCRIPTOR_TYPE_P (base_type
))
4657 base_type
= gfc_get_element_type (base_type
);
4658 loop
->temp_ss
= gfc_get_temp_ss (base_type
, dest
->info
->string_length
,
4660 gfc_add_ss_to_loop (loop
, loop
->temp_ss
);
4663 loop
->temp_ss
= NULL
;
4667 /* Browse through each array's information from the scalarizer and set the loop
4668 bounds according to the "best" one (per dimension), i.e. the one which
4669 provides the most information (constant bounds, shape, etc.). */
4672 set_loop_bounds (gfc_loopinfo
*loop
)
4674 int n
, dim
, spec_dim
;
4675 gfc_array_info
*info
;
4676 gfc_array_info
*specinfo
;
4680 bool dynamic
[GFC_MAX_DIMENSIONS
];
4683 bool nonoptional_arr
;
4685 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
4687 loopspec
= loop
->specloop
;
4690 for (n
= 0; n
< loop
->dimen
; n
++)
4695 /* If there are both optional and nonoptional array arguments, scalarize
4696 over the nonoptional; otherwise, it does not matter as then all
4697 (optional) arrays have to be present per F2008, 125.2.12p3(6). */
4699 nonoptional_arr
= false;
4701 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4702 if (ss
->info
->type
!= GFC_SS_SCALAR
&& ss
->info
->type
!= GFC_SS_TEMP
4703 && ss
->info
->type
!= GFC_SS_REFERENCE
&& !ss
->info
->can_be_null_ref
)
4705 nonoptional_arr
= true;
4709 /* We use one SS term, and use that to determine the bounds of the
4710 loop for this dimension. We try to pick the simplest term. */
4711 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4713 gfc_ss_type ss_type
;
4715 ss_type
= ss
->info
->type
;
4716 if (ss_type
== GFC_SS_SCALAR
4717 || ss_type
== GFC_SS_TEMP
4718 || ss_type
== GFC_SS_REFERENCE
4719 || (ss
->info
->can_be_null_ref
&& nonoptional_arr
))
4722 info
= &ss
->info
->data
.array
;
4725 if (loopspec
[n
] != NULL
)
4727 specinfo
= &loopspec
[n
]->info
->data
.array
;
4728 spec_dim
= loopspec
[n
]->dim
[n
];
4732 /* Silence uninitialized warnings. */
4739 gcc_assert (info
->shape
[dim
]);
4740 /* The frontend has worked out the size for us. */
4743 || !integer_zerop (specinfo
->start
[spec_dim
]))
4744 /* Prefer zero-based descriptors if possible. */
4749 if (ss_type
== GFC_SS_CONSTRUCTOR
)
4751 gfc_constructor_base base
;
4752 /* An unknown size constructor will always be rank one.
4753 Higher rank constructors will either have known shape,
4754 or still be wrapped in a call to reshape. */
4755 gcc_assert (loop
->dimen
== 1);
4757 /* Always prefer to use the constructor bounds if the size
4758 can be determined at compile time. Prefer not to otherwise,
4759 since the general case involves realloc, and it's better to
4760 avoid that overhead if possible. */
4761 base
= ss
->info
->expr
->value
.constructor
;
4762 dynamic
[n
] = gfc_get_array_constructor_size (&i
, base
);
4763 if (!dynamic
[n
] || !loopspec
[n
])
4768 /* Avoid using an allocatable lhs in an assignment, since
4769 there might be a reallocation coming. */
4770 if (loopspec
[n
] && ss
->is_alloc_lhs
)
4775 /* Criteria for choosing a loop specifier (most important first):
4776 doesn't need realloc
4782 else if (loopspec
[n
]->info
->type
== GFC_SS_CONSTRUCTOR
&& dynamic
[n
])
4784 else if (integer_onep (info
->stride
[dim
])
4785 && !integer_onep (specinfo
->stride
[spec_dim
]))
4787 else if (INTEGER_CST_P (info
->stride
[dim
])
4788 && !INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
4790 else if (INTEGER_CST_P (info
->start
[dim
])
4791 && !INTEGER_CST_P (specinfo
->start
[spec_dim
])
4792 && integer_onep (info
->stride
[dim
])
4793 == integer_onep (specinfo
->stride
[spec_dim
])
4794 && INTEGER_CST_P (info
->stride
[dim
])
4795 == INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
4797 /* We don't work out the upper bound.
4798 else if (INTEGER_CST_P (info->finish[n])
4799 && ! INTEGER_CST_P (specinfo->finish[n]))
4800 loopspec[n] = ss; */
4803 /* We should have found the scalarization loop specifier. If not,
4805 gcc_assert (loopspec
[n
]);
4807 info
= &loopspec
[n
]->info
->data
.array
;
4808 dim
= loopspec
[n
]->dim
[n
];
4810 /* Set the extents of this range. */
4811 cshape
= info
->shape
;
4812 if (cshape
&& INTEGER_CST_P (info
->start
[dim
])
4813 && INTEGER_CST_P (info
->stride
[dim
]))
4815 loop
->from
[n
] = info
->start
[dim
];
4816 mpz_set (i
, cshape
[get_array_ref_dim_for_loop_dim (loopspec
[n
], n
)]);
4817 mpz_sub_ui (i
, i
, 1);
4818 /* To = from + (size - 1) * stride. */
4819 tmp
= gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
4820 if (!integer_onep (info
->stride
[dim
]))
4821 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
4822 gfc_array_index_type
, tmp
,
4824 loop
->to
[n
] = fold_build2_loc (input_location
, PLUS_EXPR
,
4825 gfc_array_index_type
,
4826 loop
->from
[n
], tmp
);
4830 loop
->from
[n
] = info
->start
[dim
];
4831 switch (loopspec
[n
]->info
->type
)
4833 case GFC_SS_CONSTRUCTOR
:
4834 /* The upper bound is calculated when we expand the
4836 gcc_assert (loop
->to
[n
] == NULL_TREE
);
4839 case GFC_SS_SECTION
:
4840 /* Use the end expression if it exists and is not constant,
4841 so that it is only evaluated once. */
4842 loop
->to
[n
] = info
->end
[dim
];
4845 case GFC_SS_FUNCTION
:
4846 /* The loop bound will be set when we generate the call. */
4847 gcc_assert (loop
->to
[n
] == NULL_TREE
);
4850 case GFC_SS_INTRINSIC
:
4852 gfc_expr
*expr
= loopspec
[n
]->info
->expr
;
4854 /* The {l,u}bound of an assumed rank. */
4855 gcc_assert ((expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
4856 || expr
->value
.function
.isym
->id
== GFC_ISYM_UBOUND
)
4857 && expr
->value
.function
.actual
->next
->expr
== NULL
4858 && expr
->value
.function
.actual
->expr
->rank
== -1);
4860 loop
->to
[n
] = info
->end
[dim
];
4869 /* Transform everything so we have a simple incrementing variable. */
4870 if (integer_onep (info
->stride
[dim
]))
4871 info
->delta
[dim
] = gfc_index_zero_node
;
4874 /* Set the delta for this section. */
4875 info
->delta
[dim
] = gfc_evaluate_now (loop
->from
[n
], &outer_loop
->pre
);
4876 /* Number of iterations is (end - start + step) / step.
4877 with start = 0, this simplifies to
4879 for (i = 0; i<=last; i++){...}; */
4880 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4881 gfc_array_index_type
, loop
->to
[n
],
4883 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
4884 gfc_array_index_type
, tmp
, info
->stride
[dim
]);
4885 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
4886 tmp
, build_int_cst (gfc_array_index_type
, -1));
4887 loop
->to
[n
] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
4888 /* Make the loop variable start at 0. */
4889 loop
->from
[n
] = gfc_index_zero_node
;
4894 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4895 set_loop_bounds (loop
);
4899 /* Initialize the scalarization loop. Creates the loop variables. Determines
4900 the range of the loop variables. Creates a temporary if required.
4901 Also generates code for scalar expressions which have been
4902 moved outside the loop. */
4905 gfc_conv_loop_setup (gfc_loopinfo
* loop
, locus
* where
)
4910 set_loop_bounds (loop
);
4912 /* Add all the scalar code that can be taken out of the loops.
4913 This may include calculating the loop bounds, so do it before
4914 allocating the temporary. */
4915 gfc_add_loop_ss_code (loop
, loop
->ss
, false, where
);
4917 tmp_ss
= loop
->temp_ss
;
4918 /* If we want a temporary then create it. */
4921 gfc_ss_info
*tmp_ss_info
;
4923 tmp_ss_info
= tmp_ss
->info
;
4924 gcc_assert (tmp_ss_info
->type
== GFC_SS_TEMP
);
4925 gcc_assert (loop
->parent
== NULL
);
4927 /* Make absolutely sure that this is a complete type. */
4928 if (tmp_ss_info
->string_length
)
4929 tmp_ss_info
->data
.temp
.type
4930 = gfc_get_character_type_len_for_eltype
4931 (TREE_TYPE (tmp_ss_info
->data
.temp
.type
),
4932 tmp_ss_info
->string_length
);
4934 tmp
= tmp_ss_info
->data
.temp
.type
;
4935 memset (&tmp_ss_info
->data
.array
, 0, sizeof (gfc_array_info
));
4936 tmp_ss_info
->type
= GFC_SS_SECTION
;
4938 gcc_assert (tmp_ss
->dimen
!= 0);
4940 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, tmp_ss
, tmp
,
4941 NULL_TREE
, false, true, false, where
);
4944 /* For array parameters we don't have loop variables, so don't calculate the
4946 if (!loop
->array_parameter
)
4947 gfc_set_delta (loop
);
4951 /* Calculates how to transform from loop variables to array indices for each
4952 array: once loop bounds are chosen, sets the difference (DELTA field) between
4953 loop bounds and array reference bounds, for each array info. */
4956 gfc_set_delta (gfc_loopinfo
*loop
)
4958 gfc_ss
*ss
, **loopspec
;
4959 gfc_array_info
*info
;
4963 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
4965 loopspec
= loop
->specloop
;
4967 /* Calculate the translation from loop variables to array indices. */
4968 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4970 gfc_ss_type ss_type
;
4972 ss_type
= ss
->info
->type
;
4973 if (ss_type
!= GFC_SS_SECTION
4974 && ss_type
!= GFC_SS_COMPONENT
4975 && ss_type
!= GFC_SS_CONSTRUCTOR
)
4978 info
= &ss
->info
->data
.array
;
4980 for (n
= 0; n
< ss
->dimen
; n
++)
4982 /* If we are specifying the range the delta is already set. */
4983 if (loopspec
[n
] != ss
)
4987 /* Calculate the offset relative to the loop variable.
4988 First multiply by the stride. */
4989 tmp
= loop
->from
[n
];
4990 if (!integer_onep (info
->stride
[dim
]))
4991 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
4992 gfc_array_index_type
,
4993 tmp
, info
->stride
[dim
]);
4995 /* Then subtract this from our starting value. */
4996 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4997 gfc_array_index_type
,
4998 info
->start
[dim
], tmp
);
5000 info
->delta
[dim
] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
5005 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
5006 gfc_set_delta (loop
);
5010 /* Calculate the size of a given array dimension from the bounds. This
5011 is simply (ubound - lbound + 1) if this expression is positive
5012 or 0 if it is negative (pick either one if it is zero). Optionally
5013 (if or_expr is present) OR the (expression != 0) condition to it. */
5016 gfc_conv_array_extent_dim (tree lbound
, tree ubound
, tree
* or_expr
)
5021 /* Calculate (ubound - lbound + 1). */
5022 res
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5024 res
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
, res
,
5025 gfc_index_one_node
);
5027 /* Check whether the size for this dimension is negative. */
5028 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, res
,
5029 gfc_index_zero_node
);
5030 res
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
, cond
,
5031 gfc_index_zero_node
, res
);
5033 /* Build OR expression. */
5035 *or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
5036 boolean_type_node
, *or_expr
, cond
);
5042 /* For an array descriptor, get the total number of elements. This is just
5043 the product of the extents along from_dim to to_dim. */
5046 gfc_conv_descriptor_size_1 (tree desc
, int from_dim
, int to_dim
)
5051 res
= gfc_index_one_node
;
5053 for (dim
= from_dim
; dim
< to_dim
; ++dim
)
5059 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]);
5060 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]);
5062 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
5063 res
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5071 /* Full size of an array. */
5074 gfc_conv_descriptor_size (tree desc
, int rank
)
5076 return gfc_conv_descriptor_size_1 (desc
, 0, rank
);
5080 /* Size of a coarray for all dimensions but the last. */
5083 gfc_conv_descriptor_cosize (tree desc
, int rank
, int corank
)
5085 return gfc_conv_descriptor_size_1 (desc
, rank
, rank
+ corank
- 1);
5089 /* Fills in an array descriptor, and returns the size of the array.
5090 The size will be a simple_val, ie a variable or a constant. Also
5091 calculates the offset of the base. The pointer argument overflow,
5092 which should be of integer type, will increase in value if overflow
5093 occurs during the size calculation. Returns the size of the array.
5097 for (n = 0; n < rank; n++)
5099 a.lbound[n] = specified_lower_bound;
5100 offset = offset + a.lbond[n] * stride;
5102 a.ubound[n] = specified_upper_bound;
5103 a.stride[n] = stride;
5104 size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
5105 overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
5106 stride = stride * size;
5108 for (n = rank; n < rank+corank; n++)
5109 (Set lcobound/ucobound as above.)
5110 element_size = sizeof (array element);
5113 stride = (size_t) stride;
5114 overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
5115 stride = stride * element_size;
5121 gfc_array_init_size (tree descriptor
, int rank
, int corank
, tree
* poffset
,
5122 gfc_expr
** lower
, gfc_expr
** upper
, stmtblock_t
* pblock
,
5123 stmtblock_t
* descriptor_block
, tree
* overflow
,
5124 tree expr3_elem_size
, tree
*nelems
, gfc_expr
*expr3
,
5125 tree expr3_desc
, bool e3_is_array_constr
, gfc_expr
*expr
)
5138 stmtblock_t thenblock
;
5139 stmtblock_t elseblock
;
5144 type
= TREE_TYPE (descriptor
);
5146 stride
= gfc_index_one_node
;
5147 offset
= gfc_index_zero_node
;
5149 /* Set the dtype before the alloc, because registration of coarrays needs
5151 if (expr
->ts
.type
== BT_CHARACTER
5152 && expr
->ts
.deferred
5153 && VAR_P (expr
->ts
.u
.cl
->backend_decl
))
5155 type
= gfc_typenode_for_spec (&expr
->ts
);
5156 tmp
= gfc_conv_descriptor_dtype (descriptor
);
5157 gfc_add_modify (pblock
, tmp
, gfc_get_dtype_rank_type (rank
, type
));
5161 tmp
= gfc_conv_descriptor_dtype (descriptor
);
5162 gfc_add_modify (pblock
, tmp
, gfc_get_dtype (type
));
5165 or_expr
= boolean_false_node
;
5167 for (n
= 0; n
< rank
; n
++)
5172 /* We have 3 possibilities for determining the size of the array:
5173 lower == NULL => lbound = 1, ubound = upper[n]
5174 upper[n] = NULL => lbound = 1, ubound = lower[n]
5175 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
5178 /* Set lower bound. */
5179 gfc_init_se (&se
, NULL
);
5180 if (expr3_desc
!= NULL_TREE
)
5182 if (e3_is_array_constr
)
5183 /* The lbound of a constant array [] starts at zero, but when
5184 allocating it, the standard expects the array to start at
5186 se
.expr
= gfc_index_one_node
;
5188 se
.expr
= gfc_conv_descriptor_lbound_get (expr3_desc
,
5191 else if (lower
== NULL
)
5192 se
.expr
= gfc_index_one_node
;
5195 gcc_assert (lower
[n
]);
5198 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
5199 gfc_add_block_to_block (pblock
, &se
.pre
);
5203 se
.expr
= gfc_index_one_node
;
5207 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
5208 gfc_rank_cst
[n
], se
.expr
);
5209 conv_lbound
= se
.expr
;
5211 /* Work out the offset for this component. */
5212 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5214 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
5215 gfc_array_index_type
, offset
, tmp
);
5217 /* Set upper bound. */
5218 gfc_init_se (&se
, NULL
);
5219 if (expr3_desc
!= NULL_TREE
)
5221 if (e3_is_array_constr
)
5223 /* The lbound of a constant array [] starts at zero, but when
5224 allocating it, the standard expects the array to start at
5225 one. Therefore fix the upper bound to be
5226 (desc.ubound - desc.lbound)+ 1. */
5227 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5228 gfc_array_index_type
,
5229 gfc_conv_descriptor_ubound_get (
5230 expr3_desc
, gfc_rank_cst
[n
]),
5231 gfc_conv_descriptor_lbound_get (
5232 expr3_desc
, gfc_rank_cst
[n
]));
5233 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5234 gfc_array_index_type
, tmp
,
5235 gfc_index_one_node
);
5236 se
.expr
= gfc_evaluate_now (tmp
, pblock
);
5239 se
.expr
= gfc_conv_descriptor_ubound_get (expr3_desc
,
5244 gcc_assert (ubound
);
5245 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
5246 gfc_add_block_to_block (pblock
, &se
.pre
);
5247 if (ubound
->expr_type
== EXPR_FUNCTION
)
5248 se
.expr
= gfc_evaluate_now (se
.expr
, pblock
);
5250 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
5251 gfc_rank_cst
[n
], se
.expr
);
5252 conv_ubound
= se
.expr
;
5254 /* Store the stride. */
5255 gfc_conv_descriptor_stride_set (descriptor_block
, descriptor
,
5256 gfc_rank_cst
[n
], stride
);
5258 /* Calculate size and check whether extent is negative. */
5259 size
= gfc_conv_array_extent_dim (conv_lbound
, conv_ubound
, &or_expr
);
5260 size
= gfc_evaluate_now (size
, pblock
);
5262 /* Check whether multiplying the stride by the number of
5263 elements in this dimension would overflow. We must also check
5264 whether the current dimension has zero size in order to avoid
5267 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
5268 gfc_array_index_type
,
5269 fold_convert (gfc_array_index_type
,
5270 TYPE_MAX_VALUE (gfc_array_index_type
)),
5272 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
5273 boolean_type_node
, tmp
, stride
),
5274 PRED_FORTRAN_OVERFLOW
);
5275 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5276 integer_one_node
, integer_zero_node
);
5277 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
5278 boolean_type_node
, size
,
5279 gfc_index_zero_node
),
5280 PRED_FORTRAN_SIZE_ZERO
);
5281 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5282 integer_zero_node
, tmp
);
5283 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
5285 *overflow
= gfc_evaluate_now (tmp
, pblock
);
5287 /* Multiply the stride by the number of elements in this dimension. */
5288 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
5289 gfc_array_index_type
, stride
, size
);
5290 stride
= gfc_evaluate_now (stride
, pblock
);
5293 for (n
= rank
; n
< rank
+ corank
; n
++)
5297 /* Set lower bound. */
5298 gfc_init_se (&se
, NULL
);
5299 if (lower
== NULL
|| lower
[n
] == NULL
)
5301 gcc_assert (n
== rank
+ corank
- 1);
5302 se
.expr
= gfc_index_one_node
;
5306 if (ubound
|| n
== rank
+ corank
- 1)
5308 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
5309 gfc_add_block_to_block (pblock
, &se
.pre
);
5313 se
.expr
= gfc_index_one_node
;
5317 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
5318 gfc_rank_cst
[n
], se
.expr
);
5320 if (n
< rank
+ corank
- 1)
5322 gfc_init_se (&se
, NULL
);
5323 gcc_assert (ubound
);
5324 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
5325 gfc_add_block_to_block (pblock
, &se
.pre
);
5326 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
5327 gfc_rank_cst
[n
], se
.expr
);
5331 /* The stride is the number of elements in the array, so multiply by the
5332 size of an element to get the total size. Obviously, if there is a
5333 SOURCE expression (expr3) we must use its element size. */
5334 if (expr3_elem_size
!= NULL_TREE
)
5335 tmp
= expr3_elem_size
;
5336 else if (expr3
!= NULL
)
5338 if (expr3
->ts
.type
== BT_CLASS
)
5341 gfc_expr
*sz
= gfc_copy_expr (expr3
);
5342 gfc_add_vptr_component (sz
);
5343 gfc_add_size_component (sz
);
5344 gfc_init_se (&se_sz
, NULL
);
5345 gfc_conv_expr (&se_sz
, sz
);
5351 tmp
= gfc_typenode_for_spec (&expr3
->ts
);
5352 tmp
= TYPE_SIZE_UNIT (tmp
);
5356 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
5358 /* Convert to size_t. */
5359 element_size
= fold_convert (size_type_node
, tmp
);
5362 return element_size
;
5364 *nelems
= gfc_evaluate_now (stride
, pblock
);
5365 stride
= fold_convert (size_type_node
, stride
);
5367 /* First check for overflow. Since an array of type character can
5368 have zero element_size, we must check for that before
5370 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
5372 TYPE_MAX_VALUE (size_type_node
), element_size
);
5373 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
5374 boolean_type_node
, tmp
, stride
),
5375 PRED_FORTRAN_OVERFLOW
);
5376 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5377 integer_one_node
, integer_zero_node
);
5378 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
5379 boolean_type_node
, element_size
,
5380 build_int_cst (size_type_node
, 0)),
5381 PRED_FORTRAN_SIZE_ZERO
);
5382 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5383 integer_zero_node
, tmp
);
5384 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
5386 *overflow
= gfc_evaluate_now (tmp
, pblock
);
5388 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5389 stride
, element_size
);
5391 if (poffset
!= NULL
)
5393 offset
= gfc_evaluate_now (offset
, pblock
);
5397 if (integer_zerop (or_expr
))
5399 if (integer_onep (or_expr
))
5400 return build_int_cst (size_type_node
, 0);
5402 var
= gfc_create_var (TREE_TYPE (size
), "size");
5403 gfc_start_block (&thenblock
);
5404 gfc_add_modify (&thenblock
, var
, build_int_cst (size_type_node
, 0));
5405 thencase
= gfc_finish_block (&thenblock
);
5407 gfc_start_block (&elseblock
);
5408 gfc_add_modify (&elseblock
, var
, size
);
5409 elsecase
= gfc_finish_block (&elseblock
);
5411 tmp
= gfc_evaluate_now (or_expr
, pblock
);
5412 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
5413 gfc_add_expr_to_block (pblock
, tmp
);
5419 /* Retrieve the last ref from the chain. This routine is specific to
5420 gfc_array_allocate ()'s needs. */
5423 retrieve_last_ref (gfc_ref
**ref_in
, gfc_ref
**prev_ref_in
)
5425 gfc_ref
*ref
, *prev_ref
;
5428 /* Prevent warnings for uninitialized variables. */
5429 prev_ref
= *prev_ref_in
;
5430 while (ref
&& ref
->next
!= NULL
)
5432 gcc_assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
5433 || (ref
->u
.ar
.dimen
== 0 && ref
->u
.ar
.codimen
> 0));
5438 if (ref
== NULL
|| ref
->type
!= REF_ARRAY
)
5442 *prev_ref_in
= prev_ref
;
5446 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
5447 the work for an ALLOCATE statement. */
5451 gfc_array_allocate (gfc_se
* se
, gfc_expr
* expr
, tree status
, tree errmsg
,
5452 tree errlen
, tree label_finish
, tree expr3_elem_size
,
5453 tree
*nelems
, gfc_expr
*expr3
, tree e3_arr_desc
,
5454 bool e3_is_array_constr
)
5458 tree offset
= NULL_TREE
;
5459 tree token
= NULL_TREE
;
5462 tree error
= NULL_TREE
;
5463 tree overflow
; /* Boolean storing whether size calculation overflows. */
5464 tree var_overflow
= NULL_TREE
;
5466 tree set_descriptor
;
5467 stmtblock_t set_descriptor_block
;
5468 stmtblock_t elseblock
;
5471 gfc_ref
*ref
, *prev_ref
= NULL
, *coref
;
5472 bool allocatable
, coarray
, dimension
, alloc_w_e3_arr_spec
= false;
5476 /* Find the last reference in the chain. */
5477 if (!retrieve_last_ref (&ref
, &prev_ref
))
5480 /* Take the allocatable and coarray properties solely from the expr-ref's
5481 attributes and not from source=-expression. */
5484 allocatable
= expr
->symtree
->n
.sym
->attr
.allocatable
;
5485 dimension
= expr
->symtree
->n
.sym
->attr
.dimension
;
5489 allocatable
= prev_ref
->u
.c
.component
->attr
.allocatable
;
5490 dimension
= prev_ref
->u
.c
.component
->attr
.dimension
;
5493 /* For allocatable/pointer arrays in derived types, one of the refs has to be
5494 a coarray. In this case it does not matter whether we are on this_image
5497 for (coref
= expr
->ref
; coref
; coref
= coref
->next
)
5498 if (coref
->type
== REF_ARRAY
&& coref
->u
.ar
.codimen
> 0)
5505 gcc_assert (coarray
);
5507 if (ref
->u
.ar
.type
== AR_FULL
&& expr3
!= NULL
)
5509 gfc_ref
*old_ref
= ref
;
5510 /* F08:C633: Array shape from expr3. */
5513 /* Find the last reference in the chain. */
5514 if (!retrieve_last_ref (&ref
, &prev_ref
))
5516 if (expr3
->expr_type
== EXPR_FUNCTION
5517 && gfc_expr_attr (expr3
).dimension
)
5522 alloc_w_e3_arr_spec
= true;
5525 /* Figure out the size of the array. */
5526 switch (ref
->u
.ar
.type
)
5532 upper
= ref
->u
.ar
.start
;
5538 lower
= ref
->u
.ar
.start
;
5539 upper
= ref
->u
.ar
.end
;
5543 gcc_assert (ref
->u
.ar
.as
->type
== AS_EXPLICIT
5544 || alloc_w_e3_arr_spec
);
5546 lower
= ref
->u
.ar
.as
->lower
;
5547 upper
= ref
->u
.ar
.as
->upper
;
5555 overflow
= integer_zero_node
;
5557 gfc_init_block (&set_descriptor_block
);
5558 /* Take the corank only from the actual ref and not from the coref. The
5559 later will mislead the generation of the array dimensions for allocatable/
5560 pointer components in derived types. */
5561 size
= gfc_array_init_size (se
->expr
, alloc_w_e3_arr_spec
? expr
->rank
5562 : ref
->u
.ar
.as
->rank
,
5563 coarray
? ref
->u
.ar
.as
->corank
: 0,
5564 &offset
, lower
, upper
,
5565 &se
->pre
, &set_descriptor_block
, &overflow
,
5566 expr3_elem_size
, nelems
, expr3
, e3_arr_desc
,
5567 e3_is_array_constr
, expr
);
5571 var_overflow
= gfc_create_var (integer_type_node
, "overflow");
5572 gfc_add_modify (&se
->pre
, var_overflow
, overflow
);
5574 if (status
== NULL_TREE
)
5576 /* Generate the block of code handling overflow. */
5577 msg
= gfc_build_addr_expr (pchar_type_node
,
5578 gfc_build_localized_cstring_const
5579 ("Integer overflow when calculating the amount of "
5580 "memory to allocate"));
5581 error
= build_call_expr_loc (input_location
,
5582 gfor_fndecl_runtime_error
, 1, msg
);
5586 tree status_type
= TREE_TYPE (status
);
5587 stmtblock_t set_status_block
;
5589 gfc_start_block (&set_status_block
);
5590 gfc_add_modify (&set_status_block
, status
,
5591 build_int_cst (status_type
, LIBERROR_ALLOCATION
));
5592 error
= gfc_finish_block (&set_status_block
);
5596 gfc_start_block (&elseblock
);
5598 /* Allocate memory to store the data. */
5599 if (POINTER_TYPE_P (TREE_TYPE (se
->expr
)))
5600 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
5602 pointer
= gfc_conv_descriptor_data_get (se
->expr
);
5603 STRIP_NOPS (pointer
);
5605 if (coarray
&& flag_coarray
== GFC_FCOARRAY_LIB
)
5607 token
= gfc_conv_descriptor_token (se
->expr
);
5608 token
= gfc_build_addr_expr (NULL_TREE
, token
);
5611 /* The allocatable variant takes the old pointer as first argument. */
5613 gfc_allocate_allocatable (&elseblock
, pointer
, size
, token
,
5614 status
, errmsg
, errlen
, label_finish
, expr
,
5615 coref
!= NULL
? coref
->u
.ar
.as
->corank
: 0);
5617 gfc_allocate_using_malloc (&elseblock
, pointer
, size
, status
);
5621 cond
= gfc_unlikely (fold_build2_loc (input_location
, NE_EXPR
,
5622 boolean_type_node
, var_overflow
, integer_zero_node
),
5623 PRED_FORTRAN_OVERFLOW
);
5624 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
5625 error
, gfc_finish_block (&elseblock
));
5628 tmp
= gfc_finish_block (&elseblock
);
5630 gfc_add_expr_to_block (&se
->pre
, tmp
);
5632 /* Update the array descriptors. */
5634 gfc_conv_descriptor_offset_set (&set_descriptor_block
, se
->expr
, offset
);
5636 set_descriptor
= gfc_finish_block (&set_descriptor_block
);
5637 if (status
!= NULL_TREE
)
5639 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
5640 boolean_type_node
, status
,
5641 build_int_cst (TREE_TYPE (status
), 0));
5642 gfc_add_expr_to_block (&se
->pre
,
5643 fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5646 build_empty_stmt (input_location
)));
5649 gfc_add_expr_to_block (&se
->pre
, set_descriptor
);
5655 /* Create an array constructor from an initialization expression.
5656 We assume the frontend already did any expansions and conversions. */
5659 gfc_conv_array_initializer (tree type
, gfc_expr
* expr
)
5666 vec
<constructor_elt
, va_gc
> *v
= NULL
;
5668 if (expr
->expr_type
== EXPR_VARIABLE
5669 && expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
5670 && expr
->symtree
->n
.sym
->value
)
5671 expr
= expr
->symtree
->n
.sym
->value
;
5673 switch (expr
->expr_type
)
5676 case EXPR_STRUCTURE
:
5677 /* A single scalar or derived type value. Create an array with all
5678 elements equal to that value. */
5679 gfc_init_se (&se
, NULL
);
5681 if (expr
->expr_type
== EXPR_CONSTANT
)
5682 gfc_conv_constant (&se
, expr
);
5684 gfc_conv_structure (&se
, expr
, 1);
5686 wtmp
= wi::to_offset (TYPE_MAX_VALUE (TYPE_DOMAIN (type
))) + 1;
5687 /* This will probably eat buckets of memory for large arrays. */
5690 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
, se
.expr
);
5696 /* Create a vector of all the elements. */
5697 for (c
= gfc_constructor_first (expr
->value
.constructor
);
5698 c
; c
= gfc_constructor_next (c
))
5702 /* Problems occur when we get something like
5703 integer :: a(lots) = (/(i, i=1, lots)/) */
5704 gfc_fatal_error ("The number of elements in the array "
5705 "constructor at %L requires an increase of "
5706 "the allowed %d upper limit. See "
5707 "%<-fmax-array-constructor%> option",
5708 &expr
->where
, flag_max_array_constructor
);
5711 if (mpz_cmp_si (c
->offset
, 0) != 0)
5712 index
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
5716 if (mpz_cmp_si (c
->repeat
, 1) > 0)
5722 mpz_add (maxval
, c
->offset
, c
->repeat
);
5723 mpz_sub_ui (maxval
, maxval
, 1);
5724 tmp2
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
5725 if (mpz_cmp_si (c
->offset
, 0) != 0)
5727 mpz_add_ui (maxval
, c
->offset
, 1);
5728 tmp1
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
5731 tmp1
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
5733 range
= fold_build2 (RANGE_EXPR
, gfc_array_index_type
, tmp1
, tmp2
);
5739 gfc_init_se (&se
, NULL
);
5740 switch (c
->expr
->expr_type
)
5743 gfc_conv_constant (&se
, c
->expr
);
5746 case EXPR_STRUCTURE
:
5747 gfc_conv_structure (&se
, c
->expr
, 1);
5751 /* Catch those occasional beasts that do not simplify
5752 for one reason or another, assuming that if they are
5753 standard defying the frontend will catch them. */
5754 gfc_conv_expr (&se
, c
->expr
);
5758 if (range
== NULL_TREE
)
5759 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
5762 if (index
!= NULL_TREE
)
5763 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
5764 CONSTRUCTOR_APPEND_ELT (v
, range
, se
.expr
);
5770 return gfc_build_null_descriptor (type
);
5776 /* Create a constructor from the list of elements. */
5777 tmp
= build_constructor (type
, v
);
5778 TREE_CONSTANT (tmp
) = 1;
5783 /* Generate code to evaluate non-constant coarray cobounds. */
5786 gfc_trans_array_cobounds (tree type
, stmtblock_t
* pblock
,
5787 const gfc_symbol
*sym
)
5795 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
5797 for (dim
= as
->rank
; dim
< as
->rank
+ as
->corank
; dim
++)
5799 /* Evaluate non-constant array bound expressions. */
5800 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
5801 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
5803 gfc_init_se (&se
, NULL
);
5804 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
5805 gfc_add_block_to_block (pblock
, &se
.pre
);
5806 gfc_add_modify (pblock
, lbound
, se
.expr
);
5808 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
5809 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
5811 gfc_init_se (&se
, NULL
);
5812 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
5813 gfc_add_block_to_block (pblock
, &se
.pre
);
5814 gfc_add_modify (pblock
, ubound
, se
.expr
);
5820 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
5821 returns the size (in elements) of the array. */
5824 gfc_trans_array_bounds (tree type
, gfc_symbol
* sym
, tree
* poffset
,
5825 stmtblock_t
* pblock
)
5838 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
5840 size
= gfc_index_one_node
;
5841 offset
= gfc_index_zero_node
;
5842 for (dim
= 0; dim
< as
->rank
; dim
++)
5844 /* Evaluate non-constant array bound expressions. */
5845 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
5846 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
5848 gfc_init_se (&se
, NULL
);
5849 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
5850 gfc_add_block_to_block (pblock
, &se
.pre
);
5851 gfc_add_modify (pblock
, lbound
, se
.expr
);
5853 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
5854 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
5856 gfc_init_se (&se
, NULL
);
5857 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
5858 gfc_add_block_to_block (pblock
, &se
.pre
);
5859 gfc_add_modify (pblock
, ubound
, se
.expr
);
5861 /* The offset of this dimension. offset = offset - lbound * stride. */
5862 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5864 offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5867 /* The size of this dimension, and the stride of the next. */
5868 if (dim
+ 1 < as
->rank
)
5869 stride
= GFC_TYPE_ARRAY_STRIDE (type
, dim
+ 1);
5871 stride
= GFC_TYPE_ARRAY_SIZE (type
);
5873 if (ubound
!= NULL_TREE
&& !(stride
&& INTEGER_CST_P (stride
)))
5875 /* Calculate stride = size * (ubound + 1 - lbound). */
5876 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5877 gfc_array_index_type
,
5878 gfc_index_one_node
, lbound
);
5879 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5880 gfc_array_index_type
, ubound
, tmp
);
5881 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5882 gfc_array_index_type
, size
, tmp
);
5884 gfc_add_modify (pblock
, stride
, tmp
);
5886 stride
= gfc_evaluate_now (tmp
, pblock
);
5888 /* Make sure that negative size arrays are translated
5889 to being zero size. */
5890 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
5891 stride
, gfc_index_zero_node
);
5892 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5893 gfc_array_index_type
, tmp
,
5894 stride
, gfc_index_zero_node
);
5895 gfc_add_modify (pblock
, stride
, tmp
);
5901 gfc_trans_array_cobounds (type
, pblock
, sym
);
5902 gfc_trans_vla_type_sizes (sym
, pblock
);
5909 /* Generate code to initialize/allocate an array variable. */
5912 gfc_trans_auto_array_allocation (tree decl
, gfc_symbol
* sym
,
5913 gfc_wrapped_block
* block
)
5917 tree tmp
= NULL_TREE
;
5924 gcc_assert (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
));
5926 /* Do nothing for USEd variables. */
5927 if (sym
->attr
.use_assoc
)
5930 type
= TREE_TYPE (decl
);
5931 gcc_assert (GFC_ARRAY_TYPE_P (type
));
5932 onstack
= TREE_CODE (type
) != POINTER_TYPE
;
5934 gfc_init_block (&init
);
5936 /* Evaluate character string length. */
5937 if (sym
->ts
.type
== BT_CHARACTER
5938 && onstack
&& !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
5940 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
5942 gfc_trans_vla_type_sizes (sym
, &init
);
5944 /* Emit a DECL_EXPR for this variable, which will cause the
5945 gimplifier to allocate storage, and all that good stuff. */
5946 tmp
= fold_build1_loc (input_location
, DECL_EXPR
, TREE_TYPE (decl
), decl
);
5947 gfc_add_expr_to_block (&init
, tmp
);
5952 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
5956 type
= TREE_TYPE (type
);
5958 gcc_assert (!sym
->attr
.use_assoc
);
5959 gcc_assert (!TREE_STATIC (decl
));
5960 gcc_assert (!sym
->module
);
5962 if (sym
->ts
.type
== BT_CHARACTER
5963 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
5964 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
5966 size
= gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
5968 /* Don't actually allocate space for Cray Pointees. */
5969 if (sym
->attr
.cray_pointee
)
5971 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
5972 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
5974 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
5978 if (flag_stack_arrays
)
5980 gcc_assert (TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
);
5981 space
= build_decl (sym
->declared_at
.lb
->location
,
5982 VAR_DECL
, create_tmp_var_name ("A"),
5983 TREE_TYPE (TREE_TYPE (decl
)));
5984 gfc_trans_vla_type_sizes (sym
, &init
);
5988 /* The size is the number of elements in the array, so multiply by the
5989 size of an element to get the total size. */
5990 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
5991 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5992 size
, fold_convert (gfc_array_index_type
, tmp
));
5994 /* Allocate memory to hold the data. */
5995 tmp
= gfc_call_malloc (&init
, TREE_TYPE (decl
), size
);
5996 gfc_add_modify (&init
, decl
, tmp
);
5998 /* Free the temporary. */
5999 tmp
= gfc_call_free (decl
);
6003 /* Set offset of the array. */
6004 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6005 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6007 /* Automatic arrays should not have initializers. */
6008 gcc_assert (!sym
->value
);
6010 inittree
= gfc_finish_block (&init
);
6017 /* Don't create new scope, emit the DECL_EXPR in exactly the scope
6018 where also space is located. */
6019 gfc_init_block (&init
);
6020 tmp
= fold_build1_loc (input_location
, DECL_EXPR
,
6021 TREE_TYPE (space
), space
);
6022 gfc_add_expr_to_block (&init
, tmp
);
6023 addr
= fold_build1_loc (sym
->declared_at
.lb
->location
,
6024 ADDR_EXPR
, TREE_TYPE (decl
), space
);
6025 gfc_add_modify (&init
, decl
, addr
);
6026 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6029 gfc_add_init_cleanup (block
, inittree
, tmp
);
6033 /* Generate entry and exit code for g77 calling convention arrays. */
6036 gfc_trans_g77_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
6046 gfc_save_backend_locus (&loc
);
6047 gfc_set_backend_locus (&sym
->declared_at
);
6049 /* Descriptor type. */
6050 parm
= sym
->backend_decl
;
6051 type
= TREE_TYPE (parm
);
6052 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6054 gfc_start_block (&init
);
6056 if (sym
->ts
.type
== BT_CHARACTER
6057 && VAR_P (sym
->ts
.u
.cl
->backend_decl
))
6058 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6060 /* Evaluate the bounds of the array. */
6061 gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
6063 /* Set the offset. */
6064 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6065 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6067 /* Set the pointer itself if we aren't using the parameter directly. */
6068 if (TREE_CODE (parm
) != PARM_DECL
)
6070 tmp
= convert (TREE_TYPE (parm
), GFC_DECL_SAVED_DESCRIPTOR (parm
));
6071 gfc_add_modify (&init
, parm
, tmp
);
6073 stmt
= gfc_finish_block (&init
);
6075 gfc_restore_backend_locus (&loc
);
6077 /* Add the initialization code to the start of the function. */
6079 if (sym
->attr
.optional
|| sym
->attr
.not_always_present
)
6081 tmp
= gfc_conv_expr_present (sym
);
6082 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
6085 gfc_add_init_cleanup (block
, stmt
, NULL_TREE
);
6089 /* Modify the descriptor of an array parameter so that it has the
6090 correct lower bound. Also move the upper bound accordingly.
6091 If the array is not packed, it will be copied into a temporary.
6092 For each dimension we set the new lower and upper bounds. Then we copy the
6093 stride and calculate the offset for this dimension. We also work out
6094 what the stride of a packed array would be, and see it the two match.
6095 If the array need repacking, we set the stride to the values we just
6096 calculated, recalculate the offset and copy the array data.
6097 Code is also added to copy the data back at the end of the function.
6101 gfc_trans_dummy_array_bias (gfc_symbol
* sym
, tree tmpdesc
,
6102 gfc_wrapped_block
* block
)
6109 tree stmtInit
, stmtCleanup
;
6116 tree stride
, stride2
;
6126 bool is_classarray
= IS_CLASS_ARRAY (sym
);
6128 /* Do nothing for pointer and allocatable arrays. */
6129 if ((sym
->ts
.type
!= BT_CLASS
&& sym
->attr
.pointer
)
6130 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.class_pointer
)
6131 || sym
->attr
.allocatable
6132 || (is_classarray
&& CLASS_DATA (sym
)->attr
.allocatable
))
6135 if (!is_classarray
&& sym
->attr
.dummy
&& gfc_is_nodesc_array (sym
))
6137 gfc_trans_g77_array (sym
, block
);
6142 gfc_save_backend_locus (&loc
);
6143 /* loc.nextc is not set by save_backend_locus but the location routines
6145 if (loc
.nextc
== NULL
)
6146 loc
.nextc
= loc
.lb
->line
;
6147 gfc_set_backend_locus (&sym
->declared_at
);
6149 /* Descriptor type. */
6150 type
= TREE_TYPE (tmpdesc
);
6151 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6152 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6154 /* For a class array the dummy array descriptor is in the _class
6156 dumdesc
= gfc_class_data_get (dumdesc
);
6158 dumdesc
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
6159 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
6160 gfc_start_block (&init
);
6162 if (sym
->ts
.type
== BT_CHARACTER
6163 && VAR_P (sym
->ts
.u
.cl
->backend_decl
))
6164 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6166 checkparm
= (as
->type
== AS_EXPLICIT
6167 && (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
));
6169 no_repack
= !(GFC_DECL_PACKED_ARRAY (tmpdesc
)
6170 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
));
6172 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
))
6174 /* For non-constant shape arrays we only check if the first dimension
6175 is contiguous. Repacking higher dimensions wouldn't gain us
6176 anything as we still don't know the array stride. */
6177 partial
= gfc_create_var (boolean_type_node
, "partial");
6178 TREE_USED (partial
) = 1;
6179 tmp
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
6180 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, tmp
,
6181 gfc_index_one_node
);
6182 gfc_add_modify (&init
, partial
, tmp
);
6185 partial
= NULL_TREE
;
6187 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
6188 here, however I think it does the right thing. */
6191 /* Set the first stride. */
6192 stride
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
6193 stride
= gfc_evaluate_now (stride
, &init
);
6195 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
6196 stride
, gfc_index_zero_node
);
6197 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
6198 tmp
, gfc_index_one_node
, stride
);
6199 stride
= GFC_TYPE_ARRAY_STRIDE (type
, 0);
6200 gfc_add_modify (&init
, stride
, tmp
);
6202 /* Allow the user to disable array repacking. */
6203 stmt_unpacked
= NULL_TREE
;
6207 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type
, 0)));
6208 /* A library call to repack the array if necessary. */
6209 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6210 stmt_unpacked
= build_call_expr_loc (input_location
,
6211 gfor_fndecl_in_pack
, 1, tmp
);
6213 stride
= gfc_index_one_node
;
6215 if (warn_array_temporaries
)
6216 gfc_warning (OPT_Warray_temporaries
,
6217 "Creating array temporary at %L", &loc
);
6220 /* This is for the case where the array data is used directly without
6221 calling the repack function. */
6222 if (no_repack
|| partial
!= NULL_TREE
)
6223 stmt_packed
= gfc_conv_descriptor_data_get (dumdesc
);
6225 stmt_packed
= NULL_TREE
;
6227 /* Assign the data pointer. */
6228 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
6230 /* Don't repack unknown shape arrays when the first stride is 1. */
6231 tmp
= fold_build3_loc (input_location
, COND_EXPR
, TREE_TYPE (stmt_packed
),
6232 partial
, stmt_packed
, stmt_unpacked
);
6235 tmp
= stmt_packed
!= NULL_TREE
? stmt_packed
: stmt_unpacked
;
6236 gfc_add_modify (&init
, tmpdesc
, fold_convert (type
, tmp
));
6238 offset
= gfc_index_zero_node
;
6239 size
= gfc_index_one_node
;
6241 /* Evaluate the bounds of the array. */
6242 for (n
= 0; n
< as
->rank
; n
++)
6244 if (checkparm
|| !as
->upper
[n
])
6246 /* Get the bounds of the actual parameter. */
6247 dubound
= gfc_conv_descriptor_ubound_get (dumdesc
, gfc_rank_cst
[n
]);
6248 dlbound
= gfc_conv_descriptor_lbound_get (dumdesc
, gfc_rank_cst
[n
]);
6252 dubound
= NULL_TREE
;
6253 dlbound
= NULL_TREE
;
6256 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, n
);
6257 if (!INTEGER_CST_P (lbound
))
6259 gfc_init_se (&se
, NULL
);
6260 gfc_conv_expr_type (&se
, as
->lower
[n
],
6261 gfc_array_index_type
);
6262 gfc_add_block_to_block (&init
, &se
.pre
);
6263 gfc_add_modify (&init
, lbound
, se
.expr
);
6266 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, n
);
6267 /* Set the desired upper bound. */
6270 /* We know what we want the upper bound to be. */
6271 if (!INTEGER_CST_P (ubound
))
6273 gfc_init_se (&se
, NULL
);
6274 gfc_conv_expr_type (&se
, as
->upper
[n
],
6275 gfc_array_index_type
);
6276 gfc_add_block_to_block (&init
, &se
.pre
);
6277 gfc_add_modify (&init
, ubound
, se
.expr
);
6280 /* Check the sizes match. */
6283 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
6287 temp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6288 gfc_array_index_type
, ubound
, lbound
);
6289 temp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6290 gfc_array_index_type
,
6291 gfc_index_one_node
, temp
);
6292 stride2
= fold_build2_loc (input_location
, MINUS_EXPR
,
6293 gfc_array_index_type
, dubound
,
6295 stride2
= fold_build2_loc (input_location
, PLUS_EXPR
,
6296 gfc_array_index_type
,
6297 gfc_index_one_node
, stride2
);
6298 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6299 gfc_array_index_type
, temp
, stride2
);
6300 msg
= xasprintf ("Dimension %d of array '%s' has extent "
6301 "%%ld instead of %%ld", n
+1, sym
->name
);
6303 gfc_trans_runtime_check (true, false, tmp
, &init
, &loc
, msg
,
6304 fold_convert (long_integer_type_node
, temp
),
6305 fold_convert (long_integer_type_node
, stride2
));
6312 /* For assumed shape arrays move the upper bound by the same amount
6313 as the lower bound. */
6314 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6315 gfc_array_index_type
, dubound
, dlbound
);
6316 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6317 gfc_array_index_type
, tmp
, lbound
);
6318 gfc_add_modify (&init
, ubound
, tmp
);
6320 /* The offset of this dimension. offset = offset - lbound * stride. */
6321 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6323 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
6324 gfc_array_index_type
, offset
, tmp
);
6326 /* The size of this dimension, and the stride of the next. */
6327 if (n
+ 1 < as
->rank
)
6329 stride
= GFC_TYPE_ARRAY_STRIDE (type
, n
+ 1);
6331 if (no_repack
|| partial
!= NULL_TREE
)
6333 gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[n
+1]);
6335 /* Figure out the stride if not a known constant. */
6336 if (!INTEGER_CST_P (stride
))
6339 stmt_packed
= NULL_TREE
;
6342 /* Calculate stride = size * (ubound + 1 - lbound). */
6343 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6344 gfc_array_index_type
,
6345 gfc_index_one_node
, lbound
);
6346 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6347 gfc_array_index_type
, ubound
, tmp
);
6348 size
= fold_build2_loc (input_location
, MULT_EXPR
,
6349 gfc_array_index_type
, size
, tmp
);
6353 /* Assign the stride. */
6354 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
6355 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6356 gfc_array_index_type
, partial
,
6357 stmt_unpacked
, stmt_packed
);
6359 tmp
= (stmt_packed
!= NULL_TREE
) ? stmt_packed
: stmt_unpacked
;
6360 gfc_add_modify (&init
, stride
, tmp
);
6365 stride
= GFC_TYPE_ARRAY_SIZE (type
);
6367 if (stride
&& !INTEGER_CST_P (stride
))
6369 /* Calculate size = stride * (ubound + 1 - lbound). */
6370 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6371 gfc_array_index_type
,
6372 gfc_index_one_node
, lbound
);
6373 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6374 gfc_array_index_type
,
6376 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6377 gfc_array_index_type
,
6378 GFC_TYPE_ARRAY_STRIDE (type
, n
), tmp
);
6379 gfc_add_modify (&init
, stride
, tmp
);
6384 gfc_trans_array_cobounds (type
, &init
, sym
);
6386 /* Set the offset. */
6387 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6388 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6390 gfc_trans_vla_type_sizes (sym
, &init
);
6392 stmtInit
= gfc_finish_block (&init
);
6394 /* Only do the entry/initialization code if the arg is present. */
6395 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6396 optional_arg
= (sym
->attr
.optional
6397 || (sym
->ns
->proc_name
->attr
.entry_master
6398 && sym
->attr
.dummy
));
6401 tmp
= gfc_conv_expr_present (sym
);
6402 stmtInit
= build3_v (COND_EXPR
, tmp
, stmtInit
,
6403 build_empty_stmt (input_location
));
6408 stmtCleanup
= NULL_TREE
;
6411 stmtblock_t cleanup
;
6412 gfc_start_block (&cleanup
);
6414 if (sym
->attr
.intent
!= INTENT_IN
)
6416 /* Copy the data back. */
6417 tmp
= build_call_expr_loc (input_location
,
6418 gfor_fndecl_in_unpack
, 2, dumdesc
, tmpdesc
);
6419 gfc_add_expr_to_block (&cleanup
, tmp
);
6422 /* Free the temporary. */
6423 tmp
= gfc_call_free (tmpdesc
);
6424 gfc_add_expr_to_block (&cleanup
, tmp
);
6426 stmtCleanup
= gfc_finish_block (&cleanup
);
6428 /* Only do the cleanup if the array was repacked. */
6430 /* For a class array the dummy array descriptor is in the _class
6432 tmp
= gfc_class_data_get (dumdesc
);
6434 tmp
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
6435 tmp
= gfc_conv_descriptor_data_get (tmp
);
6436 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6438 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6439 build_empty_stmt (input_location
));
6443 tmp
= gfc_conv_expr_present (sym
);
6444 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6445 build_empty_stmt (input_location
));
6449 /* We don't need to free any memory allocated by internal_pack as it will
6450 be freed at the end of the function by pop_context. */
6451 gfc_add_init_cleanup (block
, stmtInit
, stmtCleanup
);
6453 gfc_restore_backend_locus (&loc
);
6457 /* Calculate the overall offset, including subreferences. */
6459 gfc_get_dataptr_offset (stmtblock_t
*block
, tree parm
, tree desc
, tree offset
,
6460 bool subref
, gfc_expr
*expr
)
6470 /* If offset is NULL and this is not a subreferenced array, there is
6472 if (offset
== NULL_TREE
)
6475 offset
= gfc_index_zero_node
;
6480 tmp
= build_array_ref (desc
, offset
, NULL
, NULL
);
6482 /* Offset the data pointer for pointer assignments from arrays with
6483 subreferences; e.g. my_integer => my_type(:)%integer_component. */
6486 /* Go past the array reference. */
6487 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6488 if (ref
->type
== REF_ARRAY
&&
6489 ref
->u
.ar
.type
!= AR_ELEMENT
)
6495 /* Calculate the offset for each subsequent subreference. */
6496 for (; ref
; ref
= ref
->next
)
6501 field
= ref
->u
.c
.component
->backend_decl
;
6502 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
6503 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
6505 tmp
, field
, NULL_TREE
);
6509 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
6510 gfc_init_se (&start
, NULL
);
6511 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
6512 gfc_add_block_to_block (block
, &start
.pre
);
6513 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
6517 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
6518 && ref
->u
.ar
.type
== AR_ELEMENT
);
6520 /* TODO - Add bounds checking. */
6521 stride
= gfc_index_one_node
;
6522 index
= gfc_index_zero_node
;
6523 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
6528 /* Update the index. */
6529 gfc_init_se (&start
, NULL
);
6530 gfc_conv_expr_type (&start
, ref
->u
.ar
.start
[n
], gfc_array_index_type
);
6531 itmp
= gfc_evaluate_now (start
.expr
, block
);
6532 gfc_init_se (&start
, NULL
);
6533 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->lower
[n
], gfc_array_index_type
);
6534 jtmp
= gfc_evaluate_now (start
.expr
, block
);
6535 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6536 gfc_array_index_type
, itmp
, jtmp
);
6537 itmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6538 gfc_array_index_type
, itmp
, stride
);
6539 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
6540 gfc_array_index_type
, itmp
, index
);
6541 index
= gfc_evaluate_now (index
, block
);
6543 /* Update the stride. */
6544 gfc_init_se (&start
, NULL
);
6545 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->upper
[n
], gfc_array_index_type
);
6546 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6547 gfc_array_index_type
, start
.expr
,
6549 itmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6550 gfc_array_index_type
,
6551 gfc_index_one_node
, itmp
);
6552 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
6553 gfc_array_index_type
, stride
, itmp
);
6554 stride
= gfc_evaluate_now (stride
, block
);
6557 /* Apply the index to obtain the array element. */
6558 tmp
= gfc_build_array_ref (tmp
, index
, NULL
);
6568 /* Set the target data pointer. */
6569 offset
= gfc_build_addr_expr (gfc_array_dataptr_type (desc
), tmp
);
6570 gfc_conv_descriptor_data_set (block
, parm
, offset
);
6574 /* gfc_conv_expr_descriptor needs the string length an expression
6575 so that the size of the temporary can be obtained. This is done
6576 by adding up the string lengths of all the elements in the
6577 expression. Function with non-constant expressions have their
6578 string lengths mapped onto the actual arguments using the
6579 interface mapping machinery in trans-expr.c. */
6581 get_array_charlen (gfc_expr
*expr
, gfc_se
*se
)
6583 gfc_interface_mapping mapping
;
6584 gfc_formal_arglist
*formal
;
6585 gfc_actual_arglist
*arg
;
6588 if (expr
->ts
.u
.cl
->length
6589 && gfc_is_constant_expr (expr
->ts
.u
.cl
->length
))
6591 if (!expr
->ts
.u
.cl
->backend_decl
)
6592 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6596 switch (expr
->expr_type
)
6599 get_array_charlen (expr
->value
.op
.op1
, se
);
6601 /* For parentheses the expression ts.u.cl is identical. */
6602 if (expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
6605 expr
->ts
.u
.cl
->backend_decl
=
6606 gfc_create_var (gfc_charlen_type_node
, "sln");
6608 if (expr
->value
.op
.op2
)
6610 get_array_charlen (expr
->value
.op
.op2
, se
);
6612 gcc_assert (expr
->value
.op
.op
== INTRINSIC_CONCAT
);
6614 /* Add the string lengths and assign them to the expression
6615 string length backend declaration. */
6616 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
6617 fold_build2_loc (input_location
, PLUS_EXPR
,
6618 gfc_charlen_type_node
,
6619 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
,
6620 expr
->value
.op
.op2
->ts
.u
.cl
->backend_decl
));
6623 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
6624 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
);
6628 if (expr
->value
.function
.esym
== NULL
6629 || expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6631 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6635 /* Map expressions involving the dummy arguments onto the actual
6636 argument expressions. */
6637 gfc_init_interface_mapping (&mapping
);
6638 formal
= gfc_sym_get_dummy_args (expr
->symtree
->n
.sym
);
6639 arg
= expr
->value
.function
.actual
;
6641 /* Set se = NULL in the calls to the interface mapping, to suppress any
6643 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
6648 gfc_add_interface_mapping (&mapping
, formal
->sym
, NULL
, arg
->expr
);
6651 gfc_init_se (&tse
, NULL
);
6653 /* Build the expression for the character length and convert it. */
6654 gfc_apply_interface_mapping (&mapping
, &tse
, expr
->ts
.u
.cl
->length
);
6656 gfc_add_block_to_block (&se
->pre
, &tse
.pre
);
6657 gfc_add_block_to_block (&se
->post
, &tse
.post
);
6658 tse
.expr
= fold_convert (gfc_charlen_type_node
, tse
.expr
);
6659 tse
.expr
= fold_build2_loc (input_location
, MAX_EXPR
,
6660 gfc_charlen_type_node
, tse
.expr
,
6661 build_int_cst (gfc_charlen_type_node
, 0));
6662 expr
->ts
.u
.cl
->backend_decl
= tse
.expr
;
6663 gfc_free_interface_mapping (&mapping
);
6667 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6673 /* Helper function to check dimensions. */
6675 transposed_dims (gfc_ss
*ss
)
6679 for (n
= 0; n
< ss
->dimen
; n
++)
6680 if (ss
->dim
[n
] != n
)
6686 /* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
6687 AR_FULL, suitable for the scalarizer. */
6690 walk_coarray (gfc_expr
*e
)
6694 gcc_assert (gfc_get_corank (e
) > 0);
6696 ss
= gfc_walk_expr (e
);
6698 /* Fix scalar coarray. */
6699 if (ss
== gfc_ss_terminator
)
6706 if (ref
->type
== REF_ARRAY
6707 && ref
->u
.ar
.codimen
> 0)
6713 gcc_assert (ref
!= NULL
);
6714 if (ref
->u
.ar
.type
== AR_ELEMENT
)
6715 ref
->u
.ar
.type
= AR_SECTION
;
6716 ss
= gfc_reverse_ss (gfc_walk_array_ref (ss
, e
, ref
));
6723 /* Convert an array for passing as an actual argument. Expressions and
6724 vector subscripts are evaluated and stored in a temporary, which is then
6725 passed. For whole arrays the descriptor is passed. For array sections
6726 a modified copy of the descriptor is passed, but using the original data.
6728 This function is also used for array pointer assignments, and there
6731 - se->want_pointer && !se->direct_byref
6732 EXPR is an actual argument. On exit, se->expr contains a
6733 pointer to the array descriptor.
6735 - !se->want_pointer && !se->direct_byref
6736 EXPR is an actual argument to an intrinsic function or the
6737 left-hand side of a pointer assignment. On exit, se->expr
6738 contains the descriptor for EXPR.
6740 - !se->want_pointer && se->direct_byref
6741 EXPR is the right-hand side of a pointer assignment and
6742 se->expr is the descriptor for the previously-evaluated
6743 left-hand side. The function creates an assignment from
6747 The se->force_tmp flag disables the non-copying descriptor optimization
6748 that is used for transpose. It may be used in cases where there is an
6749 alias between the transpose argument and another argument in the same
6753 gfc_conv_expr_descriptor (gfc_se
*se
, gfc_expr
*expr
)
6756 gfc_ss_type ss_type
;
6757 gfc_ss_info
*ss_info
;
6759 gfc_array_info
*info
;
6768 bool subref_array_target
= false;
6769 gfc_expr
*arg
, *ss_expr
;
6771 if (se
->want_coarray
)
6772 ss
= walk_coarray (expr
);
6774 ss
= gfc_walk_expr (expr
);
6776 gcc_assert (ss
!= NULL
);
6777 gcc_assert (ss
!= gfc_ss_terminator
);
6780 ss_type
= ss_info
->type
;
6781 ss_expr
= ss_info
->expr
;
6783 /* Special case: TRANSPOSE which needs no temporary. */
6784 while (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
6785 && NULL
!= (arg
= gfc_get_noncopying_intrinsic_argument (expr
)))
6787 /* This is a call to transpose which has already been handled by the
6788 scalarizer, so that we just need to get its argument's descriptor. */
6789 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
6790 expr
= expr
->value
.function
.actual
->expr
;
6793 /* Special case things we know we can pass easily. */
6794 switch (expr
->expr_type
)
6797 /* If we have a linear array section, we can pass it directly.
6798 Otherwise we need to copy it into a temporary. */
6800 gcc_assert (ss_type
== GFC_SS_SECTION
);
6801 gcc_assert (ss_expr
== expr
);
6802 info
= &ss_info
->data
.array
;
6804 /* Get the descriptor for the array. */
6805 gfc_conv_ss_descriptor (&se
->pre
, ss
, 0);
6806 desc
= info
->descriptor
;
6808 subref_array_target
= se
->direct_byref
&& is_subref_array (expr
);
6809 need_tmp
= gfc_ref_needs_temporary_p (expr
->ref
)
6810 && !subref_array_target
;
6817 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
6819 /* Create a new descriptor if the array doesn't have one. */
6822 else if (info
->ref
->u
.ar
.type
== AR_FULL
|| se
->descriptor_only
)
6824 else if (se
->direct_byref
)
6827 full
= gfc_full_array_ref_p (info
->ref
, NULL
);
6829 if (full
&& !transposed_dims (ss
))
6831 if (se
->direct_byref
&& !se
->byref_noassign
)
6833 /* Copy the descriptor for pointer assignments. */
6834 gfc_add_modify (&se
->pre
, se
->expr
, desc
);
6836 /* Add any offsets from subreferences. */
6837 gfc_get_dataptr_offset (&se
->pre
, se
->expr
, desc
, NULL_TREE
,
6838 subref_array_target
, expr
);
6840 else if (se
->want_pointer
)
6842 /* We pass full arrays directly. This means that pointers and
6843 allocatable arrays should also work. */
6844 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
6851 if (expr
->ts
.type
== BT_CHARACTER
)
6852 se
->string_length
= gfc_get_expr_charlen (expr
);
6854 gfc_free_ss_chain (ss
);
6860 /* A transformational function return value will be a temporary
6861 array descriptor. We still need to go through the scalarizer
6862 to create the descriptor. Elemental functions are handled as
6863 arbitrary expressions, i.e. copy to a temporary. */
6865 if (se
->direct_byref
)
6867 gcc_assert (ss_type
== GFC_SS_FUNCTION
&& ss_expr
== expr
);
6869 /* For pointer assignments pass the descriptor directly. */
6873 gcc_assert (se
->ss
== ss
);
6874 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
6875 gfc_conv_expr (se
, expr
);
6876 gfc_free_ss_chain (ss
);
6880 if (ss_expr
!= expr
|| ss_type
!= GFC_SS_FUNCTION
)
6882 if (ss_expr
!= expr
)
6883 /* Elemental function. */
6884 gcc_assert ((expr
->value
.function
.esym
!= NULL
6885 && expr
->value
.function
.esym
->attr
.elemental
)
6886 || (expr
->value
.function
.isym
!= NULL
6887 && expr
->value
.function
.isym
->elemental
)
6888 || gfc_inline_intrinsic_function_p (expr
));
6890 gcc_assert (ss_type
== GFC_SS_INTRINSIC
);
6893 if (expr
->ts
.type
== BT_CHARACTER
6894 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
6895 get_array_charlen (expr
, se
);
6901 /* Transformational function. */
6902 info
= &ss_info
->data
.array
;
6908 /* Constant array constructors don't need a temporary. */
6909 if (ss_type
== GFC_SS_CONSTRUCTOR
6910 && expr
->ts
.type
!= BT_CHARACTER
6911 && gfc_constant_array_constructor_p (expr
->value
.constructor
))
6914 info
= &ss_info
->data
.array
;
6924 /* Something complicated. Copy it into a temporary. */
6930 /* If we are creating a temporary, we don't need to bother about aliases
6935 gfc_init_loopinfo (&loop
);
6937 /* Associate the SS with the loop. */
6938 gfc_add_ss_to_loop (&loop
, ss
);
6940 /* Tell the scalarizer not to bother creating loop variables, etc. */
6942 loop
.array_parameter
= 1;
6944 /* The right-hand side of a pointer assignment mustn't use a temporary. */
6945 gcc_assert (!se
->direct_byref
);
6947 /* Setup the scalarizing loops and bounds. */
6948 gfc_conv_ss_startstride (&loop
);
6952 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
6953 get_array_charlen (expr
, se
);
6955 /* Tell the scalarizer to make a temporary. */
6956 loop
.temp_ss
= gfc_get_temp_ss (gfc_typenode_for_spec (&expr
->ts
),
6957 ((expr
->ts
.type
== BT_CHARACTER
)
6958 ? expr
->ts
.u
.cl
->backend_decl
6962 se
->string_length
= loop
.temp_ss
->info
->string_length
;
6963 gcc_assert (loop
.temp_ss
->dimen
== loop
.dimen
);
6964 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
6967 gfc_conv_loop_setup (&loop
, & expr
->where
);
6971 /* Copy into a temporary and pass that. We don't need to copy the data
6972 back because expressions and vector subscripts must be INTENT_IN. */
6973 /* TODO: Optimize passing function return values. */
6978 /* Start the copying loops. */
6979 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
6980 gfc_mark_ss_chain_used (ss
, 1);
6981 gfc_start_scalarized_body (&loop
, &block
);
6983 /* Copy each data element. */
6984 gfc_init_se (&lse
, NULL
);
6985 gfc_copy_loopinfo_to_se (&lse
, &loop
);
6986 gfc_init_se (&rse
, NULL
);
6987 gfc_copy_loopinfo_to_se (&rse
, &loop
);
6989 lse
.ss
= loop
.temp_ss
;
6992 gfc_conv_scalarized_array_ref (&lse
, NULL
);
6993 if (expr
->ts
.type
== BT_CHARACTER
)
6995 gfc_conv_expr (&rse
, expr
);
6996 if (POINTER_TYPE_P (TREE_TYPE (rse
.expr
)))
6997 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
7001 gfc_conv_expr_val (&rse
, expr
);
7003 gfc_add_block_to_block (&block
, &rse
.pre
);
7004 gfc_add_block_to_block (&block
, &lse
.pre
);
7006 lse
.string_length
= rse
.string_length
;
7008 deep_copy
= !se
->data_not_needed
7009 && (expr
->expr_type
== EXPR_VARIABLE
7010 || expr
->expr_type
== EXPR_ARRAY
);
7011 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
,
7013 gfc_add_expr_to_block (&block
, tmp
);
7015 /* Finish the copying loops. */
7016 gfc_trans_scalarizing_loops (&loop
, &block
);
7018 desc
= loop
.temp_ss
->info
->data
.array
.descriptor
;
7020 else if (expr
->expr_type
== EXPR_FUNCTION
&& !transposed_dims (ss
))
7022 desc
= info
->descriptor
;
7023 se
->string_length
= ss_info
->string_length
;
7027 /* We pass sections without copying to a temporary. Make a new
7028 descriptor and point it at the section we want. The loop variable
7029 limits will be the limits of the section.
7030 A function may decide to repack the array to speed up access, but
7031 we're not bothered about that here. */
7032 int dim
, ndim
, codim
;
7039 bool onebased
= false, rank_remap
;
7041 ndim
= info
->ref
? info
->ref
->u
.ar
.dimen
: ss
->dimen
;
7042 rank_remap
= ss
->dimen
< ndim
;
7044 if (se
->want_coarray
)
7046 gfc_array_ref
*ar
= &info
->ref
->u
.ar
;
7048 codim
= gfc_get_corank (expr
);
7049 for (n
= 0; n
< codim
- 1; n
++)
7051 /* Make sure we are not lost somehow. */
7052 gcc_assert (ar
->dimen_type
[n
+ ndim
] == DIMEN_THIS_IMAGE
);
7054 /* Make sure the call to gfc_conv_section_startstride won't
7055 generate unnecessary code to calculate stride. */
7056 gcc_assert (ar
->stride
[n
+ ndim
] == NULL
);
7058 gfc_conv_section_startstride (&loop
.pre
, ss
, n
+ ndim
);
7059 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
7060 loop
.to
[n
+ loop
.dimen
] = info
->end
[n
+ ndim
];
7063 gcc_assert (n
== codim
- 1);
7064 evaluate_bound (&loop
.pre
, info
->start
, ar
->start
,
7065 info
->descriptor
, n
+ ndim
, true,
7066 ar
->as
->type
== AS_DEFERRED
);
7067 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
7072 /* Set the string_length for a character array. */
7073 if (expr
->ts
.type
== BT_CHARACTER
)
7074 se
->string_length
= gfc_get_expr_charlen (expr
);
7076 /* If we have an array section or are assigning make sure that
7077 the lower bound is 1. References to the full
7078 array should otherwise keep the original bounds. */
7079 if ((!info
->ref
|| info
->ref
->u
.ar
.type
!= AR_FULL
) && !se
->want_pointer
)
7080 for (dim
= 0; dim
< loop
.dimen
; dim
++)
7081 if (!integer_onep (loop
.from
[dim
]))
7083 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7084 gfc_array_index_type
, gfc_index_one_node
,
7086 loop
.to
[dim
] = fold_build2_loc (input_location
, PLUS_EXPR
,
7087 gfc_array_index_type
,
7089 loop
.from
[dim
] = gfc_index_one_node
;
7092 desc
= info
->descriptor
;
7093 if (se
->direct_byref
&& !se
->byref_noassign
)
7095 /* For pointer assignments we fill in the destination. */
7097 parmtype
= TREE_TYPE (parm
);
7101 /* Otherwise make a new one. */
7102 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
7103 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
, codim
,
7104 loop
.from
, loop
.to
, 0,
7105 GFC_ARRAY_UNKNOWN
, false);
7106 parm
= gfc_create_var (parmtype
, "parm");
7108 /* When expression is a class object, then add the class' handle to
7110 if (expr
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_VARIABLE
)
7112 gfc_expr
*class_expr
= gfc_find_and_cut_at_last_class_ref (expr
);
7115 /* class_expr can be NULL, when no _class ref is in expr.
7116 We must not fix this here with a gfc_fix_class_ref (). */
7119 gfc_init_se (&classse
, NULL
);
7120 gfc_conv_expr (&classse
, class_expr
);
7121 gfc_free_expr (class_expr
);
7123 gcc_assert (classse
.pre
.head
== NULL_TREE
7124 && classse
.post
.head
== NULL_TREE
);
7125 gfc_allocate_lang_decl (parm
);
7126 GFC_DECL_SAVED_DESCRIPTOR (parm
) = classse
.expr
;
7131 offset
= gfc_index_zero_node
;
7133 /* The following can be somewhat confusing. We have two
7134 descriptors, a new one and the original array.
7135 {parm, parmtype, dim} refer to the new one.
7136 {desc, type, n, loop} refer to the original, which maybe
7137 a descriptorless array.
7138 The bounds of the scalarization are the bounds of the section.
7139 We don't have to worry about numeric overflows when calculating
7140 the offsets because all elements are within the array data. */
7142 /* Set the dtype. */
7143 tmp
= gfc_conv_descriptor_dtype (parm
);
7144 gfc_add_modify (&loop
.pre
, tmp
, gfc_get_dtype (parmtype
));
7146 /* Set offset for assignments to pointer only to zero if it is not
7148 if ((se
->direct_byref
|| se
->use_offset
)
7149 && ((info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
7150 || (expr
->expr_type
== EXPR_ARRAY
&& se
->use_offset
)))
7151 base
= gfc_index_zero_node
;
7152 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7153 base
= gfc_evaluate_now (gfc_conv_array_offset (desc
), &loop
.pre
);
7157 for (n
= 0; n
< ndim
; n
++)
7159 stride
= gfc_conv_array_stride (desc
, n
);
7161 /* Work out the offset. */
7163 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
7165 gcc_assert (info
->subscript
[n
]
7166 && info
->subscript
[n
]->info
->type
== GFC_SS_SCALAR
);
7167 start
= info
->subscript
[n
]->info
->data
.scalar
.value
;
7171 /* Evaluate and remember the start of the section. */
7172 start
= info
->start
[n
];
7173 stride
= gfc_evaluate_now (stride
, &loop
.pre
);
7176 tmp
= gfc_conv_array_lbound (desc
, n
);
7177 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
7179 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
7181 offset
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (tmp
),
7185 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
7187 /* For elemental dimensions, we only need the offset. */
7191 /* Vector subscripts need copying and are handled elsewhere. */
7193 gcc_assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
7195 /* look for the corresponding scalarizer dimension: dim. */
7196 for (dim
= 0; dim
< ndim
; dim
++)
7197 if (ss
->dim
[dim
] == n
)
7200 /* loop exited early: the DIM being looked for has been found. */
7201 gcc_assert (dim
< ndim
);
7203 /* Set the new lower bound. */
7204 from
= loop
.from
[dim
];
7207 onebased
= integer_onep (from
);
7208 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
7209 gfc_rank_cst
[dim
], from
);
7211 /* Set the new upper bound. */
7212 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
7213 gfc_rank_cst
[dim
], to
);
7215 /* Multiply the stride by the section stride to get the
7217 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
7218 gfc_array_index_type
,
7219 stride
, info
->stride
[n
]);
7221 if ((se
->direct_byref
|| se
->use_offset
)
7222 && ((info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
7223 || (expr
->expr_type
== EXPR_ARRAY
&& se
->use_offset
)))
7225 base
= fold_build2_loc (input_location
, MINUS_EXPR
,
7226 TREE_TYPE (base
), base
, stride
);
7228 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)) || se
->use_offset
)
7231 tmp
= gfc_conv_array_lbound (desc
, n
);
7232 toonebased
= integer_onep (tmp
);
7233 // lb(arr) - from (- start + 1)
7234 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7235 TREE_TYPE (base
), tmp
, from
);
7236 if (onebased
&& toonebased
)
7238 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7239 TREE_TYPE (base
), tmp
, start
);
7240 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7241 TREE_TYPE (base
), tmp
,
7242 gfc_index_one_node
);
7244 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7245 TREE_TYPE (base
), tmp
,
7246 gfc_conv_array_stride (desc
, n
));
7247 base
= fold_build2_loc (input_location
, PLUS_EXPR
,
7248 TREE_TYPE (base
), tmp
, base
);
7251 /* Store the new stride. */
7252 gfc_conv_descriptor_stride_set (&loop
.pre
, parm
,
7253 gfc_rank_cst
[dim
], stride
);
7256 for (n
= loop
.dimen
; n
< loop
.dimen
+ codim
; n
++)
7258 from
= loop
.from
[n
];
7260 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
7261 gfc_rank_cst
[n
], from
);
7262 if (n
< loop
.dimen
+ codim
- 1)
7263 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
7264 gfc_rank_cst
[n
], to
);
7267 if (se
->data_not_needed
)
7268 gfc_conv_descriptor_data_set (&loop
.pre
, parm
,
7269 gfc_index_zero_node
);
7271 /* Point the data pointer at the 1st element in the section. */
7272 gfc_get_dataptr_offset (&loop
.pre
, parm
, desc
, offset
,
7273 subref_array_target
, expr
);
7275 /* Force the offset to be -1, when the lower bound of the highest
7276 dimension is one and the symbol is present and is not a
7277 pointer/allocatable or associated. */
7278 if (((se
->direct_byref
|| GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7279 && !se
->data_not_needed
)
7280 || (se
->use_offset
&& base
!= NULL_TREE
))
7282 /* Set the offset depending on base. */
7283 tmp
= rank_remap
&& !se
->direct_byref
?
7284 fold_build2_loc (input_location
, PLUS_EXPR
,
7285 gfc_array_index_type
, base
,
7288 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, tmp
);
7290 else if (IS_CLASS_ARRAY (expr
) && !se
->data_not_needed
7291 && (!rank_remap
|| se
->use_offset
)
7292 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
7294 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
,
7295 gfc_conv_descriptor_offset_get (desc
));
7297 else if (onebased
&& (!rank_remap
|| se
->use_offset
)
7299 && !(expr
->symtree
->n
.sym
&& expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
7300 && !CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.class_pointer
)
7301 && !expr
->symtree
->n
.sym
->attr
.allocatable
7302 && !expr
->symtree
->n
.sym
->attr
.pointer
7303 && !expr
->symtree
->n
.sym
->attr
.host_assoc
7304 && !expr
->symtree
->n
.sym
->attr
.use_assoc
)
7306 /* Set the offset to -1. */
7308 mpz_init_set_si (minus_one
, -1);
7309 tmp
= gfc_conv_mpz_to_tree (minus_one
, gfc_index_integer_kind
);
7310 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, tmp
);
7314 /* Only the callee knows what the correct offset it, so just set
7316 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, gfc_index_zero_node
);
7321 /* For class arrays add the class tree into the saved descriptor to
7322 enable getting of _vptr and the like. */
7323 if (expr
->expr_type
== EXPR_VARIABLE
&& VAR_P (desc
)
7324 && IS_CLASS_ARRAY (expr
->symtree
->n
.sym
))
7326 gfc_allocate_lang_decl (desc
);
7327 GFC_DECL_SAVED_DESCRIPTOR (desc
) =
7328 DECL_LANG_SPECIFIC (expr
->symtree
->n
.sym
->backend_decl
) ?
7329 GFC_DECL_SAVED_DESCRIPTOR (expr
->symtree
->n
.sym
->backend_decl
)
7330 : expr
->symtree
->n
.sym
->backend_decl
;
7332 else if (expr
->expr_type
== EXPR_ARRAY
&& VAR_P (desc
)
7333 && IS_CLASS_ARRAY (expr
))
7336 gfc_allocate_lang_decl (desc
);
7337 tmp
= gfc_create_var (expr
->ts
.u
.derived
->backend_decl
, "class");
7338 GFC_DECL_SAVED_DESCRIPTOR (desc
) = tmp
;
7339 vtype
= gfc_class_vptr_get (tmp
);
7340 gfc_add_modify (&se
->pre
, vtype
,
7341 gfc_build_addr_expr (TREE_TYPE (vtype
),
7342 gfc_find_vtab (&expr
->ts
)->backend_decl
));
7344 if (!se
->direct_byref
|| se
->byref_noassign
)
7346 /* Get a pointer to the new descriptor. */
7347 if (se
->want_pointer
)
7348 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
7353 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
7354 gfc_add_block_to_block (&se
->post
, &loop
.post
);
7356 /* Cleanup the scalarizer. */
7357 gfc_cleanup_loop (&loop
);
7360 /* Helper function for gfc_conv_array_parameter if array size needs to be
7364 array_parameter_size (tree desc
, gfc_expr
*expr
, tree
*size
)
7367 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7368 *size
= GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc
));
7369 else if (expr
->rank
> 1)
7370 *size
= build_call_expr_loc (input_location
,
7371 gfor_fndecl_size0
, 1,
7372 gfc_build_addr_expr (NULL
, desc
));
7375 tree ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_index_zero_node
);
7376 tree lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_index_zero_node
);
7378 *size
= fold_build2_loc (input_location
, MINUS_EXPR
,
7379 gfc_array_index_type
, ubound
, lbound
);
7380 *size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7381 *size
, gfc_index_one_node
);
7382 *size
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
7383 *size
, gfc_index_zero_node
);
7385 elem
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
7386 *size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7387 *size
, fold_convert (gfc_array_index_type
, elem
));
7390 /* Convert an array for passing as an actual parameter. */
7391 /* TODO: Optimize passing g77 arrays. */
7394 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, bool g77
,
7395 const gfc_symbol
*fsym
, const char *proc_name
,
7400 tree tmp
= NULL_TREE
;
7402 tree parent
= DECL_CONTEXT (current_function_decl
);
7403 bool full_array_var
;
7404 bool this_array_result
;
7407 bool array_constructor
;
7408 bool good_allocatable
;
7409 bool ultimate_ptr_comp
;
7410 bool ultimate_alloc_comp
;
7415 ultimate_ptr_comp
= false;
7416 ultimate_alloc_comp
= false;
7418 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7420 if (ref
->next
== NULL
)
7423 if (ref
->type
== REF_COMPONENT
)
7425 ultimate_ptr_comp
= ref
->u
.c
.component
->attr
.pointer
;
7426 ultimate_alloc_comp
= ref
->u
.c
.component
->attr
.allocatable
;
7430 full_array_var
= false;
7433 if (expr
->expr_type
== EXPR_VARIABLE
&& ref
&& !ultimate_ptr_comp
)
7434 full_array_var
= gfc_full_array_ref_p (ref
, &contiguous
);
7436 sym
= full_array_var
? expr
->symtree
->n
.sym
: NULL
;
7438 /* The symbol should have an array specification. */
7439 gcc_assert (!sym
|| sym
->as
|| ref
->u
.ar
.as
);
7441 if (expr
->expr_type
== EXPR_ARRAY
&& expr
->ts
.type
== BT_CHARACTER
)
7443 get_array_ctor_strlen (&se
->pre
, expr
->value
.constructor
, &tmp
);
7444 expr
->ts
.u
.cl
->backend_decl
= tmp
;
7445 se
->string_length
= tmp
;
7448 /* Is this the result of the enclosing procedure? */
7449 this_array_result
= (full_array_var
&& sym
->attr
.flavor
== FL_PROCEDURE
);
7450 if (this_array_result
7451 && (sym
->backend_decl
!= current_function_decl
)
7452 && (sym
->backend_decl
!= parent
))
7453 this_array_result
= false;
7455 /* Passing address of the array if it is not pointer or assumed-shape. */
7456 if (full_array_var
&& g77
&& !this_array_result
7457 && sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
7459 tmp
= gfc_get_symbol_decl (sym
);
7461 if (sym
->ts
.type
== BT_CHARACTER
)
7462 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
7464 if (!sym
->attr
.pointer
7466 && sym
->as
->type
!= AS_ASSUMED_SHAPE
7467 && sym
->as
->type
!= AS_DEFERRED
7468 && sym
->as
->type
!= AS_ASSUMED_RANK
7469 && !sym
->attr
.allocatable
)
7471 /* Some variables are declared directly, others are declared as
7472 pointers and allocated on the heap. */
7473 if (sym
->attr
.dummy
|| POINTER_TYPE_P (TREE_TYPE (tmp
)))
7476 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
7478 array_parameter_size (tmp
, expr
, size
);
7482 if (sym
->attr
.allocatable
)
7484 if (sym
->attr
.dummy
|| sym
->attr
.result
)
7486 gfc_conv_expr_descriptor (se
, expr
);
7490 array_parameter_size (tmp
, expr
, size
);
7491 se
->expr
= gfc_conv_array_data (tmp
);
7496 /* A convenient reduction in scope. */
7497 contiguous
= g77
&& !this_array_result
&& contiguous
;
7499 /* There is no need to pack and unpack the array, if it is contiguous
7500 and not a deferred- or assumed-shape array, or if it is simply
7502 no_pack
= ((sym
&& sym
->as
7503 && !sym
->attr
.pointer
7504 && sym
->as
->type
!= AS_DEFERRED
7505 && sym
->as
->type
!= AS_ASSUMED_RANK
7506 && sym
->as
->type
!= AS_ASSUMED_SHAPE
)
7508 (ref
&& ref
->u
.ar
.as
7509 && ref
->u
.ar
.as
->type
!= AS_DEFERRED
7510 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_RANK
7511 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_SHAPE
)
7513 gfc_is_simply_contiguous (expr
, false, true));
7515 no_pack
= contiguous
&& no_pack
;
7517 /* Array constructors are always contiguous and do not need packing. */
7518 array_constructor
= g77
&& !this_array_result
&& expr
->expr_type
== EXPR_ARRAY
;
7520 /* Same is true of contiguous sections from allocatable variables. */
7521 good_allocatable
= contiguous
7523 && expr
->symtree
->n
.sym
->attr
.allocatable
;
7525 /* Or ultimate allocatable components. */
7526 ultimate_alloc_comp
= contiguous
&& ultimate_alloc_comp
;
7528 if (no_pack
|| array_constructor
|| good_allocatable
|| ultimate_alloc_comp
)
7530 gfc_conv_expr_descriptor (se
, expr
);
7531 /* Deallocate the allocatable components of structures that are
7533 if ((expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
)
7534 && expr
->ts
.u
.derived
->attr
.alloc_comp
7535 && expr
->expr_type
!= EXPR_VARIABLE
)
7537 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, se
->expr
, expr
->rank
);
7539 /* The components shall be deallocated before their containing entity. */
7540 gfc_prepend_expr_to_block (&se
->post
, tmp
);
7542 if (expr
->ts
.type
== BT_CHARACTER
)
7543 se
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
7545 array_parameter_size (se
->expr
, expr
, size
);
7546 se
->expr
= gfc_conv_array_data (se
->expr
);
7550 if (this_array_result
)
7552 /* Result of the enclosing function. */
7553 gfc_conv_expr_descriptor (se
, expr
);
7555 array_parameter_size (se
->expr
, expr
, size
);
7556 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7558 if (g77
&& TREE_TYPE (TREE_TYPE (se
->expr
)) != NULL_TREE
7559 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
7560 se
->expr
= gfc_conv_array_data (build_fold_indirect_ref_loc (input_location
,
7567 /* Every other type of array. */
7568 se
->want_pointer
= 1;
7569 gfc_conv_expr_descriptor (se
, expr
);
7571 array_parameter_size (build_fold_indirect_ref_loc (input_location
,
7576 /* Deallocate the allocatable components of structures that are
7577 not variable, for descriptorless arguments.
7578 Arguments with a descriptor are handled in gfc_conv_procedure_call. */
7579 if (g77
&& (expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
)
7580 && expr
->ts
.u
.derived
->attr
.alloc_comp
7581 && expr
->expr_type
!= EXPR_VARIABLE
)
7583 tmp
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7584 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
, expr
->rank
);
7586 /* The components shall be deallocated before their containing entity. */
7587 gfc_prepend_expr_to_block (&se
->post
, tmp
);
7590 if (g77
|| (fsym
&& fsym
->attr
.contiguous
7591 && !gfc_is_simply_contiguous (expr
, false, true)))
7593 tree origptr
= NULL_TREE
;
7597 /* For contiguous arrays, save the original value of the descriptor. */
7600 origptr
= gfc_create_var (pvoid_type_node
, "origptr");
7601 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7602 tmp
= gfc_conv_array_data (tmp
);
7603 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7604 TREE_TYPE (origptr
), origptr
,
7605 fold_convert (TREE_TYPE (origptr
), tmp
));
7606 gfc_add_expr_to_block (&se
->pre
, tmp
);
7609 /* Repack the array. */
7610 if (warn_array_temporaries
)
7613 gfc_warning (OPT_Warray_temporaries
,
7614 "Creating array temporary at %L for argument %qs",
7615 &expr
->where
, fsym
->name
);
7617 gfc_warning (OPT_Warray_temporaries
,
7618 "Creating array temporary at %L", &expr
->where
);
7621 ptr
= build_call_expr_loc (input_location
,
7622 gfor_fndecl_in_pack
, 1, desc
);
7624 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7626 tmp
= gfc_conv_expr_present (sym
);
7627 ptr
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
7628 tmp
, fold_convert (TREE_TYPE (se
->expr
), ptr
),
7629 fold_convert (TREE_TYPE (se
->expr
), null_pointer_node
));
7632 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
7634 /* Use the packed data for the actual argument, except for contiguous arrays,
7635 where the descriptor's data component is set. */
7640 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7642 gfc_ss
* ss
= gfc_walk_expr (expr
);
7643 if (!transposed_dims (ss
))
7644 gfc_conv_descriptor_data_set (&se
->pre
, tmp
, ptr
);
7647 tree old_field
, new_field
;
7649 /* The original descriptor has transposed dims so we can't reuse
7650 it directly; we have to create a new one. */
7651 tree old_desc
= tmp
;
7652 tree new_desc
= gfc_create_var (TREE_TYPE (old_desc
), "arg_desc");
7654 old_field
= gfc_conv_descriptor_dtype (old_desc
);
7655 new_field
= gfc_conv_descriptor_dtype (new_desc
);
7656 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7658 old_field
= gfc_conv_descriptor_offset (old_desc
);
7659 new_field
= gfc_conv_descriptor_offset (new_desc
);
7660 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7662 for (int i
= 0; i
< expr
->rank
; i
++)
7664 old_field
= gfc_conv_descriptor_dimension (old_desc
,
7665 gfc_rank_cst
[get_array_ref_dim_for_loop_dim (ss
, i
)]);
7666 new_field
= gfc_conv_descriptor_dimension (new_desc
,
7668 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7671 if (flag_coarray
== GFC_FCOARRAY_LIB
7672 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (old_desc
))
7673 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (old_desc
))
7674 == GFC_ARRAY_ALLOCATABLE
)
7676 old_field
= gfc_conv_descriptor_token (old_desc
);
7677 new_field
= gfc_conv_descriptor_token (new_desc
);
7678 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7681 gfc_conv_descriptor_data_set (&se
->pre
, new_desc
, ptr
);
7682 se
->expr
= gfc_build_addr_expr (NULL_TREE
, new_desc
);
7687 if (gfc_option
.rtcheck
& GFC_RTCHECK_ARRAY_TEMPS
)
7691 if (fsym
&& proc_name
)
7692 msg
= xasprintf ("An array temporary was created for argument "
7693 "'%s' of procedure '%s'", fsym
->name
, proc_name
);
7695 msg
= xasprintf ("An array temporary was created");
7697 tmp
= build_fold_indirect_ref_loc (input_location
,
7699 tmp
= gfc_conv_array_data (tmp
);
7700 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7701 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
7703 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7704 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7706 gfc_conv_expr_present (sym
), tmp
);
7708 gfc_trans_runtime_check (false, true, tmp
, &se
->pre
,
7713 gfc_start_block (&block
);
7715 /* Copy the data back. */
7716 if (fsym
== NULL
|| fsym
->attr
.intent
!= INTENT_IN
)
7718 tmp
= build_call_expr_loc (input_location
,
7719 gfor_fndecl_in_unpack
, 2, desc
, ptr
);
7720 gfc_add_expr_to_block (&block
, tmp
);
7723 /* Free the temporary. */
7724 tmp
= gfc_call_free (ptr
);
7725 gfc_add_expr_to_block (&block
, tmp
);
7727 stmt
= gfc_finish_block (&block
);
7729 gfc_init_block (&block
);
7730 /* Only if it was repacked. This code needs to be executed before the
7731 loop cleanup code. */
7732 tmp
= build_fold_indirect_ref_loc (input_location
,
7734 tmp
= gfc_conv_array_data (tmp
);
7735 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7736 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
7738 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7739 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7741 gfc_conv_expr_present (sym
), tmp
);
7743 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
7745 gfc_add_expr_to_block (&block
, tmp
);
7746 gfc_add_block_to_block (&block
, &se
->post
);
7748 gfc_init_block (&se
->post
);
7750 /* Reset the descriptor pointer. */
7753 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7754 gfc_conv_descriptor_data_set (&se
->post
, tmp
, origptr
);
7757 gfc_add_block_to_block (&se
->post
, &block
);
7762 /* This helper function calculates the size in words of a full array. */
7765 gfc_full_array_size (stmtblock_t
*block
, tree decl
, int rank
)
7770 idx
= gfc_rank_cst
[rank
- 1];
7771 nelems
= gfc_conv_descriptor_ubound_get (decl
, idx
);
7772 tmp
= gfc_conv_descriptor_lbound_get (decl
, idx
);
7773 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7775 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7776 tmp
, gfc_index_one_node
);
7777 tmp
= gfc_evaluate_now (tmp
, block
);
7779 nelems
= gfc_conv_descriptor_stride_get (decl
, idx
);
7780 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7782 return gfc_evaluate_now (tmp
, block
);
7786 /* Allocate dest to the same size as src, and copy src -> dest.
7787 If no_malloc is set, only the copy is done. */
7790 duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
7791 bool no_malloc
, bool no_memcpy
, tree str_sz
,
7792 tree add_when_allocated
)
7801 /* If the source is null, set the destination to null. Then,
7802 allocate memory to the destination. */
7803 gfc_init_block (&block
);
7805 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
7807 gfc_add_modify (&block
, dest
, fold_convert (type
, null_pointer_node
));
7808 null_data
= gfc_finish_block (&block
);
7810 gfc_init_block (&block
);
7811 if (str_sz
!= NULL_TREE
)
7814 size
= TYPE_SIZE_UNIT (TREE_TYPE (type
));
7818 tmp
= gfc_call_malloc (&block
, type
, size
);
7819 gfc_add_modify (&block
, dest
, fold_convert (type
, tmp
));
7824 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
7825 tmp
= build_call_expr_loc (input_location
, tmp
, 3, dest
, src
,
7826 fold_convert (size_type_node
, size
));
7827 gfc_add_expr_to_block (&block
, tmp
);
7832 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
7833 null_data
= gfc_finish_block (&block
);
7835 gfc_init_block (&block
);
7837 nelems
= gfc_full_array_size (&block
, src
, rank
);
7839 nelems
= gfc_index_one_node
;
7841 if (str_sz
!= NULL_TREE
)
7842 tmp
= fold_convert (gfc_array_index_type
, str_sz
);
7844 tmp
= fold_convert (gfc_array_index_type
,
7845 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
7846 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7850 tmp
= TREE_TYPE (gfc_conv_descriptor_data_get (src
));
7851 tmp
= gfc_call_malloc (&block
, tmp
, size
);
7852 gfc_conv_descriptor_data_set (&block
, dest
, tmp
);
7855 /* We know the temporary and the value will be the same length,
7856 so can use memcpy. */
7859 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
7860 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
7861 gfc_conv_descriptor_data_get (dest
),
7862 gfc_conv_descriptor_data_get (src
),
7863 fold_convert (size_type_node
, size
));
7864 gfc_add_expr_to_block (&block
, tmp
);
7868 gfc_add_expr_to_block (&block
, add_when_allocated
);
7869 tmp
= gfc_finish_block (&block
);
7871 /* Null the destination if the source is null; otherwise do
7872 the allocate and copy. */
7873 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src
)))
7876 null_cond
= gfc_conv_descriptor_data_get (src
);
7878 null_cond
= convert (pvoid_type_node
, null_cond
);
7879 null_cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7880 null_cond
, null_pointer_node
);
7881 return build3_v (COND_EXPR
, null_cond
, tmp
, null_data
);
7885 /* Allocate dest to the same size as src, and copy data src -> dest. */
7888 gfc_duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
7889 tree add_when_allocated
)
7891 return duplicate_allocatable (dest
, src
, type
, rank
, false, false,
7892 NULL_TREE
, add_when_allocated
);
7896 /* Copy data src -> dest. */
7899 gfc_copy_allocatable_data (tree dest
, tree src
, tree type
, int rank
)
7901 return duplicate_allocatable (dest
, src
, type
, rank
, true, false,
7902 NULL_TREE
, NULL_TREE
);
7905 /* Allocate dest to the same size as src, but don't copy anything. */
7908 gfc_duplicate_allocatable_nocopy (tree dest
, tree src
, tree type
, int rank
)
7910 return duplicate_allocatable (dest
, src
, type
, rank
, false, true,
7911 NULL_TREE
, NULL_TREE
);
7916 duplicate_allocatable_coarray (tree dest
, tree dest_tok
, tree src
,
7917 tree type
, int rank
)
7924 stmtblock_t block
, globalblock
;
7926 /* If the source is null, set the destination to null. Then,
7927 allocate memory to the destination. */
7928 gfc_init_block (&block
);
7929 gfc_init_block (&globalblock
);
7931 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
7934 symbol_attribute attr
;
7937 gfc_init_se (&se
, NULL
);
7938 dummy_desc
= gfc_conv_scalar_to_descriptor (&se
, dest
, attr
);
7939 gfc_add_block_to_block (&globalblock
, &se
.pre
);
7940 size
= TYPE_SIZE_UNIT (TREE_TYPE (type
));
7942 gfc_add_modify (&block
, dest
, fold_convert (type
, null_pointer_node
));
7943 gfc_allocate_using_caf_lib (&block
, dummy_desc
, size
,
7944 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
7945 NULL_TREE
, NULL_TREE
, NULL_TREE
,
7946 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
7947 null_data
= gfc_finish_block (&block
);
7949 gfc_init_block (&block
);
7951 gfc_allocate_using_caf_lib (&block
, dummy_desc
,
7952 fold_convert (size_type_node
, size
),
7953 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
7954 NULL_TREE
, NULL_TREE
, NULL_TREE
,
7955 GFC_CAF_COARRAY_ALLOC
);
7957 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
7958 tmp
= build_call_expr_loc (input_location
, tmp
, 3, dest
, src
,
7959 fold_convert (size_type_node
, size
));
7960 gfc_add_expr_to_block (&block
, tmp
);
7964 /* Set the rank or unitialized memory access may be reported. */
7965 tmp
= gfc_conv_descriptor_dtype (dest
);
7966 gfc_add_modify (&globalblock
, tmp
, build_int_cst (TREE_TYPE (tmp
), rank
));
7969 nelems
= gfc_full_array_size (&block
, src
, rank
);
7971 nelems
= integer_one_node
;
7973 tmp
= fold_convert (size_type_node
,
7974 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
7975 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
7976 fold_convert (size_type_node
, nelems
), tmp
);
7978 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
7979 gfc_allocate_using_caf_lib (&block
, dest
, fold_convert (size_type_node
,
7981 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
7982 NULL_TREE
, NULL_TREE
, NULL_TREE
,
7983 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
7984 null_data
= gfc_finish_block (&block
);
7986 gfc_init_block (&block
);
7987 gfc_allocate_using_caf_lib (&block
, dest
,
7988 fold_convert (size_type_node
, size
),
7989 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
7990 NULL_TREE
, NULL_TREE
, NULL_TREE
,
7991 GFC_CAF_COARRAY_ALLOC
);
7993 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
7994 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
7995 gfc_conv_descriptor_data_get (dest
),
7996 gfc_conv_descriptor_data_get (src
),
7997 fold_convert (size_type_node
, size
));
7998 gfc_add_expr_to_block (&block
, tmp
);
8001 tmp
= gfc_finish_block (&block
);
8003 /* Null the destination if the source is null; otherwise do
8004 the register and copy. */
8005 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src
)))
8008 null_cond
= gfc_conv_descriptor_data_get (src
);
8010 null_cond
= convert (pvoid_type_node
, null_cond
);
8011 null_cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
8012 null_cond
, null_pointer_node
);
8013 gfc_add_expr_to_block (&globalblock
, build3_v (COND_EXPR
, null_cond
, tmp
,
8015 return gfc_finish_block (&globalblock
);
8019 /* Helper function to abstract whether coarray processing is enabled. */
8022 caf_enabled (int caf_mode
)
8024 return (caf_mode
& GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
)
8025 == GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
;
8029 /* Helper function to abstract whether coarray processing is enabled
8030 and we are in a derived type coarray. */
8033 caf_in_coarray (int caf_mode
)
8035 static const int pat
= GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
8036 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
;
8037 return (caf_mode
& pat
) == pat
;
8041 /* Helper function to abstract whether coarray is to deallocate only. */
8044 gfc_caf_is_dealloc_only (int caf_mode
)
8046 return (caf_mode
& GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY
)
8047 == GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY
;
8051 /* Recursively traverse an object of derived type, generating code to
8052 deallocate, nullify or copy allocatable components. This is the work horse
8053 function for the functions named in this enum. */
8055 enum {DEALLOCATE_ALLOC_COMP
= 1, NULLIFY_ALLOC_COMP
,
8056 COPY_ALLOC_COMP
, COPY_ONLY_ALLOC_COMP
, REASSIGN_CAF_COMP
};
8059 structure_alloc_comps (gfc_symbol
* der_type
, tree decl
,
8060 tree dest
, int rank
, int purpose
, int caf_mode
)
8064 stmtblock_t fnblock
;
8065 stmtblock_t loopbody
;
8066 stmtblock_t tmpblock
;
8077 tree null_cond
= NULL_TREE
;
8078 tree add_when_allocated
;
8079 tree dealloc_fndecl
;
8083 symbol_attribute
*attr
;
8084 bool deallocate_called
;
8086 gfc_init_block (&fnblock
);
8088 decl_type
= TREE_TYPE (decl
);
8090 if ((POINTER_TYPE_P (decl_type
))
8091 || (TREE_CODE (decl_type
) == REFERENCE_TYPE
&& rank
== 0))
8093 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
8094 /* Deref dest in sync with decl, but only when it is not NULL. */
8096 dest
= build_fold_indirect_ref_loc (input_location
, dest
);
8098 /* Update the decl_type because it got dereferenced. */
8099 decl_type
= TREE_TYPE (decl
);
8102 /* If this is an array of derived types with allocatable components
8103 build a loop and recursively call this function. */
8104 if (TREE_CODE (decl_type
) == ARRAY_TYPE
8105 || (GFC_DESCRIPTOR_TYPE_P (decl_type
) && rank
!= 0))
8107 tmp
= gfc_conv_array_data (decl
);
8108 var
= build_fold_indirect_ref_loc (input_location
, tmp
);
8110 /* Get the number of elements - 1 and set the counter. */
8111 if (GFC_DESCRIPTOR_TYPE_P (decl_type
))
8113 /* Use the descriptor for an allocatable array. Since this
8114 is a full array reference, we only need the descriptor
8115 information from dimension = rank. */
8116 tmp
= gfc_full_array_size (&fnblock
, decl
, rank
);
8117 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8118 gfc_array_index_type
, tmp
,
8119 gfc_index_one_node
);
8121 null_cond
= gfc_conv_descriptor_data_get (decl
);
8122 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
8123 boolean_type_node
, null_cond
,
8124 build_int_cst (TREE_TYPE (null_cond
), 0));
8128 /* Otherwise use the TYPE_DOMAIN information. */
8129 tmp
= array_type_nelts (decl_type
);
8130 tmp
= fold_convert (gfc_array_index_type
, tmp
);
8133 /* Remember that this is, in fact, the no. of elements - 1. */
8134 nelems
= gfc_evaluate_now (tmp
, &fnblock
);
8135 index
= gfc_create_var (gfc_array_index_type
, "S");
8137 /* Build the body of the loop. */
8138 gfc_init_block (&loopbody
);
8140 vref
= gfc_build_array_ref (var
, index
, NULL
);
8142 if ((purpose
== COPY_ALLOC_COMP
|| purpose
== COPY_ONLY_ALLOC_COMP
)
8143 && !caf_enabled (caf_mode
))
8145 tmp
= build_fold_indirect_ref_loc (input_location
,
8146 gfc_conv_array_data (dest
));
8147 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
8148 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
,
8149 COPY_ALLOC_COMP
, 0);
8152 tmp
= structure_alloc_comps (der_type
, vref
, NULL_TREE
, rank
, purpose
,
8155 gfc_add_expr_to_block (&loopbody
, tmp
);
8157 /* Build the loop and return. */
8158 gfc_init_loopinfo (&loop
);
8160 loop
.from
[0] = gfc_index_zero_node
;
8161 loop
.loopvar
[0] = index
;
8162 loop
.to
[0] = nelems
;
8163 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
8164 gfc_add_block_to_block (&fnblock
, &loop
.pre
);
8166 tmp
= gfc_finish_block (&fnblock
);
8167 /* When copying allocateable components, the above implements the
8168 deep copy. Nevertheless is a deep copy only allowed, when the current
8169 component is allocated, for which code will be generated in
8170 gfc_duplicate_allocatable (), where the deep copy code is just added
8171 into the if's body, by adding tmp (the deep copy code) as last
8172 argument to gfc_duplicate_allocatable (). */
8173 if (purpose
== COPY_ALLOC_COMP
8174 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
8175 tmp
= gfc_duplicate_allocatable (dest
, decl
, decl_type
, rank
,
8177 else if (null_cond
!= NULL_TREE
)
8178 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
8179 build_empty_stmt (input_location
));
8184 /* Otherwise, act on the components or recursively call self to
8185 act on a chain of components. */
8186 for (c
= der_type
->components
; c
; c
= c
->next
)
8188 bool cmp_has_alloc_comps
= (c
->ts
.type
== BT_DERIVED
8189 || c
->ts
.type
== BT_CLASS
)
8190 && c
->ts
.u
.derived
->attr
.alloc_comp
;
8191 bool same_type
= (c
->ts
.type
== BT_DERIVED
&& der_type
== c
->ts
.u
.derived
)
8192 || (c
->ts
.type
== BT_CLASS
&& der_type
== CLASS_DATA (c
)->ts
.u
.derived
);
8194 cdecl = c
->backend_decl
;
8195 ctype
= TREE_TYPE (cdecl);
8199 case DEALLOCATE_ALLOC_COMP
:
8201 gfc_init_block (&tmpblock
);
8203 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8204 decl
, cdecl, NULL_TREE
);
8206 /* Shortcut to get the attributes of the component. */
8207 if (c
->ts
.type
== BT_CLASS
)
8208 attr
= &CLASS_DATA (c
)->attr
;
8212 if ((c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
)
8213 || (c
->ts
.type
== BT_CLASS
&& !CLASS_DATA (c
)->attr
.class_pointer
))
8214 /* Call the finalizer, which will free the memory and nullify the
8215 pointer of an array. */
8216 deallocate_called
= gfc_add_comp_finalizer_call (&tmpblock
, comp
, c
,
8217 caf_enabled (caf_mode
))
8220 deallocate_called
= false;
8222 /* Add the _class ref for classes. */
8223 if (c
->ts
.type
== BT_CLASS
&& attr
->allocatable
)
8224 comp
= gfc_class_data_get (comp
);
8226 add_when_allocated
= NULL_TREE
;
8227 if (cmp_has_alloc_comps
8228 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
8230 && !deallocate_called
)
8232 /* Add checked deallocation of the components. This code is
8233 obviously added because the finalizer is not trusted to free
8235 if (c
->ts
.type
== BT_CLASS
)
8237 rank
= CLASS_DATA (c
)->as
? CLASS_DATA (c
)->as
->rank
: 0;
8239 = structure_alloc_comps (CLASS_DATA (c
)->ts
.u
.derived
,
8240 comp
, NULL_TREE
, rank
, purpose
,
8245 rank
= c
->as
? c
->as
->rank
: 0;
8246 add_when_allocated
= structure_alloc_comps (c
->ts
.u
.derived
,
8253 if (attr
->allocatable
&& !same_type
8254 && (!attr
->codimension
|| caf_enabled (caf_mode
)))
8256 /* Handle all types of components besides components of the
8257 same_type as the current one, because those would create an
8260 = (caf_in_coarray (caf_mode
) || attr
->codimension
)
8261 ? (gfc_caf_is_dealloc_only (caf_mode
)
8262 ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
8263 : GFC_CAF_COARRAY_DEREGISTER
)
8264 : GFC_CAF_COARRAY_NOCOARRAY
;
8266 caf_token
= NULL_TREE
;
8267 /* Coarray components are handled directly by
8268 deallocate_with_status. */
8269 if (!attr
->codimension
8270 && caf_dereg_mode
!= GFC_CAF_COARRAY_NOCOARRAY
)
8273 caf_token
= fold_build3_loc (input_location
, COMPONENT_REF
,
8274 TREE_TYPE (c
->caf_token
),
8275 decl
, c
->caf_token
, NULL_TREE
);
8276 else if (attr
->dimension
&& !attr
->proc_pointer
)
8277 caf_token
= gfc_conv_descriptor_token (comp
);
8279 if (attr
->dimension
&& !attr
->codimension
&& !attr
->proc_pointer
)
8280 /* When this is an array but not in conjunction with a coarray
8281 then add the data-ref. For coarray'ed arrays the data-ref
8282 is added by deallocate_with_status. */
8283 comp
= gfc_conv_descriptor_data_get (comp
);
8285 tmp
= gfc_deallocate_with_status (comp
, NULL_TREE
, NULL_TREE
,
8286 NULL_TREE
, NULL_TREE
, true,
8287 NULL
, caf_dereg_mode
,
8288 add_when_allocated
, caf_token
);
8290 gfc_add_expr_to_block (&tmpblock
, tmp
);
8292 else if (attr
->allocatable
&& !attr
->codimension
8293 && !deallocate_called
)
8295 /* Case of recursive allocatable derived types. */
8299 stmtblock_t dealloc_block
;
8301 gfc_init_block (&dealloc_block
);
8302 if (add_when_allocated
)
8303 gfc_add_expr_to_block (&dealloc_block
, add_when_allocated
);
8305 /* Convert the component into a rank 1 descriptor type. */
8306 if (attr
->dimension
)
8308 tmp
= gfc_get_element_type (TREE_TYPE (comp
));
8309 ubound
= gfc_full_array_size (&dealloc_block
, comp
,
8310 c
->ts
.type
== BT_CLASS
8311 ? CLASS_DATA (c
)->as
->rank
8316 tmp
= TREE_TYPE (comp
);
8317 ubound
= build_int_cst (gfc_array_index_type
, 1);
8320 cdesc
= gfc_get_array_type_bounds (tmp
, 1, 0, &gfc_index_one_node
,
8322 GFC_ARRAY_ALLOCATABLE
, false);
8324 cdesc
= gfc_create_var (cdesc
, "cdesc");
8325 DECL_ARTIFICIAL (cdesc
) = 1;
8327 gfc_add_modify (&dealloc_block
, gfc_conv_descriptor_dtype (cdesc
),
8328 gfc_get_dtype_rank_type (1, tmp
));
8329 gfc_conv_descriptor_lbound_set (&dealloc_block
, cdesc
,
8330 gfc_index_zero_node
,
8331 gfc_index_one_node
);
8332 gfc_conv_descriptor_stride_set (&dealloc_block
, cdesc
,
8333 gfc_index_zero_node
,
8334 gfc_index_one_node
);
8335 gfc_conv_descriptor_ubound_set (&dealloc_block
, cdesc
,
8336 gfc_index_zero_node
, ubound
);
8338 if (attr
->dimension
)
8339 comp
= gfc_conv_descriptor_data_get (comp
);
8341 gfc_conv_descriptor_data_set (&dealloc_block
, cdesc
, comp
);
8343 /* Now call the deallocator. */
8344 vtab
= gfc_find_vtab (&c
->ts
);
8345 if (vtab
->backend_decl
== NULL
)
8346 gfc_get_symbol_decl (vtab
);
8347 tmp
= gfc_build_addr_expr (NULL_TREE
, vtab
->backend_decl
);
8348 dealloc_fndecl
= gfc_vptr_deallocate_get (tmp
);
8349 dealloc_fndecl
= build_fold_indirect_ref_loc (input_location
,
8351 tmp
= build_int_cst (TREE_TYPE (comp
), 0);
8352 is_allocated
= fold_build2_loc (input_location
, NE_EXPR
,
8353 boolean_type_node
, tmp
,
8355 cdesc
= gfc_build_addr_expr (NULL_TREE
, cdesc
);
8357 tmp
= build_call_expr_loc (input_location
,
8360 gfc_add_expr_to_block (&dealloc_block
, tmp
);
8362 tmp
= gfc_finish_block (&dealloc_block
);
8364 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
8365 void_type_node
, is_allocated
, tmp
,
8366 build_empty_stmt (input_location
));
8368 gfc_add_expr_to_block (&tmpblock
, tmp
);
8370 else if (add_when_allocated
)
8371 gfc_add_expr_to_block (&tmpblock
, add_when_allocated
);
8373 if (c
->ts
.type
== BT_CLASS
&& attr
->allocatable
8374 && (!attr
->codimension
|| !caf_enabled (caf_mode
)))
8376 /* Finally, reset the vptr to the declared type vtable and, if
8377 necessary reset the _len field.
8379 First recover the reference to the component and obtain
8381 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8382 decl
, cdecl, NULL_TREE
);
8383 tmp
= gfc_class_vptr_get (comp
);
8385 if (UNLIMITED_POLY (c
))
8387 /* Both vptr and _len field should be nulled. */
8388 gfc_add_modify (&tmpblock
, tmp
,
8389 build_int_cst (TREE_TYPE (tmp
), 0));
8390 tmp
= gfc_class_len_get (comp
);
8391 gfc_add_modify (&tmpblock
, tmp
,
8392 build_int_cst (TREE_TYPE (tmp
), 0));
8396 /* Build the vtable address and set the vptr with it. */
8399 vtable
= gfc_find_derived_vtab (c
->ts
.u
.derived
);
8400 vtab
= vtable
->backend_decl
;
8401 if (vtab
== NULL_TREE
)
8402 vtab
= gfc_get_symbol_decl (vtable
);
8403 vtab
= gfc_build_addr_expr (NULL
, vtab
);
8404 vtab
= fold_convert (TREE_TYPE (tmp
), vtab
);
8405 gfc_add_modify (&tmpblock
, tmp
, vtab
);
8409 /* Now add the deallocation of this component. */
8410 gfc_add_block_to_block (&fnblock
, &tmpblock
);
8413 case NULLIFY_ALLOC_COMP
:
8414 if (c
->attr
.pointer
|| c
->attr
.proc_pointer
8415 || !(c
->attr
.allocatable
|| (c
->ts
.type
== BT_CLASS
8416 && CLASS_DATA (c
)->attr
.allocatable
)
8417 || cmp_has_alloc_comps
))
8420 /* Coarrays need the component to be initialized before the api-call
8422 if (c
->attr
.allocatable
&& (c
->attr
.dimension
|| c
->attr
.codimension
))
8424 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8425 decl
, cdecl, NULL_TREE
);
8426 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
8427 cmp_has_alloc_comps
= false;
8429 else if (c
->attr
.allocatable
)
8431 /* Allocatable scalar components. */
8432 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8433 decl
, cdecl, NULL_TREE
);
8434 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8435 void_type_node
, comp
,
8436 build_int_cst (TREE_TYPE (comp
), 0));
8437 gfc_add_expr_to_block (&fnblock
, tmp
);
8438 if (gfc_deferred_strlen (c
, &comp
))
8440 comp
= fold_build3_loc (input_location
, COMPONENT_REF
,
8442 decl
, comp
, NULL_TREE
);
8443 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8444 TREE_TYPE (comp
), comp
,
8445 build_int_cst (TREE_TYPE (comp
), 0));
8446 gfc_add_expr_to_block (&fnblock
, tmp
);
8448 cmp_has_alloc_comps
= false;
8450 else if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
8452 /* Allocatable CLASS components. */
8453 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8454 decl
, cdecl, NULL_TREE
);
8456 comp
= gfc_class_data_get (comp
);
8457 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp
)))
8458 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
8461 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8462 void_type_node
, comp
,
8463 build_int_cst (TREE_TYPE (comp
), 0));
8464 gfc_add_expr_to_block (&fnblock
, tmp
);
8466 cmp_has_alloc_comps
= false;
8469 if (flag_coarray
== GFC_FCOARRAY_LIB
8470 && (caf_in_coarray (caf_mode
) || c
->attr
.codimension
))
8472 /* Register the component with the coarray library. */
8475 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8476 decl
, cdecl, NULL_TREE
);
8477 if (c
->attr
.dimension
|| c
->attr
.codimension
)
8479 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8480 decl
, cdecl, NULL_TREE
);
8481 token
= gfc_conv_descriptor_token (tmp
);
8486 symbol_attribute attr
;
8488 gfc_init_se (&se
, NULL
);
8489 gfc_clear_attr (&attr
);
8490 token
= fold_build3_loc (input_location
, COMPONENT_REF
,
8491 pvoid_type_node
, decl
, c
->caf_token
,
8493 comp
= gfc_conv_scalar_to_descriptor (&se
, comp
, attr
);
8494 gfc_add_block_to_block (&fnblock
, &se
.pre
);
8497 /* NULL the member-token before registering it or uninitialized
8498 memory accesses may occur. */
8499 gfc_add_modify (&fnblock
, token
, fold_convert (TREE_TYPE (token
),
8500 null_pointer_node
));
8501 gfc_allocate_using_caf_lib (&fnblock
, comp
, size_zero_node
,
8502 gfc_build_addr_expr (NULL_TREE
,
8504 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8505 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
8508 if (cmp_has_alloc_comps
)
8510 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8511 decl
, cdecl, NULL_TREE
);
8512 rank
= c
->as
? c
->as
->rank
: 0;
8513 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
8514 rank
, purpose
, caf_mode
);
8515 gfc_add_expr_to_block (&fnblock
, tmp
);
8519 case REASSIGN_CAF_COMP
:
8520 if (caf_enabled (caf_mode
)
8521 && (c
->attr
.codimension
8522 || (c
->ts
.type
== BT_CLASS
8523 && (CLASS_DATA (c
)->attr
.coarray_comp
8524 || caf_in_coarray (caf_mode
)))
8525 || (c
->ts
.type
== BT_DERIVED
8526 && (c
->ts
.u
.derived
->attr
.coarray_comp
8527 || caf_in_coarray (caf_mode
))))
8530 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8531 decl
, cdecl, NULL_TREE
);
8532 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8533 dest
, cdecl, NULL_TREE
);
8535 if (c
->attr
.codimension
)
8537 if (c
->ts
.type
== BT_CLASS
)
8539 comp
= gfc_class_data_get (comp
);
8540 dcmp
= gfc_class_data_get (dcmp
);
8542 gfc_conv_descriptor_data_set (&fnblock
, dcmp
,
8543 gfc_conv_descriptor_data_get (comp
));
8547 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, dcmp
,
8548 rank
, purpose
, caf_mode
8549 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
);
8550 gfc_add_expr_to_block (&fnblock
, tmp
);
8555 case COPY_ALLOC_COMP
:
8556 if (c
->attr
.pointer
)
8559 /* We need source and destination components. */
8560 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, decl
,
8562 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, dest
,
8564 dcmp
= fold_convert (TREE_TYPE (comp
), dcmp
);
8566 if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
8574 dst_data
= gfc_class_data_get (dcmp
);
8575 src_data
= gfc_class_data_get (comp
);
8576 size
= fold_convert (size_type_node
,
8577 gfc_class_vtab_size_get (comp
));
8579 if (CLASS_DATA (c
)->attr
.dimension
)
8581 nelems
= gfc_conv_descriptor_size (src_data
,
8582 CLASS_DATA (c
)->as
->rank
);
8583 size
= fold_build2_loc (input_location
, MULT_EXPR
,
8584 size_type_node
, size
,
8585 fold_convert (size_type_node
,
8589 nelems
= build_int_cst (size_type_node
, 1);
8591 if (CLASS_DATA (c
)->attr
.dimension
8592 || CLASS_DATA (c
)->attr
.codimension
)
8594 src_data
= gfc_conv_descriptor_data_get (src_data
);
8595 dst_data
= gfc_conv_descriptor_data_get (dst_data
);
8598 gfc_init_block (&tmpblock
);
8600 /* Coarray component have to have the same allocation status and
8601 shape/type-parameter/effective-type on the LHS and RHS of an
8602 intrinsic assignment. Hence, we did not deallocated them - and
8603 do not allocate them here. */
8604 if (!CLASS_DATA (c
)->attr
.codimension
)
8606 ftn_tree
= builtin_decl_explicit (BUILT_IN_MALLOC
);
8607 tmp
= build_call_expr_loc (input_location
, ftn_tree
, 1, size
);
8608 gfc_add_modify (&tmpblock
, dst_data
,
8609 fold_convert (TREE_TYPE (dst_data
), tmp
));
8612 tmp
= gfc_copy_class_to_class (comp
, dcmp
, nelems
,
8613 UNLIMITED_POLY (c
));
8614 gfc_add_expr_to_block (&tmpblock
, tmp
);
8615 tmp
= gfc_finish_block (&tmpblock
);
8617 gfc_init_block (&tmpblock
);
8618 gfc_add_modify (&tmpblock
, dst_data
,
8619 fold_convert (TREE_TYPE (dst_data
),
8620 null_pointer_node
));
8621 null_data
= gfc_finish_block (&tmpblock
);
8623 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
8624 boolean_type_node
, src_data
,
8627 gfc_add_expr_to_block (&fnblock
, build3_v (COND_EXPR
, null_cond
,
8632 /* To implement guarded deep copy, i.e., deep copy only allocatable
8633 components that are really allocated, the deep copy code has to
8634 be generated first and then added to the if-block in
8635 gfc_duplicate_allocatable (). */
8636 if (cmp_has_alloc_comps
&& !c
->attr
.proc_pointer
8639 rank
= c
->as
? c
->as
->rank
: 0;
8640 tmp
= fold_convert (TREE_TYPE (dcmp
), comp
);
8641 gfc_add_modify (&fnblock
, dcmp
, tmp
);
8642 add_when_allocated
= structure_alloc_comps (c
->ts
.u
.derived
,
8648 add_when_allocated
= NULL_TREE
;
8650 if (gfc_deferred_strlen (c
, &tmp
))
8654 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
8656 decl
, len
, NULL_TREE
);
8657 len
= fold_build3_loc (input_location
, COMPONENT_REF
,
8659 dest
, len
, NULL_TREE
);
8660 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8661 TREE_TYPE (len
), len
, tmp
);
8662 gfc_add_expr_to_block (&fnblock
, tmp
);
8663 size
= size_of_string_in_bytes (c
->ts
.kind
, len
);
8664 /* This component can not have allocatable components,
8665 therefore add_when_allocated of duplicate_allocatable ()
8667 tmp
= duplicate_allocatable (dcmp
, comp
, ctype
, rank
,
8668 false, false, size
, NULL_TREE
);
8669 gfc_add_expr_to_block (&fnblock
, tmp
);
8671 else if (c
->attr
.allocatable
&& !c
->attr
.proc_pointer
&& !same_type
8672 && (!(cmp_has_alloc_comps
&& c
->as
) || c
->attr
.codimension
8673 || caf_in_coarray (caf_mode
)))
8675 rank
= c
->as
? c
->as
->rank
: 0;
8676 if (c
->attr
.codimension
)
8677 tmp
= gfc_copy_allocatable_data (dcmp
, comp
, ctype
, rank
);
8678 else if (flag_coarray
== GFC_FCOARRAY_LIB
8679 && caf_in_coarray (caf_mode
))
8681 tree dst_tok
= c
->as
? gfc_conv_descriptor_token (dcmp
)
8682 : fold_build3_loc (input_location
,
8684 pvoid_type_node
, dest
,
8687 tmp
= duplicate_allocatable_coarray (dcmp
, dst_tok
, comp
,
8691 tmp
= gfc_duplicate_allocatable (dcmp
, comp
, ctype
, rank
,
8692 add_when_allocated
);
8693 gfc_add_expr_to_block (&fnblock
, tmp
);
8696 if (cmp_has_alloc_comps
)
8697 gfc_add_expr_to_block (&fnblock
, add_when_allocated
);
8707 return gfc_finish_block (&fnblock
);
8710 /* Recursively traverse an object of derived type, generating code to
8711 nullify allocatable components. */
8714 gfc_nullify_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
8716 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
8718 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
);
8722 /* Recursively traverse an object of derived type, generating code to
8723 deallocate allocatable components. */
8726 gfc_deallocate_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
8729 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
8730 DEALLOCATE_ALLOC_COMP
,
8731 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
| caf_mode
);
8735 /* Recursively traverse an object of derived type, generating code to
8736 deallocate allocatable components. But do not deallocate coarrays.
8737 To be used for intrinsic assignment, which may not change the allocation
8738 status of coarrays. */
8741 gfc_deallocate_alloc_comp_no_caf (gfc_symbol
* der_type
, tree decl
, int rank
)
8743 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
8744 DEALLOCATE_ALLOC_COMP
, 0);
8749 gfc_reassign_alloc_comp_caf (gfc_symbol
*der_type
, tree decl
, tree dest
)
8751 return structure_alloc_comps (der_type
, decl
, dest
, 0, REASSIGN_CAF_COMP
,
8752 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
);
8756 /* Recursively traverse an object of derived type, generating code to
8757 copy it and its allocatable components. */
8760 gfc_copy_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
,
8763 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ALLOC_COMP
,
8768 /* Recursively traverse an object of derived type, generating code to
8769 copy only its allocatable components. */
8772 gfc_copy_only_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
8774 return structure_alloc_comps (der_type
, decl
, dest
, rank
,
8775 COPY_ONLY_ALLOC_COMP
, 0);
8779 /* Returns the value of LBOUND for an expression. This could be broken out
8780 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
8781 called by gfc_alloc_allocatable_for_assignment. */
8783 get_std_lbound (gfc_expr
*expr
, tree desc
, int dim
, bool assumed_size
)
8788 tree cond
, cond1
, cond3
, cond4
;
8792 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
8794 tmp
= gfc_rank_cst
[dim
];
8795 lbound
= gfc_conv_descriptor_lbound_get (desc
, tmp
);
8796 ubound
= gfc_conv_descriptor_ubound_get (desc
, tmp
);
8797 stride
= gfc_conv_descriptor_stride_get (desc
, tmp
);
8798 cond1
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
8800 cond3
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
8801 stride
, gfc_index_zero_node
);
8802 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8803 boolean_type_node
, cond3
, cond1
);
8804 cond4
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
8805 stride
, gfc_index_zero_node
);
8807 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
8808 tmp
, build_int_cst (gfc_array_index_type
,
8811 cond
= boolean_false_node
;
8813 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
8814 boolean_type_node
, cond3
, cond4
);
8815 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
8816 boolean_type_node
, cond
, cond1
);
8818 return fold_build3_loc (input_location
, COND_EXPR
,
8819 gfc_array_index_type
, cond
,
8820 lbound
, gfc_index_one_node
);
8823 if (expr
->expr_type
== EXPR_FUNCTION
)
8825 /* A conversion function, so use the argument. */
8826 gcc_assert (expr
->value
.function
.isym
8827 && expr
->value
.function
.isym
->conversion
);
8828 expr
= expr
->value
.function
.actual
->expr
;
8831 if (expr
->expr_type
== EXPR_VARIABLE
)
8833 tmp
= TREE_TYPE (expr
->symtree
->n
.sym
->backend_decl
);
8834 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
8836 if (ref
->type
== REF_COMPONENT
8837 && ref
->u
.c
.component
->as
8839 && ref
->next
->u
.ar
.type
== AR_FULL
)
8840 tmp
= TREE_TYPE (ref
->u
.c
.component
->backend_decl
);
8842 return GFC_TYPE_ARRAY_LBOUND(tmp
, dim
);
8845 return gfc_index_one_node
;
8849 /* Returns true if an expression represents an lhs that can be reallocated
8853 gfc_is_reallocatable_lhs (gfc_expr
*expr
)
8860 /* An allocatable class variable with no reference. */
8861 if (expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
8862 && CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.allocatable
8863 && expr
->ref
&& expr
->ref
->type
== REF_COMPONENT
8864 && strcmp (expr
->ref
->u
.c
.component
->name
, "_data") == 0
8865 && expr
->ref
->next
== NULL
)
8868 /* An allocatable variable. */
8869 if (expr
->symtree
->n
.sym
->attr
.allocatable
8871 && expr
->ref
->type
== REF_ARRAY
8872 && expr
->ref
->u
.ar
.type
== AR_FULL
)
8875 /* All that can be left are allocatable components. */
8876 if ((expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
8877 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
8878 || !expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
8881 /* Find a component ref followed by an array reference. */
8882 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
8884 && ref
->type
== REF_COMPONENT
8885 && ref
->next
->type
== REF_ARRAY
8886 && !ref
->next
->next
)
8892 /* Return true if valid reallocatable lhs. */
8893 if (ref
->u
.c
.component
->attr
.allocatable
8894 && ref
->next
->u
.ar
.type
== AR_FULL
)
8902 concat_str_length (gfc_expr
* expr
)
8909 type
= gfc_typenode_for_spec (&expr
->value
.op
.op1
->ts
);
8910 len1
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
8911 if (len1
== NULL_TREE
)
8913 if (expr
->value
.op
.op1
->expr_type
== EXPR_OP
)
8914 len1
= concat_str_length (expr
->value
.op
.op1
);
8915 else if (expr
->value
.op
.op1
->expr_type
== EXPR_CONSTANT
)
8916 len1
= build_int_cst (gfc_charlen_type_node
,
8917 expr
->value
.op
.op1
->value
.character
.length
);
8918 else if (expr
->value
.op
.op1
->ts
.u
.cl
->length
)
8920 gfc_init_se (&se
, NULL
);
8921 gfc_conv_expr (&se
, expr
->value
.op
.op1
->ts
.u
.cl
->length
);
8927 gfc_init_se (&se
, NULL
);
8928 se
.want_pointer
= 1;
8929 se
.descriptor_only
= 1;
8930 gfc_conv_expr (&se
, expr
->value
.op
.op1
);
8931 len1
= se
.string_length
;
8935 type
= gfc_typenode_for_spec (&expr
->value
.op
.op2
->ts
);
8936 len2
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
8937 if (len2
== NULL_TREE
)
8939 if (expr
->value
.op
.op2
->expr_type
== EXPR_OP
)
8940 len2
= concat_str_length (expr
->value
.op
.op2
);
8941 else if (expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
8942 len2
= build_int_cst (gfc_charlen_type_node
,
8943 expr
->value
.op
.op2
->value
.character
.length
);
8944 else if (expr
->value
.op
.op2
->ts
.u
.cl
->length
)
8946 gfc_init_se (&se
, NULL
);
8947 gfc_conv_expr (&se
, expr
->value
.op
.op2
->ts
.u
.cl
->length
);
8953 gfc_init_se (&se
, NULL
);
8954 se
.want_pointer
= 1;
8955 se
.descriptor_only
= 1;
8956 gfc_conv_expr (&se
, expr
->value
.op
.op2
);
8957 len2
= se
.string_length
;
8961 gcc_assert(len1
&& len2
);
8962 len1
= fold_convert (gfc_charlen_type_node
, len1
);
8963 len2
= fold_convert (gfc_charlen_type_node
, len2
);
8965 return fold_build2_loc (input_location
, PLUS_EXPR
,
8966 gfc_charlen_type_node
, len1
, len2
);
8970 /* Allocate the lhs of an assignment to an allocatable array, otherwise
8974 gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop
,
8978 stmtblock_t realloc_block
;
8979 stmtblock_t alloc_block
;
8983 gfc_array_info
*linfo
;
9005 gfc_array_spec
* as
;
9006 bool coarray
= (flag_coarray
== GFC_FCOARRAY_LIB
9007 && gfc_caf_attr (expr1
, true).codimension
);
9011 /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
9012 Find the lhs expression in the loop chain and set expr1 and
9013 expr2 accordingly. */
9014 if (expr1
->expr_type
== EXPR_FUNCTION
&& expr2
== NULL
)
9017 /* Find the ss for the lhs. */
9019 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
9020 if (lss
->info
->expr
&& lss
->info
->expr
->expr_type
== EXPR_VARIABLE
)
9022 if (lss
== gfc_ss_terminator
)
9024 expr1
= lss
->info
->expr
;
9027 /* Bail out if this is not a valid allocate on assignment. */
9028 if (!gfc_is_reallocatable_lhs (expr1
)
9029 || (expr2
&& !expr2
->rank
))
9032 /* Find the ss for the lhs. */
9034 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
9035 if (lss
->info
->expr
== expr1
)
9038 if (lss
== gfc_ss_terminator
)
9041 linfo
= &lss
->info
->data
.array
;
9043 /* Find an ss for the rhs. For operator expressions, we see the
9044 ss's for the operands. Any one of these will do. */
9046 for (; rss
&& rss
!= gfc_ss_terminator
; rss
= rss
->loop_chain
)
9047 if (rss
->info
->expr
!= expr1
&& rss
!= loop
->temp_ss
)
9050 if (expr2
&& rss
== gfc_ss_terminator
)
9053 gfc_start_block (&fblock
);
9055 /* Since the lhs is allocatable, this must be a descriptor type.
9056 Get the data and array size. */
9057 desc
= linfo
->descriptor
;
9058 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)));
9059 array1
= gfc_conv_descriptor_data_get (desc
);
9061 /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
9062 deallocated if expr is an array of different shape or any of the
9063 corresponding length type parameter values of variable and expr
9064 differ." This assures F95 compatibility. */
9065 jump_label1
= gfc_build_label_decl (NULL_TREE
);
9066 jump_label2
= gfc_build_label_decl (NULL_TREE
);
9068 /* Allocate if data is NULL. */
9069 cond_null
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
9070 array1
, build_int_cst (TREE_TYPE (array1
), 0));
9072 if (expr1
->ts
.deferred
)
9073 cond_null
= gfc_evaluate_now (boolean_true_node
, &fblock
);
9075 cond_null
= gfc_evaluate_now (cond_null
, &fblock
);
9077 tmp
= build3_v (COND_EXPR
, cond_null
,
9078 build1_v (GOTO_EXPR
, jump_label1
),
9079 build_empty_stmt (input_location
));
9080 gfc_add_expr_to_block (&fblock
, tmp
);
9082 /* Get arrayspec if expr is a full array. */
9083 if (expr2
&& expr2
->expr_type
== EXPR_FUNCTION
9084 && expr2
->value
.function
.isym
9085 && expr2
->value
.function
.isym
->conversion
)
9087 /* For conversion functions, take the arg. */
9088 gfc_expr
*arg
= expr2
->value
.function
.actual
->expr
;
9089 as
= gfc_get_full_arrayspec_from_expr (arg
);
9092 as
= gfc_get_full_arrayspec_from_expr (expr2
);
9096 /* If the lhs shape is not the same as the rhs jump to setting the
9097 bounds and doing the reallocation....... */
9098 for (n
= 0; n
< expr1
->rank
; n
++)
9100 /* Check the shape. */
9101 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
9102 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
9103 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9104 gfc_array_index_type
,
9105 loop
->to
[n
], loop
->from
[n
]);
9106 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9107 gfc_array_index_type
,
9109 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9110 gfc_array_index_type
,
9112 cond
= fold_build2_loc (input_location
, NE_EXPR
,
9114 tmp
, gfc_index_zero_node
);
9115 tmp
= build3_v (COND_EXPR
, cond
,
9116 build1_v (GOTO_EXPR
, jump_label1
),
9117 build_empty_stmt (input_location
));
9118 gfc_add_expr_to_block (&fblock
, tmp
);
9121 /* ....else jump past the (re)alloc code. */
9122 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
9123 gfc_add_expr_to_block (&fblock
, tmp
);
9125 /* Add the label to start automatic (re)allocation. */
9126 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
9127 gfc_add_expr_to_block (&fblock
, tmp
);
9129 /* If the lhs has not been allocated, its bounds will not have been
9130 initialized and so its size is set to zero. */
9131 size1
= gfc_create_var (gfc_array_index_type
, NULL
);
9132 gfc_init_block (&alloc_block
);
9133 gfc_add_modify (&alloc_block
, size1
, gfc_index_zero_node
);
9134 gfc_init_block (&realloc_block
);
9135 gfc_add_modify (&realloc_block
, size1
,
9136 gfc_conv_descriptor_size (desc
, expr1
->rank
));
9137 tmp
= build3_v (COND_EXPR
, cond_null
,
9138 gfc_finish_block (&alloc_block
),
9139 gfc_finish_block (&realloc_block
));
9140 gfc_add_expr_to_block (&fblock
, tmp
);
9142 /* Get the rhs size and fix it. */
9144 desc2
= rss
->info
->data
.array
.descriptor
;
9148 size2
= gfc_index_one_node
;
9149 for (n
= 0; n
< expr2
->rank
; n
++)
9151 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9152 gfc_array_index_type
,
9153 loop
->to
[n
], loop
->from
[n
]);
9154 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9155 gfc_array_index_type
,
9156 tmp
, gfc_index_one_node
);
9157 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
9158 gfc_array_index_type
,
9161 size2
= gfc_evaluate_now (size2
, &fblock
);
9163 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
9166 /* If the lhs is deferred length, assume that the element size
9167 changes and force a reallocation. */
9168 if (expr1
->ts
.deferred
)
9169 neq_size
= gfc_evaluate_now (boolean_true_node
, &fblock
);
9171 neq_size
= gfc_evaluate_now (cond
, &fblock
);
9173 /* Deallocation of allocatable components will have to occur on
9174 reallocation. Fix the old descriptor now. */
9175 if ((expr1
->ts
.type
== BT_DERIVED
)
9176 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
9177 old_desc
= gfc_evaluate_now (desc
, &fblock
);
9179 old_desc
= NULL_TREE
;
9181 /* Now modify the lhs descriptor and the associated scalarizer
9182 variables. F2003 7.4.1.3: "If variable is or becomes an
9183 unallocated allocatable variable, then it is allocated with each
9184 deferred type parameter equal to the corresponding type parameters
9185 of expr , with the shape of expr , and with each lower bound equal
9186 to the corresponding element of LBOUND(expr)."
9187 Reuse size1 to keep a dimension-by-dimension track of the
9188 stride of the new array. */
9189 size1
= gfc_index_one_node
;
9190 offset
= gfc_index_zero_node
;
9192 for (n
= 0; n
< expr2
->rank
; n
++)
9194 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9195 gfc_array_index_type
,
9196 loop
->to
[n
], loop
->from
[n
]);
9197 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9198 gfc_array_index_type
,
9199 tmp
, gfc_index_one_node
);
9201 lbound
= gfc_index_one_node
;
9206 lbd
= get_std_lbound (expr2
, desc2
, n
,
9207 as
->type
== AS_ASSUMED_SIZE
);
9208 ubound
= fold_build2_loc (input_location
,
9210 gfc_array_index_type
,
9212 ubound
= fold_build2_loc (input_location
,
9214 gfc_array_index_type
,
9219 gfc_conv_descriptor_lbound_set (&fblock
, desc
,
9222 gfc_conv_descriptor_ubound_set (&fblock
, desc
,
9225 gfc_conv_descriptor_stride_set (&fblock
, desc
,
9228 lbound
= gfc_conv_descriptor_lbound_get (desc
,
9230 tmp2
= fold_build2_loc (input_location
, MULT_EXPR
,
9231 gfc_array_index_type
,
9233 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
9234 gfc_array_index_type
,
9236 size1
= fold_build2_loc (input_location
, MULT_EXPR
,
9237 gfc_array_index_type
,
9241 /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
9242 the array offset is saved and the info.offset is used for a
9243 running offset. Use the saved_offset instead. */
9244 tmp
= gfc_conv_descriptor_offset (desc
);
9245 gfc_add_modify (&fblock
, tmp
, offset
);
9246 if (linfo
->saved_offset
9247 && VAR_P (linfo
->saved_offset
))
9248 gfc_add_modify (&fblock
, linfo
->saved_offset
, tmp
);
9250 /* Now set the deltas for the lhs. */
9251 for (n
= 0; n
< expr1
->rank
; n
++)
9253 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
9255 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9256 gfc_array_index_type
, tmp
,
9258 if (linfo
->delta
[dim
] && VAR_P (linfo
->delta
[dim
]))
9259 gfc_add_modify (&fblock
, linfo
->delta
[dim
], tmp
);
9262 /* Get the new lhs size in bytes. */
9263 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9265 if (expr2
->ts
.deferred
)
9267 if (VAR_P (expr2
->ts
.u
.cl
->backend_decl
))
9268 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
9270 tmp
= rss
->info
->string_length
;
9274 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
9275 if (!tmp
&& expr2
->expr_type
== EXPR_OP
9276 && expr2
->value
.op
.op
== INTRINSIC_CONCAT
)
9278 tmp
= concat_str_length (expr2
);
9279 expr2
->ts
.u
.cl
->backend_decl
= gfc_evaluate_now (tmp
, &fblock
);
9281 tmp
= fold_convert (TREE_TYPE (expr1
->ts
.u
.cl
->backend_decl
), tmp
);
9284 if (expr1
->ts
.u
.cl
->backend_decl
9285 && VAR_P (expr1
->ts
.u
.cl
->backend_decl
))
9286 gfc_add_modify (&fblock
, expr1
->ts
.u
.cl
->backend_decl
, tmp
);
9288 gfc_add_modify (&fblock
, lss
->info
->string_length
, tmp
);
9290 else if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.u
.cl
->backend_decl
)
9292 tmp
= TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
)));
9293 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
9294 gfc_array_index_type
, tmp
,
9295 expr1
->ts
.u
.cl
->backend_decl
);
9298 tmp
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
9299 tmp
= fold_convert (gfc_array_index_type
, tmp
);
9300 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
9301 gfc_array_index_type
,
9303 size2
= fold_convert (size_type_node
, size2
);
9304 size2
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
9305 size2
, size_one_node
);
9306 size2
= gfc_evaluate_now (size2
, &fblock
);
9308 /* For deferred character length, the 'size' field of the dtype might
9309 have changed so set the dtype. */
9310 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
9311 && expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9314 tmp
= gfc_conv_descriptor_dtype (desc
);
9315 if (expr2
->ts
.u
.cl
->backend_decl
)
9316 type
= gfc_typenode_for_spec (&expr2
->ts
);
9318 type
= gfc_typenode_for_spec (&expr1
->ts
);
9320 gfc_add_modify (&fblock
, tmp
,
9321 gfc_get_dtype_rank_type (expr1
->rank
,type
));
9323 else if (coarray
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
9325 gfc_add_modify (&fblock
, gfc_conv_descriptor_dtype (desc
),
9326 gfc_get_dtype (TREE_TYPE (desc
)));
9329 /* Realloc expression. Note that the scalarizer uses desc.data
9330 in the array reference - (*desc.data)[<element>]. */
9331 gfc_init_block (&realloc_block
);
9332 gfc_init_se (&caf_se
, NULL
);
9336 token
= gfc_get_ultimate_alloc_ptr_comps_caf_token (&caf_se
, expr1
);
9337 if (token
== NULL_TREE
)
9339 tmp
= gfc_get_tree_for_caf_expr (expr1
);
9340 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
9341 tmp
= build_fold_indirect_ref (tmp
);
9342 gfc_get_caf_token_offset (&caf_se
, &token
, NULL
, tmp
, NULL_TREE
,
9344 token
= gfc_build_addr_expr (NULL_TREE
, token
);
9347 gfc_add_block_to_block (&realloc_block
, &caf_se
.pre
);
9349 if ((expr1
->ts
.type
== BT_DERIVED
)
9350 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
9352 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, old_desc
,
9354 gfc_add_expr_to_block (&realloc_block
, tmp
);
9359 tmp
= build_call_expr_loc (input_location
,
9360 builtin_decl_explicit (BUILT_IN_REALLOC
), 2,
9361 fold_convert (pvoid_type_node
, array1
),
9363 gfc_conv_descriptor_data_set (&realloc_block
,
9368 tmp
= build_call_expr_loc (input_location
,
9369 gfor_fndecl_caf_deregister
, 5, token
,
9370 build_int_cst (integer_type_node
,
9371 GFC_CAF_COARRAY_DEALLOCATE_ONLY
),
9372 null_pointer_node
, null_pointer_node
,
9374 gfc_add_expr_to_block (&realloc_block
, tmp
);
9375 tmp
= build_call_expr_loc (input_location
,
9376 gfor_fndecl_caf_register
,
9378 build_int_cst (integer_type_node
,
9379 GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY
),
9380 token
, gfc_build_addr_expr (NULL_TREE
, desc
),
9381 null_pointer_node
, null_pointer_node
,
9383 gfc_add_expr_to_block (&realloc_block
, tmp
);
9386 if ((expr1
->ts
.type
== BT_DERIVED
)
9387 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
9389 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, desc
,
9391 gfc_add_expr_to_block (&realloc_block
, tmp
);
9394 gfc_add_block_to_block (&realloc_block
, &caf_se
.post
);
9395 realloc_expr
= gfc_finish_block (&realloc_block
);
9397 /* Only reallocate if sizes are different. */
9398 tmp
= build3_v (COND_EXPR
, neq_size
, realloc_expr
,
9399 build_empty_stmt (input_location
));
9403 /* Malloc expression. */
9404 gfc_init_block (&alloc_block
);
9407 tmp
= build_call_expr_loc (input_location
,
9408 builtin_decl_explicit (BUILT_IN_MALLOC
),
9410 gfc_conv_descriptor_data_set (&alloc_block
,
9415 tmp
= build_call_expr_loc (input_location
,
9416 gfor_fndecl_caf_register
,
9418 build_int_cst (integer_type_node
,
9419 GFC_CAF_COARRAY_ALLOC
),
9420 token
, gfc_build_addr_expr (NULL_TREE
, desc
),
9421 null_pointer_node
, null_pointer_node
,
9423 gfc_add_expr_to_block (&alloc_block
, tmp
);
9427 /* We already set the dtype in the case of deferred character
9429 if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
9430 && ((expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9433 tmp
= gfc_conv_descriptor_dtype (desc
);
9434 gfc_add_modify (&alloc_block
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
9437 if ((expr1
->ts
.type
== BT_DERIVED
)
9438 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
9440 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, desc
,
9442 gfc_add_expr_to_block (&alloc_block
, tmp
);
9444 alloc_expr
= gfc_finish_block (&alloc_block
);
9446 /* Malloc if not allocated; realloc otherwise. */
9447 tmp
= build_int_cst (TREE_TYPE (array1
), 0);
9448 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
9451 tmp
= build3_v (COND_EXPR
, cond
, alloc_expr
, realloc_expr
);
9452 gfc_add_expr_to_block (&fblock
, tmp
);
9454 /* Make sure that the scalarizer data pointer is updated. */
9455 if (linfo
->data
&& VAR_P (linfo
->data
))
9457 tmp
= gfc_conv_descriptor_data_get (desc
);
9458 gfc_add_modify (&fblock
, linfo
->data
, tmp
);
9461 /* Add the exit label. */
9462 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
9463 gfc_add_expr_to_block (&fblock
, tmp
);
9465 return gfc_finish_block (&fblock
);
9469 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
9470 Do likewise, recursively if necessary, with the allocatable components of
9474 gfc_trans_deferred_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
9480 stmtblock_t cleanup
;
9483 bool sym_has_alloc_comp
, has_finalizer
;
9485 sym_has_alloc_comp
= (sym
->ts
.type
== BT_DERIVED
9486 || sym
->ts
.type
== BT_CLASS
)
9487 && sym
->ts
.u
.derived
->attr
.alloc_comp
;
9488 has_finalizer
= sym
->ts
.type
== BT_CLASS
|| sym
->ts
.type
== BT_DERIVED
9489 ? gfc_is_finalizable (sym
->ts
.u
.derived
, NULL
) : false;
9491 /* Make sure the frontend gets these right. */
9492 gcc_assert (sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym_has_alloc_comp
9495 gfc_save_backend_locus (&loc
);
9496 gfc_set_backend_locus (&sym
->declared_at
);
9497 gfc_init_block (&init
);
9499 gcc_assert (VAR_P (sym
->backend_decl
)
9500 || TREE_CODE (sym
->backend_decl
) == PARM_DECL
);
9502 if (sym
->ts
.type
== BT_CHARACTER
9503 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
9505 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
9506 gfc_trans_vla_type_sizes (sym
, &init
);
9509 /* Dummy, use associated and result variables don't need anything special. */
9510 if (sym
->attr
.dummy
|| sym
->attr
.use_assoc
|| sym
->attr
.result
)
9512 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
9513 gfc_restore_backend_locus (&loc
);
9517 descriptor
= sym
->backend_decl
;
9519 /* Although static, derived types with default initializers and
9520 allocatable components must not be nulled wholesale; instead they
9521 are treated component by component. */
9522 if (TREE_STATIC (descriptor
) && !sym_has_alloc_comp
&& !has_finalizer
)
9524 /* SAVEd variables are not freed on exit. */
9525 gfc_trans_static_array_pointer (sym
);
9527 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
9528 gfc_restore_backend_locus (&loc
);
9532 /* Get the descriptor type. */
9533 type
= TREE_TYPE (sym
->backend_decl
);
9535 if ((sym_has_alloc_comp
|| (has_finalizer
&& sym
->ts
.type
!= BT_CLASS
))
9536 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
9539 && !(TREE_STATIC (sym
->backend_decl
) && sym
->attr
.is_main_program
))
9541 if (sym
->value
== NULL
9542 || !gfc_has_default_initializer (sym
->ts
.u
.derived
))
9544 rank
= sym
->as
? sym
->as
->rank
: 0;
9545 tmp
= gfc_nullify_alloc_comp (sym
->ts
.u
.derived
,
9547 gfc_add_expr_to_block (&init
, tmp
);
9550 gfc_init_default_dt (sym
, &init
, false);
9553 else if (!GFC_DESCRIPTOR_TYPE_P (type
))
9555 /* If the backend_decl is not a descriptor, we must have a pointer
9557 descriptor
= build_fold_indirect_ref_loc (input_location
,
9559 type
= TREE_TYPE (descriptor
);
9562 /* NULLIFY the data pointer, for non-saved allocatables. */
9563 if (GFC_DESCRIPTOR_TYPE_P (type
) && !sym
->attr
.save
&& sym
->attr
.allocatable
)
9565 gfc_conv_descriptor_data_set (&init
, descriptor
, null_pointer_node
);
9566 if (flag_coarray
== GFC_FCOARRAY_LIB
&& sym
->attr
.codimension
)
9568 /* Declare the variable static so its array descriptor stays present
9569 after leaving the scope. It may still be accessed through another
9570 image. This may happen, for example, with the caf_mpi
9572 TREE_STATIC (descriptor
) = 1;
9573 tmp
= gfc_conv_descriptor_token (descriptor
);
9574 gfc_add_modify (&init
, tmp
, fold_convert (TREE_TYPE (tmp
),
9575 null_pointer_node
));
9579 gfc_restore_backend_locus (&loc
);
9580 gfc_init_block (&cleanup
);
9582 /* Allocatable arrays need to be freed when they go out of scope.
9583 The allocatable components of pointers must not be touched. */
9584 if (!sym
->attr
.allocatable
&& has_finalizer
&& sym
->ts
.type
!= BT_CLASS
9585 && !sym
->attr
.pointer
&& !sym
->attr
.artificial
&& !sym
->attr
.save
9586 && !sym
->ns
->proc_name
->attr
.is_main_program
)
9589 sym
->attr
.referenced
= 1;
9590 e
= gfc_lval_expr_from_sym (sym
);
9591 gfc_add_finalizer_call (&cleanup
, e
);
9594 else if ((!sym
->attr
.allocatable
|| !has_finalizer
)
9595 && sym_has_alloc_comp
&& !(sym
->attr
.function
|| sym
->attr
.result
)
9596 && !sym
->attr
.pointer
&& !sym
->attr
.save
9597 && !sym
->ns
->proc_name
->attr
.is_main_program
)
9600 rank
= sym
->as
? sym
->as
->rank
: 0;
9601 tmp
= gfc_deallocate_alloc_comp (sym
->ts
.u
.derived
, descriptor
, rank
);
9602 gfc_add_expr_to_block (&cleanup
, tmp
);
9605 if (sym
->attr
.allocatable
&& (sym
->attr
.dimension
|| sym
->attr
.codimension
)
9606 && !sym
->attr
.save
&& !sym
->attr
.result
9607 && !sym
->ns
->proc_name
->attr
.is_main_program
)
9610 e
= has_finalizer
? gfc_lval_expr_from_sym (sym
) : NULL
;
9611 tmp
= gfc_deallocate_with_status (sym
->backend_decl
, NULL_TREE
, NULL_TREE
,
9612 NULL_TREE
, NULL_TREE
, true, e
,
9613 sym
->attr
.codimension
9614 ? GFC_CAF_COARRAY_DEREGISTER
9615 : GFC_CAF_COARRAY_NOCOARRAY
);
9618 gfc_add_expr_to_block (&cleanup
, tmp
);
9621 gfc_add_init_cleanup (block
, gfc_finish_block (&init
),
9622 gfc_finish_block (&cleanup
));
9625 /************ Expression Walking Functions ******************/
9627 /* Walk a variable reference.
9629 Possible extension - multiple component subscripts.
9630 x(:,:) = foo%a(:)%b(:)
9632 forall (i=..., j=...)
9633 x(i,j) = foo%a(j)%b(i)
9635 This adds a fair amount of complexity because you need to deal with more
9636 than one ref. Maybe handle in a similar manner to vector subscripts.
9637 Maybe not worth the effort. */
9641 gfc_walk_variable_expr (gfc_ss
* ss
, gfc_expr
* expr
)
9645 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
9646 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
9649 return gfc_walk_array_ref (ss
, expr
, ref
);
9654 gfc_walk_array_ref (gfc_ss
* ss
, gfc_expr
* expr
, gfc_ref
* ref
)
9660 for (; ref
; ref
= ref
->next
)
9662 if (ref
->type
== REF_SUBSTRING
)
9664 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.start
);
9665 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.end
);
9668 /* We're only interested in array sections from now on. */
9669 if (ref
->type
!= REF_ARRAY
)
9677 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
9678 ss
= gfc_get_scalar_ss (ss
, ar
->start
[n
]);
9682 newss
= gfc_get_array_ss (ss
, expr
, ar
->as
->rank
, GFC_SS_SECTION
);
9683 newss
->info
->data
.array
.ref
= ref
;
9685 /* Make sure array is the same as array(:,:), this way
9686 we don't need to special case all the time. */
9687 ar
->dimen
= ar
->as
->rank
;
9688 for (n
= 0; n
< ar
->dimen
; n
++)
9690 ar
->dimen_type
[n
] = DIMEN_RANGE
;
9692 gcc_assert (ar
->start
[n
] == NULL
);
9693 gcc_assert (ar
->end
[n
] == NULL
);
9694 gcc_assert (ar
->stride
[n
] == NULL
);
9700 newss
= gfc_get_array_ss (ss
, expr
, 0, GFC_SS_SECTION
);
9701 newss
->info
->data
.array
.ref
= ref
;
9703 /* We add SS chains for all the subscripts in the section. */
9704 for (n
= 0; n
< ar
->dimen
; n
++)
9708 switch (ar
->dimen_type
[n
])
9711 /* Add SS for elemental (scalar) subscripts. */
9712 gcc_assert (ar
->start
[n
]);
9713 indexss
= gfc_get_scalar_ss (gfc_ss_terminator
, ar
->start
[n
]);
9714 indexss
->loop_chain
= gfc_ss_terminator
;
9715 newss
->info
->data
.array
.subscript
[n
] = indexss
;
9719 /* We don't add anything for sections, just remember this
9720 dimension for later. */
9721 newss
->dim
[newss
->dimen
] = n
;
9726 /* Create a GFC_SS_VECTOR index in which we can store
9727 the vector's descriptor. */
9728 indexss
= gfc_get_array_ss (gfc_ss_terminator
, ar
->start
[n
],
9730 indexss
->loop_chain
= gfc_ss_terminator
;
9731 newss
->info
->data
.array
.subscript
[n
] = indexss
;
9732 newss
->dim
[newss
->dimen
] = n
;
9737 /* We should know what sort of section it is by now. */
9741 /* We should have at least one non-elemental dimension,
9742 unless we are creating a descriptor for a (scalar) coarray. */
9743 gcc_assert (newss
->dimen
> 0
9744 || newss
->info
->data
.array
.ref
->u
.ar
.as
->corank
> 0);
9749 /* We should know what sort of section it is by now. */
9758 /* Walk an expression operator. If only one operand of a binary expression is
9759 scalar, we must also add the scalar term to the SS chain. */
9762 gfc_walk_op_expr (gfc_ss
* ss
, gfc_expr
* expr
)
9767 head
= gfc_walk_subexpr (ss
, expr
->value
.op
.op1
);
9768 if (expr
->value
.op
.op2
== NULL
)
9771 head2
= gfc_walk_subexpr (head
, expr
->value
.op
.op2
);
9773 /* All operands are scalar. Pass back and let the caller deal with it. */
9777 /* All operands require scalarization. */
9778 if (head
!= ss
&& (expr
->value
.op
.op2
== NULL
|| head2
!= head
))
9781 /* One of the operands needs scalarization, the other is scalar.
9782 Create a gfc_ss for the scalar expression. */
9785 /* First operand is scalar. We build the chain in reverse order, so
9786 add the scalar SS after the second operand. */
9788 while (head
&& head
->next
!= ss
)
9790 /* Check we haven't somehow broken the chain. */
9792 head
->next
= gfc_get_scalar_ss (ss
, expr
->value
.op
.op1
);
9794 else /* head2 == head */
9796 gcc_assert (head2
== head
);
9797 /* Second operand is scalar. */
9798 head2
= gfc_get_scalar_ss (head2
, expr
->value
.op
.op2
);
9805 /* Reverse a SS chain. */
9808 gfc_reverse_ss (gfc_ss
* ss
)
9813 gcc_assert (ss
!= NULL
);
9815 head
= gfc_ss_terminator
;
9816 while (ss
!= gfc_ss_terminator
)
9819 /* Check we didn't somehow break the chain. */
9820 gcc_assert (next
!= NULL
);
9830 /* Given an expression referring to a procedure, return the symbol of its
9831 interface. We can't get the procedure symbol directly as we have to handle
9832 the case of (deferred) type-bound procedures. */
9835 gfc_get_proc_ifc_for_expr (gfc_expr
*procedure_ref
)
9840 if (procedure_ref
== NULL
)
9843 /* Normal procedure case. */
9844 if (procedure_ref
->expr_type
== EXPR_FUNCTION
9845 && procedure_ref
->value
.function
.esym
)
9846 sym
= procedure_ref
->value
.function
.esym
;
9848 sym
= procedure_ref
->symtree
->n
.sym
;
9850 /* Typebound procedure case. */
9851 for (ref
= procedure_ref
->ref
; ref
; ref
= ref
->next
)
9853 if (ref
->type
== REF_COMPONENT
9854 && ref
->u
.c
.component
->attr
.proc_pointer
)
9855 sym
= ref
->u
.c
.component
->ts
.interface
;
9864 /* Walk the arguments of an elemental function.
9865 PROC_EXPR is used to check whether an argument is permitted to be absent. If
9866 it is NULL, we don't do the check and the argument is assumed to be present.
9870 gfc_walk_elemental_function_args (gfc_ss
* ss
, gfc_actual_arglist
*arg
,
9871 gfc_symbol
*proc_ifc
, gfc_ss_type type
)
9873 gfc_formal_arglist
*dummy_arg
;
9879 head
= gfc_ss_terminator
;
9883 dummy_arg
= gfc_sym_get_dummy_args (proc_ifc
);
9888 for (; arg
; arg
= arg
->next
)
9890 if (!arg
->expr
|| arg
->expr
->expr_type
== EXPR_NULL
)
9893 newss
= gfc_walk_subexpr (head
, arg
->expr
);
9896 /* Scalar argument. */
9897 gcc_assert (type
== GFC_SS_SCALAR
|| type
== GFC_SS_REFERENCE
);
9898 newss
= gfc_get_scalar_ss (head
, arg
->expr
);
9899 newss
->info
->type
= type
;
9901 newss
->info
->data
.scalar
.dummy_arg
= dummy_arg
->sym
;
9906 if (dummy_arg
!= NULL
9907 && dummy_arg
->sym
->attr
.optional
9908 && arg
->expr
->expr_type
== EXPR_VARIABLE
9909 && (gfc_expr_attr (arg
->expr
).optional
9910 || gfc_expr_attr (arg
->expr
).allocatable
9911 || gfc_expr_attr (arg
->expr
).pointer
))
9912 newss
->info
->can_be_null_ref
= true;
9918 while (tail
->next
!= gfc_ss_terminator
)
9923 if (dummy_arg
!= NULL
)
9924 dummy_arg
= dummy_arg
->next
;
9929 /* If all the arguments are scalar we don't need the argument SS. */
9930 gfc_free_ss_chain (head
);
9935 /* Add it onto the existing chain. */
9941 /* Walk a function call. Scalar functions are passed back, and taken out of
9942 scalarization loops. For elemental functions we walk their arguments.
9943 The result of functions returning arrays is stored in a temporary outside
9944 the loop, so that the function is only called once. Hence we do not need
9945 to walk their arguments. */
9948 gfc_walk_function_expr (gfc_ss
* ss
, gfc_expr
* expr
)
9950 gfc_intrinsic_sym
*isym
;
9952 gfc_component
*comp
= NULL
;
9954 isym
= expr
->value
.function
.isym
;
9956 /* Handle intrinsic functions separately. */
9958 return gfc_walk_intrinsic_function (ss
, expr
, isym
);
9960 sym
= expr
->value
.function
.esym
;
9962 sym
= expr
->symtree
->n
.sym
;
9964 if (gfc_is_alloc_class_array_function (expr
))
9965 return gfc_get_array_ss (ss
, expr
,
9966 CLASS_DATA (expr
->value
.function
.esym
->result
)->as
->rank
,
9969 /* A function that returns arrays. */
9970 comp
= gfc_get_proc_ptr_comp (expr
);
9971 if ((!comp
&& gfc_return_by_reference (sym
) && sym
->result
->attr
.dimension
)
9972 || (comp
&& comp
->attr
.dimension
))
9973 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
9975 /* Walk the parameters of an elemental function. For now we always pass
9977 if (sym
->attr
.elemental
|| (comp
&& comp
->attr
.elemental
))
9979 gfc_ss
*old_ss
= ss
;
9981 ss
= gfc_walk_elemental_function_args (old_ss
,
9982 expr
->value
.function
.actual
,
9983 gfc_get_proc_ifc_for_expr (expr
),
9987 || sym
->attr
.proc_pointer
9988 || sym
->attr
.if_source
!= IFSRC_DECL
9989 || sym
->attr
.array_outer_dependency
))
9990 ss
->info
->array_outer_dependency
= 1;
9993 /* Scalar functions are OK as these are evaluated outside the scalarization
9994 loop. Pass back and let the caller deal with it. */
9999 /* An array temporary is constructed for array constructors. */
10002 gfc_walk_array_constructor (gfc_ss
* ss
, gfc_expr
* expr
)
10004 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_CONSTRUCTOR
);
10008 /* Walk an expression. Add walked expressions to the head of the SS chain.
10009 A wholly scalar expression will not be added. */
10012 gfc_walk_subexpr (gfc_ss
* ss
, gfc_expr
* expr
)
10016 switch (expr
->expr_type
)
10018 case EXPR_VARIABLE
:
10019 head
= gfc_walk_variable_expr (ss
, expr
);
10023 head
= gfc_walk_op_expr (ss
, expr
);
10026 case EXPR_FUNCTION
:
10027 head
= gfc_walk_function_expr (ss
, expr
);
10030 case EXPR_CONSTANT
:
10032 case EXPR_STRUCTURE
:
10033 /* Pass back and let the caller deal with it. */
10037 head
= gfc_walk_array_constructor (ss
, expr
);
10040 case EXPR_SUBSTRING
:
10041 /* Pass back and let the caller deal with it. */
10045 gfc_internal_error ("bad expression type during walk (%d)",
10052 /* Entry point for expression walking.
10053 A return value equal to the passed chain means this is
10054 a scalar expression. It is up to the caller to take whatever action is
10055 necessary to translate these. */
10058 gfc_walk_expr (gfc_expr
* expr
)
10062 res
= gfc_walk_subexpr (gfc_ss_terminator
, expr
);
10063 return gfc_reverse_ss (res
);