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_type (char_len
, gfc_charlen_type_node
);
1913 mpz_clear (char_len
);
1921 *len
= ts
->u
.cl
->backend_decl
;
1925 /* Figure out the string length of a character array constructor.
1926 If len is NULL, don't calculate the length; this happens for recursive calls
1927 when a sub-array-constructor is an element but not at the first position,
1928 so when we're not interested in the length.
1929 Returns TRUE if all elements are character constants. */
1932 get_array_ctor_strlen (stmtblock_t
*block
, gfc_constructor_base base
, tree
* len
)
1939 if (gfc_constructor_first (base
) == NULL
)
1942 *len
= build_int_cstu (gfc_charlen_type_node
, 0);
1946 /* Loop over all constructor elements to find out is_const, but in len we
1947 want to store the length of the first, not the last, element. We can
1948 of course exit the loop as soon as is_const is found to be false. */
1949 for (c
= gfc_constructor_first (base
);
1950 c
&& is_const
; c
= gfc_constructor_next (c
))
1952 switch (c
->expr
->expr_type
)
1955 if (len
&& !(*len
&& INTEGER_CST_P (*len
)))
1956 *len
= build_int_cstu (gfc_charlen_type_node
,
1957 c
->expr
->value
.character
.length
);
1961 if (!get_array_ctor_strlen (block
, c
->expr
->value
.constructor
, len
))
1968 get_array_ctor_var_strlen (block
, c
->expr
, len
);
1974 get_array_ctor_all_strlen (block
, c
->expr
, len
);
1978 /* After the first iteration, we don't want the length modified. */
1985 /* Check whether the array constructor C consists entirely of constant
1986 elements, and if so returns the number of those elements, otherwise
1987 return zero. Note, an empty or NULL array constructor returns zero. */
1989 unsigned HOST_WIDE_INT
1990 gfc_constant_array_constructor_p (gfc_constructor_base base
)
1992 unsigned HOST_WIDE_INT nelem
= 0;
1994 gfc_constructor
*c
= gfc_constructor_first (base
);
1998 || c
->expr
->rank
> 0
1999 || c
->expr
->expr_type
!= EXPR_CONSTANT
)
2001 c
= gfc_constructor_next (c
);
2008 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
2009 and the tree type of it's elements, TYPE, return a static constant
2010 variable that is compile-time initialized. */
2013 gfc_build_constant_array_constructor (gfc_expr
* expr
, tree type
)
2015 tree tmptype
, init
, tmp
;
2016 HOST_WIDE_INT nelem
;
2021 vec
<constructor_elt
, va_gc
> *v
= NULL
;
2023 /* First traverse the constructor list, converting the constants
2024 to tree to build an initializer. */
2026 c
= gfc_constructor_first (expr
->value
.constructor
);
2029 gfc_init_se (&se
, NULL
);
2030 gfc_conv_constant (&se
, c
->expr
);
2031 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
2032 se
.expr
= fold_convert (type
, se
.expr
);
2033 else if (POINTER_TYPE_P (type
))
2034 se
.expr
= gfc_build_addr_expr (gfc_get_pchar_type (c
->expr
->ts
.kind
),
2036 CONSTRUCTOR_APPEND_ELT (v
, build_int_cst (gfc_array_index_type
, nelem
),
2038 c
= gfc_constructor_next (c
);
2042 /* Next determine the tree type for the array. We use the gfortran
2043 front-end's gfc_get_nodesc_array_type in order to create a suitable
2044 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
2046 memset (&as
, 0, sizeof (gfc_array_spec
));
2048 as
.rank
= expr
->rank
;
2049 as
.type
= AS_EXPLICIT
;
2052 as
.lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2053 as
.upper
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
2057 for (i
= 0; i
< expr
->rank
; i
++)
2059 int tmp
= (int) mpz_get_si (expr
->shape
[i
]);
2060 as
.lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2061 as
.upper
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
2065 tmptype
= gfc_get_nodesc_array_type (type
, &as
, PACKED_STATIC
, true);
2067 /* as is not needed anymore. */
2068 for (i
= 0; i
< as
.rank
+ as
.corank
; i
++)
2070 gfc_free_expr (as
.lower
[i
]);
2071 gfc_free_expr (as
.upper
[i
]);
2074 init
= build_constructor (tmptype
, v
);
2076 TREE_CONSTANT (init
) = 1;
2077 TREE_STATIC (init
) = 1;
2079 tmp
= build_decl (input_location
, VAR_DECL
, create_tmp_var_name ("A"),
2081 DECL_ARTIFICIAL (tmp
) = 1;
2082 DECL_IGNORED_P (tmp
) = 1;
2083 TREE_STATIC (tmp
) = 1;
2084 TREE_CONSTANT (tmp
) = 1;
2085 TREE_READONLY (tmp
) = 1;
2086 DECL_INITIAL (tmp
) = init
;
2093 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
2094 This mostly initializes the scalarizer state info structure with the
2095 appropriate values to directly use the array created by the function
2096 gfc_build_constant_array_constructor. */
2099 trans_constant_array_constructor (gfc_ss
* ss
, tree type
)
2101 gfc_array_info
*info
;
2105 tmp
= gfc_build_constant_array_constructor (ss
->info
->expr
, type
);
2107 info
= &ss
->info
->data
.array
;
2109 info
->descriptor
= tmp
;
2110 info
->data
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2111 info
->offset
= gfc_index_zero_node
;
2113 for (i
= 0; i
< ss
->dimen
; i
++)
2115 info
->delta
[i
] = gfc_index_zero_node
;
2116 info
->start
[i
] = gfc_index_zero_node
;
2117 info
->end
[i
] = gfc_index_zero_node
;
2118 info
->stride
[i
] = gfc_index_one_node
;
2124 get_rank (gfc_loopinfo
*loop
)
2129 for (; loop
; loop
= loop
->parent
)
2130 rank
+= loop
->dimen
;
2136 /* Helper routine of gfc_trans_array_constructor to determine if the
2137 bounds of the loop specified by LOOP are constant and simple enough
2138 to use with trans_constant_array_constructor. Returns the
2139 iteration count of the loop if suitable, and NULL_TREE otherwise. */
2142 constant_array_constructor_loop_size (gfc_loopinfo
* l
)
2145 tree size
= gfc_index_one_node
;
2149 total_dim
= get_rank (l
);
2151 for (loop
= l
; loop
; loop
= loop
->parent
)
2153 for (i
= 0; i
< loop
->dimen
; i
++)
2155 /* If the bounds aren't constant, return NULL_TREE. */
2156 if (!INTEGER_CST_P (loop
->from
[i
]) || !INTEGER_CST_P (loop
->to
[i
]))
2158 if (!integer_zerop (loop
->from
[i
]))
2160 /* Only allow nonzero "from" in one-dimensional arrays. */
2163 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2164 gfc_array_index_type
,
2165 loop
->to
[i
], loop
->from
[i
]);
2169 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2170 gfc_array_index_type
, tmp
, gfc_index_one_node
);
2171 size
= fold_build2_loc (input_location
, MULT_EXPR
,
2172 gfc_array_index_type
, size
, tmp
);
2181 get_loop_upper_bound_for_array (gfc_ss
*array
, int array_dim
)
2186 gcc_assert (array
->nested_ss
== NULL
);
2188 for (ss
= array
; ss
; ss
= ss
->parent
)
2189 for (n
= 0; n
< ss
->loop
->dimen
; n
++)
2190 if (array_dim
== get_array_ref_dim_for_loop_dim (ss
, n
))
2191 return &(ss
->loop
->to
[n
]);
2197 static gfc_loopinfo
*
2198 outermost_loop (gfc_loopinfo
* loop
)
2200 while (loop
->parent
!= NULL
)
2201 loop
= loop
->parent
;
2207 /* Array constructors are handled by constructing a temporary, then using that
2208 within the scalarization loop. This is not optimal, but seems by far the
2212 trans_array_constructor (gfc_ss
* ss
, locus
* where
)
2214 gfc_constructor_base c
;
2222 bool old_first_len
, old_typespec_chararray_ctor
;
2223 tree old_first_len_val
;
2224 gfc_loopinfo
*loop
, *outer_loop
;
2225 gfc_ss_info
*ss_info
;
2231 /* Save the old values for nested checking. */
2232 old_first_len
= first_len
;
2233 old_first_len_val
= first_len_val
;
2234 old_typespec_chararray_ctor
= typespec_chararray_ctor
;
2237 outer_loop
= outermost_loop (loop
);
2239 expr
= ss_info
->expr
;
2241 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
2242 typespec was given for the array constructor. */
2243 typespec_chararray_ctor
= (expr
->ts
.type
== BT_CHARACTER
2245 && expr
->ts
.u
.cl
->length_from_typespec
);
2247 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2248 && expr
->ts
.type
== BT_CHARACTER
&& !typespec_chararray_ctor
)
2250 first_len_val
= gfc_create_var (gfc_charlen_type_node
, "len");
2254 gcc_assert (ss
->dimen
== ss
->loop
->dimen
);
2256 c
= expr
->value
.constructor
;
2257 if (expr
->ts
.type
== BT_CHARACTER
)
2260 bool force_new_cl
= false;
2262 /* get_array_ctor_strlen walks the elements of the constructor, if a
2263 typespec was given, we already know the string length and want the one
2265 if (typespec_chararray_ctor
&& expr
->ts
.u
.cl
->length
2266 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
2270 const_string
= false;
2271 gfc_init_se (&length_se
, NULL
);
2272 gfc_conv_expr_type (&length_se
, expr
->ts
.u
.cl
->length
,
2273 gfc_charlen_type_node
);
2274 ss_info
->string_length
= length_se
.expr
;
2276 /* Check if the character length is negative. If it is, then
2278 neg_len
= fold_build2_loc (input_location
, LT_EXPR
,
2279 boolean_type_node
, ss_info
->string_length
,
2280 build_int_cst (gfc_charlen_type_node
, 0));
2281 /* Print a warning if bounds checking is enabled. */
2282 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2284 msg
= xasprintf ("Negative character length treated as LEN = 0");
2285 gfc_trans_runtime_check (false, true, neg_len
, &length_se
.pre
,
2290 ss_info
->string_length
2291 = fold_build3_loc (input_location
, COND_EXPR
,
2292 gfc_charlen_type_node
, neg_len
,
2293 build_int_cst (gfc_charlen_type_node
, 0),
2294 ss_info
->string_length
);
2295 ss_info
->string_length
= gfc_evaluate_now (ss_info
->string_length
,
2298 gfc_add_block_to_block (&outer_loop
->pre
, &length_se
.pre
);
2299 gfc_add_block_to_block (&outer_loop
->post
, &length_se
.post
);
2303 const_string
= get_array_ctor_strlen (&outer_loop
->pre
, c
,
2304 &ss_info
->string_length
);
2305 force_new_cl
= true;
2308 /* Complex character array constructors should have been taken care of
2309 and not end up here. */
2310 gcc_assert (ss_info
->string_length
);
2312 store_backend_decl (&expr
->ts
.u
.cl
, ss_info
->string_length
, force_new_cl
);
2314 type
= gfc_get_character_type_len (expr
->ts
.kind
, ss_info
->string_length
);
2316 type
= build_pointer_type (type
);
2319 type
= gfc_typenode_for_spec (expr
->ts
.type
== BT_CLASS
2320 ? &CLASS_DATA (expr
)->ts
: &expr
->ts
);
2322 /* See if the constructor determines the loop bounds. */
2325 loop_ubound0
= get_loop_upper_bound_for_array (ss
, 0);
2327 if (expr
->shape
&& get_rank (loop
) > 1 && *loop_ubound0
== NULL_TREE
)
2329 /* We have a multidimensional parameter. */
2330 for (s
= ss
; s
; s
= s
->parent
)
2333 for (n
= 0; n
< s
->loop
->dimen
; n
++)
2335 s
->loop
->from
[n
] = gfc_index_zero_node
;
2336 s
->loop
->to
[n
] = gfc_conv_mpz_to_tree (expr
->shape
[s
->dim
[n
]],
2337 gfc_index_integer_kind
);
2338 s
->loop
->to
[n
] = fold_build2_loc (input_location
, MINUS_EXPR
,
2339 gfc_array_index_type
,
2341 gfc_index_one_node
);
2346 if (*loop_ubound0
== NULL_TREE
)
2350 /* We should have a 1-dimensional, zero-based loop. */
2351 gcc_assert (loop
->parent
== NULL
&& loop
->nested
== NULL
);
2352 gcc_assert (loop
->dimen
== 1);
2353 gcc_assert (integer_zerop (loop
->from
[0]));
2355 /* Split the constructor size into a static part and a dynamic part.
2356 Allocate the static size up-front and record whether the dynamic
2357 size might be nonzero. */
2359 dynamic
= gfc_get_array_constructor_size (&size
, c
);
2360 mpz_sub_ui (size
, size
, 1);
2361 loop
->to
[0] = gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
2365 /* Special case constant array constructors. */
2368 unsigned HOST_WIDE_INT nelem
= gfc_constant_array_constructor_p (c
);
2371 tree size
= constant_array_constructor_loop_size (loop
);
2372 if (size
&& compare_tree_int (size
, nelem
) == 0)
2374 trans_constant_array_constructor (ss
, type
);
2380 gfc_trans_create_temp_array (&outer_loop
->pre
, &outer_loop
->post
, ss
, type
,
2381 NULL_TREE
, dynamic
, true, false, where
);
2383 desc
= ss_info
->data
.array
.descriptor
;
2384 offset
= gfc_index_zero_node
;
2385 offsetvar
= gfc_create_var_np (gfc_array_index_type
, "offset");
2386 TREE_NO_WARNING (offsetvar
) = 1;
2387 TREE_USED (offsetvar
) = 0;
2388 gfc_trans_array_constructor_value (&outer_loop
->pre
, type
, desc
, c
,
2389 &offset
, &offsetvar
, dynamic
);
2391 /* If the array grows dynamically, the upper bound of the loop variable
2392 is determined by the array's final upper bound. */
2395 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2396 gfc_array_index_type
,
2397 offsetvar
, gfc_index_one_node
);
2398 tmp
= gfc_evaluate_now (tmp
, &outer_loop
->pre
);
2399 gfc_conv_descriptor_ubound_set (&loop
->pre
, desc
, gfc_rank_cst
[0], tmp
);
2400 if (*loop_ubound0
&& VAR_P (*loop_ubound0
))
2401 gfc_add_modify (&outer_loop
->pre
, *loop_ubound0
, tmp
);
2403 *loop_ubound0
= tmp
;
2406 if (TREE_USED (offsetvar
))
2407 pushdecl (offsetvar
);
2409 gcc_assert (INTEGER_CST_P (offset
));
2412 /* Disable bound checking for now because it's probably broken. */
2413 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2420 /* Restore old values of globals. */
2421 first_len
= old_first_len
;
2422 first_len_val
= old_first_len_val
;
2423 typespec_chararray_ctor
= old_typespec_chararray_ctor
;
2427 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
2428 called after evaluating all of INFO's vector dimensions. Go through
2429 each such vector dimension and see if we can now fill in any missing
2433 set_vector_loop_bounds (gfc_ss
* ss
)
2435 gfc_loopinfo
*loop
, *outer_loop
;
2436 gfc_array_info
*info
;
2444 outer_loop
= outermost_loop (ss
->loop
);
2446 info
= &ss
->info
->data
.array
;
2448 for (; ss
; ss
= ss
->parent
)
2452 for (n
= 0; n
< loop
->dimen
; n
++)
2455 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_VECTOR
2456 || loop
->to
[n
] != NULL
)
2459 /* Loop variable N indexes vector dimension DIM, and we don't
2460 yet know the upper bound of loop variable N. Set it to the
2461 difference between the vector's upper and lower bounds. */
2462 gcc_assert (loop
->from
[n
] == gfc_index_zero_node
);
2463 gcc_assert (info
->subscript
[dim
]
2464 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
2466 gfc_init_se (&se
, NULL
);
2467 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
2468 zero
= gfc_rank_cst
[0];
2469 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2470 gfc_array_index_type
,
2471 gfc_conv_descriptor_ubound_get (desc
, zero
),
2472 gfc_conv_descriptor_lbound_get (desc
, zero
));
2473 tmp
= gfc_evaluate_now (tmp
, &outer_loop
->pre
);
2480 /* Tells whether a scalar argument to an elemental procedure is saved out
2481 of a scalarization loop as a value or as a reference. */
2484 gfc_scalar_elemental_arg_saved_as_reference (gfc_ss_info
* ss_info
)
2486 if (ss_info
->type
!= GFC_SS_REFERENCE
)
2489 /* If the actual argument can be absent (in other words, it can
2490 be a NULL reference), don't try to evaluate it; pass instead
2491 the reference directly. */
2492 if (ss_info
->can_be_null_ref
)
2495 /* If the expression is of polymorphic type, it's actual size is not known,
2496 so we avoid copying it anywhere. */
2497 if (ss_info
->data
.scalar
.dummy_arg
2498 && ss_info
->data
.scalar
.dummy_arg
->ts
.type
== BT_CLASS
2499 && ss_info
->expr
->ts
.type
== BT_CLASS
)
2502 /* If the expression is a data reference of aggregate type,
2503 and the data reference is not used on the left hand side,
2504 avoid a copy by saving a reference to the content. */
2505 if (!ss_info
->data
.scalar
.needs_temporary
2506 && (ss_info
->expr
->ts
.type
== BT_DERIVED
2507 || ss_info
->expr
->ts
.type
== BT_CLASS
)
2508 && gfc_expr_is_variable (ss_info
->expr
))
2511 /* Otherwise the expression is evaluated to a temporary variable before the
2512 scalarization loop. */
2517 /* Add the pre and post chains for all the scalar expressions in a SS chain
2518 to loop. This is called after the loop parameters have been calculated,
2519 but before the actual scalarizing loops. */
2522 gfc_add_loop_ss_code (gfc_loopinfo
* loop
, gfc_ss
* ss
, bool subscript
,
2525 gfc_loopinfo
*nested_loop
, *outer_loop
;
2527 gfc_ss_info
*ss_info
;
2528 gfc_array_info
*info
;
2532 /* Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise,
2533 arguments could get evaluated multiple times. */
2534 if (ss
->is_alloc_lhs
)
2537 outer_loop
= outermost_loop (loop
);
2539 /* TODO: This can generate bad code if there are ordering dependencies,
2540 e.g., a callee allocated function and an unknown size constructor. */
2541 gcc_assert (ss
!= NULL
);
2543 for (; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2547 /* Cross loop arrays are handled from within the most nested loop. */
2548 if (ss
->nested_ss
!= NULL
)
2552 expr
= ss_info
->expr
;
2553 info
= &ss_info
->data
.array
;
2555 switch (ss_info
->type
)
2558 /* Scalar expression. Evaluate this now. This includes elemental
2559 dimension indices, but not array section bounds. */
2560 gfc_init_se (&se
, NULL
);
2561 gfc_conv_expr (&se
, expr
);
2562 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2564 if (expr
->ts
.type
!= BT_CHARACTER
2565 && !gfc_is_alloc_class_scalar_function (expr
))
2567 /* Move the evaluation of scalar expressions outside the
2568 scalarization loop, except for WHERE assignments. */
2570 se
.expr
= convert(gfc_array_index_type
, se
.expr
);
2571 if (!ss_info
->where
)
2572 se
.expr
= gfc_evaluate_now (se
.expr
, &outer_loop
->pre
);
2573 gfc_add_block_to_block (&outer_loop
->pre
, &se
.post
);
2576 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2578 ss_info
->data
.scalar
.value
= se
.expr
;
2579 ss_info
->string_length
= se
.string_length
;
2582 case GFC_SS_REFERENCE
:
2583 /* Scalar argument to elemental procedure. */
2584 gfc_init_se (&se
, NULL
);
2585 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info
))
2586 gfc_conv_expr_reference (&se
, expr
);
2589 /* Evaluate the argument outside the loop and pass
2590 a reference to the value. */
2591 gfc_conv_expr (&se
, expr
);
2594 /* Ensure that a pointer to the string is stored. */
2595 if (expr
->ts
.type
== BT_CHARACTER
)
2596 gfc_conv_string_parameter (&se
);
2598 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2599 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2600 if (gfc_is_class_scalar_expr (expr
))
2601 /* This is necessary because the dynamic type will always be
2602 large than the declared type. In consequence, assigning
2603 the value to a temporary could segfault.
2604 OOP-TODO: see if this is generally correct or is the value
2605 has to be written to an allocated temporary, whose address
2606 is passed via ss_info. */
2607 ss_info
->data
.scalar
.value
= se
.expr
;
2609 ss_info
->data
.scalar
.value
= gfc_evaluate_now (se
.expr
,
2612 ss_info
->string_length
= se
.string_length
;
2615 case GFC_SS_SECTION
:
2616 /* Add the expressions for scalar and vector subscripts. */
2617 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2618 if (info
->subscript
[n
])
2619 gfc_add_loop_ss_code (loop
, info
->subscript
[n
], true, where
);
2621 set_vector_loop_bounds (ss
);
2625 /* Get the vector's descriptor and store it in SS. */
2626 gfc_init_se (&se
, NULL
);
2627 gfc_conv_expr_descriptor (&se
, expr
);
2628 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2629 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2630 info
->descriptor
= se
.expr
;
2633 case GFC_SS_INTRINSIC
:
2634 gfc_add_intrinsic_ss_code (loop
, ss
);
2637 case GFC_SS_FUNCTION
:
2638 /* Array function return value. We call the function and save its
2639 result in a temporary for use inside the loop. */
2640 gfc_init_se (&se
, NULL
);
2643 gfc_conv_expr (&se
, expr
);
2644 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2645 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2646 ss_info
->string_length
= se
.string_length
;
2649 case GFC_SS_CONSTRUCTOR
:
2650 if (expr
->ts
.type
== BT_CHARACTER
2651 && ss_info
->string_length
== NULL
2653 && expr
->ts
.u
.cl
->length
2654 && expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2656 gfc_init_se (&se
, NULL
);
2657 gfc_conv_expr_type (&se
, expr
->ts
.u
.cl
->length
,
2658 gfc_charlen_type_node
);
2659 ss_info
->string_length
= se
.expr
;
2660 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2661 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2663 trans_array_constructor (ss
, where
);
2667 case GFC_SS_COMPONENT
:
2668 /* Do nothing. These are handled elsewhere. */
2677 for (nested_loop
= loop
->nested
; nested_loop
;
2678 nested_loop
= nested_loop
->next
)
2679 gfc_add_loop_ss_code (nested_loop
, nested_loop
->ss
, subscript
, where
);
2683 /* Translate expressions for the descriptor and data pointer of a SS. */
2687 gfc_conv_ss_descriptor (stmtblock_t
* block
, gfc_ss
* ss
, int base
)
2690 gfc_ss_info
*ss_info
;
2691 gfc_array_info
*info
;
2695 info
= &ss_info
->data
.array
;
2697 /* Get the descriptor for the array to be scalarized. */
2698 gcc_assert (ss_info
->expr
->expr_type
== EXPR_VARIABLE
);
2699 gfc_init_se (&se
, NULL
);
2700 se
.descriptor_only
= 1;
2701 gfc_conv_expr_lhs (&se
, ss_info
->expr
);
2702 gfc_add_block_to_block (block
, &se
.pre
);
2703 info
->descriptor
= se
.expr
;
2704 ss_info
->string_length
= se
.string_length
;
2708 if (ss_info
->expr
->ts
.type
== BT_CHARACTER
&& !ss_info
->expr
->ts
.deferred
2709 && ss_info
->expr
->ts
.u
.cl
->length
== NULL
)
2711 /* Emit a DECL_EXPR for the variable sized array type in
2712 GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
2713 sizes works correctly. */
2714 tree arraytype
= TREE_TYPE (
2715 GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (info
->descriptor
)));
2716 if (! TYPE_NAME (arraytype
))
2717 TYPE_NAME (arraytype
) = build_decl (UNKNOWN_LOCATION
, TYPE_DECL
,
2718 NULL_TREE
, arraytype
);
2719 gfc_add_expr_to_block (block
, build1 (DECL_EXPR
, arraytype
,
2720 TYPE_NAME (arraytype
)));
2722 /* Also the data pointer. */
2723 tmp
= gfc_conv_array_data (se
.expr
);
2724 /* If this is a variable or address of a variable we use it directly.
2725 Otherwise we must evaluate it now to avoid breaking dependency
2726 analysis by pulling the expressions for elemental array indices
2729 || (TREE_CODE (tmp
) == ADDR_EXPR
2730 && DECL_P (TREE_OPERAND (tmp
, 0)))))
2731 tmp
= gfc_evaluate_now (tmp
, block
);
2734 tmp
= gfc_conv_array_offset (se
.expr
);
2735 info
->offset
= gfc_evaluate_now (tmp
, block
);
2737 /* Make absolutely sure that the saved_offset is indeed saved
2738 so that the variable is still accessible after the loops
2740 info
->saved_offset
= info
->offset
;
2745 /* Initialize a gfc_loopinfo structure. */
2748 gfc_init_loopinfo (gfc_loopinfo
* loop
)
2752 memset (loop
, 0, sizeof (gfc_loopinfo
));
2753 gfc_init_block (&loop
->pre
);
2754 gfc_init_block (&loop
->post
);
2756 /* Initially scalarize in order and default to no loop reversal. */
2757 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2760 loop
->reverse
[n
] = GFC_INHIBIT_REVERSE
;
2763 loop
->ss
= gfc_ss_terminator
;
2767 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2771 gfc_copy_loopinfo_to_se (gfc_se
* se
, gfc_loopinfo
* loop
)
2777 /* Return an expression for the data pointer of an array. */
2780 gfc_conv_array_data (tree descriptor
)
2784 type
= TREE_TYPE (descriptor
);
2785 if (GFC_ARRAY_TYPE_P (type
))
2787 if (TREE_CODE (type
) == POINTER_TYPE
)
2791 /* Descriptorless arrays. */
2792 return gfc_build_addr_expr (NULL_TREE
, descriptor
);
2796 return gfc_conv_descriptor_data_get (descriptor
);
2800 /* Return an expression for the base offset of an array. */
2803 gfc_conv_array_offset (tree descriptor
)
2807 type
= TREE_TYPE (descriptor
);
2808 if (GFC_ARRAY_TYPE_P (type
))
2809 return GFC_TYPE_ARRAY_OFFSET (type
);
2811 return gfc_conv_descriptor_offset_get (descriptor
);
2815 /* Get an expression for the array stride. */
2818 gfc_conv_array_stride (tree descriptor
, int dim
)
2823 type
= TREE_TYPE (descriptor
);
2825 /* For descriptorless arrays use the array size. */
2826 tmp
= GFC_TYPE_ARRAY_STRIDE (type
, dim
);
2827 if (tmp
!= NULL_TREE
)
2830 tmp
= gfc_conv_descriptor_stride_get (descriptor
, gfc_rank_cst
[dim
]);
2835 /* Like gfc_conv_array_stride, but for the lower bound. */
2838 gfc_conv_array_lbound (tree descriptor
, int dim
)
2843 type
= TREE_TYPE (descriptor
);
2845 tmp
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
2846 if (tmp
!= NULL_TREE
)
2849 tmp
= gfc_conv_descriptor_lbound_get (descriptor
, gfc_rank_cst
[dim
]);
2854 /* Like gfc_conv_array_stride, but for the upper bound. */
2857 gfc_conv_array_ubound (tree descriptor
, int dim
)
2862 type
= TREE_TYPE (descriptor
);
2864 tmp
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
2865 if (tmp
!= NULL_TREE
)
2868 /* This should only ever happen when passing an assumed shape array
2869 as an actual parameter. The value will never be used. */
2870 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor
)))
2871 return gfc_index_zero_node
;
2873 tmp
= gfc_conv_descriptor_ubound_get (descriptor
, gfc_rank_cst
[dim
]);
2878 /* Generate code to perform an array index bound check. */
2881 trans_array_bound_check (gfc_se
* se
, gfc_ss
*ss
, tree index
, int n
,
2882 locus
* where
, bool check_upper
)
2885 tree tmp_lo
, tmp_up
;
2888 const char * name
= NULL
;
2890 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
2893 descriptor
= ss
->info
->data
.array
.descriptor
;
2895 index
= gfc_evaluate_now (index
, &se
->pre
);
2897 /* We find a name for the error message. */
2898 name
= ss
->info
->expr
->symtree
->n
.sym
->name
;
2899 gcc_assert (name
!= NULL
);
2901 if (VAR_P (descriptor
))
2902 name
= IDENTIFIER_POINTER (DECL_NAME (descriptor
));
2904 /* If upper bound is present, include both bounds in the error message. */
2907 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
2908 tmp_up
= gfc_conv_array_ubound (descriptor
, n
);
2911 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
2912 "outside of expected range (%%ld:%%ld)", n
+1, name
);
2914 msg
= xasprintf ("Index '%%ld' of dimension %d "
2915 "outside of expected range (%%ld:%%ld)", n
+1);
2917 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2919 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2920 fold_convert (long_integer_type_node
, index
),
2921 fold_convert (long_integer_type_node
, tmp_lo
),
2922 fold_convert (long_integer_type_node
, tmp_up
));
2923 fault
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2925 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2926 fold_convert (long_integer_type_node
, index
),
2927 fold_convert (long_integer_type_node
, tmp_lo
),
2928 fold_convert (long_integer_type_node
, tmp_up
));
2933 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
2936 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
2937 "below lower bound of %%ld", n
+1, name
);
2939 msg
= xasprintf ("Index '%%ld' of dimension %d "
2940 "below lower bound of %%ld", n
+1);
2942 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2944 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2945 fold_convert (long_integer_type_node
, index
),
2946 fold_convert (long_integer_type_node
, tmp_lo
));
2954 /* Return the offset for an index. Performs bound checking for elemental
2955 dimensions. Single element references are processed separately.
2956 DIM is the array dimension, I is the loop dimension. */
2959 conv_array_index_offset (gfc_se
* se
, gfc_ss
* ss
, int dim
, int i
,
2960 gfc_array_ref
* ar
, tree stride
)
2962 gfc_array_info
*info
;
2967 info
= &ss
->info
->data
.array
;
2969 /* Get the index into the array for this dimension. */
2972 gcc_assert (ar
->type
!= AR_ELEMENT
);
2973 switch (ar
->dimen_type
[dim
])
2975 case DIMEN_THIS_IMAGE
:
2979 /* Elemental dimension. */
2980 gcc_assert (info
->subscript
[dim
]
2981 && info
->subscript
[dim
]->info
->type
== GFC_SS_SCALAR
);
2982 /* We've already translated this value outside the loop. */
2983 index
= info
->subscript
[dim
]->info
->data
.scalar
.value
;
2985 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
2986 ar
->as
->type
!= AS_ASSUMED_SIZE
2987 || dim
< ar
->dimen
- 1);
2991 gcc_assert (info
&& se
->loop
);
2992 gcc_assert (info
->subscript
[dim
]
2993 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
2994 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
2996 /* Get a zero-based index into the vector. */
2997 index
= fold_build2_loc (input_location
, MINUS_EXPR
,
2998 gfc_array_index_type
,
2999 se
->loop
->loopvar
[i
], se
->loop
->from
[i
]);
3001 /* Multiply the index by the stride. */
3002 index
= fold_build2_loc (input_location
, MULT_EXPR
,
3003 gfc_array_index_type
,
3004 index
, gfc_conv_array_stride (desc
, 0));
3006 /* Read the vector to get an index into info->descriptor. */
3007 data
= build_fold_indirect_ref_loc (input_location
,
3008 gfc_conv_array_data (desc
));
3009 index
= gfc_build_array_ref (data
, index
, NULL
);
3010 index
= gfc_evaluate_now (index
, &se
->pre
);
3011 index
= fold_convert (gfc_array_index_type
, index
);
3013 /* Do any bounds checking on the final info->descriptor index. */
3014 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
3015 ar
->as
->type
!= AS_ASSUMED_SIZE
3016 || dim
< ar
->dimen
- 1);
3020 /* Scalarized dimension. */
3021 gcc_assert (info
&& se
->loop
);
3023 /* Multiply the loop variable by the stride and delta. */
3024 index
= se
->loop
->loopvar
[i
];
3025 if (!integer_onep (info
->stride
[dim
]))
3026 index
= fold_build2_loc (input_location
, MULT_EXPR
,
3027 gfc_array_index_type
, index
,
3029 if (!integer_zerop (info
->delta
[dim
]))
3030 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
3031 gfc_array_index_type
, index
,
3041 /* Temporary array or derived type component. */
3042 gcc_assert (se
->loop
);
3043 index
= se
->loop
->loopvar
[se
->loop
->order
[i
]];
3045 /* Pointer functions can have stride[0] different from unity.
3046 Use the stride returned by the function call and stored in
3047 the descriptor for the temporary. */
3048 if (se
->ss
&& se
->ss
->info
->type
== GFC_SS_FUNCTION
3049 && se
->ss
->info
->expr
3050 && se
->ss
->info
->expr
->symtree
3051 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
3052 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
->attr
.pointer
)
3053 stride
= gfc_conv_descriptor_stride_get (info
->descriptor
,
3056 if (info
->delta
[dim
] && !integer_zerop (info
->delta
[dim
]))
3057 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
3058 gfc_array_index_type
, index
, info
->delta
[dim
]);
3061 /* Multiply by the stride. */
3062 if (!integer_onep (stride
))
3063 index
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3070 /* Build a scalarized array reference using the vptr 'size'. */
3073 build_class_array_ref (gfc_se
*se
, tree base
, tree index
)
3078 tree decl
= NULL_TREE
;
3080 gfc_expr
*expr
= se
->ss
->info
->expr
;
3082 gfc_ref
*class_ref
= NULL
;
3085 if (se
->expr
&& DECL_P (se
->expr
) && DECL_LANG_SPECIFIC (se
->expr
)
3086 && GFC_DECL_SAVED_DESCRIPTOR (se
->expr
)
3087 && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (se
->expr
))))
3092 || (expr
->ts
.type
!= BT_CLASS
3093 && !gfc_is_alloc_class_array_function (expr
)
3094 && !gfc_is_class_array_ref (expr
, NULL
)))
3097 if (expr
->symtree
&& expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
3098 ts
= &expr
->symtree
->n
.sym
->ts
;
3102 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3104 if (ref
->type
== REF_COMPONENT
3105 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
3106 && ref
->next
&& ref
->next
->type
== REF_COMPONENT
3107 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0
3109 && ref
->next
->next
->type
== REF_ARRAY
3110 && ref
->next
->next
->u
.ar
.type
!= AR_ELEMENT
)
3112 ts
= &ref
->u
.c
.component
->ts
;
3122 if (class_ref
== NULL
&& expr
&& expr
->symtree
->n
.sym
->attr
.function
3123 && expr
->symtree
->n
.sym
== expr
->symtree
->n
.sym
->result
)
3125 gcc_assert (expr
->symtree
->n
.sym
->backend_decl
== current_function_decl
);
3126 decl
= gfc_get_fake_result_decl (expr
->symtree
->n
.sym
, 0);
3128 else if (expr
&& gfc_is_alloc_class_array_function (expr
))
3132 for (tmp
= base
; tmp
; tmp
= TREE_OPERAND (tmp
, 0))
3135 type
= TREE_TYPE (tmp
);
3138 if (GFC_CLASS_TYPE_P (type
))
3140 if (type
!= TYPE_CANONICAL (type
))
3141 type
= TYPE_CANONICAL (type
);
3149 if (decl
== NULL_TREE
)
3152 else if (class_ref
== NULL
)
3154 if (decl
== NULL_TREE
)
3155 decl
= expr
->symtree
->n
.sym
->backend_decl
;
3156 /* For class arrays the tree containing the class is stored in
3157 GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl.
3158 For all others it's sym's backend_decl directly. */
3159 if (DECL_LANG_SPECIFIC (decl
) && GFC_DECL_SAVED_DESCRIPTOR (decl
))
3160 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
3164 /* Remove everything after the last class reference, convert the
3165 expression and then recover its tailend once more. */
3167 ref
= class_ref
->next
;
3168 class_ref
->next
= NULL
;
3169 gfc_init_se (&tmpse
, NULL
);
3170 gfc_conv_expr (&tmpse
, expr
);
3171 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3173 class_ref
->next
= ref
;
3176 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
3177 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
3179 if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl
)))
3182 size
= gfc_class_vtab_size_get (decl
);
3184 /* For unlimited polymorphic entities then _len component needs to be
3185 multiplied with the size. If no _len component is present, then
3186 gfc_class_len_or_zero_get () return a zero_node. */
3187 tmp
= gfc_class_len_or_zero_get (decl
);
3188 if (!integer_zerop (tmp
))
3189 size
= fold_build2 (MULT_EXPR
, TREE_TYPE (index
),
3190 fold_convert (TREE_TYPE (index
), size
),
3191 fold_build2 (MAX_EXPR
, TREE_TYPE (index
),
3192 fold_convert (TREE_TYPE (index
), tmp
),
3193 fold_convert (TREE_TYPE (index
),
3194 integer_one_node
)));
3196 size
= fold_convert (TREE_TYPE (index
), size
);
3198 /* Build the address of the element. */
3199 type
= TREE_TYPE (TREE_TYPE (base
));
3200 offset
= fold_build2_loc (input_location
, MULT_EXPR
,
3201 gfc_array_index_type
,
3203 tmp
= gfc_build_addr_expr (pvoid_type_node
, base
);
3204 tmp
= fold_build_pointer_plus_loc (input_location
, tmp
, offset
);
3205 tmp
= fold_convert (build_pointer_type (type
), tmp
);
3207 /* Return the element in the se expression. */
3208 se
->expr
= build_fold_indirect_ref_loc (input_location
, tmp
);
3213 /* Build a scalarized reference to an array. */
3216 gfc_conv_scalarized_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
3218 gfc_array_info
*info
;
3219 tree decl
= NULL_TREE
;
3227 expr
= ss
->info
->expr
;
3228 info
= &ss
->info
->data
.array
;
3230 n
= se
->loop
->order
[0];
3234 index
= conv_array_index_offset (se
, ss
, ss
->dim
[n
], n
, ar
, info
->stride0
);
3235 /* Add the offset for this dimension to the stored offset for all other
3237 if (info
->offset
&& !integer_zerop (info
->offset
))
3238 index
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3239 index
, info
->offset
);
3241 if (expr
&& (is_subref_array (expr
)
3242 || (expr
->ts
.deferred
&& (expr
->expr_type
== EXPR_VARIABLE
3243 || expr
->expr_type
== EXPR_FUNCTION
))))
3244 decl
= expr
->symtree
->n
.sym
->backend_decl
;
3246 tmp
= build_fold_indirect_ref_loc (input_location
, info
->data
);
3248 /* Use the vptr 'size' field to access a class the element of a class
3250 if (build_class_array_ref (se
, tmp
, index
))
3253 se
->expr
= gfc_build_array_ref (tmp
, index
, decl
);
3257 /* Translate access of temporary array. */
3260 gfc_conv_tmp_array_ref (gfc_se
* se
)
3262 se
->string_length
= se
->ss
->info
->string_length
;
3263 gfc_conv_scalarized_array_ref (se
, NULL
);
3264 gfc_advance_se_ss_chain (se
);
3267 /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
3270 add_to_offset (tree
*cst_offset
, tree
*offset
, tree t
)
3272 if (TREE_CODE (t
) == INTEGER_CST
)
3273 *cst_offset
= int_const_binop (PLUS_EXPR
, *cst_offset
, t
);
3276 if (!integer_zerop (*offset
))
3277 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3278 gfc_array_index_type
, *offset
, t
);
3286 build_array_ref (tree desc
, tree offset
, tree decl
, tree vptr
)
3291 bool classarray
= false;
3293 /* For class arrays the class declaration is stored in the saved
3295 if (INDIRECT_REF_P (desc
)
3296 && DECL_LANG_SPECIFIC (TREE_OPERAND (desc
, 0))
3297 && GFC_DECL_SAVED_DESCRIPTOR (TREE_OPERAND (desc
, 0)))
3298 cdecl = gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (
3299 TREE_OPERAND (desc
, 0)));
3303 /* Class container types do not always have the GFC_CLASS_TYPE_P
3304 but the canonical type does. */
3305 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdecl))
3306 && TREE_CODE (cdecl) == COMPONENT_REF
)
3308 type
= TREE_TYPE (TREE_OPERAND (cdecl, 0));
3309 if (TYPE_CANONICAL (type
)
3310 && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type
)))
3312 type
= TREE_TYPE (desc
);
3319 /* Class array references need special treatment because the assigned
3320 type size needs to be used to point to the element. */
3323 type
= gfc_get_element_type (type
);
3324 tmp
= TREE_OPERAND (cdecl, 0);
3325 tmp
= gfc_get_class_array_ref (offset
, tmp
, NULL_TREE
);
3326 tmp
= fold_convert (build_pointer_type (type
), tmp
);
3327 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3331 tmp
= gfc_conv_array_data (desc
);
3332 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3333 tmp
= gfc_build_array_ref (tmp
, offset
, decl
, vptr
);
3338 /* Build an array reference. se->expr already holds the array descriptor.
3339 This should be either a variable, indirect variable reference or component
3340 reference. For arrays which do not have a descriptor, se->expr will be
3342 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
3345 gfc_conv_array_ref (gfc_se
* se
, gfc_array_ref
* ar
, gfc_expr
*expr
,
3349 tree offset
, cst_offset
;
3354 gfc_symbol
* sym
= expr
->symtree
->n
.sym
;
3355 char *var_name
= NULL
;
3359 gcc_assert (ar
->codimen
);
3361 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
->expr
)))
3362 se
->expr
= build_fold_indirect_ref (gfc_conv_array_data (se
->expr
));
3365 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se
->expr
))
3366 && TREE_CODE (TREE_TYPE (se
->expr
)) == POINTER_TYPE
)
3367 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3369 /* Use the actual tree type and not the wrapped coarray. */
3370 if (!se
->want_pointer
)
3371 se
->expr
= fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se
->expr
)),
3378 /* Handle scalarized references separately. */
3379 if (ar
->type
!= AR_ELEMENT
)
3381 gfc_conv_scalarized_array_ref (se
, ar
);
3382 gfc_advance_se_ss_chain (se
);
3386 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3391 len
= strlen (sym
->name
) + 1;
3392 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3394 if (ref
->type
== REF_ARRAY
&& &ref
->u
.ar
== ar
)
3396 if (ref
->type
== REF_COMPONENT
)
3397 len
+= 2 + strlen (ref
->u
.c
.component
->name
);
3400 var_name
= XALLOCAVEC (char, len
);
3401 strcpy (var_name
, sym
->name
);
3403 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3405 if (ref
->type
== REF_ARRAY
&& &ref
->u
.ar
== ar
)
3407 if (ref
->type
== REF_COMPONENT
)
3409 strcat (var_name
, "%%");
3410 strcat (var_name
, ref
->u
.c
.component
->name
);
3415 cst_offset
= offset
= gfc_index_zero_node
;
3416 add_to_offset (&cst_offset
, &offset
, gfc_conv_array_offset (se
->expr
));
3418 /* Calculate the offsets from all the dimensions. Make sure to associate
3419 the final offset so that we form a chain of loop invariant summands. */
3420 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
3422 /* Calculate the index for this dimension. */
3423 gfc_init_se (&indexse
, se
);
3424 gfc_conv_expr_type (&indexse
, ar
->start
[n
], gfc_array_index_type
);
3425 gfc_add_block_to_block (&se
->pre
, &indexse
.pre
);
3427 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3429 /* Check array bounds. */
3433 /* Evaluate the indexse.expr only once. */
3434 indexse
.expr
= save_expr (indexse
.expr
);
3437 tmp
= gfc_conv_array_lbound (se
->expr
, n
);
3438 if (sym
->attr
.temporary
)
3440 gfc_init_se (&tmpse
, se
);
3441 gfc_conv_expr_type (&tmpse
, ar
->as
->lower
[n
],
3442 gfc_array_index_type
);
3443 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3447 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
3449 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3450 "below lower bound of %%ld", n
+1, var_name
);
3451 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3452 fold_convert (long_integer_type_node
,
3454 fold_convert (long_integer_type_node
, tmp
));
3457 /* Upper bound, but not for the last dimension of assumed-size
3459 if (n
< ar
->dimen
- 1 || ar
->as
->type
!= AS_ASSUMED_SIZE
)
3461 tmp
= gfc_conv_array_ubound (se
->expr
, n
);
3462 if (sym
->attr
.temporary
)
3464 gfc_init_se (&tmpse
, se
);
3465 gfc_conv_expr_type (&tmpse
, ar
->as
->upper
[n
],
3466 gfc_array_index_type
);
3467 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3471 cond
= fold_build2_loc (input_location
, GT_EXPR
,
3472 boolean_type_node
, indexse
.expr
, tmp
);
3473 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3474 "above upper bound of %%ld", n
+1, var_name
);
3475 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3476 fold_convert (long_integer_type_node
,
3478 fold_convert (long_integer_type_node
, tmp
));
3483 /* Multiply the index by the stride. */
3484 stride
= gfc_conv_array_stride (se
->expr
, n
);
3485 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3486 indexse
.expr
, stride
);
3488 /* And add it to the total. */
3489 add_to_offset (&cst_offset
, &offset
, tmp
);
3492 if (!integer_zerop (cst_offset
))
3493 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3494 gfc_array_index_type
, offset
, cst_offset
);
3496 se
->expr
= build_array_ref (se
->expr
, offset
, sym
->ts
.type
== BT_CLASS
?
3497 NULL_TREE
: sym
->backend_decl
, se
->class_vptr
);
3501 /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
3502 LOOP_DIM dimension (if any) to array's offset. */
3505 add_array_offset (stmtblock_t
*pblock
, gfc_loopinfo
*loop
, gfc_ss
*ss
,
3506 gfc_array_ref
*ar
, int array_dim
, int loop_dim
)
3509 gfc_array_info
*info
;
3512 info
= &ss
->info
->data
.array
;
3514 gfc_init_se (&se
, NULL
);
3516 se
.expr
= info
->descriptor
;
3517 stride
= gfc_conv_array_stride (info
->descriptor
, array_dim
);
3518 index
= conv_array_index_offset (&se
, ss
, array_dim
, loop_dim
, ar
, stride
);
3519 gfc_add_block_to_block (pblock
, &se
.pre
);
3521 info
->offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3522 gfc_array_index_type
,
3523 info
->offset
, index
);
3524 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
3528 /* Generate the code to be executed immediately before entering a
3529 scalarization loop. */
3532 gfc_trans_preloop_setup (gfc_loopinfo
* loop
, int dim
, int flag
,
3533 stmtblock_t
* pblock
)
3536 gfc_ss_info
*ss_info
;
3537 gfc_array_info
*info
;
3538 gfc_ss_type ss_type
;
3540 gfc_loopinfo
*ploop
;
3544 /* This code will be executed before entering the scalarization loop
3545 for this dimension. */
3546 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3550 if ((ss_info
->useflags
& flag
) == 0)
3553 ss_type
= ss_info
->type
;
3554 if (ss_type
!= GFC_SS_SECTION
3555 && ss_type
!= GFC_SS_FUNCTION
3556 && ss_type
!= GFC_SS_CONSTRUCTOR
3557 && ss_type
!= GFC_SS_COMPONENT
)
3560 info
= &ss_info
->data
.array
;
3562 gcc_assert (dim
< ss
->dimen
);
3563 gcc_assert (ss
->dimen
== loop
->dimen
);
3566 ar
= &info
->ref
->u
.ar
;
3570 if (dim
== loop
->dimen
- 1 && loop
->parent
!= NULL
)
3572 /* If we are in the outermost dimension of this loop, the previous
3573 dimension shall be in the parent loop. */
3574 gcc_assert (ss
->parent
!= NULL
);
3577 ploop
= loop
->parent
;
3579 /* ss and ss->parent are about the same array. */
3580 gcc_assert (ss_info
== pss
->info
);
3588 if (dim
== loop
->dimen
- 1)
3593 /* For the time being, there is no loop reordering. */
3594 gcc_assert (i
== ploop
->order
[i
]);
3595 i
= ploop
->order
[i
];
3597 if (dim
== loop
->dimen
- 1 && loop
->parent
== NULL
)
3599 stride
= gfc_conv_array_stride (info
->descriptor
,
3600 innermost_ss (ss
)->dim
[i
]);
3602 /* Calculate the stride of the innermost loop. Hopefully this will
3603 allow the backend optimizers to do their stuff more effectively.
3605 info
->stride0
= gfc_evaluate_now (stride
, pblock
);
3607 /* For the outermost loop calculate the offset due to any
3608 elemental dimensions. It will have been initialized with the
3609 base offset of the array. */
3612 for (i
= 0; i
< ar
->dimen
; i
++)
3614 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
3617 add_array_offset (pblock
, loop
, ss
, ar
, i
, /* unused */ -1);
3622 /* Add the offset for the previous loop dimension. */
3623 add_array_offset (pblock
, ploop
, ss
, ar
, pss
->dim
[i
], i
);
3625 /* Remember this offset for the second loop. */
3626 if (dim
== loop
->temp_dim
- 1 && loop
->parent
== NULL
)
3627 info
->saved_offset
= info
->offset
;
3632 /* Start a scalarized expression. Creates a scope and declares loop
3636 gfc_start_scalarized_body (gfc_loopinfo
* loop
, stmtblock_t
* pbody
)
3642 gcc_assert (!loop
->array_parameter
);
3644 for (dim
= loop
->dimen
- 1; dim
>= 0; dim
--)
3646 n
= loop
->order
[dim
];
3648 gfc_start_block (&loop
->code
[n
]);
3650 /* Create the loop variable. */
3651 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "S");
3653 if (dim
< loop
->temp_dim
)
3657 /* Calculate values that will be constant within this loop. */
3658 gfc_trans_preloop_setup (loop
, dim
, flags
, &loop
->code
[n
]);
3660 gfc_start_block (pbody
);
3664 /* Generates the actual loop code for a scalarization loop. */
3667 gfc_trans_scalarized_loop_end (gfc_loopinfo
* loop
, int n
,
3668 stmtblock_t
* pbody
)
3679 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
3680 | OMPWS_SCALARIZER_BODY
))
3681 == (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
)
3682 && n
== loop
->dimen
- 1)
3684 /* We create an OMP_FOR construct for the outermost scalarized loop. */
3685 init
= make_tree_vec (1);
3686 cond
= make_tree_vec (1);
3687 incr
= make_tree_vec (1);
3689 /* Cycle statement is implemented with a goto. Exit statement must not
3690 be present for this loop. */
3691 exit_label
= gfc_build_label_decl (NULL_TREE
);
3692 TREE_USED (exit_label
) = 1;
3694 /* Label for cycle statements (if needed). */
3695 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3696 gfc_add_expr_to_block (pbody
, tmp
);
3698 stmt
= make_node (OMP_FOR
);
3700 TREE_TYPE (stmt
) = void_type_node
;
3701 OMP_FOR_BODY (stmt
) = loopbody
= gfc_finish_block (pbody
);
3703 OMP_FOR_CLAUSES (stmt
) = build_omp_clause (input_location
,
3704 OMP_CLAUSE_SCHEDULE
);
3705 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt
))
3706 = OMP_CLAUSE_SCHEDULE_STATIC
;
3707 if (ompws_flags
& OMPWS_NOWAIT
)
3708 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt
))
3709 = build_omp_clause (input_location
, OMP_CLAUSE_NOWAIT
);
3711 /* Initialize the loopvar. */
3712 TREE_VEC_ELT (init
, 0) = build2_v (MODIFY_EXPR
, loop
->loopvar
[n
],
3714 OMP_FOR_INIT (stmt
) = init
;
3715 /* The exit condition. */
3716 TREE_VEC_ELT (cond
, 0) = build2_loc (input_location
, LE_EXPR
,
3718 loop
->loopvar
[n
], loop
->to
[n
]);
3719 SET_EXPR_LOCATION (TREE_VEC_ELT (cond
, 0), input_location
);
3720 OMP_FOR_COND (stmt
) = cond
;
3721 /* Increment the loopvar. */
3722 tmp
= build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3723 loop
->loopvar
[n
], gfc_index_one_node
);
3724 TREE_VEC_ELT (incr
, 0) = fold_build2_loc (input_location
, MODIFY_EXPR
,
3725 void_type_node
, loop
->loopvar
[n
], tmp
);
3726 OMP_FOR_INCR (stmt
) = incr
;
3728 ompws_flags
&= ~OMPWS_CURR_SINGLEUNIT
;
3729 gfc_add_expr_to_block (&loop
->code
[n
], stmt
);
3733 bool reverse_loop
= (loop
->reverse
[n
] == GFC_REVERSE_SET
)
3734 && (loop
->temp_ss
== NULL
);
3736 loopbody
= gfc_finish_block (pbody
);
3739 std::swap (loop
->from
[n
], loop
->to
[n
]);
3741 /* Initialize the loopvar. */
3742 if (loop
->loopvar
[n
] != loop
->from
[n
])
3743 gfc_add_modify (&loop
->code
[n
], loop
->loopvar
[n
], loop
->from
[n
]);
3745 exit_label
= gfc_build_label_decl (NULL_TREE
);
3747 /* Generate the loop body. */
3748 gfc_init_block (&block
);
3750 /* The exit condition. */
3751 cond
= fold_build2_loc (input_location
, reverse_loop
? LT_EXPR
: GT_EXPR
,
3752 boolean_type_node
, loop
->loopvar
[n
], loop
->to
[n
]);
3753 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3754 TREE_USED (exit_label
) = 1;
3755 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3756 gfc_add_expr_to_block (&block
, tmp
);
3758 /* The main body. */
3759 gfc_add_expr_to_block (&block
, loopbody
);
3761 /* Increment the loopvar. */
3762 tmp
= fold_build2_loc (input_location
,
3763 reverse_loop
? MINUS_EXPR
: PLUS_EXPR
,
3764 gfc_array_index_type
, loop
->loopvar
[n
],
3765 gfc_index_one_node
);
3767 gfc_add_modify (&block
, loop
->loopvar
[n
], tmp
);
3769 /* Build the loop. */
3770 tmp
= gfc_finish_block (&block
);
3771 tmp
= build1_v (LOOP_EXPR
, tmp
);
3772 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
3774 /* Add the exit label. */
3775 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3776 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
3782 /* Finishes and generates the loops for a scalarized expression. */
3785 gfc_trans_scalarizing_loops (gfc_loopinfo
* loop
, stmtblock_t
* body
)
3790 stmtblock_t
*pblock
;
3794 /* Generate the loops. */
3795 for (dim
= 0; dim
< loop
->dimen
; dim
++)
3797 n
= loop
->order
[dim
];
3798 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
3799 loop
->loopvar
[n
] = NULL_TREE
;
3800 pblock
= &loop
->code
[n
];
3803 tmp
= gfc_finish_block (pblock
);
3804 gfc_add_expr_to_block (&loop
->pre
, tmp
);
3806 /* Clear all the used flags. */
3807 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3808 if (ss
->parent
== NULL
)
3809 ss
->info
->useflags
= 0;
3813 /* Finish the main body of a scalarized expression, and start the secondary
3817 gfc_trans_scalarized_loop_boundary (gfc_loopinfo
* loop
, stmtblock_t
* body
)
3821 stmtblock_t
*pblock
;
3825 /* We finish as many loops as are used by the temporary. */
3826 for (dim
= 0; dim
< loop
->temp_dim
- 1; dim
++)
3828 n
= loop
->order
[dim
];
3829 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
3830 loop
->loopvar
[n
] = NULL_TREE
;
3831 pblock
= &loop
->code
[n
];
3834 /* We don't want to finish the outermost loop entirely. */
3835 n
= loop
->order
[loop
->temp_dim
- 1];
3836 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
3838 /* Restore the initial offsets. */
3839 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3841 gfc_ss_type ss_type
;
3842 gfc_ss_info
*ss_info
;
3846 if ((ss_info
->useflags
& 2) == 0)
3849 ss_type
= ss_info
->type
;
3850 if (ss_type
!= GFC_SS_SECTION
3851 && ss_type
!= GFC_SS_FUNCTION
3852 && ss_type
!= GFC_SS_CONSTRUCTOR
3853 && ss_type
!= GFC_SS_COMPONENT
)
3856 ss_info
->data
.array
.offset
= ss_info
->data
.array
.saved_offset
;
3859 /* Restart all the inner loops we just finished. */
3860 for (dim
= loop
->temp_dim
- 2; dim
>= 0; dim
--)
3862 n
= loop
->order
[dim
];
3864 gfc_start_block (&loop
->code
[n
]);
3866 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "Q");
3868 gfc_trans_preloop_setup (loop
, dim
, 2, &loop
->code
[n
]);
3871 /* Start a block for the secondary copying code. */
3872 gfc_start_block (body
);
3876 /* Precalculate (either lower or upper) bound of an array section.
3877 BLOCK: Block in which the (pre)calculation code will go.
3878 BOUNDS[DIM]: Where the bound value will be stored once evaluated.
3879 VALUES[DIM]: Specified bound (NULL <=> unspecified).
3880 DESC: Array descriptor from which the bound will be picked if unspecified
3881 (either lower or upper bound according to LBOUND). */
3884 evaluate_bound (stmtblock_t
*block
, tree
*bounds
, gfc_expr
** values
,
3885 tree desc
, int dim
, bool lbound
, bool deferred
)
3888 gfc_expr
* input_val
= values
[dim
];
3889 tree
*output
= &bounds
[dim
];
3894 /* Specified section bound. */
3895 gfc_init_se (&se
, NULL
);
3896 gfc_conv_expr_type (&se
, input_val
, gfc_array_index_type
);
3897 gfc_add_block_to_block (block
, &se
.pre
);
3900 else if (deferred
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
3902 /* The gfc_conv_array_lbound () routine returns a constant zero for
3903 deferred length arrays, which in the scalarizer wreaks havoc, when
3904 copying to a (newly allocated) one-based array.
3905 Keep returning the actual result in sync for both bounds. */
3906 *output
= lbound
? gfc_conv_descriptor_lbound_get (desc
,
3908 gfc_conv_descriptor_ubound_get (desc
,
3913 /* No specific bound specified so use the bound of the array. */
3914 *output
= lbound
? gfc_conv_array_lbound (desc
, dim
) :
3915 gfc_conv_array_ubound (desc
, dim
);
3917 *output
= gfc_evaluate_now (*output
, block
);
3921 /* Calculate the lower bound of an array section. */
3924 gfc_conv_section_startstride (stmtblock_t
* block
, gfc_ss
* ss
, int dim
)
3926 gfc_expr
*stride
= NULL
;
3929 gfc_array_info
*info
;
3932 gcc_assert (ss
->info
->type
== GFC_SS_SECTION
);
3934 info
= &ss
->info
->data
.array
;
3935 ar
= &info
->ref
->u
.ar
;
3937 if (ar
->dimen_type
[dim
] == DIMEN_VECTOR
)
3939 /* We use a zero-based index to access the vector. */
3940 info
->start
[dim
] = gfc_index_zero_node
;
3941 info
->end
[dim
] = NULL
;
3942 info
->stride
[dim
] = gfc_index_one_node
;
3946 gcc_assert (ar
->dimen_type
[dim
] == DIMEN_RANGE
3947 || ar
->dimen_type
[dim
] == DIMEN_THIS_IMAGE
);
3948 desc
= info
->descriptor
;
3949 stride
= ar
->stride
[dim
];
3952 /* Calculate the start of the range. For vector subscripts this will
3953 be the range of the vector. */
3954 evaluate_bound (block
, info
->start
, ar
->start
, desc
, dim
, true,
3955 ar
->as
->type
== AS_DEFERRED
);
3957 /* Similarly calculate the end. Although this is not used in the
3958 scalarizer, it is needed when checking bounds and where the end
3959 is an expression with side-effects. */
3960 evaluate_bound (block
, info
->end
, ar
->end
, desc
, dim
, false,
3961 ar
->as
->type
== AS_DEFERRED
);
3964 /* Calculate the stride. */
3966 info
->stride
[dim
] = gfc_index_one_node
;
3969 gfc_init_se (&se
, NULL
);
3970 gfc_conv_expr_type (&se
, stride
, gfc_array_index_type
);
3971 gfc_add_block_to_block (block
, &se
.pre
);
3972 info
->stride
[dim
] = gfc_evaluate_now (se
.expr
, block
);
3977 /* Calculates the range start and stride for a SS chain. Also gets the
3978 descriptor and data pointer. The range of vector subscripts is the size
3979 of the vector. Array bounds are also checked. */
3982 gfc_conv_ss_startstride (gfc_loopinfo
* loop
)
3989 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
3992 /* Determine the rank of the loop. */
3993 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3995 switch (ss
->info
->type
)
3997 case GFC_SS_SECTION
:
3998 case GFC_SS_CONSTRUCTOR
:
3999 case GFC_SS_FUNCTION
:
4000 case GFC_SS_COMPONENT
:
4001 loop
->dimen
= ss
->dimen
;
4004 /* As usual, lbound and ubound are exceptions!. */
4005 case GFC_SS_INTRINSIC
:
4006 switch (ss
->info
->expr
->value
.function
.isym
->id
)
4008 case GFC_ISYM_LBOUND
:
4009 case GFC_ISYM_UBOUND
:
4010 case GFC_ISYM_LCOBOUND
:
4011 case GFC_ISYM_UCOBOUND
:
4012 case GFC_ISYM_THIS_IMAGE
:
4013 loop
->dimen
= ss
->dimen
;
4025 /* We should have determined the rank of the expression by now. If
4026 not, that's bad news. */
4030 /* Loop over all the SS in the chain. */
4031 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4033 gfc_ss_info
*ss_info
;
4034 gfc_array_info
*info
;
4038 expr
= ss_info
->expr
;
4039 info
= &ss_info
->data
.array
;
4041 if (expr
&& expr
->shape
&& !info
->shape
)
4042 info
->shape
= expr
->shape
;
4044 switch (ss_info
->type
)
4046 case GFC_SS_SECTION
:
4047 /* Get the descriptor for the array. If it is a cross loops array,
4048 we got the descriptor already in the outermost loop. */
4049 if (ss
->parent
== NULL
)
4050 gfc_conv_ss_descriptor (&outer_loop
->pre
, ss
,
4051 !loop
->array_parameter
);
4053 for (n
= 0; n
< ss
->dimen
; n
++)
4054 gfc_conv_section_startstride (&outer_loop
->pre
, ss
, ss
->dim
[n
]);
4057 case GFC_SS_INTRINSIC
:
4058 switch (expr
->value
.function
.isym
->id
)
4060 /* Fall through to supply start and stride. */
4061 case GFC_ISYM_LBOUND
:
4062 case GFC_ISYM_UBOUND
:
4066 /* This is the variant without DIM=... */
4067 gcc_assert (expr
->value
.function
.actual
->next
->expr
== NULL
);
4069 arg
= expr
->value
.function
.actual
->expr
;
4070 if (arg
->rank
== -1)
4075 /* The rank (hence the return value's shape) is unknown,
4076 we have to retrieve it. */
4077 gfc_init_se (&se
, NULL
);
4078 se
.descriptor_only
= 1;
4079 gfc_conv_expr (&se
, arg
);
4080 /* This is a bare variable, so there is no preliminary
4082 gcc_assert (se
.pre
.head
== NULL_TREE
4083 && se
.post
.head
== NULL_TREE
);
4084 rank
= gfc_conv_descriptor_rank (se
.expr
);
4085 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4086 gfc_array_index_type
,
4087 fold_convert (gfc_array_index_type
,
4089 gfc_index_one_node
);
4090 info
->end
[0] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
4091 info
->start
[0] = gfc_index_zero_node
;
4092 info
->stride
[0] = gfc_index_one_node
;
4095 /* Otherwise fall through GFC_SS_FUNCTION. */
4098 case GFC_ISYM_LCOBOUND
:
4099 case GFC_ISYM_UCOBOUND
:
4100 case GFC_ISYM_THIS_IMAGE
:
4108 case GFC_SS_CONSTRUCTOR
:
4109 case GFC_SS_FUNCTION
:
4110 for (n
= 0; n
< ss
->dimen
; n
++)
4112 int dim
= ss
->dim
[n
];
4114 info
->start
[dim
] = gfc_index_zero_node
;
4115 info
->end
[dim
] = gfc_index_zero_node
;
4116 info
->stride
[dim
] = gfc_index_one_node
;
4125 /* The rest is just runtime bound checking. */
4126 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
4129 tree lbound
, ubound
;
4131 tree size
[GFC_MAX_DIMENSIONS
];
4132 tree stride_pos
, stride_neg
, non_zerosized
, tmp2
, tmp3
;
4133 gfc_array_info
*info
;
4137 gfc_start_block (&block
);
4139 for (n
= 0; n
< loop
->dimen
; n
++)
4140 size
[n
] = NULL_TREE
;
4142 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4145 gfc_ss_info
*ss_info
;
4148 const char *expr_name
;
4151 if (ss_info
->type
!= GFC_SS_SECTION
)
4154 /* Catch allocatable lhs in f2003. */
4155 if (flag_realloc_lhs
&& ss
->is_alloc_lhs
)
4158 expr
= ss_info
->expr
;
4159 expr_loc
= &expr
->where
;
4160 expr_name
= expr
->symtree
->name
;
4162 gfc_start_block (&inner
);
4164 /* TODO: range checking for mapped dimensions. */
4165 info
= &ss_info
->data
.array
;
4167 /* This code only checks ranges. Elemental and vector
4168 dimensions are checked later. */
4169 for (n
= 0; n
< loop
->dimen
; n
++)
4174 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
4177 if (dim
== info
->ref
->u
.ar
.dimen
- 1
4178 && info
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
4179 check_upper
= false;
4183 /* Zero stride is not allowed. */
4184 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4185 info
->stride
[dim
], gfc_index_zero_node
);
4186 msg
= xasprintf ("Zero stride is not allowed, for dimension %d "
4187 "of array '%s'", dim
+ 1, expr_name
);
4188 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4192 desc
= info
->descriptor
;
4194 /* This is the run-time equivalent of resolve.c's
4195 check_dimension(). The logical is more readable there
4196 than it is here, with all the trees. */
4197 lbound
= gfc_conv_array_lbound (desc
, dim
);
4198 end
= info
->end
[dim
];
4200 ubound
= gfc_conv_array_ubound (desc
, dim
);
4204 /* non_zerosized is true when the selected range is not
4206 stride_pos
= fold_build2_loc (input_location
, GT_EXPR
,
4207 boolean_type_node
, info
->stride
[dim
],
4208 gfc_index_zero_node
);
4209 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
4210 info
->start
[dim
], end
);
4211 stride_pos
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4212 boolean_type_node
, stride_pos
, tmp
);
4214 stride_neg
= fold_build2_loc (input_location
, LT_EXPR
,
4216 info
->stride
[dim
], gfc_index_zero_node
);
4217 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
4218 info
->start
[dim
], end
);
4219 stride_neg
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4222 non_zerosized
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
4224 stride_pos
, stride_neg
);
4226 /* Check the start of the range against the lower and upper
4227 bounds of the array, if the range is not empty.
4228 If upper bound is present, include both bounds in the
4232 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
4234 info
->start
[dim
], lbound
);
4235 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4237 non_zerosized
, tmp
);
4238 tmp2
= fold_build2_loc (input_location
, GT_EXPR
,
4240 info
->start
[dim
], ubound
);
4241 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4243 non_zerosized
, tmp2
);
4244 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4245 "outside of expected range (%%ld:%%ld)",
4246 dim
+ 1, expr_name
);
4247 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4249 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4250 fold_convert (long_integer_type_node
, lbound
),
4251 fold_convert (long_integer_type_node
, ubound
));
4252 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4254 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4255 fold_convert (long_integer_type_node
, lbound
),
4256 fold_convert (long_integer_type_node
, ubound
));
4261 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
4263 info
->start
[dim
], lbound
);
4264 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4265 boolean_type_node
, non_zerosized
, tmp
);
4266 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4267 "below lower bound of %%ld",
4268 dim
+ 1, expr_name
);
4269 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4271 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4272 fold_convert (long_integer_type_node
, lbound
));
4276 /* Compute the last element of the range, which is not
4277 necessarily "end" (think 0:5:3, which doesn't contain 5)
4278 and check it against both lower and upper bounds. */
4280 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4281 gfc_array_index_type
, end
,
4283 tmp
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
,
4284 gfc_array_index_type
, tmp
,
4286 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4287 gfc_array_index_type
, end
, tmp
);
4288 tmp2
= fold_build2_loc (input_location
, LT_EXPR
,
4289 boolean_type_node
, tmp
, lbound
);
4290 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4291 boolean_type_node
, non_zerosized
, tmp2
);
4294 tmp3
= fold_build2_loc (input_location
, GT_EXPR
,
4295 boolean_type_node
, tmp
, ubound
);
4296 tmp3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4297 boolean_type_node
, non_zerosized
, tmp3
);
4298 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4299 "outside of expected range (%%ld:%%ld)",
4300 dim
+ 1, expr_name
);
4301 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4303 fold_convert (long_integer_type_node
, tmp
),
4304 fold_convert (long_integer_type_node
, ubound
),
4305 fold_convert (long_integer_type_node
, lbound
));
4306 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4308 fold_convert (long_integer_type_node
, tmp
),
4309 fold_convert (long_integer_type_node
, ubound
),
4310 fold_convert (long_integer_type_node
, lbound
));
4315 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4316 "below lower bound of %%ld",
4317 dim
+ 1, expr_name
);
4318 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4320 fold_convert (long_integer_type_node
, tmp
),
4321 fold_convert (long_integer_type_node
, lbound
));
4325 /* Check the section sizes match. */
4326 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4327 gfc_array_index_type
, end
,
4329 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
4330 gfc_array_index_type
, tmp
,
4332 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4333 gfc_array_index_type
,
4334 gfc_index_one_node
, tmp
);
4335 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
4336 gfc_array_index_type
, tmp
,
4337 build_int_cst (gfc_array_index_type
, 0));
4338 /* We remember the size of the first section, and check all the
4339 others against this. */
4342 tmp3
= fold_build2_loc (input_location
, NE_EXPR
,
4343 boolean_type_node
, tmp
, size
[n
]);
4344 msg
= xasprintf ("Array bound mismatch for dimension %d "
4345 "of array '%s' (%%ld/%%ld)",
4346 dim
+ 1, expr_name
);
4348 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4350 fold_convert (long_integer_type_node
, tmp
),
4351 fold_convert (long_integer_type_node
, size
[n
]));
4356 size
[n
] = gfc_evaluate_now (tmp
, &inner
);
4359 tmp
= gfc_finish_block (&inner
);
4361 /* For optional arguments, only check bounds if the argument is
4363 if (expr
->symtree
->n
.sym
->attr
.optional
4364 || expr
->symtree
->n
.sym
->attr
.not_always_present
)
4365 tmp
= build3_v (COND_EXPR
,
4366 gfc_conv_expr_present (expr
->symtree
->n
.sym
),
4367 tmp
, build_empty_stmt (input_location
));
4369 gfc_add_expr_to_block (&block
, tmp
);
4373 tmp
= gfc_finish_block (&block
);
4374 gfc_add_expr_to_block (&outer_loop
->pre
, tmp
);
4377 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4378 gfc_conv_ss_startstride (loop
);
4381 /* Return true if both symbols could refer to the same data object. Does
4382 not take account of aliasing due to equivalence statements. */
4385 symbols_could_alias (gfc_symbol
*lsym
, gfc_symbol
*rsym
, bool lsym_pointer
,
4386 bool lsym_target
, bool rsym_pointer
, bool rsym_target
)
4388 /* Aliasing isn't possible if the symbols have different base types. */
4389 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
4392 /* Pointers can point to other pointers and target objects. */
4394 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4395 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4398 /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
4399 and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
4401 if (lsym_target
&& rsym_target
4402 && ((lsym
->attr
.dummy
&& !lsym
->attr
.contiguous
4403 && (!lsym
->attr
.dimension
|| lsym
->as
->type
== AS_ASSUMED_SHAPE
))
4404 || (rsym
->attr
.dummy
&& !rsym
->attr
.contiguous
4405 && (!rsym
->attr
.dimension
4406 || rsym
->as
->type
== AS_ASSUMED_SHAPE
))))
4413 /* Return true if the two SS could be aliased, i.e. both point to the same data
4415 /* TODO: resolve aliases based on frontend expressions. */
4418 gfc_could_be_alias (gfc_ss
* lss
, gfc_ss
* rss
)
4422 gfc_expr
*lexpr
, *rexpr
;
4425 bool lsym_pointer
, lsym_target
, rsym_pointer
, rsym_target
;
4427 lexpr
= lss
->info
->expr
;
4428 rexpr
= rss
->info
->expr
;
4430 lsym
= lexpr
->symtree
->n
.sym
;
4431 rsym
= rexpr
->symtree
->n
.sym
;
4433 lsym_pointer
= lsym
->attr
.pointer
;
4434 lsym_target
= lsym
->attr
.target
;
4435 rsym_pointer
= rsym
->attr
.pointer
;
4436 rsym_target
= rsym
->attr
.target
;
4438 if (symbols_could_alias (lsym
, rsym
, lsym_pointer
, lsym_target
,
4439 rsym_pointer
, rsym_target
))
4442 if (rsym
->ts
.type
!= BT_DERIVED
&& rsym
->ts
.type
!= BT_CLASS
4443 && lsym
->ts
.type
!= BT_DERIVED
&& lsym
->ts
.type
!= BT_CLASS
)
4446 /* For derived types we must check all the component types. We can ignore
4447 array references as these will have the same base type as the previous
4449 for (lref
= lexpr
->ref
; lref
!= lss
->info
->data
.array
.ref
; lref
= lref
->next
)
4451 if (lref
->type
!= REF_COMPONENT
)
4454 lsym_pointer
= lsym_pointer
|| lref
->u
.c
.sym
->attr
.pointer
;
4455 lsym_target
= lsym_target
|| lref
->u
.c
.sym
->attr
.target
;
4457 if (symbols_could_alias (lref
->u
.c
.sym
, rsym
, lsym_pointer
, lsym_target
,
4458 rsym_pointer
, rsym_target
))
4461 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4462 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4464 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4469 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
;
4472 if (rref
->type
!= REF_COMPONENT
)
4475 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4476 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4478 if (symbols_could_alias (lref
->u
.c
.sym
, rref
->u
.c
.sym
,
4479 lsym_pointer
, lsym_target
,
4480 rsym_pointer
, rsym_target
))
4483 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4484 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4486 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4487 &rref
->u
.c
.sym
->ts
))
4489 if (gfc_compare_types (&lref
->u
.c
.sym
->ts
,
4490 &rref
->u
.c
.component
->ts
))
4492 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4493 &rref
->u
.c
.component
->ts
))
4499 lsym_pointer
= lsym
->attr
.pointer
;
4500 lsym_target
= lsym
->attr
.target
;
4501 lsym_pointer
= lsym
->attr
.pointer
;
4502 lsym_target
= lsym
->attr
.target
;
4504 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
; rref
= rref
->next
)
4506 if (rref
->type
!= REF_COMPONENT
)
4509 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4510 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4512 if (symbols_could_alias (rref
->u
.c
.sym
, lsym
,
4513 lsym_pointer
, lsym_target
,
4514 rsym_pointer
, rsym_target
))
4517 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4518 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4520 if (gfc_compare_types (&lsym
->ts
, &rref
->u
.c
.component
->ts
))
4529 /* Resolve array data dependencies. Creates a temporary if required. */
4530 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
4534 gfc_conv_resolve_dependencies (gfc_loopinfo
* loop
, gfc_ss
* dest
,
4540 gfc_ss_info
*ss_info
;
4541 gfc_expr
*dest_expr
;
4546 loop
->temp_ss
= NULL
;
4547 dest_expr
= dest
->info
->expr
;
4549 for (ss
= rss
; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
4552 ss_expr
= ss_info
->expr
;
4554 if (ss_info
->array_outer_dependency
)
4560 if (ss_info
->type
!= GFC_SS_SECTION
)
4562 if (flag_realloc_lhs
4563 && dest_expr
!= ss_expr
4564 && gfc_is_reallocatable_lhs (dest_expr
)
4566 nDepend
= gfc_check_dependency (dest_expr
, ss_expr
, true);
4568 /* Check for cases like c(:)(1:2) = c(2)(2:3) */
4569 if (!nDepend
&& dest_expr
->rank
> 0
4570 && dest_expr
->ts
.type
== BT_CHARACTER
4571 && ss_expr
->expr_type
== EXPR_VARIABLE
)
4573 nDepend
= gfc_check_dependency (dest_expr
, ss_expr
, false);
4575 if (ss_info
->type
== GFC_SS_REFERENCE
4576 && gfc_check_dependency (dest_expr
, ss_expr
, false))
4577 ss_info
->data
.scalar
.needs_temporary
= 1;
4582 if (dest_expr
->symtree
->n
.sym
!= ss_expr
->symtree
->n
.sym
)
4584 if (gfc_could_be_alias (dest
, ss
)
4585 || gfc_are_equivalenced_arrays (dest_expr
, ss_expr
))
4593 lref
= dest_expr
->ref
;
4594 rref
= ss_expr
->ref
;
4596 nDepend
= gfc_dep_resolver (lref
, rref
, &loop
->reverse
[0]);
4601 for (i
= 0; i
< dest
->dimen
; i
++)
4602 for (j
= 0; j
< ss
->dimen
; j
++)
4604 && dest
->dim
[i
] == ss
->dim
[j
])
4606 /* If we don't access array elements in the same order,
4607 there is a dependency. */
4612 /* TODO : loop shifting. */
4615 /* Mark the dimensions for LOOP SHIFTING */
4616 for (n
= 0; n
< loop
->dimen
; n
++)
4618 int dim
= dest
->data
.info
.dim
[n
];
4620 if (lref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
4622 else if (! gfc_is_same_range (&lref
->u
.ar
,
4623 &rref
->u
.ar
, dim
, 0))
4627 /* Put all the dimensions with dependencies in the
4630 for (n
= 0; n
< loop
->dimen
; n
++)
4632 gcc_assert (loop
->order
[n
] == n
);
4634 loop
->order
[dim
++] = n
;
4636 for (n
= 0; n
< loop
->dimen
; n
++)
4639 loop
->order
[dim
++] = n
;
4642 gcc_assert (dim
== loop
->dimen
);
4653 tree base_type
= gfc_typenode_for_spec (&dest_expr
->ts
);
4654 if (GFC_ARRAY_TYPE_P (base_type
)
4655 || GFC_DESCRIPTOR_TYPE_P (base_type
))
4656 base_type
= gfc_get_element_type (base_type
);
4657 loop
->temp_ss
= gfc_get_temp_ss (base_type
, dest
->info
->string_length
,
4659 gfc_add_ss_to_loop (loop
, loop
->temp_ss
);
4662 loop
->temp_ss
= NULL
;
4666 /* Browse through each array's information from the scalarizer and set the loop
4667 bounds according to the "best" one (per dimension), i.e. the one which
4668 provides the most information (constant bounds, shape, etc.). */
4671 set_loop_bounds (gfc_loopinfo
*loop
)
4673 int n
, dim
, spec_dim
;
4674 gfc_array_info
*info
;
4675 gfc_array_info
*specinfo
;
4679 bool dynamic
[GFC_MAX_DIMENSIONS
];
4682 bool nonoptional_arr
;
4684 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
4686 loopspec
= loop
->specloop
;
4689 for (n
= 0; n
< loop
->dimen
; n
++)
4694 /* If there are both optional and nonoptional array arguments, scalarize
4695 over the nonoptional; otherwise, it does not matter as then all
4696 (optional) arrays have to be present per F2008, 125.2.12p3(6). */
4698 nonoptional_arr
= false;
4700 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4701 if (ss
->info
->type
!= GFC_SS_SCALAR
&& ss
->info
->type
!= GFC_SS_TEMP
4702 && ss
->info
->type
!= GFC_SS_REFERENCE
&& !ss
->info
->can_be_null_ref
)
4704 nonoptional_arr
= true;
4708 /* We use one SS term, and use that to determine the bounds of the
4709 loop for this dimension. We try to pick the simplest term. */
4710 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4712 gfc_ss_type ss_type
;
4714 ss_type
= ss
->info
->type
;
4715 if (ss_type
== GFC_SS_SCALAR
4716 || ss_type
== GFC_SS_TEMP
4717 || ss_type
== GFC_SS_REFERENCE
4718 || (ss
->info
->can_be_null_ref
&& nonoptional_arr
))
4721 info
= &ss
->info
->data
.array
;
4724 if (loopspec
[n
] != NULL
)
4726 specinfo
= &loopspec
[n
]->info
->data
.array
;
4727 spec_dim
= loopspec
[n
]->dim
[n
];
4731 /* Silence uninitialized warnings. */
4738 gcc_assert (info
->shape
[dim
]);
4739 /* The frontend has worked out the size for us. */
4742 || !integer_zerop (specinfo
->start
[spec_dim
]))
4743 /* Prefer zero-based descriptors if possible. */
4748 if (ss_type
== GFC_SS_CONSTRUCTOR
)
4750 gfc_constructor_base base
;
4751 /* An unknown size constructor will always be rank one.
4752 Higher rank constructors will either have known shape,
4753 or still be wrapped in a call to reshape. */
4754 gcc_assert (loop
->dimen
== 1);
4756 /* Always prefer to use the constructor bounds if the size
4757 can be determined at compile time. Prefer not to otherwise,
4758 since the general case involves realloc, and it's better to
4759 avoid that overhead if possible. */
4760 base
= ss
->info
->expr
->value
.constructor
;
4761 dynamic
[n
] = gfc_get_array_constructor_size (&i
, base
);
4762 if (!dynamic
[n
] || !loopspec
[n
])
4767 /* Avoid using an allocatable lhs in an assignment, since
4768 there might be a reallocation coming. */
4769 if (loopspec
[n
] && ss
->is_alloc_lhs
)
4774 /* Criteria for choosing a loop specifier (most important first):
4775 doesn't need realloc
4781 else if (loopspec
[n
]->info
->type
== GFC_SS_CONSTRUCTOR
&& dynamic
[n
])
4783 else if (integer_onep (info
->stride
[dim
])
4784 && !integer_onep (specinfo
->stride
[spec_dim
]))
4786 else if (INTEGER_CST_P (info
->stride
[dim
])
4787 && !INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
4789 else if (INTEGER_CST_P (info
->start
[dim
])
4790 && !INTEGER_CST_P (specinfo
->start
[spec_dim
])
4791 && integer_onep (info
->stride
[dim
])
4792 == integer_onep (specinfo
->stride
[spec_dim
])
4793 && INTEGER_CST_P (info
->stride
[dim
])
4794 == INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
4796 /* We don't work out the upper bound.
4797 else if (INTEGER_CST_P (info->finish[n])
4798 && ! INTEGER_CST_P (specinfo->finish[n]))
4799 loopspec[n] = ss; */
4802 /* We should have found the scalarization loop specifier. If not,
4804 gcc_assert (loopspec
[n
]);
4806 info
= &loopspec
[n
]->info
->data
.array
;
4807 dim
= loopspec
[n
]->dim
[n
];
4809 /* Set the extents of this range. */
4810 cshape
= info
->shape
;
4811 if (cshape
&& INTEGER_CST_P (info
->start
[dim
])
4812 && INTEGER_CST_P (info
->stride
[dim
]))
4814 loop
->from
[n
] = info
->start
[dim
];
4815 mpz_set (i
, cshape
[get_array_ref_dim_for_loop_dim (loopspec
[n
], n
)]);
4816 mpz_sub_ui (i
, i
, 1);
4817 /* To = from + (size - 1) * stride. */
4818 tmp
= gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
4819 if (!integer_onep (info
->stride
[dim
]))
4820 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
4821 gfc_array_index_type
, tmp
,
4823 loop
->to
[n
] = fold_build2_loc (input_location
, PLUS_EXPR
,
4824 gfc_array_index_type
,
4825 loop
->from
[n
], tmp
);
4829 loop
->from
[n
] = info
->start
[dim
];
4830 switch (loopspec
[n
]->info
->type
)
4832 case GFC_SS_CONSTRUCTOR
:
4833 /* The upper bound is calculated when we expand the
4835 gcc_assert (loop
->to
[n
] == NULL_TREE
);
4838 case GFC_SS_SECTION
:
4839 /* Use the end expression if it exists and is not constant,
4840 so that it is only evaluated once. */
4841 loop
->to
[n
] = info
->end
[dim
];
4844 case GFC_SS_FUNCTION
:
4845 /* The loop bound will be set when we generate the call. */
4846 gcc_assert (loop
->to
[n
] == NULL_TREE
);
4849 case GFC_SS_INTRINSIC
:
4851 gfc_expr
*expr
= loopspec
[n
]->info
->expr
;
4853 /* The {l,u}bound of an assumed rank. */
4854 gcc_assert ((expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
4855 || expr
->value
.function
.isym
->id
== GFC_ISYM_UBOUND
)
4856 && expr
->value
.function
.actual
->next
->expr
== NULL
4857 && expr
->value
.function
.actual
->expr
->rank
== -1);
4859 loop
->to
[n
] = info
->end
[dim
];
4868 /* Transform everything so we have a simple incrementing variable. */
4869 if (integer_onep (info
->stride
[dim
]))
4870 info
->delta
[dim
] = gfc_index_zero_node
;
4873 /* Set the delta for this section. */
4874 info
->delta
[dim
] = gfc_evaluate_now (loop
->from
[n
], &outer_loop
->pre
);
4875 /* Number of iterations is (end - start + step) / step.
4876 with start = 0, this simplifies to
4878 for (i = 0; i<=last; i++){...}; */
4879 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4880 gfc_array_index_type
, loop
->to
[n
],
4882 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
4883 gfc_array_index_type
, tmp
, info
->stride
[dim
]);
4884 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
4885 tmp
, build_int_cst (gfc_array_index_type
, -1));
4886 loop
->to
[n
] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
4887 /* Make the loop variable start at 0. */
4888 loop
->from
[n
] = gfc_index_zero_node
;
4893 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4894 set_loop_bounds (loop
);
4898 /* Initialize the scalarization loop. Creates the loop variables. Determines
4899 the range of the loop variables. Creates a temporary if required.
4900 Also generates code for scalar expressions which have been
4901 moved outside the loop. */
4904 gfc_conv_loop_setup (gfc_loopinfo
* loop
, locus
* where
)
4909 set_loop_bounds (loop
);
4911 /* Add all the scalar code that can be taken out of the loops.
4912 This may include calculating the loop bounds, so do it before
4913 allocating the temporary. */
4914 gfc_add_loop_ss_code (loop
, loop
->ss
, false, where
);
4916 tmp_ss
= loop
->temp_ss
;
4917 /* If we want a temporary then create it. */
4920 gfc_ss_info
*tmp_ss_info
;
4922 tmp_ss_info
= tmp_ss
->info
;
4923 gcc_assert (tmp_ss_info
->type
== GFC_SS_TEMP
);
4924 gcc_assert (loop
->parent
== NULL
);
4926 /* Make absolutely sure that this is a complete type. */
4927 if (tmp_ss_info
->string_length
)
4928 tmp_ss_info
->data
.temp
.type
4929 = gfc_get_character_type_len_for_eltype
4930 (TREE_TYPE (tmp_ss_info
->data
.temp
.type
),
4931 tmp_ss_info
->string_length
);
4933 tmp
= tmp_ss_info
->data
.temp
.type
;
4934 memset (&tmp_ss_info
->data
.array
, 0, sizeof (gfc_array_info
));
4935 tmp_ss_info
->type
= GFC_SS_SECTION
;
4937 gcc_assert (tmp_ss
->dimen
!= 0);
4939 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, tmp_ss
, tmp
,
4940 NULL_TREE
, false, true, false, where
);
4943 /* For array parameters we don't have loop variables, so don't calculate the
4945 if (!loop
->array_parameter
)
4946 gfc_set_delta (loop
);
4950 /* Calculates how to transform from loop variables to array indices for each
4951 array: once loop bounds are chosen, sets the difference (DELTA field) between
4952 loop bounds and array reference bounds, for each array info. */
4955 gfc_set_delta (gfc_loopinfo
*loop
)
4957 gfc_ss
*ss
, **loopspec
;
4958 gfc_array_info
*info
;
4962 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
4964 loopspec
= loop
->specloop
;
4966 /* Calculate the translation from loop variables to array indices. */
4967 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4969 gfc_ss_type ss_type
;
4971 ss_type
= ss
->info
->type
;
4972 if (ss_type
!= GFC_SS_SECTION
4973 && ss_type
!= GFC_SS_COMPONENT
4974 && ss_type
!= GFC_SS_CONSTRUCTOR
)
4977 info
= &ss
->info
->data
.array
;
4979 for (n
= 0; n
< ss
->dimen
; n
++)
4981 /* If we are specifying the range the delta is already set. */
4982 if (loopspec
[n
] != ss
)
4986 /* Calculate the offset relative to the loop variable.
4987 First multiply by the stride. */
4988 tmp
= loop
->from
[n
];
4989 if (!integer_onep (info
->stride
[dim
]))
4990 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
4991 gfc_array_index_type
,
4992 tmp
, info
->stride
[dim
]);
4994 /* Then subtract this from our starting value. */
4995 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4996 gfc_array_index_type
,
4997 info
->start
[dim
], tmp
);
4999 info
->delta
[dim
] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
5004 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
5005 gfc_set_delta (loop
);
5009 /* Calculate the size of a given array dimension from the bounds. This
5010 is simply (ubound - lbound + 1) if this expression is positive
5011 or 0 if it is negative (pick either one if it is zero). Optionally
5012 (if or_expr is present) OR the (expression != 0) condition to it. */
5015 gfc_conv_array_extent_dim (tree lbound
, tree ubound
, tree
* or_expr
)
5020 /* Calculate (ubound - lbound + 1). */
5021 res
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5023 res
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
, res
,
5024 gfc_index_one_node
);
5026 /* Check whether the size for this dimension is negative. */
5027 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, res
,
5028 gfc_index_zero_node
);
5029 res
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
, cond
,
5030 gfc_index_zero_node
, res
);
5032 /* Build OR expression. */
5034 *or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
5035 boolean_type_node
, *or_expr
, cond
);
5041 /* For an array descriptor, get the total number of elements. This is just
5042 the product of the extents along from_dim to to_dim. */
5045 gfc_conv_descriptor_size_1 (tree desc
, int from_dim
, int to_dim
)
5050 res
= gfc_index_one_node
;
5052 for (dim
= from_dim
; dim
< to_dim
; ++dim
)
5058 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]);
5059 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]);
5061 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
5062 res
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5070 /* Full size of an array. */
5073 gfc_conv_descriptor_size (tree desc
, int rank
)
5075 return gfc_conv_descriptor_size_1 (desc
, 0, rank
);
5079 /* Size of a coarray for all dimensions but the last. */
5082 gfc_conv_descriptor_cosize (tree desc
, int rank
, int corank
)
5084 return gfc_conv_descriptor_size_1 (desc
, rank
, rank
+ corank
- 1);
5088 /* Fills in an array descriptor, and returns the size of the array.
5089 The size will be a simple_val, ie a variable or a constant. Also
5090 calculates the offset of the base. The pointer argument overflow,
5091 which should be of integer type, will increase in value if overflow
5092 occurs during the size calculation. Returns the size of the array.
5096 for (n = 0; n < rank; n++)
5098 a.lbound[n] = specified_lower_bound;
5099 offset = offset + a.lbond[n] * stride;
5101 a.ubound[n] = specified_upper_bound;
5102 a.stride[n] = stride;
5103 size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
5104 overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
5105 stride = stride * size;
5107 for (n = rank; n < rank+corank; n++)
5108 (Set lcobound/ucobound as above.)
5109 element_size = sizeof (array element);
5112 stride = (size_t) stride;
5113 overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
5114 stride = stride * element_size;
5120 gfc_array_init_size (tree descriptor
, int rank
, int corank
, tree
* poffset
,
5121 gfc_expr
** lower
, gfc_expr
** upper
, stmtblock_t
* pblock
,
5122 stmtblock_t
* descriptor_block
, tree
* overflow
,
5123 tree expr3_elem_size
, tree
*nelems
, gfc_expr
*expr3
,
5124 tree expr3_desc
, bool e3_is_array_constr
, gfc_expr
*expr
)
5137 stmtblock_t thenblock
;
5138 stmtblock_t elseblock
;
5143 type
= TREE_TYPE (descriptor
);
5145 stride
= gfc_index_one_node
;
5146 offset
= gfc_index_zero_node
;
5148 /* Set the dtype before the alloc, because registration of coarrays needs
5150 if (expr
->ts
.type
== BT_CHARACTER
5151 && expr
->ts
.deferred
5152 && VAR_P (expr
->ts
.u
.cl
->backend_decl
))
5154 type
= gfc_typenode_for_spec (&expr
->ts
);
5155 tmp
= gfc_conv_descriptor_dtype (descriptor
);
5156 gfc_add_modify (pblock
, tmp
, gfc_get_dtype_rank_type (rank
, type
));
5160 tmp
= gfc_conv_descriptor_dtype (descriptor
);
5161 gfc_add_modify (pblock
, tmp
, gfc_get_dtype (type
));
5164 or_expr
= boolean_false_node
;
5166 for (n
= 0; n
< rank
; n
++)
5171 /* We have 3 possibilities for determining the size of the array:
5172 lower == NULL => lbound = 1, ubound = upper[n]
5173 upper[n] = NULL => lbound = 1, ubound = lower[n]
5174 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
5177 /* Set lower bound. */
5178 gfc_init_se (&se
, NULL
);
5179 if (expr3_desc
!= NULL_TREE
)
5181 if (e3_is_array_constr
)
5182 /* The lbound of a constant array [] starts at zero, but when
5183 allocating it, the standard expects the array to start at
5185 se
.expr
= gfc_index_one_node
;
5187 se
.expr
= gfc_conv_descriptor_lbound_get (expr3_desc
,
5190 else if (lower
== NULL
)
5191 se
.expr
= gfc_index_one_node
;
5194 gcc_assert (lower
[n
]);
5197 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
5198 gfc_add_block_to_block (pblock
, &se
.pre
);
5202 se
.expr
= gfc_index_one_node
;
5206 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
5207 gfc_rank_cst
[n
], se
.expr
);
5208 conv_lbound
= se
.expr
;
5210 /* Work out the offset for this component. */
5211 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5213 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
5214 gfc_array_index_type
, offset
, tmp
);
5216 /* Set upper bound. */
5217 gfc_init_se (&se
, NULL
);
5218 if (expr3_desc
!= NULL_TREE
)
5220 if (e3_is_array_constr
)
5222 /* The lbound of a constant array [] starts at zero, but when
5223 allocating it, the standard expects the array to start at
5224 one. Therefore fix the upper bound to be
5225 (desc.ubound - desc.lbound)+ 1. */
5226 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5227 gfc_array_index_type
,
5228 gfc_conv_descriptor_ubound_get (
5229 expr3_desc
, gfc_rank_cst
[n
]),
5230 gfc_conv_descriptor_lbound_get (
5231 expr3_desc
, gfc_rank_cst
[n
]));
5232 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5233 gfc_array_index_type
, tmp
,
5234 gfc_index_one_node
);
5235 se
.expr
= gfc_evaluate_now (tmp
, pblock
);
5238 se
.expr
= gfc_conv_descriptor_ubound_get (expr3_desc
,
5243 gcc_assert (ubound
);
5244 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
5245 gfc_add_block_to_block (pblock
, &se
.pre
);
5246 if (ubound
->expr_type
== EXPR_FUNCTION
)
5247 se
.expr
= gfc_evaluate_now (se
.expr
, pblock
);
5249 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
5250 gfc_rank_cst
[n
], se
.expr
);
5251 conv_ubound
= se
.expr
;
5253 /* Store the stride. */
5254 gfc_conv_descriptor_stride_set (descriptor_block
, descriptor
,
5255 gfc_rank_cst
[n
], stride
);
5257 /* Calculate size and check whether extent is negative. */
5258 size
= gfc_conv_array_extent_dim (conv_lbound
, conv_ubound
, &or_expr
);
5259 size
= gfc_evaluate_now (size
, pblock
);
5261 /* Check whether multiplying the stride by the number of
5262 elements in this dimension would overflow. We must also check
5263 whether the current dimension has zero size in order to avoid
5266 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
5267 gfc_array_index_type
,
5268 fold_convert (gfc_array_index_type
,
5269 TYPE_MAX_VALUE (gfc_array_index_type
)),
5271 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
5272 boolean_type_node
, tmp
, stride
),
5273 PRED_FORTRAN_OVERFLOW
);
5274 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5275 integer_one_node
, integer_zero_node
);
5276 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
5277 boolean_type_node
, size
,
5278 gfc_index_zero_node
),
5279 PRED_FORTRAN_SIZE_ZERO
);
5280 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5281 integer_zero_node
, tmp
);
5282 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
5284 *overflow
= gfc_evaluate_now (tmp
, pblock
);
5286 /* Multiply the stride by the number of elements in this dimension. */
5287 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
5288 gfc_array_index_type
, stride
, size
);
5289 stride
= gfc_evaluate_now (stride
, pblock
);
5292 for (n
= rank
; n
< rank
+ corank
; n
++)
5296 /* Set lower bound. */
5297 gfc_init_se (&se
, NULL
);
5298 if (lower
== NULL
|| lower
[n
] == NULL
)
5300 gcc_assert (n
== rank
+ corank
- 1);
5301 se
.expr
= gfc_index_one_node
;
5305 if (ubound
|| n
== rank
+ corank
- 1)
5307 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
5308 gfc_add_block_to_block (pblock
, &se
.pre
);
5312 se
.expr
= gfc_index_one_node
;
5316 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
5317 gfc_rank_cst
[n
], se
.expr
);
5319 if (n
< rank
+ corank
- 1)
5321 gfc_init_se (&se
, NULL
);
5322 gcc_assert (ubound
);
5323 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
5324 gfc_add_block_to_block (pblock
, &se
.pre
);
5325 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
5326 gfc_rank_cst
[n
], se
.expr
);
5330 /* The stride is the number of elements in the array, so multiply by the
5331 size of an element to get the total size. Obviously, if there is a
5332 SOURCE expression (expr3) we must use its element size. */
5333 if (expr3_elem_size
!= NULL_TREE
)
5334 tmp
= expr3_elem_size
;
5335 else if (expr3
!= NULL
)
5337 if (expr3
->ts
.type
== BT_CLASS
)
5340 gfc_expr
*sz
= gfc_copy_expr (expr3
);
5341 gfc_add_vptr_component (sz
);
5342 gfc_add_size_component (sz
);
5343 gfc_init_se (&se_sz
, NULL
);
5344 gfc_conv_expr (&se_sz
, sz
);
5350 tmp
= gfc_typenode_for_spec (&expr3
->ts
);
5351 tmp
= TYPE_SIZE_UNIT (tmp
);
5355 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
5357 /* Convert to size_t. */
5358 element_size
= fold_convert (size_type_node
, tmp
);
5361 return element_size
;
5363 *nelems
= gfc_evaluate_now (stride
, pblock
);
5364 stride
= fold_convert (size_type_node
, stride
);
5366 /* First check for overflow. Since an array of type character can
5367 have zero element_size, we must check for that before
5369 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
5371 TYPE_MAX_VALUE (size_type_node
), element_size
);
5372 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
5373 boolean_type_node
, tmp
, stride
),
5374 PRED_FORTRAN_OVERFLOW
);
5375 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5376 integer_one_node
, integer_zero_node
);
5377 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
5378 boolean_type_node
, element_size
,
5379 build_int_cst (size_type_node
, 0)),
5380 PRED_FORTRAN_SIZE_ZERO
);
5381 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5382 integer_zero_node
, tmp
);
5383 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
5385 *overflow
= gfc_evaluate_now (tmp
, pblock
);
5387 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5388 stride
, element_size
);
5390 if (poffset
!= NULL
)
5392 offset
= gfc_evaluate_now (offset
, pblock
);
5396 if (integer_zerop (or_expr
))
5398 if (integer_onep (or_expr
))
5399 return build_int_cst (size_type_node
, 0);
5401 var
= gfc_create_var (TREE_TYPE (size
), "size");
5402 gfc_start_block (&thenblock
);
5403 gfc_add_modify (&thenblock
, var
, build_int_cst (size_type_node
, 0));
5404 thencase
= gfc_finish_block (&thenblock
);
5406 gfc_start_block (&elseblock
);
5407 gfc_add_modify (&elseblock
, var
, size
);
5408 elsecase
= gfc_finish_block (&elseblock
);
5410 tmp
= gfc_evaluate_now (or_expr
, pblock
);
5411 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
5412 gfc_add_expr_to_block (pblock
, tmp
);
5418 /* Retrieve the last ref from the chain. This routine is specific to
5419 gfc_array_allocate ()'s needs. */
5422 retrieve_last_ref (gfc_ref
**ref_in
, gfc_ref
**prev_ref_in
)
5424 gfc_ref
*ref
, *prev_ref
;
5427 /* Prevent warnings for uninitialized variables. */
5428 prev_ref
= *prev_ref_in
;
5429 while (ref
&& ref
->next
!= NULL
)
5431 gcc_assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
5432 || (ref
->u
.ar
.dimen
== 0 && ref
->u
.ar
.codimen
> 0));
5437 if (ref
== NULL
|| ref
->type
!= REF_ARRAY
)
5441 *prev_ref_in
= prev_ref
;
5445 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
5446 the work for an ALLOCATE statement. */
5450 gfc_array_allocate (gfc_se
* se
, gfc_expr
* expr
, tree status
, tree errmsg
,
5451 tree errlen
, tree label_finish
, tree expr3_elem_size
,
5452 tree
*nelems
, gfc_expr
*expr3
, tree e3_arr_desc
,
5453 bool e3_is_array_constr
)
5457 tree offset
= NULL_TREE
;
5458 tree token
= NULL_TREE
;
5461 tree error
= NULL_TREE
;
5462 tree overflow
; /* Boolean storing whether size calculation overflows. */
5463 tree var_overflow
= NULL_TREE
;
5465 tree set_descriptor
;
5466 stmtblock_t set_descriptor_block
;
5467 stmtblock_t elseblock
;
5470 gfc_ref
*ref
, *prev_ref
= NULL
, *coref
;
5471 bool allocatable
, coarray
, dimension
, alloc_w_e3_arr_spec
= false,
5472 non_ulimate_coarray_ptr_comp
;
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
;
5486 non_ulimate_coarray_ptr_comp
= false;
5490 allocatable
= prev_ref
->u
.c
.component
->attr
.allocatable
;
5491 /* Pointer components in coarrayed derived types must be treated
5492 specially in that they are registered without a check if the are
5493 already associated. This does not hold for ultimate coarray
5495 non_ulimate_coarray_ptr_comp
= (prev_ref
->u
.c
.component
->attr
.pointer
5496 && !prev_ref
->u
.c
.component
->attr
.codimension
);
5497 dimension
= prev_ref
->u
.c
.component
->attr
.dimension
;
5500 /* For allocatable/pointer arrays in derived types, one of the refs has to be
5501 a coarray. In this case it does not matter whether we are on this_image
5504 for (coref
= expr
->ref
; coref
; coref
= coref
->next
)
5505 if (coref
->type
== REF_ARRAY
&& coref
->u
.ar
.codimen
> 0)
5512 gcc_assert (coarray
);
5514 if (ref
->u
.ar
.type
== AR_FULL
&& expr3
!= NULL
)
5516 gfc_ref
*old_ref
= ref
;
5517 /* F08:C633: Array shape from expr3. */
5520 /* Find the last reference in the chain. */
5521 if (!retrieve_last_ref (&ref
, &prev_ref
))
5523 if (expr3
->expr_type
== EXPR_FUNCTION
5524 && gfc_expr_attr (expr3
).dimension
)
5529 alloc_w_e3_arr_spec
= true;
5532 /* Figure out the size of the array. */
5533 switch (ref
->u
.ar
.type
)
5539 upper
= ref
->u
.ar
.start
;
5545 lower
= ref
->u
.ar
.start
;
5546 upper
= ref
->u
.ar
.end
;
5550 gcc_assert (ref
->u
.ar
.as
->type
== AS_EXPLICIT
5551 || alloc_w_e3_arr_spec
);
5553 lower
= ref
->u
.ar
.as
->lower
;
5554 upper
= ref
->u
.ar
.as
->upper
;
5562 overflow
= integer_zero_node
;
5564 gfc_init_block (&set_descriptor_block
);
5565 /* Take the corank only from the actual ref and not from the coref. The
5566 later will mislead the generation of the array dimensions for allocatable/
5567 pointer components in derived types. */
5568 size
= gfc_array_init_size (se
->expr
, alloc_w_e3_arr_spec
? expr
->rank
5569 : ref
->u
.ar
.as
->rank
,
5570 coarray
? ref
->u
.ar
.as
->corank
: 0,
5571 &offset
, lower
, upper
,
5572 &se
->pre
, &set_descriptor_block
, &overflow
,
5573 expr3_elem_size
, nelems
, expr3
, e3_arr_desc
,
5574 e3_is_array_constr
, expr
);
5578 var_overflow
= gfc_create_var (integer_type_node
, "overflow");
5579 gfc_add_modify (&se
->pre
, var_overflow
, overflow
);
5581 if (status
== NULL_TREE
)
5583 /* Generate the block of code handling overflow. */
5584 msg
= gfc_build_addr_expr (pchar_type_node
,
5585 gfc_build_localized_cstring_const
5586 ("Integer overflow when calculating the amount of "
5587 "memory to allocate"));
5588 error
= build_call_expr_loc (input_location
,
5589 gfor_fndecl_runtime_error
, 1, msg
);
5593 tree status_type
= TREE_TYPE (status
);
5594 stmtblock_t set_status_block
;
5596 gfc_start_block (&set_status_block
);
5597 gfc_add_modify (&set_status_block
, status
,
5598 build_int_cst (status_type
, LIBERROR_ALLOCATION
));
5599 error
= gfc_finish_block (&set_status_block
);
5603 gfc_start_block (&elseblock
);
5605 /* Allocate memory to store the data. */
5606 if (POINTER_TYPE_P (TREE_TYPE (se
->expr
)))
5607 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
5609 if (coarray
&& flag_coarray
== GFC_FCOARRAY_LIB
)
5611 pointer
= non_ulimate_coarray_ptr_comp
? se
->expr
5612 : gfc_conv_descriptor_data_get (se
->expr
);
5613 token
= gfc_conv_descriptor_token (se
->expr
);
5614 token
= gfc_build_addr_expr (NULL_TREE
, token
);
5617 pointer
= gfc_conv_descriptor_data_get (se
->expr
);
5618 STRIP_NOPS (pointer
);
5620 /* The allocatable variant takes the old pointer as first argument. */
5622 gfc_allocate_allocatable (&elseblock
, pointer
, size
, token
,
5623 status
, errmsg
, errlen
, label_finish
, expr
,
5624 coref
!= NULL
? coref
->u
.ar
.as
->corank
: 0);
5625 else if (non_ulimate_coarray_ptr_comp
&& token
)
5626 /* The token is set only for GFC_FCOARRAY_LIB mode. */
5627 gfc_allocate_using_caf_lib (&elseblock
, pointer
, size
, token
, status
,
5629 GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY
);
5631 gfc_allocate_using_malloc (&elseblock
, pointer
, size
, status
);
5635 cond
= gfc_unlikely (fold_build2_loc (input_location
, NE_EXPR
,
5636 boolean_type_node
, var_overflow
, integer_zero_node
),
5637 PRED_FORTRAN_OVERFLOW
);
5638 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
5639 error
, gfc_finish_block (&elseblock
));
5642 tmp
= gfc_finish_block (&elseblock
);
5644 gfc_add_expr_to_block (&se
->pre
, tmp
);
5646 /* Update the array descriptors. */
5648 gfc_conv_descriptor_offset_set (&set_descriptor_block
, se
->expr
, offset
);
5650 set_descriptor
= gfc_finish_block (&set_descriptor_block
);
5651 if (status
!= NULL_TREE
)
5653 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
5654 boolean_type_node
, status
,
5655 build_int_cst (TREE_TYPE (status
), 0));
5656 gfc_add_expr_to_block (&se
->pre
,
5657 fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5660 build_empty_stmt (input_location
)));
5663 gfc_add_expr_to_block (&se
->pre
, set_descriptor
);
5669 /* Create an array constructor from an initialization expression.
5670 We assume the frontend already did any expansions and conversions. */
5673 gfc_conv_array_initializer (tree type
, gfc_expr
* expr
)
5680 vec
<constructor_elt
, va_gc
> *v
= NULL
;
5682 if (expr
->expr_type
== EXPR_VARIABLE
5683 && expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
5684 && expr
->symtree
->n
.sym
->value
)
5685 expr
= expr
->symtree
->n
.sym
->value
;
5687 switch (expr
->expr_type
)
5690 case EXPR_STRUCTURE
:
5691 /* A single scalar or derived type value. Create an array with all
5692 elements equal to that value. */
5693 gfc_init_se (&se
, NULL
);
5695 if (expr
->expr_type
== EXPR_CONSTANT
)
5696 gfc_conv_constant (&se
, expr
);
5698 gfc_conv_structure (&se
, expr
, 1);
5700 wtmp
= wi::to_offset (TYPE_MAX_VALUE (TYPE_DOMAIN (type
))) + 1;
5701 /* This will probably eat buckets of memory for large arrays. */
5704 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
, se
.expr
);
5710 /* Create a vector of all the elements. */
5711 for (c
= gfc_constructor_first (expr
->value
.constructor
);
5712 c
; c
= gfc_constructor_next (c
))
5716 /* Problems occur when we get something like
5717 integer :: a(lots) = (/(i, i=1, lots)/) */
5718 gfc_fatal_error ("The number of elements in the array "
5719 "constructor at %L requires an increase of "
5720 "the allowed %d upper limit. See "
5721 "%<-fmax-array-constructor%> option",
5722 &expr
->where
, flag_max_array_constructor
);
5725 if (mpz_cmp_si (c
->offset
, 0) != 0)
5726 index
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
5730 if (mpz_cmp_si (c
->repeat
, 1) > 0)
5736 mpz_add (maxval
, c
->offset
, c
->repeat
);
5737 mpz_sub_ui (maxval
, maxval
, 1);
5738 tmp2
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
5739 if (mpz_cmp_si (c
->offset
, 0) != 0)
5741 mpz_add_ui (maxval
, c
->offset
, 1);
5742 tmp1
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
5745 tmp1
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
5747 range
= fold_build2 (RANGE_EXPR
, gfc_array_index_type
, tmp1
, tmp2
);
5753 gfc_init_se (&se
, NULL
);
5754 switch (c
->expr
->expr_type
)
5757 gfc_conv_constant (&se
, c
->expr
);
5760 case EXPR_STRUCTURE
:
5761 gfc_conv_structure (&se
, c
->expr
, 1);
5765 /* Catch those occasional beasts that do not simplify
5766 for one reason or another, assuming that if they are
5767 standard defying the frontend will catch them. */
5768 gfc_conv_expr (&se
, c
->expr
);
5772 if (range
== NULL_TREE
)
5773 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
5776 if (index
!= NULL_TREE
)
5777 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
5778 CONSTRUCTOR_APPEND_ELT (v
, range
, se
.expr
);
5784 return gfc_build_null_descriptor (type
);
5790 /* Create a constructor from the list of elements. */
5791 tmp
= build_constructor (type
, v
);
5792 TREE_CONSTANT (tmp
) = 1;
5797 /* Generate code to evaluate non-constant coarray cobounds. */
5800 gfc_trans_array_cobounds (tree type
, stmtblock_t
* pblock
,
5801 const gfc_symbol
*sym
)
5809 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
5811 for (dim
= as
->rank
; dim
< as
->rank
+ as
->corank
; dim
++)
5813 /* Evaluate non-constant array bound expressions. */
5814 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
5815 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
5817 gfc_init_se (&se
, NULL
);
5818 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
5819 gfc_add_block_to_block (pblock
, &se
.pre
);
5820 gfc_add_modify (pblock
, lbound
, se
.expr
);
5822 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
5823 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
5825 gfc_init_se (&se
, NULL
);
5826 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
5827 gfc_add_block_to_block (pblock
, &se
.pre
);
5828 gfc_add_modify (pblock
, ubound
, se
.expr
);
5834 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
5835 returns the size (in elements) of the array. */
5838 gfc_trans_array_bounds (tree type
, gfc_symbol
* sym
, tree
* poffset
,
5839 stmtblock_t
* pblock
)
5852 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
5854 size
= gfc_index_one_node
;
5855 offset
= gfc_index_zero_node
;
5856 for (dim
= 0; dim
< as
->rank
; dim
++)
5858 /* Evaluate non-constant array bound expressions. */
5859 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
5860 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
5862 gfc_init_se (&se
, NULL
);
5863 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
5864 gfc_add_block_to_block (pblock
, &se
.pre
);
5865 gfc_add_modify (pblock
, lbound
, se
.expr
);
5867 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
5868 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
5870 gfc_init_se (&se
, NULL
);
5871 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
5872 gfc_add_block_to_block (pblock
, &se
.pre
);
5873 gfc_add_modify (pblock
, ubound
, se
.expr
);
5875 /* The offset of this dimension. offset = offset - lbound * stride. */
5876 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5878 offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5881 /* The size of this dimension, and the stride of the next. */
5882 if (dim
+ 1 < as
->rank
)
5883 stride
= GFC_TYPE_ARRAY_STRIDE (type
, dim
+ 1);
5885 stride
= GFC_TYPE_ARRAY_SIZE (type
);
5887 if (ubound
!= NULL_TREE
&& !(stride
&& INTEGER_CST_P (stride
)))
5889 /* Calculate stride = size * (ubound + 1 - lbound). */
5890 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5891 gfc_array_index_type
,
5892 gfc_index_one_node
, lbound
);
5893 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5894 gfc_array_index_type
, ubound
, tmp
);
5895 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5896 gfc_array_index_type
, size
, tmp
);
5898 gfc_add_modify (pblock
, stride
, tmp
);
5900 stride
= gfc_evaluate_now (tmp
, pblock
);
5902 /* Make sure that negative size arrays are translated
5903 to being zero size. */
5904 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
5905 stride
, gfc_index_zero_node
);
5906 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5907 gfc_array_index_type
, tmp
,
5908 stride
, gfc_index_zero_node
);
5909 gfc_add_modify (pblock
, stride
, tmp
);
5915 gfc_trans_array_cobounds (type
, pblock
, sym
);
5916 gfc_trans_vla_type_sizes (sym
, pblock
);
5923 /* Generate code to initialize/allocate an array variable. */
5926 gfc_trans_auto_array_allocation (tree decl
, gfc_symbol
* sym
,
5927 gfc_wrapped_block
* block
)
5931 tree tmp
= NULL_TREE
;
5938 gcc_assert (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
));
5940 /* Do nothing for USEd variables. */
5941 if (sym
->attr
.use_assoc
)
5944 type
= TREE_TYPE (decl
);
5945 gcc_assert (GFC_ARRAY_TYPE_P (type
));
5946 onstack
= TREE_CODE (type
) != POINTER_TYPE
;
5948 gfc_init_block (&init
);
5950 /* Evaluate character string length. */
5951 if (sym
->ts
.type
== BT_CHARACTER
5952 && onstack
&& !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
5954 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
5956 gfc_trans_vla_type_sizes (sym
, &init
);
5958 /* Emit a DECL_EXPR for this variable, which will cause the
5959 gimplifier to allocate storage, and all that good stuff. */
5960 tmp
= fold_build1_loc (input_location
, DECL_EXPR
, TREE_TYPE (decl
), decl
);
5961 gfc_add_expr_to_block (&init
, tmp
);
5966 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
5970 type
= TREE_TYPE (type
);
5972 gcc_assert (!sym
->attr
.use_assoc
);
5973 gcc_assert (!TREE_STATIC (decl
));
5974 gcc_assert (!sym
->module
);
5976 if (sym
->ts
.type
== BT_CHARACTER
5977 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
5978 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
5980 size
= gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
5982 /* Don't actually allocate space for Cray Pointees. */
5983 if (sym
->attr
.cray_pointee
)
5985 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
5986 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
5988 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
5992 if (flag_stack_arrays
)
5994 gcc_assert (TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
);
5995 space
= build_decl (sym
->declared_at
.lb
->location
,
5996 VAR_DECL
, create_tmp_var_name ("A"),
5997 TREE_TYPE (TREE_TYPE (decl
)));
5998 gfc_trans_vla_type_sizes (sym
, &init
);
6002 /* The size is the number of elements in the array, so multiply by the
6003 size of an element to get the total size. */
6004 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
6005 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6006 size
, fold_convert (gfc_array_index_type
, tmp
));
6008 /* Allocate memory to hold the data. */
6009 tmp
= gfc_call_malloc (&init
, TREE_TYPE (decl
), size
);
6010 gfc_add_modify (&init
, decl
, tmp
);
6012 /* Free the temporary. */
6013 tmp
= gfc_call_free (decl
);
6017 /* Set offset of the array. */
6018 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6019 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6021 /* Automatic arrays should not have initializers. */
6022 gcc_assert (!sym
->value
);
6024 inittree
= gfc_finish_block (&init
);
6031 /* Don't create new scope, emit the DECL_EXPR in exactly the scope
6032 where also space is located. */
6033 gfc_init_block (&init
);
6034 tmp
= fold_build1_loc (input_location
, DECL_EXPR
,
6035 TREE_TYPE (space
), space
);
6036 gfc_add_expr_to_block (&init
, tmp
);
6037 addr
= fold_build1_loc (sym
->declared_at
.lb
->location
,
6038 ADDR_EXPR
, TREE_TYPE (decl
), space
);
6039 gfc_add_modify (&init
, decl
, addr
);
6040 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6043 gfc_add_init_cleanup (block
, inittree
, tmp
);
6047 /* Generate entry and exit code for g77 calling convention arrays. */
6050 gfc_trans_g77_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
6060 gfc_save_backend_locus (&loc
);
6061 gfc_set_backend_locus (&sym
->declared_at
);
6063 /* Descriptor type. */
6064 parm
= sym
->backend_decl
;
6065 type
= TREE_TYPE (parm
);
6066 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6068 gfc_start_block (&init
);
6070 if (sym
->ts
.type
== BT_CHARACTER
6071 && VAR_P (sym
->ts
.u
.cl
->backend_decl
))
6072 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6074 /* Evaluate the bounds of the array. */
6075 gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
6077 /* Set the offset. */
6078 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6079 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6081 /* Set the pointer itself if we aren't using the parameter directly. */
6082 if (TREE_CODE (parm
) != PARM_DECL
)
6084 tmp
= convert (TREE_TYPE (parm
), GFC_DECL_SAVED_DESCRIPTOR (parm
));
6085 gfc_add_modify (&init
, parm
, tmp
);
6087 stmt
= gfc_finish_block (&init
);
6089 gfc_restore_backend_locus (&loc
);
6091 /* Add the initialization code to the start of the function. */
6093 if (sym
->attr
.optional
|| sym
->attr
.not_always_present
)
6095 tmp
= gfc_conv_expr_present (sym
);
6096 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
6099 gfc_add_init_cleanup (block
, stmt
, NULL_TREE
);
6103 /* Modify the descriptor of an array parameter so that it has the
6104 correct lower bound. Also move the upper bound accordingly.
6105 If the array is not packed, it will be copied into a temporary.
6106 For each dimension we set the new lower and upper bounds. Then we copy the
6107 stride and calculate the offset for this dimension. We also work out
6108 what the stride of a packed array would be, and see it the two match.
6109 If the array need repacking, we set the stride to the values we just
6110 calculated, recalculate the offset and copy the array data.
6111 Code is also added to copy the data back at the end of the function.
6115 gfc_trans_dummy_array_bias (gfc_symbol
* sym
, tree tmpdesc
,
6116 gfc_wrapped_block
* block
)
6123 tree stmtInit
, stmtCleanup
;
6130 tree stride
, stride2
;
6140 bool is_classarray
= IS_CLASS_ARRAY (sym
);
6142 /* Do nothing for pointer and allocatable arrays. */
6143 if ((sym
->ts
.type
!= BT_CLASS
&& sym
->attr
.pointer
)
6144 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.class_pointer
)
6145 || sym
->attr
.allocatable
6146 || (is_classarray
&& CLASS_DATA (sym
)->attr
.allocatable
))
6149 if (!is_classarray
&& sym
->attr
.dummy
&& gfc_is_nodesc_array (sym
))
6151 gfc_trans_g77_array (sym
, block
);
6156 gfc_save_backend_locus (&loc
);
6157 /* loc.nextc is not set by save_backend_locus but the location routines
6159 if (loc
.nextc
== NULL
)
6160 loc
.nextc
= loc
.lb
->line
;
6161 gfc_set_backend_locus (&sym
->declared_at
);
6163 /* Descriptor type. */
6164 type
= TREE_TYPE (tmpdesc
);
6165 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6166 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6168 /* For a class array the dummy array descriptor is in the _class
6170 dumdesc
= gfc_class_data_get (dumdesc
);
6172 dumdesc
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
6173 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
6174 gfc_start_block (&init
);
6176 if (sym
->ts
.type
== BT_CHARACTER
6177 && VAR_P (sym
->ts
.u
.cl
->backend_decl
))
6178 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6180 checkparm
= (as
->type
== AS_EXPLICIT
6181 && (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
));
6183 no_repack
= !(GFC_DECL_PACKED_ARRAY (tmpdesc
)
6184 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
));
6186 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
))
6188 /* For non-constant shape arrays we only check if the first dimension
6189 is contiguous. Repacking higher dimensions wouldn't gain us
6190 anything as we still don't know the array stride. */
6191 partial
= gfc_create_var (boolean_type_node
, "partial");
6192 TREE_USED (partial
) = 1;
6193 tmp
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
6194 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, tmp
,
6195 gfc_index_one_node
);
6196 gfc_add_modify (&init
, partial
, tmp
);
6199 partial
= NULL_TREE
;
6201 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
6202 here, however I think it does the right thing. */
6205 /* Set the first stride. */
6206 stride
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
6207 stride
= gfc_evaluate_now (stride
, &init
);
6209 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
6210 stride
, gfc_index_zero_node
);
6211 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
6212 tmp
, gfc_index_one_node
, stride
);
6213 stride
= GFC_TYPE_ARRAY_STRIDE (type
, 0);
6214 gfc_add_modify (&init
, stride
, tmp
);
6216 /* Allow the user to disable array repacking. */
6217 stmt_unpacked
= NULL_TREE
;
6221 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type
, 0)));
6222 /* A library call to repack the array if necessary. */
6223 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6224 stmt_unpacked
= build_call_expr_loc (input_location
,
6225 gfor_fndecl_in_pack
, 1, tmp
);
6227 stride
= gfc_index_one_node
;
6229 if (warn_array_temporaries
)
6230 gfc_warning (OPT_Warray_temporaries
,
6231 "Creating array temporary at %L", &loc
);
6234 /* This is for the case where the array data is used directly without
6235 calling the repack function. */
6236 if (no_repack
|| partial
!= NULL_TREE
)
6237 stmt_packed
= gfc_conv_descriptor_data_get (dumdesc
);
6239 stmt_packed
= NULL_TREE
;
6241 /* Assign the data pointer. */
6242 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
6244 /* Don't repack unknown shape arrays when the first stride is 1. */
6245 tmp
= fold_build3_loc (input_location
, COND_EXPR
, TREE_TYPE (stmt_packed
),
6246 partial
, stmt_packed
, stmt_unpacked
);
6249 tmp
= stmt_packed
!= NULL_TREE
? stmt_packed
: stmt_unpacked
;
6250 gfc_add_modify (&init
, tmpdesc
, fold_convert (type
, tmp
));
6252 offset
= gfc_index_zero_node
;
6253 size
= gfc_index_one_node
;
6255 /* Evaluate the bounds of the array. */
6256 for (n
= 0; n
< as
->rank
; n
++)
6258 if (checkparm
|| !as
->upper
[n
])
6260 /* Get the bounds of the actual parameter. */
6261 dubound
= gfc_conv_descriptor_ubound_get (dumdesc
, gfc_rank_cst
[n
]);
6262 dlbound
= gfc_conv_descriptor_lbound_get (dumdesc
, gfc_rank_cst
[n
]);
6266 dubound
= NULL_TREE
;
6267 dlbound
= NULL_TREE
;
6270 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, n
);
6271 if (!INTEGER_CST_P (lbound
))
6273 gfc_init_se (&se
, NULL
);
6274 gfc_conv_expr_type (&se
, as
->lower
[n
],
6275 gfc_array_index_type
);
6276 gfc_add_block_to_block (&init
, &se
.pre
);
6277 gfc_add_modify (&init
, lbound
, se
.expr
);
6280 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, n
);
6281 /* Set the desired upper bound. */
6284 /* We know what we want the upper bound to be. */
6285 if (!INTEGER_CST_P (ubound
))
6287 gfc_init_se (&se
, NULL
);
6288 gfc_conv_expr_type (&se
, as
->upper
[n
],
6289 gfc_array_index_type
);
6290 gfc_add_block_to_block (&init
, &se
.pre
);
6291 gfc_add_modify (&init
, ubound
, se
.expr
);
6294 /* Check the sizes match. */
6297 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
6301 temp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6302 gfc_array_index_type
, ubound
, lbound
);
6303 temp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6304 gfc_array_index_type
,
6305 gfc_index_one_node
, temp
);
6306 stride2
= fold_build2_loc (input_location
, MINUS_EXPR
,
6307 gfc_array_index_type
, dubound
,
6309 stride2
= fold_build2_loc (input_location
, PLUS_EXPR
,
6310 gfc_array_index_type
,
6311 gfc_index_one_node
, stride2
);
6312 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6313 gfc_array_index_type
, temp
, stride2
);
6314 msg
= xasprintf ("Dimension %d of array '%s' has extent "
6315 "%%ld instead of %%ld", n
+1, sym
->name
);
6317 gfc_trans_runtime_check (true, false, tmp
, &init
, &loc
, msg
,
6318 fold_convert (long_integer_type_node
, temp
),
6319 fold_convert (long_integer_type_node
, stride2
));
6326 /* For assumed shape arrays move the upper bound by the same amount
6327 as the lower bound. */
6328 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6329 gfc_array_index_type
, dubound
, dlbound
);
6330 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6331 gfc_array_index_type
, tmp
, lbound
);
6332 gfc_add_modify (&init
, ubound
, tmp
);
6334 /* The offset of this dimension. offset = offset - lbound * stride. */
6335 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6337 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
6338 gfc_array_index_type
, offset
, tmp
);
6340 /* The size of this dimension, and the stride of the next. */
6341 if (n
+ 1 < as
->rank
)
6343 stride
= GFC_TYPE_ARRAY_STRIDE (type
, n
+ 1);
6345 if (no_repack
|| partial
!= NULL_TREE
)
6347 gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[n
+1]);
6349 /* Figure out the stride if not a known constant. */
6350 if (!INTEGER_CST_P (stride
))
6353 stmt_packed
= NULL_TREE
;
6356 /* Calculate stride = size * (ubound + 1 - lbound). */
6357 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6358 gfc_array_index_type
,
6359 gfc_index_one_node
, lbound
);
6360 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6361 gfc_array_index_type
, ubound
, tmp
);
6362 size
= fold_build2_loc (input_location
, MULT_EXPR
,
6363 gfc_array_index_type
, size
, tmp
);
6367 /* Assign the stride. */
6368 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
6369 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6370 gfc_array_index_type
, partial
,
6371 stmt_unpacked
, stmt_packed
);
6373 tmp
= (stmt_packed
!= NULL_TREE
) ? stmt_packed
: stmt_unpacked
;
6374 gfc_add_modify (&init
, stride
, tmp
);
6379 stride
= GFC_TYPE_ARRAY_SIZE (type
);
6381 if (stride
&& !INTEGER_CST_P (stride
))
6383 /* Calculate size = stride * (ubound + 1 - lbound). */
6384 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6385 gfc_array_index_type
,
6386 gfc_index_one_node
, lbound
);
6387 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6388 gfc_array_index_type
,
6390 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6391 gfc_array_index_type
,
6392 GFC_TYPE_ARRAY_STRIDE (type
, n
), tmp
);
6393 gfc_add_modify (&init
, stride
, tmp
);
6398 gfc_trans_array_cobounds (type
, &init
, sym
);
6400 /* Set the offset. */
6401 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6402 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6404 gfc_trans_vla_type_sizes (sym
, &init
);
6406 stmtInit
= gfc_finish_block (&init
);
6408 /* Only do the entry/initialization code if the arg is present. */
6409 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6410 optional_arg
= (sym
->attr
.optional
6411 || (sym
->ns
->proc_name
->attr
.entry_master
6412 && sym
->attr
.dummy
));
6415 tmp
= gfc_conv_expr_present (sym
);
6416 stmtInit
= build3_v (COND_EXPR
, tmp
, stmtInit
,
6417 build_empty_stmt (input_location
));
6422 stmtCleanup
= NULL_TREE
;
6425 stmtblock_t cleanup
;
6426 gfc_start_block (&cleanup
);
6428 if (sym
->attr
.intent
!= INTENT_IN
)
6430 /* Copy the data back. */
6431 tmp
= build_call_expr_loc (input_location
,
6432 gfor_fndecl_in_unpack
, 2, dumdesc
, tmpdesc
);
6433 gfc_add_expr_to_block (&cleanup
, tmp
);
6436 /* Free the temporary. */
6437 tmp
= gfc_call_free (tmpdesc
);
6438 gfc_add_expr_to_block (&cleanup
, tmp
);
6440 stmtCleanup
= gfc_finish_block (&cleanup
);
6442 /* Only do the cleanup if the array was repacked. */
6444 /* For a class array the dummy array descriptor is in the _class
6446 tmp
= gfc_class_data_get (dumdesc
);
6448 tmp
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
6449 tmp
= gfc_conv_descriptor_data_get (tmp
);
6450 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6452 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6453 build_empty_stmt (input_location
));
6457 tmp
= gfc_conv_expr_present (sym
);
6458 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6459 build_empty_stmt (input_location
));
6463 /* We don't need to free any memory allocated by internal_pack as it will
6464 be freed at the end of the function by pop_context. */
6465 gfc_add_init_cleanup (block
, stmtInit
, stmtCleanup
);
6467 gfc_restore_backend_locus (&loc
);
6471 /* Calculate the overall offset, including subreferences. */
6473 gfc_get_dataptr_offset (stmtblock_t
*block
, tree parm
, tree desc
, tree offset
,
6474 bool subref
, gfc_expr
*expr
)
6484 /* If offset is NULL and this is not a subreferenced array, there is
6486 if (offset
== NULL_TREE
)
6489 offset
= gfc_index_zero_node
;
6494 tmp
= build_array_ref (desc
, offset
, NULL
, NULL
);
6496 /* Offset the data pointer for pointer assignments from arrays with
6497 subreferences; e.g. my_integer => my_type(:)%integer_component. */
6500 /* Go past the array reference. */
6501 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6502 if (ref
->type
== REF_ARRAY
&&
6503 ref
->u
.ar
.type
!= AR_ELEMENT
)
6509 /* Calculate the offset for each subsequent subreference. */
6510 for (; ref
; ref
= ref
->next
)
6515 field
= ref
->u
.c
.component
->backend_decl
;
6516 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
6517 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
6519 tmp
, field
, NULL_TREE
);
6523 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
6524 gfc_init_se (&start
, NULL
);
6525 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
6526 gfc_add_block_to_block (block
, &start
.pre
);
6527 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
6531 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
6532 && ref
->u
.ar
.type
== AR_ELEMENT
);
6534 /* TODO - Add bounds checking. */
6535 stride
= gfc_index_one_node
;
6536 index
= gfc_index_zero_node
;
6537 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
6542 /* Update the index. */
6543 gfc_init_se (&start
, NULL
);
6544 gfc_conv_expr_type (&start
, ref
->u
.ar
.start
[n
], gfc_array_index_type
);
6545 itmp
= gfc_evaluate_now (start
.expr
, block
);
6546 gfc_init_se (&start
, NULL
);
6547 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->lower
[n
], gfc_array_index_type
);
6548 jtmp
= gfc_evaluate_now (start
.expr
, block
);
6549 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6550 gfc_array_index_type
, itmp
, jtmp
);
6551 itmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6552 gfc_array_index_type
, itmp
, stride
);
6553 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
6554 gfc_array_index_type
, itmp
, index
);
6555 index
= gfc_evaluate_now (index
, block
);
6557 /* Update the stride. */
6558 gfc_init_se (&start
, NULL
);
6559 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->upper
[n
], gfc_array_index_type
);
6560 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6561 gfc_array_index_type
, start
.expr
,
6563 itmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6564 gfc_array_index_type
,
6565 gfc_index_one_node
, itmp
);
6566 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
6567 gfc_array_index_type
, stride
, itmp
);
6568 stride
= gfc_evaluate_now (stride
, block
);
6571 /* Apply the index to obtain the array element. */
6572 tmp
= gfc_build_array_ref (tmp
, index
, NULL
);
6582 /* Set the target data pointer. */
6583 offset
= gfc_build_addr_expr (gfc_array_dataptr_type (desc
), tmp
);
6584 gfc_conv_descriptor_data_set (block
, parm
, offset
);
6588 /* gfc_conv_expr_descriptor needs the string length an expression
6589 so that the size of the temporary can be obtained. This is done
6590 by adding up the string lengths of all the elements in the
6591 expression. Function with non-constant expressions have their
6592 string lengths mapped onto the actual arguments using the
6593 interface mapping machinery in trans-expr.c. */
6595 get_array_charlen (gfc_expr
*expr
, gfc_se
*se
)
6597 gfc_interface_mapping mapping
;
6598 gfc_formal_arglist
*formal
;
6599 gfc_actual_arglist
*arg
;
6602 if (expr
->ts
.u
.cl
->length
6603 && gfc_is_constant_expr (expr
->ts
.u
.cl
->length
))
6605 if (!expr
->ts
.u
.cl
->backend_decl
)
6606 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6610 switch (expr
->expr_type
)
6613 get_array_charlen (expr
->value
.op
.op1
, se
);
6615 /* For parentheses the expression ts.u.cl is identical. */
6616 if (expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
6619 expr
->ts
.u
.cl
->backend_decl
=
6620 gfc_create_var (gfc_charlen_type_node
, "sln");
6622 if (expr
->value
.op
.op2
)
6624 get_array_charlen (expr
->value
.op
.op2
, se
);
6626 gcc_assert (expr
->value
.op
.op
== INTRINSIC_CONCAT
);
6628 /* Add the string lengths and assign them to the expression
6629 string length backend declaration. */
6630 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
6631 fold_build2_loc (input_location
, PLUS_EXPR
,
6632 gfc_charlen_type_node
,
6633 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
,
6634 expr
->value
.op
.op2
->ts
.u
.cl
->backend_decl
));
6637 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
6638 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
);
6642 if (expr
->value
.function
.esym
== NULL
6643 || expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6645 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6649 /* Map expressions involving the dummy arguments onto the actual
6650 argument expressions. */
6651 gfc_init_interface_mapping (&mapping
);
6652 formal
= gfc_sym_get_dummy_args (expr
->symtree
->n
.sym
);
6653 arg
= expr
->value
.function
.actual
;
6655 /* Set se = NULL in the calls to the interface mapping, to suppress any
6657 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
6662 gfc_add_interface_mapping (&mapping
, formal
->sym
, NULL
, arg
->expr
);
6665 gfc_init_se (&tse
, NULL
);
6667 /* Build the expression for the character length and convert it. */
6668 gfc_apply_interface_mapping (&mapping
, &tse
, expr
->ts
.u
.cl
->length
);
6670 gfc_add_block_to_block (&se
->pre
, &tse
.pre
);
6671 gfc_add_block_to_block (&se
->post
, &tse
.post
);
6672 tse
.expr
= fold_convert (gfc_charlen_type_node
, tse
.expr
);
6673 tse
.expr
= fold_build2_loc (input_location
, MAX_EXPR
,
6674 gfc_charlen_type_node
, tse
.expr
,
6675 build_int_cst (gfc_charlen_type_node
, 0));
6676 expr
->ts
.u
.cl
->backend_decl
= tse
.expr
;
6677 gfc_free_interface_mapping (&mapping
);
6681 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6687 /* Helper function to check dimensions. */
6689 transposed_dims (gfc_ss
*ss
)
6693 for (n
= 0; n
< ss
->dimen
; n
++)
6694 if (ss
->dim
[n
] != n
)
6700 /* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
6701 AR_FULL, suitable for the scalarizer. */
6704 walk_coarray (gfc_expr
*e
)
6708 gcc_assert (gfc_get_corank (e
) > 0);
6710 ss
= gfc_walk_expr (e
);
6712 /* Fix scalar coarray. */
6713 if (ss
== gfc_ss_terminator
)
6720 if (ref
->type
== REF_ARRAY
6721 && ref
->u
.ar
.codimen
> 0)
6727 gcc_assert (ref
!= NULL
);
6728 if (ref
->u
.ar
.type
== AR_ELEMENT
)
6729 ref
->u
.ar
.type
= AR_SECTION
;
6730 ss
= gfc_reverse_ss (gfc_walk_array_ref (ss
, e
, ref
));
6737 /* Convert an array for passing as an actual argument. Expressions and
6738 vector subscripts are evaluated and stored in a temporary, which is then
6739 passed. For whole arrays the descriptor is passed. For array sections
6740 a modified copy of the descriptor is passed, but using the original data.
6742 This function is also used for array pointer assignments, and there
6745 - se->want_pointer && !se->direct_byref
6746 EXPR is an actual argument. On exit, se->expr contains a
6747 pointer to the array descriptor.
6749 - !se->want_pointer && !se->direct_byref
6750 EXPR is an actual argument to an intrinsic function or the
6751 left-hand side of a pointer assignment. On exit, se->expr
6752 contains the descriptor for EXPR.
6754 - !se->want_pointer && se->direct_byref
6755 EXPR is the right-hand side of a pointer assignment and
6756 se->expr is the descriptor for the previously-evaluated
6757 left-hand side. The function creates an assignment from
6761 The se->force_tmp flag disables the non-copying descriptor optimization
6762 that is used for transpose. It may be used in cases where there is an
6763 alias between the transpose argument and another argument in the same
6767 gfc_conv_expr_descriptor (gfc_se
*se
, gfc_expr
*expr
)
6770 gfc_ss_type ss_type
;
6771 gfc_ss_info
*ss_info
;
6773 gfc_array_info
*info
;
6782 bool subref_array_target
= false;
6783 gfc_expr
*arg
, *ss_expr
;
6785 if (se
->want_coarray
)
6786 ss
= walk_coarray (expr
);
6788 ss
= gfc_walk_expr (expr
);
6790 gcc_assert (ss
!= NULL
);
6791 gcc_assert (ss
!= gfc_ss_terminator
);
6794 ss_type
= ss_info
->type
;
6795 ss_expr
= ss_info
->expr
;
6797 /* Special case: TRANSPOSE which needs no temporary. */
6798 while (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
6799 && NULL
!= (arg
= gfc_get_noncopying_intrinsic_argument (expr
)))
6801 /* This is a call to transpose which has already been handled by the
6802 scalarizer, so that we just need to get its argument's descriptor. */
6803 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
6804 expr
= expr
->value
.function
.actual
->expr
;
6807 /* Special case things we know we can pass easily. */
6808 switch (expr
->expr_type
)
6811 /* If we have a linear array section, we can pass it directly.
6812 Otherwise we need to copy it into a temporary. */
6814 gcc_assert (ss_type
== GFC_SS_SECTION
);
6815 gcc_assert (ss_expr
== expr
);
6816 info
= &ss_info
->data
.array
;
6818 /* Get the descriptor for the array. */
6819 gfc_conv_ss_descriptor (&se
->pre
, ss
, 0);
6820 desc
= info
->descriptor
;
6822 subref_array_target
= se
->direct_byref
&& is_subref_array (expr
);
6823 need_tmp
= gfc_ref_needs_temporary_p (expr
->ref
)
6824 && !subref_array_target
;
6831 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
6833 /* Create a new descriptor if the array doesn't have one. */
6836 else if (info
->ref
->u
.ar
.type
== AR_FULL
|| se
->descriptor_only
)
6838 else if (se
->direct_byref
)
6841 full
= gfc_full_array_ref_p (info
->ref
, NULL
);
6843 if (full
&& !transposed_dims (ss
))
6845 if (se
->direct_byref
&& !se
->byref_noassign
)
6847 /* Copy the descriptor for pointer assignments. */
6848 gfc_add_modify (&se
->pre
, se
->expr
, desc
);
6850 /* Add any offsets from subreferences. */
6851 gfc_get_dataptr_offset (&se
->pre
, se
->expr
, desc
, NULL_TREE
,
6852 subref_array_target
, expr
);
6854 else if (se
->want_pointer
)
6856 /* We pass full arrays directly. This means that pointers and
6857 allocatable arrays should also work. */
6858 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
6865 if (expr
->ts
.type
== BT_CHARACTER
)
6866 se
->string_length
= gfc_get_expr_charlen (expr
);
6868 gfc_free_ss_chain (ss
);
6874 /* A transformational function return value will be a temporary
6875 array descriptor. We still need to go through the scalarizer
6876 to create the descriptor. Elemental functions are handled as
6877 arbitrary expressions, i.e. copy to a temporary. */
6879 if (se
->direct_byref
)
6881 gcc_assert (ss_type
== GFC_SS_FUNCTION
&& ss_expr
== expr
);
6883 /* For pointer assignments pass the descriptor directly. */
6887 gcc_assert (se
->ss
== ss
);
6888 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
6889 gfc_conv_expr (se
, expr
);
6890 gfc_free_ss_chain (ss
);
6894 if (ss_expr
!= expr
|| ss_type
!= GFC_SS_FUNCTION
)
6896 if (ss_expr
!= expr
)
6897 /* Elemental function. */
6898 gcc_assert ((expr
->value
.function
.esym
!= NULL
6899 && expr
->value
.function
.esym
->attr
.elemental
)
6900 || (expr
->value
.function
.isym
!= NULL
6901 && expr
->value
.function
.isym
->elemental
)
6902 || gfc_inline_intrinsic_function_p (expr
));
6904 gcc_assert (ss_type
== GFC_SS_INTRINSIC
);
6907 if (expr
->ts
.type
== BT_CHARACTER
6908 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
6909 get_array_charlen (expr
, se
);
6915 /* Transformational function. */
6916 info
= &ss_info
->data
.array
;
6922 /* Constant array constructors don't need a temporary. */
6923 if (ss_type
== GFC_SS_CONSTRUCTOR
6924 && expr
->ts
.type
!= BT_CHARACTER
6925 && gfc_constant_array_constructor_p (expr
->value
.constructor
))
6928 info
= &ss_info
->data
.array
;
6938 /* Something complicated. Copy it into a temporary. */
6944 /* If we are creating a temporary, we don't need to bother about aliases
6949 gfc_init_loopinfo (&loop
);
6951 /* Associate the SS with the loop. */
6952 gfc_add_ss_to_loop (&loop
, ss
);
6954 /* Tell the scalarizer not to bother creating loop variables, etc. */
6956 loop
.array_parameter
= 1;
6958 /* The right-hand side of a pointer assignment mustn't use a temporary. */
6959 gcc_assert (!se
->direct_byref
);
6961 /* Setup the scalarizing loops and bounds. */
6962 gfc_conv_ss_startstride (&loop
);
6966 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
6967 get_array_charlen (expr
, se
);
6969 /* Tell the scalarizer to make a temporary. */
6970 loop
.temp_ss
= gfc_get_temp_ss (gfc_typenode_for_spec (&expr
->ts
),
6971 ((expr
->ts
.type
== BT_CHARACTER
)
6972 ? expr
->ts
.u
.cl
->backend_decl
6976 se
->string_length
= loop
.temp_ss
->info
->string_length
;
6977 gcc_assert (loop
.temp_ss
->dimen
== loop
.dimen
);
6978 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
6981 gfc_conv_loop_setup (&loop
, & expr
->where
);
6985 /* Copy into a temporary and pass that. We don't need to copy the data
6986 back because expressions and vector subscripts must be INTENT_IN. */
6987 /* TODO: Optimize passing function return values. */
6992 /* Start the copying loops. */
6993 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
6994 gfc_mark_ss_chain_used (ss
, 1);
6995 gfc_start_scalarized_body (&loop
, &block
);
6997 /* Copy each data element. */
6998 gfc_init_se (&lse
, NULL
);
6999 gfc_copy_loopinfo_to_se (&lse
, &loop
);
7000 gfc_init_se (&rse
, NULL
);
7001 gfc_copy_loopinfo_to_se (&rse
, &loop
);
7003 lse
.ss
= loop
.temp_ss
;
7006 gfc_conv_scalarized_array_ref (&lse
, NULL
);
7007 if (expr
->ts
.type
== BT_CHARACTER
)
7009 gfc_conv_expr (&rse
, expr
);
7010 if (POINTER_TYPE_P (TREE_TYPE (rse
.expr
)))
7011 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
7015 gfc_conv_expr_val (&rse
, expr
);
7017 gfc_add_block_to_block (&block
, &rse
.pre
);
7018 gfc_add_block_to_block (&block
, &lse
.pre
);
7020 lse
.string_length
= rse
.string_length
;
7022 deep_copy
= !se
->data_not_needed
7023 && (expr
->expr_type
== EXPR_VARIABLE
7024 || expr
->expr_type
== EXPR_ARRAY
);
7025 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
,
7027 gfc_add_expr_to_block (&block
, tmp
);
7029 /* Finish the copying loops. */
7030 gfc_trans_scalarizing_loops (&loop
, &block
);
7032 desc
= loop
.temp_ss
->info
->data
.array
.descriptor
;
7034 else if (expr
->expr_type
== EXPR_FUNCTION
&& !transposed_dims (ss
))
7036 desc
= info
->descriptor
;
7037 se
->string_length
= ss_info
->string_length
;
7041 /* We pass sections without copying to a temporary. Make a new
7042 descriptor and point it at the section we want. The loop variable
7043 limits will be the limits of the section.
7044 A function may decide to repack the array to speed up access, but
7045 we're not bothered about that here. */
7046 int dim
, ndim
, codim
;
7053 bool onebased
= false, rank_remap
;
7055 ndim
= info
->ref
? info
->ref
->u
.ar
.dimen
: ss
->dimen
;
7056 rank_remap
= ss
->dimen
< ndim
;
7058 if (se
->want_coarray
)
7060 gfc_array_ref
*ar
= &info
->ref
->u
.ar
;
7062 codim
= gfc_get_corank (expr
);
7063 for (n
= 0; n
< codim
- 1; n
++)
7065 /* Make sure we are not lost somehow. */
7066 gcc_assert (ar
->dimen_type
[n
+ ndim
] == DIMEN_THIS_IMAGE
);
7068 /* Make sure the call to gfc_conv_section_startstride won't
7069 generate unnecessary code to calculate stride. */
7070 gcc_assert (ar
->stride
[n
+ ndim
] == NULL
);
7072 gfc_conv_section_startstride (&loop
.pre
, ss
, n
+ ndim
);
7073 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
7074 loop
.to
[n
+ loop
.dimen
] = info
->end
[n
+ ndim
];
7077 gcc_assert (n
== codim
- 1);
7078 evaluate_bound (&loop
.pre
, info
->start
, ar
->start
,
7079 info
->descriptor
, n
+ ndim
, true,
7080 ar
->as
->type
== AS_DEFERRED
);
7081 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
7086 /* Set the string_length for a character array. */
7087 if (expr
->ts
.type
== BT_CHARACTER
)
7088 se
->string_length
= gfc_get_expr_charlen (expr
);
7090 /* If we have an array section or are assigning make sure that
7091 the lower bound is 1. References to the full
7092 array should otherwise keep the original bounds. */
7093 if ((!info
->ref
|| info
->ref
->u
.ar
.type
!= AR_FULL
) && !se
->want_pointer
)
7094 for (dim
= 0; dim
< loop
.dimen
; dim
++)
7095 if (!integer_onep (loop
.from
[dim
]))
7097 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7098 gfc_array_index_type
, gfc_index_one_node
,
7100 loop
.to
[dim
] = fold_build2_loc (input_location
, PLUS_EXPR
,
7101 gfc_array_index_type
,
7103 loop
.from
[dim
] = gfc_index_one_node
;
7106 desc
= info
->descriptor
;
7107 if (se
->direct_byref
&& !se
->byref_noassign
)
7109 /* For pointer assignments we fill in the destination. */
7111 parmtype
= TREE_TYPE (parm
);
7115 /* Otherwise make a new one. */
7116 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
7117 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
, codim
,
7118 loop
.from
, loop
.to
, 0,
7119 GFC_ARRAY_UNKNOWN
, false);
7120 parm
= gfc_create_var (parmtype
, "parm");
7122 /* When expression is a class object, then add the class' handle to
7124 if (expr
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_VARIABLE
)
7126 gfc_expr
*class_expr
= gfc_find_and_cut_at_last_class_ref (expr
);
7129 /* class_expr can be NULL, when no _class ref is in expr.
7130 We must not fix this here with a gfc_fix_class_ref (). */
7133 gfc_init_se (&classse
, NULL
);
7134 gfc_conv_expr (&classse
, class_expr
);
7135 gfc_free_expr (class_expr
);
7137 gcc_assert (classse
.pre
.head
== NULL_TREE
7138 && classse
.post
.head
== NULL_TREE
);
7139 gfc_allocate_lang_decl (parm
);
7140 GFC_DECL_SAVED_DESCRIPTOR (parm
) = classse
.expr
;
7145 offset
= gfc_index_zero_node
;
7147 /* The following can be somewhat confusing. We have two
7148 descriptors, a new one and the original array.
7149 {parm, parmtype, dim} refer to the new one.
7150 {desc, type, n, loop} refer to the original, which maybe
7151 a descriptorless array.
7152 The bounds of the scalarization are the bounds of the section.
7153 We don't have to worry about numeric overflows when calculating
7154 the offsets because all elements are within the array data. */
7156 /* Set the dtype. */
7157 tmp
= gfc_conv_descriptor_dtype (parm
);
7158 gfc_add_modify (&loop
.pre
, tmp
, gfc_get_dtype (parmtype
));
7160 /* Set offset for assignments to pointer only to zero if it is not
7162 if ((se
->direct_byref
|| se
->use_offset
)
7163 && ((info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
7164 || (expr
->expr_type
== EXPR_ARRAY
&& se
->use_offset
)))
7165 base
= gfc_index_zero_node
;
7166 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7167 base
= gfc_evaluate_now (gfc_conv_array_offset (desc
), &loop
.pre
);
7171 for (n
= 0; n
< ndim
; n
++)
7173 stride
= gfc_conv_array_stride (desc
, n
);
7175 /* Work out the offset. */
7177 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
7179 gcc_assert (info
->subscript
[n
]
7180 && info
->subscript
[n
]->info
->type
== GFC_SS_SCALAR
);
7181 start
= info
->subscript
[n
]->info
->data
.scalar
.value
;
7185 /* Evaluate and remember the start of the section. */
7186 start
= info
->start
[n
];
7187 stride
= gfc_evaluate_now (stride
, &loop
.pre
);
7190 tmp
= gfc_conv_array_lbound (desc
, n
);
7191 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
7193 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
7195 offset
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (tmp
),
7199 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
7201 /* For elemental dimensions, we only need the offset. */
7205 /* Vector subscripts need copying and are handled elsewhere. */
7207 gcc_assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
7209 /* look for the corresponding scalarizer dimension: dim. */
7210 for (dim
= 0; dim
< ndim
; dim
++)
7211 if (ss
->dim
[dim
] == n
)
7214 /* loop exited early: the DIM being looked for has been found. */
7215 gcc_assert (dim
< ndim
);
7217 /* Set the new lower bound. */
7218 from
= loop
.from
[dim
];
7221 onebased
= integer_onep (from
);
7222 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
7223 gfc_rank_cst
[dim
], from
);
7225 /* Set the new upper bound. */
7226 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
7227 gfc_rank_cst
[dim
], to
);
7229 /* Multiply the stride by the section stride to get the
7231 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
7232 gfc_array_index_type
,
7233 stride
, info
->stride
[n
]);
7235 if ((se
->direct_byref
|| se
->use_offset
)
7236 && ((info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
7237 || (expr
->expr_type
== EXPR_ARRAY
&& se
->use_offset
)))
7239 base
= fold_build2_loc (input_location
, MINUS_EXPR
,
7240 TREE_TYPE (base
), base
, stride
);
7242 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)) || se
->use_offset
)
7245 tmp
= gfc_conv_array_lbound (desc
, n
);
7246 toonebased
= integer_onep (tmp
);
7247 // lb(arr) - from (- start + 1)
7248 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7249 TREE_TYPE (base
), tmp
, from
);
7250 if (onebased
&& toonebased
)
7252 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7253 TREE_TYPE (base
), tmp
, start
);
7254 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7255 TREE_TYPE (base
), tmp
,
7256 gfc_index_one_node
);
7258 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7259 TREE_TYPE (base
), tmp
,
7260 gfc_conv_array_stride (desc
, n
));
7261 base
= fold_build2_loc (input_location
, PLUS_EXPR
,
7262 TREE_TYPE (base
), tmp
, base
);
7265 /* Store the new stride. */
7266 gfc_conv_descriptor_stride_set (&loop
.pre
, parm
,
7267 gfc_rank_cst
[dim
], stride
);
7270 for (n
= loop
.dimen
; n
< loop
.dimen
+ codim
; n
++)
7272 from
= loop
.from
[n
];
7274 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
7275 gfc_rank_cst
[n
], from
);
7276 if (n
< loop
.dimen
+ codim
- 1)
7277 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
7278 gfc_rank_cst
[n
], to
);
7281 if (se
->data_not_needed
)
7282 gfc_conv_descriptor_data_set (&loop
.pre
, parm
,
7283 gfc_index_zero_node
);
7285 /* Point the data pointer at the 1st element in the section. */
7286 gfc_get_dataptr_offset (&loop
.pre
, parm
, desc
, offset
,
7287 subref_array_target
, expr
);
7289 /* Force the offset to be -1, when the lower bound of the highest
7290 dimension is one and the symbol is present and is not a
7291 pointer/allocatable or associated. */
7292 if (((se
->direct_byref
|| GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7293 && !se
->data_not_needed
)
7294 || (se
->use_offset
&& base
!= NULL_TREE
))
7296 /* Set the offset depending on base. */
7297 tmp
= rank_remap
&& !se
->direct_byref
?
7298 fold_build2_loc (input_location
, PLUS_EXPR
,
7299 gfc_array_index_type
, base
,
7302 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, tmp
);
7304 else if (IS_CLASS_ARRAY (expr
) && !se
->data_not_needed
7305 && (!rank_remap
|| se
->use_offset
)
7306 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
7308 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
,
7309 gfc_conv_descriptor_offset_get (desc
));
7311 else if (onebased
&& (!rank_remap
|| se
->use_offset
)
7313 && !(expr
->symtree
->n
.sym
&& expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
7314 && !CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.class_pointer
)
7315 && !expr
->symtree
->n
.sym
->attr
.allocatable
7316 && !expr
->symtree
->n
.sym
->attr
.pointer
7317 && !expr
->symtree
->n
.sym
->attr
.host_assoc
7318 && !expr
->symtree
->n
.sym
->attr
.use_assoc
)
7320 /* Set the offset to -1. */
7322 mpz_init_set_si (minus_one
, -1);
7323 tmp
= gfc_conv_mpz_to_tree (minus_one
, gfc_index_integer_kind
);
7324 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, tmp
);
7328 /* Only the callee knows what the correct offset it, so just set
7330 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, gfc_index_zero_node
);
7335 /* For class arrays add the class tree into the saved descriptor to
7336 enable getting of _vptr and the like. */
7337 if (expr
->expr_type
== EXPR_VARIABLE
&& VAR_P (desc
)
7338 && IS_CLASS_ARRAY (expr
->symtree
->n
.sym
))
7340 gfc_allocate_lang_decl (desc
);
7341 GFC_DECL_SAVED_DESCRIPTOR (desc
) =
7342 DECL_LANG_SPECIFIC (expr
->symtree
->n
.sym
->backend_decl
) ?
7343 GFC_DECL_SAVED_DESCRIPTOR (expr
->symtree
->n
.sym
->backend_decl
)
7344 : expr
->symtree
->n
.sym
->backend_decl
;
7346 else if (expr
->expr_type
== EXPR_ARRAY
&& VAR_P (desc
)
7347 && IS_CLASS_ARRAY (expr
))
7350 gfc_allocate_lang_decl (desc
);
7351 tmp
= gfc_create_var (expr
->ts
.u
.derived
->backend_decl
, "class");
7352 GFC_DECL_SAVED_DESCRIPTOR (desc
) = tmp
;
7353 vtype
= gfc_class_vptr_get (tmp
);
7354 gfc_add_modify (&se
->pre
, vtype
,
7355 gfc_build_addr_expr (TREE_TYPE (vtype
),
7356 gfc_find_vtab (&expr
->ts
)->backend_decl
));
7358 if (!se
->direct_byref
|| se
->byref_noassign
)
7360 /* Get a pointer to the new descriptor. */
7361 if (se
->want_pointer
)
7362 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
7367 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
7368 gfc_add_block_to_block (&se
->post
, &loop
.post
);
7370 /* Cleanup the scalarizer. */
7371 gfc_cleanup_loop (&loop
);
7374 /* Helper function for gfc_conv_array_parameter if array size needs to be
7378 array_parameter_size (tree desc
, gfc_expr
*expr
, tree
*size
)
7381 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7382 *size
= GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc
));
7383 else if (expr
->rank
> 1)
7384 *size
= build_call_expr_loc (input_location
,
7385 gfor_fndecl_size0
, 1,
7386 gfc_build_addr_expr (NULL
, desc
));
7389 tree ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_index_zero_node
);
7390 tree lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_index_zero_node
);
7392 *size
= fold_build2_loc (input_location
, MINUS_EXPR
,
7393 gfc_array_index_type
, ubound
, lbound
);
7394 *size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7395 *size
, gfc_index_one_node
);
7396 *size
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
7397 *size
, gfc_index_zero_node
);
7399 elem
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
7400 *size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7401 *size
, fold_convert (gfc_array_index_type
, elem
));
7404 /* Convert an array for passing as an actual parameter. */
7405 /* TODO: Optimize passing g77 arrays. */
7408 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, bool g77
,
7409 const gfc_symbol
*fsym
, const char *proc_name
,
7414 tree tmp
= NULL_TREE
;
7416 tree parent
= DECL_CONTEXT (current_function_decl
);
7417 bool full_array_var
;
7418 bool this_array_result
;
7421 bool array_constructor
;
7422 bool good_allocatable
;
7423 bool ultimate_ptr_comp
;
7424 bool ultimate_alloc_comp
;
7429 ultimate_ptr_comp
= false;
7430 ultimate_alloc_comp
= false;
7432 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7434 if (ref
->next
== NULL
)
7437 if (ref
->type
== REF_COMPONENT
)
7439 ultimate_ptr_comp
= ref
->u
.c
.component
->attr
.pointer
;
7440 ultimate_alloc_comp
= ref
->u
.c
.component
->attr
.allocatable
;
7444 full_array_var
= false;
7447 if (expr
->expr_type
== EXPR_VARIABLE
&& ref
&& !ultimate_ptr_comp
)
7448 full_array_var
= gfc_full_array_ref_p (ref
, &contiguous
);
7450 sym
= full_array_var
? expr
->symtree
->n
.sym
: NULL
;
7452 /* The symbol should have an array specification. */
7453 gcc_assert (!sym
|| sym
->as
|| ref
->u
.ar
.as
);
7455 if (expr
->expr_type
== EXPR_ARRAY
&& expr
->ts
.type
== BT_CHARACTER
)
7457 get_array_ctor_strlen (&se
->pre
, expr
->value
.constructor
, &tmp
);
7458 expr
->ts
.u
.cl
->backend_decl
= tmp
;
7459 se
->string_length
= tmp
;
7462 /* Is this the result of the enclosing procedure? */
7463 this_array_result
= (full_array_var
&& sym
->attr
.flavor
== FL_PROCEDURE
);
7464 if (this_array_result
7465 && (sym
->backend_decl
!= current_function_decl
)
7466 && (sym
->backend_decl
!= parent
))
7467 this_array_result
= false;
7469 /* Passing address of the array if it is not pointer or assumed-shape. */
7470 if (full_array_var
&& g77
&& !this_array_result
7471 && sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
7473 tmp
= gfc_get_symbol_decl (sym
);
7475 if (sym
->ts
.type
== BT_CHARACTER
)
7476 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
7478 if (!sym
->attr
.pointer
7480 && sym
->as
->type
!= AS_ASSUMED_SHAPE
7481 && sym
->as
->type
!= AS_DEFERRED
7482 && sym
->as
->type
!= AS_ASSUMED_RANK
7483 && !sym
->attr
.allocatable
)
7485 /* Some variables are declared directly, others are declared as
7486 pointers and allocated on the heap. */
7487 if (sym
->attr
.dummy
|| POINTER_TYPE_P (TREE_TYPE (tmp
)))
7490 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
7492 array_parameter_size (tmp
, expr
, size
);
7496 if (sym
->attr
.allocatable
)
7498 if (sym
->attr
.dummy
|| sym
->attr
.result
)
7500 gfc_conv_expr_descriptor (se
, expr
);
7504 array_parameter_size (tmp
, expr
, size
);
7505 se
->expr
= gfc_conv_array_data (tmp
);
7510 /* A convenient reduction in scope. */
7511 contiguous
= g77
&& !this_array_result
&& contiguous
;
7513 /* There is no need to pack and unpack the array, if it is contiguous
7514 and not a deferred- or assumed-shape array, or if it is simply
7516 no_pack
= ((sym
&& sym
->as
7517 && !sym
->attr
.pointer
7518 && sym
->as
->type
!= AS_DEFERRED
7519 && sym
->as
->type
!= AS_ASSUMED_RANK
7520 && sym
->as
->type
!= AS_ASSUMED_SHAPE
)
7522 (ref
&& ref
->u
.ar
.as
7523 && ref
->u
.ar
.as
->type
!= AS_DEFERRED
7524 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_RANK
7525 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_SHAPE
)
7527 gfc_is_simply_contiguous (expr
, false, true));
7529 no_pack
= contiguous
&& no_pack
;
7531 /* Array constructors are always contiguous and do not need packing. */
7532 array_constructor
= g77
&& !this_array_result
&& expr
->expr_type
== EXPR_ARRAY
;
7534 /* Same is true of contiguous sections from allocatable variables. */
7535 good_allocatable
= contiguous
7537 && expr
->symtree
->n
.sym
->attr
.allocatable
;
7539 /* Or ultimate allocatable components. */
7540 ultimate_alloc_comp
= contiguous
&& ultimate_alloc_comp
;
7542 if (no_pack
|| array_constructor
|| good_allocatable
|| ultimate_alloc_comp
)
7544 gfc_conv_expr_descriptor (se
, expr
);
7545 /* Deallocate the allocatable components of structures that are
7547 if ((expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
)
7548 && expr
->ts
.u
.derived
->attr
.alloc_comp
7549 && expr
->expr_type
!= EXPR_VARIABLE
)
7551 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, se
->expr
, expr
->rank
);
7553 /* The components shall be deallocated before their containing entity. */
7554 gfc_prepend_expr_to_block (&se
->post
, tmp
);
7556 if (expr
->ts
.type
== BT_CHARACTER
)
7557 se
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
7559 array_parameter_size (se
->expr
, expr
, size
);
7560 se
->expr
= gfc_conv_array_data (se
->expr
);
7564 if (this_array_result
)
7566 /* Result of the enclosing function. */
7567 gfc_conv_expr_descriptor (se
, expr
);
7569 array_parameter_size (se
->expr
, expr
, size
);
7570 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7572 if (g77
&& TREE_TYPE (TREE_TYPE (se
->expr
)) != NULL_TREE
7573 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
7574 se
->expr
= gfc_conv_array_data (build_fold_indirect_ref_loc (input_location
,
7581 /* Every other type of array. */
7582 se
->want_pointer
= 1;
7583 gfc_conv_expr_descriptor (se
, expr
);
7585 array_parameter_size (build_fold_indirect_ref_loc (input_location
,
7590 /* Deallocate the allocatable components of structures that are
7591 not variable, for descriptorless arguments.
7592 Arguments with a descriptor are handled in gfc_conv_procedure_call. */
7593 if (g77
&& (expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
)
7594 && expr
->ts
.u
.derived
->attr
.alloc_comp
7595 && expr
->expr_type
!= EXPR_VARIABLE
)
7597 tmp
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7598 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
, expr
->rank
);
7600 /* The components shall be deallocated before their containing entity. */
7601 gfc_prepend_expr_to_block (&se
->post
, tmp
);
7604 if (g77
|| (fsym
&& fsym
->attr
.contiguous
7605 && !gfc_is_simply_contiguous (expr
, false, true)))
7607 tree origptr
= NULL_TREE
;
7611 /* For contiguous arrays, save the original value of the descriptor. */
7614 origptr
= gfc_create_var (pvoid_type_node
, "origptr");
7615 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7616 tmp
= gfc_conv_array_data (tmp
);
7617 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7618 TREE_TYPE (origptr
), origptr
,
7619 fold_convert (TREE_TYPE (origptr
), tmp
));
7620 gfc_add_expr_to_block (&se
->pre
, tmp
);
7623 /* Repack the array. */
7624 if (warn_array_temporaries
)
7627 gfc_warning (OPT_Warray_temporaries
,
7628 "Creating array temporary at %L for argument %qs",
7629 &expr
->where
, fsym
->name
);
7631 gfc_warning (OPT_Warray_temporaries
,
7632 "Creating array temporary at %L", &expr
->where
);
7635 ptr
= build_call_expr_loc (input_location
,
7636 gfor_fndecl_in_pack
, 1, desc
);
7638 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7640 tmp
= gfc_conv_expr_present (sym
);
7641 ptr
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
7642 tmp
, fold_convert (TREE_TYPE (se
->expr
), ptr
),
7643 fold_convert (TREE_TYPE (se
->expr
), null_pointer_node
));
7646 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
7648 /* Use the packed data for the actual argument, except for contiguous arrays,
7649 where the descriptor's data component is set. */
7654 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7656 gfc_ss
* ss
= gfc_walk_expr (expr
);
7657 if (!transposed_dims (ss
))
7658 gfc_conv_descriptor_data_set (&se
->pre
, tmp
, ptr
);
7661 tree old_field
, new_field
;
7663 /* The original descriptor has transposed dims so we can't reuse
7664 it directly; we have to create a new one. */
7665 tree old_desc
= tmp
;
7666 tree new_desc
= gfc_create_var (TREE_TYPE (old_desc
), "arg_desc");
7668 old_field
= gfc_conv_descriptor_dtype (old_desc
);
7669 new_field
= gfc_conv_descriptor_dtype (new_desc
);
7670 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7672 old_field
= gfc_conv_descriptor_offset (old_desc
);
7673 new_field
= gfc_conv_descriptor_offset (new_desc
);
7674 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7676 for (int i
= 0; i
< expr
->rank
; i
++)
7678 old_field
= gfc_conv_descriptor_dimension (old_desc
,
7679 gfc_rank_cst
[get_array_ref_dim_for_loop_dim (ss
, i
)]);
7680 new_field
= gfc_conv_descriptor_dimension (new_desc
,
7682 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7685 if (flag_coarray
== GFC_FCOARRAY_LIB
7686 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (old_desc
))
7687 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (old_desc
))
7688 == GFC_ARRAY_ALLOCATABLE
)
7690 old_field
= gfc_conv_descriptor_token (old_desc
);
7691 new_field
= gfc_conv_descriptor_token (new_desc
);
7692 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7695 gfc_conv_descriptor_data_set (&se
->pre
, new_desc
, ptr
);
7696 se
->expr
= gfc_build_addr_expr (NULL_TREE
, new_desc
);
7701 if (gfc_option
.rtcheck
& GFC_RTCHECK_ARRAY_TEMPS
)
7705 if (fsym
&& proc_name
)
7706 msg
= xasprintf ("An array temporary was created for argument "
7707 "'%s' of procedure '%s'", fsym
->name
, proc_name
);
7709 msg
= xasprintf ("An array temporary was created");
7711 tmp
= build_fold_indirect_ref_loc (input_location
,
7713 tmp
= gfc_conv_array_data (tmp
);
7714 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7715 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
7717 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7718 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7720 gfc_conv_expr_present (sym
), tmp
);
7722 gfc_trans_runtime_check (false, true, tmp
, &se
->pre
,
7727 gfc_start_block (&block
);
7729 /* Copy the data back. */
7730 if (fsym
== NULL
|| fsym
->attr
.intent
!= INTENT_IN
)
7732 tmp
= build_call_expr_loc (input_location
,
7733 gfor_fndecl_in_unpack
, 2, desc
, ptr
);
7734 gfc_add_expr_to_block (&block
, tmp
);
7737 /* Free the temporary. */
7738 tmp
= gfc_call_free (ptr
);
7739 gfc_add_expr_to_block (&block
, tmp
);
7741 stmt
= gfc_finish_block (&block
);
7743 gfc_init_block (&block
);
7744 /* Only if it was repacked. This code needs to be executed before the
7745 loop cleanup code. */
7746 tmp
= build_fold_indirect_ref_loc (input_location
,
7748 tmp
= gfc_conv_array_data (tmp
);
7749 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7750 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
7752 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7753 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7755 gfc_conv_expr_present (sym
), tmp
);
7757 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
7759 gfc_add_expr_to_block (&block
, tmp
);
7760 gfc_add_block_to_block (&block
, &se
->post
);
7762 gfc_init_block (&se
->post
);
7764 /* Reset the descriptor pointer. */
7767 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7768 gfc_conv_descriptor_data_set (&se
->post
, tmp
, origptr
);
7771 gfc_add_block_to_block (&se
->post
, &block
);
7776 /* This helper function calculates the size in words of a full array. */
7779 gfc_full_array_size (stmtblock_t
*block
, tree decl
, int rank
)
7784 idx
= gfc_rank_cst
[rank
- 1];
7785 nelems
= gfc_conv_descriptor_ubound_get (decl
, idx
);
7786 tmp
= gfc_conv_descriptor_lbound_get (decl
, idx
);
7787 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7789 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7790 tmp
, gfc_index_one_node
);
7791 tmp
= gfc_evaluate_now (tmp
, block
);
7793 nelems
= gfc_conv_descriptor_stride_get (decl
, idx
);
7794 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7796 return gfc_evaluate_now (tmp
, block
);
7800 /* Allocate dest to the same size as src, and copy src -> dest.
7801 If no_malloc is set, only the copy is done. */
7804 duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
7805 bool no_malloc
, bool no_memcpy
, tree str_sz
,
7806 tree add_when_allocated
)
7815 /* If the source is null, set the destination to null. Then,
7816 allocate memory to the destination. */
7817 gfc_init_block (&block
);
7819 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
7821 gfc_add_modify (&block
, dest
, fold_convert (type
, null_pointer_node
));
7822 null_data
= gfc_finish_block (&block
);
7824 gfc_init_block (&block
);
7825 if (str_sz
!= NULL_TREE
)
7828 size
= TYPE_SIZE_UNIT (TREE_TYPE (type
));
7832 tmp
= gfc_call_malloc (&block
, type
, size
);
7833 gfc_add_modify (&block
, dest
, fold_convert (type
, tmp
));
7838 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
7839 tmp
= build_call_expr_loc (input_location
, tmp
, 3, dest
, src
,
7840 fold_convert (size_type_node
, size
));
7841 gfc_add_expr_to_block (&block
, tmp
);
7846 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
7847 null_data
= gfc_finish_block (&block
);
7849 gfc_init_block (&block
);
7851 nelems
= gfc_full_array_size (&block
, src
, rank
);
7853 nelems
= gfc_index_one_node
;
7855 if (str_sz
!= NULL_TREE
)
7856 tmp
= fold_convert (gfc_array_index_type
, str_sz
);
7858 tmp
= fold_convert (gfc_array_index_type
,
7859 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
7860 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7864 tmp
= TREE_TYPE (gfc_conv_descriptor_data_get (src
));
7865 tmp
= gfc_call_malloc (&block
, tmp
, size
);
7866 gfc_conv_descriptor_data_set (&block
, dest
, tmp
);
7869 /* We know the temporary and the value will be the same length,
7870 so can use memcpy. */
7873 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
7874 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
7875 gfc_conv_descriptor_data_get (dest
),
7876 gfc_conv_descriptor_data_get (src
),
7877 fold_convert (size_type_node
, size
));
7878 gfc_add_expr_to_block (&block
, tmp
);
7882 gfc_add_expr_to_block (&block
, add_when_allocated
);
7883 tmp
= gfc_finish_block (&block
);
7885 /* Null the destination if the source is null; otherwise do
7886 the allocate and copy. */
7887 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src
)))
7890 null_cond
= gfc_conv_descriptor_data_get (src
);
7892 null_cond
= convert (pvoid_type_node
, null_cond
);
7893 null_cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7894 null_cond
, null_pointer_node
);
7895 return build3_v (COND_EXPR
, null_cond
, tmp
, null_data
);
7899 /* Allocate dest to the same size as src, and copy data src -> dest. */
7902 gfc_duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
7903 tree add_when_allocated
)
7905 return duplicate_allocatable (dest
, src
, type
, rank
, false, false,
7906 NULL_TREE
, add_when_allocated
);
7910 /* Copy data src -> dest. */
7913 gfc_copy_allocatable_data (tree dest
, tree src
, tree type
, int rank
)
7915 return duplicate_allocatable (dest
, src
, type
, rank
, true, false,
7916 NULL_TREE
, NULL_TREE
);
7919 /* Allocate dest to the same size as src, but don't copy anything. */
7922 gfc_duplicate_allocatable_nocopy (tree dest
, tree src
, tree type
, int rank
)
7924 return duplicate_allocatable (dest
, src
, type
, rank
, false, true,
7925 NULL_TREE
, NULL_TREE
);
7930 duplicate_allocatable_coarray (tree dest
, tree dest_tok
, tree src
,
7931 tree type
, int rank
)
7938 stmtblock_t block
, globalblock
;
7940 /* If the source is null, set the destination to null. Then,
7941 allocate memory to the destination. */
7942 gfc_init_block (&block
);
7943 gfc_init_block (&globalblock
);
7945 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
7948 symbol_attribute attr
;
7951 gfc_init_se (&se
, NULL
);
7952 dummy_desc
= gfc_conv_scalar_to_descriptor (&se
, dest
, attr
);
7953 gfc_add_block_to_block (&globalblock
, &se
.pre
);
7954 size
= TYPE_SIZE_UNIT (TREE_TYPE (type
));
7956 gfc_add_modify (&block
, dest
, fold_convert (type
, null_pointer_node
));
7957 gfc_allocate_using_caf_lib (&block
, dummy_desc
, size
,
7958 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
7959 NULL_TREE
, NULL_TREE
, NULL_TREE
,
7960 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
7961 null_data
= gfc_finish_block (&block
);
7963 gfc_init_block (&block
);
7965 gfc_allocate_using_caf_lib (&block
, dummy_desc
,
7966 fold_convert (size_type_node
, size
),
7967 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
7968 NULL_TREE
, NULL_TREE
, NULL_TREE
,
7969 GFC_CAF_COARRAY_ALLOC
);
7971 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
7972 tmp
= build_call_expr_loc (input_location
, tmp
, 3, dest
, src
,
7973 fold_convert (size_type_node
, size
));
7974 gfc_add_expr_to_block (&block
, tmp
);
7978 /* Set the rank or unitialized memory access may be reported. */
7979 tmp
= gfc_conv_descriptor_dtype (dest
);
7980 gfc_add_modify (&globalblock
, tmp
, build_int_cst (TREE_TYPE (tmp
), rank
));
7983 nelems
= gfc_full_array_size (&block
, src
, rank
);
7985 nelems
= integer_one_node
;
7987 tmp
= fold_convert (size_type_node
,
7988 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
7989 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
7990 fold_convert (size_type_node
, nelems
), tmp
);
7992 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
7993 gfc_allocate_using_caf_lib (&block
, dest
, fold_convert (size_type_node
,
7995 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
7996 NULL_TREE
, NULL_TREE
, NULL_TREE
,
7997 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
7998 null_data
= gfc_finish_block (&block
);
8000 gfc_init_block (&block
);
8001 gfc_allocate_using_caf_lib (&block
, dest
,
8002 fold_convert (size_type_node
, size
),
8003 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8004 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8005 GFC_CAF_COARRAY_ALLOC
);
8007 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8008 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
8009 gfc_conv_descriptor_data_get (dest
),
8010 gfc_conv_descriptor_data_get (src
),
8011 fold_convert (size_type_node
, size
));
8012 gfc_add_expr_to_block (&block
, tmp
);
8015 tmp
= gfc_finish_block (&block
);
8017 /* Null the destination if the source is null; otherwise do
8018 the register and copy. */
8019 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src
)))
8022 null_cond
= gfc_conv_descriptor_data_get (src
);
8024 null_cond
= convert (pvoid_type_node
, null_cond
);
8025 null_cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
8026 null_cond
, null_pointer_node
);
8027 gfc_add_expr_to_block (&globalblock
, build3_v (COND_EXPR
, null_cond
, tmp
,
8029 return gfc_finish_block (&globalblock
);
8033 /* Helper function to abstract whether coarray processing is enabled. */
8036 caf_enabled (int caf_mode
)
8038 return (caf_mode
& GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
)
8039 == GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
;
8043 /* Helper function to abstract whether coarray processing is enabled
8044 and we are in a derived type coarray. */
8047 caf_in_coarray (int caf_mode
)
8049 static const int pat
= GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
8050 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
;
8051 return (caf_mode
& pat
) == pat
;
8055 /* Helper function to abstract whether coarray is to deallocate only. */
8058 gfc_caf_is_dealloc_only (int caf_mode
)
8060 return (caf_mode
& GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY
)
8061 == GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY
;
8065 /* Recursively traverse an object of derived type, generating code to
8066 deallocate, nullify or copy allocatable components. This is the work horse
8067 function for the functions named in this enum. */
8069 enum {DEALLOCATE_ALLOC_COMP
= 1, NULLIFY_ALLOC_COMP
,
8070 COPY_ALLOC_COMP
, COPY_ONLY_ALLOC_COMP
, REASSIGN_CAF_COMP
};
8073 structure_alloc_comps (gfc_symbol
* der_type
, tree decl
,
8074 tree dest
, int rank
, int purpose
, int caf_mode
)
8078 stmtblock_t fnblock
;
8079 stmtblock_t loopbody
;
8080 stmtblock_t tmpblock
;
8091 tree null_cond
= NULL_TREE
;
8092 tree add_when_allocated
;
8093 tree dealloc_fndecl
;
8097 symbol_attribute
*attr
;
8098 bool deallocate_called
;
8100 gfc_init_block (&fnblock
);
8102 decl_type
= TREE_TYPE (decl
);
8104 if ((POINTER_TYPE_P (decl_type
))
8105 || (TREE_CODE (decl_type
) == REFERENCE_TYPE
&& rank
== 0))
8107 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
8108 /* Deref dest in sync with decl, but only when it is not NULL. */
8110 dest
= build_fold_indirect_ref_loc (input_location
, dest
);
8112 /* Update the decl_type because it got dereferenced. */
8113 decl_type
= TREE_TYPE (decl
);
8116 /* If this is an array of derived types with allocatable components
8117 build a loop and recursively call this function. */
8118 if (TREE_CODE (decl_type
) == ARRAY_TYPE
8119 || (GFC_DESCRIPTOR_TYPE_P (decl_type
) && rank
!= 0))
8121 tmp
= gfc_conv_array_data (decl
);
8122 var
= build_fold_indirect_ref_loc (input_location
, tmp
);
8124 /* Get the number of elements - 1 and set the counter. */
8125 if (GFC_DESCRIPTOR_TYPE_P (decl_type
))
8127 /* Use the descriptor for an allocatable array. Since this
8128 is a full array reference, we only need the descriptor
8129 information from dimension = rank. */
8130 tmp
= gfc_full_array_size (&fnblock
, decl
, rank
);
8131 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8132 gfc_array_index_type
, tmp
,
8133 gfc_index_one_node
);
8135 null_cond
= gfc_conv_descriptor_data_get (decl
);
8136 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
8137 boolean_type_node
, null_cond
,
8138 build_int_cst (TREE_TYPE (null_cond
), 0));
8142 /* Otherwise use the TYPE_DOMAIN information. */
8143 tmp
= array_type_nelts (decl_type
);
8144 tmp
= fold_convert (gfc_array_index_type
, tmp
);
8147 /* Remember that this is, in fact, the no. of elements - 1. */
8148 nelems
= gfc_evaluate_now (tmp
, &fnblock
);
8149 index
= gfc_create_var (gfc_array_index_type
, "S");
8151 /* Build the body of the loop. */
8152 gfc_init_block (&loopbody
);
8154 vref
= gfc_build_array_ref (var
, index
, NULL
);
8156 if ((purpose
== COPY_ALLOC_COMP
|| purpose
== COPY_ONLY_ALLOC_COMP
)
8157 && !caf_enabled (caf_mode
))
8159 tmp
= build_fold_indirect_ref_loc (input_location
,
8160 gfc_conv_array_data (dest
));
8161 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
8162 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
,
8163 COPY_ALLOC_COMP
, 0);
8166 tmp
= structure_alloc_comps (der_type
, vref
, NULL_TREE
, rank
, purpose
,
8169 gfc_add_expr_to_block (&loopbody
, tmp
);
8171 /* Build the loop and return. */
8172 gfc_init_loopinfo (&loop
);
8174 loop
.from
[0] = gfc_index_zero_node
;
8175 loop
.loopvar
[0] = index
;
8176 loop
.to
[0] = nelems
;
8177 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
8178 gfc_add_block_to_block (&fnblock
, &loop
.pre
);
8180 tmp
= gfc_finish_block (&fnblock
);
8181 /* When copying allocateable components, the above implements the
8182 deep copy. Nevertheless is a deep copy only allowed, when the current
8183 component is allocated, for which code will be generated in
8184 gfc_duplicate_allocatable (), where the deep copy code is just added
8185 into the if's body, by adding tmp (the deep copy code) as last
8186 argument to gfc_duplicate_allocatable (). */
8187 if (purpose
== COPY_ALLOC_COMP
8188 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
8189 tmp
= gfc_duplicate_allocatable (dest
, decl
, decl_type
, rank
,
8191 else if (null_cond
!= NULL_TREE
)
8192 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
8193 build_empty_stmt (input_location
));
8198 /* Otherwise, act on the components or recursively call self to
8199 act on a chain of components. */
8200 for (c
= der_type
->components
; c
; c
= c
->next
)
8202 bool cmp_has_alloc_comps
= (c
->ts
.type
== BT_DERIVED
8203 || c
->ts
.type
== BT_CLASS
)
8204 && c
->ts
.u
.derived
->attr
.alloc_comp
;
8205 bool same_type
= (c
->ts
.type
== BT_DERIVED
&& der_type
== c
->ts
.u
.derived
)
8206 || (c
->ts
.type
== BT_CLASS
&& der_type
== CLASS_DATA (c
)->ts
.u
.derived
);
8208 cdecl = c
->backend_decl
;
8209 ctype
= TREE_TYPE (cdecl);
8213 case DEALLOCATE_ALLOC_COMP
:
8215 gfc_init_block (&tmpblock
);
8217 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8218 decl
, cdecl, NULL_TREE
);
8220 /* Shortcut to get the attributes of the component. */
8221 if (c
->ts
.type
== BT_CLASS
)
8222 attr
= &CLASS_DATA (c
)->attr
;
8226 if ((c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
)
8227 || (c
->ts
.type
== BT_CLASS
&& !CLASS_DATA (c
)->attr
.class_pointer
))
8228 /* Call the finalizer, which will free the memory and nullify the
8229 pointer of an array. */
8230 deallocate_called
= gfc_add_comp_finalizer_call (&tmpblock
, comp
, c
,
8231 caf_enabled (caf_mode
))
8234 deallocate_called
= false;
8236 /* Add the _class ref for classes. */
8237 if (c
->ts
.type
== BT_CLASS
&& attr
->allocatable
)
8238 comp
= gfc_class_data_get (comp
);
8240 add_when_allocated
= NULL_TREE
;
8241 if (cmp_has_alloc_comps
8242 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
8244 && !deallocate_called
)
8246 /* Add checked deallocation of the components. This code is
8247 obviously added because the finalizer is not trusted to free
8249 if (c
->ts
.type
== BT_CLASS
)
8251 rank
= CLASS_DATA (c
)->as
? CLASS_DATA (c
)->as
->rank
: 0;
8253 = structure_alloc_comps (CLASS_DATA (c
)->ts
.u
.derived
,
8254 comp
, NULL_TREE
, rank
, purpose
,
8259 rank
= c
->as
? c
->as
->rank
: 0;
8260 add_when_allocated
= structure_alloc_comps (c
->ts
.u
.derived
,
8267 if (attr
->allocatable
&& !same_type
8268 && (!attr
->codimension
|| caf_enabled (caf_mode
)))
8270 /* Handle all types of components besides components of the
8271 same_type as the current one, because those would create an
8274 = (caf_in_coarray (caf_mode
) || attr
->codimension
)
8275 ? (gfc_caf_is_dealloc_only (caf_mode
)
8276 ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
8277 : GFC_CAF_COARRAY_DEREGISTER
)
8278 : GFC_CAF_COARRAY_NOCOARRAY
;
8280 caf_token
= NULL_TREE
;
8281 /* Coarray components are handled directly by
8282 deallocate_with_status. */
8283 if (!attr
->codimension
8284 && caf_dereg_mode
!= GFC_CAF_COARRAY_NOCOARRAY
)
8287 caf_token
= fold_build3_loc (input_location
, COMPONENT_REF
,
8288 TREE_TYPE (c
->caf_token
),
8289 decl
, c
->caf_token
, NULL_TREE
);
8290 else if (attr
->dimension
&& !attr
->proc_pointer
)
8291 caf_token
= gfc_conv_descriptor_token (comp
);
8293 if (attr
->dimension
&& !attr
->codimension
&& !attr
->proc_pointer
)
8294 /* When this is an array but not in conjunction with a coarray
8295 then add the data-ref. For coarray'ed arrays the data-ref
8296 is added by deallocate_with_status. */
8297 comp
= gfc_conv_descriptor_data_get (comp
);
8299 tmp
= gfc_deallocate_with_status (comp
, NULL_TREE
, NULL_TREE
,
8300 NULL_TREE
, NULL_TREE
, true,
8301 NULL
, caf_dereg_mode
,
8302 add_when_allocated
, caf_token
);
8304 gfc_add_expr_to_block (&tmpblock
, tmp
);
8306 else if (attr
->allocatable
&& !attr
->codimension
8307 && !deallocate_called
)
8309 /* Case of recursive allocatable derived types. */
8313 stmtblock_t dealloc_block
;
8315 gfc_init_block (&dealloc_block
);
8316 if (add_when_allocated
)
8317 gfc_add_expr_to_block (&dealloc_block
, add_when_allocated
);
8319 /* Convert the component into a rank 1 descriptor type. */
8320 if (attr
->dimension
)
8322 tmp
= gfc_get_element_type (TREE_TYPE (comp
));
8323 ubound
= gfc_full_array_size (&dealloc_block
, comp
,
8324 c
->ts
.type
== BT_CLASS
8325 ? CLASS_DATA (c
)->as
->rank
8330 tmp
= TREE_TYPE (comp
);
8331 ubound
= build_int_cst (gfc_array_index_type
, 1);
8334 cdesc
= gfc_get_array_type_bounds (tmp
, 1, 0, &gfc_index_one_node
,
8336 GFC_ARRAY_ALLOCATABLE
, false);
8338 cdesc
= gfc_create_var (cdesc
, "cdesc");
8339 DECL_ARTIFICIAL (cdesc
) = 1;
8341 gfc_add_modify (&dealloc_block
, gfc_conv_descriptor_dtype (cdesc
),
8342 gfc_get_dtype_rank_type (1, tmp
));
8343 gfc_conv_descriptor_lbound_set (&dealloc_block
, cdesc
,
8344 gfc_index_zero_node
,
8345 gfc_index_one_node
);
8346 gfc_conv_descriptor_stride_set (&dealloc_block
, cdesc
,
8347 gfc_index_zero_node
,
8348 gfc_index_one_node
);
8349 gfc_conv_descriptor_ubound_set (&dealloc_block
, cdesc
,
8350 gfc_index_zero_node
, ubound
);
8352 if (attr
->dimension
)
8353 comp
= gfc_conv_descriptor_data_get (comp
);
8355 gfc_conv_descriptor_data_set (&dealloc_block
, cdesc
, comp
);
8357 /* Now call the deallocator. */
8358 vtab
= gfc_find_vtab (&c
->ts
);
8359 if (vtab
->backend_decl
== NULL
)
8360 gfc_get_symbol_decl (vtab
);
8361 tmp
= gfc_build_addr_expr (NULL_TREE
, vtab
->backend_decl
);
8362 dealloc_fndecl
= gfc_vptr_deallocate_get (tmp
);
8363 dealloc_fndecl
= build_fold_indirect_ref_loc (input_location
,
8365 tmp
= build_int_cst (TREE_TYPE (comp
), 0);
8366 is_allocated
= fold_build2_loc (input_location
, NE_EXPR
,
8367 boolean_type_node
, tmp
,
8369 cdesc
= gfc_build_addr_expr (NULL_TREE
, cdesc
);
8371 tmp
= build_call_expr_loc (input_location
,
8374 gfc_add_expr_to_block (&dealloc_block
, tmp
);
8376 tmp
= gfc_finish_block (&dealloc_block
);
8378 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
8379 void_type_node
, is_allocated
, tmp
,
8380 build_empty_stmt (input_location
));
8382 gfc_add_expr_to_block (&tmpblock
, tmp
);
8384 else if (add_when_allocated
)
8385 gfc_add_expr_to_block (&tmpblock
, add_when_allocated
);
8387 if (c
->ts
.type
== BT_CLASS
&& attr
->allocatable
8388 && (!attr
->codimension
|| !caf_enabled (caf_mode
)))
8390 /* Finally, reset the vptr to the declared type vtable and, if
8391 necessary reset the _len field.
8393 First recover the reference to the component and obtain
8395 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8396 decl
, cdecl, NULL_TREE
);
8397 tmp
= gfc_class_vptr_get (comp
);
8399 if (UNLIMITED_POLY (c
))
8401 /* Both vptr and _len field should be nulled. */
8402 gfc_add_modify (&tmpblock
, tmp
,
8403 build_int_cst (TREE_TYPE (tmp
), 0));
8404 tmp
= gfc_class_len_get (comp
);
8405 gfc_add_modify (&tmpblock
, tmp
,
8406 build_int_cst (TREE_TYPE (tmp
), 0));
8410 /* Build the vtable address and set the vptr with it. */
8413 vtable
= gfc_find_derived_vtab (c
->ts
.u
.derived
);
8414 vtab
= vtable
->backend_decl
;
8415 if (vtab
== NULL_TREE
)
8416 vtab
= gfc_get_symbol_decl (vtable
);
8417 vtab
= gfc_build_addr_expr (NULL
, vtab
);
8418 vtab
= fold_convert (TREE_TYPE (tmp
), vtab
);
8419 gfc_add_modify (&tmpblock
, tmp
, vtab
);
8423 /* Now add the deallocation of this component. */
8424 gfc_add_block_to_block (&fnblock
, &tmpblock
);
8427 case NULLIFY_ALLOC_COMP
:
8429 - allocatable components (regular or in class)
8430 - components that have allocatable components
8431 - pointer components when in a coarray.
8432 Skip everything else especially proc_pointers, which may come
8433 coupled with the regular pointer attribute. */
8434 if (c
->attr
.proc_pointer
8435 || !(c
->attr
.allocatable
|| (c
->ts
.type
== BT_CLASS
8436 && CLASS_DATA (c
)->attr
.allocatable
)
8437 || (cmp_has_alloc_comps
8438 && ((c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
)
8439 || (c
->ts
.type
== BT_CLASS
8440 && !CLASS_DATA (c
)->attr
.class_pointer
)))
8441 || (caf_in_coarray (caf_mode
) && c
->attr
.pointer
)))
8444 /* Process class components first, because they always have the
8445 pointer-attribute set which would be caught wrong else. */
8446 if (c
->ts
.type
== BT_CLASS
8447 && (CLASS_DATA (c
)->attr
.allocatable
8448 || CLASS_DATA (c
)->attr
.class_pointer
))
8450 /* Allocatable CLASS components. */
8451 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8452 decl
, cdecl, NULL_TREE
);
8454 comp
= gfc_class_data_get (comp
);
8455 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp
)))
8456 gfc_conv_descriptor_data_set (&fnblock
, comp
,
8460 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8461 void_type_node
, comp
,
8462 build_int_cst (TREE_TYPE (comp
), 0));
8463 gfc_add_expr_to_block (&fnblock
, tmp
);
8465 cmp_has_alloc_comps
= false;
8467 /* Coarrays need the component to be nulled before the api-call
8469 else if (c
->attr
.pointer
|| c
->attr
.allocatable
)
8471 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8472 decl
, cdecl, NULL_TREE
);
8473 if (c
->attr
.dimension
|| c
->attr
.codimension
)
8474 gfc_conv_descriptor_data_set (&fnblock
, comp
,
8477 gfc_add_modify (&fnblock
, comp
,
8478 build_int_cst (TREE_TYPE (comp
), 0));
8479 if (gfc_deferred_strlen (c
, &comp
))
8481 comp
= fold_build3_loc (input_location
, COMPONENT_REF
,
8483 decl
, comp
, NULL_TREE
);
8484 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8485 TREE_TYPE (comp
), comp
,
8486 build_int_cst (TREE_TYPE (comp
), 0));
8487 gfc_add_expr_to_block (&fnblock
, tmp
);
8489 cmp_has_alloc_comps
= false;
8492 if (flag_coarray
== GFC_FCOARRAY_LIB
8493 && (caf_in_coarray (caf_mode
) || c
->attr
.codimension
))
8495 /* Register the component with the coarray library. */
8498 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8499 decl
, cdecl, NULL_TREE
);
8500 if (c
->attr
.dimension
|| c
->attr
.codimension
)
8502 /* Set the dtype, because caf_register needs it. */
8503 gfc_add_modify (&fnblock
, gfc_conv_descriptor_dtype (comp
),
8504 gfc_get_dtype (TREE_TYPE (comp
)));
8505 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8506 decl
, cdecl, NULL_TREE
);
8507 token
= gfc_conv_descriptor_token (tmp
);
8512 symbol_attribute attr
;
8514 gfc_init_se (&se
, NULL
);
8515 gfc_clear_attr (&attr
);
8516 token
= fold_build3_loc (input_location
, COMPONENT_REF
,
8517 pvoid_type_node
, decl
, c
->caf_token
,
8519 comp
= gfc_conv_scalar_to_descriptor (&se
, comp
, attr
);
8520 gfc_add_block_to_block (&fnblock
, &se
.pre
);
8523 gfc_allocate_using_caf_lib (&fnblock
, comp
, size_zero_node
,
8524 gfc_build_addr_expr (NULL_TREE
,
8526 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8527 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
8530 if (cmp_has_alloc_comps
)
8532 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8533 decl
, cdecl, NULL_TREE
);
8534 rank
= c
->as
? c
->as
->rank
: 0;
8535 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
8536 rank
, purpose
, caf_mode
);
8537 gfc_add_expr_to_block (&fnblock
, tmp
);
8541 case REASSIGN_CAF_COMP
:
8542 if (caf_enabled (caf_mode
)
8543 && (c
->attr
.codimension
8544 || (c
->ts
.type
== BT_CLASS
8545 && (CLASS_DATA (c
)->attr
.coarray_comp
8546 || caf_in_coarray (caf_mode
)))
8547 || (c
->ts
.type
== BT_DERIVED
8548 && (c
->ts
.u
.derived
->attr
.coarray_comp
8549 || caf_in_coarray (caf_mode
))))
8552 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8553 decl
, cdecl, NULL_TREE
);
8554 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8555 dest
, cdecl, NULL_TREE
);
8557 if (c
->attr
.codimension
)
8559 if (c
->ts
.type
== BT_CLASS
)
8561 comp
= gfc_class_data_get (comp
);
8562 dcmp
= gfc_class_data_get (dcmp
);
8564 gfc_conv_descriptor_data_set (&fnblock
, dcmp
,
8565 gfc_conv_descriptor_data_get (comp
));
8569 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, dcmp
,
8570 rank
, purpose
, caf_mode
8571 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
);
8572 gfc_add_expr_to_block (&fnblock
, tmp
);
8577 case COPY_ALLOC_COMP
:
8578 if (c
->attr
.pointer
)
8581 /* We need source and destination components. */
8582 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, decl
,
8584 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, dest
,
8586 dcmp
= fold_convert (TREE_TYPE (comp
), dcmp
);
8588 if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
8596 dst_data
= gfc_class_data_get (dcmp
);
8597 src_data
= gfc_class_data_get (comp
);
8598 size
= fold_convert (size_type_node
,
8599 gfc_class_vtab_size_get (comp
));
8601 if (CLASS_DATA (c
)->attr
.dimension
)
8603 nelems
= gfc_conv_descriptor_size (src_data
,
8604 CLASS_DATA (c
)->as
->rank
);
8605 size
= fold_build2_loc (input_location
, MULT_EXPR
,
8606 size_type_node
, size
,
8607 fold_convert (size_type_node
,
8611 nelems
= build_int_cst (size_type_node
, 1);
8613 if (CLASS_DATA (c
)->attr
.dimension
8614 || CLASS_DATA (c
)->attr
.codimension
)
8616 src_data
= gfc_conv_descriptor_data_get (src_data
);
8617 dst_data
= gfc_conv_descriptor_data_get (dst_data
);
8620 gfc_init_block (&tmpblock
);
8622 /* Coarray component have to have the same allocation status and
8623 shape/type-parameter/effective-type on the LHS and RHS of an
8624 intrinsic assignment. Hence, we did not deallocated them - and
8625 do not allocate them here. */
8626 if (!CLASS_DATA (c
)->attr
.codimension
)
8628 ftn_tree
= builtin_decl_explicit (BUILT_IN_MALLOC
);
8629 tmp
= build_call_expr_loc (input_location
, ftn_tree
, 1, size
);
8630 gfc_add_modify (&tmpblock
, dst_data
,
8631 fold_convert (TREE_TYPE (dst_data
), tmp
));
8634 tmp
= gfc_copy_class_to_class (comp
, dcmp
, nelems
,
8635 UNLIMITED_POLY (c
));
8636 gfc_add_expr_to_block (&tmpblock
, tmp
);
8637 tmp
= gfc_finish_block (&tmpblock
);
8639 gfc_init_block (&tmpblock
);
8640 gfc_add_modify (&tmpblock
, dst_data
,
8641 fold_convert (TREE_TYPE (dst_data
),
8642 null_pointer_node
));
8643 null_data
= gfc_finish_block (&tmpblock
);
8645 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
8646 boolean_type_node
, src_data
,
8649 gfc_add_expr_to_block (&fnblock
, build3_v (COND_EXPR
, null_cond
,
8654 /* To implement guarded deep copy, i.e., deep copy only allocatable
8655 components that are really allocated, the deep copy code has to
8656 be generated first and then added to the if-block in
8657 gfc_duplicate_allocatable (). */
8658 if (cmp_has_alloc_comps
&& !c
->attr
.proc_pointer
8661 rank
= c
->as
? c
->as
->rank
: 0;
8662 tmp
= fold_convert (TREE_TYPE (dcmp
), comp
);
8663 gfc_add_modify (&fnblock
, dcmp
, tmp
);
8664 add_when_allocated
= structure_alloc_comps (c
->ts
.u
.derived
,
8670 add_when_allocated
= NULL_TREE
;
8672 if (gfc_deferred_strlen (c
, &tmp
))
8676 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
8678 decl
, len
, NULL_TREE
);
8679 len
= fold_build3_loc (input_location
, COMPONENT_REF
,
8681 dest
, len
, NULL_TREE
);
8682 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8683 TREE_TYPE (len
), len
, tmp
);
8684 gfc_add_expr_to_block (&fnblock
, tmp
);
8685 size
= size_of_string_in_bytes (c
->ts
.kind
, len
);
8686 /* This component can not have allocatable components,
8687 therefore add_when_allocated of duplicate_allocatable ()
8689 tmp
= duplicate_allocatable (dcmp
, comp
, ctype
, rank
,
8690 false, false, size
, NULL_TREE
);
8691 gfc_add_expr_to_block (&fnblock
, tmp
);
8693 else if (c
->attr
.allocatable
&& !c
->attr
.proc_pointer
&& !same_type
8694 && (!(cmp_has_alloc_comps
&& c
->as
) || c
->attr
.codimension
8695 || caf_in_coarray (caf_mode
)))
8697 rank
= c
->as
? c
->as
->rank
: 0;
8698 if (c
->attr
.codimension
)
8699 tmp
= gfc_copy_allocatable_data (dcmp
, comp
, ctype
, rank
);
8700 else if (flag_coarray
== GFC_FCOARRAY_LIB
8701 && caf_in_coarray (caf_mode
))
8703 tree dst_tok
= c
->as
? gfc_conv_descriptor_token (dcmp
)
8704 : fold_build3_loc (input_location
,
8706 pvoid_type_node
, dest
,
8709 tmp
= duplicate_allocatable_coarray (dcmp
, dst_tok
, comp
,
8713 tmp
= gfc_duplicate_allocatable (dcmp
, comp
, ctype
, rank
,
8714 add_when_allocated
);
8715 gfc_add_expr_to_block (&fnblock
, tmp
);
8718 if (cmp_has_alloc_comps
)
8719 gfc_add_expr_to_block (&fnblock
, add_when_allocated
);
8729 return gfc_finish_block (&fnblock
);
8732 /* Recursively traverse an object of derived type, generating code to
8733 nullify allocatable components. */
8736 gfc_nullify_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
8739 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
8741 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
| caf_mode
);
8745 /* Recursively traverse an object of derived type, generating code to
8746 deallocate allocatable components. */
8749 gfc_deallocate_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
8752 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
8753 DEALLOCATE_ALLOC_COMP
,
8754 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
| caf_mode
);
8758 /* Recursively traverse an object of derived type, generating code to
8759 deallocate allocatable components. But do not deallocate coarrays.
8760 To be used for intrinsic assignment, which may not change the allocation
8761 status of coarrays. */
8764 gfc_deallocate_alloc_comp_no_caf (gfc_symbol
* der_type
, tree decl
, int rank
)
8766 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
8767 DEALLOCATE_ALLOC_COMP
, 0);
8772 gfc_reassign_alloc_comp_caf (gfc_symbol
*der_type
, tree decl
, tree dest
)
8774 return structure_alloc_comps (der_type
, decl
, dest
, 0, REASSIGN_CAF_COMP
,
8775 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
);
8779 /* Recursively traverse an object of derived type, generating code to
8780 copy it and its allocatable components. */
8783 gfc_copy_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
,
8786 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ALLOC_COMP
,
8791 /* Recursively traverse an object of derived type, generating code to
8792 copy only its allocatable components. */
8795 gfc_copy_only_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
8797 return structure_alloc_comps (der_type
, decl
, dest
, rank
,
8798 COPY_ONLY_ALLOC_COMP
, 0);
8802 /* Returns the value of LBOUND for an expression. This could be broken out
8803 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
8804 called by gfc_alloc_allocatable_for_assignment. */
8806 get_std_lbound (gfc_expr
*expr
, tree desc
, int dim
, bool assumed_size
)
8811 tree cond
, cond1
, cond3
, cond4
;
8815 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
8817 tmp
= gfc_rank_cst
[dim
];
8818 lbound
= gfc_conv_descriptor_lbound_get (desc
, tmp
);
8819 ubound
= gfc_conv_descriptor_ubound_get (desc
, tmp
);
8820 stride
= gfc_conv_descriptor_stride_get (desc
, tmp
);
8821 cond1
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
8823 cond3
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
8824 stride
, gfc_index_zero_node
);
8825 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8826 boolean_type_node
, cond3
, cond1
);
8827 cond4
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
8828 stride
, gfc_index_zero_node
);
8830 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
8831 tmp
, build_int_cst (gfc_array_index_type
,
8834 cond
= boolean_false_node
;
8836 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
8837 boolean_type_node
, cond3
, cond4
);
8838 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
8839 boolean_type_node
, cond
, cond1
);
8841 return fold_build3_loc (input_location
, COND_EXPR
,
8842 gfc_array_index_type
, cond
,
8843 lbound
, gfc_index_one_node
);
8846 if (expr
->expr_type
== EXPR_FUNCTION
)
8848 /* A conversion function, so use the argument. */
8849 gcc_assert (expr
->value
.function
.isym
8850 && expr
->value
.function
.isym
->conversion
);
8851 expr
= expr
->value
.function
.actual
->expr
;
8854 if (expr
->expr_type
== EXPR_VARIABLE
)
8856 tmp
= TREE_TYPE (expr
->symtree
->n
.sym
->backend_decl
);
8857 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
8859 if (ref
->type
== REF_COMPONENT
8860 && ref
->u
.c
.component
->as
8862 && ref
->next
->u
.ar
.type
== AR_FULL
)
8863 tmp
= TREE_TYPE (ref
->u
.c
.component
->backend_decl
);
8865 return GFC_TYPE_ARRAY_LBOUND(tmp
, dim
);
8868 return gfc_index_one_node
;
8872 /* Returns true if an expression represents an lhs that can be reallocated
8876 gfc_is_reallocatable_lhs (gfc_expr
*expr
)
8883 /* An allocatable class variable with no reference. */
8884 if (expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
8885 && CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.allocatable
8886 && expr
->ref
&& expr
->ref
->type
== REF_COMPONENT
8887 && strcmp (expr
->ref
->u
.c
.component
->name
, "_data") == 0
8888 && expr
->ref
->next
== NULL
)
8891 /* An allocatable variable. */
8892 if (expr
->symtree
->n
.sym
->attr
.allocatable
8894 && expr
->ref
->type
== REF_ARRAY
8895 && expr
->ref
->u
.ar
.type
== AR_FULL
)
8898 /* All that can be left are allocatable components. */
8899 if ((expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
8900 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
8901 || !expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
8904 /* Find a component ref followed by an array reference. */
8905 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
8907 && ref
->type
== REF_COMPONENT
8908 && ref
->next
->type
== REF_ARRAY
8909 && !ref
->next
->next
)
8915 /* Return true if valid reallocatable lhs. */
8916 if (ref
->u
.c
.component
->attr
.allocatable
8917 && ref
->next
->u
.ar
.type
== AR_FULL
)
8925 concat_str_length (gfc_expr
* expr
)
8932 type
= gfc_typenode_for_spec (&expr
->value
.op
.op1
->ts
);
8933 len1
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
8934 if (len1
== NULL_TREE
)
8936 if (expr
->value
.op
.op1
->expr_type
== EXPR_OP
)
8937 len1
= concat_str_length (expr
->value
.op
.op1
);
8938 else if (expr
->value
.op
.op1
->expr_type
== EXPR_CONSTANT
)
8939 len1
= build_int_cst (gfc_charlen_type_node
,
8940 expr
->value
.op
.op1
->value
.character
.length
);
8941 else if (expr
->value
.op
.op1
->ts
.u
.cl
->length
)
8943 gfc_init_se (&se
, NULL
);
8944 gfc_conv_expr (&se
, expr
->value
.op
.op1
->ts
.u
.cl
->length
);
8950 gfc_init_se (&se
, NULL
);
8951 se
.want_pointer
= 1;
8952 se
.descriptor_only
= 1;
8953 gfc_conv_expr (&se
, expr
->value
.op
.op1
);
8954 len1
= se
.string_length
;
8958 type
= gfc_typenode_for_spec (&expr
->value
.op
.op2
->ts
);
8959 len2
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
8960 if (len2
== NULL_TREE
)
8962 if (expr
->value
.op
.op2
->expr_type
== EXPR_OP
)
8963 len2
= concat_str_length (expr
->value
.op
.op2
);
8964 else if (expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
8965 len2
= build_int_cst (gfc_charlen_type_node
,
8966 expr
->value
.op
.op2
->value
.character
.length
);
8967 else if (expr
->value
.op
.op2
->ts
.u
.cl
->length
)
8969 gfc_init_se (&se
, NULL
);
8970 gfc_conv_expr (&se
, expr
->value
.op
.op2
->ts
.u
.cl
->length
);
8976 gfc_init_se (&se
, NULL
);
8977 se
.want_pointer
= 1;
8978 se
.descriptor_only
= 1;
8979 gfc_conv_expr (&se
, expr
->value
.op
.op2
);
8980 len2
= se
.string_length
;
8984 gcc_assert(len1
&& len2
);
8985 len1
= fold_convert (gfc_charlen_type_node
, len1
);
8986 len2
= fold_convert (gfc_charlen_type_node
, len2
);
8988 return fold_build2_loc (input_location
, PLUS_EXPR
,
8989 gfc_charlen_type_node
, len1
, len2
);
8993 /* Allocate the lhs of an assignment to an allocatable array, otherwise
8997 gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop
,
9001 stmtblock_t realloc_block
;
9002 stmtblock_t alloc_block
;
9006 gfc_array_info
*linfo
;
9028 gfc_array_spec
* as
;
9029 bool coarray
= (flag_coarray
== GFC_FCOARRAY_LIB
9030 && gfc_caf_attr (expr1
, true).codimension
);
9034 /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
9035 Find the lhs expression in the loop chain and set expr1 and
9036 expr2 accordingly. */
9037 if (expr1
->expr_type
== EXPR_FUNCTION
&& expr2
== NULL
)
9040 /* Find the ss for the lhs. */
9042 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
9043 if (lss
->info
->expr
&& lss
->info
->expr
->expr_type
== EXPR_VARIABLE
)
9045 if (lss
== gfc_ss_terminator
)
9047 expr1
= lss
->info
->expr
;
9050 /* Bail out if this is not a valid allocate on assignment. */
9051 if (!gfc_is_reallocatable_lhs (expr1
)
9052 || (expr2
&& !expr2
->rank
))
9055 /* Find the ss for the lhs. */
9057 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
9058 if (lss
->info
->expr
== expr1
)
9061 if (lss
== gfc_ss_terminator
)
9064 linfo
= &lss
->info
->data
.array
;
9066 /* Find an ss for the rhs. For operator expressions, we see the
9067 ss's for the operands. Any one of these will do. */
9069 for (; rss
&& rss
!= gfc_ss_terminator
; rss
= rss
->loop_chain
)
9070 if (rss
->info
->expr
!= expr1
&& rss
!= loop
->temp_ss
)
9073 if (expr2
&& rss
== gfc_ss_terminator
)
9076 gfc_start_block (&fblock
);
9078 /* Since the lhs is allocatable, this must be a descriptor type.
9079 Get the data and array size. */
9080 desc
= linfo
->descriptor
;
9081 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)));
9082 array1
= gfc_conv_descriptor_data_get (desc
);
9084 /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
9085 deallocated if expr is an array of different shape or any of the
9086 corresponding length type parameter values of variable and expr
9087 differ." This assures F95 compatibility. */
9088 jump_label1
= gfc_build_label_decl (NULL_TREE
);
9089 jump_label2
= gfc_build_label_decl (NULL_TREE
);
9091 /* Allocate if data is NULL. */
9092 cond_null
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
9093 array1
, build_int_cst (TREE_TYPE (array1
), 0));
9095 if (expr1
->ts
.deferred
)
9096 cond_null
= gfc_evaluate_now (boolean_true_node
, &fblock
);
9098 cond_null
= gfc_evaluate_now (cond_null
, &fblock
);
9100 tmp
= build3_v (COND_EXPR
, cond_null
,
9101 build1_v (GOTO_EXPR
, jump_label1
),
9102 build_empty_stmt (input_location
));
9103 gfc_add_expr_to_block (&fblock
, tmp
);
9105 /* Get arrayspec if expr is a full array. */
9106 if (expr2
&& expr2
->expr_type
== EXPR_FUNCTION
9107 && expr2
->value
.function
.isym
9108 && expr2
->value
.function
.isym
->conversion
)
9110 /* For conversion functions, take the arg. */
9111 gfc_expr
*arg
= expr2
->value
.function
.actual
->expr
;
9112 as
= gfc_get_full_arrayspec_from_expr (arg
);
9115 as
= gfc_get_full_arrayspec_from_expr (expr2
);
9119 /* If the lhs shape is not the same as the rhs jump to setting the
9120 bounds and doing the reallocation....... */
9121 for (n
= 0; n
< expr1
->rank
; n
++)
9123 /* Check the shape. */
9124 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
9125 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
9126 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9127 gfc_array_index_type
,
9128 loop
->to
[n
], loop
->from
[n
]);
9129 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9130 gfc_array_index_type
,
9132 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9133 gfc_array_index_type
,
9135 cond
= fold_build2_loc (input_location
, NE_EXPR
,
9137 tmp
, gfc_index_zero_node
);
9138 tmp
= build3_v (COND_EXPR
, cond
,
9139 build1_v (GOTO_EXPR
, jump_label1
),
9140 build_empty_stmt (input_location
));
9141 gfc_add_expr_to_block (&fblock
, tmp
);
9144 /* ....else jump past the (re)alloc code. */
9145 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
9146 gfc_add_expr_to_block (&fblock
, tmp
);
9148 /* Add the label to start automatic (re)allocation. */
9149 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
9150 gfc_add_expr_to_block (&fblock
, tmp
);
9152 /* If the lhs has not been allocated, its bounds will not have been
9153 initialized and so its size is set to zero. */
9154 size1
= gfc_create_var (gfc_array_index_type
, NULL
);
9155 gfc_init_block (&alloc_block
);
9156 gfc_add_modify (&alloc_block
, size1
, gfc_index_zero_node
);
9157 gfc_init_block (&realloc_block
);
9158 gfc_add_modify (&realloc_block
, size1
,
9159 gfc_conv_descriptor_size (desc
, expr1
->rank
));
9160 tmp
= build3_v (COND_EXPR
, cond_null
,
9161 gfc_finish_block (&alloc_block
),
9162 gfc_finish_block (&realloc_block
));
9163 gfc_add_expr_to_block (&fblock
, tmp
);
9165 /* Get the rhs size and fix it. */
9167 desc2
= rss
->info
->data
.array
.descriptor
;
9171 size2
= gfc_index_one_node
;
9172 for (n
= 0; n
< expr2
->rank
; n
++)
9174 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9175 gfc_array_index_type
,
9176 loop
->to
[n
], loop
->from
[n
]);
9177 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9178 gfc_array_index_type
,
9179 tmp
, gfc_index_one_node
);
9180 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
9181 gfc_array_index_type
,
9184 size2
= gfc_evaluate_now (size2
, &fblock
);
9186 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
9189 /* If the lhs is deferred length, assume that the element size
9190 changes and force a reallocation. */
9191 if (expr1
->ts
.deferred
)
9192 neq_size
= gfc_evaluate_now (boolean_true_node
, &fblock
);
9194 neq_size
= gfc_evaluate_now (cond
, &fblock
);
9196 /* Deallocation of allocatable components will have to occur on
9197 reallocation. Fix the old descriptor now. */
9198 if ((expr1
->ts
.type
== BT_DERIVED
)
9199 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
9200 old_desc
= gfc_evaluate_now (desc
, &fblock
);
9202 old_desc
= NULL_TREE
;
9204 /* Now modify the lhs descriptor and the associated scalarizer
9205 variables. F2003 7.4.1.3: "If variable is or becomes an
9206 unallocated allocatable variable, then it is allocated with each
9207 deferred type parameter equal to the corresponding type parameters
9208 of expr , with the shape of expr , and with each lower bound equal
9209 to the corresponding element of LBOUND(expr)."
9210 Reuse size1 to keep a dimension-by-dimension track of the
9211 stride of the new array. */
9212 size1
= gfc_index_one_node
;
9213 offset
= gfc_index_zero_node
;
9215 for (n
= 0; n
< expr2
->rank
; n
++)
9217 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9218 gfc_array_index_type
,
9219 loop
->to
[n
], loop
->from
[n
]);
9220 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9221 gfc_array_index_type
,
9222 tmp
, gfc_index_one_node
);
9224 lbound
= gfc_index_one_node
;
9229 lbd
= get_std_lbound (expr2
, desc2
, n
,
9230 as
->type
== AS_ASSUMED_SIZE
);
9231 ubound
= fold_build2_loc (input_location
,
9233 gfc_array_index_type
,
9235 ubound
= fold_build2_loc (input_location
,
9237 gfc_array_index_type
,
9242 gfc_conv_descriptor_lbound_set (&fblock
, desc
,
9245 gfc_conv_descriptor_ubound_set (&fblock
, desc
,
9248 gfc_conv_descriptor_stride_set (&fblock
, desc
,
9251 lbound
= gfc_conv_descriptor_lbound_get (desc
,
9253 tmp2
= fold_build2_loc (input_location
, MULT_EXPR
,
9254 gfc_array_index_type
,
9256 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
9257 gfc_array_index_type
,
9259 size1
= fold_build2_loc (input_location
, MULT_EXPR
,
9260 gfc_array_index_type
,
9264 /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
9265 the array offset is saved and the info.offset is used for a
9266 running offset. Use the saved_offset instead. */
9267 tmp
= gfc_conv_descriptor_offset (desc
);
9268 gfc_add_modify (&fblock
, tmp
, offset
);
9269 if (linfo
->saved_offset
9270 && VAR_P (linfo
->saved_offset
))
9271 gfc_add_modify (&fblock
, linfo
->saved_offset
, tmp
);
9273 /* Now set the deltas for the lhs. */
9274 for (n
= 0; n
< expr1
->rank
; n
++)
9276 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
9278 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9279 gfc_array_index_type
, tmp
,
9281 if (linfo
->delta
[dim
] && VAR_P (linfo
->delta
[dim
]))
9282 gfc_add_modify (&fblock
, linfo
->delta
[dim
], tmp
);
9285 /* Get the new lhs size in bytes. */
9286 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9288 if (expr2
->ts
.deferred
)
9290 if (VAR_P (expr2
->ts
.u
.cl
->backend_decl
))
9291 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
9293 tmp
= rss
->info
->string_length
;
9297 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
9298 if (!tmp
&& expr2
->expr_type
== EXPR_OP
9299 && expr2
->value
.op
.op
== INTRINSIC_CONCAT
)
9301 tmp
= concat_str_length (expr2
);
9302 expr2
->ts
.u
.cl
->backend_decl
= gfc_evaluate_now (tmp
, &fblock
);
9304 tmp
= fold_convert (TREE_TYPE (expr1
->ts
.u
.cl
->backend_decl
), tmp
);
9307 if (expr1
->ts
.u
.cl
->backend_decl
9308 && VAR_P (expr1
->ts
.u
.cl
->backend_decl
))
9309 gfc_add_modify (&fblock
, expr1
->ts
.u
.cl
->backend_decl
, tmp
);
9311 gfc_add_modify (&fblock
, lss
->info
->string_length
, tmp
);
9313 else if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.u
.cl
->backend_decl
)
9315 tmp
= TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
)));
9316 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
9317 gfc_array_index_type
, tmp
,
9318 expr1
->ts
.u
.cl
->backend_decl
);
9321 tmp
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
9322 tmp
= fold_convert (gfc_array_index_type
, tmp
);
9323 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
9324 gfc_array_index_type
,
9326 size2
= fold_convert (size_type_node
, size2
);
9327 size2
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
9328 size2
, size_one_node
);
9329 size2
= gfc_evaluate_now (size2
, &fblock
);
9331 /* For deferred character length, the 'size' field of the dtype might
9332 have changed so set the dtype. */
9333 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
9334 && expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9337 tmp
= gfc_conv_descriptor_dtype (desc
);
9338 if (expr2
->ts
.u
.cl
->backend_decl
)
9339 type
= gfc_typenode_for_spec (&expr2
->ts
);
9341 type
= gfc_typenode_for_spec (&expr1
->ts
);
9343 gfc_add_modify (&fblock
, tmp
,
9344 gfc_get_dtype_rank_type (expr1
->rank
,type
));
9346 else if (coarray
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
9348 gfc_add_modify (&fblock
, gfc_conv_descriptor_dtype (desc
),
9349 gfc_get_dtype (TREE_TYPE (desc
)));
9352 /* Realloc expression. Note that the scalarizer uses desc.data
9353 in the array reference - (*desc.data)[<element>]. */
9354 gfc_init_block (&realloc_block
);
9355 gfc_init_se (&caf_se
, NULL
);
9359 token
= gfc_get_ultimate_alloc_ptr_comps_caf_token (&caf_se
, expr1
);
9360 if (token
== NULL_TREE
)
9362 tmp
= gfc_get_tree_for_caf_expr (expr1
);
9363 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
9364 tmp
= build_fold_indirect_ref (tmp
);
9365 gfc_get_caf_token_offset (&caf_se
, &token
, NULL
, tmp
, NULL_TREE
,
9367 token
= gfc_build_addr_expr (NULL_TREE
, token
);
9370 gfc_add_block_to_block (&realloc_block
, &caf_se
.pre
);
9372 if ((expr1
->ts
.type
== BT_DERIVED
)
9373 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
9375 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, old_desc
,
9377 gfc_add_expr_to_block (&realloc_block
, tmp
);
9382 tmp
= build_call_expr_loc (input_location
,
9383 builtin_decl_explicit (BUILT_IN_REALLOC
), 2,
9384 fold_convert (pvoid_type_node
, array1
),
9386 gfc_conv_descriptor_data_set (&realloc_block
,
9391 tmp
= build_call_expr_loc (input_location
,
9392 gfor_fndecl_caf_deregister
, 5, token
,
9393 build_int_cst (integer_type_node
,
9394 GFC_CAF_COARRAY_DEALLOCATE_ONLY
),
9395 null_pointer_node
, null_pointer_node
,
9397 gfc_add_expr_to_block (&realloc_block
, tmp
);
9398 tmp
= build_call_expr_loc (input_location
,
9399 gfor_fndecl_caf_register
,
9401 build_int_cst (integer_type_node
,
9402 GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY
),
9403 token
, gfc_build_addr_expr (NULL_TREE
, desc
),
9404 null_pointer_node
, null_pointer_node
,
9406 gfc_add_expr_to_block (&realloc_block
, tmp
);
9409 if ((expr1
->ts
.type
== BT_DERIVED
)
9410 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
9412 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, desc
,
9414 gfc_add_expr_to_block (&realloc_block
, tmp
);
9417 gfc_add_block_to_block (&realloc_block
, &caf_se
.post
);
9418 realloc_expr
= gfc_finish_block (&realloc_block
);
9420 /* Only reallocate if sizes are different. */
9421 tmp
= build3_v (COND_EXPR
, neq_size
, realloc_expr
,
9422 build_empty_stmt (input_location
));
9426 /* Malloc expression. */
9427 gfc_init_block (&alloc_block
);
9430 tmp
= build_call_expr_loc (input_location
,
9431 builtin_decl_explicit (BUILT_IN_MALLOC
),
9433 gfc_conv_descriptor_data_set (&alloc_block
,
9438 tmp
= build_call_expr_loc (input_location
,
9439 gfor_fndecl_caf_register
,
9441 build_int_cst (integer_type_node
,
9442 GFC_CAF_COARRAY_ALLOC
),
9443 token
, gfc_build_addr_expr (NULL_TREE
, desc
),
9444 null_pointer_node
, null_pointer_node
,
9446 gfc_add_expr_to_block (&alloc_block
, tmp
);
9450 /* We already set the dtype in the case of deferred character
9452 if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
9453 && ((expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9456 tmp
= gfc_conv_descriptor_dtype (desc
);
9457 gfc_add_modify (&alloc_block
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
9460 if ((expr1
->ts
.type
== BT_DERIVED
)
9461 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
9463 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, desc
,
9465 gfc_add_expr_to_block (&alloc_block
, tmp
);
9467 alloc_expr
= gfc_finish_block (&alloc_block
);
9469 /* Malloc if not allocated; realloc otherwise. */
9470 tmp
= build_int_cst (TREE_TYPE (array1
), 0);
9471 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
9474 tmp
= build3_v (COND_EXPR
, cond
, alloc_expr
, realloc_expr
);
9475 gfc_add_expr_to_block (&fblock
, tmp
);
9477 /* Make sure that the scalarizer data pointer is updated. */
9478 if (linfo
->data
&& VAR_P (linfo
->data
))
9480 tmp
= gfc_conv_descriptor_data_get (desc
);
9481 gfc_add_modify (&fblock
, linfo
->data
, tmp
);
9484 /* Add the exit label. */
9485 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
9486 gfc_add_expr_to_block (&fblock
, tmp
);
9488 return gfc_finish_block (&fblock
);
9492 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
9493 Do likewise, recursively if necessary, with the allocatable components of
9497 gfc_trans_deferred_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
9503 stmtblock_t cleanup
;
9506 bool sym_has_alloc_comp
, has_finalizer
;
9508 sym_has_alloc_comp
= (sym
->ts
.type
== BT_DERIVED
9509 || sym
->ts
.type
== BT_CLASS
)
9510 && sym
->ts
.u
.derived
->attr
.alloc_comp
;
9511 has_finalizer
= sym
->ts
.type
== BT_CLASS
|| sym
->ts
.type
== BT_DERIVED
9512 ? gfc_is_finalizable (sym
->ts
.u
.derived
, NULL
) : false;
9514 /* Make sure the frontend gets these right. */
9515 gcc_assert (sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym_has_alloc_comp
9518 gfc_save_backend_locus (&loc
);
9519 gfc_set_backend_locus (&sym
->declared_at
);
9520 gfc_init_block (&init
);
9522 gcc_assert (VAR_P (sym
->backend_decl
)
9523 || TREE_CODE (sym
->backend_decl
) == PARM_DECL
);
9525 if (sym
->ts
.type
== BT_CHARACTER
9526 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
9528 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
9529 gfc_trans_vla_type_sizes (sym
, &init
);
9532 /* Dummy, use associated and result variables don't need anything special. */
9533 if (sym
->attr
.dummy
|| sym
->attr
.use_assoc
|| sym
->attr
.result
)
9535 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
9536 gfc_restore_backend_locus (&loc
);
9540 descriptor
= sym
->backend_decl
;
9542 /* Although static, derived types with default initializers and
9543 allocatable components must not be nulled wholesale; instead they
9544 are treated component by component. */
9545 if (TREE_STATIC (descriptor
) && !sym_has_alloc_comp
&& !has_finalizer
)
9547 /* SAVEd variables are not freed on exit. */
9548 gfc_trans_static_array_pointer (sym
);
9550 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
9551 gfc_restore_backend_locus (&loc
);
9555 /* Get the descriptor type. */
9556 type
= TREE_TYPE (sym
->backend_decl
);
9558 if ((sym_has_alloc_comp
|| (has_finalizer
&& sym
->ts
.type
!= BT_CLASS
))
9559 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
9562 && !(TREE_STATIC (sym
->backend_decl
) && sym
->attr
.is_main_program
))
9564 if (sym
->value
== NULL
9565 || !gfc_has_default_initializer (sym
->ts
.u
.derived
))
9567 rank
= sym
->as
? sym
->as
->rank
: 0;
9568 tmp
= gfc_nullify_alloc_comp (sym
->ts
.u
.derived
,
9570 gfc_add_expr_to_block (&init
, tmp
);
9573 gfc_init_default_dt (sym
, &init
, false);
9576 else if (!GFC_DESCRIPTOR_TYPE_P (type
))
9578 /* If the backend_decl is not a descriptor, we must have a pointer
9580 descriptor
= build_fold_indirect_ref_loc (input_location
,
9582 type
= TREE_TYPE (descriptor
);
9585 /* NULLIFY the data pointer, for non-saved allocatables. */
9586 if (GFC_DESCRIPTOR_TYPE_P (type
) && !sym
->attr
.save
&& sym
->attr
.allocatable
)
9588 gfc_conv_descriptor_data_set (&init
, descriptor
, null_pointer_node
);
9589 if (flag_coarray
== GFC_FCOARRAY_LIB
&& sym
->attr
.codimension
)
9591 /* Declare the variable static so its array descriptor stays present
9592 after leaving the scope. It may still be accessed through another
9593 image. This may happen, for example, with the caf_mpi
9595 TREE_STATIC (descriptor
) = 1;
9596 tmp
= gfc_conv_descriptor_token (descriptor
);
9597 gfc_add_modify (&init
, tmp
, fold_convert (TREE_TYPE (tmp
),
9598 null_pointer_node
));
9602 gfc_restore_backend_locus (&loc
);
9603 gfc_init_block (&cleanup
);
9605 /* Allocatable arrays need to be freed when they go out of scope.
9606 The allocatable components of pointers must not be touched. */
9607 if (!sym
->attr
.allocatable
&& has_finalizer
&& sym
->ts
.type
!= BT_CLASS
9608 && !sym
->attr
.pointer
&& !sym
->attr
.artificial
&& !sym
->attr
.save
9609 && !sym
->ns
->proc_name
->attr
.is_main_program
)
9612 sym
->attr
.referenced
= 1;
9613 e
= gfc_lval_expr_from_sym (sym
);
9614 gfc_add_finalizer_call (&cleanup
, e
);
9617 else if ((!sym
->attr
.allocatable
|| !has_finalizer
)
9618 && sym_has_alloc_comp
&& !(sym
->attr
.function
|| sym
->attr
.result
)
9619 && !sym
->attr
.pointer
&& !sym
->attr
.save
9620 && !sym
->ns
->proc_name
->attr
.is_main_program
)
9623 rank
= sym
->as
? sym
->as
->rank
: 0;
9624 tmp
= gfc_deallocate_alloc_comp (sym
->ts
.u
.derived
, descriptor
, rank
);
9625 gfc_add_expr_to_block (&cleanup
, tmp
);
9628 if (sym
->attr
.allocatable
&& (sym
->attr
.dimension
|| sym
->attr
.codimension
)
9629 && !sym
->attr
.save
&& !sym
->attr
.result
9630 && !sym
->ns
->proc_name
->attr
.is_main_program
)
9633 e
= has_finalizer
? gfc_lval_expr_from_sym (sym
) : NULL
;
9634 tmp
= gfc_deallocate_with_status (sym
->backend_decl
, NULL_TREE
, NULL_TREE
,
9635 NULL_TREE
, NULL_TREE
, true, e
,
9636 sym
->attr
.codimension
9637 ? GFC_CAF_COARRAY_DEREGISTER
9638 : GFC_CAF_COARRAY_NOCOARRAY
);
9641 gfc_add_expr_to_block (&cleanup
, tmp
);
9644 gfc_add_init_cleanup (block
, gfc_finish_block (&init
),
9645 gfc_finish_block (&cleanup
));
9648 /************ Expression Walking Functions ******************/
9650 /* Walk a variable reference.
9652 Possible extension - multiple component subscripts.
9653 x(:,:) = foo%a(:)%b(:)
9655 forall (i=..., j=...)
9656 x(i,j) = foo%a(j)%b(i)
9658 This adds a fair amount of complexity because you need to deal with more
9659 than one ref. Maybe handle in a similar manner to vector subscripts.
9660 Maybe not worth the effort. */
9664 gfc_walk_variable_expr (gfc_ss
* ss
, gfc_expr
* expr
)
9668 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
9669 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
9672 return gfc_walk_array_ref (ss
, expr
, ref
);
9677 gfc_walk_array_ref (gfc_ss
* ss
, gfc_expr
* expr
, gfc_ref
* ref
)
9683 for (; ref
; ref
= ref
->next
)
9685 if (ref
->type
== REF_SUBSTRING
)
9687 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.start
);
9688 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.end
);
9691 /* We're only interested in array sections from now on. */
9692 if (ref
->type
!= REF_ARRAY
)
9700 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
9701 ss
= gfc_get_scalar_ss (ss
, ar
->start
[n
]);
9705 newss
= gfc_get_array_ss (ss
, expr
, ar
->as
->rank
, GFC_SS_SECTION
);
9706 newss
->info
->data
.array
.ref
= ref
;
9708 /* Make sure array is the same as array(:,:), this way
9709 we don't need to special case all the time. */
9710 ar
->dimen
= ar
->as
->rank
;
9711 for (n
= 0; n
< ar
->dimen
; n
++)
9713 ar
->dimen_type
[n
] = DIMEN_RANGE
;
9715 gcc_assert (ar
->start
[n
] == NULL
);
9716 gcc_assert (ar
->end
[n
] == NULL
);
9717 gcc_assert (ar
->stride
[n
] == NULL
);
9723 newss
= gfc_get_array_ss (ss
, expr
, 0, GFC_SS_SECTION
);
9724 newss
->info
->data
.array
.ref
= ref
;
9726 /* We add SS chains for all the subscripts in the section. */
9727 for (n
= 0; n
< ar
->dimen
; n
++)
9731 switch (ar
->dimen_type
[n
])
9734 /* Add SS for elemental (scalar) subscripts. */
9735 gcc_assert (ar
->start
[n
]);
9736 indexss
= gfc_get_scalar_ss (gfc_ss_terminator
, ar
->start
[n
]);
9737 indexss
->loop_chain
= gfc_ss_terminator
;
9738 newss
->info
->data
.array
.subscript
[n
] = indexss
;
9742 /* We don't add anything for sections, just remember this
9743 dimension for later. */
9744 newss
->dim
[newss
->dimen
] = n
;
9749 /* Create a GFC_SS_VECTOR index in which we can store
9750 the vector's descriptor. */
9751 indexss
= gfc_get_array_ss (gfc_ss_terminator
, ar
->start
[n
],
9753 indexss
->loop_chain
= gfc_ss_terminator
;
9754 newss
->info
->data
.array
.subscript
[n
] = indexss
;
9755 newss
->dim
[newss
->dimen
] = n
;
9760 /* We should know what sort of section it is by now. */
9764 /* We should have at least one non-elemental dimension,
9765 unless we are creating a descriptor for a (scalar) coarray. */
9766 gcc_assert (newss
->dimen
> 0
9767 || newss
->info
->data
.array
.ref
->u
.ar
.as
->corank
> 0);
9772 /* We should know what sort of section it is by now. */
9781 /* Walk an expression operator. If only one operand of a binary expression is
9782 scalar, we must also add the scalar term to the SS chain. */
9785 gfc_walk_op_expr (gfc_ss
* ss
, gfc_expr
* expr
)
9790 head
= gfc_walk_subexpr (ss
, expr
->value
.op
.op1
);
9791 if (expr
->value
.op
.op2
== NULL
)
9794 head2
= gfc_walk_subexpr (head
, expr
->value
.op
.op2
);
9796 /* All operands are scalar. Pass back and let the caller deal with it. */
9800 /* All operands require scalarization. */
9801 if (head
!= ss
&& (expr
->value
.op
.op2
== NULL
|| head2
!= head
))
9804 /* One of the operands needs scalarization, the other is scalar.
9805 Create a gfc_ss for the scalar expression. */
9808 /* First operand is scalar. We build the chain in reverse order, so
9809 add the scalar SS after the second operand. */
9811 while (head
&& head
->next
!= ss
)
9813 /* Check we haven't somehow broken the chain. */
9815 head
->next
= gfc_get_scalar_ss (ss
, expr
->value
.op
.op1
);
9817 else /* head2 == head */
9819 gcc_assert (head2
== head
);
9820 /* Second operand is scalar. */
9821 head2
= gfc_get_scalar_ss (head2
, expr
->value
.op
.op2
);
9828 /* Reverse a SS chain. */
9831 gfc_reverse_ss (gfc_ss
* ss
)
9836 gcc_assert (ss
!= NULL
);
9838 head
= gfc_ss_terminator
;
9839 while (ss
!= gfc_ss_terminator
)
9842 /* Check we didn't somehow break the chain. */
9843 gcc_assert (next
!= NULL
);
9853 /* Given an expression referring to a procedure, return the symbol of its
9854 interface. We can't get the procedure symbol directly as we have to handle
9855 the case of (deferred) type-bound procedures. */
9858 gfc_get_proc_ifc_for_expr (gfc_expr
*procedure_ref
)
9863 if (procedure_ref
== NULL
)
9866 /* Normal procedure case. */
9867 if (procedure_ref
->expr_type
== EXPR_FUNCTION
9868 && procedure_ref
->value
.function
.esym
)
9869 sym
= procedure_ref
->value
.function
.esym
;
9871 sym
= procedure_ref
->symtree
->n
.sym
;
9873 /* Typebound procedure case. */
9874 for (ref
= procedure_ref
->ref
; ref
; ref
= ref
->next
)
9876 if (ref
->type
== REF_COMPONENT
9877 && ref
->u
.c
.component
->attr
.proc_pointer
)
9878 sym
= ref
->u
.c
.component
->ts
.interface
;
9887 /* Walk the arguments of an elemental function.
9888 PROC_EXPR is used to check whether an argument is permitted to be absent. If
9889 it is NULL, we don't do the check and the argument is assumed to be present.
9893 gfc_walk_elemental_function_args (gfc_ss
* ss
, gfc_actual_arglist
*arg
,
9894 gfc_symbol
*proc_ifc
, gfc_ss_type type
)
9896 gfc_formal_arglist
*dummy_arg
;
9902 head
= gfc_ss_terminator
;
9906 dummy_arg
= gfc_sym_get_dummy_args (proc_ifc
);
9911 for (; arg
; arg
= arg
->next
)
9913 if (!arg
->expr
|| arg
->expr
->expr_type
== EXPR_NULL
)
9916 newss
= gfc_walk_subexpr (head
, arg
->expr
);
9919 /* Scalar argument. */
9920 gcc_assert (type
== GFC_SS_SCALAR
|| type
== GFC_SS_REFERENCE
);
9921 newss
= gfc_get_scalar_ss (head
, arg
->expr
);
9922 newss
->info
->type
= type
;
9924 newss
->info
->data
.scalar
.dummy_arg
= dummy_arg
->sym
;
9929 if (dummy_arg
!= NULL
9930 && dummy_arg
->sym
->attr
.optional
9931 && arg
->expr
->expr_type
== EXPR_VARIABLE
9932 && (gfc_expr_attr (arg
->expr
).optional
9933 || gfc_expr_attr (arg
->expr
).allocatable
9934 || gfc_expr_attr (arg
->expr
).pointer
))
9935 newss
->info
->can_be_null_ref
= true;
9941 while (tail
->next
!= gfc_ss_terminator
)
9946 if (dummy_arg
!= NULL
)
9947 dummy_arg
= dummy_arg
->next
;
9952 /* If all the arguments are scalar we don't need the argument SS. */
9953 gfc_free_ss_chain (head
);
9958 /* Add it onto the existing chain. */
9964 /* Walk a function call. Scalar functions are passed back, and taken out of
9965 scalarization loops. For elemental functions we walk their arguments.
9966 The result of functions returning arrays is stored in a temporary outside
9967 the loop, so that the function is only called once. Hence we do not need
9968 to walk their arguments. */
9971 gfc_walk_function_expr (gfc_ss
* ss
, gfc_expr
* expr
)
9973 gfc_intrinsic_sym
*isym
;
9975 gfc_component
*comp
= NULL
;
9977 isym
= expr
->value
.function
.isym
;
9979 /* Handle intrinsic functions separately. */
9981 return gfc_walk_intrinsic_function (ss
, expr
, isym
);
9983 sym
= expr
->value
.function
.esym
;
9985 sym
= expr
->symtree
->n
.sym
;
9987 if (gfc_is_alloc_class_array_function (expr
))
9988 return gfc_get_array_ss (ss
, expr
,
9989 CLASS_DATA (expr
->value
.function
.esym
->result
)->as
->rank
,
9992 /* A function that returns arrays. */
9993 comp
= gfc_get_proc_ptr_comp (expr
);
9994 if ((!comp
&& gfc_return_by_reference (sym
) && sym
->result
->attr
.dimension
)
9995 || (comp
&& comp
->attr
.dimension
))
9996 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
9998 /* Walk the parameters of an elemental function. For now we always pass
10000 if (sym
->attr
.elemental
|| (comp
&& comp
->attr
.elemental
))
10002 gfc_ss
*old_ss
= ss
;
10004 ss
= gfc_walk_elemental_function_args (old_ss
,
10005 expr
->value
.function
.actual
,
10006 gfc_get_proc_ifc_for_expr (expr
),
10010 || sym
->attr
.proc_pointer
10011 || sym
->attr
.if_source
!= IFSRC_DECL
10012 || sym
->attr
.array_outer_dependency
))
10013 ss
->info
->array_outer_dependency
= 1;
10016 /* Scalar functions are OK as these are evaluated outside the scalarization
10017 loop. Pass back and let the caller deal with it. */
10022 /* An array temporary is constructed for array constructors. */
10025 gfc_walk_array_constructor (gfc_ss
* ss
, gfc_expr
* expr
)
10027 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_CONSTRUCTOR
);
10031 /* Walk an expression. Add walked expressions to the head of the SS chain.
10032 A wholly scalar expression will not be added. */
10035 gfc_walk_subexpr (gfc_ss
* ss
, gfc_expr
* expr
)
10039 switch (expr
->expr_type
)
10041 case EXPR_VARIABLE
:
10042 head
= gfc_walk_variable_expr (ss
, expr
);
10046 head
= gfc_walk_op_expr (ss
, expr
);
10049 case EXPR_FUNCTION
:
10050 head
= gfc_walk_function_expr (ss
, expr
);
10053 case EXPR_CONSTANT
:
10055 case EXPR_STRUCTURE
:
10056 /* Pass back and let the caller deal with it. */
10060 head
= gfc_walk_array_constructor (ss
, expr
);
10063 case EXPR_SUBSTRING
:
10064 /* Pass back and let the caller deal with it. */
10068 gfc_internal_error ("bad expression type during walk (%d)",
10075 /* Entry point for expression walking.
10076 A return value equal to the passed chain means this is
10077 a scalar expression. It is up to the caller to take whatever action is
10078 necessary to translate these. */
10081 gfc_walk_expr (gfc_expr
* expr
)
10085 res
= gfc_walk_subexpr (gfc_ss_terminator
, expr
);
10086 return gfc_reverse_ss (res
);